| blob | 76768bb6a69e3a49283e270680afab7a2b4614a9 |
1 !WRF:MODEL_RA:RADIATION
2 !
3 !-----------------------------------------------------------------------
4 !-- Search for "!GFDL" for changes to improve coupling with microphysics
5 !-----------------------------------------------------------------------
6 MODULE MODULE_RA_HWRF
7 USE MODULE_CONFIGURE,ONLY : GRID_CONFIG_REC_TYPE
8 USE MODULE_MODEL_CONSTANTS
9 !GFDL USE MODULE_MP_ETANEW, ONLY : RHGRD,FPVS
10 USE MODULE_MP_HWRF, ONLY : RHGRD_in,RHGRD_out,FPVS !GFDL
11 INTEGER,PARAMETER :: NL=81
12 INTEGER,PARAMETER :: NBLY=15
13 REAL,PARAMETER :: RTHRESH=1.E-15
15 INTEGER, SAVE, DIMENSION(3) :: LTOP
16 REAL , SAVE, DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
17 REAL , SAVE, DIMENSION(NL) :: PRGFDL
18 REAL , SAVE :: AB15WD,SKO2D,SKC1R,SKO3R
20 REAL , SAVE :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), &
21 TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
22 SOURCE(28,NBLY), DSRCE(28,NBLY)
24 REAL ,SAVE, DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW,EM3V
25 REAL ,SAVE :: R1
26 ! Created by CO2 initialization
27 REAL, SAVE, ALLOCATABLE, DIMENSION(:,:) :: CO251,CDT51,CDT58,C2D51,&
28 C2D58,CO258
29 REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: STEMP,GTEMP,CO231,CO238, &
30 C2D31,C2D38,CDT31,CDT38, &
31 CO271,CO278,C2D71,C2D78, &
32 CDT71,CDT78
33 REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: CO2M51,CO2M58,CDTM51,CDTM58, &
34 C2DM51,C2DM58
35 CHARACTER(256) :: ERRMESS
37 ! Used by CO2 initialization
38 ! COMMON/PRESS/PA(109)
39 ! COMMON/TRAN/ TRANSA(109,109)
40 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
41 REAL ,SAVE, DIMENSION(109) :: PA, XA, CA, ETA, SEXPV
42 REAL ,SAVE, DIMENSION(109,109) :: TRANSA
43 REAL ,SAVE :: CORE,UEXP,SEXP
45 EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1))
46 EQUIVALENCE (EM3V(1),EM3(1,1))
47 EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
48 (T4(1),TABLE3(1,1))
49 CONTAINS
51 !-----------------------------------------------------------------------
52 SUBROUTINE HWRFRAINIT(SFULL,SHALF,PPTOP,JULYR,MONTH,IDAY,GMT, &
53 & CONFIG_FLAGS, ALLOWED_TO_READ, &
54 & KDS,KDE,KMS,KME,KTS,KTE)
55 !-----------------------------------------------------------------------
56 IMPLICIT NONE
57 !-----------------------------------------------------------------------
58 TYPE (GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS
59 INTEGER,INTENT(IN) :: KDS,KDE,KMS,KME,KTS,KTE
60 REAL,DIMENSION(KMS:KME),INTENT(IN) :: SFULL, SHALF
61 INTEGER,INTENT(IN) :: JULYR,MONTH,IDAY
62 REAL,INTENT(IN) :: GMT,PPTOP
63 LOGICAL,INTENT(IN) :: ALLOWED_TO_READ
64 INTEGER :: IHRST,N
65 REAL :: PCLD
66 REAL :: SSLP=1013.25
67 REAL :: PTOP_HI=150.,PTOP_MID=350.,PTOP_LO=642.
68 !-----------------------------------------------------------------------
69 !***********************************************************************
70 !-----------------------------------------------------------------------
71 !
72 !*** INITIALIZE DIAGNOSTIC LOW,MIDDLE,HIGH CLOUD LAYER PRESSURE LIMITS.
73 !
74 LTOP(1)=0
75 LTOP(2)=0
76 LTOP(3)=0
77 !
78 !dule DO N=1,KTE
79 DO N=1,KTE-1
80 PCLD=(SSLP-PPTOP*10.)*SHALF(N)+PPTOP*10.
81 IF(PCLD>=PTOP_LO)LTOP(1)=N
82 IF(PCLD>=PTOP_MID)LTOP(2)=N
83 IF(PCLD>=PTOP_HI)LTOP(3)=N
84 ! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
85 ENDDO
86 !
87 !*** USE CALL TO CONRAD FOR DIRECT READ OF CO2 FUNCTIONS
88 !*** OTHERWISE CALL CO2O3.
89 !
90 IF(ALLOWED_TO_READ)THEN
91 #if (EM_CORE==1)
92 CALL CO2O3(SFULL,SHALF,PPTOP,KME-KMS,KME-KMS+1,KME-KMS+2)
93 #endif
94 #if (NMM_CORE==1)
95 IF(CONFIG_FLAGS%CO2TF==1)THEN
96 CALL CO2O3(SFULL,SHALF,PPTOP,KME-KMS,KME-KMS+1,KME-KMS+2)
97 ELSE
98 CALL CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
99 ENDIF
100 #endif
101 !
102 CALL O3CLIM
103 CALL TABLE
104 IHRST=NINT(GMT)
105 CALL SOLARD(IHRST,IDAY,MONTH,JULYR)
106 ENDIF
107 !
108 !-----------------------------------------------------------------------
109 END SUBROUTINE HWRFRAINIT
110 !-----------------------------------------------------------------------
111 !
112 !
113 !-----------------------------------------------------------------------
114 SUBROUTINE HWRFRA(DT,THRATEN,THRATENLW,THRATENSW,PI3D &
115 & ,XLAND,P8W,DZ8W,RHO_PHY,P_PHY,T &
116 & ,QV,QW,QI &
117 & ,TSK2D,GLW,GSW &
118 & ,TOTSWDN,TOTLWDN,RSWTOA,RLWTOA,CZMEAN &
119 & ,GLAT,GLON,HTOP,HBOT,htopr,hbotr,ALBEDO,CUPPT &
120 & ,VEGFRA,SNOW,G,GMT &
121 & ,NSTEPRA,NPHS,ITIMESTEP &
122 & ,JULYR,JULDAY,GFDL_LW,GFDL_SW &
123 & ,CFRACL,CFRACM,CFRACH &
124 & ,ACFRST,NCFRST,ACFRCV,NCFRCV &
125 & ,IDS,IDE,JDS,JDE,KDS,KDE &
126 & ,IMS,IME,JMS,JME,KMS,KME &
127 & ,ITS,ITE,JTS,JTE,KTS,KTE)
128 !-----------------------------------------------------------------------
129 IMPLICIT NONE
130 !-----------------------------------------------------------------------
131 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
132 & ,IMS,IME,JMS,JME,KMS,KME &
133 & ,ITS,ITE,JTS,JTE,KTS,KTE,ITIMESTEP &
134 & ,NPHS,NSTEPRA
136 INTEGER,INTENT(IN) :: julyr,julday
137 INTEGER,INTENT(INOUT),DIMENSION(ims:ime,jms:jme) :: NCFRST & !Added
138 ,NCFRCV !Added
139 REAL,INTENT(IN) :: DT,GMT,G
141 REAL,INTENT(INOUT),DIMENSION(ims:ime, kms:kme, jms:jme):: &
142 THRATEN,THRATENLW,THRATENSW
143 REAL,INTENT(IN),DIMENSION(ims:ime, kms:kme, jms:jme)::p8w,dz8w, &
144 & rho_phy, &
145 & p_phy, &
146 & PI3D
147 REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: ALBEDO,SNOW, &
148 & TSK2D,VEGFRA, &
149 & XLAND
150 REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: GLAT,GLON
151 REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: HTOP,HBOT,htopr,hbotr,CUPPT
152 REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: RSWTOA, & !Added
153 & RLWTOA, & !Added
154 & ACFRST, & !Added
155 & ACFRCV
156 REAL,INTENT(INOUT),DIMENSION(ims:ime, jms:jme):: GLW,GSW
157 REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CZMEAN, &
158 & TOTLWDN,TOTSWDN
159 REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CFRACL,CFRACM, & !Added
160 & CFRACH !Added
161 REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QI,QV, &
162 & QW,T
163 ! REAL, INTENT(IN), DIMENSION(37*kte) :: RAD1,RAD2,RAD3,RAD4
164 LOGICAL, INTENT(IN) :: gfdl_lw,gfdl_sw
166 REAL, DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP,QIFLIP,QFLIP, &
167 & QWFLIP,TFLIP
168 REAL, DIMENSION(its:ite, kms:kme, jts:jte)::P8WFLIP,PHYD
169 REAL, DIMENSION(its:ite, kts:kte, jts:jte)::TENDS,TENDL
171 INTEGER :: IDAT(3),Jmonth,Jday
172 INTEGER :: I,J,K,KFLIP,IHRST
173 !-----------------------------------------------------------------------
174 !***********************************************************************
175 !-----------------------------------------------------------------------
176 IF(GFDL_LW.AND.GFDL_SW )GO TO 100
177 !
178 ! NEED HYDROSTATIC PRESSURE HERE (MONOTONIC CHANGE WITH HEIGHT)
179 DO J=JTS,JTE
180 DO I=ITS,ITE
181 PHYD(I,KTS,J)=P8W(I,KTS,J)
182 ENDDO
183 ENDDO
184 !
185 DO J=JTS,JTE
186 DO K=KTS,KTE
187 DO I=ITS,ITE
188 PHYD(I,K+1,J)=PHYD(I,K,J)-G*RHO_PHY(I,K,J)*DZ8W(I,K,J)
189 ENDDO
190 ENDDO
191 ENDDO
192 !
193 DO K=KMS,KME
194 KFLIP=KME+1-K
195 DO J=JTS,JTE
196 DO I=ITS,ITE
197 P8WFLIP(I,K,J)=PHYD(I,KFLIP,J)
198 ENDDO
199 ENDDO
200 ENDDO
201 !
202 !- Note that the effects of rain are ignored in this radiation package (BSF 2005-01-25)
203 !
204 DO K=KTS,KTE
205 KFLIP=KTE+1-K
206 DO J=JTS,JTE
207 DO I=ITS,ITE
208 TFLIP (I,K,J)=T(I,KFLIP,J)
209 QFLIP (I,K,J)=MAX(0.,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J)))
210 QWFLIP(I,K,J)=QW(I,KFLIP,J) !Modified
211 QIFLIP(I,K,J)=QI(I,KFLIP,J) !Added QI
212 ! PFLIP (I,K,J)=P_PHY(I,KFLIP,J)
213 !
214 !*** USE MONOTONIC HYDROSTATIC PRESSURE INTERPOLATED TO MID-LEVEL
215 !
216 PFLIP(I,K,J)=0.5*(P8WFLIP(I,K,J)+P8WFLIP(I,K+1,J))
217 ENDDO
218 ENDDO
219 ENDDO
220 !
221 DO J=JTS,JTE
222 DO I=ITS,ITE
223 HBOTR(I,J)=HBOT(I,J)
224 HTOPR(I,J)=HTOP(I,J)
225 ENDDO
226 ENDDO
228 DO J=JTS,JTE
229 DO I=ITS,ITE
230 HBOT(I,J)=KTE+1-HBOT(I,J)
231 HTOP(I,J)=KTE+1-HTOP(I,J)
232 ENDDO
233 ENDDO
234 !
235 CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY)
236 !
237 IDAT(1)=JMONTH
238 IDAT(2)=JDAY
239 IDAT(3)=JULYR
240 IHRST =NINT(GMT)
242 ! CALL SOLARD(R1,IHRST,IDAT)
243 ! CALL SOLARD(R1,IHRST,JULDAY)
244 !-----------------------------------------------------------------------
245 CALL RADTN (DT,TFLIP,QFLIP,QWFLIP,QIFLIP, &
246 & PFLIP,P8WFLIP,XLAND,TSK2D, &
247 & GLAT,GLON,HTOP,HBOT,ALBEDO,CUPPT, &
248 & ACFRCV,NCFRCV,ACFRST,NCFRST, &
249 & VEGFRA,SNOW,GLW,GSW, &
250 & TOTSWDN,TOTLWDN, &
251 & IDAT,IHRST, &
252 & NSTEPRA,NSTEPRA,NPHS,ITIMESTEP, &
253 & TENDS,TENDL,RSWTOA,RLWTOA,CZMEAN, &
254 & CFRACL,CFRACM,CFRACH, &
255 & IDS,IDE,JDS,JDE,KDS,KDE, &
256 & IMS,IME,JMS,JME,KMS,KME, &
257 & ITS,ITE,JTS,JTE,KTS,KTE )
258 !-----------------------------------------------------------------------
259 !
260 IF(GFDL_LW)THEN
261 DO J=JTS,JTE
262 DO K = KTS,KTE
263 KFLIP=KTE+1-K
264 DO I=ITS,ITE
265 THRATENLW(I,K,J)=TENDL(I,KFLIP,J)/PI3D(I,K,J)
266 THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J) !Put in SW section
267 THRATEN(I,K,J) =THRATEN(I,K,J) + THRATENLW(I,K,J)
268 ENDDO
269 ENDDO
270 ENDDO
271 ENDIF
272 !
273 !*** THIS ASSUMES THAT LONGWAVE IS CALLED FIRST IN THE RADIATION_DRIVER.
274 !
275 IF(GFDL_SW)THEN
276 DO J=JTS,JTE
277 DO K=KTS,KTE
278 KFLIP=KTE+1-K
279 DO I=ITS,ITE
280 THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J)
281 !!! THRATEN(I,K,J)=THRATEN(I,K,J)+THRATENSW(I,K,J) !Added
282 ENDDO
283 ENDDO
284 ENDDO
285 ENDIF
287 !
288 !*** RESET ACCUMULATED CONVECTIVE CLOUD TOP/BOT AND CONVECTIVE PRECIP
289 !*** FOR NEXT INTERVAL BETWEEN RADIATION CALLS
290 !
291 DO J=JTS,JTE
292 DO I=ITS,ITE
293 !!!! HBOT(I,J)=KTE+1-HBOT(I,J)
294 !!!! HTOP(I,J)=KTE+1-HTOP(I,J)
295 HBOT(I,J)=REAL(KTE+1)
296 HTOP(I,J)=0.
297 CUPPT(I,J)=0.
298 ENDDO
299 ENDDO
300 !
301 100 IF(GFDL_SW)THEN
302 DO J=JTS,JTE
303 DO K=KTS,KTE
304 KFLIP=KTE+1-K
305 DO I=ITS,ITE
306 THRATEN(I,K,J)=THRATEN(I,K,J)+THRATENSW(I,K,J)
307 ENDDO
308 ENDDO
309 ENDDO
310 ENDIF
311 !
312 END SUBROUTINE HWRFRA
313 !
314 !-----------------------------------------------------------------------
315 SUBROUTINE RADTN(DT,T,Q,QCW,QICE, &
316 & PFLIP,P8WFLIP,XLAND,TSK2D, &
317 & GLAT,GLON,HTOP,HBOT,ALB,CUPPT, &
318 ! & RAD1,RAD2,RAD3,RAD4, &
319 ! & TABLE1,TABLE2,TABLE3,EM1,EM1WDE,EM3, &
320 & ACFRCV,NCFRCV,ACFRST,NCFRST, &
321 & VEGFRC,SNO,GLW,GSW, &
322 & RSWIN,RLWIN, & !Added
323 ! & IDAT,LTOP,IHRST,PRGFDL, &
324 & IDAT,IHRST, &
325 & NRADS,NRADL,NPHS,NTSD, &
326 ! & SKO3R,AB15WD,SKC1R,SKO2D, &
327 !#$ & TENDS,TENDL, &
328 & TENDS,TENDL,RSWTOA,RLWTOA,CZMEAN, &
329 & CFRACL,CFRACM,CFRACH, & !Added
330 & ids,ide, jds,jde, kds,kde, &
331 & ims,ime, jms,jme, kms,kme, &
332 & its,ite, jts,jte, kts,kte )
333 !-----------------------------------------------------------------------
334 IMPLICIT NONE
335 !-----------------------------------------------------------------------
336 ! GLAT : geodetic latitude in radians of the mass points on the computational grid.
338 ! CZEN : instantaneous cosine of the solar zenith angle.
340 ! HTOP : (REAL) model layer number that is highest in the atmosphere
341 ! in which convective cloud occurred since the previous call to the
342 ! radiation driver.
344 ! HBOT : (REAL) model layer number that is lowest in the atmosphere
345 ! in which convective cloud occurred since the previous call to the
346 ! radiation driver.
348 ! ALB : is no longer used in the operational radiation. Prior to 24 July 2001
349 ! ALB was the climatological albedo that was modified within RADTN to
350 ! account for vegetation fraction and snow.
351 !
352 ! ALB : reintroduced as the dynamic albedo from LSM
354 ! CUPPT: accumulated convective precipitation (meters) since the
355 ! last call to the radiation.
357 ! THS : potential temperature of the ground surface.
359 ! IHE and IHW are relative location indices needed to locate neighboring
360 ! points on the Eta's Arakawa E grid since arrays are indexed locally on
361 ! each MPI task rather than globally. IHE refers to the adjacent grid
362 ! point (a V point) to the east of the mass point being considered. IHW
363 ! is the adjacent grid point to the west of the given mass point.
365 ! IRAD is a relic from older code that is no longer needed.
367 ! ACFRCV : sum of the convective cloud fractions that were computed
368 ! during each call to the radiation between calls to the subroutines that
369 ! do the forecast output.
371 ! NCFRCV : the total number of times in which the convective cloud
372 ! fraction was computed to be greater than zero in the radiation between
373 ! calls to the output routines. In the post-processor, ACFRCV is divided
374 ! by NCFRCV to yield an average convective cloud fraction.
376 ! ACFRST and NCFRST are the analogs for stratiform cloud cover.
378 ! VEGFRC is the fraction of the gridbox with vegetation.
380 ! LVL holds the number of model layers that lie below the ground surface
381 ! at each point. Clearly for sigma coordinates LVL is zero everywhere.
383 ! CTHK : an assumed maximum thickness of stratiform clouds currently set
384 ! to 20000 Pascals. I think this is relevant for computing "low",
385 ! "middle", and "high" cloud fractions which are post-processed but which
386 ! do not feed back into the integration.
388 ! IDAT : a 3-element integer array holding the month, day, and year,
389 ! respectively, of the date for the start time of the free forecast.
391 ! ABCFF : holds coefficients for various absorption bands. You can see
392 ! where they are set in GFDLRD.F.
394 ! LTOP : a 3-element integer array holding the model layer that is at or
395 ! immediately below the specified pressure levels for the tops
396 ! of "high" (15000 Pa), "middle" (35000 Pa), and "low" (64200 Pa)
397 ! stratiform clouds. These are for the diagnostic cloud layers
398 ! needed in the output but not in the integration.
400 ! R1 : earth-sun distance in astronomical units.
402 ! NRADS : integer number of fundamental timesteps (our smallest
403 ! timestep, i.e., the one for inertial gravity wave adjustment)
404 ! between updates of the shortwave tendencies. Currently we
405 ! update the shortwave every hour.
407 ! NRADL : integer number of fundamental timesteps between updates of
408 ! the longwave tendencies. Currently we update the longwave
409 ! every two hours.
411 ! NTSD : integer counter of the fundamental timesteps that have
412 ! elapsed since the start of the forecast.
413 !
414 !**********************************************************************
415 !****************************** NOTE **********************************
416 !**********************************************************************
417 !*** DUE TO THE RESETTING OF CONVECTIVE PRECIP AND CONVECTIVE CLOUD
418 !*** TOPS AND BOTTOMS, SHORTWAVE MUST NOT BE CALLED LESS FREQUENTLY
419 !*** THAN LONGWAVE.
420 !**********************************************************************
421 !****************************** NOTE **********************************
422 !**********************************************************************
423 !-----------------------------------------------------------------------
424 ! INTEGER, PARAMETER :: NL=81
425 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
426 & ims,ime, jms,jme, kms,kme , &
427 & its,ite, jts,jte, kts,kte
428 INTEGER, INTENT(IN) :: NRADS,NRADL,NTSD,NPHS
429 ! LOGICAL, INTENT(IN) :: RESTRT
430 REAL , INTENT(IN) :: DT
431 ! REAL , INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
432 INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
433 !-----------------------------------------------------------------------
434 REAL, PARAMETER :: CAPA=R_D/CP,DTR=3.1415926/180.
435 INTEGER :: LM1,LP1,LM
436 INTEGER, INTENT(IN) :: IHRST
437 ! REAL, INTENT(IN), DIMENSION(NL) :: PRGFDL
438 !
439 REAL, PARAMETER :: ALPHA0=100.,CLFRMIN=0.1,CUPRATE=24.*1000., &
440 & EPS=R_D/R_V,EPSO3=1.E-10, &
441 & EPSQ=1.E-12,EPSQ1=1.E-5, &
442 & GAMMA=0.49,H0=0.,H1=1.,H69=-6.9,HPINC=1.E1, &
443 & PBOT=10000.0,PEXP=0.25, &
444 & QCLDMIN=EPSQ,RLAG=14.8125, &
445 & STBOL=STBOLT,T_ICE=-10.
446 !
447 INTEGER, PARAMETER :: NB=12,KSMUD=0
448 INTEGER,PARAMETER :: K15=SELECTED_REAL_KIND(15)
449 REAL (KIND=K15) :: DDX,EEX,PROD
450 ! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D
451 !-----------------------------------------------------------------------
452 LOGICAL :: SHORT,LONG
453 LOGICAL :: BITX,BITY,BITZ,BITW,BIT1,BIT2,BITC,BITS,BITCP1,BITSP1
454 LOGICAL :: CNCLD,NEW_CLOUD
455 !-----------------------------------------------------------------------
456 REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: XLAND,TSK2D
457 REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: Q,QCW, &
458 & QICE,T
459 REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP, &
460 & P8WFLIP
462 ! REAL, INTENT(IN), DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3,EM3,EM1,EM1WDE
463 REAL, INTENT(OUT), DIMENSION(ims:ime, jms:jme):: GLW,GSW,CZMEAN &
464 & ,RSWIN,RLWIN & !Added
465 & ,CFRACL,CFRACM &
466 & ,CFRACH
468 ! REAL, INTENT(IN), DIMENSION(kms:kme) :: ETAD
469 ! REAL, INTENT(IN), DIMENSION(kms:kme) :: AETA
470 !-----------------------------------------------------------------------
471 REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: HTOP,HBOT
472 REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: ALB,SNO
473 REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: GLAT,GLON
474 !-----------------------------------------------------------------------
475 REAL, DIMENSION(ims:ime,jms:jme) :: CZEN
476 !#$ REAL, DIMENSION(its:ite,jts:jte) :: CZMEAN,SIGT4
477 REAL, DIMENSION(its:ite,jts:jte) :: SIGT4
478 INTEGER, DIMENSION(its:ite, jts:jte):: LMH
479 !-----------------------------------------------------------------------
480 REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: CUPPT
481 ! REAL, DIMENSION(37*kte) :: RAD1,RAD2,RAD3,RAD4
482 !-----------------------------------------------------------------------
483 ! INTEGER,INTENT(IN), DIMENSION(jms:jme) :: IHE,IHW
484 !-----------------------------------------------------------------------
485 REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: ACFRCV,ACFRST &
486 ,RSWTOA,RLWTOA
487 INTEGER,INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: NCFRCV,NCFRST
488 !-----------------------------------------------------------------------
489 !#$ REAL, DIMENSION(its:ite,jts:jte) :: RLWIN,RLWOUT
490 REAL, DIMENSION(its:ite,jts:jte) :: RLWOUT
491 !-----------------------------------------------------------------------
492 REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: VEGFRC
493 REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte,jts:jte) :: TENDL,&
494 & TENDS
495 !#$ REAL, DIMENSION(its:ite,jts:jte) :: RSWIN,RSWOUT,RSWTOA
496 !#$ REAL, DIMENSION(its:ite,jts:jte) :: RSWIN,RSWOUT
497 REAL, DIMENSION(its:ite,jts:jte) :: RSWOUT
498 REAL, DIMENSION(its:ite,kts:kte,jts:jte):: RSWTT,RLWTT
499 !-----------------------------------------------------------------------
500 REAL :: CTHK(3)
501 DATA CTHK/20000.0,20000.0,20000.0/
503 REAL :: PTOPC(4)
504 REAL,DIMENSION(10),SAVE :: CC,PPT
505 !-----------------------------------------------------------------------
506 REAL,SAVE :: ABCFF(NB)
507 INTEGER,DIMENSION(its:ite,jts:jte) :: LVL
508 REAL, DIMENSION(its:ite, jts:jte):: PDSL,FNE,FSE,TL
509 REAL, DIMENSION( 0:kte) :: CLDAMT
510 REAL, DIMENSION(its:ite,3):: CLDCFR
511 INTEGER, DIMENSION(its:ite,3):: MBOT,MTOP
512 REAL, DIMENSION(its:ite) :: PSFC,TSKN,ALBEDO,XLAT,COSZ, &
513 & SLMSK,FLWUP, &
514 & FSWDN,FSWUP,FSWDNS,FSWUPS,FLWDNS, &
515 & FLWUPS
517 REAL, DIMENSION(its:ite,kts:kte) :: PMID,TMID
518 REAL, DIMENSION(its:ite,kts:kte) :: QMID,THMID,OZN,POZN
519 REAL, DIMENSION(its:ite,jts:jte) :: TOT
521 REAL, DIMENSION(its:ite,kts:kte+1) :: PINT,EMIS,CAMT
522 INTEGER,DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
523 INTEGER,DIMENSION(its:ite) :: NCLDS,KCLD
524 REAL, DIMENSION(its:ite) :: TAUDAR
525 REAL, DIMENSION(its:ite,NB,kts:kte+1) ::RRCL,TTCL
527 REAL, DIMENSION(its:ite,kts:kte):: CSMID,CCMID,QWMID,QIMID
528 REAL,SAVE :: PLOMD,PMDHI,PHITP,P400,PLBTM
529 INTEGER,SAVE :: NFILE
531 !-----------------------------------------------------------------------
532 REAL :: CLSTP,TIME,DAYI,HOUR,ADDL,RANG,RSIN1,RCOS1,RCOS2
533 REAL :: TIMES,EXNER,APES,SNOFAC,CCLIMIT,CLIMIT,P1,P2,CC1,CC2
534 REAL :: PMOD,CLFR1,CTAU,WV,ARG,CLDMAX
535 REAL :: CL1,CL2,CR1,DPCL,QSUM,PRS1,PRS2,DELP,TCLD,DD,EE,AA,FF
536 REAL :: BB,GG,DENOM,FCTRA,FCTRB,PDSLIJ,CFRAVG,SNOMM
537 REAL :: TAUC,THICK,CONVPRATE,CLFR,ESAT,QSAT,RHUM,QCLD,RHGRID
538 INTEGER :: I,J,MYJS,MYJE,MYIS,MYIE,NTSPH,NRADPP,ITIMSW,ITIMLW, &
539 & JD,II
540 INTEGER :: L,N,LML,LVLIJ,IR,KNTLYR,LL,NC,L400,NMOD,LTROP,IWKL
541 INTEGER :: LCNVB,LCNVT
542 INTEGER :: NLVL,MALVL,LLTOP,LLBOT,KBT2,KTH1,KBT1,KTH2,KTOP1,KFLIP
543 INTEGER :: NBAND,NCLD,LBASE,NKTP,NBTM,KS,MYJS1,MYJS2,MYJE2,MYJE1
545 ! REAL,DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW,EM3V
547 ! EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1))
548 ! EQUIVALENCE (EM3V(1),EM3(1,1))
549 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
550 ! (T4(1),TABLE3(1,1))
552 DATA PLOMD/64200./,PMDHI/35000./,PHITP/15000./,P400/40000./, &
553 PLBTM/105000./
554 DATA NFILE/14/
555 DATA CC/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0/
556 DATA PPT/0.,.14,.31,.70,1.6,3.4,7.7,17.,38.,85./
557 DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190.,989., &
558 & 2706.,39011./
560 !-----------------------------------------------------------------------
561 !***********************************************************************
562 !-----------------------------------------------------------------------
563 MYJS=jts
564 MYJE=jte
565 MYIS=its
566 MYIE=ite
567 MYJS1=jts !????
568 MYJE1=jte
569 MYJS2=jts
570 MYJE2=jte
571 LM=kte
572 LM1=LM-1
573 LP1=LM+1
574 CNCLD=.TRUE.
575 !
576 DO J=JTS,JTE
577 DO I=ITS,ITE
578 LMH(I,J)=KME-1
579 LVL(I,J)=0
580 ENDDO
581 ENDDO
582 !***
583 !*** ASSIGN THE PRESSURES FOR CLOUD DOMAIN BOUNDARIES
584 !***
585 PTOPC(1)=PLBTM
586 PTOPC(2)=PLOMD
587 PTOPC(3)=PMDHI
588 PTOPC(4)=PHITP
589 !**********************************************************************
590 !*** THE FOLLOWING CODE IS EXECUTED EACH TIME THE RADIATION IS CALLED.
591 !**********************************************************************
592 !----------------------CONVECTION--------------------------------------
593 ! NRADPP IS THE NUMBER OF TIME STEPS TO ACCUMULATE CONVECTIVE PRECIP
594 ! FOR RADIATION
595 ! NOTE: THIS WILL NOT WORK IF NRADS AND NRADL ARE DIFFERENT UNLESS
596 ! THEY ARE INTEGER MULTIPLES OF EACH OTHER
597 ! CLSTP IS THE NUMBER OF HOURS OF THE ACCUMULATION PERIOD
598 !
599 NTSPH=NINT(3600./DT)
600 NRADPP=MIN(NRADS,NRADL)
601 CLSTP=1.0*NRADPP/NTSPH
602 CONVPRATE=CUPRATE/CLSTP
603 !GFDL RHGRID=RHGRD
604 RHGRID=RHgrd_in !GFDL => simple right now w/o height-dependencies
605 !----------------------CONVECTION--------------------------------------
606 !***
607 !*** STATE WHETHER THE SHORT OR LONGWAVE COMPUTATIONS ARE TO BE DONE.
608 !***
609 SHORT=.TRUE.
610 LONG=.TRUE.
611 ITIMSW=0
612 ITIMLW=0
613 IF(SHORT)ITIMSW=1
614 IF(LONG) ITIMLW=1
615 !***
616 !*** FIND THE MEAN COSINE OF THE SOLAR ZENITH ANGLE
617 !*** BETWEEN THE CURRENT TIME AND THE NEXT TIME RADIATION IS
618 !*** CALLED. ONLY AVERAGE IF THE SUN IS ABOVE THE HORIZON.
619 !***
620 TIME=NTSD*DT
621 ! CALL ZENITH(TIME,DAYI,HOUR)
622 !-----------------------------------------------------------------------
623 CALL ZENITH(TIME,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
624 & MYIS,MYIE,MYJS,MYJE, &
625 & ids,ide, jds,jde, kds,kde, &
626 & ims,ime, jms,jme, kms,kme, &
627 & its,ite, jts,jte, kts,kte )
628 !-----------------------------------------------------------------------
630 JD=INT(DAYI+0.50)
631 ADDL=0.
632 IF(MOD(IDAT(3),4).EQ.0)ADDL=1.
633 RANG=PI2*(DAYI-RLAG)/(365.25+ADDL)
634 RSIN1=SIN(RANG)
635 RCOS1=COS(RANG)
636 RCOS2=COS(2.*RANG)
637 !
638 !-----------------------------------------------------------------------
639 IF(SHORT)THEN
640 DO J=MYJS,MYJE
641 DO I=MYIS,MYIE
642 CZMEAN(I,J)=0.
643 TOT(I,J)=0.
644 ENDDO
645 ENDDO
646 !
647 DO II=0,NRADS,NPHS
648 TIMES=NTSD*DT+II*DT
649 CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
650 & MYIS,MYIE,MYJS,MYJE, &
651 & ids,ide, jds,jde, kds,kde, &
652 & ims,ime, jms,jme, kms,kme, &
653 & its,ite, jts,jte, kts,kte )
654 DO J=MYJS,MYJE
655 DO I=MYIS,MYIE
656 IF(CZEN(I,J).GT.0.)THEN
657 CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J)
658 TOT(I,J)=TOT(I,J)+1.
659 ENDIF
660 !
661 ENDDO
662 ENDDO
663 ENDDO
664 DO J=MYJS,MYJE
665 DO I=MYIS,MYIE
666 IF(TOT(I,J).GT.0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J)
667 !
668 ENDDO
669 ENDDO
670 !
671 !*** MODIFY CZEN TO BE AT THE TOP OF THE HOUR.
672 !
673 ! TIMES=NTSD*DT
674 ! CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
675 ! & MYIS,MYIE,MYJS,MYJE, &
676 ! & ids,ide, jds,jde, kds,kde, &
677 ! & ims,ime, jms,jme, kms,kme, &
678 ! & its,ite, jts,jte, kts,kte )
679 ENDIF
680 !-----------------------------------------------------------------------
681 !
682 !***********************************************************************
683 !*** THIS IS THE BEGINNING OF THE PRIMARY LOOP THROUGH THE DOMAIN
684 !***********************************************************************
685 ! *********************
686 DO 700 J = MYJS, MYJE
687 ! *********************
688 !
689 DO 125 L=1,LM
690 DO I=MYIS,MYIE
691 ! IR=IRAD(I)
692 TMID(I,L)=T(I,1,J)
693 QMID(I,L)=EPSQ
694 QWMID(I,L)=0.
695 QIMID(I,L)=0.
696 CSMID(I,L)=0.
697 CCMID(I,L)=0.
698 OZN(I,L)=EPSO3
699 TENDS(I,L,J)=0.
700 TENDL(I,L,J)=0.
701 ENDDO
702 125 CONTINUE
703 !
704 DO 140 N=1,3
705 DO I=MYIS,MYIE
706 CLDCFR(I,N)=0.
707 MTOP(I,N)=0
708 MBOT(I,N)=0
709 ENDDO
710 140 CONTINUE
711 !***
712 !*** FILL IN WORKING ARRAYS WHERE VALUES AT L=LM ARE THOSE THAT
713 !*** ARE ACTUALLY AT ETA LEVEL L=LMH.
714 !***
715 DO 200 I=MYIS,MYIE
716 ! IR=IRAD(I)
717 LML=LMH(I,J)
718 LVLIJ=LVL(I,J)
719 !
720 DO L=1,LML
721 PMID(I,L+LVLIJ)=PFLIP(I,L,J)
722 PINT(I,L+LVLIJ+1)=P8WFLIP(I,L+1,J)
723 EXNER=(1.E5/PMID(I,L+LVLIJ))**CAPA
724 TMID(I,L+LVLIJ)=T(I,L,J)
725 THMID(I,L+LVLIJ)=T(I,L,J)*EXNER
726 QMID(I,L+LVLIJ)=Q(I,L,J)
727 !--- Note that rain is ignored, only effects from cloud water and ice are considered
728 QWMID(I,L+LVLIJ)=QCW(I,L,J)
729 QIMID(I,L+LVLIJ)=QICE(I,L,J)
730 ENDDO
731 !***
732 !*** FILL IN ARTIFICIAL VALUES ABOVE THE TOP OF THE DOMAIN.
733 !*** PRESSURE DEPTHS OF THESE LAYERS IS 1 HPA.
734 !*** TEMPERATURES ABOVE ARE ALREADY ISOTHERMAL WITH (TRUE) LAYER 1.
735 !***
736 IF(LVLIJ.GT.0)THEN
737 KNTLYR=0
738 !
739 DO L=LVLIJ,1,-1
740 KNTLYR=KNTLYR+1
741 PMID(I,L)=P8WFLIP(I,1,J)-REAL(2*KNTLYR-1)*0.5*HPINC
742 PINT(I,L+1)=PMID(I,L)+0.5*HPINC
743 EXNER=(1.E5/PMID(I,L))**CAPA
744 THMID(I,L)=TMID(I,L)*EXNER
745 ENDDO
746 ENDIF
747 !
748 IF(LVLIJ.EQ.0) THEN
749 PINT(I,1)=P8WFLIP(I,1,J)
750 ELSE
751 PINT(I,1)=PMID(I,1)-0.5*HPINC
752 ENDIF
753 200 CONTINUE
754 !***
755 !*** FILL IN THE SURFACE PRESSURE, SKIN TEMPERATURE, GEODETIC LATITUDE,
756 !*** ZENITH ANGLE, SEA MASK, AND ALBEDO. THE SKIN TEMPERATURE IS
757 !*** NEGATIVE OVER WATER.
758 !***
759 DO 250 I=MYIS,MYIE
760 PSFC(I)=P8WFLIP(I,KME,J)
761 APES=(PSFC(I)*1.E-5)**CAPA
762 ! TSKN(I)=THS(I,J)*APES*(1.-2.*SM(I,J))
763 IF((XLAND(I,J)-1.5).GT.0.)THEN
764 TSKN(I)=-TSK2D(I,J)
765 ELSE
766 TSKN(I)=TSK2D(I,J)
767 ENDIF
769 ! TSKN(I)=THS(I,J)*APES*(1.-2.*(XLAND(I,J)-1.))
770 ! SLMSK(I)=SM(I,J)
771 SLMSK(I)=XLAND(I,J)-1.
772 !
773 ! SNO(I,J)=AMAX1(SNO(I,J),0.)
774 SNOMM=AMAX1(SNO(I,J),0.)
775 SNOFAC=AMIN1(SNOMM/0.02, 1.0)
776 !!!! ALBEDO(I)=ALB(I,J)+(1.0-0.01*VEGFRC(I,J))*SNOFAC*(SNOALB-ALB(I,J))
777 ALBEDO(I)=ALB(I,J)
778 !
779 XLAT(I)=GLAT(I,J)/DTR
780 COSZ(I)=CZMEAN(I,J)
781 250 CONTINUE
782 !-----------------------------------------------------------------------
783 !--- COMPUTE GRID-SCALE CLOUD COVER FOR RADIATION
784 ! (modified by Ferrier, Feb '02)
785 !
786 !--- Cloud fraction parameterization follows Randall, 1994
787 ! (see Hong et al., 1998)
788 !-----------------------------------------------------------------------
789 !
790 DO I=MYIS,MYIE
791 LML=LMH(I,J)
792 LVLIJ=LVL(I,J)
793 DO L=1,LML
794 LL=L+LVLIJ
795 !
796 !--- Water vapor mixing ratio
797 !
798 WV=QMID(I,LL)/(1.-QMID(I,LL))
799 !
800 !--- Saturation vapor pressure w/r/t water ( >=0C ) or ice ( <0C )
801 !
802 ESAT=1000.*FPVS(TMID(I,LL)) !--- Saturation vapor pressure (Pa)
803 QSAT=EPS*ESAT/(PMID(I,LL)-ESAT) !--- Saturation mixing ratio
804 RHUM=WV/QSAT !--- Relative humidity
805 !
806 !--- Total "cloud" mixing ratio, QCLD. Rain is not part of cloud,
807 ! only cloud water + cloud ice + snow
808 !
809 QCLD=QWMID(I,LL)+QIMID(I,LL)
810 !
811 !--- Determine cloud fraction (modified from original algorithm)
812 !
813 IF (QCLD .LT. QCLDMIN) THEN
814 !
815 !--- Assume zero cloud fraction if there is no cloud mixing ratio
816 !
817 CLFR=H0
818 ELSEIF(RHUM.GE.RHGRID)THEN
819 !
820 !--- Assume cloud fraction of unity if near saturation and the cloud
821 ! mixing ratio is at or above the minimum threshold
822 !
823 CLFR=H1
824 ELSE
825 !
826 !--- Adaptation of original algorithm (Randall, 1994; Zhao, 1995)
827 ! modified based on assumed grid-scale saturation at RH=RHgrid.
828 !
829 DENOM=(RHGRID*QSAT-WV)**GAMMA
830 ARG=MAX(H69, -ALPHA0*QCLD/DENOM) ! <-- EXP(-6.9)=.001
831 CLFR=(RHUM/RHGRID)**PEXP*(1.-EXP(ARG))
832 !! ARG=-1000*QCLD/(RHUM-RHGRID)
833 !! ARG=MAX(ARG, ARGMIN)
834 !! CLFR=(RHUM/RHGRID)*(1.-EXP(ARG))
835 IF (CLFR .LT. .01) CLFR=0.
836 ENDIF !--- End IF (QCLD .LT. QCLDmin) ...
837 CSMID(I,LL)=MIN(H1,CLFR)
838 ENDDO !--- End DO L ...
839 ENDDO !--- End DO I ...
840 !***********************************************************************
841 !********************END OF STRATIFORM CLOUD SECTION********************
842 !***********************************************************************
843 !
844 !-----------------------------------------------------------------------
845 !--- COMPUTE CONVECTIVE CLOUD COVER FOR RADIATION
846 !
847 !--- The parameterization of Slingo (1987, QJRMS, Table 1, p. 904) is
848 ! used for convective cloud fraction as a function of precipitation
849 ! rate. Cloud fractions have been increased by 20% for each rainrate
850 ! interval so that shallow, nonprecipitating convection is ascribed a
851 ! constant cloud fraction of 0.1 (Ferrier, Feb '02).
852 !-----------------------------------------------------------------
853 !
854 IF (CNCLD) THEN
855 DO I=MYIS,MYIE
856 !
857 !*** CLOUD TOPS AND BOTTOMS COME FROM CUCNVC.
858 !*** CONVECTIVE CLOUDS NEED TO BE AT LEAST 2 MODEL LAYERS THICK.
859 !
860 IF (HBOT(I,J)-HTOP(I,J) .GT. 1.0) THEN
861 !--- Compute convective cloud fractions if appropriate (Ferrier, Feb '02)
862 CLFR=CC(1)
863 PMOD=CUPPT(I,J)*CONVPRATE
864 IF (PMOD .GT. PPT(1)) THEN
865 DO NC=1,10
866 IF(PMOD.GT.PPT(NC)) NMOD=NC
867 ENDDO
868 IF (NMOD .GE. 10) THEN
869 CLFR=CC(10)
870 ELSE
871 CC1=CC(NMOD)
872 CC2=CC(NMOD+1)
873 P1=PPT(NMOD)
874 P2=PPT(NMOD+1)
875 CLFR=CC1+(CC2-CC1)*(PMOD-P1)/(P2-P1)
876 ENDIF !--- End IF (NMOD .GE. 10) ...
877 CLFR=MIN(H1, CLFR)
878 ENDIF !--- End IF (PMOD .GT. PPT(1)) ...
879 !
880 !*** ADD LVL TO BE CONSISTENT WITH OTHER WORKING ARRAYS
881 !
882 LVLIJ=LVL(I,J)
883 LCNVT=NINT(HTOP(I,J))+LVLIJ
884 LCNVT=MIN(LM,LCNVT)
885 LCNVB=NINT(HBOT(I,J))+LVLIJ
886 LCNVB=MIN(LM,LCNVB)
887 !
888 DO LL=LCNVT,LCNVB
889 CCMID(I,LL)=CLFR
890 ENDDO
891 ENDIF !--- IF (HBOT(I,J)-HTOP(I,J) .GT. 1.0) ...
892 ENDDO !--- End DO I loop
893 ENDIF !--- End IF (CNCLD) ...
894 !*********************************************************************
895 !*****************END OF CONVECTIVE CLOUD SECTION*****************
896 !*********************************************************************
897 !***
898 !*** DETERMINE THE FRACTIONAL CLOUD COVERAGE FOR HIGH, MID
899 !*** AND LOW OF CLOUDS FROM THE CLOUD COVERAGE AT EACH LEVEL
900 !***
901 !*** NOTE: THIS IS FOR DIAGNOSTICS ONLY!!!
902 !***
903 !***
904 DO 500 I=MYIS,MYIE
905 !!
906 DO L=0,LM
907 CLDAMT(L)=0.
908 ENDDO
909 !!
910 !!*** NOW GOES LOW, MIDDLE, HIGH
911 !!
912 DO 480 NLVL=1,3
913 CLDMAX=0.
914 MALVL=LM
915 LLTOP=LM+1-LTOP(NLVL)+LVL(I,J)
916 !!***
917 !!*** GO TO THE NEXT CLOUD LAYER IF THE TOP OF THE CLOUD-TYPE IN
918 !!*** QUESTION IS BELOW GROUND OR IS IN THE LOWEST LAYER ABOVE GROUND.
919 !!***
920 IF(LLTOP.GE.LM)GO TO 480
921 !!
922 IF(NLVL.GT.1)THEN
923 LLBOT=LM+1-LTOP(NLVL-1)-1+LVL(I,J)
924 LLBOT=MIN(LLBOT,LM1)
925 ELSE
926 LLBOT=LM1
927 ENDIF
928 !!
929 DO 435 L=LLTOP,LLBOT
930 CLDAMT(L)=AMAX1(CSMID(I,L),CCMID(I,L))
931 IF(CLDAMT(L).GT.CLDMAX)THEN
932 MALVL=L
933 CLDMAX=CLDAMT(L)
934 ENDIF
935 435 CONTINUE
936 !!*********************************************************************
937 !! NOW, CALCULATE THE TOTAL CLOUD FRACTION IN THIS PRESSURE DOMAIN
938 !! USING THE METHOD DEVELOPED BY Y.H., K.A.C. AND A.K. (NOV., 1992).
939 !! IN THIS METHOD, IT IS ASSUMED THAT SEPERATED CLOUD LAYERS ARE
940 !! RADOMLY OVERLAPPED AND ADJACENT CLOUD LAYERS ARE MAXIMUM OVERLAPPED.
941 !! VERTICAL LOCATION OF EACH TYPE OF CLOUD IS DETERMINED BY THE THICKEST
942 !! CONTINUING CLOUD LAYERS IN THE DOMAIN.
943 !!*********************************************************************
944 CL1=0.0
945 CL2=0.0
946 KBT1=LLBOT
947 KBT2=LLBOT
948 KTH1=0
949 KTH2=0
950 !!
951 DO 450 LL=LLTOP,LLBOT
952 L=LLBOT-LL+LLTOP
953 BIT1=.FALSE.
954 CR1=CLDAMT(L)
955 BITX=(PINT(I,L).GE.PTOPC(NLVL+1)).AND. &
956 & (PINT(I,L).LT.PTOPC(NLVL)).AND. &
957 & (CLDAMT(L).GT.0.0)
958 BIT1=BIT1.OR.BITX
959 IF(.NOT.BIT1)GO TO 450
960 !!***
961 !!*** BITY=T: FIRST CLOUD LAYER; BITZ=T:CONSECUTIVE CLOUD LAYER
962 !!*** NOTE: WE ASSUME THAT THE THICKNESS OF EACH CLOUD LAYER IN THE
963 !!*** DOMAIN IS LESS THAN 200 MB TO AVOID TOO MUCH COOLING OR
964 !!*** HEATING. SO WE SET CTHK(NLVL)=200*E2. BUT THIS LIMIT MAY
965 !!*** WORK WELL FOR CONVECTIVE CLOUDS. MODIFICATION MAY BE
966 !!*** NEEDED IN THE FUTURE.
967 !!***
968 BITY=BITX.AND.(KTH2.LE.0)
969 BITZ=BITX.AND.(KTH2.GT.0)
970 !!
971 IF(BITY)THEN
972 KBT2=L
973 KTH2=1
974 ENDIF
975 !!
976 IF(BITZ)THEN
977 KTOP1=KBT2-KTH2+1
978 DPCL=PMID(I,KBT2)-PMID(I,KTOP1)
979 IF(DPCL.LT.CTHK(NLVL))THEN
980 KTH2=KTH2+1
981 ELSE
982 KBT2=KBT2-1
983 ENDIF
984 ENDIF
985 IF(BITX)CL2=AMAX1(CL2,CR1)
986 !!***
987 !!*** AT THE DOMAIN BOUNDARY OR SEPARATED CLD LAYERS, RANDOM OVERLAP.
988 !!*** CHOOSE THE THICKEST OR THE LARGEST FRACTION AMT AS THE CLD
989 !!*** LAYER IN THAT DOMAIN.
990 !!***
991 BIT2=.FALSE.
992 BITY=BITX.AND.(CLDAMT(L-1).LE.0.0.OR. &
993 PINT(I,L-1).LT.PTOPC(NLVL+1))
994 BITZ=BITY.AND.CL1.GT.0.0
995 BITW=BITY.AND.CL1.LE.0.0
996 BIT2=BIT2.OR.BITY
997 IF(.NOT.BIT2)GO TO 450
998 !!
999 IF(BITZ)THEN
1000 KBT1=INT((CL1*KBT1+CL2*KBT2)/(CL1+CL2))
1001 KTH1=INT((CL1*KTH1+CL2*KTH2)/(CL1+CL2))+1
1002 CL1=CL1+CL2-CL1*CL2
1003 ENDIF
1004 !!
1005 IF(BITW)THEN
1006 KBT1=KBT2
1007 KTH1=KTH2
1008 CL1=CL2
1009 ENDIF
1010 !!
1011 IF(BITY)THEN
1012 KBT2=LLBOT
1013 KTH2=0
1014 CL2=0.0
1015 ENDIF
1016 450 CONTINUE
1017 !
1018 CLDCFR(I,NLVL)=AMIN1(1.0,CL1)
1019 MTOP(I,NLVL)=MIN(KBT1,KBT1-KTH1+1)
1020 MBOT(I,NLVL)=KBT1
1021 480 CONTINUE
1022 500 CONTINUE
1024 !***
1025 !*** SET THE UN-NEEDED TAUDAR TO ONE
1026 !***
1027 DO I=MYIS,MYIE
1028 TAUDAR(I)=1.0
1029 ENDDO
1030 !----------------------------------------------------------------------
1031 ! NOW, CALCULATE THE CLOUD RADIATIVE PROPERTIES AFTER DAVIS (1982),
1032 ! HARSHVARDHAN ET AL (1987) AND Y.H., K.A.C. AND A.K. (1993).
1033 !
1034 ! UPDATE: THE FOLLOWING PARTS ARE MODIFIED, AFTER Y.T.H. (1994), TO
1035 ! CALCULATE THE RADIATIVE PROPERTIES OF CLOUDS ON EACH MODEL
1036 ! LAYER. BOTH CONVECTIVE AND STRATIFORM CLOUDS ARE USED
1037 ! IN THIS CALCULATIONS.
1038 !
1039 ! QINGYUN ZHAO 95-3-22
1040 !
1041 !----------------------------------------------------------------------
1042 !
1043 !***
1044 !*** INITIALIZE ARRAYS FOR USES LATER
1045 !***
1047 DO 600 I=MYIS,MYIE
1048 LML=LMH(I,J)
1049 LVLIJ=LVL(I,J)
1050 !
1051 !***
1052 !*** NOTE: LAYER=1 IS THE SURFACE, AND LAYER=2 IS THE FIRST CLOUD
1053 !*** LAYER ABOVE THE SURFACE AND SO ON.
1054 !***
1055 EMIS(I,1)=1.0
1056 KTOP(I,1)=LP1
1057 KBTM(I,1)=LP1
1058 CAMT(I,1)=1.0
1059 KCLD(I)=2
1060 !
1061 DO NBAND=1,NB
1062 RRCL(I,NBAND,1)=0.0
1063 TTCL(I,NBAND,1)=1.0
1064 ENDDO
1065 !
1066 DO 510 L=2,LP1
1067 CAMT(I,L)=0.0
1068 KTOP(I,L)=1
1069 KBTM(I,L)=1
1070 EMIS(I,L)=0.0
1071 !
1072 DO NBAND=1,NB
1073 RRCL(I,NBAND,L)=0.0
1074 TTCL(I,NBAND,L)=1.0
1075 ENDDO
1076 510 CONTINUE
1077 !***
1078 !*** NOW CALCULATE THE AMOUNT, TOP, BOTTOM AND TYPE OF EACH CLOUD LAYER
1079 !*** CLOUD TYPE=1: STRATIFORM CLOUD
1080 !*** TYPE=2: CONVECTIVE CLOUD
1081 !*** WHEN BOTH CONVECTIVE AND STRATIFORM CLOUDS EXIST AT THE SAME POINT,
1082 !*** SELECT CONVECTIVE CLOUD WITH THE HIGHER CLOUD FRACTION.
1083 !*** CLOUD LAYERS ARE SEPARATED BY TOTAL ABSENCE OF CLOUDINESS.
1084 !*** NOTE: THERE IS ONLY ONE CONVECTIVE CLOUD LAYER IN ONE COLUMN.
1085 !*** KTOP AND KBTM ARE THE TOP AND BOTTOM OF EACH CLOUD LAYER IN TERMS
1086 !*** OF MODEL LEVEL.
1087 !***
1088 NEW_CLOUD=.TRUE.
1089 !
1090 DO L=2,LML
1091 LL=LML-L+1+LVLIJ !-- Model layer
1092 CLFR=MAX(CCMID(I,LL),CSMID(I,LL)) !-- Cloud fraction in layer
1093 CLFR1=MAX(CCMID(I,LL+1),CSMID(I,LL+1)) !-- Cloud fraction in lower layer
1094 !-------------------
1095 IF (CLFR .GE. CLFRMIN) THEN
1096 !--- Cloud present at level
1097 IF (NEW_CLOUD) THEN
1098 !--- New cloud layer
1099 IF(L==2.AND.CLFR1>=CLFRmin)THEN
1100 KBTM(I,KCLD(I))=LL+1
1101 CAMT(I,KCLD(I))=CLFR1
1102 ELSE
1103 KBTM(I,KCLD(I))=LL
1104 CAMT(I,KCLD(I))=CLFR
1105 ENDIF
1106 NEW_CLOUD=.FALSE.
1107 ELSE
1108 !--- Existing cloud layer
1109 CAMT(I,KCLD(I))=AMAX1(CAMT(I,KCLD(I)), CLFR)
1110 ENDIF ! End IF (NEW_CLOUD .EQ. 0) ...
1111 ELSE IF (CLFR1 .GE. CLFRMIN) THEN
1112 !--- Cloud is not present at level but did exist at lower level, then ...
1113 IF (L .EQ. 2) THEN
1114 !--- For the case of ground fog
1115 KBTM(I,KCLD(I))=LL+1
1116 CAMT(I,KCLD(I))=CLFR1
1117 ENDIF
1118 KTOP(I,KCLD(I))=LL+1
1119 NEW_CLOUD=.TRUE.
1120 KCLD(I)=KCLD(I)+1
1121 CAMT(I,KCLD(I))=0.0
1122 ENDIF
1123 !-------------------
1124 ENDDO !--- End DO L loop
1125 !***
1126 !*** THE REAL NUMBER OF CLOUD LAYERS IS (THE FIRST IS THE GROUND;
1127 !*** THE LAST IS THE SKY):
1128 !***
1129 NCLDS(I)=KCLD(I)-2
1130 NCLD=NCLDS(I)
1131 !***
1132 !*** NOW CALCULATE CLOUD RADIATIVE PROPERTIES
1133 !***
1134 IF(NCLD.GE.1)THEN
1135 !***
1136 !*** NOTE: THE FOLLOWING CALCULATIONS, THE UNIT FOR PRESSURE IS MB!!!
1137 !***
1138 DO 580 NC=2,NCLD+1
1139 !
1140 TAUC=0.0 ! Total optical depth for each cloud layer
1141 QSUM=0.0
1142 NKTP=LP1
1143 NBTM=0
1144 BITX=CAMT(I,NC).GE.CLFRMIN
1145 NKTP=MIN(NKTP,KTOP(I,NC))
1146 NBTM=MAX(NBTM,KBTM(I,NC))
1147 !
1148 DO LL=NKTP,NBTM
1149 IF(LL.GE.KTOP(I,NC).AND.LL.LE.KBTM(I,NC).AND.BITX)THEN
1150 PRS1=PINT(I,LL)*0.01
1151 PRS2=PINT(I,LL+1)*0.01
1152 DELP=PRS2-PRS1
1153 TCLD=TMID(I,LL)-273.16
1154 QSUM=QSUM+QMID(I,LL)*DELP*(PRS1+PRS2) &
1155 & /(120.1612*SQRT(TMID(I,LL)))
1156 !
1157 !--- The simple optical depth parameterization from eq. (1) of Harshvardhan
1158 ! et al. (1989, JAS, p. 1924; hereafter referred to as HRCD by authorship)
1159 ! is used for convective cloud properties with some simple changes.
1160 !
1161 !--- The optical depth Tau is Tau=CTau*DELP, where values of CTau are
1162 ! described below.
1163 !
1164 !--- For convection, assume simple optical depth coefficients of
1165 ! 1) CTau=0.16 for ice, assumed to be for T<=T_ICE (=-10C in GSMCOLUMN)
1166 ! This was referenced as "optically thick anvil associated with
1167 ! convection in
1168 ! 2) CTau=0.08 for water, assumed to be present for T>T_ICE
1169 !
1170 !--- For grid-scale processes in the absence of convection:
1171 ! 1) CTau=0.08*min(1., Qc/Q0) for cloud water, where
1172 ! Q0 is assumed to be the threshold mixing ratio for "thick anvils",
1173 ! as noted in the 2nd paragraph after eq. (1) in Harshvardhan et al.
1174 ! (1989). A value of Q0=0.1 g/kg is assumed based on experience w/
1175 ! cloud observations, and it is intended only to be a crude scaling
1176 ! factor for "order of magnitude" effects. The functional dependence
1177 ! on mixing ratio is based on Stephens (1978, JAS, p. 2124, eq. 7).
1178 ! 2) CTau=500*Qi for ice particles. This is based on the optical depth
1179 ! of snow. Prof. Q. Fu (U. Washington) provided the following eq.:
1180 ! Tau-1.5*SWP/(Res*RHOs)
1181 ! SWP is snow water path, Res is the snow effective radius, RHOs is
1182 ! the snow density. Based on derivations using Petch (1998, JAS, 1846-
1183 ! 1858) as a starting point, Res=1.5*Ds with Ds being the mean diameter
1184 ! of an exponential distribution of ice particles ("snow"). After some
1185 ! manipulation,
1186 ! Tau=CTau*DELP => CTau=CSTau*Qice, where
1187 ! CSTau=100./(G*Ds*RHOs) ~ 500 based on values of Ds and RHOs in the
1188 ! ice lookup tables (actually varies from 920 for Ds=.1 mm to ~520 for
1189 ! Ds>0.5 mm), and units of DELP in mb (must convert from Pascals).
1190 ! "Snow" (precipitating ice) is assumed because of it dominates over
1191 ! cloud ice in the scheme.
1192 !
1193 CTAU=0.
1194 IF (CCMID(I,LL) .GE. CLFRMIN) THEN
1195 !-- Crude convective cloud properties
1196 IF (TCLD .GT. T_ICE) THEN
1197 CTAU=0.08 !--- Cloud water
1198 ELSE
1199 CTAU=0.16 !--- Ice
1200 ENDIF
1201 ENDIF
1202 !-- Crude grid-scale cloud properties
1203 IF (CSMID(I,LL) .GE. CLFRMIN) &
1204 & CTAU=CTAU+800.*QWMID(I,LL)+500.*QIMID(I,LL)
1205 TAUC=TAUC+DELP*CTAU
1206 ENDIF !--- End IF(LL.GE.KTOP(I,NC) ....
1207 ENDDO !--- End DO LL
1208 !
1209 IF(BITX)EMIS(I,NC)=1.0-EXP(-0.75*TAUC)
1210 !GFDL => should consider using this => IF(BITX)EMIS(I,NC)=1.0-EXP(-1.66*TAUC)
1211 IF(QSUM.GE.EPSQ1)THEN
1212 !
1213 DO 570 NBAND=1,NB
1214 IF(BITX)THEN
1215 PROD=ABCFF(NBAND)*QSUM
1216 DDX=TAUC/(TAUC+PROD)
1217 EEX=1.0-DDX
1218 IF(ABS(EEX).GE.1.E-8)THEN
1219 DD=DDX
1220 EE=EEX
1221 FF=1.0-DD*0.85
1222 AA=MIN(50.0,SQRT(3.0*EE*FF)*TAUC)
1223 AA=EXP(-AA)
1224 BB=FF/EE
1225 GG=SQRT(BB)
1226 DD=(GG+1.0)*(GG+1.0)-(GG-1.0)*(GG-1.0)*AA*AA
1227 RRCL(I,NBAND,NC)=MAX(0.1E-5,(BB-1.0)*(1.0-AA*AA)/DD)
1228 TTCL(I,NBAND,NC)=AMAX1(0.1E-5,4.0*GG*AA/DD)
1229 ENDIF
1230 ENDIF
1231 570 CONTINUE
1232 ENDIF
1233 580 CONTINUE
1234 !
1235 ENDIF
1236 !
1237 600 CONTINUE
1238 !*********************************************************************
1239 !****************** COMPUTE OZONE AT MIDLAYERS *********************
1240 !*********************************************************************
1241 !
1242 !*** MODIFY PRESSURES SO THAT THE ENTIRE COLUMN OF OZONE (TO 0 MB)
1243 !*** IS INCLUDED IN THE MODEL COLUMN EVEN WHEN PT > 0 MB
1244 !***
1245 DO L=1,LM
1246 DO I=MYIS,MYIE
1247 DENOM=1./(PINT(I,LP1)-PINT(I,1))
1248 FCTRA=PINT(I,LP1)*DENOM
1249 FCTRB=-PINT(I,1)*PINT(I,LP1)*DENOM
1250 POZN(I,L)=PMID(I,L)*FCTRA+FCTRB
1251 ENDDO
1252 ENDDO
1253 !
1254 CALL OZON2D(LM,POZN,XLAT,RSIN1,RCOS1,RCOS2,OZN, &
1255 ! XDUO3N,XDO3N4,XDO3N2,XDO3N3, &
1256 ! PRGFDL,MYIS,MYIE, &
1257 MYIS,MYIE, &
1258 ids,ide, jds,jde, kds,kde, &
1259 ims,ime, jms,jme, kms,kme, &
1260 its,ite, jts,jte, kts,kte )
1261 !
1262 !***
1263 !*** NOW THE VARIABLES REQUIRED BY RADFS HAVE BEEN CALCULATED.
1264 !***
1265 !----------------------------------------------------------------------
1266 !***
1267 !*** CALL THE GFDL RADIATION DRIVER
1268 !***
1269 !***
1270 CALL RADFS &
1271 & (PSFC,PMID,PINT,QMID,TMID,OZN,TSKN,SLMSK,ALBEDO,XLAT &
1272 &, CAMT,KTOP,KBTM,NCLDS,EMIS,RRCL,TTCL &
1273 &, COSZ,TAUDAR,1 &
1274 &, 1,0 &
1275 &, ITIMSW,ITIMLW,JD,HOUR &
1276 &, TENDS(ITS,KTS,J),TENDL(ITS,KTS,J) &
1277 &, FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS &
1278 &, ids,ide, jds,jde, kds,kde &
1279 &, ims,ime, jms,jme, kms,kme &
1280 &, its,ite, jts,jte, kts,kte )
1281 !----------------------------------------------------------------------
1282 IF(LONG)THEN
1283 DO I=MYIS,MYIE
1284 GLW(I,J)=FLWDNS(I)
1285 ENDDO
1286 ENDIF
1287 !
1288 IF(SHORT)THEN
1289 DO I=MYIS,MYIE
1290 GSW(I,J)=FSWDNS(I)-FSWUPS(I)
1291 ENDDO
1292 ENDIF
1293 !
1294 DO 650 I=MYIS,MYIE
1295 CFRACL(I,J)=CLDCFR(I,1)
1296 CFRACM(I,J)=CLDCFR(I,2)
1297 CFRACH(I,J)=CLDCFR(I,3)
1298 !
1299 !*** ARRAYS ACFRST AND ACFRCV ACCUMULATE AVERAGE STRATIFORM AND
1300 !*** CONVECTIVE CLOUD FRACTIONS, RESPECTIVELY.
1301 !*** ACCUMLATE THESE VARIABLES ONLY ONCE PER RADIATION CALL.
1302 !
1303 !*** ASSUME RANDOM OVERLAP BETWEEN LOW, MIDDLE, & HIGH LAYERS.
1304 !
1305 CFRAVG=1.-(1.-CFRACL(I,J))*(1.-CFRACM(I,J))*(1.-CFRACH(I,J))
1306 !
1307 IF(CNCLD)THEN
1308 IF(HBOT(I,J)-HTOP(I,J).GT.1.)THEN
1309 !--- Count locations with convective cloudiness
1310 ACFRST(I,J)=ACFRST(I,J)+CFRAVG
1311 NCFRST(I,J)=NCFRST(I,J)+1
1312 ENDIF
1313 BITS=.FALSE.
1314 DO LL=1,LM
1315 BITS=CSMID(I,LL).GE.CLFRMIN !--- Existence of grid-scale cloud in layer
1316 IF(BITS)EXIT
1317 ENDDO
1318 IF(BITS)THEN
1319 !--- Count locations with grid-scale cloudiness
1320 ACFRST(I,J)=ACFRST(I,J)+CFRAVG
1321 NCFRST(I,J)=NCFRST(I,J)+1
1322 ENDIF
1323 ELSE
1324 !--- Count only locations with grid-scale cloudiness
1325 ACFRCV(I,J)=ACFRCV(I,J)+CFRAVG
1326 NCFRCV(I,J)=NCFRCV(I,J)+1
1327 ENDIF
1328 650 CONTINUE
1329 !***
1330 !*** COLLECT ATMOSPHERIC TEMPERATURE TENDENCIES DUE TO RADIATION.
1331 !*** ALSO COLLECT THE TOTAL SW AND INCOMING LW RADIATION (W/M**2)
1332 !*** AND CONVERT TO FORM NEEDED FOR PREDICTION OF THS IN SURFCE.
1333 !***
1334 DO 660 I=MYIS,MYIE
1335 DO L=1,LM
1336 LL=LVL(I,J)+L
1337 IF(SHORT)RSWTT(I,L,J)=TENDS(I,LL,J)
1338 IF(LONG) RLWTT(I,L,J)=TENDL(I,LL,J)
1339 IF(LL.EQ.LM)GO TO 660
1340 ENDDO
1341 660 CONTINUE
1342 !***
1343 !*** SUM THE LW INCOMING AND SW RADIATION (W/M**2) FOR RADIN.
1344 !***
1345 DO 675 I=MYIS,MYIE
1346 IF(LONG)THEN
1347 SIGT4(I,J)=STBOL*TMID(I,LM)*TMID(I,LM)* &
1348 TMID(I,LM)*TMID(I,LM)
1349 ENDIF
1350 !
1351 !*** ACCUMULATE VARIOUS LW AND SW RADIATIVE FLUXES FOR POST
1352 !*** PROCESSOR. PASSED VIA COMMON ACMRDL AND ACMRDS.
1353 !
1354 IF(LONG)THEN
1355 RLWIN(I,J) =FLWDNS(I)
1356 RLWOUT(I,J)=FLWUPS(I)
1357 RLWTOA(I,J)=FLWUP(I)
1358 ENDIF
1359 IF(SHORT)THEN
1360 RSWIN(I,J) =FSWDNS(I)
1361 RSWOUT(I,J)=FSWUPS(I)
1362 RSWTOA(I,J)=FSWUP(I)
1363 ENDIF
1364 675 CONTINUE
1365 !***
1366 !*** THIS ROW IS FINISHED. GO TO NEXT
1367 !***
1368 ! *********************
1369 700 CONTINUE
1370 ! *********************
1371 !----------------------------------------------------------------------
1372 !***
1373 !*** CALLS TO RADIATION THIS TIME STEP ARE COMPLETE.
1374 !***
1375 !----------------------------------------------------------------------
1376 !----------------------------------------------------------------------
1377 !***
1378 !*** HORIZONTAL SMOOTHING OF TEMPERATURE TENDENCIES
1379 !***
1380 !----------------------------------------------------------------------
1381 IF(SHORT) THEN
1382 DO 800 L=1,LM
1383 ! CALL ZERO2(TL, &
1384 ! ids,ide, jds,jde, kds,kde, &
1385 ! ims,ime, jms,jme, kms,kme, &
1386 ! its,ite, jts,jte, kts,kte )
1387 ! CALL ZERO2(FNE, &
1388 ! ids,ide, jds,jde, kds,kde, &
1389 ! ims,ime, jms,jme, kms,kme, &
1390 ! its,ite, jts,jte, kts,kte )
1391 ! CALL ZERO2(FSE, &
1392 ! ids,ide, jds,jde, kds,kde, &
1393 ! ims,ime, jms,jme, kms,kme, &
1394 ! its,ite, jts,jte, kts,kte )
1395 !
1396 ! IF(KSMUD.GE.1)THEN
1397 ! DO 750 KS=1,KSMUD
1398 !!
1399 ! DO J=MYJS,MYJE
1400 ! DO I=MYIS,MYIE
1401 ! TL(I,J)=RSWTT(I,L,J)
1402 !! TL(I,J)=RSWTT(I,L,J)*HTM(I,L,J)
1403 ! ENDDO
1404 ! ENDDO
1405 !!
1406 ! DO J=MYJS,MYJE
1407 ! DO I=MYIS,MYIE
1408 ! FNE(I,J)=(TL(I+IHE(J),J+1)-TL(I,J))
1409 !! *HTM(I,L,J)*HTM(I+IHE(J),J+1,L)
1410 ! ENDDO
1411 ! ENDDO
1412 !!
1413 ! DO J=MYJS1,MYJE
1414 ! DO I=MYIS,MYIE
1415 ! FSE(I,J)=(TL(I+IHE(J),J-1)-TL(I,J))
1416 !! *HTM(I+IHE(J),J-1,L)*HTM(I,L,J)
1417 ! ENDDO
1418 ! ENDDO
1419 !!
1420 ! DO J=MYJS2,MYJE2
1421 ! DO I=MYIS,MYIE
1422 ! TL(I,J)=(FNE(I,J)-FNE(I+IHW(J),J-1) &
1423 ! +FSE(I,J)-FSE(I+IHW(J),J+1)) &
1424 ! *0.125+TL(I,J)
1425 !! *HBM2(I,J)*0.125+TL(I,J)
1426 ! ENDDO
1427 ! ENDDO
1428 !!
1429 ! DO J=MYJS,MYJE
1430 ! DO I=MYIS,MYIE
1431 ! RSWTT(I,L,J)=TL(I,J)
1432 ! ENDDO
1433 ! ENDDO
1434 !!
1435 ! 750 CONTINUE
1436 ! ENDIF
1437 !
1438 800 CONTINUE
1439 ENDIF
1440 !----------------------------------------------------------------------
1441 !
1442 IF(LONG)THEN
1443 !
1444 DO 900 L=1,LM
1445 ! CALL ZERO2(TL, &
1446 ! ids,ide, jds,jde, kds,kde, &
1447 ! ims,ime, jms,jme, kms,kme, &
1448 ! its,ite, jts,jte, kts,kte )
1449 ! CALL ZERO2(FNE, &
1450 ! ids,ide, jds,jde, kds,kde, &
1451 ! ims,ime, jms,jme, kms,kme, &
1452 ! its,ite, jts,jte, kts,kte )
1453 ! CALL ZERO2(FSE, &
1454 ! ids,ide, jds,jde, kds,kde, &
1455 ! ims,ime, jms,jme, kms,kme, &
1456 ! its,ite, jts,jte, kts,kte )
1457 !
1458 ! IF(KSMUD.GE.1)THEN
1459 ! DO 850 KS=1,KSMUD
1460 !!
1461 ! DO J=MYJS,MYJE
1462 ! DO I=MYIS,MYIE
1463 ! TL(I,J)=RLWTT(I,L,J)
1464 !! TL(I,J)=RLWTT(I,L,J)*HTM(I,L,J)
1465 ! ENDDO
1466 ! ENDDO
1467 !!
1468 ! DO J=MYJS,MYJE1
1469 ! DO I=MYIS,MYIE
1470 ! FNE(I,J)=(TL(I+IHE(J),J+1)-TL(I,J))
1471 !! *HTM(I,L,J)*HTM(I+IHE(J),J+1,L)
1472 ! ENDDO
1473 ! ENDDO
1474 !!
1475 ! DO J=MYJS1,MYJE
1476 ! DO I=MYIS,MYIE
1477 ! FSE(I,J)=(TL(I+IHE(J),J-1)-TL(I,J))
1478 !! *HTM(I+IHE(J),J-1,L)*HTM(I,L,J)
1479 ! ENDDO
1480 ! ENDDO
1481 !!
1482 ! DO J=MYJS2,MYJE2
1483 ! DO I=MYIS,MYIE
1484 ! TL(I,J)=(FNE(I,J)-FNE(I+IHW(J),J-1) &
1485 ! +FSE(I,J)-FSE(I+IHW(J),J+1)) &
1486 ! *0.125+TL(I,J)
1487 !! *HBM2(I,J)*0.125+TL(I,J)
1488 ! ENDDO
1489 ! ENDDO
1490 !!
1491 ! DO J=MYJS,MYJE
1492 ! DO I=MYIS,MYIE
1493 ! RLWTT(I,L,J)=TL(I,J)
1494 ! ENDDO
1495 ! ENDDO
1496 !!
1497 ! 850 CONTINUE
1498 ! ENDIF
1499 900 CONTINUE
1500 ENDIF
1501 !----------------------------------------------------------------------
1503 END SUBROUTINE RADTN
1505 !----------------------------------------------------------------------
1507 SUBROUTINE ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
1508 MYIS,MYIE,MYJS,MYJE, &
1509 IDS,IDE, JDS,JDE, KDS,KDE, &
1510 IMS,IME, JMS,JME, KMS,KME, &
1511 ITS,ITE, JTS,JTE, KTS,KTE)
1512 !----------------------------------------------------------------------
1513 IMPLICIT NONE
1514 !----------------------------------------------------------------------
1515 INTEGER, INTENT(IN) :: IDS,IDE, JDS,JDE, KDS,KDE , &
1516 IMS,IME, JMS,JME, KMS,KME , &
1517 ITS,ITE, JTS,JTE, KTS,KTE
1518 INTEGER, INTENT(IN) :: MYJS,MYJE,MYIS,MYIE
1520 REAL, INTENT(IN) :: TIMES
1521 REAL, INTENT(OUT) :: HOUR,DAYI
1522 INTEGER, INTENT(IN) :: IHRST
1524 INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
1525 REAL, INTENT(IN), DIMENSION(IMS:IME,JMS:JME) :: GLAT,GLON
1526 REAL, INTENT(OUT), DIMENSION(IMS:IME,JMS:JME) :: CZEN
1528 REAL, PARAMETER :: GSTC1=24110.54841,GSTC2=8640184.812866, &
1529 GSTC3=9.3104E-2,GSTC4=-6.2E-6, &
1530 PI=3.1415926,PI2=2.*PI,PIH=0.5*PI, &
1531 !#$ DEG2RD=1.745329E-2,OBLIQ=23.440*DEG2RD, &
1532 DEG2RD=3.1415926/180.,OBLIQ=23.440*DEG2RD, &
1533 ZEROJD=2451545.0
1535 REAL :: DAY,YFCTR,ADDDAY,STARTYR,DATJUL,DIFJD,SLONM, &
1536 ANOM,SLON,DEC,RA,DATJ0,TU,STIM0,SIDTIM,HRANG
1537 REAL :: HRLCL,SINALT
1538 INTEGER :: KMNTH,KNT,IDIFYR,J,I
1539 LOGICAL :: LEAP
1540 !-----------------------------------------------------------------------
1541 !-----------------------------------------------------------------------
1542 INTEGER :: MONTH (12)
1543 !-----------------------------------------------------------------------
1544 DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
1545 !***********************************************************************
1546 ! SAVE MONTH
1547 DAY=0.
1548 LEAP=.FALSE.
1549 IF(MOD(IDAT(3),4).EQ.0)THEN
1550 MONTH(2)=29
1551 LEAP=.TRUE.
1552 ENDIF
1553 IF(IDAT(1).GT.1)THEN
1554 KMNTH=IDAT(1)-1
1555 DO 10 KNT=1,KMNTH
1556 DAY=DAY+REAL(MONTH(KNT))
1557 10 CONTINUE
1558 ENDIF
1559 !***
1560 !*** CALCULATE EXACT NUMBER OF DAYS FROM BEGINNING OF YEAR TO
1561 !*** FORECAST TIME OF INTEREST
1562 !***
1563 DAY=DAY+REAL(IDAT(2)-1)+(REAL(IHRST)+TIMES/3600.)/24.
1564 DAYI=REAL(INT(DAY)+1)
1565 HOUR=(DAY-DAYI+1.)*24.
1566 YFCTR=2000.-IDAT(3)
1567 !-----------------------------------------------------------------------
1568 !***
1569 !*** FIND CELESTIAL LONGITUDE OF THE SUN THEN THE SOLAR DECLINATION AND
1570 !*** RIGHT ASCENSION.
1571 !***
1572 !-----------------------------------------------------------------------
1573 IDIFYR=IDAT(3)-2000
1574 !***
1575 !*** FIND JULIAN DATE OF START OF THE RELEVANT YEAR
1576 !*** ADDING IN LEAP DAYS AS NEEDED
1577 !***
1578 IF(IDIFYR.LT.0)THEN
1579 ADDDAY=REAL(IDIFYR/4)
1580 ELSE
1581 ADDDAY=REAL((IDIFYR+3)/4)
1582 ENDIF
1583 STARTYR=ZEROJD+IDIFYR*365.+ADDDAY-0.5
1584 !***
1585 !*** THE JULIAN DATE OF THE TIME IN QUESTION
1586 !***
1587 DATJUL=STARTYR+DAY
1588 !
1589 !*** DIFFERENCE OF ACTUAL JULIAN DATE FROM JULIAN DATE
1590 !*** AT 00H 1 January 2000
1591 !
1592 DIFJD=DATJUL-ZEROJD
1593 !
1594 !*** MEAN GEOMETRIC LONGITUDE OF THE SUN
1595 !
1596 SLONM=(280.460+0.9856474*DIFJD)*DEG2RD+YFCTR*PI2
1597 !
1598 !*** THE MEAN ANOMOLY
1599 !
1600 ANOM=(357.528+0.9856003*DIFJD)*DEG2RD
1601 !
1602 !*** APPARENT GEOMETRIC LONGITUDE OF THE SUN
1603 !
1604 SLON=SLONM+(1.915*SIN(ANOM)+0.020*SIN(2.*ANOM))*DEG2RD
1605 IF(SLON.GT.PI2)SLON=SLON-PI2
1606 !
1607 !*** DECLINATION AND RIGHT ASCENSION
1608 !
1609 DEC=ASIN(SIN(SLON)*SIN(OBLIQ))
1610 RA=ACOS(COS(SLON)/COS(DEC))
1611 IF(SLON.GT.PI)RA=PI2-RA
1612 !***
1613 !*** FIND THE GREENWICH SIDEREAL TIME THEN THE LOCAL SOLAR
1614 !*** HOUR ANGLE.
1615 !***
1616 DATJ0=STARTYR+DAYI-1.
1617 TU=(DATJ0-2451545.)/36525.
1618 STIM0=GSTC1+GSTC2*TU+GSTC3*TU**2+GSTC4*TU**3
1619 SIDTIM=STIM0/3600.+YFCTR*24.+1.00273791*HOUR
1620 SIDTIM=SIDTIM*15.*DEG2RD
1621 IF(SIDTIM.LT.0.)SIDTIM=SIDTIM+PI2
1622 IF(SIDTIM.GT.PI2)SIDTIM=SIDTIM-PI2
1623 HRANG=SIDTIM-RA
1624 !
1625 DO 100 J=MYJS,MYJE
1626 DO 100 I=MYIS,MYIE
1627 ! HRLCL=HRANG-GLON(I,J)
1628 HRLCL=HRANG+GLON(I,J)+PI2
1629 !***
1630 !*** THE ZENITH ANGLE IS THE COMPLEMENT OF THE ALTITUDE THUS THE
1631 !*** COSINE OF THE ZENITH ANGLE EQUALS THE SINE OF THE ALTITUDE.
1632 !***
1633 SINALT=SIN(DEC)*SIN(GLAT(I,J))+COS(DEC)*COS(HRLCL)* &
1634 COS(GLAT(I,J))
1635 IF(SINALT.LT.0.)SINALT=0.
1636 CZEN(I,J)=SINALT
1637 100 CONTINUE
1638 !***
1639 !*** IF THE FORECAST IS IN A DIFFERENT YEAR THAN THE START TIME,
1640 !*** RESET DAYI TO THE PROPER DAY OF THE NEW YEAR (IT MUST NOT BE
1641 !*** RESET BEFORE THE SOLAR ZENITH ANGLE IS COMPUTED).
1642 !***
1643 IF(DAYI.GT.365.)THEN
1644 IF(.NOT.LEAP)THEN
1645 DAYI=DAYI-365.
1646 ELSEIF(LEAP.AND.DAYI.GT.366.)THEN
1647 DAYI=DAYI-366.
1648 ENDIF
1649 ENDIF
1650 !
1651 END SUBROUTINE ZENITH
1652 !-----------------------------------------------------------------------
1654 SUBROUTINE OZON2D (LK,POZN,XLAT,RSIN1,RCOS1,RCOS2,QO3, &
1655 ! XDUO3N,XDO3N4,XDO3N2,XDO3N3, &
1656 ! PRGFDL,MYIS,MYIE, &
1657 MYIS,MYIE, &
1658 ids,ide, jds,jde, kds,kde, &
1659 ims,ime, jms,jme, kms,kme, &
1660 its,ite, jts,jte, kts,kte )
1661 !----------------------------------------------------------------------
1662 IMPLICIT NONE
1663 !----------------------------------------------------------------------
1664 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
1665 ims,ime, jms,jme, kms,kme , &
1666 its,ite, jts,jte, kts,kte
1667 INTEGER, INTENT(IN) :: LK,MYIS,MYIE
1668 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: POZN
1669 REAL, INTENT(IN), DIMENSION(its:ite) :: XLAT
1670 REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte) :: QO3
1671 REAL, INTENT(IN) :: RSIN1,RCOS1,RCOS2
1672 !----------------------------------------------------------------------
1673 INTEGER, PARAMETER :: NL=81,NLP1=NL+1,LNGTH=37*NL
1674 REAL, PARAMETER :: RTD=57.2957795
1676 ! REAL, INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N4,XDO3N2,XDO3N3
1677 ! REAL, INTENT(IN), DIMENSION(NL) :: PRGFDL
1678 !----------------------------------------------------------------------
1679 !----------------------------------------------------------------------
1680 INTEGER,DIMENSION(its:ite) :: JJROW
1681 REAL, DIMENSION(its:ite) :: TTHAN
1682 REAL, DIMENSION(its:ite,NL) :: QO3O3
1684 INTEGER :: I,K,NUMITR,ILOG,IT,NHALF
1685 REAL :: TH2,DO3V,DO3VP,APHI,APLO
1686 !----------------------------------------------------------------------
1687 DO I=MYIS,MYIE
1688 TH2=0.2*XLAT(I)
1689 JJROW(I)=19.001-TH2
1690 TTHAN(I)=(19-JJROW(I))-TH2
1691 ENDDO
1692 !
1693 !*** SEASONAL AND SPATIAL INTERPOLATION DONE BELOW.
1694 !
1695 DO K=1,NL
1696 DO I=MYIS,MYIE
1697 DO3V=XDUO3N(JJROW(I),K)+RSIN1*XDO3N2(JJROW(I),K) &
1698 +RCOS1*XDO3N3(JJROW(I),K) &
1699 +RCOS2*XDO3N4(JJROW(I),K)
1700 DO3VP=XDUO3N(JJROW(I)+1,K)+RSIN1*XDO3N2(JJROW(I)+1,K) &
1701 +RCOS1*XDO3N3(JJROW(I)+1,K) &
1702 +RCOS2*XDO3N4(JJROW(I)+1,K)
1703 !
1704 !*** NOW LATITUDINAL INTERPOLATION
1705 !*** AND CONVERT O3 INTO MASS MIXING RATIO (ORIG DATA MPY BY 1.E4)
1706 !
1707 QO3O3(I,K)=1.E-4*(DO3V+TTHAN(I)*(DO3VP-DO3V))
1708 ENDDO
1709 ENDDO
1710 !***
1711 !*** VERTICAL INTERPOLATION FOR EACH GRIDPOINT (LINEAR IN LN P)
1712 !***
1713 NUMITR=0
1714 ILOG=NL
1715 20 CONTINUE
1716 ILOG=(ILOG+1)/2
1717 IF(ILOG.EQ.1)GO TO 25
1718 NUMITR=NUMITR+1
1719 GO TO 20
1720 25 CONTINUE
1721 !
1722 DO 60 K=1,LK
1723 !
1724 NHALF=(NL+1)/2
1725 DO I=MYIS,MYIE
1726 JJROW(I)=NHALF
1727 ENDDO
1728 !
1729 DO 40 IT=1,NUMITR
1730 NHALF=(NHALF+1)/2
1731 DO I=MYIS,MYIE
1732 IF(POZN(I,K).LT.PRGFDL(JJROW(I)-1))THEN
1733 JJROW(I)=JJROW(I)-NHALF
1734 ELSEIF(POZN(I,K).GE.PRGFDL(JJROW(I)))THEN
1735 JJROW(I)=JJROW(I)+NHALF
1736 ENDIF
1737 JJROW(I)=MIN(JJROW(I),NL)
1738 JJROW(I)=MAX(JJROW(I),2)
1739 ENDDO
1740 40 CONTINUE
1741 !
1742 DO 50 I=MYIS,MYIE
1743 IF(POZN(I,K).LT.PRGFDL(1))THEN
1744 QO3(I,K)=QO3O3(I,1)
1745 ELSE IF(POZN(I,K).GT.PRGFDL(NL))THEN
1746 QO3(I,K)=QO3O3(I,NL)
1747 ELSE
1748 APLO=ALOG(PRGFDL(JJROW(I)-1))
1749 APHI=ALOG(PRGFDL(JJROW(I)))
1750 QO3(I,K)=QO3O3(I,JJROW(I))+(ALOG(POZN(I,K))-APHI)/ &
1751 (APLO-APHI)* &
1752 (QO3O3(I,JJROW(I)-1)-QO3O3(I,JJROW(I)))
1753 ENDIF
1754 50 CONTINUE
1755 !
1756 60 CONTINUE
1758 END SUBROUTINE OZON2D
1759 !-----------------------------------------------------------------------
1761 ! SUBROUTINE ZERO2(ARRAY, &
1762 ! ids,ide, jds,jde, kds,kde, &
1763 ! ims,ime, jms,jme, kms,kme, &
1764 ! its,ite, jts,jte, kts,kte )
1765 !----------------------------------------------------------------------
1766 !IMPLICIT NONE
1767 !----------------------------------------------------------------------
1768 ! INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
1769 ! ims,ime, jms,jme, kms,kme , &
1770 ! its,ite, jts,jte, kts,kte
1771 ! REAL, INTENT(INOUT), DIMENSION(its:ite,jts:jte) :: ARRAY
1772 ! INTEGER :: I,J
1773 !----------------------------------------------------------------------
1774 ! DO J=jts,jte
1775 ! DO I=its,ite
1776 ! ARRAY(I,J)=0.
1777 ! ENDDO
1778 ! ENDDO
1780 ! END SUBROUTINE ZERO2
1782 !----------------------------------------------------------------
1784 SUBROUTINE O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, &
1785 ids,ide, jds,jde, kds,kde, &
1786 ims,ime, jms,jme, kms,kme, &
1787 its,ite, jts,jte, kts,kte )
1788 !----------------------------------------------------------------------
1789 IMPLICIT NONE
1790 !----------------------------------------------------------------------
1791 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
1792 ims,ime, jms,jme, kms,kme , &
1793 its,ite, jts,jte, kts,kte
1795 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
1796 ! . . . .
1797 ! SUBPROGRAM: O3INT COMPUTE ZONAL MEAN OZONE FOR ETA LYRS
1798 ! PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07
1799 ! MICHAEL BALDWIN ORG: W/NMC22 DATE: 92-06-08
1800 !
1801 ! ABSTRACT: THIS CODE WRITTEN AT GFDL...
1802 ! CALCULATES SEASONAL ZONAL MEAN OZONE,EVERY 5 DEG OF LATITUDE,
1803 ! FOR CURRENT MODEL VERTICAL COORDINATE. OUTPUT DATA IN G/G * 1.E4
1804 ! CODE IS CALLED ONLY ONCE.
1805 !
1806 ! PROGRAM HISTORY LOG:
1807 ! 84-01-01 FELS AND SCHWARZKOPF,GFDL.
1808 ! 89-07-07 K. CAMPANA - ADAPTED STAND-ALONE CODE FOR IN-LINE USE.
1809 ! 92-06-08 M. BALDWIN - UPDATE TO RUN IN ETA MODEL
1810 !
1811 ! USAGE: CALL O3INT(O3,SIGL) OLD
1812 ! INPUT ARGUMENT LIST:
1813 ! PHALF - MID LAYER PRESSURE (K=LM+1 IS MODEL SURFACE)
1814 ! OUTPUT ARGUMENT LIST:
1815 ! DDUO3N - ZONAL MEAN OZONE DATA IN ALL MODEL LAYERS (G/G*1.E4)
1816 ! DDO3N2 DIMENSIONED(L,N),WHERE L(=37) IS LATITUDE BETWEEN
1817 ! DDO3N3 N AND S POLES,N=NUM OF VERTICAL LYRS(K=1 IS TOP LYR)
1818 ! DDO3N4 AND SEASON-WIN,SPR,SUM,FALL.
1819 ! IN COMMON
1820 !
1821 ! OUTPUT FILES:
1822 ! OUTPUT - PRINT FILE.
1823 !
1824 ! ATTRIBUTES:
1825 ! LANGUAGE: FORTRAN 200.
1826 !
1827 !$$$
1828 !.... PROGRAM O3INT FROM DAN SCHWARZKOPF-GETS ZONAL MEAN O3
1829 !.. OUTPUT O3 IS WINTER,SPRING,SUMMER,FALL (NORTHERN HEMISPHERE)
1830 !-----------------------------------------------------------------------
1831 ! INCLUDE "parmeta"
1832 !-----------------------------------------------------------------------
1833 ! *********************************************************
1835 INTEGER :: N,NP,NP2,NM1
1837 ! PARAMETER (N=LM,NP=N+1,NP2=N+2,NM1=N-1)
1838 ! *********************************************************
1839 !-----------------------------------------------------------------------
1840 !***
1841 !*** SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN
1842 !*** CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE).
1843 !*** DEFINED AS 5 DEG LAT MEANS N.P.->S.P.
1844 !***
1845 REAL, INTENT(OUT), DIMENSION(37,kte):: DDUO3N,DDO3N2,DDO3N3,DDO3N4
1847 ! C O M M O N /SAVMEM/
1848 ! ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL.....
1849 ! 1 DDUO3N(37,LM), DDO3N2(37,LM), DDO3N3(37,LM), DDO3N4(37,LM)
1850 ! ..... K.CAMPANA OCTOBER 1988
1851 !CCC DIMENSION T41(NP2,2),O3O3(37,N,4)
1852 ! DIMENSION SIGL(N)
1853 ! *********************************************************
1854 REAL :: QI(82)
1855 REAL :: DDUO3(19,kts:kte),RO31(10,41),RO32(10,41),DUO3N(19,41)
1856 REAL :: TEMPN(19)
1857 REAL :: O3HI(10,25),O3LO1(10,16),O3LO2(10,16),O3LO3(10,16), &
1858 O3LO4(10,16)
1859 REAL :: O3HI1(10,16),O3HI2(10,9),PH1(45),PH2(37),P1(48),P2(33)
1860 REAL :: O35DEG(37,kts:kte)
1861 REAL :: RSTD(81),RO3(10,41),RO3M(10,40),RBAR(kts:kte),RDATA(81), &
1862 PHALF(kts:kte+1),P(81),PH(82)
1864 INTEGER :: NKK,NK,NKP,K,L,NCASE,ITAPE,IPLACE,NKMM,NKM,KI,KK,KQ,JJ,KEN
1865 REAL :: O3RD,O3TOT,O3DU
1867 EQUIVALENCE (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17))
1868 EQUIVALENCE (PH1(1),PH(1)),(PH2(1),PH(46))
1869 EQUIVALENCE (P1(1),P(1)),(P2(1),P(49))
1870 DATA PH1/ 0., &
1871 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, &
1872 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, &
1873 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, &
1874 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, &
1875 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, &
1876 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, &
1877 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, &
1878 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, &
1879 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, &
1880 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, &
1881 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
1882 DATA PH2/ &
1883 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, &
1884 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, &
1885 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, &
1886 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, &
1887 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, &
1888 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, &
1889 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, &
1890 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, &
1891 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, &
1892 0.1000000E+01/
1893 DATA P1/ &
1894 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, &
1895 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, &
1896 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, &
1897 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, &
1898 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, &
1899 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, &
1900 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, &
1901 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, &
1902 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, &
1903 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, &
1904 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, &
1905 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
1906 DATA P2/ &
1907 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, &
1908 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, &
1909 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, &
1910 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, &
1911 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, &
1912 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, &
1913 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, &
1914 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, &
1915 0.1000000E+01/
1916 DATA O3HI1/ &
1917 .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, &
1918 .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, &
1919 .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, &
1920 .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, &
1921 .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, &
1922 .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, &
1923 .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, &
1924 .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, &
1925 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, &
1926 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, &
1927 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, &
1928 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, &
1929 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, &
1930 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, &
1931 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, &
1932 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/
1933 DATA O3HI2/ &
1934 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, &
1935 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, &
1936 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, &
1937 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, &
1938 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, &
1939 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, &
1940 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
1941 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, &
1942 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
1943 DATA O3LO1/ &
1944 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, &
1945 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, &
1946 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, &
1947 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, &
1948 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, &
1949 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, &
1950 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, &
1951 .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, &
1952 .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, &
1953 .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, &
1954 .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, &
1955 .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, &
1956 .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, &
1957 .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, &
1958 .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, &
1959 .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
1960 DATA O3LO2/ &
1961 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, &
1962 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, &
1963 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, &
1964 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, &
1965 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, &
1966 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, &
1967 .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, &
1968 .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, &
1969 .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, &
1970 .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, &
1971 .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, &
1972 .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, &
1973 .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, &
1974 .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, &
1975 .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, &
1976 .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
1977 DATA O3LO3/ &
1978 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, &
1979 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, &
1980 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, &
1981 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, &
1982 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, &
1983 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, &
1984 .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, &
1985 .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, &
1986 .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, &
1987 .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, &
1988 .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, &
1989 .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, &
1990 .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, &
1991 .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, &
1992 .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, &
1993 .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
1994 DATA O3LO4/ &
1995 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, &
1996 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, &
1997 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, &
1998 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, &
1999 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, &
2000 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, &
2001 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, &
2002 .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, &
2003 .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, &
2004 .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, &
2005 .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, &
2006 .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, &
2007 .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, &
2008 .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, &
2009 .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, &
2010 .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/
2012 !!!!!
2013 ! PSS=101325.
2014 ! PDIF=PSS-PT
2015 !
2016 ! DO L=1,LM1
2017 ! PHALF(L+1)=AETA(L)*PDIF+PT
2018 ! ENDDO
2019 !
2020 ! PHALF(1)=0.
2021 ! PHALF(LP1)=PSS
2022 !!!!
2023 N=kte;NP=N+1;NP2=N+2;NM1=N-1
2025 NKK=41
2026 NK=81
2027 NKP=NK+1
2028 DO 24 K=1,NP
2029 ! 24 PHALF(K)=PHALF(K)*1.0E 03
2030 24 PHALF(K)=PHALF(K)*0.01*1.0E+03
2031 ! 24 PSTD(K)=PSTD(K+1)*1.0E 03
2032 DO 25 K=1,NK
2033 PH(K)=PH(K)*1013250.
2034 25 P(K)=P(K)*1013250.
2035 PH(NKP)=PH(NKP)*1013250.
2036 !KAC WRITE (6,3) PH
2037 !KAC WRITE (6,3) P
2038 ! WRITE (6,3) (PHALF(K),K=1,NP)
2039 ! WRITE (6,3) (PSTD(K),K=1,NP)
2040 !***LOAD ARRAYS RO31,RO32,AS IN DICKS PGM.
2041 DO 1010 K=1,25
2042 DO 1010 L=1,10
2043 RO31(L,K)=O3HI(L,K)
2044 RO32(L,K)=O3HI(L,K)
2045 1010 CONTINUE
2046 !
2047 DO 3000 NCASE=1,4
2048 ITAPE=NCASE+50
2049 IPLACE=2
2050 IF (NCASE.EQ.2) IPLACE=4
2051 IF (NCASE.EQ.3) IPLACE=1
2052 IF (NCASE.EQ.4) IPLACE=3
2053 !***NCASE=1: SPRING (IN N.H.)
2054 !***NCASE=2: FALL (IN N.H.)
2055 !***NCASE=3: WINTER (IN N.H.)
2056 !***NCASE=4: SUMMER (IN N.H.)
2057 IF (NCASE.EQ.1.OR.NCASE.EQ.2) THEN
2058 DO 1011 K=26,41
2059 DO 1011 L=1,10
2060 RO31(L,K)=O3LO1(L,K-25)
2061 RO32(L,K)=O3LO2(L,K-25)
2062 1011 CONTINUE
2063 ENDIF
2064 IF (NCASE.EQ.3.OR.NCASE.EQ.4) THEN
2065 DO 1031 K=26,41
2066 DO 1031 L=1,10
2067 RO31(L,K)=O3LO3(L,K-25)
2068 RO32(L,K)=O3LO4(L,K-25)
2069 1031 CONTINUE
2070 ENDIF
2071 DO 30 KK=1,NKK
2072 DO 31 L=1,10
2073 DUO3N(L,KK)=RO31(11-L,KK)
2074 31 DUO3N(L+9,KK)=RO32(L,KK)
2075 DUO3N(10,KK)=.5*(RO31(1,KK)+RO32(1,KK))
2076 30 CONTINUE
2077 !***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON
2078 IF (NCASE.EQ.2.OR.NCASE.EQ.4) THEN
2079 DO 1024 KK=1,NKK
2080 DO 1025 L=1,19
2081 TEMPN(L)=DUO3N(20-L,KK)
2082 1025 CONTINUE
2083 DO 1026 L=1,19
2084 DUO3N(L,KK)=TEMPN(L)
2085 1026 CONTINUE
2086 1024 CONTINUE
2087 ENDIF
2088 !***DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON,AT STD. PRESSURE
2089 ! LEVELS
2090 !KAC WRITE (6,800) DUO3N
2091 !***BEGIN LATITUDE (10 DEG) LOOP
2092 DO 33 L=1,19
2093 DO 22 KK=1,NKK
2094 22 RSTD(KK)=DUO3N(L,KK)
2095 NKM=NK-1
2096 NKMM=NK-3
2097 ! BESSELS HALF-POINT INTERPOLATION FORMULA
2098 DO 60 K=4,NKMM,2
2099 KI=K/2
2100 60 RDATA(K)=.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1)-RSTD(KI)+ &
2101 RSTD(KI-1))/16.
2102 RDATA(2)=.5*(RSTD(2)+RSTD(1))
2103 RDATA(NKM)=.5*(RSTD(NKK)+RSTD(NKK-1))
2104 ! PUT UNCHANGED DATA INTO NEW ARRAY
2105 DO 61 K=1,NK,2
2106 KQ=(K+1)/2
2107 61 RDATA(K)=RSTD(KQ)
2108 !---NOTE TO NMC: THIS WRITE IS COMMENTED OUT TO REDUCE PRINTOUT
2109 ! WRITE (6,798) RDATA
2110 ! CALCULATE LAYER-MEAN OZONE MIXING RATIO FOR EACH MODEL LEVEL
2111 DO 99 KK=1,N
2112 RBAR(KK)=0.
2113 ! LOOP TO CALCULATE SUMS TO GET LAYER OZONE MEAN
2114 DO 98 K=1,NK
2115 IF(PH(K+1).LT.PHALF(KK)) GO TO 98
2116 IF(PH(K).GT.PHALF(KK+1)) GO TO 98
2117 IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).LT.PHALF(KK)) RBAR(KK)=RBAR(KK &
2118 )+RDATA(K)*(PH(K+1)-PHALF(KK))
2119 IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).GE.PHALF(KK)) RBAR(KK)=RBAR(KK &
2120 )+RDATA(K)*(PH(K+1)-PH(K))
2121 IF(PH(K+1).GT.PHALF(KK+1).AND.PH(K).GT.PHALF(KK)) RBAR(KK)=RBAR(KK &
2122 )+RDATA(K)*(PHALF(KK+1)-PH(K))
2123 98 CONTINUE
2124 RBAR(KK)=RBAR(KK)/(PHALF(KK+1)-PHALF(KK))
2125 IF(RBAR(KK).GT..0000) GO TO 99
2126 ! CODE TO COVER CASE WHEN MODEL RESOLUTION IS SO FINE THAT NO VALUE
2127 ! OF P(K) IN THE OZONE DATA ARRAY FALLS BETWEEN PHALF(KK+1) AND
2128 ! PHALF(KK). PROCEDURE IS TO SIMPLY GRAB THE NEAREST VALUE FROM
2129 ! RDATA
2130 DO 29 K=1,NK
2131 IF(PH(K).LT.PHALF(KK).AND.PH(K+1).GE.PHALF(KK+1)) RBAR(KK)=RDATA(K)
2132 29 CONTINUE
2133 99 CONTINUE
2134 ! CALCULATE TOTAL OZONE
2135 O3RD=0.
2136 DO 89 KK=1,80
2137 89 O3RD=O3RD+RDATA(KK)*(PH(KK+1)-PH(KK))
2138 O3RD=O3RD+RDATA(81)*(P(81)-PH(81))
2139 O3RD=O3RD/980.
2140 O3TOT=0.
2141 DO 88 KK=1,N
2142 88 O3TOT=O3TOT+RBAR(KK)*(PHALF(KK+1)-PHALF(KK))
2143 O3TOT=O3TOT/980.
2144 ! UNITS ARE MICROGRAMS/CM**2
2145 O3DU=O3TOT/2.144
2146 ! O3DU UNITS ARE DOBSON UNITS (10**-3 ATM-CM)
2147 !--NOTE TO NMC: THIS IS COMMENTED OUT TO SAVE PRINTOUT
2148 ! WRITE (6,796) O3RD,O3TOT,O3DU
2149 DO 23 KK=1,N
2150 23 DDUO3(L,KK)=RBAR(KK)*.01
2151 33 CONTINUE
2152 !***END OF LATITUDE LOOP
2153 !
2154 !***CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF
2155 ! 10 DEG VALUES
2156 DO 1060 KK=1,N
2157 DO 1061 L=1,19
2158 O35DEG(2*L-1,KK)=DDUO3(L,KK)
2159 1061 CONTINUE
2160 DO 1062 L=1,18
2161 O35DEG(2*L,KK)=0.5*(DDUO3(L,KK)+DDUO3(L+1,KK))
2162 1062 CONTINUE
2163 1060 CONTINUE
2164 !***OUTPUT TO UNIT (ITAPE) THE OZONE VALUES FOR LATER USE
2165 !O222 ***************************************************
2166 !C WRITE (66) O35DEG
2167 IF (IPLACE.EQ.1) THEN
2168 DO 302 JJ=1,37
2169 DO 302 KEN=1,N
2170 DDUO3N(JJ,KEN) = O35DEG(JJ,KEN)
2171 302 CONTINUE
2172 ELSE IF (IPLACE.EQ.2) THEN
2173 DO 312 JJ=1,37
2174 DO 312 KEN=1,N
2175 DDO3N2(JJ,KEN) = O35DEG(JJ,KEN)
2176 312 CONTINUE
2177 ELSE IF (IPLACE.EQ.3) THEN
2178 DO 322 JJ=1,37
2179 DO 322 KEN=1,N
2180 DDO3N3(JJ,KEN) = O35DEG(JJ,KEN)
2181 322 CONTINUE
2182 ELSE IF (IPLACE.EQ.4) THEN
2183 DO 332 JJ=1,37
2184 DO 332 KEN=1,N
2185 DDO3N4(JJ,KEN) = O35DEG(JJ,KEN)
2186 332 CONTINUE
2187 END IF
2188 !O222 ***************************************************
2189 3000 CONTINUE
2190 !***END OF LOOP OVER CASES
2191 RETURN
2192 1 FORMAT(10F4.2)
2193 2 FORMAT(10X,E14.7,1X,E14.7,1X,E14.7,1X,E14.7,1X)
2194 3 FORMAT(10E12.5)
2195 797 FORMAT(10F7.2)
2196 799 FORMAT(19F6.4)
2197 800 FORMAT(19F6.2)
2198 102 FORMAT(' O3 IPLACE=',I4)
2199 1033 FORMAT(19F6.5)
2200 101 FORMAT(5X,1H*,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5, &
2201 1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,)
2203 END SUBROUTINE O3INT
2204 !----------------------------------------------------------------
2206 SUBROUTINE CLO89(CLDFAC,CAMT,NCLDS,KBTM,KTOP &
2207 , ids,ide, jds,jde, kds,kde &
2208 , ims,ime, jms,jme, kms,kme &
2209 , its,ite, jts,jte, kts,kte )
2210 !----------------------------------------------------------------------
2211 IMPLICIT NONE
2212 !----------------------------------------------------------------------
2213 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
2214 ims,ime, jms,jme, kms,kme , &
2215 its,ite, jts,jte, kts,kte
2216 !----------------------------------------------------------------------
2218 ! ************************************************************
2219 ! * *
2220 ! * THIS SUBROUTINE WAS MODIFIED TO BE USED IN THE ETA MODEL *
2221 ! * *
2222 ! * Q. ZHAO 95-3-22 *
2223 ! * *
2224 ! ************************************************************
2226 REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2227 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT
2228 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2229 INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS
2231 REAL, DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT
2232 REAL, DIMENSION(kts:kte+1) :: CLDROW
2233 INTEGER:: IQ,ITOP,I,J,JTOP,IR,IP,K1,K2,KB,K,KP,KT,NC
2234 REAL :: XCLD
2236 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE
2238 ! DIMENSION CLDIPT(LP1,LP1, 64 )
2239 ! DIMENSION NCLDS(IDIM1:IDIM2),KTOP(IDIM1:IDIM2,LP1), &
2240 ! KBTM(IDIM1:IDIM2,LP1)
2241 ! DIMENSION CLDROW(LP1)
2242 ! DIMENSION CAMT(IDIM1:IDIM2,LP1),CLDFAC(IDIM1:IDIM2,LP1,LP1)
2244 L=kte
2245 LP1=L+1; LP2=L+2; LP3=L+3
2246 LM1=L-1; LM2=L-2; LM3=L-3
2247 MYIS=its; MYIE=ite
2249 !
2250 DO 1 IQ=MYIS,MYIE,64
2251 ITOP=IQ+63
2252 IF(ITOP.GT.MYIE) ITOP=MYIE
2253 JTOP=ITOP-IQ+1
2254 DO 11 IP=1,JTOP
2255 IR=IQ+IP-1
2256 IF (NCLDS(IR).EQ.0) THEN
2257 DO 25 J=1,LP1
2258 DO 25 I=1,LP1
2259 CLDIPT(I,J,IP)=1.
2260 25 CONTINUE
2261 ENDIF
2262 IF (NCLDS(IR).GE.1) THEN
2263 XCLD=1.-CAMT(IR,2)
2264 K1=KTOP(IR,2)+1
2265 K2=KBTM(IR,2)
2266 DO 27 J=1,LP1
2267 CLDROW(J)=1.
2268 27 CONTINUE
2269 DO 29 J=1,K2
2270 CLDROW(J)=XCLD
2271 29 CONTINUE
2272 KB=MAX(K1,K2+1)
2273 DO 33 K=KB,LP1
2274 DO 33 KP=1,LP1
2275 CLDIPT(KP,K,IP)=CLDROW(KP)
2276 33 CONTINUE
2277 DO 37 J=1,LP1
2278 CLDROW(J)=1.
2279 37 CONTINUE
2280 DO 39 J=K1,LP1
2281 CLDROW(J)=XCLD
2282 39 CONTINUE
2283 KT=MIN(K1-1,K2)
2284 DO 43 K=1,KT
2285 DO 43 KP=1,LP1
2286 CLDIPT(KP,K,IP)=CLDROW(KP)
2287 43 CONTINUE
2288 IF(K2+1.LE.K1-1) THEN
2289 DO 31 J=K2+1,K1-1
2290 DO 31 I=1,LP1
2291 CLDIPT(I,J,IP)=1.
2292 31 CONTINUE
2293 ELSE IF(K1.LE.K2) THEN
2294 DO 32 J=K1,K2
2295 DO 32 I=1,LP1
2296 CLDIPT(I,J,IP)=XCLD
2297 32 CONTINUE
2298 ENDIF
2299 ENDIF
2301 IF (NCLDS(IR).GE.2) THEN
2302 DO 21 NC=2,NCLDS(IR)
2303 XCLD=1.-CAMT(IR,NC+1)
2304 K1=KTOP(IR,NC+1)+1
2305 K2=KBTM(IR,NC+1)
2306 DO 47 J=1,LP1
2307 CLDROW(J)=1.
2308 47 CONTINUE
2309 DO 49 J=1,K2
2310 CLDROW(J)=XCLD
2311 49 CONTINUE
2312 KB=MAX(K1,K2+1)
2313 DO 53 K=KB,LP1
2314 DO 53 KP=1,LP1
2315 CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP)
2316 53 CONTINUE
2317 DO 57 J=1,LP1
2318 CLDROW(J)=1.
2319 57 CONTINUE
2320 DO 59 J=K1,LP1
2321 CLDROW(J)=XCLD
2322 59 CONTINUE
2323 KT=MIN(K1-1,K2)
2324 DO 63 K=1,KT
2325 DO 63 KP=1,LP1
2326 CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP)
2327 63 CONTINUE
2328 IF(K1.LE.K2) THEN
2329 DO 52 J=K1,K2
2330 DO 52 I=1,LP1
2331 CLDIPT(I,J,IP)=CLDIPT(I,J,IP)*XCLD
2332 52 CONTINUE
2333 ENDIF
2334 21 CONTINUE
2335 ENDIF
2336 11 CONTINUE
2337 DO 71 J=1,LP1
2338 DO 71 I=1,LP1
2339 DO 71 IP=1,JTOP
2340 IR=IQ+IP-1
2341 CLDFAC(IR,I,J)=CLDIPT(I,J,IP)
2342 71 CONTINUE
2343 1 CONTINUE
2345 END SUBROUTINE CLO89
2346 !----------------------------------------------------------------
2347 ! SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, &
2348 ! PRESS,TEMP,RH2O,QO3,CLDFAC, &
2349 ! CAMT,NCLDS,KTOP,KBTM, &
2350 !! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
2351 ! BO3RND,AO3RND, &
2352 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2353 ! ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
2354 ! GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
2355 ! P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
2356 ! TEN,HP1,FOUR,HM1EZ,SKO3R, &
2357 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
2358 ! HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
2359 ! RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, &
2360 ! ids,ide, jds,jde, kds,kde, &
2361 ! ims,ime, jms,jme, kms,kme, &
2362 ! its,ite, jts,jte, kts,kte )
2364 SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, &
2365 PRESS,TEMP,RH2O,QO3,CLDFAC, &
2366 CAMT,NCLDS,KTOP,KBTM, &
2367 ! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
2368 BO3RND,AO3RND, &
2369 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2370 ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
2371 GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
2372 P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
2373 TEN,HP1,FOUR,HM1EZ, &
2374 RADCON,QUARTR,TWO, &
2375 HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
2376 RADCON1,H16E1, H28E1,H44194M2,H1P41819, &
2377 ids,ide, jds,jde, kds,kde, &
2378 ims,ime, jms,jme, kms,kme, &
2379 its,ite, jts,jte, kts,kte )
2380 !---------------------------------------------------------------------
2381 IMPLICIT NONE
2382 !----------------------------------------------------------------------
2383 ! INTEGER, PARAMETER :: NBLY=15
2385 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
2386 ims,ime, jms,jme, kms,kme , &
2387 its,ite, jts,jte, kts,kte
2388 REAL, INTENT(IN) :: ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR
2389 REAL, INTENT(IN) :: GINV,H3M4,BETINW,RATH2OMW,GP0INV
2390 REAL, INTENT(IN) :: P0XZP8,P0XZP2,H3M3,P0,H1M3
2391 REAL, INTENT(IN) :: H1M2,H25E2,B0,B1,B2,B3,HAF
2392 ! REAL, INTENT(IN) :: TEN,HP1,FOUR,HM1EZ,SKO3R
2393 REAL, INTENT(IN) :: TEN,HP1,FOUR,HM1EZ
2394 ! REAL, INTENT(IN) :: AB15WD,SKC1R,RADCON,QUARTR,TWO
2395 REAL, INTENT(IN) :: RADCON,QUARTR,TWO
2396 REAL, INTENT(IN) :: HM6666M2,HMP66667,HMP5, HP166666,H41666M2
2397 ! REAL, INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D
2398 REAL, INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819
2399 !----------------------------------------------------------------------
2400 REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND
2401 ! REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW
2402 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
2403 REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
2404 BCOMB,BETACM
2406 REAL, INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2407 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT
2408 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2409 INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS
2411 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
2412 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: RH2O,QO3
2413 REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte) :: HEATRA
2414 REAL, INTENT(OUT), DIMENSION(its:ite) :: GRNFLX,TOPFLX
2416 ! REAL, DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT
2418 ! Include co2 data from a file, which needs to have exactly vertical
2419 ! dimension of the model.
2422 !!! ??? co2 table
2423 ! REAL, DIMENSION(kts:kte+1,kts:kte+1) :: CO251,CDT51,CDT58,C2D51,&
2424 ! C2D58,CO258
2425 ! REAL, DIMENSION(kts:kte+1) :: STEMP,GTEMP,CO231,CO238, &
2426 ! C2D31,C2D38,CDT31,CDT38, &
2427 ! CO271,CO278,C2D71,C2D78, &
2428 ! CDT71,CDT78
2429 ! REAL, DIMENSION(kts:kte) :: CO2M51,CO2M58,CDTM51,CDTM58, &
2430 ! C2DM51,C2DM58
2431 !!! end co2 table
2433 ! REAL, DIMENSION(kts:kte+1) :: CLDROW
2435 REAL, DIMENSION(its:ite,kts:kte+1) :: TEXPSL,TOTPHI,TOTO3,CNTVAL,&
2436 TPHIO3,TOTVO2,TSTDAV,TDAV, &
2437 VSUM3,CO2R1,D2CD21,DCO2D1, &
2438 CO2R2,D2CD22,DCO2D2,CO2SP1,&
2439 CO2SP2,CO2R,DCO2DT,D2CDT2, &
2440 TLSQU,DIFT
2441 REAL, DIMENSION(its:ite,kts:kte) :: DELP2,DELP,CO2NBL,&
2442 QH2O,VV,VAR1,VAR2,VAR3,VAR4
2443 REAL, DIMENSION(its:ite,kts:kte+1) :: P,T
2444 REAL, DIMENSION(its:ite,kts:kte) :: CO2MR,CO2MD,CO2M2D
2445 REAL, DIMENSION(its:ite,kts:kte*2+1):: EMPL
2447 REAL, DIMENSION(its:ite) :: EMX1,EMX2,VSUM1,VSUM2,A1,A2
2448 REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21
2450 ! COMMON/CO2BD3/CO251(LP1,LP1),CO258(LP1,LP1),CDT51(LP1,LP1),
2451 ! DIMENSION CO21(IDIM1:IDIM2,LP1,LP1),CO2NBL(IDIM1:IDIM2,L)
2452 ! DIMENSION CO2R(IDIM1:IDIM2,LP1),DIFT(IDIM1:IDIM2,LP1)
2453 ! 1 CO2M2D(IDIM1:IDIM2,L)
2454 ! DIMENSION CO2MR(IDIM1:IDIM2,L),CO2MD(IDIM1:IDIM2,L),
2455 ! 2 CO2M58(L),CDTM51(L),CDTM58(L),C2DM51(L),C2DM58(L),
2456 ! 1 CDT58(LP1,LP1),C2D51(LP1,LP1),C2D58(LP1,LP1),CO2M51(L),
2457 ! COMMON / CO2BD2 / CO231(LP1),CO238(LP1),CDT31(LP1),
2458 ! 1 CDT38(LP1),C2D31(LP1),C2D38(LP1)
2459 ! DIMENSION CO2R1(IDIM1:IDIM2,LP1),DCO2D1(IDIM1:IDIM2,LP1)
2460 ! DIMENSION D2CD21(IDIM1:IDIM2,LP1),D2CD22(IDIM1:IDIM2,LP1)
2461 ! 3 STEMP(LP1),GTEMP(LP1),B0,B1,B2,B3
2462 ! 1 VV(IDIM1:IDIM2,L),VSUM3(IDIM1:IDIM2,LP1),VSUM1(IDIM1:IDIM2),
2463 ! 2 VSUM2(IDIM1:IDIM2)
2464 ! DIMENSION TDAV(IDIM1:IDIM2,LP1),TSTDAV(IDIM1:IDIM2,LP1),
2465 ! LLP1=LL+1, LL = 2L
2466 ! EMX2(IDIM1:IDIM2),EMPL(IDIM1:IDIM2,LLP1)
2467 ! DIMENSION TPHIO3(IDIM1:IDIM2,LP1),
2468 ! DIMENSION TEXPSL(IDIM1:IDIM2,LP1)
2469 ! DIMENSION QH2O(IDIM1:IDIM2,L)
2470 ! DIMENSION DELP2(IDIM1:IDIM2,L)
2471 ! DIMENSION VAR1(IDIM1:IDIM2,L),VAR2(IDIM1:IDIM2,L),
2472 ! 1 VAR3(IDIM1:IDIM2,L),VAR4(IDIM1:IDIM2,L)
2473 ! 1 VV(IDIM1:IDIM2,L)
2474 ! DIMENSION CNTVAL(IDIM1:IDIM2,LP1)
2475 ! DIMENSION TOTO3(IDIM1:IDIM2,LP1)
2476 ! DIMENSION EMX1(IDIM1:IDIM2),
2478 ! DIMENSION PRESS(IDIM1:IDIM2,LP1),TEMP(IDIM1:IDIM2,LP1), &
2479 ! RH2O(IDIM1:IDIM2,L),QO3(IDIM1:IDIM2,L)
2480 ! DIMENSION HEATRA(IDIM1:IDIM2,L),GRNFLX(IDIM1:IDIM2), &
2481 ! TOPFLX(IDIM1:IDIM2)
2483 !
2484 !
2485 !****COMPUTE FLUX PRESSURES (P) AND DIFFERENCES (DELP2,DELP)
2486 !****COMPUTE FLUX LEVEL TEMPERATURES (T) AND CONTINUUM TEMPERATURE
2487 ! CORRECTIONS (TEXPSL)
2489 INTEGER :: K, I,KP
2490 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL
2492 L=kte
2493 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
2494 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
2495 MYIS=its; MYIE=ite
2498 DO 103 K=2,L
2499 DO 103 I=MYIS,MYIE
2500 P(I,K)=HAF*(PRESS(I,K-1)+PRESS(I,K))
2501 T(I,K)=HAF*(TEMP(I,K-1)+TEMP(I,K))
2502 103 CONTINUE
2503 DO 105 I=MYIS,MYIE
2504 P(I,1)=ZERO
2505 P(I,LP1)=PRESS(I,LP1)
2506 T(I,1)=TEMP(I,1)
2507 T(I,LP1)=TEMP(I,LP1)
2508 105 CONTINUE
2509 DO 107 K=1,L
2510 DO 107 I=MYIS,MYIE
2511 DELP2(I,K)=P(I,K+1)-P(I,K)
2512 DELP(I,K)=ONE/DELP2(I,K)
2513 107 CONTINUE
2514 !****COMPUTE ARGUMENT FOR CONT.TEMP.COEFF.
2515 ! (THIS IS 1800.(1./TEMP-1./296.))
2516 DO 125 K=1,LP1
2517 DO 125 I=MYIS,MYIE
2518 TEXPSL(I,K)=H18E3/TEMP(I,K)-H6P08108
2519 !...THEN TAKE EXPONENTIAL
2520 TEXPSL(I,K)=EXP(TEXPSL(I,K))
2521 125 CONTINUE
2522 !***COMPUTE OPTICAL PATHS FOR H2O AND O3, USING THE DIFFUSIVITY
2523 ! APPROXIMATION FOR THE ANGULAR INTEGRATION (1.66). OBTAIN THE
2524 ! UNWEIGHTED VALUES(VAR1,VAR3) AND THE WEIGHTED VALUES(VAR2,VAR4).
2525 ! THE QUANTITIES H3M4(.0003) AND H3M3(.003) APPEARING IN THE VAR2 AND
2526 ! VAR4 EXPRESSIONS ARE THE APPROXIMATE VOIGT CORRECTIONS FOR H2O AND
2527 ! O3,RESPECTIVELY.
2528 !
2529 DO 131 K=1,L
2530 DO 131 I=MYIS,MYIE
2531 QH2O(I,K)=RH2O(I,K)*DIFFCTR
2532 !---VV IS THE LAYER-MEAN PRESSURE (IN ATM),WHICH IS NOT THE SAME AS
2533 ! THE LEVEL PRESSURE (PRESS)
2534 VV(I,K)=HAF*(P(I,K+1)+P(I,K))*P0INV
2535 VAR1(I,K)=DELP2(I,K)*QH2O(I,K)*GINV
2536 VAR3(I,K)=DELP2(I,K)*QO3(I,K)*DIFFCTR*GINV
2537 VAR2(I,K)=VAR1(I,K)*(VV(I,K)+H3M4)
2538 VAR4(I,K)=VAR3(I,K)*(VV(I,K)+H3M3)
2539 ! COMPUTE OPTICAL PATH FOR THE H2O CONTINUUM, USING ROBERTS COEFFS.
2540 ! (BETINW),AND TEMP. CORRECTION (TEXPSL). THE DIFFUSIVITY FACTOR
2541 ! (WHICH CANCELS OUT IN THIS EXPRESSION) IS ASSUMED TO BE 1.66. THE
2542 ! USE OF THE DIFFUSIVITY FACTOR HAS BEEN SHOWN TO BE A SIGNIFICANT
2543 ! SOURCE OF ERROR IN THE CONTINUUM CALCS.,BUT THE TIME PENALTY OF
2544 ! AN ANGULAR INTEGRATION IS SEVERE.
2545 !
2546 CNTVAL(I,K)=TEXPSL(I,K)*RH2O(I,K)*VAR2(I,K)*BETINW/ &
2547 (RH2O(I,K)+RATH2OMW)
2548 131 CONTINUE
2549 ! COMPUTE SUMMED OPTICAL PATHS FOR H2O,O3 AND CONTINUUM
2550 DO 201 I=MYIS,MYIE
2551 TOTPHI(I,1)=ZERO
2552 TOTO3(I,1)=ZERO
2553 TPHIO3(I,1)=ZERO
2554 TOTVO2(I,1)=ZERO
2555 201 CONTINUE
2556 DO 203 K=2,LP1
2557 DO 203 I=MYIS,MYIE
2558 TOTPHI(I,K)=TOTPHI(I,K-1)+VAR2(I,K-1)
2559 TOTO3(I,K)=TOTO3(I,K-1)+VAR3(I,K-1)
2560 TPHIO3(I,K)=TPHIO3(I,K-1)+VAR4(I,K-1)
2561 TOTVO2(I,K)=TOTVO2(I,K-1)+CNTVAL(I,K-1)
2562 203 CONTINUE
2563 !---EMX1 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO
2564 ! P(L). IT IS USED IN NEARBY LAYER AND EMISS CALCULATIONS.
2565 !---EMX2 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO
2566 ! P(LP1). IT IS USED IN CALCULATIONS BETWEEN FLUX LEVELS L AND LP1.
2567 !
2568 DO 801 I=MYIS,MYIE
2569 EMX1(I)=QH2O(I,L)*PRESS(I,L)*(PRESS(I,L)-P(I,L))*GP0INV
2570 EMX2(I)=QH2O(I,L)*PRESS(I,L)*(P(I,LP1)-PRESS(I,L))*GP0INV
2571 801 CONTINUE
2572 !---EMPL IS THE PRESSURE SCALED MASS FROM P(K) TO PRESS(K) (INDEX 2-LP1)
2573 ! OR TO PRESS(K+1) (INDEX LP2-LL)
2574 DO 811 K=1,L
2575 DO 811 I=MYIS,MYIE
2576 EMPL(I,K+1)=QH2O(I,K)*P(I,K+1)*(P(I,K+1)-PRESS(I,K))*GP0INV
2577 811 CONTINUE
2578 DO 812 K=1,LM1
2579 DO 812 I=MYIS,MYIE
2580 EMPL(I,LP2+K-1)=QH2O(I,K+1)*P(I,K+1)*(PRESS(I,K+1)-P(I,K+1)) &
2581 *GP0INV
2582 812 CONTINUE
2583 DO 821 I=MYIS,MYIE
2584 EMPL(I,1)=VAR2(I,L)
2585 EMPL(I,LLP1)=EMPL(I,LL)
2586 821 CONTINUE
2587 !***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS
2588 ! FOR USE IN OBTAINING TEMP. DIFFERENCE BET. SOUNDING AND STD.
2589 ! TEMP. SOUNDING (DIFT)
2590 DO 161 I=MYIS,MYIE
2591 TSTDAV(I,1)=ZERO
2592 TDAV(I,1)=ZERO
2593 161 CONTINUE
2594 DO 162 K=1,LP1
2595 DO 162 I=MYIS,MYIE
2596 VSUM3(I,K)=TEMP(I,K)-STEMP(K)
2597 162 CONTINUE
2598 DO 163 K=1,L
2599 DO 165 I=MYIS,MYIE
2600 VSUM2(I)=GTEMP(K)*DELP2(I,K)
2601 VSUM1(I)=VSUM2(I)*VSUM3(I,K)
2602 TSTDAV(I,K+1)=TSTDAV(I,K)+VSUM2(I)
2603 TDAV(I,K+1)=TDAV(I,K)+VSUM1(I)
2604 165 CONTINUE
2605 163 CONTINUE
2606 !
2607 !****EVALUATE COEFFICIENTS FOR CO2 PRESSURE INTERPOLATION (A1,A2)
2608 DO 171 I=MYIS,MYIE
2609 A1(I)=(PRESS(I,LP1)-P0XZP8)/P0XZP2
2610 A2(I)=(P0-PRESS(I,LP1))/P0XZP2
2611 171 CONTINUE
2612 !***PERFORM CO2 PRESSURE INTERPOLATION ON ALL INPUTTED TRANSMISSION
2613 ! FUNCTIONS AND TEMP. DERIVATIVES
2614 !---SUCCESSIVELY COMPUTING CO2R,DCO2DT AND D2CDT2 IS DONE TO SAVE
2615 ! STORAGE (AT A SLIGHT LOSS IN COMPUTATION TIME)
2616 DO 184 K=1,LP1
2617 DO 184 I=MYIS,MYIE
2618 CO2R1(I,K)=A1(I)*CO231(K)+A2(I)*CO238(K)
2619 D2CD21(I,K)=H1M3*(A1(I)*C2D31(K)+A2(I)*C2D38(K))
2620 DCO2D1(I,K)=H1M2*(A1(I)*CDT31(K)+A2(I)*CDT38(K))
2621 CO2R2(I,K)=A1(I)*CO271(K)+A2(I)*CO278(K)
2622 D2CD22(I,K)=H1M3*(A1(I)*C2D71(K)+A2(I)*C2D78(K))
2623 DCO2D2(I,K)=H1M2*(A1(I)*CDT71(K)+A2(I)*CDT78(K))
2624 184 CONTINUE
2625 DO 190 K=1,L
2626 DO 190 I=MYIS,MYIE
2627 CO2MR(I,K)=A1(I)*CO2M51(K)+A2(I)*CO2M58(K)
2628 CO2MD(I,K)=H1M2*(A1(I)*CDTM51(K)+A2(I)*CDTM58(K))
2629 CO2M2D(I,K)=H1M3*(A1(I)*C2DM51(K)+A2(I)*C2DM58(K))
2630 190 CONTINUE
2631 !***COMPUTE CO2 TEMPERATURE INTERPOLATIONS FOR ALL BANDS,USING DIFT
2632 !
2633 ! THE CASE WHERE K=1 IS HANDLED FIRST. WE ARE NOW REPLACING
2634 ! 3-DIMENSIONAL ARRAYS BY 2-D ARRAYS, TO SAVE SPACE. THUS THIS
2635 ! CALCULATION IS FOR (I,KP,1)
2636 DO 211 KP=2,LP1
2637 DO 211 I=MYIS,MYIE
2638 DIFT(I,KP)=TDAV(I,KP)/TSTDAV(I,KP)
2639 211 CONTINUE
2640 DO 212 I=MYIS,MYIE
2641 CO21(I,1,1)=1.0
2642 CO2SP1(I,1)=1.0
2643 CO2SP2(I,1)=1.0
2644 212 CONTINUE
2645 DO 215 KP=2,LP1
2646 DO 215 I=MYIS,MYIE
2647 !---CALCULATIONS FOR KP>1 FOR K=1
2648 CO2R(I,KP)=A1(I)*CO251(KP,1)+A2(I)*CO258(KP,1)
2649 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,1)+A2(I)*CDT58(KP,1))
2650 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,1)+A2(I)*C2D58(KP,1))
2651 CO21(I,KP,1)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2652 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2653 !---CALCULATIONS FOR (EFFECTIVELY) KP=1,K>KP. THESE USE THE
2654 ! SAME VALUE OF DIFT DUE TO SYMMETRY
2655 CO2R(I,KP)=A1(I)*CO251(1,KP)+A2(I)*CO258(1,KP)
2656 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(1,KP)+A2(I)*CDT58(1,KP))
2657 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(1,KP)+A2(I)*C2D58(1,KP))
2658 CO21(I,1,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2659 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2660 215 CONTINUE
2661 ! THE TRANSMISSION FUNCTIONS USED IN SPA88 MAY BE COMPUTED NOW.
2662 !---(IN THE 250 LOOP,DIFT REALLY SHOULD BE (I,1,K), BUT DIFT IS
2663 ! INVARIANT WITH RESPECT TO K,KP,AND SO (I,1,K)=(I,K,1))
2664 DO 250 K=2,LP1
2665 DO 250 I=MYIS,MYIE
2666 CO2SP1(I,K)=CO2R1(I,K)+DIFT(I,K)*(DCO2D1(I,K)+HAF*DIFT(I,K)* &
2667 D2CD21(I,K))
2668 CO2SP2(I,K)=CO2R2(I,K)+DIFT(I,K)*(DCO2D2(I,K)+HAF*DIFT(I,K)* &
2669 D2CD22(I,K))
2670 250 CONTINUE
2671 !
2672 ! NEXT THE CASE WHEN K=2...L
2673 DO 220 K=2,L
2674 DO 222 KP=K+1,LP1
2675 DO 222 I=MYIS,MYIE
2676 DIFT(I,KP)=(TDAV(I,KP)-TDAV(I,K))/ &
2677 (TSTDAV(I,KP)-TSTDAV(I,K))
2678 CO2R(I,KP)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K)
2679 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,K)+A2(I)*CDT58(KP,K))
2680 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,K)+A2(I)*C2D58(KP,K))
2681 CO21(I,KP,K)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2682 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2683 CO2R(I,KP)=A1(I)*CO251(K,KP)+A2(I)*CO258(K,KP)
2684 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(K,KP)+A2(I)*CDT58(K,KP))
2685 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(K,KP)+A2(I)*C2D58(K,KP))
2686 CO21(I,K,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2687 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2688 222 CONTINUE
2689 220 CONTINUE
2690 ! FINALLY THE CASE WHEN K=KP,K=2..LP1
2691 DO 206 K=2,LP1
2692 DO 206 I=MYIS,MYIE
2693 DIFT(I,K)=HAF*(VSUM3(I,K)+VSUM3(I,K-1))
2694 CO2R(I,K)=A1(I)*CO251(K,K)+A2(I)*CO258(K,K)
2695 DCO2DT(I,K)=H1M2*(A1(I)*CDT51(K,K)+A2(I)*CDT58(K,K))
2696 D2CDT2(I,K)=H1M3*(A1(I)*C2D51(K,K)+A2(I)*C2D58(K,K))
2697 CO21(I,K,K)=CO2R(I,K)+DIFT(I,K)*(DCO2DT(I,K)+ &
2698 HAF*DIFT(I,K)*D2CDT2(I,K))
2699 206 CONTINUE
2700 !--- WE AREN'T DOING NBL TFS ON THE 100 CM-1 BANDS .
2701 DO 260 K=1,L
2702 DO 260 I=MYIS,MYIE
2703 CO2NBL(I,K)=CO2MR(I,K)+VSUM3(I,K)*(CO2MD(I,K)+HAF* &
2704 VSUM3(I,K)*CO2M2D(I,K))
2705 260 CONTINUE
2706 !***COMPUTE TEMP. COEFFICIENT BASED ON T(K) (SEE REF.2)
2707 DO 264 K=1,LP1
2708 DO 264 I=MYIS,MYIE
2709 IF (T(I,K).LE.H25E2) THEN
2710 TLSQU(I,K)=B0+(T(I,K)-H25E2)* &
2711 (B1+(T(I,K)-H25E2)* &
2712 (B2+B3*(T(I,K)-H25E2)))
2713 ELSE
2714 TLSQU(I,K)=B0
2715 ENDIF
2716 264 CONTINUE
2717 !***APPLY TO ALL CO2 TFS
2718 DO 280 K=1,LP1
2719 DO 282 KP=1,LP1
2720 DO 282 I=MYIS,MYIE
2721 CO21(I,KP,K)=CO21(I,KP,K)*(ONE-TLSQU(I,KP))+TLSQU(I,KP)
2722 282 CONTINUE
2723 280 CONTINUE
2724 DO 284 K=1,LP1
2725 DO 286 I=MYIS,MYIE
2726 CO2SP1(I,K)=CO2SP1(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1)
2727 CO2SP2(I,K)=CO2SP2(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1)
2728 286 CONTINUE
2729 284 CONTINUE
2730 DO 288 K=1,L
2731 DO 290 I=MYIS,MYIE
2732 CO2NBL(I,K)=CO2NBL(I,K)*(ONE-TLSQU(I,K))+TLSQU(I,K)
2733 290 CONTINUE
2734 288 CONTINUE
2735 ! CALL FST88(HEATRA,GRNFLX,TOPFLX, &
2736 ! QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2737 ! CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2738 ! CO21,CO2NBL,CO2SP1,CO2SP2, &
2739 ! VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2740 ! TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2741 ! EMX1,EMX2,EMPL, &
2742 !
2743 ! BO3RND,AO3RND, &
2744 !! T1,T2,T4 , EM1V,EM1VW, EM3V, &
2745 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2746 ! TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, &
2747 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
2748 ! HM6666M2,HMP66667,HMP5, &
2749 ! HP166666,H41666M2,RADCON1, &
2750 ! H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2751 ! SKO2D, &
2752 ! ids,ide, jds,jde, kds,kde, &
2753 ! ims,ime, jms,jme, kms,kme, &
2754 ! its,ite, jts,jte, kts,kte )
2756 CALL FST88(HEATRA,GRNFLX,TOPFLX, &
2757 QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2758 CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2759 CO21,CO2NBL,CO2SP1,CO2SP2, &
2760 VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2761 TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2762 EMX1,EMX2,EMPL, &
2763 !
2764 BO3RND,AO3RND, &
2765 ! T1,T2,T4 , EM1V,EM1VW, EM3V, &
2766 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2767 TEN,HP1,HAF,ONE,FOUR,HM1EZ, &
2768 RADCON,QUARTR,TWO, &
2769 HM6666M2,HMP66667,HMP5, &
2770 HP166666,H41666M2,RADCON1, &
2771 H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2772 ids,ide, jds,jde, kds,kde, &
2773 ims,ime, jms,jme, kms,kme, &
2774 its,ite, jts,jte, kts,kte )
2776 END SUBROUTINE LWR88
2777 !---------------------------------------------------------------------
2778 ! SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, &
2779 ! QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2780 ! CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2781 ! CO21,CO2NBL,CO2SP1,CO2SP2, &
2782 ! VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2783 ! TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2784 ! EMX1,EMX2,EMPL, &
2785 ! BO3RND,AO3RND, &
2786 !! T1,T2,T4 , EM1V,EM1VW, EM3V, &
2787 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2788 ! TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, &
2789 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
2790 ! HM6666M2,HMP66667,HMP5, &
2791 ! HP166666,H41666M2,RADCON1, &
2792 ! H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2793 ! SKO2D, &
2794 ! ids,ide, jds,jde, kds,kde, &
2795 ! ims,ime, jms,jme, kms,kme, &
2796 ! its,ite, jts,jte, kts,kte )
2798 SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, &
2799 QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2800 CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2801 CO21,CO2NBL,CO2SP1,CO2SP2, &
2802 VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2803 TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2804 EMX1,EMX2,EMPL, &
2805 BO3RND,AO3RND, &
2806 ! T1,T2,T4 , EM1V,EM1VW, EM3V, &
2807 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2808 TEN,HP1,HAF,ONE,FOUR,HM1EZ, &
2809 RADCON,QUARTR,TWO, &
2810 HM6666M2,HMP66667,HMP5, &
2811 HP166666,H41666M2,RADCON1, &
2812 H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2813 ids,ide, jds,jde, kds,kde, &
2814 ims,ime, jms,jme, kms,kme, &
2815 its,ite, jts,jte, kts,kte )
2816 !---------------------------------------------------------------------
2817 IMPLICIT NONE
2818 !----------------------------------------------------------------------
2819 ! INTEGER, PARAMETER :: NBLY=15
2821 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
2822 ims,ime, jms,jme, kms,kme , &
2823 its,ite, jts,jte, kts,kte
2825 ! REAL, INTENT(IN) :: TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R
2826 REAL, INTENT(IN) :: TEN,HP1,HAF,ONE,FOUR,HM1EZ
2827 ! REAL, INTENT(IN) :: AB15WD,SKC1R,RADCON,QUARTR,TWO
2828 REAL, INTENT(IN) :: RADCON,QUARTR,TWO
2829 REAL, INTENT(IN) :: HM6666M2,HMP66667,HMP5
2830 REAL, INTENT(IN) :: HP166666,H41666M2,RADCON1,H16E1, H28E1
2831 ! REAL, INTENT(IN) :: H25E2,H44194M2,H1P41819,SKO2D
2832 REAL, INTENT(IN) :: H25E2,H44194M2,H1P41819
2834 REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
2835 BCOMB,BETACM
2837 ! REAL, INTENT(IN), DIMENSION(5040) :: T1,T2,T4,EM1V,EM1VW
2838 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
2839 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: EMPL
2840 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TOTO3,TPHIO3,TOTPHI,CNTVAL,&
2841 CO2SP1,CO2SP2
2843 REAL, INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2844 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT,TOTVO2
2845 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2846 INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS
2847 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: QH2O
2848 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
2849 REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte) :: HEATRA
2850 REAL, INTENT(OUT), DIMENSION(its:ite) :: GRNFLX,TOPFLX
2851 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: P,T
2852 REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21
2853 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: CO2NBL,DELP2, &
2854 DELP,&
2855 VAR1,VAR2,VAR3,VAR4
2856 REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND
2857 REAL, INTENT(IN), DIMENSION(its:ite) :: EMX1,EMX2
2859 REAL, DIMENSION(its:ite,kts:kte*2+1) :: TPL,EMD,ALP,C,CSUB,CSUB2
2860 REAL, DIMENSION(its:ite,kts:kte*2+1) :: C2
2861 INTEGER, DIMENSION(its:ite,kts:kte+1) :: IXO
2862 REAL, DIMENSION(its:ite,kts:kte+1) :: VTMP3,FXO,DT,FXOE2,DTE2, &
2863 SS1,CSOUR,TC,OSS,CSS,DTC,SS2,&
2864 AVEPHI,E1CTS1,E1FLX, &
2865 E1CTW1,DSORC,EMISS,FAC1,&
2866 TO3SP,OVER1D,CNTTAU,TOTEVV,&
2867 CO2SP,FLX,AVMO3, &
2868 AVPHO3,AVVO2,CONT1D,TO31D,EMISDG,&
2869 DELPR1
2870 REAL, DIMENSION(its:ite,kts:kte+1) :: EMISSB,DELPR2,CONTDG,TO3DG,HEATEM,&
2871 VSUM1,FLXNET,Z1
2873 REAL, DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC
2874 REAL, DIMENSION(its:ite,kts:kte) :: E1CTS2,E1CTW2,TO3SPC,RLOG,EXCTS,&
2875 CTSO3,CTS
2876 REAL, DIMENSION(its:ite) :: GXCTS,FLX1E1
2877 REAL, DIMENSION(its:ite) :: PTOP,PBOT,FTOP,FBOT,DELPTC
2878 REAL, DIMENSION(its:ite,2) :: FXOSP,DTSP,EMSPEC
2879 ! REAL, DIMENSION(28,NBLY) :: SOURCE,DSRCE
2880 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
2881 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
2883 L=kte
2884 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
2885 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
2886 LLM2 = LL-2; LLM1=LL-1
2887 MYIS=its; MYIE=ite
2889 !
2890 DO 101 K=1,LP1
2891 DO 101 I=MYIS,MYIE
2892 !---TEMP. INDICES FOR E1,SOURCE
2893 VTMP3(I,K)=AINT(TEMP(I,K)*HP1)
2894 FXO(I,K)=VTMP3(I,K)-9.
2895 DT(I,K)=TEMP(I,K)-TEN*VTMP3(I,K)
2896 !---INTEGER INDEX FOR SOURCE (USED IMMEDIATELY)
2897 IXO(I,K)=FXO(I,K)
2898 101 CONTINUE
2899 DO 103 k=1,L
2900 DO 103 I=MYIS,MYIE
2901 !---TEMP. INDICES FOR E2 (KP=1 LAYER NOT USED IN FLUX CALCULATIONS)
2902 VTMP3(I,K)=AINT(T(I,K+1)*HP1)
2903 FXOE2(I,K)=VTMP3(I,K)-9.
2904 DTE2(I,K)=T(I,K+1)-TEN*VTMP3(I,K)
2905 103 CONTINUE
2906 !---SPECIAL CASE TO HANDLE KP=LP1 LAYER AND SPECIAL E2 CALCS.
2907 DO 105 I=MYIS,MYIE
2908 FXOE2(I,LP1)=FXO(I,L)
2909 DTE2(I,LP1)=DT(I,L)
2910 FXOSP(I,1)=FXOE2(I,LM1)
2911 FXOSP(I,2)=FXO(I,LM1)
2912 DTSP(I,1)=DTE2(I,LM1)
2913 DTSP(I,2)=DT(I,LM1)
2914 105 CONTINUE
2915 !
2916 !---SOURCE FUNCTION FOR COMBINED BAND 1
2917 DO 4114 I=MYIS,MYIE
2918 DO 4114 K=1,LP1
2919 VTMP3(I,K)=SOURCE(IXO(I,K),1)
2920 DSORC(I,K)=DSRCE(IXO(I,K),1)
2921 4114 CONTINUE
2922 DO 4112 K=1,LP1
2923 DO 4112 I=MYIS,MYIE
2924 SORC(I,K,1)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2925 4112 CONTINUE
2926 !---SOURCE FUNCTION FOR COMBINED BAND 2
2927 DO 4214 I=MYIS,MYIE
2928 DO 4214 K=1,LP1
2929 VTMP3(I,K)=SOURCE(IXO(I,K),2)
2930 DSORC(I,K)=DSRCE(IXO(I,K),2)
2931 4214 CONTINUE
2932 DO 4212 K=1,LP1
2933 DO 4212 I=MYIS,MYIE
2934 SORC(I,K,2)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2935 4212 CONTINUE
2936 !---SOURCE FUNCTION FOR COMBINED BAND 3
2937 DO 4314 I=MYIS,MYIE
2938 DO 4314 K=1,LP1
2939 VTMP3(I,K)=SOURCE(IXO(I,K),3)
2940 DSORC(I,K)=DSRCE(IXO(I,K),3)
2941 4314 CONTINUE
2942 DO 4312 K=1,LP1
2943 DO 4312 I=MYIS,MYIE
2944 SORC(I,K,3)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2945 4312 CONTINUE
2946 !---SOURCE FUNCTION FOR COMBINED BAND 4
2947 DO 4414 I=MYIS,MYIE
2948 DO 4414 K=1,LP1
2949 VTMP3(I,K)=SOURCE(IXO(I,K),4)
2950 DSORC(I,K)=DSRCE(IXO(I,K),4)
2951 4414 CONTINUE
2952 DO 4412 K=1,LP1
2953 DO 4412 I=MYIS,MYIE
2954 SORC(I,K,4)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2955 4412 CONTINUE
2956 !---SOURCE FUNCTION FOR COMBINED BAND 5
2957 DO 4514 I=MYIS,MYIE
2958 DO 4514 K=1,LP1
2959 VTMP3(I,K)=SOURCE(IXO(I,K),5)
2960 DSORC(I,K)=DSRCE(IXO(I,K),5)
2961 4514 CONTINUE
2962 DO 4512 K=1,LP1
2963 DO 4512 I=MYIS,MYIE
2964 SORC(I,K,5)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2965 4512 CONTINUE
2966 !---SOURCE FUNCTION FOR COMBINED BAND 6
2967 DO 4614 I=MYIS,MYIE
2968 DO 4614 K=1,LP1
2969 VTMP3(I,K)=SOURCE(IXO(I,K),6)
2970 DSORC(I,K)=DSRCE(IXO(I,K),6)
2971 4614 CONTINUE
2972 DO 4612 K=1,LP1
2973 DO 4612 I=MYIS,MYIE
2974 SORC(I,K,6)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2975 4612 CONTINUE
2976 !---SOURCE FUNCTION FOR COMBINED BAND 7
2977 DO 4714 I=MYIS,MYIE
2978 DO 4714 K=1,LP1
2979 VTMP3(I,K)=SOURCE(IXO(I,K),7)
2980 DSORC(I,K)=DSRCE(IXO(I,K),7)
2981 4714 CONTINUE
2982 DO 4712 K=1,LP1
2983 DO 4712 I=MYIS,MYIE
2984 SORC(I,K,7)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2985 4712 CONTINUE
2986 !---SOURCE FUNCTION FOR COMBINED BAND 8
2987 DO 4814 I=MYIS,MYIE
2988 DO 4814 K=1,LP1
2989 VTMP3(I,K)=SOURCE(IXO(I,K),8)
2990 DSORC(I,K)=DSRCE(IXO(I,K),8)
2991 4814 CONTINUE
2992 DO 4812 K=1,LP1
2993 DO 4812 I=MYIS,MYIE
2994 SORC(I,K,8)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2995 4812 CONTINUE
2996 !---SOURCE FUNCTION FOR BAND 9 (560-670 CM-1)
2997 DO 4914 I=MYIS,MYIE
2998 DO 4914 K=1,LP1
2999 VTMP3(I,K)=SOURCE(IXO(I,K),9)
3000 DSORC(I,K)=DSRCE(IXO(I,K),9)
3001 4914 CONTINUE
3002 DO 4912 K=1,LP1
3003 DO 4912 I=MYIS,MYIE
3004 SORC(I,K,9)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3005 4912 CONTINUE
3006 !---SOURCE FUNCTION FOR BAND 10 (670-800 CM-1)
3007 DO 5014 I=MYIS,MYIE
3008 DO 5014 K=1,LP1
3009 VTMP3(I,K)=SOURCE(IXO(I,K),10)
3010 DSORC(I,K)=DSRCE(IXO(I,K),10)
3011 5014 CONTINUE
3012 DO 5012 K=1,LP1
3013 DO 5012 I=MYIS,MYIE
3014 SORC(I,K,10)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3015 5012 CONTINUE
3016 !---SOURCE FUNCTION FOR BAND 11 (800-900 CM-1)
3017 DO 5114 I=MYIS,MYIE
3018 DO 5114 K=1,LP1
3019 VTMP3(I,K)=SOURCE(IXO(I,K),11)
3020 DSORC(I,K)=DSRCE(IXO(I,K),11)
3021 5114 CONTINUE
3022 DO 5112 K=1,LP1
3023 DO 5112 I=MYIS,MYIE
3024 SORC(I,K,11)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3025 5112 CONTINUE
3026 !---SOURCE FUNCTION FOR BAND 12 (900-990 CM-1)
3027 DO 5214 I=MYIS,MYIE
3028 DO 5214 K=1,LP1
3029 VTMP3(I,K)=SOURCE(IXO(I,K),12)
3030 DSORC(I,K)=DSRCE(IXO(I,K),12)
3031 5214 CONTINUE
3032 DO 5212 K=1,LP1
3033 DO 5212 I=MYIS,MYIE
3034 SORC(I,K,12)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3035 5212 CONTINUE
3036 !---SOURCE FUNCTION FOR BAND 13 (990-1070 CM-1)
3037 DO 5314 I=MYIS,MYIE
3038 DO 5314 K=1,LP1
3039 VTMP3(I,K)=SOURCE(IXO(I,K),13)
3040 DSORC(I,K)=DSRCE(IXO(I,K),13)
3041 5314 CONTINUE
3042 DO 5312 K=1,LP1
3043 DO 5312 I=MYIS,MYIE
3044 SORC(I,K,13)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3045 5312 CONTINUE
3046 !---SOURCE FUNCTION FOR BAND 14 (1070-1200 CM-1)
3047 DO 5414 I=MYIS,MYIE
3048 DO 5414 K=1,LP1
3049 VTMP3(I,K)=SOURCE(IXO(I,K),14)
3050 DSORC(I,K)=DSRCE(IXO(I,K),14)
3051 5414 CONTINUE
3052 DO 5412 K=1,LP1
3053 DO 5412 I=MYIS,MYIE
3054 SORC(I,K,14)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3055 5412 CONTINUE
3056 !
3057 ! THE FOLLOWING SUBROUTINE OBTAINS NLTE SOURCE FUNCTION FOR CO2
3058 !
3059 !
3060 ! CALL NLTE
3061 !
3062 !
3063 !---OBTAIN SPECIAL SOURCE FUNCTIONS FOR THE 15 UM BAND (CSOUR)
3064 ! AND THE WINDOW REGION (SS1)
3065 DO 131 K=1,LP1
3066 DO 131 I=MYIS,MYIE
3067 SS1(I,K)=SORC(I,K,11)+SORC(I,K,12)+SORC(I,K,14)
3068 131 CONTINUE
3069 DO 143 K=1,LP1
3070 DO 143 I=MYIS,MYIE
3071 CSOUR(I,K)=SORC(I,K,9)+SORC(I,K,10)
3072 143 CONTINUE
3073 !
3074 !---COMPUTE TEMP**4 (TC) AND VERTICAL TEMPERATURE DIFFERENCES
3075 ! (OSS,CSS,SS2,DTC). ALL THESE WILL BE USED LATER IN FLUX COMPUTA-
3076 ! TIONS.
3077 !
3078 DO 901 K=1,LP1
3079 DO 901 I=MYIS,MYIE
3080 TC(I,K)=(TEMP(I,K)*TEMP(I,K))**2
3081 901 CONTINUE
3082 DO 903 K=1,L
3083 DO 903 I=MYIS,MYIE
3084 OSS(I,K+1)=SORC(I,K+1,13)-SORC(I,K,13)
3085 CSS(I,K+1)=CSOUR(I,K+1)-CSOUR(I,K)
3086 DTC(I,K+1)=TC(I,K+1)-TC(I,K)
3087 SS2(I,K+1)=SS1(I,K+1)-SS1(I,K)
3088 903 CONTINUE
3089 !
3090 !
3091 !---THE FOLLOWIMG IS A DRASTIC REWRITE OF THE RADIATION CODE TO
3092 ! (LARGELY) ELIMINATE THREE-DIMENSIONAL ARRAYS. THE CODE WORKS
3093 ! ON THE FOLLOWING PRINCIPLES:
3094 !
3095 ! LET K = FIXED FLUX LEVEL, KP = VARYING FLUX LEVEL
3096 ! THEN FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K))
3097 ! OVER ALL KP'S, FROM 1 TO LP1.
3098 !
3099 ! WE CAN BREAK DOWN THE CALCULATIONS FOR ALL K'S AS FOLLOWS:
3100 !
3101 ! FOR ALL K'S K=1 TO LP1:
3102 ! FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K)) (1)
3103 ! OVER ALL KP'S, FROM K+1 TO LP1
3104 ! AND
3105 ! FOR KP FROM K+1 TO LP1:
3106 ! FLUX(KP) = DELTAB(K)*TAU(K,KP) (2)
3107 !
3108 ! NOW IF TAU(K,KP)=TAU(KP,K) (SYMMETRICAL ARRAYS)
3109 ! WE CAN COMPUTE A 1-DIMENSIONAL ARRAY TAU1D(KP) FROM
3110 ! K+1 TO LP1, EACH TIME K IS INCREMENTED.
3111 ! EQUATIONS (1) AND (2) THEN BECOME:
3112 !
3113 ! TAU1D(KP) = (VALUES FOR TAU(KP,K) AT THE PARTICULAR K)
3114 ! FLUX(K) = SUM OVER KP : (DELTAB(KP)*TAU1D(KP)) (3)
3115 ! FLUX(KP) = DELTAB(K)*TAU1D(KP) (4)
3116 !
3117 ! THE TERMS FOR TAU (K,K) AND OTHER SPECIAL TERMS (FOR
3118 ! NEARBY LAYERS) MUST, OF COURSE, BE HANDLED SEPARATELY, AND
3119 ! WITH CARE.
3120 !
3121 ! COMPUTE "UPPER TRIANGLE" TRANSMISSION FUNCTIONS FOR
3122 ! THE 9.6 UM BAND (TO3SP) AND THE 15 UM BAND (OVER1D). ALSO,
3123 ! THE
3124 ! STAGE 1...COMPUTE O3 ,OVER TRANSMISSION FCTNS AND AVEPHI
3125 !---DO K=1 CALCULATION (FROM FLUX LAYER KK TO THE TOP) SEPARATELY
3126 ! AS VECTORIZATION IS IMPROVED,AND OZONE CTS TRANSMISSIVITY
3127 ! MAY BE EXTRACTED HERE.
3128 DO 3021 K=1,L
3129 DO 3021 I=MYIS,MYIE
3130 AVEPHI(I,K)=TOTPHI(I,K+1)
3131 3021 CONTINUE
3132 !---IN ORDER TO PROPERLY EVALUATE EMISS INTEGRATED OVER THE (LP1)
3133 ! LAYER, A SPECIAL EVALUATION OF EMISS IS DONE. THIS REQUIRES
3134 ! A SPECIAL COMPUTATION OF AVEPHI, AND IT IS STORED IN THE
3135 ! (OTHERWISE VACANT) LP1'TH POSITION
3136 !
3137 DO 803 I=MYIS,MYIE
3138 AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I)
3139 803 CONTINUE
3140 ! COMPUTE FLUXES FOR K=1
3141 CALL E1E290(E1CTS1,E1CTS2,E1FLX,E1CTW1,E1CTW2,EMISS, &
3142 FXO,DT,FXOE2,DTE2,AVEPHI,TEMP,T, &
3143 ! T1,T2,T4 ,EM1V,EM1VW, &
3144 H16E1,TEN,HP1,H28E1,HAF, &
3145 ids,ide, jds,jde, kds,kde, &
3146 ims,ime, jms,jme, kms,kme, &
3147 its,ite, jts,jte, kts,kte )
3149 DO 302 K=1,L
3150 DO 302 I=MYIS,MYIE
3151 FAC1(I,K)=BO3RND(2)*TPHIO3(I,K+1)/TOTO3(I,K+1)
3152 TO3SPC(I,K)=HAF*(FAC1(I,K)* &
3153 (SQRT(ONE+(FOUR*AO3RND(2)*TOTO3(I,K+1))/FAC1(I,K))-ONE))
3154 ! FOR K=1, TO3SP IS USED INSTEAD OF TO31D (THEY ARE EQUAL IN THIS
3155 ! CASE); TO3SP IS PASSED TO SPA90, WHILE TO31D IS A WORK-ARRAY.
3156 TO3SP(I,K)=EXP(HM1EZ*(TO3SPC(I,K)+SKO3R*TOTVO2(I,K+1)))
3157 OVER1D(I,K)=EXP(HM1EZ*(SQRT(AB15WD*TOTPHI(I,K+1))+ &
3158 SKC1R*TOTVO2(I,K+1)))
3159 !---BECAUSE ALL CONTINUUM TRANSMISSIVITIES ARE OBTAINED FROM THE
3160 ! 2-D QUANTITY CNTTAU (AND ITS RECIPROCAL TOTEVV) WE STORE BOTH
3161 ! OF THESE HERE. FOR K=1, CONT1D EQUALS CNTTAU
3162 CNTTAU(I,K)=EXP(HM1EZ*TOTVO2(I,K+1))
3163 TOTEVV(I,K)=1./CNTTAU(I,K)
3164 302 CONTINUE
3165 DO 3022 K=1,L
3166 DO 3022 I=MYIS,MYIE
3167 CO2SP(I,K+1)=OVER1D(I,K)*CO21(I,1,K+1)
3168 3022 CONTINUE
3169 DO 3023 K=1,L
3170 DO 3023 I=MYIS,MYIE
3171 CO21(I,K+1,1)=CO21(I,K+1,1)*OVER1D(I,K)
3172 3023 CONTINUE
3173 !---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION
3174 DO 1808 I=MYIS,MYIE
3175 RLOG(I,1)=OVER1D(I,1)*CO2NBL(I,1)
3176 1808 CONTINUE
3177 !---THE TERMS WHEN KP=1 FOR ALL K ARE THE PHOTON EXCHANGE WITH
3178 ! THE TOP OF THE ATMOSPHERE, AND ARE OBTAINED DIFFERENTLY THAN
3179 ! THE OTHER CALCULATIONS
3180 DO 305 K=2,LP1
3181 DO 305 I=MYIS,MYIE
3182 FLX(I,K)= (TC(I,1)*E1FLX(I,K) &
3183 +SS1(I,1)*CNTTAU(I,K-1) &
3184 +SORC(I,1,13)*TO3SP(I,K-1) &
3185 +CSOUR(I,1)*CO2SP(I,K)) &
3186 *CLDFAC(I,1,K)
3187 305 CONTINUE
3188 DO 307 I=MYIS,MYIE
3189 FLX(I,1)= TC(I,1)*E1FLX(I,1)+SS1(I,1)+SORC(I,1,13) &
3190 +CSOUR(I,1)
3191 307 CONTINUE
3192 !---THE KP TERMS FOR K=1...
3193 DO 303 KP=2,LP1
3194 DO 303 I=MYIS,MYIE
3195 FLX(I,1)=FLX(I,1)+(OSS(I,KP)*TO3SP(I,KP-1) &
3196 +SS2(I,KP)*CNTTAU(I,KP-1) &
3197 +CSS(I,KP)*CO21(I,KP,1) &
3198 +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,1)
3199 303 CONTINUE
3200 ! SUBROUTINE SPA88 IS CALLED TO OBTAIN EXACT CTS FOR WATER
3201 ! CO2 AND O3, AND APPROXIMATE CTS CO2 AND O3 CALCULATIONS.
3202 !
3203 CALL SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, &
3204 CLDFAC,TEMP,PRESS,VAR1,VAR2, &
3205 P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, &
3206 CO2SP1,CO2SP2,CO2SP, &
3207 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
3208 H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, &
3209 ! SKO2D,RADCON, &
3210 RADCON, &
3211 ids,ide, jds,jde, kds,kde, &
3212 ims,ime, jms,jme, kms,kme, &
3213 its,ite, jts,jte, kts,kte )
3215 !
3216 ! THIS SECTION COMPUTES THE EMISSIVITY CTS HEATING RATES FOR 2
3217 ! EMISSIVITY BANDS: THE 0-160,1200-2200 CM-1 BAND AND THE 800-
3218 ! 990,1070-1200 CM-1 BAND. THE REMAINING CTS COMTRIBUTIONS ARE
3219 ! CONTAINED IN CTSO3, COMPUTED IN SPA88.
3220 !
3221 DO 998 I=MYIS,MYIE
3222 VTMP3(I,1)=1.
3223 998 CONTINUE
3224 DO 999 K=1,L
3225 DO 999 I=MYIS,MYIE
3226 VTMP3(I,K+1)=CNTTAU(I,K)*CLDFAC(I,K+1,1)
3227 999 CONTINUE
3228 DO 1001 K=1,L
3229 DO 1001 I=MYIS,MYIE
3230 CTS(I,K)=RADCON*DELP(I,K)*(TC(I,K)* &
3231 (E1CTW2(I,K)*CLDFAC(I,K+1,1)-E1CTW1(I,K)*CLDFAC(I,K,1)) + &
3232 SS1(I,K)*(VTMP3(I,K+1)-VTMP3(I,K)))
3233 1001 CONTINUE
3234 !
3235 DO 1011 K=1,L
3236 DO 1011 I=MYIS,MYIE
3237 VTMP3(I,K)=TC(I,K)*(CLDFAC(I,K,1)*(E1CTS1(I,K)-E1CTW1(I,K)) - &
3238 CLDFAC(I,K+1,1)*(E1CTS2(I,K)-E1CTW2(I,K)))
3239 1011 CONTINUE
3240 DO 1012 I=MYIS,MYIE
3241 FLX1E1(I)=TC(I,LP1)*CLDFAC(I,LP1,1)* &
3242 (E1CTS1(I,LP1)-E1CTW1(I,LP1))
3243 1012 CONTINUE
3244 DO 1014 K=1,L
3245 DO 1013 I=MYIS,MYIE
3246 FLX1E1(I)=FLX1E1(I)+VTMP3(I,K)
3247 1013 CONTINUE
3248 1014 CONTINUE
3249 !
3250 !---NOW REPEAT FLUX CALCULATIONS FOR THE K=2..LM1 CASES.
3251 ! CALCULATIONS FOR FLUX LEVEL L AND LP1 ARE DONE SEPARATELY, AS ALL
3252 ! EMISSIVITY AND CO2 CALCULATIONS ARE SPECIAL CASES OR NEARBY LAYERS.
3253 !
3254 DO 321 K=2,LM1
3255 KLEN=K
3256 !
3257 DO 3218 KK=1,LP1-K
3258 DO 3218 I=MYIS,MYIE
3259 AVEPHI(I,KK+K-1)=TOTPHI(I,KK+K)-TOTPHI(I,K)
3260 3218 CONTINUE
3261 DO 1803 I=MYIS,MYIE
3262 AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I)
3263 1803 CONTINUE
3264 !---COMPUTE EMISSIVITY FLUXES (E2) FOR THIS CASE. NOTE THAT
3265 ! WE HAVE OMITTED THE NEARBY LATER CASE (EMISS(I,K,K)) AS WELL
3266 ! AS ALL CASES WITH K=L OR LP1. BUT THESE CASES HAVE ALWAYS
3267 ! BEEN HANDLED AS SPECIAL CASES, SO WE MAY AS WELL COMPUTE
3268 ! THEIR FLUXES SEPARASTELY.
3269 !
3270 CALL E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, &
3271 ! T1,T2,T4, &
3272 H16E1,HP1,H28E1,HAF,TEN, &
3273 ids,ide, jds,jde, kds,kde, &
3274 ims,ime, jms,jme, kms,kme, &
3275 its,ite, jts,jte, kts,kte )
3277 DO 322 KK=1,LP1-K
3278 DO 322 I=MYIS,MYIE
3279 AVMO3(I,KK+K-1)=TOTO3(I,KK+K)-TOTO3(I,K)
3280 AVPHO3(I,KK+K-1)=TPHIO3(I,KK+K)-TPHIO3(I,K)
3281 AVVO2(I,KK+K-1)=TOTVO2(I,KK+K)-TOTVO2(I,K)
3282 CONT1D(I,KK+K-1)=CNTTAU(I,KK+K-1)*TOTEVV(I,K-1)
3283 322 CONTINUE
3284 !
3285 DO 3221 KK=1,LP1-K
3286 DO 3221 I=MYIS,MYIE
3287 FAC1(I,K+KK-1)=BO3RND(2)*AVPHO3(I,K+KK-1)/AVMO3(I,K+KK-1)
3288 VTMP3(I,K+KK-1)=HAF*(FAC1(I,K+KK-1)* &
3289 (SQRT(ONE+(FOUR*AO3RND(2)*AVMO3(I,K+KK-1))/ &
3290 FAC1(I,K+KK-1))-ONE))
3291 TO31D(I,K+KK-1)=EXP(HM1EZ*(VTMP3(I,K+KK-1) &
3292 +SKO3R*AVVO2(I,K+KK-1)))
3293 OVER1D(I,K+KK-1)=EXP(HM1EZ*(SQRT(AB15WD*AVEPHI(I,K+KK-1))+ &
3294 SKC1R*AVVO2(I,K+KK-1)))
3295 CO21(I,K+KK,K)=OVER1D(I,K+KK-1)*CO21(I,K+KK,K)
3296 3221 CONTINUE
3297 DO 3223 KP=K+1,LP1
3298 DO 3223 I=MYIS,MYIE
3299 CO21(I,K,KP)=OVER1D(I,KP-1)*CO21(I,K,KP)
3300 3223 CONTINUE
3301 !---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION
3302 DO 1804 I=MYIS,MYIE
3303 RLOG(I,K)=OVER1D(I,K)*CO2NBL(I,K)
3304 1804 CONTINUE
3305 !---THE KP TERMS FOR ARBIRRARY K..
3306 DO 3423 KP=K+1,LP1
3307 DO 3423 I=MYIS,MYIE
3308 FLX(I,K)=FLX(I,K)+(OSS(I,KP)*TO31D(I,KP-1) &
3309 +SS2(I,KP)*CONT1D(I,KP-1) &
3310 +CSS(I,KP)*CO21(I,KP,K) &
3311 +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,K)
3312 3423 CONTINUE
3313 DO 3425 KP=K+1,LP1
3314 DO 3425 I=MYIS,MYIE
3315 FLX(I,KP)=FLX(I,KP)+(OSS(I,K)*TO31D(I,KP-1) &
3316 +SS2(I,K)*CONT1D(I,KP-1) &
3317 +CSS(I,K)*CO21(I,K,KP) &
3318 +DTC(I,K)*EMISSB(I,KP-1))*CLDFAC(I,K,KP)
3319 3425 CONTINUE
3320 321 CONTINUE
3321 !
3322 DO 821 I=MYIS,MYIE
3323 TPL(I,1)=TEMP(I,L)
3324 TPL(I,LP1)=HAF*(T(I,LP1)+TEMP(I,L))
3325 TPL(I,LLP1)=HAF*(T(I,L)+TEMP(I,L))
3326 821 CONTINUE
3327 DO 823 K=2,L
3328 DO 823 I=MYIS,MYIE
3329 TPL(I,K)=T(I,K)
3330 TPL(I,K+L)=T(I,K)
3331 823 CONTINUE
3332 !
3333 !---E2 FUNCTIONS ARE REQUIRED IN THE NBL CALCULATIONS FOR 2 CASES,
3334 ! DENOTED (IN OLD CODE) AS (L,LP1) AND (LP1,LP1)
3335 DO 833 I=MYIS,MYIE
3336 AVEPHI(I,1)=VAR2(I,L)
3337 AVEPHI(I,2)=VAR2(I,L)+EMPL(I,L)
3338 833 CONTINUE
3339 CALL E2SPEC(EMISS,AVEPHI,FXOSP,DTSP, &
3340 ! T1,T2,T4, &
3341 H16E1,TEN,H28E1,HP1, &
3342 ids,ide, jds,jde, kds,kde, &
3343 ims,ime, jms,jme, kms,kme, &
3344 its,ite, jts,jte, kts,kte )
3346 !
3347 ! CALL E3V88 FOR NBL H2O TRANSMISSIVITIES
3348 ! CALL E3V88(EMD,TPL,EMPL,EM3V, &
3349 CALL E3V88(EMD,TPL,EMPL, &
3350 TEN,HP1,H28E1,H16E1, &
3351 ids,ide, jds,jde, kds,kde, &
3352 ims,ime, jms,jme, kms,kme, &
3353 its,ite, jts,jte, kts,kte )
3354 !
3355 ! COMPUTE NEARBY LAYER AND SPECIAL-CASE TRANSMISSIVITIES FOR EMISS
3356 ! USING METHODS FOR H2O GIVEN IN REF. (4)
3357 DO 851 K=2,L
3358 DO 851 I=MYIS,MYIE
3359 EMISDG(I,K)=EMD(I,K+L)+EMD(I,K)
3360 851 CONTINUE
3361 !
3362 ! NOTE THAT EMX1/2 (PRESSURE SCALED PATHS) ARE NOW COMPUTED IN
3363 ! LWR88
3364 DO 861 I=MYIS,MYIE
3365 EMSPEC(I,1)=(EMD(I,1)*EMPL(I,1)-EMD(I,LP1)*EMPL(I,LP1))/ &
3366 EMX1(I) + QUARTR*(EMISS(I,1)+EMISS(I,2))
3367 EMISDG(I,LP1)=TWO*EMD(I,LP1)
3368 EMSPEC(I,2)=TWO*(EMD(I,1)*EMPL(I,1)-EMD(I,LLP1)*EMPL(I,LLP1))/ &
3369 EMX2(I)
3370 861 CONTINUE
3371 DO 331 I=MYIS,MYIE
3372 FAC1(I,L)=BO3RND(2)*VAR4(I,L)/VAR3(I,L)
3373 VTMP3(I,L)=HAF*(FAC1(I,L)* &
3374 (SQRT(ONE+(FOUR*AO3RND(2)*VAR3(I,L))/FAC1(I,L))-ONE))
3375 TO31D(I,L)=EXP(HM1EZ*(VTMP3(I,L)+SKO3R*CNTVAL(I,L)))
3376 OVER1D(I,L)=EXP(HM1EZ*(SQRT(AB15WD*VAR2(I,L))+ &
3377 SKC1R*CNTVAL(I,L)))
3378 CONT1D(I,L)=CNTTAU(I,L)*TOTEVV(I,LM1)
3379 RLOG(I,L)=OVER1D(I,L)*CO2NBL(I,L)
3380 331 CONTINUE
3381 DO 618 K=1,L
3382 DO 618 I=MYIS,MYIE
3383 RLOG(I,K)=LOG(RLOG(I,K))
3384 618 CONTINUE
3385 DO 601 K=1,LM1
3386 DO 601 I=MYIS,MYIE
3387 DELPR1(I,K+1)=DELP(I,K+1)*(PRESS(I,K+1)-P(I,K+1))
3388 ALP(I,LP1+K-1)=-SQRT(DELPR1(I,K+1))*RLOG(I,K+1)
3389 601 CONTINUE
3390 DO 603 K=1,L
3391 DO 603 I=MYIS,MYIE
3392 DELPR2(I,K+1)=DELP(I,K)*(P(I,K+1)-PRESS(I,K))
3393 ALP(I,K)=-SQRT(DELPR2(I,K+1))*RLOG(I,K)
3394 603 CONTINUE
3395 DO 625 I=MYIS,MYIE
3396 ALP(I,LL)=-RLOG(I,L)
3397 ALP(I,LLP1)=-RLOG(I,L)*SQRT(DELP(I,L)*(P(I,LP1)-PRESS(I,LM1)))
3398 625 CONTINUE
3399 ! THE FIRST COMPUTATION IS FOR THE 15 UM BAND,WITH THE
3400 ! FOR THE COMBINED H2O AND CO2 TRANSMISSION FUNCTION.
3401 !
3402 ! PERFORM NBL COMPUTATIONS FOR THE 15 UM BAND
3403 !***THE STATEMENT FUNCTION SF IN PREV. VERSIONS IS NOW EXPLICITLY
3404 ! EVALUATED.
3405 DO 631 K=1,LLP1
3406 DO 631 I=MYIS,MYIE
3407 C(I,K)=ALP(I,K)*(HMP66667+ALP(I,K)*(QUARTR+ALP(I,K)*HM6666M2))
3408 631 CONTINUE
3409 DO 641 I=MYIS,MYIE
3410 CO21(I,LP1,LP1)=ONE+C(I,L)
3411 CO21(I,LP1,L)=ONE+(DELP2(I,L)*C(I,LL)-(PRESS(I,L)-P(I,L))* &
3412 C(I,LLM1))/(P(I,LP1)-PRESS(I,L))
3413 CO21(I,L,LP1)=ONE+((P(I,LP1)-PRESS(I,LM1))*C(I,LLP1)- &
3414 (P(I,LP1)-PRESS(I,L))*C(I,L))/(PRESS(I,L)-PRESS(I,LM1))
3415 641 CONTINUE
3416 DO 643 K=2,L
3417 DO 643 I=MYIS,MYIE
3418 CO21(I,K,K)=ONE+HAF*(C(I,LM1+K)+C(I,K-1))
3419 643 CONTINUE
3420 !
3421 ! COMPUTE NEARBY-LAYER TRANSMISSIVITIES FOR THE O3 BAND AND FOR THE
3422 ! ONE-BAND CONTINUUM BAND (TO3 AND EMISS2). THE SF2 FUNCTION IS
3423 ! USED. THE METHOD IS THE SAME AS DESCRIBED FOR CO2 IN REF (4).
3424 DO 651 K=1,LM1
3425 DO 651 I=MYIS,MYIE
3426 CSUB(I,K+1)=CNTVAL(I,K+1)*DELPR1(I,K+1)
3427 CSUB(I,LP1+K-1)=CNTVAL(I,K)*DELPR2(I,K+1)
3428 651 CONTINUE
3429 !---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED
3430 DO 655 K=1,LLM2
3431 DO 655 I=MYIS,MYIE
3432 CSUB2(I,K+1)=SKO3R*CSUB(I,K+1)
3433 C(I,K+1)=CSUB(I,K+1)*(HMP5+CSUB(I,K+1)* &
3434 (HP166666-CSUB(I,K+1)*H41666M2))
3435 C2(I,K+1)=CSUB2(I,K+1)*(HMP5+CSUB2(I,K+1)* &
3436 (HP166666-CSUB2(I,K+1)*H41666M2))
3437 655 CONTINUE
3438 DO 661 I=MYIS,MYIE
3439 CONTDG(I,LP1)=1.+C(I,LLM1)
3440 TO3DG(I,LP1)=1.+C2(I,LLM1)
3441 661 CONTINUE
3442 DO 663 K=2,L
3443 DO 663 I=MYIS,MYIE
3444 CONTDG(I,K)=ONE+HAF*(C(I,K)+C(I,LM1+K))
3445 TO3DG(I,K)=ONE+HAF*(C2(I,K)+C2(I,LM1+K))
3446 663 CONTINUE
3447 !---NOW OBTAIN FLUXES
3448 !
3449 ! FOR THE DIAGONAL TERMS...
3450 DO 871 K=2,LP1
3451 DO 871 I=MYIS,MYIE
3452 FLX(I,K)=FLX(I,K)+(DTC(I,K)*EMISDG(I,K) &
3453 +SS2(I,K)*CONTDG(I,K) &
3454 +OSS(I,K)*TO3DG(I,K) &
3455 +CSS(I,K)*CO21(I,K,K))*CLDFAC(I,K,K)
3456 871 CONTINUE
3457 ! FOR THE TWO OFF-DIAGONAL TERMS...
3458 DO 873 I=MYIS,MYIE
3459 FLX(I,L)=FLX(I,L)+(CSS(I,LP1)*CO21(I,LP1,L) &
3460 +DTC(I,LP1)*EMSPEC(I,2) &
3461 +OSS(I,LP1)*TO31D(I,L) &
3462 +SS2(I,LP1)*CONT1D(I,L))*CLDFAC(I,LP1,L)
3463 FLX(I,LP1)=FLX(I,LP1)+(CSS(I,L)*CO21(I,L,LP1) &
3464 +OSS(I,L)*TO31D(I,L) &
3465 +SS2(I,L)*CONT1D(I,L) &
3466 +DTC(I,L)*EMSPEC(I,1))*CLDFAC(I,L,LP1)
3467 873 CONTINUE
3468 !
3469 ! FINAL SECTION OBTAINS EMISSIVITY HEATING RATES,
3470 ! TOTAL HEATING RATES AND THE FLUX AT THE GROUND
3471 !
3472 ! .....CALCULATE THE EMISSIVITY HEATING RATES
3473 DO 1101 K=1,L
3474 DO 1101 I=MYIS,MYIE
3475 HEATEM(I,K)=RADCON*(FLX(I,K+1)-FLX(I,K))*DELP(I,K)
3476 1101 CONTINUE
3477 ! .....CALCULATE THE TOTAL HEATING RATES
3478 DO 1103 K=1,L
3479 DO 1103 I=MYIS,MYIE
3480 HEATRA(I,K)=HEATEM(I,K)-CTS(I,K)-CTSO3(I,K)+EXCTS(I,K)
3481 1103 CONTINUE
3482 ! .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE
3483 ! TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1)
3484 DO 1111 K=1,L
3485 DO 1111 I=MYIS,MYIE
3486 VSUM1(I,K)=HEATRA(I,K)*DELP2(I,K)*RADCON1
3487 1111 CONTINUE
3488 DO 1115 I=MYIS,MYIE
3489 TOPFLX(I)=FLX1E1(I)+GXCTS(I)
3490 FLXNET(I,1)=TOPFLX(I)
3491 1115 CONTINUE
3492 !---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS
3493 ! THE THICK CLOUD SECTION IS INVOKED.
3494 DO 1123 K=2,LP1
3495 DO 1123 I=MYIS,MYIE
3496 FLXNET(I,K)=FLXNET(I,K-1)+VSUM1(I,K-1)
3497 1123 CONTINUE
3498 DO 1125 I=MYIS,MYIE
3499 GRNFLX(I)=FLXNET(I,LP1)
3500 1125 CONTINUE
3501 !
3502 ! THIS IS THE THICK CLOUD SECTION.OPTIONALLY,IF THICK CLOUD
3503 ! FLUXES ARE TO BE "CONVECTIVELY ADJUSTED",IE,DF/DP IS CONSTANT,
3504 ! FOR CLOUDY PART OF GRID POINT, THE FOLLOWING CODE IS EXECUTED.
3505 !***FIRST,COUNT THE NUMBER OF CLOUDS ALONG THE LAT. ROW. SKIP THE
3506 ! ENTIRE THICK CLOUD COMPUTATION OF THERE ARE NO CLOUDS.
3507 ICNT=0
3508 DO 1301 I=MYIS,MYIE
3509 ICNT=ICNT+NCLDS(I)
3510 1301 CONTINUE
3511 IF (ICNT.EQ.0) GO TO 6999
3512 !---FIND THE MAXIMUM NUMBER OF CLOUDS IN THE LATITUDE ROW
3513 KCLDS=NCLDS(MYIS)
3514 DO 2106 I=MYIS,MYIE
3515 KCLDS=MAX(NCLDS(I),KCLDS)
3516 2106 CONTINUE
3517 !
3518 !
3519 !***OBTAIN THE PRESSURES AND FLUXES OF THE TOP AND BOTTOM OF
3520 ! THE NC'TH CLOUD (IT IS ASSUMED THAT ALL KTOP AND KBTM'S HAVE
3521 ! BEEN DEFINED!).
3522 DO 1361 KK=1,KCLDS
3523 KMIN=LP1
3524 KMAX=0
3525 DO 1362 I=MYIS,MYIE
3526 J1=KTOP(I,KK+1)
3527 ! IF (J1.EQ.1) GO TO 1362
3528 J3=KBTM(I,KK+1)
3529 IF (J3.GT.J1) THEN
3530 PTOP(I)=P(I,J1)
3531 PBOT(I)=P(I,J3+1)
3532 FTOP(I)=FLXNET(I,J1)
3533 FBOT(I)=FLXNET(I,J3+1)
3534 !***OBTAIN THE "FLUX DERIVATIVE" DF/DP (DELPTC)
3535 DELPTC(I)=(FTOP(I)-FBOT(I))/(PTOP(I)-PBOT(I))
3536 KMIN=MIN(KMIN,J1)
3537 KMAX=MAX(KMAX,J3)
3538 ENDIF
3539 1362 CONTINUE
3540 KMIN=KMIN+1
3541 !***CALCULATE THE TOT. FLUX CHG. FROM THE TOP OF THE CLOUD, FOR
3542 ! ALL LEVELS.
3543 DO 1365 K=KMIN,KMAX
3544 DO 1363 I=MYIS,MYIE
3545 ! IF (KTOP(I,KK+1).EQ.1) GO TO 1363
3546 IF(KTOP(I,KK+1).LT.K .AND. K.LE.KBTM(I,KK+1)) THEN
3547 Z1(I,K)=(P(I,K)-PTOP(I))*DELPTC(I)+FTOP(I)
3548 !ORIGINAL FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,KK+1)) +
3549 !ORIGINAL1 Z1(I,K)*CAMT(I,KK+1)
3550 FLXNET(I,K)=Z1(I,K)
3551 ENDIF
3552 1363 CONTINUE
3553 1365 CONTINUE
3554 1361 CONTINUE
3555 !***USING THIS FLUX CHG. IN THE CLOUDY PART OF THE GRID BOX, OBTAIN
3556 ! THE NEW FLUXES, WEIGHTING THE CLEAR AND CLOUDY FLUXES:AGAIN, ONLY
3557 ! THE FLUXES IN THICK-CLOUD LEVELS WILL EVENTUALLY BE USED.
3558 ! DO 6051 K=1,LP1
3559 ! DO 6051 I=MYIS,MYIE
3560 ! FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,NC)) +
3561 ! 1 Z1(I,K)*CAMT(I,NC)
3562 !051 CONTINUE
3563 !***MERGE FLXTHK INTO FLXNET FOR APPROPRIATE LEVELS.
3564 ! DO 1401 K=1,LP1
3565 ! DO 1401 I=MYIS,MYIE
3566 ! IF (K.GT.ITOP(I) .AND. K.LE.IBOT(I)
3567 ! 1 .AND. (NC-1).LE.NCLDS(I)) THEN
3568 ! FLXNET(I,K)=FLXTHK(I,K)
3569 ! ENDIF
3570 !401 CONTINUE
3571 !
3572 !******END OF CLOUD LOOP*****
3573 6001 CONTINUE
3574 6999 CONTINUE
3575 !***THE FINAL STEP IS TO RECOMPUTE THE HEATING RATES BASED ON THE
3576 ! REVISED FLUXES:
3577 DO 6101 K=1,L
3578 DO 6101 I=MYIS,MYIE
3579 HEATRA(I,K)=RADCON*(FLXNET(I,K+1)-FLXNET(I,K))*DELP(I,K)
3580 6101 CONTINUE
3581 ! THE THICK CLOUD SECTION ENDS HERE.
3583 END SUBROUTINE FST88
3585 !----------------------------------------------------------------------
3587 SUBROUTINE E1E290(G1,G2,G3,G4,G5,EMISS,FXOE1,DTE1,FXOE2,DTE2, &
3588 AVEPHI,TEMP,T, &
3589 ! T1,T2,T4,EM1V,EM1VW, &
3590 H16E1,TEN,HP1,H28E1,HAF, &
3591 ids,ide, jds,jde, kds,kde, &
3592 ims,ime, jms,jme, kms,kme, &
3593 its,ite, jts,jte, kts,kte )
3594 !---------------------------------------------------------------------
3595 IMPLICIT NONE
3596 !----------------------------------------------------------------------
3597 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
3598 ims,ime, jms,jme, kms,kme , &
3599 its,ite, jts,jte, kts,kte
3600 REAL,INTENT(IN) :: H16E1,TEN,HP1,H28E1,HAF
3602 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: G1,G4,G3,EMISS
3603 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: FXOE1,DTE1,FXOE2,DTE2
3604 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,TEMP,T
3605 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: G2,G5
3606 ! REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4 ,EM1V,EM1VW
3608 REAL,DIMENSION(its:ite,kts:kte+1) :: TMP3,DU,FYO,WW1,WW2
3609 INTEGER,DIMENSION(its:ite,kts:kte*3+2) :: IT1
3610 INTEGER,DIMENSION(its:ite,kts:kte+1) :: IVAL
3612 ! REAL,DIMENSION(28,180):: EM1,EM1WDE,TABLE1,TABLE2, &
3613 ! TABLE3
3614 ! EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1))
3615 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
3616 ! (T4(1),TABLE3(1,1))
3618 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
3619 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
3621 L=kte
3622 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
3623 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
3624 LLM2 = LL-2; LLM1=LL-1
3625 MYIS=its; MYIE=ite
3627 !---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE
3628 ! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE
3629 ! THUS GENERATES THE E2 FUNCTION. THE FXO INDICES HAVE BEEN
3630 ! OBTAINED IN FST88, FOR CONVENIENCE.
3631 !
3632 !---THIS SUBROUTINE EVALUATES THE K=1 CASE ONLY--
3633 !
3634 !---THIS LOOP REPLACES LOOPS GOING FROMI=1,IMAX AND KP=2,LP1 PLUS
3635 ! THE SPECIAL CASE FOR THE LP1TH LAYER.
3637 DO 1322 K=1,LP1
3638 DO 1322 I=MYIS,MYIE
3639 TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1
3640 FYO(I,K)=AINT(TMP3(I,K)*TEN)
3641 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
3642 FYO(I,K)=H28E1*FYO(I,K)
3643 IVAL(I,K)=FYO(I,K)+FXOE2(I,K)
3644 EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
3645 +DTE2(I,K)*T4(IVAL(I,K))
3646 1322 CONTINUE
3647 !
3648 !---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW
3649 ! BY AVERAGING THE VALUES FOR L AND LP1:
3650 DO 1344 I=MYIS,MYIE
3651 EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1))
3652 1344 CONTINUE
3653 !
3654 ! CALCULATIONS FOR THE KP=1 LAYER ARE NOT PERFORMED, AS
3655 ! THE RADIATION CODE ASSUMES THAT THE TOP FLUX LAYER (ABOVE THE
3656 ! TOP DATA LEVEL) IS ISOTHERMAL, AND HENCE CONTRIBUTES NOTHING
3657 ! TO THE FLUXES AT OTHER LEVELS.
3658 !
3659 !***THE FOLLOWING IS THE CALCULATION FOR THE E1 FUNCTION, FORMERLY
3660 ! DONE IN SUBROUTINE E1V88. THE MOVE TO E1E288 IS DUE TO THE
3661 ! SAVINGS IN OBTAINING INDEX VALUES (THE TEMP. INDICES HAVE
3662 ! BEEN OBTAINED IN FST88, WHILE THE U-INDICES ARE OBTAINED
3663 ! IN THE E2 CALCS.,WITH K=1).
3664 !
3665 !
3666 ! FOR TERMS INVOLVING TOP LAYER, DU IS NOT KNOWN; IN FACT, WE
3667 ! USE INDEX 2 TO REPERSENT INDEX 1 IN PREV. CODE. THIS MEANS THAT
3668 ! THE IT1 INDEX 1 AND LLP1 HAS TO BE CALCULATED SEPARATELY. THE
3669 ! INDEX LLP2 GIVES THE SAME VALUE AS 1; IT CAN BE OMITTED.
3670 DO 208 I=MYIS,MYIE
3671 IT1(I,1)=FXOE1(I,1)
3672 WW1(I,1)=TEN-DTE1(I,1)
3673 WW2(I,1)=HP1
3674 208 CONTINUE
3675 DO 209 K=1,L
3676 DO 209 I=MYIS,MYIE
3677 IT1(I,K+1)=FYO(I,K)+FXOE1(I,K+1)
3678 IT1(I,LP2+K-1)=FYO(I,K)+FXOE1(I,K)
3679 WW1(I,K+1)=TEN-DTE1(I,K+1)
3680 WW2(I,K+1)=HP1-DU(I,K)
3681 209 CONTINUE
3682 DO 211 KP=1,L
3683 DO 211 I=MYIS,MYIE
3684 IT1(I,KP+LLP1)=FYO(I,KP)+FXOE1(I,1)
3685 211 CONTINUE
3686 !
3687 !
3688 ! G3(I,1) HAS THE SAME VALUES AS G1 (AND DID ALL ALONG)
3689 DO 230 I=MYIS,MYIE
3690 G1(I,1)=WW1(I,1)*WW2(I,1)*EM1V(IT1(I,1))+ &
3691 WW2(I,1)*DTE1(I,1)*EM1V(IT1(I,1)+1)
3692 G3(I,1)=G1(I,1)
3693 230 CONTINUE
3694 DO 240 K=1,L
3695 DO 240 I=MYIS,MYIE
3696 G1(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1V(IT1(I,K+1))+ &
3697 WW2(I,K+1)*DTE1(I,K+1)*EM1V(IT1(I,K+1)+1)+ &
3698 WW1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+28)+ &
3699 DTE1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+29)
3700 G2(I,K)=WW1(I,K)*WW2(I,K+1)*EM1V(IT1(I,K+LP2-1))+ &
3701 WW2(I,K+1)*DTE1(I,K)*EM1V(IT1(I,K+LP2-1)+1)+ &
3702 WW1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+28)+ &
3703 DTE1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+29)
3704 240 CONTINUE
3705 DO 241 KP=2,LP1
3706 DO 241 I=MYIS,MYIE
3707 G3(I,KP)=WW1(I,1)*WW2(I,KP)*EM1V(IT1(I,LL+KP))+ &
3708 WW2(I,KP)*DTE1(I,1)*EM1V(IT1(I,LL+KP)+1)+ &
3709 WW1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+28)+ &
3710 DTE1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+29)
3711 241 CONTINUE
3712 !
3713 DO 244 I=MYIS,MYIE
3714 G4(I,1)=WW1(I,1)*WW2(I,1)*EM1VW(IT1(I,1))+ &
3715 WW2(I,1)*DTE1(I,1)*EM1VW(IT1(I,1)+1)
3716 244 CONTINUE
3717 DO 242 K=1,L
3718 DO 242 I=MYIS,MYIE
3719 G4(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1VW(IT1(I,K+1))+ &
3720 WW2(I,K+1)*DTE1(I,K+1)*EM1VW(IT1(I,K+1)+1)+ &
3721 WW1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+28)+ &
3722 DTE1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+29)
3723 G5(I,K)=WW1(I,K)*WW2(I,K+1)*EM1VW(IT1(I,K+LP2-1))+ &
3724 WW2(I,K+1)*DTE1(I,K)*EM1VW(IT1(I,K+LP2-1)+1)+ &
3725 WW1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+28)+ &
3726 DTE1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+29)
3727 242 CONTINUE
3728 !
3729 END SUBROUTINE E1E290
3731 !----------------------------------------------------------------------
3733 SUBROUTINE SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, &
3734 CLDFAC,TEMP,PRESS,VAR1,VAR2, &
3735 P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, &
3736 CO2SP1,CO2SP2,CO2SP, &
3737 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
3738 H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, &
3739 ! SKO2D,RADCON, &
3740 RADCON, &
3741 ids,ide, jds,jde, kds,kde, &
3742 ims,ime, jms,jme, kms,kme, &
3743 its,ite, jts,jte, kts,kte )
3744 !---------------------------------------------------------------------
3745 IMPLICIT NONE
3746 !----------------------------------------------------------------------
3747 ! INTEGER, PARAMETER :: NBLY=15
3748 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
3749 ims,ime, jms,jme, kms,kme , &
3750 its,ite, jts,jte, kts,kte
3752 REAL,INTENT(IN) :: H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, &
3753 RADCON
3754 ! SKO2D,RADCON
3756 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: CSOUR
3757 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: CTSO3
3758 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: EXCTS
3759 REAL,INTENT(OUT),DIMENSION(its:ite) :: GXCTS
3760 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC
3761 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
3762 REAL,INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
3764 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: VAR1,VAR2
3765 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: P
3766 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: DELP,DELP2,TO3SPC
3767 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) ::TOTVO2,TO3SP,CO2SP1,&
3768 CO2SP2,CO2SP
3769 REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
3770 BCOMB,BETACM
3772 REAL,DIMENSION(its:ite,kts:kte+1) ::CTMP,CTMP2,CTMP3
3773 REAL,DIMENSION(its:ite,kts:kte) ::X,Y,FAC1,FAC2,F,FF,AG,AGG, &
3774 PHITMP,PSITMP,TOPM,TOPPHI,TT
3776 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
3777 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
3779 L=kte
3780 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
3781 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
3782 LLM2 = LL-2; LLM1=LL-1
3783 MYIS=its; MYIE=ite
3785 !--!COMPUTE TEMPERATURE QUANTITIES FOR USE IN PROGRAM
3787 DO 101 K=1,L
3788 DO 101 I=MYIS,MYIE
3789 X(I,K)=TEMP(I,K)-H25E2
3790 Y(I,K)=X(I,K)*X(I,K)
3791 101 CONTINUE
3792 !---INITIALIZE CTMP(I,1),CTMP2(I,1),CTMP3(I,1) TO UNITY; THESE ARE
3793 ! TRANSMISSION FCTNS AT THE TOP.
3794 DO 345 I=MYIS,MYIE
3795 CTMP(I,1)=ONE
3796 CTMP2(I,1)=1.
3797 CTMP3(I,1)=1.
3798 345 CONTINUE
3799 !***BEGIN LOOP ON FREQUENCY BANDS (1)***
3800 !
3801 !---CALCULATION FOR BAND 1 (COMBINED BAND 1)
3802 !
3803 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3804 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3805 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3806 DO 301 K=1,L
3807 DO 301 I=MYIS,MYIE
3808 F(I,K)=H44194M2*(APCM(1)*X(I,K)+BPCM(1)*Y(I,K))
3809 FF(I,K)=H44194M2*(ATPCM(1)*X(I,K)+BTPCM(1)*Y(I,K))
3810 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3811 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3812 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3813 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3814 301 CONTINUE
3815 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3816 ! P(K) (TOPM,TOPPHI)
3817 DO 315 I=MYIS,MYIE
3818 TOPM(I,1)=PHITMP(I,1)
3819 TOPPHI(I,1)=PSITMP(I,1)
3820 315 CONTINUE
3821 DO 319 K=2,L
3822 DO 317 I=MYIS,MYIE
3823 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3824 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3825 317 CONTINUE
3826 319 CONTINUE
3827 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3828 DO 321 K=1,L
3829 DO 321 I=MYIS,MYIE
3830 FAC1(I,K)=ACOMB(1)*TOPM(I,K)
3831 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(1)*TOPPHI(I,K))
3832 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3833 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3834 321 CONTINUE
3835 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3836 DO 353 K=1,L
3837 DO 353 I=MYIS,MYIE
3838 EXCTS(I,K)=SORC(I,K,1)*(CTMP(I,K+1)-CTMP(I,K))
3839 353 CONTINUE
3840 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3841 DO 361 I=MYIS,MYIE
3842 GXCTS(I)=CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,1)+ &
3843 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3844 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3845 (SORC(I,LP1,1)-SORC(I,L,1)))
3846 361 CONTINUE
3847 !
3848 !
3849 !-----CALCULATION FOR BAND 2 (COMBINED BAND 2)
3850 !
3851 !
3852 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3853 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3854 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3855 DO 401 K=1,L
3856 DO 401 I=MYIS,MYIE
3857 F(I,K)=H44194M2*(APCM(2)*X(I,K)+BPCM(2)*Y(I,K))
3858 FF(I,K)=H44194M2*(ATPCM(2)*X(I,K)+BTPCM(2)*Y(I,K))
3859 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3860 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3861 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3862 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3863 401 CONTINUE
3864 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3865 ! P(K) (TOPM,TOPPHI)
3866 DO 415 I=MYIS,MYIE
3867 TOPM(I,1)=PHITMP(I,1)
3868 TOPPHI(I,1)=PSITMP(I,1)
3869 415 CONTINUE
3870 DO 419 K=2,L
3871 DO 417 I=MYIS,MYIE
3872 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3873 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3874 417 CONTINUE
3875 419 CONTINUE
3876 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3877 DO 421 K=1,L
3878 DO 421 I=MYIS,MYIE
3879 FAC1(I,K)=ACOMB(2)*TOPM(I,K)
3880 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(2)*TOPPHI(I,K))
3881 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3882 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3883 421 CONTINUE
3884 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3885 DO 453 K=1,L
3886 DO 453 I=MYIS,MYIE
3887 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,2)* &
3888 (CTMP(I,K+1)-CTMP(I,K))
3889 453 CONTINUE
3890 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3891 DO 461 I=MYIS,MYIE
3892 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,2)+ &
3893 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3894 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3895 (SORC(I,LP1,2)-SORC(I,L,2)))
3896 461 CONTINUE
3897 !
3898 !-----CALCULATION FOR BAND 3 (COMBINED BAND 3)
3899 !
3900 !
3901 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3902 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3903 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3904 DO 501 K=1,L
3905 DO 501 I=MYIS,MYIE
3906 F(I,K)=H44194M2*(APCM(3)*X(I,K)+BPCM(3)*Y(I,K))
3907 FF(I,K)=H44194M2*(ATPCM(3)*X(I,K)+BTPCM(3)*Y(I,K))
3908 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3909 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3910 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3911 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3912 501 CONTINUE
3913 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3914 ! P(K) (TOPM,TOPPHI)
3915 DO 515 I=MYIS,MYIE
3916 TOPM(I,1)=PHITMP(I,1)
3917 TOPPHI(I,1)=PSITMP(I,1)
3918 515 CONTINUE
3919 DO 519 K=2,L
3920 DO 517 I=MYIS,MYIE
3921 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3922 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3923 517 CONTINUE
3924 519 CONTINUE
3925 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3926 DO 521 K=1,L
3927 DO 521 I=MYIS,MYIE
3928 FAC1(I,K)=ACOMB(3)*TOPM(I,K)
3929 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(3)*TOPPHI(I,K))
3930 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3931 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3932 521 CONTINUE
3933 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3934 DO 553 K=1,L
3935 DO 553 I=MYIS,MYIE
3936 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,3)* &
3937 (CTMP(I,K+1)-CTMP(I,K))
3938 553 CONTINUE
3939 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3940 DO 561 I=MYIS,MYIE
3941 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,3)+ &
3942 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3943 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3944 (SORC(I,LP1,3)-SORC(I,L,3)))
3945 561 CONTINUE
3946 !
3947 !-----CALCULATION FOR BAND 4 (COMBINED BAND 4)
3948 !
3949 !
3950 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3951 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3952 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3953 DO 601 K=1,L
3954 DO 601 I=MYIS,MYIE
3955 F(I,K)=H44194M2*(APCM(4)*X(I,K)+BPCM(4)*Y(I,K))
3956 FF(I,K)=H44194M2*(ATPCM(4)*X(I,K)+BTPCM(4)*Y(I,K))
3957 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3958 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3959 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3960 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3961 601 CONTINUE
3962 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3963 ! P(K) (TOPM,TOPPHI)
3964 DO 615 I=MYIS,MYIE
3965 TOPM(I,1)=PHITMP(I,1)
3966 TOPPHI(I,1)=PSITMP(I,1)
3967 615 CONTINUE
3968 DO 619 K=2,L
3969 DO 617 I=MYIS,MYIE
3970 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3971 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3972 617 CONTINUE
3973 619 CONTINUE
3974 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3975 DO 621 K=1,L
3976 DO 621 I=MYIS,MYIE
3977 FAC1(I,K)=ACOMB(4)*TOPM(I,K)
3978 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(4)*TOPPHI(I,K))
3979 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3980 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3981 621 CONTINUE
3982 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3983 DO 653 K=1,L
3984 DO 653 I=MYIS,MYIE
3985 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,4)* &
3986 (CTMP(I,K+1)-CTMP(I,K))
3987 653 CONTINUE
3988 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3989 DO 661 I=MYIS,MYIE
3990 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,4)+ &
3991 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3992 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3993 (SORC(I,LP1,4)-SORC(I,L,4)))
3994 661 CONTINUE
3995 !
3996 !-----CALCULATION FOR BAND 5 (COMBINED BAND 5)
3997 !
3998 !
3999 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4000 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4001 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4002 DO 701 K=1,L
4003 DO 701 I=MYIS,MYIE
4004 F(I,K)=H44194M2*(APCM(5)*X(I,K)+BPCM(5)*Y(I,K))
4005 FF(I,K)=H44194M2*(ATPCM(5)*X(I,K)+BTPCM(5)*Y(I,K))
4006 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4007 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4008 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4009 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4010 701 CONTINUE
4011 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4012 ! P(K) (TOPM,TOPPHI)
4013 DO 715 I=MYIS,MYIE
4014 TOPM(I,1)=PHITMP(I,1)
4015 TOPPHI(I,1)=PSITMP(I,1)
4016 715 CONTINUE
4017 DO 719 K=2,L
4018 DO 717 I=MYIS,MYIE
4019 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4020 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4021 717 CONTINUE
4022 719 CONTINUE
4023 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4024 DO 721 K=1,L
4025 DO 721 I=MYIS,MYIE
4026 FAC1(I,K)=ACOMB(5)*TOPM(I,K)
4027 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(5)*TOPPHI(I,K))
4028 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4029 BETACM(5)*TOTVO2(I,K+1)*SKO2D))
4030 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4031 721 CONTINUE
4032 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4033 DO 753 K=1,L
4034 DO 753 I=MYIS,MYIE
4035 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,5)* &
4036 (CTMP(I,K+1)-CTMP(I,K))
4037 753 CONTINUE
4038 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4039 DO 761 I=MYIS,MYIE
4040 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,5)+ &
4041 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4042 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4043 (SORC(I,LP1,5)-SORC(I,L,5)))
4044 761 CONTINUE
4045 !
4046 !-----CALCULATION FOR BAND 6 (COMBINED BAND 6)
4047 !
4048 !
4049 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4050 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4051 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4052 DO 801 K=1,L
4053 DO 801 I=MYIS,MYIE
4054 F(I,K)=H44194M2*(APCM(6)*X(I,K)+BPCM(6)*Y(I,K))
4055 FF(I,K)=H44194M2*(ATPCM(6)*X(I,K)+BTPCM(6)*Y(I,K))
4056 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4057 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4058 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4059 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4060 801 CONTINUE
4061 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4062 ! P(K) (TOPM,TOPPHI)
4063 DO 815 I=MYIS,MYIE
4064 TOPM(I,1)=PHITMP(I,1)
4065 TOPPHI(I,1)=PSITMP(I,1)
4066 815 CONTINUE
4067 DO 819 K=2,L
4068 DO 817 I=MYIS,MYIE
4069 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4070 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4071 817 CONTINUE
4072 819 CONTINUE
4073 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4074 DO 821 K=1,L
4075 DO 821 I=MYIS,MYIE
4076 FAC1(I,K)=ACOMB(6)*TOPM(I,K)
4077 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(6)*TOPPHI(I,K))
4078 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4079 BETACM(6)*TOTVO2(I,K+1)*SKO2D))
4080 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4081 821 CONTINUE
4082 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4083 DO 853 K=1,L
4084 DO 853 I=MYIS,MYIE
4085 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,6)* &
4086 (CTMP(I,K+1)-CTMP(I,K))
4087 853 CONTINUE
4088 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4089 DO 861 I=MYIS,MYIE
4090 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,6)+ &
4091 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4092 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4093 (SORC(I,LP1,6)-SORC(I,L,6)))
4094 861 CONTINUE
4095 !
4096 !-----CALCULATION FOR BAND 7 (COMBINED BAND 7)
4097 !
4098 !
4099 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4100 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4101 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4102 DO 901 K=1,L
4103 DO 901 I=MYIS,MYIE
4104 F(I,K)=H44194M2*(APCM(7)*X(I,K)+BPCM(7)*Y(I,K))
4105 FF(I,K)=H44194M2*(ATPCM(7)*X(I,K)+BTPCM(7)*Y(I,K))
4106 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4107 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4108 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4109 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4110 901 CONTINUE
4111 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4112 ! P(K) (TOPM,TOPPHI)
4113 DO 915 I=MYIS,MYIE
4114 TOPM(I,1)=PHITMP(I,1)
4115 TOPPHI(I,1)=PSITMP(I,1)
4116 915 CONTINUE
4117 DO 919 K=2,L
4118 DO 917 I=MYIS,MYIE
4119 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4120 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4121 917 CONTINUE
4122 919 CONTINUE
4123 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4124 DO 921 K=1,L
4125 DO 921 I=MYIS,MYIE
4126 FAC1(I,K)=ACOMB(7)*TOPM(I,K)
4127 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(7)*TOPPHI(I,K))
4128 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4129 BETACM(7)*TOTVO2(I,K+1)*SKO2D))
4130 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4131 921 CONTINUE
4132 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4133 DO 953 K=1,L
4134 DO 953 I=MYIS,MYIE
4135 EXCTS(I,K)=EXCTS(I,K)+SORC(I,k,7)* &
4136 (CTMP(I,K+1)-CTMP(I,K))
4137 953 CONTINUE
4138 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4139 DO 961 I=MYIS,MYIE
4140 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,7)+ &
4141 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4142 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4143 (SORC(I,LP1,7)-SORC(I,L,7)))
4144 961 CONTINUE
4145 !
4146 !-----CALCULATION FOR BAND 8 (COMBINED BAND 8)
4147 !
4148 !
4149 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4150 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4151 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4152 DO 1001 K=1,L
4153 DO 1001 I=MYIS,MYIE
4154 F(I,K)=H44194M2*(APCM(8)*X(I,K)+BPCM(8)*Y(I,K))
4155 FF(I,K)=H44194M2*(ATPCM(8)*X(I,K)+BTPCM(8)*Y(I,K))
4156 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4157 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4158 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4159 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4160 1001 CONTINUE
4161 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4162 ! P(K) (TOPM,TOPPHI)
4163 DO 1015 I=MYIS,MYIE
4164 TOPM(I,1)=PHITMP(I,1)
4165 TOPPHI(I,1)=PSITMP(I,1)
4166 1015 CONTINUE
4167 DO 1019 K=2,L
4168 DO 1017 I=MYIS,MYIE
4169 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4170 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4171 1017 CONTINUE
4172 1019 CONTINUE
4173 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4174 DO 1021 K=1,L
4175 DO 1021 I=MYIS,MYIE
4176 FAC1(I,K)=ACOMB(8)*TOPM(I,K)
4177 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(8)*TOPPHI(I,K))
4178 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4179 BETACM(8)*TOTVO2(I,K+1)*SKO2D))
4180 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4181 1021 CONTINUE
4182 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4183 DO 1053 K=1,L
4184 DO 1053 I=MYIS,MYIE
4185 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,8)* &
4186 (CTMP(I,K+1)-CTMP(I,K))
4187 1053 CONTINUE
4188 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4189 DO 1061 I=MYIS,MYIE
4190 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,8)+ &
4191 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4192 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4193 (SORC(I,LP1,8)-SORC(I,L,8)))
4194 1061 CONTINUE
4195 !
4196 !-----CALCULATION FOR BAND 9 ( 560-670 CM-1; INCLUDES CO2)
4197 !
4198 !
4199 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4200 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4201 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4202 DO 1101 K=1,L
4203 DO 1101 I=MYIS,MYIE
4204 F(I,K)=H44194M2*(APCM(9)*X(I,K)+BPCM(9)*Y(I,K))
4205 FF(I,K)=H44194M2*(ATPCM(9)*X(I,K)+BTPCM(9)*Y(I,K))
4206 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4207 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4208 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4209 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4210 1101 CONTINUE
4211 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4212 ! P(K) (TOPM,TOPPHI)
4213 DO 1115 I=MYIS,MYIE
4214 TOPM(I,1)=PHITMP(I,1)
4215 TOPPHI(I,1)=PSITMP(I,1)
4216 1115 CONTINUE
4217 DO 1119 K=2,L
4218 DO 1117 I=MYIS,MYIE
4219 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4220 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4221 1117 CONTINUE
4222 1119 CONTINUE
4223 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4224 DO 1121 K=1,L
4225 DO 1121 I=MYIS,MYIE
4226 FAC1(I,K)=ACOMB(9)*TOPM(I,K)
4227 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(9)*TOPPHI(I,K))
4228 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4229 BETACM(9)*TOTVO2(I,K+1)*SKO2D))*CO2SP1(I,K+1)
4230 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4231 1121 CONTINUE
4232 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4233 DO 1153 K=1,L
4234 DO 1153 I=MYIS,MYIE
4235 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,9)* &
4236 (CTMP(I,K+1)-CTMP(I,K))
4237 1153 CONTINUE
4238 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4239 DO 1161 I=MYIS,MYIE
4240 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,9)+ &
4241 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4242 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4243 (SORC(I,LP1,9)-SORC(I,L,9)))
4244 1161 CONTINUE
4245 !
4246 !-----CALCULATION FOR BAND 10 (670-800 CM-1; INCLUDES CO2)
4247 !
4248 !
4249 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4250 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4251 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4252 DO 1201 K=1,L
4253 DO 1201 I=MYIS,MYIE
4254 F(I,K)=H44194M2*(APCM(10)*X(I,K)+BPCM(10)*Y(I,K))
4255 FF(I,K)=H44194M2*(ATPCM(10)*X(I,K)+BTPCM(10)*Y(I,K))
4256 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4257 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4258 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4259 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4260 1201 CONTINUE
4261 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4262 ! P(K) (TOPM,TOPPHI)
4263 DO 1215 I=MYIS,MYIE
4264 TOPM(I,1)=PHITMP(I,1)
4265 TOPPHI(I,1)=PSITMP(I,1)
4266 1215 CONTINUE
4267 DO 1219 K=2,L
4268 DO 1217 I=MYIS,MYIE
4269 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4270 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4271 1217 CONTINUE
4272 1219 CONTINUE
4273 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4274 DO 1221 K=1,L
4275 DO 1221 I=MYIS,MYIE
4276 FAC1(I,K)=ACOMB(10)*TOPM(I,K)
4277 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(10)*TOPPHI(I,K))
4278 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4279 BETACM(10)*TOTVO2(I,K+1)*SKO2D))*CO2SP2(I,K+1)
4280 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4281 1221 CONTINUE
4282 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4283 DO 1253 K=1,L
4284 DO 1253 I=MYIS,MYIE
4285 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,10)* &
4286 (CTMP(I,K+1)-CTMP(I,K))
4287 1253 CONTINUE
4288 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4289 DO 1261 I=MYIS,MYIE
4290 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,10)+ &
4291 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4292 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4293 (SORC(I,LP1,10)-SORC(I,L,10)))
4294 1261 CONTINUE
4295 !
4296 !-----CALCULATION FOR BAND 11 (800-900 CM-1)
4297 !
4298 !
4299 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4300 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4301 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4302 DO 1301 K=1,L
4303 DO 1301 I=MYIS,MYIE
4304 F(I,K)=H44194M2*(APCM(11)*X(I,K)+BPCM(11)*Y(I,K))
4305 FF(I,K)=H44194M2*(ATPCM(11)*X(I,K)+BTPCM(11)*Y(I,K))
4306 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4307 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4308 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4309 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4310 1301 CONTINUE
4311 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4312 ! P(K) (TOPM,TOPPHI)
4313 DO 1315 I=MYIS,MYIE
4314 TOPM(I,1)=PHITMP(I,1)
4315 TOPPHI(I,1)=PSITMP(I,1)
4316 1315 CONTINUE
4317 DO 1319 K=2,L
4318 DO 1317 I=MYIS,MYIE
4319 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4320 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4321 1317 CONTINUE
4322 1319 CONTINUE
4323 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4324 DO 1321 K=1,L
4325 DO 1321 I=MYIS,MYIE
4326 FAC1(I,K)=ACOMB(11)*TOPM(I,K)
4327 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(11)*TOPPHI(I,K))
4328 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4329 BETACM(11)*TOTVO2(I,K+1)*SKO2D))
4330 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4331 1321 CONTINUE
4332 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4333 DO 1353 K=1,L
4334 DO 1353 I=MYIS,MYIE
4335 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,11)* &
4336 (CTMP(I,K+1)-CTMP(I,K))
4337 1353 CONTINUE
4338 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4339 DO 1361 I=MYIS,MYIE
4340 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,11)+ &
4341 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4342 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4343 (SORC(I,LP1,11)-SORC(I,L,11)))
4344 1361 CONTINUE
4345 !
4346 !-----CALCULATION FOR BAND 12 (900-990 CM-1)
4347 !
4348 !
4349 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4350 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4351 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4352 DO 1401 K=1,L
4353 DO 1401 I=MYIS,MYIE
4354 F(I,K)=H44194M2*(APCM(12)*X(I,K)+BPCM(12)*Y(I,K))
4355 FF(I,K)=H44194M2*(ATPCM(12)*X(I,K)+BTPCM(12)*Y(I,K))
4356 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4357 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4358 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4359 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4360 1401 CONTINUE
4361 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4362 ! P(K) (TOPM,TOPPHI)
4363 DO 1415 I=MYIS,MYIE
4364 TOPM(I,1)=PHITMP(I,1)
4365 TOPPHI(I,1)=PSITMP(I,1)
4366 1415 CONTINUE
4367 DO 1419 K=2,L
4368 DO 1417 I=MYIS,MYIE
4369 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4370 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4371 1417 CONTINUE
4372 1419 CONTINUE
4373 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4374 DO 1421 K=1,L
4375 DO 1421 I=MYIS,MYIE
4376 FAC1(I,K)=ACOMB(12)*TOPM(I,K)
4377 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(12)*TOPPHI(I,K))
4378 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4379 BETACM(12)*TOTVO2(I,K+1)*SKO2D))
4380 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4381 1421 CONTINUE
4382 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4383 DO 1453 K=1,L
4384 DO 1453 I=MYIS,MYIE
4385 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,12)* &
4386 (CTMP(I,K+1)-CTMP(I,K))
4387 1453 CONTINUE
4388 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4389 DO 1461 I=MYIS,MYIE
4390 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,12)+ &
4391 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4392 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4393 (SORC(I,LP1,12)-SORC(I,L,12)))
4394 1461 CONTINUE
4395 !
4396 !-----CALCULATION FOR BAND 13 (990-1070 CM-1; INCLUDES O3))
4397 !
4398 !
4399 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4400 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4401 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4402 DO 1501 K=1,L
4403 DO 1501 I=MYIS,MYIE
4404 F(I,K)=H44194M2*(APCM(13)*X(I,K)+BPCM(13)*Y(I,K))
4405 FF(I,K)=H44194M2*(ATPCM(13)*X(I,K)+BTPCM(13)*Y(I,K))
4406 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4407 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4408 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4409 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4410 1501 CONTINUE
4411 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4412 ! P(K) (TOPM,TOPPHI)
4413 DO 1515 I=MYIS,MYIE
4414 TOPM(I,1)=PHITMP(I,1)
4415 TOPPHI(I,1)=PSITMP(I,1)
4416 1515 CONTINUE
4417 DO 1519 K=2,L
4418 DO 1517 I=MYIS,MYIE
4419 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4420 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4421 1517 CONTINUE
4422 1519 CONTINUE
4423 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4424 DO 1521 K=1,L
4425 DO 1521 I=MYIS,MYIE
4426 FAC1(I,K)=ACOMB(13)*TOPM(I,K)
4427 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(13)*TOPPHI(I,K))
4428 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4429 BETACM(13)*TOTVO2(I,K+1)*SKO2D+TO3SPC(I,K)))
4430 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4431 1521 CONTINUE
4432 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4433 DO 1553 K=1,L
4434 DO 1553 I=MYIS,MYIE
4435 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,13)* &
4436 (CTMP(I,K+1)-CTMP(I,K))
4437 1553 CONTINUE
4438 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4439 DO 1561 I=MYIS,MYIE
4440 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,13)+ &
4441 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4442 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4443 (SORC(I,LP1,13)-SORC(I,L,13)))
4444 1561 CONTINUE
4445 !
4446 !-----CALCULATION FOR BAND 14 (1070-1200 CM-1)
4447 !
4448 !
4449 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4450 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4451 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4452 DO 1601 K=1,L
4453 DO 1601 I=MYIS,MYIE
4454 F(I,K)=H44194M2*(APCM(14)*X(I,K)+BPCM(14)*Y(I,K))
4455 FF(I,K)=H44194M2*(ATPCM(14)*X(I,K)+BTPCM(14)*Y(I,K))
4456 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4457 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4458 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4459 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4460 1601 CONTINUE
4461 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4462 ! P(K) (TOPM,TOPPHI)
4463 DO 1615 I=MYIS,MYIE
4464 TOPM(I,1)=PHITMP(I,1)
4465 TOPPHI(I,1)=PSITMP(I,1)
4466 1615 CONTINUE
4467 DO 1619 K=2,L
4468 DO 1617 I=MYIS,MYIE
4469 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4470 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4471 1617 CONTINUE
4472 1619 CONTINUE
4473 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4474 DO 1621 K=1,L
4475 DO 1621 I=MYIS,MYIE
4476 FAC1(I,K)=ACOMB(14)*TOPM(I,K)
4477 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(14)*TOPPHI(I,K))
4478 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4479 BETACM(14)*TOTVO2(I,K+1)*SKO2D))
4480 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4481 1621 CONTINUE
4482 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4483 DO 1653 K=1,L
4484 DO 1653 I=MYIS,MYIE
4485 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,14)* &
4486 (CTMP(I,K+1)-CTMP(I,K))
4487 1653 CONTINUE
4488 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4489 DO 1661 I=MYIS,MYIE
4490 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,14)+ &
4491 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4492 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4493 (SORC(I,LP1,14)-SORC(I,L,14)))
4494 1661 CONTINUE
4495 !
4496 !
4497 ! OBTAIN CTS FLUX AT THE TOP BY INTEGRATION OF HEATING RATES AND
4498 ! USING CTS FLUX AT THE BOTTOM (CURRENT VALUE OF GXCTS). NOTE
4499 ! THAT THE PRESSURE QUANTITIES AND CONVERSION FACTORS HAVE NOT
4500 ! BEEN INCLUDED EITHER IN EXCTS OR IN GXCTS. THESE CANCEL OUT, THUS
4501 ! REDUCING COMPUTATIONS!
4502 DO 1731 K=1,L
4503 DO 1731 I=MYIS,MYIE
4504 GXCTS(I)=GXCTS(I)-EXCTS(I,K)
4505 1731 CONTINUE
4506 !
4507 ! NOW SCALE THE COOLING RATE (EXCTS) BY INCLUDING THE PRESSURE
4508 ! FACTOR (DELP) AND THE CONVERSION FACTOR (RADCON)
4509 DO 1741 K=1,L
4510 DO 1741 I=MYIS,MYIE
4511 EXCTS(I,K)=EXCTS(I,K)*RADCON*DELP(I,K)
4512 1741 CONTINUE
4513 !---THIS IS THE END OF THE EXACT CTS COMPUTATIONS; AT THIS POINT
4514 ! EXCTS HAS ITS APPROPRIATE VALUE.
4515 !
4516 !*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS
4517 ! (CTSO3)
4518 DO 1711 K=1,L
4519 DO 1711 I=MYIS,MYIE
4520 CTMP2(I,K+1)=CO2SP(I,K+1)*CLDFAC(I,K+1,1)
4521 CTMP3(I,K+1)=TO3SP(I,K)*CLDFAC(I,K+1,1)
4522 1711 CONTINUE
4523 DO 1701 K=1,L
4524 DO 1701 I=MYIS,MYIE
4525 CTSO3(I,K)=RADCON*DELP(I,K)* &
4526 (CSOUR(I,K)*(CTMP2(I,K+1)-CTMP2(I,K)) + &
4527 SORC(I,K,13)*(CTMP3(I,K+1)-CTMP3(I,K)))
4528 1701 CONTINUE
4530 END SUBROUTINE SPA88
4531 !----------------------------------------------------------------------
4533 SUBROUTINE E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, &
4534 ! T1,T2,T4, &
4535 H16E1,HP1,H28E1,HAF,TEN, &
4536 ids,ide, jds,jde, kds,kde, &
4537 ims,ime, jms,jme, kms,kme, &
4538 its,ite, jts,jte, kts,kte )
4539 !---------------------------------------------------------------------
4540 IMPLICIT NONE
4541 !----------------------------------------------------------------------
4542 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4543 ims,ime, jms,jme, kms,kme , &
4544 its,ite, jts,jte, kts,kte
4545 INTEGER, INTENT(IN) :: KLEN
4546 REAL, INTENT(IN) :: H16E1,HP1,H28E1,HAF ,TEN
4547 REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: EMISSB
4548 REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,FXOE2,DTE2
4550 ! REAL, INTENT(IN ), DIMENSION(5040) :: T1,T2,T4
4552 REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1) :: EMISS
4554 REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,DT,FYO,DU
4555 INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL
4557 ! REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3
4558 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
4559 ! (T4(1),TABLE3(1,1))
4560 ! EQUIVALENCE (TMP3,DT)
4562 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
4563 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK
4565 L=kte
4566 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
4567 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
4568 LLM2 = LL-2; LLM1=LL-1
4569 MYIS=its; MYIE=ite
4572 !---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE
4573 ! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE
4574 ! THUS GENERATES THE E2 FUNCTION.
4575 !
4576 !---CALCULATIONS FOR VARYING KP (FROM KP=K+1 TO LP1, INCLUDING SPECIAL
4577 ! CASE: RESULTS ARE IN EMISS
4581 DO 132 K=1,LP2-KLEN
4582 DO 132 I=MYIS,MYIE
4583 TMP3(I,K)=LOG10(AVEPHI(I,KLEN+K-1))+H16E1
4584 FYO(I,K)=AINT(TMP3(I,K)*TEN)
4585 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4586 FYO(I,K)=H28E1*FYO(I,K)
4587 IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN+K-1)
4588 EMISS(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
4589 +DTE2(I,KLEN+K-1)*T4(IVAL(I,K))
4590 132 CONTINUE
4591 !---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW
4592 ! BY AVERAGING THE VALUES FOR L AND LP1:
4593 DO 1344 I=MYIS,MYIE
4594 EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1))
4595 1344 CONTINUE
4596 !---NOTE THAT EMISS(I,LP1) IS NOT USEFUL AFTER THIS POINT.
4597 !
4598 !---CALCULATIONS FOR KP=KLEN AND VARYING K; RESULTS ARE IN EMISSB.
4599 ! IN THIS CASE, THE TEMPERATURE INDEX IS UNCHANGED, ALWAYS BEING
4600 ! FXO(I,KLEN-1); THE WATER INDEX CHANGES, BUT IS SYMMETRICAL WITH
4601 ! THAT FOR THE VARYING KP CASE.NOTE THAT THE SPECIAL CASE IS NOT
4602 ! INVOLVED HERE.
4603 ! (FIXED LEVEL) K VARIES FROM (KLEN+1) TO LP1; RESULTS ARE IN
4604 ! EMISSB(I,(KLEN) TO L)
4605 DO 142 K=1,LP1-KLEN
4606 DO 142 I=MYIS,MYIE
4607 DT(I,K)=DTE2(I,KLEN-1)
4608 IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN-1)
4609 142 CONTINUE
4610 !
4611 DO 234 K=1,LP1-KLEN
4612 DO 234 I=MYIS,MYIE
4613 EMISSB(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
4614 +DT(I,K)*T4(IVAL(I,K))
4615 234 CONTINUE
4617 END SUBROUTINE E290
4619 !---------------------------------------------------------------------
4621 SUBROUTINE E2SPEC(EMISS,AVEPHI,FXOSP,DTSP, &
4622 ! T1,T2,T4, &
4623 H16E1,TEN,H28E1,HP1, &
4624 ids,ide, jds,jde, kds,kde, &
4625 ims,ime, jms,jme, kms,kme, &
4626 its,ite, jts,jte, kts,kte )
4627 !---------------------------------------------------------------------
4628 IMPLICIT NONE
4629 !----------------------------------------------------------------------
4630 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4631 ims,ime, jms,jme, kms,kme , &
4632 its,ite, jts,jte, kts,kte
4633 REAL,INTENT(IN ) :: H16E1,TEN,H28E1,HP1
4634 REAL,INTENT(INOUT),DIMENSION(its:ite,kts:kte+1) :: EMISS
4635 REAL,INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI
4636 REAL,INTENT(IN ),DIMENSION(its:ite,2) :: FXOSP,DTSP
4638 ! REAL, INTENT(IN ),DIMENSION(5040) :: T1,T2,T4
4640 ! REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3
4641 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
4642 ! (T4(1),TABLE3(1,1))
4644 INTEGER :: K,I,MYIS,MYIE
4646 REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,FYO,DU
4647 INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL
4649 MYIS=its
4650 MYIE=ite
4652 DO 132 K=1,2
4653 DO 132 I=MYIS,MYIE
4654 TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1
4655 FYO(I,K)=AINT(TMP3(I,K)*TEN)
4656 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4657 IVAL(I,K)=H28E1*FYO(I,K)+FXOSP(I,K)
4658 EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K))+ &
4659 DTSP(I,K)*T4(IVAL(I,K))
4660 132 CONTINUE
4662 END SUBROUTINE E2SPEC
4664 !---------------------------------------------------------------------
4666 ! SUBROUTINE E3V88(EMV,TV,AV,EM3V, &
4667 SUBROUTINE E3V88(EMV,TV,AV, &
4668 TEN,HP1,H28E1,H16E1, &
4669 ids,ide, jds,jde, kds,kde, &
4670 ims,ime, jms,jme, kms,kme, &
4671 its,ite, jts,jte, kts,kte )
4672 !---------------------------------------------------------------------
4673 IMPLICIT NONE
4674 !----------------------------------------------------------------------
4675 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4676 ims,ime, jms,jme, kms,kme , &
4677 its,ite, jts,jte, kts,kte
4678 REAL, INTENT(IN) :: TEN,HP1,H28E1,H16E1
4679 !-----------------------------------------------------------------------
4680 REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte*2+1) :: EMV
4681 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: TV,AV
4682 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
4684 REAL,DIMENSION(its:ite,kts:kte*2+1) ::FXO,TMP3,DT,WW1,WW2,DU,&
4685 FYO
4686 ! REAL, DIMENSION(5040) :: EM3V
4688 ! EQUIVALENCE (EM3V(1),EM3(1,1))
4690 INTEGER,DIMENSION(its:ite,kts:kte*2+1) ::IT
4692 INTEGER :: LLP1,I,K,MYIS,MYIE ,L
4693 L = kte
4694 LLP1 = 2*L + 1
4695 MYIS=its; MYIE=ite
4697 !---THE FOLLOWING LOOP REPLACES A DOUBLE LOOP OVER I (1-IMAX) AND
4698 ! K (1-LLP1)
4700 DO 203 K=1,LLP1
4701 DO 203 I=MYIS,MYIE
4702 FXO(I,K)=AINT(TV(I,K)*HP1)
4703 TMP3(I,K)=LOG10(AV(I,K))+H16E1
4704 DT(I,K)=TV(I,K)-TEN*FXO(I,K)
4705 FYO(I,K)=AINT(TMP3(I,K)*TEN)
4706 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4707 !---OBTAIN INDEX FOR TABLE LOOKUP; THIS VALUE WILL HAVE TO BE
4708 ! DECREMENTED BY 9 TO ACCOUNT FOR TABLE TEMPS STARTING AT 100K.
4709 IT(I,K)=FXO(I,K)+FYO(I,K)*H28E1
4710 WW1(I,K)=TEN-DT(I,K)
4711 WW2(I,K)=HP1-DU(I,K)
4712 EMV(I,K)=WW1(I,K)*WW2(I,K)*EM3V(IT(I,K)-9)+ &
4713 WW2(I,K)*DT(I,K)*EM3V(IT(I,K)-8)+ &
4714 WW1(I,K)*DU(I,K)*EM3V(IT(I,K)+19)+ &
4715 DT(I,K)*DU(I,K)*EM3V(IT(I,K)+20)
4716 203 CONTINUE
4718 END SUBROUTINE E3V88
4719 !-----------------------------------------------------------------------
4721 SUBROUTINE SWR93(FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL, &
4722 DFSWL, &
4723 PRESS,COSZRO,TAUDAR,RH2O,RRCO2,SSOLAR,QO3, &
4724 NCLDS,KTOPSW,KBTMSW,CAMT,CRR,CTT, &
4725 ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, &
4726 ! UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2, &
4727 ABCFF,PWTS, &
4728 H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219, &
4729 HP816,RRAYAV,GINV,CFCO2,CFO3, &
4730 TWO,H235M3,HP26,H129M2,H75826M4,H1036E2, &
4731 H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2, &
4732 H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON, &
4733 ids,ide, jds,jde, kds,kde, &
4734 ims,ime, jms,jme, kms,kme, &
4735 its,ite, jts,jte, kts,kte )
4736 !----------------------------------------------------------------------
4737 IMPLICIT NONE
4738 !----------------------------------------------------------------------
4739 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4740 ims,ime, jms,jme, kms,kme , &
4741 its,ite, jts,jte, kts,kte
4742 REAL,INTENT(IN) :: RRCO2,SSOLAR
4743 REAL,INTENT(IN) :: H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219,HP816,RRAYAV,&
4744 GINV,CFCO2,CFO3
4745 REAL,INTENT(IN) :: TWO,H235M3,HP26,H129M2,H75826M4,H1036E2
4746 REAL,INTENT(IN) :: H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2,H323M4,HM1EZ
4747 REAL,INTENT(IN) :: DIFFCTR,O3DIFCTR,FIFTY,RADCON
4748 !----------------------------------------------------------------------
4749 INTEGER, PARAMETER :: NB=12
4750 REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: PRESS,CAMT
4751 REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte) :: RH2O,QO3
4752 REAL, INTENT(IN ),DIMENSION(its:ite) :: COSZRO,TAUDAR,ALVB,ALVD,ALNB,ALND
4753 INTEGER, INTENT(IN ),DIMENSION(its:ite) :: NCLDS
4754 INTEGER, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) ::KTOPSW,KBTMSW
4755 REAL, INTENT(IN ),DIMENSION(its:ite,NB,kts:kte+1) ::CRR,CTT
4757 REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: &
4758 FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL,DFSWL
4759 REAL, INTENT(OUT),DIMENSION(its:ite) :: GDFVB,GDFVD,GDFNB,GDFND
4760 REAL, INTENT(IN), DIMENSION(NB) :: ABCFF,PWTS
4762 ! REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3
4763 ! REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TUCO2,TUO3,TDO3,TDCO2
4765 REAL, DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3
4766 REAL, DIMENSION(its:ite,kts:kte+1) :: TUCO2,TUO3,TDO3,TDCO2
4768 REAL, DIMENSION(its:ite,kts:kte*2+2) :: TCO2,TO3
4769 REAL, DIMENSION(its:ite,kts:kte+1) :: PP,DP,PR2,DU,DUCO2,DUO3,UD,TTD
4770 REAL, DIMENSION(its:ite,kts:kte+1) :: UDCO2,UDO3,UR,URCO2,URO3,TTU
4771 REAL, DIMENSION(its:ite,kts:kte+1) :: DFN,UFN
4772 REAL, DIMENSION(its:ite,kts:kte+1) :: XAMT,FF,FFCO2,FFO3,CR,CT
4773 REAL, DIMENSION(its:ite,kts:kte+1) :: PPTOP,DPCLD,TTDB1,TTUB1
4774 REAL, DIMENSION(its:ite,kts:kte+1) :: TDCL1,TUCL1,TDCL2,DFNTRN, &
4775 UFNTRN,TCLU,TCLD,ALFA,ALFAU, &
4776 UFNCLU,DFNCLU
4778 REAL, DIMENSION(its:ite,NB) :: DFNTOP
4779 REAL, DIMENSION(its:ite) :: SECZ,TMP1,RRAY,REFL,REFL2,CCMAX
4781 ! EQUIVALENCE &
4782 ! (UDO3,UO3(its,1),DFNCLU), (URO3,UO3(its,kte+2), UFNCLU) &
4783 ! , (UDCO2,UCO2(its,1),TCLD), (URCO2,UCO2(its,kte+2), TCLU) &
4784 ! , (TDO3 ,TO3(its,1),DFNTRN),(TUO3,TO3(its,kte+2), UFNTRN) &
4785 ! , (TDCO2,TCO2(its,1) ),(TUCO2,TCO2(its,kte+2) ) &
4786 ! , (FF , ALFA ), (FFCO2 , ALFAU ), (FFO3 , TTDB1 ) &
4787 ! , (DU , TTUB1), (DUCO2 , TUCL1 ), (DUO3 , TDCL1 ) &
4788 ! , (PR2 , TDCL2)
4790 ! EQUIVALENCE &
4791 ! (UDO3,DFNCLU), (URO3,UFNCLU) &
4792 ! , (UDCO2,TCLD ), (URCO2,TCLU) &
4793 ! , (TDO3 ,DFNTRN),(TUO3,UFNTRN) &
4794 !! , (TDCO2,TCO2(its,1) ),(TUCO2,TCO2(its,kte+2) ) &
4795 ! , (FF , ALFA ), (FFCO2 , ALFAU ), (FFO3 , TTDB1 ) &
4796 ! , (DU , TTUB1), (DUCO2 , TUCL1 ), (DUO3 , TDCL1 ) &
4797 ! , (PR2 , TDCL2)
4799 INTEGER :: K,I,KP,N,IP,MYIS1,KCLDS,NNCLDS,JTOP,KK,J2,J3,J1
4800 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL
4801 REAL :: DENOM,HTEMP,TEMPF,TEMPG
4803 L=kte
4804 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
4805 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
4806 MYIS=its; MYIE=ite
4807 MYIS1=MYIS+1 ! ??
4809 DO 100 I=MYIS,MYIE
4810 SECZ(I) = H35E1/SQRT(H1224E3*COSZRO(I)*COSZRO(I)+ONE)
4811 PP(I,1) = ZERO
4812 PP(I,LP1) = PRESS(I,LP1)
4813 TMP1(I) = ONE/PRESS(I,LP1)
4814 100 CONTINUE
4815 DO 110 K=1,LM1
4816 DO 110 I=MYIS,MYIE
4817 PP(I,K+1) = HAF*(PRESS(I,K+1)+PRESS(I,K))
4818 110 CONTINUE
4819 DO 120 K=1,L
4820 DO 120 I=MYIS,MYIE
4821 DP (I,K) = PP(I,K+1)-PP(I,K)
4822 PR2(I,K) = HAF*(PP(I,K)+PP(I,K+1))
4823 120 CONTINUE
4824 DO 130 K=1,L
4825 DO 130 I=MYIS,MYIE
4826 PR2(I,K) = PR2(I,K)*TMP1(I)
4827 130 CONTINUE
4828 ! CALCULATE ENTERING FLUX AT THE TOP FOR EACH BAND(IN CGS UNITS)
4829 DO 140 N=1,NB
4830 DO 140 IP=MYIS,MYIE
4831 DFNTOP(IP,N) = SSOLAR*H69766E5*COSZRO(IP)*TAUDAR(IP)*PWTS(N)
4832 140 CONTINUE
4833 ! EXECUTE THE LACIS-HANSEN REFLECTIVITY PARAMETERIZATION
4834 ! FOR THE VISIBLE BAND
4835 DO 150 I=MYIS,MYIE
4836 RRAY(I) = HP219/(ONE+HP816*COSZRO(I))
4837 REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVB(I)/ &
4838 (ONE-ALVD(I)*RRAYAV)
4839 150 CONTINUE
4840 DO 155 I=MYIS,MYIE
4841 RRAY(I) = 0.104/(ONE+4.8*COSZRO(I))
4842 REFL2(I)= RRAY(I) + (ONE-RRAY(I))*(ONE-0.093)*ALVB(I)/ &
4843 (ONE-ALVD(I)*0.093)
4844 155 CONTINUE
4845 ! CALCULATE PRESSURE-WEIGHTED OPTICAL PATHS FOR EACH LAYER
4846 ! IN UNITS OF CM-ATM. PRESSURE WEIGHTING IS USING PR2.
4847 ! DU= VALUE FOR H2O;DUCO2 FOR CO2;DUO3 FOR O3.
4848 DO 160 K=1,L
4849 DO 160 I=MYIS,MYIE
4850 DU (I,K) = GINV*RH2O(I,K)*DP(I,K)*PR2(I,K)
4851 DUCO2(I,K) = (RRCO2*GINV*CFCO2)*DP(I,K)*PR2(I,K)
4852 DUO3 (I,K) = (GINV*CFO3)*QO3(I,K)*DP(I,K)
4853 160 CONTINUE
4854 !
4855 ! CALCULATE CLEAR SKY SW FLUX
4856 !
4857 ! OBTAIN THE OPTICAL PATH FROM THE TOP OF THE ATMOSPHERE TO THE
4858 ! FLUX PRESSURE. ANGULAR FACTORS ARE NOW INCLUDED. UD=DOWNWARD
4859 ! PATH FOR H2O,WIGTH UR THE UPWARD PATH FOR H2O. CORRESPONDING
4860 ! QUANTITIES FOR CO2,O3 ARE UDCO2/URCO2 AND UDO3/URO3.
4861 DO 200 IP=MYIS,MYIE
4862 UD (IP,1) = ZERO
4863 UDCO2(IP,1) = ZERO
4864 UDO3 (IP,1) = ZERO
4865 ! SH
4866 UO3 (IP,1) = UDO3 (IP,1)
4867 UCO2 (IP,1) = UDCO2(IP,1)
4869 200 CONTINUE
4870 DO 210 K=2,LP1
4871 DO 210 I=MYIS,MYIE
4872 UD (I,K) = UD (I,K-1)+DU (I,K-1)*SECZ(I)
4873 UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*SECZ(I)
4874 UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*SECZ(I)
4875 ! SH
4876 UO3 (I,K) = UDO3 (I,K)
4877 UCO2 (I,K) = UDCO2(I,K)
4879 210 CONTINUE
4880 DO 220 IP=MYIS,MYIE
4881 UR (IP,LP1) = UD (IP,LP1)
4882 URCO2(IP,LP1) = UDCO2(IP,LP1)
4883 URO3 (IP,LP1) = UDO3 (IP,LP1)
4884 ! SH
4885 UO3 (IP,LP1+LP1) = URO3 (IP,LP1)
4886 UCO2 (IP,LP1+LP1) = URCO2(IP,LP1)
4888 220 CONTINUE
4889 DO 230 K=L,1,-1
4890 DO 230 IP=MYIS,MYIE
4891 UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR
4892 URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR
4893 URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR
4894 ! SH
4895 UO3 (IP,LP1+K) = URO3 (IP,K)
4896 UCO2(IP,LP1+K) = URCO2(IP,K)
4898 230 CONTINUE
4899 ! CALCULATE CO2 ABSORPTIONS . THEY WILL BE USED IN NEAR INFRARED
4900 ! BANDS.SINCE THE ABSORPTION AMOUNT IS GIVEN (IN THE FORMULA USED
4901 ! BELOW, DERIVED FROM SASAMORI) IN TERMS OF THE TOTAL SOLAR FLUX,
4902 ! AND THE ABSORPTION IS ONLY INCLUDED IN THE NEAR IR (50 PERCENT
4903 ! OF THE SOLAR SPECTRUM), THE ABSORPTIONS ARE MULTIPLIED BY 2.
4904 ! SINCE CODE ACTUALLY REQUIRES TRANSMISSIONS, THESE ARE THE
4905 ! VALUES ACTUALLY STORED IN TCO2.
4906 DO 240 K=1,LL
4907 DO 240 I=MYIS,MYIE
4908 TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) &
4909 -H75826M4)
4910 240 CONTINUE
4912 ! SH
4913 DO 241 K=1,L
4914 DO 241 I=MYIS,MYIE
4915 TDCO2(I,K+1)=TCO2(I,K+1)
4916 241 CONTINUE
4917 DO 242 K=1,L
4918 DO 242 I=MYIS,MYIE
4919 TUCO2(I,K)=TCO2(I,LP1+K)
4920 242 CONTINUE
4922 ! NOW CALCULATE OZONE ABSORPTIONS. THESE WILL BE USED IN
4923 ! THE VISIBLE BAND.JUST AS IN THE CO2 CASE, SINCE THIS BAND IS
4924 ! 50 PERCENT OF THE SOLAR SPECTRUM,THE ABSORPTIONS ARE MULTIPLIED
4925 ! BY 2. THE TRANSMISSIONS ARE STORED IN TO3.
4926 HTEMP = H1036E2*H1036E2*H1036E2
4927 DO 250 K=1,LL
4928 DO 250 I=MYIS,MYIE
4929 TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* &
4930 (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ &
4931 H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ &
4932 H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1))))
4933 250 CONTINUE
4935 ! SH
4936 DO 251 K=1,L
4937 DO 251 I=MYIS,MYIE
4938 TDO3(I,K+1)=TO3(I,K+1)
4939 251 CONTINUE
4940 DO 252 K=1,L
4941 DO 252 I=MYIS,MYIE
4942 TUO3(I,K)=TO3(I,LP1+K)
4943 252 CONTINUE
4946 ! START FREQUENCY LOOP (ON N) HERE
4947 !
4948 !--- BAND 1 (VISIBLE) INCLUDES O3 AND H2O ABSORPTION
4949 DO 260 K=1,L
4950 DO 260 I=MYIS,MYIE
4951 TTD(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1)))
4952 TTU(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K)))
4953 DFN(I,K+1) = TTD(I,K+1)*TDO3(I,K+1)
4954 UFN(I,K) = TTU(I,K)*TUO3(I,K)
4955 260 CONTINUE
4956 DO 270 I=MYIS,MYIE
4957 DFN(I,1) = ONE
4958 UFN(I,LP1) = DFN(I,LP1)
4959 270 CONTINUE
4960 ! SCALE VISIBLE BAND FLUXES BY SOLAR FLUX AT THE TOP OF THE
4961 ! ATMOSPHERE (DFNTOP(I,1))
4962 ! DFSW/UFSW WILL BE THE FLUXES, SUMMED OVER ALL BANDS
4963 DO 280 K=1,LP1
4964 DO 280 I=MYIS,MYIE
4965 DFSWL(I,K) = DFN(I,K)*DFNTOP(I,1)
4966 UFSWL(I,K) = REFL(I)*UFN(I,K)*DFNTOP(I,1)
4967 280 CONTINUE
4968 DO 285 I=MYIS,MYIE
4969 GDFVB(I) = DFSWL(I,LP1)*EXP(-0.15746*SECZ(I))
4970 GDFVD(I) = ((ONE-REFL2(I))*DFSWL(I,LP1) - &
4971 (ONE-ALVB(I)) *GDFVB(I)) / (ONE-ALVD(I))
4972 GDFNB(I) = ZERO
4973 GDFND(I) = ZERO
4974 285 CONTINUE
4975 !---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME
4976 ! AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND
4977 ! TRANSMISSION COEFFICIENTS (OBTAINED BELOW) ARE DIFFERENT, AS
4978 ! RAYLEIGH SCATTERING NEED NOT BE CONSIDERED.
4979 DO 350 N=2,NB
4980 IF (N.EQ.2) THEN
4981 ! THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO
4982 ! THAT OF BAND 1 (SAVED AS TTD,TTU)
4983 !--- BAND 2-9 (NEAR-IR) INCLUDES O3, CO2 AND H2O ABSORPTION
4984 DO 290 K=1,L
4985 DO 290 I=MYIS,MYIE
4986 DFN(I,K+1) = TTD(I,K+1)*TDCO2(I,K+1)
4987 UFN(I,K) = TTU(I,K)*TUCO2(I,K)
4988 290 CONTINUE
4989 ELSE
4990 ! CALCULATE WATER VAPOR TRANSMISSION FUNCTIONS FOR NEAR INFRARED
4991 ! BANDS. INCLUDE CO2 TRANSMISSION (TDCO2/TUCO2), WHICH
4992 ! IS THE SAME FOR ALL INFRARED BANDS.
4993 DO 300 K=1,L
4994 DO 300 I=MYIS,MYIE
4995 DFN(I,K+1)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,K+1))) &
4996 *TDCO2(I,K+1)
4997 UFN(I,K)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,K))) &
4998 *TUCO2(I,K)
4999 300 CONTINUE
5000 ENDIF
5001 !---AT THIS POINT,INCLUDE DFN(1),UFN(LP1), NOTING THAT DFN(1)=1 FOR
5002 ! ALL BANDS, AND THAT UFN(LP1)=DFN(LP1) FOR ALL BANDS.
5003 DO 310 I=MYIS,MYIE
5004 DFN(I,1) = ONE
5005 UFN(I,LP1) = DFN(I,LP1)
5006 310 CONTINUE
5007 ! SCALE THE PREVIOUSLY COMPUTED FLUXES BY THE FLUX AT THE TOP
5008 ! AND SUM OVER BANDS
5009 DO 320 K=1,LP1
5010 DO 320 I=MYIS,MYIE
5011 DFSWL(I,K) = DFSWL(I,K) + DFN(I,K)*DFNTOP(I,N)
5012 UFSWL(I,K) = UFSWL(I,K) + ALNB(I)*UFN(I,K)*DFNTOP(I,N)
5013 320 CONTINUE
5014 DO 330 I=MYIS,MYIE
5015 GDFNB(I) = GDFNB(I) + DFN(I,LP1)*DFNTOP(I,N)
5016 330 CONTINUE
5017 350 CONTINUE
5018 DO 360 K=1,LP1
5019 DO 360 I=MYIS,MYIE
5020 FSWL(I,K) = UFSWL(I,K)-DFSWL(I,K)
5021 360 CONTINUE
5022 DO 370 K=1,L
5023 DO 370 I=MYIS,MYIE
5024 HSWL(I,K)=RADCON*(FSWL(I,K+1)-FSWL(I,K))/DP(I,K)
5025 370 CONTINUE
5026 !
5027 !---END OF FREQUENCY LOOP (OVER N)
5028 !
5029 ! CALCULATE CLOUDY SKY SW FLUX
5030 !
5031 KCLDS=NCLDS(MYIS)
5032 DO 400 I=MYIS1,MYIE
5033 KCLDS=MAX(NCLDS(I),KCLDS)
5034 400 CONTINUE
5035 DO 410 K=1,LP1
5036 DO 410 I=MYIS,MYIE
5037 DFSWC(I,K) = DFSWL(I,K)
5038 UFSWC(I,K) = UFSWL(I,K)
5039 FSWC (I,K) = FSWL (I,K)
5040 410 CONTINUE
5041 DO 420 K=1,L
5042 DO 420 I=MYIS,MYIE
5043 HSWC(I,K) = HSWL(I,K)
5044 420 CONTINUE
5045 !*******************************************************************
5046 IF (KCLDS .EQ. 0) RETURN
5047 !*******************************************************************
5048 DO 430 K=1,LP1
5049 DO 430 I=MYIS,MYIE
5050 XAMT(I,K) = CAMT(I,K)
5051 430 CONTINUE
5052 DO 470 I=MYIS,MYIE
5053 NNCLDS = NCLDS(I)
5054 CCMAX(I) = ZERO
5055 IF (NNCLDS .LE. 0) GO TO 470
5056 CCMAX(I) = ONE
5057 DO 450 K=1,NNCLDS
5058 CCMAX(I) = CCMAX(I) * (ONE - CAMT(I,K+1))
5059 450 CONTINUE
5060 CCMAX(I) = ONE - CCMAX(I)
5061 IF (CCMAX(I) .GT. ZERO) THEN
5062 DO 460 K=1,NNCLDS
5063 XAMT(I,K+1) = CAMT(I,K+1)/CCMAX(I)
5064 460 CONTINUE
5065 END IF
5066 470 CONTINUE
5067 DO 480 K=1,LP1
5068 DO 480 I=MYIS,MYIE
5069 FF (I,K) = DIFFCTR
5070 FFCO2(I,K) = DIFFCTR
5071 FFO3 (I,K) = O3DIFCTR
5072 480 CONTINUE
5073 DO 490 IP=MYIS,MYIE
5074 JTOP = KTOPSW(IP,NCLDS(IP)+1)
5075 DO 490 K=1,JTOP
5076 FF (IP,K) = SECZ(IP)
5077 FFCO2(IP,K) = SECZ(IP)
5078 FFO3 (IP,K) = SECZ(IP)
5079 490 CONTINUE
5080 DO 500 I=MYIS,MYIE
5081 RRAY(I) = HP219/(ONE+HP816*COSZRO(I))
5082 REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVD(I)/ &
5083 (ONE-ALVD(I)*RRAYAV)
5084 500 CONTINUE
5085 DO 510 IP=MYIS,MYIE
5086 UD (IP,1) = ZERO
5087 UDCO2(IP,1) = ZERO
5088 UDO3 (IP,1) = ZERO
5089 ! SH
5090 UO3 (IP,1) = UDO3 (IP,1)
5091 UCO2 (IP,1) = UDCO2(IP,1)
5093 510 CONTINUE
5094 DO 520 K=2,LP1
5095 DO 520 I=MYIS,MYIE
5096 UD (I,K) = UD (I,K-1)+DU (I,K-1)*FF (I,K)
5097 UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*FFCO2(I,K)
5098 UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*FFO3 (I,K)
5099 ! SH
5100 UO3 (I,K) = UDO3 (I,K)
5101 UCO2(I,K) = UDCO2(I,K)
5103 520 CONTINUE
5104 DO 530 IP=MYIS,MYIE
5105 UR (IP,LP1) = UD (IP,LP1)
5106 URCO2(IP,LP1) = UDCO2(IP,LP1)
5107 URO3 (IP,LP1) = UDO3 (IP,LP1)
5108 ! SH
5109 UO3 (IP,LP1+LP1) = URO3 (IP,LP1)
5110 UCO2 (IP,LP1+LP1) = URCO2(IP,LP1)
5112 530 CONTINUE
5113 DO 540 K=L,1,-1
5114 DO 540 IP=MYIS,MYIE
5115 UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR
5116 URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR
5117 URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR
5118 ! SH
5119 UO3 (IP,LP1+K) = URO3 (IP,K)
5120 UCO2(IP,LP1+K) = URCO2(IP,K)
5122 540 CONTINUE
5123 DO 550 K=1,LL
5124 DO 550 I=MYIS,MYIE
5125 TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) &
5126 -H75826M4)
5127 550 CONTINUE
5128 ! SH
5129 DO 551 K=1,L
5130 DO 551 I=MYIS,MYIE
5131 TDCO2(I,K+1)=TCO2(I,K+1)
5132 551 CONTINUE
5133 DO 552 K=1,L
5134 DO 552 I=MYIS,MYIE
5135 TUCO2(I,K)=TCO2(I,LP1+K)
5136 552 CONTINUE
5138 DO 560 K=1,LL
5139 DO 560 I=MYIS,MYIE
5140 TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* &
5141 (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ &
5142 H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ &
5143 H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1))))
5144 560 CONTINUE
5145 ! SH
5146 DO 561 K=1,L
5147 DO 561 I=MYIS,MYIE
5148 TDO3(I,K+1)=TO3(I,K+1)
5149 561 CONTINUE
5150 DO 562 K=1,L
5151 DO 562 I=MYIS,MYIE
5152 TUO3(I,K)=TO3(I,LP1+K)
5153 562 CONTINUE
5155 !********************************************************************
5156 !---THE FIRST CLOUD IS THE GROUND; ITS PROPERTIES ARE GIVEN
5157 ! BY REFL (THE TRANSMISSION (0) IS IRRELEVANT FOR NOW!).
5158 !********************************************************************
5159 DO 570 I=MYIS,MYIE
5160 CR(I,1) = REFL(I)
5161 570 CONTINUE
5162 !***OBTAIN CLOUD REFLECTION AND TRANSMISSION COEFFICIENTS FOR
5163 ! REMAINING CLOUDS (IF ANY) IN THE VISIBLE BAND
5164 !---THE MAXIMUM NO OF CLOUDS IN THE ROW (KCLDS) IS USED. THIS CREATES
5165 ! EXTRA WORK (MAY BE REMOVED IN A SUBSEQUENT UPDATE).
5166 DO 581 I=MYIS,MYIE
5167 KCLDS=NCLDS(I)
5168 IF(KCLDS.EQ.0) GO TO 581
5169 DO 580 KK=2,KCLDS+1
5170 CR(I,KK) = CRR(I,1,KK)*XAMT(I,KK)
5171 CT(I,KK) = ONE - (ONE-CTT(I,1,KK))*XAMT(I,KK)
5172 580 CONTINUE
5173 581 CONTINUE
5174 !---OBTAIN THE PRESSURE AT THE TOP,BOTTOM AND THE THICKNESS OF
5175 ! "THICK" CLOUDS (THOSE AT LEAST 2 LAYERS THICK). THIS IS USED
5176 ! LATER IS OBTAINING FLUXES INSIDE THE THICK CLOUDS, FOR ALL
5177 ! FREQUENCY BANDS.
5178 DO 591 I=MYIS,MYIE
5179 KCLDS=NCLDS(I)
5180 IF(KCLDS.EQ.0) GO TO 591
5181 DO 590 KK=1,KCLDS
5182 IF ((KBTMSW(I,KK+1)-1).GT.KTOPSW(I,KK+1)) THEN
5183 PPTOP(I,KK)=PP(I,KTOPSW(I,KK+1))
5184 DPCLD(I,KK)=ONE/(PPTOP(I,KK)-PP(I,KBTMSW(I,KK+1)))
5185 ENDIF
5186 590 CONTINUE
5187 591 CONTINUE
5188 DO 600 K=1,L
5189 DO 600 I=MYIS,MYIE
5190 TTDB1(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1)))
5191 TTUB1(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K)))
5192 TTD (I,K+1) = TTDB1(I,K+1)*TDO3(I,K+1)
5193 TTU (I,K) = TTUB1(I,K)*TUO3(I,K)
5194 600 CONTINUE
5195 DO 610 I=MYIS,MYIE
5196 TTD(I,1) = ONE
5197 TTU(I,LP1) = TTD(I,LP1)
5198 610 CONTINUE
5199 !***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT
5200 ! TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR
5201 ! EACH BAND N. THE REQUIRED QUANTITIES ARE:
5202 ! TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5203 ! TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5204 ! TTD(I,KBTMSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5205 ! AND INVERSES OF THE FIRST TWO. THE ABOVE QUANTITIES ARE
5206 ! STORED IN TDCL1,TUCL1,TDCL2, AND DFNTRN,UFNTRN, RESPECTIVELY,
5207 ! AS THEY HAVE MULTIPLE USE IN THE PGM.
5208 !---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN:
5209 DO 620 I=MYIS,MYIE
5210 TDCL1 (I,1) = TTD(I,LP1)
5211 TUCL1 (I,1) = TTU(I,LP1)
5212 TDCL2 (I,1) = TDCL1(I,1)
5213 DFNTRN(I,1) = ONE/TDCL1(I,1)
5214 UFNTRN(I,1) = DFNTRN(I,1)
5215 620 CONTINUE
5216 DO 631 I=MYIS,MYIE
5217 KCLDS=NCLDS(I)
5218 IF(KCLDS.EQ.0) GO TO 631
5219 DO 630 KK=2,KCLDS+1
5220 TDCL1(I,KK) = TTD(I,KTOPSW(I,KK))
5221 TUCL1(I,KK) = TTU(I,KTOPSW(I,KK))
5222 TDCL2(I,KK) = TTD(I,KBTMSW(I,KK))
5223 630 CONTINUE
5224 631 CONTINUE
5225 !---COMPUTE INVERSES
5226 DO 641 I=MYIS,MYIE
5227 KCLDS=NCLDS(I)
5228 IF(KCLDS.EQ.0) GO TO 641
5229 ! SH
5230 DO 640 KK=2,KCLDS+1
5231 DFNTRN(I,KK) = ONE/TDCL1(I,KK)
5232 UFNTRN(I,KK) = ONE/TUCL1(I,KK)
5233 640 CONTINUE
5234 641 CONTINUE
5235 !---COMPUTE THE TRANSMISSIVITY FROM THE TOP OF CLOUD (K+1) TO THE
5236 ! TOP OF CLOUD (K). THE CLOUD TRANSMISSION (CT) IS INCLUDED. THIS
5237 ! QUANTITY IS CALLED TCLU (INDEX K). ALSO, OBTAIN THE TRANSMISSIVITY
5238 ! FROM THE BOTTOM OF CLOUD (K+1) TO THE TOP OF CLOUD (K)(A PATH
5239 ! ENTIRELY OUTSIDE CLOUDS). THIS QUANTITY IS CALLED TCLD (INDEX K).
5240 DO 651 I=MYIS,MYIE
5241 KCLDS=NCLDS(I)
5242 IF(KCLDS.EQ.0) GO TO 651
5243 DO 650 KK=1,KCLDS
5244 TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1)
5245 TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1)
5246 650 CONTINUE
5247 651 CONTINUE
5248 !***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION
5249 ! COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE
5250 ! FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW
5251 ! THE CLOUD IN QUESTION.
5252 !---ALFAU IS ALFA WITHOUT THE REFLECTION OF THE CLOUD IN QUESTION
5253 DO 660 I=MYIS,MYIE
5254 KCLDS=NCLDS(I)
5255 IF(KCLDS.EQ.0) GO TO 660
5256 ALFA (I,1)=CR(I,1)
5257 ALFAU(I,1)=ZERO
5258 660 CONTINUE
5259 !---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER!
5260 DO 671 I=MYIS,MYIE
5261 KCLDS=NCLDS(I)
5262 IF(KCLDS.EQ.0) GO TO 671
5263 DO 670 KK=2,KCLDS+1
5264 ALFAU(I,KK)= TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/ &
5265 (ONE - TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK))
5266 ALFA (I,KK)= ALFAU(I,KK)+CR(I,KK)
5267 670 CONTINUE
5268 671 CONTINUE
5269 ! CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS
5270 !---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP
5271 ! OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX
5272 ! AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IN THE FIRST
5273 ! CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE
5274 ! HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU
5275 ! EQUALS ALFA. THIS IS ALSO CORRECT.
5276 DO 680 I=MYIS,MYIE
5277 KCLDS=NCLDS(I)
5278 IF(KCLDS.EQ.0) GO TO 680
5279 UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1)
5280 DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1)
5281 680 CONTINUE
5282 !---THIS CALCULATION IS THE REVERSE OF THE RECURSION RELATION USED
5283 ! ABOVE
5284 DO 691 I=MYIS,MYIE
5285 KCLDS=NCLDS(I)
5286 IF(KCLDS.EQ.0) GO TO 691
5287 DO 690 KK=KCLDS,1,-1
5288 UFNCLU(I,KK) = UFNCLU(I,KK+1)*ALFAU(I,KK+1)/(ALFA(I,KK+1)* &
5289 TCLU(I,KK))
5290 DFNCLU(I,KK) = UFNCLU(I,KK)/ALFA(I,KK)
5291 690 CONTINUE
5292 691 CONTINUE
5293 DO 701 I=MYIS,MYIE
5294 KCLDS=NCLDS(I)
5295 IF(KCLDS.EQ.0) GO TO 701
5296 DO 700 KK=1,KCLDS+1
5297 UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK)
5298 DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK)
5299 700 CONTINUE
5300 701 CONTINUE
5301 !---CASE OF KK=1( FROM THE GROUND TO THE BOTTOM OF THE LOWEST CLOUD)
5302 DO 720 I=MYIS,MYIE
5303 KCLDS=NCLDS(I)
5304 IF(KCLDS.EQ.0) GO TO 720
5305 J2=KBTMSW(I,2)
5306 DO 710 K=J2,LP1
5307 UFN(I,K) = UFNTRN(I,1)*TTU(I,K)
5308 DFN(I,K) = DFNTRN(I,1)*TTD(I,K)
5309 710 CONTINUE
5310 720 CONTINUE
5311 !---REMAINING LEVELS (IF ANY!)
5312 DO 760 I=MYIS,MYIE
5313 KCLDS=NCLDS(I)
5314 IF(KCLDS.EQ.0) GO TO 760
5315 DO 755 KK=2,KCLDS+1
5316 J1=KTOPSW(I,KK)
5317 J2=KBTMSW(I,KK+1)
5318 IF (J1.EQ.1) GO TO 755
5319 DO 730 K=J2,J1
5320 UFN(I,K) = UFNTRN(I,KK)*TTU(I,K)
5321 DFN(I,K) = DFNTRN(I,KK)*TTD(I,K)
5322 730 CONTINUE
5323 !---FOR THE THICK CLOUDS, THE FLUX DIVERGENCE THROUGH THE CLOUD
5324 ! LAYER IS ASSUMED TO BE CONSTANT. THE FLUX DERIVATIVE IS GIVEN BY
5325 ! TEMPF (FOR THE UPWARD FLUX) AND TEMPG (FOR THE DOWNWARD FLUX).
5326 J3=KBTMSW(I,KK)
5327 IF ((J3-J1).GT.1) THEN
5328 TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1)
5329 TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1)
5330 DO 740 K=J1+1,J3-1
5331 UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1))
5332 DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1))
5333 740 CONTINUE
5334 ENDIF
5335 755 CONTINUE
5336 760 CONTINUE
5337 DO 770 I=MYIS,MYIE
5338 KCLDS=NCLDS(I)
5339 IF(KCLDS.EQ.0) GO TO 770
5340 DO 771 K=1,LP1
5341 DFSWC(I,K) = DFN(I,K)*DFNTOP(I,1)
5342 UFSWC(I,K) = UFN(I,K)*DFNTOP(I,1)
5343 771 CONTINUE
5344 770 CONTINUE
5345 DO 780 I=MYIS,MYIE
5346 KCLDS=NCLDS(I)
5347 IF(KCLDS.EQ.0) GO TO 780
5348 TMP1(I) = ONE - CCMAX(I)
5349 GDFVB(I) = TMP1(I)*GDFVB(I)
5350 GDFNB(I) = TMP1(I)*GDFNB(I)
5351 GDFVD(I) = TMP1(I)*GDFVD(I) + CCMAX(I)*DFSWC(I,LP1)
5352 780 CONTINUE
5353 !---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME
5354 ! AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND
5355 ! TRANSMISSION COEFFICIENTS ARE DIFFERENT, AS
5356 ! RAYLEIGH SCATTERING NEED NOT BE CONSIDERED.
5357 !
5358 DO 1000 N=2,NB
5359 !YH93
5360 DO 791 I=MYIS,MYIE
5361 KCLDS=NCLDS(I)
5362 IF(KCLDS.EQ.0) GO TO 791
5363 DO 790 K=1,KCLDS+1
5364 CR(I,K) = CRR(I,N,K)*XAMT(I,K)
5365 CT(I,K) = ONE - (ONE-CTT(I,N,K))*XAMT(I,K)
5366 790 CONTINUE
5367 791 CONTINUE
5368 !YH93
5369 IF (N.EQ.2) THEN
5370 ! THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO
5371 ! THAT OF BAND 1 (SAVED AS TTDB1,TTUB1)
5372 DO 800 I=MYIS,MYIE
5373 KCLDS=NCLDS(I)
5374 IF(KCLDS.EQ.0) GO TO 800
5375 DO 801 KK=2,LP1
5376 TTD(I,KK) = TTDB1(I,KK)*TDCO2(I,KK)
5377 801 CONTINUE
5378 DO 802 KK=1,L
5379 TTU(I,KK) = TTUB1(I,KK)*TUCO2(I,KK)
5380 802 CONTINUE
5381 800 CONTINUE
5382 ELSE
5383 DO 810 I=MYIS,MYIE
5384 KCLDS=NCLDS(I)
5385 IF(KCLDS.EQ.0) GO TO 810
5386 DO 811 KK=2,LP1
5387 TTD(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,KK))) &
5388 * TDCO2(I,KK)
5389 811 CONTINUE
5390 DO 812 KK=1,L
5391 TTU(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,KK))) &
5392 * TUCO2(I,KK)
5393 812 CONTINUE
5394 810 CONTINUE
5395 ENDIF
5396 !---AT THIS POINT,INCLUDE TTD(1),TTU(LP1), NOTING THAT TTD(1)=1 FOR
5397 ! ALL BANDS, AND THAT TTU(LP1)=TTD(LP1) FOR ALL BANDS.
5398 DO 820 I=MYIS,MYIE
5399 KCLDS=NCLDS(I)
5400 IF(KCLDS.EQ.0) GO TO 820
5401 TTU(I,LP1) = TTD(I,LP1)
5402 TTD(I,1) = ONE
5403 820 CONTINUE
5404 !***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT
5405 ! TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR
5406 ! EACH BAND N. THE REQUIRED QUANTITIES ARE:
5407 ! TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5408 ! TTD(I,KBTMSW(I,K),N) K RUNS FROM 2 TO NCLDS(I)+1:
5409 ! TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5410 ! AND INVERSES OF THE ABOVE. THE ABOVE QUANTITIES ARE STORED
5411 ! IN TDCL1,TDCL2,TUCL1,AND DFNTRN,UFNTRN,RESPECTIVELY, AS
5412 ! THEY HAVE MULTIPLE USE IN THE PGM.
5413 !---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN:
5414 DO 830 I=MYIS,MYIE
5415 KCLDS=NCLDS(I)
5416 IF(KCLDS.EQ.0) GO TO 830
5417 TDCL1 (I,1) = TTD(I,LP1)
5418 TUCL1 (I,1) = TTU(I,LP1)
5419 TDCL2 (I,1) = TDCL1(I,1)
5420 DFNTRN(I,1) = ONE/TDCL1(I,1)
5421 UFNTRN(I,1) = DFNTRN(I,1)
5422 830 CONTINUE
5423 DO 841 I=MYIS,MYIE
5424 KCLDS=NCLDS(I)
5425 IF(KCLDS.EQ.0) GO TO 841
5426 DO 840 KK=2,KCLDS+1
5427 TDCL1(I,KK) = TTD(I,KTOPSW(I,KK))
5428 TUCL1(I,KK) = TTU(I,KTOPSW(I,KK))
5429 TDCL2(I,KK) = TTD(I,KBTMSW(I,KK))
5430 840 CONTINUE
5431 841 CONTINUE
5432 DO 851 I=MYIS,MYIE
5433 KCLDS=NCLDS(I)
5434 IF(KCLDS.EQ.0) GO TO 851
5435 DO 850 KK=2,KCLDS+1
5436 DFNTRN(I,KK) = ONE/TDCL1(I,KK)
5437 UFNTRN(I,KK) = ONE/TUCL1(I,KK)
5438 850 CONTINUE
5439 851 CONTINUE
5440 DO 861 I=MYIS,MYIE
5441 KCLDS=NCLDS(I)
5442 IF(KCLDS.EQ.0) GO TO 861
5443 DO 860 KK=1,KCLDS
5444 TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1)
5445 TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1)
5446 860 CONTINUE
5447 861 CONTINUE
5448 !***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION
5449 ! COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE
5450 ! FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW
5451 ! THE CLOUD IN QUESTION.
5452 DO 870 I=MYIS,MYIE
5453 KCLDS=NCLDS(I)
5454 IF(KCLDS.EQ.0) GO TO 870
5455 ALFA (I,1) = CR(I,1)
5456 ALFAU(I,1) = ZERO
5457 870 CONTINUE
5458 !---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER!
5459 DO 881 I=MYIS,MYIE
5460 KCLDS=NCLDS(I)
5461 IF(KCLDS.EQ.0) GO TO 881
5462 DO 880 KK=2,KCLDS+1
5463 ALFAU(I,KK) = TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/(ONE - &
5464 TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK))
5465 ALFA (I,KK) = ALFAU(I,KK)+CR(I,KK)
5466 880 CONTINUE
5467 881 CONTINUE
5468 ! CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS
5469 !---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP
5470 ! OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX
5471 ! AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IT THE FIRST
5472 ! CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE
5473 ! HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU
5474 ! EQUALS ALFA. THIS IS ALSO CORRECT.
5475 DO 890 I=MYIS,MYIE
5476 KCLDS=NCLDS(I)
5477 IF(KCLDS.EQ.0) GO TO 890
5478 UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1)
5479 DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1)
5480 890 CONTINUE
5481 DO 901 I=MYIS,MYIE
5482 KCLDS=NCLDS(I)
5483 IF(KCLDS.EQ.0) GO TO 901
5484 DO 900 KK=KCLDS,1,-1
5485 !
5486 !*** ACCOUNT FOR UNREALISTICALLY SMALL CLOUD AMOUNT
5487 !
5488 DENOM=ALFA(I,KK+1)*TCLU(I,KK)
5489 IF(DENOM.GT.RTHRESH)THEN
5490 UFNCLU(I,KK)=UFNCLU(I,KK+1)*ALFAU(I,KK+1)/DENOM
5491 ELSE
5492 UFNCLU(I,KK)=0.
5493 ENDIF
5494 IF(ALFA(I,KK).GT.RTHRESH)THEN
5495 DFNCLU(I,KK)=UFNCLU(I,KK)/ALFA(I,KK)
5496 ELSE
5497 DFNCLU(I,KK)=0.
5498 ENDIF
5499 900 CONTINUE
5500 901 CONTINUE
5501 ! NOW OBTAIN DFN AND UFN FOR LEVELS BETWEEN THE CLOUDS
5502 DO 911 I=MYIS,MYIE
5503 KCLDS=NCLDS(I)
5504 IF(KCLDS.EQ.0) GO TO 911
5505 DO 910 KK=1,KCLDS+1
5506 UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK)
5507 DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK)
5508 910 CONTINUE
5509 911 CONTINUE
5510 DO 930 I=MYIS,MYIE
5511 KCLDS=NCLDS(I)
5512 IF(KCLDS.EQ.0) GO TO 930
5513 J2=KBTMSW(I,2)
5514 DO 920 K=J2,LP1
5515 UFN(I,K) = UFNTRN(I,1)*TTU(I,K)
5516 DFN(I,K) = DFNTRN(I,1)*TTD(I,K)
5517 920 CONTINUE
5518 930 CONTINUE
5519 DO 970 I=MYIS,MYIE
5520 KCLDS=NCLDS(I)
5521 IF(KCLDS.EQ.0) GO TO 970
5522 DO 965 KK=2,KCLDS+1
5523 J1 = KTOPSW(I,KK)
5524 J2 = KBTMSW(I,KK+1)
5525 IF (J1.EQ.1) GO TO 965
5526 DO 940 K=J2,J1
5527 UFN(I,K) = UFNTRN(I,KK)*TTU(I,K)
5528 DFN(I,K) = DFNTRN(I,KK)*TTD(I,K)
5529 940 CONTINUE
5530 J3 = KBTMSW(I,KK)
5531 IF ((J3-J1).GT.1) THEN
5532 TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1)
5533 TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1)
5534 DO 950 K=J1+1,J3-1
5535 UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1))
5536 DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1))
5537 950 CONTINUE
5538 ENDIF
5539 965 CONTINUE
5540 970 CONTINUE
5541 DO 980 I=MYIS,MYIE
5542 KCLDS=NCLDS(I)
5543 IF(KCLDS.EQ.0) GO TO 980
5544 DO 981 K=1,LP1
5545 DFSWC(I,K) = DFSWC(I,K) + DFN(I,K)*DFNTOP(I,N)
5546 UFSWC(I,K) = UFSWC(I,K) + UFN(I,K)*DFNTOP(I,N)
5547 981 CONTINUE
5548 980 CONTINUE
5549 DO 990 I=MYIS,MYIE
5550 KCLDS=NCLDS(I)
5551 IF(KCLDS.EQ.0) GO TO 990
5552 GDFND(I) = GDFND(I) + CCMAX(I)*DFN(I,LP1)*DFNTOP(I,N)
5553 990 CONTINUE
5554 1000 CONTINUE
5555 DO 1100 I=MYIS,MYIE
5556 KCLDS=NCLDS(I)
5557 IF(KCLDS.EQ.0) GO TO 1100
5558 DO 1101 K=1,LP1
5559 DFSWC(I,K) = TMP1(I)*DFSWL(I,K) + CCMAX(I)*DFSWC(I,K)
5560 UFSWC(I,K) = TMP1(I)*UFSWL(I,K) + CCMAX(I)*UFSWC(I,K)
5561 1101 CONTINUE
5562 1100 CONTINUE
5563 DO 1200 I=MYIS,MYIE
5564 KCLDS=NCLDS(I)
5565 IF(KCLDS.EQ.0) GO TO 1200
5566 DO 1201 KK=1,LP1
5567 FSWC(I,KK) = UFSWC(I,KK)-DFSWC(I,KK)
5568 1201 CONTINUE
5569 1200 CONTINUE
5570 DO 1250 I=MYIS,MYIE
5571 KCLDS=NCLDS(I)
5572 IF(KCLDS.EQ.0) GO TO 1250
5573 DO 1251 KK=1, L
5574 HSWC(I,KK) = RADCON*(FSWC(I,KK+1)-FSWC(I,KK))/DP(I,KK)
5575 1251 CONTINUE
5576 1250 CONTINUE
5578 END SUBROUTINE SWR93
5579 !-----------------------------------------------------------------------
5581 SUBROUTINE RADFS &
5583 ! *****************************************************************
5584 ! * *
5585 ! * THE INTERNAL DRIVE FOR GFDL RADIATION *
5586 ! * THIS SUBROUTINE WAS FROM Y.H AND K.A.C (1993) *
5587 ! * AND MODIFIED BY Q. ZHAO FOR USE IN THE ETA MODEL *
5588 ! * NOV. 18, 1993 *
5589 ! * *
5590 ! * UPDATE: THIS SUBROUTINE WAS MODIFIED TO USE CLOUD FRACTION *
5591 ! * ON EACH MODEL LAYER. *
5592 ! * QINGYUN ZHAO 95-3-22 *
5593 ! * *
5594 ! * UPDATE: R1 HAS BEEN ADDED TO THE INPUTS FROM RADTN TO *
5595 ! * COMPUTE THE VARIATION OF SOLAR CONSTANT AT THE TOP *
5596 ! * OF ATMOSPHERE WITH JULIAN DAY IN A YEAR. *
5597 ! * QINGYUN ZHAO 96-7-23 *
5598 ! *****************************************************************
5599 !***
5600 !*** REQUIRED INPUT:
5601 !***
5602 (QS,PP,PPI,QQH2O,TT,O3QO3,TSFC,SLMSK,ALBEDO,XLAT &
5603 , CAMT,KTOP,KBTM,NCLDS,EMCLD,RRCL,TTCL &
5604 , COSZRO,TAUDAR,IBEG &
5605 , KO3,KALB &
5606 , ITIMSW,ITIMLW &
5607 !***************************************************************************
5608 !* IX IS THE LENGTH OF A ROW IN THE DOMAIN
5609 !
5610 !* QS(IX): THE SURFACE PRESSURE (PA)
5611 !* PP(IX,L): THE MIDLAYER PRESSURES (PA) (L IS THE VERT. DIMEN.)
5612 !* PPI(IX,LP1) THE INTERFACE PRESSURES (PA)
5613 !* QQH2O(IX,L): THE MIDLAYER WATER VAPOR MIXING RATIO (KG/KG)
5614 !* TT(IX,L): THE MIDLAYER TEMPERATURE (K)
5615 !* O3QO3(IX,L): THE MIDLAYER OZONE MIXING RATIO
5616 !* TSFC(IX): THE SKIN TEMP. (K); NEGATIVE OVER WATER
5617 !* SLMSK(IX): THE SEA MASK (LAND=0,SEA=1)
5618 !* ALBEDO(IX): THE SURFACE ALBEDO (EXPRESSED AS A FRACTION)
5619 !* XLAT(IX): THE GEODETIC LATITUDES OF EACH COLUMN IN DEGREES
5620 !* (N.H.> 0)
5621 !* THE FOLLOWING ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
5622 !* LAYER=1:SURFACE
5623 !* LAYER=2:FIRST LAYER ABOVE GROUND, AND SO ON
5624 !* CAMT(IX,LP1): CLOUD FRACTION OF EACH CLOUD LAYER
5625 !* ITYP(IX,LP1): CLOUD TYPE(=1: STRATIFORM, =2:CONVECTIVE)
5626 !* KTOP(IX,LP1): HEIGHT OF CLOUD TOP OF EACH CLOUD LAYER (IN ETA LEVEL)
5627 !* KBTM(IX,LP1): BOTTOM OF EACH CLOUD LAYER
5628 !* NCLDS(IX): NUMBER OF CLOUD LAYERS
5629 !* EMCLD(IX,LP1): CLOUD EMISSIVITY
5630 !* RRCL(IX,NB,LP1) CLOUD REFLECTTANCES FOR SW SPECTRAL BANDS
5631 !* TTCL(IX,NB,LP1) CLOUD TRANSMITANCES FOR SW SPECTRAL BANDS
5632 !* THE ABOVE ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
5633 !*
5634 !* COSZRO(IX): THE COSINE OF THE SOLAR ZENITH ANGLE
5635 !* TAUDAR: =1.0
5636 !* IBEG: =1
5637 !* KO3: =1 ( READ IN THE QZONE DATA)
5638 !* KALB: =0
5639 !* SLMRF(LP1): THE INTERFACE'S ETA (LP1=L+1)
5640 !* SLYMRF(L): THE MIDLAYER ETA
5641 !* ITIMSW: =1/0 (SHORTWAVE CALC. ARE DESIRED/NOT DESIRED)
5642 !* ITIMLW: =1/0 (LONGWAVE CALC. ARE DESIRED/NOT DESIRED)
5643 !************************************************************************
5644 !***
5645 !*** THE FOLLOWING ARE ADDITIONAL FOR ETA MODEL
5646 !***
5647 , JD,GMT &
5648 !**************************************************************************
5649 !* JD: JULIAN DAY IN A YEAR
5650 !* R1: THE NON-DIMENSIONAL SUN-EARTH DISTANCE
5651 !* GMT:HOUR
5652 !**************************************************************************
5653 !***
5654 !*** GENERATED OUTPUT REQUIRED BY THE ETA MODEL
5655 !***
5656 , SWH,HLW &
5657 ! , T1,T2,T4,EM1V,EM1VW,EM3V &
5658 , FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS &
5659 ! , DDUO3N,DDO3N2,DDO3N3,DDO3N4 &
5660 ! , SKO3R,AB15WD,SKC1R,SKO2D &
5661 , ids,ide, jds,jde, kds,kde &
5662 , ims,ime, jms,jme, kms,kme &
5663 , its,ite, jts,jte, kts,kte )
5664 !************************************************************************
5665 !* SWH: ATMOSPHERIC SHORTWAVE HEATING RATES IN K/S.
5666 !* SWH IS A REAL ARRAY DIMENSIONED (NCOL X LM).
5667 !* HLW: ATMOSPHERIC LONGWAVE HEATING RATES IN K/S.
5668 !* HLW IS A REAL ARRAY DIMENSIONED (NCOL X LM).
5669 !* FLWUP: UPWARD LONGWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5670 !* FLWUP IS A REAL ARRAY DIMENSIONED (NCOL).
5671 !* FSWUP: UPWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5672 !* FSWUP IS A REAL ARRAY DIMENSIONED (NCOL).
5673 !* FSWDN: DOWNWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5674 !* FSWDN IS A REAL ARRAY DIMENSIONED (NCOL).
5675 !* FSWDNS: DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5676 !* FSWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
5677 !* FSWUPS: UPWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5678 !* FSWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
5679 !* FLWDNS: DOWNWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
5680 !* FLWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
5681 !* FLWUPS: UPWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
5682 !* FLWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
5683 !************************************************************************
5684 !***
5685 !*** THE FOLLOWING OUTPUTS ARE NOT REQUIRED BY THE ETA MODEL
5686 !***
5687 !----------------------------------------------------------------------
5688 IMPLICIT NONE
5689 !----------------------------------------------------------------------
5690 !INTEGER, PARAMETER :: NBLY=15
5691 INTEGER, PARAMETER :: NB=12
5692 INTEGER, PARAMETER :: NBLX=47
5693 INTEGER , PARAMETER:: NBLW = 163
5695 REAL,PARAMETER :: AMOLWT=28.9644
5696 REAL,PARAMETER :: CSUBP=1.00484E7
5697 REAL,PARAMETER :: DIFFCTR=1.66
5698 REAL,PARAMETER :: G=980.665
5699 REAL,PARAMETER :: GINV=1./G
5700 REAL,PARAMETER :: GRAVDR=980.0
5701 REAL,PARAMETER :: O3DIFCTR=1.90
5702 REAL,PARAMETER :: P0=1013250.
5703 REAL,PARAMETER :: P0INV=1./P0
5704 REAL,PARAMETER :: GP0INV=GINV*P0INV
5705 REAL,PARAMETER :: P0XZP2=202649.902
5706 REAL,PARAMETER :: P0XZP8=810600.098
5707 REAL,PARAMETER :: P0X2=2.*1013250.
5708 REAL,PARAMETER :: RADCON=8.427
5709 REAL,PARAMETER :: RADCON1=1./8.427
5710 REAL,PARAMETER :: RATCO2MW=1.519449738
5711 REAL,PARAMETER :: RATH2OMW=.622
5712 REAL,PARAMETER :: RGAS=8.3142E7
5713 REAL,PARAMETER :: RGASSP=8.31432E7
5714 REAL,PARAMETER :: SECPDA=8.64E4
5715 !
5716 !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
5717 ! ARRANGED IN DECREASING ORDER
5718 REAL,PARAMETER :: HUNDRED=100.
5719 REAL,PARAMETER :: HNINETY=90.
5720 REAL,PARAMETER :: HNINE=9.0
5721 REAL,PARAMETER :: SIXTY=60.
5722 REAL,PARAMETER :: FIFTY=50.
5723 REAL,PARAMETER :: TEN=10.
5724 REAL,PARAMETER :: EIGHT=8.
5725 REAL,PARAMETER :: FIVE=5.
5726 REAL,PARAMETER :: FOUR=4.
5727 REAL,PARAMETER :: THREE=3.
5728 REAL,PARAMETER :: TWO=2.
5729 REAL,PARAMETER :: ONE=1.
5730 REAL,PARAMETER :: HAF=0.5
5731 REAL,PARAMETER :: QUARTR=0.25
5732 REAL,PARAMETER :: ZERO=0.
5733 !
5734 !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
5735 ! ARRANGED IN DECREASING ORDER
5736 REAL,PARAMETER :: H83E26=8.3E26
5737 REAL,PARAMETER :: H71E26=7.1E26
5738 REAL,PARAMETER :: H1E15=1.E15
5739 REAL,PARAMETER :: H1E13=1.E13
5740 REAL,PARAMETER :: H1E11=1.E11
5741 REAL,PARAMETER :: H1E8=1.E8
5742 REAL,PARAMETER :: H2E6=2.0E6
5743 REAL,PARAMETER :: H1E6=1.0E6
5744 REAL,PARAMETER :: H69766E5=6.97667E5
5745 REAL,PARAMETER :: H4E5=4.E5
5746 REAL,PARAMETER :: H165E5=1.65E5
5747 REAL,PARAMETER :: H5725E4=57250.
5748 REAL,PARAMETER :: H488E4=48800.
5749 REAL,PARAMETER :: H1E4=1.E4
5750 REAL,PARAMETER :: H24E3=2400.
5751 REAL,PARAMETER :: H20788E3=2078.8
5752 REAL,PARAMETER :: H2075E3=2075.
5753 REAL,PARAMETER :: H18E3=1800.
5754 REAL,PARAMETER :: H1224E3=1224.
5755 REAL,PARAMETER :: H67390E2=673.9057
5756 REAL,PARAMETER :: H5E2=500.
5757 REAL,PARAMETER :: H3082E2=308.2
5758 REAL,PARAMETER :: H3E2=300.
5759 REAL,PARAMETER :: H2945E2=294.5
5760 REAL,PARAMETER :: H29316E2=293.16
5761 REAL,PARAMETER :: H26E2=260.0
5762 REAL,PARAMETER :: H25E2=250.
5763 REAL,PARAMETER :: H23E2=230.
5764 REAL,PARAMETER :: H2E2=200.0
5765 REAL,PARAMETER :: H15E2=150.
5766 REAL,PARAMETER :: H1386E2=138.6
5767 REAL,PARAMETER :: H1036E2=103.6
5768 REAL,PARAMETER :: H8121E1=81.21
5769 REAL,PARAMETER :: H35E1=35.
5770 REAL,PARAMETER :: H3116E1=31.16
5771 REAL,PARAMETER :: H28E1=28.
5772 REAL,PARAMETER :: H181E1=18.1
5773 REAL,PARAMETER :: H18E1=18.
5774 REAL,PARAMETER :: H161E1=16.1
5775 REAL,PARAMETER :: H16E1=16.
5776 REAL,PARAMETER :: H1226E1=12.26
5777 REAL,PARAMETER :: H9P94=9.94
5778 REAL,PARAMETER :: H6P08108=6.081081081
5779 REAL,PARAMETER :: H3P6=3.6
5780 REAL,PARAMETER :: H3P5=3.5
5781 REAL,PARAMETER :: H2P9=2.9
5782 REAL,PARAMETER :: H2P8=2.8
5783 REAL,PARAMETER :: H2P5=2.5
5784 REAL,PARAMETER :: H1P8=1.8
5785 REAL,PARAMETER :: H1P4387=1.4387
5786 REAL,PARAMETER :: H1P41819=1.418191
5787 REAL,PARAMETER :: H1P4=1.4
5788 REAL,PARAMETER :: H1P25892=1.258925411
5789 REAL,PARAMETER :: H1P082=1.082
5790 REAL,PARAMETER :: HP816=0.816
5791 REAL,PARAMETER :: HP805=0.805
5792 REAL,PARAMETER :: HP8=0.8
5793 REAL,PARAMETER :: HP60241=0.60241
5794 REAL,PARAMETER :: HP602409=0.60240964
5795 REAL,PARAMETER :: HP6=0.6
5796 REAL,PARAMETER :: HP526315=0.52631579
5797 REAL,PARAMETER :: HP518=0.518
5798 REAL,PARAMETER :: HP5048=0.5048
5799 REAL,PARAMETER :: HP3795=0.3795
5800 REAL,PARAMETER :: HP369=0.369
5801 REAL,PARAMETER :: HP26=0.26
5802 REAL,PARAMETER :: HP228=0.228
5803 REAL,PARAMETER :: HP219=0.219
5804 REAL,PARAMETER :: HP166666=.166666
5805 REAL,PARAMETER :: HP144=0.144
5806 REAL,PARAMETER :: HP118666=0.118666192
5807 REAL,PARAMETER :: HP1=0.1
5808 ! (NEGATIVE EXPONENTIALS BEGIN HERE)
5809 REAL,PARAMETER :: H658M2=0.0658
5810 REAL,PARAMETER :: H625M2=0.0625
5811 REAL,PARAMETER :: H44871M2=4.4871E-2
5812 REAL,PARAMETER :: H44194M2=.044194
5813 REAL,PARAMETER :: H42M2=0.042
5814 REAL,PARAMETER :: H41666M2=0.0416666
5815 REAL,PARAMETER :: H28571M2=.02857142857
5816 REAL,PARAMETER :: H2118M2=0.02118
5817 REAL,PARAMETER :: H129M2=0.0129
5818 REAL,PARAMETER :: H1M2=.01
5819 REAL,PARAMETER :: H559M3=5.59E-3
5820 REAL,PARAMETER :: H3M3=0.003
5821 REAL,PARAMETER :: H235M3=2.35E-3
5822 REAL,PARAMETER :: H1M3=1.0E-3
5823 REAL,PARAMETER :: H987M4=9.87E-4
5824 REAL,PARAMETER :: H323M4=0.000323
5825 REAL,PARAMETER :: H3M4=0.0003
5826 REAL,PARAMETER :: H285M4=2.85E-4
5827 REAL,PARAMETER :: H1M4=0.0001
5828 REAL,PARAMETER :: H75826M4=7.58265E-4
5829 REAL,PARAMETER :: H6938M5=6.938E-5
5830 REAL,PARAMETER :: H394M5=3.94E-5
5831 REAL,PARAMETER :: H37412M5=3.7412E-5
5832 REAL,PARAMETER :: H15M5=1.5E-5
5833 REAL,PARAMETER :: H1439M5=1.439E-5
5834 REAL,PARAMETER :: H128M5=1.28E-5
5835 REAL,PARAMETER :: H102M5=1.02E-5
5836 REAL,PARAMETER :: H1M5=1.0E-5
5837 REAL,PARAMETER :: H7M6=7.E-6
5838 REAL,PARAMETER :: H4999M6=4.999E-6
5839 REAL,PARAMETER :: H451M6=4.51E-6
5840 REAL,PARAMETER :: H25452M6=2.5452E-6
5841 REAL,PARAMETER :: H1M6=1.E-6
5842 REAL,PARAMETER :: H391M7=3.91E-7
5843 REAL,PARAMETER :: H1174M7=1.174E-7
5844 REAL,PARAMETER :: H8725M8=8.725E-8
5845 REAL,PARAMETER :: H327M8=3.27E-8
5846 REAL,PARAMETER :: H257M8=2.57E-8
5847 REAL,PARAMETER :: H1M8=1.0E-8
5848 REAL,PARAMETER :: H23M10=2.3E-10
5849 REAL,PARAMETER :: H14M10=1.4E-10
5850 REAL,PARAMETER :: H11M10=1.1E-10
5851 REAL,PARAMETER :: H1M10=1.E-10
5852 REAL,PARAMETER :: H83M11=8.3E-11
5853 REAL,PARAMETER :: H82M11=8.2E-11
5854 REAL,PARAMETER :: H8M11=8.E-11
5855 REAL,PARAMETER :: H77M11=7.7E-11
5856 REAL,PARAMETER :: H72M11=7.2E-11
5857 REAL,PARAMETER :: H53M11=5.3E-11
5858 REAL,PARAMETER :: H48M11=4.8E-11
5859 REAL,PARAMETER :: H44M11=4.4E-11
5860 REAL,PARAMETER :: H42M11=4.2E-11
5861 REAL,PARAMETER :: H37M11=3.7E-11
5862 REAL,PARAMETER :: H35M11=3.5E-11
5863 REAL,PARAMETER :: H32M11=3.2E-11
5864 REAL,PARAMETER :: H3M11=3.0E-11
5865 REAL,PARAMETER :: H28M11=2.8E-11
5866 REAL,PARAMETER :: H24M11=2.4E-11
5867 REAL,PARAMETER :: H23M11=2.3E-11
5868 REAL,PARAMETER :: H2M11=2.E-11
5869 REAL,PARAMETER :: H18M11=1.8E-11
5870 REAL,PARAMETER :: H15M11=1.5E-11
5871 REAL,PARAMETER :: H14M11=1.4E-11
5872 REAL,PARAMETER :: H114M11=1.14E-11
5873 REAL,PARAMETER :: H11M11=1.1E-11
5874 REAL,PARAMETER :: H1M11=1.E-11
5875 REAL,PARAMETER :: H96M12=9.6E-12
5876 REAL,PARAMETER :: H93M12=9.3E-12
5877 REAL,PARAMETER :: H77M12=7.7E-12
5878 REAL,PARAMETER :: H74M12=7.4E-12
5879 REAL,PARAMETER :: H65M12=6.5E-12
5880 REAL,PARAMETER :: H62M12=6.2E-12
5881 REAL,PARAMETER :: H6M12=6.E-12
5882 REAL,PARAMETER :: H45M12=4.5E-12
5883 REAL,PARAMETER :: H44M12=4.4E-12
5884 REAL,PARAMETER :: H4M12=4.E-12
5885 REAL,PARAMETER :: H38M12=3.8E-12
5886 REAL,PARAMETER :: H37M12=3.7E-12
5887 REAL,PARAMETER :: H3M12=3.E-12
5888 REAL,PARAMETER :: H29M12=2.9E-12
5889 REAL,PARAMETER :: H28M12=2.8E-12
5890 REAL,PARAMETER :: H24M12=2.4E-12
5891 REAL,PARAMETER :: H21M12=2.1E-12
5892 REAL,PARAMETER :: H16M12=1.6E-12
5893 REAL,PARAMETER :: H14M12=1.4E-12
5894 REAL,PARAMETER :: H12M12=1.2E-12
5895 REAL,PARAMETER :: H8M13=8.E-13
5896 REAL,PARAMETER :: H46M13=4.6E-13
5897 REAL,PARAMETER :: H36M13=3.6E-13
5898 REAL,PARAMETER :: H135M13=1.35E-13
5899 REAL,PARAMETER :: H12M13=1.2E-13
5900 REAL,PARAMETER :: H1M13=1.E-13
5901 REAL,PARAMETER :: H3M14=3.E-14
5902 REAL,PARAMETER :: H15M14=1.5E-14
5903 REAL,PARAMETER :: H14M14=1.4E-14
5904 !
5905 !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
5906 ! ARRANGED IN DESCENDING ORDER
5907 REAL,PARAMETER :: HM2M2=-.02
5908 REAL,PARAMETER :: HM6666M2=-.066667
5909 REAL,PARAMETER :: HMP5=-0.5
5910 REAL,PARAMETER :: HMP575=-0.575
5911 REAL,PARAMETER :: HMP66667=-.66667
5912 REAL,PARAMETER :: HMP805=-0.805
5913 REAL,PARAMETER :: HM1EZ=-1.
5914 REAL,PARAMETER :: HM13EZ=-1.3
5915 REAL,PARAMETER :: HM19EZ=-1.9
5916 REAL,PARAMETER :: HM1E1=-10.
5917 REAL,PARAMETER :: HM1597E1=-15.97469413
5918 REAL,PARAMETER :: HM161E1=-16.1
5919 REAL,PARAMETER :: HM1797E1=-17.97469413
5920 REAL,PARAMETER :: HM181E1=-18.1
5921 REAL,PARAMETER :: HM8E1=-80.
5922 REAL,PARAMETER :: HM1E2=-100.
5923 !
5924 REAL,PARAMETER :: H1M16=1.0E-16
5925 REAL,PARAMETER :: H1M20=1.E-20
5926 REAL,PARAMETER :: HP98=0.98
5927 REAL,PARAMETER :: Q19001=19.001
5928 REAL,PARAMETER :: DAYSEC=1.1574E-5
5929 REAL,PARAMETER :: HSIGMA=5.673E-5
5930 REAL,PARAMETER :: TWENTY=20.0
5931 REAL,PARAMETER :: HP537=0.537
5932 REAL,PARAMETER :: HP2=0.2
5933 REAL,PARAMETER :: RCO2=3.3E-4
5934 REAL,PARAMETER :: Q14330=1.43306E-6
5935 REAL,PARAMETER :: H3M6=3.0E-6
5936 REAL,PARAMETER :: PI=3.1415927
5937 REAL,PARAMETER :: DEGRAD=180.0/PI
5938 REAL,PARAMETER :: H74E1=74.0
5939 REAL,PARAMETER :: H15E1=15.0
5941 REAL, PARAMETER:: B0 = -.51926410E-4
5942 REAL, PARAMETER:: B1 = -.18113332E-3
5943 REAL, PARAMETER:: B2 = -.10680132E-5
5944 REAL, PARAMETER:: B3 = -.67303519E-7
5945 REAL, PARAMETER:: AWIDE = 0.309801E+01
5946 REAL, PARAMETER:: BWIDE = 0.495357E-01
5947 REAL, PARAMETER:: BETAWD = 0.347839E+02
5948 REAL, PARAMETER:: BETINW = 0.766811E+01
5951 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
5952 ims,ime, jms,jme, kms,kme , &
5953 its,ite, jts,jte, kts,kte
5954 INTEGER, INTENT(IN) :: IBEG,KO3,KALB,ITIMSW,ITIMLW,JD
5955 REAL, INTENT(IN) :: GMT
5956 !----------------------------------------------------------------------
5957 ! ****************************************************************
5958 ! * GENERALIZED FOR PLUG-COMPATIBILITY - *
5959 ! * ORIGINAL CODE WAS CLEANED-UP GFDL CODE...K.CAMPANA MAR89..*
5960 !......* EXAMPLE FOR MRF: *
5961 ! * KO3 =0 AND O3QO3=DUMMY ARRAY. (GFDL CLIMO O3 USED) *
5962 ! * KEMIS=0 AND HI CLD EMIS COMPUTED HERE (CEMIS=DUMMY INPUT)*
5963 ! * KALB =0 AND SFC ALBEDO OVER OPEN WATER COMPUTED BELOW... *
5964 ! * KCCO2=0,CO2 OBTAINED FROM BLOCK DATA *
5965 ! * =1,CO2 COMPUTED IN HERE --- NOT AVAILABLE YET... *
5966 ! * SLMRF = INTERFACE (LEVELS) SIGMA *
5967 ! * SLYMRF= LAYER SIGMA *
5968 ! * UPDATED FOR YUTAI HOU SIB SW RADIATION....KAC 6 MAR 92 *
5969 ! * OCEAN ALBEDO FOR BEAM SET TO BULK SFCALB, SINCE *
5970 ! * COSINE ZENITH ANGLE EFFECTS ALREADY THERE(REF:PAYNE) *
5971 ! * SLMSK = 0. *
5972 ! * SNOW ICE ALBEDO FOR BEAM NOT ENHANCED VIA COSINE ZENITH *
5973 ! * ANGLE EITHER CAUSE VALU ALREADY HIGH (WE SEE POLAR *
5974 ! * COOLING IF WE DO BEAM CALCULATION)....KAC 17MAR92 *
5975 ! * ALBEDO GE .5 *
5976 ! * UPDATED TO OBTAIN CLEAR SKY FLUXES "ON THE FLY" FOR *
5977 ! * CLOUD FORCING DIAGNOSTICS ELSEWHERE...KAC 7AUG92 *
5978 ! * SEE ##CLR LINES...RADFS,LWR88,FST88,SPA88 ....... *
5979 ! * UPDATED FOR USE NEW CLD SCHEME ......YH DEC 92 *
5980 ! * INPUT CLD MAY BE AS ORIGINAL IN 3 DOMAIN (CLD,MTOP,MBOT) *
5981 ! * OR IN A VERTICAL ARRAY OF 18 MDL LAYERS (CLDARY) *
5982 ! * IEMIS=0 USE THE ORG. CLD EMIS SCHEME *
5983 ! * =1 USE TEMP DEP. CLD EMIS SCHEME *
5984 ! * UPDATED TO COMPUTE CLD LAYER REFLECTTANCE AND TRANSMITTANCE *
5985 ! * INPUT CLD EMISSIVITY AND OPTICAL THICKNESS 'EMIS0,TAUC0' *
5986 ! * ......YH FEB 93 *
5987 ! ****************************************************************
5988 !--------------------------------
5989 ! INTEGER, PARAMETER:: LNGTH=37*kte
5990 !--------------------------------
5992 ! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D
5994 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: PP,TT
5995 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: QQH2O
5996 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: PPI,CAMT,EMCLD
5997 REAL, INTENT(IN), DIMENSION(its:ite):: QS,TSFC,SLMSK,ALBEDO,XLAT
5998 REAL, INTENT(IN), DIMENSION(its:ite):: COSZRO,TAUDAR
5999 REAL, INTENT(OUT), DIMENSION(its:ite):: FLWUPS
6000 INTEGER, INTENT(IN), DIMENSION(its:ite):: NCLDS
6001 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: KTOP,KBTM
6002 REAL, INTENT(INOUT), DIMENSION(its:ite,NB,kts:kte+1):: TTCL,RRCL
6003 REAL, intent(IN), DIMENSION(its:ite,kts:kte):: O3QO3
6004 ! REAL, INTENT(IN), DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW
6005 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
6007 ! REAL, DIMENSION(its:ite)::ALVBR,ALNBR, ALVDR,ALNDR
6009 ! TABLE ???
6011 REAL, DIMENSION(3) :: BO3RND,AO3RND
6012 REAL, DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
6013 BCOMB,BETACM
6015 DATA AO3RND / 0.543368E+02, 0.234676E+04, 0.384881E+02/
6016 DATA BO3RND / 0.526064E+01, 0.922424E+01, 0.496515E+01/
6018 DATA ACOMB / &
6019 0.152070E+05, 0.332194E+04, 0.527177E+03, 0.163124E+03, &
6020 0.268808E+03, 0.534591E+02, 0.268071E+02, 0.123133E+02, &
6021 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, &
6022 0.178110E-01, 0.170166E+00, 0.537083E-02/
6023 DATA BCOMB / &
6024 0.152538E+00, 0.118677E+00, 0.103660E+00, 0.100119E+00, &
6025 0.127518E+00, 0.118409E+00, 0.904061E-01, 0.642011E-01, &
6026 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, &
6027 0.875182E-01, 0.857907E-01, 0.214005E+00/
6028 DATA APCM / &
6029 -0.671879E-03, 0.654345E-02, 0.143657E-01, 0.923593E-02, &
6030 0.117022E-01, 0.159596E-01, 0.181600E-01, 0.145013E-01, &
6031 0.170062E-01, 0.233303E-01, 0.256735E-01, 0.274745E-01, &
6032 0.279259E-01, 0.197002E-01, 0.349782E-01/
6033 DATA BPCM / &
6034 -0.113520E-04, -0.323965E-04, -0.448417E-04, -0.230779E-04, &
6035 -0.361981E-04, -0.145117E-04, 0.198349E-04, -0.486529E-04, &
6036 -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, &
6037 -0.982953E-04, -0.772497E-04, -0.748263E-04/
6038 DATA ATPCM / &
6039 -0.106346E-02, 0.641531E-02, 0.137362E-01, 0.922513E-02, &
6040 0.136162E-01, 0.169791E-01, 0.206959E-01, 0.166223E-01, &
6041 0.171776E-01, 0.229724E-01, 0.275530E-01, 0.302731E-01, &
6042 0.281662E-01, 0.199525E-01, 0.370962E-01/
6043 DATA BTPCM / &
6044 -0.735731E-05, -0.294149E-04, -0.505592E-04, -0.280894E-04, &
6045 -0.492972E-04, -0.341508E-04, -0.362947E-04, -0.250487E-04, &
6046 -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, &
6047 -0.933645E-04, -0.664045E-04, -0.115290E-03/
6048 DATA BETACM / &
6049 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
6050 0.188625E+03, 0.144293E+03, 0.174098E+03, 0.909366E+02, &
6051 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, &
6052 0.589554E+01, 0.495227E+01, 0.000000E+00/
6055 ! *********************************************
6056 !====> * OUTPUT TO CALLING PROGRAM *
6057 ! *********************************************
6059 REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte)::SWH,HLW
6060 REAL, INTENT(OUT), DIMENSION(its:ite):: FSWUP,FSWUPS,FSWDN, &
6061 FSWDNS,FLWUP,FLWDNS
6063 ! *********************************************
6064 !====> * POSSIBLE OUTPUT TO CALLING PROGRAM *
6065 ! *********************************************
6067 REAL, DIMENSION(its:ite):: GDFVBR,GDFNBR,GDFVDR,GDFNDR
6069 ! ************************************************************
6070 !====> * ARRAYS NEEDED BY SWR91SIB..FOR CLEAR SKY DATA(EG.FSWL) *
6071 ! ************************************************************
6073 REAL, DIMENSION(its:ite,kts:kte+1)::FSWL,HSWL,UFL,DFL
6075 ! ******************************************************
6076 !====> * ARRAYS NEEDED BY CLO88, LWR88, SWR89 OR SWR91SIB *
6077 ! ******************************************************
6079 REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1)::CLDFAC
6080 REAL, DIMENSION(its:ite,kts:kte+1)::EQCMT,PRESS,TEMP,FSW,HSW,UF,DF
6081 REAL, DIMENSION(its:ite,kts:kte)::RH2O,QO3,HEATRA
6082 REAL, DIMENSION(its:ite):: COSZEN,TAUDA,GRNFLX,TOPFLX,GRDFLX
6083 REAL, DIMENSION(kts:kte+1)::PHALF
6084 !..... ADD PRESSURE INTERFACE
6086 REAL, DIMENSION(NB) :: ABCFF,PWTS
6088 DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190., &
6089 989.,2706.,39011./
6090 DATA PWTS/.5000,.121416,.0698,.1558,.0631,.0362,.0243,.0158,.0087, &
6091 .001467,.002342,.001075/
6093 REAL :: CFCO2,CFO3,REFLO3,RRAYAV
6095 DATA CFCO2,CFO3/508.96,466.64/
6096 DATA REFLO3/1.9/
6097 DATA RRAYAV/0.144/
6099 ! *********************************************
6100 !====> * VECTOR TEMPORARIES FOR CLOUD CALC. *
6101 ! *********************************************
6103 REAL, DIMENSION(its:ite):: TTHAN
6104 REAL, DIMENSION(its:ite,kts:kte):: DO3V,DO3VP
6105 INTEGER, DIMENSION(its:ite):: JJROW
6107 !====> **************************************************************
6108 !-- SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN
6109 ! CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE).
6110 ! DEFINED AS 5 DEG LAT MEANS N.P.->S.P.
6111 ! COMMON /SAVMEM/ &
6112 !- ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL.....
6113 ! DDUO3N(37,L), DDO3N2(37,L), DDO3N3(37,L), DDO3N4(37,L)
6115 REAL, DIMENSION(37,kte) :: DDUO3N,DDO3N2,DDO3N3,DDO3N4
6117 ! DIMENSION RAD1(37*kte), RAD2(37*kte), RAD3(37*kte), RAD4(37*kte)
6118 ! EQUIVALENCE (RAD1(1),DDUO3N(1,1)),(RAD2(1),DDO3N2(1,1))
6119 ! EQUIVALENCE (RAD3(1),DDO3N3(1,1)),(RAD4(1),DDO3N4(1,1))
6120 !====> **************************************************************
6121 !
6122 REAL, DIMENSION(21,20) :: ALBD
6123 REAL, DIMENSION(20) :: ZA
6124 REAL, DIMENSION(21) :: TRN
6125 REAL, DIMENSION(19) :: DZA
6127 REAL :: YEAR,RLAG,TPI,SC,SSOLAR,DATE,RANG,TH2,ZEN,DZEN,ALB1,ALB2
6128 INTEGER :: IR,IQ,JX
6129 DATA TRN/.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60,.65, &
6130 .70,.75,.80,.85,.90,.95,1.00/
6132 REAL :: ALB11(21,7),ALB22(21,7),ALB33(21,6)
6134 EQUIVALENCE (ALB11(1,1),ALBD(1,1)),(ALB22(1,1),ALBD(1,8)), &
6135 (ALB33(1,1),ALBD(1,15))
6136 DATA ALB11/ .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, &
6137 .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, &
6138 .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, &
6139 .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, &
6140 .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, &
6141 .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, &
6142 .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, &
6143 .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, &
6144 .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, &
6145 .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, &
6146 .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, &
6147 .246,.235,.222,.211,.205,.200/
6148 DATA ALB22/ .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, &
6149 .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, &
6150 .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, &
6151 .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, &
6152 .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, &
6153 .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, &
6154 .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, &
6155 .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, &
6156 .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, &
6157 .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, &
6158 .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, &
6159 .058,.055,.054,.053,.052,.052/
6160 DATA ALB33/ .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, &
6161 .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, &
6162 .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, &
6163 .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, &
6164 .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, &
6165 .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, &
6166 .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, &
6167 .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, &
6168 .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, &
6169 .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025/
6170 DATA ZA/90.,88.,86.,84.,82.,80.,78.,76.,74.,70.,66.,62.,58.,54., &
6171 50.,40.,30.,20.,10.,0.0/
6172 DATA DZA/8*2.0,6*4.0,5*10.0/
6174 ! ***********************************************************
6175 !
6177 REAL, DIMENSION(its:ite) :: ALVB,ALNB,ALVD,ALND, &
6178 GDFVB, &
6179 GDFNB,GDFVD,GDFND, &
6180 SFCALB
6181 REAL :: SOLC,RSIN1,RCOS1,RCOS2
6183 REAL :: ALBD0,ALVD1,ALND1,RRVCO2,RRCO2
6184 INTEGER :: N
6186 !====> BEGIN HERE .......................
6187 !
6188 ! SOLC,THE SOLAR CONSTANT IS SCALED TO A MORE CURRENT VALUE.
6189 ! I.E. IF SOLC=2.0 LY/MIN THEN SSOLAR=1.96 LY/MIN.
6190 !.. RE-COMPUTED CAUSE SSOLAR OVERWRITTEN AS PART OF SCRATCH COMMON
6191 !
6194 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
6195 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
6197 L=kte
6198 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
6199 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
6200 LLM2 = LL-2; LLM1=LL-1
6201 MYIS=its; MYIE=ite
6203 !******ZHAO
6204 ! NOTE: XLAT IS IN DEGREE HERE
6205 !*****ZHAO
6206 YEAR=365.25
6207 RLAG=14.8125
6208 TPI=6.283185308
6209 SC=2.
6210 SOLC=SC/(R1*R1)
6211 !*****************************
6212 ! Special note: The solar constant is reduced extra 3 percent to account
6213 ! for the lack of aerosols in the shortwave radiation
6214 ! parameterization. Q. Zhao 96-7-23
6215 !****************************
6216 SSOLAR=SOLC*HP98
6217 SSOLAR=SSOLAR*0.97
6218 DATE=JD+GMT/24.0
6219 RANG=TPI*(DATE-RLAG)/YEAR
6220 RSIN1=SIN(RANG)
6221 RCOS1=COS(RANG)
6222 RCOS2=COS(2.0*RANG)
6223 DO 40 I=MYIS,MYIE
6224 IR = I + IBEG - 1
6225 TH2=HP2*XLAT(IR)
6226 JJROW(I)=Q19001-TH2
6227 TTHAN(I)=(19-JJROW(I))-TH2
6228 !..... NOTE THAT THE NMC VARIABLES ARE IN MKS (THUS PRESSURE IS IN
6229 ! CENTIBARS)WHILE ALL GFDL VARIABLES ARE IN CGS UNITS
6230 SFCALB(I) = ALBEDO(IR)
6231 !..... NOW PUT SFC TEMP,PRESSURES, ZENITH ANGLE INTO SW COMMON BLOCK...
6232 !***ZHAO
6233 ! NOTE: ALL PRESSURES INPUT FROM THE ETA MODEL ARE IN PA
6234 ! THE UNIT FOR PRESS IS MICRO BAR
6235 ! SURFACE TEMPERATURE ARE NEGATIVE OVER OCEANS IN THE ETA MODEL
6236 !***ZHAO
6237 PRESS(I,LP1)=QS(IR)*10.0
6238 TEMP(I,LP1)=ABS(TSFC(IR))
6239 COSZEN(I) = COSZRO(IR)
6240 TAUDA(I) = TAUDAR(IR)
6241 40 CONTINUE
6242 !***ZHAO
6243 !..... ALL GFDL VARIABLES HAVE K=1 AT THE TOP OF THE ATMOSPHERE.NMC
6244 ! ETA MODEL HAS THE SAME STRUCTURE
6245 !***ZHAO
6246 DO 50 K=1,L
6247 DO 50 I=MYIS,MYIE
6248 IR = I + IBEG - 1
6249 !..... NOW PUT TEMP,PRESSURES, INTO SW COMMON BLOCK..........
6250 TEMP(I,K) = TT(IR,K)
6251 PRESS(I,K) = 10.0 * PP(IR,K)
6252 !.... STORE LYR MOISTURE AND ADD TO SW COMMON BLOCK
6253 RH2O(I,K)=QQH2O(IR,K)
6254 IF(RH2O(I,K).LT.H3M6) RH2O(I,K)=H3M6
6255 50 CONTINUE
6256 !... *************************
6257 IF (KO3.EQ.0) GO TO 65
6258 !... *************************
6259 DO 60 K=1,L
6260 DO 60 I=MYIS,MYIE
6261 QO3(I,K) = O3QO3(I+IBEG-1,K)
6262 60 CONTINUE
6263 65 CONTINUE
6264 !... ************************************
6265 IF (KALB.GT.0) GO TO 110
6266 !... ************************************
6267 !..... THE FOLLOWING CODE GETS ALBEDO FROM PAYNE,1972 TABLES IF
6268 ! 1) OPEN SEA POINT (SLMSK=1);2) KALB=0
6269 IQ=INT(TWENTY*HP537+ONE)
6270 DO 105 I=MYIS,MYIE
6271 IF(COSZEN(I).GT.0.0 .AND. SLMSK(I+IBEG-1).GT.0.5) THEN
6272 ZEN=DEGRAD*ACOS(MAX(COSZEN(I),0.0))
6273 IF(ZEN.GE.H74E1) JX=INT(HAF*(HNINETY-ZEN)+ONE)
6274 IF(ZEN.LT.H74E1.AND.ZEN.GE.FIFTY) &
6275 JX=INT(QUARTR*(H74E1-ZEN)+HNINE)
6276 IF(ZEN.LT.FIFTY) JX=INT(HP1*(FIFTY-ZEN)+H15E1)
6277 DZEN=-(ZEN-ZA(JX))/DZA(JX)
6278 ALB1=ALBD(IQ,JX)+DZEN*(ALBD(IQ,JX+1)-ALBD(IQ,JX))
6279 ALB2=ALBD(IQ+1,JX)+DZEN*(ALBD(IQ+1,JX+1)-ALBD(IQ+1,JX))
6280 SFCALB(I)=ALB1+TWENTY*(ALB2-ALB1)*(HP537-TRN(IQ))
6281 ENDIF
6282 105 CONTINUE
6283 110 CONTINUE
6284 ! **********************************
6285 IF (KO3.GT.0) GO TO 135
6286 ! **********************************
6287 !.... COMPUTE CLIMATOLOGICAL ZONAL MEAN OZONE,
6288 !.... SEASONAL AND SPATIAL INTERPOLATION DONE BELOW.
6289 DO 125 I=MYIS,MYIE
6291 PHALF(1)=0.
6292 PHALF(LP1)=PPI(I,kme)
6293 DO L=1,LM1
6294 PHALF(L+1)=PP(I,L) ! AETA(L)*PDIF+PT
6295 ENDDO
6297 CALL O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, &
6298 ids,ide, jds,jde, kds,kde, &
6299 ims,ime, jms,jme, kms,kme, &
6300 its,ite, jts,jte, kts,kte )
6302 DO 130 K=1,L
6303 DO3V(I,K) = DDUO3N(JJROW(I),K) + RSIN1*DDO3N2(JJROW(I),K) &
6304 +RCOS1*DDO3N3(JJROW(I),K) &
6305 +RCOS2*DDO3N4(JJROW(I),K)
6306 DO3VP(I,K) = DDUO3N(JJROW(I)+1,K) + RSIN1*DDO3N2(JJROW(I)+1,K) &
6307 +RCOS1*DDO3N3(JJROW(I)+1,K) &
6308 +RCOS2*DDO3N4(JJROW(I)+1,K)
6309 !... NOW LATITUDINAL INTERPOLATION, AND
6310 ! CONVERT O3 INTO MASS MIXING RATIO(ORIGINAL DATA MPY BY 1.E4)
6311 QO3(I,K) = H1M4 * (DO3V(I,K)+TTHAN(I)*(DO3VP(I,K)-DO3V(I,K)))
6312 130 CONTINUE
6313 125 CONTINUE
6314 135 CONTINUE
6315 !.............
6316 DO 195 I=MYIS,MYIE
6317 !..... VISIBLE AND NEAR IR DIFFUSE ALBEDO
6318 ALVD(I) = SFCALB(I)
6319 ALND(I) = SFCALB(I)
6320 !..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO
6321 ALVB(I) = SFCALB(I)
6322 ALNB(I) = SFCALB(I)
6323 !..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO,IF NOT OCEAN NOR SNOW
6324 ! ..FUNCTION OF COSINE SOLAR ZENITH ANGLE..
6325 IF (SLMSK(I+IBEG-1).LT.0.5) THEN
6326 IF (SFCALB(I).LE.0.5) THEN
6327 ALBD0 = -18.0 * (0.5 - ACOS(COSZEN(I))/PI)
6328 ALBD0 = EXP (ALBD0)
6329 ALVD1 = (ALVD(I) - 0.054313) / 0.945687
6330 ALND1 = (ALND(I) - 0.054313) / 0.945687
6331 ALVB(I) = ALVD1 + (1.0 - ALVD1) * ALBD0
6332 ALNB(I) = ALND1 + (1.0 - ALND1) * ALBD0
6333 END IF
6334 END IF
6335 195 CONTINUE
6336 !.....SURFACE VALUES OF RRCL AND TTCL
6337 DO 200 N=1,2
6338 DO 200 I=MYIS,MYIE
6339 RRCL(I,N,1)=ALVD(I)
6340 TTCL(I,N,1)=ZERO
6341 200 CONTINUE
6342 DO 220 N=3,NB
6343 DO 220 I=MYIS,MYIE
6344 RRCL(I,N,1)=ALND(I)
6345 TTCL(I,N,1)=ZERO
6346 220 CONTINUE
6347 !... **************************
6348 !... * END OF CLOUD SECTION *
6349 !... **************************
6350 !... THE FOLLOWING CODE CONVERTS RRVCO2,THE VOLUME MIXING RATIO OF CO2
6351 ! INTO RRCO2,THE MASS MIXING RATIO.
6352 RRVCO2=RCO2
6353 RRCO2=RRVCO2*RATCO2MW
6354 250 IF(ITIMLW .EQ. 0) GO TO 300
6355 !
6356 ! ***********************
6357 !====> * LONG WAVE RADIATION *
6358 ! ***********************
6359 !
6360 !.... ACCOUNT FOR REDUCED EMISSIVITY OF ANY CLDS
6361 DO 240 K=1,LP1
6362 DO 240 I=MYIS,MYIE
6363 EQCMT(I,K)=CAMT(I,K)*EMCLD(I,K)
6364 240 CONTINUE
6365 !.... GET CLD FACTOR FOR LW CALCULATIONS
6366 !....
6368 ! shuhua
6370 CALL CLO89(CLDFAC,EQCMT,NCLDS,KBTM,KTOP, &
6371 ids,ide, jds,jde, kds,kde, &
6372 ims,ime, jms,jme, kms,kme, &
6373 its,ite, jts,jte, kts,kte )
6375 ! shuhua
6376 !===> LONG WAVE RADIATION
6377 ! CALL LWR88(HEATRA,GRNFLX,TOPFLX, &
6378 ! PRESS,TEMP,RH2O,QO3,CLDFAC, &
6379 ! EQCMT,NCLDS,KTOP,KBTM, &
6380 !
6381 !! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
6382 ! BO3RND,AO3RND, &
6383 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
6384 ! ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
6385 ! GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
6386 ! P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
6387 ! TEN,HP1,FOUR,HM1EZ,SKO3R, &
6388 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
6389 ! HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
6390 ! RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, &
6391 ! ids,ide, jds,jde, kds,kde, &
6392 ! ims,ime, jms,jme, kms,kme, &
6393 ! its,ite, jts,jte, kts,kte )
6395 CALL LWR88(HEATRA,GRNFLX,TOPFLX, &
6396 PRESS,TEMP,RH2O,QO3,CLDFAC, &
6397 EQCMT,NCLDS,KTOP,KBTM, &
6398 !
6399 ! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
6400 BO3RND,AO3RND, &
6401 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
6402 ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
6403 GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
6404 P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
6405 TEN,HP1,FOUR,HM1EZ, &
6406 RADCON,QUARTR,TWO, &
6407 HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
6408 RADCON1,H16E1, H28E1,H44194M2,H1P41819, &
6409 ids,ide, jds,jde, kds,kde, &
6410 ims,ime, jms,jme, kms,kme, &
6411 its,ite, jts,jte, kts,kte )
6413 !....
6414 DO 280 I=MYIS,MYIE
6415 IR = I + IBEG - 1
6416 FLWUP(IR) = TOPFLX(I) * .001E0
6417 GRNFLX(I)=Q14330*(HSIGMA*TEMP(I,LP1)**4-GRNFLX(I))
6418 !.... GET LW FLUX DOWN AND UP AT GROUND(WATTS/M**2) - GRNFLX=LW DOWN.
6419 FLWDNS(IR)=GRNFLX(I)/(1.43306E-06*1000.E0)
6420 FLWUPS(IR)=HSIGMA*.001E0 * TEMP(I,LP1)**4
6421 280 CONTINUE
6422 !.... CONVERT HEATING RATES TO DEG/SEC
6423 DO 290 K=1,L
6424 DO 290 I=MYIS,MYIE
6425 HLW(I+IBEG-1,K)=HEATRA(I,K)*DAYSEC
6426 290 CONTINUE
6427 300 CONTINUE
6428 IF(ITIMSW .EQ. 0) GO TO 350
6429 !SW
6430 CALL SWR93(FSW,HSW,UF,DF,FSWL,HSWL,UFL,DFL, &
6431 PRESS,COSZEN,TAUDA,RH2O,RRCO2,SSOLAR,QO3, &
6432 NCLDS,KTOP,KBTM,CAMT,RRCL,TTCL, &
6433 ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, &
6434 !
6435 ! UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2, &
6436 ABCFF,PWTS, &
6437 H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219, &
6438 HP816,RRAYAV,GINV,CFCO2,CFO3, &
6439 TWO,H235M3,HP26,H129M2,H75826M4,H1036E2, &
6440 H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2, &
6441 H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON, &
6442 ids,ide, jds,jde, kds,kde, &
6443 ims,ime, jms,jme, kms,kme, &
6444 its,ite, jts,jte, kts,kte )
6446 !SW
6447 !
6448 !..... GET SW FLUXES IN WATTS/M**2
6449 DO 320 I=MYIS,MYIE
6450 IR = I + IBEG - 1
6451 FSWUP(IR) = UF(I,1) * 1.E-3
6452 FSWDN(IR) = DF(I,1) * 1.E-3
6453 FSWUPS(IR) = UF(I,LP1) * 1.E-3
6454 !C..COUPLE W/M2 DIFF, IF FSWDNS(IR)=DF(I,LP1)*1.#E-3
6455 FSWDNS(IR) = (GDFVB(I)+GDFNB(I)+GDFVD(I)+GDFND(I)) * 1.E-3
6456 !... DOWNWARD SFC FLUX FOR THE SIB PARAMETERATION
6457 !..... VISIBLE AND NEAR IR DIFFUSE
6458 GDFVDR(IR) = GDFVD(I) * 1.E-3
6459 GDFNDR(IR) = GDFND(I) * 1.E-3
6460 !..... VISIBLE AND NEAR IR DIRECT BEAM
6461 GDFVBR(IR) = GDFVB(I) * 1.E-3
6462 GDFNBR(IR) = GDFNB(I) * 1.E-3
6463 320 CONTINUE
6464 !.... CONVERT HEATING RATES TO DEG/SEC
6465 DO 330 K=1,L
6466 DO 330 I=MYIS,MYIE
6467 SWH(I+IBEG-1,K)=HSW(I,K)*DAYSEC
6468 330 CONTINUE
6469 350 CONTINUE
6470 RETURN
6471 1000 FORMAT(1H ,' YOU ARE CALLING GFDL RADIATION CODE FOR',I5,' PTS', &
6472 'AND',I4,' LYRS,WITH KDAPRX,KO3,KCZ,KEMIS,KALB = ',5I2)
6474 END SUBROUTINE RADFS
6476 !-----------------------------------------------------------------------
6477 SUBROUTINE O3CLIM
6478 ! (XDUO3N,XDO3N2,XDO3N3,XDO3N4,PRGFDL, &
6479 ! ids,ide, jds,jde, kds,kde, &
6480 ! ims,ime, jms,jme, kms,kme, &
6481 ! its,ite, jts,jte, kts,kte )
6482 !----------------------------------------------------------------------
6483 IMPLICIT NONE
6484 !----------------------------------------------------------------------
6485 ! INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
6486 ! ims,ime, jms,jme, kms,kme , &
6487 ! its,ite, jts,jte, kts,kte
6489 ! ******************************************************************
6490 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
6491 ! . . .
6492 ! SUBPROGRAM: O3CLIM GENERATE SEASONAL OZONE DISTRIBUTION
6493 ! PRGRMMR: GFDL/CAMPANA ORG: W/NP22 DATE: ??-??-??
6494 !
6495 ! ABSTRACT:
6496 ! O3CLIM COMPUTES THE SEASONAL CLIMATOLOGY OF OZONE USING
6497 ! 81-LAYER DATA FROM GFDL.
6498 !
6499 ! PROGRAM HISTORY LOG:
6500 ! ??-??-?? GFDL/KC - ORIGINATOR
6501 ! 96-07-26 BLACK - MODIFIED FOR ETA MODEL
6502 !
6503 ! USAGE: CALL O3CLIM FROM SUBROUTINE RADTN
6504 ! INPUT ARGUMENT LIST:
6505 ! NONE
6506 !
6507 ! OUTPUT ARGUMENT LIST:
6508 ! NONE
6509 !
6510 ! OUTPUT FILES:
6511 ! NONE
6512 !
6513 ! SUBPROGRAMS CALLED:
6514 !
6515 ! UNIQUE:
6516 ! NONE
6517 !
6518 ! LIBRARY:
6519 ! NONE
6520 !
6521 ! COMMON BLOCKS: SEASO3
6522 ! O3DATA
6523 !
6524 ! ATTRIBUTES:
6525 ! LANGUAGE: FORTRAN 90
6526 ! MACHINE : IBM SP
6527 !$$$
6528 !----------------------------------------------------------------------
6529 ! INTEGER :: NL,NLP1,NLGTH,NKK,NK,NKP
6530 INTEGER, PARAMETER :: NL=81,NLP1=NL+1,NLGTH=37*NL,NKK=41,NK=81,NKP=NK+1
6531 !----------------------------------------------------------------------
6532 ! INCLUDE "SEASO3.comm"
6533 !---------------------------------------------------------------------
6534 ! REAL, INTENT(OUT), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
6535 ! REAL, INTENT(OUT), DIMENSION(NL) :: PRGFDL
6537 ! COMMON /SEASO3/
6538 ! ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL.....
6539 ! & XDUO3N(37,NL), XDO3N2(37,NL), XDO3N3(37,NL), XDO3N4(37,NL)
6540 !
6541 ! &,PRGFDL(NL)
6542 !---------------------------------------------------------------------
6543 REAL :: PH1(45),PH2(37),P1(48),P2(33),O3HI1(10,16),O3HI2(10,9) &
6544 ,O3LO1(10,16),O3LO2(10,16),O3LO3(10,16),O3LO4(10,16)
6545 !----------------------------------------------------------------------
6546 REAL :: AVG,A1,B1,B2
6547 INTEGER :: K,N,NCASE,IPLACE,KK,NKM,NKMM,KI,KQ,JJ,KEN,I,iindex,jindex
6548 !----------------------------------------------------------------------
6549 REAL :: PSTD(NL),TEMPN(19),O3O3(37,NL,4),O35DEG(37,NL) &
6550 ,XRAD1(NLGTH),XRAD2(NLGTH),XRAD3(NLGTH),XRAD4(NLGTH) &
6551 ,DDUO3N(19,NL),DUO3N(19,41) &
6552 ,RO3(10,41),RO3M(10,40),RO31(10,41),RO32(10,41) &
6553 ,O3HI(10,25) &
6554 ,RSTD(81),RBAR(NL),RDATA(81) &
6555 ,PHALF(NL),P(81),PH(82)
6557 REAL :: PXX(81),PYY(82) ! fix for nesting: gopal's doing
6559 !----------------------------------------------------------------------
6560 ! EQUIVALENCE &
6561 ! (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
6562 ! ,(PH1(1),PH(1)),(PH2(1),PH(46)) &
6563 ! ,(P1(1),P(1)),(P2(1),P(49))
6565 EQUIVALENCE &
6566 (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
6567 ,(PH1(1),PYY(1)),(PH2(1),PYY(46)) & ! fix for nesting: gopal's doing
6568 ,(P1(1),PXX(1)),(P2(1),PXX(49)) ! fix for nesting: gopal's doing
6571 !----------------------------------------------------------------------
6572 ! EQUIVALENCE &
6573 ! (XRAD1(1),XDUO3N(1,1),O3O3(1,1,1)) &
6574 ! ,(XRAD2(1),XDO3N2(1,1)) &
6575 ! ,(XRAD3(1),XDO3N3(1,1)),(XRAD4(1),XDO3N4(1,1),)
6576 EQUIVALENCE &
6577 (XRAD1(1),O3O3(1,1,1)) &
6578 ,(XRAD2(1),O3O3(1,1,2)) &
6579 ,(XRAD3(1),O3O3(1,1,3)),(XRAD4(1),O3O3(1,1,4))
6580 !----------------------------------------------------------------------
6581 !---------------------------------------------------------------------
6582 DATA PH1/ 0., &
6583 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, &
6584 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, &
6585 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, &
6586 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, &
6587 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, &
6588 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, &
6589 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, &
6590 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, &
6591 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, &
6592 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, &
6593 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
6594 DATA PH2/ &
6595 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, &
6596 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, &
6597 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, &
6598 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, &
6599 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, &
6600 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, &
6601 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, &
6602 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, &
6603 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, &
6604 0.1000000E+01/
6605 DATA P1/ &
6606 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, &
6607 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, &
6608 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, &
6609 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, &
6610 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, &
6611 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, &
6612 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, &
6613 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, &
6614 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, &
6615 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, &
6616 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, &
6617 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
6618 DATA P2/ &
6619 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, &
6620 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, &
6621 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, &
6622 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, &
6623 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, &
6624 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, &
6625 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, &
6626 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, &
6627 0.1000000E+01/
6628 DATA O3HI1/ &
6629 .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, &
6630 .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, &
6631 .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, &
6632 .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, &
6633 .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, &
6634 .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, &
6635 .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, &
6636 .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, &
6637 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, &
6638 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, &
6639 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, &
6640 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, &
6641 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, &
6642 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, &
6643 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, &
6644 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/
6645 DATA O3HI2/ &
6646 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, &
6647 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, &
6648 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, &
6649 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, &
6650 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, &
6651 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, &
6652 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
6653 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, &
6654 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
6655 DATA O3LO1/ &
6656 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, &
6657 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, &
6658 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, &
6659 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, &
6660 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, &
6661 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, &
6662 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, &
6663 .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, &
6664 .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, &
6665 .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, &
6666 .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, &
6667 .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, &
6668 .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, &
6669 .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, &
6670 .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, &
6671 .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
6672 DATA O3LO2/ &
6673 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, &
6674 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, &
6675 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, &
6676 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, &
6677 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, &
6678 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, &
6679 .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, &
6680 .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, &
6681 .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, &
6682 .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, &
6683 .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, &
6684 .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, &
6685 .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, &
6686 .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, &
6687 .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, &
6688 .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
6689 DATA O3LO3/ &
6690 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, &
6691 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, &
6692 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, &
6693 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, &
6694 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, &
6695 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, &
6696 .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, &
6697 .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, &
6698 .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, &
6699 .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, &
6700 .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, &
6701 .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, &
6702 .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, &
6703 .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, &
6704 .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, &
6705 .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
6706 DATA O3LO4/ &
6707 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, &
6708 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, &
6709 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, &
6710 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, &
6711 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, &
6712 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, &
6713 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, &
6714 .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, &
6715 .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, &
6716 .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, &
6717 .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, &
6718 .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, &
6719 .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, &
6720 .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, &
6721 .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, &
6722 .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/
6723 !----------------------------------------------------------------------
6724 !***
6725 !*** COMPUTE DETAILED O3 PROFILE FROM THE ORIGINAL GFDL PRESSURES
6726 !*** WHERE OUTPUT FROM O3INT (PSTD) IS TOP DOWN IN MB*1.E3
6727 !*** AND PSFC=1013.25 MB ......K.A.C. DEC94
6728 !***
6730 DO K=1,NK
6731 PH(K)=PYY(K)*1013250. ! fix for nesting: gopal's doing
6732 P(K)=PXX(K)*1013250.
6733 ENDDO
6734 !
6735 PH(NKP)=PYY(NKP)*1013250. ! fixed; dusan
6736 !
6737 DO K=1,NL
6738 PSTD(K)=P(K)
6739 ENDDO
6740 !
6741 DO K=1,25
6742 DO N=1,10
6743 RO31(N,K)=O3HI(N,K)
6744 RO32(N,K)=O3HI(N,K)
6745 ENDDO
6746 ENDDO
6747 !----------------------------------------------------------------------
6748 DO 100 NCASE=1,4
6749 !
6750 !*** NCASE=1: SPRING (IN N.H.)
6751 !*** NCASE=2: FALL (IN N.H.)
6752 !*** NCASE=3: WINTER (IN N.H.)
6753 !*** NCASE=4: SUMMER (IN N.H.)
6754 !
6755 IPLACE=2
6756 IF(NCASE.EQ.2)IPLACE=4
6757 IF(NCASE.EQ.3)IPLACE=1
6758 IF(NCASE.EQ.4)IPLACE=3
6759 !
6760 IF(NCASE.EQ.1.OR.NCASE.EQ.2)THEN
6761 DO K=26,41
6762 DO N=1,10
6763 RO31(N,K)=O3LO1(N,K-25)
6764 RO32(N,K)=O3LO2(N,K-25)
6765 ENDDO
6766 ENDDO
6767 ENDIF
6768 !
6769 IF(NCASE.EQ.3.OR.NCASE.EQ.4)THEN
6770 DO K=26,41
6771 DO N=1,10
6772 RO31(N,K)=O3LO3(N,K-25)
6773 RO32(N,K)=O3LO4(N,K-25)
6774 ENDDO
6775 ENDDO
6776 ENDIF
6777 !
6778 DO 25 KK=1,NKK
6779 DO N=1,10
6780 DUO3N(N,KK)=RO31(11-N,KK)
6781 DUO3N(N+9,KK)=RO32(N,KK)
6782 ENDDO
6783 DUO3N(10,KK)=0.5*(RO31(1,KK)+RO32(1,KK))
6784 25 CONTINUE
6785 !
6786 !***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON
6787 !
6788 IF(NCASE.EQ.2.OR.NCASE.EQ.4)THEN
6789 DO 50 KK=1,NKK
6790 DO N=1,19
6791 TEMPN(N)=DUO3N(20-N,KK)
6792 ENDDO
6793 DO N=1,19
6794 DUO3N(N,KK)=TEMPN(N)
6795 ENDDO
6796 50 CONTINUE
6797 ENDIF
6798 !
6799 !*** DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON AT STD PRESSURE
6800 !*** LEVELS
6801 !
6802 !*** BEGIN LATITUDE (10 DEG) LOOP
6803 !
6804 DO 75 N=1,19
6805 !
6806 DO KK=1,NKK
6807 RSTD(KK)=DUO3N(N,KK)
6808 ENDDO
6809 !
6810 NKM=NK-1
6811 NKMM=NK-3
6812 !***
6813 !*** BESSELS HALF-POINT INTERPOLATION FORMULA
6814 !***
6815 DO K=4,NKMM,2
6816 KI=K/2
6817 RDATA(K)=0.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1) &
6818 -RSTD(KI)+RSTD(KI-1))/16.
6819 ENDDO
6820 !
6821 RDATA(2)=0.5*(RSTD(2)+RSTD(1))
6822 RDATA(NKM)=0.5*(RSTD(NKK)+RSTD(NKK-1))
6823 !
6824 !*** PUT UNCHANGED DATA INTO NEW ARRAY
6825 !
6826 DO K=1,NK,2
6827 KQ=(K+1)/2
6828 RDATA(K)=RSTD(KQ)
6829 ENDDO
6830 !
6831 DO KK=1,NL
6832 DDUO3N(N,KK)=RDATA(KK)*.01
6833 ENDDO
6834 !
6835 75 CONTINUE
6836 !
6837 !*** END OF LATITUDE LOOP
6838 !
6839 !----------------------------------------------------------------------
6840 !***
6841 !*** CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF
6842 !*** 10 DEG VALUES
6843 !***
6844 DO 90 KK=1,NL
6845 !
6846 DO N=1,19
6847 O35DEG(2*N-1,KK)=DDUO3N(N,KK)
6848 ENDDO
6849 !
6850 DO N=1,18
6851 O35DEG(2*N,KK)=0.5*(DDUO3N(N,KK)+DDUO3N(N+1,KK))
6852 ENDDO
6853 !
6854 90 CONTINUE
6855 !
6856 DO JJ=1,37
6857 DO KEN=1,NL
6858 O3O3(JJ,KEN,IPLACE)=O35DEG(JJ,KEN)
6859 ENDDO
6860 ENDDO
6861 !
6862 100 CONTINUE
6863 !----------------------------------------------------------------------
6864 !*** END OF LOOP OVER CASES
6865 !----------------------------------------------------------------------
6866 !***
6867 !*** AVERAGE CLIMATOLOGICAL VALUS OF O3 FROM 5 DEG LAT MEANS, SO THAT
6868 !*** TIME AND SPACE INTERPOLATION WILL WORK (SEE SUBR OZON2D)
6869 !***
6870 DO I=1,NLGTH
6871 AVG=0.25*(XRAD1(I)+XRAD2(I)+XRAD3(I)+XRAD4(I))
6872 A1=0.5*(XRAD2(I)-XRAD4(I))
6873 B1=0.5*(XRAD1(I)-XRAD3(I))
6874 B2=0.25*((XRAD1(I)+XRAD3(I))-(XRAD2(I)+XRAD4(I)))
6876 ! XRAD1(I)=AVG
6877 ! XRAD2(I)=A1
6878 ! XRAD3(I)=B1
6879 ! XRAD4(I)=B2
6881 iindex = 1+mod((I-1),37)
6882 jindex = 1+(I-1)/37
6883 XDUO3N(iindex,jindex)=AVG
6884 XDO3N2(iindex,jindex)=A1
6885 XDO3N3(iindex,jindex)=B1
6886 XDO3N4(iindex,jindex)=B2
6887 ENDDO
6888 !***
6889 !*** CONVERT GFDL PRESSURE (MICROBARS) TO PA
6890 !***
6891 DO N=1,NL
6892 PRGFDL(N)=PSTD(N)*1.E-1
6893 ENDDO
6894 !
6895 END SUBROUTINE O3CLIM
6897 !---------------------------------------------------------------------
6898 SUBROUTINE TABLE
6899 ! (TABLE1,TABLE2,TABLE3,EM1,EM1WDE,EM3, &
6900 ! SOURCE,DSRCE )
6901 !---------------------------------------------------------------------
6902 IMPLICIT NONE
6903 !----------------------------------------------------------------------
6905 !INTEGER, PARAMETER :: NBLY=15
6906 INTEGER, PARAMETER :: NB=12
6907 INTEGER, PARAMETER :: NBLX=47
6908 INTEGER , PARAMETER:: NBLW = 163
6910 REAL,PARAMETER :: AMOLWT=28.9644
6911 REAL,PARAMETER :: CSUBP=1.00484E7
6912 REAL,PARAMETER :: DIFFCTR=1.66
6913 REAL,PARAMETER :: G=980.665
6914 REAL,PARAMETER :: GINV=1./G
6915 REAL,PARAMETER :: GRAVDR=980.0
6916 REAL,PARAMETER :: O3DIFCTR=1.90
6917 REAL,PARAMETER :: P0=1013250.
6918 REAL,PARAMETER :: P0INV=1./P0
6919 REAL,PARAMETER :: GP0INV=GINV*P0INV
6920 REAL,PARAMETER :: P0XZP2=202649.902
6921 REAL,PARAMETER :: P0XZP8=810600.098
6922 REAL,PARAMETER :: P0X2=2.*1013250.
6923 REAL,PARAMETER :: RADCON=8.427
6924 REAL,PARAMETER :: RADCON1=1./8.427
6925 REAL,PARAMETER :: RATCO2MW=1.519449738
6926 REAL,PARAMETER :: RATH2OMW=.622
6927 REAL,PARAMETER :: RGAS=8.3142E7
6928 REAL,PARAMETER :: RGASSP=8.31432E7
6929 REAL,PARAMETER :: SECPDA=8.64E4
6930 !
6931 !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
6932 ! ARRANGED IN DECREASING ORDER
6933 REAL,PARAMETER :: HUNDRED=100.
6934 REAL,PARAMETER :: HNINETY=90.
6935 REAL,PARAMETER :: HNINE=9.0
6936 REAL,PARAMETER :: SIXTY=60.
6937 REAL,PARAMETER :: FIFTY=50.
6938 REAL,PARAMETER :: TEN=10.
6939 REAL,PARAMETER :: EIGHT=8.
6940 REAL,PARAMETER :: FIVE=5.
6941 REAL,PARAMETER :: FOUR=4.
6942 REAL,PARAMETER :: THREE=3.
6943 REAL,PARAMETER :: TWO=2.
6944 REAL,PARAMETER :: ONE=1.
6945 REAL,PARAMETER :: HAF=0.5
6946 REAL,PARAMETER :: QUARTR=0.25
6947 REAL,PARAMETER :: ZERO=0.
6948 !
6949 !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
6950 ! ARRANGED IN DECREASING ORDER
6951 REAL,PARAMETER :: H83E26=8.3E26
6952 REAL,PARAMETER :: H71E26=7.1E26
6953 REAL,PARAMETER :: H1E15=1.E15
6954 REAL,PARAMETER :: H1E13=1.E13
6955 REAL,PARAMETER :: H1E11=1.E11
6956 REAL,PARAMETER :: H1E8=1.E8
6957 REAL,PARAMETER :: H2E6=2.0E6
6958 REAL,PARAMETER :: H1E6=1.0E6
6959 REAL,PARAMETER :: H69766E5=6.97667E5
6960 REAL,PARAMETER :: H4E5=4.E5
6961 REAL,PARAMETER :: H165E5=1.65E5
6962 REAL,PARAMETER :: H5725E4=57250.
6963 REAL,PARAMETER :: H488E4=48800.
6964 REAL,PARAMETER :: H1E4=1.E4
6965 REAL,PARAMETER :: H24E3=2400.
6966 REAL,PARAMETER :: H20788E3=2078.8
6967 REAL,PARAMETER :: H2075E3=2075.
6968 REAL,PARAMETER :: H18E3=1800.
6969 REAL,PARAMETER :: H1224E3=1224.
6970 REAL,PARAMETER :: H67390E2=673.9057
6971 REAL,PARAMETER :: H5E2=500.
6972 REAL,PARAMETER :: H3082E2=308.2
6973 REAL,PARAMETER :: H3E2=300.
6974 REAL,PARAMETER :: H2945E2=294.5
6975 REAL,PARAMETER :: H29316E2=293.16
6976 REAL,PARAMETER :: H26E2=260.0
6977 REAL,PARAMETER :: H25E2=250.
6978 REAL,PARAMETER :: H23E2=230.
6979 REAL,PARAMETER :: H2E2=200.0
6980 REAL,PARAMETER :: H15E2=150.
6981 REAL,PARAMETER :: H1386E2=138.6
6982 REAL,PARAMETER :: H1036E2=103.6
6983 REAL,PARAMETER :: H8121E1=81.21
6984 REAL,PARAMETER :: H35E1=35.
6985 REAL,PARAMETER :: H3116E1=31.16
6986 REAL,PARAMETER :: H28E1=28.
6987 REAL,PARAMETER :: H181E1=18.1
6988 REAL,PARAMETER :: H18E1=18.
6989 REAL,PARAMETER :: H161E1=16.1
6990 REAL,PARAMETER :: H16E1=16.
6991 REAL,PARAMETER :: H1226E1=12.26
6992 REAL,PARAMETER :: H9P94=9.94
6993 REAL,PARAMETER :: H6P08108=6.081081081
6994 REAL,PARAMETER :: H3P6=3.6
6995 REAL,PARAMETER :: H3P5=3.5
6996 REAL,PARAMETER :: H2P9=2.9
6997 REAL,PARAMETER :: H2P8=2.8
6998 REAL,PARAMETER :: H2P5=2.5
6999 REAL,PARAMETER :: H1P8=1.8
7000 REAL,PARAMETER :: H1P4387=1.4387
7001 REAL,PARAMETER :: H1P41819=1.418191
7002 REAL,PARAMETER :: H1P4=1.4
7003 REAL,PARAMETER :: H1P25892=1.258925411
7004 REAL,PARAMETER :: H1P082=1.082
7005 REAL,PARAMETER :: HP816=0.816
7006 REAL,PARAMETER :: HP805=0.805
7007 REAL,PARAMETER :: HP8=0.8
7008 REAL,PARAMETER :: HP60241=0.60241
7009 REAL,PARAMETER :: HP602409=0.60240964
7010 REAL,PARAMETER :: HP6=0.6
7011 REAL,PARAMETER :: HP526315=0.52631579
7012 REAL,PARAMETER :: HP518=0.518
7013 REAL,PARAMETER :: HP5048=0.5048
7014 REAL,PARAMETER :: HP3795=0.3795
7015 REAL,PARAMETER :: HP369=0.369
7016 REAL,PARAMETER :: HP26=0.26
7017 REAL,PARAMETER :: HP228=0.228
7018 REAL,PARAMETER :: HP219=0.219
7019 REAL,PARAMETER :: HP166666=.166666
7020 REAL,PARAMETER :: HP144=0.144
7021 REAL,PARAMETER :: HP118666=0.118666192
7022 REAL,PARAMETER :: HP1=0.1
7023 ! (NEGATIVE EXPONENTIALS BEGIN HERE)
7024 REAL,PARAMETER :: H658M2=0.0658
7025 REAL,PARAMETER :: H625M2=0.0625
7026 REAL,PARAMETER :: H44871M2=4.4871E-2
7027 REAL,PARAMETER :: H44194M2=.044194
7028 REAL,PARAMETER :: H42M2=0.042
7029 REAL,PARAMETER :: H41666M2=0.0416666
7030 REAL,PARAMETER :: H28571M2=.02857142857
7031 REAL,PARAMETER :: H2118M2=0.02118
7032 REAL,PARAMETER :: H129M2=0.0129
7033 REAL,PARAMETER :: H1M2=.01
7034 REAL,PARAMETER :: H559M3=5.59E-3
7035 REAL,PARAMETER :: H3M3=0.003
7036 REAL,PARAMETER :: H235M3=2.35E-3
7037 REAL,PARAMETER :: H1M3=1.0E-3
7038 REAL,PARAMETER :: H987M4=9.87E-4
7039 REAL,PARAMETER :: H323M4=0.000323
7040 REAL,PARAMETER :: H3M4=0.0003
7041 REAL,PARAMETER :: H285M4=2.85E-4
7042 REAL,PARAMETER :: H1M4=0.0001
7043 REAL,PARAMETER :: H75826M4=7.58265E-4
7044 REAL,PARAMETER :: H6938M5=6.938E-5
7045 REAL,PARAMETER :: H394M5=3.94E-5
7046 REAL,PARAMETER :: H37412M5=3.7412E-5
7047 REAL,PARAMETER :: H15M5=1.5E-5
7048 REAL,PARAMETER :: H1439M5=1.439E-5
7049 REAL,PARAMETER :: H128M5=1.28E-5
7050 REAL,PARAMETER :: H102M5=1.02E-5
7051 REAL,PARAMETER :: H1M5=1.0E-5
7052 REAL,PARAMETER :: H7M6=7.E-6
7053 REAL,PARAMETER :: H4999M6=4.999E-6
7054 REAL,PARAMETER :: H451M6=4.51E-6
7055 REAL,PARAMETER :: H25452M6=2.5452E-6
7056 REAL,PARAMETER :: H1M6=1.E-6
7057 REAL,PARAMETER :: H391M7=3.91E-7
7058 REAL,PARAMETER :: H1174M7=1.174E-7
7059 REAL,PARAMETER :: H8725M8=8.725E-8
7060 REAL,PARAMETER :: H327M8=3.27E-8
7061 REAL,PARAMETER :: H257M8=2.57E-8
7062 REAL,PARAMETER :: H1M8=1.0E-8
7063 REAL,PARAMETER :: H23M10=2.3E-10
7064 REAL,PARAMETER :: H14M10=1.4E-10
7065 REAL,PARAMETER :: H11M10=1.1E-10
7066 REAL,PARAMETER :: H1M10=1.E-10
7067 REAL,PARAMETER :: H83M11=8.3E-11
7068 REAL,PARAMETER :: H82M11=8.2E-11
7069 REAL,PARAMETER :: H8M11=8.E-11
7070 REAL,PARAMETER :: H77M11=7.7E-11
7071 REAL,PARAMETER :: H72M11=7.2E-11
7072 REAL,PARAMETER :: H53M11=5.3E-11
7073 REAL,PARAMETER :: H48M11=4.8E-11
7074 REAL,PARAMETER :: H44M11=4.4E-11
7075 REAL,PARAMETER :: H42M11=4.2E-11
7076 REAL,PARAMETER :: H37M11=3.7E-11
7077 REAL,PARAMETER :: H35M11=3.5E-11
7078 REAL,PARAMETER :: H32M11=3.2E-11
7079 REAL,PARAMETER :: H3M11=3.0E-11
7080 REAL,PARAMETER :: H28M11=2.8E-11
7081 REAL,PARAMETER :: H24M11=2.4E-11
7082 REAL,PARAMETER :: H23M11=2.3E-11
7083 REAL,PARAMETER :: H2M11=2.E-11
7084 REAL,PARAMETER :: H18M11=1.8E-11
7085 REAL,PARAMETER :: H15M11=1.5E-11
7086 REAL,PARAMETER :: H14M11=1.4E-11
7087 REAL,PARAMETER :: H114M11=1.14E-11
7088 REAL,PARAMETER :: H11M11=1.1E-11
7089 REAL,PARAMETER :: H1M11=1.E-11
7090 REAL,PARAMETER :: H96M12=9.6E-12
7091 REAL,PARAMETER :: H93M12=9.3E-12
7092 REAL,PARAMETER :: H77M12=7.7E-12
7093 REAL,PARAMETER :: H74M12=7.4E-12
7094 REAL,PARAMETER :: H65M12=6.5E-12
7095 REAL,PARAMETER :: H62M12=6.2E-12
7096 REAL,PARAMETER :: H6M12=6.E-12
7097 REAL,PARAMETER :: H45M12=4.5E-12
7098 REAL,PARAMETER :: H44M12=4.4E-12
7099 REAL,PARAMETER :: H4M12=4.E-12
7100 REAL,PARAMETER :: H38M12=3.8E-12
7101 REAL,PARAMETER :: H37M12=3.7E-12
7102 REAL,PARAMETER :: H3M12=3.E-12
7103 REAL,PARAMETER :: H29M12=2.9E-12
7104 REAL,PARAMETER :: H28M12=2.8E-12
7105 REAL,PARAMETER :: H24M12=2.4E-12
7106 REAL,PARAMETER :: H21M12=2.1E-12
7107 REAL,PARAMETER :: H16M12=1.6E-12
7108 REAL,PARAMETER :: H14M12=1.4E-12
7109 REAL,PARAMETER :: H12M12=1.2E-12
7110 REAL,PARAMETER :: H8M13=8.E-13
7111 REAL,PARAMETER :: H46M13=4.6E-13
7112 REAL,PARAMETER :: H36M13=3.6E-13
7113 REAL,PARAMETER :: H135M13=1.35E-13
7114 REAL,PARAMETER :: H12M13=1.2E-13
7115 REAL,PARAMETER :: H1M13=1.E-13
7116 REAL,PARAMETER :: H3M14=3.E-14
7117 REAL,PARAMETER :: H15M14=1.5E-14
7118 REAL,PARAMETER :: H14M14=1.4E-14
7119 !
7120 !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
7121 ! ARRANGED IN DESCENDING ORDER
7122 REAL,PARAMETER :: HM2M2=-.02
7123 REAL,PARAMETER :: HM6666M2=-.066667
7124 REAL,PARAMETER :: HMP5=-0.5
7125 REAL,PARAMETER :: HMP575=-0.575
7126 REAL,PARAMETER :: HMP66667=-.66667
7127 REAL,PARAMETER :: HMP805=-0.805
7128 REAL,PARAMETER :: HM1EZ=-1.
7129 REAL,PARAMETER :: HM13EZ=-1.3
7130 REAL,PARAMETER :: HM19EZ=-1.9
7131 REAL,PARAMETER :: HM1E1=-10.
7132 REAL,PARAMETER :: HM1597E1=-15.97469413
7133 REAL,PARAMETER :: HM161E1=-16.1
7134 REAL,PARAMETER :: HM1797E1=-17.97469413
7135 REAL,PARAMETER :: HM181E1=-18.1
7136 REAL,PARAMETER :: HM8E1=-80.
7137 REAL,PARAMETER :: HM1E2=-100.
7138 !
7139 REAL,PARAMETER :: H1M16=1.0E-16
7140 REAL,PARAMETER :: H1M20=1.E-20
7141 REAL,PARAMETER :: HP98=0.98
7142 REAL,PARAMETER :: Q19001=19.001
7143 REAL,PARAMETER :: DAYSEC=1.1574E-5
7144 REAL,PARAMETER :: HSIGMA=5.673E-5
7145 REAL,PARAMETER :: TWENTY=20.0
7146 REAL,PARAMETER :: HP537=0.537
7147 REAL,PARAMETER :: HP2=0.2
7148 REAL,PARAMETER :: RCO2=3.3E-4
7149 REAL,PARAMETER :: Q14330=1.43306E-6
7150 REAL,PARAMETER :: H3M6=3.0E-6
7151 REAL,PARAMETER :: PI=3.1415927
7152 REAL,PARAMETER :: DEGRAD=180.0/PI
7153 REAL,PARAMETER :: H74E1=74.0
7154 REAL,PARAMETER :: H15E1=15.0
7156 REAL, PARAMETER:: B0 = -.51926410E-4
7157 REAL, PARAMETER:: B1 = -.18113332E-3
7158 REAL, PARAMETER:: B2 = -.10680132E-5
7159 REAL, PARAMETER:: B3 = -.67303519E-7
7160 REAL, PARAMETER:: AWIDE = 0.309801E+01
7161 REAL, PARAMETER:: BWIDE = 0.495357E-01
7162 REAL, PARAMETER:: BETAWD = 0.347839E+02
7163 REAL, PARAMETER:: BETINW = 0.766811E+01
7166 ! REAL, INTENT(OUT) :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), &
7167 ! TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
7168 ! SOURCE(28,NBLY), DSRCE(28,NBLY)
7170 !
7171 REAL :: ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW)
7172 REAL :: BANDLO(NBLW),BANDHI(NBLW)
7174 INTEGER :: IBAND(40)
7176 REAL :: BANDL1(64),BANDL2(64),BANDL3(35)
7177 REAL :: BANDH1(64),BANDH2(64),BANDH3(35)
7178 ! REAL :: AB15WD,SKO2D,SKC1R,SKO3R
7180 ! REAL :: AWIDE,BWIDE,BETAWD,BETINW
7182 ! DATA AWIDE / 0.309801E+01/
7183 ! DATA BWIDE / 0.495357E-01/
7184 ! DATA BETAWD / 0.347839E+02/
7185 ! DATA BETINW / 0.766811E+01/
7187 !
7188 !% #NPADL = #PAGE*#NPAGE - 4*28*180 - 2*181 - 7*28 - 180 ;
7189 !% #NPADL = #NPADL - 11*28 - 2*180 - 2*30 ;
7191 ! PARAMETER (NPADL = #NPADL - 28*NBLX - 2*28*NBLW - 7*NBLW)
7193 REAL :: &
7194 SUM(28,180),PERTSM(28,180),SUM3(28,180), &
7195 SUMWDE(28,180),SRCWD(28,NBLX),SRC1NB(28,NBLW), &
7196 DBDTNB(28,NBLW)
7197 REAL :: &
7198 ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28), &
7199 TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28), &
7200 SUM4(28),SUM6(28),SUM7(28),SUM8(28),SUM4WD(28), &
7201 R1T(28),R2(28),S2(28),T3(28),R1WD(28)
7202 REAL :: EXPO(180),FAC(180)
7203 REAL :: CNUSB(30),DNUSB(30)
7204 REAL :: ALFANB(NBLW),AROTNB(NBLW)
7205 REAL :: ANB(NBLW),BNB(NBLW),CENTNB(NBLW),DELNB(NBLW), &
7206 BETANB(NBLW)
7208 REAL :: AB15(2)
7210 REAL :: ARNDM1(64),ARNDM2(64),ARNDM3(35)
7211 REAL :: BRNDM1(64),BRNDM2(64),BRNDM3(35)
7212 REAL :: BETAD1(64),BETAD2(64),BETAD3(35)
7214 EQUIVALENCE (ARNDM1(1),ARNDM(1)),(ARNDM2(1),ARNDM(65)), &
7215 (ARNDM3(1),ARNDM(129))
7216 EQUIVALENCE (BRNDM1(1),BRNDM(1)),(BRNDM2(1),BRNDM(65)), &
7217 (BRNDM3(1),BRNDM(129))
7218 EQUIVALENCE (BETAD1(1),BETAD(1)),(BETAD2(1),BETAD(65)), &
7219 (BETAD3(1),BETAD(129))
7221 !---------------------------------------------------------------
7222 REAL :: CENT,DEL,BDLO,BDHI,C1,ANU,tmp
7223 INTEGER :: N,I,ICNT,I1,I2E,I2
7224 INTEGER :: J,JP,NSUBDS,NSB,IA
7226 !---------------------------------------------------------------
7228 DATA IBAND / &
7229 2, 1, 2, 2, 1, 2, 1, 3, 2, 2, &
7230 3, 2, 2, 4, 2, 4, 2, 3, 3, 2, &
7231 4, 3, 4, 3, 7, 5, 6, 7, 6, 5, &
7232 7, 6, 7, 8, 6, 6, 8, 8, 8, 8/
7234 DATA BANDL1 / &
7235 0.000000E+00, 0.100000E+02, 0.200000E+02, 0.300000E+02, &
7236 0.400000E+02, 0.500000E+02, 0.600000E+02, 0.700000E+02, &
7237 0.800000E+02, 0.900000E+02, 0.100000E+03, 0.110000E+03, &
7238 0.120000E+03, 0.130000E+03, 0.140000E+03, 0.150000E+03, &
7239 0.160000E+03, 0.170000E+03, 0.180000E+03, 0.190000E+03, &
7240 0.200000E+03, 0.210000E+03, 0.220000E+03, 0.230000E+03, &
7241 0.240000E+03, 0.250000E+03, 0.260000E+03, 0.270000E+03, &
7242 0.280000E+03, 0.290000E+03, 0.300000E+03, 0.310000E+03, &
7243 0.320000E+03, 0.330000E+03, 0.340000E+03, 0.350000E+03, &
7244 0.360000E+03, 0.370000E+03, 0.380000E+03, 0.390000E+03, &
7245 0.400000E+03, 0.410000E+03, 0.420000E+03, 0.430000E+03, &
7246 0.440000E+03, 0.450000E+03, 0.460000E+03, 0.470000E+03, &
7247 0.480000E+03, 0.490000E+03, 0.500000E+03, 0.510000E+03, &
7248 0.520000E+03, 0.530000E+03, 0.540000E+03, 0.550000E+03, &
7249 0.560000E+03, 0.670000E+03, 0.800000E+03, 0.900000E+03, &
7250 0.990000E+03, 0.107000E+04, 0.120000E+04, 0.121000E+04/
7251 DATA BANDL2 / &
7252 0.122000E+04, 0.123000E+04, 0.124000E+04, 0.125000E+04, &
7253 0.126000E+04, 0.127000E+04, 0.128000E+04, 0.129000E+04, &
7254 0.130000E+04, 0.131000E+04, 0.132000E+04, 0.133000E+04, &
7255 0.134000E+04, 0.135000E+04, 0.136000E+04, 0.137000E+04, &
7256 0.138000E+04, 0.139000E+04, 0.140000E+04, 0.141000E+04, &
7257 0.142000E+04, 0.143000E+04, 0.144000E+04, 0.145000E+04, &
7258 0.146000E+04, 0.147000E+04, 0.148000E+04, 0.149000E+04, &
7259 0.150000E+04, 0.151000E+04, 0.152000E+04, 0.153000E+04, &
7260 0.154000E+04, 0.155000E+04, 0.156000E+04, 0.157000E+04, &
7261 0.158000E+04, 0.159000E+04, 0.160000E+04, 0.161000E+04, &
7262 0.162000E+04, 0.163000E+04, 0.164000E+04, 0.165000E+04, &
7263 0.166000E+04, 0.167000E+04, 0.168000E+04, 0.169000E+04, &
7264 0.170000E+04, 0.171000E+04, 0.172000E+04, 0.173000E+04, &
7265 0.174000E+04, 0.175000E+04, 0.176000E+04, 0.177000E+04, &
7266 0.178000E+04, 0.179000E+04, 0.180000E+04, 0.181000E+04, &
7267 0.182000E+04, 0.183000E+04, 0.184000E+04, 0.185000E+04/
7268 DATA BANDL3 / &
7269 0.186000E+04, 0.187000E+04, 0.188000E+04, 0.189000E+04, &
7270 0.190000E+04, 0.191000E+04, 0.192000E+04, 0.193000E+04, &
7271 0.194000E+04, 0.195000E+04, 0.196000E+04, 0.197000E+04, &
7272 0.198000E+04, 0.199000E+04, 0.200000E+04, 0.201000E+04, &
7273 0.202000E+04, 0.203000E+04, 0.204000E+04, 0.205000E+04, &
7274 0.206000E+04, 0.207000E+04, 0.208000E+04, 0.209000E+04, &
7275 0.210000E+04, 0.211000E+04, 0.212000E+04, 0.213000E+04, &
7276 0.214000E+04, 0.215000E+04, 0.216000E+04, 0.217000E+04, &
7277 0.218000E+04, 0.219000E+04, 0.227000E+04/
7279 DATA BANDH1 / &
7280 0.100000E+02, 0.200000E+02, 0.300000E+02, 0.400000E+02, &
7281 0.500000E+02, 0.600000E+02, 0.700000E+02, 0.800000E+02, &
7282 0.900000E+02, 0.100000E+03, 0.110000E+03, 0.120000E+03, &
7283 0.130000E+03, 0.140000E+03, 0.150000E+03, 0.160000E+03, &
7284 0.170000E+03, 0.180000E+03, 0.190000E+03, 0.200000E+03, &
7285 0.210000E+03, 0.220000E+03, 0.230000E+03, 0.240000E+03, &
7286 0.250000E+03, 0.260000E+03, 0.270000E+03, 0.280000E+03, &
7287 0.290000E+03, 0.300000E+03, 0.310000E+03, 0.320000E+03, &
7288 0.330000E+03, 0.340000E+03, 0.350000E+03, 0.360000E+03, &
7289 0.370000E+03, 0.380000E+03, 0.390000E+03, 0.400000E+03, &
7290 0.410000E+03, 0.420000E+03, 0.430000E+03, 0.440000E+03, &
7291 0.450000E+03, 0.460000E+03, 0.470000E+03, 0.480000E+03, &
7292 0.490000E+03, 0.500000E+03, 0.510000E+03, 0.520000E+03, &
7293 0.530000E+03, 0.540000E+03, 0.550000E+03, 0.560000E+03, &
7294 0.670000E+03, 0.800000E+03, 0.900000E+03, 0.990000E+03, &
7295 0.107000E+04, 0.120000E+04, 0.121000E+04, 0.122000E+04/
7296 DATA BANDH2 / &
7297 0.123000E+04, 0.124000E+04, 0.125000E+04, 0.126000E+04, &
7298 0.127000E+04, 0.128000E+04, 0.129000E+04, 0.130000E+04, &
7299 0.131000E+04, 0.132000E+04, 0.133000E+04, 0.134000E+04, &
7300 0.135000E+04, 0.136000E+04, 0.137000E+04, 0.138000E+04, &
7301 0.139000E+04, 0.140000E+04, 0.141000E+04, 0.142000E+04, &
7302 0.143000E+04, 0.144000E+04, 0.145000E+04, 0.146000E+04, &
7303 0.147000E+04, 0.148000E+04, 0.149000E+04, 0.150000E+04, &
7304 0.151000E+04, 0.152000E+04, 0.153000E+04, 0.154000E+04, &
7305 0.155000E+04, 0.156000E+04, 0.157000E+04, 0.158000E+04, &
7306 0.159000E+04, 0.160000E+04, 0.161000E+04, 0.162000E+04, &
7307 0.163000E+04, 0.164000E+04, 0.165000E+04, 0.166000E+04, &
7308 0.167000E+04, 0.168000E+04, 0.169000E+04, 0.170000E+04, &
7309 0.171000E+04, 0.172000E+04, 0.173000E+04, 0.174000E+04, &
7310 0.175000E+04, 0.176000E+04, 0.177000E+04, 0.178000E+04, &
7311 0.179000E+04, 0.180000E+04, 0.181000E+04, 0.182000E+04, &
7312 0.183000E+04, 0.184000E+04, 0.185000E+04, 0.186000E+04/
7313 DATA BANDH3 / &
7314 0.187000E+04, 0.188000E+04, 0.189000E+04, 0.190000E+04, &
7315 0.191000E+04, 0.192000E+04, 0.193000E+04, 0.194000E+04, &
7316 0.195000E+04, 0.196000E+04, 0.197000E+04, 0.198000E+04, &
7317 0.199000E+04, 0.200000E+04, 0.201000E+04, 0.202000E+04, &
7318 0.203000E+04, 0.204000E+04, 0.205000E+04, 0.206000E+04, &
7319 0.207000E+04, 0.208000E+04, 0.209000E+04, 0.210000E+04, &
7320 0.211000E+04, 0.212000E+04, 0.213000E+04, 0.214000E+04, &
7321 0.215000E+04, 0.216000E+04, 0.217000E+04, 0.218000E+04, &
7322 0.219000E+04, 0.220000E+04, 0.238000E+04/
7324 !
7325 !***THE FOLLOWING DATA STATEMENTS ARE BAND PARAMETERS OBTAINED USING
7326 ! THE 1982 AFGL CATALOG ON THE SPECIFIED BANDS
7327 DATA ARNDM1 / &
7328 0.354693E+00, 0.269857E+03, 0.167062E+03, 0.201314E+04, &
7329 0.964533E+03, 0.547971E+04, 0.152933E+04, 0.599429E+04, &
7330 0.699329E+04, 0.856721E+04, 0.962489E+04, 0.233348E+04, &
7331 0.127091E+05, 0.104383E+05, 0.504249E+04, 0.181227E+05, &
7332 0.856480E+03, 0.136354E+05, 0.288635E+04, 0.170200E+04, &
7333 0.209761E+05, 0.126797E+04, 0.110096E+05, 0.336436E+03, &
7334 0.491663E+04, 0.863701E+04, 0.540389E+03, 0.439786E+04, &
7335 0.347836E+04, 0.130557E+03, 0.465332E+04, 0.253086E+03, &
7336 0.257387E+04, 0.488041E+03, 0.892991E+03, 0.117148E+04, &
7337 0.125880E+03, 0.458852E+03, 0.142975E+03, 0.446355E+03, &
7338 0.302887E+02, 0.394451E+03, 0.438112E+02, 0.348811E+02, &
7339 0.615503E+02, 0.143165E+03, 0.103958E+02, 0.725108E+02, &
7340 0.316628E+02, 0.946456E+01, 0.542675E+02, 0.351557E+02, &
7341 0.301797E+02, 0.381010E+01, 0.126319E+02, 0.548010E+01, &
7342 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, &
7343 0.178110E-01, 0.170166E+00, 0.273514E-01, 0.983767E+00/
7344 DATA ARNDM2 / &
7345 0.753946E+00, 0.941763E-01, 0.970547E+00, 0.268862E+00, &
7346 0.564373E+01, 0.389794E+01, 0.310955E+01, 0.128235E+01, &
7347 0.196414E+01, 0.247113E+02, 0.593435E+01, 0.377552E+02, &
7348 0.305173E+02, 0.852479E+01, 0.116780E+03, 0.101490E+03, &
7349 0.138939E+03, 0.324228E+03, 0.683729E+02, 0.471304E+03, &
7350 0.159684E+03, 0.427101E+03, 0.114716E+03, 0.106190E+04, &
7351 0.294607E+03, 0.762948E+03, 0.333199E+03, 0.830645E+03, &
7352 0.162512E+04, 0.525676E+03, 0.137739E+04, 0.136252E+04, &
7353 0.147164E+04, 0.187196E+04, 0.131118E+04, 0.103975E+04, &
7354 0.621637E+01, 0.399459E+02, 0.950648E+02, 0.943161E+03, &
7355 0.526821E+03, 0.104150E+04, 0.905610E+03, 0.228142E+04, &
7356 0.806270E+03, 0.691845E+03, 0.155237E+04, 0.192241E+04, &
7357 0.991871E+03, 0.123907E+04, 0.457289E+02, 0.146146E+04, &
7358 0.319382E+03, 0.436074E+03, 0.374214E+03, 0.778217E+03, &
7359 0.140227E+03, 0.562540E+03, 0.682685E+02, 0.820292E+02, &
7360 0.178779E+03, 0.186150E+03, 0.383864E+03, 0.567416E+01/
7361 DATA ARNDM3 / &
7362 0.225129E+03, 0.473099E+01, 0.753149E+02, 0.233689E+02, &
7363 0.339802E+02, 0.108855E+03, 0.380016E+02, 0.151039E+01, &
7364 0.660346E+02, 0.370165E+01, 0.234169E+02, 0.440206E+00, &
7365 0.615283E+01, 0.304077E+02, 0.117769E+01, 0.125248E+02, &
7366 0.142652E+01, 0.241831E+00, 0.483721E+01, 0.226357E-01, &
7367 0.549835E+01, 0.597067E+00, 0.404553E+00, 0.143584E+01, &
7368 0.294291E+00, 0.466273E+00, 0.156048E+00, 0.656185E+00, &
7369 0.172727E+00, 0.118349E+00, 0.141598E+00, 0.588581E-01, &
7370 0.919409E-01, 0.155521E-01, 0.537083E-02/
7371 DATA BRNDM1 / &
7372 0.789571E-01, 0.920256E-01, 0.696960E-01, 0.245544E+00, &
7373 0.188503E+00, 0.266127E+00, 0.271371E+00, 0.330917E+00, &
7374 0.190424E+00, 0.224498E+00, 0.282517E+00, 0.130675E+00, &
7375 0.212579E+00, 0.227298E+00, 0.138585E+00, 0.187106E+00, &
7376 0.194527E+00, 0.177034E+00, 0.115902E+00, 0.118499E+00, &
7377 0.142848E+00, 0.216869E+00, 0.149848E+00, 0.971585E-01, &
7378 0.151532E+00, 0.865628E-01, 0.764246E-01, 0.100035E+00, &
7379 0.171133E+00, 0.134737E+00, 0.105173E+00, 0.860832E-01, &
7380 0.148921E+00, 0.869234E-01, 0.106018E+00, 0.184865E+00, &
7381 0.767454E-01, 0.108981E+00, 0.123094E+00, 0.177287E+00, &
7382 0.848146E-01, 0.119356E+00, 0.133829E+00, 0.954505E-01, &
7383 0.155405E+00, 0.164167E+00, 0.161390E+00, 0.113287E+00, &
7384 0.714720E-01, 0.741598E-01, 0.719590E-01, 0.140616E+00, &
7385 0.355356E-01, 0.832779E-01, 0.128680E+00, 0.983013E-01, &
7386 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, &
7387 0.875182E-01, 0.857907E-01, 0.358808E+00, 0.178840E+00/
7388 DATA BRNDM2 / &
7389 0.254265E+00, 0.297901E+00, 0.153916E+00, 0.537774E+00, &
7390 0.267906E+00, 0.104254E+00, 0.400723E+00, 0.389670E+00, &
7391 0.263701E+00, 0.338116E+00, 0.351528E+00, 0.267764E+00, &
7392 0.186419E+00, 0.238237E+00, 0.210408E+00, 0.176869E+00, &
7393 0.114715E+00, 0.173299E+00, 0.967770E-01, 0.172565E+00, &
7394 0.162085E+00, 0.157782E+00, 0.886832E-01, 0.242999E+00, &
7395 0.760298E-01, 0.164248E+00, 0.221428E+00, 0.166799E+00, &
7396 0.312514E+00, 0.380600E+00, 0.353828E+00, 0.269500E+00, &
7397 0.254759E+00, 0.285408E+00, 0.159764E+00, 0.721058E-01, &
7398 0.170528E+00, 0.231595E+00, 0.307184E+00, 0.564136E-01, &
7399 0.159884E+00, 0.147907E+00, 0.185666E+00, 0.183567E+00, &
7400 0.182482E+00, 0.230650E+00, 0.175348E+00, 0.195978E+00, &
7401 0.255323E+00, 0.198517E+00, 0.195500E+00, 0.208356E+00, &
7402 0.309603E+00, 0.112011E+00, 0.102570E+00, 0.128276E+00, &
7403 0.168100E+00, 0.177836E+00, 0.105533E+00, 0.903330E-01, &
7404 0.126036E+00, 0.101430E+00, 0.124546E+00, 0.221406E+00/
7405 DATA BRNDM3 / &
7406 0.137509E+00, 0.911365E-01, 0.724508E-01, 0.795788E-01, &
7407 0.137411E+00, 0.549175E-01, 0.787714E-01, 0.165544E+00, &
7408 0.136484E+00, 0.146729E+00, 0.820496E-01, 0.846211E-01, &
7409 0.785821E-01, 0.122527E+00, 0.125359E+00, 0.101589E+00, &
7410 0.155756E+00, 0.189239E+00, 0.999086E-01, 0.480993E+00, &
7411 0.100233E+00, 0.153754E+00, 0.130780E+00, 0.136136E+00, &
7412 0.159353E+00, 0.156634E+00, 0.272265E+00, 0.186874E+00, &
7413 0.192090E+00, 0.135397E+00, 0.131497E+00, 0.127463E+00, &
7414 0.227233E+00, 0.190562E+00, 0.214005E+00/
7415 DATA BETAD1 / &
7416 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7417 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7418 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7419 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7420 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7421 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7422 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7423 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7424 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7425 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7426 0.234879E+03, 0.217419E+03, 0.201281E+03, 0.186364E+03, &
7427 0.172576E+03, 0.159831E+03, 0.148051E+03, 0.137163E+03, &
7428 0.127099E+03, 0.117796E+03, 0.109197E+03, 0.101249E+03, &
7429 0.939031E+02, 0.871127E+02, 0.808363E+02, 0.750349E+02, &
7430 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, &
7431 0.589554E+01, 0.495227E+01, 0.000000E+00, 0.000000E+00/
7432 DATA BETAD2 / &
7433 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7434 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7435 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7436 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7437 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7438 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7439 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7440 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7441 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7442 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7443 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7444 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7445 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7446 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7447 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7448 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00/
7449 DATA BETAD3 / &
7450 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7451 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7452 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7453 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7454 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7455 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7456 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7457 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7458 0.000000E+00, 0.000000E+00, 0.000000E+00/
7459 !---------------------------------------------------------------
7460 ! EQUIVALENCE (BANDL1(1),BANDLO(1)),(BANDL2(1),BANDLO(65)), &
7461 ! (BANDL3(1),BANDLO(129))
7463 ! L = kme-1
7464 ! LP1 = L+1
7465 ! LP1V = LP1*(1+2*L/2)
7466 ! IMAX = ite
7467 ! LP2 = L + 2
7469 DO I = 1,64
7470 BANDLO(I)=BANDL1(I)
7471 ENDDO
7473 DO I = 65,128
7474 BANDLO(I)=BANDL2(I-64)
7475 ENDDO
7477 DO I = 129,163
7478 BANDLO(I)=BANDL3(I-128)
7479 ENDDO
7481 DO I = 1,64
7482 BANDHI(I)=BANDH1(I)
7483 ENDDO
7485 DO I = 65,128
7486 BANDHI(I)=BANDH2(I-64)
7487 ENDDO
7489 DO I = 129,163
7490 BANDHI(I)=BANDH3(I-128)
7491 ENDDO
7493 !****************************************
7494 !***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15
7495 !....FOR NARROW-BANDS...
7496 DO 101 N=1,NBLW
7497 ANB(N)=ARNDM(N)
7498 BNB(N)=BRNDM(N)
7499 CENTNB(N)=HAF*(BANDLO(N)+BANDHI(N))
7500 DELNB(N)=BANDHI(N)-BANDLO(N)
7501 BETANB(N)=BETAD(N)
7502 101 CONTINUE
7503 AB15(1)=ANB(57)*BNB(57)
7504 AB15(2)=ANB(58)*BNB(58)
7505 !....FOR WIDE BANDS...
7506 AB15WD=AWIDE*BWIDE
7507 !
7508 !***COMPUTE INDICES: IND,INDX2,KMAXV
7509 !SH ICNT=0
7510 !SH DO 113 I1=1,L
7511 !SH I2E=LP1-I1
7512 !SH DO 115 I2=1,I2E
7513 !SH ICNT=ICNT+1
7514 !SH INDX2(ICNT)=LP1*(I2-1)+LP2*I1
7515 !SH115 CONTINUE
7516 !SH113 CONTINUE
7517 !SH KMAXV(1)=1
7518 !SH DO 117 I=2,L
7519 !SH KMAXV(I)=KMAXV(I-1)+(LP2-I)
7520 117 CONTINUE
7521 !SH KMAXVM=KMAXV(L)
7522 !***COMPUTE RATIOS OF CONT. COEFFS
7523 SKC1R=BETAWD/BETINW
7524 SKO3R=BETAD(61)/BETINW
7525 SKO2D=ONE/BETINW
7526 !
7527 !****BEGIN TABLE COMPUTATIONS HERE***
7528 !***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES
7529 !---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS
7530 ! WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM
7531 ! 100K TO 370K.
7532 !---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF
7533 ! 180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS
7534 ! ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS.
7535 ZMASS(1)=H1M16
7536 DO 201 J=1,180
7537 JP=J+1
7538 ZROOT(J)=SQRT(ZMASS(J))
7539 ZMASS(JP)=ZMASS(J)*H1P25892
7540 201 CONTINUE
7541 DO 203 I=1,28
7542 XTEMV(I)=HNINETY+TEN*I
7543 TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I)
7544 FORTCU(I)=FOUR*XTEMV(I)*XTEMV(I)*XTEMV(I)
7545 203 CONTINUE
7546 !******THE COMPUTATION OF SOURCE,DSRCE IS NEEDED ONLY
7547 ! FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE
7548 ! MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD)
7549 ! THEN COMBINED (USING IBAND) INTO SOURCE.
7550 DO 205 N=1,NBLY
7551 DO 205 I=1,28
7552 SOURCE(I,N)=ZERO
7553 205 CONTINUE
7554 DO 207 N=1,NBLX
7555 DO 207 I=1,28
7556 SRCWD(I,N)=ZERO
7557 207 CONTINUE
7558 !---BEGIN FREQ. LOOP (ON N)
7559 DO 211 N=1,NBLX
7560 IF (N.LE.46) THEN
7561 !***THE 160-1200 BAND CASES
7562 CENT=CENTNB(N+16)
7563 DEL=DELNB(N+16)
7564 BDLO=BANDLO(N+16)
7565 BDHI=BANDHI(N+16)
7566 ENDIF
7567 IF (N.EQ.NBLX) THEN
7568 !***THE 2270-2380 BAND CASE
7569 CENT=CENTNB(NBLW)
7570 DEL=DELNB(NBLW)
7571 BDLO=BANDLO(NBLW)
7572 BDHI=BANDHI(NBLW)
7573 ENDIF
7574 !***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE
7575 ! ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS.
7576 NSUBDS=(DEL-H1M3)/10+1
7577 DO 213 NSB=1,NSUBDS
7578 IF (NSB.NE.NSUBDS) THEN
7579 CNUSB(NSB)=TEN*(NSB-1)+BDLO+FIVE
7580 DNUSB(NSB)=TEN
7581 ELSE
7582 CNUSB(NSB)=HAF*(TEN*(NSB-1)+BDLO+BDHI)
7583 DNUSB(NSB)=BDHI-(TEN*(NSB-1)+BDLO)
7584 ENDIF
7585 C1=(H37412M5)*CNUSB(NSB)**3
7586 !---BEGIN TEMP. LOOP (ON I)
7587 DO 215 I=1,28
7588 X(I)=H1P4387*CNUSB(NSB)/XTEMV(I)
7589 X1(I)=EXP(X(I))
7590 SRCS(I)=C1/(X1(I)-ONE)
7591 SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB)
7592 215 CONTINUE
7593 213 CONTINUE
7594 211 CONTINUE
7595 !***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE
7596 ! AND DSRCE
7597 DO 221 N=1,40
7598 DO 221 I=1,28
7599 SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N)
7600 221 CONTINUE
7601 DO 223 N=9,NBLY
7602 DO 223 I=1,28
7603 SOURCE(I,N)=SRCWD(I,N+32)
7604 223 CONTINUE
7605 DO 225 N=1,NBLY
7606 DO 225 I=1,27
7607 DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*HP1
7608 225 CONTINUE
7609 DO 231 N=1,NBLW
7610 ALFANB(N)=BNB(N)*ANB(N)
7611 AROTNB(N)=SQRT(ALFANB(N))
7612 231 CONTINUE
7613 !***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR
7614 ! USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE
7615 ! BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ.
7616 ! RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT.
7617 !
7618 DO 301 N=1,NBLW
7619 CENT=CENTNB(N)
7620 DEL=DELNB(N)
7621 !---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT
7622 ! IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR
7623 ! THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY.
7624 #if 0
7625 DO 303 IA=1,3
7626 #else
7627 !jm -- getting floating point exceptions for IA=1, since 2 is only
7628 ! used anyway, I disabled the looping.
7629 DO 303 IA=2,2
7630 #endif
7631 ANU=CENT+HAF*(IA-2)*DEL
7632 C1=(H37412M5)*ANU*ANU*ANU+H1M20
7633 !---TEMPERATURE LOOP---
7634 DO 305 I=1,28
7635 X(I)=H1P4387*ANU/XTEMV(I)
7636 X1(I)=EXP(X(I))
7637 !#$ tmp=max((X1(I)-ONE),H1M20)
7638 !#$ SC(I)=C1/tmp
7639 SC(I)=C1/((X1(I)-ONE)+H1M20)
7640 !#$ DSC(I)=X(I)*SC(I)*SC(I)*X1(I)/(XTEMV(I)*C1)
7641 DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1)
7642 305 CONTINUE
7643 IF (IA.EQ.2) THEN
7644 DO 307 I=1,28
7645 SRC1NB(I,N)=DEL*SC(I)
7646 DBDTNB(I,N)=DEL*DSC(I)
7647 307 CONTINUE
7648 ENDIF
7649 303 CONTINUE
7650 301 CONTINUE
7651 !***NEXT COMPUTE R1T,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION
7652 ! WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A
7653 ! DIFFERENT DEPENDENCE ON (ZMASS).
7654 !---ALSO OBTAIN R1WD, WHICH IS R1T SUMMED OVER THE 160-560 CM-1 RANGE
7655 DO 311 I=1,28
7656 SUM4(I)=ZERO
7657 SUM6(I)=ZERO
7658 SUM7(I)=ZERO
7659 SUM8(I)=ZERO
7660 SUM4WD(I)=ZERO
7661 311 CONTINUE
7662 DO 313 N=1,NBLW
7663 CENT=CENTNB(N)
7664 !***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4
7665 ! SUM6,SUM7,SUM8
7666 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
7667 DO 315 I=1,28
7668 SUM4(I)=SUM4(I)+SRC1NB(I,N)
7669 SUM6(I)=SUM6(I)+DBDTNB(I,N)
7670 SUM7(I)=SUM7(I)+DBDTNB(I,N)*AROTNB(N)
7671 SUM8(I)=SUM8(I)+DBDTNB(I,N)*ALFANB(N)
7672 315 CONTINUE
7673 ENDIF
7674 !***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD
7675 IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
7676 DO 316 I=1,28
7677 SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N)
7678 316 CONTINUE
7679 ENDIF
7680 313 CONTINUE
7681 DO 317 I=1,28
7682 R1T(I)=SUM4(I)/TFOUR(I)
7683 R2(I)=SUM6(I)/FORTCU(I)
7684 S2(I)=SUM7(I)/FORTCU(I)
7685 T3(I)=SUM8(I)/FORTCU(I)
7686 R1WD(I)=SUM4WD(I)/TFOUR(I)
7687 317 CONTINUE
7688 DO 401 J=1,180
7689 DO 401 I=1,28
7690 SUM(I,J)=ZERO
7691 PERTSM(I,J)=ZERO
7692 SUM3(I,J)=ZERO
7693 SUMWDE(I,J)=ZERO
7694 401 CONTINUE
7695 !---FREQUENCY LOOP BEGINS---
7696 DO 411 N=1,NBLW
7697 CENT=CENTNB(N)
7698 !***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1
7699 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
7700 DO 413 J=1,180
7701 X2(J)=AROTNB(N)*ZROOT(J)
7702 EXPO(J)=EXP(-X2(J))
7703 413 CONTINUE
7704 DO 415 J=1,180
7705 IF (X2(J).GE.HUNDRED) THEN
7706 EXPO(J)=ZERO
7707 ENDIF
7708 415 CONTINUE
7709 DO 417 J=121,180
7710 FAC(J)=ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J))
7711 417 CONTINUE
7712 DO 419 J=1,180
7713 DO 419 I=1,28
7714 SUM(I,J)=SUM(I,J)+SRC1NB(I,N)*EXPO(J)
7715 PERTSM(I,J)=PERTSM(I,J)+DBDTNB(I,N)*EXPO(J)
7716 419 CONTINUE
7717 DO 421 J=121,180
7718 DO 421 I=1,28
7719 SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J)
7720 421 CONTINUE
7721 ENDIF
7722 !---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE)
7723 IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
7724 DO 420 J=1,180
7725 DO 420 I=1,28
7726 SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J)
7727 420 CONTINUE
7728 ENDIF
7729 411 CONTINUE
7730 DO 431 J=1,180
7731 DO 431 I=1,28
7732 EM1(I,J)=SUM(I,J)/TFOUR(I)
7733 TABLE1(I,J)=PERTSM(I,J)/FORTCU(I)
7734 431 CONTINUE
7735 DO 433 J=121,180
7736 DO 433 I=1,28
7737 EM3(I,J)=SUM3(I,J)/FORTCU(I)
7738 433 CONTINUE
7739 DO 441 J=1,179
7740 DO 441 I=1,28
7741 TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*TEN
7742 441 CONTINUE
7743 DO 443 J=1,180
7744 DO 443 I=1,27
7745 TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*HP1
7746 443 CONTINUE
7747 DO 445 I=1,28
7748 TABLE2(I,180)=ZERO
7749 445 CONTINUE
7750 DO 447 J=1,180
7751 TABLE3(28,J)=ZERO
7752 447 CONTINUE
7753 DO 449 J=1,2
7754 DO 449 I=1,28
7755 EM1(I,J)=R1T(I)
7756 449 CONTINUE
7757 DO 451 J=1,120
7758 DO 451 I=1,28
7759 EM3(I,J)=R2(I)/TWO-S2(I)*SQRT(ZMASS(J))/THREE+T3(I)*ZMASS(J)/EIGHT
7760 451 CONTINUE
7761 DO 453 J=121,180
7762 DO 453 I=1,28
7763 EM3(I,J)=EM3(I,J)/ZMASS(J)
7764 453 CONTINUE
7765 !***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY.
7766 ! WE USE R1WD AND SUMWDE OBTAINED ABOVE.
7767 DO 501 J=1,180
7768 DO 501 I=1,28
7769 EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I)
7770 501 CONTINUE
7771 DO 503 J=1,2
7772 DO 503 I=1,28
7773 EM1WDE(I,J)=R1WD(I)
7774 503 CONTINUE
7776 END SUBROUTINE TABLE
7778 !---------------------------------------------------------------------
7779 SUBROUTINE SOLARD(IHRST,IDAY,MONTH,JULYR)
7780 !---------------------------------------------------------------------
7781 IMPLICIT NONE
7782 !---------------------------------------------------------------------
7783 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
7784 ! . . . .
7785 ! SUBPROGRAM: SOLARD COMPUTE THE SOLAR-EARTH DISTANCE
7786 ! PRGRMMR: Q.ZHAO ORG: W/NMC2 DATE: 96-7-23
7787 !
7788 ! ABSTRACT:
7789 ! SOLARD CALCULATES THE SOLAR-EARTH DISTANCE ON EACH DAY
7790 ! FOR USE IN SHORT-WAVE RADIATION.
7791 !
7792 ! PROGRAM HISTORY LOG:
7793 ! 96-07-23 Q.ZHAO - ORIGINATOR
7794 ! 98-10-09 Q.ZHAO - CHANGED TO USE IW3JDN IN W3LIB TO
7795 ! CALCULATE JD.
7796 !
7797 ! USAGE: CALL SOLARD FROM SUBROUTINE INIT
7798 !
7799 ! INPUT ARGUMENT LIST:
7800 ! NONE
7801 !
7802 ! OUTPUT ARGUMENT LIST:
7803 ! R1 - THE NON-DIMENSIONAL DISTANCE BETWEEN SUN AND THE EARTH
7804 ! (LESS THAN 1.0 IN SUMMER AND LARGER THAN 1.0 IN WINTER).
7805 !
7806 ! INPUT FILES:
7807 ! NONE
7808 !
7809 ! OUTPUT FILES:
7810 ! NONE
7811 !
7812 ! SUBPROGRAMS CALLED:
7813 !
7814 ! UNIQUE: NONE
7815 !
7816 ! LIBRARY: IW3JDN
7817 !
7818 ! COMMON BLOCKS: CTLBLK
7819 !
7820 ! ATTRIBUTES:
7821 ! LANGUAGE: FORTRAN 90
7822 ! MACHINE : IBM SP
7823 !***********************************************************************
7824 REAL, PARAMETER :: PI=3.1415926,PI2=2.*PI
7825 !-----------------------------------------------------------------------
7826 ! INTEGER, INTENT(IN ) :: IHRST,IDAT(3)
7827 INTEGER, INTENT(IN ) :: IHRST,IDAY,MONTH,JULYR
7828 ! REAL , INTENT(OUT) :: R1
7829 !-----------------------------------------------------------------------
7830 INTEGER :: NDM(12),JYR19,JMN
7831 REAL :: CCR
7833 DATA JYR19/1900/, JMN/0/, CCR/1.3E-6/
7834 DATA NDM/0,31,59,90,120,151,181,212,243,273,304,334/
7836 !.....TPP = DAYS BETWEEN EPOCH AND PERIHELION PASSAGE OF 1900
7837 !.....JDOR1 = JD OF DECEMBER 30, 1899 AT 12 HOURS UT
7838 !.....JDOR2 = JD OF EPOCH WHICH IS JANUARY 0, 1990 AT 12 HOURS UT
7839 !
7840 REAL :: TPP
7841 DATA TPP/1.55/
7843 INTEGER :: JDOR2,JDOR1
7844 DATA JDOR2/2415020/, JDOR1/2415019/
7846 REAL :: DAYINC,DAT,T,YEAR,DATE,EM,E,EC,EP,CR,FJD,FJD1
7847 INTEGER :: JYR,JMNTH,JDAY,JHRJD,JHR,JD,ITER
7848 !
7849 ! LIBRARY: IW3JDN
7850 !
7851 ! --------------------------------------------------------------------
7852 ! COMPUTES JULIAN DAY AND FRACTION FROM YEAR, MONTH, DAY AND TIME UT
7853 ! ACCURATE ONLY BETWEEN MARCH 1, 1900 AND FEBRUARY 28, 2100
7854 ! BASED ON JULIAN CALENDAR CORRECTED TO CORRESPOND TO GREGORIAN
7855 ! CALENDAR DURING THIS PERIOD
7856 ! --------------------------------------------------------------------
7858 ! JYR=IDAT(3)
7859 ! JMNTH=IDAT(1)
7860 ! JDAY=IDAT(2)
7861 JHR=IHRST
7862 !
7863 JD=IDAY-32075 &
7864 +1461*(JULYR+4800+(MONTH-14)/12)/4 &
7865 +367*(MONTH-2-(MONTH-14)/12*12)/12 &
7866 -3*((JULYR+4900+(MONTH-14)/12)/100)/4
7867 IF(JHR.LT.12)THEN
7868 JD=JD-1
7869 FJD=.5+.041666667*REAL(JHR)+.00069444444*REAL(JMN)
7870 ELSE
7871 7 FJD=.041666667E0*FLOAT(JHR-12)+.00069444444E0*FLOAT(JMN)
7872 END IF
7873 DAYINC=JHR/24.0
7874 FJD1=JD+FJD+DAYINC
7875 JD=FJD1
7876 FJD=FJD1-JD
7877 !***
7878 !*** CALCULATE THE SOLAR-EARTH DISTANCE
7879 !***
7880 DAT=REAL(JD-JDOR2)-TPP+FJD
7881 !***
7882 ! COMPUTES TIME IN JULIAN CENTURIES AFTER EPOCH
7883 !***
7884 T=FLOAT(JD-JDOR2)/36525.E0
7885 !***
7886 ! COMPUTES LENGTH OF ANOMALISTIC AND TROPICAL YEARS (MINUS 365 DAYS)
7887 !***
7888 YEAR=.25964134E0+.304E-5*T
7889 !***
7890 ! COMPUTES ORBIT ECCENTRICITY FROM T
7891 !***
7892 EC=.01675104E0-(.418E-4+.126E-6*T)*T
7893 YEAR=YEAR+365.E0
7894 !***
7895 ! DATE=DAYS SINCE LAST PERIHELION PASSAGE
7896 !***
7897 DATE = MOD(DAT,YEAR)
7898 !***
7899 ! SOLVE ORBIT EQUATIONS BY NEWTON'S METHOD
7900 !***
7901 EM=PI2*DATE/YEAR
7902 E=1.E0
7903 ITER = 0
7904 31 EP=E-(E-EC*SIN(E)-EM)/(1.E0-EC*COS(E))
7905 CR=ABS(E-EP)
7906 E=EP
7907 ITER = ITER + 1
7908 IF(ITER.GT.10) GOTO 1031
7909 IF(CR.GT.CCR) GO TO 31
7910 1031 CONTINUE
7911 R1=1.E0-EC*COS(E)
7912 !
7913 ! WRITE(6,1000)JYR,JMNTH,JDAY,JHR,R1
7914 ! WRITE(6,*)JHR,R1
7915 1000 FORMAT('SUN-EARTH DISTANCE CALCULATION FINISHED IN SOLARD'/ &
7916 'YEAR=',I5,' MONTH=',I3,' DAY=',I3,' HOUR=' &
7917 , I3,' R1=',F9.4)
7918 !***
7919 ! RETURN TO RADTN
7920 !***
7921 END SUBROUTINE SOLARD
7922 !---------------------------------------------------------------------
7923 SUBROUTINE CAL_MON_DAY(JULDAY,julyr,Jmonth,Jday)
7924 !---------------------------------------------------------------------
7925 IMPLICIT NONE
7926 !-----------------------------------------------------------------------
7927 INTEGER, INTENT(IN) :: JULDAY,julyr
7928 INTEGER, INTENT(OUT) :: Jmonth,Jday
7929 LOGICAL :: LEAP,NOT_FIND_DATE
7930 INTEGER :: MONTH (12),itmpday,itmpmon,i
7931 !-----------------------------------------------------------------------
7932 DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
7933 !***********************************************************************
7934 NOT_FIND_DATE = .true.
7936 itmpday = JULDAY
7937 itmpmon = 1
7938 LEAP=.FALSE.
7939 IF(MOD(julyr,4).EQ.0)THEN
7940 MONTH(2)=29
7941 LEAP=.TRUE.
7942 ENDIF
7944 i = 1
7945 DO WHILE (NOT_FIND_DATE)
7946 IF(itmpday.GT.MONTH(i))THEN
7947 itmpday=itmpday-MONTH(i)
7948 ELSE
7949 Jday=itmpday
7950 Jmonth=i
7951 NOT_FIND_DATE = .false.
7952 ENDIF
7953 i = i+1
7954 END DO
7956 END SUBROUTINE CAL_MON_DAY
7957 !!================================================================================
7958 ! CO2 initialization code
7960 FUNCTION ANTEMP(L,Z)
7961 REAL :: ZB(10,7),C(11,7),DELTA(10,7),TSTAR(7)
7962 ! ************** TROPICAL SOUNDING **************************
7963 DATA (ZB(N,1),N=1,10)/ 2.0, 3.0, 16.5, 21.5, 45.0, &
7964 51.0, 70.0, 100., 200., 300./
7965 DATA (C(N,1),N=1,11)/ -6.0, -4.0, -6.7, 4.0, 2.2, &
7966 1.0, -2.8, -.27, 0.0, 0.0, 0.0/
7967 DATA (DELTA(N,1),N=1,10)/.5, .5, .3, .5, 1.0, &
7968 1.0, 1.0, 1.0, 1.0, 1.0/
7969 ! ************** SUB-TROPICAL SUMMER ************************
7970 DATA (ZB(N,2),N=1,10)/ 1.5, 6.5, 13.0, 18.0, 26.0, &
7971 36.0, 48.0, 50.0, 70.0, 100./
7972 DATA (C(N,2),N=1,11)/ -4.0, -6.0, -6.5, 0.0, 1.2, &
7973 2.2, 2.5, 0.0, -3.0, -0.25, 0.0/
7974 DATA (DELTA(N,2),N=1,10)/ .5, 1.0, .5, .5, 1.0, &
7975 1.0, 2.5, .5, 1.0, 1.0/
7976 ! ************** SUB-TROPICAL WINTER ************************
7977 DATA (ZB(N,3),N=1,10)/ 3.0, 10.0, 19.0, 25.0, 32.0, &
7978 44.5, 50.0, 71.0, 98.0, 200.0/
7979 DATA (C(N,3),N=1,11)/ -3.5, -6.0, -0.5, 0.0, 0.4, &
7980 3.2, 1.6, -1.8, -0.7, 0.0, 0.0/
7981 DATA (DELTA(N,3),N=1,10)/ .5, .5, 1.0, 1.0, 1.0, &
7982 1.0, 1.0, 1.0, 1.0, 1.0/
7983 ! ************* SUB-ARCTIC SUMMER *************************
7984 DATA (ZB(N,4),N=1,10)/ 4.7, 10.0, 23.0, 31.8, 44.0, &
7985 50.2, 69.2, 100.0, 102.0, 103.0/
7986 DATA (C(N,4),N=1,11)/ -5.3, -7.0, 0.0, 1.4, 3.0, &
7987 0.7, -3.3, -0.2, 0.0, 0.0, 0.0/
7988 DATA (DELTA(N,4),N=1,10)/ .5, .3, 1.0, 1.0, 2.0, &
7989 1.0, 1.5, 1.0, 1.0, 1.0/
7990 ! ************ SUB-ARCTIC WINTER *****************************
7991 DATA (ZB(N,5),N=1,10)/ 1.0, 3.2, 8.5, 15.5, 25.0, &
7992 30.0, 35.0, 50.0, 70.0, 100.0/
7993 DATA (C(N,5),N=1,11)/ 3.0, -3.2, -6.8, 0.0, -0.6, &
7994 1.0, 1.2, 2.5, -0.7, -1.2, 0.0/
7995 DATA (DELTA(N,5),N=1,10)/ .4, 1.5, .3 , .5, 1.0, &
7996 1.0, 1.0, 1.0, 1.0, 1.0/
7997 ! ************ US STANDARD 1976 ******************************
7998 DATA (ZB(N,6),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, &
7999 71.0, 84.8520, 90.0, 91.0, 92.0/
8000 DATA (C(N,6),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, &
8001 -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/
8002 DATA (DELTA(N,6),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, &
8003 1.0, 1.0, 1.0, 1.0, 1.0/
8004 !
8005 ! ************ ENLARGED US STANDARD 1976 **********************
8006 DATA (ZB(N,7),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, &
8007 71.0, 84.8520, 90.0, 91.0, 92.0/
8008 DATA (C(N,7),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, &
8009 -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/
8010 DATA (DELTA(N,7),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, &
8011 1.0, 1.0, 1.0, 1.0, 1.0/
8012 !
8013 DATA TSTAR/ 300.0, 294.0, 272.2, 287.0, 257.1, 2*288.15/
8014 !
8015 NLAST=10
8016 TEMP=TSTAR(L)+C(1,L)*Z
8017 DO 20 N=1,NLAST
8018 EXPO=(Z-ZB(N,L))/DELTA(N,L)
8019 EXPP=ZB(N,L)/DELTA(N,L)
8020 !JD single-precision change
8021 ! FAC=EXP(EXPP)+EXP(-EXPP)
8022 !mp write(6,*) '.........................................'
8023 !mp what in the hell does the next line do?
8024 !mp
8025 !mp apparently if statement <0 or =0 then 23, else 24
8026 !mp IF(ABS(EXPO)-100.0) 23,23,24
8027 !
8028 ! changed to a more reasonable value for the workstation
8029 !
8030 IF(ABS(EXPO)-50.0) 23,23,24
8031 23 X=EXP(EXPO)
8032 Y=X+1.0/X
8033 ZLOG=ALOG(Y)
8034 GO TO 25
8035 24 ZLOG=ABS(EXPO)
8036 !mp 25 IF(EXPP-100.0) 27,27,28
8037 25 IF(EXPP-50.0) 27,27,28
8038 !JD single-precision change
8039 27 FAC=EXP(EXPP)+EXP(-EXPP)
8040 FACLOG=ALOG(FAC)
8041 GO TO 29
8042 28 FACLOG=EXPP
8043 ! TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)*
8044 ! 1 ALOG((EXP(EXPO)+EXP(-EXPO))/FAC))
8045 29 TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)* &
8046 (ZLOG-FACLOG))
8047 !mp write(6,*) 'ANTEMP pieces (C,C,ZLOG,FACLOG)', C(N+1,L),C(N,L),
8048 !mp + ZLOG,FACLOG
8049 20 CONTINUE
8050 ANTEMP=TEMP
8052 END FUNCTION ANTEMP
8054 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
8056 SUBROUTINE COEINT(RAT,IR)
8057 ! **********************************************************************
8058 !
8059 !
8060 ! THE TRANSMISSION FUNCTION BETWEEN P1 AND P2 IS ASSUMED TO
8061 ! THE FUNCTIONAL FORM
8062 ! TAU(P1,P2)= 1.0-SQRT(C*LOG(1.0+X*PATH)),
8063 ! WHERE
8064 ! PATH(P1,P2)=((P1-P2)**2)*(P1+P2+CORE)/
8065 ! (ETA*(P1+P2+CORE)+(P1-P2))
8066 !
8067 !
8068 ! THE PARAMETERS C AND X ARE FUNCTIONS OF P2, AND ARE TO BE DETER
8069 ! WHILE CORE IS A PRESPECIFIED NUMBER.ETA IS A FUNCTION OF THE TH
8070 ! PRODUCT (CX);IT IS OBTAITED ITERATIVELY. THE DERIVATION OF ALL
8071 ! VALUES WILL BE EXPLAINED IN A FORTHCOMING PAPER.
8072 ! SUBROUTINE COEINT DETERMINES C(I) AND X(I) BY USING THE ACT
8073 ! VALUES OF TAU(P(I-2),P(I)) AND TAU(P(I-1),P(I)) AND THE PREVIOU
8074 ! ITERATION VALUE OF ETA.
8075 ! DEFINE:
8076 ! PATHA=PATH(P(I),P(I-2),CORE,ETA)
8077 ! PATHB=PATH(P(I),P(I-1),CORE,ETA);
8078 ! THEN
8079 ! R=(1-TAU(P(I),P(I-2)))/(1-TAU(P(I),P(I-1)))
8080 ! = SQRT(LOG(1+X*PATHA)/LOG(1+X*PATHB)),
8081 ! SO THAT
8082 ! R**2= LOG(1+X*PATHA)/LOG(1+X*PATHB).
8083 ! THIS EQUATION CAN BE SOLVED BY NEWTON S METHOD FOR X AND THEN T
8084 ! RESULT USED TO FIND C. THIS IS REPEATED FOR EACH VALUE OF I GRE
8085 ! THAN 2 TO GIVE THE ARRAYS X(I) AND C(I).
8086 ! NEWTON S METHOD FOR SOLVING THE EQUATION
8087 ! F(X)=0
8088 ! MAKES USE OF THE LOOP XNEW= XOLD-F(XOLD)/FPRIME(XOLD).
8089 ! THIS IS ITERATED 20 TIMES, WHICH IS PROBABLY EXCESSIVE.
8090 ! THE FIRST GUESS FOR ETA IS 3.2E-4*EXP(-P(I)/1000),WHICH HAS
8091 ! BEEN FOUND TO BE FAIRLY REALISTIC BY EXPERIMENT; WE ITERATE 5 T
8092 ! (AGAIN,PROBABLY EXCESSIVELY) TO OBTAIN THE VALUES FOR C,X,ETA T
8093 ! USED FOR INTERPOLATION.
8094 ! THERE ARE SEVERAL POSSIBLE PITFALLS:
8095 ! 1) IN THE COURSE OF ITERATION, X MAY REACH A VALUE WHICH
8096 ! 1+X*PATHA NEGATIVE; IN THIS CASE THE ITERATION IS STOP
8097 ! AND AN ERROR MESSAGE IS PRINTED OUT.
8098 ! 2) EVEN IF (1) DOES NOT OCCUR, IT IS STILL POSSIBLE THAT
8099 ! BE NEGATIVE AND LARGE ENOUGH TO MAKE 1+X*PATH(P(I),0,C
8100 ! NEGATIVE. THIS IS CHECKED FOR IN A FINAL LOOP, AND IF
8101 ! A WARNING IS PRINTED OUT.
8102 !
8103 ! *********************************************************************
8104 !....
8105 ! IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8106 ! COMMON/PRESS/PA(109)
8107 REAL RAT,SINV
8108 ! REAL PA,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
8109 REAL PA2
8110 ! COMMON/TRAN/ TRANSA(109,109)
8111 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
8112 DIMENSION PATH0(109),ETAP(109),XAP(109),CAP(109)
8113 DIMENSION SINV(4)
8114 INTEGER :: IERR
8115 DATA SINV/2.74992,2.12731,4.38111,0.0832926/
8116 !NOV89 DIMENSION SINV(3)
8117 !NOV89 DATA SINV/2.74992,2.12731,4.38111/
8118 !O222 OLD CODE USED 2.7528 RATHER THAN 2.74992 ---K.A.C. OCTOBER 1988
8119 !O222 WHEN 2.7528 WAS USED,WE EXACTLY REPRODUCED THE MRF CO2 ARRAYS
8120 CORE=5.000
8121 UEXP=0.90
8122 ! P0=0.7
8123 DO 902 I=1,109
8124 PA2=PA(I)*PA(I)
8125 SEXPV(I)=.505+2.0E-5*PA(I)+.035*(PA2-.25)/(PA2+.25)
8126 902 CONTINUE
8127 DO 900 I=1,109
8128 ETA(I)=3.2E-4*EXP(-PA(I)/500.)
8129 ETAP(I)=ETA(I)
8130 900 CONTINUE
8131 DO 1200 NP=1,10
8132 DO 1000 I=3,109
8133 SEXP=SEXPV(I)
8134 R=(1.0D0-TRANSA(I,I-2))/(1.0D0-TRANSA(I,I-1))
8135 REXP=R**(UEXP/SEXP)
8136 arg1=path(pa(i),pa(i-2),core,eta(i))
8137 arg2=path(pa(i),pa(i-1),core,eta(i))
8138 PATHA=(PATH(PA(I),PA(I-2),CORE,ETA(I)))**UEXP
8139 PATHB=(PATH(PA(I),PA(I-1),CORE,ETA(I)))**UEXP
8140 XX=2.0D0*(PATHB*REXP-PATHA)/(PATHB*PATHB*REXP-PATHA*PATHA)
8141 DO 1010 LL=1,20
8142 F1=DLOG(1.0D0+XX*PATHA)
8143 F2=DLOG(1.0D0+XX*PATHB)
8144 F=F1/F2-REXP
8145 FPRIME=(F2*PATHA/(1.0D0+XX*PATHA)-F1*PATHB/(1.0D0+XX*PATHB))/ &
8146 (F2*F2)
8147 XX=XX-F/FPRIME
8148 CHECK=1.0D0+XX*PATHA
8149 !!!! IF (CHECK) 1020,1020,1025
8150 IF(CHECK.LE.0.)THEN
8151 WRITE(errmess,360)I,LL,CHECK
8152 WRITE(errmess,*)' xx=',xx,' patha=',patha
8153 360 FORMAT(' ERROR,I=',I3,'LL=',I3,'CHECK=',F20.10)
8154 CALL wrf_error_fatal ( errmess )
8155 ENDIF
8156 1010 CONTINUE
8157 CA(I)=(1.0D0-TRANSA(I,I-2))**(UEXP/SEXP)/ &
8158 (DLOG(1.0D0+XX*PATHA)+1.0D-20)
8159 XA(I)=XX
8160 1000 CONTINUE
8161 XA(2)=XA(3)
8162 XA(1)=XA(3)
8163 CA(2)=CA(3)
8164 CA(1)=CA(3)
8165 DO 1100 I=3,109
8166 PATH0(I)=(PATH(PA(I),0.,CORE,ETA(I)))**UEXP
8167 PATH0(I)=1.0D0+XA(I)*PATH0(I)
8168 !+++ IF (PATH0(I).LT.0.) WRITE (6,361) I,PATH0(I),XA(I)
8169 1100 CONTINUE
8170 DO 1035 I=1,109
8171 SEXP=SEXPV(I)
8172 ETAP(I)=ETA(I)
8173 ETA(I)=(SINV(IR)/RAT)**(1./SEXP)* &
8174 (CA(I)*XA(I))**(1./UEXP)
8175 1035 CONTINUE
8176 !
8177 ! THE ETA FORMULATION IS DETAILED IN SCHWARZKOPF AND FELS(1985).
8178 ! THE QUANTITY SINV=(G*DELTANU)/(RCO2*D*S)
8179 ! IN CGS UNITS,WITH D,THE DIFFUSICITY FACTOR=2, AND
8180 ! S,THE SUM OF CO2 LINE STRENGTHS OVER THE 15UM CO2 BAND
8181 ! ALSO,THE DENOMINATOR IS MULTIPLIED BY
8182 ! 1000 TO PERMIT USE OF MB UNITS FOR PRESSURE.
8183 ! S IS ACTUALLY WEIGHTED BY B(250) AT 10 CM-1 WIDE INTERVALS,IN
8184 ! ORDER TO BE CONSISTENT WITH THE METHODS USED TO OBTAIN THE LBL
8185 ! 1-BAND CONSOLIDATED TRANCMISSION FUNCTIONS.
8186 ! FOR THE 490-850 INTERVAL (DELTANU=360,IR=1) SINV=2.74992.
8187 ! (SLIGHTLY DIFFERENT FROM 2.7528 USED IN EARLIER VERSIONS)
8188 ! FOR THE 490-670 INTERVAL (IR=2) SINV=2.12731
8189 ! FOR THE 670-850 INTERVAL (IR=3) SINV=4.38111
8190 ! FOR THE 2270-2380 INTERVAL (IR=4) SINV=0.0832926
8191 ! SINV HAS BEEN OBTAINED USING THE 1982 AFGL CATALOG FOR CO2
8192 ! RAT IS THE ACTUAL CO2 MIXING RATIO IN UNITS OF 330 PPMV,
8193 ! LETTING USE OF THIS FORMULATION FOR ANY CO2 CONCENTRATION.
8194 !
8195 ! WRITE (6,366) (NP,I,CA(I),XA(I),ETA(I),SEXPV(I),I=1,109)
8196 !366 FORMAT (2I4,4E20.12)
8197 1200 CONTINUE
8198 361 FORMAT (' **WARNING:** 1+XA*PATH(PA(I),0) IS NEGATIVE,I= ',I3,/ &
8199 20X,'PATH0(I)=',F16.6,' XA(I)=',F16.6)
8200 RETURN
8201 END SUBROUTINE COEINT
8203 !--------------
8206 !CCC PROGRAM CO2INS
8207 SUBROUTINE CO2INS(T22,T23,T66,IQ,L,LP1,iflag)
8208 ! *********************************************************
8209 ! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ******
8210 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988...
8211 ! ..... K.CAMPANA DECEMBER 1988-CLEANED UP FOR LAUNCHER
8212 ! ..... K.CAMPANA NOVEMBER 1989-ALTERED FOR NEW RADIATION
8213 ! *********************************************************
8214 DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3),T66(LP1,LP1,6)
8215 DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
8216 CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
8217 CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
8218 !CC ITIN=22
8219 !CC ITIN1=23
8220 !O222 LATEST CODE HAD IQ=1
8221 !CC IQ=4
8222 1011 FORMAT (4F20.14)
8223 !CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
8224 !CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
8225 !CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
8226 !CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
8227 !CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
8228 !CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
8229 DO 300 J=1,LP1
8230 DO 300 I=1,LP1
8231 CO2PO(I,J) = T22(I,J,1)
8232 !NOV89
8233 IF (IQ.EQ.5) GO TO 300
8234 !NOV89
8235 CO2PO1(I,J) = T22(I,J,2)
8236 CO2PO2(I,J) = T22(I,J,3)
8237 300 CONTINUE
8238 DO 301 J=1,LP1
8239 DO 301 I=1,LP1
8240 CO2800(I,J) = T23(I,J,1)
8241 !NOV89
8242 IF (IQ.EQ.5) GO TO 301
8243 !NOV89
8244 CO2801(I,J) = T23(I,J,2)
8245 CO2802(I,J) = T23(I,J,3)
8246 301 CONTINUE
8247 !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
8248 ! ARE:
8249 ! IQ=1 560-800 (CONSOL.=490-850)
8250 ! IQ=2 560-670 (CONSOL.=490-670)
8251 ! IQ=3 670-800 (CONSOL.=670-850)
8252 ! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850)
8253 !NOV89
8254 ! IQ=5 2270-2380 (CONSOL.=2270-2380)
8255 !NOV89
8256 ! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
8257 ! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
8258 ! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
8259 !NOV89
8260 ! NOTE: ALTHOUGH THE BAND TRANSMISSION FUNCTIONS ARE
8261 ! COMPUTED FOR ALL RADIATIVE BANDS, AS OF 9/28/88, THEY
8262 ! ARE WRITTEN OUT IN FULL ONLY FOR THE FULL 15 UM BAND CASES
8263 ! (IQ=1,4). IN OTHER CASES, THE TRANSMISSIVITIES (1,K) ARE
8264 ! WRITTEN OUT, AS THESE ARE THE ONLY ONES NEEDED FOR CTS
8265 ! CALCULATIONS. ALSO, FOR THE 4.3 UM BAND (IQ=5) THE TEMP.
8266 ! DERIVATIVE TERMS ARE NOT WRITTEN OUT, AS THEY ARE UNUSED.
8267 !NOV89
8268 IF (IQ.EQ.1) THEN
8269 C1=1.5
8270 C2x=0.5
8271 ENDIF
8272 IF (IQ.EQ.2) THEN
8273 C1=18./11.
8274 C2x=7./11.
8275 ENDIF
8276 IF (IQ.EQ.3) THEN
8277 C1=18./13.
8278 C2x=5./13.
8279 ENDIF
8280 IF (IQ.EQ.4) THEN
8281 C1=1.8
8282 C2x=0.8
8283 ENDIF
8284 !NOV89
8285 IF (IQ.EQ.5) THEN
8286 C1=1.0
8287 C2x=0.0
8288 ENDIF
8289 !NOV89
8290 DO 1021 I=1,LP1
8291 DO 1021 J=1,LP1
8292 CO2PO(J,I)=C1*CO2PO(J,I)-C2x
8293 CO2800(J,I)=C1*CO2800(J,I)-C2x
8294 !NOV89
8295 IF (IQ.EQ.5) GO TO 1021
8296 !NOV89
8297 CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
8298 CO2801(J,I)=C1*CO2801(J,I)-C2x
8299 CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
8300 CO2802(J,I)=C1*CO2802(J,I)-C2x
8301 1021 CONTINUE
8302 !NOV89
8303 IF (IQ.GE.1.AND.IQ.LE.4) THEN
8304 !NOV89
8305 DO 1 J=1,LP1
8306 DO 1 I=1,LP1
8307 DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
8308 DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
8309 D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
8310 D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
8311 1 CONTINUE
8312 !NOV89
8313 ENDIF
8314 !NOV89
8315 !O222 *********************************************************
8316 !CC REWIND 66
8317 ! SAVE CDT51,CO251,C2D51,CDT58,CO258,C2D58..ON TEMPO FILE
8318 !CC WRITE (66) DCDT10
8319 !CC WRITE (66) CO2PO
8320 !CC WRITE (66) D2CT10
8321 !CC WRITE (66) DCDT8
8322 !CC WRITE (66) CO2800
8323 !CC WRITE (66) D2CT8
8324 !CC REWIND 66
8325 !NOV89
8326 IF (IQ.EQ.1.OR.IQ.EQ.4) THEN
8327 !NOV89
8328 DO 400 J=1,LP1
8329 DO 400 I=1,LP1
8330 T66(I,J,1) = DCDT10(I,J)
8331 T66(I,J,2) = CO2PO(I,J)
8332 T66(I,J,3) = D2CT10(I,J)
8333 T66(I,J,4) = DCDT8(I,J)
8334 T66(I,J,5) = CO2800(I,J)
8335 T66(I,J,6) = D2CT8(I,J)
8336 400 CONTINUE
8337 !NOV89
8338 ELSE
8339 DO 409 I=1,LP1
8340 T66(I,1,2) = CO2PO(1,I)
8341 T66(I,1,5) = CO2800(1,I)
8342 IF (IQ.EQ.5) GO TO 409
8343 T66(I,1,1) = DCDT10(1,I)
8344 T66(I,1,3) = D2CT10(1,I)
8345 T66(I,1,4) = DCDT8(1,I)
8346 T66(I,1,6) = D2CT8(1,I)
8347 409 CONTINUE
8348 ENDIF
8349 !NOV89
8350 !O222 *********************************************************
8351 RETURN
8352 END SUBROUTINE CO2INS
8353 !O222 PROGRAM CO2INT(INPUT,TAPE5=INPUT)
8354 !NOV89
8355 SUBROUTINE CO2INT(ITAPE,T15A,T15B,T22,RATIO,IR,NMETHD,NLEVLS,NLP1,NLP2)
8356 !NOV89
8357 ! *********************************************************
8358 ! CHANGES TO DATA READ AND FORMAT SEE CO222 ***
8359 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988
8360 ! CHANGES TO PASS ITAPE,AND IF IR=4,READ 1 CO2 REC..KAC NOV89
8361 ! *********************************************************
8362 ! CO2INT INTERPOLATES CARBON DIOXIDE TRANSMISSION FUNCTIONS
8363 ! FROM THE 109 LEVEL GRID,FOR WHICH THE TRANSMISSION FUNCTIONS
8364 ! HAVE BEEN PRE-CALCULATED, TO THE GRID STRUCTURE SPECIFIED BY THE
8365 ! USER.
8366 !
8367 ! METHOD:
8368 !
8369 ! CO2INT IS EMPLOYABLE FOR TWO PURPOSES: 1) TO OBTAIN TRANSMIS-
8370 ! SIVITIES BETWEEN ANY 2 OF AN ARRAY OF USER-DEFINED PRESSURES; AND
8371 ! 2) TO OBTAIN LAYER-MEAN TRANSMISSIVITIES BETWEEN ANY 2 OF AN ARRAY
8372 ! OF USER-DEFINED PRESSURE LAYERS.TO CLARIFY THESE TWO PURPOSES,SEE
8373 ! THE DIAGRAM AND DISCUSSION BELOW.
8374 ! CO2INT MAY BE USED TO EXECUTE ONLY ONE PURPOSE AT ONE TIME.
8375 !
8376 ! LET P BE AN ARRAY OF USER-DEFINED PRESSURES
8377 ! AND PD BE USER-DEFINED PRESSURE LAYERS.
8378 !
8379 ! - - - - - - - - - PD(I-1) ---
8380 ! ^
8381 ! ----------------- P(I) ^ PRESSURE LAYER I (PLM(I))
8382 ! ^
8383 ! - - - - - - - - - PD(I) ---
8384 ! ^
8385 ! ----------------- P(I+1) ^ PRESSURE LAYER I+1 (PLM(I+1))
8386 ! ^
8387 ! - - - - - - - - - PD(I+1)---
8388 ! ... (THE NOTATION USED IS
8389 ! ... CONSISTENT WITH THE CODE)
8390 ! ...
8391 ! - - - - - - - - - PD(J-1)
8392 !
8393 ! ----------------- P(J)
8394 !
8395 ! - - - - - - - - - PD(J)
8396 !
8397 ! PURPOSE 1: THE TRANSMISSIVITY BETWEEN SPECIFIC PRESSURES
8398 ! P(I) AND P(J) ,TAU(P(I),P(J)) IS COMPUTED BY THIS PROGRAM.
8399 ! IN THIS MODE,THERE IS NO REFERENCE TO LAYER PRESSURES PD
8400 ! (PD,PLM ARE NOT INPUTTED).
8401 !
8402 ! PURPOSE 2: THE LAYER-MEAN TRANSMISSIVITY BETWEEN A LAYER-
8403 ! MEAN PRESSURE PLM(J) AND PRESSURE LAYER I IS GIVEN BY
8404 ! TAULM(PLM(I),PLM(J)). IT IS COMPUTED BY THE INTEGRAL
8405 !
8406 ! PD(I)
8407 ! ----
8408 ! 1 ^
8409 ! ------------- * ^ TAU ( P',PLM(J) ) DP'
8410 ! PD(I)-PD(I-1) ^
8411 ! ----
8412 ! PD(I-1)
8413 !
8414 ! THE LAYER-MEAN PRESSURE PLM(I) IS SPECIFIED BY THE USER.
8415 ! FOR MANY PURPOSES,PLM WILL BE CHOSEN TO BE THE AVERAGE
8416 ! PRESSURE IN THE LAYER-IE,PLM(I)=0.5*(PD(I-1)+PD(I)).
8417 ! FOR LAYER-MEAN TRANSMISSIVITIES,THE USER THUS INPUTS
8418 ! A PRESSURE ARRAY (PD) DEFINING THE PRESSURE LAYERS AND AN
8419 ! ARRAY (PLM) DEFINING THE LAYER-MEAN PRESSURES.THE CALCULATION
8420 ! DOES NOT DEPEND ON THE P ARRAY USED FOR PURPOSE 1 (P IS NOT
8421 ! INPUTTED).
8422 !
8423 ! THE FOLLOWING PARAGRAPHS DEPICT THE UTILIZATION OF THIS
8424 ! CODE WHEN USED TO COMPUTE TRANSMISSIVITIES BETWEEN SPECIFIC
8425 ! PRESSURES. LATER PARAGRAPHS DESCRIBE ADDITIONAL FEATURES NEEDED
8426 ! FOR LAYER-MEAN TRANSMISSIVITIES.
8427 !
8428 ! FOR A GIVEN CO2 MIXING RATIO AND STANDARD TEMPERATURE
8429 ! PROFILE,A TABLE OF TRANSMISSION FUNCTIONS FOR A FIXED GRID
8430 ! OF ATMOSPHERIC PRESSURES HAS BEEN PRE-CALCULATED.
8431 ! THE STANDARD TEMPERATURE PROFILE IS COMPUTED FROM THE US
8432 ! STANDARD ATMOSPHERE (1977) TABLE.ADDITIONALLY, THE
8433 ! SAME TRANSMISSION FUNCTIONS HAVE BEEN PRE-CALCULATED FOR A
8434 ! TEMPERATURE PROFILE INCREASED AND DECREASED (AT ALL LEVELS)
8435 ! BY 25 DEGREES.
8436 ! THIS PROGRAM READS IN THE PRESPECIFIED TRANSMISSION FUNCTIONS
8437 ! AND A USER-SUPPLIED PRESSURE GRID (P(I)) AND CALCULATES TRANS-
8438 ! MISSION FUNCTIONS ,TAU(P(I),P(J)), FOR ALL P(I) S AND P(J) S.
8439 ! A LOGARITHMIC INTERPOLATION SCHEME IS USED.
8440 ! THIS METHOD IS REPEATED FOR THE THREE TEMPERATURE PROFILES
8441 ! GIVEN ABOVE .THEREFORE OUTPUTS FROM THE PROGRAM ARE THREE TABLES
8442 ! OF TRANSMISSION FUNCTIONS FOR THE USER-SUPPLIED PRESSURE GRID.
8443 ! THE EXISTENCE OF THE THREE TABLES PERMITS SUBSEQUENT INTERPO-
8444 ! LATION TO A USER-SUPPLIED TEMPERATURE PROFILE USING THE METHOD
8445 ! DESCRIBED IN THE REFERENCE.SEE LIMITATIONS SECTION IF THE
8446 ! USER DESIRES TO OBTAIN ONLY 1 TABLE OF TRANSMISSIVITIES.
8447 !
8448 ! MODIFICATIONS FOR LAYER-MEAN TRANSMISSIVITIES:
8449 ! THE PRESSURES INPUTTED ARE THE LAYER-MEAN PRESSURES,PD,
8450 ! AND THE LAYER-MEAN PRESSURES ,PLM. A SERIES OF TRANSMISSIVITIES
8451 ! (TAU(P'',PLM(J)) ARE COMPUTED AND THE INTEGRAL GIVEN IN THE
8452 ! DISCUSSION OF PURPOSE 2 IS COMPUTED.FOR PLM(I) NOT EQUAL TO
8453 ! PLM(J) SIMPSON S RULE IS USED WITH 5 POINTS. IF PLM(I)=PLM(J)
8454 ! (THE -NEARBY LAYER- CASE) A 49-POINT QUADRATURE IS USED FOR
8455 ! GREATER ACCURACY.THE OUTPUT IS IN TAULM(PLM(I),PLM(J)).
8456 ! NOTE:
8457 ! TAULM IS NOT A SYMMETRICAL MATRIX. FOR THE ARRAY ELEMENT
8458 ! TAULM(PLM(I),PLM(J)),THE INNER(FIRST,MOST RAPIDLY VARYING)
8459 ! DIMENSION IS THE VARYING LAYER-MEAN PRESSURE,PLM(I);THE OUTER
8460 ! (SECOND) DIMENSION IS THE FIXED LAYER-MEAN PRESSURE PLM(J).
8461 ! THUS THE ELEMENT TAULM(2,3) IS THE TRANSMISSION FUNCTION BETWEEN
8462 ! THE FIXED PRESSURE PLM(3) AND THE PRESSURE LAYER HAVING AN AVERAG
8463 ! PRESSURE OF PLM(2).
8464 ! ALSO NOTE THAT NO QUADRATURE IS PERFORMED OVER THE LAYER
8465 ! BETWEEN THE SMALLEST NONZERO PRESSURE AND ZERO PRESSURE;
8466 ! TAULM IS TAULM(0,PLM(J)) IN THIS CASE,AND TAULM(0,0)=1.
8467 !
8468 !
8469 ! REFERENCE:
8470 ! S.B.FELS AND M.D.SCHWARZKOPF,-AN EFFICIENT ACCURATE
8471 ! ALGORITHM FOR CALCULATING CO2 15 UM BAND COOLING RATES-,JOURNAL
8472 ! OF GEOPHYSICAL RESEARCH,VOL.86,NO. C2, PP.1205-1232,1981.
8473 ! MODIFICATIONS TO THE ALGORITHM HAVE BEEN MADE BY THE AUTHORS;
8474 ! CONTACT S.B.F.OR M.D.S. FOR FURTHER DETAILS.A NOTE TO J.G.R.
8475 ! IS PLANNED TO DOCUMENT THESE CHANGES.
8476 !
8477 ! AUTHOR: M.DANIEL SCHWARZKOPF
8478 !
8479 ! DATE: 14 JULY 1983
8480 !
8481 ! ADDRESS:
8482 !
8483 ! G.F.D.L.
8484 ! P.O.BOX 308
8485 ! PRINCETON,N.J.08540
8486 ! U.S.A.
8487 ! TELEPHONE: (609) 452-6521
8488 !
8489 ! INFORMATION ON TAPE: THIS SOURCE IS THE FIRST FILE
8490 ! ON THIS TAPE.THE SIX FILES THAT FOLLOW ARE CO2 TRANS-
8491 ! MISSIVITIES FOR THE 500-850 CM-1 INTERVAL FOR CO2
8492 ! CONCENTRATIONS OF 330 PPMV (1X) ,660 PPMV (2X), AND
8493 ! 1320 PPMV (4X). THE FILES ARE ARRANGED AS FOLLOWS:
8494 ! FILE 2 1X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8495 ! FILE 3 1X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8496 ! FILE 4 2X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8497 ! FILE 5 2X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8498 ! FILE 6 4X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8499 ! FILE 7 4X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8500 ! FILES 2,4,6 ARE RECOMMENDED FOR USE IN OBTAINING
8501 ! TRANSMISSION FUNCTIONS FOR USE IN HEATING RATE
8502 ! COMPUTATIONS;THEY CORRESPOND TO THE TRANSMISSIVITIES
8503 ! DISCUSSED IN THE 1980 PAPER.FILES 3,5,7 ARE PROVIDED
8504 ! TO FACILITATE COMPARISON WITH OBSERVATION AND WITH OTHER
8505 ! CALCULATIONS.
8506 !
8507 ! PROGRAM LANGUAGE: FORTRAN 1977,INCLUDING PARAMETER
8508 ! AND PROGRAM STATEMENTS.THE PROGRAM IS WRITTEN ON A
8509 ! CYBER 170-730.SEE THE SECTION ON LIMITATIONS FOR
8510 ! ADAPTATIONS TO OTHER MACHINES.
8511 !
8512 ! INPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
8513 !
8514 ! UNIT NO VARIABLES FORMAT STATEMENT NO. TYPE
8515 ! 5 P (PURPOSE 1) (5E16.9) 201 CARDS
8516 ! 5 PD (PURPOSE 2) (5E16.9) 201 CARDS
8517 ! 5 PLM(PURPOSE 2) (5E16.9) 201 CARDS
8518 ! 5 NMETHD (I3) 202 CARDS
8519 ! 20 TRANSA (4F20.14) 102 TAPE
8520 !NOV89
8521 ! ITAPE TRANSA (4F20.14) 102 TAPE
8522 !NOV89
8523 !
8524 ! OUTPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
8525 !
8526 ! UNIT NO VARIABLES FORMAT STATEMENT NO.
8527 ! 6 TRNFCT (1X,8F15.8) 301 PRINT
8528 ! 22 TRNFCT (4F20.14) 102 TAPE
8529 !
8530 ! PARAMETER INPUTS:
8531 ! A) NLEVLS : NLEVLS IS AN (INTEGER) PARAMETER DENOTING
8532 ! THE NUMBER OF NONZERO PRESSURE LEVELS FOR PURPOSE 1
8533 ! OR THE NUMBER OF NONZERO LAYER PRESSURES NEEDED TO
8534 ! SPECIFY THE PRESSURE LAYERS(PURPOSE 2) IN THE OUTPUT
8535 ! GRID. FOR EXAMPLE,IN PURPOSE 1,IF P=0,100,1000,NLEVLS=2.
8536 ! IF,IN PURPOSE 2,PD=0,100,500,1000,THE NUMBER OF NONZERO
8537 ! PRESSURE LAYERS=2,SO NLEVLS=2
8538 ! IN THE CODE AS WRITTEN,NLEVLS=40; THE USER SHOULD
8539 ! CHANGE THIS VALUE TO A USER-SPECIFIED VALUE.
8540 ! B) NLP1,NLP2 : INTEGER PARAMETERS DEFINED AS: NLP1=NLEVLS+1;
8541 ! NLP2=NLEVLS+2.
8542 ! SEE LIMITATIONS FOR CODE MODIFICATIONS IF PARAMETER
8543 ! STATEMENTS ARE NOT ALLOWED ON YOUR MACHINE.
8544 !
8545 ! INPUTS:
8546 !
8547 ! A) TRANSA : THE 109X109 GRID OF TRANSMISSION FUNCTIONS
8548 ! TRANSA IS A DOUBLE PRECISION REAL ARRAY.
8549 !
8550 ! TRANSA IS READ FROM FILE 20. THIS FILE CONTAINS 3
8551 ! RECORDS,AS FOLLOWS:
8552 ! 1) TRANSA, STANDARD TEMPERATURE PROFILE
8553 ! 3) TRANSA, STANDARD TEMPERATURES + 25 DEG
8554 ! 5) TRANSA, STANDARD TEMPERATURES - 25 DEG
8555 !
8556 ! B) NMETHD: AN INTEGER WHOSE VALUE IS EITHER 1 (IF CO2INT IS
8557 ! TO BE USED FOR PURPOSE 1) OR 2 (IF CO2INT IS TO BE USED FOR
8558 ! PURPOSE 2).
8559 !
8560 ! C) P,PD,PLM :
8561 ! P IS A REAL ARRAY (LENGTH NLP1) SPECIFYING THE PRESSURE
8562 ! GRID AT WHICH TRANSMISSION FUNCTIONS ARE TO BE COMPUTED FOR
8563 ! PURPOSE 1.THE DIMENSION OF P IS IN MILLIBARS.THE
8564 ! FOLLOWING LIMITATIONS WILL BE EXPLAINED MORE
8565 ! IN THE SECTION ON LIMITATIONS: P(1) MUST BE ZERO; P(NLP1),THE
8566 ! LARGEST PRESSURE, MUST NOT EXCEED 1165 MILLIBARS.
8567 ! PD IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE PRESSURE
8568 ! LAYERS FOR WHICH LAYER-AVERAGED TRANSMISSION FUNCTIONS ARE
8569 ! TO BE COMPUTED.THE DIMENSION OF PD IS MILLIBARS.THE LIMITATIONS
8570 ! FOR PD ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
8571 ! LIMITATIONS.
8572 ! PLM IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE LAYER-MEAN
8573 ! PRESSURES. THE DIMENSION OF PLM IS MILLIBARS. THE LIMITATIONS
8574 ! FOR PLM ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
8575 ! LIMITATIONS.PD IS READ IN BEFORE PLM.
8576 !
8577 ! NOTE: AGAIN,WE NOTE THAT THE USER WILL INPUT EITHER P (FOR
8578 ! PURPOSE 1) OR PD AND PLM(FOR PURPOSE 2) BUT NOT BOTH.
8579 !
8580 !
8581 !
8582 !
8583 ! LIMITATIONS:
8584 ! 1) P(1)=0.,PD(1)=0.,PLM(1)=0. THE TOP PRESSURE LEVEL
8585 ! MUST BE ZERO,OR THE TOP PRESSURE LAYER MUST BE BOUNDED BY ZERO.
8586 ! THE TOP LAYER-MEAN PRESSURE (PLM(1)) MUST BE ZERO; NO
8587 ! QUADRATURE IS DONE ON THE TOP PRESSURE LAYER.EVEN IF ONE IS
8588 ! NOT INTERESTED IN THE TRANSMISSION FUNCTION BETWEEN 0 AND P(J),
8589 ! ONE MUST INCLUDE SUCH A LEVEL.
8590 ! 2) PD(NLP2)=P(NLP1) IS LESS THAN OR EQUAL TO 1165 MB.
8591 ! EXTRAPOLATION TO HIGHER PRESSURES IS NOT POSSIBLE.
8592 ! 3) IF PROGRAM IS NOT PERMITTED ON YOUR COMPILER,
8593 ! SIMPLY DELETE THE LINE.
8594 ! 4) IF PARAMETER IS NOT PERMITTED,DO THE FOLLOWING:
8595 ! 1) DELETE ALL PARAMETER STATEMENTS IN CO2INT
8596 ! 2) AT THE POINT WHERE NMETHOD IS READ IN,ADD:
8597 ! READ (5,202) NLEVLS
8598 ! NLP1=NLEVLS+1
8599 ! NLP2=NLEVLS+2
8600 ! 3) CHANGE DIMENSION AND/OR COMMON STATEMENTS DEFINING
8601 ! ARRAYS TRNS,DELTA,P,PD,TRNFCT,PS,PDS,PLM IN CO2INT.
8602 ! THE NUMERICAL VALUE OF (NLEVLS+1) SHOULD BE INSERTED
8603 ! IN DIMENSION OR COMMON STATEMENTS FOR TRNS,DELTA,
8604 ! P,TRNFCT,PS,PLM; THE NUMERICAL VALUE OF (NLEVLS+2)
8605 ! IN DIMENSION OR COMMON STATEMENTS FOR PD,PDS.
8606 ! 5) PARAMETER (NLEVLS=40) AND THE OTHER PARAMETER
8607 ! STATEMENTS ARE WRITTEN IN CDC FORTRAN; ON OTHER MACHINES THE
8608 ! SAME STATEMENT MAY BE WRITTEN DIFFERENTLY,FOR EXAMPLE AS
8609 ! PARAMETER NLEVLS=40
8610 ! 6) -DOUBLE PRECISION- IS USED INSTEAD OF -REAL*8- ,DUE TO
8611 ! REQUIREMENTS OF CDC FORTAN.
8612 ! 7) THE STATEMENT -DO 400 KKK=1,3- CONTROLS THE NUMBER OF
8613 ! TRANSMISSIVITY OUTPUT MATRICES PORDUCED BY THE PROGRAM.TO
8614 ! PRODUCE 1 OUTPUT MATRIX,DELETE THIS STATEMENT.
8615 !
8616 ! OUTPUT:
8617 ! A) TRNFCT IS AN (NLP1,NLP1) REAL ARRAY OF THE TRANSMISSION
8618 ! FUNCTIONS APPROPRIATE TO YOUR ARRAY. IT IS TO BE SAVED ON FILE 22.
8619 ! THE PROCEDURE FOR SAVING MAY BE MODIFIED; AS GIVEN HERE,THE
8620 ! OUTPUT IS IN CARD IMAGE FORM WITH A FORMAT OF (4F20.14).
8621 !
8622 ! B) PRINTED OUTPUT IS A LISTING OF TRNFCT ON UNIT 6, IN
8623 ! THE FORMAT (1X,8F15.8) (FORMAT STATEMENT 301). THE USER MAY
8624 ! MODIFY OR ELIMINATE THIS AT WILL.
8625 !
8626 ! ************ FUNCTION INTERPOLATER ROUTINE *****************
8627 !
8628 !
8629 ! ****** THE FOLLOWING PARAMETER GIVES THE NUMBER OF *******
8630 ! ****** DATA LEVELS IN THE MODEL *******
8631 ! ****************************************************************
8632 ! ****************************************************************
8633 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
8634 ! COMMON/PRESS/PA(109)
8635 ! COMMON/TRAN/ TRANSA(109,109)
8636 ! COMMON / OUTPUT / TRNS(NLP1,NLP1)
8637 ! COMMON/INPUTP/P(NLP1),PD(NLP2)
8638 DIMENSION TRNS(NLP1,NLP1)
8639 DIMENSION P(NLP1),PD(NLP2)
8640 DIMENSION PS(NLP1),PDS(NLP2),PLM(NLP1)
8641 DIMENSION NRTAB(3)
8642 DIMENSION T15A(NLP2,2),T15B(NLP1)
8643 DIMENSION T22(NLP1,NLP1,3)
8644 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
8645 DATA NRTAB/1,2,4/
8646 !***********************************
8647 ! THE FOLLOWING ARE THE INPUT FORMATS
8648 100 FORMAT (4F20.14)
8649 743 FORMAT (F20.14)
8650 201 FORMAT (5E16.9)
8651 202 FORMAT (I3)
8652 !O222 203 FORMAT (F12.6,I2)
8653 203 FORMAT (F12.6)
8654 ! THE FOLLOWING ARE THE OUTPUT FORMATS
8655 102 FORMAT (4F20.14)
8656 301 FORMAT (1X,8F15.8)
8657 !
8658 !CC REWIND 15
8659 !CC REWIND 20
8660 !NOV89
8661 REWIND ITAPE
8662 !NOV89
8663 !CC REWIND 22
8664 !
8665 ! CALCULATION OF PA -THE -TABLE- OF 109 GRID PRESSURES
8666 ! NOTE-THIS CODE MUST NOT BE CHANGED BY THE USER^^^^^^^^^
8667 PA(1)=0.
8668 FACT15=10.**(1./15.)
8669 FACT30=10.**(1./30.)
8670 PA(2)=1.0E-3
8671 DO 231 I=2,76
8672 PA(I+1)=PA(I)*FACT15
8673 231 CONTINUE
8674 DO 232 I=77,108
8675 PA(I+1)=PA(I)*FACT30
8676 232 CONTINUE
8677 !
8678 N=25
8679 NLV=NLEVLS
8680 NLP1V=NLP1
8681 NLP2V=NLP2
8682 ! READ IN THE CO2 MIXING RATIO(IN UNITS OF 330 PPMV),AND AN INDEX
8683 ! GIVING THE FREQUENCY RANGE OF THE LBL DATA
8684 !O222 READ (5,203) RATIO,IR
8685 !CC IR = 1
8686 !CC READ (5,203) RATIO
8687 !O222 ***********************************
8688 !***VALUES FOR IR*****
8689 ! IR=1 CONSOL. LBL TRANS. =490-850
8690 ! IR=2 CONSOL. LBL TRANS. =490-670
8691 ! IR=3 CONSOL. LBL TRANS. =670-850
8692 ! IR=4 CONSOL. LBL TRANS. =2270-2380
8693 !*** IR MUST BE 1,2,3 OR 4 FOR THE PGM. TO WORK
8694 ! ALSO READ IN THE METHOD NO.(1 OR 2)
8695 !CC READ (5,202) NMETHD
8696 IF (RATIO.EQ.1.0) GO TO 621
8697 CALL wrf_error_fatal( 'SUBROUTINE CO2INT: 8746' )
8698 !NOV89 621 ITAP1=20
8699 621 ITAP1=ITAPE
8700 !NOV89
8701 NTAP=1
8702 IF (NMETHD.EQ.2) GO TO 502
8703 ! *****CARDS FOR PURPOSE 1(NMETHD=1)
8704 !CC READ (15,201) (P(I),I=1,NLP1)
8705 DO 300 I=1,NLP1
8706 P(I)=T15B(I)
8707 300 CONTINUE
8708 DO 801 I=1,NLP1
8709 PS(I)=P(I)
8710 801 CONTINUE
8711 GO TO 503
8712 502 CONTINUE
8713 ! *****CARDS FOR PURPOSE 2(NMETHD=2)
8714 !CC READ (15,201) (PD(I),I=1,NLP2)
8715 !CC READ (15,201) (PLM(I),I=1,NLP1)
8716 DO 303 I=1,NLP2
8717 PD(I)=T15A(I,1)
8718 303 CONTINUE
8719 DO 302 I=1,NLP1
8720 PLM(I)=T15A(I,2)
8721 302 CONTINUE
8722 DO 802 I=1,NLP1
8723 PDS(I)=PD(I+1)
8724 PS(I)=PLM(I)
8725 802 CONTINUE
8726 !
8727 503 CONTINUE
8728 ! *****DO LOOP CONTROLLING NUMBER OF OUTPUT MATRICES
8729 !NOV89
8730 !NOV89 DO 400 KKK=1,3
8731 ICLOOP = 3
8732 IF (IR.EQ.4) ICLOOP = 1
8733 DO 400 KKK=1,ICLOOP
8734 !NOV89
8735 ! **********************
8736 IF (NMETHD.EQ.2) GO TO 505
8737 ! *****CARDS FOR PURPOSE 1(NMETHD=1)
8738 DO 803 I=1,NLP1
8739 P(I)=PS(I)
8740 803 CONTINUE
8741 GO TO 506
8742 505 CONTINUE
8743 ! *****CARDS FOR PURPOSE 2(NMETHD=2)
8744 DO 804 I=1,NLP1
8745 PD(I)=PDS(I)
8746 P(I)=PS(I)
8747 804 CONTINUE
8748 !
8749 506 CONTINUE
8750 IA=108
8751 IAP=IA+1
8752 !NOV89 IF (NTAP.EQ.1) READ (20,100) ((TRANSA(I,J),I=1,109),J=1,109)
8753 !mp IF (NTAP.EQ.1) READ (ITAPE,100) ((TRANSA(I,J),I=1,109),J=1,109)
8754 IF (NTAP.EQ.1) THEN
8755 IF ( wrf_dm_on_monitor() ) READ (ITAPE,743) ((TRANSA(I,J),I=1,109),J=1,109)
8756 CALL wrf_dm_bcast_bytes ( TRANSA , size ( TRANSA ) * RWORDSIZE )
8757 ENDIF
8758 !mp IF (NTAP.EQ.1) READ (ITAPE,100) (tmp(I),I=1,11881
8759 !mp
8760 do J=109,1,-6
8761 !mp write(6,697)(TRANSA(I,J),I=5,105,10)
8762 enddo
8763 697 format(11(f5.3,1x))
8764 !mp
8765 !NOV89
8766 DO 4 I=1,IAP
8767 TRANSA(I,I)=1.0
8768 4 CONTINUE
8769 CALL COEINT(RATIO,IR)
8770 DO 805 I=1,NLP1
8771 DO 805 J=1,NLP1
8772 TRNS(J,I)=1.00
8773 805 CONTINUE
8774 DO 10 I=1,NLP1
8775 DO 20 J=1,I
8776 IF (I.EQ.J) GO TO 20
8777 P1=P(J)
8778 P2=P(I)
8779 CALL SINTR2
8780 TRNS(J,I)=TRNSLO
8781 20 CONTINUE
8782 10 CONTINUE
8783 DO 47 I=1,NLP1
8784 DO 47 J=I,NLP1
8785 TRNS(J,I)=TRNS(I,J)
8786 47 CONTINUE
8787 ! *****THIS IS THE END OF PURPOSE 1 CALCULATIONS
8788 IF (NMETHD.EQ.1) GO TO 2872
8789 !
8790 DO 51 J=1,NLP1
8791 DO 52 I=2,NLP1
8792 IA=I
8793 JA=J
8794 N=25
8795 IF (I.NE.J) N=3
8796 CALL QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
8797 52 CONTINUE
8798 51 CONTINUE
8799 ! *****THIS IS THE END OF PURPOSE 2 CALCULATIONS
8800 2872 CONTINUE
8801 !
8802 !+++ WRITE (6,301) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
8803 !CC WRITE (22,102) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
8804 DO 304 J=1,NLP1
8805 DO 304 I=1,NLP1
8806 T22(I,J,KKK) = TRNS(I,J)
8807 304 CONTINUE
8808 400 CONTINUE
8809 RETURN
8810 END SUBROUTINE CO2INT
8811 !CCC PROGRAM CO2IN1
8812 SUBROUTINE CO2IN1(T20,T21,T66,IQ,L,LP1)
8813 ! CO2IN1=CO2INS FOR METHOD 1
8814 ! *********************************************************
8815 ! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ***
8816 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988
8817 ! ..... K.CAMPANA DECEMBER 88 CLEANED UP FOR LAUNCHER
8818 ! *********************************************************
8819 DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3),T66(L,6)
8820 DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
8821 CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
8822 CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
8823 ITIN=20
8824 ITIN1=21
8825 !O222 LATEST CODE HAS IQ=1
8826 !CC IQ=4
8827 1011 FORMAT (4F20.14)
8828 !CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
8829 !CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
8830 !CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
8831 !CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
8832 !CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
8833 !CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
8834 DO 300 J=1,LP1
8835 DO 300 I=1,LP1
8836 CO2PO(I,J) = T20(I,J,1)
8837 !NOV89
8838 IF (IQ.EQ.5) GO TO 300
8839 !NOV89
8840 CO2PO1(I,J) = T20(I,J,2)
8841 CO2PO2(I,J) = T20(I,J,3)
8842 300 CONTINUE
8843 DO 301 J=1,LP1
8844 DO 301 I=1,LP1
8845 CO2800(I,J) = T21(I,J,1)
8846 !NOV89
8847 IF (IQ.EQ.5) GO TO 301
8848 !NOV89
8849 CO2801(I,J) = T21(I,J,2)
8850 CO2802(I,J) = T21(I,J,3)
8851 301 CONTINUE
8852 !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
8853 ! ARE:
8854 ! IQ=1 560-800 (CONSOL.=490-850)
8855 ! IQ=2 560-670 (CONSOL.=490-670)
8856 ! IQ=3 670-800 (CONSOL.=670-850)
8857 ! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850)
8858 !NOV89
8859 ! IQ=5 2270-2380 (CONSOL.=2270-2380)
8860 !NOV89
8861 ! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
8862 ! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
8863 ! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
8864 IF (IQ.EQ.1) THEN
8865 C1=1.5
8866 C2x=0.5
8867 ENDIF
8868 IF (IQ.EQ.2) THEN
8869 C1=18./11.
8870 C2x=7./11.
8871 ENDIF
8872 IF (IQ.EQ.3) THEN
8873 C1=18./13.
8874 C2x=5./13.
8875 ENDIF
8876 IF (IQ.EQ.4) THEN
8877 C1=1.8
8878 C2x=0.8
8879 ENDIF
8880 !NOV89
8881 IF (IQ.EQ.5) THEN
8882 C1=1.0
8883 C2x=0.0
8884 ENDIF
8885 !NOV89
8886 DO 1021 I=1,LP1
8887 DO 1021 J=1,LP1
8888 CO2PO(J,I)=C1*CO2PO(J,I)-C2x
8889 CO2800(J,I)=C1*CO2800(J,I)-C2x
8890 !NOV89
8891 IF (IQ.EQ.5) GO TO 1021
8892 !NOV89
8893 CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
8894 CO2801(J,I)=C1*CO2801(J,I)-C2x
8895 CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
8896 CO2802(J,I)=C1*CO2802(J,I)-C2x
8897 1021 CONTINUE
8898 !NOV89
8899 IF (IQ.GE.1.AND.IQ.LE.4) THEN
8900 !NOV89
8901 DO 1 J=1,LP1
8902 DO 1 I=1,LP1
8903 DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
8904 DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
8905 D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
8906 D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
8907 1 CONTINUE
8908 !NOV89
8909 ENDIF
8910 !NOV89
8911 !O222 *********************************************************
8912 !CC REWIND 66
8913 ! SAVE CDTM51,CO2M51,C2DM51,CDTM58,CO2M58,C2DM58..ON TEMPO FILE
8914 !CC WRITE (66) (DCDT10(I,I+1),I=1,L)
8915 !CC WRITE (66) (CO2PO(I,I+1),I=1,L)
8916 !CC WRITE (66) (D2CT10(I,I+1),I=1,L)
8917 !CC WRITE (66) (DCDT8(I,I+1),I=1,L)
8918 !CC WRITE (66) (CO2800(I,I+1),I=1,L)
8919 !CC WRITE (66) (D2CT8(I,I+1),I=1,L)
8920 !CC REWIND 66
8921 !O222 *********************************************************
8922 DO 400 I=1,L
8923 T66(I,2) = CO2PO(I,I+1)
8924 T66(I,5) = CO2800(I,I+1)
8925 !NOV89
8926 IF (IQ.EQ.5) GO TO 400
8927 !NOV89
8928 T66(I,1) = DCDT10(I,I+1)
8929 T66(I,3) = D2CT10(I,I+1)
8930 T66(I,4) = DCDT8(I,I+1)
8931 T66(I,6) = D2CT8(I,I+1)
8932 400 CONTINUE
8933 RETURN
8934 END SUBROUTINE CO2IN1
8935 !CCC PROGRAM PTZ - COURTESY OF DAN SCHWARZKOPF,GFDL DEC 1987....
8936 SUBROUTINE CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
8937 SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLP2)
8938 !
8939 ! ** THIS PROGRAM CALCULATES TEMPERATURES ,H2O MIXING RATIOS
8940 ! ** AND O3 MIXING RATIOS BY USING AN ANALYTICAL
8941 ! ** FUNCTION WHICH APPROXIMATES
8942 ! ** THE US STANDARD (1976). THIS IS
8943 ! ** CALCULATED IN FUNCTION 'ANTEMP', WHICH IS CALLED BY THE
8944 ! ** MAIN PROGRAM. THE FORM OF THE ANALYTICAL FUNCTION WAS
8945 ! ** SUGGESTED TO ME IN 1971 BY RICHARD S. LINDZEN.
8946 ! ******************************************************************
8947 ! CODE TO SAVE STEMP,GTEMP ON DATA SET,BRACKETED BY CO222 **
8948 ! ....K. CAMPANA MARCH 88,OCTOBER 88
8949 DIMENSION SGTEMP(NLP,2),T41(NLP2,2),T42(NLP), &
8950 T43(NLP2,2),T44(NLP)
8951 DIMENSION SGLVNU(NLP),SIGLNU(NL)
8952 DIMENSION SFULL(NLP),SHALF(NL)
8953 ! ******************************************************************
8954 !
8955 !*****THIS VERSION IS ONLY USABLE FOR 1976 US STD ATM AND OBTAINS
8956 ! QUANTITIES FOR CO2 INTERPOLATION AND INSERTION INTO OPERA-
8957 ! TIONAL RADIATION CODES
8958 !
8959 CHARACTER*20 PROFIL
8960 DIMENSION PRESS(NLP),TEMP(NLP),ALT(NLP),WMIX(NLP),O3MIX(NLP)
8961 DIMENSION WMXINT(NLP,4),WMXOUT(NLP2),OMXINT(NLP,4),OMXOUT(NLP2)
8962 DIMENSION PD(NLP2),GTEMP(NLP)
8963 DIMENSION PRS(NLP),TEMPS(NLP),PRSINT(NLP),TMPINT(NLP,4),A(NLP,4)
8964 DIMENSION PROUT(NLP2),TMPOUT(NLP2),TMPFLX(NLP2),TMPMID(NLP2)
8965 !
8966 !
8967 DATA PROFIL/ &
8968 'US STANDARD 1976'/
8969 DATA PSMAX/1013.250/
8970 !
8971 ! ** NTYPE IS AN INTEGER VARIABLE WHICH HAS THE FOLLOWING
8972 ! ** VALUES: 0 =SIGMA LEVELS ARE USED; 1= SKYHI L40 LEVELS
8973 ! ** ARE USED; 2 = SKYHI L80 LEVELS ARE USED. DEFAULT: 0
8974 !
8975 NTYPE=0
8976 !O222 READ (*,*) NTYPE
8977 5 NLEV=NL
8978 DELZAP=0.5
8979 R=8.31432
8980 G0=9.80665
8981 ZMASS=28.9644
8982 AA=6356.766
8983 ALT(1)=0.0
8984 TEMP(1)=ANTEMP(6,0.0)
8985 !*******DETERMINE THE PRESSURES (PRESS)
8986 PSTAR=PSMAX
8987 !
8988 !*** LTOP COMPUTATION MOVED FROM MODEL INITIALIZATION
8989 !
8990 LTOP(1)=0
8991 LTOP(2)=0
8992 LTOP(3)=0
8993 DO 30 N=1,NL
8994 PCLD=(PSTAR-PPTOP*10.)*SHALF(N)+PPTOP*10.
8995 IF(PCLD.GE.642.)LTOP(1)=N
8996 IF(PCLD.GE.350.)LTOP(2)=N
8997 IF(PCLD.GE.150.)LTOP(3)=N
8998 ! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
8999 30 CONTINUE
9000 !
9001 !O222 IF (NTYPE.EQ.1) CALL SKYP(PSTAR,PD,GTEMP)
9002 !O222 IF (NTYPE.EQ.2) CALL SKY80P(PSTAR,PD,GTEMP)
9003 !O222 IF (NTYPE.EQ.0) CALL SIGP(PSTAR,PD,GTEMP)
9004 !CC---- CALL SIGP(PSTAR,PD,GTEMP)
9005 NLM=NL-1
9006 CALL SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9007 SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLM,NLP2)
9008 PD(NLP2)=PSTAR
9009 DO 40 N=1,NLP
9010 PRSINT(N)=PD(NLP2+1-N)
9011 40 CONTINUE
9012 ! *** CALCULATE TEMPS FOR SEVERAL PRESSURES TO DO QUADRATURE
9013 DO 504 NQ=1,4
9014 DO 505 N=2,NLP
9015 505 PRESS(N)=PRSINT(N)+0.25*(NQ-1)*(PRSINT(N-1)-PRSINT(N))
9016 PRESS(1)=PRSINT(1)
9017 !*********************
9018 DO 100 N=1,NLEV
9019 !
9020 ! ** ESTABLISH COMPUTATATIONAL LEVELS BETWEEN USER LEVELS AT
9021 ! ** INTERVALS OF APPROXIMATELY 'DELZAP' KM.
9022 !
9023 DLOGP=7.0*ALOG(PRESS(N)/PRESS(N+1))
9024 NINT=DLOGP/DELZAP
9025 NINT=NINT+1
9026 ZNINT=NINT
9027 ! G=G0
9028 DZ=R*DLOGP/(7.0*ZMASS*G0*ZNINT)
9029 HT=ALT(N)
9030 !
9031 ! ** CALCULATE HEIGHT AT NEXT USER LEVEL BY MEANS OF
9032 ! ** RUNGE-KUTTA INTEGRATION.
9033 !
9034 DO 200 M=1,NINT
9035 RK1=ANTEMP(6,HT)*DZ
9036 RK2=ANTEMP(6,HT+0.5*RK1)*DZ
9037 RK3=ANTEMP(6,HT+0.5*RK2)*DZ
9038 RK4=ANTEMP(6,HT+RK3)*DZ
9039 !mp write(6,*) 'RK values,DZ ', RK1,RK2,RK3,RK4,DZ
9040 HT=HT+0.16666667*(RK1+RK2+RK2+RK3+RK3+RK4)
9041 200 CONTINUE
9042 ALT(N+1)=HT
9043 TEMP(N+1)=ANTEMP(6,HT)
9044 100 CONTINUE
9045 DO 506 N=1,NLP
9046 TMPINT(N,NQ)=TEMP(N)
9047 A(N,NQ)=ALT(N)
9048 506 CONTINUE
9049 504 CONTINUE
9050 !O222 *****************************************************
9051 !***OUTPUT TEMPERATURES
9052 !O222 *****************************************************
9053 DO 901 N=1,NLP
9054 SGTEMP(N,1) = TMPINT(NLP2-N,1)
9055 901 CONTINUE
9056 !O222 *****************************************************
9057 !***OUTPUT GTEMP
9058 !O222 *****************************************************
9059 DO 902 N=1,NLP
9060 SGTEMP(N,2) = GTEMP(N)
9061 902 CONTINUE
9062 !O222 *****************************************************
9063 RETURN
9064 END SUBROUTINE CO2PTZ
9065 FUNCTION PATH(A,B,C,E)
9066 !....
9067 ! DOUBLE PRECISION XA,CA
9068 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
9069 PEXP=1./SEXP
9070 PATH=((A-B)**PEXP*(A+B+C))/(E*(A+B+C)+(A-B)**(PEXP-1.))
9071 RETURN
9072 END FUNCTION PATH
9073 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9074 SUBROUTINE QINTRP(XM,X0,XP,FM,F0,FP,X,F)
9075 !....
9076 ! DOUBLE PRECISION FM,F0,FP,F,D1,D2,B,A,DEL
9077 D1=(FP-F0)/(XP-X0)
9078 D2=(FM-F0)/(XM-X0)
9079 B=(D1-D2)/(XP-XM)
9080 A=D1-B*(XP-X0)
9081 DEL=(X-X0)
9082 F=F0+DEL*(A+DEL*B)
9083 RETURN
9084 END SUBROUTINE QINTRP
9085 SUBROUTINE QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
9086 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
9087 DIMENSION P(NLP1V),PD(NLP2V),TRNS(NLP1V,NLP1V)
9088 DIMENSION WT(101)
9089 N2=2*N
9090 N2P=2*N+1
9091 ! *****WEIGHTS ARE CALCULATED
9092 WT(1)=1.
9093 DO 21 I=1,N
9094 WT(2*I)=4.
9095 WT(2*I+1)=1.
9096 21 CONTINUE
9097 IF (N.EQ.1) GO TO 25
9098 DO 22 I=2,N
9099 WT(2*I-1)=2.
9100 22 CONTINUE
9101 25 CONTINUE
9102 TRNSNB=0.
9103 DP=(PD(IA)-PD(IA-1))/N2
9104 PFIX=P(JA)
9105 DO 1 KK=1,N2P
9106 PVARY=PD(IA-1)+(KK-1)*DP
9107 IF (PVARY.GE.PFIX) P2=PVARY
9108 IF (PVARY.GE.PFIX) P1=PFIX
9109 IF (PVARY.LT.PFIX) P1=PVARY
9110 IF (PVARY.LT.PFIX) P2=PFIX
9111 CALL SINTR2
9112 TRNSNB=TRNSNB+TRNSLO*WT(KK)
9113 1 CONTINUE
9114 TRNS(IA,JA)=TRNSNB*DP/(3.*(PD(IA)-PD(IA-1)))
9115 RETURN
9116 END SUBROUTINE QUADSR
9117 !---------------------------------------------------------------------
9118 SUBROUTINE SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9119 SIGLV,SIGLY,PPTOP,LREAD,KD,KP,KM,KP2)
9120 DIMENSION Q(KD),QMH(KP),PD(KP2),PLM(KP),GTEMP(KP),PDT(KP2)
9121 DIMENSION SIGLY(KD),SIGLV(KP)
9122 DIMENSION CI(KP),SGLVNU(KP),DEL(KD),SIGLNU(KD),CL(KD),RPI(KM)
9123 DIMENSION IDATE(4)
9124 DIMENSION T41(KP2,2),T42(KP), &
9125 T43(KP2,2),T44(KP)
9126 ! integer :: retval
9127 ! character(50) :: prsmid='prsmid'
9128 !CC 18 LEVEL SIGMAS FOR NMC MRF(NEW) MODEL
9129 !CC DATA Q/.021,.074,.124,.175,.225,.275,.325,.375,.425,.497, &
9130 !CC .594,.688,.777,.856,.920,.960,.981,.995/
9131 ! FOR SIGMA MODELS,Q=SIGMA,QMH=0.5(Q(I)+Q(I+1),
9132 ! PD=Q*PSS,PLM=QMH*PSS.PSS=SURFACE PRESSURE(SPEC.)
9133 !
9134 !..... GET NMC SIGMA STRUCTURE
9135 !CC IF (LREAD.GT.0) GO TO 914
9136 !--- PPTOP IS MODEL TOP PRESSURE IN CB....
9137 ! SIGMA DATA IS BOTTOM OF ATMOSPHERE TO T.O.A.....
9138 !cccc PPTOP=5.0
9139 ! READ(11,PPTOP,END=12321)
9140 12321 CONTINUE
9141 ! WRITE(6,88221)PPTOP,KD,KP
9142 !88221 FORMAT(' ENTER SIGP PPTOP=',E12.5,' KD=',I2,' KP=',I2)
9143 ! open(unit=23,file='fort.23',form='unformatted' &
9144 ! , access='sequential')
9145 ! REWIND 23
9146 ! READ(23)SIGLY
9147 ! DO KKK=1,KD
9148 ! SIGLY(KKK)=1.-(FLOAT(KKK)-0.5)/KD
9149 ! END DO
9150 ! WRITE(6,88222)
9151 !88222 FORMAT(' READ AETA')
9152 ! DO 37821 LLL=1,KD
9153 ! WRITE(6,37820)LLL,SIGLY(LLL)
9154 !37820 FORMAT(' L=',I2,' AETA=',E12.5)
9155 !37821 CONTINUE
9156 ! READ(23)SIGLV
9157 ! DO KKK=1,KP
9158 ! SIGLV(KKK)=1.-(FLOAT(KKK-1))/KD
9159 ! END DO
9160 ! WRITE(6,88223)
9161 !88223 FORMAT(' READ ETA')
9162 ! PRINT 704,(SIGLY(K),K=1,KD)
9163 ! PRINT 704,(SIGLV(K),K=1,KP)
9164 ! DO 37823 LLL=1,KP
9165 ! WRITE(6,37822)LLL,SIGLV(LLL)
9166 !37822 FORMAT(' L=',I2,' ETA=',E12.5)
9167 !37823 CONTINUE
9168 701 FORMAT(F6.2)
9169 702 FORMAT(7F10.6)
9170 IF (PPTOP.LE.0.) GO TO 708
9171 PSFC=100.
9172 !--- IF PTOP NOT EQUAL TO ZERO ADJUST SIGMA SO AS TO GET PROPER STD ATM
9173 ! VERTICAL LOCATION
9174 DO 706 K=1,KD
9175 SIGLY(K) = (SIGLY(K)*(PSFC-PPTOP)+PPTOP)/PSFC
9176 706 CONTINUE
9177 DO 707 K=1,KP
9178 SIGLV(K) = (SIGLV(K)*(PSFC-PPTOP)+PPTOP)/PSFC
9179 707 CONTINUE
9180 708 CONTINUE
9181 ! PRINT 703,PPTOP
9182 ! PRINT 704,(SIGLY(K),K=1,KD)
9183 ! PRINT 704,(SIGLV(K),K=1,KP)
9184 703 FORMAT(1H ,'PTOP =',F6.2)
9185 704 FORMAT(1H ,7F10.6)
9186 DO 913 K=1,KP
9187 SGLVNU(K) = SIGLV(K)
9188 IF (K.LE.KD) SIGLNU(K) = SIGLY(K)
9189 913 CONTINUE
9190 DO 77 K=1,KD
9191 Q(K) = SIGLNU(KD+1-K)
9192 77 CONTINUE
9193 PSS= 1013250.
9194 QMH(1)=0.
9195 QMH(KP)=1.
9196 DO 1 K=2,KD
9197 QMH(K)=0.5*(Q(K-1)+Q(K))
9198 1 CONTINUE
9199 PD(1)=0.
9200 PD(KP2)=PSS
9201 DO 2 K=2,KP
9202 PD(K)=Q(K-1)*PSS
9203 2 CONTINUE
9204 ! call int_get_fresh_handle(retval)
9205 ! close(retval)
9206 ! write(0,*)' before open in CO2O3'
9207 ! open(unit=retval,file=prsmid,form='UNFORMATTED',iostat=ier)
9208 ! write(0,*)' after open1'
9209 ! do k=1,62
9210 ! write(retval)pd(k)
9211 ! enddo
9212 ! close(retval)
9213 PLM(1)=0.
9214 DO 3 K=1,KM
9215 PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
9216 3 CONTINUE
9217 PLM(KP)=PSS
9218 DO 4 K=1,KD
9219 GTEMP(K)=PD(K+1)**0.2*(1.+PD(K+1)/30000.)**0.8/1013250.
9220 4 CONTINUE
9221 GTEMP(KP)=0.
9222 !+++ WRITE (6,100) (GTEMP(K),K=1,KD)
9223 !+++ WRITE (6,100) (PD(K),K=1,KP2)
9224 !+++ WRITE (6,100) (PLM(K),K=1,KP)
9225 !***TAPES 41,42 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM (PS=1013MB)
9226 ! THE FOLLOWING PUTS P-DATA INTO MB
9227 DO 11 I=1,KP
9228 PD(I)=PD(I)*1.0E-3
9229 PLM(I)=PLM(I)*1.0E-3
9230 11 CONTINUE
9231 PD(KP2)=PD(KP2)*1.0E-3
9232 !CC WRITE (41,101) (PD(K),K=1,KP2)
9233 !CC WRITE (41,101) (PLM(K),K=1,KP)
9234 !CC WRITE (42,101) (PLM(K),K=1,KP)
9235 DO 300 K=1,KP2
9236 T41(K,1) = PD(K)
9237 300 CONTINUE
9238 DO 301 K=1,KP
9239 T41(K,2) = PLM(K)
9240 T42(K) = PLM(K)
9241 301 CONTINUE
9242 !***STORE AS PDT,SO THAT RIGHT PD IS RETURNED TO PTZ
9243 DO 12 I=1,KP2
9244 PDT(I)=PD(I)
9245 12 CONTINUE
9246 !***SECOND PASS: PSS=810MB,GTEMP NOT COMPUTED
9247 PSS=0.8*1013250.
9248 QMH(1)=0.
9249 QMH(KP)=1.
9250 DO 201 K=2,KD
9251 QMH(K)=0.5*(Q(K-1)+Q(K))
9252 201 CONTINUE
9253 PD(1)=0.
9254 PD(KP2)=PSS
9255 DO 202 K=2,KP
9256 PD(K)=Q(K-1)*PSS
9257 202 CONTINUE
9258 PLM(1)=0.
9259 DO 203 K=1,KM
9260 PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
9261 203 CONTINUE
9262 PLM(KP)=PSS
9263 !+++ WRITE (6,100) (PD(K),K=1,KP2)
9264 !+++ WRITE (6,100) (PLM(K),K=1,KP)
9265 !***TAPES 43,44 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM(PS=810 MB)
9266 ! THE FOLLOWING PUTS P-DATA INTO MB
9267 DO 211 I=1,KP
9268 PD(I)=PD(I)*1.0E-3
9269 PLM(I)=PLM(I)*1.0E-3
9270 211 CONTINUE
9271 PD(KP2)=PD(KP2)*1.0E-3
9272 !CC WRITE (43,101) (PD(K),K=1,KP2)
9273 !CC WRITE (43,101) (PLM(K),K=1,KP)
9274 !CC WRITE (44,101) (PLM(K),K=1,KP)
9275 DO 302 K=1,KP2
9276 T43(K,1) = PD(K)
9277 302 CONTINUE
9278 DO 303 K=1,KP
9279 T43(K,2) = PLM(K)
9280 T44(K) = PLM(K)
9281 303 CONTINUE
9282 !***RESTORE PD
9283 DO 212 I=1,KP2
9284 PD(I)=PDT(I)
9285 212 CONTINUE
9286 100 FORMAT (1X,5E20.13)
9287 101 FORMAT (5E16.9)
9288 RETURN
9289 END SUBROUTINE SIGP
9290 !---------------------------------------------------------------------
9291 SUBROUTINE SINTR2
9292 !....
9293 ! IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9294 ! REAL P1,P2,PA,TRNSLO,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
9295 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
9296 ! COMMON/PRESS/ PA(109)
9297 ! COMMON/TRAN/ TRANSA(109,109)
9298 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
9299 DO 70 L=1,109
9300 IP1=L
9301 IF (P2-PA(L)) 65,65,70
9302 70 CONTINUE
9303 65 I=IP1-1
9304 IF (IP1.EQ.1) IP1=2
9305 IF (I.EQ.0) I=1
9306 DO 80 L=1,109
9307 JP1=L
9308 IF (P1-PA(L)) 75,75,80
9309 80 CONTINUE
9310 75 J=JP1-1
9311 IF (JP1.EQ.1) JP1=2
9312 IF (J.EQ.0) J=1
9313 JJJ=J
9314 III=I
9315 J=JJJ
9316 JP1=J+1
9317 I=III
9318 IP1=I+1
9319 ! DETERMINE ETAP,THE VALUE OF ETA TO USE BY LINEAR INTERPOLATION
9320 ! FOR PETA(=0.5*(P1+P2))
9321 PETA=P2
9322 DO 90 L=1,109
9323 IETAP1=L
9324 IF (PETA-PA(L)) 85,85,90
9325 90 CONTINUE
9326 85 IETA=IETAP1-1
9327 IF (IETAP1.EQ.1) IETAP1=2
9328 IF (IETA.EQ.0) IETA=1
9329 ETAP=ETA(IETA)+(PETA-PA(IETA))*(ETA(IETAP1)-ETA(IETA))/ &
9330 (PA(IETAP1)-PA(IETA))
9331 SEXP=SEXPV(IETA)+(PETA-PA(IETA))*(SEXPV(IETAP1)- &
9332 SEXPV(IETA))/ (PA(IETAP1)-PA(IETA))
9333 PIPMPI=PA(IP1)-PA(I)
9334 UP2P1=(PATH(P2,P1,CORE,ETAP))**UEXP
9335 IF (I-J) 126,126,127
9336 126 CONTINUE
9337 TRIP=(CA(IP1)*DLOG(1.0D0+XA(IP1)*UP2P1))**(SEXP/UEXP)
9338 TRI=(CA(I)*DLOG(1.0D0+XA(I)*UP2P1))**(SEXP/UEXP)
9339 TRNSLO=1.0D0-((PA(IP1)-P2)*TRI+(P2-PA(I))*TRIP)/PIPMPI
9340 GO TO 128
9341 127 TIJ=TRANSA(I,J)
9342 TIPJ=TRANSA(I+1,J)
9343 TIJP=TRANSA(I,J+1)
9344 TIPJP=TRANSA(I+1,J+1)
9345 UIJ=(PATH(PA(I),PA(J),CORE,ETAP))**UEXP
9346 UIPJ=(PATH(PA(I+1),PA(J),CORE,ETAP))**UEXP
9347 UIJP=(PATH(PA(I),PA(J+1),CORE,ETAP))**UEXP
9348 UIPJP=(PATH(PA(I+1),PA(J+1),CORE,ETAP))**UEXP
9349 PRODI=CA(I)*XA(I)
9350 PRODIP=CA(I+1)*XA(I+1)
9351 PROD=((PA(I+1)-P2)*PRODI+(P2-PA(I))*PRODIP)/PIPMPI
9352 XINT=((PA(I+1)-P2)*XA(I)+(P2-PA(I))*XA(I+1))/PIPMPI
9353 CINT=PROD/XINT
9354 AIJ=(CINT*DLOG(1.0D0+XINT*UIJ))**(SEXP/UEXP)
9355 AIJP=(CINT*DLOG(1.0D0+XINT*UIJP))**(SEXP/UEXP)
9356 AIPJ=(CINT*DLOG(1.0D0+XINT*UIPJ))**(SEXP/UEXP)
9357 AIPJP=(CINT*DLOG(1.0D0+XINT*UIPJP))**(SEXP/UEXP)
9358 EIJ=TIJ+AIJ
9359 EIPJ=TIPJ+AIPJ
9360 EIJP=TIJP+AIJP
9361 EIPJP=TIPJP+AIPJP
9362 DTDJ=(EIJP-EIJ)/(PA(J+1)-PA(J))
9363 DTDPJ=(EIPJP-EIPJ)/(PA(J+1)-PA(J))
9364 EPIP1=EIJ+DTDJ*(P1-PA(J))
9365 EPIPP1=EIPJ+DTDPJ*(P1-PA(J))
9366 EPP2P1=((PA(I+1)-P2)*EPIP1+(P2-PA(I))*EPIPP1)/PIPMPI
9367 TRNSLO=EPP2P1-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
9368 IF (I.GE.108.OR.J.GE.108) GO TO 350
9369 IF (I-J-2) 350,350,355
9370 355 CONTINUE
9371 TIP2J=TRANSA(I+2,J)
9372 TIP2JP=TRANSA(I+2,J+1)
9373 TI2J2=TRANSA(I+2,J+2)
9374 TIJP2=TRANSA(I,J+2)
9375 TIPJP2=TRANSA(I+1,J+2)
9376 UIP2J=(PATH(PA(I+2),PA(J),CORE,ETAP))**UEXP
9377 UIJP2=(PATH(PA(I),PA(J+2),CORE,ETAP))**UEXP
9378 UIPJP2=(PATH(PA(I+1),PA(J+2),CORE,ETAP))**UEXP
9379 UI2J2=(PATH(PA(I+2),PA(J+2),CORE,ETAP))**UEXP
9380 UIP2JP=(PATH(PA(I+2),PA(J+1),CORE,ETAP))**UEXP
9381 AIJP2=(CINT*DLOG(1.0D0+XINT*UIJP2))**(SEXP/UEXP)
9382 AIPJP2=(CINT*DLOG(1.0D0+XINT*UIPJP2))**(SEXP/UEXP)
9383 AIP2J=(CINT*DLOG(1.0D0+XINT*UIP2J))**(SEXP/UEXP)
9384 AIP2JP=(CINT*DLOG(1.0D0+XINT*UIP2JP))**(SEXP/UEXP)
9385 AI2J2=(CINT*DLOG(1.0D0+XINT*UI2J2))**(SEXP/UEXP)
9386 EIP2J=TIP2J+AIP2J
9387 EIP2JP=TIP2JP+AIP2JP
9388 EIJP2=TIJP2+AIJP2
9389 EIPJP2=TIPJP2+AIPJP2
9390 EI2J2=TI2J2+AI2J2
9391 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIJ,EIJP,EIJP2,P1,EI)
9392 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIPJ,EIPJP,EIPJP2,P1,EP)
9393 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIP2J,EIP2JP,EI2J2,P1,EP2)
9394 CALL QINTRP(PA(I),PA(I+1),PA(I+2),EI,EP,EP2,P2,EPSIL)
9395 TRNSLO=EPSIL-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
9396 350 CONTINUE
9397 128 CONTINUE
9398 205 CONTINUE
9399 RETURN
9400 END SUBROUTINE SINTR2
9401 SUBROUTINE CO2O3(SFULL,SHALF,PPTOP,L,LP1,LP2)
9402 !CCC PROGRAM CO2O3 = CONSOLIDATION OF A NUMBER OF DAN SCHWARZKOPF,GFDL
9403 ! CODES TO PRODUCE A FILE OF CO2 HGT DATA
9404 ! FOR ANY VERTICAL COORDINATE (READ BY SUBROUTINE
9405 ! CONRAD IN THE GFDL RADIATION CODES)-K.A.C. JUN89.
9406 !NOV89--UPDATED (NOV 89) FOR LATEST GFDL LW RADIATION.....K.A.C.
9407 LOGICAL :: opened
9408 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
9409 CHARACTER*80 errmess
9410 ! integer :: retval,kk,ka,kb
9411 ! character(50) :: co2='co2'
9412 INTEGER etarad_unit61, etarad_unit62, etarad_unit63,IERROR
9413 DIMENSION SGTEMP(LP1,2),CO2D1D(L,6),CO2D2D(LP1,LP1,6)
9414 !NOV89
9415 DIMENSION CO2IQ2(LP1,LP1,6),CO2IQ3(LP1,LP1,6),CO2IQ5(LP1,LP1,6)
9416 !NOV89
9417 DIMENSION T41(LP2,2),T42(LP1), &
9418 T43(LP2,2),T44(LP1)
9419 DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3)
9420 DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3)
9421 DIMENSION SGLVNU(LP1),SIGLNU(L)
9422 DIMENSION SFULL(LP1),SHALF(L)
9423 ! DIMENSION STEMP(LP1),GTEMP(LP1)
9424 ! DIMENSION CDTM51(L),CO2M51(L),C2DM51(L)
9425 ! DIMENSION CDTM58(L),CO2M58(L),C2DM58(L)
9426 ! DIMENSION CDT51(LP1,LP1),CO251(LP1,LP1),C2D51(LP1,LP1)
9427 ! DIMENSION CDT58(LP1,LP1),CO258(LP1,LP1),C2D58(LP1,LP1)
9428 !NOV89
9429 ! DIMENSION CDT31(LP1),CO231(LP1),C2D31(LP1)
9430 ! DIMENSION CDT38(LP1),CO238(LP1),C2D38(LP1)
9431 ! DIMENSION CDT71(LP1),CO271(LP1),C2D71(LP1)
9432 ! DIMENSION CDT78(LP1),CO278(LP1),C2D78(LP1)
9433 ! DIMENSION CO211(LP1),CO218(LP1)
9434 ! EQUIVALENCE (CDT31(1),CO2IQ2(1,1,1)),(CO231(1),CO2IQ2(1,1,2))
9435 ! EQUIVALENCE (C2D31(1),CO2IQ2(1,1,3)),(CDT38(1),CO2IQ2(1,1,4))
9436 ! EQUIVALENCE (CO238(1),CO2IQ2(1,1,5)),(C2D38(1),CO2IQ2(1,1,6))
9437 ! EQUIVALENCE (CDT71(1),CO2IQ3(1,1,1)),(CO271(1),CO2IQ3(1,1,2))
9438 ! EQUIVALENCE (C2D71(1),CO2IQ3(1,1,3)),(CDT78(1),CO2IQ3(1,1,4))
9439 ! EQUIVALENCE (CO278(1),CO2IQ3(1,1,5)),(C2D78(1),CO2IQ3(1,1,6))
9440 ! EQUIVALENCE (CO211(1),CO2IQ5(1,1,2)),(CO218(1),CO2IQ5(1,1,5))
9441 !NOV89
9442 ! EQUIVALENCE (STEMP(1),SGTEMP(1,1)),(GTEMP(1),SGTEMP(1,2))
9443 ! EQUIVALENCE (CDTM51(1),CO2D1D(1,1)),(CO2M51(1),CO2D1D(1,2))
9444 ! EQUIVALENCE (C2DM51(1),CO2D1D(1,3)),(CDTM58(1),CO2D1D(1,4))
9445 ! EQUIVALENCE (CO2M58(1),CO2D1D(1,5)),(C2DM58(1),CO2D1D(1,6))
9446 ! EQUIVALENCE (CDT51(1,1),CO2D2D(1,1,1)),(CO251(1,1),CO2D2D(1,1,2))
9447 ! EQUIVALENCE (C2D51(1,1),CO2D2D(1,1,3)),(CDT58(1,1),CO2D2D(1,1,4))
9448 ! EQUIVALENCE (CO258(1,1),CO2D2D(1,1,5)),(C2D58(1,1),CO2D2D(1,1,6))
9450 ! Deallocate before reading. This is required for nested domain init.
9451 !
9452 IF(ALLOCATED (CO251))DEALLOCATE(CO251)
9453 IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
9454 IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
9455 IF(ALLOCATED (CO258))DEALLOCATE(CO258)
9456 IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
9457 IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
9458 IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
9459 IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
9460 IF(ALLOCATED (CO231))DEALLOCATE(CO231)
9461 IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
9462 IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
9463 IF(ALLOCATED (CO238))DEALLOCATE(CO238)
9464 IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
9465 IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
9466 IF(ALLOCATED (CO271))DEALLOCATE(CO271)
9467 IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
9468 IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
9469 IF(ALLOCATED (CO278))DEALLOCATE(CO278)
9470 IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
9471 IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
9472 IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
9473 IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
9474 IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
9475 IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
9476 IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
9477 IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
9479 ALLOCATE(CO251(LP1,LP1))
9480 ALLOCATE(CDT51(LP1,LP1))
9481 ALLOCATE(C2D51(LP1,LP1))
9482 ALLOCATE(CO258(LP1,LP1))
9483 ALLOCATE(CDT58(LP1,LP1))
9484 ALLOCATE(C2D58(LP1,LP1))
9485 ALLOCATE(STEMP(LP1))
9486 ALLOCATE(GTEMP(LP1))
9487 ALLOCATE(CO231(LP1))
9488 ALLOCATE(CDT31(LP1))
9489 ALLOCATE(C2D31(LP1))
9490 ALLOCATE(CO238(LP1))
9491 ALLOCATE(CDT38(LP1))
9492 ALLOCATE(C2D38(LP1))
9493 ALLOCATE(CO271(LP1))
9494 ALLOCATE(CDT71(LP1))
9495 ALLOCATE(C2D71(LP1))
9496 ALLOCATE(CO278(LP1))
9497 ALLOCATE(CDT78(LP1))
9498 ALLOCATE(C2D78(LP1))
9499 ALLOCATE(CO2M51(L))
9500 ALLOCATE(CDTM51(L))
9501 ALLOCATE(C2DM51(L))
9502 ALLOCATE(CO2M58(L))
9503 ALLOCATE(CDTM58(L))
9504 ALLOCATE(C2DM58(L))
9505 IF ( wrf_dm_on_monitor() ) THEN
9506 DO i = 61,99
9507 INQUIRE ( i , OPENED = opened )
9508 IF ( .NOT. opened ) THEN
9509 etarad_unit61 = i
9510 GOTO 2061
9511 ENDIF
9512 ENDDO
9513 etarad_unit61 = -1
9514 2061 CONTINUE
9515 DO i = 62,99
9516 INQUIRE ( i , OPENED = opened )
9517 IF ( .NOT. opened ) THEN
9518 etarad_unit62 = i
9519 GOTO 2062
9520 ENDIF
9521 ENDDO
9522 etarad_unit62 = -1
9523 2062 CONTINUE
9524 DO i = 63,99
9525 INQUIRE ( i , OPENED = opened )
9526 IF ( .NOT. opened ) THEN
9527 etarad_unit63 = i
9528 GOTO 2063
9529 ENDIF
9530 ENDDO
9531 etarad_unit63 = -1
9532 2063 CONTINUE
9533 ENDIF
9534 CALL wrf_dm_bcast_bytes ( etarad_unit61 , IWORDSIZE )
9535 IF ( etarad_unit61 < 0 ) THEN
9536 CALL wrf_error_fatal ( 'module_ra_hwrf: co2o3: Can not find unused fortran unit to read in lookup table.' )
9537 ENDIF
9538 CALL wrf_dm_bcast_bytes ( etarad_unit62 , IWORDSIZE )
9539 IF ( etarad_unit62 < 0 ) THEN
9540 CALL wrf_error_fatal ( 'module_ra_hwrf: co2o3: Can not find unused fortran unit to read in lookup table.' )
9541 ENDIF
9542 CALL wrf_dm_bcast_bytes ( etarad_unit63 , IWORDSIZE )
9543 IF ( etarad_unit63 < 0 ) THEN
9544 CALL wrf_error_fatal ( 'module_ra_hwrf: co2o3: Can not find unused fortran unit to read in lookup table.' )
9545 ENDIF
9546 IF ( wrf_dm_on_monitor() ) THEN
9547 OPEN(etarad_unit61,FILE='tr49t85', &
9548 FORM='FORMATTED',STATUS='OLD',ERR=9061,IOSTAT=IERROR)
9549 ENDIF
9550 IF ( wrf_dm_on_monitor() ) THEN
9551 OPEN(etarad_unit62,FILE='tr49t67', &
9552 FORM='FORMATTED',STATUS='OLD',ERR=9062,IOSTAT=IERROR)
9553 ENDIF
9554 IF ( wrf_dm_on_monitor() ) THEN
9555 OPEN(etarad_unit63,FILE='tr67t85', &
9556 FORM='FORMATTED',STATUS='OLD',ERR=9063,IOSTAT=IERROR)
9557 ENDIF
9559 !===> GET SGTEMP AND OUTPUT WHICH USED TO BE ON UNITS 41,42,43,44....
9560 LREAD = 0
9561 ! DO KKK=1,L
9562 !JD READ(23)SIGLNU(KKK)
9563 ! SIGLNU(KKK)=1.-FLOAT(KKK)/LP1
9564 ! END DO
9565 CALL CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9566 SFULL,SHALF,PPTOP,LREAD,L,LP1,LP2)
9567 ! call int_get_fresh_handle(retval)
9568 ! close(retval)
9569 ! open(unit=retval,file=co2,form='UNFORMATTED',iostat=ier)
9570 ! do kk=1,2
9571 ! write(retval)(sgtemp(k,kk),k=1,61)
9572 ! enddo
9573 DO K=1,LP1
9574 STEMP(K)=SGTEMP(K,1)
9575 GTEMP(K)=SGTEMP(K,2)
9576 ENDDO
9577 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9578 ! IR=1,IQ=1 IS FOR COMMON /CO2BD3/ IN RADIATION CODE...
9579 ! FOR THE CONSOLIDATED 490-850 CM-1 BAND...
9580 !NOV89
9581 ! ICO2TP=61
9582 ICO2TP=etarad_unit61
9583 !NOV89
9584 IR = 1
9585 RATIO = 1.0
9586 NMETHD = 2
9587 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9588 IR = 1
9589 RATIO = 1.0
9590 NMETHD = 1
9591 CALL CO2INT(ICO2TP,T41,T42,T20,RATIO,IR,NMETHD,L,LP1,LP2)
9592 IR = 1
9593 RATIO = 1.0
9594 NMETHD = 2
9595 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9596 IR = 1
9597 RATIO = 1.0
9598 NMETHD = 1
9599 CALL CO2INT(ICO2TP,T43,T44,T21,RATIO,IR,NMETHD,L,LP1,LP2)
9600 !===> FILL UP THE CO2D1D ARRAY
9601 ! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND
9602 ! THEIR DERIVATIVES FOR TAU(I,I+1),I=1,LEVS,
9603 ! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE BUT ARE THE
9604 ! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. THESE
9605 ! ARE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING H2O..
9606 !
9607 IQ = 1
9608 CALL CO2IN1(T20,T21,CO2D1D,IQ,L,LP1)
9609 ! do kk=1,6
9610 ! write(retval)(co2d1d(k,kk),k=1,60)
9611 ! enddo
9612 DO K=1,L
9613 CDTM51(K)=CO2D1D(K,1)
9614 CO2M51(K)=CO2D1D(K,2)
9615 C2DM51(K)=CO2D1D(K,3)
9616 CDTM58(K)=CO2D1D(K,4)
9617 CO2M58(K)=CO2D1D(K,5)
9618 C2DM58(K)=CO2D1D(K,6)
9619 ENDDO
9620 !
9621 !===> FILL UP THE CO2D2D ARRAY
9622 ! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9623 ! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
9624 ! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
9625 ! TO THE MRF VERTICAL COORDINATE,AND RE-CONSOLIDATED TO A
9626 ! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
9627 ! SCHWARZKOPF AND FELS (J.G.R.,1985).
9628 !
9629 CALL CO2INS(T22,T23,CO2D2D,IQ,L,LP1,1)
9630 ! do kk=1,6
9631 ! write(retval)((co2d2d(ka,kb,kk),ka=1,61),kb=1,61)
9632 ! enddo
9633 DO K1=1,LP1
9634 DO K2=1,LP1
9635 CDT51(K1,K2)=CO2D2D(K1,K2,1)
9636 CO251(K1,K2)=CO2D2D(K1,K2,2)
9637 C2D51(K1,K2)=CO2D2D(K1,K2,3)
9638 CDT58(K1,K2)=CO2D2D(K1,K2,4)
9639 CO258(K1,K2)=CO2D2D(K1,K2,5)
9640 C2D58(K1,K2)=CO2D2D(K1,K2,6)
9641 ENDDO
9642 ENDDO
9643 !
9644 !NOV89
9645 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9646 ! IR=2,IQ=2 IS FOR COMMON /CO2BD2/ IN RADIATION CODE...
9647 ! FOR THE CONSOLIDATED 490-670 CM-1 BAND...
9648 ! ICO2TP=62
9649 ICO2TP=etarad_unit62
9650 IR = 2
9651 RATIO = 1.0
9652 NMETHD = 2
9653 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9654 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9655 IQ = 2
9656 CALL CO2INS(T22,T23,CO2IQ2,IQ,L,LP1,2)
9657 ! do kk=1,6
9658 ! write(retval)(co2iq2(k,1,kk),k=1,61)
9659 ! enddo
9660 DO K=1,LP1
9661 CDT31(K)=CO2IQ2(K,1,1)
9662 CO231(K)=CO2IQ2(K,1,2)
9663 C2D31(K)=CO2IQ2(K,1,3)
9664 CDT38(K)=CO2IQ2(K,1,4)
9665 CO238(K)=CO2IQ2(K,1,5)
9666 C2D38(K)=CO2IQ2(K,1,6)
9667 ENDDO
9668 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9669 ! IR=3,IQ=3 IS FOR COMMON /CO2BD4/ IN RADIATION CODE...
9670 ! FOR THE CONSOLIDATED 670-850 CM-1 BAND...
9671 ! ICO2TP=63
9672 ICO2TP=etarad_unit63
9673 IR = 3
9674 RATIO = 1.0
9675 NMETHD = 2
9676 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9677 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9678 IQ = 3
9679 CALL CO2INS(T22,T23,CO2IQ3,IQ,L,LP1,3)
9680 ! do kk=1,6
9681 ! write(retval)(co2iq3(k,1,kk),k=1,61)
9682 ! enddo
9683 ! close(retval)
9684 DO K=1,LP1
9685 CDT71(K)=CO2IQ3(K,1,1)
9686 CO271(K)=CO2IQ3(K,1,2)
9687 C2D71(K)=CO2IQ3(K,1,3)
9688 CDT78(K)=CO2IQ3(K,1,4)
9689 CO278(K)=CO2IQ3(K,1,5)
9690 C2D78(K)=CO2IQ3(K,1,6)
9691 ENDDO
9692 !--- FOLLOWING CODE NOT WORKING AND NOT NEEDED YET
9693 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9694 ! IR=4,IQ=5 IS FOR COMMON /CO2BD5/ IN RADIATION CODE...
9695 ! FOR THE 4.3 MICRON BAND...
9696 ! NOT USED YET ICO2TP=65
9697 ! NOT USED YET IR = 4
9698 ! NOT USED YET RATIO = 1.0
9699 ! DAN SCHWARZ --- USE 300PPMV RATIO = 0.9091 (NOT TESTED YET).....
9700 ! NOT USED YET NMETHD = 2
9701 ! NOT USED YET CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD)
9702 ! NOT USED YET CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD)
9703 ! NOT USED YET IQ = 5
9704 ! NOT USED YET CALL CO2INS(T22,T23,CO2IQ5,IQ)
9705 !NOV89
9706 !... WRITE DATA TO DISK..
9707 ! ...SINCE THESE CODES ARE COMPILED WITH AUTODBL,THE CO2 DATA
9708 ! IS CONVERTED TO SINGLE PRECISION IN A LATER JOB STEP..
9710 ! NOT USED YET WRITE(66) CO211
9711 ! NOT USED YET WRITE(66) CO218
9712 !NOV89
9713 IF ( wrf_dm_on_monitor() ) THEN
9714 CLOSE (etarad_unit61)
9715 CLOSE (etarad_unit62)
9716 CLOSE (etarad_unit63)
9717 ENDIF
9719 RETURN
9720 9061 CONTINUE
9721 WRITE( errmess , '(A49,I4)' ) 'module_ra_hwrf: error reading tr49t85 on unit ',etarad_unit61
9722 write(0,*)' IERROR=',IERROR
9723 CALL wrf_error_fatal(errmess)
9724 9062 CONTINUE
9725 WRITE( errmess , '(A49,I4)' ) 'module_ra_hwrf: error reading tr49t67 on unit ',etarad_unit62
9726 write(0,*)' IERROR=',IERROR
9727 CALL wrf_error_fatal(errmess)
9728 9063 CONTINUE
9729 WRITE( errmess , '(A49,I4)' ) 'module_ra_hwrf: error reading tr67t85 on unit ',etarad_unit63
9730 write(0,*)' IERROR=',IERROR
9731 CALL wrf_error_fatal(errmess)
9732 END SUBROUTINE CO2O3
9735 !!================================================================================
9736 !----------------------------------------------------------------------
9737 !----------------------------------------------------------------------
9738 SUBROUTINE CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
9739 !----------------------------------------------------------------------
9740 ! *******************************************************************
9741 ! * C O N R A D *
9742 ! * READ CO2 TRANSMISSION DATA FROM UNIT(NFILE)FOR NEW VERTICAL *
9743 ! * COORDINATE TESTS ... *
9744 ! * THESE ARRAYS USED TO BE IN BLOCK DATA ...K.CAMPANA-MAR 90 *
9745 ! *******************************************************************
9746 !
9747 !----------------------------------------------------------------------
9748 IMPLICIT NONE
9749 !----------------------------------------------------------------------
9750 INTEGER,INTENT(IN) :: KDS,KDE,KMS,KME,KTS,KTE
9751 !----------------------------------------------------------------------
9752 !
9753 INTEGER :: I,I1,I2,IERROR,IRTN,J,K,KK,L,LP1,N,NUNIT_CO2,RSIZE
9754 INTEGER,DIMENSION(3) :: RSZE
9755 !
9756 REAL,DIMENSION(KMS:KME-1,6) :: CO21D
9757 REAL,DIMENSION(KMS:KME,2) :: SGTMP
9758 REAL,DIMENSION(KMS:KME,6) :: CO21D3,CO21D7
9759 REAL,DIMENSION(KMS:KME,KMS:KME,6) :: CO22D
9760 REAL,DIMENSION((KME-KMS+1)*(KME-KMS+1)) :: DATA2
9761 LOGICAL :: OPENED
9762 LOGICAL,EXTERNAL :: wrf_dm_on_monitor
9763 CHARACTER*80 errmess
9764 !
9765 !----------------------------------------------------------------------
9766 !
9767 ! CO2 DATA TABLES FOR USER'S VERTICAL COORDINATE
9768 !
9769 ! THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION
9770 ! FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND
9771 ! SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985),
9772 !----- THE 2-DIMENSIONAL ARRAYS ARE
9773 ! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9774 ! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
9775 ! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
9776 ! TO THE NMC MRF VERTICAL COORDINATTE,AND RE-CONSOLIDATED TO A
9777 ! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
9778 ! SCHWARZKOPF AND FELS (J.G.R.,1985).
9779 !----- THE 1-DIM ARRAYS ARE
9780 ! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9781 ! FOR TAU(I,I+1),I=1,L,
9782 ! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE,BUT ARE THE
9783 ! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES.
9784 ! THESE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING QH2O.
9785 !----- THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/
9786 ! 1013250.,WHERE P(K)=PRESSURE,NMC MRF(NEW) L18 DATA LEVELS FOR
9787 ! PSTAR=1013250.
9788 !----- STEMP IS US STANDARD ATMOSPHERES,1976,AT DATA PRESSURE LEVELS
9789 ! USING NMC MRF SIGMAS,WHERE PSTAR=1013.25 MB (PTZ PROGRAM)
9790 !
9791 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9792 ! AND PRESSURE DERIVATIVES FOR THE 560-800 CM-1 BAND. ALSO INCLUDED
9793 ! ARE THE STANDARD TEMPERATURES AND THE WEIGHTING FUNCTION. THESE
9794 ! DATA ARE IN BLOCK DATA BD3:
9795 ! CO251 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9796 ! WITH P(SFC)=1013.25 MB
9797 ! CO258 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9798 ! WITH P(SFC)= 810 MB
9799 ! CDT51 = FIRST TEMPERATURE DERIVATIVE OF CO251
9800 ! CDT58 = FIRST TEMPERATURE DERIVATIVE OF CO258
9801 ! C2D51 = SECOND TEMPERATURE DERIVATIVE OF CO251
9802 ! C2D58 = SECOND TEMPERATURE DERIVATIVE OF CO251
9803 ! CO2M51 = TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE
9804 ! LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR
9805 ! NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB
9806 ! CO2M58 = SAME AS CO2M51,WITH P(SFC)= 810 MB
9807 ! CDTM51 = FIRST TEMPERATURE DERIVATIVE OF CO2M51
9808 ! CDTM58 = FIRST TEMPERATURE DERIVATIVE OF CO2M58
9809 ! C2DM51 = SECOND TEMPERATURE DERIVATIVE OF CO2M51
9810 ! C2DM58 = SECOND TEMPERATURE DERIVATIVE OF CO2M58
9811 ! STEMP = STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL
9812 ! STRUCTURE WITH P(SFC)=1013.25 MB
9813 ! GTEMP = WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL
9814 ! STRUCTURE WITH P(SFC)=1013.25 MB.
9815 !----- THE FOLLOWING ARE STILL IN BLOCK DATA
9816 ! B0 = TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN.
9817 ! CORRECTION FOR T(K). (SEE REF. 4 AND BD3)
9818 ! B1 = TEMP. COEFFICIENT, USED ALONG WITH B0
9819 ! B2 = TEMP. COEFFICIENT, USED ALONG WITH B0
9820 ! B3 = TEMP. COEFFICIENT, USED ALONG WITH B0
9821 !
9822 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9823 ! AND PRESSURE DERIVATIVES FOR THE 560-670 CM-1 PART OF THE 15 UM
9824 ! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD2.
9825 ! FOR THE 560-670 CM-1 BAND,ONLY THE (1,I) VALUES ARE USED , SINCE
9826 ! THESE ARE USED FOR CTS COMPUTATIONS.
9827 ! CO231 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9828 ! WITH P(SFC)=1013.25 MB
9829 ! CO238 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9830 ! WITH P(SFC)= 810 MB
9831 ! CDT31 = FIRST TEMPERATURE DERIVATIVE OF CO231
9832 ! CDT38 = FIRST TEMPERATURE DERIVATIVE OF CO238
9833 ! C2D31 = SECOND TEMPERATURE DERIVATIVE OF CO231
9834 ! C2D38 = SECOND TEMPERATURE DERIVATIVE OF CO231
9835 !
9836 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9837 ! AND PRESSURE DERIVATIVES FOR THE 670-800 CM-1 PART OF THE 15 UM
9838 ! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD4.
9839 ! CO271 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9840 ! WITH P(SFC)=1013.25 MB
9841 ! CO278 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9842 ! WITH P(SFC)= 810 MB
9843 ! CDT71 = FIRST TEMPERATURE DERIVATIVE OF CO271
9844 ! CDT78 = FIRST TEMPERATURE DERIVATIVE OF CO278
9845 ! C2D71 = SECOND TEMPERATURE DERIVATIVE OF CO271
9846 ! C2D78 = SECOND TEMPERATURE DERIVATIVE OF CO271
9847 !
9848 ! *****THE FOLLOWING NOT USED IN CURRENT VERSION OF RADIATION *******
9849 !
9850 ! --CO2 TRANSMISSION FUNCTIONS FOR THE 2270-
9851 ! 2380 PART OF THE 4.3 UM CO2 BAND.
9852 ! THESE DATA ARE IN BLOCK DATA BD5.
9853 ! CO211 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9854 ! WITH P(SFC)=1013.25 MB
9855 ! CO218 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9856 ! WITH P(SFC)= 810 MB
9857 !
9858 ! *****THE ABOVE NOT USED IN CURRENT VERSION OF RADIATION ***********
9859 !----------------------------------------------------------------------
9860 !
9861 L=KME-KMS
9862 LP1=KME-KMS+1
9863 !
9864 !----------------------------------------------------------------------
9865 IF ( wrf_dm_on_monitor() ) THEN
9866 DO i = 14,99
9867 INQUIRE ( i , OPENED = opened )
9868 IF ( .NOT. opened ) THEN
9869 nunit_co2 = i
9870 GOTO 2014
9871 ENDIF
9872 ENDDO
9873 nunit_co2 = -1
9874 2014 CONTINUE
9875 ENDIF
9876 IF ( wrf_dm_on_monitor() ) THEN
9877 OPEN(nunit_co2,FILE='co2_trans', &
9878 FORM='UNFORMATTED',STATUS='OLD',ERR=9014,IOSTAT=IERROR)
9879 REWIND NUNIT_CO2
9880 ENDIF
9883 !----------------------------------------------------------------------
9884 !
9885 !*** READ IN PRE-COMPUTED CO2 TRANSMISSION DATA.
9886 !
9887 RSZE(1) = LP1
9888 RSZE(2) = L
9889 RSZE(3) = LP1*LP1
9890 !----------------------------------------------------------------------
9891 !
9892 RSIZE = RSZE(1)
9893 !
9894 DO KK=1,2
9895 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(SGTMP(I,KK),I=1,RSIZE)
9896 CALL wrf_dm_bcast_real( SGTMP(1,KK), RSIZE )
9897 ENDDO
9898 !
9899 !----------------------------------------------------------------------
9900 !
9901 RSIZE = RSZE(2)
9902 !
9903 DO KK=1,6
9904 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D(I,KK),I=1,RSIZE)
9905 CALL wrf_dm_bcast_real( CO21D(1,KK), RSIZE )
9906 ENDDO
9907 !
9908 !----------------------------------------------------------------------
9909 !
9910 RSIZE = RSZE(3)
9911 !
9912 DO KK=1,6
9913 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(DATA2(I),I=1,RSIZE)
9914 CALL wrf_dm_bcast_real( DATA2(1), RSIZE )
9915 N=0
9916 !
9917 DO I1=1,LP1
9918 DO I2=1,LP1
9919 N=N+1
9920 CO22D(I1,I2,KK)=DATA2(N)
9921 ENDDO
9922 ENDDO
9923 !
9924 ENDDO
9926 !
9927 ! Deallocate before reading. This is required for nested domain init.
9928 ! This is gopal's doing
9929 !
9930 IF(ALLOCATED (CO251))DEALLOCATE(CO251)
9931 IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
9932 IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
9933 IF(ALLOCATED (CO258))DEALLOCATE(CO258)
9934 IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
9935 IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
9936 IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
9937 IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
9938 IF(ALLOCATED (CO231))DEALLOCATE(CO231)
9939 IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
9940 IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
9941 IF(ALLOCATED (CO238))DEALLOCATE(CO238)
9942 IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
9943 IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
9944 IF(ALLOCATED (CO271))DEALLOCATE(CO271)
9945 IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
9946 IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
9947 IF(ALLOCATED (CO278))DEALLOCATE(CO278)
9948 IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
9949 IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
9950 IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
9951 IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
9952 IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
9953 IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
9954 IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
9955 IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
9956 !
9957 !----------------------------------------------------------------------
9958 !
9959 RSIZE = RSZE(1)
9960 !
9961 DO KK=1,6
9962 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D3(I,KK),I=1,RSIZE)
9963 CALL wrf_dm_bcast_real( CO21D3(1,KK), RSIZE )
9964 ENDDO
9965 !
9966 !----------------------------------------------------------------------
9967 !
9968 DO KK=1,6
9969 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D7(I,KK),I=1,RSIZE)
9970 CALL wrf_dm_bcast_real ( CO21D7(1,KK), RSIZE )
9971 ENDDO
9972 !
9973 !----------------------------------------------------------------------
9974 ALLOCATE(CO251(LP1,LP1))
9975 ALLOCATE(CDT51(LP1,LP1))
9976 ALLOCATE(C2D51(LP1,LP1))
9977 ALLOCATE(CO258(LP1,LP1))
9978 ALLOCATE(CDT58(LP1,LP1))
9979 ALLOCATE(C2D58(LP1,LP1))
9980 ALLOCATE(STEMP(LP1))
9981 ALLOCATE(GTEMP(LP1))
9982 ALLOCATE(CO231(LP1))
9983 ALLOCATE(CDT31(LP1))
9984 ALLOCATE(C2D31(LP1))
9985 ALLOCATE(CO238(LP1))
9986 ALLOCATE(CDT38(LP1))
9987 ALLOCATE(C2D38(LP1))
9988 ALLOCATE(CO271(LP1))
9989 ALLOCATE(CDT71(LP1))
9990 ALLOCATE(C2D71(LP1))
9991 ALLOCATE(CO278(LP1))
9992 ALLOCATE(CDT78(LP1))
9993 ALLOCATE(C2D78(LP1))
9994 ALLOCATE(CO2M51(L))
9995 ALLOCATE(CDTM51(L))
9996 ALLOCATE(C2DM51(L))
9997 ALLOCATE(CO2M58(L))
9998 ALLOCATE(CDTM58(L))
9999 ALLOCATE(C2DM58(L))
10000 !----------------------------------------------------------------------
10001 !
10002 DO K=1,LP1
10003 STEMP(K) = SGTMP(K,1)
10004 GTEMP(K) = SGTMP(K,2)
10005 ENDDO
10006 !
10007 DO K=1,L
10008 CDTM51(K) = CO21D(K,1)
10009 CO2M51(K) = CO21D(K,2)
10010 C2DM51(K) = CO21D(K,3)
10011 CDTM58(K) = CO21D(K,4)
10012 CO2M58(K) = CO21D(K,5)
10013 C2DM58(K) = CO21D(K,6)
10014 ENDDO
10015 !
10016 DO J=1,LP1
10017 DO I=1,LP1
10018 CDT51(I,J) = CO22D(I,J,1)
10019 CO251(I,J) = CO22D(I,J,2)
10020 C2D51(I,J) = CO22D(I,J,3)
10021 CDT58(I,J) = CO22D(I,J,4)
10022 CO258(I,J) = CO22D(I,J,5)
10023 C2D58(I,J) = CO22D(I,J,6)
10024 ENDDO
10025 ENDDO
10026 !
10027 DO K=1,LP1
10028 CDT31(K) = CO21D3(K,1)
10029 CO231(K) = CO21D3(K,2)
10030 C2D31(K) = CO21D3(K,3)
10031 CDT38(K) = CO21D3(K,4)
10032 CO238(K) = CO21D3(K,5)
10033 C2D38(K) = CO21D3(K,6)
10034 ENDDO
10035 !
10036 DO K=1,LP1
10037 CDT71(K) = CO21D7(K,1)
10038 CO271(K) = CO21D7(K,2)
10039 C2D71(K) = CO21D7(K,3)
10040 CDT78(K) = CO21D7(K,4)
10041 CO278(K) = CO21D7(K,5)
10042 C2D78(K) = CO21D7(K,6)
10043 ENDDO
10044 !
10045 !----------------------------------------------------------------------
10046 IF(wrf_dm_on_monitor())WRITE(0,66)NUNIT_CO2
10047 66 FORMAT('----READ CO2 TRANSMISSION FUNCTIONS FROM UNIT ',I2)
10048 !----------------------------------------------------------------------
10049 IF( wrf_dm_on_monitor() )THEN
10050 CLOSE(nunit_co2)
10051 ENDIF
10052 RETURN
10053 !
10054 9014 CONTINUE
10055 WRITE(errmess,'(A51,I4)')'module_ra_hwrf: error reading co2_trans on unit ',nunit_co2
10056 CALL wrf_error_fatal(errmess)
10057 !----------------------------------------------------------------------
10058 END SUBROUTINE CONRAD
10059 !----------------------------------------------------------------------
10060 !
10061 END MODULE module_RA_HWRF
10062 !
10063 !----------------------------------------------------------------------