| blob | 600b18fccc873de64a296d4a58101362569c6b34 |
1 !WRF:MODEL_RA:RADIATION
2 !
3 #define FERRIER_GFDL
4 MODULE MODULE_RA_GFDLETA
5 USE MODULE_CONFIGURE,ONLY : GRID_CONFIG_REC_TYPE
6 USE MODULE_MODEL_CONSTANTS
7 #ifdef FERRIER_GFDL
8 USE MODULE_MP_ETANEW, ONLY : FPVS,GPVS
9 #endif
10 INTEGER,PARAMETER :: NL=81
11 INTEGER,PARAMETER :: NBLY=15
12 REAL,PARAMETER :: RTHRESH=1.E-15,RTD=1./DEGRAD
14 INTEGER, SAVE, DIMENSION(3) :: LTOP
15 REAL , SAVE, DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
16 REAL , SAVE, DIMENSION(NL) :: PRGFDL
17 REAL , SAVE :: AB15WD,SKO2D,SKC1R,SKO3R
19 REAL , SAVE :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), &
20 TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
21 SOURCE(28,NBLY), DSRCE(28,NBLY)
23 REAL ,SAVE, DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW,EM3V
24 REAL ,SAVE :: R1,RSIN1,RCOS1,RCOS2
25 ! Created by CO2 initialization
26 REAL, SAVE, ALLOCATABLE, DIMENSION(:,:) :: CO251,CDT51,CDT58,C2D51,&
27 C2D58,CO258
28 REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: STEMP,GTEMP,CO231,CO238, &
29 C2D31,C2D38,CDT31,CDT38, &
30 CO271,CO278,C2D71,C2D78, &
31 CDT71,CDT78
32 REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: CO2M51,CO2M58,CDTM51,CDTM58, &
33 C2DM51,C2DM58
34 CHARACTER(256) :: ERRMESS
36 ! Used by CO2 initialization
37 ! COMMON/PRESS/PA(109)
38 ! COMMON/TRAN/ TRANSA(109,109)
39 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
40 REAL ,SAVE, DIMENSION(109) :: PA, XA, CA, ETA, SEXPV
41 REAL ,SAVE, DIMENSION(109,109) :: TRANSA
42 REAL ,SAVE :: CORE,UEXP,SEXP
44 EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1))
45 EQUIVALENCE (EM3V(1),EM3(1,1))
46 EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
47 (T4(1),TABLE3(1,1))
48 REAL,SAVE,DIMENSION(4) :: PTOPC
49 !
50 !--- Used for Gaussian look up tables
51 !
52 REAL, PRIVATE,PARAMETER :: XSDmax=3.1, DXSD=.01
53 INTEGER, PRIVATE,PARAMETER :: NXSD=XSDmax/DXSD
54 REAL, DIMENSION(NXSD),PRIVATE,SAVE :: AXSD
55 REAL, PRIVATE :: RSQR
56 LOGICAL, PRIVATE,SAVE :: SDprint=.FALSE.
59 REAL, PRIVATE, PARAMETER :: RHgrd=1.0
60 REAL, PRIVATE, PARAMETER :: T_ice=-40.0
62 !
63 !--- Important parameters for cloud properties - see extensive comments in
64 ! DO 580 loop within subroutine RADTN
65 !
66 REAL, PARAMETER :: &
67 & TRAD_ice=0.5*T_ice & !--- Very tunable parameter
68 &, ABSCOEF_W=800. & !--- Very tunable parameter
69 &, ABSCOEF_I=500. & !--- Very tunable parameter
70 &, SECANG=-1.66 & !--- Very tunable parameter
71 !! &, SECANG=-0.75 & !--- Very tunable parameter
72 &, CLDCOEF_LW=1.5 & !--- Enhance LW cloud depths
73 &, ABSCOEF_LW=SECANG*CLDCOEF_LW & !--- Final factor for cloud emissivities
74 &, Qconv=0.1e-3 & !--- Very tunable parameter
75 &, CTauCW=ABSCOEF_W*Qconv &
76 &, CTauCI=ABSCOEF_I*Qconv
77 !
79 CONTAINS
81 !-----------------------------------------------------------------------
82 SUBROUTINE GFDLETAINIT(EMISS,SFULL,SHALF,PPTOP, &
83 & JULYR,MONTH,IDAY,GMT, &
84 & CONFIG_FLAGS,ALLOWED_TO_READ, &
85 & IDS, IDE, JDS, JDE, KDS, KDE, &
86 & IMS, IME, JMS, JME, KMS, KME, &
87 & ITS, ITE, JTS, JTE, KTS, KTE )
88 !-----------------------------------------------------------------------
89 IMPLICIT NONE
90 !-----------------------------------------------------------------------
91 TYPE (GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS
92 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
93 & ,IMS,IME,JMS,JME,KMS,KME &
94 & ,ITS,ITE,JTS,JTE,KTS,KTE
95 INTEGER,INTENT(IN) :: JULYR,MONTH,IDAY
96 REAL,INTENT(IN) :: GMT,PPTOP
97 REAL,DIMENSION(KMS:KME),INTENT(IN) :: SFULL, SHALF
98 REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: EMISS
99 LOGICAL,INTENT(IN) :: ALLOWED_TO_READ
100 !
101 INTEGER :: I,IHRST,J,N
102 REAL :: PCLD,XSD,PI,SQR2PI
103 REAL :: SSLP=1013.25
104 REAL, PARAMETER :: PTOP_HI=150.,PTOP_MID=350.,PTOP_LO=642., &
105 & PLBTM=105000.
106 !-----------------------------------------------------------------------
107 !***********************************************************************
108 !-----------------------------------------------------------------------
109 !
110 !--- In case ETAMPNEW microphysics is not called, initialize lookup tables for
111 ! saturation vapor pressures (only FPVS is used in radiation, which calculates
112 ! vapor pressure w/r/t water for T>=0C and w/r/t ice for T<0C).
113 !
114 CALL GPVS
116 !*** INITIALIZE DIAGNOSTIC LOW,MIDDLE,HIGH CLOUD LAYER PRESSURE LIMITS.
117 !
118 LTOP(1)=0
119 LTOP(2)=0
120 LTOP(3)=0
121 !
122 DO N=1,KTE
123 PCLD=(SSLP-PPTOP*10.)*SHALF(N)+PPTOP*10.
124 IF(PCLD>=PTOP_LO)LTOP(1)=N
125 IF(PCLD>=PTOP_MID)LTOP(2)=N
126 IF(PCLD>=PTOP_HI)LTOP(3)=N
127 ! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
128 ENDDO
129 !***
130 !*** ASSIGN THE PRESSURES FOR CLOUD DOMAIN BOUNDARIES
131 !***
132 PTOPC(1)=PLBTM
133 PTOPC(2)=PTOP_LO*100.
134 PTOPC(3)=PTOP_MID*100.
135 PTOPC(4)=PTOP_HI*100.
136 !
137 !*** USE CALL TO CONRAD FOR DIRECT READ OF CO2 FUNCTIONS
138 !*** OTHERWISE CALL CO2O3.
139 !
140 IF(ALLOWED_TO_READ)THEN
141 IF(CONFIG_FLAGS%CO2TF==1)THEN
142 CALL CO2O3(SFULL,SHALF,PPTOP,KME-KMS,KME-KMS+1,KME-KMS+2)
143 ELSE
144 CALL CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
145 ENDIF
146 !
147 CALL O3CLIM
148 CALL TABLE
149 IHRST=NINT(GMT)
150 ! WRITE(0,*)'into solard ',gmt,ihrst
151 CALL SOLARD(IHRST,IDAY,MONTH,JULYR)
152 ENDIF
153 !
154 !*** FOR NOW, GFDL RADIATION ASSUMES EMISSIVITY = 1.0
155 !
156 DO J=JTS,JTE
157 DO I=ITS,ITE
158 EMISS(I,J) = 1.0
159 ENDDO
160 ENDDO
161 !
162 !--- Calculate the area under the Gaussian curve at the start of the
163 !--- model run and build the look up table AXSD
164 !
165 PI=ACOS(-1.)
166 SQR2PI=SQRT(2.*PI)
167 RSQR=1./SQR2PI
168 DO I=1,NXSD
169 XSD=REAL(I)*DXSD
170 AXSD(I)=GAUSIN(XSD)
171 if (SDprint) print *,'I, XSD, AXSD =',I,XSD,AXSD(I)
172 ENDDO
173 !
174 !-----------------------------------------------------------------------
175 END SUBROUTINE GFDLETAINIT
176 !-----------------------------------------------------------------------
177 !
178 !
179 !-----------------------------------------------------------------------
180 SUBROUTINE ETARA(DT,THRATEN,THRATENLW,THRATENSW,CLDFRA,PI3D &
181 & ,XLAND,P8W,DZ8W,RHO_PHY,P_PHY,T &
182 & ,QV,QW,QI,QS &
183 & ,TSK2D,GLW,RSWIN,GSW,RSWINC &
184 & ,RSWTOA,RLWTOA,CZMEAN &
185 & ,GLAT,GLON,HTOP,HBOT,HTOPR,HBOTR,ALBEDO,CUPPT &
186 & ,VEGFRA,SNOW,G,GMT &
187 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
188 & ,NSTEPRA,NPHS,ITIMESTEP &
189 & ,XTIME,JULIAN &
190 & ,JULYR,JULDAY,GFDL_LW,GFDL_SW &
191 & ,CFRACL,CFRACM,CFRACH &
192 & ,ACFRST,NCFRST,ACFRCV,NCFRCV &
193 & ,IDS,IDE,JDS,JDE,KDS,KDE &
194 & ,IMS,IME,JMS,JME,KMS,KME &
195 & ,ITS,ITE,JTS,JTE,KTS,KTE)
196 !-----------------------------------------------------------------------
197 IMPLICIT NONE
198 !-----------------------------------------------------------------------
199 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
200 & ,IMS,IME,JMS,JME,KMS,KME &
201 & ,ITS,ITE,JTS,JTE,KTS,KTE,ITIMESTEP &
202 & ,NPHS,NSTEPRA
204 INTEGER,INTENT(IN) :: julyr,julday
205 INTEGER,INTENT(INOUT),DIMENSION(ims:ime,jms:jme) :: NCFRST & !Added
206 ,NCFRCV !Added
207 REAL,INTENT(IN) :: DT,GMT,G,XTIME,JULIAN
209 REAL,INTENT(INOUT),DIMENSION(ims:ime, kms:kme, jms:jme):: &
210 THRATEN,THRATENLW,THRATENSW,CLDFRA !Added CLDFRA
211 REAL,INTENT(IN),DIMENSION(ims:ime, kms:kme, jms:jme)::p8w,dz8w, &
212 & rho_phy, &
213 & p_phy, &
214 & PI3D
215 REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: ALBEDO,SNOW, &
216 & TSK2D,VEGFRA, &
217 & XLAND
218 REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: GLAT,GLON
219 REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: HTOP,HBOT,HTOPR,HBOTR,CUPPT
220 REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: RSWTOA, & !Added
221 & RLWTOA, & !Added
222 & ACFRST, & !Added
223 & ACFRCV
224 REAL,INTENT(INOUT),DIMENSION(ims:ime, jms:jme):: GLW,GSW
225 REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CZMEAN &
226 & ,RSWIN,RSWINC &
227 & ,CFRACL,CFRACM,CFRACH
228 REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QS,QV, &
229 & QW,T
230 LOGICAL, INTENT(IN) :: gfdl_lw,gfdl_sw
231 REAL, OPTIONAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QI
233 REAL, DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP,QIFLIP,QFLIP, &
234 & QWFLIP,TFLIP
235 REAL, DIMENSION(its:ite, kms:kme, jts:jte)::P8WFLIP
236 REAL, DIMENSION(its:ite, kts:kte, jts:jte)::TENDS,TENDL
237 REAL, DIMENSION(ims:ime, jms:jme):: CUTOP,CUBOT
238 INTEGER :: IDAT(3),IHOUR,Jmonth,Jday
239 INTEGER :: I,J,K,KFLIP,IHRST
241 ! begin debugging radiation
242 integer :: imd,jmd
243 real :: FSWrat
244 ! end debugging radiation
245 !-----------------------------------------------------------------------
246 !***********************************************************************
247 !-----------------------------------------------------------------------
248 IF(GFDL_LW.AND.GFDL_SW )GO TO 100
249 !
250 DO J=JMS,JME
251 DO K=KMS,KME
252 DO I=IMS,IME
253 CLDFRA(I,K,J)=0.
254 ENDDO
255 ENDDO
256 ENDDO
257 !
258 DO K=KMS,KME
259 KFLIP=KME+1-K
260 DO J=JTS,JTE
261 DO I=ITS,ITE
262 P8WFLIP(I,K,J)=P8W(I,KFLIP,J)
263 ENDDO
264 ENDDO
265 ENDDO
266 !
267 !- Note that the effects of rain are ignored in this radiation package (BSF 2005-01-25)
268 !
269 DO K=KTS,KTE
270 KFLIP=KTE+1-K
271 DO J=JTS,JTE
272 DO I=ITS,ITE
273 TFLIP (I,K,J)=T(I,KFLIP,J)
274 QFLIP (I,K,J)=MAX(0.,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J)))
275 QWFLIP(I,K,J)=MAX(QW(I,KFLIP,J),0.) !Modified
276 ! Note that QIFLIP will contain QS+QI if both are passed in, otherwise just QS
277 ! Eta MP now outputs QS instead of QI (JD 2006-05-12)
278 QIFLIP(I,K,J)=MAX(QS(I,KFLIP,J),0.) !Added QS
279 IF(PRESENT(QI))QIFLIP(I,K,J)=QIFLIP(I,K,J)+QI(I,KFLIP,J) !Added QI
280 PFLIP (I,K,J)=P_PHY(I,KFLIP,J)
281 !
282 !*** USE MONOTONIC HYDROSTATIC PRESSURE INTERPOLATED TO MID-LEVEL
283 !
284 ENDDO
285 ENDDO
286 ENDDO
287 !
288 DO J=JTS,JTE
289 DO I=ITS,ITE
290 CUBOT(I,J)=KTE+1-HBOT(I,J)
291 CUTOP(I,J)=KTE+1-HTOP(I,J)
292 ENDDO
293 ENDDO
294 !
295 CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY)
296 !
297 IDAT(1)=JMONTH
298 IDAT(2)=JDAY
299 IDAT(3)=JULYR
300 IHRST =NINT(GMT)
302 IHOUR =MOD((IHRST+NINT(XTIME/60.0)),24)
303 ! write(0,*)' before SOLARD in ETARA ', IHOUR,JDAY,JMONTH,JULYR
304 CALL SOLARD(IHOUR,JDAY,JMONTH,JULYR)
305 !-----------------------------------------------------------------------
306 CALL RADTN (DT,TFLIP,QFLIP,QWFLIP,QIFLIP, &
307 & PFLIP,P8WFLIP,XLAND,TSK2D, &
308 & GLAT,GLON,CUTOP,CUBOT,ALBEDO,CUPPT, &
309 & ACFRCV,NCFRCV,ACFRST,NCFRST, &
310 & VEGFRA,SNOW,GLW,GSW,RSWIN,RSWINC, &
311 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
312 & IDAT,IHRST,XTIME,JULIAN, &
313 & NSTEPRA,NSTEPRA,NPHS,ITIMESTEP, &
314 & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, &
315 & CFRACL,CFRACM,CFRACH, &
316 & IDS,IDE,JDS,JDE,KDS,KDE, &
317 & IMS,IME,JMS,JME,KMS,KME, &
318 & ITS,ITE,JTS,JTE,KTS,KTE )
319 !-----------------------------------------------------------------------
320 ! begin debugging radiation
321 ! imd=(ims+ime)/2
322 ! jmd=(jms+jme)/2
323 ! FSWrat=0.
324 ! if (RSWIN(imd,jmd) .gt. 0.) &
325 ! FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd)
326 ! write(6,"(2a,2i5,5f9.2,f8.4,i3,2f8.4)") &
327 ! '{rad4 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' &
328 ! ,'ACFRCV,NCFRCV,ALBEDO,RSWOUT/RSWIN = ' &
329 ! ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd) &
330 ! ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) &
331 ! ,ACFRCV(imd,jmd),NCFRCV(imd,jmd),ALBEDO(imd,jmd),FSWrat
332 ! end debugging radiation
333 !
334 !--- Need to save LW & SW tendencies since radiation calculates both and this block
335 ! is skipped when GFDL SW is called, both only if GFDL LW is also called
336 !
337 IF(GFDL_LW)THEN
338 DO J=JTS,JTE
339 DO K = KTS,KTE
340 KFLIP=KTE+1-K
341 DO I=ITS,ITE
342 THRATENLW(I,K,J)=TENDL(I,KFLIP,J)/PI3D(I,K,J)
343 THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J)
344 THRATEN(I,K,J) =THRATEN(I,K,J) + THRATENLW(I,K,J)
345 ENDDO
346 ENDDO
347 ENDDO
348 ENDIF
349 !
350 !*** THIS ASSUMES THAT LONGWAVE IS CALLED FIRST IN THE RADIATION_DRIVER.
351 ! Only gets executed if a different LW scheme (not GFDL) is called
352 !
353 IF(GFDL_SW)THEN
354 DO J=JTS,JTE
355 DO K=KTS,KTE
356 KFLIP=KTE+1-K
357 DO I=ITS,ITE
358 THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J)
359 ENDDO
360 ENDDO
361 ENDDO
362 ENDIF
363 !
364 !*** RESET ACCUMULATED CONVECTIVE CLOUD TOP/BOT AND CONVECTIVE PRECIP
365 !*** FOR NEXT INTERVAL BETWEEN RADIATION CALLS
366 !
367 DO J=JTS,JTE
368 DO I=ITS,ITE
369 ! SAVE VALUE USED BY RADIATION BEFORE RESETTING HTOP AND HBOT
370 HBOTR(I,J)=HBOT(I,J)
371 HTOPR(I,J)=HTOP(I,J)
372 HBOT(I,J)=REAL(KTE+1)
373 HTOP(I,J)=0.
374 CUPPT(I,J)=0.
375 ENDDO
376 ENDDO
377 !
378 100 IF(GFDL_SW)THEN
379 DO J=JTS,JTE
380 DO K=KTS,KTE
381 KFLIP=KTE+1-K
382 DO I=ITS,ITE
383 THRATEN(I,K,J)=THRATEN(I,K,J)+THRATENSW(I,K,J)
384 ENDDO
385 ENDDO
386 ENDDO
387 ENDIF
388 !
389 END SUBROUTINE ETARA
390 !
391 !-----------------------------------------------------------------------
392 SUBROUTINE RADTN(DT,T,Q,QCW,QICE, &
393 & PFLIP,P8WFLIP,XLAND,TSK2D, &
394 & GLAT,GLON,CUTOP,CUBOT,ALB,CUPPT, &
395 & ACFRCV,NCFRCV,ACFRST,NCFRST, &
396 & VEGFRC,SNO,GLW,GSW,RSWIN,RSWINC, &
397 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
398 & IDAT,IHRST,XTIME,JULIAN, &
399 & NRADS,NRADL,NPHS,NTSD, &
400 & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, &
401 & CFRACL,CFRACM,CFRACH, &
402 & ids,ide, jds,jde, kds,kde, &
403 & ims,ime, jms,jme, kms,kme, &
404 & its,ite, jts,jte, kts,kte )
405 !-----------------------------------------------------------------------
406 IMPLICIT NONE
407 !-----------------------------------------------------------------------
409 ! GLAT : geodetic latitude in radians of the mass points on the computational grid.
411 ! CZEN : instantaneous cosine of the solar zenith angle.
413 ! CUTOP : (REAL) model layer number that is highest in the atmosphere
414 ! in which convective cloud occurred since the previous call to the
415 ! radiation driver.
417 ! CUBOT : (REAL) model layer number that is lowest in the atmosphere
418 ! in which convective cloud occurred since the previous call to the
419 ! radiation driver.
421 ! ALB : is no longer used in the operational radiation. Prior to 24 July 2001
422 ! ALB was the climatological albedo that was modified within RADTN to
423 ! account for vegetation fraction and snow.
424 !
425 ! ALB : reintroduced as the dynamic albedo from LSM
427 ! CUPPT: accumulated convective precipitation (meters) since the
428 ! last call to the radiation.
430 ! TSK2D : skin temperature
432 ! IHE and IHW are relative location indices needed to locate neighboring
433 ! points on the Eta's Arakawa E grid since arrays are indexed locally on
434 ! each MPI task rather than globally. IHE refers to the adjacent grid
435 ! point (a V point) to the east of the mass point being considered. IHW
436 ! is the adjacent grid point to the west of the given mass point.
438 ! IRAD is a relic from older code that is no longer needed.
440 ! ACFRCV : sum of the convective cloud fractions that were computed
441 ! during each call to the radiation between calls to the subroutines that
442 ! do the forecast output.
444 ! NCFRCV : the total number of times in which the convective cloud
445 ! fraction was computed to be greater than zero in the radiation between
446 ! calls to the output routines. In the post-processor, ACFRCV is divided
447 ! by NCFRCV to yield an average convective cloud fraction.
449 ! ACFRST and NCFRST are the analogs for stratiform cloud cover.
451 ! VEGFRC is the fraction of the gridbox with vegetation.
453 ! LVL holds the number of model layers that lie below the ground surface
454 ! at each point. Clearly for sigma coordinates LVL is zero everywhere.
456 ! CTHK : an assumed maximum thickness of stratiform clouds currently set
457 ! to 20000 Pascals. I think this is relevant for computing "low",
458 ! "middle", and "high" cloud fractions which are post-processed but which
459 ! do not feed back into the integration.
461 ! IDAT : a 3-element integer array holding the month, day, and year,
462 ! respectively, of the date for the start time of the free forecast.
464 ! ABCFF : holds coefficients for various absorption bands. You can see
465 ! where they are set in GFDLRD.F.
467 ! LTOP : a 3-element integer array holding the model layer that is at or
468 ! immediately below the specified pressure levels for the tops
469 ! of "high" (15000 Pa), "middle" (35000 Pa), and "low" (64200 Pa)
470 ! stratiform clouds. These are for the diagnostic cloud layers
471 ! needed in the output but not in the integration.
473 ! NRADS : integer number of fundamental timesteps (our smallest
474 ! timestep, i.e., the one for inertial gravity wave adjustment)
475 ! between updates of the shortwave tendencies.
477 ! NRADL : integer number of fundamental timesteps between updates of
478 ! the longwave tendencies.
480 ! NTSD : integer counter of the fundamental timesteps that have
481 ! elapsed since the start of the forecast.
483 ! GLW : incoming longwave radiation at the surface
484 ! GSW : NET (down minus up, or incoming minus outgoing) all-sky shortwave radiation at the surface
485 ! RSWIN : total (clear + cloudy sky) incoming (downward) solar radiation at the surface
486 ! RSWINC : clear sky incoming (downward) solar radiation at the surface
488 ! TENDS,TENDL : shortwave,longwave (respectively) temperature tendency
490 ! CLDFRA : 3D cloud fraction
492 ! RSWTOA, RLWTOA : outgoing shortwave, longwave (respectively) fluxes at top of atmosphere
494 ! CZMEAN : time-average cosine of the zenith angle
496 ! CFRACL,CFRACM,CFRACH : low, middle, & high (diagnosed) cloud fractions
498 ! XTIME : time since simulation start (minutes)
500 ! JULIAN: Day of year (0.0 at 00Z Jan 1st)
502 !**********************************************************************
503 !****************************** NOTE **********************************
504 !**********************************************************************
505 !*** DUE TO THE RESETTING OF CONVECTIVE PRECIP AND CONVECTIVE CLOUD
506 !*** TOPS AND BOTTOMS, SHORTWAVE MUST NOT BE CALLED LESS FREQUENTLY
507 !*** THAN LONGWAVE.
508 !**********************************************************************
509 !****************************** NOTE **********************************
510 !**********************************************************************
511 !-----------------------------------------------------------------------
512 ! INTEGER, PARAMETER :: NL=81
513 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
514 & ims,ime, jms,jme, kms,kme , &
515 & its,ite, jts,jte, kts,kte
516 INTEGER, INTENT(IN) :: NRADS,NRADL,NTSD,NPHS
517 ! LOGICAL, INTENT(IN) :: RESTRT
518 REAL , INTENT(IN) :: DT,XTIME,JULIAN
519 ! REAL , INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
520 INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
521 !-----------------------------------------------------------------------
522 INTEGER :: LM1,LP1,LM
523 INTEGER, INTENT(IN) :: IHRST
524 ! REAL, INTENT(IN), DIMENSION(NL) :: PRGFDL
525 !
526 REAL, PARAMETER :: EPSQ1=1.E-5,EPSQ=1.E-12,EPSO3=1.E-10,H0=0. &
527 &, H1=1.,HALF=.5,T0C=273.15,CUPRATE=24.*1000.,HPINC=HALF*1.E1 &
528 !------------------------ For Clouds ----------------------------------
529 &, CLFRmin=0.01, TAUCmax=4.161 &
530 !--- Parameters used for new cloud cover scheme
531 &, XSDmin=-XSDmax, DXSD1=-DXSD, STSDM=0.01, CVSDM=.04 &
532 &, DXSD2=HALF*DXSD, DXSD2N=-DXSD2, PCLDY=0.25
533 !
534 INTEGER, PARAMETER :: NB=12,KSMUD=0
535 INTEGER,PARAMETER :: K15=SELECTED_REAL_KIND(15)
536 REAL (KIND=K15) :: DDX,EEX,PROD
537 ! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D
538 !-----------------------------------------------------------------------
539 LOGICAL :: SHORT,LONG
540 LOGICAL :: BITX,BITY,BITZ,BITW,BIT1,BIT2,BITC,BITCP1,BITSP1
541 LOGICAL, SAVE :: CNCLD=.TRUE.
542 LOGICAL :: NEW_CLOUD
543 !-----------------------------------------------------------------------
544 REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: XLAND,TSK2D
545 REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: Q,QCW, &
546 & QICE,T, &
547 & PFLIP, &
548 & P8WFLIP
550 ! REAL, INTENT(IN), DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3,EM3,EM1,EM1WDE
551 REAL, INTENT(OUT), DIMENSION(ims:ime, jms:jme):: GLW,GSW,CZMEAN &
552 & ,RSWIN,RSWINC & !Added
553 & ,CFRACL,CFRACM &
554 & ,CFRACH
555 REAL, INTENT(OUT),DIMENSION(ims:ime,kms:kme,jms:jme) :: CLDFRA !added
557 ! REAL, INTENT(IN), DIMENSION(kms:kme) :: ETAD
558 ! REAL, INTENT(IN), DIMENSION(kms:kme) :: AETA
559 !-----------------------------------------------------------------------
560 REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: CUTOP,CUBOT,CUPPT
561 REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: ALB,SNO
562 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
563 REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: GLAT,GLON
564 !-----------------------------------------------------------------------
565 REAL, DIMENSION(ims:ime,jms:jme) :: CZEN
566 INTEGER, DIMENSION(its:ite, jts:jte):: LMH
567 !-----------------------------------------------------------------------
568 ! INTEGER,INTENT(IN), DIMENSION(jms:jme) :: IHE,IHW
569 !-----------------------------------------------------------------------
570 REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: ACFRCV,ACFRST &
571 ,RSWTOA,RLWTOA
572 INTEGER,INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: NCFRCV,NCFRST
573 !-----------------------------------------------------------------------
574 REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: VEGFRC
575 REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte,jts:jte) :: TENDL,&
576 & TENDS
577 !-----------------------------------------------------------------------
578 REAL :: CTHK(3)
579 DATA CTHK/20000.0,20000.0,20000.0/
581 REAL,DIMENSION(10),SAVE :: CC,PPT
582 !-----------------------------------------------------------------------
583 REAL,SAVE :: ABCFF(NB)
584 INTEGER,DIMENSION(its:ite,jts:jte) :: LVL
585 REAL, DIMENSION(its:ite, jts:jte):: PDSL,FNE,FSE,TL
586 REAL, DIMENSION( 0:kte) :: CLDAMT
587 REAL, DIMENSION(its:ite,3):: CLDCFR
588 INTEGER, DIMENSION(its:ite,3):: MBOT,MTOP
589 REAL, DIMENSION(its:ite) :: PSFC,TSKN,ALBEDO,XLAT,COSZ, &
590 & SLMSK,FLWUP, &
591 & FSWDN,FSWUP,FSWDNS,FSWUPS,FLWDNS, &
592 & FLWUPS,FSWDNSC
594 REAL, DIMENSION(its:ite,kts:kte) :: PMID,TMID
595 REAL, DIMENSION(its:ite,kts:kte) :: QMID,THMID,OZN,POZN
596 REAL, DIMENSION(its:ite,jts:jte) :: TOT
598 REAL, DIMENSION(its:ite,kts:kte+1) :: PINT,EMIS,CAMT
599 INTEGER,DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
600 INTEGER,DIMENSION(its:ite) :: NCLDS,KCLD
601 REAL, DIMENSION(its:ite) :: TAUDAR
602 REAL, DIMENSION(its:ite,NB,kts:kte+1) ::RRCL,TTCL
604 REAL, DIMENSION(its:ite,kts:kte):: CSMID,CCMID,QWMID,QIMID
605 !! & ,QOVRCST ! Added
606 REAL,SAVE :: P400=40000.
607 INTEGER,SAVE :: NFILE=14
609 !-----------------------------------------------------------------------
610 REAL :: CLSTP,TIME,DAYI,HOUR,ADDL,RANG
611 REAL :: TIMES,EXNER,APES,SNOFAC,CCLIMIT,CLIMIT,P1,P2,CC1,CC2
612 REAL :: PMOD,CLFR1,CTAU,WV,ARG,CLDMAX
613 REAL :: CL1,CL2,CR1,DPCL,QSUM,PRS1,PRS2,DELP,TCLD,DD,EE,AA,FF
614 REAL :: BB,GG,FCTR,PDSLIJ,CFRAVG,SNOMM
615 REAL :: THICK,CONVPRATE,CLFR,ESAT,QSAT,RHUM,QCLD
616 REAL :: RHtot,SDM
617 REAL :: TauC,CTauL,CTauS, CFSmax,CFCmax
618 INTEGER :: I,J,MYJS,MYJE,MYIS,MYIE,NTSPH,NRADPP,ITIMSW,ITIMLW, &
619 & JD,II
620 INTEGER :: L,N,LML,LVLIJ,IR,KNTLYR,LL,NC,L400,NMOD,LTROP,IWKL
621 INTEGER :: LCNVB,LCNVT
622 INTEGER :: NLVL,MALVL,LLTOP,LLBOT,KBT2,KTH1,KBT1,KTH2,KTOP1,KFLIP
623 INTEGER :: NBAND,NCLD,LBASE,NKTP,NBTM,KS,MYJS1,MYJS2,MYJE2,MYJE1
625 INTEGER :: INDEXS,IXSD
626 DATA CC/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0/
627 DATA PPT/0.,.14,.31,.70,1.6,3.4,7.7,17.,38.,85./
628 DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190.,989., &
629 & 2706.,39011./
630 ! begin debugging radiation
631 integer :: imd,jmd, Jndx
632 real :: FSWrat
633 imd=(ims+ime)/2
634 jmd=(jms+jme)/2
635 ! end debugging radiation
636 !
637 !=======================================================================
638 !
639 MYJS=jts
640 MYJE=jte
641 MYIS=its
642 MYIE=ite
643 MYJS1=jts !????
644 MYJE1=jte
645 MYJS2=jts
646 MYJE2=jte
647 LM=kte
648 LM1=LM-1
649 LP1=LM+1
650 !
651 DO J=JTS,JTE
652 DO I=ITS,ITE
653 LMH(I,J)=KME-1
654 LVL(I,J)=0
655 ENDDO
656 ENDDO
657 !**********************************************************************
658 !*** THE FOLLOWING CODE IS EXECUTED EACH TIME THE RADIATION IS CALLED.
659 !**********************************************************************
660 !----------------------CONVECTION--------------------------------------
661 ! NRADPP IS THE NUMBER OF TIME STEPS TO ACCUMULATE CONVECTIVE PRECIP
662 ! FOR RADIATION
663 ! NOTE: THIS WILL NOT WORK IF NRADS AND NRADL ARE DIFFERENT UNLESS
664 ! THEY ARE INTEGER MULTIPLES OF EACH OTHER
665 ! CLSTP IS THE NUMBER OF HOURS OF THE ACCUMULATION PERIOD
666 !
667 NTSPH=NINT(3600./DT)
668 NRADPP=MIN(NRADS,NRADL)
669 CLSTP=1.0*NRADPP/NTSPH
670 CONVPRATE=CUPRATE/CLSTP
671 !----------------------CONVECTION--------------------------------------
672 !***
673 !*** STATE WHETHER THE SHORT OR LONGWAVE COMPUTATIONS ARE TO BE DONE.
674 !***
675 SHORT=.TRUE.
676 LONG=.TRUE.
677 ITIMSW=0
678 ITIMLW=0
679 IF(SHORT)ITIMSW=1
680 IF(LONG) ITIMLW=1
681 !***
682 !*** FIND THE MEAN COSINE OF THE SOLAR ZENITH ANGLE
683 !*** BETWEEN THE CURRENT TIME AND THE NEXT TIME RADIATION IS
684 !*** CALLED. ONLY AVERAGE IF THE SUN IS ABOVE THE HORIZON.
685 !***
686 ! TIME=NTSD*DT
687 TIME=XTIME*60.
688 !-----------------------------------------------------------------------
689 CALL ZENITH(TIME,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
690 & MYIS,MYIE,MYJS,MYJE, &
691 & ids,ide, jds,jde, kds,kde, &
692 & ims,ime, jms,jme, kms,kme, &
693 & its,ite, jts,jte, kts,kte )
694 !-----------------------------------------------------------------------
695 ! write(0,*)'1st ZEN ',TIME,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS)
696 ADDL=0.
697 IF(MOD(IDAT(3),4).EQ.0)ADDL=1.
698 RANG=PI2*(DAYI-RLAG)/(365.+ADDL)
699 RSIN1=SIN(RANG)
700 RCOS1=COS(RANG)
701 RCOS2=COS(2.*RANG)
702 !
703 !-----------------------------------------------------------------------
704 IF(SHORT)THEN
705 DO J=MYJS,MYJE
706 DO I=MYIS,MYIE
707 CZMEAN(I,J)=0.
708 TOT(I,J)=0.
709 ENDDO
710 ENDDO
711 !
712 DO II=0,NRADS,NPHS
713 TIMES=XTIME*60.+II*DT
714 CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
715 & MYIS,MYIE,MYJS,MYJE, &
716 & ids,ide, jds,jde, kds,kde, &
717 & ims,ime, jms,jme, kms,kme, &
718 & its,ite, jts,jte, kts,kte )
719 ! write(0,*)'2nd ZEN ',TIMES,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS),&
720 ! & II,NRADS,NPHS,NTSD,DT
721 DO J=MYJS,MYJE
722 DO I=MYIS,MYIE
723 IF(CZEN(I,J).GT.0.)THEN
724 CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J)
725 TOT(I,J)=TOT(I,J)+1.
726 ENDIF
727 ENDDO
728 ENDDO
729 ENDDO
730 DO J=MYJS,MYJE
731 DO I=MYIS,MYIE
732 IF(TOT(I,J).GT.0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J)
733 ENDDO
734 ENDDO
735 ENDIF
737 !
738 !
739 !*** Do not modify pressure for ozone concentrations below the top layer
740 !***
741 DO L=2,LM
742 DO I=MYIS,MYIE
743 POZN(I,L)=H1
744 ENDDO
745 ENDDO
746 !-----------------------------------------------------------------------
747 !
748 !***********************************************************************
749 !*** THIS IS THE BEGINNING OF THE PRIMARY LOOP THROUGH THE DOMAIN
750 !***********************************************************************
751 ! *********************
752 DO 700 J = MYJS, MYJE
753 ! *********************
754 !
755 DO 125 L=1,LM
756 DO I=MYIS,MYIE
757 TMID(I,L)=T(I,1,J)
758 QMID(I,L)=EPSQ
759 QWMID(I,L)=0.
760 QIMID(I,L)=0.
761 CSMID(I,L)=0.
762 CCMID(I,L)=0.
763 OZN(I,L)=EPSO3
764 TENDS(I,L,J)=0.
765 TENDL(I,L,J)=0.
766 ENDDO
767 125 CONTINUE
768 !
769 DO 140 N=1,3
770 DO I=MYIS,MYIE
771 CLDCFR(I,N)=0.
772 MTOP(I,N)=0
773 MBOT(I,N)=0
774 ENDDO
775 140 CONTINUE
776 !***
777 !*** FILL IN WORKING ARRAYS WHERE VALUES AT L=LM ARE THOSE THAT
778 !*** ARE ACTUALLY AT ETA LEVEL L=LMH.
779 !***
780 DO 200 I=MYIS,MYIE
781 ! IR=IRAD(I)
782 LML=LMH(I,J)
783 LVLIJ=LVL(I,J)
784 !
785 DO L=1,LML
786 PMID(I,L+LVLIJ)=PFLIP(I,L,J)
787 PINT(I,L+LVLIJ+1)=P8WFLIP(I,L+1,J)
788 EXNER=(1.E5/PMID(I,L+LVLIJ))**RCP
789 TMID(I,L+LVLIJ)=T(I,L,J)
790 THMID(I,L+LVLIJ)=T(I,L,J)*EXNER
791 QMID(I,L+LVLIJ)=MAX(EPSQ, Q(I,L,J))
792 !--- Note that rain is ignored, only effects from cloud water and
793 ! ice (cloud ice + snow) are considered
794 QWMID(I,L+LVLIJ)=QCW(I,L,J)
795 QIMID(I,L+LVLIJ)=QICE(I,L,J)
796 ENDDO
797 !***
798 !*** FILL IN ARTIFICIAL VALUES ABOVE THE TOP OF THE DOMAIN.
799 !*** PRESSURE DEPTHS OF THESE LAYERS IS 1 HPA.
800 !*** TEMPERATURES ABOVE ARE ALREADY ISOTHERMAL WITH (TRUE) LAYER 1.
801 !***
802 IF(LVLIJ.GT.0)THEN
803 KNTLYR=0
804 !
805 DO L=LVLIJ,1,-1
806 KNTLYR=KNTLYR+1
807 PMID(I,L)=P8WFLIP(I,1,J)-REAL(2*KNTLYR-1)*HPINC
808 PINT(I,L+1)=PMID(I,L)+HPINC
809 EXNER=(1.E5/PMID(I,L))**RCP
810 THMID(I,L)=TMID(I,L)*EXNER
811 ENDDO
812 ENDIF
813 !
814 IF(LVLIJ.EQ.0) THEN
815 PINT(I,1)=P8WFLIP(I,1,J)
816 ELSE
817 PINT(I,1)=PMID(I,1)-HPINC
818 ENDIF
819 200 CONTINUE
820 !***
821 !*** FILL IN THE SURFACE PRESSURE, SKIN TEMPERATURE, GEODETIC LATITUDE,
822 !*** ZENITH ANGLE, SEA MASK, AND ALBEDO. THE SKIN TEMPERATURE IS
823 !*** NEGATIVE OVER WATER.
824 !***
825 DO 250 I=MYIS,MYIE
826 PSFC(I)=P8WFLIP(I,KME,J)
827 APES=(PSFC(I)*1.E-5)**RCP
828 ! TSKN(I)=THS(I,J)*APES*(1.-2.*SM(I,J))
829 IF((XLAND(I,J)-1.5).GT.0.)THEN
830 TSKN(I)=-TSK2D(I,J)
831 ELSE
832 TSKN(I)=TSK2D(I,J)
833 ENDIF
835 ! TSKN(I)=THS(I,J)*APES*(1.-2.*(XLAND(I,J)-1.))
836 ! SLMSK(I)=SM(I,J)
837 SLMSK(I)=XLAND(I,J)-1.
838 !
839 ! SNO(I,J)=AMAX1(SNO(I,J),0.)
840 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
841 SNOMM=AMAX1(SNO(I,J),0.)
842 SNOFAC=AMIN1(SNOMM/0.02, 1.0)
843 !!!! ALBEDO(I)=ALB(I,J)+(1.0-0.01*VEGFRC(I,J))*SNOFAC*(SNOALB-ALB(I,J))
844 ALBEDO(I)=ALB(I,J)
845 !
846 XLAT(I)=GLAT(I,J)*RTD
847 COSZ(I)=CZMEAN(I,J)
848 250 CONTINUE
849 !-----------------------------------------------------------------------
850 !--- COMPUTE GRID-SCALE CLOUD COVER FOR RADIATION (Ferrier, Nov '04)
851 !
852 !--- Assumes Gaussian-distributed probability density functions (PDFs) for
853 ! total relative humidity (RHtot) within the grid for convective and
854 ! grid-scale cloud processes. The standard deviation of RHtot is assumed
855 ! to be larger for convective clouds than grid-scale (stratiform) clouds.
856 !-----------------------------------------------------------------------
857 !
858 DO I=MYIS,MYIE
859 LML=LMH(I,J)
860 LVLIJ=LVL(I,J)
861 DO 255 L=1,LML
862 LL=L+LVLIJ
863 WV=QMID(I,LL)/(1.-QMID(I,LL)) !--- Water vapor mixing ratio
864 QCLD=QWMID(I,LL)+QIMID(I,LL) !--- Total cloud water + ice mixing ratio
865 IF (QCLD .LE. EPSQ) GO TO 255 !--- Skip if no condensate is present
866 CLFR=H0
867 WV=QMID(I,LL)/(1.-QMID(I,LL)) !--- Water vapor mixing ratio
869 !
870 !--- Saturation vapor pressure w/r/t water ( >=0C ) or ice ( <0C )
871 !
872 #ifdef FERRIER_GFDL
873 ESAT=1000.*FPVS(TMID(I,LL)) !--- Saturation vapor pressure (Pa)
874 #else
875 ESAT=FPVS_new(TMID(I,LL)) !--- Saturation vapor pressure (Pa)
876 #endif
877 QSAT=EP_2*ESAT/(PMID(I,LL)-ESAT) !--- Saturation mixing ratio
878 RHUM=WV/QSAT !--- Relative humidity
879 !
880 !--- Revised cloud cover parameterization (temporarily ignore rain)
881 !
882 RHtot=(WV+QCLD)/QSAT !--- Total relative humidity
883 LCNVT=NINT(CUTOP(I,J))+LVLIJ
884 LCNVT=MIN(LM,LCNVT)
885 LCNVB=NINT(CUBOT(I,J))+LVLIJ
886 LCNVB=MIN(LM,LCNVB)
887 IF (LL.GE.LCNVT .AND. LL.LE.LCNVB) THEN
888 SDM=CVSDM
889 ELSE
890 SDM=STSDM
891 ENDIF
892 ARG=(RHtot-RHgrd)/SDM
893 IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N) THEN
894 CLFR=HALF
895 ELSE IF (ARG .GT. DXSD2) THEN
896 IF (ARG .GE. XSDmax) THEN
897 CLFR=H1
898 ELSE
899 IXSD=INT(ARG/DXSD+HALF)
900 IXSD=MIN(NXSD, MAX(IXSD,1))
901 CLFR=HALF+AXSD(IXSD)
902 if (SDprint) &
903 & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)") &
904 & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot &
905 & ,1000.*QSAT,TCLD,.01*PMID(I,LL)
906 ENDIF !--- End IF (ARG .GE. XSDmax)
907 ELSE
908 IF (ARG .LE. XSDmin) THEN
909 CLFR=H0
910 ELSE
911 IXSD=INT(ARG/DXSD1+HALF)
912 IXSD=MIN(NXSD, MAX(IXSD,1))
913 CLFR=HALF-AXSD(IXSD)
914 if (SDprint) &
915 & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)") &
916 & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot &
917 & ,1000.*QSAT,TCLD,.01*PMID(I,LL)
918 IF (CLFR .LT. CLFRmin) CLFR=H0
919 ENDIF !--- End IF (ARG .LE. XSDmin)
920 ENDIF !--- IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N)
921 CSMID(I,LL)=CLFR
922 255 CONTINUE !--- End DO L=1,LML
923 ENDDO !--- End DO I=MYIS,MYIE
924 !
925 !***********************************************************************
926 !****************** END OF GRID-SCALE CLOUD FRACTIONS ****************
927 !
928 !--- COMPUTE CONVECTIVE CLOUD COVER FOR RADIATION
929 !
930 !--- The parameterization of Slingo (1987, QJRMS, Table 1, p. 904) is
931 ! used for convective cloud fraction as a function of precipitation
932 ! rate. Cloud fractions have been increased by 20% for each rainrate
933 ! interval so that shallow, nonprecipitating convection is ascribed a
934 ! constant cloud fraction of 0.1 (Ferrier, Feb '02).
935 !***********************************************************************
936 !
937 IF (CNCLD) THEN
938 DO I=MYIS,MYIE
939 !
940 !*** CLOUD TOPS AND BOTTOMS COME FROM CUCNVC
941 ! Convective clouds need to be at least 2 model layers thick
942 !
943 IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) THEN
944 !--- Compute convective cloud fractions if appropriate (Ferrier, Feb '02)
945 CLFR=CC(1)
946 PMOD=CUPPT(I,J)*CONVPRATE
947 IF (PMOD .GT. PPT(1)) THEN
948 DO NC=1,10
949 IF(PMOD.GT.PPT(NC)) NMOD=NC
950 ENDDO
951 IF (NMOD .GE. 10) THEN
952 CLFR=CC(10)
953 ELSE
954 CC1=CC(NMOD)
955 CC2=CC(NMOD+1)
956 P1=PPT(NMOD)
957 P2=PPT(NMOD+1)
958 CLFR=CC1+(CC2-CC1)*(PMOD-P1)/(P2-P1)
959 ENDIF !--- End IF (NMOD .GE. 10) ...
960 CLFR=MIN(H1, CLFR)
961 ENDIF !--- End IF (PMOD .GT. PPT(1)) ...
962 !
963 !*** ADD LVL TO BE CONSISTENT WITH OTHER WORKING ARRAYS
964 !
965 LVLIJ=LVL(I,J)
966 LCNVT=NINT(CUTOP(I,J))+LVLIJ
967 LCNVT=MIN(LM,LCNVT)
968 LCNVB=NINT(CUBOT(I,J))+LVLIJ
969 LCNVB=MIN(LM,LCNVB)
970 !! !
971 !! !---- For debugging
972 !! !
973 !! WRITE(6,"(2(A,I3),2(A,I2),2(A,F5.2),2(A,I2),A,F6.4)")
974 !! & ' J=',J,' I=',I,' LCNVB=',LCNVB,' LCNVT=',LCNVT
975 !! &, ' CUBOT=',CUBOT(I,J),' CUTOP=',CUTOP(I,J)
976 !! &,' LVL=',LVLIJ,' LMH=',LMH(I,J),' CCMID=',CLFR
977 !! !
978 !
979 !--- Build in small amounts of subgrid-scale convective condensate
980 ! (simple assumptions), but only if the convective cloud fraction
981 ! exceeds that of the grid-scale cloud fraction
982 !
983 DO LL=LCNVT,LCNVB
984 ARG=MAX(H0, H1-CSMID(I,LL))
985 CCMID(I,LL)=MIN(ARG,CLFR)
986 ENDDO !--- End DO LL=LCNVT,LCNVB
987 ENDIF !--- IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) ...
988 ENDDO !--- End DO I loop
989 ENDIF !--- End IF (CNCLD) ...
990 !
991 !*********************************************************************
992 !*************** END OF CONVECTIVE CLOUD FRACTIONS *****************
993 !*********************************************************************
994 !***
995 !*** DETERMINE THE FRACTIONAL CLOUD COVERAGE FOR HIGH, MID
996 !*** AND LOW OF CLOUDS FROM THE CLOUD COVERAGE AT EACH LEVEL
997 !***
998 !*** NOTE: THIS IS FOR DIAGNOSTICS ONLY!!!
999 !***
1000 !***
1001 DO 500 I=MYIS,MYIE
1002 !!
1003 DO L=0,LM
1004 CLDAMT(L)=0.
1005 ENDDO
1006 !!
1007 !!*** NOW GOES LOW, MIDDLE, HIGH
1008 !!
1009 DO 480 NLVL=1,3
1010 CLDMAX=0.
1011 MALVL=LM
1012 LLTOP=LM+1-LTOP(NLVL)+LVL(I,J)
1013 !!***
1014 !!*** GO TO THE NEXT CLOUD LAYER IF THE TOP OF THE CLOUD-TYPE IN
1015 !!*** QUESTION IS BELOW GROUND OR IS IN THE LOWEST LAYER ABOVE GROUND.
1016 !!***
1017 IF(LLTOP.GE.LM)GO TO 480
1018 !!
1019 IF(NLVL.GT.1)THEN
1020 LLBOT=LM+1-LTOP(NLVL-1)-1+LVL(I,J)
1021 LLBOT=MIN(LLBOT,LM1)
1022 ELSE
1023 LLBOT=LM1
1024 ENDIF
1025 !!
1026 DO 435 L=LLTOP,LLBOT
1027 CLDAMT(L)=AMAX1(CSMID(I,L),CCMID(I,L))
1028 IF(CLDAMT(L).GT.CLDMAX)THEN
1029 MALVL=L
1030 CLDMAX=CLDAMT(L)
1031 ENDIF
1032 435 CONTINUE
1033 !!*********************************************************************
1034 !! NOW, CALCULATE THE TOTAL CLOUD FRACTION IN THIS PRESSURE DOMAIN
1035 !! USING THE METHOD DEVELOPED BY Y.H., K.A.C. AND A.K. (NOV., 1992).
1036 !! IN THIS METHOD, IT IS ASSUMED THAT SEPERATED CLOUD LAYERS ARE
1037 !! RADOMLY OVERLAPPED AND ADJACENT CLOUD LAYERS ARE MAXIMUM OVERLAPPED.
1038 !! VERTICAL LOCATION OF EACH TYPE OF CLOUD IS DETERMINED BY THE THICKEST
1039 !! CONTINUING CLOUD LAYERS IN THE DOMAIN.
1040 !!*********************************************************************
1041 CL1=0.0
1042 CL2=0.0
1043 KBT1=LLBOT
1044 KBT2=LLBOT
1045 KTH1=0
1046 KTH2=0
1047 !!
1048 DO 450 LL=LLTOP,LLBOT
1049 L=LLBOT-LL+LLTOP
1050 BIT1=.FALSE.
1051 CR1=CLDAMT(L)
1052 BITX=(PINT(I,L).GE.PTOPC(NLVL+1)).AND. &
1053 & (PINT(I,L).LT.PTOPC(NLVL)).AND. &
1054 & (CLDAMT(L).GT.0.0)
1055 BIT1=BIT1.OR.BITX
1056 IF(.NOT.BIT1)GO TO 450
1057 !!***
1058 !!*** BITY=T: FIRST CLOUD LAYER; BITZ=T:CONSECUTIVE CLOUD LAYER
1059 !!*** NOTE: WE ASSUME THAT THE THICKNESS OF EACH CLOUD LAYER IN THE
1060 !!*** DOMAIN IS LESS THAN 200 MB TO AVOID TOO MUCH COOLING OR
1061 !!*** HEATING. SO WE SET CTHK(NLVL)=200*E2. BUT THIS LIMIT MAY
1062 !!*** WORK WELL FOR CONVECTIVE CLOUDS. MODIFICATION MAY BE
1063 !!*** NEEDED IN THE FUTURE.
1064 !!***
1065 BITY=BITX.AND.(KTH2.LE.0)
1066 BITZ=BITX.AND.(KTH2.GT.0)
1067 !!
1068 IF(BITY)THEN
1069 KBT2=L
1070 KTH2=1
1071 ENDIF
1072 !!
1073 IF(BITZ)THEN
1074 KTOP1=KBT2-KTH2+1
1075 DPCL=PMID(I,KBT2)-PMID(I,KTOP1)
1076 IF(DPCL.LT.CTHK(NLVL))THEN
1077 KTH2=KTH2+1
1078 ELSE
1079 KBT2=KBT2-1
1080 ENDIF
1081 ENDIF
1082 IF(BITX)CL2=AMAX1(CL2,CR1)
1083 !!***
1084 !!*** AT THE DOMAIN BOUNDARY OR SEPARATED CLD LAYERS, RANDOM OVERLAP.
1085 !!*** CHOOSE THE THICKEST OR THE LARGEST FRACTION AMT AS THE CLD
1086 !!*** LAYER IN THAT DOMAIN.
1087 !!***
1088 BIT2=.FALSE.
1089 BITY=BITX.AND.(CLDAMT(L-1).LE.0.0.OR. &
1090 PINT(I,L-1).LT.PTOPC(NLVL+1))
1091 BITZ=BITY.AND.CL1.GT.0.0
1092 BITW=BITY.AND.CL1.LE.0.0
1093 BIT2=BIT2.OR.BITY
1094 IF(.NOT.BIT2)GO TO 450
1095 !!
1096 IF(BITZ)THEN
1097 KBT1=INT((CL1*KBT1+CL2*KBT2)/(CL1+CL2))
1098 KTH1=INT((CL1*KTH1+CL2*KTH2)/(CL1+CL2))+1
1099 CL1=CL1+CL2-CL1*CL2
1100 ENDIF
1101 !!
1102 IF(BITW)THEN
1103 KBT1=KBT2
1104 KTH1=KTH2
1105 CL1=CL2
1106 ENDIF
1107 !!
1108 IF(BITY)THEN
1109 KBT2=LLBOT
1110 KTH2=0
1111 CL2=0.0
1112 ENDIF
1113 450 CONTINUE
1114 !
1115 CLDCFR(I,NLVL)=AMIN1(1.0,CL1)
1116 MTOP(I,NLVL)=MIN(KBT1,KBT1-KTH1+1)
1117 MBOT(I,NLVL)=KBT1
1118 480 CONTINUE
1119 500 CONTINUE
1121 !***
1122 !*** SET THE UN-NEEDED TAUDAR TO ONE
1123 !***
1124 DO I=MYIS,MYIE
1125 TAUDAR(I)=1.0
1126 ENDDO
1127 !----------------------------------------------------------------------
1128 ! NOW, CALCULATE THE CLOUD RADIATIVE PROPERTIES AFTER DAVIS (1982),
1129 ! HARSHVARDHAN ET AL (1987) AND Y.H., K.A.C. AND A.K. (1993).
1130 !
1131 ! UPDATE: THE FOLLOWING PARTS ARE MODIFIED, AFTER Y.T.H. (1994), TO
1132 ! CALCULATE THE RADIATIVE PROPERTIES OF CLOUDS ON EACH MODEL
1133 ! LAYER. BOTH CONVECTIVE AND STRATIFORM CLOUDS ARE USED
1134 ! IN THIS CALCULATIONS.
1135 !
1136 ! QINGYUN ZHAO 95-3-22
1137 !
1138 !----------------------------------------------------------------------
1139 !
1140 !***
1141 !*** INITIALIZE ARRAYS FOR USES LATER
1142 !***
1144 DO 600 I=MYIS,MYIE
1145 LML=LMH(I,J)
1146 LVLIJ=LVL(I,J)
1147 !
1148 !***
1149 !*** NOTE: LAYER=1 IS THE SURFACE, AND LAYER=2 IS THE FIRST CLOUD
1150 !*** LAYER ABOVE THE SURFACE AND SO ON.
1151 !***
1152 EMIS(I,1)=1.0
1153 KTOP(I,1)=LP1
1154 KBTM(I,1)=LP1
1155 CAMT(I,1)=1.0
1156 KCLD(I)=2
1157 !
1158 DO NBAND=1,NB
1159 RRCL(I,NBAND,1)=0.0
1160 TTCL(I,NBAND,1)=1.0
1161 ENDDO
1162 !
1163 DO 510 L=2,LP1
1164 CAMT(I,L)=0.0
1165 KTOP(I,L)=1
1166 KBTM(I,L)=1
1167 EMIS(I,L)=0.0
1168 !
1169 DO NBAND=1,NB
1170 RRCL(I,NBAND,L)=0.0
1171 TTCL(I,NBAND,L)=1.0
1172 ENDDO
1173 510 CONTINUE
1175 !### End changes so far
1176 !***
1177 !*** NOW CALCULATE THE AMOUNT, TOP, BOTTOM AND TYPE OF EACH CLOUD LAYER
1178 !*** CLOUD TYPE=1: STRATIFORM CLOUD
1179 !*** TYPE=2: CONVECTIVE CLOUD
1180 !*** WHEN BOTH CONVECTIVE AND STRATIFORM CLOUDS EXIST AT THE SAME POINT,
1181 !*** SELECT CONVECTIVE CLOUD WITH THE HIGHER CLOUD FRACTION.
1182 !*** CLOUD LAYERS ARE SEPARATED BY TOTAL ABSENCE OF CLOUDINESS.
1183 !*** NOTE: THERE IS ONLY ONE CONVECTIVE CLOUD LAYER IN ONE COLUMN.
1184 !*** KTOP AND KBTM ARE THE TOP AND BOTTOM OF EACH CLOUD LAYER IN TERMS
1185 !*** OF MODEL LEVEL.
1186 !***
1187 NEW_CLOUD=.TRUE.
1188 !
1189 DO L=2,LML
1190 LL=LML-L+1+LVLIJ !-- Model layer
1191 CLFR=MAX(CCMID(I,LL),CSMID(I,LL)) !-- Cloud fraction in layer
1192 CLFR1=MAX(CCMID(I,LL+1),CSMID(I,LL+1)) !-- Cloud fraction in lower layer
1193 !-------------------
1194 IF (CLFR .GE. CLFRMIN) THEN
1195 !--- Cloud present at level
1196 IF (NEW_CLOUD) THEN
1197 !--- New cloud layer
1198 IF(L==2.AND.CLFR1>=CLFRmin)THEN
1199 KBTM(I,KCLD(I))=LL+1
1200 CAMT(I,KCLD(I))=CLFR1
1201 ELSE
1202 KBTM(I,KCLD(I))=LL
1203 CAMT(I,KCLD(I))=CLFR
1204 ENDIF
1205 NEW_CLOUD=.FALSE.
1206 ELSE
1207 !--- Existing cloud layer
1208 CAMT(I,KCLD(I))=AMAX1(CAMT(I,KCLD(I)), CLFR)
1209 ENDIF ! End IF (NEW_CLOUD .EQ. 0) ...
1210 ELSE IF (CLFR1 .GE. CLFRMIN) THEN
1211 !--- Cloud is not present at level but did exist at lower level, then ...
1212 IF (L .EQ. 2) THEN
1213 !--- For the case of ground fog
1214 KBTM(I,KCLD(I))=LL+1
1215 CAMT(I,KCLD(I))=CLFR1
1216 ENDIF
1217 KTOP(I,KCLD(I))=LL+1
1218 NEW_CLOUD=.TRUE.
1219 KCLD(I)=KCLD(I)+1
1220 CAMT(I,KCLD(I))=0.0
1221 ENDIF
1222 !-------------------
1223 ENDDO !--- End DO L loop
1224 !***
1225 !*** THE REAL NUMBER OF CLOUD LAYERS IS (THE FIRST IS THE GROUND;
1226 !*** THE LAST IS THE SKY):
1227 !***
1228 NCLDS(I)=KCLD(I)-2
1229 NCLD=NCLDS(I)
1230 !***
1231 !*** NOW CALCULATE CLOUD RADIATIVE PROPERTIES
1232 !***
1233 IF(NCLD.GE.1)THEN
1234 !***
1235 !*** NOTE: THE FOLLOWING CALCULATIONS, THE UNIT FOR PRESSURE IS MB!!!
1236 !***
1237 DO 580 NC=2,NCLD+1
1238 !
1239 TauC=0. !--- Total optical depth for each cloud layer (solar & longwave)
1240 QSUM=0.0
1241 NKTP=LP1
1242 NBTM=0
1243 BITX=CAMT(I,NC).GE.CLFRMIN
1244 NKTP=MIN(NKTP,KTOP(I,NC))
1245 NBTM=MAX(NBTM,KBTM(I,NC))
1246 !
1247 DO LL=NKTP,NBTM
1248 IF(LL.GE.KTOP(I,NC).AND.LL.LE.KBTM(I,NC).AND.BITX)THEN
1249 PRS1=PINT(I,LL)*0.01
1250 PRS2=PINT(I,LL+1)*0.01
1251 DELP=PRS2-PRS1
1252 TCLD=TMID(I,LL)-T0C
1253 QSUM=QSUM+QMID(I,LL)*DELP*(PRS1+PRS2) &
1254 & /(120.1612*SQRT(TMID(I,LL)))
1255 !
1256 !***********************************************************************
1257 !**** IMPORTANT NOTES concerning input cloud optical properties ******
1258 !***********************************************************************
1259 !
1260 !--- The simple optical depth parameterization from eq. (1) of Harshvardhan
1261 ! et al. (1989, JAS, p. 1924; hereafter referred to as HRCD by authorship)
1262 ! is used for convective cloud properties with some simple changes.
1263 !
1264 !--- The optical depth Tau is Tau=CTau*DELP, where values of CTau are
1265 ! described below.
1266 ! 1) CTau=0.08*(Qc/Q0) for cloud water mixing ratio (Qc), where
1267 ! Q0 is assumed to be the threshold mixing ratio for "thick anvils",
1268 ! as noted in the 2nd paragraph after eq. (1) in Harshvardhan et al.
1269 ! (1989). A value of Q0=0.1 g/kg is assumed based on experience w/
1270 ! cloud observations, and it is intended only to be a crude scaling
1271 ! factor for "order of magnitude" effects. The functional dependence
1272 ! on mixing ratio is based on Stephens (1978, JAS, p. 2124, eq. 7).
1273 ! Result: CTau=800.*Qc => note that the "800." factor is referred to
1274 ! as an absorption coefficient
1275 ! 2) For an assumed value of Q0=1 g/kg for "thick anvils", then
1276 ! CTau=80.*Qc, or an absorption coefficient that is an order of
1277 ! magnitude less.
1278 ! => ABSCOEF_W can vary from 100. to 1000. !!
1279 ! 3) From p. 3105 of Dudhia (1989), values of
1280 ! 0.14 (m**2/g) * 1000 (g/kg) / 9.81 (m/s**2) = 14.27 /Pa
1281 ! => 14.27 (/Pa) * 100 (Pa/mb) = 1427 /mb
1282 ! 4) From Dudhia's SW radiation, ABSCOEF_W ~ 1000. after units conversion
1283 ! 5) Again from p. 3105 of Dudhia (1989), he notes that ice absorption
1284 ! coefficients are roughly half those of cloud water, it was decided
1285 ! to keep this simple and assume half that of water.
1286 ! => ABSCOEF_I=0.5*ABSCOEF_W
1287 !
1288 !--- For convection, the following is assumed:
1289 ! 1) A characteristic water/ice mixing ratio (Qconv)
1290 ! 2) A temperature threshold for water or ice (TRAD_ice)
1291 !
1292 !-----------------------------------------------------------------------
1293 !
1294 CTau=0.
1295 !-- For crude estimation of convective cloud optical depths
1296 IF (CCMID(I,LL) .GE. CLFRmin) THEN
1297 IF (TCLD .GE. TRAD_ice) THEN
1298 CTau=CTauCW !--- Convective cloud water
1299 ELSE
1300 CTau=CTauCI !--- Convective ice
1301 ENDIF
1302 ! CTau=CTau*CCMID(I,LL) !--- Reduce by convective cloud fraction
1303 ENDIF
1304 !
1305 !-- For crude estimation of grid-scale cloud optical depths
1306 !
1307 !-- => The following 2 lines were intended to reduce cloud optical depths further
1308 ! than what's parameterized in the NAM and what's theoretically justified
1309 ! CTau=CTau+CSMID(I,LL)* &
1310 ! & ( ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL) )
1311 CTau=CTau+ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL)
1312 TauC=TauC+DELP*CTau
1313 ENDIF !--- End IF(LL.GE.KTOP(I,NC) ....
1314 ENDDO !--- End DO LL
1315 !
1316 IF(BITX)EMIS(I,NC)=1.0-EXP(ABSCOEF_LW*TauC)
1317 IF(QSUM.GE.EPSQ1)THEN
1318 !
1319 DO 570 NBAND=1,NB
1320 IF(BITX)THEN
1321 PROD=ABCFF(NBAND)*QSUM
1322 DDX=TauC/(TauC+PROD)
1323 EEX=1.0-DDX
1324 IF(ABS(EEX).GE.1.E-8)THEN
1325 DD=DDX
1326 EE=EEX
1327 FF=1.0-DD*0.85
1328 AA=MIN(50.0,SQRT(3.0*EE*FF)*TauC)
1329 AA=EXP(-AA)
1330 BB=FF/EE
1331 GG=SQRT(BB)
1332 DD=(GG+1.0)*(GG+1.0)-(GG-1.0)*(GG-1.0)*AA*AA
1333 RRCL(I,NBAND,NC)=MAX(0.1E-5,(BB-1.0)*(1.0-AA*AA)/DD)
1334 TTCL(I,NBAND,NC)=AMAX1(0.1E-5,4.0*GG*AA/DD)
1335 ENDIF
1336 ENDIF
1337 570 CONTINUE
1338 ENDIF
1339 580 CONTINUE
1340 !
1341 ENDIF
1342 !
1343 600 CONTINUE
1344 !*********************************************************************
1345 !****************** COMPUTE OZONE AT MIDLAYERS *********************
1346 !*********************************************************************
1347 !
1348 !*** MODIFY PRESSURE AT THE TOP MODEL LAYER TO ACCOUNT FOR THE TOTAL
1349 !*** OZONE FROM MODEL TOP (PINT_1) TO THE TOP OF THE ATMOSPHERE (0 MB)
1350 !
1351 DO I=MYIS,MYIE
1352 FCTR=PINT(I,2)/(PINT(I,2)-PINT(I,1))
1353 POZN(I,1)=FCTR*(PMID(I,1)-PINT(I,1))
1354 ENDDO
1355 !
1356 CALL OZON2D(LM,POZN,XLAT,OZN, &
1357 MYIS,MYIE, &
1358 ids,ide, jds,jde, kds,kde, &
1359 ims,ime, jms,jme, kms,kme, &
1360 its,ite, jts,jte, kts,kte )
1361 !
1362 !***
1363 !*** NOW THE VARIABLES REQUIRED BY RADFS HAVE BEEN CALCULATED.
1364 !***
1365 !----------------------------------------------------------------------
1366 !***
1367 !*** CALL THE GFDL RADIATION DRIVER
1368 !***
1369 !***
1370 Jndx=J
1371 CALL RADFS &
1372 & (PSFC,PMID,PINT,QMID,TMID,OZN,TSKN,SLMSK,ALBEDO,XLAT &
1373 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
1374 &, CAMT,KTOP,KBTM,NCLDS,EMIS,RRCL,TTCL &
1375 &, COSZ,TAUDAR,1 &
1376 &, 1,0 &
1377 &, ITIMSW,ITIMLW &
1378 &, TENDS(ITS,KTS,J),TENDL(ITS,KTS,J) &
1379 &, FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC &
1380 &, ids,ide, jds,jde, kds,kde &
1381 &, ims,ime, jms,jme, kms,kme &
1382 ! begin debugging radiation
1383 &, its,ite, jts,jte, kts,kte &
1384 &, imd,jmd, Jndx )
1385 ! end debugging radiation
1386 !----------------------------------------------------------------------
1387 IF(LONG)THEN
1388 !
1389 !-- All fluxes in W/m**2
1390 !--- GLW => downward longwave at the surface (formerly RLWIN)
1391 !--- RLWTOA => outgoing longwave at the top of the atmosphere
1392 !-- Note: RLWOUT & SIGT4 have been removed because they are no longer being used!
1393 !
1394 DO I=MYIS,MYIE
1395 GLW(I,J)=FLWDNS(I)
1396 RLWTOA(I,J)=FLWUP(I)
1397 ENDDO
1398 ENDIF
1399 !
1400 IF(SHORT)THEN
1401 !
1402 !-- All fluxes in W/m**2
1403 !--- GSW => NET shortwave at the surface
1404 !--- RSWIN => incoming shortwave at the surface (all sky)
1405 !--- RSWINC => clear-sky incoming shortwave at the surface
1406 !--- RSWTOA => outgoing (reflected) shortwave at the top of the atmosphere
1407 !
1408 DO I=MYIS,MYIE
1409 GSW(I,J)=FSWDNS(I)-FSWUPS(I)
1410 RSWIN(I,J) =FSWDNS(I)
1411 RSWINC(I,J)=FSWDNSC(I)
1412 RSWTOA(I,J)=FSWUP(I)
1413 ENDDO
1414 ENDIF
1415 !
1416 !*** ARRAYS ACFRST AND ACFRCV ACCUMULATE AVERAGE STRATIFORM AND
1417 !*** CONVECTIVE CLOUD FRACTIONS, RESPECTIVELY.
1418 !*** ACCUMLATE THESE VARIABLES ONLY ONCE PER RADIATION CALL.
1419 !
1420 !*** ASSUME RANDOM OVERLAP BETWEEN LOW, MIDDLE, & HIGH LAYERS.
1421 !
1422 !*** UPDATE NEW 3D CLOUD FRACTION (CLDFRA)
1423 !
1424 DO I=MYIS,MYIE
1425 CFRACL(I,J)=CLDCFR(I,1)
1426 CFRACM(I,J)=CLDCFR(I,2)
1427 CFRACH(I,J)=CLDCFR(I,3)
1428 IF(CNCLD)THEN
1429 CFSmax=0. !-- Maximum cloud fraction (stratiform component)
1430 CFCmax=0. !-- Maximum cloud fraction (convective component)
1431 DO L=1,LMH(I,J)
1432 LL=L+LVL(I,J)
1433 CFSmax=MAX(CFSmax, CSMID(I,LL) )
1434 CFCmax=MAX(CFCmax, CCMID(I,LL) )
1435 ENDDO
1436 ACFRST(I,J)=ACFRST(I,J)+CFSmax
1437 NCFRST(I,J)=NCFRST(I,J)+1
1438 ACFRCV(I,J)=ACFRCV(I,J)+CFCmax
1439 NCFRCV(I,J)=NCFRCV(I,J)+1
1440 ELSE
1441 !--- Count only locations with grid-scale cloudiness, ignore convective clouds
1442 ! (option not used, but if so set to the total cloud fraction)
1443 CFRAVG=1.-(1.-CFRACL(I,J))*(1.-CFRACM(I,J))*(1.-CFRACH(I,J))
1444 ACFRST(I,J)=ACFRST(I,J)+CFRAVG
1445 NCFRST(I,J)=NCFRST(I,J)+1
1446 ENDIF
1447 !--- Flip 3D cloud fractions in the vertical and save time
1448 LML=LMH(I,J)
1449 DO L=1,LML
1450 LL=LML-L+1+LVL(I,J)
1451 CLDFRA(I,L,J)=MAX(CCMID(I,LL),CSMID(I,LL))
1452 ENDDO
1453 ENDDO !-- I index
1454 !***
1455 !*** THIS ROW IS FINISHED. GO TO NEXT
1456 !***
1457 ! *********************
1458 700 CONTINUE
1459 ! *********************
1460 !----------------------------------------------------------------------
1461 !***
1462 !*** CALLS TO RADIATION THIS TIME STEP ARE COMPLETE.
1463 !***
1464 !----------------------------------------------------------------------
1465 ! begin debugging radiation
1466 ! FSWrat=0.
1467 ! if (RSWIN(imd,jmd) .gt. 0.) &
1468 ! FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd)
1469 ! write(6,"(2a,2i5,7f9.2)") &
1470 ! '{rad3 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' &
1471 ! ,'ALBEDO,RSWOUT/RSWIN = '&
1472 ! ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd) &
1473 ! ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) &
1474 ! ,ALB(imd,jmd),FSWrat
1475 ! end debugging radiation
1476 !----------------------------------------------------------------------
1477 !
1478 !--- Need to save LW & SW tendencies since radiation calculates both and this block
1480 END SUBROUTINE RADTN
1482 !----------------------------------------------------------------------
1484 REAL FUNCTION GAUSIN(xsd)
1485 REAL, PARAMETER :: crit=1.e-3
1486 REAL A1,A2,RN,B1,B2,B3,SUM
1487 !
1488 ! This function calculate area under the Gaussian curve between mean
1489 ! and xsd # of standard deviation (03/22/2004 Hsin-mu Lin)
1490 !
1491 a1=xsd*RSQR
1492 a2=exp(-0.5*xsd**2)
1493 rn=1.
1494 b1=1.
1495 b2=1.
1496 b3=1.
1497 sum=1.
1498 do while (b2 .gt. crit)
1499 rn=rn+1.
1500 b2=xsd**2/(2.*rn-1.)
1501 b3=b1*b2
1502 sum=sum+b3
1503 b1=b3
1504 enddo
1505 GAUSIN=a1*a2*sum
1506 RETURN
1507 END FUNCTION GAUSIN
1509 !----------------------------------------------------------------------
1511 SUBROUTINE ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
1512 MYIS,MYIE,MYJS,MYJE, &
1513 IDS,IDE, JDS,JDE, KDS,KDE, &
1514 IMS,IME, JMS,JME, KMS,KME, &
1515 ITS,ITE, JTS,JTE, KTS,KTE )
1516 !----------------------------------------------------------------------
1517 IMPLICIT NONE
1518 !----------------------------------------------------------------------
1519 INTEGER, INTENT(IN) :: IDS,IDE, JDS,JDE, KDS,KDE , &
1520 IMS,IME, JMS,JME, KMS,KME , &
1521 ITS,ITE, JTS,JTE, KTS,KTE
1522 INTEGER, INTENT(IN) :: MYJS,MYJE,MYIS,MYIE
1524 REAL, INTENT(IN) :: TIMES
1525 REAL, INTENT(OUT) :: HOUR,DAYI
1526 INTEGER, INTENT(IN) :: IHRST
1528 INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
1529 REAL, INTENT(IN), DIMENSION(IMS:IME,JMS:JME) :: GLAT,GLON
1530 REAL, INTENT(OUT), DIMENSION(IMS:IME,JMS:JME) :: CZEN
1532 REAL, PARAMETER :: GSTC1=24110.54841,GSTC2=8640184.812866, &
1533 GSTC3=9.3104E-2,GSTC4=-6.2E-6, &
1534 PI=3.1415926,PI2=2.*PI,PIH=0.5*PI, &
1535 !#$ DEG2RD=1.745329E-2,OBLIQ=23.440*DEG2RD, &
1536 DEG2RD=3.1415926/180.,OBLIQ=23.440*DEG2RD, &
1537 ZEROJD=2451545.0
1539 REAL :: DAY,YFCTR,ADDDAY,STARTYR,DATJUL,DIFJD,SLONM, &
1540 ANOM,SLON,DEC,RA,DATJ0,TU,STIM0,SIDTIM,HRANG
1541 REAL :: HRLCL,SINALT
1542 INTEGER :: KMNTH,KNT,IDIFYR,J,I
1543 LOGICAL :: LEAP
1544 !-----------------------------------------------------------------------
1545 !-----------------------------------------------------------------------
1546 INTEGER :: MONTH (12)
1547 !-----------------------------------------------------------------------
1548 DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
1549 !***********************************************************************
1550 ! SAVE MONTH
1551 DAY=0.
1552 LEAP=.FALSE.
1553 IF(MOD(IDAT(3),4).EQ.0)THEN
1554 MONTH(2)=29
1555 LEAP=.TRUE.
1556 ENDIF
1557 IF(IDAT(1).GT.1)THEN
1558 KMNTH=IDAT(1)-1
1559 DO 10 KNT=1,KMNTH
1560 DAY=DAY+REAL(MONTH(KNT))
1561 10 CONTINUE
1562 ENDIF
1563 !***
1564 !*** CALCULATE EXACT NUMBER OF DAYS FROM BEGINNING OF YEAR TO
1565 !*** FORECAST TIME OF INTEREST
1566 !***
1567 DAY=DAY+REAL(IDAT(2)-1)+(REAL(IHRST)+TIMES/3600.)/24.
1568 DAYI=REAL(INT(DAY)+1)
1569 HOUR=(DAY-DAYI+1.)*24.
1570 YFCTR=2000.-IDAT(3)
1571 !-----------------------------------------------------------------------
1572 !***
1573 !*** FIND CELESTIAL LONGITUDE OF THE SUN THEN THE SOLAR DECLINATION AND
1574 !*** RIGHT ASCENSION.
1575 !***
1576 !-----------------------------------------------------------------------
1577 IDIFYR=IDAT(3)-2000
1578 !***
1579 !*** FIND JULIAN DATE OF START OF THE RELEVANT YEAR
1580 !*** ADDING IN LEAP DAYS AS NEEDED
1581 !***
1582 IF(IDIFYR.LT.0)THEN
1583 ADDDAY=REAL(IDIFYR/4)
1584 ELSE
1585 ADDDAY=REAL((IDIFYR+3)/4)
1586 ENDIF
1587 STARTYR=ZEROJD+IDIFYR*365.+ADDDAY-0.5
1588 !***
1589 !*** THE JULIAN DATE OF THE TIME IN QUESTION
1590 !***
1591 DATJUL=STARTYR+DAY
1592 !
1593 !*** DIFFERENCE OF ACTUAL JULIAN DATE FROM JULIAN DATE
1594 !*** AT 00H 1 January 2000
1595 !
1596 DIFJD=DATJUL-ZEROJD
1597 !
1598 !*** MEAN GEOMETRIC LONGITUDE OF THE SUN
1599 !
1600 SLONM=(280.460+0.9856474*DIFJD)*DEG2RD+YFCTR*PI2
1601 !
1602 !*** THE MEAN ANOMOLY
1603 !
1604 ANOM=(357.528+0.9856003*DIFJD)*DEG2RD
1605 !
1606 !*** APPARENT GEOMETRIC LONGITUDE OF THE SUN
1607 !
1608 SLON=SLONM+(1.915*SIN(ANOM)+0.020*SIN(2.*ANOM))*DEG2RD
1609 IF(SLON.GT.PI2)SLON=SLON-PI2
1610 !
1611 !*** DECLINATION AND RIGHT ASCENSION
1612 !
1613 DEC=ASIN(SIN(SLON)*SIN(OBLIQ))
1614 RA=ACOS(COS(SLON)/COS(DEC))
1615 IF(SLON.GT.PI)RA=PI2-RA
1616 !***
1617 !*** FIND THE GREENWICH SIDEREAL TIME THEN THE LOCAL SOLAR
1618 !*** HOUR ANGLE.
1619 !***
1620 DATJ0=STARTYR+DAYI-1.
1621 TU=(DATJ0-2451545.)/36525.
1622 STIM0=GSTC1+TU*(GSTC2+GSTC3*TU+GSTC4*TU*TU)
1623 SIDTIM=STIM0/3600.+YFCTR*24.+1.00273791*HOUR
1624 SIDTIM=SIDTIM*15.*DEG2RD
1625 IF(SIDTIM.LT.0.)SIDTIM=SIDTIM+PI2
1626 IF(SIDTIM.GT.PI2)SIDTIM=SIDTIM-PI2
1627 HRANG=SIDTIM-RA
1628 !
1629 DO 100 J=MYJS,MYJE
1630 DO 100 I=MYIS,MYIE
1631 ! HRLCL=HRANG-GLON(I,J)
1632 HRLCL=HRANG+GLON(I,J)+PI2
1633 !***
1634 !*** THE ZENITH ANGLE IS THE COMPLEMENT OF THE ALTITUDE THUS THE
1635 !*** COSINE OF THE ZENITH ANGLE EQUALS THE SINE OF THE ALTITUDE.
1636 !***
1637 SINALT=SIN(DEC)*SIN(GLAT(I,J))+COS(DEC)*COS(HRLCL)* &
1638 COS(GLAT(I,J))
1639 IF(SINALT.LT.0.)SINALT=0.
1640 CZEN(I,J)=SINALT
1641 100 CONTINUE
1642 !***
1643 !*** IF THE FORECAST IS IN A DIFFERENT YEAR THAN THE START TIME,
1644 !*** RESET DAYI TO THE PROPER DAY OF THE NEW YEAR (IT MUST NOT BE
1645 !*** RESET BEFORE THE SOLAR ZENITH ANGLE IS COMPUTED).
1646 !***
1647 IF(DAYI.GT.365.)THEN
1648 IF(.NOT.LEAP)THEN
1649 DAYI=DAYI-365.
1650 ELSEIF(LEAP.AND.DAYI.GT.366.)THEN
1651 DAYI=DAYI-366.
1652 ENDIF
1653 ENDIF
1654 !
1655 END SUBROUTINE ZENITH
1656 !-----------------------------------------------------------------------
1658 SUBROUTINE OZON2D (LK,POZN,XLAT,QO3, &
1659 MYIS,MYIE, &
1660 ids,ide, jds,jde, kds,kde, &
1661 ims,ime, jms,jme, kms,kme, &
1662 its,ite, jts,jte, kts,kte )
1663 !----------------------------------------------------------------------
1664 IMPLICIT NONE
1665 !----------------------------------------------------------------------
1666 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
1667 ims,ime, jms,jme, kms,kme , &
1668 its,ite, jts,jte, kts,kte
1669 INTEGER, INTENT(IN) :: LK,MYIS,MYIE
1670 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: POZN
1671 REAL, INTENT(IN), DIMENSION(its:ite) :: XLAT
1672 REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte) :: QO3
1673 !----------------------------------------------------------------------
1674 INTEGER, PARAMETER :: NL=81,NLP1=NL+1,LNGTH=37*NL
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)*TEMP(I,K)*TEMP(I,K)
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 !***
5595 !*** REQUIRED INPUT:
5596 !***
5597 (QS,PP,PPI,QQH2O,TT,O3QO3,TSFC,SLMSK,ALBEDO,XLAT &
5598 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
5599 , CAMT,KTOP,KBTM,NCLDS,EMCLD,RRCL,TTCL &
5600 , COSZRO,TAUDAR,IBEG &
5601 , KO3,KALB &
5602 , ITIMSW,ITIMLW &
5603 !***************************************************************************
5604 !* IX IS THE LENGTH OF A ROW IN THE DOMAIN
5605 !
5606 !* QS(IX): THE SURFACE PRESSURE (PA)
5607 !* PP(IX,L): THE MIDLAYER PRESSURES (PA) (L IS THE VERT. DIMEN.)
5608 !* PPI(IX,LP1) THE INTERFACE PRESSURES (PA)
5609 !* QQH2O(IX,L): THE MIDLAYER WATER VAPOR MIXING RATIO (KG/KG)
5610 !* TT(IX,L): THE MIDLAYER TEMPERATURE (K)
5611 !* O3QO3(IX,L): THE MIDLAYER OZONE MIXING RATIO
5612 !* TSFC(IX): THE SKIN TEMP. (K); NEGATIVE OVER WATER
5613 !* SLMSK(IX): THE SEA MASK (LAND=0,SEA=1)
5614 !* ALBEDO(IX): THE SURFACE ALBEDO (EXPRESSED AS A FRACTION)
5615 !* XLAT(IX): THE GEODETIC LATITUDES OF EACH COLUMN IN DEGREES
5616 !* (N.H.> 0)
5617 !* THE FOLLOWING ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
5618 !* LAYER=1:SURFACE
5619 !* LAYER=2:FIRST LAYER ABOVE GROUND, AND SO ON
5620 !* CAMT(IX,LP1): CLOUD FRACTION OF EACH CLOUD LAYER
5621 !* ITYP(IX,LP1): CLOUD TYPE(=1: STRATIFORM, =2:CONVECTIVE)
5622 !* KTOP(IX,LP1): HEIGHT OF CLOUD TOP OF EACH CLOUD LAYER (IN ETA LEVEL)
5623 !* KBTM(IX,LP1): BOTTOM OF EACH CLOUD LAYER
5624 !* NCLDS(IX): NUMBER OF CLOUD LAYERS
5625 !* EMCLD(IX,LP1): CLOUD EMISSIVITY
5626 !* RRCL(IX,NB,LP1) CLOUD REFLECTTANCES FOR SW SPECTRAL BANDS
5627 !* TTCL(IX,NB,LP1) CLOUD TRANSMITANCES FOR SW SPECTRAL BANDS
5628 !* THE ABOVE ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
5629 !*
5630 !* COSZRO(IX): THE COSINE OF THE SOLAR ZENITH ANGLE
5631 !* TAUDAR: =1.0
5632 !* IBEG: =1
5633 !* KO3: =1 ( READ IN THE QZONE DATA)
5634 !* KALB: =0
5635 !* ITIMSW: =1/0 (SHORTWAVE CALC. ARE DESIRED/NOT DESIRED)
5636 !* ITIMLW: =1/0 (LONGWAVE CALC. ARE DESIRED/NOT DESIRED)
5637 !************************************************************************
5638 !***
5639 !*** GENERATED OUTPUT REQUIRED BY THE ETA MODEL
5640 !***
5641 , SWH,HLW &
5642 , FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC &
5643 , ids,ide, jds,jde, kds,kde &
5644 , ims,ime, jms,jme, kms,kme &
5645 ! begin debugging radiation
5646 , its,ite, jts,jte, kts,kte &
5647 , imd,jmd, Jndx )
5648 ! end debugging radiation
5649 !************************************************************************
5650 !* SWH: ATMOSPHERIC SHORTWAVE HEATING RATES IN K/S.
5651 !* SWH IS A REAL ARRAY DIMENSIONED (NCOL X LM).
5652 !* HLW: ATMOSPHERIC LONGWAVE HEATING RATES IN K/S.
5653 !* HLW IS A REAL ARRAY DIMENSIONED (NCOL X LM).
5654 !* FLWUP: UPWARD LONGWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5655 !* FLWUP IS A REAL ARRAY DIMENSIONED (NCOL).
5656 !* FSWUP: UPWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5657 !* FSWUP IS A REAL ARRAY DIMENSIONED (NCOL).
5658 !* FSWDN: DOWNWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5659 !* FSWDN IS A REAL ARRAY DIMENSIONED (NCOL).
5660 !* FSWDNS: DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5661 !* FSWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
5662 !* FSWUPS: UPWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5663 !* FSWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
5664 !* FLWDNS: DOWNWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
5665 !* FLWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
5666 !* FLWUPS: UPWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
5667 !* FLWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
5668 !* FSWDNSC: CLEAR-SKY DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5669 !* FSWDNSC IS A REAL ARRAY DIMENSIONED (NCOL).
5670 !************************************************************************
5671 !***
5672 !*** THE FOLLOWING OUTPUTS ARE NOT REQUIRED BY THE ETA MODEL
5673 !***
5674 !----------------------------------------------------------------------
5675 IMPLICIT NONE
5676 !----------------------------------------------------------------------
5677 !INTEGER, PARAMETER :: NBLY=15
5678 INTEGER, PARAMETER :: NB=12
5679 INTEGER, PARAMETER :: NBLX=47
5680 INTEGER , PARAMETER:: NBLW = 163
5682 REAL,PARAMETER :: AMOLWT=28.9644
5683 REAL,PARAMETER :: CSUBP=1.00484E7
5684 REAL,PARAMETER :: DIFFCTR=1.66
5685 REAL,PARAMETER :: G=980.665
5686 REAL,PARAMETER :: GINV=1./G
5687 REAL,PARAMETER :: GRAVDR=980.0
5688 REAL,PARAMETER :: O3DIFCTR=1.90
5689 REAL,PARAMETER :: P0=1013250.
5690 REAL,PARAMETER :: P0INV=1./P0
5691 REAL,PARAMETER :: GP0INV=GINV*P0INV
5692 REAL,PARAMETER :: P0XZP2=202649.902
5693 REAL,PARAMETER :: P0XZP8=810600.098
5694 REAL,PARAMETER :: P0X2=2.*1013250.
5695 REAL,PARAMETER :: RADCON=8.427
5696 REAL,PARAMETER :: RADCON1=1./8.427
5697 REAL,PARAMETER :: RATCO2MW=1.519449738
5698 REAL,PARAMETER :: RATH2OMW=.622
5699 REAL,PARAMETER :: RGAS=8.3142E7
5700 REAL,PARAMETER :: RGASSP=8.31432E7
5701 REAL,PARAMETER :: SECPDA=8.64E4
5702 !
5703 !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
5704 ! ARRANGED IN DECREASING ORDER
5705 REAL,PARAMETER :: HUNDRED=100.
5706 REAL,PARAMETER :: HNINETY=90.
5707 REAL,PARAMETER :: HNINE=9.0
5708 REAL,PARAMETER :: SIXTY=60.
5709 REAL,PARAMETER :: FIFTY=50.
5710 REAL,PARAMETER :: TEN=10.
5711 REAL,PARAMETER :: EIGHT=8.
5712 REAL,PARAMETER :: FIVE=5.
5713 REAL,PARAMETER :: FOUR=4.
5714 REAL,PARAMETER :: THREE=3.
5715 REAL,PARAMETER :: TWO=2.
5716 REAL,PARAMETER :: ONE=1.
5717 REAL,PARAMETER :: HAF=0.5
5718 REAL,PARAMETER :: QUARTR=0.25
5719 REAL,PARAMETER :: ZERO=0.
5720 !
5721 !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
5722 ! ARRANGED IN DECREASING ORDER
5723 REAL,PARAMETER :: H83E26=8.3E26
5724 REAL,PARAMETER :: H71E26=7.1E26
5725 REAL,PARAMETER :: H1E15=1.E15
5726 REAL,PARAMETER :: H1E13=1.E13
5727 REAL,PARAMETER :: H1E11=1.E11
5728 REAL,PARAMETER :: H1E8=1.E8
5729 REAL,PARAMETER :: H2E6=2.0E6
5730 REAL,PARAMETER :: H1E6=1.0E6
5731 REAL,PARAMETER :: H69766E5=6.97667E5
5732 REAL,PARAMETER :: H4E5=4.E5
5733 REAL,PARAMETER :: H165E5=1.65E5
5734 REAL,PARAMETER :: H5725E4=57250.
5735 REAL,PARAMETER :: H488E4=48800.
5736 REAL,PARAMETER :: H1E4=1.E4
5737 REAL,PARAMETER :: H24E3=2400.
5738 REAL,PARAMETER :: H20788E3=2078.8
5739 REAL,PARAMETER :: H2075E3=2075.
5740 REAL,PARAMETER :: H18E3=1800.
5741 REAL,PARAMETER :: H1224E3=1224.
5742 REAL,PARAMETER :: H67390E2=673.9057
5743 REAL,PARAMETER :: H5E2=500.
5744 REAL,PARAMETER :: H3082E2=308.2
5745 REAL,PARAMETER :: H3E2=300.
5746 REAL,PARAMETER :: H2945E2=294.5
5747 REAL,PARAMETER :: H29316E2=293.16
5748 REAL,PARAMETER :: H26E2=260.0
5749 REAL,PARAMETER :: H25E2=250.
5750 REAL,PARAMETER :: H23E2=230.
5751 REAL,PARAMETER :: H2E2=200.0
5752 REAL,PARAMETER :: H15E2=150.
5753 REAL,PARAMETER :: H1386E2=138.6
5754 REAL,PARAMETER :: H1036E2=103.6
5755 REAL,PARAMETER :: H8121E1=81.21
5756 REAL,PARAMETER :: H35E1=35.
5757 REAL,PARAMETER :: H3116E1=31.16
5758 REAL,PARAMETER :: H28E1=28.
5759 REAL,PARAMETER :: H181E1=18.1
5760 REAL,PARAMETER :: H18E1=18.
5761 REAL,PARAMETER :: H161E1=16.1
5762 REAL,PARAMETER :: H16E1=16.
5763 REAL,PARAMETER :: H1226E1=12.26
5764 REAL,PARAMETER :: H9P94=9.94
5765 REAL,PARAMETER :: H6P08108=6.081081081
5766 REAL,PARAMETER :: H3P6=3.6
5767 REAL,PARAMETER :: H3P5=3.5
5768 REAL,PARAMETER :: H2P9=2.9
5769 REAL,PARAMETER :: H2P8=2.8
5770 REAL,PARAMETER :: H2P5=2.5
5771 REAL,PARAMETER :: H1P8=1.8
5772 REAL,PARAMETER :: H1P4387=1.4387
5773 REAL,PARAMETER :: H1P41819=1.418191
5774 REAL,PARAMETER :: H1P4=1.4
5775 REAL,PARAMETER :: H1P25892=1.258925411
5776 REAL,PARAMETER :: H1P082=1.082
5777 REAL,PARAMETER :: HP816=0.816
5778 REAL,PARAMETER :: HP805=0.805
5779 REAL,PARAMETER :: HP8=0.8
5780 REAL,PARAMETER :: HP60241=0.60241
5781 REAL,PARAMETER :: HP602409=0.60240964
5782 REAL,PARAMETER :: HP6=0.6
5783 REAL,PARAMETER :: HP526315=0.52631579
5784 REAL,PARAMETER :: HP518=0.518
5785 REAL,PARAMETER :: HP5048=0.5048
5786 REAL,PARAMETER :: HP3795=0.3795
5787 REAL,PARAMETER :: HP369=0.369
5788 REAL,PARAMETER :: HP26=0.26
5789 REAL,PARAMETER :: HP228=0.228
5790 REAL,PARAMETER :: HP219=0.219
5791 REAL,PARAMETER :: HP166666=.166666
5792 REAL,PARAMETER :: HP144=0.144
5793 REAL,PARAMETER :: HP118666=0.118666192
5794 REAL,PARAMETER :: HP1=0.1
5795 ! (NEGATIVE EXPONENTIALS BEGIN HERE)
5796 REAL,PARAMETER :: H658M2=0.0658
5797 REAL,PARAMETER :: H625M2=0.0625
5798 REAL,PARAMETER :: H44871M2=4.4871E-2
5799 REAL,PARAMETER :: H44194M2=.044194
5800 REAL,PARAMETER :: H42M2=0.042
5801 REAL,PARAMETER :: H41666M2=0.0416666
5802 REAL,PARAMETER :: H28571M2=.02857142857
5803 REAL,PARAMETER :: H2118M2=0.02118
5804 REAL,PARAMETER :: H129M2=0.0129
5805 REAL,PARAMETER :: H1M2=.01
5806 REAL,PARAMETER :: H559M3=5.59E-3
5807 REAL,PARAMETER :: H3M3=0.003
5808 REAL,PARAMETER :: H235M3=2.35E-3
5809 REAL,PARAMETER :: H1M3=1.0E-3
5810 REAL,PARAMETER :: H987M4=9.87E-4
5811 REAL,PARAMETER :: H323M4=0.000323
5812 REAL,PARAMETER :: H3M4=0.0003
5813 REAL,PARAMETER :: H285M4=2.85E-4
5814 REAL,PARAMETER :: H1M4=0.0001
5815 REAL,PARAMETER :: H75826M4=7.58265E-4
5816 REAL,PARAMETER :: H6938M5=6.938E-5
5817 REAL,PARAMETER :: H394M5=3.94E-5
5818 REAL,PARAMETER :: H37412M5=3.7412E-5
5819 REAL,PARAMETER :: H15M5=1.5E-5
5820 REAL,PARAMETER :: H1439M5=1.439E-5
5821 REAL,PARAMETER :: H128M5=1.28E-5
5822 REAL,PARAMETER :: H102M5=1.02E-5
5823 REAL,PARAMETER :: H1M5=1.0E-5
5824 REAL,PARAMETER :: H7M6=7.E-6
5825 REAL,PARAMETER :: H4999M6=4.999E-6
5826 REAL,PARAMETER :: H451M6=4.51E-6
5827 REAL,PARAMETER :: H25452M6=2.5452E-6
5828 REAL,PARAMETER :: H1M6=1.E-6
5829 REAL,PARAMETER :: H391M7=3.91E-7
5830 REAL,PARAMETER :: H1174M7=1.174E-7
5831 REAL,PARAMETER :: H8725M8=8.725E-8
5832 REAL,PARAMETER :: H327M8=3.27E-8
5833 REAL,PARAMETER :: H257M8=2.57E-8
5834 REAL,PARAMETER :: H1M8=1.0E-8
5835 REAL,PARAMETER :: H23M10=2.3E-10
5836 REAL,PARAMETER :: H14M10=1.4E-10
5837 REAL,PARAMETER :: H11M10=1.1E-10
5838 REAL,PARAMETER :: H1M10=1.E-10
5839 REAL,PARAMETER :: H83M11=8.3E-11
5840 REAL,PARAMETER :: H82M11=8.2E-11
5841 REAL,PARAMETER :: H8M11=8.E-11
5842 REAL,PARAMETER :: H77M11=7.7E-11
5843 REAL,PARAMETER :: H72M11=7.2E-11
5844 REAL,PARAMETER :: H53M11=5.3E-11
5845 REAL,PARAMETER :: H48M11=4.8E-11
5846 REAL,PARAMETER :: H44M11=4.4E-11
5847 REAL,PARAMETER :: H42M11=4.2E-11
5848 REAL,PARAMETER :: H37M11=3.7E-11
5849 REAL,PARAMETER :: H35M11=3.5E-11
5850 REAL,PARAMETER :: H32M11=3.2E-11
5851 REAL,PARAMETER :: H3M11=3.0E-11
5852 REAL,PARAMETER :: H28M11=2.8E-11
5853 REAL,PARAMETER :: H24M11=2.4E-11
5854 REAL,PARAMETER :: H23M11=2.3E-11
5855 REAL,PARAMETER :: H2M11=2.E-11
5856 REAL,PARAMETER :: H18M11=1.8E-11
5857 REAL,PARAMETER :: H15M11=1.5E-11
5858 REAL,PARAMETER :: H14M11=1.4E-11
5859 REAL,PARAMETER :: H114M11=1.14E-11
5860 REAL,PARAMETER :: H11M11=1.1E-11
5861 REAL,PARAMETER :: H1M11=1.E-11
5862 REAL,PARAMETER :: H96M12=9.6E-12
5863 REAL,PARAMETER :: H93M12=9.3E-12
5864 REAL,PARAMETER :: H77M12=7.7E-12
5865 REAL,PARAMETER :: H74M12=7.4E-12
5866 REAL,PARAMETER :: H65M12=6.5E-12
5867 REAL,PARAMETER :: H62M12=6.2E-12
5868 REAL,PARAMETER :: H6M12=6.E-12
5869 REAL,PARAMETER :: H45M12=4.5E-12
5870 REAL,PARAMETER :: H44M12=4.4E-12
5871 REAL,PARAMETER :: H4M12=4.E-12
5872 REAL,PARAMETER :: H38M12=3.8E-12
5873 REAL,PARAMETER :: H37M12=3.7E-12
5874 REAL,PARAMETER :: H3M12=3.E-12
5875 REAL,PARAMETER :: H29M12=2.9E-12
5876 REAL,PARAMETER :: H28M12=2.8E-12
5877 REAL,PARAMETER :: H24M12=2.4E-12
5878 REAL,PARAMETER :: H21M12=2.1E-12
5879 REAL,PARAMETER :: H16M12=1.6E-12
5880 REAL,PARAMETER :: H14M12=1.4E-12
5881 REAL,PARAMETER :: H12M12=1.2E-12
5882 REAL,PARAMETER :: H8M13=8.E-13
5883 REAL,PARAMETER :: H46M13=4.6E-13
5884 REAL,PARAMETER :: H36M13=3.6E-13
5885 REAL,PARAMETER :: H135M13=1.35E-13
5886 REAL,PARAMETER :: H12M13=1.2E-13
5887 REAL,PARAMETER :: H1M13=1.E-13
5888 REAL,PARAMETER :: H3M14=3.E-14
5889 REAL,PARAMETER :: H15M14=1.5E-14
5890 REAL,PARAMETER :: H14M14=1.4E-14
5891 !
5892 !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
5893 ! ARRANGED IN DESCENDING ORDER
5894 REAL,PARAMETER :: HM2M2=-.02
5895 REAL,PARAMETER :: HM6666M2=-.066667
5896 REAL,PARAMETER :: HMP5=-0.5
5897 REAL,PARAMETER :: HMP575=-0.575
5898 REAL,PARAMETER :: HMP66667=-.66667
5899 REAL,PARAMETER :: HMP805=-0.805
5900 REAL,PARAMETER :: HM1EZ=-1.
5901 REAL,PARAMETER :: HM13EZ=-1.3
5902 REAL,PARAMETER :: HM19EZ=-1.9
5903 REAL,PARAMETER :: HM1E1=-10.
5904 REAL,PARAMETER :: HM1597E1=-15.97469413
5905 REAL,PARAMETER :: HM161E1=-16.1
5906 REAL,PARAMETER :: HM1797E1=-17.97469413
5907 REAL,PARAMETER :: HM181E1=-18.1
5908 REAL,PARAMETER :: HM8E1=-80.
5909 REAL,PARAMETER :: HM1E2=-100.
5910 !
5911 REAL,PARAMETER :: H1M16=1.0E-16
5912 REAL,PARAMETER :: H1M20=1.E-20
5913 REAL,PARAMETER :: Q19001=19.001
5914 REAL,PARAMETER :: DAYSEC=1.1574E-5
5915 REAL,PARAMETER :: HSIGMA=5.673E-8
5916 REAL,PARAMETER :: TWENTY=20.0
5917 REAL,PARAMETER :: HP537=0.537
5918 REAL,PARAMETER :: HP2=0.2
5919 REAL,PARAMETER :: RCO2=3.3E-4
5920 REAL,PARAMETER :: H3M6=3.0E-6
5921 REAL,PARAMETER :: PI=3.1415927
5922 REAL,PARAMETER :: DEGRAD1=180.0/PI
5923 REAL,PARAMETER :: H74E1=74.0
5924 REAL,PARAMETER :: H15E1=15.0
5926 REAL, PARAMETER:: B0 = -.51926410E-4
5927 REAL, PARAMETER:: B1 = -.18113332E-3
5928 REAL, PARAMETER:: B2 = -.10680132E-5
5929 REAL, PARAMETER:: B3 = -.67303519E-7
5930 REAL, PARAMETER:: AWIDE = 0.309801E+01
5931 REAL, PARAMETER:: BWIDE = 0.495357E-01
5932 REAL, PARAMETER:: BETAWD = 0.347839E+02
5933 REAL, PARAMETER:: BETINW = 0.766811E+01
5936 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
5937 ims,ime, jms,jme, kms,kme , &
5938 its,ite, jts,jte, kts,kte
5939 INTEGER, INTENT(IN) :: IBEG,KO3,KALB,ITIMSW,ITIMLW
5940 !----------------------------------------------------------------------
5941 ! ****************************************************************
5942 ! * GENERALIZED FOR PLUG-COMPATIBILITY - *
5943 ! * ORIGINAL CODE WAS CLEANED-UP GFDL CODE...K.CAMPANA MAR89..*
5944 !......* EXAMPLE FOR MRF: *
5945 ! * KO3 =0 AND O3QO3=DUMMY ARRAY. (GFDL CLIMO O3 USED) *
5946 ! * KEMIS=0 AND HI CLD EMIS COMPUTED HERE (CEMIS=DUMMY INPUT)*
5947 ! * KALB =0 AND SFC ALBEDO OVER OPEN WATER COMPUTED BELOW... *
5948 ! * KCCO2=0,CO2 OBTAINED FROM BLOCK DATA *
5949 ! * =1,CO2 COMPUTED IN HERE --- NOT AVAILABLE YET... *
5950 ! * UPDATED FOR YUTAI HOU SIB SW RADIATION....KAC 6 MAR 92 *
5951 ! * OCEAN ALBEDO FOR BEAM SET TO BULK SFCALB, SINCE *
5952 ! * COSINE ZENITH ANGLE EFFECTS ALREADY THERE(REF:PAYNE) *
5953 ! * SLMSK = 0. *
5954 ! * SNOW ICE ALBEDO FOR BEAM NOT ENHANCED VIA COSINE ZENITH *
5955 ! * ANGLE EITHER CAUSE VALU ALREADY HIGH (WE SEE POLAR *
5956 ! * COOLING IF WE DO BEAM CALCULATION)....KAC 17MAR92 *
5957 ! * ALBEDO GE .5 *
5958 ! * UPDATED TO OBTAIN CLEAR SKY FLUXES "ON THE FLY" FOR *
5959 ! * CLOUD FORCING DIAGNOSTICS ELSEWHERE...KAC 7AUG92 *
5960 ! * SEE ##CLR LINES...RADFS,LWR88,FST88,SPA88 ....... *
5961 ! * UPDATED FOR USE NEW CLD SCHEME ......YH DEC 92 *
5962 ! * INPUT CLD MAY BE AS ORIGINAL IN 3 DOMAIN (CLD,MTOP,MBOT) *
5963 ! * OR IN A VERTICAL ARRAY OF 18 MDL LAYERS (CLDARY) *
5964 ! * IEMIS=0 USE THE ORG. CLD EMIS SCHEME *
5965 ! * =1 USE TEMP DEP. CLD EMIS SCHEME *
5966 ! * UPDATED TO COMPUTE CLD LAYER REFLECTTANCE AND TRANSMITTANCE *
5967 ! * INPUT CLD EMISSIVITY AND OPTICAL THICKNESS 'EMIS0,TAUC0' *
5968 ! * ......YH FEB 93 *
5969 ! ****************************************************************
5970 !--------------------------------
5971 ! INTEGER, PARAMETER:: LNGTH=37*kte
5972 !--------------------------------
5974 ! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D
5976 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: PP,TT
5977 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: QQH2O
5978 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: PPI,CAMT,EMCLD
5979 REAL, INTENT(IN), DIMENSION(its:ite):: QS,TSFC,SLMSK,ALBEDO,XLAT
5980 REAL, INTENT(IN), DIMENSION(its:ite):: COSZRO,TAUDAR
5981 REAL, INTENT(OUT), DIMENSION(its:ite):: FLWUPS
5982 INTEGER, INTENT(IN), DIMENSION(its:ite):: NCLDS
5983 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: KTOP,KBTM
5984 REAL, INTENT(INOUT), DIMENSION(its:ite,NB,kts:kte+1):: TTCL,RRCL
5985 REAL, intent(IN), DIMENSION(its:ite,kts:kte):: O3QO3
5986 ! REAL, INTENT(IN), DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW
5987 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
5989 ! REAL, DIMENSION(its:ite)::ALVBR,ALNBR, ALVDR,ALNDR
5991 ! TABLE ???
5993 REAL, DIMENSION(3) :: BO3RND,AO3RND
5994 REAL, DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
5995 BCOMB,BETACM
5997 DATA AO3RND / 0.543368E+02, 0.234676E+04, 0.384881E+02/
5998 DATA BO3RND / 0.526064E+01, 0.922424E+01, 0.496515E+01/
6000 DATA ACOMB / &
6001 0.152070E+05, 0.332194E+04, 0.527177E+03, 0.163124E+03, &
6002 0.268808E+03, 0.534591E+02, 0.268071E+02, 0.123133E+02, &
6003 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, &
6004 0.178110E-01, 0.170166E+00, 0.537083E-02/
6005 DATA BCOMB / &
6006 0.152538E+00, 0.118677E+00, 0.103660E+00, 0.100119E+00, &
6007 0.127518E+00, 0.118409E+00, 0.904061E-01, 0.642011E-01, &
6008 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, &
6009 0.875182E-01, 0.857907E-01, 0.214005E+00/
6010 DATA APCM / &
6011 -0.671879E-03, 0.654345E-02, 0.143657E-01, 0.923593E-02, &
6012 0.117022E-01, 0.159596E-01, 0.181600E-01, 0.145013E-01, &
6013 0.170062E-01, 0.233303E-01, 0.256735E-01, 0.274745E-01, &
6014 0.279259E-01, 0.197002E-01, 0.349782E-01/
6015 DATA BPCM / &
6016 -0.113520E-04, -0.323965E-04, -0.448417E-04, -0.230779E-04, &
6017 -0.361981E-04, -0.145117E-04, 0.198349E-04, -0.486529E-04, &
6018 -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, &
6019 -0.982953E-04, -0.772497E-04, -0.748263E-04/
6020 DATA ATPCM / &
6021 -0.106346E-02, 0.641531E-02, 0.137362E-01, 0.922513E-02, &
6022 0.136162E-01, 0.169791E-01, 0.206959E-01, 0.166223E-01, &
6023 0.171776E-01, 0.229724E-01, 0.275530E-01, 0.302731E-01, &
6024 0.281662E-01, 0.199525E-01, 0.370962E-01/
6025 DATA BTPCM / &
6026 -0.735731E-05, -0.294149E-04, -0.505592E-04, -0.280894E-04, &
6027 -0.492972E-04, -0.341508E-04, -0.362947E-04, -0.250487E-04, &
6028 -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, &
6029 -0.933645E-04, -0.664045E-04, -0.115290E-03/
6030 DATA BETACM / &
6031 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
6032 0.188625E+03, 0.144293E+03, 0.174098E+03, 0.909366E+02, &
6033 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, &
6034 0.589554E+01, 0.495227E+01, 0.000000E+00/
6037 ! *********************************************
6038 !====> * OUTPUT TO CALLING PROGRAM *
6039 ! *********************************************
6041 REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte)::SWH,HLW
6042 REAL, INTENT(OUT), DIMENSION(its:ite):: FSWUP,FSWUPS,FSWDN, &
6043 FSWDNS,FLWUP,FLWDNS,FSWDNSC
6045 ! *********************************************
6046 !====> * POSSIBLE OUTPUT TO CALLING PROGRAM *
6047 ! *********************************************
6049 REAL, DIMENSION(its:ite):: GDFVBR,GDFNBR,GDFVDR,GDFNDR
6051 ! ************************************************************
6052 !====> * ARRAYS NEEDED BY SWR91SIB..FOR CLEAR SKY DATA(EG.FSWL) *
6053 ! ************************************************************
6055 REAL, DIMENSION(its:ite,kts:kte+1)::FSWL,HSWL,UFL,DFL
6057 ! ******************************************************
6058 !====> * ARRAYS NEEDED BY CLO88, LWR88, SWR89 OR SWR91SIB *
6059 ! ******************************************************
6061 REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1)::CLDFAC
6062 REAL, DIMENSION(its:ite,kts:kte+1)::EQCMT,PRESS,TEMP,FSW,HSW,UF,DF
6063 REAL, DIMENSION(its:ite,kts:kte)::RH2O,QO3,HEATRA
6064 REAL, DIMENSION(its:ite):: COSZEN,TAUDA,GRNFLX,TOPFLX,GRDFLX
6065 REAL, DIMENSION(kts:kte+1)::PHALF
6066 !..... ADD PRESSURE INTERFACE
6068 REAL, DIMENSION(NB) :: ABCFF,PWTS
6070 DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190., &
6071 989.,2706.,39011./
6072 DATA PWTS/.5000,.121416,.0698,.1558,.0631,.0362,.0243,.0158,.0087, &
6073 .001467,.002342,.001075/
6075 REAL :: CFCO2,CFO3,REFLO3,RRAYAV
6077 DATA CFCO2,CFO3/508.96,466.64/
6078 DATA REFLO3/1.9/
6079 DATA RRAYAV/0.144/
6081 ! *********************************************
6082 !====> * VECTOR TEMPORARIES FOR CLOUD CALC. *
6083 ! *********************************************
6085 REAL, DIMENSION(its:ite):: TTHAN
6086 REAL, DIMENSION(its:ite,kts:kte):: DO3V,DO3VP
6087 INTEGER, DIMENSION(its:ite):: JJROW
6089 !====> **************************************************************
6090 !-- SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN
6091 ! CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE).
6092 ! DEFINED AS 5 DEG LAT MEANS N.P.->S.P.
6093 ! COMMON /SAVMEM/ &
6094 !- ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL.....
6095 ! DDUO3N(37,L), DDO3N2(37,L), DDO3N3(37,L), DDO3N4(37,L)
6097 REAL, DIMENSION(37,kte) :: DDUO3N,DDO3N2,DDO3N3,DDO3N4
6099 !====> **************************************************************
6100 !
6101 REAL, DIMENSION(21,20) :: ALBD
6102 REAL, DIMENSION(20) :: ZA
6103 REAL, DIMENSION(21) :: TRN
6104 REAL, DIMENSION(19) :: DZA
6106 REAL :: YEAR,TPI,SSOLAR,DATE,TH2,ZEN,DZEN,ALB1,ALB2
6107 INTEGER :: IR,IQ,JX
6108 DATA TRN/.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60,.65, &
6109 .70,.75,.80,.85,.90,.95,1.00/
6111 REAL :: ALB11(21,7),ALB22(21,7),ALB33(21,6)
6113 EQUIVALENCE (ALB11(1,1),ALBD(1,1)),(ALB22(1,1),ALBD(1,8)), &
6114 (ALB33(1,1),ALBD(1,15))
6115 DATA ALB11/ .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, &
6116 .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, &
6117 .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, &
6118 .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, &
6119 .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, &
6120 .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, &
6121 .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, &
6122 .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, &
6123 .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, &
6124 .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, &
6125 .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, &
6126 .246,.235,.222,.211,.205,.200/
6127 DATA ALB22/ .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, &
6128 .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, &
6129 .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, &
6130 .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, &
6131 .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, &
6132 .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, &
6133 .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, &
6134 .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, &
6135 .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, &
6136 .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, &
6137 .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, &
6138 .058,.055,.054,.053,.052,.052/
6139 DATA ALB33/ .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, &
6140 .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, &
6141 .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, &
6142 .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, &
6143 .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, &
6144 .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, &
6145 .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, &
6146 .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, &
6147 .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, &
6148 .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025/
6149 DATA ZA/90.,88.,86.,84.,82.,80.,78.,76.,74.,70.,66.,62.,58.,54., &
6150 50.,40.,30.,20.,10.,0.0/
6151 DATA DZA/8*2.0,6*4.0,5*10.0/
6153 ! ***********************************************************
6154 !
6156 REAL, DIMENSION(its:ite) :: ALVB,ALNB,ALVD,ALND, &
6157 GDFVB, &
6158 GDFNB,GDFVD,GDFND, &
6159 SFCALB
6161 REAL :: RRVCO2,RRCO2,TDUM
6162 REAL :: ALBD0,ALVD1,ALND1
6163 INTEGER :: N
6164 !
6165 !*** The following two lines are for debugging.
6166 integer :: imd,jmd, Jndx
6167 real :: FSWrat,FSWrat1,FSWDNS1
6168 !***
6170 !====> BEGIN HERE .......................
6171 !
6172 !--- SSOLAR IS THE SOLAR CONSTANT SCALED TO A MORE CURRENT VALUE;
6173 ! I.E. IF SOLC=2.0 LY/MIN THEN SSOLAR=1.96 LY/MIN.
6174 REAL,PARAMETER :: H196=1.96
6176 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
6177 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
6179 L=kte
6180 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
6181 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
6182 LLM2 = LL-2; LLM1=LL-1
6183 MYIS=its; MYIE=ite
6185 !******ZHAO
6186 ! NOTE: XLAT IS IN DEGREE HERE
6187 !*****ZHAO
6188 !-- Formerly => SOLC=2./(R1*R1), SSOLAR=0.98*SOLC
6189 SSOLAR=H196/(R1*R1)
6190 !*********************************************************
6191 ! Special note: The solar constant is reduced extra 3 percent to account
6192 ! for the lack of aerosols in the shortwave radiation
6193 ! parameterization. Q. Zhao 96-7-23
6194 ! ### May also be due not accounting for reduction in solar constant due to
6195 ! absorption by ozone above the top of the model domain (Ferrier, Apr-2005)
6196 !*********************************************************
6197 SSOLAR=SSOLAR*0.97
6198 !
6199 DO 40 I=MYIS,MYIE
6200 IR = I + IBEG - 1
6201 TH2=HP2*XLAT(IR)
6202 JJROW(I)=Q19001-TH2
6203 TTHAN(I)=(19-JJROW(I))-TH2
6204 !..... NOTE THAT THE NMC VARIABLES ARE IN MKS (THUS PRESSURE IS IN
6205 ! CENTIBARS)WHILE ALL GFDL VARIABLES ARE IN CGS UNITS
6206 SFCALB(I) = ALBEDO(IR)
6207 !..... NOW PUT SFC TEMP,PRESSURES, ZENITH ANGLE INTO SW COMMON BLOCK...
6208 !***ZHAO
6209 ! NOTE: ALL PRESSURES INPUT FROM THE ETA MODEL ARE IN PA
6210 ! THE UNIT FOR PRESS IS MICRO BAR
6211 ! SURFACE TEMPERATURE ARE NEGATIVE OVER OCEANS IN THE ETA MODEL
6212 !***ZHAO
6213 PRESS(I,LP1)=QS(IR)*10.0
6214 TEMP(I,LP1)=ABS(TSFC(IR))
6215 COSZEN(I) = COSZRO(IR)
6216 TAUDA(I) = TAUDAR(IR)
6217 40 CONTINUE
6218 !***ZHAO
6219 !..... ALL GFDL VARIABLES HAVE K=1 AT THE TOP OF THE ATMOSPHERE.NMC
6220 ! ETA MODEL HAS THE SAME STRUCTURE
6221 !***ZHAO
6222 DO 50 K=1,L
6223 DO 50 I=MYIS,MYIE
6224 IR = I + IBEG - 1
6225 !..... NOW PUT TEMP,PRESSURES, INTO SW COMMON BLOCK..........
6226 TEMP(I,K) = TT(IR,K)
6227 PRESS(I,K) = 10.0 * PP(IR,K)
6228 !.... STORE LYR MOISTURE AND ADD TO SW COMMON BLOCK
6229 RH2O(I,K)=QQH2O(IR,K)
6230 IF(RH2O(I,K).LT.H3M6) RH2O(I,K)=H3M6
6231 50 CONTINUE
6232 !... *************************
6233 IF (KO3.EQ.0) GO TO 65
6234 !... *************************
6235 DO 60 K=1,L
6236 DO 60 I=MYIS,MYIE
6237 QO3(I,K) = O3QO3(I+IBEG-1,K)
6238 60 CONTINUE
6239 65 CONTINUE
6240 !... ************************************
6241 IF (KALB.GT.0) GO TO 110
6242 !... ************************************
6243 !..... THE FOLLOWING CODE GETS ALBEDO FROM PAYNE,1972 TABLES IF
6244 ! 1) OPEN SEA POINT (SLMSK=1);2) KALB=0
6245 IQ=INT(TWENTY*HP537+ONE)
6246 DO 105 I=MYIS,MYIE
6247 IF(COSZEN(I).GT.0.0 .AND. SLMSK(I+IBEG-1).GT.0.5) THEN
6248 ZEN=DEGRAD1*ACOS(MAX(COSZEN(I),0.0))
6249 IF(ZEN.GE.H74E1) JX=INT(HAF*(HNINETY-ZEN)+ONE)
6250 IF(ZEN.LT.H74E1.AND.ZEN.GE.FIFTY) &
6251 JX=INT(QUARTR*(H74E1-ZEN)+HNINE)
6252 IF(ZEN.LT.FIFTY) JX=INT(HP1*(FIFTY-ZEN)+H15E1)
6253 DZEN=-(ZEN-ZA(JX))/DZA(JX)
6254 ALB1=ALBD(IQ,JX)+DZEN*(ALBD(IQ,JX+1)-ALBD(IQ,JX))
6255 ALB2=ALBD(IQ+1,JX)+DZEN*(ALBD(IQ+1,JX+1)-ALBD(IQ+1,JX))
6256 SFCALB(I)=ALB1+TWENTY*(ALB2-ALB1)*(HP537-TRN(IQ))
6257 ENDIF
6258 105 CONTINUE
6259 110 CONTINUE
6260 ! **********************************
6261 IF (KO3.GT.0) GO TO 135
6262 ! **********************************
6263 !.... COMPUTE CLIMATOLOGICAL ZONAL MEAN OZONE,
6264 !.... SEASONAL AND SPATIAL INTERPOLATION DONE BELOW.
6265 DO 125 I=MYIS,MYIE
6267 PHALF(1)=0.
6268 PHALF(LP1)=PPI(I,kme)
6269 DO K=1,LM1
6270 PHALF(K+1)=PP(I,K) ! AETA(K)*PDIF+PT ! BSF index was erroneously L
6271 ENDDO
6273 CALL O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, &
6274 ids,ide, jds,jde, kds,kde, &
6275 ims,ime, jms,jme, kms,kme, &
6276 its,ite, jts,jte, kts,kte )
6278 DO 130 K=1,L
6279 DO3V(I,K) = DDUO3N(JJROW(I),K) + RSIN1*DDO3N2(JJROW(I),K) &
6280 +RCOS1*DDO3N3(JJROW(I),K) &
6281 +RCOS2*DDO3N4(JJROW(I),K)
6282 DO3VP(I,K) = DDUO3N(JJROW(I)+1,K) + RSIN1*DDO3N2(JJROW(I)+1,K) &
6283 +RCOS1*DDO3N3(JJROW(I)+1,K) &
6284 +RCOS2*DDO3N4(JJROW(I)+1,K)
6285 !... NOW LATITUDINAL INTERPOLATION, AND
6286 ! CONVERT O3 INTO MASS MIXING RATIO(ORIGINAL DATA MPY BY 1.E4)
6287 QO3(I,K) = H1M4 * (DO3V(I,K)+TTHAN(I)*(DO3VP(I,K)-DO3V(I,K)))
6288 130 CONTINUE
6289 125 CONTINUE
6290 135 CONTINUE
6291 !.............
6292 DO 195 I=MYIS,MYIE
6293 !..... VISIBLE AND NEAR IR DIFFUSE ALBEDO
6294 ALVD(I) = SFCALB(I)
6295 ALND(I) = SFCALB(I)
6296 !..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO
6297 ALVB(I) = SFCALB(I)
6298 ALNB(I) = SFCALB(I)
6299 !
6300 !--- Remove diurnal variation of land surface albedos (Ferrier, 6/28/05)
6301 !--- Turn back on to mimic NAM 8/17/05
6302 !
6303 !..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO,IF NOT OCEAN NOR SNOW
6304 ! ..FUNCTION OF COSINE SOLAR ZENITH ANGLE..
6305 IF (SLMSK(I+IBEG-1).LT.0.5) THEN
6306 IF (SFCALB(I).LE.0.5) THEN
6307 ALBD0 = -18.0 * (0.5 - ACOS(COSZEN(I))/PI)
6308 ALBD0 = EXP (ALBD0)
6309 ALVD1 = (ALVD(I) - 0.054313) / 0.945687
6310 ALND1 = (ALND(I) - 0.054313) / 0.945687
6311 ALVB(I) = ALVD1 + (1.0 - ALVD1) * ALBD0
6312 ALNB(I) = ALND1 + (1.0 - ALND1) * ALBD0
6313 !-- Put in an upper limit on beam albedos
6314 ALVB(I) = MIN(0.5,ALVB(I))
6315 ALNB(I) = MIN(0.5,ALNB(I))
6316 END IF
6317 END IF
6318 195 CONTINUE
6319 !.....SURFACE VALUES OF RRCL AND TTCL
6320 DO 200 N=1,2
6321 DO 200 I=MYIS,MYIE
6322 RRCL(I,N,1)=ALVD(I)
6323 TTCL(I,N,1)=ZERO
6324 200 CONTINUE
6325 DO 220 N=3,NB
6326 DO 220 I=MYIS,MYIE
6327 RRCL(I,N,1)=ALND(I)
6328 TTCL(I,N,1)=ZERO
6329 220 CONTINUE
6330 !... **************************
6331 !... * END OF CLOUD SECTION *
6332 !... **************************
6333 !... THE FOLLOWING CODE CONVERTS RRVCO2,THE VOLUME MIXING RATIO OF CO2
6334 ! INTO RRCO2,THE MASS MIXING RATIO.
6335 RRVCO2=RCO2
6336 RRCO2=RRVCO2*RATCO2MW
6337 250 IF(ITIMLW .EQ. 0) GO TO 300
6338 !
6339 ! ***********************
6340 !====> * LONG WAVE RADIATION *
6341 ! ***********************
6342 !
6343 !.... ACCOUNT FOR REDUCED EMISSIVITY OF ANY CLDS
6344 DO 240 K=1,LP1
6345 DO 240 I=MYIS,MYIE
6346 EQCMT(I,K)=CAMT(I,K)*EMCLD(I,K)
6347 240 CONTINUE
6348 !.... GET CLD FACTOR FOR LW CALCULATIONS
6349 !....
6351 ! shuhua
6353 CALL CLO89(CLDFAC,EQCMT,NCLDS,KBTM,KTOP, &
6354 ids,ide, jds,jde, kds,kde, &
6355 ims,ime, jms,jme, kms,kme, &
6356 its,ite, jts,jte, kts,kte )
6358 ! shuhua
6359 !===> LONG WAVE RADIATION
6360 ! CALL LWR88(HEATRA,GRNFLX,TOPFLX, &
6361 ! PRESS,TEMP,RH2O,QO3,CLDFAC, &
6362 ! EQCMT,NCLDS,KTOP,KBTM, &
6363 !
6364 !! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
6365 ! BO3RND,AO3RND, &
6366 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
6367 ! ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
6368 ! GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
6369 ! P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
6370 ! TEN,HP1,FOUR,HM1EZ,SKO3R, &
6371 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
6372 ! HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
6373 ! RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, &
6374 ! ids,ide, jds,jde, kds,kde, &
6375 ! ims,ime, jms,jme, kms,kme, &
6376 ! its,ite, jts,jte, kts,kte )
6378 CALL LWR88(HEATRA,GRNFLX,TOPFLX, &
6379 PRESS,TEMP,RH2O,QO3,CLDFAC, &
6380 EQCMT,NCLDS,KTOP,KBTM, &
6381 !
6382 ! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
6383 BO3RND,AO3RND, &
6384 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
6385 ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
6386 GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
6387 P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
6388 TEN,HP1,FOUR,HM1EZ, &
6389 RADCON,QUARTR,TWO, &
6390 HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
6391 RADCON1,H16E1, H28E1,H44194M2,H1P41819, &
6392 ids,ide, jds,jde, kds,kde, &
6393 ims,ime, jms,jme, kms,kme, &
6394 its,ite, jts,jte, kts,kte )
6396 !....
6397 !================================================================================
6398 !--- IMPORTANT!! Y.-T Hou advised Ferrier, Mitchell, & Ek on 7/28/05 to use
6399 ! the following algorithm, because the GFDL code calculates NET longwave flux
6400 ! (GRNFLX, Up - Down) as its fundamental quantity.
6401 !
6402 ! 1. Calculate upward LW at surface (FLWUPS)
6403 ! 2. Calculate downward LW at surface (FLWDNS) = FLWUPS - .001*GRNFLX
6404 !
6405 !--- Note: The following fluxes must be multipled by .001 to convert to mks
6406 ! => GRNFLX, or GRound Net FLuX
6407 ! => TOPFLX, or top of the atmosphere fluxes (FLWUP)
6408 !
6409 !--- IMPORTANT!! If the surface emissivity (SFCEMS) differs from 1.0, then
6410 ! uncomment the line below starting with "!BSF"
6411 !================================================================================
6412 DO 280 I=MYIS,MYIE
6413 IR = I + IBEG - 1
6414 FLWUP(IR) = .001*TOPFLX(I)
6415 ! TDUM=TEMP(I,LP1)
6416 !--- Use an average of the skin & lowest model level temperature
6417 TDUM=.5*(TEMP(I,LP1)+TEMP(I,L))
6418 FLWUPS(IR)=HSIGMA*TDUM*TDUM*TDUM*TDUM
6419 !BSF FLWUPS(IR)=SFCEMS*HSIGMA*TDUM*TDUM*TDUM*TDUM
6420 FLWDNS(IR)=FLWUPS(IR)-.001*GRNFLX(I)
6421 280 CONTINUE
6422 !.... Average LW heating/cooling rates over the lowest 2 atmospheric layers,
6423 ! which may be necessary for when dealing with thin layers near the surface
6424 DO I=MYIS,MYIE
6425 TDUM=.5*(HEATRA(I,L)+HEATRA(I,LM1))
6426 HEATRA(I,L)=TDUM
6427 HEATRA(I,LM1)=TDUM
6428 ENDDO
6429 !.... CONVERT HEATING RATES TO DEG/SEC
6430 DO 290 K=1,L
6431 DO 290 I=MYIS,MYIE
6432 HLW(I+IBEG-1,K)=HEATRA(I,K)*DAYSEC
6433 290 CONTINUE
6434 300 CONTINUE
6435 IF(ITIMSW .EQ. 0) GO TO 350
6436 !SW
6437 CALL SWR93(FSW,HSW,UF,DF,FSWL,HSWL,UFL,DFL, &
6438 PRESS,COSZEN,TAUDA,RH2O,RRCO2,SSOLAR,QO3, &
6439 NCLDS,KTOP,KBTM,CAMT,RRCL,TTCL, &
6440 ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, &
6441 !
6442 ! UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2, &
6443 ABCFF,PWTS, &
6444 H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219, &
6445 HP816,RRAYAV,GINV,CFCO2,CFO3, &
6446 TWO,H235M3,HP26,H129M2,H75826M4,H1036E2, &
6447 H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2, &
6448 H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON, &
6449 ids,ide, jds,jde, kds,kde, &
6450 ims,ime, jms,jme, kms,kme, &
6451 its,ite, jts,jte, kts,kte )
6453 !SW
6454 !
6455 !..... GET SW FLUXES IN WATTS/M**2
6456 DO 320 I=MYIS,MYIE
6457 IR = I + IBEG - 1
6458 FSWUP(IR) = UF(I,1) * 1.E-3
6459 FSWDN(IR) = DF(I,1) * 1.E-3
6460 FSWUPS(IR) = UF(I,LP1) * 1.E-3
6461 !-- FSWDNS is more accurate using array DF than summing the GDFxx arrays
6462 !C..COUPLE W/M2 DIFF, IF FSWDNS(IR)=DF(I,LP1)*1.#E-3
6463 !! FSWDNS(IR) = (GDFVB(I)+GDFNB(I)+GDFVD(I)+GDFND(I)) * 1.E-3
6464 FSWDNS(IR) = DF(I,LP1) * 1.E-3
6465 FSWDNSC(IR) = DFL(I,LP1) * 1.E-3
6466 !... DOWNWARD SFC FLUX FOR THE SIB PARAMETERATION
6467 !..... VISIBLE AND NEAR IR DIFFUSE
6468 GDFVDR(IR) = GDFVD(I) * 1.E-3
6469 GDFNDR(IR) = GDFND(I) * 1.E-3
6470 !..... VISIBLE AND NEAR IR DIRECT BEAM
6471 GDFVBR(IR) = GDFVB(I) * 1.E-3
6472 GDFNBR(IR) = GDFNB(I) * 1.E-3
6473 320 CONTINUE
6474 !.... CONVERT HEATING RATES TO DEG/SEC
6475 DO 330 K=1,L
6476 DO 330 I=MYIS,MYIE
6477 SWH(I+IBEG-1,K)=HSW(I,K)*DAYSEC
6478 330 CONTINUE
6479 350 CONTINUE
6480 ! begin debugging radiation
6482 ! if (Jndx .eq. jmd) then
6483 ! FSWDNS1=(GDFVB(imd)+GDFNB(imd)+GDFVD(imd)+GDFND(imd))*.001
6484 ! write(6,"(3a,2i5,7f9.2)") '{rad2 imd,Jndx,' &
6485 ! ,'GSW=FSWDNS-FSWUPS,RSWIN=FSWDNS,RSWIN_1=FSWDNS1,' &
6486 ! ,'FSWDNS-FSWDNS1,RSWOUT=FSWUPS,RSWINC=FSWDNSC,GLW=FLWDNS = ' &
6487 ! ,imd,Jndx, FSWDNS(imd)-FSWUPS(imd),FSWDNS(imd),FSWDNS1 &
6488 ! ,FSWDNS(imd)-FSWDNS1,FSWUPS(imd),FSWDNSC(imd),FLWDNS(imd)
6489 ! FSWrat=0.
6490 ! if (FSWDNS(imd) .ne. 0.) FSWrat=FSWUPS(imd)/FSWDNS(imd)
6491 ! FSWrat1=0.
6492 ! if (FSWDNS1 .ne. 0.) FSWrat1=FSWUPS(imd)/FSWDNS1
6493 ! write(6,"(2a,10f8.4)") '{rad2a ALBEDO,SFCALB,ALVD,ALND,ALVB,' &
6494 ! ,'ALNB,CZEN,SLMSK,FSWUPS/FSWDNS,FSWUPS/FSWDNS1 = ' &
6495 ! ,ALBEDO(imd),SFCALB(imd),ALVD(imd),ALND(imd),ALVB(imd) &
6496 ! ,ALNB(imd),COSZEN(imd),SLMSK(imd),FSWrat,FSWrat1
6497 ! endif
6498 ! end debugging radiation
6499 RETURN
6500 1000 FORMAT(1H ,' YOU ARE CALLING GFDL RADIATION CODE FOR',I5,' PTS', &
6501 'AND',I4,' LYRS,WITH KDAPRX,KO3,KCZ,KEMIS,KALB = ',5I2)
6503 END SUBROUTINE RADFS
6505 !-----------------------------------------------------------------------
6506 SUBROUTINE O3CLIM
6507 ! (XDUO3N,XDO3N2,XDO3N3,XDO3N4,PRGFDL, &
6508 ! ids,ide, jds,jde, kds,kde, &
6509 ! ims,ime, jms,jme, kms,kme, &
6510 ! its,ite, jts,jte, kts,kte )
6511 !----------------------------------------------------------------------
6512 IMPLICIT NONE
6513 !----------------------------------------------------------------------
6514 ! INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
6515 ! ims,ime, jms,jme, kms,kme , &
6516 ! its,ite, jts,jte, kts,kte
6518 ! ******************************************************************
6519 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
6520 ! . . .
6521 ! SUBPROGRAM: O3CLIM GENERATE SEASONAL OZONE DISTRIBUTION
6522 ! PRGRMMR: GFDL/CAMPANA ORG: W/NP22 DATE: ??-??-??
6523 !
6524 ! ABSTRACT:
6525 ! O3CLIM COMPUTES THE SEASONAL CLIMATOLOGY OF OZONE USING
6526 ! 81-LAYER DATA FROM GFDL.
6527 !
6528 ! PROGRAM HISTORY LOG:
6529 ! ??-??-?? GFDL/KC - ORIGINATOR
6530 ! 96-07-26 BLACK - MODIFIED FOR ETA MODEL
6531 !
6532 ! USAGE: CALL O3CLIM FROM SUBROUTINE RADTN
6533 ! INPUT ARGUMENT LIST:
6534 ! NONE
6535 !
6536 ! OUTPUT ARGUMENT LIST:
6537 ! NONE
6538 !
6539 ! OUTPUT FILES:
6540 ! NONE
6541 !
6542 ! SUBPROGRAMS CALLED:
6543 !
6544 ! UNIQUE:
6545 ! NONE
6546 !
6547 ! LIBRARY:
6548 ! NONE
6549 !
6550 ! COMMON BLOCKS: SEASO3
6551 ! O3DATA
6552 !
6553 ! ATTRIBUTES:
6554 ! LANGUAGE: FORTRAN 90
6555 ! MACHINE : IBM SP
6556 !$$$
6557 !----------------------------------------------------------------------
6558 ! INTEGER :: NL,NLP1,NLGTH,NKK,NK,NKP
6559 INTEGER, PARAMETER :: NL=81,NLP1=NL+1,NLGTH=37*NL,NKK=41,NK=81,NKP=NK+1
6560 !----------------------------------------------------------------------
6561 ! INCLUDE "SEASO3.comm"
6562 !---------------------------------------------------------------------
6563 ! REAL, INTENT(OUT), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
6564 ! REAL, INTENT(OUT), DIMENSION(NL) :: PRGFDL
6566 ! COMMON /SEASO3/
6567 ! ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL.....
6568 ! & XDUO3N(37,NL), XDO3N2(37,NL), XDO3N3(37,NL), XDO3N4(37,NL)
6569 !
6570 ! &,PRGFDL(NL)
6571 !---------------------------------------------------------------------
6572 REAL :: PH1(45),PH2(37),P1(48),P2(33),O3HI1(10,16),O3HI2(10,9) &
6573 ,O3LO1(10,16),O3LO2(10,16),O3LO3(10,16),O3LO4(10,16)
6574 !----------------------------------------------------------------------
6575 REAL :: AVG,A1,B1,B2
6576 INTEGER :: K,N,NCASE,IPLACE,KK,NKM,NKMM,KI,KQ,JJ,KEN,I,iindex,jindex
6577 !----------------------------------------------------------------------
6578 REAL :: PSTD(NL),TEMPN(19),O3O3(37,NL,4),O35DEG(37,NL) &
6579 ,XRAD1(NLGTH),XRAD2(NLGTH),XRAD3(NLGTH),XRAD4(NLGTH) &
6580 ,DDUO3N(19,NL),DUO3N(19,41) &
6581 ,RO3(10,41),RO3M(10,40),RO31(10,41),RO32(10,41) &
6582 ,O3HI(10,25) &
6583 ,RSTD(81),RBAR(NL),RDATA(81) &
6584 ,PHALF(NL),P(81),PH(82)
6585 REAL :: PXX(81),PYY(82) ! fix for nesting
6586 !----------------------------------------------------------------------
6587 !nesting EQUIVALENCE &
6588 !nesting (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
6589 !nesting ,(PH1(1),PH(1)),(PH2(1),PH(46)) &
6590 !nesting ,(P1(1),P(1)),(P2(1),P(49))
6591 EQUIVALENCE &
6592 (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
6593 ,(PH1(1),PYY(1)),(PH2(1),PYY(46)) & ! fix for nesting
6594 ,(P1(1),PXX(1)),(P2(1),PXX(49)) ! fix for nesting
6595 !----------------------------------------------------------------------
6596 ! EQUIVALENCE &
6597 ! (XRAD1(1),XDUO3N(1,1),O3O3(1,1,1)) &
6598 ! ,(XRAD2(1),XDO3N2(1,1)) &
6599 ! ,(XRAD3(1),XDO3N3(1,1)),(XRAD4(1),XDO3N4(1,1),)
6600 EQUIVALENCE &
6601 (XRAD1(1),O3O3(1,1,1)) &
6602 ,(XRAD2(1),O3O3(1,1,2)) &
6603 ,(XRAD3(1),O3O3(1,1,3)),(XRAD4(1),O3O3(1,1,4))
6604 !----------------------------------------------------------------------
6605 !---------------------------------------------------------------------
6606 DATA PH1/ 0., &
6607 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, &
6608 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, &
6609 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, &
6610 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, &
6611 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, &
6612 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, &
6613 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, &
6614 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, &
6615 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, &
6616 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, &
6617 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
6618 DATA PH2/ &
6619 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, &
6620 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, &
6621 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, &
6622 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, &
6623 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, &
6624 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, &
6625 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, &
6626 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, &
6627 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, &
6628 0.1000000E+01/
6629 DATA P1/ &
6630 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, &
6631 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, &
6632 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, &
6633 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, &
6634 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, &
6635 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, &
6636 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, &
6637 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, &
6638 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, &
6639 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, &
6640 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, &
6641 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
6642 DATA P2/ &
6643 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, &
6644 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, &
6645 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, &
6646 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, &
6647 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, &
6648 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, &
6649 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, &
6650 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, &
6651 0.1000000E+01/
6652 DATA O3HI1/ &
6653 .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, &
6654 .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, &
6655 .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, &
6656 .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, &
6657 .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, &
6658 .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, &
6659 .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, &
6660 .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, &
6661 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, &
6662 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, &
6663 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, &
6664 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, &
6665 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, &
6666 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, &
6667 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, &
6668 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/
6669 DATA O3HI2/ &
6670 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, &
6671 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, &
6672 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, &
6673 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, &
6674 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, &
6675 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, &
6676 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
6677 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, &
6678 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
6679 DATA O3LO1/ &
6680 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, &
6681 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, &
6682 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, &
6683 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, &
6684 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, &
6685 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, &
6686 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, &
6687 .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, &
6688 .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, &
6689 .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, &
6690 .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, &
6691 .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, &
6692 .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, &
6693 .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, &
6694 .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, &
6695 .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
6696 DATA O3LO2/ &
6697 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, &
6698 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, &
6699 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, &
6700 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, &
6701 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, &
6702 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, &
6703 .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, &
6704 .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, &
6705 .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, &
6706 .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, &
6707 .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, &
6708 .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, &
6709 .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, &
6710 .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, &
6711 .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, &
6712 .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
6713 DATA O3LO3/ &
6714 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, &
6715 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, &
6716 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, &
6717 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, &
6718 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, &
6719 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, &
6720 .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, &
6721 .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, &
6722 .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, &
6723 .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, &
6724 .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, &
6725 .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, &
6726 .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, &
6727 .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, &
6728 .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, &
6729 .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
6730 DATA O3LO4/ &
6731 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, &
6732 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, &
6733 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, &
6734 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, &
6735 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, &
6736 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, &
6737 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, &
6738 .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, &
6739 .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, &
6740 .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, &
6741 .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, &
6742 .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, &
6743 .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, &
6744 .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, &
6745 .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, &
6746 .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/
6747 !----------------------------------------------------------------------
6748 !***
6749 !*** COMPUTE DETAILED O3 PROFILE FROM THE ORIGINAL GFDL PRESSURES
6750 !*** WHERE OUTPUT FROM O3INT (PSTD) IS TOP DOWN IN MB*1.E3
6751 !*** AND PSFC=1013.25 MB ......K.A.C. DEC94
6752 !***
6753 DO K=1,NK
6754 ! PH(K)=PH(K)*1013250.
6755 ! P(K)=P(K)*1013250.
6756 PH(K)=PYY(K)*1013250. ! fix for nesting
6757 P(K)=PXX(K)*1013250. ! fix for nesting
6758 ENDDO
6759 !
6760 ! PH(NKP)=PH(NKP)*1013250.
6761 PH(NKP)=PYY(NKP)*1013250. ! fix for nesting
6762 !
6763 DO K=1,NL
6764 PSTD(K)=P(K)
6765 ENDDO
6766 !
6767 DO K=1,25
6768 DO N=1,10
6769 RO31(N,K)=O3HI(N,K)
6770 RO32(N,K)=O3HI(N,K)
6771 ENDDO
6772 ENDDO
6773 !----------------------------------------------------------------------
6774 DO 100 NCASE=1,4
6775 !
6776 !*** NCASE=1: SPRING (IN N.H.)
6777 !*** NCASE=2: FALL (IN N.H.)
6778 !*** NCASE=3: WINTER (IN N.H.)
6779 !*** NCASE=4: SUMMER (IN N.H.)
6780 !
6781 IPLACE=2
6782 IF(NCASE.EQ.2)IPLACE=4
6783 IF(NCASE.EQ.3)IPLACE=1
6784 IF(NCASE.EQ.4)IPLACE=3
6785 !
6786 IF(NCASE.EQ.1.OR.NCASE.EQ.2)THEN
6787 DO K=26,41
6788 DO N=1,10
6789 RO31(N,K)=O3LO1(N,K-25)
6790 RO32(N,K)=O3LO2(N,K-25)
6791 ENDDO
6792 ENDDO
6793 ENDIF
6794 !
6795 IF(NCASE.EQ.3.OR.NCASE.EQ.4)THEN
6796 DO K=26,41
6797 DO N=1,10
6798 RO31(N,K)=O3LO3(N,K-25)
6799 RO32(N,K)=O3LO4(N,K-25)
6800 ENDDO
6801 ENDDO
6802 ENDIF
6803 !
6804 DO 25 KK=1,NKK
6805 DO N=1,10
6806 DUO3N(N,KK)=RO31(11-N,KK)
6807 DUO3N(N+9,KK)=RO32(N,KK)
6808 ENDDO
6809 DUO3N(10,KK)=0.5*(RO31(1,KK)+RO32(1,KK))
6810 25 CONTINUE
6811 !
6812 !***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON
6813 !
6814 IF(NCASE.EQ.2.OR.NCASE.EQ.4)THEN
6815 DO 50 KK=1,NKK
6816 DO N=1,19
6817 TEMPN(N)=DUO3N(20-N,KK)
6818 ENDDO
6819 DO N=1,19
6820 DUO3N(N,KK)=TEMPN(N)
6821 ENDDO
6822 50 CONTINUE
6823 ENDIF
6824 !
6825 !*** DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON AT STD PRESSURE
6826 !*** LEVELS
6827 !
6828 !*** BEGIN LATITUDE (10 DEG) LOOP
6829 !
6830 DO 75 N=1,19
6831 !
6832 DO KK=1,NKK
6833 RSTD(KK)=DUO3N(N,KK)
6834 ENDDO
6835 !
6836 NKM=NK-1
6837 NKMM=NK-3
6838 !***
6839 !*** BESSELS HALF-POINT INTERPOLATION FORMULA
6840 !***
6841 DO K=4,NKMM,2
6842 KI=K/2
6843 RDATA(K)=0.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1) &
6844 -RSTD(KI)+RSTD(KI-1))/16.
6845 ENDDO
6846 !
6847 RDATA(2)=0.5*(RSTD(2)+RSTD(1))
6848 RDATA(NKM)=0.5*(RSTD(NKK)+RSTD(NKK-1))
6849 !
6850 !*** PUT UNCHANGED DATA INTO NEW ARRAY
6851 !
6852 DO K=1,NK,2
6853 KQ=(K+1)/2
6854 RDATA(K)=RSTD(KQ)
6855 ENDDO
6856 !
6857 DO KK=1,NL
6858 DDUO3N(N,KK)=RDATA(KK)*.01
6859 ENDDO
6860 !
6861 75 CONTINUE
6862 !
6863 !*** END OF LATITUDE LOOP
6864 !
6865 !----------------------------------------------------------------------
6866 !***
6867 !*** CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF
6868 !*** 10 DEG VALUES
6869 !***
6870 DO 90 KK=1,NL
6871 !
6872 DO N=1,19
6873 O35DEG(2*N-1,KK)=DDUO3N(N,KK)
6874 ENDDO
6875 !
6876 DO N=1,18
6877 O35DEG(2*N,KK)=0.5*(DDUO3N(N,KK)+DDUO3N(N+1,KK))
6878 ENDDO
6879 !
6880 90 CONTINUE
6881 !
6882 DO JJ=1,37
6883 DO KEN=1,NL
6884 O3O3(JJ,KEN,IPLACE)=O35DEG(JJ,KEN)
6885 ENDDO
6886 ENDDO
6887 !
6888 100 CONTINUE
6889 !----------------------------------------------------------------------
6890 !*** END OF LOOP OVER CASES
6891 !----------------------------------------------------------------------
6892 !***
6893 !*** AVERAGE CLIMATOLOGICAL VALUS OF O3 FROM 5 DEG LAT MEANS, SO THAT
6894 !*** TIME AND SPACE INTERPOLATION WILL WORK (SEE SUBR OZON2D)
6895 !***
6896 DO I=1,NLGTH
6897 AVG=0.25*(XRAD1(I)+XRAD2(I)+XRAD3(I)+XRAD4(I))
6898 A1=0.5*(XRAD2(I)-XRAD4(I))
6899 B1=0.5*(XRAD1(I)-XRAD3(I))
6900 B2=0.25*((XRAD1(I)+XRAD3(I))-(XRAD2(I)+XRAD4(I)))
6902 ! XRAD1(I)=AVG
6903 ! XRAD2(I)=A1
6904 ! XRAD3(I)=B1
6905 ! XRAD4(I)=B2
6907 iindex = 1+mod((I-1),37)
6908 jindex = 1+(I-1)/37
6909 XDUO3N(iindex,jindex)=AVG
6910 XDO3N2(iindex,jindex)=A1
6911 XDO3N3(iindex,jindex)=B1
6912 XDO3N4(iindex,jindex)=B2
6913 ENDDO
6914 !***
6915 !*** CONVERT GFDL PRESSURE (MICROBARS) TO PA
6916 !***
6917 DO N=1,NL
6918 PRGFDL(N)=PSTD(N)*1.E-1
6919 ENDDO
6920 !
6921 END SUBROUTINE O3CLIM
6923 !---------------------------------------------------------------------
6924 SUBROUTINE TABLE
6925 ! (TABLE1,TABLE2,TABLE3,EM1,EM1WDE,EM3, &
6926 ! SOURCE,DSRCE )
6927 !---------------------------------------------------------------------
6928 IMPLICIT NONE
6929 !----------------------------------------------------------------------
6931 !INTEGER, PARAMETER :: NBLY=15
6932 INTEGER, PARAMETER :: NB=12
6933 INTEGER, PARAMETER :: NBLX=47
6934 INTEGER , PARAMETER:: NBLW = 163
6936 REAL,PARAMETER :: AMOLWT=28.9644
6937 REAL,PARAMETER :: CSUBP=1.00484E7
6938 REAL,PARAMETER :: DIFFCTR=1.66
6939 REAL,PARAMETER :: G=980.665
6940 REAL,PARAMETER :: GINV=1./G
6941 REAL,PARAMETER :: GRAVDR=980.0
6942 REAL,PARAMETER :: O3DIFCTR=1.90
6943 REAL,PARAMETER :: P0=1013250.
6944 REAL,PARAMETER :: P0INV=1./P0
6945 REAL,PARAMETER :: GP0INV=GINV*P0INV
6946 REAL,PARAMETER :: P0XZP2=202649.902
6947 REAL,PARAMETER :: P0XZP8=810600.098
6948 REAL,PARAMETER :: P0X2=2.*1013250.
6949 REAL,PARAMETER :: RADCON=8.427
6950 REAL,PARAMETER :: RADCON1=1./8.427
6951 REAL,PARAMETER :: RATCO2MW=1.519449738
6952 REAL,PARAMETER :: RATH2OMW=.622
6953 REAL,PARAMETER :: RGAS=8.3142E7
6954 REAL,PARAMETER :: RGASSP=8.31432E7
6955 REAL,PARAMETER :: SECPDA=8.64E4
6956 !
6957 !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
6958 ! ARRANGED IN DECREASING ORDER
6959 REAL,PARAMETER :: HUNDRED=100.
6960 REAL,PARAMETER :: HNINETY=90.
6961 REAL,PARAMETER :: HNINE=9.0
6962 REAL,PARAMETER :: SIXTY=60.
6963 REAL,PARAMETER :: FIFTY=50.
6964 REAL,PARAMETER :: TEN=10.
6965 REAL,PARAMETER :: EIGHT=8.
6966 REAL,PARAMETER :: FIVE=5.
6967 REAL,PARAMETER :: FOUR=4.
6968 REAL,PARAMETER :: THREE=3.
6969 REAL,PARAMETER :: TWO=2.
6970 REAL,PARAMETER :: ONE=1.
6971 REAL,PARAMETER :: HAF=0.5
6972 REAL,PARAMETER :: QUARTR=0.25
6973 REAL,PARAMETER :: ZERO=0.
6974 !
6975 !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
6976 ! ARRANGED IN DECREASING ORDER
6977 REAL,PARAMETER :: H83E26=8.3E26
6978 REAL,PARAMETER :: H71E26=7.1E26
6979 REAL,PARAMETER :: H1E15=1.E15
6980 REAL,PARAMETER :: H1E13=1.E13
6981 REAL,PARAMETER :: H1E11=1.E11
6982 REAL,PARAMETER :: H1E8=1.E8
6983 REAL,PARAMETER :: H2E6=2.0E6
6984 REAL,PARAMETER :: H1E6=1.0E6
6985 REAL,PARAMETER :: H69766E5=6.97667E5
6986 REAL,PARAMETER :: H4E5=4.E5
6987 REAL,PARAMETER :: H165E5=1.65E5
6988 REAL,PARAMETER :: H5725E4=57250.
6989 REAL,PARAMETER :: H488E4=48800.
6990 REAL,PARAMETER :: H1E4=1.E4
6991 REAL,PARAMETER :: H24E3=2400.
6992 REAL,PARAMETER :: H20788E3=2078.8
6993 REAL,PARAMETER :: H2075E3=2075.
6994 REAL,PARAMETER :: H18E3=1800.
6995 REAL,PARAMETER :: H1224E3=1224.
6996 REAL,PARAMETER :: H67390E2=673.9057
6997 REAL,PARAMETER :: H5E2=500.
6998 REAL,PARAMETER :: H3082E2=308.2
6999 REAL,PARAMETER :: H3E2=300.
7000 REAL,PARAMETER :: H2945E2=294.5
7001 REAL,PARAMETER :: H29316E2=293.16
7002 REAL,PARAMETER :: H26E2=260.0
7003 REAL,PARAMETER :: H25E2=250.
7004 REAL,PARAMETER :: H23E2=230.
7005 REAL,PARAMETER :: H2E2=200.0
7006 REAL,PARAMETER :: H15E2=150.
7007 REAL,PARAMETER :: H1386E2=138.6
7008 REAL,PARAMETER :: H1036E2=103.6
7009 REAL,PARAMETER :: H8121E1=81.21
7010 REAL,PARAMETER :: H35E1=35.
7011 REAL,PARAMETER :: H3116E1=31.16
7012 REAL,PARAMETER :: H28E1=28.
7013 REAL,PARAMETER :: H181E1=18.1
7014 REAL,PARAMETER :: H18E1=18.
7015 REAL,PARAMETER :: H161E1=16.1
7016 REAL,PARAMETER :: H16E1=16.
7017 REAL,PARAMETER :: H1226E1=12.26
7018 REAL,PARAMETER :: H9P94=9.94
7019 REAL,PARAMETER :: H6P08108=6.081081081
7020 REAL,PARAMETER :: H3P6=3.6
7021 REAL,PARAMETER :: H3P5=3.5
7022 REAL,PARAMETER :: H2P9=2.9
7023 REAL,PARAMETER :: H2P8=2.8
7024 REAL,PARAMETER :: H2P5=2.5
7025 REAL,PARAMETER :: H1P8=1.8
7026 REAL,PARAMETER :: H1P4387=1.4387
7027 REAL,PARAMETER :: H1P41819=1.418191
7028 REAL,PARAMETER :: H1P4=1.4
7029 REAL,PARAMETER :: H1P25892=1.258925411
7030 REAL,PARAMETER :: H1P082=1.082
7031 REAL,PARAMETER :: HP816=0.816
7032 REAL,PARAMETER :: HP805=0.805
7033 REAL,PARAMETER :: HP8=0.8
7034 REAL,PARAMETER :: HP60241=0.60241
7035 REAL,PARAMETER :: HP602409=0.60240964
7036 REAL,PARAMETER :: HP6=0.6
7037 REAL,PARAMETER :: HP526315=0.52631579
7038 REAL,PARAMETER :: HP518=0.518
7039 REAL,PARAMETER :: HP5048=0.5048
7040 REAL,PARAMETER :: HP3795=0.3795
7041 REAL,PARAMETER :: HP369=0.369
7042 REAL,PARAMETER :: HP26=0.26
7043 REAL,PARAMETER :: HP228=0.228
7044 REAL,PARAMETER :: HP219=0.219
7045 REAL,PARAMETER :: HP166666=.166666
7046 REAL,PARAMETER :: HP144=0.144
7047 REAL,PARAMETER :: HP118666=0.118666192
7048 REAL,PARAMETER :: HP1=0.1
7049 ! (NEGATIVE EXPONENTIALS BEGIN HERE)
7050 REAL,PARAMETER :: H658M2=0.0658
7051 REAL,PARAMETER :: H625M2=0.0625
7052 REAL,PARAMETER :: H44871M2=4.4871E-2
7053 REAL,PARAMETER :: H44194M2=.044194
7054 REAL,PARAMETER :: H42M2=0.042
7055 REAL,PARAMETER :: H41666M2=0.0416666
7056 REAL,PARAMETER :: H28571M2=.02857142857
7057 REAL,PARAMETER :: H2118M2=0.02118
7058 REAL,PARAMETER :: H129M2=0.0129
7059 REAL,PARAMETER :: H1M2=.01
7060 REAL,PARAMETER :: H559M3=5.59E-3
7061 REAL,PARAMETER :: H3M3=0.003
7062 REAL,PARAMETER :: H235M3=2.35E-3
7063 REAL,PARAMETER :: H1M3=1.0E-3
7064 REAL,PARAMETER :: H987M4=9.87E-4
7065 REAL,PARAMETER :: H323M4=0.000323
7066 REAL,PARAMETER :: H3M4=0.0003
7067 REAL,PARAMETER :: H285M4=2.85E-4
7068 REAL,PARAMETER :: H1M4=0.0001
7069 REAL,PARAMETER :: H75826M4=7.58265E-4
7070 REAL,PARAMETER :: H6938M5=6.938E-5
7071 REAL,PARAMETER :: H394M5=3.94E-5
7072 REAL,PARAMETER :: H37412M5=3.7412E-5
7073 REAL,PARAMETER :: H15M5=1.5E-5
7074 REAL,PARAMETER :: H1439M5=1.439E-5
7075 REAL,PARAMETER :: H128M5=1.28E-5
7076 REAL,PARAMETER :: H102M5=1.02E-5
7077 REAL,PARAMETER :: H1M5=1.0E-5
7078 REAL,PARAMETER :: H7M6=7.E-6
7079 REAL,PARAMETER :: H4999M6=4.999E-6
7080 REAL,PARAMETER :: H451M6=4.51E-6
7081 REAL,PARAMETER :: H25452M6=2.5452E-6
7082 REAL,PARAMETER :: H1M6=1.E-6
7083 REAL,PARAMETER :: H391M7=3.91E-7
7084 REAL,PARAMETER :: H1174M7=1.174E-7
7085 REAL,PARAMETER :: H8725M8=8.725E-8
7086 REAL,PARAMETER :: H327M8=3.27E-8
7087 REAL,PARAMETER :: H257M8=2.57E-8
7088 REAL,PARAMETER :: H1M8=1.0E-8
7089 REAL,PARAMETER :: H23M10=2.3E-10
7090 REAL,PARAMETER :: H14M10=1.4E-10
7091 REAL,PARAMETER :: H11M10=1.1E-10
7092 REAL,PARAMETER :: H1M10=1.E-10
7093 REAL,PARAMETER :: H83M11=8.3E-11
7094 REAL,PARAMETER :: H82M11=8.2E-11
7095 REAL,PARAMETER :: H8M11=8.E-11
7096 REAL,PARAMETER :: H77M11=7.7E-11
7097 REAL,PARAMETER :: H72M11=7.2E-11
7098 REAL,PARAMETER :: H53M11=5.3E-11
7099 REAL,PARAMETER :: H48M11=4.8E-11
7100 REAL,PARAMETER :: H44M11=4.4E-11
7101 REAL,PARAMETER :: H42M11=4.2E-11
7102 REAL,PARAMETER :: H37M11=3.7E-11
7103 REAL,PARAMETER :: H35M11=3.5E-11
7104 REAL,PARAMETER :: H32M11=3.2E-11
7105 REAL,PARAMETER :: H3M11=3.0E-11
7106 REAL,PARAMETER :: H28M11=2.8E-11
7107 REAL,PARAMETER :: H24M11=2.4E-11
7108 REAL,PARAMETER :: H23M11=2.3E-11
7109 REAL,PARAMETER :: H2M11=2.E-11
7110 REAL,PARAMETER :: H18M11=1.8E-11
7111 REAL,PARAMETER :: H15M11=1.5E-11
7112 REAL,PARAMETER :: H14M11=1.4E-11
7113 REAL,PARAMETER :: H114M11=1.14E-11
7114 REAL,PARAMETER :: H11M11=1.1E-11
7115 REAL,PARAMETER :: H1M11=1.E-11
7116 REAL,PARAMETER :: H96M12=9.6E-12
7117 REAL,PARAMETER :: H93M12=9.3E-12
7118 REAL,PARAMETER :: H77M12=7.7E-12
7119 REAL,PARAMETER :: H74M12=7.4E-12
7120 REAL,PARAMETER :: H65M12=6.5E-12
7121 REAL,PARAMETER :: H62M12=6.2E-12
7122 REAL,PARAMETER :: H6M12=6.E-12
7123 REAL,PARAMETER :: H45M12=4.5E-12
7124 REAL,PARAMETER :: H44M12=4.4E-12
7125 REAL,PARAMETER :: H4M12=4.E-12
7126 REAL,PARAMETER :: H38M12=3.8E-12
7127 REAL,PARAMETER :: H37M12=3.7E-12
7128 REAL,PARAMETER :: H3M12=3.E-12
7129 REAL,PARAMETER :: H29M12=2.9E-12
7130 REAL,PARAMETER :: H28M12=2.8E-12
7131 REAL,PARAMETER :: H24M12=2.4E-12
7132 REAL,PARAMETER :: H21M12=2.1E-12
7133 REAL,PARAMETER :: H16M12=1.6E-12
7134 REAL,PARAMETER :: H14M12=1.4E-12
7135 REAL,PARAMETER :: H12M12=1.2E-12
7136 REAL,PARAMETER :: H8M13=8.E-13
7137 REAL,PARAMETER :: H46M13=4.6E-13
7138 REAL,PARAMETER :: H36M13=3.6E-13
7139 REAL,PARAMETER :: H135M13=1.35E-13
7140 REAL,PARAMETER :: H12M13=1.2E-13
7141 REAL,PARAMETER :: H1M13=1.E-13
7142 REAL,PARAMETER :: H3M14=3.E-14
7143 REAL,PARAMETER :: H15M14=1.5E-14
7144 REAL,PARAMETER :: H14M14=1.4E-14
7145 !
7146 !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
7147 ! ARRANGED IN DESCENDING ORDER
7148 REAL,PARAMETER :: HM2M2=-.02
7149 REAL,PARAMETER :: HM6666M2=-.066667
7150 REAL,PARAMETER :: HMP5=-0.5
7151 REAL,PARAMETER :: HMP575=-0.575
7152 REAL,PARAMETER :: HMP66667=-.66667
7153 REAL,PARAMETER :: HMP805=-0.805
7154 REAL,PARAMETER :: HM1EZ=-1.
7155 REAL,PARAMETER :: HM13EZ=-1.3
7156 REAL,PARAMETER :: HM19EZ=-1.9
7157 REAL,PARAMETER :: HM1E1=-10.
7158 REAL,PARAMETER :: HM1597E1=-15.97469413
7159 REAL,PARAMETER :: HM161E1=-16.1
7160 REAL,PARAMETER :: HM1797E1=-17.97469413
7161 REAL,PARAMETER :: HM181E1=-18.1
7162 REAL,PARAMETER :: HM8E1=-80.
7163 REAL,PARAMETER :: HM1E2=-100.
7164 !
7165 REAL,PARAMETER :: H1M16=1.0E-16
7166 REAL,PARAMETER :: H1M20=1.E-20
7167 REAL,PARAMETER :: HP98=0.98
7168 REAL,PARAMETER :: Q19001=19.001
7169 REAL,PARAMETER :: DAYSEC=1.1574E-5
7170 REAL,PARAMETER :: HSIGMA=5.673E-5
7171 REAL,PARAMETER :: TWENTY=20.0
7172 REAL,PARAMETER :: HP537=0.537
7173 REAL,PARAMETER :: HP2=0.2
7174 REAL,PARAMETER :: RCO2=3.3E-4
7175 REAL,PARAMETER :: H3M6=3.0E-6
7176 REAL,PARAMETER :: PI=3.1415927
7177 REAL,PARAMETER :: DEGRAD1=180.0/PI
7178 REAL,PARAMETER :: H74E1=74.0
7179 REAL,PARAMETER :: H15E1=15.0
7181 REAL, PARAMETER:: B0 = -.51926410E-4
7182 REAL, PARAMETER:: B1 = -.18113332E-3
7183 REAL, PARAMETER:: B2 = -.10680132E-5
7184 REAL, PARAMETER:: B3 = -.67303519E-7
7185 REAL, PARAMETER:: AWIDE = 0.309801E+01
7186 REAL, PARAMETER:: BWIDE = 0.495357E-01
7187 REAL, PARAMETER:: BETAWD = 0.347839E+02
7188 REAL, PARAMETER:: BETINW = 0.766811E+01
7191 ! REAL, INTENT(OUT) :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), &
7192 ! TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
7193 ! SOURCE(28,NBLY), DSRCE(28,NBLY)
7195 !
7196 REAL :: ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW)
7197 REAL :: BANDLO(NBLW),BANDHI(NBLW)
7199 INTEGER :: IBAND(40)
7201 REAL :: BANDL1(64),BANDL2(64),BANDL3(35)
7202 REAL :: BANDH1(64),BANDH2(64),BANDH3(35)
7203 ! REAL :: AB15WD,SKO2D,SKC1R,SKO3R
7205 ! REAL :: AWIDE,BWIDE,BETAWD,BETINW
7207 ! DATA AWIDE / 0.309801E+01/
7208 ! DATA BWIDE / 0.495357E-01/
7209 ! DATA BETAWD / 0.347839E+02/
7210 ! DATA BETINW / 0.766811E+01/
7212 !
7213 !% #NPADL = #PAGE*#NPAGE - 4*28*180 - 2*181 - 7*28 - 180 ;
7214 !% #NPADL = #NPADL - 11*28 - 2*180 - 2*30 ;
7216 ! PARAMETER (NPADL = #NPADL - 28*NBLX - 2*28*NBLW - 7*NBLW)
7218 REAL :: &
7219 SUM(28,180),PERTSM(28,180),SUM3(28,180), &
7220 SUMWDE(28,180),SRCWD(28,NBLX),SRC1NB(28,NBLW), &
7221 DBDTNB(28,NBLW)
7222 REAL :: &
7223 ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28), &
7224 TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28), &
7225 SUM4(28),SUM6(28),SUM7(28),SUM8(28),SUM4WD(28), &
7226 R1T(28),R2(28),S2(28),T3(28),R1WD(28)
7227 REAL :: EXPO(180),FAC(180)
7228 REAL :: CNUSB(30),DNUSB(30)
7229 REAL :: ALFANB(NBLW),AROTNB(NBLW)
7230 REAL :: ANB(NBLW),BNB(NBLW),CENTNB(NBLW),DELNB(NBLW), &
7231 BETANB(NBLW)
7233 REAL :: AB15(2)
7235 REAL :: ARNDM1(64),ARNDM2(64),ARNDM3(35)
7236 REAL :: BRNDM1(64),BRNDM2(64),BRNDM3(35)
7237 REAL :: BETAD1(64),BETAD2(64),BETAD3(35)
7239 EQUIVALENCE (ARNDM1(1),ARNDM(1)),(ARNDM2(1),ARNDM(65)), &
7240 (ARNDM3(1),ARNDM(129))
7241 EQUIVALENCE (BRNDM1(1),BRNDM(1)),(BRNDM2(1),BRNDM(65)), &
7242 (BRNDM3(1),BRNDM(129))
7243 EQUIVALENCE (BETAD1(1),BETAD(1)),(BETAD2(1),BETAD(65)), &
7244 (BETAD3(1),BETAD(129))
7246 !---------------------------------------------------------------
7247 REAL :: CENT,DEL,BDLO,BDHI,C1,ANU,tmp
7248 INTEGER :: N,I,ICNT,I1,I2E,I2
7249 INTEGER :: J,JP,NSUBDS,NSB,IA
7251 !---------------------------------------------------------------
7253 DATA IBAND / &
7254 2, 1, 2, 2, 1, 2, 1, 3, 2, 2, &
7255 3, 2, 2, 4, 2, 4, 2, 3, 3, 2, &
7256 4, 3, 4, 3, 7, 5, 6, 7, 6, 5, &
7257 7, 6, 7, 8, 6, 6, 8, 8, 8, 8/
7259 DATA BANDL1 / &
7260 0.000000E+00, 0.100000E+02, 0.200000E+02, 0.300000E+02, &
7261 0.400000E+02, 0.500000E+02, 0.600000E+02, 0.700000E+02, &
7262 0.800000E+02, 0.900000E+02, 0.100000E+03, 0.110000E+03, &
7263 0.120000E+03, 0.130000E+03, 0.140000E+03, 0.150000E+03, &
7264 0.160000E+03, 0.170000E+03, 0.180000E+03, 0.190000E+03, &
7265 0.200000E+03, 0.210000E+03, 0.220000E+03, 0.230000E+03, &
7266 0.240000E+03, 0.250000E+03, 0.260000E+03, 0.270000E+03, &
7267 0.280000E+03, 0.290000E+03, 0.300000E+03, 0.310000E+03, &
7268 0.320000E+03, 0.330000E+03, 0.340000E+03, 0.350000E+03, &
7269 0.360000E+03, 0.370000E+03, 0.380000E+03, 0.390000E+03, &
7270 0.400000E+03, 0.410000E+03, 0.420000E+03, 0.430000E+03, &
7271 0.440000E+03, 0.450000E+03, 0.460000E+03, 0.470000E+03, &
7272 0.480000E+03, 0.490000E+03, 0.500000E+03, 0.510000E+03, &
7273 0.520000E+03, 0.530000E+03, 0.540000E+03, 0.550000E+03, &
7274 0.560000E+03, 0.670000E+03, 0.800000E+03, 0.900000E+03, &
7275 0.990000E+03, 0.107000E+04, 0.120000E+04, 0.121000E+04/
7276 DATA BANDL2 / &
7277 0.122000E+04, 0.123000E+04, 0.124000E+04, 0.125000E+04, &
7278 0.126000E+04, 0.127000E+04, 0.128000E+04, 0.129000E+04, &
7279 0.130000E+04, 0.131000E+04, 0.132000E+04, 0.133000E+04, &
7280 0.134000E+04, 0.135000E+04, 0.136000E+04, 0.137000E+04, &
7281 0.138000E+04, 0.139000E+04, 0.140000E+04, 0.141000E+04, &
7282 0.142000E+04, 0.143000E+04, 0.144000E+04, 0.145000E+04, &
7283 0.146000E+04, 0.147000E+04, 0.148000E+04, 0.149000E+04, &
7284 0.150000E+04, 0.151000E+04, 0.152000E+04, 0.153000E+04, &
7285 0.154000E+04, 0.155000E+04, 0.156000E+04, 0.157000E+04, &
7286 0.158000E+04, 0.159000E+04, 0.160000E+04, 0.161000E+04, &
7287 0.162000E+04, 0.163000E+04, 0.164000E+04, 0.165000E+04, &
7288 0.166000E+04, 0.167000E+04, 0.168000E+04, 0.169000E+04, &
7289 0.170000E+04, 0.171000E+04, 0.172000E+04, 0.173000E+04, &
7290 0.174000E+04, 0.175000E+04, 0.176000E+04, 0.177000E+04, &
7291 0.178000E+04, 0.179000E+04, 0.180000E+04, 0.181000E+04, &
7292 0.182000E+04, 0.183000E+04, 0.184000E+04, 0.185000E+04/
7293 DATA BANDL3 / &
7294 0.186000E+04, 0.187000E+04, 0.188000E+04, 0.189000E+04, &
7295 0.190000E+04, 0.191000E+04, 0.192000E+04, 0.193000E+04, &
7296 0.194000E+04, 0.195000E+04, 0.196000E+04, 0.197000E+04, &
7297 0.198000E+04, 0.199000E+04, 0.200000E+04, 0.201000E+04, &
7298 0.202000E+04, 0.203000E+04, 0.204000E+04, 0.205000E+04, &
7299 0.206000E+04, 0.207000E+04, 0.208000E+04, 0.209000E+04, &
7300 0.210000E+04, 0.211000E+04, 0.212000E+04, 0.213000E+04, &
7301 0.214000E+04, 0.215000E+04, 0.216000E+04, 0.217000E+04, &
7302 0.218000E+04, 0.219000E+04, 0.227000E+04/
7304 DATA BANDH1 / &
7305 0.100000E+02, 0.200000E+02, 0.300000E+02, 0.400000E+02, &
7306 0.500000E+02, 0.600000E+02, 0.700000E+02, 0.800000E+02, &
7307 0.900000E+02, 0.100000E+03, 0.110000E+03, 0.120000E+03, &
7308 0.130000E+03, 0.140000E+03, 0.150000E+03, 0.160000E+03, &
7309 0.170000E+03, 0.180000E+03, 0.190000E+03, 0.200000E+03, &
7310 0.210000E+03, 0.220000E+03, 0.230000E+03, 0.240000E+03, &
7311 0.250000E+03, 0.260000E+03, 0.270000E+03, 0.280000E+03, &
7312 0.290000E+03, 0.300000E+03, 0.310000E+03, 0.320000E+03, &
7313 0.330000E+03, 0.340000E+03, 0.350000E+03, 0.360000E+03, &
7314 0.370000E+03, 0.380000E+03, 0.390000E+03, 0.400000E+03, &
7315 0.410000E+03, 0.420000E+03, 0.430000E+03, 0.440000E+03, &
7316 0.450000E+03, 0.460000E+03, 0.470000E+03, 0.480000E+03, &
7317 0.490000E+03, 0.500000E+03, 0.510000E+03, 0.520000E+03, &
7318 0.530000E+03, 0.540000E+03, 0.550000E+03, 0.560000E+03, &
7319 0.670000E+03, 0.800000E+03, 0.900000E+03, 0.990000E+03, &
7320 0.107000E+04, 0.120000E+04, 0.121000E+04, 0.122000E+04/
7321 DATA BANDH2 / &
7322 0.123000E+04, 0.124000E+04, 0.125000E+04, 0.126000E+04, &
7323 0.127000E+04, 0.128000E+04, 0.129000E+04, 0.130000E+04, &
7324 0.131000E+04, 0.132000E+04, 0.133000E+04, 0.134000E+04, &
7325 0.135000E+04, 0.136000E+04, 0.137000E+04, 0.138000E+04, &
7326 0.139000E+04, 0.140000E+04, 0.141000E+04, 0.142000E+04, &
7327 0.143000E+04, 0.144000E+04, 0.145000E+04, 0.146000E+04, &
7328 0.147000E+04, 0.148000E+04, 0.149000E+04, 0.150000E+04, &
7329 0.151000E+04, 0.152000E+04, 0.153000E+04, 0.154000E+04, &
7330 0.155000E+04, 0.156000E+04, 0.157000E+04, 0.158000E+04, &
7331 0.159000E+04, 0.160000E+04, 0.161000E+04, 0.162000E+04, &
7332 0.163000E+04, 0.164000E+04, 0.165000E+04, 0.166000E+04, &
7333 0.167000E+04, 0.168000E+04, 0.169000E+04, 0.170000E+04, &
7334 0.171000E+04, 0.172000E+04, 0.173000E+04, 0.174000E+04, &
7335 0.175000E+04, 0.176000E+04, 0.177000E+04, 0.178000E+04, &
7336 0.179000E+04, 0.180000E+04, 0.181000E+04, 0.182000E+04, &
7337 0.183000E+04, 0.184000E+04, 0.185000E+04, 0.186000E+04/
7338 DATA BANDH3 / &
7339 0.187000E+04, 0.188000E+04, 0.189000E+04, 0.190000E+04, &
7340 0.191000E+04, 0.192000E+04, 0.193000E+04, 0.194000E+04, &
7341 0.195000E+04, 0.196000E+04, 0.197000E+04, 0.198000E+04, &
7342 0.199000E+04, 0.200000E+04, 0.201000E+04, 0.202000E+04, &
7343 0.203000E+04, 0.204000E+04, 0.205000E+04, 0.206000E+04, &
7344 0.207000E+04, 0.208000E+04, 0.209000E+04, 0.210000E+04, &
7345 0.211000E+04, 0.212000E+04, 0.213000E+04, 0.214000E+04, &
7346 0.215000E+04, 0.216000E+04, 0.217000E+04, 0.218000E+04, &
7347 0.219000E+04, 0.220000E+04, 0.238000E+04/
7349 !
7350 !***THE FOLLOWING DATA STATEMENTS ARE BAND PARAMETERS OBTAINED USING
7351 ! THE 1982 AFGL CATALOG ON THE SPECIFIED BANDS
7352 DATA ARNDM1 / &
7353 0.354693E+00, 0.269857E+03, 0.167062E+03, 0.201314E+04, &
7354 0.964533E+03, 0.547971E+04, 0.152933E+04, 0.599429E+04, &
7355 0.699329E+04, 0.856721E+04, 0.962489E+04, 0.233348E+04, &
7356 0.127091E+05, 0.104383E+05, 0.504249E+04, 0.181227E+05, &
7357 0.856480E+03, 0.136354E+05, 0.288635E+04, 0.170200E+04, &
7358 0.209761E+05, 0.126797E+04, 0.110096E+05, 0.336436E+03, &
7359 0.491663E+04, 0.863701E+04, 0.540389E+03, 0.439786E+04, &
7360 0.347836E+04, 0.130557E+03, 0.465332E+04, 0.253086E+03, &
7361 0.257387E+04, 0.488041E+03, 0.892991E+03, 0.117148E+04, &
7362 0.125880E+03, 0.458852E+03, 0.142975E+03, 0.446355E+03, &
7363 0.302887E+02, 0.394451E+03, 0.438112E+02, 0.348811E+02, &
7364 0.615503E+02, 0.143165E+03, 0.103958E+02, 0.725108E+02, &
7365 0.316628E+02, 0.946456E+01, 0.542675E+02, 0.351557E+02, &
7366 0.301797E+02, 0.381010E+01, 0.126319E+02, 0.548010E+01, &
7367 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, &
7368 0.178110E-01, 0.170166E+00, 0.273514E-01, 0.983767E+00/
7369 DATA ARNDM2 / &
7370 0.753946E+00, 0.941763E-01, 0.970547E+00, 0.268862E+00, &
7371 0.564373E+01, 0.389794E+01, 0.310955E+01, 0.128235E+01, &
7372 0.196414E+01, 0.247113E+02, 0.593435E+01, 0.377552E+02, &
7373 0.305173E+02, 0.852479E+01, 0.116780E+03, 0.101490E+03, &
7374 0.138939E+03, 0.324228E+03, 0.683729E+02, 0.471304E+03, &
7375 0.159684E+03, 0.427101E+03, 0.114716E+03, 0.106190E+04, &
7376 0.294607E+03, 0.762948E+03, 0.333199E+03, 0.830645E+03, &
7377 0.162512E+04, 0.525676E+03, 0.137739E+04, 0.136252E+04, &
7378 0.147164E+04, 0.187196E+04, 0.131118E+04, 0.103975E+04, &
7379 0.621637E+01, 0.399459E+02, 0.950648E+02, 0.943161E+03, &
7380 0.526821E+03, 0.104150E+04, 0.905610E+03, 0.228142E+04, &
7381 0.806270E+03, 0.691845E+03, 0.155237E+04, 0.192241E+04, &
7382 0.991871E+03, 0.123907E+04, 0.457289E+02, 0.146146E+04, &
7383 0.319382E+03, 0.436074E+03, 0.374214E+03, 0.778217E+03, &
7384 0.140227E+03, 0.562540E+03, 0.682685E+02, 0.820292E+02, &
7385 0.178779E+03, 0.186150E+03, 0.383864E+03, 0.567416E+01/
7386 DATA ARNDM3 / &
7387 0.225129E+03, 0.473099E+01, 0.753149E+02, 0.233689E+02, &
7388 0.339802E+02, 0.108855E+03, 0.380016E+02, 0.151039E+01, &
7389 0.660346E+02, 0.370165E+01, 0.234169E+02, 0.440206E+00, &
7390 0.615283E+01, 0.304077E+02, 0.117769E+01, 0.125248E+02, &
7391 0.142652E+01, 0.241831E+00, 0.483721E+01, 0.226357E-01, &
7392 0.549835E+01, 0.597067E+00, 0.404553E+00, 0.143584E+01, &
7393 0.294291E+00, 0.466273E+00, 0.156048E+00, 0.656185E+00, &
7394 0.172727E+00, 0.118349E+00, 0.141598E+00, 0.588581E-01, &
7395 0.919409E-01, 0.155521E-01, 0.537083E-02/
7396 DATA BRNDM1 / &
7397 0.789571E-01, 0.920256E-01, 0.696960E-01, 0.245544E+00, &
7398 0.188503E+00, 0.266127E+00, 0.271371E+00, 0.330917E+00, &
7399 0.190424E+00, 0.224498E+00, 0.282517E+00, 0.130675E+00, &
7400 0.212579E+00, 0.227298E+00, 0.138585E+00, 0.187106E+00, &
7401 0.194527E+00, 0.177034E+00, 0.115902E+00, 0.118499E+00, &
7402 0.142848E+00, 0.216869E+00, 0.149848E+00, 0.971585E-01, &
7403 0.151532E+00, 0.865628E-01, 0.764246E-01, 0.100035E+00, &
7404 0.171133E+00, 0.134737E+00, 0.105173E+00, 0.860832E-01, &
7405 0.148921E+00, 0.869234E-01, 0.106018E+00, 0.184865E+00, &
7406 0.767454E-01, 0.108981E+00, 0.123094E+00, 0.177287E+00, &
7407 0.848146E-01, 0.119356E+00, 0.133829E+00, 0.954505E-01, &
7408 0.155405E+00, 0.164167E+00, 0.161390E+00, 0.113287E+00, &
7409 0.714720E-01, 0.741598E-01, 0.719590E-01, 0.140616E+00, &
7410 0.355356E-01, 0.832779E-01, 0.128680E+00, 0.983013E-01, &
7411 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, &
7412 0.875182E-01, 0.857907E-01, 0.358808E+00, 0.178840E+00/
7413 DATA BRNDM2 / &
7414 0.254265E+00, 0.297901E+00, 0.153916E+00, 0.537774E+00, &
7415 0.267906E+00, 0.104254E+00, 0.400723E+00, 0.389670E+00, &
7416 0.263701E+00, 0.338116E+00, 0.351528E+00, 0.267764E+00, &
7417 0.186419E+00, 0.238237E+00, 0.210408E+00, 0.176869E+00, &
7418 0.114715E+00, 0.173299E+00, 0.967770E-01, 0.172565E+00, &
7419 0.162085E+00, 0.157782E+00, 0.886832E-01, 0.242999E+00, &
7420 0.760298E-01, 0.164248E+00, 0.221428E+00, 0.166799E+00, &
7421 0.312514E+00, 0.380600E+00, 0.353828E+00, 0.269500E+00, &
7422 0.254759E+00, 0.285408E+00, 0.159764E+00, 0.721058E-01, &
7423 0.170528E+00, 0.231595E+00, 0.307184E+00, 0.564136E-01, &
7424 0.159884E+00, 0.147907E+00, 0.185666E+00, 0.183567E+00, &
7425 0.182482E+00, 0.230650E+00, 0.175348E+00, 0.195978E+00, &
7426 0.255323E+00, 0.198517E+00, 0.195500E+00, 0.208356E+00, &
7427 0.309603E+00, 0.112011E+00, 0.102570E+00, 0.128276E+00, &
7428 0.168100E+00, 0.177836E+00, 0.105533E+00, 0.903330E-01, &
7429 0.126036E+00, 0.101430E+00, 0.124546E+00, 0.221406E+00/
7430 DATA BRNDM3 / &
7431 0.137509E+00, 0.911365E-01, 0.724508E-01, 0.795788E-01, &
7432 0.137411E+00, 0.549175E-01, 0.787714E-01, 0.165544E+00, &
7433 0.136484E+00, 0.146729E+00, 0.820496E-01, 0.846211E-01, &
7434 0.785821E-01, 0.122527E+00, 0.125359E+00, 0.101589E+00, &
7435 0.155756E+00, 0.189239E+00, 0.999086E-01, 0.480993E+00, &
7436 0.100233E+00, 0.153754E+00, 0.130780E+00, 0.136136E+00, &
7437 0.159353E+00, 0.156634E+00, 0.272265E+00, 0.186874E+00, &
7438 0.192090E+00, 0.135397E+00, 0.131497E+00, 0.127463E+00, &
7439 0.227233E+00, 0.190562E+00, 0.214005E+00/
7440 DATA BETAD1 / &
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 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7450 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7451 0.234879E+03, 0.217419E+03, 0.201281E+03, 0.186364E+03, &
7452 0.172576E+03, 0.159831E+03, 0.148051E+03, 0.137163E+03, &
7453 0.127099E+03, 0.117796E+03, 0.109197E+03, 0.101249E+03, &
7454 0.939031E+02, 0.871127E+02, 0.808363E+02, 0.750349E+02, &
7455 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, &
7456 0.589554E+01, 0.495227E+01, 0.000000E+00, 0.000000E+00/
7457 DATA BETAD2 / &
7458 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7459 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7460 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7461 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7462 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7463 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7464 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7465 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7466 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7467 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7468 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7469 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7470 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7471 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7472 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7473 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00/
7474 DATA BETAD3 / &
7475 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7476 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7477 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7478 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7479 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7480 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7481 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7482 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7483 0.000000E+00, 0.000000E+00, 0.000000E+00/
7484 !---------------------------------------------------------------
7485 ! EQUIVALENCE (BANDL1(1),BANDLO(1)),(BANDL2(1),BANDLO(65)), &
7486 ! (BANDL3(1),BANDLO(129))
7488 ! L = kme-1
7489 ! LP1 = L+1
7490 ! LP1V = LP1*(1+2*L/2)
7491 ! IMAX = ite
7492 ! LP2 = L + 2
7494 DO I = 1,64
7495 BANDLO(I)=BANDL1(I)
7496 ENDDO
7498 DO I = 65,128
7499 BANDLO(I)=BANDL2(I-64)
7500 ENDDO
7502 DO I = 129,163
7503 BANDLO(I)=BANDL3(I-128)
7504 ENDDO
7506 DO I = 1,64
7507 BANDHI(I)=BANDH1(I)
7508 ENDDO
7510 DO I = 65,128
7511 BANDHI(I)=BANDH2(I-64)
7512 ENDDO
7514 DO I = 129,163
7515 BANDHI(I)=BANDH3(I-128)
7516 ENDDO
7518 !****************************************
7519 !***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15
7520 !....FOR NARROW-BANDS...
7521 DO 101 N=1,NBLW
7522 ANB(N)=ARNDM(N)
7523 BNB(N)=BRNDM(N)
7524 CENTNB(N)=HAF*(BANDLO(N)+BANDHI(N))
7525 DELNB(N)=BANDHI(N)-BANDLO(N)
7526 BETANB(N)=BETAD(N)
7527 101 CONTINUE
7528 AB15(1)=ANB(57)*BNB(57)
7529 AB15(2)=ANB(58)*BNB(58)
7530 !....FOR WIDE BANDS...
7531 AB15WD=AWIDE*BWIDE
7532 !
7533 !***COMPUTE INDICES: IND,INDX2,KMAXV
7534 !SH ICNT=0
7535 !SH DO 113 I1=1,L
7536 !SH I2E=LP1-I1
7537 !SH DO 115 I2=1,I2E
7538 !SH ICNT=ICNT+1
7539 !SH INDX2(ICNT)=LP1*(I2-1)+LP2*I1
7540 !SH115 CONTINUE
7541 !SH113 CONTINUE
7542 !SH KMAXV(1)=1
7543 !SH DO 117 I=2,L
7544 !SH KMAXV(I)=KMAXV(I-1)+(LP2-I)
7545 117 CONTINUE
7546 !SH KMAXVM=KMAXV(L)
7547 !***COMPUTE RATIOS OF CONT. COEFFS
7548 SKC1R=BETAWD/BETINW
7549 SKO3R=BETAD(61)/BETINW
7550 SKO2D=ONE/BETINW
7551 !
7552 !****BEGIN TABLE COMPUTATIONS HERE***
7553 !***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES
7554 !---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS
7555 ! WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM
7556 ! 100K TO 370K.
7557 !---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF
7558 ! 180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS
7559 ! ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS.
7560 ZMASS(1)=H1M16
7561 DO 201 J=1,180
7562 JP=J+1
7563 ZROOT(J)=SQRT(ZMASS(J))
7564 ZMASS(JP)=ZMASS(J)*H1P25892
7565 201 CONTINUE
7566 DO 203 I=1,28
7567 XTEMV(I)=HNINETY+TEN*I
7568 TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I)
7569 FORTCU(I)=FOUR*XTEMV(I)*XTEMV(I)*XTEMV(I)
7570 203 CONTINUE
7571 !******THE COMPUTATION OF SOURCE,DSRCE IS NEEDED ONLY
7572 ! FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE
7573 ! MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD)
7574 ! THEN COMBINED (USING IBAND) INTO SOURCE.
7575 DO 205 N=1,NBLY
7576 DO 205 I=1,28
7577 SOURCE(I,N)=ZERO
7578 205 CONTINUE
7579 DO 207 N=1,NBLX
7580 DO 207 I=1,28
7581 SRCWD(I,N)=ZERO
7582 207 CONTINUE
7583 !---BEGIN FREQ. LOOP (ON N)
7584 DO 211 N=1,NBLX
7585 IF (N.LE.46) THEN
7586 !***THE 160-1200 BAND CASES
7587 CENT=CENTNB(N+16)
7588 DEL=DELNB(N+16)
7589 BDLO=BANDLO(N+16)
7590 BDHI=BANDHI(N+16)
7591 ENDIF
7592 IF (N.EQ.NBLX) THEN
7593 !***THE 2270-2380 BAND CASE
7594 CENT=CENTNB(NBLW)
7595 DEL=DELNB(NBLW)
7596 BDLO=BANDLO(NBLW)
7597 BDHI=BANDHI(NBLW)
7598 ENDIF
7599 !***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE
7600 ! ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS.
7601 NSUBDS=(DEL-H1M3)/10+1
7602 DO 213 NSB=1,NSUBDS
7603 IF (NSB.NE.NSUBDS) THEN
7604 CNUSB(NSB)=TEN*(NSB-1)+BDLO+FIVE
7605 DNUSB(NSB)=TEN
7606 ELSE
7607 CNUSB(NSB)=HAF*(TEN*(NSB-1)+BDLO+BDHI)
7608 DNUSB(NSB)=BDHI-(TEN*(NSB-1)+BDLO)
7609 ENDIF
7610 C1=(H37412M5)*CNUSB(NSB)**3
7611 !---BEGIN TEMP. LOOP (ON I)
7612 DO 215 I=1,28
7613 X(I)=H1P4387*CNUSB(NSB)/XTEMV(I)
7614 X1(I)=EXP(X(I))
7615 SRCS(I)=C1/(X1(I)-ONE)
7616 SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB)
7617 215 CONTINUE
7618 213 CONTINUE
7619 211 CONTINUE
7620 !***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE
7621 ! AND DSRCE
7622 DO 221 N=1,40
7623 DO 221 I=1,28
7624 SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N)
7625 221 CONTINUE
7626 DO 223 N=9,NBLY
7627 DO 223 I=1,28
7628 SOURCE(I,N)=SRCWD(I,N+32)
7629 223 CONTINUE
7630 DO 225 N=1,NBLY
7631 DO 225 I=1,27
7632 DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*HP1
7633 225 CONTINUE
7634 DO 231 N=1,NBLW
7635 ALFANB(N)=BNB(N)*ANB(N)
7636 AROTNB(N)=SQRT(ALFANB(N))
7637 231 CONTINUE
7638 !***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR
7639 ! USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE
7640 ! BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ.
7641 ! RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT.
7642 !
7643 DO 301 N=1,NBLW
7644 CENT=CENTNB(N)
7645 DEL=DELNB(N)
7646 !---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT
7647 ! IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR
7648 ! THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY.
7649 #if 0
7650 DO 303 IA=1,3
7651 #else
7652 !jm -- getting floating point exceptions for IA=1, since 2 is only
7653 ! used anyway, I disabled the looping.
7654 DO 303 IA=2,2
7655 #endif
7656 ANU=CENT+HAF*(IA-2)*DEL
7657 C1=(H37412M5)*ANU*ANU*ANU+H1M20
7658 !---TEMPERATURE LOOP---
7659 DO 305 I=1,28
7660 X(I)=H1P4387*ANU/XTEMV(I)
7661 X1(I)=EXP(X(I))
7662 !#$ tmp=max((X1(I)-ONE),H1M20)
7663 !#$ SC(I)=C1/tmp
7664 SC(I)=C1/((X1(I)-ONE)+H1M20)
7665 !#$ DSC(I)=X(I)*SC(I)*SC(I)*X1(I)/(XTEMV(I)*C1)
7666 DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1)
7667 305 CONTINUE
7668 IF (IA.EQ.2) THEN
7669 DO 307 I=1,28
7670 SRC1NB(I,N)=DEL*SC(I)
7671 DBDTNB(I,N)=DEL*DSC(I)
7672 307 CONTINUE
7673 ENDIF
7674 303 CONTINUE
7675 301 CONTINUE
7676 !***NEXT COMPUTE R1T,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION
7677 ! WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A
7678 ! DIFFERENT DEPENDENCE ON (ZMASS).
7679 !---ALSO OBTAIN R1WD, WHICH IS R1T SUMMED OVER THE 160-560 CM-1 RANGE
7680 DO 311 I=1,28
7681 SUM4(I)=ZERO
7682 SUM6(I)=ZERO
7683 SUM7(I)=ZERO
7684 SUM8(I)=ZERO
7685 SUM4WD(I)=ZERO
7686 311 CONTINUE
7687 DO 313 N=1,NBLW
7688 CENT=CENTNB(N)
7689 !***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4
7690 ! SUM6,SUM7,SUM8
7691 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
7692 DO 315 I=1,28
7693 SUM4(I)=SUM4(I)+SRC1NB(I,N)
7694 SUM6(I)=SUM6(I)+DBDTNB(I,N)
7695 SUM7(I)=SUM7(I)+DBDTNB(I,N)*AROTNB(N)
7696 SUM8(I)=SUM8(I)+DBDTNB(I,N)*ALFANB(N)
7697 315 CONTINUE
7698 ENDIF
7699 !***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD
7700 IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
7701 DO 316 I=1,28
7702 SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N)
7703 316 CONTINUE
7704 ENDIF
7705 313 CONTINUE
7706 DO 317 I=1,28
7707 R1T(I)=SUM4(I)/TFOUR(I)
7708 R2(I)=SUM6(I)/FORTCU(I)
7709 S2(I)=SUM7(I)/FORTCU(I)
7710 T3(I)=SUM8(I)/FORTCU(I)
7711 R1WD(I)=SUM4WD(I)/TFOUR(I)
7712 317 CONTINUE
7713 DO 401 J=1,180
7714 DO 401 I=1,28
7715 SUM(I,J)=ZERO
7716 PERTSM(I,J)=ZERO
7717 SUM3(I,J)=ZERO
7718 SUMWDE(I,J)=ZERO
7719 401 CONTINUE
7720 !---FREQUENCY LOOP BEGINS---
7721 DO 411 N=1,NBLW
7722 CENT=CENTNB(N)
7723 !***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1
7724 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
7725 DO 413 J=1,180
7726 X2(J)=AROTNB(N)*ZROOT(J)
7727 EXPO(J)=EXP(-X2(J))
7728 413 CONTINUE
7729 DO 415 J=1,180
7730 IF (X2(J).GE.HUNDRED) THEN
7731 EXPO(J)=ZERO
7732 ENDIF
7733 415 CONTINUE
7734 DO 417 J=121,180
7735 FAC(J)=ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J))
7736 417 CONTINUE
7737 DO 419 J=1,180
7738 DO 419 I=1,28
7739 SUM(I,J)=SUM(I,J)+SRC1NB(I,N)*EXPO(J)
7740 PERTSM(I,J)=PERTSM(I,J)+DBDTNB(I,N)*EXPO(J)
7741 419 CONTINUE
7742 DO 421 J=121,180
7743 DO 421 I=1,28
7744 SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J)
7745 421 CONTINUE
7746 ENDIF
7747 !---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE)
7748 IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
7749 DO 420 J=1,180
7750 DO 420 I=1,28
7751 SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J)
7752 420 CONTINUE
7753 ENDIF
7754 411 CONTINUE
7755 DO 431 J=1,180
7756 DO 431 I=1,28
7757 EM1(I,J)=SUM(I,J)/TFOUR(I)
7758 TABLE1(I,J)=PERTSM(I,J)/FORTCU(I)
7759 431 CONTINUE
7760 DO 433 J=121,180
7761 DO 433 I=1,28
7762 EM3(I,J)=SUM3(I,J)/FORTCU(I)
7763 433 CONTINUE
7764 DO 441 J=1,179
7765 DO 441 I=1,28
7766 TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*TEN
7767 441 CONTINUE
7768 DO 443 J=1,180
7769 DO 443 I=1,27
7770 TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*HP1
7771 443 CONTINUE
7772 DO 445 I=1,28
7773 TABLE2(I,180)=ZERO
7774 445 CONTINUE
7775 DO 447 J=1,180
7776 TABLE3(28,J)=ZERO
7777 447 CONTINUE
7778 DO 449 J=1,2
7779 DO 449 I=1,28
7780 EM1(I,J)=R1T(I)
7781 449 CONTINUE
7782 DO 451 J=1,120
7783 DO 451 I=1,28
7784 EM3(I,J)=R2(I)/TWO-S2(I)*SQRT(ZMASS(J))/THREE+T3(I)*ZMASS(J)/EIGHT
7785 451 CONTINUE
7786 DO 453 J=121,180
7787 DO 453 I=1,28
7788 EM3(I,J)=EM3(I,J)/ZMASS(J)
7789 453 CONTINUE
7790 !***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY.
7791 ! WE USE R1WD AND SUMWDE OBTAINED ABOVE.
7792 DO 501 J=1,180
7793 DO 501 I=1,28
7794 EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I)
7795 501 CONTINUE
7796 DO 503 J=1,2
7797 DO 503 I=1,28
7798 EM1WDE(I,J)=R1WD(I)
7799 503 CONTINUE
7801 END SUBROUTINE TABLE
7803 !---------------------------------------------------------------------
7804 SUBROUTINE SOLARD(IHRST,IDAY,MONTH,JULYR)
7805 !---------------------------------------------------------------------
7806 IMPLICIT NONE
7807 !---------------------------------------------------------------------
7808 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
7809 ! . . . .
7810 ! SUBPROGRAM: SOLARD COMPUTE THE SOLAR-EARTH DISTANCE
7811 ! PRGRMMR: Q.ZHAO ORG: W/NMC2 DATE: 96-7-23
7812 !
7813 ! ABSTRACT:
7814 ! SOLARD CALCULATES THE SOLAR-EARTH DISTANCE ON EACH DAY
7815 ! FOR USE IN SHORT-WAVE RADIATION.
7816 !
7817 ! PROGRAM HISTORY LOG:
7818 ! 96-07-23 Q.ZHAO - ORIGINATOR
7819 ! 98-10-09 Q.ZHAO - CHANGED TO USE IW3JDN IN W3LIB TO
7820 ! CALCULATE JD.
7821 ! 04-11-18 Y.-T. HOU - FIXED ERROR IN JULIAN DAY CALCULATION
7822 !
7823 ! USAGE: CALL SOLARD FROM SUBROUTINE INIT
7824 !
7825 ! INPUT ARGUMENT LIST:
7826 ! NONE
7827 !
7828 ! OUTPUT ARGUMENT LIST:
7829 ! R1 - THE NON-DIMENSIONAL DISTANCE BETWEEN SUN AND THE EARTH
7830 ! (LESS THAN 1.0 IN SUMMER AND LARGER THAN 1.0 IN WINTER).
7831 !
7832 ! INPUT FILES:
7833 ! NONE
7834 !
7835 ! OUTPUT FILES:
7836 ! NONE
7837 !
7838 ! SUBPROGRAMS CALLED:
7839 !
7840 ! UNIQUE: NONE
7841 !
7842 ! LIBRARY: IW3JDN
7843 !
7844 ! COMMON BLOCKS: CTLBLK
7845 !
7846 ! ATTRIBUTES:
7847 ! LANGUAGE: FORTRAN 90
7848 ! MACHINE : IBM SP
7849 !***********************************************************************
7850 REAL, PARAMETER :: PI=3.1415926,PI2=2.*PI
7851 !-----------------------------------------------------------------------
7852 ! INTEGER, INTENT(IN ) :: IHRST,IDAT(3)
7853 INTEGER, INTENT(IN ) :: IHRST,IDAY,MONTH,JULYR
7854 ! REAL , INTENT(OUT) :: R1
7855 !-----------------------------------------------------------------------
7856 INTEGER :: NDM(12),JYR19,JMN
7857 REAL :: CCR
7859 DATA JYR19/1900/, JMN/0/, CCR/1.3E-6/
7860 DATA NDM/0,31,59,90,120,151,181,212,243,273,304,334/
7862 !.....TPP = DAYS BETWEEN EPOCH AND PERIHELION PASSAGE OF 1900
7863 !.....JDOR1 = JD OF DECEMBER 30, 1899 AT 12 HOURS UT
7864 !.....JDOR2 = JD OF EPOCH WHICH IS JANUARY 0, 1990 AT 12 HOURS UT
7865 !
7866 REAL :: TPP
7867 DATA TPP/1.55/
7869 INTEGER :: JDOR2,JDOR1
7870 DATA JDOR2/2415020/, JDOR1/2415019/
7872 REAL :: DAYINC,DAT,T,YEAR,DATE,EM,E,EC,EP,CR,FJD,FJD1
7873 INTEGER :: JHR,JD,ITER
7874 !
7875 ! LIBRARY: IW3JDN
7876 !
7877 ! --------------------------------------------------------------------
7878 ! COMPUTES JULIAN DAY AND FRACTION FROM YEAR, MONTH, DAY AND TIME UT
7879 ! ACCURATE ONLY BETWEEN MARCH 1, 1900 AND FEBRUARY 28, 2100
7880 ! BASED ON JULIAN CALENDAR CORRECTED TO CORRESPOND TO GREGORIAN
7881 ! CALENDAR DURING THIS PERIOD
7882 ! --------------------------------------------------------------------
7884 JHR=IHRST
7885 !
7886 JD=IDAY-32075 &
7887 +1461*(JULYR+4800+(MONTH-14)/12)/4 &
7888 +367*(MONTH-2-(MONTH-14)/12*12)/12 &
7889 -3*((JULYR+4900+(MONTH-14)/12)/100)/4
7890 IF(JHR.LT.12)THEN
7891 JD=JD-1
7892 FJD=.5+.041666667*REAL(JHR)+.00069444444*REAL(JMN)
7893 ELSE
7894 7 FJD=.041666667E0*FLOAT(JHR-12)+.00069444444E0*FLOAT(JMN)
7895 END IF
7896 DAYINC=JHR/24.0
7897 FJD1=JD+FJD+DAYINC
7898 JD=FJD1
7899 FJD=FJD1-JD
7900 !***
7901 !*** CALCULATE THE SOLAR-EARTH DISTANCE
7902 !***
7903 DAT=REAL(JD-JDOR2)-TPP+FJD
7904 !***
7905 ! COMPUTES TIME IN JULIAN CENTURIES AFTER EPOCH
7906 !***
7907 T=FLOAT(JD-JDOR2)/36525.E0
7908 !***
7909 ! COMPUTES LENGTH OF ANOMALISTIC AND TROPICAL YEARS (MINUS 365 DAYS)
7910 !***
7911 YEAR=.25964134E0+.304E-5*T
7912 !***
7913 ! COMPUTES ORBIT ECCENTRICITY FROM T
7914 !***
7915 EC=.01675104E0-(.418E-4+.126E-6*T)*T
7916 YEAR=YEAR+365.E0
7917 !***
7918 ! DATE=DAYS SINCE LAST PERIHELION PASSAGE
7919 !***
7920 DATE = MOD(DAT,YEAR)
7921 !***
7922 ! SOLVE ORBIT EQUATIONS BY NEWTON'S METHOD
7923 !***
7924 EM=PI2*DATE/YEAR
7925 E=1.E0
7926 ITER = 0
7927 31 EP=E-(E-EC*SIN(E)-EM)/(1.E0-EC*COS(E))
7928 CR=ABS(E-EP)
7929 E=EP
7930 ITER = ITER + 1
7931 IF(ITER.GT.10) GOTO 1031
7932 IF(CR.GT.CCR) GO TO 31
7933 1031 CONTINUE
7934 R1=1.E0-EC*COS(E)
7935 !
7936 WRITE(0,1000)JULYR,MONTH,IDAY,IHRST,R1
7937 1000 FORMAT('SUN-EARTH DISTANCE CALCULATION FINISHED IN SOLARD'/ &
7938 'YEAR=',I5,' MONTH=',I3,' DAY=',I3,' HOUR=' &
7939 , I3,' R1=',F9.4)
7940 !***
7941 ! RETURN TO RADTN
7942 !***
7943 END SUBROUTINE SOLARD
7944 !---------------------------------------------------------------------
7945 SUBROUTINE CAL_MON_DAY(JULDAY,julyr,Jmonth,Jday)
7946 !---------------------------------------------------------------------
7947 IMPLICIT NONE
7948 !-----------------------------------------------------------------------
7949 INTEGER, INTENT(IN) :: JULDAY,julyr
7950 INTEGER, INTENT(OUT) :: Jmonth,Jday
7951 LOGICAL :: LEAP,NOT_FIND_DATE
7952 INTEGER :: MONTH (12),itmpday,itmpmon,i
7953 !-----------------------------------------------------------------------
7954 DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
7955 !***********************************************************************
7956 NOT_FIND_DATE = .true.
7958 itmpday = JULDAY
7959 itmpmon = 1
7960 LEAP=.FALSE.
7961 IF(MOD(julyr,4).EQ.0)THEN
7962 MONTH(2)=29
7963 LEAP=.TRUE.
7964 ENDIF
7966 i = 1
7967 DO WHILE (NOT_FIND_DATE)
7968 IF(itmpday.GT.MONTH(i))THEN
7969 itmpday=itmpday-MONTH(i)
7970 ELSE
7971 Jday=itmpday
7972 Jmonth=i
7973 NOT_FIND_DATE = .false.
7974 ENDIF
7975 i = i+1
7976 END DO
7978 END SUBROUTINE CAL_MON_DAY
7979 !!================================================================================
7980 ! CO2 initialization code
7982 FUNCTION ANTEMP(L,Z)
7983 REAL :: ZB(10,7),C(11,7),DELTA(10,7),TSTAR(7)
7984 ! ************** TROPICAL SOUNDING **************************
7985 DATA (ZB(N,1),N=1,10)/ 2.0, 3.0, 16.5, 21.5, 45.0, &
7986 51.0, 70.0, 100., 200., 300./
7987 DATA (C(N,1),N=1,11)/ -6.0, -4.0, -6.7, 4.0, 2.2, &
7988 1.0, -2.8, -.27, 0.0, 0.0, 0.0/
7989 DATA (DELTA(N,1),N=1,10)/.5, .5, .3, .5, 1.0, &
7990 1.0, 1.0, 1.0, 1.0, 1.0/
7991 ! ************** SUB-TROPICAL SUMMER ************************
7992 DATA (ZB(N,2),N=1,10)/ 1.5, 6.5, 13.0, 18.0, 26.0, &
7993 36.0, 48.0, 50.0, 70.0, 100./
7994 DATA (C(N,2),N=1,11)/ -4.0, -6.0, -6.5, 0.0, 1.2, &
7995 2.2, 2.5, 0.0, -3.0, -0.25, 0.0/
7996 DATA (DELTA(N,2),N=1,10)/ .5, 1.0, .5, .5, 1.0, &
7997 1.0, 2.5, .5, 1.0, 1.0/
7998 ! ************** SUB-TROPICAL WINTER ************************
7999 DATA (ZB(N,3),N=1,10)/ 3.0, 10.0, 19.0, 25.0, 32.0, &
8000 44.5, 50.0, 71.0, 98.0, 200.0/
8001 DATA (C(N,3),N=1,11)/ -3.5, -6.0, -0.5, 0.0, 0.4, &
8002 3.2, 1.6, -1.8, -0.7, 0.0, 0.0/
8003 DATA (DELTA(N,3),N=1,10)/ .5, .5, 1.0, 1.0, 1.0, &
8004 1.0, 1.0, 1.0, 1.0, 1.0/
8005 ! ************* SUB-ARCTIC SUMMER *************************
8006 DATA (ZB(N,4),N=1,10)/ 4.7, 10.0, 23.0, 31.8, 44.0, &
8007 50.2, 69.2, 100.0, 102.0, 103.0/
8008 DATA (C(N,4),N=1,11)/ -5.3, -7.0, 0.0, 1.4, 3.0, &
8009 0.7, -3.3, -0.2, 0.0, 0.0, 0.0/
8010 DATA (DELTA(N,4),N=1,10)/ .5, .3, 1.0, 1.0, 2.0, &
8011 1.0, 1.5, 1.0, 1.0, 1.0/
8012 ! ************ SUB-ARCTIC WINTER *****************************
8013 DATA (ZB(N,5),N=1,10)/ 1.0, 3.2, 8.5, 15.5, 25.0, &
8014 30.0, 35.0, 50.0, 70.0, 100.0/
8015 DATA (C(N,5),N=1,11)/ 3.0, -3.2, -6.8, 0.0, -0.6, &
8016 1.0, 1.2, 2.5, -0.7, -1.2, 0.0/
8017 DATA (DELTA(N,5),N=1,10)/ .4, 1.5, .3 , .5, 1.0, &
8018 1.0, 1.0, 1.0, 1.0, 1.0/
8019 ! ************ US STANDARD 1976 ******************************
8020 DATA (ZB(N,6),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, &
8021 71.0, 84.8520, 90.0, 91.0, 92.0/
8022 DATA (C(N,6),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, &
8023 -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/
8024 DATA (DELTA(N,6),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, &
8025 1.0, 1.0, 1.0, 1.0, 1.0/
8026 !
8027 ! ************ ENLARGED US STANDARD 1976 **********************
8028 DATA (ZB(N,7),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, &
8029 71.0, 84.8520, 90.0, 91.0, 92.0/
8030 DATA (C(N,7),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, &
8031 -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/
8032 DATA (DELTA(N,7),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, &
8033 1.0, 1.0, 1.0, 1.0, 1.0/
8034 !
8035 DATA TSTAR/ 300.0, 294.0, 272.2, 287.0, 257.1, 2*288.15/
8036 !
8037 NLAST=10
8038 TEMP=TSTAR(L)+C(1,L)*Z
8039 DO 20 N=1,NLAST
8040 EXPO=(Z-ZB(N,L))/DELTA(N,L)
8041 EXPP=ZB(N,L)/DELTA(N,L)
8042 !JD single-precision change
8043 ! FAC=EXP(EXPP)+EXP(-EXPP)
8044 !mp write(6,*) '.........................................'
8045 !mp what in the hell does the next line do?
8046 !mp
8047 !mp apparently if statement <0 or =0 then 23, else 24
8048 !mp IF(ABS(EXPO)-100.0) 23,23,24
8049 !
8050 ! changed to a more reasonable value for the workstation
8051 !
8052 IF(ABS(EXPO)-50.0) 23,23,24
8053 23 X=EXP(EXPO)
8054 Y=X+1.0/X
8055 ZLOG=ALOG(Y)
8056 GO TO 25
8057 24 ZLOG=ABS(EXPO)
8058 !mp 25 IF(EXPP-100.0) 27,27,28
8059 25 IF(EXPP-50.0) 27,27,28
8060 !JD single-precision change
8061 27 FAC=EXP(EXPP)+EXP(-EXPP)
8062 FACLOG=ALOG(FAC)
8063 GO TO 29
8064 28 FACLOG=EXPP
8065 ! TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)*
8066 ! 1 ALOG((EXP(EXPO)+EXP(-EXPO))/FAC))
8067 29 TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)* &
8068 (ZLOG-FACLOG))
8069 !mp write(6,*) 'ANTEMP pieces (C,C,ZLOG,FACLOG)', C(N+1,L),C(N,L),
8070 !mp + ZLOG,FACLOG
8071 20 CONTINUE
8072 ANTEMP=TEMP
8074 END FUNCTION ANTEMP
8076 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
8078 SUBROUTINE COEINT(RAT,IR)
8079 ! **********************************************************************
8080 !
8081 !
8082 ! THE TRANSMISSION FUNCTION BETWEEN P1 AND P2 IS ASSUMED TO
8083 ! THE FUNCTIONAL FORM
8084 ! TAU(P1,P2)= 1.0-SQRT(C*LOG(1.0+X*PATH)),
8085 ! WHERE
8086 ! PATH(P1,P2)=((P1-P2)**2)*(P1+P2+CORE)/
8087 ! (ETA*(P1+P2+CORE)+(P1-P2))
8088 !
8089 !
8090 ! THE PARAMETERS C AND X ARE FUNCTIONS OF P2, AND ARE TO BE DETER
8091 ! WHILE CORE IS A PRESPECIFIED NUMBER.ETA IS A FUNCTION OF THE TH
8092 ! PRODUCT (CX);IT IS OBTAITED ITERATIVELY. THE DERIVATION OF ALL
8093 ! VALUES WILL BE EXPLAINED IN A FORTHCOMING PAPER.
8094 ! SUBROUTINE COEINT DETERMINES C(I) AND X(I) BY USING THE ACT
8095 ! VALUES OF TAU(P(I-2),P(I)) AND TAU(P(I-1),P(I)) AND THE PREVIOU
8096 ! ITERATION VALUE OF ETA.
8097 ! DEFINE:
8098 ! PATHA=PATH(P(I),P(I-2),CORE,ETA)
8099 ! PATHB=PATH(P(I),P(I-1),CORE,ETA);
8100 ! THEN
8101 ! R=(1-TAU(P(I),P(I-2)))/(1-TAU(P(I),P(I-1)))
8102 ! = SQRT(LOG(1+X*PATHA)/LOG(1+X*PATHB)),
8103 ! SO THAT
8104 ! R**2= LOG(1+X*PATHA)/LOG(1+X*PATHB).
8105 ! THIS EQUATION CAN BE SOLVED BY NEWTON S METHOD FOR X AND THEN T
8106 ! RESULT USED TO FIND C. THIS IS REPEATED FOR EACH VALUE OF I GRE
8107 ! THAN 2 TO GIVE THE ARRAYS X(I) AND C(I).
8108 ! NEWTON S METHOD FOR SOLVING THE EQUATION
8109 ! F(X)=0
8110 ! MAKES USE OF THE LOOP XNEW= XOLD-F(XOLD)/FPRIME(XOLD).
8111 ! THIS IS ITERATED 20 TIMES, WHICH IS PROBABLY EXCESSIVE.
8112 ! THE FIRST GUESS FOR ETA IS 3.2E-4*EXP(-P(I)/1000),WHICH HAS
8113 ! BEEN FOUND TO BE FAIRLY REALISTIC BY EXPERIMENT; WE ITERATE 5 T
8114 ! (AGAIN,PROBABLY EXCESSIVELY) TO OBTAIN THE VALUES FOR C,X,ETA T
8115 ! USED FOR INTERPOLATION.
8116 ! THERE ARE SEVERAL POSSIBLE PITFALLS:
8117 ! 1) IN THE COURSE OF ITERATION, X MAY REACH A VALUE WHICH
8118 ! 1+X*PATHA NEGATIVE; IN THIS CASE THE ITERATION IS STOP
8119 ! AND AN ERROR MESSAGE IS PRINTED OUT.
8120 ! 2) EVEN IF (1) DOES NOT OCCUR, IT IS STILL POSSIBLE THAT
8121 ! BE NEGATIVE AND LARGE ENOUGH TO MAKE 1+X*PATH(P(I),0,C
8122 ! NEGATIVE. THIS IS CHECKED FOR IN A FINAL LOOP, AND IF
8123 ! A WARNING IS PRINTED OUT.
8124 !
8125 ! *********************************************************************
8126 !....
8127 ! IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8128 ! COMMON/PRESS/PA(109)
8129 REAL RAT,SINV
8130 ! REAL PA,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
8131 REAL PA2
8132 ! COMMON/TRAN/ TRANSA(109,109)
8133 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
8134 DIMENSION PATH0(109),ETAP(109),XAP(109),CAP(109)
8135 DIMENSION SINV(4)
8136 INTEGER :: IERR
8137 DATA SINV/2.74992,2.12731,4.38111,0.0832926/
8138 !NOV89 DIMENSION SINV(3)
8139 !NOV89 DATA SINV/2.74992,2.12731,4.38111/
8140 !O222 OLD CODE USED 2.7528 RATHER THAN 2.74992 ---K.A.C. OCTOBER 1988
8141 !O222 WHEN 2.7528 WAS USED,WE EXACTLY REPRODUCED THE MRF CO2 ARRAYS
8142 CORE=5.000
8143 UEXP=0.90
8144 ! P0=0.7
8145 DO 902 I=1,109
8146 PA2=PA(I)*PA(I)
8147 SEXPV(I)=.505+2.0E-5*PA(I)+.035*(PA2-.25)/(PA2+.25)
8148 902 CONTINUE
8149 DO 900 I=1,109
8150 ETA(I)=3.2E-4*EXP(-PA(I)/500.)
8151 ETAP(I)=ETA(I)
8152 900 CONTINUE
8153 DO 1200 NP=1,10
8154 DO 1000 I=3,109
8155 SEXP=SEXPV(I)
8156 R=(1.0D0-TRANSA(I,I-2))/(1.0D0-TRANSA(I,I-1))
8157 REXP=R**(UEXP/SEXP)
8158 arg1=path(pa(i),pa(i-2),core,eta(i))
8159 arg2=path(pa(i),pa(i-1),core,eta(i))
8160 PATHA=(PATH(PA(I),PA(I-2),CORE,ETA(I)))**UEXP
8161 PATHB=(PATH(PA(I),PA(I-1),CORE,ETA(I)))**UEXP
8162 XX=2.0D0*(PATHB*REXP-PATHA)/(PATHB*PATHB*REXP-PATHA*PATHA)
8163 DO 1010 LL=1,20
8164 F1=DLOG(1.0D0+XX*PATHA)
8165 F2=DLOG(1.0D0+XX*PATHB)
8166 F=F1/F2-REXP
8167 FPRIME=(F2*PATHA/(1.0D0+XX*PATHA)-F1*PATHB/(1.0D0+XX*PATHB))/ &
8168 (F2*F2)
8169 XX=XX-F/FPRIME
8170 CHECK=1.0D0+XX*PATHA
8171 !!!! IF (CHECK) 1020,1020,1025
8172 IF(CHECK.LE.0.)THEN
8173 WRITE(errmess,360)I,LL,CHECK
8174 WRITE(errmess,*)' xx=',xx,' patha=',patha
8175 360 FORMAT(' ERROR,I=',I3,'LL=',I3,'CHECK=',F20.10)
8176 CALL wrf_error_fatal ( errmess )
8177 ENDIF
8178 1010 CONTINUE
8179 CA(I)=(1.0D0-TRANSA(I,I-2))**(UEXP/SEXP)/ &
8180 (DLOG(1.0D0+XX*PATHA)+1.0D-20)
8181 XA(I)=XX
8182 1000 CONTINUE
8183 XA(2)=XA(3)
8184 XA(1)=XA(3)
8185 CA(2)=CA(3)
8186 CA(1)=CA(3)
8187 DO 1100 I=3,109
8188 PATH0(I)=(PATH(PA(I),0.,CORE,ETA(I)))**UEXP
8189 PATH0(I)=1.0D0+XA(I)*PATH0(I)
8190 !+++ IF (PATH0(I).LT.0.) WRITE (6,361) I,PATH0(I),XA(I)
8191 1100 CONTINUE
8192 DO 1035 I=1,109
8193 SEXP=SEXPV(I)
8194 ETAP(I)=ETA(I)
8195 ETA(I)=(SINV(IR)/RAT)**(1./SEXP)* &
8196 (CA(I)*XA(I))**(1./UEXP)
8197 1035 CONTINUE
8198 !
8199 ! THE ETA FORMULATION IS DETAILED IN SCHWARZKOPF AND FELS(1985).
8200 ! THE QUANTITY SINV=(G*DELTANU)/(RCO2*D*S)
8201 ! IN CGS UNITS,WITH D,THE DIFFUSICITY FACTOR=2, AND
8202 ! S,THE SUM OF CO2 LINE STRENGTHS OVER THE 15UM CO2 BAND
8203 ! ALSO,THE DENOMINATOR IS MULTIPLIED BY
8204 ! 1000 TO PERMIT USE OF MB UNITS FOR PRESSURE.
8205 ! S IS ACTUALLY WEIGHTED BY B(250) AT 10 CM-1 WIDE INTERVALS,IN
8206 ! ORDER TO BE CONSISTENT WITH THE METHODS USED TO OBTAIN THE LBL
8207 ! 1-BAND CONSOLIDATED TRANCMISSION FUNCTIONS.
8208 ! FOR THE 490-850 INTERVAL (DELTANU=360,IR=1) SINV=2.74992.
8209 ! (SLIGHTLY DIFFERENT FROM 2.7528 USED IN EARLIER VERSIONS)
8210 ! FOR THE 490-670 INTERVAL (IR=2) SINV=2.12731
8211 ! FOR THE 670-850 INTERVAL (IR=3) SINV=4.38111
8212 ! FOR THE 2270-2380 INTERVAL (IR=4) SINV=0.0832926
8213 ! SINV HAS BEEN OBTAINED USING THE 1982 AFGL CATALOG FOR CO2
8214 ! RAT IS THE ACTUAL CO2 MIXING RATIO IN UNITS OF 330 PPMV,
8215 ! LETTING USE OF THIS FORMULATION FOR ANY CO2 CONCENTRATION.
8216 !
8217 ! WRITE (6,366) (NP,I,CA(I),XA(I),ETA(I),SEXPV(I),I=1,109)
8218 !366 FORMAT (2I4,4E20.12)
8219 1200 CONTINUE
8220 361 FORMAT (' **WARNING:** 1+XA*PATH(PA(I),0) IS NEGATIVE,I= ',I3,/ &
8221 20X,'PATH0(I)=',F16.6,' XA(I)=',F16.6)
8222 RETURN
8223 END SUBROUTINE COEINT
8225 !--------------
8228 !CCC PROGRAM CO2INS
8229 SUBROUTINE CO2INS(T22,T23,T66,IQ,L,LP1,iflag)
8230 ! *********************************************************
8231 ! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ******
8232 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988...
8233 ! ..... K.CAMPANA DECEMBER 1988-CLEANED UP FOR LAUNCHER
8234 ! ..... K.CAMPANA NOVEMBER 1989-ALTERED FOR NEW RADIATION
8235 ! *********************************************************
8236 DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3),T66(LP1,LP1,6)
8237 DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
8238 CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
8239 CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
8240 !CC ITIN=22
8241 !CC ITIN1=23
8242 !O222 LATEST CODE HAD IQ=1
8243 !CC IQ=4
8244 1011 FORMAT (4F20.14)
8245 !CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
8246 !CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
8247 !CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
8248 !CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
8249 !CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
8250 !CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
8251 DO 300 J=1,LP1
8252 DO 300 I=1,LP1
8253 CO2PO(I,J) = T22(I,J,1)
8254 !NOV89
8255 IF (IQ.EQ.5) GO TO 300
8256 !NOV89
8257 CO2PO1(I,J) = T22(I,J,2)
8258 CO2PO2(I,J) = T22(I,J,3)
8259 300 CONTINUE
8260 DO 301 J=1,LP1
8261 DO 301 I=1,LP1
8262 CO2800(I,J) = T23(I,J,1)
8263 !NOV89
8264 IF (IQ.EQ.5) GO TO 301
8265 !NOV89
8266 CO2801(I,J) = T23(I,J,2)
8267 CO2802(I,J) = T23(I,J,3)
8268 301 CONTINUE
8269 !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
8270 ! ARE:
8271 ! IQ=1 560-800 (CONSOL.=490-850)
8272 ! IQ=2 560-670 (CONSOL.=490-670)
8273 ! IQ=3 670-800 (CONSOL.=670-850)
8274 ! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850)
8275 !NOV89
8276 ! IQ=5 2270-2380 (CONSOL.=2270-2380)
8277 !NOV89
8278 ! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
8279 ! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
8280 ! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
8281 !NOV89
8282 ! NOTE: ALTHOUGH THE BAND TRANSMISSION FUNCTIONS ARE
8283 ! COMPUTED FOR ALL RADIATIVE BANDS, AS OF 9/28/88, THEY
8284 ! ARE WRITTEN OUT IN FULL ONLY FOR THE FULL 15 UM BAND CASES
8285 ! (IQ=1,4). IN OTHER CASES, THE TRANSMISSIVITIES (1,K) ARE
8286 ! WRITTEN OUT, AS THESE ARE THE ONLY ONES NEEDED FOR CTS
8287 ! CALCULATIONS. ALSO, FOR THE 4.3 UM BAND (IQ=5) THE TEMP.
8288 ! DERIVATIVE TERMS ARE NOT WRITTEN OUT, AS THEY ARE UNUSED.
8289 !NOV89
8290 IF (IQ.EQ.1) THEN
8291 C1=1.5
8292 C2x=0.5
8293 ENDIF
8294 IF (IQ.EQ.2) THEN
8295 C1=18./11.
8296 C2x=7./11.
8297 ENDIF
8298 IF (IQ.EQ.3) THEN
8299 C1=18./13.
8300 C2x=5./13.
8301 ENDIF
8302 IF (IQ.EQ.4) THEN
8303 C1=1.8
8304 C2x=0.8
8305 ENDIF
8306 !NOV89
8307 IF (IQ.EQ.5) THEN
8308 C1=1.0
8309 C2x=0.0
8310 ENDIF
8311 !NOV89
8312 DO 1021 I=1,LP1
8313 DO 1021 J=1,LP1
8314 CO2PO(J,I)=C1*CO2PO(J,I)-C2x
8315 CO2800(J,I)=C1*CO2800(J,I)-C2x
8316 !NOV89
8317 IF (IQ.EQ.5) GO TO 1021
8318 !NOV89
8319 CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
8320 CO2801(J,I)=C1*CO2801(J,I)-C2x
8321 CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
8322 CO2802(J,I)=C1*CO2802(J,I)-C2x
8323 1021 CONTINUE
8324 !NOV89
8325 IF (IQ.GE.1.AND.IQ.LE.4) THEN
8326 !NOV89
8327 DO 1 J=1,LP1
8328 DO 1 I=1,LP1
8329 DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
8330 DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
8331 D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
8332 D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
8333 1 CONTINUE
8334 !NOV89
8335 ENDIF
8336 !NOV89
8337 !O222 *********************************************************
8338 !CC REWIND 66
8339 ! SAVE CDT51,CO251,C2D51,CDT58,CO258,C2D58..ON TEMPO FILE
8340 !CC WRITE (66) DCDT10
8341 !CC WRITE (66) CO2PO
8342 !CC WRITE (66) D2CT10
8343 !CC WRITE (66) DCDT8
8344 !CC WRITE (66) CO2800
8345 !CC WRITE (66) D2CT8
8346 !CC REWIND 66
8347 !NOV89
8348 IF (IQ.EQ.1.OR.IQ.EQ.4) THEN
8349 !NOV89
8350 DO 400 J=1,LP1
8351 DO 400 I=1,LP1
8352 T66(I,J,1) = DCDT10(I,J)
8353 T66(I,J,2) = CO2PO(I,J)
8354 T66(I,J,3) = D2CT10(I,J)
8355 T66(I,J,4) = DCDT8(I,J)
8356 T66(I,J,5) = CO2800(I,J)
8357 T66(I,J,6) = D2CT8(I,J)
8358 400 CONTINUE
8359 !NOV89
8360 ELSE
8361 DO 409 I=1,LP1
8362 T66(I,1,2) = CO2PO(1,I)
8363 T66(I,1,5) = CO2800(1,I)
8364 IF (IQ.EQ.5) GO TO 409
8365 T66(I,1,1) = DCDT10(1,I)
8366 T66(I,1,3) = D2CT10(1,I)
8367 T66(I,1,4) = DCDT8(1,I)
8368 T66(I,1,6) = D2CT8(1,I)
8369 409 CONTINUE
8370 ENDIF
8371 !NOV89
8372 !O222 *********************************************************
8373 RETURN
8374 END SUBROUTINE CO2INS
8375 !O222 PROGRAM CO2INT(INPUT,TAPE5=INPUT)
8376 !NOV89
8377 SUBROUTINE CO2INT(ITAPE,T15A,T15B,T22,RATIO,IR,NMETHD,NLEVLS,NLP1,NLP2)
8378 !NOV89
8379 ! *********************************************************
8380 ! CHANGES TO DATA READ AND FORMAT SEE CO222 ***
8381 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988
8382 ! CHANGES TO PASS ITAPE,AND IF IR=4,READ 1 CO2 REC..KAC NOV89
8383 ! *********************************************************
8384 ! CO2INT INTERPOLATES CARBON DIOXIDE TRANSMISSION FUNCTIONS
8385 ! FROM THE 109 LEVEL GRID,FOR WHICH THE TRANSMISSION FUNCTIONS
8386 ! HAVE BEEN PRE-CALCULATED, TO THE GRID STRUCTURE SPECIFIED BY THE
8387 ! USER.
8388 !
8389 ! METHOD:
8390 !
8391 ! CO2INT IS EMPLOYABLE FOR TWO PURPOSES: 1) TO OBTAIN TRANSMIS-
8392 ! SIVITIES BETWEEN ANY 2 OF AN ARRAY OF USER-DEFINED PRESSURES; AND
8393 ! 2) TO OBTAIN LAYER-MEAN TRANSMISSIVITIES BETWEEN ANY 2 OF AN ARRAY
8394 ! OF USER-DEFINED PRESSURE LAYERS.TO CLARIFY THESE TWO PURPOSES,SEE
8395 ! THE DIAGRAM AND DISCUSSION BELOW.
8396 ! CO2INT MAY BE USED TO EXECUTE ONLY ONE PURPOSE AT ONE TIME.
8397 !
8398 ! LET P BE AN ARRAY OF USER-DEFINED PRESSURES
8399 ! AND PD BE USER-DEFINED PRESSURE LAYERS.
8400 !
8401 ! - - - - - - - - - PD(I-1) ---
8402 ! ^
8403 ! ----------------- P(I) ^ PRESSURE LAYER I (PLM(I))
8404 ! ^
8405 ! - - - - - - - - - PD(I) ---
8406 ! ^
8407 ! ----------------- P(I+1) ^ PRESSURE LAYER I+1 (PLM(I+1))
8408 ! ^
8409 ! - - - - - - - - - PD(I+1)---
8410 ! ... (THE NOTATION USED IS
8411 ! ... CONSISTENT WITH THE CODE)
8412 ! ...
8413 ! - - - - - - - - - PD(J-1)
8414 !
8415 ! ----------------- P(J)
8416 !
8417 ! - - - - - - - - - PD(J)
8418 !
8419 ! PURPOSE 1: THE TRANSMISSIVITY BETWEEN SPECIFIC PRESSURES
8420 ! P(I) AND P(J) ,TAU(P(I),P(J)) IS COMPUTED BY THIS PROGRAM.
8421 ! IN THIS MODE,THERE IS NO REFERENCE TO LAYER PRESSURES PD
8422 ! (PD,PLM ARE NOT INPUTTED).
8423 !
8424 ! PURPOSE 2: THE LAYER-MEAN TRANSMISSIVITY BETWEEN A LAYER-
8425 ! MEAN PRESSURE PLM(J) AND PRESSURE LAYER I IS GIVEN BY
8426 ! TAULM(PLM(I),PLM(J)). IT IS COMPUTED BY THE INTEGRAL
8427 !
8428 ! PD(I)
8429 ! ----
8430 ! 1 ^
8431 ! ------------- * ^ TAU ( P',PLM(J) ) DP'
8432 ! PD(I)-PD(I-1) ^
8433 ! ----
8434 ! PD(I-1)
8435 !
8436 ! THE LAYER-MEAN PRESSURE PLM(I) IS SPECIFIED BY THE USER.
8437 ! FOR MANY PURPOSES,PLM WILL BE CHOSEN TO BE THE AVERAGE
8438 ! PRESSURE IN THE LAYER-IE,PLM(I)=0.5*(PD(I-1)+PD(I)).
8439 ! FOR LAYER-MEAN TRANSMISSIVITIES,THE USER THUS INPUTS
8440 ! A PRESSURE ARRAY (PD) DEFINING THE PRESSURE LAYERS AND AN
8441 ! ARRAY (PLM) DEFINING THE LAYER-MEAN PRESSURES.THE CALCULATION
8442 ! DOES NOT DEPEND ON THE P ARRAY USED FOR PURPOSE 1 (P IS NOT
8443 ! INPUTTED).
8444 !
8445 ! THE FOLLOWING PARAGRAPHS DEPICT THE UTILIZATION OF THIS
8446 ! CODE WHEN USED TO COMPUTE TRANSMISSIVITIES BETWEEN SPECIFIC
8447 ! PRESSURES. LATER PARAGRAPHS DESCRIBE ADDITIONAL FEATURES NEEDED
8448 ! FOR LAYER-MEAN TRANSMISSIVITIES.
8449 !
8450 ! FOR A GIVEN CO2 MIXING RATIO AND STANDARD TEMPERATURE
8451 ! PROFILE,A TABLE OF TRANSMISSION FUNCTIONS FOR A FIXED GRID
8452 ! OF ATMOSPHERIC PRESSURES HAS BEEN PRE-CALCULATED.
8453 ! THE STANDARD TEMPERATURE PROFILE IS COMPUTED FROM THE US
8454 ! STANDARD ATMOSPHERE (1977) TABLE.ADDITIONALLY, THE
8455 ! SAME TRANSMISSION FUNCTIONS HAVE BEEN PRE-CALCULATED FOR A
8456 ! TEMPERATURE PROFILE INCREASED AND DECREASED (AT ALL LEVELS)
8457 ! BY 25 DEGREES.
8458 ! THIS PROGRAM READS IN THE PRESPECIFIED TRANSMISSION FUNCTIONS
8459 ! AND A USER-SUPPLIED PRESSURE GRID (P(I)) AND CALCULATES TRANS-
8460 ! MISSION FUNCTIONS ,TAU(P(I),P(J)), FOR ALL P(I) S AND P(J) S.
8461 ! A LOGARITHMIC INTERPOLATION SCHEME IS USED.
8462 ! THIS METHOD IS REPEATED FOR THE THREE TEMPERATURE PROFILES
8463 ! GIVEN ABOVE .THEREFORE OUTPUTS FROM THE PROGRAM ARE THREE TABLES
8464 ! OF TRANSMISSION FUNCTIONS FOR THE USER-SUPPLIED PRESSURE GRID.
8465 ! THE EXISTENCE OF THE THREE TABLES PERMITS SUBSEQUENT INTERPO-
8466 ! LATION TO A USER-SUPPLIED TEMPERATURE PROFILE USING THE METHOD
8467 ! DESCRIBED IN THE REFERENCE.SEE LIMITATIONS SECTION IF THE
8468 ! USER DESIRES TO OBTAIN ONLY 1 TABLE OF TRANSMISSIVITIES.
8469 !
8470 ! MODIFICATIONS FOR LAYER-MEAN TRANSMISSIVITIES:
8471 ! THE PRESSURES INPUTTED ARE THE LAYER-MEAN PRESSURES,PD,
8472 ! AND THE LAYER-MEAN PRESSURES ,PLM. A SERIES OF TRANSMISSIVITIES
8473 ! (TAU(P'',PLM(J)) ARE COMPUTED AND THE INTEGRAL GIVEN IN THE
8474 ! DISCUSSION OF PURPOSE 2 IS COMPUTED.FOR PLM(I) NOT EQUAL TO
8475 ! PLM(J) SIMPSON S RULE IS USED WITH 5 POINTS. IF PLM(I)=PLM(J)
8476 ! (THE -NEARBY LAYER- CASE) A 49-POINT QUADRATURE IS USED FOR
8477 ! GREATER ACCURACY.THE OUTPUT IS IN TAULM(PLM(I),PLM(J)).
8478 ! NOTE:
8479 ! TAULM IS NOT A SYMMETRICAL MATRIX. FOR THE ARRAY ELEMENT
8480 ! TAULM(PLM(I),PLM(J)),THE INNER(FIRST,MOST RAPIDLY VARYING)
8481 ! DIMENSION IS THE VARYING LAYER-MEAN PRESSURE,PLM(I);THE OUTER
8482 ! (SECOND) DIMENSION IS THE FIXED LAYER-MEAN PRESSURE PLM(J).
8483 ! THUS THE ELEMENT TAULM(2,3) IS THE TRANSMISSION FUNCTION BETWEEN
8484 ! THE FIXED PRESSURE PLM(3) AND THE PRESSURE LAYER HAVING AN AVERAG
8485 ! PRESSURE OF PLM(2).
8486 ! ALSO NOTE THAT NO QUADRATURE IS PERFORMED OVER THE LAYER
8487 ! BETWEEN THE SMALLEST NONZERO PRESSURE AND ZERO PRESSURE;
8488 ! TAULM IS TAULM(0,PLM(J)) IN THIS CASE,AND TAULM(0,0)=1.
8489 !
8490 !
8491 ! REFERENCE:
8492 ! S.B.FELS AND M.D.SCHWARZKOPF,-AN EFFICIENT ACCURATE
8493 ! ALGORITHM FOR CALCULATING CO2 15 UM BAND COOLING RATES-,JOURNAL
8494 ! OF GEOPHYSICAL RESEARCH,VOL.86,NO. C2, PP.1205-1232,1981.
8495 ! MODIFICATIONS TO THE ALGORITHM HAVE BEEN MADE BY THE AUTHORS;
8496 ! CONTACT S.B.F.OR M.D.S. FOR FURTHER DETAILS.A NOTE TO J.G.R.
8497 ! IS PLANNED TO DOCUMENT THESE CHANGES.
8498 !
8499 ! AUTHOR: M.DANIEL SCHWARZKOPF
8500 !
8501 ! DATE: 14 JULY 1983
8502 !
8503 ! ADDRESS:
8504 !
8505 ! G.F.D.L.
8506 ! P.O.BOX 308
8507 ! PRINCETON,N.J.08540
8508 ! U.S.A.
8509 ! TELEPHONE: (609) 452-6521
8510 !
8511 ! INFORMATION ON TAPE: THIS SOURCE IS THE FIRST FILE
8512 ! ON THIS TAPE.THE SIX FILES THAT FOLLOW ARE CO2 TRANS-
8513 ! MISSIVITIES FOR THE 500-850 CM-1 INTERVAL FOR CO2
8514 ! CONCENTRATIONS OF 330 PPMV (1X) ,660 PPMV (2X), AND
8515 ! 1320 PPMV (4X). THE FILES ARE ARRANGED AS FOLLOWS:
8516 ! FILE 2 1X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8517 ! FILE 3 1X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8518 ! FILE 4 2X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8519 ! FILE 5 2X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8520 ! FILE 6 4X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8521 ! FILE 7 4X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8522 ! FILES 2,4,6 ARE RECOMMENDED FOR USE IN OBTAINING
8523 ! TRANSMISSION FUNCTIONS FOR USE IN HEATING RATE
8524 ! COMPUTATIONS;THEY CORRESPOND TO THE TRANSMISSIVITIES
8525 ! DISCUSSED IN THE 1980 PAPER.FILES 3,5,7 ARE PROVIDED
8526 ! TO FACILITATE COMPARISON WITH OBSERVATION AND WITH OTHER
8527 ! CALCULATIONS.
8528 !
8529 ! PROGRAM LANGUAGE: FORTRAN 1977,INCLUDING PARAMETER
8530 ! AND PROGRAM STATEMENTS.THE PROGRAM IS WRITTEN ON A
8531 ! CYBER 170-730.SEE THE SECTION ON LIMITATIONS FOR
8532 ! ADAPTATIONS TO OTHER MACHINES.
8533 !
8534 ! INPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
8535 !
8536 ! UNIT NO VARIABLES FORMAT STATEMENT NO. TYPE
8537 ! 5 P (PURPOSE 1) (5E16.9) 201 CARDS
8538 ! 5 PD (PURPOSE 2) (5E16.9) 201 CARDS
8539 ! 5 PLM(PURPOSE 2) (5E16.9) 201 CARDS
8540 ! 5 NMETHD (I3) 202 CARDS
8541 ! 20 TRANSA (4F20.14) 102 TAPE
8542 !NOV89
8543 ! ITAPE TRANSA (4F20.14) 102 TAPE
8544 !NOV89
8545 !
8546 ! OUTPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
8547 !
8548 ! UNIT NO VARIABLES FORMAT STATEMENT NO.
8549 ! 6 TRNFCT (1X,8F15.8) 301 PRINT
8550 ! 22 TRNFCT (4F20.14) 102 TAPE
8551 !
8552 ! PARAMETER INPUTS:
8553 ! A) NLEVLS : NLEVLS IS AN (INTEGER) PARAMETER DENOTING
8554 ! THE NUMBER OF NONZERO PRESSURE LEVELS FOR PURPOSE 1
8555 ! OR THE NUMBER OF NONZERO LAYER PRESSURES NEEDED TO
8556 ! SPECIFY THE PRESSURE LAYERS(PURPOSE 2) IN THE OUTPUT
8557 ! GRID. FOR EXAMPLE,IN PURPOSE 1,IF P=0,100,1000,NLEVLS=2.
8558 ! IF,IN PURPOSE 2,PD=0,100,500,1000,THE NUMBER OF NONZERO
8559 ! PRESSURE LAYERS=2,SO NLEVLS=2
8560 ! IN THE CODE AS WRITTEN,NLEVLS=40; THE USER SHOULD
8561 ! CHANGE THIS VALUE TO A USER-SPECIFIED VALUE.
8562 ! B) NLP1,NLP2 : INTEGER PARAMETERS DEFINED AS: NLP1=NLEVLS+1;
8563 ! NLP2=NLEVLS+2.
8564 ! SEE LIMITATIONS FOR CODE MODIFICATIONS IF PARAMETER
8565 ! STATEMENTS ARE NOT ALLOWED ON YOUR MACHINE.
8566 !
8567 ! INPUTS:
8568 !
8569 ! A) TRANSA : THE 109X109 GRID OF TRANSMISSION FUNCTIONS
8570 ! TRANSA IS A DOUBLE PRECISION REAL ARRAY.
8571 !
8572 ! TRANSA IS READ FROM FILE 20. THIS FILE CONTAINS 3
8573 ! RECORDS,AS FOLLOWS:
8574 ! 1) TRANSA, STANDARD TEMPERATURE PROFILE
8575 ! 3) TRANSA, STANDARD TEMPERATURES + 25 DEG
8576 ! 5) TRANSA, STANDARD TEMPERATURES - 25 DEG
8577 !
8578 ! B) NMETHD: AN INTEGER WHOSE VALUE IS EITHER 1 (IF CO2INT IS
8579 ! TO BE USED FOR PURPOSE 1) OR 2 (IF CO2INT IS TO BE USED FOR
8580 ! PURPOSE 2).
8581 !
8582 ! C) P,PD,PLM :
8583 ! P IS A REAL ARRAY (LENGTH NLP1) SPECIFYING THE PRESSURE
8584 ! GRID AT WHICH TRANSMISSION FUNCTIONS ARE TO BE COMPUTED FOR
8585 ! PURPOSE 1.THE DIMENSION OF P IS IN MILLIBARS.THE
8586 ! FOLLOWING LIMITATIONS WILL BE EXPLAINED MORE
8587 ! IN THE SECTION ON LIMITATIONS: P(1) MUST BE ZERO; P(NLP1),THE
8588 ! LARGEST PRESSURE, MUST NOT EXCEED 1165 MILLIBARS.
8589 ! PD IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE PRESSURE
8590 ! LAYERS FOR WHICH LAYER-AVERAGED TRANSMISSION FUNCTIONS ARE
8591 ! TO BE COMPUTED.THE DIMENSION OF PD IS MILLIBARS.THE LIMITATIONS
8592 ! FOR PD ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
8593 ! LIMITATIONS.
8594 ! PLM IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE LAYER-MEAN
8595 ! PRESSURES. THE DIMENSION OF PLM IS MILLIBARS. THE LIMITATIONS
8596 ! FOR PLM ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
8597 ! LIMITATIONS.PD IS READ IN BEFORE PLM.
8598 !
8599 ! NOTE: AGAIN,WE NOTE THAT THE USER WILL INPUT EITHER P (FOR
8600 ! PURPOSE 1) OR PD AND PLM(FOR PURPOSE 2) BUT NOT BOTH.
8601 !
8602 !
8603 !
8604 !
8605 ! LIMITATIONS:
8606 ! 1) P(1)=0.,PD(1)=0.,PLM(1)=0. THE TOP PRESSURE LEVEL
8607 ! MUST BE ZERO,OR THE TOP PRESSURE LAYER MUST BE BOUNDED BY ZERO.
8608 ! THE TOP LAYER-MEAN PRESSURE (PLM(1)) MUST BE ZERO; NO
8609 ! QUADRATURE IS DONE ON THE TOP PRESSURE LAYER.EVEN IF ONE IS
8610 ! NOT INTERESTED IN THE TRANSMISSION FUNCTION BETWEEN 0 AND P(J),
8611 ! ONE MUST INCLUDE SUCH A LEVEL.
8612 ! 2) PD(NLP2)=P(NLP1) IS LESS THAN OR EQUAL TO 1165 MB.
8613 ! EXTRAPOLATION TO HIGHER PRESSURES IS NOT POSSIBLE.
8614 ! 3) IF PROGRAM IS NOT PERMITTED ON YOUR COMPILER,
8615 ! SIMPLY DELETE THE LINE.
8616 ! 4) IF PARAMETER IS NOT PERMITTED,DO THE FOLLOWING:
8617 ! 1) DELETE ALL PARAMETER STATEMENTS IN CO2INT
8618 ! 2) AT THE POINT WHERE NMETHOD IS READ IN,ADD:
8619 ! READ (5,202) NLEVLS
8620 ! NLP1=NLEVLS+1
8621 ! NLP2=NLEVLS+2
8622 ! 3) CHANGE DIMENSION AND/OR COMMON STATEMENTS DEFINING
8623 ! ARRAYS TRNS,DELTA,P,PD,TRNFCT,PS,PDS,PLM IN CO2INT.
8624 ! THE NUMERICAL VALUE OF (NLEVLS+1) SHOULD BE INSERTED
8625 ! IN DIMENSION OR COMMON STATEMENTS FOR TRNS,DELTA,
8626 ! P,TRNFCT,PS,PLM; THE NUMERICAL VALUE OF (NLEVLS+2)
8627 ! IN DIMENSION OR COMMON STATEMENTS FOR PD,PDS.
8628 ! 5) PARAMETER (NLEVLS=40) AND THE OTHER PARAMETER
8629 ! STATEMENTS ARE WRITTEN IN CDC FORTRAN; ON OTHER MACHINES THE
8630 ! SAME STATEMENT MAY BE WRITTEN DIFFERENTLY,FOR EXAMPLE AS
8631 ! PARAMETER NLEVLS=40
8632 ! 6) -DOUBLE PRECISION- IS USED INSTEAD OF -REAL*8- ,DUE TO
8633 ! REQUIREMENTS OF CDC FORTAN.
8634 ! 7) THE STATEMENT -DO 400 KKK=1,3- CONTROLS THE NUMBER OF
8635 ! TRANSMISSIVITY OUTPUT MATRICES PORDUCED BY THE PROGRAM.TO
8636 ! PRODUCE 1 OUTPUT MATRIX,DELETE THIS STATEMENT.
8637 !
8638 ! OUTPUT:
8639 ! A) TRNFCT IS AN (NLP1,NLP1) REAL ARRAY OF THE TRANSMISSION
8640 ! FUNCTIONS APPROPRIATE TO YOUR ARRAY. IT IS TO BE SAVED ON FILE 22.
8641 ! THE PROCEDURE FOR SAVING MAY BE MODIFIED; AS GIVEN HERE,THE
8642 ! OUTPUT IS IN CARD IMAGE FORM WITH A FORMAT OF (4F20.14).
8643 !
8644 ! B) PRINTED OUTPUT IS A LISTING OF TRNFCT ON UNIT 6, IN
8645 ! THE FORMAT (1X,8F15.8) (FORMAT STATEMENT 301). THE USER MAY
8646 ! MODIFY OR ELIMINATE THIS AT WILL.
8647 !
8648 ! ************ FUNCTION INTERPOLATER ROUTINE *****************
8649 !
8650 !
8651 ! ****** THE FOLLOWING PARAMETER GIVES THE NUMBER OF *******
8652 ! ****** DATA LEVELS IN THE MODEL *******
8653 ! ****************************************************************
8654 ! ****************************************************************
8655 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
8656 ! COMMON/PRESS/PA(109)
8657 ! COMMON/TRAN/ TRANSA(109,109)
8658 ! COMMON / OUTPUT / TRNS(NLP1,NLP1)
8659 ! COMMON/INPUTP/P(NLP1),PD(NLP2)
8660 DIMENSION TRNS(NLP1,NLP1)
8661 DIMENSION P(NLP1),PD(NLP2)
8662 DIMENSION PS(NLP1),PDS(NLP2),PLM(NLP1)
8663 DIMENSION NRTAB(3)
8664 DIMENSION T15A(NLP2,2),T15B(NLP1)
8665 DIMENSION T22(NLP1,NLP1,3)
8666 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
8667 DATA NRTAB/1,2,4/
8668 !***********************************
8669 ! THE FOLLOWING ARE THE INPUT FORMATS
8670 100 FORMAT (4F20.14)
8671 743 FORMAT (F20.14)
8672 201 FORMAT (5E16.9)
8673 202 FORMAT (I3)
8674 !O222 203 FORMAT (F12.6,I2)
8675 203 FORMAT (F12.6)
8676 ! THE FOLLOWING ARE THE OUTPUT FORMATS
8677 102 FORMAT (4F20.14)
8678 301 FORMAT (1X,8F15.8)
8679 !
8680 !CC REWIND 15
8681 !CC REWIND 20
8682 !NOV89
8683 REWIND ITAPE
8684 !NOV89
8685 !CC REWIND 22
8686 !
8687 ! CALCULATION OF PA -THE -TABLE- OF 109 GRID PRESSURES
8688 ! NOTE-THIS CODE MUST NOT BE CHANGED BY THE USER^^^^^^^^^
8689 PA(1)=0.
8690 FACT15=10.**(1./15.)
8691 FACT30=10.**(1./30.)
8692 PA(2)=1.0E-3
8693 DO 231 I=2,76
8694 PA(I+1)=PA(I)*FACT15
8695 231 CONTINUE
8696 DO 232 I=77,108
8697 PA(I+1)=PA(I)*FACT30
8698 232 CONTINUE
8699 !
8700 N=25
8701 NLV=NLEVLS
8702 NLP1V=NLP1
8703 NLP2V=NLP2
8704 ! READ IN THE CO2 MIXING RATIO(IN UNITS OF 330 PPMV),AND AN INDEX
8705 ! GIVING THE FREQUENCY RANGE OF THE LBL DATA
8706 !O222 READ (5,203) RATIO,IR
8707 !CC IR = 1
8708 !CC READ (5,203) RATIO
8709 !O222 ***********************************
8710 !***VALUES FOR IR*****
8711 ! IR=1 CONSOL. LBL TRANS. =490-850
8712 ! IR=2 CONSOL. LBL TRANS. =490-670
8713 ! IR=3 CONSOL. LBL TRANS. =670-850
8714 ! IR=4 CONSOL. LBL TRANS. =2270-2380
8715 !*** IR MUST BE 1,2,3 OR 4 FOR THE PGM. TO WORK
8716 ! ALSO READ IN THE METHOD NO.(1 OR 2)
8717 !CC READ (5,202) NMETHD
8718 IF (RATIO.EQ.1.0) GO TO 621
8719 CALL wrf_error_fatal( 'SUBROUTINE CO2INT: 8746' )
8720 !NOV89 621 ITAP1=20
8721 621 ITAP1=ITAPE
8722 !NOV89
8723 NTAP=1
8724 IF (NMETHD.EQ.2) GO TO 502
8725 ! *****CARDS FOR PURPOSE 1(NMETHD=1)
8726 !CC READ (15,201) (P(I),I=1,NLP1)
8727 DO 300 I=1,NLP1
8728 P(I)=T15B(I)
8729 300 CONTINUE
8730 DO 801 I=1,NLP1
8731 PS(I)=P(I)
8732 801 CONTINUE
8733 GO TO 503
8734 502 CONTINUE
8735 ! *****CARDS FOR PURPOSE 2(NMETHD=2)
8736 !CC READ (15,201) (PD(I),I=1,NLP2)
8737 !CC READ (15,201) (PLM(I),I=1,NLP1)
8738 DO 303 I=1,NLP2
8739 PD(I)=T15A(I,1)
8740 303 CONTINUE
8741 DO 302 I=1,NLP1
8742 PLM(I)=T15A(I,2)
8743 302 CONTINUE
8744 DO 802 I=1,NLP1
8745 PDS(I)=PD(I+1)
8746 PS(I)=PLM(I)
8747 802 CONTINUE
8748 !
8749 503 CONTINUE
8750 ! *****DO LOOP CONTROLLING NUMBER OF OUTPUT MATRICES
8751 !NOV89
8752 !NOV89 DO 400 KKK=1,3
8753 ICLOOP = 3
8754 IF (IR.EQ.4) ICLOOP = 1
8755 DO 400 KKK=1,ICLOOP
8756 !NOV89
8757 ! **********************
8758 IF (NMETHD.EQ.2) GO TO 505
8759 ! *****CARDS FOR PURPOSE 1(NMETHD=1)
8760 DO 803 I=1,NLP1
8761 P(I)=PS(I)
8762 803 CONTINUE
8763 GO TO 506
8764 505 CONTINUE
8765 ! *****CARDS FOR PURPOSE 2(NMETHD=2)
8766 DO 804 I=1,NLP1
8767 PD(I)=PDS(I)
8768 P(I)=PS(I)
8769 804 CONTINUE
8770 !
8771 506 CONTINUE
8772 IA=108
8773 IAP=IA+1
8774 !NOV89 IF (NTAP.EQ.1) READ (20,100) ((TRANSA(I,J),I=1,109),J=1,109)
8775 !mp IF (NTAP.EQ.1) READ (ITAPE,100) ((TRANSA(I,J),I=1,109),J=1,109)
8776 IF (NTAP.EQ.1) THEN
8777 IF ( wrf_dm_on_monitor() ) READ (ITAPE,743) ((TRANSA(I,J),I=1,109),J=1,109)
8778 CALL wrf_dm_bcast_bytes ( TRANSA , size ( TRANSA ) * RWORDSIZE )
8779 ENDIF
8780 !mp IF (NTAP.EQ.1) READ (ITAPE,100) (tmp(I),I=1,11881
8781 !mp
8782 do J=109,1,-6
8783 !mp write(6,697)(TRANSA(I,J),I=5,105,10)
8784 enddo
8785 ! 697 format(11(f5.3,1x))
8786 !mp
8787 !NOV89
8788 DO 4 I=1,IAP
8789 TRANSA(I,I)=1.0
8790 4 CONTINUE
8791 CALL COEINT(RATIO,IR)
8792 DO 805 I=1,NLP1
8793 DO 805 J=1,NLP1
8794 TRNS(J,I)=1.00
8795 805 CONTINUE
8796 DO 10 I=1,NLP1
8797 DO 20 J=1,I
8798 IF (I.EQ.J) GO TO 20
8799 P1=P(J)
8800 P2=P(I)
8801 CALL SINTR2
8802 TRNS(J,I)=TRNSLO
8803 20 CONTINUE
8804 10 CONTINUE
8805 DO 47 I=1,NLP1
8806 DO 47 J=I,NLP1
8807 TRNS(J,I)=TRNS(I,J)
8808 47 CONTINUE
8809 ! *****THIS IS THE END OF PURPOSE 1 CALCULATIONS
8810 IF (NMETHD.EQ.1) GO TO 2872
8811 !
8812 DO 51 J=1,NLP1
8813 DO 52 I=2,NLP1
8814 IA=I
8815 JA=J
8816 N=25
8817 IF (I.NE.J) N=3
8818 CALL QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
8819 52 CONTINUE
8820 51 CONTINUE
8821 ! *****THIS IS THE END OF PURPOSE 2 CALCULATIONS
8822 2872 CONTINUE
8823 !
8824 !+++ WRITE (6,301) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
8825 !CC WRITE (22,102) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
8826 DO 304 J=1,NLP1
8827 DO 304 I=1,NLP1
8828 T22(I,J,KKK) = TRNS(I,J)
8829 304 CONTINUE
8830 400 CONTINUE
8831 RETURN
8832 END SUBROUTINE CO2INT
8833 !CCC PROGRAM CO2IN1
8834 SUBROUTINE CO2IN1(T20,T21,T66,IQ,L,LP1)
8835 ! CO2IN1=CO2INS FOR METHOD 1
8836 ! *********************************************************
8837 ! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ***
8838 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988
8839 ! ..... K.CAMPANA DECEMBER 88 CLEANED UP FOR LAUNCHER
8840 ! *********************************************************
8841 DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3),T66(L,6)
8842 DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
8843 CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
8844 CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
8845 ITIN=20
8846 ITIN1=21
8847 !O222 LATEST CODE HAS IQ=1
8848 !CC IQ=4
8849 1011 FORMAT (4F20.14)
8850 !CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
8851 !CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
8852 !CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
8853 !CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
8854 !CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
8855 !CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
8856 DO 300 J=1,LP1
8857 DO 300 I=1,LP1
8858 CO2PO(I,J) = T20(I,J,1)
8859 !NOV89
8860 IF (IQ.EQ.5) GO TO 300
8861 !NOV89
8862 CO2PO1(I,J) = T20(I,J,2)
8863 CO2PO2(I,J) = T20(I,J,3)
8864 300 CONTINUE
8865 DO 301 J=1,LP1
8866 DO 301 I=1,LP1
8867 CO2800(I,J) = T21(I,J,1)
8868 !NOV89
8869 IF (IQ.EQ.5) GO TO 301
8870 !NOV89
8871 CO2801(I,J) = T21(I,J,2)
8872 CO2802(I,J) = T21(I,J,3)
8873 301 CONTINUE
8874 !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
8875 ! ARE:
8876 ! IQ=1 560-800 (CONSOL.=490-850)
8877 ! IQ=2 560-670 (CONSOL.=490-670)
8878 ! IQ=3 670-800 (CONSOL.=670-850)
8879 ! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850)
8880 !NOV89
8881 ! IQ=5 2270-2380 (CONSOL.=2270-2380)
8882 !NOV89
8883 ! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
8884 ! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
8885 ! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
8886 IF (IQ.EQ.1) THEN
8887 C1=1.5
8888 C2x=0.5
8889 ENDIF
8890 IF (IQ.EQ.2) THEN
8891 C1=18./11.
8892 C2x=7./11.
8893 ENDIF
8894 IF (IQ.EQ.3) THEN
8895 C1=18./13.
8896 C2x=5./13.
8897 ENDIF
8898 IF (IQ.EQ.4) THEN
8899 C1=1.8
8900 C2x=0.8
8901 ENDIF
8902 !NOV89
8903 IF (IQ.EQ.5) THEN
8904 C1=1.0
8905 C2x=0.0
8906 ENDIF
8907 !NOV89
8908 DO 1021 I=1,LP1
8909 DO 1021 J=1,LP1
8910 CO2PO(J,I)=C1*CO2PO(J,I)-C2x
8911 CO2800(J,I)=C1*CO2800(J,I)-C2x
8912 !NOV89
8913 IF (IQ.EQ.5) GO TO 1021
8914 !NOV89
8915 CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
8916 CO2801(J,I)=C1*CO2801(J,I)-C2x
8917 CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
8918 CO2802(J,I)=C1*CO2802(J,I)-C2x
8919 1021 CONTINUE
8920 !NOV89
8921 IF (IQ.GE.1.AND.IQ.LE.4) THEN
8922 !NOV89
8923 DO 1 J=1,LP1
8924 DO 1 I=1,LP1
8925 DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
8926 DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
8927 D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
8928 D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
8929 1 CONTINUE
8930 !NOV89
8931 ENDIF
8932 !NOV89
8933 !O222 *********************************************************
8934 !CC REWIND 66
8935 ! SAVE CDTM51,CO2M51,C2DM51,CDTM58,CO2M58,C2DM58..ON TEMPO FILE
8936 !CC WRITE (66) (DCDT10(I,I+1),I=1,L)
8937 !CC WRITE (66) (CO2PO(I,I+1),I=1,L)
8938 !CC WRITE (66) (D2CT10(I,I+1),I=1,L)
8939 !CC WRITE (66) (DCDT8(I,I+1),I=1,L)
8940 !CC WRITE (66) (CO2800(I,I+1),I=1,L)
8941 !CC WRITE (66) (D2CT8(I,I+1),I=1,L)
8942 !CC REWIND 66
8943 !O222 *********************************************************
8944 DO 400 I=1,L
8945 T66(I,2) = CO2PO(I,I+1)
8946 T66(I,5) = CO2800(I,I+1)
8947 !NOV89
8948 IF (IQ.EQ.5) GO TO 400
8949 !NOV89
8950 T66(I,1) = DCDT10(I,I+1)
8951 T66(I,3) = D2CT10(I,I+1)
8952 T66(I,4) = DCDT8(I,I+1)
8953 T66(I,6) = D2CT8(I,I+1)
8954 400 CONTINUE
8955 RETURN
8956 END SUBROUTINE CO2IN1
8957 !CCC PROGRAM PTZ - COURTESY OF DAN SCHWARZKOPF,GFDL DEC 1987....
8958 SUBROUTINE CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
8959 SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLP2)
8960 !
8961 ! ** THIS PROGRAM CALCULATES TEMPERATURES ,H2O MIXING RATIOS
8962 ! ** AND O3 MIXING RATIOS BY USING AN ANALYTICAL
8963 ! ** FUNCTION WHICH APPROXIMATES
8964 ! ** THE US STANDARD (1976). THIS IS
8965 ! ** CALCULATED IN FUNCTION 'ANTEMP', WHICH IS CALLED BY THE
8966 ! ** MAIN PROGRAM. THE FORM OF THE ANALYTICAL FUNCTION WAS
8967 ! ** SUGGESTED TO ME IN 1971 BY RICHARD S. LINDZEN.
8968 ! ******************************************************************
8969 ! CODE TO SAVE STEMP,GTEMP ON DATA SET,BRACKETED BY CO222 **
8970 ! ....K. CAMPANA MARCH 88,OCTOBER 88
8971 DIMENSION SGTEMP(NLP,2),T41(NLP2,2),T42(NLP), &
8972 T43(NLP2,2),T44(NLP)
8973 DIMENSION SGLVNU(NLP),SIGLNU(NL)
8974 DIMENSION SFULL(NLP),SHALF(NL)
8975 ! ******************************************************************
8976 !
8977 !*****THIS VERSION IS ONLY USABLE FOR 1976 US STD ATM AND OBTAINS
8978 ! QUANTITIES FOR CO2 INTERPOLATION AND INSERTION INTO OPERA-
8979 ! TIONAL RADIATION CODES
8980 !
8981 CHARACTER*20 PROFIL
8982 DIMENSION PRESS(NLP),TEMP(NLP),ALT(NLP),WMIX(NLP),O3MIX(NLP)
8983 DIMENSION WMXINT(NLP,4),WMXOUT(NLP2),OMXINT(NLP,4),OMXOUT(NLP2)
8984 DIMENSION PD(NLP2),GTEMP(NLP)
8985 DIMENSION PRS(NLP),TEMPS(NLP),PRSINT(NLP),TMPINT(NLP,4),A(NLP,4)
8986 DIMENSION PROUT(NLP2),TMPOUT(NLP2),TMPFLX(NLP2),TMPMID(NLP2)
8987 !
8988 !
8989 DATA PROFIL/ &
8990 'US STANDARD 1976'/
8991 DATA PSMAX/1013.250/
8992 !
8993 ! ** NTYPE IS AN INTEGER VARIABLE WHICH HAS THE FOLLOWING
8994 ! ** VALUES: 0 =SIGMA LEVELS ARE USED; 1= SKYHI L40 LEVELS
8995 ! ** ARE USED; 2 = SKYHI L80 LEVELS ARE USED. DEFAULT: 0
8996 !
8997 NTYPE=0
8998 !O222 READ (*,*) NTYPE
8999 5 NLEV=NL
9000 DELZAP=0.5
9001 R=8.31432
9002 G0=9.80665
9003 ZMASS=28.9644
9004 AA=6356.766
9005 ALT(1)=0.0
9006 TEMP(1)=ANTEMP(6,0.0)
9007 !*******DETERMINE THE PRESSURES (PRESS)
9008 PSTAR=PSMAX
9009 !
9010 !*** LTOP COMPUTATION MOVED FROM MODEL INITIALIZATION
9011 !
9012 LTOP(1)=0
9013 LTOP(2)=0
9014 LTOP(3)=0
9015 DO 30 N=1,NL
9016 PCLD=(PSTAR-PPTOP*10.)*SHALF(N)+PPTOP*10.
9017 IF(PCLD.GE.642.)LTOP(1)=N
9018 IF(PCLD.GE.350.)LTOP(2)=N
9019 IF(PCLD.GE.150.)LTOP(3)=N
9020 ! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
9021 30 CONTINUE
9022 !
9023 !O222 IF (NTYPE.EQ.1) CALL SKYP(PSTAR,PD,GTEMP)
9024 !O222 IF (NTYPE.EQ.2) CALL SKY80P(PSTAR,PD,GTEMP)
9025 !O222 IF (NTYPE.EQ.0) CALL SIGP(PSTAR,PD,GTEMP)
9026 !CC---- CALL SIGP(PSTAR,PD,GTEMP)
9027 NLM=NL-1
9028 CALL SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9029 SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLM,NLP2)
9030 PD(NLP2)=PSTAR
9031 DO 40 N=1,NLP
9032 PRSINT(N)=PD(NLP2+1-N)
9033 40 CONTINUE
9034 ! *** CALCULATE TEMPS FOR SEVERAL PRESSURES TO DO QUADRATURE
9035 DO 504 NQ=1,4
9036 DO 505 N=2,NLP
9037 505 PRESS(N)=PRSINT(N)+0.25*(NQ-1)*(PRSINT(N-1)-PRSINT(N))
9038 PRESS(1)=PRSINT(1)
9039 !*********************
9040 DO 100 N=1,NLEV
9041 !
9042 ! ** ESTABLISH COMPUTATATIONAL LEVELS BETWEEN USER LEVELS AT
9043 ! ** INTERVALS OF APPROXIMATELY 'DELZAP' KM.
9044 !
9045 DLOGP=7.0*ALOG(PRESS(N)/PRESS(N+1))
9046 NINT=DLOGP/DELZAP
9047 NINT=NINT+1
9048 ZNINT=NINT
9049 ! G=G0
9050 DZ=R*DLOGP/(7.0*ZMASS*G0*ZNINT)
9051 HT=ALT(N)
9052 !
9053 ! ** CALCULATE HEIGHT AT NEXT USER LEVEL BY MEANS OF
9054 ! ** RUNGE-KUTTA INTEGRATION.
9055 !
9056 DO 200 M=1,NINT
9057 RK1=ANTEMP(6,HT)*DZ
9058 RK2=ANTEMP(6,HT+0.5*RK1)*DZ
9059 RK3=ANTEMP(6,HT+0.5*RK2)*DZ
9060 RK4=ANTEMP(6,HT+RK3)*DZ
9061 !mp write(6,*) 'RK values,DZ ', RK1,RK2,RK3,RK4,DZ
9062 HT=HT+0.16666667*(RK1+RK2+RK2+RK3+RK3+RK4)
9063 200 CONTINUE
9064 ALT(N+1)=HT
9065 TEMP(N+1)=ANTEMP(6,HT)
9066 100 CONTINUE
9067 DO 506 N=1,NLP
9068 TMPINT(N,NQ)=TEMP(N)
9069 A(N,NQ)=ALT(N)
9070 506 CONTINUE
9071 504 CONTINUE
9072 !O222 *****************************************************
9073 !***OUTPUT TEMPERATURES
9074 !O222 *****************************************************
9075 DO 901 N=1,NLP
9076 SGTEMP(N,1) = TMPINT(NLP2-N,1)
9077 901 CONTINUE
9078 !O222 *****************************************************
9079 !***OUTPUT GTEMP
9080 !O222 *****************************************************
9081 DO 902 N=1,NLP
9082 SGTEMP(N,2) = GTEMP(N)
9083 902 CONTINUE
9084 !O222 *****************************************************
9085 RETURN
9086 END SUBROUTINE CO2PTZ
9087 FUNCTION PATH(A,B,C,E)
9088 !....
9089 ! DOUBLE PRECISION XA,CA
9090 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
9091 PEXP=1./SEXP
9092 PATH=((A-B)**PEXP*(A+B+C))/(E*(A+B+C)+(A-B)**(PEXP-1.))
9093 RETURN
9094 END FUNCTION PATH
9095 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9096 SUBROUTINE QINTRP(XM,X0,XP,FM,F0,FP,X,F)
9097 !....
9098 ! DOUBLE PRECISION FM,F0,FP,F,D1,D2,B,A,DEL
9099 D1=(FP-F0)/(XP-X0)
9100 D2=(FM-F0)/(XM-X0)
9101 B=(D1-D2)/(XP-XM)
9102 A=D1-B*(XP-X0)
9103 DEL=(X-X0)
9104 F=F0+DEL*(A+DEL*B)
9105 RETURN
9106 END SUBROUTINE QINTRP
9107 SUBROUTINE QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
9108 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
9109 DIMENSION P(NLP1V),PD(NLP2V),TRNS(NLP1V,NLP1V)
9110 DIMENSION WT(101)
9111 N2=2*N
9112 N2P=2*N+1
9113 ! *****WEIGHTS ARE CALCULATED
9114 WT(1)=1.
9115 DO 21 I=1,N
9116 WT(2*I)=4.
9117 WT(2*I+1)=1.
9118 21 CONTINUE
9119 IF (N.EQ.1) GO TO 25
9120 DO 22 I=2,N
9121 WT(2*I-1)=2.
9122 22 CONTINUE
9123 25 CONTINUE
9124 TRNSNB=0.
9125 DP=(PD(IA)-PD(IA-1))/N2
9126 PFIX=P(JA)
9127 DO 1 KK=1,N2P
9128 PVARY=PD(IA-1)+(KK-1)*DP
9129 IF (PVARY.GE.PFIX) P2=PVARY
9130 IF (PVARY.GE.PFIX) P1=PFIX
9131 IF (PVARY.LT.PFIX) P1=PVARY
9132 IF (PVARY.LT.PFIX) P2=PFIX
9133 CALL SINTR2
9134 TRNSNB=TRNSNB+TRNSLO*WT(KK)
9135 1 CONTINUE
9136 TRNS(IA,JA)=TRNSNB*DP/(3.*(PD(IA)-PD(IA-1)))
9137 RETURN
9138 END SUBROUTINE QUADSR
9139 !---------------------------------------------------------------------
9140 SUBROUTINE SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9141 SIGLV,SIGLY,PPTOP,LREAD,KD,KP,KM,KP2)
9142 DIMENSION Q(KD),QMH(KP),PD(KP2),PLM(KP),GTEMP(KP),PDT(KP2)
9143 DIMENSION SIGLY(KD),SIGLV(KP)
9144 DIMENSION CI(KP),SGLVNU(KP),DEL(KD),SIGLNU(KD),CL(KD),RPI(KM)
9145 DIMENSION IDATE(4)
9146 DIMENSION T41(KP2,2),T42(KP), &
9147 T43(KP2,2),T44(KP)
9148 ! integer :: retval
9149 ! character(50) :: prsmid='prsmid'
9150 !CC 18 LEVEL SIGMAS FOR NMC MRF(NEW) MODEL
9151 !CC DATA Q/.021,.074,.124,.175,.225,.275,.325,.375,.425,.497, &
9152 !CC .594,.688,.777,.856,.920,.960,.981,.995/
9153 ! FOR SIGMA MODELS,Q=SIGMA,QMH=0.5(Q(I)+Q(I+1),
9154 ! PD=Q*PSS,PLM=QMH*PSS.PSS=SURFACE PRESSURE(SPEC.)
9155 !
9156 !..... GET NMC SIGMA STRUCTURE
9157 !CC IF (LREAD.GT.0) GO TO 914
9158 !--- PPTOP IS MODEL TOP PRESSURE IN CB....
9159 ! SIGMA DATA IS BOTTOM OF ATMOSPHERE TO T.O.A.....
9160 !cccc PPTOP=5.0
9161 ! READ(11,PPTOP,END=12321)
9162 12321 CONTINUE
9163 ! WRITE(6,88221)PPTOP,KD,KP
9164 !88221 FORMAT(' ENTER SIGP PPTOP=',E12.5,' KD=',I2,' KP=',I2)
9165 ! open(unit=23,file='fort.23',form='unformatted' &
9166 ! , access='sequential')
9167 ! REWIND 23
9168 ! READ(23)SIGLY
9169 ! DO KKK=1,KD
9170 ! SIGLY(KKK)=1.-(FLOAT(KKK)-0.5)/KD
9171 ! END DO
9172 ! WRITE(6,88222)
9173 !88222 FORMAT(' READ AETA')
9174 ! DO 37821 LLL=1,KD
9175 ! WRITE(6,37820)LLL,SIGLY(LLL)
9176 !37820 FORMAT(' L=',I2,' AETA=',E12.5)
9177 !37821 CONTINUE
9178 ! READ(23)SIGLV
9179 ! DO KKK=1,KP
9180 ! SIGLV(KKK)=1.-(FLOAT(KKK-1))/KD
9181 ! END DO
9182 ! WRITE(6,88223)
9183 !88223 FORMAT(' READ ETA')
9184 ! PRINT 704,(SIGLY(K),K=1,KD)
9185 ! PRINT 704,(SIGLV(K),K=1,KP)
9186 ! DO 37823 LLL=1,KP
9187 ! WRITE(6,37822)LLL,SIGLV(LLL)
9188 !37822 FORMAT(' L=',I2,' ETA=',E12.5)
9189 !37823 CONTINUE
9190 701 FORMAT(F6.2)
9191 702 FORMAT(7F10.6)
9192 IF (PPTOP.LE.0.) GO TO 708
9193 PSFC=100.
9194 !--- IF PTOP NOT EQUAL TO ZERO ADJUST SIGMA SO AS TO GET PROPER STD ATM
9195 ! VERTICAL LOCATION
9196 DO 706 K=1,KD
9197 SIGLY(K) = (SIGLY(K)*(PSFC-PPTOP)+PPTOP)/PSFC
9198 706 CONTINUE
9199 DO 707 K=1,KP
9200 SIGLV(K) = (SIGLV(K)*(PSFC-PPTOP)+PPTOP)/PSFC
9201 707 CONTINUE
9202 708 CONTINUE
9203 ! PRINT 703,PPTOP
9204 ! PRINT 704,(SIGLY(K),K=1,KD)
9205 ! PRINT 704,(SIGLV(K),K=1,KP)
9206 703 FORMAT(1H ,'PTOP =',F6.2)
9207 704 FORMAT(1H ,7F10.6)
9208 DO 913 K=1,KP
9209 SGLVNU(K) = SIGLV(K)
9210 IF (K.LE.KD) SIGLNU(K) = SIGLY(K)
9211 913 CONTINUE
9212 DO 77 K=1,KD
9213 Q(K) = SIGLNU(KD+1-K)
9214 77 CONTINUE
9215 PSS= 1013250.
9216 QMH(1)=0.
9217 QMH(KP)=1.
9218 DO 1 K=2,KD
9219 QMH(K)=0.5*(Q(K-1)+Q(K))
9220 1 CONTINUE
9221 PD(1)=0.
9222 PD(KP2)=PSS
9223 DO 2 K=2,KP
9224 PD(K)=Q(K-1)*PSS
9225 2 CONTINUE
9226 ! call int_get_fresh_handle(retval)
9227 ! close(retval)
9228 ! write(0,*)' before open in CO2O3'
9229 ! open(unit=retval,file=prsmid,form='UNFORMATTED',iostat=ier)
9230 ! write(0,*)' after open1'
9231 ! do k=1,62
9232 ! write(retval)pd(k)
9233 ! enddo
9234 ! close(retval)
9235 PLM(1)=0.
9236 DO 3 K=1,KM
9237 PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
9238 3 CONTINUE
9239 PLM(KP)=PSS
9240 DO 4 K=1,KD
9241 GTEMP(K)=PD(K+1)**0.2*(1.+PD(K+1)/30000.)**0.8/1013250.
9242 4 CONTINUE
9243 GTEMP(KP)=0.
9244 !+++ WRITE (6,100) (GTEMP(K),K=1,KD)
9245 !+++ WRITE (6,100) (PD(K),K=1,KP2)
9246 !+++ WRITE (6,100) (PLM(K),K=1,KP)
9247 !***TAPES 41,42 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM (PS=1013MB)
9248 ! THE FOLLOWING PUTS P-DATA INTO MB
9249 DO 11 I=1,KP
9250 PD(I)=PD(I)*1.0E-3
9251 PLM(I)=PLM(I)*1.0E-3
9252 11 CONTINUE
9253 PD(KP2)=PD(KP2)*1.0E-3
9254 !CC WRITE (41,101) (PD(K),K=1,KP2)
9255 !CC WRITE (41,101) (PLM(K),K=1,KP)
9256 !CC WRITE (42,101) (PLM(K),K=1,KP)
9257 DO 300 K=1,KP2
9258 T41(K,1) = PD(K)
9259 300 CONTINUE
9260 DO 301 K=1,KP
9261 T41(K,2) = PLM(K)
9262 T42(K) = PLM(K)
9263 301 CONTINUE
9264 !***STORE AS PDT,SO THAT RIGHT PD IS RETURNED TO PTZ
9265 DO 12 I=1,KP2
9266 PDT(I)=PD(I)
9267 12 CONTINUE
9268 !***SECOND PASS: PSS=810MB,GTEMP NOT COMPUTED
9269 PSS=0.8*1013250.
9270 QMH(1)=0.
9271 QMH(KP)=1.
9272 DO 201 K=2,KD
9273 QMH(K)=0.5*(Q(K-1)+Q(K))
9274 201 CONTINUE
9275 PD(1)=0.
9276 PD(KP2)=PSS
9277 DO 202 K=2,KP
9278 PD(K)=Q(K-1)*PSS
9279 202 CONTINUE
9280 PLM(1)=0.
9281 DO 203 K=1,KM
9282 PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
9283 203 CONTINUE
9284 PLM(KP)=PSS
9285 !+++ WRITE (6,100) (PD(K),K=1,KP2)
9286 !+++ WRITE (6,100) (PLM(K),K=1,KP)
9287 !***TAPES 43,44 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM(PS=810 MB)
9288 ! THE FOLLOWING PUTS P-DATA INTO MB
9289 DO 211 I=1,KP
9290 PD(I)=PD(I)*1.0E-3
9291 PLM(I)=PLM(I)*1.0E-3
9292 211 CONTINUE
9293 PD(KP2)=PD(KP2)*1.0E-3
9294 !CC WRITE (43,101) (PD(K),K=1,KP2)
9295 !CC WRITE (43,101) (PLM(K),K=1,KP)
9296 !CC WRITE (44,101) (PLM(K),K=1,KP)
9297 DO 302 K=1,KP2
9298 T43(K,1) = PD(K)
9299 302 CONTINUE
9300 DO 303 K=1,KP
9301 T43(K,2) = PLM(K)
9302 T44(K) = PLM(K)
9303 303 CONTINUE
9304 !***RESTORE PD
9305 DO 212 I=1,KP2
9306 PD(I)=PDT(I)
9307 212 CONTINUE
9308 100 FORMAT (1X,5E20.13)
9309 101 FORMAT (5E16.9)
9310 RETURN
9311 END SUBROUTINE SIGP
9312 !---------------------------------------------------------------------
9313 SUBROUTINE SINTR2
9314 !....
9315 ! IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9316 ! REAL P1,P2,PA,TRNSLO,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
9317 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
9318 ! COMMON/PRESS/ PA(109)
9319 ! COMMON/TRAN/ TRANSA(109,109)
9320 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
9321 DO 70 L=1,109
9322 IP1=L
9323 IF (P2-PA(L)) 65,65,70
9324 70 CONTINUE
9325 65 I=IP1-1
9326 IF (IP1.EQ.1) IP1=2
9327 IF (I.EQ.0) I=1
9328 DO 80 L=1,109
9329 JP1=L
9330 IF (P1-PA(L)) 75,75,80
9331 80 CONTINUE
9332 75 J=JP1-1
9333 IF (JP1.EQ.1) JP1=2
9334 IF (J.EQ.0) J=1
9335 JJJ=J
9336 III=I
9337 J=JJJ
9338 JP1=J+1
9339 I=III
9340 IP1=I+1
9341 ! DETERMINE ETAP,THE VALUE OF ETA TO USE BY LINEAR INTERPOLATION
9342 ! FOR PETA(=0.5*(P1+P2))
9343 PETA=P2
9344 DO 90 L=1,109
9345 IETAP1=L
9346 IF (PETA-PA(L)) 85,85,90
9347 90 CONTINUE
9348 85 IETA=IETAP1-1
9349 IF (IETAP1.EQ.1) IETAP1=2
9350 IF (IETA.EQ.0) IETA=1
9351 ETAP=ETA(IETA)+(PETA-PA(IETA))*(ETA(IETAP1)-ETA(IETA))/ &
9352 (PA(IETAP1)-PA(IETA))
9353 SEXP=SEXPV(IETA)+(PETA-PA(IETA))*(SEXPV(IETAP1)- &
9354 SEXPV(IETA))/ (PA(IETAP1)-PA(IETA))
9355 PIPMPI=PA(IP1)-PA(I)
9356 UP2P1=(PATH(P2,P1,CORE,ETAP))**UEXP
9357 IF (I-J) 126,126,127
9358 126 CONTINUE
9359 TRIP=(CA(IP1)*DLOG(1.0D0+XA(IP1)*UP2P1))**(SEXP/UEXP)
9360 TRI=(CA(I)*DLOG(1.0D0+XA(I)*UP2P1))**(SEXP/UEXP)
9361 TRNSLO=1.0D0-((PA(IP1)-P2)*TRI+(P2-PA(I))*TRIP)/PIPMPI
9362 GO TO 128
9363 127 TIJ=TRANSA(I,J)
9364 TIPJ=TRANSA(I+1,J)
9365 TIJP=TRANSA(I,J+1)
9366 TIPJP=TRANSA(I+1,J+1)
9367 UIJ=(PATH(PA(I),PA(J),CORE,ETAP))**UEXP
9368 UIPJ=(PATH(PA(I+1),PA(J),CORE,ETAP))**UEXP
9369 UIJP=(PATH(PA(I),PA(J+1),CORE,ETAP))**UEXP
9370 UIPJP=(PATH(PA(I+1),PA(J+1),CORE,ETAP))**UEXP
9371 PRODI=CA(I)*XA(I)
9372 PRODIP=CA(I+1)*XA(I+1)
9373 PROD=((PA(I+1)-P2)*PRODI+(P2-PA(I))*PRODIP)/PIPMPI
9374 XINT=((PA(I+1)-P2)*XA(I)+(P2-PA(I))*XA(I+1))/PIPMPI
9375 CINT=PROD/XINT
9376 AIJ=(CINT*DLOG(1.0D0+XINT*UIJ))**(SEXP/UEXP)
9377 AIJP=(CINT*DLOG(1.0D0+XINT*UIJP))**(SEXP/UEXP)
9378 AIPJ=(CINT*DLOG(1.0D0+XINT*UIPJ))**(SEXP/UEXP)
9379 AIPJP=(CINT*DLOG(1.0D0+XINT*UIPJP))**(SEXP/UEXP)
9380 EIJ=TIJ+AIJ
9381 EIPJ=TIPJ+AIPJ
9382 EIJP=TIJP+AIJP
9383 EIPJP=TIPJP+AIPJP
9384 DTDJ=(EIJP-EIJ)/(PA(J+1)-PA(J))
9385 DTDPJ=(EIPJP-EIPJ)/(PA(J+1)-PA(J))
9386 EPIP1=EIJ+DTDJ*(P1-PA(J))
9387 EPIPP1=EIPJ+DTDPJ*(P1-PA(J))
9388 EPP2P1=((PA(I+1)-P2)*EPIP1+(P2-PA(I))*EPIPP1)/PIPMPI
9389 TRNSLO=EPP2P1-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
9390 IF (I.GE.108.OR.J.GE.108) GO TO 350
9391 IF (I-J-2) 350,350,355
9392 355 CONTINUE
9393 TIP2J=TRANSA(I+2,J)
9394 TIP2JP=TRANSA(I+2,J+1)
9395 TI2J2=TRANSA(I+2,J+2)
9396 TIJP2=TRANSA(I,J+2)
9397 TIPJP2=TRANSA(I+1,J+2)
9398 UIP2J=(PATH(PA(I+2),PA(J),CORE,ETAP))**UEXP
9399 UIJP2=(PATH(PA(I),PA(J+2),CORE,ETAP))**UEXP
9400 UIPJP2=(PATH(PA(I+1),PA(J+2),CORE,ETAP))**UEXP
9401 UI2J2=(PATH(PA(I+2),PA(J+2),CORE,ETAP))**UEXP
9402 UIP2JP=(PATH(PA(I+2),PA(J+1),CORE,ETAP))**UEXP
9403 AIJP2=(CINT*DLOG(1.0D0+XINT*UIJP2))**(SEXP/UEXP)
9404 AIPJP2=(CINT*DLOG(1.0D0+XINT*UIPJP2))**(SEXP/UEXP)
9405 AIP2J=(CINT*DLOG(1.0D0+XINT*UIP2J))**(SEXP/UEXP)
9406 AIP2JP=(CINT*DLOG(1.0D0+XINT*UIP2JP))**(SEXP/UEXP)
9407 AI2J2=(CINT*DLOG(1.0D0+XINT*UI2J2))**(SEXP/UEXP)
9408 EIP2J=TIP2J+AIP2J
9409 EIP2JP=TIP2JP+AIP2JP
9410 EIJP2=TIJP2+AIJP2
9411 EIPJP2=TIPJP2+AIPJP2
9412 EI2J2=TI2J2+AI2J2
9413 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIJ,EIJP,EIJP2,P1,EI)
9414 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIPJ,EIPJP,EIPJP2,P1,EP)
9415 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIP2J,EIP2JP,EI2J2,P1,EP2)
9416 CALL QINTRP(PA(I),PA(I+1),PA(I+2),EI,EP,EP2,P2,EPSIL)
9417 TRNSLO=EPSIL-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
9418 350 CONTINUE
9419 128 CONTINUE
9420 205 CONTINUE
9421 RETURN
9422 END SUBROUTINE SINTR2
9423 SUBROUTINE CO2O3(SFULL,SHALF,PPTOP,L,LP1,LP2)
9424 !CCC PROGRAM CO2O3 = CONSOLIDATION OF A NUMBER OF DAN SCHWARZKOPF,GFDL
9425 ! CODES TO PRODUCE A FILE OF CO2 HGT DATA
9426 ! FOR ANY VERTICAL COORDINATE (READ BY SUBROUTINE
9427 ! CONRAD IN THE GFDL RADIATION CODES)-K.A.C. JUN89.
9428 !NOV89--UPDATED (NOV 89) FOR LATEST GFDL LW RADIATION.....K.A.C.
9429 LOGICAL :: opened
9430 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
9431 CHARACTER*80 errmess
9432 ! integer :: retval,kk,ka,kb
9433 ! character(50) :: co2='co2'
9434 INTEGER etarad_unit61, etarad_unit62, etarad_unit63,IERROR
9435 DIMENSION SGTEMP(LP1,2),CO2D1D(L,6),CO2D2D(LP1,LP1,6)
9436 !NOV89
9437 DIMENSION CO2IQ2(LP1,LP1,6),CO2IQ3(LP1,LP1,6),CO2IQ5(LP1,LP1,6)
9438 !NOV89
9439 DIMENSION T41(LP2,2),T42(LP1), &
9440 T43(LP2,2),T44(LP1)
9441 DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3)
9442 DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3)
9443 DIMENSION SGLVNU(LP1),SIGLNU(L)
9444 DIMENSION SFULL(LP1),SHALF(L)
9445 ! DIMENSION STEMP(LP1),GTEMP(LP1)
9446 ! DIMENSION CDTM51(L),CO2M51(L),C2DM51(L)
9447 ! DIMENSION CDTM58(L),CO2M58(L),C2DM58(L)
9448 ! DIMENSION CDT51(LP1,LP1),CO251(LP1,LP1),C2D51(LP1,LP1)
9449 ! DIMENSION CDT58(LP1,LP1),CO258(LP1,LP1),C2D58(LP1,LP1)
9450 !NOV89
9451 ! DIMENSION CDT31(LP1),CO231(LP1),C2D31(LP1)
9452 ! DIMENSION CDT38(LP1),CO238(LP1),C2D38(LP1)
9453 ! DIMENSION CDT71(LP1),CO271(LP1),C2D71(LP1)
9454 ! DIMENSION CDT78(LP1),CO278(LP1),C2D78(LP1)
9455 ! DIMENSION CO211(LP1),CO218(LP1)
9456 ! EQUIVALENCE (CDT31(1),CO2IQ2(1,1,1)),(CO231(1),CO2IQ2(1,1,2))
9457 ! EQUIVALENCE (C2D31(1),CO2IQ2(1,1,3)),(CDT38(1),CO2IQ2(1,1,4))
9458 ! EQUIVALENCE (CO238(1),CO2IQ2(1,1,5)),(C2D38(1),CO2IQ2(1,1,6))
9459 ! EQUIVALENCE (CDT71(1),CO2IQ3(1,1,1)),(CO271(1),CO2IQ3(1,1,2))
9460 ! EQUIVALENCE (C2D71(1),CO2IQ3(1,1,3)),(CDT78(1),CO2IQ3(1,1,4))
9461 ! EQUIVALENCE (CO278(1),CO2IQ3(1,1,5)),(C2D78(1),CO2IQ3(1,1,6))
9462 ! EQUIVALENCE (CO211(1),CO2IQ5(1,1,2)),(CO218(1),CO2IQ5(1,1,5))
9463 !NOV89
9464 ! EQUIVALENCE (STEMP(1),SGTEMP(1,1)),(GTEMP(1),SGTEMP(1,2))
9465 ! EQUIVALENCE (CDTM51(1),CO2D1D(1,1)),(CO2M51(1),CO2D1D(1,2))
9466 ! EQUIVALENCE (C2DM51(1),CO2D1D(1,3)),(CDTM58(1),CO2D1D(1,4))
9467 ! EQUIVALENCE (CO2M58(1),CO2D1D(1,5)),(C2DM58(1),CO2D1D(1,6))
9468 ! EQUIVALENCE (CDT51(1,1),CO2D2D(1,1,1)),(CO251(1,1),CO2D2D(1,1,2))
9469 ! EQUIVALENCE (C2D51(1,1),CO2D2D(1,1,3)),(CDT58(1,1),CO2D2D(1,1,4))
9470 ! EQUIVALENCE (CO258(1,1),CO2D2D(1,1,5)),(C2D58(1,1),CO2D2D(1,1,6))
9472 !
9473 ! Deallocate before reading. This is required for nested domain init.
9474 !
9475 IF(ALLOCATED (CO251))DEALLOCATE(CO251)
9476 IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
9477 IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
9478 IF(ALLOCATED (CO258))DEALLOCATE(CO258)
9479 IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
9480 IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
9481 IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
9482 IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
9483 IF(ALLOCATED (CO231))DEALLOCATE(CO231)
9484 IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
9485 IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
9486 IF(ALLOCATED (CO238))DEALLOCATE(CO238)
9487 IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
9488 IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
9489 IF(ALLOCATED (CO271))DEALLOCATE(CO271)
9490 IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
9491 IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
9492 IF(ALLOCATED (CO278))DEALLOCATE(CO278)
9493 IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
9494 IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
9495 IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
9496 IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
9497 IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
9498 IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
9499 IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
9500 IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
9501 !
9502 ALLOCATE(CO251(LP1,LP1))
9503 ALLOCATE(CDT51(LP1,LP1))
9504 ALLOCATE(C2D51(LP1,LP1))
9505 ALLOCATE(CO258(LP1,LP1))
9506 ALLOCATE(CDT58(LP1,LP1))
9507 ALLOCATE(C2D58(LP1,LP1))
9508 ALLOCATE(STEMP(LP1))
9509 ALLOCATE(GTEMP(LP1))
9510 ALLOCATE(CO231(LP1))
9511 ALLOCATE(CDT31(LP1))
9512 ALLOCATE(C2D31(LP1))
9513 ALLOCATE(CO238(LP1))
9514 ALLOCATE(CDT38(LP1))
9515 ALLOCATE(C2D38(LP1))
9516 ALLOCATE(CO271(LP1))
9517 ALLOCATE(CDT71(LP1))
9518 ALLOCATE(C2D71(LP1))
9519 ALLOCATE(CO278(LP1))
9520 ALLOCATE(CDT78(LP1))
9521 ALLOCATE(C2D78(LP1))
9522 ALLOCATE(CO2M51(L))
9523 ALLOCATE(CDTM51(L))
9524 ALLOCATE(C2DM51(L))
9525 ALLOCATE(CO2M58(L))
9526 ALLOCATE(CDTM58(L))
9527 ALLOCATE(C2DM58(L))
9528 IF ( wrf_dm_on_monitor() ) THEN
9529 DO i = 61,99
9530 INQUIRE ( i , OPENED = opened )
9531 IF ( .NOT. opened ) THEN
9532 etarad_unit61 = i
9533 GOTO 2061
9534 ENDIF
9535 ENDDO
9536 etarad_unit61 = -1
9537 2061 CONTINUE
9538 DO i = 62,99
9539 INQUIRE ( i , OPENED = opened )
9540 IF ( .NOT. opened ) THEN
9541 etarad_unit62 = i
9542 GOTO 2062
9543 ENDIF
9544 ENDDO
9545 etarad_unit62 = -1
9546 2062 CONTINUE
9547 DO i = 63,99
9548 INQUIRE ( i , OPENED = opened )
9549 IF ( .NOT. opened ) THEN
9550 etarad_unit63 = i
9551 GOTO 2063
9552 ENDIF
9553 ENDDO
9554 etarad_unit63 = -1
9555 2063 CONTINUE
9556 ENDIF
9557 CALL wrf_dm_bcast_bytes ( etarad_unit61 , IWORDSIZE )
9558 IF ( etarad_unit61 < 0 ) THEN
9559 CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9560 ENDIF
9561 CALL wrf_dm_bcast_bytes ( etarad_unit62 , IWORDSIZE )
9562 IF ( etarad_unit62 < 0 ) THEN
9563 CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9564 ENDIF
9565 CALL wrf_dm_bcast_bytes ( etarad_unit63 , IWORDSIZE )
9566 IF ( etarad_unit63 < 0 ) THEN
9567 CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9568 ENDIF
9569 IF ( wrf_dm_on_monitor() ) THEN
9570 OPEN(etarad_unit61,FILE='tr49t85', &
9571 FORM='FORMATTED',STATUS='OLD',ERR=9061,IOSTAT=IERROR)
9572 ENDIF
9573 IF ( wrf_dm_on_monitor() ) THEN
9574 OPEN(etarad_unit62,FILE='tr49t67', &
9575 FORM='FORMATTED',STATUS='OLD',ERR=9062,IOSTAT=IERROR)
9576 ENDIF
9577 IF ( wrf_dm_on_monitor() ) THEN
9578 OPEN(etarad_unit63,FILE='tr67t85', &
9579 FORM='FORMATTED',STATUS='OLD',ERR=9063,IOSTAT=IERROR)
9580 ENDIF
9582 !===> GET SGTEMP AND OUTPUT WHICH USED TO BE ON UNITS 41,42,43,44....
9583 LREAD = 0
9584 ! DO KKK=1,L
9585 !JD READ(23)SIGLNU(KKK)
9586 ! SIGLNU(KKK)=1.-FLOAT(KKK)/LP1
9587 ! END DO
9588 CALL CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9589 SFULL,SHALF,PPTOP,LREAD,L,LP1,LP2)
9590 ! call int_get_fresh_handle(retval)
9591 ! close(retval)
9592 ! open(unit=retval,file=co2,form='UNFORMATTED',iostat=ier)
9593 ! do kk=1,2
9594 ! write(retval)(sgtemp(k,kk),k=1,61)
9595 ! enddo
9596 DO K=1,LP1
9597 STEMP(K)=SGTEMP(K,1)
9598 GTEMP(K)=SGTEMP(K,2)
9599 ENDDO
9600 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9601 ! IR=1,IQ=1 IS FOR COMMON /CO2BD3/ IN RADIATION CODE...
9602 ! FOR THE CONSOLIDATED 490-850 CM-1 BAND...
9603 !NOV89
9604 ! ICO2TP=61
9605 ICO2TP=etarad_unit61
9606 !NOV89
9607 IR = 1
9608 RATIO = 1.0
9609 NMETHD = 2
9610 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9611 IR = 1
9612 RATIO = 1.0
9613 NMETHD = 1
9614 CALL CO2INT(ICO2TP,T41,T42,T20,RATIO,IR,NMETHD,L,LP1,LP2)
9615 IR = 1
9616 RATIO = 1.0
9617 NMETHD = 2
9618 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9619 IR = 1
9620 RATIO = 1.0
9621 NMETHD = 1
9622 CALL CO2INT(ICO2TP,T43,T44,T21,RATIO,IR,NMETHD,L,LP1,LP2)
9623 !===> FILL UP THE CO2D1D ARRAY
9624 ! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND
9625 ! THEIR DERIVATIVES FOR TAU(I,I+1),I=1,LEVS,
9626 ! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE BUT ARE THE
9627 ! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. THESE
9628 ! ARE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING H2O..
9629 !
9630 IQ = 1
9631 CALL CO2IN1(T20,T21,CO2D1D,IQ,L,LP1)
9632 ! do kk=1,6
9633 ! write(retval)(co2d1d(k,kk),k=1,60)
9634 ! enddo
9635 DO K=1,L
9636 CDTM51(K)=CO2D1D(K,1)
9637 CO2M51(K)=CO2D1D(K,2)
9638 C2DM51(K)=CO2D1D(K,3)
9639 CDTM58(K)=CO2D1D(K,4)
9640 CO2M58(K)=CO2D1D(K,5)
9641 C2DM58(K)=CO2D1D(K,6)
9642 ENDDO
9643 !
9644 !===> FILL UP THE CO2D2D ARRAY
9645 ! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9646 ! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
9647 ! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
9648 ! TO THE MRF VERTICAL COORDINATE,AND RE-CONSOLIDATED TO A
9649 ! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
9650 ! SCHWARZKOPF AND FELS (J.G.R.,1985).
9651 !
9652 CALL CO2INS(T22,T23,CO2D2D,IQ,L,LP1,1)
9653 ! do kk=1,6
9654 ! write(retval)((co2d2d(ka,kb,kk),ka=1,61),kb=1,61)
9655 ! enddo
9656 DO K1=1,LP1
9657 DO K2=1,LP1
9658 CDT51(K1,K2)=CO2D2D(K1,K2,1)
9659 CO251(K1,K2)=CO2D2D(K1,K2,2)
9660 C2D51(K1,K2)=CO2D2D(K1,K2,3)
9661 CDT58(K1,K2)=CO2D2D(K1,K2,4)
9662 CO258(K1,K2)=CO2D2D(K1,K2,5)
9663 C2D58(K1,K2)=CO2D2D(K1,K2,6)
9664 ENDDO
9665 ENDDO
9666 !
9667 !NOV89
9668 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9669 ! IR=2,IQ=2 IS FOR COMMON /CO2BD2/ IN RADIATION CODE...
9670 ! FOR THE CONSOLIDATED 490-670 CM-1 BAND...
9671 ! ICO2TP=62
9672 ICO2TP=etarad_unit62
9673 IR = 2
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 = 2
9679 CALL CO2INS(T22,T23,CO2IQ2,IQ,L,LP1,2)
9680 ! do kk=1,6
9681 ! write(retval)(co2iq2(k,1,kk),k=1,61)
9682 ! enddo
9683 DO K=1,LP1
9684 CDT31(K)=CO2IQ2(K,1,1)
9685 CO231(K)=CO2IQ2(K,1,2)
9686 C2D31(K)=CO2IQ2(K,1,3)
9687 CDT38(K)=CO2IQ2(K,1,4)
9688 CO238(K)=CO2IQ2(K,1,5)
9689 C2D38(K)=CO2IQ2(K,1,6)
9690 ENDDO
9691 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9692 ! IR=3,IQ=3 IS FOR COMMON /CO2BD4/ IN RADIATION CODE...
9693 ! FOR THE CONSOLIDATED 670-850 CM-1 BAND...
9694 ! ICO2TP=63
9695 ICO2TP=etarad_unit63
9696 IR = 3
9697 RATIO = 1.0
9698 NMETHD = 2
9699 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9700 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9701 IQ = 3
9702 CALL CO2INS(T22,T23,CO2IQ3,IQ,L,LP1,3)
9703 ! do kk=1,6
9704 ! write(retval)(co2iq3(k,1,kk),k=1,61)
9705 ! enddo
9706 ! close(retval)
9707 DO K=1,LP1
9708 CDT71(K)=CO2IQ3(K,1,1)
9709 CO271(K)=CO2IQ3(K,1,2)
9710 C2D71(K)=CO2IQ3(K,1,3)
9711 CDT78(K)=CO2IQ3(K,1,4)
9712 CO278(K)=CO2IQ3(K,1,5)
9713 C2D78(K)=CO2IQ3(K,1,6)
9714 ENDDO
9715 !--- FOLLOWING CODE NOT WORKING AND NOT NEEDED YET
9716 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9717 ! IR=4,IQ=5 IS FOR COMMON /CO2BD5/ IN RADIATION CODE...
9718 ! FOR THE 4.3 MICRON BAND...
9719 ! NOT USED YET ICO2TP=65
9720 ! NOT USED YET IR = 4
9721 ! NOT USED YET RATIO = 1.0
9722 ! DAN SCHWARZ --- USE 300PPMV RATIO = 0.9091 (NOT TESTED YET).....
9723 ! NOT USED YET NMETHD = 2
9724 ! NOT USED YET CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD)
9725 ! NOT USED YET CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD)
9726 ! NOT USED YET IQ = 5
9727 ! NOT USED YET CALL CO2INS(T22,T23,CO2IQ5,IQ)
9728 !NOV89
9729 !... WRITE DATA TO DISK..
9730 ! ...SINCE THESE CODES ARE COMPILED WITH AUTODBL,THE CO2 DATA
9731 ! IS CONVERTED TO SINGLE PRECISION IN A LATER JOB STEP..
9733 ! NOT USED YET WRITE(66) CO211
9734 ! NOT USED YET WRITE(66) CO218
9735 !NOV89
9736 IF ( wrf_dm_on_monitor() ) THEN
9737 CLOSE (etarad_unit61)
9738 CLOSE (etarad_unit62)
9739 CLOSE (etarad_unit63)
9740 ENDIF
9742 RETURN
9743 9061 CONTINUE
9744 WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t85 on unit ',etarad_unit61
9745 write(0,*)' IERROR=',IERROR
9746 CALL wrf_error_fatal(errmess)
9747 9062 CONTINUE
9748 WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t67 on unit ',etarad_unit62
9749 write(0,*)' IERROR=',IERROR
9750 CALL wrf_error_fatal(errmess)
9751 9063 CONTINUE
9752 WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr67t85 on unit ',etarad_unit63
9753 write(0,*)' IERROR=',IERROR
9754 CALL wrf_error_fatal(errmess)
9755 END SUBROUTINE CO2O3
9758 !!================================================================================
9759 !----------------------------------------------------------------------
9760 !----------------------------------------------------------------------
9761 SUBROUTINE CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
9762 !----------------------------------------------------------------------
9763 ! *******************************************************************
9764 ! * C O N R A D *
9765 ! * READ CO2 TRANSMISSION DATA FROM UNIT(NFILE)FOR NEW VERTICAL *
9766 ! * COORDINATE TESTS ... *
9767 ! * THESE ARRAYS USED TO BE IN BLOCK DATA ...K.CAMPANA-MAR 90 *
9768 ! *******************************************************************
9769 !
9770 !----------------------------------------------------------------------
9771 IMPLICIT NONE
9772 !----------------------------------------------------------------------
9773 INTEGER,INTENT(IN) :: KDS,KDE,KMS,KME,KTS,KTE
9774 !----------------------------------------------------------------------
9775 !
9776 INTEGER :: I,I1,I2,IERROR,IRTN,J,K,KK,L,LP1,N,NUNIT_CO2,RSIZE
9777 INTEGER,DIMENSION(3) :: RSZE
9778 !
9779 REAL,DIMENSION(KMS:KME-1,6) :: CO21D
9780 REAL,DIMENSION(KMS:KME,2) :: SGTMP
9781 REAL,DIMENSION(KMS:KME,6) :: CO21D3,CO21D7
9782 REAL,DIMENSION(KMS:KME,KMS:KME,6) :: CO22D
9783 REAL,DIMENSION((KME-KMS+1)*(KME-KMS+1)) :: DATA2
9784 LOGICAL :: OPENED
9785 LOGICAL,EXTERNAL :: wrf_dm_on_monitor
9786 CHARACTER*80 errmess
9787 !
9788 !----------------------------------------------------------------------
9789 !
9790 ! CO2 DATA TABLES FOR USER'S VERTICAL COORDINATE
9791 !
9792 ! THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION
9793 ! FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND
9794 ! SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985),
9795 !----- THE 2-DIMENSIONAL ARRAYS ARE
9796 ! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9797 ! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
9798 ! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
9799 ! TO THE NMC MRF VERTICAL COORDINATTE,AND RE-CONSOLIDATED TO A
9800 ! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
9801 ! SCHWARZKOPF AND FELS (J.G.R.,1985).
9802 !----- THE 1-DIM ARRAYS ARE
9803 ! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9804 ! FOR TAU(I,I+1),I=1,L,
9805 ! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE,BUT ARE THE
9806 ! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES.
9807 ! THESE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING QH2O.
9808 !----- THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/
9809 ! 1013250.,WHERE P(K)=PRESSURE,NMC MRF(NEW) L18 DATA LEVELS FOR
9810 ! PSTAR=1013250.
9811 !----- STEMP IS US STANDARD ATMOSPHERES,1976,AT DATA PRESSURE LEVELS
9812 ! USING NMC MRF SIGMAS,WHERE PSTAR=1013.25 MB (PTZ PROGRAM)
9813 !
9814 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9815 ! AND PRESSURE DERIVATIVES FOR THE 560-800 CM-1 BAND. ALSO INCLUDED
9816 ! ARE THE STANDARD TEMPERATURES AND THE WEIGHTING FUNCTION. THESE
9817 ! DATA ARE IN BLOCK DATA BD3:
9818 ! CO251 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9819 ! WITH P(SFC)=1013.25 MB
9820 ! CO258 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9821 ! WITH P(SFC)= 810 MB
9822 ! CDT51 = FIRST TEMPERATURE DERIVATIVE OF CO251
9823 ! CDT58 = FIRST TEMPERATURE DERIVATIVE OF CO258
9824 ! C2D51 = SECOND TEMPERATURE DERIVATIVE OF CO251
9825 ! C2D58 = SECOND TEMPERATURE DERIVATIVE OF CO251
9826 ! CO2M51 = TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE
9827 ! LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR
9828 ! NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB
9829 ! CO2M58 = SAME AS CO2M51,WITH P(SFC)= 810 MB
9830 ! CDTM51 = FIRST TEMPERATURE DERIVATIVE OF CO2M51
9831 ! CDTM58 = FIRST TEMPERATURE DERIVATIVE OF CO2M58
9832 ! C2DM51 = SECOND TEMPERATURE DERIVATIVE OF CO2M51
9833 ! C2DM58 = SECOND TEMPERATURE DERIVATIVE OF CO2M58
9834 ! STEMP = STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL
9835 ! STRUCTURE WITH P(SFC)=1013.25 MB
9836 ! GTEMP = WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL
9837 ! STRUCTURE WITH P(SFC)=1013.25 MB.
9838 !----- THE FOLLOWING ARE STILL IN BLOCK DATA
9839 ! B0 = TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN.
9840 ! CORRECTION FOR T(K). (SEE REF. 4 AND BD3)
9841 ! B1 = TEMP. COEFFICIENT, USED ALONG WITH B0
9842 ! B2 = TEMP. COEFFICIENT, USED ALONG WITH B0
9843 ! B3 = TEMP. COEFFICIENT, USED ALONG WITH B0
9844 !
9845 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9846 ! AND PRESSURE DERIVATIVES FOR THE 560-670 CM-1 PART OF THE 15 UM
9847 ! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD2.
9848 ! FOR THE 560-670 CM-1 BAND,ONLY THE (1,I) VALUES ARE USED , SINCE
9849 ! THESE ARE USED FOR CTS COMPUTATIONS.
9850 ! CO231 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9851 ! WITH P(SFC)=1013.25 MB
9852 ! CO238 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9853 ! WITH P(SFC)= 810 MB
9854 ! CDT31 = FIRST TEMPERATURE DERIVATIVE OF CO231
9855 ! CDT38 = FIRST TEMPERATURE DERIVATIVE OF CO238
9856 ! C2D31 = SECOND TEMPERATURE DERIVATIVE OF CO231
9857 ! C2D38 = SECOND TEMPERATURE DERIVATIVE OF CO231
9858 !
9859 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9860 ! AND PRESSURE DERIVATIVES FOR THE 670-800 CM-1 PART OF THE 15 UM
9861 ! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD4.
9862 ! CO271 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9863 ! WITH P(SFC)=1013.25 MB
9864 ! CO278 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9865 ! WITH P(SFC)= 810 MB
9866 ! CDT71 = FIRST TEMPERATURE DERIVATIVE OF CO271
9867 ! CDT78 = FIRST TEMPERATURE DERIVATIVE OF CO278
9868 ! C2D71 = SECOND TEMPERATURE DERIVATIVE OF CO271
9869 ! C2D78 = SECOND TEMPERATURE DERIVATIVE OF CO271
9870 !
9871 ! *****THE FOLLOWING NOT USED IN CURRENT VERSION OF RADIATION *******
9872 !
9873 ! --CO2 TRANSMISSION FUNCTIONS FOR THE 2270-
9874 ! 2380 PART OF THE 4.3 UM CO2 BAND.
9875 ! THESE DATA ARE IN BLOCK DATA BD5.
9876 ! CO211 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9877 ! WITH P(SFC)=1013.25 MB
9878 ! CO218 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9879 ! WITH P(SFC)= 810 MB
9880 !
9881 ! *****THE ABOVE NOT USED IN CURRENT VERSION OF RADIATION ***********
9882 !----------------------------------------------------------------------
9883 !
9884 L=KME-KMS
9885 LP1=KME-KMS+1
9886 !
9887 !----------------------------------------------------------------------
9888 IF ( wrf_dm_on_monitor() ) THEN
9889 DO i = 14,99
9890 write(0,*)' in CONRAD i=',i,' opened=',opened
9891 INQUIRE ( i , OPENED = opened )
9892 IF ( .NOT. opened ) THEN
9893 nunit_co2 = i
9894 GOTO 2014
9895 ENDIF
9896 ENDDO
9897 nunit_co2 = -1
9898 2014 CONTINUE
9899 ENDIF
9900 IF ( wrf_dm_on_monitor() ) THEN
9901 OPEN(nunit_co2,FILE='co2_trans', &
9902 FORM='UNFORMATTED',STATUS='OLD',ERR=9014,IOSTAT=IERROR)
9903 REWIND NUNIT_CO2
9904 ENDIF
9906 !----------------------------------------------------------------------
9907 !
9908 !*** READ IN PRE-COMPUTED CO2 TRANSMISSION DATA.
9909 !
9910 RSZE(1) = LP1
9911 RSZE(2) = L
9912 RSZE(3) = LP1*LP1
9913 !----------------------------------------------------------------------
9914 !
9915 RSIZE = RSZE(1)
9916 !
9917 DO KK=1,2
9918 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(SGTMP(I,KK),I=1,RSIZE)
9919 CALL wrf_dm_bcast_real( SGTMP(1,KK), RSIZE )
9920 ENDDO
9921 !
9922 !----------------------------------------------------------------------
9923 !
9924 RSIZE = RSZE(2)
9925 !
9926 DO KK=1,6
9927 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D(I,KK),I=1,RSIZE)
9928 CALL wrf_dm_bcast_real( CO21D(1,KK), RSIZE )
9929 ENDDO
9930 !
9931 !----------------------------------------------------------------------
9932 !
9933 RSIZE = RSZE(3)
9934 !
9935 DO KK=1,6
9936 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(DATA2(I),I=1,RSIZE)
9937 CALL wrf_dm_bcast_real( DATA2(1), RSIZE )
9938 N=0
9939 !
9940 DO I1=1,LP1
9941 DO I2=1,LP1
9942 N=N+1
9943 CO22D(I1,I2,KK)=DATA2(N)
9944 ENDDO
9945 ENDDO
9946 !
9947 ENDDO
9949 !
9950 ! Deallocate before reading. This is required for nested domain init.
9951 !
9952 IF(ALLOCATED (CO251))DEALLOCATE(CO251)
9953 IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
9954 IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
9955 IF(ALLOCATED (CO258))DEALLOCATE(CO258)
9956 IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
9957 IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
9958 IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
9959 IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
9960 IF(ALLOCATED (CO231))DEALLOCATE(CO231)
9961 IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
9962 IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
9963 IF(ALLOCATED (CO238))DEALLOCATE(CO238)
9964 IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
9965 IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
9966 IF(ALLOCATED (CO271))DEALLOCATE(CO271)
9967 IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
9968 IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
9969 IF(ALLOCATED (CO278))DEALLOCATE(CO278)
9970 IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
9971 IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
9972 IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
9973 IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
9974 IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
9975 IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
9976 IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
9977 IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
9978 !
9979 !----------------------------------------------------------------------
9980 !
9981 RSIZE = RSZE(1)
9982 !
9983 DO KK=1,6
9984 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D3(I,KK),I=1,RSIZE)
9985 CALL wrf_dm_bcast_real( CO21D3(1,KK), RSIZE )
9986 ENDDO
9987 !
9988 !----------------------------------------------------------------------
9989 !
9990 DO KK=1,6
9991 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D7(I,KK),I=1,RSIZE)
9992 CALL wrf_dm_bcast_real ( CO21D7(1,KK), RSIZE )
9993 ENDDO
9994 !
9995 !----------------------------------------------------------------------
9996 ALLOCATE(CO251(LP1,LP1))
9997 ALLOCATE(CDT51(LP1,LP1))
9998 ALLOCATE(C2D51(LP1,LP1))
9999 ALLOCATE(CO258(LP1,LP1))
10000 ALLOCATE(CDT58(LP1,LP1))
10001 ALLOCATE(C2D58(LP1,LP1))
10002 ALLOCATE(STEMP(LP1))
10003 ALLOCATE(GTEMP(LP1))
10004 ALLOCATE(CO231(LP1))
10005 ALLOCATE(CDT31(LP1))
10006 ALLOCATE(C2D31(LP1))
10007 ALLOCATE(CO238(LP1))
10008 ALLOCATE(CDT38(LP1))
10009 ALLOCATE(C2D38(LP1))
10010 ALLOCATE(CO271(LP1))
10011 ALLOCATE(CDT71(LP1))
10012 ALLOCATE(C2D71(LP1))
10013 ALLOCATE(CO278(LP1))
10014 ALLOCATE(CDT78(LP1))
10015 ALLOCATE(C2D78(LP1))
10016 ALLOCATE(CO2M51(L))
10017 ALLOCATE(CDTM51(L))
10018 ALLOCATE(C2DM51(L))
10019 ALLOCATE(CO2M58(L))
10020 ALLOCATE(CDTM58(L))
10021 ALLOCATE(C2DM58(L))
10022 !----------------------------------------------------------------------
10023 !
10024 DO K=1,LP1
10025 STEMP(K) = SGTMP(K,1)
10026 GTEMP(K) = SGTMP(K,2)
10027 ENDDO
10028 !
10029 DO K=1,L
10030 CDTM51(K) = CO21D(K,1)
10031 CO2M51(K) = CO21D(K,2)
10032 C2DM51(K) = CO21D(K,3)
10033 CDTM58(K) = CO21D(K,4)
10034 CO2M58(K) = CO21D(K,5)
10035 C2DM58(K) = CO21D(K,6)
10036 ENDDO
10037 !
10038 DO J=1,LP1
10039 DO I=1,LP1
10040 CDT51(I,J) = CO22D(I,J,1)
10041 CO251(I,J) = CO22D(I,J,2)
10042 C2D51(I,J) = CO22D(I,J,3)
10043 CDT58(I,J) = CO22D(I,J,4)
10044 CO258(I,J) = CO22D(I,J,5)
10045 C2D58(I,J) = CO22D(I,J,6)
10046 ENDDO
10047 ENDDO
10048 !
10049 DO K=1,LP1
10050 CDT31(K) = CO21D3(K,1)
10051 CO231(K) = CO21D3(K,2)
10052 C2D31(K) = CO21D3(K,3)
10053 CDT38(K) = CO21D3(K,4)
10054 CO238(K) = CO21D3(K,5)
10055 C2D38(K) = CO21D3(K,6)
10056 ENDDO
10057 !
10058 DO K=1,LP1
10059 CDT71(K) = CO21D7(K,1)
10060 CO271(K) = CO21D7(K,2)
10061 C2D71(K) = CO21D7(K,3)
10062 CDT78(K) = CO21D7(K,4)
10063 CO278(K) = CO21D7(K,5)
10064 C2D78(K) = CO21D7(K,6)
10065 ENDDO
10066 !
10067 !----------------------------------------------------------------------
10068 IF(wrf_dm_on_monitor())WRITE(0,66)NUNIT_CO2
10069 66 FORMAT('----READ CO2 TRANSMISSION FUNCTIONS FROM UNIT ',I2)
10070 !----------------------------------------------------------------------
10071 IF( wrf_dm_on_monitor() )THEN
10072 CLOSE(nunit_co2)
10073 ENDIF
10074 RETURN
10075 !
10076 9014 CONTINUE
10077 WRITE(errmess,'(A51,I4)')'module_ra_gfdleta: error reading co2_trans on unit ',nunit_co2
10078 CALL wrf_error_fatal(errmess)
10079 !----------------------------------------------------------------------
10080 END SUBROUTINE CONRAD
10081 !+---+-----------------------------------------------------------------+
10082 ! Replacement routine to compute saturation vapor pressure over
10083 ! water/ice. This is needed here in case we run microphysics other
10084 ! than ETAMPNEW (Ferrier) because it initializes a lookup table to
10085 ! facilitate calculations of FVPS. For speed, we use the polynomial
10086 ! expansion of Flatau & Walko, 1989.
10087 !+---+-----------------------------------------------------------------+
10088 REAL FUNCTION FPVS_new(T)
10090 IMPLICIT NONE
10091 REAL, INTENT(IN):: T
10093 if (T .ge. 273.16) then
10094 FPVS_new = e_sub_l(T)
10095 else
10096 FPVS_new = e_sub_i(T)
10097 endif
10099 END FUNCTION FPVS_new
10100 !
10101 !+---+-----------------------------------------------------------------+
10102 ! THIS FUNCTION CALCULATES THE LIQUID SATURATION PRESSURE AS
10103 ! A FUNCTION OF TEMPERATURE.
10104 !
10105 REAL FUNCTION e_sub_l(T)
10107 IMPLICIT NONE
10108 REAL, INTENT(IN):: T
10109 REAL:: ESL,X
10110 REAL, PARAMETER:: C0= .611583699E03
10111 REAL, PARAMETER:: C1= .444606896E02
10112 REAL, PARAMETER:: C2= .143177157E01
10113 REAL, PARAMETER:: C3= .264224321E-1
10114 REAL, PARAMETER:: C4= .299291081E-3
10115 REAL, PARAMETER:: C5= .203154182E-5
10116 REAL, PARAMETER:: C6= .702620698E-8
10117 REAL, PARAMETER:: C7= .379534310E-11
10118 REAL, PARAMETER:: C8=-.321582393E-13
10120 X=AMAX1(-80.,T-273.16)
10122 ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
10124 e_sub_l = ESL
10126 END FUNCTION e_sub_l
10127 !
10128 !+---+-----------------------------------------------------------------+
10129 ! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR PRESSURE AS A
10130 ! FUNCTION OF TEMPERATURE.
10131 !
10132 REAL FUNCTION e_sub_i(T)
10134 IMPLICIT NONE
10135 REAL, INTENT(IN):: T
10136 REAL:: ESI,X
10137 REAL, PARAMETER:: C0= .609868993E03
10138 REAL, PARAMETER:: C1= .499320233E02
10139 REAL, PARAMETER:: C2= .184672631E01
10140 REAL, PARAMETER:: C3= .402737184E-1
10141 REAL, PARAMETER:: C4= .565392987E-3
10142 REAL, PARAMETER:: C5= .521693933E-5
10143 REAL, PARAMETER:: C6= .307839583E-7
10144 REAL, PARAMETER:: C7= .105785160E-9
10145 REAL, PARAMETER:: C8= .161444444E-12
10147 X=AMAX1(-80.,T-273.16)
10148 ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
10150 e_sub_i = ESI
10152 END FUNCTION e_sub_i
10154 !
10156 !----------------------------------------------------------------------
10157 !
10158 END MODULE module_RA_GFDLETA
10159 !
10160 !----------------------------------------------------------------------