| blob | d3112560f3da523e6618b063ef4336e9d5ce41af |
1 !WRF:MODEL_RA:RADIATION
2 !
3 #define FERRIER_GFDL
4 MODULE MODULE_RA_GFDLETA
5 USE MODULE_CONFIGURE,ONLY : GRID_CONFIG_REC_TYPE
6 USE MODULE_MODEL_CONSTANTS
7 #ifdef FERRIER_GFDL
8 USE MODULE_MP_ETANEW, ONLY : &
9 & RHgrd,T_ICE,FPVS,QAUT0,XMImax,XMIexp,MDImin,MDImax,MASSI, &
10 & FLARGE1,FLARGE2,NLImin,NLImax
11 #endif
12 INTEGER,PARAMETER :: NL=81
13 INTEGER,PARAMETER :: NBLY=15
14 REAL,PARAMETER :: RTHRESH=1.E-15,RTD=1./DEGRAD
16 INTEGER, SAVE, DIMENSION(3) :: LTOP
17 REAL , SAVE, DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
18 REAL , SAVE, DIMENSION(NL) :: PRGFDL
19 REAL , SAVE :: AB15WD,SKO2D,SKC1R,SKO3R
21 REAL , SAVE :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), &
22 TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
23 SOURCE(28,NBLY), DSRCE(28,NBLY)
25 REAL ,SAVE, DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW,EM3V
26 REAL ,SAVE :: R1,RSIN1,RCOS1,RCOS2
27 ! Created by CO2 initialization
28 REAL, SAVE, ALLOCATABLE, DIMENSION(:,:) :: CO251,CDT51,CDT58,C2D51,&
29 C2D58,CO258
30 REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: STEMP,GTEMP,CO231,CO238, &
31 C2D31,C2D38,CDT31,CDT38, &
32 CO271,CO278,C2D71,C2D78, &
33 CDT71,CDT78
34 REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: CO2M51,CO2M58,CDTM51,CDTM58, &
35 C2DM51,C2DM58
36 CHARACTER(256) :: ERRMESS
38 ! Used by CO2 initialization
39 ! COMMON/PRESS/PA(109)
40 ! COMMON/TRAN/ TRANSA(109,109)
41 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
42 REAL ,SAVE, DIMENSION(109) :: PA, XA, CA, ETA, SEXPV
43 REAL ,SAVE, DIMENSION(109,109) :: TRANSA
44 REAL ,SAVE :: CORE,UEXP,SEXP
46 EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1))
47 EQUIVALENCE (EM3V(1),EM3(1,1))
48 EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
49 (T4(1),TABLE3(1,1))
50 REAL,SAVE,DIMENSION(4) :: PTOPC
51 !
52 !--- Used for Gaussian look up tables
53 !
54 REAL, PRIVATE,PARAMETER :: XSDmax=3.1, DXSD=.01
55 INTEGER, PRIVATE,PARAMETER :: NXSD=XSDmax/DXSD
56 REAL, DIMENSION(NXSD),PRIVATE,SAVE :: AXSD
57 REAL, PRIVATE :: RSQR
58 LOGICAL, PRIVATE,SAVE :: SDprint=.FALSE.
61 #ifndef FERRIER_GFDL
62 REAL, PRIVATE, PARAMETER :: RHgrd=1.0
63 REAL, PRIVATE, PARAMETER :: T_ice=-40.0
64 #endif
66 !
67 !--- Important parameters for cloud properties - see extensive comments in
68 ! DO 580 loop within subroutine RADTN
69 !
70 REAL, PARAMETER :: &
71 & TRAD_ice=0.5*T_ice & !--- Very tunable parameter
72 &, ABSCOEF_W=800. & !--- Very tunable parameter
73 &, ABSCOEF_I=500. & !--- Very tunable parameter
74 &, SECANG=-1.66 & !--- Very tunable parameter
75 !! &, SECANG=-0.75 & !--- Very tunable parameter
76 &, CLDCOEF_LW=1.5 & !--- Enhance LW cloud depths
77 &, ABSCOEF_LW=SECANG*CLDCOEF_LW & !--- Final factor for cloud emissivities
78 &, Qconv=0.1e-3 & !--- Very tunable parameter
79 &, CTauCW=ABSCOEF_W*Qconv &
80 &, CTauCI=ABSCOEF_I*Qconv
81 !
83 CONTAINS
85 !-----------------------------------------------------------------------
86 SUBROUTINE GFDLETAINIT(EMISS,SFULL,SHALF,PPTOP, &
87 & JULYR,MONTH,IDAY,GMT, &
88 & CONFIG_FLAGS,ALLOWED_TO_READ, &
89 & IDS, IDE, JDS, JDE, KDS, KDE, &
90 & IMS, IME, JMS, JME, KMS, KME, &
91 & ITS, ITE, JTS, JTE, KTS, KTE )
92 !-----------------------------------------------------------------------
93 IMPLICIT NONE
94 !-----------------------------------------------------------------------
95 TYPE (GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS
96 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
97 & ,IMS,IME,JMS,JME,KMS,KME &
98 & ,ITS,ITE,JTS,JTE,KTS,KTE
99 INTEGER,INTENT(IN) :: JULYR,MONTH,IDAY
100 REAL,INTENT(IN) :: GMT,PPTOP
101 REAL,DIMENSION(KMS:KME),INTENT(IN) :: SFULL, SHALF
102 REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: EMISS
103 LOGICAL,INTENT(IN) :: ALLOWED_TO_READ
104 !
105 INTEGER :: I,IHRST,J,N
106 REAL :: PCLD,XSD,PI,SQR2PI
107 REAL :: SSLP=1013.25
108 REAL, PARAMETER :: PTOP_HI=150.,PTOP_MID=350.,PTOP_LO=642., &
109 & PLBTM=105000.
110 !-----------------------------------------------------------------------
111 !***********************************************************************
112 !-----------------------------------------------------------------------
113 !
114 !*** INITIALIZE DIAGNOSTIC LOW,MIDDLE,HIGH CLOUD LAYER PRESSURE LIMITS.
115 !
116 LTOP(1)=0
117 LTOP(2)=0
118 LTOP(3)=0
119 !
120 DO N=1,KTE
121 PCLD=(SSLP-PPTOP*10.)*SHALF(N)+PPTOP*10.
122 IF(PCLD>=PTOP_LO)LTOP(1)=N
123 IF(PCLD>=PTOP_MID)LTOP(2)=N
124 IF(PCLD>=PTOP_HI)LTOP(3)=N
125 ! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
126 ENDDO
127 !***
128 !*** ASSIGN THE PRESSURES FOR CLOUD DOMAIN BOUNDARIES
129 !***
130 PTOPC(1)=PLBTM
131 PTOPC(2)=PTOP_LO*100.
132 PTOPC(3)=PTOP_MID*100.
133 PTOPC(4)=PTOP_HI*100.
134 !
135 !*** USE CALL TO CONRAD FOR DIRECT READ OF CO2 FUNCTIONS
136 !*** OTHERWISE CALL CO2O3.
137 !
138 IF(ALLOWED_TO_READ)THEN
139 IF(CONFIG_FLAGS%CO2TF==1)THEN
140 CALL CO2O3(SFULL,SHALF,PPTOP,KME-KMS,KME-KMS+1,KME-KMS+2)
141 ELSE
142 CALL CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
143 ENDIF
144 !
145 CALL O3CLIM
146 CALL TABLE
147 IHRST=NINT(GMT)
148 ! WRITE(0,*)'into solard ',gmt,ihrst
149 CALL SOLARD(IHRST,IDAY,MONTH,JULYR)
150 ENDIF
151 !
152 !*** FOR NOW, GFDL RADIATION ASSUMES EMISSIVITY = 1.0
153 !
154 DO J=JTS,JTE
155 DO I=ITS,ITE
156 EMISS(I,J) = 1.0
157 ENDDO
158 ENDDO
159 !
160 !--- Calculate the area under the Gaussian curve at the start of the
161 !--- model run and build the look up table AXSD
162 !
163 PI=ACOS(-1.)
164 SQR2PI=SQRT(2.*PI)
165 RSQR=1./SQR2PI
166 DO I=1,NXSD
167 XSD=REAL(I)*DXSD
168 AXSD(I)=GAUSIN(XSD)
169 if (SDprint) print *,'I, XSD, AXSD =',I,XSD,AXSD(I)
170 ENDDO
171 !! !***
172 !! !*** MESO STANDARD DEVIATION OF EK AND MAHRT'S CLOUD COVER ALOGRITHM
173 !! !***
174 !! SDM=-0.03-0.00015*DX+0.02*LOG(DX) ! meso SD
175 !! if (SDprint) print *,'DX, SDM=',DX,SDM
176 ! if (SDprint) print *, &
177 ! & 'RHgrd,T_ICE,NLImin,NLImax,FLARGE1,FLARGE2,MDImin,MDImax=',&
178 ! & RHgrd,T_ICE,NLImin,NLImax,FLARGE1,FLARGE2,MDImin,MDImax
179 !
180 !-----------------------------------------------------------------------
181 END SUBROUTINE GFDLETAINIT
182 !-----------------------------------------------------------------------
183 !
184 !
185 !-----------------------------------------------------------------------
186 SUBROUTINE ETARA(DT,THRATEN,THRATENLW,THRATENSW,CLDFRA,PI3D &
187 & ,XLAND,P8W,DZ8W,RHO_PHY,P_PHY,T &
188 & ,QV,QW,QI,QS &
189 & ,TSK2D,GLW,RSWIN,GSW,RSWINC &
190 & ,RSWTOA,RLWTOA,CZMEAN &
191 & ,GLAT,GLON,HTOP,HBOT,HTOPR,HBOTR,ALBEDO,CUPPT &
192 & ,VEGFRA,SNOW,G,GMT &
193 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
194 & ,NSTEPRA,NPHS,ITIMESTEP &
195 & ,XTIME,JULIAN &
196 & ,JULYR,JULDAY,GFDL_LW,GFDL_SW &
197 & ,CFRACL,CFRACM,CFRACH &
198 & ,ACFRST,NCFRST,ACFRCV,NCFRCV &
199 & ,IDS,IDE,JDS,JDE,KDS,KDE &
200 & ,IMS,IME,JMS,JME,KMS,KME &
201 & ,ITS,ITE,JTS,JTE,KTS,KTE)
202 !-----------------------------------------------------------------------
203 IMPLICIT NONE
204 !-----------------------------------------------------------------------
205 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
206 & ,IMS,IME,JMS,JME,KMS,KME &
207 & ,ITS,ITE,JTS,JTE,KTS,KTE,ITIMESTEP &
208 & ,NPHS,NSTEPRA
210 INTEGER,INTENT(IN) :: julyr,julday
211 INTEGER,INTENT(INOUT),DIMENSION(ims:ime,jms:jme) :: NCFRST & !Added
212 ,NCFRCV !Added
213 REAL,INTENT(IN) :: DT,GMT,G,XTIME,JULIAN
215 REAL,INTENT(INOUT),DIMENSION(ims:ime, kms:kme, jms:jme):: &
216 THRATEN,THRATENLW,THRATENSW,CLDFRA !Added CLDFRA
217 REAL,INTENT(IN),DIMENSION(ims:ime, kms:kme, jms:jme)::p8w,dz8w, &
218 & rho_phy, &
219 & p_phy, &
220 & PI3D
221 REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: ALBEDO,SNOW, &
222 & TSK2D,VEGFRA, &
223 & XLAND
224 REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: GLAT,GLON
225 REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: HTOP,HBOT,HTOPR,HBOTR,CUPPT
226 REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: RSWTOA, & !Added
227 & RLWTOA, & !Added
228 & ACFRST, & !Added
229 & ACFRCV
230 REAL,INTENT(INOUT),DIMENSION(ims:ime, jms:jme):: GLW,GSW
231 REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CZMEAN &
232 & ,RSWIN,RSWINC &
233 & ,CFRACL,CFRACM,CFRACH
234 REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QS,QV, &
235 & QW,T
236 LOGICAL, INTENT(IN) :: gfdl_lw,gfdl_sw
237 REAL, OPTIONAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QI
239 REAL, DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP,QIFLIP,QFLIP, &
240 & QWFLIP,TFLIP
241 REAL, DIMENSION(its:ite, kms:kme, jts:jte)::P8WFLIP
242 REAL, DIMENSION(its:ite, kts:kte, jts:jte)::TENDS,TENDL
243 REAL, DIMENSION(ims:ime, jms:jme):: CUTOP,CUBOT
244 INTEGER :: IDAT(3),IHOUR,Jmonth,Jday
245 INTEGER :: I,J,K,KFLIP,IHRST
247 ! begin debugging radiation
248 integer :: imd,jmd
249 real :: FSWrat
250 ! end debugging radiation
251 !-----------------------------------------------------------------------
252 !***********************************************************************
253 !-----------------------------------------------------------------------
254 IF(GFDL_LW.AND.GFDL_SW )GO TO 100
255 !
256 DO J=JMS,JME
257 DO K=KMS,KME
258 DO I=IMS,IME
259 CLDFRA(I,K,J)=0.
260 ENDDO
261 ENDDO
262 ENDDO
263 !
264 DO K=KMS,KME
265 KFLIP=KME+1-K
266 DO J=JTS,JTE
267 DO I=ITS,ITE
268 P8WFLIP(I,K,J)=P8W(I,KFLIP,J)
269 ENDDO
270 ENDDO
271 ENDDO
272 !
273 !- Note that the effects of rain are ignored in this radiation package (BSF 2005-01-25)
274 !
275 DO K=KTS,KTE
276 KFLIP=KTE+1-K
277 DO J=JTS,JTE
278 DO I=ITS,ITE
279 TFLIP (I,K,J)=T(I,KFLIP,J)
280 QFLIP (I,K,J)=MAX(0.,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J)))
281 QWFLIP(I,K,J)=MAX(QW(I,KFLIP,J),0.) !Modified
282 ! Note that QIFLIP will contain QS+QI if both are passed in, otherwise just QS
283 ! Eta MP now outputs QS instead of QI (JD 2006-05-12)
284 QIFLIP(I,K,J)=MAX(QS(I,KFLIP,J),0.) !Added QS
285 IF(PRESENT(QI))QIFLIP(I,K,J)=QIFLIP(I,K,J)+QI(I,KFLIP,J) !Added QI
286 PFLIP (I,K,J)=P_PHY(I,KFLIP,J)
287 !
288 !*** USE MONOTONIC HYDROSTATIC PRESSURE INTERPOLATED TO MID-LEVEL
289 !
290 ENDDO
291 ENDDO
292 ENDDO
293 !
294 DO J=JTS,JTE
295 DO I=ITS,ITE
296 CUBOT(I,J)=KTE+1-HBOT(I,J)
297 CUTOP(I,J)=KTE+1-HTOP(I,J)
298 ENDDO
299 ENDDO
300 !
301 CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY)
302 !
303 IDAT(1)=JMONTH
304 IDAT(2)=JDAY
305 IDAT(3)=JULYR
306 IHRST =NINT(GMT)
308 IHOUR =MOD((IHRST+NINT(XTIME/60.0)),24)
309 ! write(0,*)' before SOLARD in ETARA ', IHOUR,JDAY,JMONTH,JULYR
310 CALL SOLARD(IHOUR,JDAY,JMONTH,JULYR)
311 !-----------------------------------------------------------------------
312 CALL RADTN (DT,TFLIP,QFLIP,QWFLIP,QIFLIP, &
313 & PFLIP,P8WFLIP,XLAND,TSK2D, &
314 & GLAT,GLON,CUTOP,CUBOT,ALBEDO,CUPPT, &
315 & ACFRCV,NCFRCV,ACFRST,NCFRST, &
316 & VEGFRA,SNOW,GLW,GSW,RSWIN,RSWINC, &
317 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
318 & IDAT,IHRST,XTIME,JULIAN, &
319 & NSTEPRA,NSTEPRA,NPHS,ITIMESTEP, &
320 & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, &
321 & CFRACL,CFRACM,CFRACH, &
322 & IDS,IDE,JDS,JDE,KDS,KDE, &
323 & IMS,IME,JMS,JME,KMS,KME, &
324 & ITS,ITE,JTS,JTE,KTS,KTE )
325 !-----------------------------------------------------------------------
326 ! begin debugging radiation
327 ! imd=(ims+ime)/2
328 ! jmd=(jms+jme)/2
329 ! FSWrat=0.
330 ! if (RSWIN(imd,jmd) .gt. 0.) &
331 ! FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd)
332 ! write(6,"(2a,2i5,5f9.2,f8.4,i3,2f8.4)") &
333 ! '{rad4 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' &
334 ! ,'ACFRCV,NCFRCV,ALBEDO,RSWOUT/RSWIN = ' &
335 ! ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd) &
336 ! ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) &
337 ! ,ACFRCV(imd,jmd),NCFRCV(imd,jmd),ALBEDO(imd,jmd),FSWrat
338 ! end debugging radiation
339 !
340 !--- Need to save LW & SW tendencies since radiation calculates both and this block
341 ! is skipped when GFDL SW is called, both only if GFDL LW is also called
342 !
343 IF(GFDL_LW)THEN
344 DO J=JTS,JTE
345 DO K = KTS,KTE
346 KFLIP=KTE+1-K
347 DO I=ITS,ITE
348 THRATENLW(I,K,J)=TENDL(I,KFLIP,J)/PI3D(I,K,J)
349 THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J)
350 THRATEN(I,K,J) =THRATEN(I,K,J) + THRATENLW(I,K,J)
351 ENDDO
352 ENDDO
353 ENDDO
354 ENDIF
355 !
356 !*** THIS ASSUMES THAT LONGWAVE IS CALLED FIRST IN THE RADIATION_DRIVER.
357 ! Only gets executed if a different LW scheme (not GFDL) is called
358 !
359 IF(GFDL_SW)THEN
360 DO J=JTS,JTE
361 DO K=KTS,KTE
362 KFLIP=KTE+1-K
363 DO I=ITS,ITE
364 THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J)
365 ENDDO
366 ENDDO
367 ENDDO
368 ENDIF
369 !
370 !*** RESET ACCUMULATED CONVECTIVE CLOUD TOP/BOT AND CONVECTIVE PRECIP
371 !*** FOR NEXT INTERVAL BETWEEN RADIATION CALLS
372 !
373 DO J=JTS,JTE
374 DO I=ITS,ITE
375 ! SAVE VALUE USED BY RADIATION BEFORE RESETTING HTOP AND HBOT
376 HBOTR(I,J)=HBOT(I,J)
377 HTOPR(I,J)=HTOP(I,J)
378 HBOT(I,J)=REAL(KTE+1)
379 HTOP(I,J)=0.
380 CUPPT(I,J)=0.
381 ENDDO
382 ENDDO
383 !
384 100 IF(GFDL_SW)THEN
385 DO J=JTS,JTE
386 DO K=KTS,KTE
387 KFLIP=KTE+1-K
388 DO I=ITS,ITE
389 THRATEN(I,K,J)=THRATEN(I,K,J)+THRATENSW(I,K,J)
390 ENDDO
391 ENDDO
392 ENDDO
393 ENDIF
394 !
395 END SUBROUTINE ETARA
396 !
397 !-----------------------------------------------------------------------
398 SUBROUTINE RADTN(DT,T,Q,QCW,QICE, &
399 & PFLIP,P8WFLIP,XLAND,TSK2D, &
400 & GLAT,GLON,CUTOP,CUBOT,ALB,CUPPT, &
401 & ACFRCV,NCFRCV,ACFRST,NCFRST, &
402 & VEGFRC,SNO,GLW,GSW,RSWIN,RSWINC, &
403 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
404 & IDAT,IHRST,XTIME,JULIAN, &
405 & NRADS,NRADL,NPHS,NTSD, &
406 & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, &
407 & CFRACL,CFRACM,CFRACH, &
408 & ids,ide, jds,jde, kds,kde, &
409 & ims,ime, jms,jme, kms,kme, &
410 & its,ite, jts,jte, kts,kte )
411 !-----------------------------------------------------------------------
412 IMPLICIT NONE
413 !-----------------------------------------------------------------------
415 ! GLAT : geodetic latitude in radians of the mass points on the computational grid.
417 ! CZEN : instantaneous cosine of the solar zenith angle.
419 ! CUTOP : (REAL) model layer number that is highest in the atmosphere
420 ! in which convective cloud occurred since the previous call to the
421 ! radiation driver.
423 ! CUBOT : (REAL) model layer number that is lowest in the atmosphere
424 ! in which convective cloud occurred since the previous call to the
425 ! radiation driver.
427 ! ALB : is no longer used in the operational radiation. Prior to 24 July 2001
428 ! ALB was the climatological albedo that was modified within RADTN to
429 ! account for vegetation fraction and snow.
430 !
431 ! ALB : reintroduced as the dynamic albedo from LSM
433 ! CUPPT: accumulated convective precipitation (meters) since the
434 ! last call to the radiation.
436 ! TSK2D : skin temperature
438 ! IHE and IHW are relative location indices needed to locate neighboring
439 ! points on the Eta's Arakawa E grid since arrays are indexed locally on
440 ! each MPI task rather than globally. IHE refers to the adjacent grid
441 ! point (a V point) to the east of the mass point being considered. IHW
442 ! is the adjacent grid point to the west of the given mass point.
444 ! IRAD is a relic from older code that is no longer needed.
446 ! ACFRCV : sum of the convective cloud fractions that were computed
447 ! during each call to the radiation between calls to the subroutines that
448 ! do the forecast output.
450 ! NCFRCV : the total number of times in which the convective cloud
451 ! fraction was computed to be greater than zero in the radiation between
452 ! calls to the output routines. In the post-processor, ACFRCV is divided
453 ! by NCFRCV to yield an average convective cloud fraction.
455 ! ACFRST and NCFRST are the analogs for stratiform cloud cover.
457 ! VEGFRC is the fraction of the gridbox with vegetation.
459 ! LVL holds the number of model layers that lie below the ground surface
460 ! at each point. Clearly for sigma coordinates LVL is zero everywhere.
462 ! CTHK : an assumed maximum thickness of stratiform clouds currently set
463 ! to 20000 Pascals. I think this is relevant for computing "low",
464 ! "middle", and "high" cloud fractions which are post-processed but which
465 ! do not feed back into the integration.
467 ! IDAT : a 3-element integer array holding the month, day, and year,
468 ! respectively, of the date for the start time of the free forecast.
470 ! ABCFF : holds coefficients for various absorption bands. You can see
471 ! where they are set in GFDLRD.F.
473 ! LTOP : a 3-element integer array holding the model layer that is at or
474 ! immediately below the specified pressure levels for the tops
475 ! of "high" (15000 Pa), "middle" (35000 Pa), and "low" (64200 Pa)
476 ! stratiform clouds. These are for the diagnostic cloud layers
477 ! needed in the output but not in the integration.
479 ! NRADS : integer number of fundamental timesteps (our smallest
480 ! timestep, i.e., the one for inertial gravity wave adjustment)
481 ! between updates of the shortwave tendencies.
483 ! NRADL : integer number of fundamental timesteps between updates of
484 ! the longwave tendencies.
486 ! NTSD : integer counter of the fundamental timesteps that have
487 ! elapsed since the start of the forecast.
489 ! GLW : incoming longwave radiation at the surface
490 ! GSW : NET (down minus up, or incoming minus outgoing) all-sky shortwave radiation at the surface
491 ! RSWIN : total (clear + cloudy sky) incoming (downward) solar radiation at the surface
492 ! RSWINC : clear sky incoming (downward) solar radiation at the surface
494 ! TENDS,TENDL : shortwave,longwave (respectively) temperature tendency
496 ! CLDFRA : 3D cloud fraction
498 ! RSWTOA, RLWTOA : outgoing shortwave, longwave (respectively) fluxes at top of atmosphere
500 ! CZMEAN : time-average cosine of the zenith angle
502 ! CFRACL,CFRACM,CFRACH : low, middle, & high (diagnosed) cloud fractions
504 ! XTIME : time since simulation start (minutes)
506 ! JULIAN: Day of year (0.0 at 00Z Jan 1st)
508 !**********************************************************************
509 !****************************** NOTE **********************************
510 !**********************************************************************
511 !*** DUE TO THE RESETTING OF CONVECTIVE PRECIP AND CONVECTIVE CLOUD
512 !*** TOPS AND BOTTOMS, SHORTWAVE MUST NOT BE CALLED LESS FREQUENTLY
513 !*** THAN LONGWAVE.
514 !**********************************************************************
515 !****************************** NOTE **********************************
516 !**********************************************************************
517 !-----------------------------------------------------------------------
518 ! INTEGER, PARAMETER :: NL=81
519 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
520 & ims,ime, jms,jme, kms,kme , &
521 & its,ite, jts,jte, kts,kte
522 INTEGER, INTENT(IN) :: NRADS,NRADL,NTSD,NPHS
523 ! LOGICAL, INTENT(IN) :: RESTRT
524 REAL , INTENT(IN) :: DT,XTIME,JULIAN
525 ! REAL , INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
526 INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
527 !-----------------------------------------------------------------------
528 INTEGER :: LM1,LP1,LM
529 INTEGER, INTENT(IN) :: IHRST
530 ! REAL, INTENT(IN), DIMENSION(NL) :: PRGFDL
531 !
532 REAL, PARAMETER :: EPSQ1=1.E-5,EPSQ=1.E-12,EPSO3=1.E-10,H0=0. &
533 &, H1=1.,HALF=.5,T0C=273.15,CUPRATE=24.*1000.,HPINC=HALF*1.E1 &
534 !------------------------ For Clouds ----------------------------------
535 &, CLFRmin=0.01, TAUCmax=4.161 &
536 !--- Parameters used for new cloud cover scheme
537 &, XSDmin=-XSDmax, DXSD1=-DXSD, STSDM=0.01, CVSDM=.04 &
538 &, DXSD2=HALF*DXSD, DXSD2N=-DXSD2, PCLDY=0.25
539 !
540 INTEGER, PARAMETER :: NB=12,KSMUD=0
541 INTEGER,PARAMETER :: K15=SELECTED_REAL_KIND(15)
542 REAL (KIND=K15) :: DDX,EEX,PROD
543 ! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D
544 !-----------------------------------------------------------------------
545 LOGICAL :: SHORT,LONG
546 LOGICAL :: BITX,BITY,BITZ,BITW,BIT1,BIT2,BITC,BITCP1,BITSP1
547 LOGICAL, SAVE :: CNCLD=.TRUE.
548 LOGICAL :: NEW_CLOUD
549 !-----------------------------------------------------------------------
550 REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: XLAND,TSK2D
551 REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: Q,QCW, &
552 & QICE,T, &
553 & PFLIP, &
554 & P8WFLIP
556 ! REAL, INTENT(IN), DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3,EM3,EM1,EM1WDE
557 REAL, INTENT(OUT), DIMENSION(ims:ime, jms:jme):: GLW,GSW,CZMEAN &
558 & ,RSWIN,RSWINC & !Added
559 & ,CFRACL,CFRACM &
560 & ,CFRACH
561 REAL, INTENT(OUT),DIMENSION(ims:ime,kms:kme,jms:jme) :: CLDFRA !added
563 ! REAL, INTENT(IN), DIMENSION(kms:kme) :: ETAD
564 ! REAL, INTENT(IN), DIMENSION(kms:kme) :: AETA
565 !-----------------------------------------------------------------------
566 REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: CUTOP,CUBOT,CUPPT
567 REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: ALB,SNO
568 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
569 REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: GLAT,GLON
570 !-----------------------------------------------------------------------
571 REAL, DIMENSION(ims:ime,jms:jme) :: CZEN
572 INTEGER, DIMENSION(its:ite, jts:jte):: LMH
573 !-----------------------------------------------------------------------
574 ! INTEGER,INTENT(IN), DIMENSION(jms:jme) :: IHE,IHW
575 !-----------------------------------------------------------------------
576 REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: ACFRCV,ACFRST &
577 ,RSWTOA,RLWTOA
578 INTEGER,INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: NCFRCV,NCFRST
579 !-----------------------------------------------------------------------
580 REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: VEGFRC
581 REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte,jts:jte) :: TENDL,&
582 & TENDS
583 !-----------------------------------------------------------------------
584 REAL :: CTHK(3)
585 DATA CTHK/20000.0,20000.0,20000.0/
587 REAL,DIMENSION(10),SAVE :: CC,PPT
588 !-----------------------------------------------------------------------
589 REAL,SAVE :: ABCFF(NB)
590 INTEGER,DIMENSION(its:ite,jts:jte) :: LVL
591 REAL, DIMENSION(its:ite, jts:jte):: PDSL,FNE,FSE,TL
592 REAL, DIMENSION( 0:kte) :: CLDAMT
593 REAL, DIMENSION(its:ite,3):: CLDCFR
594 INTEGER, DIMENSION(its:ite,3):: MBOT,MTOP
595 REAL, DIMENSION(its:ite) :: PSFC,TSKN,ALBEDO,XLAT,COSZ, &
596 & SLMSK,FLWUP, &
597 & FSWDN,FSWUP,FSWDNS,FSWUPS,FLWDNS, &
598 & FLWUPS,FSWDNSC
600 REAL, DIMENSION(its:ite,kts:kte) :: PMID,TMID
601 REAL, DIMENSION(its:ite,kts:kte) :: QMID,THMID,OZN,POZN
602 REAL, DIMENSION(its:ite,jts:jte) :: TOT
604 REAL, DIMENSION(its:ite,kts:kte+1) :: PINT,EMIS,CAMT
605 INTEGER,DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
606 INTEGER,DIMENSION(its:ite) :: NCLDS,KCLD
607 REAL, DIMENSION(its:ite) :: TAUDAR
608 REAL, DIMENSION(its:ite,NB,kts:kte+1) ::RRCL,TTCL
610 REAL, DIMENSION(its:ite,kts:kte):: CSMID,CCMID,QWMID,QIMID
611 !! & ,QOVRCST ! Added
612 REAL,SAVE :: P400=40000.
613 INTEGER,SAVE :: NFILE=14
615 !-----------------------------------------------------------------------
616 REAL :: CLSTP,TIME,DAYI,HOUR,ADDL,RANG
617 REAL :: TIMES,EXNER,APES,SNOFAC,CCLIMIT,CLIMIT,P1,P2,CC1,CC2
618 REAL :: PMOD,CLFR1,CTAU,WV,ARG,CLDMAX
619 REAL :: CL1,CL2,CR1,DPCL,QSUM,PRS1,PRS2,DELP,TCLD,DD,EE,AA,FF
620 REAL :: BB,GG,FCTR,PDSLIJ,CFRAVG,SNOMM
621 REAL :: THICK,CONVPRATE,CLFR,ESAT,QSAT,RHUM,QCLD
622 REAL :: RHtot,RRHO,FLARGE,FSMALL,DSNOW,SDM,QPCLDY,DIFCLD
623 REAL :: TauC,CTauL,CTauS, CFSmax,CFCmax
624 INTEGER :: I,J,MYJS,MYJE,MYIS,MYIE,NTSPH,NRADPP,ITIMSW,ITIMLW, &
625 & JD,II
626 INTEGER :: L,N,LML,LVLIJ,IR,KNTLYR,LL,NC,L400,NMOD,LTROP,IWKL
627 INTEGER :: LCNVB,LCNVT
628 INTEGER :: NLVL,MALVL,LLTOP,LLBOT,KBT2,KTH1,KBT1,KTH2,KTOP1,KFLIP
629 INTEGER :: NBAND,NCLD,LBASE,NKTP,NBTM,KS,MYJS1,MYJS2,MYJE2,MYJE1
631 INTEGER :: INDEXS,IXSD
632 DATA CC/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0/
633 DATA PPT/0.,.14,.31,.70,1.6,3.4,7.7,17.,38.,85./
634 DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190.,989., &
635 & 2706.,39011./
636 ! begin debugging radiation
637 integer :: imd,jmd, Jndx
638 real :: FSWrat
639 imd=(ims+ime)/2
640 jmd=(jms+jme)/2
641 ! end debugging radiation
642 !
643 !=======================================================================
644 !
645 MYJS=jts
646 MYJE=jte
647 MYIS=its
648 MYIE=ite
649 MYJS1=jts !????
650 MYJE1=jte
651 MYJS2=jts
652 MYJE2=jte
653 LM=kte
654 LM1=LM-1
655 LP1=LM+1
656 !
657 DO J=JTS,JTE
658 DO I=ITS,ITE
659 LMH(I,J)=KME-1
660 LVL(I,J)=0
661 ENDDO
662 ENDDO
663 !**********************************************************************
664 !*** THE FOLLOWING CODE IS EXECUTED EACH TIME THE RADIATION IS CALLED.
665 !**********************************************************************
666 !----------------------CONVECTION--------------------------------------
667 ! NRADPP IS THE NUMBER OF TIME STEPS TO ACCUMULATE CONVECTIVE PRECIP
668 ! FOR RADIATION
669 ! NOTE: THIS WILL NOT WORK IF NRADS AND NRADL ARE DIFFERENT UNLESS
670 ! THEY ARE INTEGER MULTIPLES OF EACH OTHER
671 ! CLSTP IS THE NUMBER OF HOURS OF THE ACCUMULATION PERIOD
672 !
673 NTSPH=NINT(3600./DT)
674 NRADPP=MIN(NRADS,NRADL)
675 CLSTP=1.0*NRADPP/NTSPH
676 CONVPRATE=CUPRATE/CLSTP
677 !----------------------CONVECTION--------------------------------------
678 !***
679 !*** STATE WHETHER THE SHORT OR LONGWAVE COMPUTATIONS ARE TO BE DONE.
680 !***
681 SHORT=.TRUE.
682 LONG=.TRUE.
683 ITIMSW=0
684 ITIMLW=0
685 IF(SHORT)ITIMSW=1
686 IF(LONG) ITIMLW=1
687 !***
688 !*** FIND THE MEAN COSINE OF THE SOLAR ZENITH ANGLE
689 !*** BETWEEN THE CURRENT TIME AND THE NEXT TIME RADIATION IS
690 !*** CALLED. ONLY AVERAGE IF THE SUN IS ABOVE THE HORIZON.
691 !***
692 ! TIME=NTSD*DT
693 TIME=XTIME*60.
694 !-----------------------------------------------------------------------
695 CALL ZENITH(TIME,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
696 & MYIS,MYIE,MYJS,MYJE, &
697 & ids,ide, jds,jde, kds,kde, &
698 & ims,ime, jms,jme, kms,kme, &
699 & its,ite, jts,jte, kts,kte )
700 !-----------------------------------------------------------------------
701 ! write(0,*)'1st ZEN ',TIME,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS)
702 ADDL=0.
703 IF(MOD(IDAT(3),4).EQ.0)ADDL=1.
704 RANG=PI2*(DAYI-RLAG)/(365.+ADDL)
705 RSIN1=SIN(RANG)
706 RCOS1=COS(RANG)
707 RCOS2=COS(2.*RANG)
708 !
709 !-----------------------------------------------------------------------
710 IF(SHORT)THEN
711 DO J=MYJS,MYJE
712 DO I=MYIS,MYIE
713 CZMEAN(I,J)=0.
714 TOT(I,J)=0.
715 ENDDO
716 ENDDO
717 !
718 DO II=0,NRADS,NPHS
719 TIMES=XTIME*60.+II*DT
720 CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
721 & MYIS,MYIE,MYJS,MYJE, &
722 & ids,ide, jds,jde, kds,kde, &
723 & ims,ime, jms,jme, kms,kme, &
724 & its,ite, jts,jte, kts,kte )
725 ! write(0,*)'2nd ZEN ',TIMES,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS),&
726 ! & II,NRADS,NPHS,NTSD,DT
727 DO J=MYJS,MYJE
728 DO I=MYIS,MYIE
729 IF(CZEN(I,J).GT.0.)THEN
730 CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J)
731 TOT(I,J)=TOT(I,J)+1.
732 ENDIF
733 ENDDO
734 ENDDO
735 ENDDO
736 DO J=MYJS,MYJE
737 DO I=MYIS,MYIE
738 IF(TOT(I,J).GT.0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J)
739 ENDDO
740 ENDDO
741 ENDIF
743 !
744 !
745 !*** Do not modify pressure for ozone concentrations below the top layer
746 !***
747 DO L=2,LM
748 DO I=MYIS,MYIE
749 POZN(I,L)=H1
750 ENDDO
751 ENDDO
752 !-----------------------------------------------------------------------
753 !
754 !***********************************************************************
755 !*** THIS IS THE BEGINNING OF THE PRIMARY LOOP THROUGH THE DOMAIN
756 !***********************************************************************
757 ! *********************
758 DO 700 J = MYJS, MYJE
759 ! *********************
760 !
761 DO 125 L=1,LM
762 DO I=MYIS,MYIE
763 TMID(I,L)=T(I,1,J)
764 QMID(I,L)=EPSQ
765 QWMID(I,L)=0.
766 QIMID(I,L)=0.
767 CSMID(I,L)=0.
768 CCMID(I,L)=0.
769 OZN(I,L)=EPSO3
770 TENDS(I,L,J)=0.
771 TENDL(I,L,J)=0.
772 ENDDO
773 125 CONTINUE
774 !
775 DO 140 N=1,3
776 DO I=MYIS,MYIE
777 CLDCFR(I,N)=0.
778 MTOP(I,N)=0
779 MBOT(I,N)=0
780 ENDDO
781 140 CONTINUE
782 !***
783 !*** FILL IN WORKING ARRAYS WHERE VALUES AT L=LM ARE THOSE THAT
784 !*** ARE ACTUALLY AT ETA LEVEL L=LMH.
785 !***
786 DO 200 I=MYIS,MYIE
787 ! IR=IRAD(I)
788 LML=LMH(I,J)
789 LVLIJ=LVL(I,J)
790 !
791 DO L=1,LML
792 PMID(I,L+LVLIJ)=PFLIP(I,L,J)
793 PINT(I,L+LVLIJ+1)=P8WFLIP(I,L+1,J)
794 EXNER=(1.E5/PMID(I,L+LVLIJ))**RCP
795 TMID(I,L+LVLIJ)=T(I,L,J)
796 THMID(I,L+LVLIJ)=T(I,L,J)*EXNER
797 QMID(I,L+LVLIJ)=MAX(EPSQ, Q(I,L,J))
798 !--- Note that rain is ignored, only effects from cloud water and
799 ! ice (cloud ice + snow) are considered
800 QWMID(I,L+LVLIJ)=QCW(I,L,J)
801 QIMID(I,L+LVLIJ)=QICE(I,L,J)
802 ENDDO
803 !***
804 !*** FILL IN ARTIFICIAL VALUES ABOVE THE TOP OF THE DOMAIN.
805 !*** PRESSURE DEPTHS OF THESE LAYERS IS 1 HPA.
806 !*** TEMPERATURES ABOVE ARE ALREADY ISOTHERMAL WITH (TRUE) LAYER 1.
807 !***
808 IF(LVLIJ.GT.0)THEN
809 KNTLYR=0
810 !
811 DO L=LVLIJ,1,-1
812 KNTLYR=KNTLYR+1
813 PMID(I,L)=P8WFLIP(I,1,J)-REAL(2*KNTLYR-1)*HPINC
814 PINT(I,L+1)=PMID(I,L)+HPINC
815 EXNER=(1.E5/PMID(I,L))**RCP
816 THMID(I,L)=TMID(I,L)*EXNER
817 ENDDO
818 ENDIF
819 !
820 IF(LVLIJ.EQ.0) THEN
821 PINT(I,1)=P8WFLIP(I,1,J)
822 ELSE
823 PINT(I,1)=PMID(I,1)-HPINC
824 ENDIF
825 200 CONTINUE
826 !***
827 !*** FILL IN THE SURFACE PRESSURE, SKIN TEMPERATURE, GEODETIC LATITUDE,
828 !*** ZENITH ANGLE, SEA MASK, AND ALBEDO. THE SKIN TEMPERATURE IS
829 !*** NEGATIVE OVER WATER.
830 !***
831 DO 250 I=MYIS,MYIE
832 PSFC(I)=P8WFLIP(I,KME,J)
833 APES=(PSFC(I)*1.E-5)**RCP
834 ! TSKN(I)=THS(I,J)*APES*(1.-2.*SM(I,J))
835 IF((XLAND(I,J)-1.5).GT.0.)THEN
836 TSKN(I)=-TSK2D(I,J)
837 ELSE
838 TSKN(I)=TSK2D(I,J)
839 ENDIF
841 ! TSKN(I)=THS(I,J)*APES*(1.-2.*(XLAND(I,J)-1.))
842 ! SLMSK(I)=SM(I,J)
843 SLMSK(I)=XLAND(I,J)-1.
844 !
845 ! SNO(I,J)=AMAX1(SNO(I,J),0.)
846 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
847 SNOMM=AMAX1(SNO(I,J),0.)
848 SNOFAC=AMIN1(SNOMM/0.02, 1.0)
849 !!!! ALBEDO(I)=ALB(I,J)+(1.0-0.01*VEGFRC(I,J))*SNOFAC*(SNOALB-ALB(I,J))
850 ALBEDO(I)=ALB(I,J)
851 !
852 XLAT(I)=GLAT(I,J)*RTD
853 COSZ(I)=CZMEAN(I,J)
854 250 CONTINUE
855 !-----------------------------------------------------------------------
856 !--- COMPUTE GRID-SCALE CLOUD COVER FOR RADIATION (Ferrier, Nov '04)
857 !
858 !--- Assumes Gaussian-distributed probability density functions (PDFs) for
859 ! total relative humidity (RHtot) within the grid for convective and
860 ! grid-scale cloud processes. The standard deviation of RHtot is assumed
861 ! to be larger for convective clouds than grid-scale (stratiform) clouds.
862 !-----------------------------------------------------------------------
863 !
864 DO I=MYIS,MYIE
865 LML=LMH(I,J)
866 LVLIJ=LVL(I,J)
867 DO 255 L=1,LML
868 LL=L+LVLIJ
869 WV=QMID(I,LL)/(1.-QMID(I,LL)) !--- Water vapor mixing ratio
870 QCLD=QWMID(I,LL)+QIMID(I,LL) !--- Total cloud water + ice mixing ratio
871 IF (QCLD .LE. EPSQ) GO TO 255 !--- Skip if no condensate is present
872 CLFR=H0
873 WV=QMID(I,LL)/(1.-QMID(I,LL)) !--- Water vapor mixing ratio
875 !
876 !--- Saturation vapor pressure w/r/t water ( >=0C ) or ice ( <0C )
877 !
878 #ifdef FERRIER_GFDL
879 ESAT=1000.*FPVS(TMID(I,LL)) !--- Saturation vapor pressure (Pa)
880 #else
881 ESAT=FPVS_new(TMID(I,LL)) !--- Saturation vapor pressure (Pa)
882 #endif
883 QSAT=EP_2*ESAT/(PMID(I,LL)-ESAT) !--- Saturation mixing ratio
884 RHUM=WV/QSAT !--- Relative humidity
885 !
886 !--- Revised cloud cover parameterization (temporarily ignore rain)
887 !
888 RHtot=(WV+QCLD)/QSAT !--- Total relative humidity
889 !! !
890 !! !--- QOVRCST is the amount of cloud condensate associated with full
891 !! ! overcast, PCLDY is an arbitrary factor for partial cloudiness
892 !! !
893 !! TCLD=TMID(I,LL)-T0C !--- Air temp in deg C
894 !! RRHO=(R_D*TMID(I,LL)*(1.+EP_1*QMID(I,LL)))/PMID(I,LL)
895 !! IF (TCLD .GE. 0.) THEN
896 !! QOVRCST(I,LL)=QAUT0*RRHO
897 !! ELSE
898 !! IF (TCLD.GE.-8. .AND. TCLD.LE.-3.) THEN
899 !! FLARGE=FLARGE1
900 !! ELSE
901 !! FLARGE=FLARGE2
902 !! ENDIF
903 !! FSMALL=(1.-FLARGE)/FLARGE
904 !! DSNOW=XMImax*EXP(XMIexp*TCLD)
905 !! INDEXS=MAX(MDImin, MIN(MDImax, INT(DSNOW)))
906 !! QOVRCST(I,LL)=NLImax*( FSMALL*MASSI(MDImin) &
907 !! & +MASSI(INDEXS) )*RRHO
908 !! ENDIF !--- End IF (TCLD .GE. 0.)
909 !! QOVRCST(I,LL)=PCLDY*QOVRCST(I,LL)
910 LCNVT=NINT(CUTOP(I,J))+LVLIJ
911 LCNVT=MIN(LM,LCNVT)
912 LCNVB=NINT(CUBOT(I,J))+LVLIJ
913 LCNVB=MIN(LM,LCNVB)
914 IF (LL.GE.LCNVT .AND. LL.LE.LCNVB) THEN
915 SDM=CVSDM
916 ELSE
917 SDM=STSDM
918 ENDIF
919 ARG=(RHtot-RHgrd)/SDM
920 IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N) THEN
921 CLFR=HALF
922 ELSE IF (ARG .GT. DXSD2) THEN
923 IF (ARG .GE. XSDmax) THEN
924 CLFR=H1
925 ELSE
926 IXSD=INT(ARG/DXSD+HALF)
927 IXSD=MIN(NXSD, MAX(IXSD,1))
928 CLFR=HALF+AXSD(IXSD)
929 if (SDprint) &
930 & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)") &
931 & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot &
932 & ,1000.*QSAT,TCLD,.01*PMID(I,LL)
933 ENDIF !--- End IF (ARG .GE. XSDmax)
934 ELSE
935 IF (ARG .LE. XSDmin) THEN
936 CLFR=H0
937 ELSE
938 IXSD=INT(ARG/DXSD1+HALF)
939 IXSD=MIN(NXSD, MAX(IXSD,1))
940 CLFR=HALF-AXSD(IXSD)
941 if (SDprint) &
942 & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)") &
943 & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot &
944 & ,1000.*QSAT,TCLD,.01*PMID(I,LL)
945 IF (CLFR .LT. CLFRmin) CLFR=H0
946 ENDIF !--- End IF (ARG .LE. XSDmin)
947 ENDIF !--- IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N)
948 CSMID(I,LL)=CLFR
949 !! !
950 !! !--- Here the condensate is adjusted to be only over the cloudy area
951 !! !
952 !! IF (CLFR.GT.0. .AND. QCLD.LE.0.) THEN
953 !! !
954 !! !--- Put in modest amounts of cloud water & cloud ice for partially cloudy grids
955 !! !
956 !! QPCLDY=MIN(.01*QSAT, QOVRCST(I,LL))
957 !! IF (TCLD .GE. H0) THEN
958 !! QWMID(I,LL)=QPCLDY
959 !! ELSE
960 !! QIMID(I,LL)=QPCLDY
961 !! ENDIF
962 !! ENDIF !--- End IF (CLFR.GT.0. .AND. QCLD.LE.0.)
963 255 CONTINUE !--- End DO L=1,LML
964 ENDDO !--- End DO I=MYIS,MYIE
965 !
966 !***********************************************************************
967 !****************** END OF GRID-SCALE CLOUD FRACTIONS ****************
968 !
969 !--- COMPUTE CONVECTIVE CLOUD COVER FOR RADIATION
970 !
971 !--- The parameterization of Slingo (1987, QJRMS, Table 1, p. 904) is
972 ! used for convective cloud fraction as a function of precipitation
973 ! rate. Cloud fractions have been increased by 20% for each rainrate
974 ! interval so that shallow, nonprecipitating convection is ascribed a
975 ! constant cloud fraction of 0.1 (Ferrier, Feb '02).
976 !***********************************************************************
977 !
978 IF (CNCLD) THEN
979 DO I=MYIS,MYIE
980 !
981 !*** CLOUD TOPS AND BOTTOMS COME FROM CUCNVC
982 ! Convective clouds need to be at least 2 model layers thick
983 !
984 IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) THEN
985 !--- Compute convective cloud fractions if appropriate (Ferrier, Feb '02)
986 CLFR=CC(1)
987 PMOD=CUPPT(I,J)*CONVPRATE
988 IF (PMOD .GT. PPT(1)) THEN
989 DO NC=1,10
990 IF(PMOD.GT.PPT(NC)) NMOD=NC
991 ENDDO
992 IF (NMOD .GE. 10) THEN
993 CLFR=CC(10)
994 ELSE
995 CC1=CC(NMOD)
996 CC2=CC(NMOD+1)
997 P1=PPT(NMOD)
998 P2=PPT(NMOD+1)
999 CLFR=CC1+(CC2-CC1)*(PMOD-P1)/(P2-P1)
1000 ENDIF !--- End IF (NMOD .GE. 10) ...
1001 CLFR=MIN(H1, CLFR)
1002 ENDIF !--- End IF (PMOD .GT. PPT(1)) ...
1003 !
1004 !*** ADD LVL TO BE CONSISTENT WITH OTHER WORKING ARRAYS
1005 !
1006 LVLIJ=LVL(I,J)
1007 LCNVT=NINT(CUTOP(I,J))+LVLIJ
1008 LCNVT=MIN(LM,LCNVT)
1009 LCNVB=NINT(CUBOT(I,J))+LVLIJ
1010 LCNVB=MIN(LM,LCNVB)
1011 !! !
1012 !! !---- For debugging
1013 !! !
1014 !! WRITE(6,"(2(A,I3),2(A,I2),2(A,F5.2),2(A,I2),A,F6.4)")
1015 !! & ' J=',J,' I=',I,' LCNVB=',LCNVB,' LCNVT=',LCNVT
1016 !! &, ' CUBOT=',CUBOT(I,J),' CUTOP=',CUTOP(I,J)
1017 !! &,' LVL=',LVLIJ,' LMH=',LMH(I,J),' CCMID=',CLFR
1018 !! !
1019 !
1020 !--- Build in small amounts of subgrid-scale convective condensate
1021 ! (simple assumptions), but only if the convective cloud fraction
1022 ! exceeds that of the grid-scale cloud fraction
1023 !
1024 DO LL=LCNVT,LCNVB
1025 ARG=MAX(H0, H1-CSMID(I,LL))
1026 CCMID(I,LL)=MIN(ARG,CLFR)
1027 ENDDO !--- End DO LL=LCNVT,LCNVB
1028 ENDIF !--- IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) ...
1029 ENDDO !--- End DO I loop
1030 ENDIF !--- End IF (CNCLD) ...
1031 !
1032 !*********************************************************************
1033 !*************** END OF CONVECTIVE CLOUD FRACTIONS *****************
1034 !*********************************************************************
1035 !***
1036 !*** DETERMINE THE FRACTIONAL CLOUD COVERAGE FOR HIGH, MID
1037 !*** AND LOW OF CLOUDS FROM THE CLOUD COVERAGE AT EACH LEVEL
1038 !***
1039 !*** NOTE: THIS IS FOR DIAGNOSTICS ONLY!!!
1040 !***
1041 !***
1042 DO 500 I=MYIS,MYIE
1043 !!
1044 DO L=0,LM
1045 CLDAMT(L)=0.
1046 ENDDO
1047 !!
1048 !!*** NOW GOES LOW, MIDDLE, HIGH
1049 !!
1050 DO 480 NLVL=1,3
1051 CLDMAX=0.
1052 MALVL=LM
1053 LLTOP=LM+1-LTOP(NLVL)+LVL(I,J)
1054 !!***
1055 !!*** GO TO THE NEXT CLOUD LAYER IF THE TOP OF THE CLOUD-TYPE IN
1056 !!*** QUESTION IS BELOW GROUND OR IS IN THE LOWEST LAYER ABOVE GROUND.
1057 !!***
1058 IF(LLTOP.GE.LM)GO TO 480
1059 !!
1060 IF(NLVL.GT.1)THEN
1061 LLBOT=LM+1-LTOP(NLVL-1)-1+LVL(I,J)
1062 LLBOT=MIN(LLBOT,LM1)
1063 ELSE
1064 LLBOT=LM1
1065 ENDIF
1066 !!
1067 DO 435 L=LLTOP,LLBOT
1068 CLDAMT(L)=AMAX1(CSMID(I,L),CCMID(I,L))
1069 IF(CLDAMT(L).GT.CLDMAX)THEN
1070 MALVL=L
1071 CLDMAX=CLDAMT(L)
1072 ENDIF
1073 435 CONTINUE
1074 !!*********************************************************************
1075 !! NOW, CALCULATE THE TOTAL CLOUD FRACTION IN THIS PRESSURE DOMAIN
1076 !! USING THE METHOD DEVELOPED BY Y.H., K.A.C. AND A.K. (NOV., 1992).
1077 !! IN THIS METHOD, IT IS ASSUMED THAT SEPERATED CLOUD LAYERS ARE
1078 !! RADOMLY OVERLAPPED AND ADJACENT CLOUD LAYERS ARE MAXIMUM OVERLAPPED.
1079 !! VERTICAL LOCATION OF EACH TYPE OF CLOUD IS DETERMINED BY THE THICKEST
1080 !! CONTINUING CLOUD LAYERS IN THE DOMAIN.
1081 !!*********************************************************************
1082 CL1=0.0
1083 CL2=0.0
1084 KBT1=LLBOT
1085 KBT2=LLBOT
1086 KTH1=0
1087 KTH2=0
1088 !!
1089 DO 450 LL=LLTOP,LLBOT
1090 L=LLBOT-LL+LLTOP
1091 BIT1=.FALSE.
1092 CR1=CLDAMT(L)
1093 BITX=(PINT(I,L).GE.PTOPC(NLVL+1)).AND. &
1094 & (PINT(I,L).LT.PTOPC(NLVL)).AND. &
1095 & (CLDAMT(L).GT.0.0)
1096 BIT1=BIT1.OR.BITX
1097 IF(.NOT.BIT1)GO TO 450
1098 !!***
1099 !!*** BITY=T: FIRST CLOUD LAYER; BITZ=T:CONSECUTIVE CLOUD LAYER
1100 !!*** NOTE: WE ASSUME THAT THE THICKNESS OF EACH CLOUD LAYER IN THE
1101 !!*** DOMAIN IS LESS THAN 200 MB TO AVOID TOO MUCH COOLING OR
1102 !!*** HEATING. SO WE SET CTHK(NLVL)=200*E2. BUT THIS LIMIT MAY
1103 !!*** WORK WELL FOR CONVECTIVE CLOUDS. MODIFICATION MAY BE
1104 !!*** NEEDED IN THE FUTURE.
1105 !!***
1106 BITY=BITX.AND.(KTH2.LE.0)
1107 BITZ=BITX.AND.(KTH2.GT.0)
1108 !!
1109 IF(BITY)THEN
1110 KBT2=L
1111 KTH2=1
1112 ENDIF
1113 !!
1114 IF(BITZ)THEN
1115 KTOP1=KBT2-KTH2+1
1116 DPCL=PMID(I,KBT2)-PMID(I,KTOP1)
1117 IF(DPCL.LT.CTHK(NLVL))THEN
1118 KTH2=KTH2+1
1119 ELSE
1120 KBT2=KBT2-1
1121 ENDIF
1122 ENDIF
1123 IF(BITX)CL2=AMAX1(CL2,CR1)
1124 !!***
1125 !!*** AT THE DOMAIN BOUNDARY OR SEPARATED CLD LAYERS, RANDOM OVERLAP.
1126 !!*** CHOOSE THE THICKEST OR THE LARGEST FRACTION AMT AS THE CLD
1127 !!*** LAYER IN THAT DOMAIN.
1128 !!***
1129 BIT2=.FALSE.
1130 BITY=BITX.AND.(CLDAMT(L-1).LE.0.0.OR. &
1131 PINT(I,L-1).LT.PTOPC(NLVL+1))
1132 BITZ=BITY.AND.CL1.GT.0.0
1133 BITW=BITY.AND.CL1.LE.0.0
1134 BIT2=BIT2.OR.BITY
1135 IF(.NOT.BIT2)GO TO 450
1136 !!
1137 IF(BITZ)THEN
1138 KBT1=INT((CL1*KBT1+CL2*KBT2)/(CL1+CL2))
1139 KTH1=INT((CL1*KTH1+CL2*KTH2)/(CL1+CL2))+1
1140 CL1=CL1+CL2-CL1*CL2
1141 ENDIF
1142 !!
1143 IF(BITW)THEN
1144 KBT1=KBT2
1145 KTH1=KTH2
1146 CL1=CL2
1147 ENDIF
1148 !!
1149 IF(BITY)THEN
1150 KBT2=LLBOT
1151 KTH2=0
1152 CL2=0.0
1153 ENDIF
1154 450 CONTINUE
1155 !
1156 CLDCFR(I,NLVL)=AMIN1(1.0,CL1)
1157 MTOP(I,NLVL)=MIN(KBT1,KBT1-KTH1+1)
1158 MBOT(I,NLVL)=KBT1
1159 480 CONTINUE
1160 500 CONTINUE
1162 !***
1163 !*** SET THE UN-NEEDED TAUDAR TO ONE
1164 !***
1165 DO I=MYIS,MYIE
1166 TAUDAR(I)=1.0
1167 ENDDO
1168 !----------------------------------------------------------------------
1169 ! NOW, CALCULATE THE CLOUD RADIATIVE PROPERTIES AFTER DAVIS (1982),
1170 ! HARSHVARDHAN ET AL (1987) AND Y.H., K.A.C. AND A.K. (1993).
1171 !
1172 ! UPDATE: THE FOLLOWING PARTS ARE MODIFIED, AFTER Y.T.H. (1994), TO
1173 ! CALCULATE THE RADIATIVE PROPERTIES OF CLOUDS ON EACH MODEL
1174 ! LAYER. BOTH CONVECTIVE AND STRATIFORM CLOUDS ARE USED
1175 ! IN THIS CALCULATIONS.
1176 !
1177 ! QINGYUN ZHAO 95-3-22
1178 !
1179 !----------------------------------------------------------------------
1180 !
1181 !***
1182 !*** INITIALIZE ARRAYS FOR USES LATER
1183 !***
1185 DO 600 I=MYIS,MYIE
1186 LML=LMH(I,J)
1187 LVLIJ=LVL(I,J)
1188 !
1189 !***
1190 !*** NOTE: LAYER=1 IS THE SURFACE, AND LAYER=2 IS THE FIRST CLOUD
1191 !*** LAYER ABOVE THE SURFACE AND SO ON.
1192 !***
1193 EMIS(I,1)=1.0
1194 KTOP(I,1)=LP1
1195 KBTM(I,1)=LP1
1196 CAMT(I,1)=1.0
1197 KCLD(I)=2
1198 !
1199 DO NBAND=1,NB
1200 RRCL(I,NBAND,1)=0.0
1201 TTCL(I,NBAND,1)=1.0
1202 ENDDO
1203 !
1204 DO 510 L=2,LP1
1205 CAMT(I,L)=0.0
1206 KTOP(I,L)=1
1207 KBTM(I,L)=1
1208 EMIS(I,L)=0.0
1209 !
1210 DO NBAND=1,NB
1211 RRCL(I,NBAND,L)=0.0
1212 TTCL(I,NBAND,L)=1.0
1213 ENDDO
1214 510 CONTINUE
1216 !### End changes so far
1217 !***
1218 !*** NOW CALCULATE THE AMOUNT, TOP, BOTTOM AND TYPE OF EACH CLOUD LAYER
1219 !*** CLOUD TYPE=1: STRATIFORM CLOUD
1220 !*** TYPE=2: CONVECTIVE CLOUD
1221 !*** WHEN BOTH CONVECTIVE AND STRATIFORM CLOUDS EXIST AT THE SAME POINT,
1222 !*** SELECT CONVECTIVE CLOUD WITH THE HIGHER CLOUD FRACTION.
1223 !*** CLOUD LAYERS ARE SEPARATED BY TOTAL ABSENCE OF CLOUDINESS.
1224 !*** NOTE: THERE IS ONLY ONE CONVECTIVE CLOUD LAYER IN ONE COLUMN.
1225 !*** KTOP AND KBTM ARE THE TOP AND BOTTOM OF EACH CLOUD LAYER IN TERMS
1226 !*** OF MODEL LEVEL.
1227 !***
1228 NEW_CLOUD=.TRUE.
1229 !
1230 DO L=2,LML
1231 LL=LML-L+1+LVLIJ !-- Model layer
1232 CLFR=MAX(CCMID(I,LL),CSMID(I,LL)) !-- Cloud fraction in layer
1233 CLFR1=MAX(CCMID(I,LL+1),CSMID(I,LL+1)) !-- Cloud fraction in lower layer
1234 !-------------------
1235 IF (CLFR .GE. CLFRMIN) THEN
1236 !--- Cloud present at level
1237 IF (NEW_CLOUD) THEN
1238 !--- New cloud layer
1239 IF(L==2.AND.CLFR1>=CLFRmin)THEN
1240 KBTM(I,KCLD(I))=LL+1
1241 CAMT(I,KCLD(I))=CLFR1
1242 ELSE
1243 KBTM(I,KCLD(I))=LL
1244 CAMT(I,KCLD(I))=CLFR
1245 ENDIF
1246 NEW_CLOUD=.FALSE.
1247 ELSE
1248 !--- Existing cloud layer
1249 CAMT(I,KCLD(I))=AMAX1(CAMT(I,KCLD(I)), CLFR)
1250 ENDIF ! End IF (NEW_CLOUD .EQ. 0) ...
1251 ELSE IF (CLFR1 .GE. CLFRMIN) THEN
1252 !--- Cloud is not present at level but did exist at lower level, then ...
1253 IF (L .EQ. 2) THEN
1254 !--- For the case of ground fog
1255 KBTM(I,KCLD(I))=LL+1
1256 CAMT(I,KCLD(I))=CLFR1
1257 ENDIF
1258 KTOP(I,KCLD(I))=LL+1
1259 NEW_CLOUD=.TRUE.
1260 KCLD(I)=KCLD(I)+1
1261 CAMT(I,KCLD(I))=0.0
1262 ENDIF
1263 !-------------------
1264 ENDDO !--- End DO L loop
1265 !***
1266 !*** THE REAL NUMBER OF CLOUD LAYERS IS (THE FIRST IS THE GROUND;
1267 !*** THE LAST IS THE SKY):
1268 !***
1269 NCLDS(I)=KCLD(I)-2
1270 NCLD=NCLDS(I)
1271 !***
1272 !*** NOW CALCULATE CLOUD RADIATIVE PROPERTIES
1273 !***
1274 IF(NCLD.GE.1)THEN
1275 !***
1276 !*** NOTE: THE FOLLOWING CALCULATIONS, THE UNIT FOR PRESSURE IS MB!!!
1277 !***
1278 DO 580 NC=2,NCLD+1
1279 !
1280 TauC=0. !--- Total optical depth for each cloud layer (solar & longwave)
1281 QSUM=0.0
1282 NKTP=LP1
1283 NBTM=0
1284 BITX=CAMT(I,NC).GE.CLFRMIN
1285 NKTP=MIN(NKTP,KTOP(I,NC))
1286 NBTM=MAX(NBTM,KBTM(I,NC))
1287 !
1288 DO LL=NKTP,NBTM
1289 IF(LL.GE.KTOP(I,NC).AND.LL.LE.KBTM(I,NC).AND.BITX)THEN
1290 PRS1=PINT(I,LL)*0.01
1291 PRS2=PINT(I,LL+1)*0.01
1292 DELP=PRS2-PRS1
1293 TCLD=TMID(I,LL)-T0C
1294 QSUM=QSUM+QMID(I,LL)*DELP*(PRS1+PRS2) &
1295 & /(120.1612*SQRT(TMID(I,LL)))
1296 !
1297 !***********************************************************************
1298 !**** IMPORTANT NOTES concerning input cloud optical properties ******
1299 !***********************************************************************
1300 !
1301 !--- The simple optical depth parameterization from eq. (1) of Harshvardhan
1302 ! et al. (1989, JAS, p. 1924; hereafter referred to as HRCD by authorship)
1303 ! is used for convective cloud properties with some simple changes.
1304 !
1305 !--- The optical depth Tau is Tau=CTau*DELP, where values of CTau are
1306 ! described below.
1307 ! 1) CTau=0.08*(Qc/Q0) for cloud water mixing ratio (Qc), where
1308 ! Q0 is assumed to be the threshold mixing ratio for "thick anvils",
1309 ! as noted in the 2nd paragraph after eq. (1) in Harshvardhan et al.
1310 ! (1989). A value of Q0=0.1 g/kg is assumed based on experience w/
1311 ! cloud observations, and it is intended only to be a crude scaling
1312 ! factor for "order of magnitude" effects. The functional dependence
1313 ! on mixing ratio is based on Stephens (1978, JAS, p. 2124, eq. 7).
1314 ! Result: CTau=800.*Qc => note that the "800." factor is referred to
1315 ! as an absorption coefficient
1316 ! 2) For an assumed value of Q0=1 g/kg for "thick anvils", then
1317 ! CTau=80.*Qc, or an absorption coefficient that is an order of
1318 ! magnitude less.
1319 ! => ABSCOEF_W can vary from 100. to 1000. !!
1320 ! 3) From p. 3105 of Dudhia (1989), values of
1321 ! 0.14 (m**2/g) * 1000 (g/kg) / 9.81 (m/s**2) = 14.27 /Pa
1322 ! => 14.27 (/Pa) * 100 (Pa/mb) = 1427 /mb
1323 ! 4) From Dudhia's SW radiation, ABSCOEF_W ~ 1000. after units conversion
1324 ! 5) Again from p. 3105 of Dudhia (1989), he notes that ice absorption
1325 ! coefficients are roughly half those of cloud water, it was decided
1326 ! to keep this simple and assume half that of water.
1327 ! => ABSCOEF_I=0.5*ABSCOEF_W
1328 !
1329 !--- For convection, the following is assumed:
1330 ! 1) A characteristic water/ice mixing ratio (Qconv)
1331 ! 2) A temperature threshold for water or ice (TRAD_ice)
1332 !
1333 !-----------------------------------------------------------------------
1334 !
1335 CTau=0.
1336 !-- For crude estimation of convective cloud optical depths
1337 IF (CCMID(I,LL) .GE. CLFRmin) THEN
1338 IF (TCLD .GE. TRAD_ice) THEN
1339 CTau=CTauCW !--- Convective cloud water
1340 ELSE
1341 CTau=CTauCI !--- Convective ice
1342 ENDIF
1343 ! CTau=CTau*CCMID(I,LL) !--- Reduce by convective cloud fraction
1344 ENDIF
1345 !
1346 !-- For crude estimation of grid-scale cloud optical depths
1347 !
1348 !-- => The following 2 lines were intended to reduce cloud optical depths further
1349 ! than what's parameterized in the NAM and what's theoretically justified
1350 ! CTau=CTau+CSMID(I,LL)* &
1351 ! & ( ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL) )
1352 CTau=CTau+ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL)
1353 TauC=TauC+DELP*CTau
1354 ENDIF !--- End IF(LL.GE.KTOP(I,NC) ....
1355 ENDDO !--- End DO LL
1356 !
1357 IF(BITX)EMIS(I,NC)=1.0-EXP(ABSCOEF_LW*TauC)
1358 IF(QSUM.GE.EPSQ1)THEN
1359 !
1360 DO 570 NBAND=1,NB
1361 IF(BITX)THEN
1362 PROD=ABCFF(NBAND)*QSUM
1363 DDX=TauC/(TauC+PROD)
1364 EEX=1.0-DDX
1365 IF(ABS(EEX).GE.1.E-8)THEN
1366 DD=DDX
1367 EE=EEX
1368 FF=1.0-DD*0.85
1369 AA=MIN(50.0,SQRT(3.0*EE*FF)*TauC)
1370 AA=EXP(-AA)
1371 BB=FF/EE
1372 GG=SQRT(BB)
1373 DD=(GG+1.0)*(GG+1.0)-(GG-1.0)*(GG-1.0)*AA*AA
1374 RRCL(I,NBAND,NC)=MAX(0.1E-5,(BB-1.0)*(1.0-AA*AA)/DD)
1375 TTCL(I,NBAND,NC)=AMAX1(0.1E-5,4.0*GG*AA/DD)
1376 ENDIF
1377 ENDIF
1378 570 CONTINUE
1379 ENDIF
1380 580 CONTINUE
1381 !
1382 ENDIF
1383 !
1384 600 CONTINUE
1385 !*********************************************************************
1386 !****************** COMPUTE OZONE AT MIDLAYERS *********************
1387 !*********************************************************************
1388 !
1389 !*** MODIFY PRESSURE AT THE TOP MODEL LAYER TO ACCOUNT FOR THE TOTAL
1390 !*** OZONE FROM MODEL TOP (PINT_1) TO THE TOP OF THE ATMOSPHERE (0 MB)
1391 !
1392 DO I=MYIS,MYIE
1393 FCTR=PINT(I,2)/(PINT(I,2)-PINT(I,1))
1394 POZN(I,1)=FCTR*(PMID(I,1)-PINT(I,1))
1395 ENDDO
1396 !
1397 CALL OZON2D(LM,POZN,XLAT,OZN, &
1398 MYIS,MYIE, &
1399 ids,ide, jds,jde, kds,kde, &
1400 ims,ime, jms,jme, kms,kme, &
1401 its,ite, jts,jte, kts,kte )
1402 !
1403 !***
1404 !*** NOW THE VARIABLES REQUIRED BY RADFS HAVE BEEN CALCULATED.
1405 !***
1406 !----------------------------------------------------------------------
1407 !***
1408 !*** CALL THE GFDL RADIATION DRIVER
1409 !***
1410 !***
1411 Jndx=J
1412 CALL RADFS &
1413 & (PSFC,PMID,PINT,QMID,TMID,OZN,TSKN,SLMSK,ALBEDO,XLAT &
1414 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
1415 &, CAMT,KTOP,KBTM,NCLDS,EMIS,RRCL,TTCL &
1416 &, COSZ,TAUDAR,1 &
1417 &, 1,0 &
1418 &, ITIMSW,ITIMLW &
1419 &, TENDS(ITS,KTS,J),TENDL(ITS,KTS,J) &
1420 &, FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC &
1421 &, ids,ide, jds,jde, kds,kde &
1422 &, ims,ime, jms,jme, kms,kme &
1423 ! begin debugging radiation
1424 &, its,ite, jts,jte, kts,kte &
1425 &, imd,jmd, Jndx )
1426 ! end debugging radiation
1427 !----------------------------------------------------------------------
1428 IF(LONG)THEN
1429 !
1430 !-- All fluxes in W/m**2
1431 !--- GLW => downward longwave at the surface (formerly RLWIN)
1432 !--- RLWTOA => outgoing longwave at the top of the atmosphere
1433 !-- Note: RLWOUT & SIGT4 have been removed because they are no longer being used!
1434 !
1435 DO I=MYIS,MYIE
1436 GLW(I,J)=FLWDNS(I)
1437 RLWTOA(I,J)=FLWUP(I)
1438 ENDDO
1439 ENDIF
1440 !
1441 IF(SHORT)THEN
1442 !
1443 !-- All fluxes in W/m**2
1444 !--- GSW => NET shortwave at the surface
1445 !--- RSWIN => incoming shortwave at the surface (all sky)
1446 !--- RSWINC => clear-sky incoming shortwave at the surface
1447 !--- RSWTOA => outgoing (reflected) shortwave at the top of the atmosphere
1448 !
1449 DO I=MYIS,MYIE
1450 GSW(I,J)=FSWDNS(I)-FSWUPS(I)
1451 RSWIN(I,J) =FSWDNS(I)
1452 RSWINC(I,J)=FSWDNSC(I)
1453 RSWTOA(I,J)=FSWUP(I)
1454 ENDDO
1455 ENDIF
1456 !
1457 !*** ARRAYS ACFRST AND ACFRCV ACCUMULATE AVERAGE STRATIFORM AND
1458 !*** CONVECTIVE CLOUD FRACTIONS, RESPECTIVELY.
1459 !*** ACCUMLATE THESE VARIABLES ONLY ONCE PER RADIATION CALL.
1460 !
1461 !*** ASSUME RANDOM OVERLAP BETWEEN LOW, MIDDLE, & HIGH LAYERS.
1462 !
1463 !*** UPDATE NEW 3D CLOUD FRACTION (CLDFRA)
1464 !
1465 DO I=MYIS,MYIE
1466 CFRACL(I,J)=CLDCFR(I,1)
1467 CFRACM(I,J)=CLDCFR(I,2)
1468 CFRACH(I,J)=CLDCFR(I,3)
1469 IF(CNCLD)THEN
1470 CFSmax=0. !-- Maximum cloud fraction (stratiform component)
1471 CFCmax=0. !-- Maximum cloud fraction (convective component)
1472 DO L=1,LMH(I,J)
1473 LL=L+LVL(I,J)
1474 CFSmax=MAX(CFSmax, CSMID(I,LL) )
1475 CFCmax=MAX(CFCmax, CCMID(I,LL) )
1476 ENDDO
1477 ACFRST(I,J)=ACFRST(I,J)+CFSmax
1478 NCFRST(I,J)=NCFRST(I,J)+1
1479 ACFRCV(I,J)=ACFRCV(I,J)+CFCmax
1480 NCFRCV(I,J)=NCFRCV(I,J)+1
1481 ELSE
1482 !--- Count only locations with grid-scale cloudiness, ignore convective clouds
1483 ! (option not used, but if so set to the total cloud fraction)
1484 CFRAVG=1.-(1.-CFRACL(I,J))*(1.-CFRACM(I,J))*(1.-CFRACH(I,J))
1485 ACFRST(I,J)=ACFRST(I,J)+CFRAVG
1486 NCFRST(I,J)=NCFRST(I,J)+1
1487 ENDIF
1488 !--- Flip 3D cloud fractions in the vertical and save time
1489 LML=LMH(I,J)
1490 DO L=1,LML
1491 LL=LML-L+1+LVL(I,J)
1492 CLDFRA(I,L,J)=MAX(CCMID(I,LL),CSMID(I,LL))
1493 ENDDO
1494 ENDDO !-- I index
1495 !***
1496 !*** THIS ROW IS FINISHED. GO TO NEXT
1497 !***
1498 ! *********************
1499 700 CONTINUE
1500 ! *********************
1501 !----------------------------------------------------------------------
1502 !***
1503 !*** CALLS TO RADIATION THIS TIME STEP ARE COMPLETE.
1504 !***
1505 !----------------------------------------------------------------------
1506 ! begin debugging radiation
1507 ! FSWrat=0.
1508 ! if (RSWIN(imd,jmd) .gt. 0.) &
1509 ! FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd)
1510 ! write(6,"(2a,2i5,7f9.2)") &
1511 ! '{rad3 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' &
1512 ! ,'ALBEDO,RSWOUT/RSWIN = '&
1513 ! ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd) &
1514 ! ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) &
1515 ! ,ALB(imd,jmd),FSWrat
1516 ! end debugging radiation
1517 !----------------------------------------------------------------------
1518 !
1519 !--- Need to save LW & SW tendencies since radiation calculates both and this block
1521 END SUBROUTINE RADTN
1523 !----------------------------------------------------------------------
1525 REAL FUNCTION GAUSIN(xsd)
1526 REAL, PARAMETER :: crit=1.e-3
1527 REAL A1,A2,RN,B1,B2,B3,SUM
1528 !
1529 ! This function calculate area under the Gaussian curve between mean
1530 ! and xsd # of standard deviation (03/22/2004 Hsin-mu Lin)
1531 !
1532 a1=xsd*RSQR
1533 a2=exp(-0.5*xsd**2)
1534 rn=1.
1535 b1=1.
1536 b2=1.
1537 b3=1.
1538 sum=1.
1539 do while (b2 .gt. crit)
1540 rn=rn+1.
1541 b2=xsd**2/(2.*rn-1.)
1542 b3=b1*b2
1543 sum=sum+b3
1544 b1=b3
1545 enddo
1546 GAUSIN=a1*a2*sum
1547 RETURN
1548 END FUNCTION GAUSIN
1550 !----------------------------------------------------------------------
1552 SUBROUTINE ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
1553 MYIS,MYIE,MYJS,MYJE, &
1554 IDS,IDE, JDS,JDE, KDS,KDE, &
1555 IMS,IME, JMS,JME, KMS,KME, &
1556 ITS,ITE, JTS,JTE, KTS,KTE )
1557 !----------------------------------------------------------------------
1558 IMPLICIT NONE
1559 !----------------------------------------------------------------------
1560 INTEGER, INTENT(IN) :: IDS,IDE, JDS,JDE, KDS,KDE , &
1561 IMS,IME, JMS,JME, KMS,KME , &
1562 ITS,ITE, JTS,JTE, KTS,KTE
1563 INTEGER, INTENT(IN) :: MYJS,MYJE,MYIS,MYIE
1565 REAL, INTENT(IN) :: TIMES
1566 REAL, INTENT(OUT) :: HOUR,DAYI
1567 INTEGER, INTENT(IN) :: IHRST
1569 INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
1570 REAL, INTENT(IN), DIMENSION(IMS:IME,JMS:JME) :: GLAT,GLON
1571 REAL, INTENT(OUT), DIMENSION(IMS:IME,JMS:JME) :: CZEN
1573 REAL, PARAMETER :: GSTC1=24110.54841,GSTC2=8640184.812866, &
1574 GSTC3=9.3104E-2,GSTC4=-6.2E-6, &
1575 PI=3.1415926,PI2=2.*PI,PIH=0.5*PI, &
1576 !#$ DEG2RD=1.745329E-2,OBLIQ=23.440*DEG2RD, &
1577 DEG2RD=3.1415926/180.,OBLIQ=23.440*DEG2RD, &
1578 ZEROJD=2451545.0
1580 REAL :: DAY,YFCTR,ADDDAY,STARTYR,DATJUL,DIFJD,SLONM, &
1581 ANOM,SLON,DEC,RA,DATJ0,TU,STIM0,SIDTIM,HRANG
1582 REAL :: HRLCL,SINALT
1583 INTEGER :: KMNTH,KNT,IDIFYR,J,I
1584 LOGICAL :: LEAP
1585 !-----------------------------------------------------------------------
1586 !-----------------------------------------------------------------------
1587 INTEGER :: MONTH (12)
1588 !-----------------------------------------------------------------------
1589 DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
1590 !***********************************************************************
1591 ! SAVE MONTH
1592 DAY=0.
1593 LEAP=.FALSE.
1594 IF(MOD(IDAT(3),4).EQ.0)THEN
1595 MONTH(2)=29
1596 LEAP=.TRUE.
1597 ENDIF
1598 IF(IDAT(1).GT.1)THEN
1599 KMNTH=IDAT(1)-1
1600 DO 10 KNT=1,KMNTH
1601 DAY=DAY+REAL(MONTH(KNT))
1602 10 CONTINUE
1603 ENDIF
1604 !***
1605 !*** CALCULATE EXACT NUMBER OF DAYS FROM BEGINNING OF YEAR TO
1606 !*** FORECAST TIME OF INTEREST
1607 !***
1608 DAY=DAY+REAL(IDAT(2)-1)+(REAL(IHRST)+TIMES/3600.)/24.
1609 DAYI=REAL(INT(DAY)+1)
1610 HOUR=(DAY-DAYI+1.)*24.
1611 YFCTR=2000.-IDAT(3)
1612 !-----------------------------------------------------------------------
1613 !***
1614 !*** FIND CELESTIAL LONGITUDE OF THE SUN THEN THE SOLAR DECLINATION AND
1615 !*** RIGHT ASCENSION.
1616 !***
1617 !-----------------------------------------------------------------------
1618 IDIFYR=IDAT(3)-2000
1619 !***
1620 !*** FIND JULIAN DATE OF START OF THE RELEVANT YEAR
1621 !*** ADDING IN LEAP DAYS AS NEEDED
1622 !***
1623 IF(IDIFYR.LT.0)THEN
1624 ADDDAY=REAL(IDIFYR/4)
1625 ELSE
1626 ADDDAY=REAL((IDIFYR+3)/4)
1627 ENDIF
1628 STARTYR=ZEROJD+IDIFYR*365.+ADDDAY-0.5
1629 !***
1630 !*** THE JULIAN DATE OF THE TIME IN QUESTION
1631 !***
1632 DATJUL=STARTYR+DAY
1633 !
1634 !*** DIFFERENCE OF ACTUAL JULIAN DATE FROM JULIAN DATE
1635 !*** AT 00H 1 January 2000
1636 !
1637 DIFJD=DATJUL-ZEROJD
1638 !
1639 !*** MEAN GEOMETRIC LONGITUDE OF THE SUN
1640 !
1641 SLONM=(280.460+0.9856474*DIFJD)*DEG2RD+YFCTR*PI2
1642 !
1643 !*** THE MEAN ANOMOLY
1644 !
1645 ANOM=(357.528+0.9856003*DIFJD)*DEG2RD
1646 !
1647 !*** APPARENT GEOMETRIC LONGITUDE OF THE SUN
1648 !
1649 SLON=SLONM+(1.915*SIN(ANOM)+0.020*SIN(2.*ANOM))*DEG2RD
1650 IF(SLON.GT.PI2)SLON=SLON-PI2
1651 !
1652 !*** DECLINATION AND RIGHT ASCENSION
1653 !
1654 DEC=ASIN(SIN(SLON)*SIN(OBLIQ))
1655 RA=ACOS(COS(SLON)/COS(DEC))
1656 IF(SLON.GT.PI)RA=PI2-RA
1657 !***
1658 !*** FIND THE GREENWICH SIDEREAL TIME THEN THE LOCAL SOLAR
1659 !*** HOUR ANGLE.
1660 !***
1661 DATJ0=STARTYR+DAYI-1.
1662 TU=(DATJ0-2451545.)/36525.
1663 STIM0=GSTC1+TU*(GSTC2+GSTC3*TU+GSTC4*TU*TU)
1664 SIDTIM=STIM0/3600.+YFCTR*24.+1.00273791*HOUR
1665 SIDTIM=SIDTIM*15.*DEG2RD
1666 IF(SIDTIM.LT.0.)SIDTIM=SIDTIM+PI2
1667 IF(SIDTIM.GT.PI2)SIDTIM=SIDTIM-PI2
1668 HRANG=SIDTIM-RA
1669 !
1670 DO 100 J=MYJS,MYJE
1671 DO 100 I=MYIS,MYIE
1672 ! HRLCL=HRANG-GLON(I,J)
1673 HRLCL=HRANG+GLON(I,J)+PI2
1674 !***
1675 !*** THE ZENITH ANGLE IS THE COMPLEMENT OF THE ALTITUDE THUS THE
1676 !*** COSINE OF THE ZENITH ANGLE EQUALS THE SINE OF THE ALTITUDE.
1677 !***
1678 SINALT=SIN(DEC)*SIN(GLAT(I,J))+COS(DEC)*COS(HRLCL)* &
1679 COS(GLAT(I,J))
1680 IF(SINALT.LT.0.)SINALT=0.
1681 CZEN(I,J)=SINALT
1682 100 CONTINUE
1683 !***
1684 !*** IF THE FORECAST IS IN A DIFFERENT YEAR THAN THE START TIME,
1685 !*** RESET DAYI TO THE PROPER DAY OF THE NEW YEAR (IT MUST NOT BE
1686 !*** RESET BEFORE THE SOLAR ZENITH ANGLE IS COMPUTED).
1687 !***
1688 IF(DAYI.GT.365.)THEN
1689 IF(.NOT.LEAP)THEN
1690 DAYI=DAYI-365.
1691 ELSEIF(LEAP.AND.DAYI.GT.366.)THEN
1692 DAYI=DAYI-366.
1693 ENDIF
1694 ENDIF
1695 !
1696 END SUBROUTINE ZENITH
1697 !-----------------------------------------------------------------------
1699 SUBROUTINE OZON2D (LK,POZN,XLAT,QO3, &
1700 MYIS,MYIE, &
1701 ids,ide, jds,jde, kds,kde, &
1702 ims,ime, jms,jme, kms,kme, &
1703 its,ite, jts,jte, kts,kte )
1704 !----------------------------------------------------------------------
1705 IMPLICIT NONE
1706 !----------------------------------------------------------------------
1707 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
1708 ims,ime, jms,jme, kms,kme , &
1709 its,ite, jts,jte, kts,kte
1710 INTEGER, INTENT(IN) :: LK,MYIS,MYIE
1711 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: POZN
1712 REAL, INTENT(IN), DIMENSION(its:ite) :: XLAT
1713 REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte) :: QO3
1714 !----------------------------------------------------------------------
1715 INTEGER, PARAMETER :: NL=81,NLP1=NL+1,LNGTH=37*NL
1717 ! REAL, INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N4,XDO3N2,XDO3N3
1718 ! REAL, INTENT(IN), DIMENSION(NL) :: PRGFDL
1719 !----------------------------------------------------------------------
1720 !----------------------------------------------------------------------
1721 INTEGER,DIMENSION(its:ite) :: JJROW
1722 REAL, DIMENSION(its:ite) :: TTHAN
1723 REAL, DIMENSION(its:ite,NL) :: QO3O3
1725 INTEGER :: I,K,NUMITR,ILOG,IT,NHALF
1726 REAL :: TH2,DO3V,DO3VP,APHI,APLO
1727 !----------------------------------------------------------------------
1728 DO I=MYIS,MYIE
1729 TH2=0.2*XLAT(I)
1730 JJROW(I)=19.001-TH2
1731 TTHAN(I)=(19-JJROW(I))-TH2
1732 ENDDO
1733 !
1734 !*** SEASONAL AND SPATIAL INTERPOLATION DONE BELOW.
1735 !
1736 DO K=1,NL
1737 DO I=MYIS,MYIE
1738 DO3V=XDUO3N(JJROW(I),K)+RSIN1*XDO3N2(JJROW(I),K) &
1739 +RCOS1*XDO3N3(JJROW(I),K) &
1740 +RCOS2*XDO3N4(JJROW(I),K)
1741 DO3VP=XDUO3N(JJROW(I)+1,K)+RSIN1*XDO3N2(JJROW(I)+1,K) &
1742 +RCOS1*XDO3N3(JJROW(I)+1,K) &
1743 +RCOS2*XDO3N4(JJROW(I)+1,K)
1744 !
1745 !*** NOW LATITUDINAL INTERPOLATION
1746 !*** AND CONVERT O3 INTO MASS MIXING RATIO (ORIG DATA MPY BY 1.E4)
1747 !
1748 QO3O3(I,K)=1.E-4*(DO3V+TTHAN(I)*(DO3VP-DO3V))
1749 ENDDO
1750 ENDDO
1751 !***
1752 !*** VERTICAL INTERPOLATION FOR EACH GRIDPOINT (LINEAR IN LN P)
1753 !***
1754 NUMITR=0
1755 ILOG=NL
1756 20 CONTINUE
1757 ILOG=(ILOG+1)/2
1758 IF(ILOG.EQ.1)GO TO 25
1759 NUMITR=NUMITR+1
1760 GO TO 20
1761 25 CONTINUE
1762 !
1763 DO 60 K=1,LK
1764 !
1765 NHALF=(NL+1)/2
1766 DO I=MYIS,MYIE
1767 JJROW(I)=NHALF
1768 ENDDO
1769 !
1770 DO 40 IT=1,NUMITR
1771 NHALF=(NHALF+1)/2
1772 DO I=MYIS,MYIE
1773 IF(POZN(I,K).LT.PRGFDL(JJROW(I)-1))THEN
1774 JJROW(I)=JJROW(I)-NHALF
1775 ELSEIF(POZN(I,K).GE.PRGFDL(JJROW(I)))THEN
1776 JJROW(I)=JJROW(I)+NHALF
1777 ENDIF
1778 JJROW(I)=MIN(JJROW(I),NL)
1779 JJROW(I)=MAX(JJROW(I),2)
1780 ENDDO
1781 40 CONTINUE
1782 !
1783 DO 50 I=MYIS,MYIE
1784 IF(POZN(I,K).LT.PRGFDL(1))THEN
1785 QO3(I,K)=QO3O3(I,1)
1786 ELSE IF(POZN(I,K).GT.PRGFDL(NL))THEN
1787 QO3(I,K)=QO3O3(I,NL)
1788 ELSE
1789 APLO=ALOG(PRGFDL(JJROW(I)-1))
1790 APHI=ALOG(PRGFDL(JJROW(I)))
1791 QO3(I,K)=QO3O3(I,JJROW(I))+(ALOG(POZN(I,K))-APHI)/ &
1792 (APLO-APHI)* &
1793 (QO3O3(I,JJROW(I)-1)-QO3O3(I,JJROW(I)))
1794 ENDIF
1795 50 CONTINUE
1796 !
1797 60 CONTINUE
1799 END SUBROUTINE OZON2D
1800 !-----------------------------------------------------------------------
1802 ! SUBROUTINE ZERO2(ARRAY, &
1803 ! ids,ide, jds,jde, kds,kde, &
1804 ! ims,ime, jms,jme, kms,kme, &
1805 ! its,ite, jts,jte, kts,kte )
1806 !----------------------------------------------------------------------
1807 !IMPLICIT NONE
1808 !----------------------------------------------------------------------
1809 ! INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
1810 ! ims,ime, jms,jme, kms,kme , &
1811 ! its,ite, jts,jte, kts,kte
1812 ! REAL, INTENT(INOUT), DIMENSION(its:ite,jts:jte) :: ARRAY
1813 ! INTEGER :: I,J
1814 !----------------------------------------------------------------------
1815 ! DO J=jts,jte
1816 ! DO I=its,ite
1817 ! ARRAY(I,J)=0.
1818 ! ENDDO
1819 ! ENDDO
1821 ! END SUBROUTINE ZERO2
1823 !----------------------------------------------------------------
1825 SUBROUTINE O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, &
1826 ids,ide, jds,jde, kds,kde, &
1827 ims,ime, jms,jme, kms,kme, &
1828 its,ite, jts,jte, kts,kte )
1829 !----------------------------------------------------------------------
1830 IMPLICIT NONE
1831 !----------------------------------------------------------------------
1832 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
1833 ims,ime, jms,jme, kms,kme , &
1834 its,ite, jts,jte, kts,kte
1836 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
1837 ! . . . .
1838 ! SUBPROGRAM: O3INT COMPUTE ZONAL MEAN OZONE FOR ETA LYRS
1839 ! PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07
1840 ! MICHAEL BALDWIN ORG: W/NMC22 DATE: 92-06-08
1841 !
1842 ! ABSTRACT: THIS CODE WRITTEN AT GFDL...
1843 ! CALCULATES SEASONAL ZONAL MEAN OZONE,EVERY 5 DEG OF LATITUDE,
1844 ! FOR CURRENT MODEL VERTICAL COORDINATE. OUTPUT DATA IN G/G * 1.E4
1845 ! CODE IS CALLED ONLY ONCE.
1846 !
1847 ! PROGRAM HISTORY LOG:
1848 ! 84-01-01 FELS AND SCHWARZKOPF,GFDL.
1849 ! 89-07-07 K. CAMPANA - ADAPTED STAND-ALONE CODE FOR IN-LINE USE.
1850 ! 92-06-08 M. BALDWIN - UPDATE TO RUN IN ETA MODEL
1851 !
1852 ! USAGE: CALL O3INT(O3,SIGL) OLD
1853 ! INPUT ARGUMENT LIST:
1854 ! PHALF - MID LAYER PRESSURE (K=LM+1 IS MODEL SURFACE)
1855 ! OUTPUT ARGUMENT LIST:
1856 ! DDUO3N - ZONAL MEAN OZONE DATA IN ALL MODEL LAYERS (G/G*1.E4)
1857 ! DDO3N2 DIMENSIONED(L,N),WHERE L(=37) IS LATITUDE BETWEEN
1858 ! DDO3N3 N AND S POLES,N=NUM OF VERTICAL LYRS(K=1 IS TOP LYR)
1859 ! DDO3N4 AND SEASON-WIN,SPR,SUM,FALL.
1860 ! IN COMMON
1861 !
1862 ! OUTPUT FILES:
1863 ! OUTPUT - PRINT FILE.
1864 !
1865 ! ATTRIBUTES:
1866 ! LANGUAGE: FORTRAN 200.
1867 !
1868 !$$$
1869 !.... PROGRAM O3INT FROM DAN SCHWARZKOPF-GETS ZONAL MEAN O3
1870 !.. OUTPUT O3 IS WINTER,SPRING,SUMMER,FALL (NORTHERN HEMISPHERE)
1871 !-----------------------------------------------------------------------
1872 ! INCLUDE "parmeta"
1873 !-----------------------------------------------------------------------
1874 ! *********************************************************
1876 INTEGER :: N,NP,NP2,NM1
1878 ! PARAMETER (N=LM,NP=N+1,NP2=N+2,NM1=N-1)
1879 ! *********************************************************
1880 !-----------------------------------------------------------------------
1881 !***
1882 !*** SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN
1883 !*** CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE).
1884 !*** DEFINED AS 5 DEG LAT MEANS N.P.->S.P.
1885 !***
1886 REAL, INTENT(OUT), DIMENSION(37,kte):: DDUO3N,DDO3N2,DDO3N3,DDO3N4
1888 ! C O M M O N /SAVMEM/
1889 ! ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL.....
1890 ! 1 DDUO3N(37,LM), DDO3N2(37,LM), DDO3N3(37,LM), DDO3N4(37,LM)
1891 ! ..... K.CAMPANA OCTOBER 1988
1892 !CCC DIMENSION T41(NP2,2),O3O3(37,N,4)
1893 ! DIMENSION SIGL(N)
1894 ! *********************************************************
1895 REAL :: QI(82)
1896 REAL :: DDUO3(19,kts:kte),RO31(10,41),RO32(10,41),DUO3N(19,41)
1897 REAL :: TEMPN(19)
1898 REAL :: O3HI(10,25),O3LO1(10,16),O3LO2(10,16),O3LO3(10,16), &
1899 O3LO4(10,16)
1900 REAL :: O3HI1(10,16),O3HI2(10,9),PH1(45),PH2(37),P1(48),P2(33)
1901 REAL :: O35DEG(37,kts:kte)
1902 REAL :: RSTD(81),RO3(10,41),RO3M(10,40),RBAR(kts:kte),RDATA(81), &
1903 PHALF(kts:kte+1),P(81),PH(82)
1905 INTEGER :: NKK,NK,NKP,K,L,NCASE,ITAPE,IPLACE,NKMM,NKM,KI,KK,KQ,JJ,KEN
1906 REAL :: O3RD,O3TOT,O3DU
1908 EQUIVALENCE (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17))
1909 EQUIVALENCE (PH1(1),PH(1)),(PH2(1),PH(46))
1910 EQUIVALENCE (P1(1),P(1)),(P2(1),P(49))
1911 DATA PH1/ 0., &
1912 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, &
1913 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, &
1914 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, &
1915 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, &
1916 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, &
1917 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, &
1918 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, &
1919 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, &
1920 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, &
1921 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, &
1922 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
1923 DATA PH2/ &
1924 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, &
1925 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, &
1926 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, &
1927 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, &
1928 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, &
1929 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, &
1930 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, &
1931 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, &
1932 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, &
1933 0.1000000E+01/
1934 DATA P1/ &
1935 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, &
1936 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, &
1937 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, &
1938 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, &
1939 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, &
1940 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, &
1941 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, &
1942 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, &
1943 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, &
1944 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, &
1945 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, &
1946 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
1947 DATA P2/ &
1948 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, &
1949 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, &
1950 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, &
1951 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, &
1952 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, &
1953 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, &
1954 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, &
1955 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, &
1956 0.1000000E+01/
1957 DATA O3HI1/ &
1958 .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, &
1959 .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, &
1960 .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, &
1961 .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, &
1962 .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, &
1963 .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, &
1964 .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, &
1965 .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, &
1966 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, &
1967 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, &
1968 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, &
1969 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, &
1970 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, &
1971 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, &
1972 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, &
1973 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/
1974 DATA O3HI2/ &
1975 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, &
1976 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, &
1977 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, &
1978 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, &
1979 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, &
1980 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, &
1981 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
1982 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, &
1983 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
1984 DATA O3LO1/ &
1985 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, &
1986 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, &
1987 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, &
1988 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, &
1989 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, &
1990 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, &
1991 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, &
1992 .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, &
1993 .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, &
1994 .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, &
1995 .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, &
1996 .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, &
1997 .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, &
1998 .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, &
1999 .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, &
2000 .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
2001 DATA O3LO2/ &
2002 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, &
2003 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, &
2004 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, &
2005 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, &
2006 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, &
2007 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, &
2008 .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, &
2009 .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, &
2010 .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, &
2011 .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, &
2012 .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, &
2013 .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, &
2014 .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, &
2015 .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, &
2016 .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, &
2017 .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
2018 DATA O3LO3/ &
2019 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, &
2020 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, &
2021 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, &
2022 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, &
2023 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, &
2024 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, &
2025 .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, &
2026 .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, &
2027 .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, &
2028 .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, &
2029 .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, &
2030 .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, &
2031 .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, &
2032 .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, &
2033 .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, &
2034 .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
2035 DATA O3LO4/ &
2036 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, &
2037 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, &
2038 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, &
2039 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, &
2040 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, &
2041 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, &
2042 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, &
2043 .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, &
2044 .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, &
2045 .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, &
2046 .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, &
2047 .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, &
2048 .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, &
2049 .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, &
2050 .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, &
2051 .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/
2053 !!!!!
2054 ! PSS=101325.
2055 ! PDIF=PSS-PT
2056 !
2057 ! DO L=1,LM1
2058 ! PHALF(L+1)=AETA(L)*PDIF+PT
2059 ! ENDDO
2060 !
2061 ! PHALF(1)=0.
2062 ! PHALF(LP1)=PSS
2063 !!!!
2064 N=kte;NP=N+1;NP2=N+2;NM1=N-1
2066 NKK=41
2067 NK=81
2068 NKP=NK+1
2069 DO 24 K=1,NP
2070 ! 24 PHALF(K)=PHALF(K)*1.0E 03
2071 24 PHALF(K)=PHALF(K)*0.01*1.0E+03
2072 ! 24 PSTD(K)=PSTD(K+1)*1.0E 03
2073 DO 25 K=1,NK
2074 PH(K)=PH(K)*1013250.
2075 25 P(K)=P(K)*1013250.
2076 PH(NKP)=PH(NKP)*1013250.
2077 !KAC WRITE (6,3) PH
2078 !KAC WRITE (6,3) P
2079 ! WRITE (6,3) (PHALF(K),K=1,NP)
2080 ! WRITE (6,3) (PSTD(K),K=1,NP)
2081 !***LOAD ARRAYS RO31,RO32,AS IN DICKS PGM.
2082 DO 1010 K=1,25
2083 DO 1010 L=1,10
2084 RO31(L,K)=O3HI(L,K)
2085 RO32(L,K)=O3HI(L,K)
2086 1010 CONTINUE
2087 !
2088 DO 3000 NCASE=1,4
2089 ITAPE=NCASE+50
2090 IPLACE=2
2091 IF (NCASE.EQ.2) IPLACE=4
2092 IF (NCASE.EQ.3) IPLACE=1
2093 IF (NCASE.EQ.4) IPLACE=3
2094 !***NCASE=1: SPRING (IN N.H.)
2095 !***NCASE=2: FALL (IN N.H.)
2096 !***NCASE=3: WINTER (IN N.H.)
2097 !***NCASE=4: SUMMER (IN N.H.)
2098 IF (NCASE.EQ.1.OR.NCASE.EQ.2) THEN
2099 DO 1011 K=26,41
2100 DO 1011 L=1,10
2101 RO31(L,K)=O3LO1(L,K-25)
2102 RO32(L,K)=O3LO2(L,K-25)
2103 1011 CONTINUE
2104 ENDIF
2105 IF (NCASE.EQ.3.OR.NCASE.EQ.4) THEN
2106 DO 1031 K=26,41
2107 DO 1031 L=1,10
2108 RO31(L,K)=O3LO3(L,K-25)
2109 RO32(L,K)=O3LO4(L,K-25)
2110 1031 CONTINUE
2111 ENDIF
2112 DO 30 KK=1,NKK
2113 DO 31 L=1,10
2114 DUO3N(L,KK)=RO31(11-L,KK)
2115 31 DUO3N(L+9,KK)=RO32(L,KK)
2116 DUO3N(10,KK)=.5*(RO31(1,KK)+RO32(1,KK))
2117 30 CONTINUE
2118 !***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON
2119 IF (NCASE.EQ.2.OR.NCASE.EQ.4) THEN
2120 DO 1024 KK=1,NKK
2121 DO 1025 L=1,19
2122 TEMPN(L)=DUO3N(20-L,KK)
2123 1025 CONTINUE
2124 DO 1026 L=1,19
2125 DUO3N(L,KK)=TEMPN(L)
2126 1026 CONTINUE
2127 1024 CONTINUE
2128 ENDIF
2129 !***DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON,AT STD. PRESSURE
2130 ! LEVELS
2131 !KAC WRITE (6,800) DUO3N
2132 !***BEGIN LATITUDE (10 DEG) LOOP
2133 DO 33 L=1,19
2134 DO 22 KK=1,NKK
2135 22 RSTD(KK)=DUO3N(L,KK)
2136 NKM=NK-1
2137 NKMM=NK-3
2138 ! BESSELS HALF-POINT INTERPOLATION FORMULA
2139 DO 60 K=4,NKMM,2
2140 KI=K/2
2141 60 RDATA(K)=.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1)-RSTD(KI)+ &
2142 RSTD(KI-1))/16.
2143 RDATA(2)=.5*(RSTD(2)+RSTD(1))
2144 RDATA(NKM)=.5*(RSTD(NKK)+RSTD(NKK-1))
2145 ! PUT UNCHANGED DATA INTO NEW ARRAY
2146 DO 61 K=1,NK,2
2147 KQ=(K+1)/2
2148 61 RDATA(K)=RSTD(KQ)
2149 !---NOTE TO NMC: THIS WRITE IS COMMENTED OUT TO REDUCE PRINTOUT
2150 ! WRITE (6,798) RDATA
2151 ! CALCULATE LAYER-MEAN OZONE MIXING RATIO FOR EACH MODEL LEVEL
2152 DO 99 KK=1,N
2153 RBAR(KK)=0.
2154 ! LOOP TO CALCULATE SUMS TO GET LAYER OZONE MEAN
2155 DO 98 K=1,NK
2156 IF(PH(K+1).LT.PHALF(KK)) GO TO 98
2157 IF(PH(K).GT.PHALF(KK+1)) GO TO 98
2158 IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).LT.PHALF(KK)) RBAR(KK)=RBAR(KK &
2159 )+RDATA(K)*(PH(K+1)-PHALF(KK))
2160 IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).GE.PHALF(KK)) RBAR(KK)=RBAR(KK &
2161 )+RDATA(K)*(PH(K+1)-PH(K))
2162 IF(PH(K+1).GT.PHALF(KK+1).AND.PH(K).GT.PHALF(KK)) RBAR(KK)=RBAR(KK &
2163 )+RDATA(K)*(PHALF(KK+1)-PH(K))
2164 98 CONTINUE
2165 RBAR(KK)=RBAR(KK)/(PHALF(KK+1)-PHALF(KK))
2166 IF(RBAR(KK).GT..0000) GO TO 99
2167 ! CODE TO COVER CASE WHEN MODEL RESOLUTION IS SO FINE THAT NO VALUE
2168 ! OF P(K) IN THE OZONE DATA ARRAY FALLS BETWEEN PHALF(KK+1) AND
2169 ! PHALF(KK). PROCEDURE IS TO SIMPLY GRAB THE NEAREST VALUE FROM
2170 ! RDATA
2171 DO 29 K=1,NK
2172 IF(PH(K).LT.PHALF(KK).AND.PH(K+1).GE.PHALF(KK+1)) RBAR(KK)=RDATA(K)
2173 29 CONTINUE
2174 99 CONTINUE
2175 ! CALCULATE TOTAL OZONE
2176 O3RD=0.
2177 DO 89 KK=1,80
2178 89 O3RD=O3RD+RDATA(KK)*(PH(KK+1)-PH(KK))
2179 O3RD=O3RD+RDATA(81)*(P(81)-PH(81))
2180 O3RD=O3RD/980.
2181 O3TOT=0.
2182 DO 88 KK=1,N
2183 88 O3TOT=O3TOT+RBAR(KK)*(PHALF(KK+1)-PHALF(KK))
2184 O3TOT=O3TOT/980.
2185 ! UNITS ARE MICROGRAMS/CM**2
2186 O3DU=O3TOT/2.144
2187 ! O3DU UNITS ARE DOBSON UNITS (10**-3 ATM-CM)
2188 !--NOTE TO NMC: THIS IS COMMENTED OUT TO SAVE PRINTOUT
2189 ! WRITE (6,796) O3RD,O3TOT,O3DU
2190 DO 23 KK=1,N
2191 23 DDUO3(L,KK)=RBAR(KK)*.01
2192 33 CONTINUE
2193 !***END OF LATITUDE LOOP
2194 !
2195 !***CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF
2196 ! 10 DEG VALUES
2197 DO 1060 KK=1,N
2198 DO 1061 L=1,19
2199 O35DEG(2*L-1,KK)=DDUO3(L,KK)
2200 1061 CONTINUE
2201 DO 1062 L=1,18
2202 O35DEG(2*L,KK)=0.5*(DDUO3(L,KK)+DDUO3(L+1,KK))
2203 1062 CONTINUE
2204 1060 CONTINUE
2205 !***OUTPUT TO UNIT (ITAPE) THE OZONE VALUES FOR LATER USE
2206 !O222 ***************************************************
2207 !C WRITE (66) O35DEG
2208 IF (IPLACE.EQ.1) THEN
2209 DO 302 JJ=1,37
2210 DO 302 KEN=1,N
2211 DDUO3N(JJ,KEN) = O35DEG(JJ,KEN)
2212 302 CONTINUE
2213 ELSE IF (IPLACE.EQ.2) THEN
2214 DO 312 JJ=1,37
2215 DO 312 KEN=1,N
2216 DDO3N2(JJ,KEN) = O35DEG(JJ,KEN)
2217 312 CONTINUE
2218 ELSE IF (IPLACE.EQ.3) THEN
2219 DO 322 JJ=1,37
2220 DO 322 KEN=1,N
2221 DDO3N3(JJ,KEN) = O35DEG(JJ,KEN)
2222 322 CONTINUE
2223 ELSE IF (IPLACE.EQ.4) THEN
2224 DO 332 JJ=1,37
2225 DO 332 KEN=1,N
2226 DDO3N4(JJ,KEN) = O35DEG(JJ,KEN)
2227 332 CONTINUE
2228 END IF
2229 !O222 ***************************************************
2230 3000 CONTINUE
2231 !***END OF LOOP OVER CASES
2232 RETURN
2233 1 FORMAT(10F4.2)
2234 2 FORMAT(10X,E14.7,1X,E14.7,1X,E14.7,1X,E14.7,1X)
2235 3 FORMAT(10E12.5)
2236 797 FORMAT(10F7.2)
2237 799 FORMAT(19F6.4)
2238 800 FORMAT(19F6.2)
2239 102 FORMAT(' O3 IPLACE=',I4)
2240 1033 FORMAT(19F6.5)
2241 101 FORMAT(5X,1H*,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5, &
2242 1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,)
2244 END SUBROUTINE O3INT
2245 !----------------------------------------------------------------
2247 SUBROUTINE CLO89(CLDFAC,CAMT,NCLDS,KBTM,KTOP &
2248 , ids,ide, jds,jde, kds,kde &
2249 , ims,ime, jms,jme, kms,kme &
2250 , its,ite, jts,jte, kts,kte )
2251 !----------------------------------------------------------------------
2252 IMPLICIT NONE
2253 !----------------------------------------------------------------------
2254 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
2255 ims,ime, jms,jme, kms,kme , &
2256 its,ite, jts,jte, kts,kte
2257 !----------------------------------------------------------------------
2259 ! ************************************************************
2260 ! * *
2261 ! * THIS SUBROUTINE WAS MODIFIED TO BE USED IN THE ETA MODEL *
2262 ! * *
2263 ! * Q. ZHAO 95-3-22 *
2264 ! * *
2265 ! ************************************************************
2267 REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2268 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT
2269 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2270 INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS
2272 REAL, DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT
2273 REAL, DIMENSION(kts:kte+1) :: CLDROW
2274 INTEGER:: IQ,ITOP,I,J,JTOP,IR,IP,K1,K2,KB,K,KP,KT,NC
2275 REAL :: XCLD
2277 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE
2279 ! DIMENSION CLDIPT(LP1,LP1, 64 )
2280 ! DIMENSION NCLDS(IDIM1:IDIM2),KTOP(IDIM1:IDIM2,LP1), &
2281 ! KBTM(IDIM1:IDIM2,LP1)
2282 ! DIMENSION CLDROW(LP1)
2283 ! DIMENSION CAMT(IDIM1:IDIM2,LP1),CLDFAC(IDIM1:IDIM2,LP1,LP1)
2285 L=kte
2286 LP1=L+1; LP2=L+2; LP3=L+3
2287 LM1=L-1; LM2=L-2; LM3=L-3
2288 MYIS=its; MYIE=ite
2290 !
2291 DO 1 IQ=MYIS,MYIE,64
2292 ITOP=IQ+63
2293 IF(ITOP.GT.MYIE) ITOP=MYIE
2294 JTOP=ITOP-IQ+1
2295 DO 11 IP=1,JTOP
2296 IR=IQ+IP-1
2297 IF (NCLDS(IR).EQ.0) THEN
2298 DO 25 J=1,LP1
2299 DO 25 I=1,LP1
2300 CLDIPT(I,J,IP)=1.
2301 25 CONTINUE
2302 ENDIF
2303 IF (NCLDS(IR).GE.1) THEN
2304 XCLD=1.-CAMT(IR,2)
2305 K1=KTOP(IR,2)+1
2306 K2=KBTM(IR,2)
2307 DO 27 J=1,LP1
2308 CLDROW(J)=1.
2309 27 CONTINUE
2310 DO 29 J=1,K2
2311 CLDROW(J)=XCLD
2312 29 CONTINUE
2313 KB=MAX(K1,K2+1)
2314 DO 33 K=KB,LP1
2315 DO 33 KP=1,LP1
2316 CLDIPT(KP,K,IP)=CLDROW(KP)
2317 33 CONTINUE
2318 DO 37 J=1,LP1
2319 CLDROW(J)=1.
2320 37 CONTINUE
2321 DO 39 J=K1,LP1
2322 CLDROW(J)=XCLD
2323 39 CONTINUE
2324 KT=MIN(K1-1,K2)
2325 DO 43 K=1,KT
2326 DO 43 KP=1,LP1
2327 CLDIPT(KP,K,IP)=CLDROW(KP)
2328 43 CONTINUE
2329 IF(K2+1.LE.K1-1) THEN
2330 DO 31 J=K2+1,K1-1
2331 DO 31 I=1,LP1
2332 CLDIPT(I,J,IP)=1.
2333 31 CONTINUE
2334 ELSE IF(K1.LE.K2) THEN
2335 DO 32 J=K1,K2
2336 DO 32 I=1,LP1
2337 CLDIPT(I,J,IP)=XCLD
2338 32 CONTINUE
2339 ENDIF
2340 ENDIF
2342 IF (NCLDS(IR).GE.2) THEN
2343 DO 21 NC=2,NCLDS(IR)
2344 XCLD=1.-CAMT(IR,NC+1)
2345 K1=KTOP(IR,NC+1)+1
2346 K2=KBTM(IR,NC+1)
2347 DO 47 J=1,LP1
2348 CLDROW(J)=1.
2349 47 CONTINUE
2350 DO 49 J=1,K2
2351 CLDROW(J)=XCLD
2352 49 CONTINUE
2353 KB=MAX(K1,K2+1)
2354 DO 53 K=KB,LP1
2355 DO 53 KP=1,LP1
2356 CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP)
2357 53 CONTINUE
2358 DO 57 J=1,LP1
2359 CLDROW(J)=1.
2360 57 CONTINUE
2361 DO 59 J=K1,LP1
2362 CLDROW(J)=XCLD
2363 59 CONTINUE
2364 KT=MIN(K1-1,K2)
2365 DO 63 K=1,KT
2366 DO 63 KP=1,LP1
2367 CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP)
2368 63 CONTINUE
2369 IF(K1.LE.K2) THEN
2370 DO 52 J=K1,K2
2371 DO 52 I=1,LP1
2372 CLDIPT(I,J,IP)=CLDIPT(I,J,IP)*XCLD
2373 52 CONTINUE
2374 ENDIF
2375 21 CONTINUE
2376 ENDIF
2377 11 CONTINUE
2378 DO 71 J=1,LP1
2379 DO 71 I=1,LP1
2380 DO 71 IP=1,JTOP
2381 IR=IQ+IP-1
2382 CLDFAC(IR,I,J)=CLDIPT(I,J,IP)
2383 71 CONTINUE
2384 1 CONTINUE
2386 END SUBROUTINE CLO89
2387 !----------------------------------------------------------------
2388 ! SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, &
2389 ! PRESS,TEMP,RH2O,QO3,CLDFAC, &
2390 ! CAMT,NCLDS,KTOP,KBTM, &
2391 !! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
2392 ! BO3RND,AO3RND, &
2393 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2394 ! ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
2395 ! GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
2396 ! P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
2397 ! TEN,HP1,FOUR,HM1EZ,SKO3R, &
2398 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
2399 ! HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
2400 ! RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, &
2401 ! ids,ide, jds,jde, kds,kde, &
2402 ! ims,ime, jms,jme, kms,kme, &
2403 ! its,ite, jts,jte, kts,kte )
2405 SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, &
2406 PRESS,TEMP,RH2O,QO3,CLDFAC, &
2407 CAMT,NCLDS,KTOP,KBTM, &
2408 ! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
2409 BO3RND,AO3RND, &
2410 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2411 ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
2412 GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
2413 P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
2414 TEN,HP1,FOUR,HM1EZ, &
2415 RADCON,QUARTR,TWO, &
2416 HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
2417 RADCON1,H16E1, H28E1,H44194M2,H1P41819, &
2418 ids,ide, jds,jde, kds,kde, &
2419 ims,ime, jms,jme, kms,kme, &
2420 its,ite, jts,jte, kts,kte )
2421 !---------------------------------------------------------------------
2422 IMPLICIT NONE
2423 !----------------------------------------------------------------------
2424 ! INTEGER, PARAMETER :: NBLY=15
2426 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
2427 ims,ime, jms,jme, kms,kme , &
2428 its,ite, jts,jte, kts,kte
2429 REAL, INTENT(IN) :: ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR
2430 REAL, INTENT(IN) :: GINV,H3M4,BETINW,RATH2OMW,GP0INV
2431 REAL, INTENT(IN) :: P0XZP8,P0XZP2,H3M3,P0,H1M3
2432 REAL, INTENT(IN) :: H1M2,H25E2,B0,B1,B2,B3,HAF
2433 ! REAL, INTENT(IN) :: TEN,HP1,FOUR,HM1EZ,SKO3R
2434 REAL, INTENT(IN) :: TEN,HP1,FOUR,HM1EZ
2435 ! REAL, INTENT(IN) :: AB15WD,SKC1R,RADCON,QUARTR,TWO
2436 REAL, INTENT(IN) :: RADCON,QUARTR,TWO
2437 REAL, INTENT(IN) :: HM6666M2,HMP66667,HMP5, HP166666,H41666M2
2438 ! REAL, INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D
2439 REAL, INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819
2440 !----------------------------------------------------------------------
2441 REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND
2442 ! REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW
2443 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
2444 REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
2445 BCOMB,BETACM
2447 REAL, INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2448 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT
2449 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2450 INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS
2452 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
2453 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: RH2O,QO3
2454 REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte) :: HEATRA
2455 REAL, INTENT(OUT), DIMENSION(its:ite) :: GRNFLX,TOPFLX
2457 ! REAL, DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT
2459 ! Include co2 data from a file, which needs to have exactly vertical
2460 ! dimension of the model.
2463 !!! ??? co2 table
2464 ! REAL, DIMENSION(kts:kte+1,kts:kte+1) :: CO251,CDT51,CDT58,C2D51,&
2465 ! C2D58,CO258
2466 ! REAL, DIMENSION(kts:kte+1) :: STEMP,GTEMP,CO231,CO238, &
2467 ! C2D31,C2D38,CDT31,CDT38, &
2468 ! CO271,CO278,C2D71,C2D78, &
2469 ! CDT71,CDT78
2470 ! REAL, DIMENSION(kts:kte) :: CO2M51,CO2M58,CDTM51,CDTM58, &
2471 ! C2DM51,C2DM58
2472 !!! end co2 table
2474 ! REAL, DIMENSION(kts:kte+1) :: CLDROW
2476 REAL, DIMENSION(its:ite,kts:kte+1) :: TEXPSL,TOTPHI,TOTO3,CNTVAL,&
2477 TPHIO3,TOTVO2,TSTDAV,TDAV, &
2478 VSUM3,CO2R1,D2CD21,DCO2D1, &
2479 CO2R2,D2CD22,DCO2D2,CO2SP1,&
2480 CO2SP2,CO2R,DCO2DT,D2CDT2, &
2481 TLSQU,DIFT
2482 REAL, DIMENSION(its:ite,kts:kte) :: DELP2,DELP,CO2NBL,&
2483 QH2O,VV,VAR1,VAR2,VAR3,VAR4
2484 REAL, DIMENSION(its:ite,kts:kte+1) :: P,T
2485 REAL, DIMENSION(its:ite,kts:kte) :: CO2MR,CO2MD,CO2M2D
2486 REAL, DIMENSION(its:ite,kts:kte*2+1):: EMPL
2488 REAL, DIMENSION(its:ite) :: EMX1,EMX2,VSUM1,VSUM2,A1,A2
2489 REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21
2491 ! COMMON/CO2BD3/CO251(LP1,LP1),CO258(LP1,LP1),CDT51(LP1,LP1),
2492 ! DIMENSION CO21(IDIM1:IDIM2,LP1,LP1),CO2NBL(IDIM1:IDIM2,L)
2493 ! DIMENSION CO2R(IDIM1:IDIM2,LP1),DIFT(IDIM1:IDIM2,LP1)
2494 ! 1 CO2M2D(IDIM1:IDIM2,L)
2495 ! DIMENSION CO2MR(IDIM1:IDIM2,L),CO2MD(IDIM1:IDIM2,L),
2496 ! 2 CO2M58(L),CDTM51(L),CDTM58(L),C2DM51(L),C2DM58(L),
2497 ! 1 CDT58(LP1,LP1),C2D51(LP1,LP1),C2D58(LP1,LP1),CO2M51(L),
2498 ! COMMON / CO2BD2 / CO231(LP1),CO238(LP1),CDT31(LP1),
2499 ! 1 CDT38(LP1),C2D31(LP1),C2D38(LP1)
2500 ! DIMENSION CO2R1(IDIM1:IDIM2,LP1),DCO2D1(IDIM1:IDIM2,LP1)
2501 ! DIMENSION D2CD21(IDIM1:IDIM2,LP1),D2CD22(IDIM1:IDIM2,LP1)
2502 ! 3 STEMP(LP1),GTEMP(LP1),B0,B1,B2,B3
2503 ! 1 VV(IDIM1:IDIM2,L),VSUM3(IDIM1:IDIM2,LP1),VSUM1(IDIM1:IDIM2),
2504 ! 2 VSUM2(IDIM1:IDIM2)
2505 ! DIMENSION TDAV(IDIM1:IDIM2,LP1),TSTDAV(IDIM1:IDIM2,LP1),
2506 ! LLP1=LL+1, LL = 2L
2507 ! EMX2(IDIM1:IDIM2),EMPL(IDIM1:IDIM2,LLP1)
2508 ! DIMENSION TPHIO3(IDIM1:IDIM2,LP1),
2509 ! DIMENSION TEXPSL(IDIM1:IDIM2,LP1)
2510 ! DIMENSION QH2O(IDIM1:IDIM2,L)
2511 ! DIMENSION DELP2(IDIM1:IDIM2,L)
2512 ! DIMENSION VAR1(IDIM1:IDIM2,L),VAR2(IDIM1:IDIM2,L),
2513 ! 1 VAR3(IDIM1:IDIM2,L),VAR4(IDIM1:IDIM2,L)
2514 ! 1 VV(IDIM1:IDIM2,L)
2515 ! DIMENSION CNTVAL(IDIM1:IDIM2,LP1)
2516 ! DIMENSION TOTO3(IDIM1:IDIM2,LP1)
2517 ! DIMENSION EMX1(IDIM1:IDIM2),
2519 ! DIMENSION PRESS(IDIM1:IDIM2,LP1),TEMP(IDIM1:IDIM2,LP1), &
2520 ! RH2O(IDIM1:IDIM2,L),QO3(IDIM1:IDIM2,L)
2521 ! DIMENSION HEATRA(IDIM1:IDIM2,L),GRNFLX(IDIM1:IDIM2), &
2522 ! TOPFLX(IDIM1:IDIM2)
2524 !
2525 !
2526 !****COMPUTE FLUX PRESSURES (P) AND DIFFERENCES (DELP2,DELP)
2527 !****COMPUTE FLUX LEVEL TEMPERATURES (T) AND CONTINUUM TEMPERATURE
2528 ! CORRECTIONS (TEXPSL)
2530 INTEGER :: K, I,KP
2531 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL
2533 L=kte
2534 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
2535 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
2536 MYIS=its; MYIE=ite
2539 DO 103 K=2,L
2540 DO 103 I=MYIS,MYIE
2541 P(I,K)=HAF*(PRESS(I,K-1)+PRESS(I,K))
2542 T(I,K)=HAF*(TEMP(I,K-1)+TEMP(I,K))
2543 103 CONTINUE
2544 DO 105 I=MYIS,MYIE
2545 P(I,1)=ZERO
2546 P(I,LP1)=PRESS(I,LP1)
2547 T(I,1)=TEMP(I,1)
2548 T(I,LP1)=TEMP(I,LP1)
2549 105 CONTINUE
2550 DO 107 K=1,L
2551 DO 107 I=MYIS,MYIE
2552 DELP2(I,K)=P(I,K+1)-P(I,K)
2553 DELP(I,K)=ONE/DELP2(I,K)
2554 107 CONTINUE
2555 !****COMPUTE ARGUMENT FOR CONT.TEMP.COEFF.
2556 ! (THIS IS 1800.(1./TEMP-1./296.))
2557 DO 125 K=1,LP1
2558 DO 125 I=MYIS,MYIE
2559 TEXPSL(I,K)=H18E3/TEMP(I,K)-H6P08108
2560 !...THEN TAKE EXPONENTIAL
2561 TEXPSL(I,K)=EXP(TEXPSL(I,K))
2562 125 CONTINUE
2563 !***COMPUTE OPTICAL PATHS FOR H2O AND O3, USING THE DIFFUSIVITY
2564 ! APPROXIMATION FOR THE ANGULAR INTEGRATION (1.66). OBTAIN THE
2565 ! UNWEIGHTED VALUES(VAR1,VAR3) AND THE WEIGHTED VALUES(VAR2,VAR4).
2566 ! THE QUANTITIES H3M4(.0003) AND H3M3(.003) APPEARING IN THE VAR2 AND
2567 ! VAR4 EXPRESSIONS ARE THE APPROXIMATE VOIGT CORRECTIONS FOR H2O AND
2568 ! O3,RESPECTIVELY.
2569 !
2570 DO 131 K=1,L
2571 DO 131 I=MYIS,MYIE
2572 QH2O(I,K)=RH2O(I,K)*DIFFCTR
2573 !---VV IS THE LAYER-MEAN PRESSURE (IN ATM),WHICH IS NOT THE SAME AS
2574 ! THE LEVEL PRESSURE (PRESS)
2575 VV(I,K)=HAF*(P(I,K+1)+P(I,K))*P0INV
2576 VAR1(I,K)=DELP2(I,K)*QH2O(I,K)*GINV
2577 VAR3(I,K)=DELP2(I,K)*QO3(I,K)*DIFFCTR*GINV
2578 VAR2(I,K)=VAR1(I,K)*(VV(I,K)+H3M4)
2579 VAR4(I,K)=VAR3(I,K)*(VV(I,K)+H3M3)
2580 ! COMPUTE OPTICAL PATH FOR THE H2O CONTINUUM, USING ROBERTS COEFFS.
2581 ! (BETINW),AND TEMP. CORRECTION (TEXPSL). THE DIFFUSIVITY FACTOR
2582 ! (WHICH CANCELS OUT IN THIS EXPRESSION) IS ASSUMED TO BE 1.66. THE
2583 ! USE OF THE DIFFUSIVITY FACTOR HAS BEEN SHOWN TO BE A SIGNIFICANT
2584 ! SOURCE OF ERROR IN THE CONTINUUM CALCS.,BUT THE TIME PENALTY OF
2585 ! AN ANGULAR INTEGRATION IS SEVERE.
2586 !
2587 CNTVAL(I,K)=TEXPSL(I,K)*RH2O(I,K)*VAR2(I,K)*BETINW/ &
2588 (RH2O(I,K)+RATH2OMW)
2589 131 CONTINUE
2590 ! COMPUTE SUMMED OPTICAL PATHS FOR H2O,O3 AND CONTINUUM
2591 DO 201 I=MYIS,MYIE
2592 TOTPHI(I,1)=ZERO
2593 TOTO3(I,1)=ZERO
2594 TPHIO3(I,1)=ZERO
2595 TOTVO2(I,1)=ZERO
2596 201 CONTINUE
2597 DO 203 K=2,LP1
2598 DO 203 I=MYIS,MYIE
2599 TOTPHI(I,K)=TOTPHI(I,K-1)+VAR2(I,K-1)
2600 TOTO3(I,K)=TOTO3(I,K-1)+VAR3(I,K-1)
2601 TPHIO3(I,K)=TPHIO3(I,K-1)+VAR4(I,K-1)
2602 TOTVO2(I,K)=TOTVO2(I,K-1)+CNTVAL(I,K-1)
2603 203 CONTINUE
2604 !---EMX1 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO
2605 ! P(L). IT IS USED IN NEARBY LAYER AND EMISS CALCULATIONS.
2606 !---EMX2 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO
2607 ! P(LP1). IT IS USED IN CALCULATIONS BETWEEN FLUX LEVELS L AND LP1.
2608 !
2609 DO 801 I=MYIS,MYIE
2610 EMX1(I)=QH2O(I,L)*PRESS(I,L)*(PRESS(I,L)-P(I,L))*GP0INV
2611 EMX2(I)=QH2O(I,L)*PRESS(I,L)*(P(I,LP1)-PRESS(I,L))*GP0INV
2612 801 CONTINUE
2613 !---EMPL IS THE PRESSURE SCALED MASS FROM P(K) TO PRESS(K) (INDEX 2-LP1)
2614 ! OR TO PRESS(K+1) (INDEX LP2-LL)
2615 DO 811 K=1,L
2616 DO 811 I=MYIS,MYIE
2617 EMPL(I,K+1)=QH2O(I,K)*P(I,K+1)*(P(I,K+1)-PRESS(I,K))*GP0INV
2618 811 CONTINUE
2619 DO 812 K=1,LM1
2620 DO 812 I=MYIS,MYIE
2621 EMPL(I,LP2+K-1)=QH2O(I,K+1)*P(I,K+1)*(PRESS(I,K+1)-P(I,K+1)) &
2622 *GP0INV
2623 812 CONTINUE
2624 DO 821 I=MYIS,MYIE
2625 EMPL(I,1)=VAR2(I,L)
2626 EMPL(I,LLP1)=EMPL(I,LL)
2627 821 CONTINUE
2628 !***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS
2629 ! FOR USE IN OBTAINING TEMP. DIFFERENCE BET. SOUNDING AND STD.
2630 ! TEMP. SOUNDING (DIFT)
2631 DO 161 I=MYIS,MYIE
2632 TSTDAV(I,1)=ZERO
2633 TDAV(I,1)=ZERO
2634 161 CONTINUE
2635 DO 162 K=1,LP1
2636 DO 162 I=MYIS,MYIE
2637 VSUM3(I,K)=TEMP(I,K)-STEMP(K)
2638 162 CONTINUE
2639 DO 163 K=1,L
2640 DO 165 I=MYIS,MYIE
2641 VSUM2(I)=GTEMP(K)*DELP2(I,K)
2642 VSUM1(I)=VSUM2(I)*VSUM3(I,K)
2643 TSTDAV(I,K+1)=TSTDAV(I,K)+VSUM2(I)
2644 TDAV(I,K+1)=TDAV(I,K)+VSUM1(I)
2645 165 CONTINUE
2646 163 CONTINUE
2647 !
2648 !****EVALUATE COEFFICIENTS FOR CO2 PRESSURE INTERPOLATION (A1,A2)
2649 DO 171 I=MYIS,MYIE
2650 A1(I)=(PRESS(I,LP1)-P0XZP8)/P0XZP2
2651 A2(I)=(P0-PRESS(I,LP1))/P0XZP2
2652 171 CONTINUE
2653 !***PERFORM CO2 PRESSURE INTERPOLATION ON ALL INPUTTED TRANSMISSION
2654 ! FUNCTIONS AND TEMP. DERIVATIVES
2655 !---SUCCESSIVELY COMPUTING CO2R,DCO2DT AND D2CDT2 IS DONE TO SAVE
2656 ! STORAGE (AT A SLIGHT LOSS IN COMPUTATION TIME)
2657 DO 184 K=1,LP1
2658 DO 184 I=MYIS,MYIE
2659 CO2R1(I,K)=A1(I)*CO231(K)+A2(I)*CO238(K)
2660 D2CD21(I,K)=H1M3*(A1(I)*C2D31(K)+A2(I)*C2D38(K))
2661 DCO2D1(I,K)=H1M2*(A1(I)*CDT31(K)+A2(I)*CDT38(K))
2662 CO2R2(I,K)=A1(I)*CO271(K)+A2(I)*CO278(K)
2663 D2CD22(I,K)=H1M3*(A1(I)*C2D71(K)+A2(I)*C2D78(K))
2664 DCO2D2(I,K)=H1M2*(A1(I)*CDT71(K)+A2(I)*CDT78(K))
2665 184 CONTINUE
2666 DO 190 K=1,L
2667 DO 190 I=MYIS,MYIE
2668 CO2MR(I,K)=A1(I)*CO2M51(K)+A2(I)*CO2M58(K)
2669 CO2MD(I,K)=H1M2*(A1(I)*CDTM51(K)+A2(I)*CDTM58(K))
2670 CO2M2D(I,K)=H1M3*(A1(I)*C2DM51(K)+A2(I)*C2DM58(K))
2671 190 CONTINUE
2672 !***COMPUTE CO2 TEMPERATURE INTERPOLATIONS FOR ALL BANDS,USING DIFT
2673 !
2674 ! THE CASE WHERE K=1 IS HANDLED FIRST. WE ARE NOW REPLACING
2675 ! 3-DIMENSIONAL ARRAYS BY 2-D ARRAYS, TO SAVE SPACE. THUS THIS
2676 ! CALCULATION IS FOR (I,KP,1)
2677 DO 211 KP=2,LP1
2678 DO 211 I=MYIS,MYIE
2679 DIFT(I,KP)=TDAV(I,KP)/TSTDAV(I,KP)
2680 211 CONTINUE
2681 DO 212 I=MYIS,MYIE
2682 CO21(I,1,1)=1.0
2683 CO2SP1(I,1)=1.0
2684 CO2SP2(I,1)=1.0
2685 212 CONTINUE
2686 DO 215 KP=2,LP1
2687 DO 215 I=MYIS,MYIE
2688 !---CALCULATIONS FOR KP>1 FOR K=1
2689 CO2R(I,KP)=A1(I)*CO251(KP,1)+A2(I)*CO258(KP,1)
2690 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,1)+A2(I)*CDT58(KP,1))
2691 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,1)+A2(I)*C2D58(KP,1))
2692 CO21(I,KP,1)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2693 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2694 !---CALCULATIONS FOR (EFFECTIVELY) KP=1,K>KP. THESE USE THE
2695 ! SAME VALUE OF DIFT DUE TO SYMMETRY
2696 CO2R(I,KP)=A1(I)*CO251(1,KP)+A2(I)*CO258(1,KP)
2697 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(1,KP)+A2(I)*CDT58(1,KP))
2698 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(1,KP)+A2(I)*C2D58(1,KP))
2699 CO21(I,1,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2700 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2701 215 CONTINUE
2702 ! THE TRANSMISSION FUNCTIONS USED IN SPA88 MAY BE COMPUTED NOW.
2703 !---(IN THE 250 LOOP,DIFT REALLY SHOULD BE (I,1,K), BUT DIFT IS
2704 ! INVARIANT WITH RESPECT TO K,KP,AND SO (I,1,K)=(I,K,1))
2705 DO 250 K=2,LP1
2706 DO 250 I=MYIS,MYIE
2707 CO2SP1(I,K)=CO2R1(I,K)+DIFT(I,K)*(DCO2D1(I,K)+HAF*DIFT(I,K)* &
2708 D2CD21(I,K))
2709 CO2SP2(I,K)=CO2R2(I,K)+DIFT(I,K)*(DCO2D2(I,K)+HAF*DIFT(I,K)* &
2710 D2CD22(I,K))
2711 250 CONTINUE
2712 !
2713 ! NEXT THE CASE WHEN K=2...L
2714 DO 220 K=2,L
2715 DO 222 KP=K+1,LP1
2716 DO 222 I=MYIS,MYIE
2717 DIFT(I,KP)=(TDAV(I,KP)-TDAV(I,K))/ &
2718 (TSTDAV(I,KP)-TSTDAV(I,K))
2719 CO2R(I,KP)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K)
2720 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,K)+A2(I)*CDT58(KP,K))
2721 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,K)+A2(I)*C2D58(KP,K))
2722 CO21(I,KP,K)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2723 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2724 CO2R(I,KP)=A1(I)*CO251(K,KP)+A2(I)*CO258(K,KP)
2725 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(K,KP)+A2(I)*CDT58(K,KP))
2726 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(K,KP)+A2(I)*C2D58(K,KP))
2727 CO21(I,K,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2728 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2729 222 CONTINUE
2730 220 CONTINUE
2731 ! FINALLY THE CASE WHEN K=KP,K=2..LP1
2732 DO 206 K=2,LP1
2733 DO 206 I=MYIS,MYIE
2734 DIFT(I,K)=HAF*(VSUM3(I,K)+VSUM3(I,K-1))
2735 CO2R(I,K)=A1(I)*CO251(K,K)+A2(I)*CO258(K,K)
2736 DCO2DT(I,K)=H1M2*(A1(I)*CDT51(K,K)+A2(I)*CDT58(K,K))
2737 D2CDT2(I,K)=H1M3*(A1(I)*C2D51(K,K)+A2(I)*C2D58(K,K))
2738 CO21(I,K,K)=CO2R(I,K)+DIFT(I,K)*(DCO2DT(I,K)+ &
2739 HAF*DIFT(I,K)*D2CDT2(I,K))
2740 206 CONTINUE
2741 !--- WE AREN'T DOING NBL TFS ON THE 100 CM-1 BANDS .
2742 DO 260 K=1,L
2743 DO 260 I=MYIS,MYIE
2744 CO2NBL(I,K)=CO2MR(I,K)+VSUM3(I,K)*(CO2MD(I,K)+HAF* &
2745 VSUM3(I,K)*CO2M2D(I,K))
2746 260 CONTINUE
2747 !***COMPUTE TEMP. COEFFICIENT BASED ON T(K) (SEE REF.2)
2748 DO 264 K=1,LP1
2749 DO 264 I=MYIS,MYIE
2750 IF (T(I,K).LE.H25E2) THEN
2751 TLSQU(I,K)=B0+(T(I,K)-H25E2)* &
2752 (B1+(T(I,K)-H25E2)* &
2753 (B2+B3*(T(I,K)-H25E2)))
2754 ELSE
2755 TLSQU(I,K)=B0
2756 ENDIF
2757 264 CONTINUE
2758 !***APPLY TO ALL CO2 TFS
2759 DO 280 K=1,LP1
2760 DO 282 KP=1,LP1
2761 DO 282 I=MYIS,MYIE
2762 CO21(I,KP,K)=CO21(I,KP,K)*(ONE-TLSQU(I,KP))+TLSQU(I,KP)
2763 282 CONTINUE
2764 280 CONTINUE
2765 DO 284 K=1,LP1
2766 DO 286 I=MYIS,MYIE
2767 CO2SP1(I,K)=CO2SP1(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1)
2768 CO2SP2(I,K)=CO2SP2(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1)
2769 286 CONTINUE
2770 284 CONTINUE
2771 DO 288 K=1,L
2772 DO 290 I=MYIS,MYIE
2773 CO2NBL(I,K)=CO2NBL(I,K)*(ONE-TLSQU(I,K))+TLSQU(I,K)
2774 290 CONTINUE
2775 288 CONTINUE
2776 ! CALL FST88(HEATRA,GRNFLX,TOPFLX, &
2777 ! QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2778 ! CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2779 ! CO21,CO2NBL,CO2SP1,CO2SP2, &
2780 ! VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2781 ! TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2782 ! EMX1,EMX2,EMPL, &
2783 !
2784 ! BO3RND,AO3RND, &
2785 !! T1,T2,T4 , EM1V,EM1VW, EM3V, &
2786 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2787 ! TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, &
2788 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
2789 ! HM6666M2,HMP66667,HMP5, &
2790 ! HP166666,H41666M2,RADCON1, &
2791 ! H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2792 ! SKO2D, &
2793 ! ids,ide, jds,jde, kds,kde, &
2794 ! ims,ime, jms,jme, kms,kme, &
2795 ! its,ite, jts,jte, kts,kte )
2797 CALL FST88(HEATRA,GRNFLX,TOPFLX, &
2798 QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2799 CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2800 CO21,CO2NBL,CO2SP1,CO2SP2, &
2801 VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2802 TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2803 EMX1,EMX2,EMPL, &
2804 !
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 )
2817 END SUBROUTINE LWR88
2818 !---------------------------------------------------------------------
2819 ! SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, &
2820 ! QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2821 ! CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2822 ! CO21,CO2NBL,CO2SP1,CO2SP2, &
2823 ! VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2824 ! TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2825 ! EMX1,EMX2,EMPL, &
2826 ! BO3RND,AO3RND, &
2827 !! T1,T2,T4 , EM1V,EM1VW, EM3V, &
2828 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2829 ! TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, &
2830 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
2831 ! HM6666M2,HMP66667,HMP5, &
2832 ! HP166666,H41666M2,RADCON1, &
2833 ! H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2834 ! SKO2D, &
2835 ! ids,ide, jds,jde, kds,kde, &
2836 ! ims,ime, jms,jme, kms,kme, &
2837 ! its,ite, jts,jte, kts,kte )
2839 SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, &
2840 QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2841 CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2842 CO21,CO2NBL,CO2SP1,CO2SP2, &
2843 VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2844 TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2845 EMX1,EMX2,EMPL, &
2846 BO3RND,AO3RND, &
2847 ! T1,T2,T4 , EM1V,EM1VW, EM3V, &
2848 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2849 TEN,HP1,HAF,ONE,FOUR,HM1EZ, &
2850 RADCON,QUARTR,TWO, &
2851 HM6666M2,HMP66667,HMP5, &
2852 HP166666,H41666M2,RADCON1, &
2853 H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2854 ids,ide, jds,jde, kds,kde, &
2855 ims,ime, jms,jme, kms,kme, &
2856 its,ite, jts,jte, kts,kte )
2857 !---------------------------------------------------------------------
2858 IMPLICIT NONE
2859 !----------------------------------------------------------------------
2860 ! INTEGER, PARAMETER :: NBLY=15
2862 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
2863 ims,ime, jms,jme, kms,kme , &
2864 its,ite, jts,jte, kts,kte
2866 ! REAL, INTENT(IN) :: TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R
2867 REAL, INTENT(IN) :: TEN,HP1,HAF,ONE,FOUR,HM1EZ
2868 ! REAL, INTENT(IN) :: AB15WD,SKC1R,RADCON,QUARTR,TWO
2869 REAL, INTENT(IN) :: RADCON,QUARTR,TWO
2870 REAL, INTENT(IN) :: HM6666M2,HMP66667,HMP5
2871 REAL, INTENT(IN) :: HP166666,H41666M2,RADCON1,H16E1, H28E1
2872 ! REAL, INTENT(IN) :: H25E2,H44194M2,H1P41819,SKO2D
2873 REAL, INTENT(IN) :: H25E2,H44194M2,H1P41819
2875 REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
2876 BCOMB,BETACM
2878 ! REAL, INTENT(IN), DIMENSION(5040) :: T1,T2,T4,EM1V,EM1VW
2879 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
2880 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: EMPL
2881 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TOTO3,TPHIO3,TOTPHI,CNTVAL,&
2882 CO2SP1,CO2SP2
2884 REAL, INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2885 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT,TOTVO2
2886 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2887 INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS
2888 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: QH2O
2889 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
2890 REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte) :: HEATRA
2891 REAL, INTENT(OUT), DIMENSION(its:ite) :: GRNFLX,TOPFLX
2892 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: P,T
2893 REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21
2894 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: CO2NBL,DELP2, &
2895 DELP,&
2896 VAR1,VAR2,VAR3,VAR4
2897 REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND
2898 REAL, INTENT(IN), DIMENSION(its:ite) :: EMX1,EMX2
2900 REAL, DIMENSION(its:ite,kts:kte*2+1) :: TPL,EMD,ALP,C,CSUB,CSUB2
2901 REAL, DIMENSION(its:ite,kts:kte*2+1) :: C2
2902 INTEGER, DIMENSION(its:ite,kts:kte+1) :: IXO
2903 REAL, DIMENSION(its:ite,kts:kte+1) :: VTMP3,FXO,DT,FXOE2,DTE2, &
2904 SS1,CSOUR,TC,OSS,CSS,DTC,SS2,&
2905 AVEPHI,E1CTS1,E1FLX, &
2906 E1CTW1,DSORC,EMISS,FAC1,&
2907 TO3SP,OVER1D,CNTTAU,TOTEVV,&
2908 CO2SP,FLX,AVMO3, &
2909 AVPHO3,AVVO2,CONT1D,TO31D,EMISDG,&
2910 DELPR1
2911 REAL, DIMENSION(its:ite,kts:kte+1) :: EMISSB,DELPR2,CONTDG,TO3DG,HEATEM,&
2912 VSUM1,FLXNET,Z1
2914 REAL, DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC
2915 REAL, DIMENSION(its:ite,kts:kte) :: E1CTS2,E1CTW2,TO3SPC,RLOG,EXCTS,&
2916 CTSO3,CTS
2917 REAL, DIMENSION(its:ite) :: GXCTS,FLX1E1
2918 REAL, DIMENSION(its:ite) :: PTOP,PBOT,FTOP,FBOT,DELPTC
2919 REAL, DIMENSION(its:ite,2) :: FXOSP,DTSP,EMSPEC
2920 ! REAL, DIMENSION(28,NBLY) :: SOURCE,DSRCE
2921 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
2922 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
2924 L=kte
2925 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
2926 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
2927 LLM2 = LL-2; LLM1=LL-1
2928 MYIS=its; MYIE=ite
2930 !
2931 DO 101 K=1,LP1
2932 DO 101 I=MYIS,MYIE
2933 !---TEMP. INDICES FOR E1,SOURCE
2934 VTMP3(I,K)=AINT(TEMP(I,K)*HP1)
2935 FXO(I,K)=VTMP3(I,K)-9.
2936 DT(I,K)=TEMP(I,K)-TEN*VTMP3(I,K)
2937 !---INTEGER INDEX FOR SOURCE (USED IMMEDIATELY)
2938 IXO(I,K)=FXO(I,K)
2939 101 CONTINUE
2940 DO 103 k=1,L
2941 DO 103 I=MYIS,MYIE
2942 !---TEMP. INDICES FOR E2 (KP=1 LAYER NOT USED IN FLUX CALCULATIONS)
2943 VTMP3(I,K)=AINT(T(I,K+1)*HP1)
2944 FXOE2(I,K)=VTMP3(I,K)-9.
2945 DTE2(I,K)=T(I,K+1)-TEN*VTMP3(I,K)
2946 103 CONTINUE
2947 !---SPECIAL CASE TO HANDLE KP=LP1 LAYER AND SPECIAL E2 CALCS.
2948 DO 105 I=MYIS,MYIE
2949 FXOE2(I,LP1)=FXO(I,L)
2950 DTE2(I,LP1)=DT(I,L)
2951 FXOSP(I,1)=FXOE2(I,LM1)
2952 FXOSP(I,2)=FXO(I,LM1)
2953 DTSP(I,1)=DTE2(I,LM1)
2954 DTSP(I,2)=DT(I,LM1)
2955 105 CONTINUE
2956 !
2957 !---SOURCE FUNCTION FOR COMBINED BAND 1
2958 DO 4114 I=MYIS,MYIE
2959 DO 4114 K=1,LP1
2960 VTMP3(I,K)=SOURCE(IXO(I,K),1)
2961 DSORC(I,K)=DSRCE(IXO(I,K),1)
2962 4114 CONTINUE
2963 DO 4112 K=1,LP1
2964 DO 4112 I=MYIS,MYIE
2965 SORC(I,K,1)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2966 4112 CONTINUE
2967 !---SOURCE FUNCTION FOR COMBINED BAND 2
2968 DO 4214 I=MYIS,MYIE
2969 DO 4214 K=1,LP1
2970 VTMP3(I,K)=SOURCE(IXO(I,K),2)
2971 DSORC(I,K)=DSRCE(IXO(I,K),2)
2972 4214 CONTINUE
2973 DO 4212 K=1,LP1
2974 DO 4212 I=MYIS,MYIE
2975 SORC(I,K,2)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2976 4212 CONTINUE
2977 !---SOURCE FUNCTION FOR COMBINED BAND 3
2978 DO 4314 I=MYIS,MYIE
2979 DO 4314 K=1,LP1
2980 VTMP3(I,K)=SOURCE(IXO(I,K),3)
2981 DSORC(I,K)=DSRCE(IXO(I,K),3)
2982 4314 CONTINUE
2983 DO 4312 K=1,LP1
2984 DO 4312 I=MYIS,MYIE
2985 SORC(I,K,3)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2986 4312 CONTINUE
2987 !---SOURCE FUNCTION FOR COMBINED BAND 4
2988 DO 4414 I=MYIS,MYIE
2989 DO 4414 K=1,LP1
2990 VTMP3(I,K)=SOURCE(IXO(I,K),4)
2991 DSORC(I,K)=DSRCE(IXO(I,K),4)
2992 4414 CONTINUE
2993 DO 4412 K=1,LP1
2994 DO 4412 I=MYIS,MYIE
2995 SORC(I,K,4)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
2996 4412 CONTINUE
2997 !---SOURCE FUNCTION FOR COMBINED BAND 5
2998 DO 4514 I=MYIS,MYIE
2999 DO 4514 K=1,LP1
3000 VTMP3(I,K)=SOURCE(IXO(I,K),5)
3001 DSORC(I,K)=DSRCE(IXO(I,K),5)
3002 4514 CONTINUE
3003 DO 4512 K=1,LP1
3004 DO 4512 I=MYIS,MYIE
3005 SORC(I,K,5)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3006 4512 CONTINUE
3007 !---SOURCE FUNCTION FOR COMBINED BAND 6
3008 DO 4614 I=MYIS,MYIE
3009 DO 4614 K=1,LP1
3010 VTMP3(I,K)=SOURCE(IXO(I,K),6)
3011 DSORC(I,K)=DSRCE(IXO(I,K),6)
3012 4614 CONTINUE
3013 DO 4612 K=1,LP1
3014 DO 4612 I=MYIS,MYIE
3015 SORC(I,K,6)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3016 4612 CONTINUE
3017 !---SOURCE FUNCTION FOR COMBINED BAND 7
3018 DO 4714 I=MYIS,MYIE
3019 DO 4714 K=1,LP1
3020 VTMP3(I,K)=SOURCE(IXO(I,K),7)
3021 DSORC(I,K)=DSRCE(IXO(I,K),7)
3022 4714 CONTINUE
3023 DO 4712 K=1,LP1
3024 DO 4712 I=MYIS,MYIE
3025 SORC(I,K,7)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3026 4712 CONTINUE
3027 !---SOURCE FUNCTION FOR COMBINED BAND 8
3028 DO 4814 I=MYIS,MYIE
3029 DO 4814 K=1,LP1
3030 VTMP3(I,K)=SOURCE(IXO(I,K),8)
3031 DSORC(I,K)=DSRCE(IXO(I,K),8)
3032 4814 CONTINUE
3033 DO 4812 K=1,LP1
3034 DO 4812 I=MYIS,MYIE
3035 SORC(I,K,8)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3036 4812 CONTINUE
3037 !---SOURCE FUNCTION FOR BAND 9 (560-670 CM-1)
3038 DO 4914 I=MYIS,MYIE
3039 DO 4914 K=1,LP1
3040 VTMP3(I,K)=SOURCE(IXO(I,K),9)
3041 DSORC(I,K)=DSRCE(IXO(I,K),9)
3042 4914 CONTINUE
3043 DO 4912 K=1,LP1
3044 DO 4912 I=MYIS,MYIE
3045 SORC(I,K,9)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3046 4912 CONTINUE
3047 !---SOURCE FUNCTION FOR BAND 10 (670-800 CM-1)
3048 DO 5014 I=MYIS,MYIE
3049 DO 5014 K=1,LP1
3050 VTMP3(I,K)=SOURCE(IXO(I,K),10)
3051 DSORC(I,K)=DSRCE(IXO(I,K),10)
3052 5014 CONTINUE
3053 DO 5012 K=1,LP1
3054 DO 5012 I=MYIS,MYIE
3055 SORC(I,K,10)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3056 5012 CONTINUE
3057 !---SOURCE FUNCTION FOR BAND 11 (800-900 CM-1)
3058 DO 5114 I=MYIS,MYIE
3059 DO 5114 K=1,LP1
3060 VTMP3(I,K)=SOURCE(IXO(I,K),11)
3061 DSORC(I,K)=DSRCE(IXO(I,K),11)
3062 5114 CONTINUE
3063 DO 5112 K=1,LP1
3064 DO 5112 I=MYIS,MYIE
3065 SORC(I,K,11)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3066 5112 CONTINUE
3067 !---SOURCE FUNCTION FOR BAND 12 (900-990 CM-1)
3068 DO 5214 I=MYIS,MYIE
3069 DO 5214 K=1,LP1
3070 VTMP3(I,K)=SOURCE(IXO(I,K),12)
3071 DSORC(I,K)=DSRCE(IXO(I,K),12)
3072 5214 CONTINUE
3073 DO 5212 K=1,LP1
3074 DO 5212 I=MYIS,MYIE
3075 SORC(I,K,12)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3076 5212 CONTINUE
3077 !---SOURCE FUNCTION FOR BAND 13 (990-1070 CM-1)
3078 DO 5314 I=MYIS,MYIE
3079 DO 5314 K=1,LP1
3080 VTMP3(I,K)=SOURCE(IXO(I,K),13)
3081 DSORC(I,K)=DSRCE(IXO(I,K),13)
3082 5314 CONTINUE
3083 DO 5312 K=1,LP1
3084 DO 5312 I=MYIS,MYIE
3085 SORC(I,K,13)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3086 5312 CONTINUE
3087 !---SOURCE FUNCTION FOR BAND 14 (1070-1200 CM-1)
3088 DO 5414 I=MYIS,MYIE
3089 DO 5414 K=1,LP1
3090 VTMP3(I,K)=SOURCE(IXO(I,K),14)
3091 DSORC(I,K)=DSRCE(IXO(I,K),14)
3092 5414 CONTINUE
3093 DO 5412 K=1,LP1
3094 DO 5412 I=MYIS,MYIE
3095 SORC(I,K,14)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3096 5412 CONTINUE
3097 !
3098 ! THE FOLLOWING SUBROUTINE OBTAINS NLTE SOURCE FUNCTION FOR CO2
3099 !
3100 !
3101 ! CALL NLTE
3102 !
3103 !
3104 !---OBTAIN SPECIAL SOURCE FUNCTIONS FOR THE 15 UM BAND (CSOUR)
3105 ! AND THE WINDOW REGION (SS1)
3106 DO 131 K=1,LP1
3107 DO 131 I=MYIS,MYIE
3108 SS1(I,K)=SORC(I,K,11)+SORC(I,K,12)+SORC(I,K,14)
3109 131 CONTINUE
3110 DO 143 K=1,LP1
3111 DO 143 I=MYIS,MYIE
3112 CSOUR(I,K)=SORC(I,K,9)+SORC(I,K,10)
3113 143 CONTINUE
3114 !
3115 !---COMPUTE TEMP**4 (TC) AND VERTICAL TEMPERATURE DIFFERENCES
3116 ! (OSS,CSS,SS2,DTC). ALL THESE WILL BE USED LATER IN FLUX COMPUTA-
3117 ! TIONS.
3118 !
3119 DO 901 K=1,LP1
3120 DO 901 I=MYIS,MYIE
3121 TC(I,K)=TEMP(I,K)*TEMP(I,K)*TEMP(I,K)*TEMP(I,K)
3122 901 CONTINUE
3123 DO 903 K=1,L
3124 DO 903 I=MYIS,MYIE
3125 OSS(I,K+1)=SORC(I,K+1,13)-SORC(I,K,13)
3126 CSS(I,K+1)=CSOUR(I,K+1)-CSOUR(I,K)
3127 DTC(I,K+1)=TC(I,K+1)-TC(I,K)
3128 SS2(I,K+1)=SS1(I,K+1)-SS1(I,K)
3129 903 CONTINUE
3130 !
3131 !
3132 !---THE FOLLOWIMG IS A DRASTIC REWRITE OF THE RADIATION CODE TO
3133 ! (LARGELY) ELIMINATE THREE-DIMENSIONAL ARRAYS. THE CODE WORKS
3134 ! ON THE FOLLOWING PRINCIPLES:
3135 !
3136 ! LET K = FIXED FLUX LEVEL, KP = VARYING FLUX LEVEL
3137 ! THEN FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K))
3138 ! OVER ALL KP'S, FROM 1 TO LP1.
3139 !
3140 ! WE CAN BREAK DOWN THE CALCULATIONS FOR ALL K'S AS FOLLOWS:
3141 !
3142 ! FOR ALL K'S K=1 TO LP1:
3143 ! FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K)) (1)
3144 ! OVER ALL KP'S, FROM K+1 TO LP1
3145 ! AND
3146 ! FOR KP FROM K+1 TO LP1:
3147 ! FLUX(KP) = DELTAB(K)*TAU(K,KP) (2)
3148 !
3149 ! NOW IF TAU(K,KP)=TAU(KP,K) (SYMMETRICAL ARRAYS)
3150 ! WE CAN COMPUTE A 1-DIMENSIONAL ARRAY TAU1D(KP) FROM
3151 ! K+1 TO LP1, EACH TIME K IS INCREMENTED.
3152 ! EQUATIONS (1) AND (2) THEN BECOME:
3153 !
3154 ! TAU1D(KP) = (VALUES FOR TAU(KP,K) AT THE PARTICULAR K)
3155 ! FLUX(K) = SUM OVER KP : (DELTAB(KP)*TAU1D(KP)) (3)
3156 ! FLUX(KP) = DELTAB(K)*TAU1D(KP) (4)
3157 !
3158 ! THE TERMS FOR TAU (K,K) AND OTHER SPECIAL TERMS (FOR
3159 ! NEARBY LAYERS) MUST, OF COURSE, BE HANDLED SEPARATELY, AND
3160 ! WITH CARE.
3161 !
3162 ! COMPUTE "UPPER TRIANGLE" TRANSMISSION FUNCTIONS FOR
3163 ! THE 9.6 UM BAND (TO3SP) AND THE 15 UM BAND (OVER1D). ALSO,
3164 ! THE
3165 ! STAGE 1...COMPUTE O3 ,OVER TRANSMISSION FCTNS AND AVEPHI
3166 !---DO K=1 CALCULATION (FROM FLUX LAYER KK TO THE TOP) SEPARATELY
3167 ! AS VECTORIZATION IS IMPROVED,AND OZONE CTS TRANSMISSIVITY
3168 ! MAY BE EXTRACTED HERE.
3169 DO 3021 K=1,L
3170 DO 3021 I=MYIS,MYIE
3171 AVEPHI(I,K)=TOTPHI(I,K+1)
3172 3021 CONTINUE
3173 !---IN ORDER TO PROPERLY EVALUATE EMISS INTEGRATED OVER THE (LP1)
3174 ! LAYER, A SPECIAL EVALUATION OF EMISS IS DONE. THIS REQUIRES
3175 ! A SPECIAL COMPUTATION OF AVEPHI, AND IT IS STORED IN THE
3176 ! (OTHERWISE VACANT) LP1'TH POSITION
3177 !
3178 DO 803 I=MYIS,MYIE
3179 AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I)
3180 803 CONTINUE
3181 ! COMPUTE FLUXES FOR K=1
3182 CALL E1E290(E1CTS1,E1CTS2,E1FLX,E1CTW1,E1CTW2,EMISS, &
3183 FXO,DT,FXOE2,DTE2,AVEPHI,TEMP,T, &
3184 ! T1,T2,T4 ,EM1V,EM1VW, &
3185 H16E1,TEN,HP1,H28E1,HAF, &
3186 ids,ide, jds,jde, kds,kde, &
3187 ims,ime, jms,jme, kms,kme, &
3188 its,ite, jts,jte, kts,kte )
3190 DO 302 K=1,L
3191 DO 302 I=MYIS,MYIE
3192 FAC1(I,K)=BO3RND(2)*TPHIO3(I,K+1)/TOTO3(I,K+1)
3193 TO3SPC(I,K)=HAF*(FAC1(I,K)* &
3194 (SQRT(ONE+(FOUR*AO3RND(2)*TOTO3(I,K+1))/FAC1(I,K))-ONE))
3195 ! FOR K=1, TO3SP IS USED INSTEAD OF TO31D (THEY ARE EQUAL IN THIS
3196 ! CASE); TO3SP IS PASSED TO SPA90, WHILE TO31D IS A WORK-ARRAY.
3197 TO3SP(I,K)=EXP(HM1EZ*(TO3SPC(I,K)+SKO3R*TOTVO2(I,K+1)))
3198 OVER1D(I,K)=EXP(HM1EZ*(SQRT(AB15WD*TOTPHI(I,K+1))+ &
3199 SKC1R*TOTVO2(I,K+1)))
3200 !---BECAUSE ALL CONTINUUM TRANSMISSIVITIES ARE OBTAINED FROM THE
3201 ! 2-D QUANTITY CNTTAU (AND ITS RECIPROCAL TOTEVV) WE STORE BOTH
3202 ! OF THESE HERE. FOR K=1, CONT1D EQUALS CNTTAU
3203 CNTTAU(I,K)=EXP(HM1EZ*TOTVO2(I,K+1))
3204 TOTEVV(I,K)=1./CNTTAU(I,K)
3205 302 CONTINUE
3206 DO 3022 K=1,L
3207 DO 3022 I=MYIS,MYIE
3208 CO2SP(I,K+1)=OVER1D(I,K)*CO21(I,1,K+1)
3209 3022 CONTINUE
3210 DO 3023 K=1,L
3211 DO 3023 I=MYIS,MYIE
3212 CO21(I,K+1,1)=CO21(I,K+1,1)*OVER1D(I,K)
3213 3023 CONTINUE
3214 !---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION
3215 DO 1808 I=MYIS,MYIE
3216 RLOG(I,1)=OVER1D(I,1)*CO2NBL(I,1)
3217 1808 CONTINUE
3218 !---THE TERMS WHEN KP=1 FOR ALL K ARE THE PHOTON EXCHANGE WITH
3219 ! THE TOP OF THE ATMOSPHERE, AND ARE OBTAINED DIFFERENTLY THAN
3220 ! THE OTHER CALCULATIONS
3221 DO 305 K=2,LP1
3222 DO 305 I=MYIS,MYIE
3223 FLX(I,K)= (TC(I,1)*E1FLX(I,K) &
3224 +SS1(I,1)*CNTTAU(I,K-1) &
3225 +SORC(I,1,13)*TO3SP(I,K-1) &
3226 +CSOUR(I,1)*CO2SP(I,K)) &
3227 *CLDFAC(I,1,K)
3228 305 CONTINUE
3229 DO 307 I=MYIS,MYIE
3230 FLX(I,1)= TC(I,1)*E1FLX(I,1)+SS1(I,1)+SORC(I,1,13) &
3231 +CSOUR(I,1)
3232 307 CONTINUE
3233 !---THE KP TERMS FOR K=1...
3234 DO 303 KP=2,LP1
3235 DO 303 I=MYIS,MYIE
3236 FLX(I,1)=FLX(I,1)+(OSS(I,KP)*TO3SP(I,KP-1) &
3237 +SS2(I,KP)*CNTTAU(I,KP-1) &
3238 +CSS(I,KP)*CO21(I,KP,1) &
3239 +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,1)
3240 303 CONTINUE
3241 ! SUBROUTINE SPA88 IS CALLED TO OBTAIN EXACT CTS FOR WATER
3242 ! CO2 AND O3, AND APPROXIMATE CTS CO2 AND O3 CALCULATIONS.
3243 !
3244 CALL SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, &
3245 CLDFAC,TEMP,PRESS,VAR1,VAR2, &
3246 P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, &
3247 CO2SP1,CO2SP2,CO2SP, &
3248 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
3249 H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, &
3250 ! SKO2D,RADCON, &
3251 RADCON, &
3252 ids,ide, jds,jde, kds,kde, &
3253 ims,ime, jms,jme, kms,kme, &
3254 its,ite, jts,jte, kts,kte )
3256 !
3257 ! THIS SECTION COMPUTES THE EMISSIVITY CTS HEATING RATES FOR 2
3258 ! EMISSIVITY BANDS: THE 0-160,1200-2200 CM-1 BAND AND THE 800-
3259 ! 990,1070-1200 CM-1 BAND. THE REMAINING CTS COMTRIBUTIONS ARE
3260 ! CONTAINED IN CTSO3, COMPUTED IN SPA88.
3261 !
3262 DO 998 I=MYIS,MYIE
3263 VTMP3(I,1)=1.
3264 998 CONTINUE
3265 DO 999 K=1,L
3266 DO 999 I=MYIS,MYIE
3267 VTMP3(I,K+1)=CNTTAU(I,K)*CLDFAC(I,K+1,1)
3268 999 CONTINUE
3269 DO 1001 K=1,L
3270 DO 1001 I=MYIS,MYIE
3271 CTS(I,K)=RADCON*DELP(I,K)*(TC(I,K)* &
3272 (E1CTW2(I,K)*CLDFAC(I,K+1,1)-E1CTW1(I,K)*CLDFAC(I,K,1)) + &
3273 SS1(I,K)*(VTMP3(I,K+1)-VTMP3(I,K)))
3274 1001 CONTINUE
3275 !
3276 DO 1011 K=1,L
3277 DO 1011 I=MYIS,MYIE
3278 VTMP3(I,K)=TC(I,K)*(CLDFAC(I,K,1)*(E1CTS1(I,K)-E1CTW1(I,K)) - &
3279 CLDFAC(I,K+1,1)*(E1CTS2(I,K)-E1CTW2(I,K)))
3280 1011 CONTINUE
3281 DO 1012 I=MYIS,MYIE
3282 FLX1E1(I)=TC(I,LP1)*CLDFAC(I,LP1,1)* &
3283 (E1CTS1(I,LP1)-E1CTW1(I,LP1))
3284 1012 CONTINUE
3285 DO 1014 K=1,L
3286 DO 1013 I=MYIS,MYIE
3287 FLX1E1(I)=FLX1E1(I)+VTMP3(I,K)
3288 1013 CONTINUE
3289 1014 CONTINUE
3290 !
3291 !---NOW REPEAT FLUX CALCULATIONS FOR THE K=2..LM1 CASES.
3292 ! CALCULATIONS FOR FLUX LEVEL L AND LP1 ARE DONE SEPARATELY, AS ALL
3293 ! EMISSIVITY AND CO2 CALCULATIONS ARE SPECIAL CASES OR NEARBY LAYERS.
3294 !
3295 DO 321 K=2,LM1
3296 KLEN=K
3297 !
3298 DO 3218 KK=1,LP1-K
3299 DO 3218 I=MYIS,MYIE
3300 AVEPHI(I,KK+K-1)=TOTPHI(I,KK+K)-TOTPHI(I,K)
3301 3218 CONTINUE
3302 DO 1803 I=MYIS,MYIE
3303 AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I)
3304 1803 CONTINUE
3305 !---COMPUTE EMISSIVITY FLUXES (E2) FOR THIS CASE. NOTE THAT
3306 ! WE HAVE OMITTED THE NEARBY LATER CASE (EMISS(I,K,K)) AS WELL
3307 ! AS ALL CASES WITH K=L OR LP1. BUT THESE CASES HAVE ALWAYS
3308 ! BEEN HANDLED AS SPECIAL CASES, SO WE MAY AS WELL COMPUTE
3309 ! THEIR FLUXES SEPARASTELY.
3310 !
3311 CALL E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, &
3312 ! T1,T2,T4, &
3313 H16E1,HP1,H28E1,HAF,TEN, &
3314 ids,ide, jds,jde, kds,kde, &
3315 ims,ime, jms,jme, kms,kme, &
3316 its,ite, jts,jte, kts,kte )
3318 DO 322 KK=1,LP1-K
3319 DO 322 I=MYIS,MYIE
3320 AVMO3(I,KK+K-1)=TOTO3(I,KK+K)-TOTO3(I,K)
3321 AVPHO3(I,KK+K-1)=TPHIO3(I,KK+K)-TPHIO3(I,K)
3322 AVVO2(I,KK+K-1)=TOTVO2(I,KK+K)-TOTVO2(I,K)
3323 CONT1D(I,KK+K-1)=CNTTAU(I,KK+K-1)*TOTEVV(I,K-1)
3324 322 CONTINUE
3325 !
3326 DO 3221 KK=1,LP1-K
3327 DO 3221 I=MYIS,MYIE
3328 FAC1(I,K+KK-1)=BO3RND(2)*AVPHO3(I,K+KK-1)/AVMO3(I,K+KK-1)
3329 VTMP3(I,K+KK-1)=HAF*(FAC1(I,K+KK-1)* &
3330 (SQRT(ONE+(FOUR*AO3RND(2)*AVMO3(I,K+KK-1))/ &
3331 FAC1(I,K+KK-1))-ONE))
3332 TO31D(I,K+KK-1)=EXP(HM1EZ*(VTMP3(I,K+KK-1) &
3333 +SKO3R*AVVO2(I,K+KK-1)))
3334 OVER1D(I,K+KK-1)=EXP(HM1EZ*(SQRT(AB15WD*AVEPHI(I,K+KK-1))+ &
3335 SKC1R*AVVO2(I,K+KK-1)))
3336 CO21(I,K+KK,K)=OVER1D(I,K+KK-1)*CO21(I,K+KK,K)
3337 3221 CONTINUE
3338 DO 3223 KP=K+1,LP1
3339 DO 3223 I=MYIS,MYIE
3340 CO21(I,K,KP)=OVER1D(I,KP-1)*CO21(I,K,KP)
3341 3223 CONTINUE
3342 !---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION
3343 DO 1804 I=MYIS,MYIE
3344 RLOG(I,K)=OVER1D(I,K)*CO2NBL(I,K)
3345 1804 CONTINUE
3346 !---THE KP TERMS FOR ARBIRRARY K..
3347 DO 3423 KP=K+1,LP1
3348 DO 3423 I=MYIS,MYIE
3349 FLX(I,K)=FLX(I,K)+(OSS(I,KP)*TO31D(I,KP-1) &
3350 +SS2(I,KP)*CONT1D(I,KP-1) &
3351 +CSS(I,KP)*CO21(I,KP,K) &
3352 +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,K)
3353 3423 CONTINUE
3354 DO 3425 KP=K+1,LP1
3355 DO 3425 I=MYIS,MYIE
3356 FLX(I,KP)=FLX(I,KP)+(OSS(I,K)*TO31D(I,KP-1) &
3357 +SS2(I,K)*CONT1D(I,KP-1) &
3358 +CSS(I,K)*CO21(I,K,KP) &
3359 +DTC(I,K)*EMISSB(I,KP-1))*CLDFAC(I,K,KP)
3360 3425 CONTINUE
3361 321 CONTINUE
3362 !
3363 DO 821 I=MYIS,MYIE
3364 TPL(I,1)=TEMP(I,L)
3365 TPL(I,LP1)=HAF*(T(I,LP1)+TEMP(I,L))
3366 TPL(I,LLP1)=HAF*(T(I,L)+TEMP(I,L))
3367 821 CONTINUE
3368 DO 823 K=2,L
3369 DO 823 I=MYIS,MYIE
3370 TPL(I,K)=T(I,K)
3371 TPL(I,K+L)=T(I,K)
3372 823 CONTINUE
3373 !
3374 !---E2 FUNCTIONS ARE REQUIRED IN THE NBL CALCULATIONS FOR 2 CASES,
3375 ! DENOTED (IN OLD CODE) AS (L,LP1) AND (LP1,LP1)
3376 DO 833 I=MYIS,MYIE
3377 AVEPHI(I,1)=VAR2(I,L)
3378 AVEPHI(I,2)=VAR2(I,L)+EMPL(I,L)
3379 833 CONTINUE
3380 CALL E2SPEC(EMISS,AVEPHI,FXOSP,DTSP, &
3381 ! T1,T2,T4, &
3382 H16E1,TEN,H28E1,HP1, &
3383 ids,ide, jds,jde, kds,kde, &
3384 ims,ime, jms,jme, kms,kme, &
3385 its,ite, jts,jte, kts,kte )
3387 !
3388 ! CALL E3V88 FOR NBL H2O TRANSMISSIVITIES
3389 ! CALL E3V88(EMD,TPL,EMPL,EM3V, &
3390 CALL E3V88(EMD,TPL,EMPL, &
3391 TEN,HP1,H28E1,H16E1, &
3392 ids,ide, jds,jde, kds,kde, &
3393 ims,ime, jms,jme, kms,kme, &
3394 its,ite, jts,jte, kts,kte )
3395 !
3396 ! COMPUTE NEARBY LAYER AND SPECIAL-CASE TRANSMISSIVITIES FOR EMISS
3397 ! USING METHODS FOR H2O GIVEN IN REF. (4)
3398 DO 851 K=2,L
3399 DO 851 I=MYIS,MYIE
3400 EMISDG(I,K)=EMD(I,K+L)+EMD(I,K)
3401 851 CONTINUE
3402 !
3403 ! NOTE THAT EMX1/2 (PRESSURE SCALED PATHS) ARE NOW COMPUTED IN
3404 ! LWR88
3405 DO 861 I=MYIS,MYIE
3406 EMSPEC(I,1)=(EMD(I,1)*EMPL(I,1)-EMD(I,LP1)*EMPL(I,LP1))/ &
3407 EMX1(I) + QUARTR*(EMISS(I,1)+EMISS(I,2))
3408 EMISDG(I,LP1)=TWO*EMD(I,LP1)
3409 EMSPEC(I,2)=TWO*(EMD(I,1)*EMPL(I,1)-EMD(I,LLP1)*EMPL(I,LLP1))/ &
3410 EMX2(I)
3411 861 CONTINUE
3412 DO 331 I=MYIS,MYIE
3413 FAC1(I,L)=BO3RND(2)*VAR4(I,L)/VAR3(I,L)
3414 VTMP3(I,L)=HAF*(FAC1(I,L)* &
3415 (SQRT(ONE+(FOUR*AO3RND(2)*VAR3(I,L))/FAC1(I,L))-ONE))
3416 TO31D(I,L)=EXP(HM1EZ*(VTMP3(I,L)+SKO3R*CNTVAL(I,L)))
3417 OVER1D(I,L)=EXP(HM1EZ*(SQRT(AB15WD*VAR2(I,L))+ &
3418 SKC1R*CNTVAL(I,L)))
3419 CONT1D(I,L)=CNTTAU(I,L)*TOTEVV(I,LM1)
3420 RLOG(I,L)=OVER1D(I,L)*CO2NBL(I,L)
3421 331 CONTINUE
3422 DO 618 K=1,L
3423 DO 618 I=MYIS,MYIE
3424 RLOG(I,K)=LOG(RLOG(I,K))
3425 618 CONTINUE
3426 DO 601 K=1,LM1
3427 DO 601 I=MYIS,MYIE
3428 DELPR1(I,K+1)=DELP(I,K+1)*(PRESS(I,K+1)-P(I,K+1))
3429 ALP(I,LP1+K-1)=-SQRT(DELPR1(I,K+1))*RLOG(I,K+1)
3430 601 CONTINUE
3431 DO 603 K=1,L
3432 DO 603 I=MYIS,MYIE
3433 DELPR2(I,K+1)=DELP(I,K)*(P(I,K+1)-PRESS(I,K))
3434 ALP(I,K)=-SQRT(DELPR2(I,K+1))*RLOG(I,K)
3435 603 CONTINUE
3436 DO 625 I=MYIS,MYIE
3437 ALP(I,LL)=-RLOG(I,L)
3438 ALP(I,LLP1)=-RLOG(I,L)*SQRT(DELP(I,L)*(P(I,LP1)-PRESS(I,LM1)))
3439 625 CONTINUE
3440 ! THE FIRST COMPUTATION IS FOR THE 15 UM BAND,WITH THE
3441 ! FOR THE COMBINED H2O AND CO2 TRANSMISSION FUNCTION.
3442 !
3443 ! PERFORM NBL COMPUTATIONS FOR THE 15 UM BAND
3444 !***THE STATEMENT FUNCTION SF IN PREV. VERSIONS IS NOW EXPLICITLY
3445 ! EVALUATED.
3446 DO 631 K=1,LLP1
3447 DO 631 I=MYIS,MYIE
3448 C(I,K)=ALP(I,K)*(HMP66667+ALP(I,K)*(QUARTR+ALP(I,K)*HM6666M2))
3449 631 CONTINUE
3450 DO 641 I=MYIS,MYIE
3451 CO21(I,LP1,LP1)=ONE+C(I,L)
3452 CO21(I,LP1,L)=ONE+(DELP2(I,L)*C(I,LL)-(PRESS(I,L)-P(I,L))* &
3453 C(I,LLM1))/(P(I,LP1)-PRESS(I,L))
3454 CO21(I,L,LP1)=ONE+((P(I,LP1)-PRESS(I,LM1))*C(I,LLP1)- &
3455 (P(I,LP1)-PRESS(I,L))*C(I,L))/(PRESS(I,L)-PRESS(I,LM1))
3456 641 CONTINUE
3457 DO 643 K=2,L
3458 DO 643 I=MYIS,MYIE
3459 CO21(I,K,K)=ONE+HAF*(C(I,LM1+K)+C(I,K-1))
3460 643 CONTINUE
3461 !
3462 ! COMPUTE NEARBY-LAYER TRANSMISSIVITIES FOR THE O3 BAND AND FOR THE
3463 ! ONE-BAND CONTINUUM BAND (TO3 AND EMISS2). THE SF2 FUNCTION IS
3464 ! USED. THE METHOD IS THE SAME AS DESCRIBED FOR CO2 IN REF (4).
3465 DO 651 K=1,LM1
3466 DO 651 I=MYIS,MYIE
3467 CSUB(I,K+1)=CNTVAL(I,K+1)*DELPR1(I,K+1)
3468 CSUB(I,LP1+K-1)=CNTVAL(I,K)*DELPR2(I,K+1)
3469 651 CONTINUE
3470 !---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED
3471 DO 655 K=1,LLM2
3472 DO 655 I=MYIS,MYIE
3473 CSUB2(I,K+1)=SKO3R*CSUB(I,K+1)
3474 C(I,K+1)=CSUB(I,K+1)*(HMP5+CSUB(I,K+1)* &
3475 (HP166666-CSUB(I,K+1)*H41666M2))
3476 C2(I,K+1)=CSUB2(I,K+1)*(HMP5+CSUB2(I,K+1)* &
3477 (HP166666-CSUB2(I,K+1)*H41666M2))
3478 655 CONTINUE
3479 DO 661 I=MYIS,MYIE
3480 CONTDG(I,LP1)=1.+C(I,LLM1)
3481 TO3DG(I,LP1)=1.+C2(I,LLM1)
3482 661 CONTINUE
3483 DO 663 K=2,L
3484 DO 663 I=MYIS,MYIE
3485 CONTDG(I,K)=ONE+HAF*(C(I,K)+C(I,LM1+K))
3486 TO3DG(I,K)=ONE+HAF*(C2(I,K)+C2(I,LM1+K))
3487 663 CONTINUE
3488 !---NOW OBTAIN FLUXES
3489 !
3490 ! FOR THE DIAGONAL TERMS...
3491 DO 871 K=2,LP1
3492 DO 871 I=MYIS,MYIE
3493 FLX(I,K)=FLX(I,K)+(DTC(I,K)*EMISDG(I,K) &
3494 +SS2(I,K)*CONTDG(I,K) &
3495 +OSS(I,K)*TO3DG(I,K) &
3496 +CSS(I,K)*CO21(I,K,K))*CLDFAC(I,K,K)
3497 871 CONTINUE
3498 ! FOR THE TWO OFF-DIAGONAL TERMS...
3499 DO 873 I=MYIS,MYIE
3500 FLX(I,L)=FLX(I,L)+(CSS(I,LP1)*CO21(I,LP1,L) &
3501 +DTC(I,LP1)*EMSPEC(I,2) &
3502 +OSS(I,LP1)*TO31D(I,L) &
3503 +SS2(I,LP1)*CONT1D(I,L))*CLDFAC(I,LP1,L)
3504 FLX(I,LP1)=FLX(I,LP1)+(CSS(I,L)*CO21(I,L,LP1) &
3505 +OSS(I,L)*TO31D(I,L) &
3506 +SS2(I,L)*CONT1D(I,L) &
3507 +DTC(I,L)*EMSPEC(I,1))*CLDFAC(I,L,LP1)
3508 873 CONTINUE
3509 !
3510 ! FINAL SECTION OBTAINS EMISSIVITY HEATING RATES,
3511 ! TOTAL HEATING RATES AND THE FLUX AT THE GROUND
3512 !
3513 ! .....CALCULATE THE EMISSIVITY HEATING RATES
3514 DO 1101 K=1,L
3515 DO 1101 I=MYIS,MYIE
3516 HEATEM(I,K)=RADCON*(FLX(I,K+1)-FLX(I,K))*DELP(I,K)
3517 1101 CONTINUE
3518 ! .....CALCULATE THE TOTAL HEATING RATES
3519 DO 1103 K=1,L
3520 DO 1103 I=MYIS,MYIE
3521 HEATRA(I,K)=HEATEM(I,K)-CTS(I,K)-CTSO3(I,K)+EXCTS(I,K)
3522 1103 CONTINUE
3523 ! .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE
3524 ! TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1)
3525 DO 1111 K=1,L
3526 DO 1111 I=MYIS,MYIE
3527 VSUM1(I,K)=HEATRA(I,K)*DELP2(I,K)*RADCON1
3528 1111 CONTINUE
3529 DO 1115 I=MYIS,MYIE
3530 TOPFLX(I)=FLX1E1(I)+GXCTS(I)
3531 FLXNET(I,1)=TOPFLX(I)
3532 1115 CONTINUE
3533 !---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS
3534 ! THE THICK CLOUD SECTION IS INVOKED.
3535 DO 1123 K=2,LP1
3536 DO 1123 I=MYIS,MYIE
3537 FLXNET(I,K)=FLXNET(I,K-1)+VSUM1(I,K-1)
3538 1123 CONTINUE
3539 DO 1125 I=MYIS,MYIE
3540 GRNFLX(I)=FLXNET(I,LP1)
3541 1125 CONTINUE
3542 !
3543 ! THIS IS THE THICK CLOUD SECTION.OPTIONALLY,IF THICK CLOUD
3544 ! FLUXES ARE TO BE "CONVECTIVELY ADJUSTED",IE,DF/DP IS CONSTANT,
3545 ! FOR CLOUDY PART OF GRID POINT, THE FOLLOWING CODE IS EXECUTED.
3546 !***FIRST,COUNT THE NUMBER OF CLOUDS ALONG THE LAT. ROW. SKIP THE
3547 ! ENTIRE THICK CLOUD COMPUTATION OF THERE ARE NO CLOUDS.
3548 ICNT=0
3549 DO 1301 I=MYIS,MYIE
3550 ICNT=ICNT+NCLDS(I)
3551 1301 CONTINUE
3552 IF (ICNT.EQ.0) GO TO 6999
3553 !---FIND THE MAXIMUM NUMBER OF CLOUDS IN THE LATITUDE ROW
3554 KCLDS=NCLDS(MYIS)
3555 DO 2106 I=MYIS,MYIE
3556 KCLDS=MAX(NCLDS(I),KCLDS)
3557 2106 CONTINUE
3558 !
3559 !
3560 !***OBTAIN THE PRESSURES AND FLUXES OF THE TOP AND BOTTOM OF
3561 ! THE NC'TH CLOUD (IT IS ASSUMED THAT ALL KTOP AND KBTM'S HAVE
3562 ! BEEN DEFINED!).
3563 DO 1361 KK=1,KCLDS
3564 KMIN=LP1
3565 KMAX=0
3566 DO 1362 I=MYIS,MYIE
3567 J1=KTOP(I,KK+1)
3568 ! IF (J1.EQ.1) GO TO 1362
3569 J3=KBTM(I,KK+1)
3570 IF (J3.GT.J1) THEN
3571 PTOP(I)=P(I,J1)
3572 PBOT(I)=P(I,J3+1)
3573 FTOP(I)=FLXNET(I,J1)
3574 FBOT(I)=FLXNET(I,J3+1)
3575 !***OBTAIN THE "FLUX DERIVATIVE" DF/DP (DELPTC)
3576 DELPTC(I)=(FTOP(I)-FBOT(I))/(PTOP(I)-PBOT(I))
3577 KMIN=MIN(KMIN,J1)
3578 KMAX=MAX(KMAX,J3)
3579 ENDIF
3580 1362 CONTINUE
3581 KMIN=KMIN+1
3582 !***CALCULATE THE TOT. FLUX CHG. FROM THE TOP OF THE CLOUD, FOR
3583 ! ALL LEVELS.
3584 DO 1365 K=KMIN,KMAX
3585 DO 1363 I=MYIS,MYIE
3586 ! IF (KTOP(I,KK+1).EQ.1) GO TO 1363
3587 IF(KTOP(I,KK+1).LT.K .AND. K.LE.KBTM(I,KK+1)) THEN
3588 Z1(I,K)=(P(I,K)-PTOP(I))*DELPTC(I)+FTOP(I)
3589 !ORIGINAL FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,KK+1)) +
3590 !ORIGINAL1 Z1(I,K)*CAMT(I,KK+1)
3591 FLXNET(I,K)=Z1(I,K)
3592 ENDIF
3593 1363 CONTINUE
3594 1365 CONTINUE
3595 1361 CONTINUE
3596 !***USING THIS FLUX CHG. IN THE CLOUDY PART OF THE GRID BOX, OBTAIN
3597 ! THE NEW FLUXES, WEIGHTING THE CLEAR AND CLOUDY FLUXES:AGAIN, ONLY
3598 ! THE FLUXES IN THICK-CLOUD LEVELS WILL EVENTUALLY BE USED.
3599 ! DO 6051 K=1,LP1
3600 ! DO 6051 I=MYIS,MYIE
3601 ! FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,NC)) +
3602 ! 1 Z1(I,K)*CAMT(I,NC)
3603 !051 CONTINUE
3604 !***MERGE FLXTHK INTO FLXNET FOR APPROPRIATE LEVELS.
3605 ! DO 1401 K=1,LP1
3606 ! DO 1401 I=MYIS,MYIE
3607 ! IF (K.GT.ITOP(I) .AND. K.LE.IBOT(I)
3608 ! 1 .AND. (NC-1).LE.NCLDS(I)) THEN
3609 ! FLXNET(I,K)=FLXTHK(I,K)
3610 ! ENDIF
3611 !401 CONTINUE
3612 !
3613 !******END OF CLOUD LOOP*****
3614 6001 CONTINUE
3615 6999 CONTINUE
3616 !***THE FINAL STEP IS TO RECOMPUTE THE HEATING RATES BASED ON THE
3617 ! REVISED FLUXES:
3618 DO 6101 K=1,L
3619 DO 6101 I=MYIS,MYIE
3620 HEATRA(I,K)=RADCON*(FLXNET(I,K+1)-FLXNET(I,K))*DELP(I,K)
3621 6101 CONTINUE
3622 ! THE THICK CLOUD SECTION ENDS HERE.
3624 END SUBROUTINE FST88
3626 !----------------------------------------------------------------------
3628 SUBROUTINE E1E290(G1,G2,G3,G4,G5,EMISS,FXOE1,DTE1,FXOE2,DTE2, &
3629 AVEPHI,TEMP,T, &
3630 ! T1,T2,T4,EM1V,EM1VW, &
3631 H16E1,TEN,HP1,H28E1,HAF, &
3632 ids,ide, jds,jde, kds,kde, &
3633 ims,ime, jms,jme, kms,kme, &
3634 its,ite, jts,jte, kts,kte )
3635 !---------------------------------------------------------------------
3636 IMPLICIT NONE
3637 !----------------------------------------------------------------------
3638 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
3639 ims,ime, jms,jme, kms,kme , &
3640 its,ite, jts,jte, kts,kte
3641 REAL,INTENT(IN) :: H16E1,TEN,HP1,H28E1,HAF
3643 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: G1,G4,G3,EMISS
3644 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: FXOE1,DTE1,FXOE2,DTE2
3645 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,TEMP,T
3646 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: G2,G5
3647 ! REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4 ,EM1V,EM1VW
3649 REAL,DIMENSION(its:ite,kts:kte+1) :: TMP3,DU,FYO,WW1,WW2
3650 INTEGER,DIMENSION(its:ite,kts:kte*3+2) :: IT1
3651 INTEGER,DIMENSION(its:ite,kts:kte+1) :: IVAL
3653 ! REAL,DIMENSION(28,180):: EM1,EM1WDE,TABLE1,TABLE2, &
3654 ! TABLE3
3655 ! EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1))
3656 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
3657 ! (T4(1),TABLE3(1,1))
3659 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
3660 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
3662 L=kte
3663 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
3664 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
3665 LLM2 = LL-2; LLM1=LL-1
3666 MYIS=its; MYIE=ite
3668 !---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE
3669 ! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE
3670 ! THUS GENERATES THE E2 FUNCTION. THE FXO INDICES HAVE BEEN
3671 ! OBTAINED IN FST88, FOR CONVENIENCE.
3672 !
3673 !---THIS SUBROUTINE EVALUATES THE K=1 CASE ONLY--
3674 !
3675 !---THIS LOOP REPLACES LOOPS GOING FROMI=1,IMAX AND KP=2,LP1 PLUS
3676 ! THE SPECIAL CASE FOR THE LP1TH LAYER.
3678 DO 1322 K=1,LP1
3679 DO 1322 I=MYIS,MYIE
3680 TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1
3681 FYO(I,K)=AINT(TMP3(I,K)*TEN)
3682 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
3683 FYO(I,K)=H28E1*FYO(I,K)
3684 IVAL(I,K)=FYO(I,K)+FXOE2(I,K)
3685 EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
3686 +DTE2(I,K)*T4(IVAL(I,K))
3687 1322 CONTINUE
3688 !
3689 !---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW
3690 ! BY AVERAGING THE VALUES FOR L AND LP1:
3691 DO 1344 I=MYIS,MYIE
3692 EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1))
3693 1344 CONTINUE
3694 !
3695 ! CALCULATIONS FOR THE KP=1 LAYER ARE NOT PERFORMED, AS
3696 ! THE RADIATION CODE ASSUMES THAT THE TOP FLUX LAYER (ABOVE THE
3697 ! TOP DATA LEVEL) IS ISOTHERMAL, AND HENCE CONTRIBUTES NOTHING
3698 ! TO THE FLUXES AT OTHER LEVELS.
3699 !
3700 !***THE FOLLOWING IS THE CALCULATION FOR THE E1 FUNCTION, FORMERLY
3701 ! DONE IN SUBROUTINE E1V88. THE MOVE TO E1E288 IS DUE TO THE
3702 ! SAVINGS IN OBTAINING INDEX VALUES (THE TEMP. INDICES HAVE
3703 ! BEEN OBTAINED IN FST88, WHILE THE U-INDICES ARE OBTAINED
3704 ! IN THE E2 CALCS.,WITH K=1).
3705 !
3706 !
3707 ! FOR TERMS INVOLVING TOP LAYER, DU IS NOT KNOWN; IN FACT, WE
3708 ! USE INDEX 2 TO REPERSENT INDEX 1 IN PREV. CODE. THIS MEANS THAT
3709 ! THE IT1 INDEX 1 AND LLP1 HAS TO BE CALCULATED SEPARATELY. THE
3710 ! INDEX LLP2 GIVES THE SAME VALUE AS 1; IT CAN BE OMITTED.
3711 DO 208 I=MYIS,MYIE
3712 IT1(I,1)=FXOE1(I,1)
3713 WW1(I,1)=TEN-DTE1(I,1)
3714 WW2(I,1)=HP1
3715 208 CONTINUE
3716 DO 209 K=1,L
3717 DO 209 I=MYIS,MYIE
3718 IT1(I,K+1)=FYO(I,K)+FXOE1(I,K+1)
3719 IT1(I,LP2+K-1)=FYO(I,K)+FXOE1(I,K)
3720 WW1(I,K+1)=TEN-DTE1(I,K+1)
3721 WW2(I,K+1)=HP1-DU(I,K)
3722 209 CONTINUE
3723 DO 211 KP=1,L
3724 DO 211 I=MYIS,MYIE
3725 IT1(I,KP+LLP1)=FYO(I,KP)+FXOE1(I,1)
3726 211 CONTINUE
3727 !
3728 !
3729 ! G3(I,1) HAS THE SAME VALUES AS G1 (AND DID ALL ALONG)
3730 DO 230 I=MYIS,MYIE
3731 G1(I,1)=WW1(I,1)*WW2(I,1)*EM1V(IT1(I,1))+ &
3732 WW2(I,1)*DTE1(I,1)*EM1V(IT1(I,1)+1)
3733 G3(I,1)=G1(I,1)
3734 230 CONTINUE
3735 DO 240 K=1,L
3736 DO 240 I=MYIS,MYIE
3737 G1(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1V(IT1(I,K+1))+ &
3738 WW2(I,K+1)*DTE1(I,K+1)*EM1V(IT1(I,K+1)+1)+ &
3739 WW1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+28)+ &
3740 DTE1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+29)
3741 G2(I,K)=WW1(I,K)*WW2(I,K+1)*EM1V(IT1(I,K+LP2-1))+ &
3742 WW2(I,K+1)*DTE1(I,K)*EM1V(IT1(I,K+LP2-1)+1)+ &
3743 WW1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+28)+ &
3744 DTE1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+29)
3745 240 CONTINUE
3746 DO 241 KP=2,LP1
3747 DO 241 I=MYIS,MYIE
3748 G3(I,KP)=WW1(I,1)*WW2(I,KP)*EM1V(IT1(I,LL+KP))+ &
3749 WW2(I,KP)*DTE1(I,1)*EM1V(IT1(I,LL+KP)+1)+ &
3750 WW1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+28)+ &
3751 DTE1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+29)
3752 241 CONTINUE
3753 !
3754 DO 244 I=MYIS,MYIE
3755 G4(I,1)=WW1(I,1)*WW2(I,1)*EM1VW(IT1(I,1))+ &
3756 WW2(I,1)*DTE1(I,1)*EM1VW(IT1(I,1)+1)
3757 244 CONTINUE
3758 DO 242 K=1,L
3759 DO 242 I=MYIS,MYIE
3760 G4(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1VW(IT1(I,K+1))+ &
3761 WW2(I,K+1)*DTE1(I,K+1)*EM1VW(IT1(I,K+1)+1)+ &
3762 WW1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+28)+ &
3763 DTE1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+29)
3764 G5(I,K)=WW1(I,K)*WW2(I,K+1)*EM1VW(IT1(I,K+LP2-1))+ &
3765 WW2(I,K+1)*DTE1(I,K)*EM1VW(IT1(I,K+LP2-1)+1)+ &
3766 WW1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+28)+ &
3767 DTE1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+29)
3768 242 CONTINUE
3769 !
3770 END SUBROUTINE E1E290
3772 !----------------------------------------------------------------------
3774 SUBROUTINE SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, &
3775 CLDFAC,TEMP,PRESS,VAR1,VAR2, &
3776 P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, &
3777 CO2SP1,CO2SP2,CO2SP, &
3778 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
3779 H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, &
3780 ! SKO2D,RADCON, &
3781 RADCON, &
3782 ids,ide, jds,jde, kds,kde, &
3783 ims,ime, jms,jme, kms,kme, &
3784 its,ite, jts,jte, kts,kte )
3785 !---------------------------------------------------------------------
3786 IMPLICIT NONE
3787 !----------------------------------------------------------------------
3788 ! INTEGER, PARAMETER :: NBLY=15
3789 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
3790 ims,ime, jms,jme, kms,kme , &
3791 its,ite, jts,jte, kts,kte
3793 REAL,INTENT(IN) :: H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, &
3794 RADCON
3795 ! SKO2D,RADCON
3797 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: CSOUR
3798 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: CTSO3
3799 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: EXCTS
3800 REAL,INTENT(OUT),DIMENSION(its:ite) :: GXCTS
3801 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC
3802 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
3803 REAL,INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
3805 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: VAR1,VAR2
3806 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: P
3807 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: DELP,DELP2,TO3SPC
3808 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) ::TOTVO2,TO3SP,CO2SP1,&
3809 CO2SP2,CO2SP
3810 REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
3811 BCOMB,BETACM
3813 REAL,DIMENSION(its:ite,kts:kte+1) ::CTMP,CTMP2,CTMP3
3814 REAL,DIMENSION(its:ite,kts:kte) ::X,Y,FAC1,FAC2,F,FF,AG,AGG, &
3815 PHITMP,PSITMP,TOPM,TOPPHI,TT
3817 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
3818 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
3820 L=kte
3821 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
3822 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
3823 LLM2 = LL-2; LLM1=LL-1
3824 MYIS=its; MYIE=ite
3826 !--!COMPUTE TEMPERATURE QUANTITIES FOR USE IN PROGRAM
3828 DO 101 K=1,L
3829 DO 101 I=MYIS,MYIE
3830 X(I,K)=TEMP(I,K)-H25E2
3831 Y(I,K)=X(I,K)*X(I,K)
3832 101 CONTINUE
3833 !---INITIALIZE CTMP(I,1),CTMP2(I,1),CTMP3(I,1) TO UNITY; THESE ARE
3834 ! TRANSMISSION FCTNS AT THE TOP.
3835 DO 345 I=MYIS,MYIE
3836 CTMP(I,1)=ONE
3837 CTMP2(I,1)=1.
3838 CTMP3(I,1)=1.
3839 345 CONTINUE
3840 !***BEGIN LOOP ON FREQUENCY BANDS (1)***
3841 !
3842 !---CALCULATION FOR BAND 1 (COMBINED BAND 1)
3843 !
3844 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3845 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3846 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3847 DO 301 K=1,L
3848 DO 301 I=MYIS,MYIE
3849 F(I,K)=H44194M2*(APCM(1)*X(I,K)+BPCM(1)*Y(I,K))
3850 FF(I,K)=H44194M2*(ATPCM(1)*X(I,K)+BTPCM(1)*Y(I,K))
3851 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3852 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3853 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3854 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3855 301 CONTINUE
3856 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3857 ! P(K) (TOPM,TOPPHI)
3858 DO 315 I=MYIS,MYIE
3859 TOPM(I,1)=PHITMP(I,1)
3860 TOPPHI(I,1)=PSITMP(I,1)
3861 315 CONTINUE
3862 DO 319 K=2,L
3863 DO 317 I=MYIS,MYIE
3864 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3865 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3866 317 CONTINUE
3867 319 CONTINUE
3868 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3869 DO 321 K=1,L
3870 DO 321 I=MYIS,MYIE
3871 FAC1(I,K)=ACOMB(1)*TOPM(I,K)
3872 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(1)*TOPPHI(I,K))
3873 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3874 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3875 321 CONTINUE
3876 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3877 DO 353 K=1,L
3878 DO 353 I=MYIS,MYIE
3879 EXCTS(I,K)=SORC(I,K,1)*(CTMP(I,K+1)-CTMP(I,K))
3880 353 CONTINUE
3881 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3882 DO 361 I=MYIS,MYIE
3883 GXCTS(I)=CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,1)+ &
3884 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3885 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3886 (SORC(I,LP1,1)-SORC(I,L,1)))
3887 361 CONTINUE
3888 !
3889 !
3890 !-----CALCULATION FOR BAND 2 (COMBINED BAND 2)
3891 !
3892 !
3893 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3894 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3895 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3896 DO 401 K=1,L
3897 DO 401 I=MYIS,MYIE
3898 F(I,K)=H44194M2*(APCM(2)*X(I,K)+BPCM(2)*Y(I,K))
3899 FF(I,K)=H44194M2*(ATPCM(2)*X(I,K)+BTPCM(2)*Y(I,K))
3900 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3901 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3902 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3903 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3904 401 CONTINUE
3905 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3906 ! P(K) (TOPM,TOPPHI)
3907 DO 415 I=MYIS,MYIE
3908 TOPM(I,1)=PHITMP(I,1)
3909 TOPPHI(I,1)=PSITMP(I,1)
3910 415 CONTINUE
3911 DO 419 K=2,L
3912 DO 417 I=MYIS,MYIE
3913 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3914 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3915 417 CONTINUE
3916 419 CONTINUE
3917 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3918 DO 421 K=1,L
3919 DO 421 I=MYIS,MYIE
3920 FAC1(I,K)=ACOMB(2)*TOPM(I,K)
3921 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(2)*TOPPHI(I,K))
3922 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3923 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3924 421 CONTINUE
3925 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3926 DO 453 K=1,L
3927 DO 453 I=MYIS,MYIE
3928 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,2)* &
3929 (CTMP(I,K+1)-CTMP(I,K))
3930 453 CONTINUE
3931 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3932 DO 461 I=MYIS,MYIE
3933 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,2)+ &
3934 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3935 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3936 (SORC(I,LP1,2)-SORC(I,L,2)))
3937 461 CONTINUE
3938 !
3939 !-----CALCULATION FOR BAND 3 (COMBINED BAND 3)
3940 !
3941 !
3942 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3943 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3944 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3945 DO 501 K=1,L
3946 DO 501 I=MYIS,MYIE
3947 F(I,K)=H44194M2*(APCM(3)*X(I,K)+BPCM(3)*Y(I,K))
3948 FF(I,K)=H44194M2*(ATPCM(3)*X(I,K)+BTPCM(3)*Y(I,K))
3949 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3950 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3951 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3952 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3953 501 CONTINUE
3954 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3955 ! P(K) (TOPM,TOPPHI)
3956 DO 515 I=MYIS,MYIE
3957 TOPM(I,1)=PHITMP(I,1)
3958 TOPPHI(I,1)=PSITMP(I,1)
3959 515 CONTINUE
3960 DO 519 K=2,L
3961 DO 517 I=MYIS,MYIE
3962 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3963 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3964 517 CONTINUE
3965 519 CONTINUE
3966 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3967 DO 521 K=1,L
3968 DO 521 I=MYIS,MYIE
3969 FAC1(I,K)=ACOMB(3)*TOPM(I,K)
3970 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(3)*TOPPHI(I,K))
3971 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3972 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3973 521 CONTINUE
3974 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3975 DO 553 K=1,L
3976 DO 553 I=MYIS,MYIE
3977 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,3)* &
3978 (CTMP(I,K+1)-CTMP(I,K))
3979 553 CONTINUE
3980 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3981 DO 561 I=MYIS,MYIE
3982 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,3)+ &
3983 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3984 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3985 (SORC(I,LP1,3)-SORC(I,L,3)))
3986 561 CONTINUE
3987 !
3988 !-----CALCULATION FOR BAND 4 (COMBINED BAND 4)
3989 !
3990 !
3991 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3992 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3993 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3994 DO 601 K=1,L
3995 DO 601 I=MYIS,MYIE
3996 F(I,K)=H44194M2*(APCM(4)*X(I,K)+BPCM(4)*Y(I,K))
3997 FF(I,K)=H44194M2*(ATPCM(4)*X(I,K)+BTPCM(4)*Y(I,K))
3998 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3999 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4000 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4001 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4002 601 CONTINUE
4003 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4004 ! P(K) (TOPM,TOPPHI)
4005 DO 615 I=MYIS,MYIE
4006 TOPM(I,1)=PHITMP(I,1)
4007 TOPPHI(I,1)=PSITMP(I,1)
4008 615 CONTINUE
4009 DO 619 K=2,L
4010 DO 617 I=MYIS,MYIE
4011 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4012 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4013 617 CONTINUE
4014 619 CONTINUE
4015 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4016 DO 621 K=1,L
4017 DO 621 I=MYIS,MYIE
4018 FAC1(I,K)=ACOMB(4)*TOPM(I,K)
4019 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(4)*TOPPHI(I,K))
4020 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
4021 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4022 621 CONTINUE
4023 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4024 DO 653 K=1,L
4025 DO 653 I=MYIS,MYIE
4026 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,4)* &
4027 (CTMP(I,K+1)-CTMP(I,K))
4028 653 CONTINUE
4029 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4030 DO 661 I=MYIS,MYIE
4031 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,4)+ &
4032 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4033 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4034 (SORC(I,LP1,4)-SORC(I,L,4)))
4035 661 CONTINUE
4036 !
4037 !-----CALCULATION FOR BAND 5 (COMBINED BAND 5)
4038 !
4039 !
4040 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4041 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4042 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4043 DO 701 K=1,L
4044 DO 701 I=MYIS,MYIE
4045 F(I,K)=H44194M2*(APCM(5)*X(I,K)+BPCM(5)*Y(I,K))
4046 FF(I,K)=H44194M2*(ATPCM(5)*X(I,K)+BTPCM(5)*Y(I,K))
4047 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4048 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4049 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4050 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4051 701 CONTINUE
4052 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4053 ! P(K) (TOPM,TOPPHI)
4054 DO 715 I=MYIS,MYIE
4055 TOPM(I,1)=PHITMP(I,1)
4056 TOPPHI(I,1)=PSITMP(I,1)
4057 715 CONTINUE
4058 DO 719 K=2,L
4059 DO 717 I=MYIS,MYIE
4060 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4061 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4062 717 CONTINUE
4063 719 CONTINUE
4064 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4065 DO 721 K=1,L
4066 DO 721 I=MYIS,MYIE
4067 FAC1(I,K)=ACOMB(5)*TOPM(I,K)
4068 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(5)*TOPPHI(I,K))
4069 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4070 BETACM(5)*TOTVO2(I,K+1)*SKO2D))
4071 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4072 721 CONTINUE
4073 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4074 DO 753 K=1,L
4075 DO 753 I=MYIS,MYIE
4076 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,5)* &
4077 (CTMP(I,K+1)-CTMP(I,K))
4078 753 CONTINUE
4079 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4080 DO 761 I=MYIS,MYIE
4081 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,5)+ &
4082 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4083 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4084 (SORC(I,LP1,5)-SORC(I,L,5)))
4085 761 CONTINUE
4086 !
4087 !-----CALCULATION FOR BAND 6 (COMBINED BAND 6)
4088 !
4089 !
4090 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4091 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4092 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4093 DO 801 K=1,L
4094 DO 801 I=MYIS,MYIE
4095 F(I,K)=H44194M2*(APCM(6)*X(I,K)+BPCM(6)*Y(I,K))
4096 FF(I,K)=H44194M2*(ATPCM(6)*X(I,K)+BTPCM(6)*Y(I,K))
4097 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4098 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4099 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4100 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4101 801 CONTINUE
4102 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4103 ! P(K) (TOPM,TOPPHI)
4104 DO 815 I=MYIS,MYIE
4105 TOPM(I,1)=PHITMP(I,1)
4106 TOPPHI(I,1)=PSITMP(I,1)
4107 815 CONTINUE
4108 DO 819 K=2,L
4109 DO 817 I=MYIS,MYIE
4110 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4111 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4112 817 CONTINUE
4113 819 CONTINUE
4114 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4115 DO 821 K=1,L
4116 DO 821 I=MYIS,MYIE
4117 FAC1(I,K)=ACOMB(6)*TOPM(I,K)
4118 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(6)*TOPPHI(I,K))
4119 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4120 BETACM(6)*TOTVO2(I,K+1)*SKO2D))
4121 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4122 821 CONTINUE
4123 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4124 DO 853 K=1,L
4125 DO 853 I=MYIS,MYIE
4126 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,6)* &
4127 (CTMP(I,K+1)-CTMP(I,K))
4128 853 CONTINUE
4129 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4130 DO 861 I=MYIS,MYIE
4131 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,6)+ &
4132 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4133 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4134 (SORC(I,LP1,6)-SORC(I,L,6)))
4135 861 CONTINUE
4136 !
4137 !-----CALCULATION FOR BAND 7 (COMBINED BAND 7)
4138 !
4139 !
4140 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4141 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4142 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4143 DO 901 K=1,L
4144 DO 901 I=MYIS,MYIE
4145 F(I,K)=H44194M2*(APCM(7)*X(I,K)+BPCM(7)*Y(I,K))
4146 FF(I,K)=H44194M2*(ATPCM(7)*X(I,K)+BTPCM(7)*Y(I,K))
4147 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4148 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4149 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4150 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4151 901 CONTINUE
4152 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4153 ! P(K) (TOPM,TOPPHI)
4154 DO 915 I=MYIS,MYIE
4155 TOPM(I,1)=PHITMP(I,1)
4156 TOPPHI(I,1)=PSITMP(I,1)
4157 915 CONTINUE
4158 DO 919 K=2,L
4159 DO 917 I=MYIS,MYIE
4160 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4161 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4162 917 CONTINUE
4163 919 CONTINUE
4164 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4165 DO 921 K=1,L
4166 DO 921 I=MYIS,MYIE
4167 FAC1(I,K)=ACOMB(7)*TOPM(I,K)
4168 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(7)*TOPPHI(I,K))
4169 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4170 BETACM(7)*TOTVO2(I,K+1)*SKO2D))
4171 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4172 921 CONTINUE
4173 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4174 DO 953 K=1,L
4175 DO 953 I=MYIS,MYIE
4176 EXCTS(I,K)=EXCTS(I,K)+SORC(I,k,7)* &
4177 (CTMP(I,K+1)-CTMP(I,K))
4178 953 CONTINUE
4179 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4180 DO 961 I=MYIS,MYIE
4181 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,7)+ &
4182 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4183 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4184 (SORC(I,LP1,7)-SORC(I,L,7)))
4185 961 CONTINUE
4186 !
4187 !-----CALCULATION FOR BAND 8 (COMBINED BAND 8)
4188 !
4189 !
4190 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4191 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4192 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4193 DO 1001 K=1,L
4194 DO 1001 I=MYIS,MYIE
4195 F(I,K)=H44194M2*(APCM(8)*X(I,K)+BPCM(8)*Y(I,K))
4196 FF(I,K)=H44194M2*(ATPCM(8)*X(I,K)+BTPCM(8)*Y(I,K))
4197 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4198 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4199 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4200 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4201 1001 CONTINUE
4202 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4203 ! P(K) (TOPM,TOPPHI)
4204 DO 1015 I=MYIS,MYIE
4205 TOPM(I,1)=PHITMP(I,1)
4206 TOPPHI(I,1)=PSITMP(I,1)
4207 1015 CONTINUE
4208 DO 1019 K=2,L
4209 DO 1017 I=MYIS,MYIE
4210 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4211 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4212 1017 CONTINUE
4213 1019 CONTINUE
4214 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4215 DO 1021 K=1,L
4216 DO 1021 I=MYIS,MYIE
4217 FAC1(I,K)=ACOMB(8)*TOPM(I,K)
4218 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(8)*TOPPHI(I,K))
4219 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4220 BETACM(8)*TOTVO2(I,K+1)*SKO2D))
4221 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4222 1021 CONTINUE
4223 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4224 DO 1053 K=1,L
4225 DO 1053 I=MYIS,MYIE
4226 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,8)* &
4227 (CTMP(I,K+1)-CTMP(I,K))
4228 1053 CONTINUE
4229 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4230 DO 1061 I=MYIS,MYIE
4231 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,8)+ &
4232 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4233 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4234 (SORC(I,LP1,8)-SORC(I,L,8)))
4235 1061 CONTINUE
4236 !
4237 !-----CALCULATION FOR BAND 9 ( 560-670 CM-1; INCLUDES CO2)
4238 !
4239 !
4240 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4241 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4242 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4243 DO 1101 K=1,L
4244 DO 1101 I=MYIS,MYIE
4245 F(I,K)=H44194M2*(APCM(9)*X(I,K)+BPCM(9)*Y(I,K))
4246 FF(I,K)=H44194M2*(ATPCM(9)*X(I,K)+BTPCM(9)*Y(I,K))
4247 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4248 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4249 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4250 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4251 1101 CONTINUE
4252 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4253 ! P(K) (TOPM,TOPPHI)
4254 DO 1115 I=MYIS,MYIE
4255 TOPM(I,1)=PHITMP(I,1)
4256 TOPPHI(I,1)=PSITMP(I,1)
4257 1115 CONTINUE
4258 DO 1119 K=2,L
4259 DO 1117 I=MYIS,MYIE
4260 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4261 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4262 1117 CONTINUE
4263 1119 CONTINUE
4264 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4265 DO 1121 K=1,L
4266 DO 1121 I=MYIS,MYIE
4267 FAC1(I,K)=ACOMB(9)*TOPM(I,K)
4268 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(9)*TOPPHI(I,K))
4269 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4270 BETACM(9)*TOTVO2(I,K+1)*SKO2D))*CO2SP1(I,K+1)
4271 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4272 1121 CONTINUE
4273 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4274 DO 1153 K=1,L
4275 DO 1153 I=MYIS,MYIE
4276 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,9)* &
4277 (CTMP(I,K+1)-CTMP(I,K))
4278 1153 CONTINUE
4279 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4280 DO 1161 I=MYIS,MYIE
4281 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,9)+ &
4282 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4283 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4284 (SORC(I,LP1,9)-SORC(I,L,9)))
4285 1161 CONTINUE
4286 !
4287 !-----CALCULATION FOR BAND 10 (670-800 CM-1; INCLUDES CO2)
4288 !
4289 !
4290 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4291 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4292 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4293 DO 1201 K=1,L
4294 DO 1201 I=MYIS,MYIE
4295 F(I,K)=H44194M2*(APCM(10)*X(I,K)+BPCM(10)*Y(I,K))
4296 FF(I,K)=H44194M2*(ATPCM(10)*X(I,K)+BTPCM(10)*Y(I,K))
4297 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4298 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4299 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4300 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4301 1201 CONTINUE
4302 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4303 ! P(K) (TOPM,TOPPHI)
4304 DO 1215 I=MYIS,MYIE
4305 TOPM(I,1)=PHITMP(I,1)
4306 TOPPHI(I,1)=PSITMP(I,1)
4307 1215 CONTINUE
4308 DO 1219 K=2,L
4309 DO 1217 I=MYIS,MYIE
4310 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4311 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4312 1217 CONTINUE
4313 1219 CONTINUE
4314 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4315 DO 1221 K=1,L
4316 DO 1221 I=MYIS,MYIE
4317 FAC1(I,K)=ACOMB(10)*TOPM(I,K)
4318 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(10)*TOPPHI(I,K))
4319 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4320 BETACM(10)*TOTVO2(I,K+1)*SKO2D))*CO2SP2(I,K+1)
4321 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4322 1221 CONTINUE
4323 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4324 DO 1253 K=1,L
4325 DO 1253 I=MYIS,MYIE
4326 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,10)* &
4327 (CTMP(I,K+1)-CTMP(I,K))
4328 1253 CONTINUE
4329 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4330 DO 1261 I=MYIS,MYIE
4331 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,10)+ &
4332 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4333 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4334 (SORC(I,LP1,10)-SORC(I,L,10)))
4335 1261 CONTINUE
4336 !
4337 !-----CALCULATION FOR BAND 11 (800-900 CM-1)
4338 !
4339 !
4340 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4341 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4342 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4343 DO 1301 K=1,L
4344 DO 1301 I=MYIS,MYIE
4345 F(I,K)=H44194M2*(APCM(11)*X(I,K)+BPCM(11)*Y(I,K))
4346 FF(I,K)=H44194M2*(ATPCM(11)*X(I,K)+BTPCM(11)*Y(I,K))
4347 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4348 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4349 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4350 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4351 1301 CONTINUE
4352 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4353 ! P(K) (TOPM,TOPPHI)
4354 DO 1315 I=MYIS,MYIE
4355 TOPM(I,1)=PHITMP(I,1)
4356 TOPPHI(I,1)=PSITMP(I,1)
4357 1315 CONTINUE
4358 DO 1319 K=2,L
4359 DO 1317 I=MYIS,MYIE
4360 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4361 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4362 1317 CONTINUE
4363 1319 CONTINUE
4364 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4365 DO 1321 K=1,L
4366 DO 1321 I=MYIS,MYIE
4367 FAC1(I,K)=ACOMB(11)*TOPM(I,K)
4368 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(11)*TOPPHI(I,K))
4369 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4370 BETACM(11)*TOTVO2(I,K+1)*SKO2D))
4371 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4372 1321 CONTINUE
4373 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4374 DO 1353 K=1,L
4375 DO 1353 I=MYIS,MYIE
4376 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,11)* &
4377 (CTMP(I,K+1)-CTMP(I,K))
4378 1353 CONTINUE
4379 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4380 DO 1361 I=MYIS,MYIE
4381 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,11)+ &
4382 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4383 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4384 (SORC(I,LP1,11)-SORC(I,L,11)))
4385 1361 CONTINUE
4386 !
4387 !-----CALCULATION FOR BAND 12 (900-990 CM-1)
4388 !
4389 !
4390 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4391 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4392 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4393 DO 1401 K=1,L
4394 DO 1401 I=MYIS,MYIE
4395 F(I,K)=H44194M2*(APCM(12)*X(I,K)+BPCM(12)*Y(I,K))
4396 FF(I,K)=H44194M2*(ATPCM(12)*X(I,K)+BTPCM(12)*Y(I,K))
4397 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4398 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4399 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4400 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4401 1401 CONTINUE
4402 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4403 ! P(K) (TOPM,TOPPHI)
4404 DO 1415 I=MYIS,MYIE
4405 TOPM(I,1)=PHITMP(I,1)
4406 TOPPHI(I,1)=PSITMP(I,1)
4407 1415 CONTINUE
4408 DO 1419 K=2,L
4409 DO 1417 I=MYIS,MYIE
4410 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4411 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4412 1417 CONTINUE
4413 1419 CONTINUE
4414 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4415 DO 1421 K=1,L
4416 DO 1421 I=MYIS,MYIE
4417 FAC1(I,K)=ACOMB(12)*TOPM(I,K)
4418 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(12)*TOPPHI(I,K))
4419 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4420 BETACM(12)*TOTVO2(I,K+1)*SKO2D))
4421 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4422 1421 CONTINUE
4423 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4424 DO 1453 K=1,L
4425 DO 1453 I=MYIS,MYIE
4426 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,12)* &
4427 (CTMP(I,K+1)-CTMP(I,K))
4428 1453 CONTINUE
4429 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4430 DO 1461 I=MYIS,MYIE
4431 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,12)+ &
4432 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4433 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4434 (SORC(I,LP1,12)-SORC(I,L,12)))
4435 1461 CONTINUE
4436 !
4437 !-----CALCULATION FOR BAND 13 (990-1070 CM-1; INCLUDES O3))
4438 !
4439 !
4440 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4441 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4442 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4443 DO 1501 K=1,L
4444 DO 1501 I=MYIS,MYIE
4445 F(I,K)=H44194M2*(APCM(13)*X(I,K)+BPCM(13)*Y(I,K))
4446 FF(I,K)=H44194M2*(ATPCM(13)*X(I,K)+BTPCM(13)*Y(I,K))
4447 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4448 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4449 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4450 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4451 1501 CONTINUE
4452 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4453 ! P(K) (TOPM,TOPPHI)
4454 DO 1515 I=MYIS,MYIE
4455 TOPM(I,1)=PHITMP(I,1)
4456 TOPPHI(I,1)=PSITMP(I,1)
4457 1515 CONTINUE
4458 DO 1519 K=2,L
4459 DO 1517 I=MYIS,MYIE
4460 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4461 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4462 1517 CONTINUE
4463 1519 CONTINUE
4464 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4465 DO 1521 K=1,L
4466 DO 1521 I=MYIS,MYIE
4467 FAC1(I,K)=ACOMB(13)*TOPM(I,K)
4468 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(13)*TOPPHI(I,K))
4469 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4470 BETACM(13)*TOTVO2(I,K+1)*SKO2D+TO3SPC(I,K)))
4471 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4472 1521 CONTINUE
4473 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4474 DO 1553 K=1,L
4475 DO 1553 I=MYIS,MYIE
4476 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,13)* &
4477 (CTMP(I,K+1)-CTMP(I,K))
4478 1553 CONTINUE
4479 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4480 DO 1561 I=MYIS,MYIE
4481 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,13)+ &
4482 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4483 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4484 (SORC(I,LP1,13)-SORC(I,L,13)))
4485 1561 CONTINUE
4486 !
4487 !-----CALCULATION FOR BAND 14 (1070-1200 CM-1)
4488 !
4489 !
4490 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4491 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4492 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4493 DO 1601 K=1,L
4494 DO 1601 I=MYIS,MYIE
4495 F(I,K)=H44194M2*(APCM(14)*X(I,K)+BPCM(14)*Y(I,K))
4496 FF(I,K)=H44194M2*(ATPCM(14)*X(I,K)+BTPCM(14)*Y(I,K))
4497 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4498 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4499 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4500 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4501 1601 CONTINUE
4502 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4503 ! P(K) (TOPM,TOPPHI)
4504 DO 1615 I=MYIS,MYIE
4505 TOPM(I,1)=PHITMP(I,1)
4506 TOPPHI(I,1)=PSITMP(I,1)
4507 1615 CONTINUE
4508 DO 1619 K=2,L
4509 DO 1617 I=MYIS,MYIE
4510 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4511 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4512 1617 CONTINUE
4513 1619 CONTINUE
4514 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4515 DO 1621 K=1,L
4516 DO 1621 I=MYIS,MYIE
4517 FAC1(I,K)=ACOMB(14)*TOPM(I,K)
4518 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(14)*TOPPHI(I,K))
4519 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4520 BETACM(14)*TOTVO2(I,K+1)*SKO2D))
4521 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4522 1621 CONTINUE
4523 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4524 DO 1653 K=1,L
4525 DO 1653 I=MYIS,MYIE
4526 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,14)* &
4527 (CTMP(I,K+1)-CTMP(I,K))
4528 1653 CONTINUE
4529 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4530 DO 1661 I=MYIS,MYIE
4531 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,14)+ &
4532 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4533 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4534 (SORC(I,LP1,14)-SORC(I,L,14)))
4535 1661 CONTINUE
4536 !
4537 !
4538 ! OBTAIN CTS FLUX AT THE TOP BY INTEGRATION OF HEATING RATES AND
4539 ! USING CTS FLUX AT THE BOTTOM (CURRENT VALUE OF GXCTS). NOTE
4540 ! THAT THE PRESSURE QUANTITIES AND CONVERSION FACTORS HAVE NOT
4541 ! BEEN INCLUDED EITHER IN EXCTS OR IN GXCTS. THESE CANCEL OUT, THUS
4542 ! REDUCING COMPUTATIONS!
4543 DO 1731 K=1,L
4544 DO 1731 I=MYIS,MYIE
4545 GXCTS(I)=GXCTS(I)-EXCTS(I,K)
4546 1731 CONTINUE
4547 !
4548 ! NOW SCALE THE COOLING RATE (EXCTS) BY INCLUDING THE PRESSURE
4549 ! FACTOR (DELP) AND THE CONVERSION FACTOR (RADCON)
4550 DO 1741 K=1,L
4551 DO 1741 I=MYIS,MYIE
4552 EXCTS(I,K)=EXCTS(I,K)*RADCON*DELP(I,K)
4553 1741 CONTINUE
4554 !---THIS IS THE END OF THE EXACT CTS COMPUTATIONS; AT THIS POINT
4555 ! EXCTS HAS ITS APPROPRIATE VALUE.
4556 !
4557 !*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS
4558 ! (CTSO3)
4559 DO 1711 K=1,L
4560 DO 1711 I=MYIS,MYIE
4561 CTMP2(I,K+1)=CO2SP(I,K+1)*CLDFAC(I,K+1,1)
4562 CTMP3(I,K+1)=TO3SP(I,K)*CLDFAC(I,K+1,1)
4563 1711 CONTINUE
4564 DO 1701 K=1,L
4565 DO 1701 I=MYIS,MYIE
4566 CTSO3(I,K)=RADCON*DELP(I,K)* &
4567 (CSOUR(I,K)*(CTMP2(I,K+1)-CTMP2(I,K)) + &
4568 SORC(I,K,13)*(CTMP3(I,K+1)-CTMP3(I,K)))
4569 1701 CONTINUE
4571 END SUBROUTINE SPA88
4572 !----------------------------------------------------------------------
4574 SUBROUTINE E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, &
4575 ! T1,T2,T4, &
4576 H16E1,HP1,H28E1,HAF,TEN, &
4577 ids,ide, jds,jde, kds,kde, &
4578 ims,ime, jms,jme, kms,kme, &
4579 its,ite, jts,jte, kts,kte )
4580 !---------------------------------------------------------------------
4581 IMPLICIT NONE
4582 !----------------------------------------------------------------------
4583 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4584 ims,ime, jms,jme, kms,kme , &
4585 its,ite, jts,jte, kts,kte
4586 INTEGER, INTENT(IN) :: KLEN
4587 REAL, INTENT(IN) :: H16E1,HP1,H28E1,HAF ,TEN
4588 REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: EMISSB
4589 REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,FXOE2,DTE2
4591 ! REAL, INTENT(IN ), DIMENSION(5040) :: T1,T2,T4
4593 REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1) :: EMISS
4595 REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,DT,FYO,DU
4596 INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL
4598 ! REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3
4599 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
4600 ! (T4(1),TABLE3(1,1))
4601 ! EQUIVALENCE (TMP3,DT)
4603 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
4604 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK
4606 L=kte
4607 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
4608 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
4609 LLM2 = LL-2; LLM1=LL-1
4610 MYIS=its; MYIE=ite
4613 !---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE
4614 ! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE
4615 ! THUS GENERATES THE E2 FUNCTION.
4616 !
4617 !---CALCULATIONS FOR VARYING KP (FROM KP=K+1 TO LP1, INCLUDING SPECIAL
4618 ! CASE: RESULTS ARE IN EMISS
4622 DO 132 K=1,LP2-KLEN
4623 DO 132 I=MYIS,MYIE
4624 TMP3(I,K)=LOG10(AVEPHI(I,KLEN+K-1))+H16E1
4625 FYO(I,K)=AINT(TMP3(I,K)*TEN)
4626 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4627 FYO(I,K)=H28E1*FYO(I,K)
4628 IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN+K-1)
4629 EMISS(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
4630 +DTE2(I,KLEN+K-1)*T4(IVAL(I,K))
4631 132 CONTINUE
4632 !---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW
4633 ! BY AVERAGING THE VALUES FOR L AND LP1:
4634 DO 1344 I=MYIS,MYIE
4635 EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1))
4636 1344 CONTINUE
4637 !---NOTE THAT EMISS(I,LP1) IS NOT USEFUL AFTER THIS POINT.
4638 !
4639 !---CALCULATIONS FOR KP=KLEN AND VARYING K; RESULTS ARE IN EMISSB.
4640 ! IN THIS CASE, THE TEMPERATURE INDEX IS UNCHANGED, ALWAYS BEING
4641 ! FXO(I,KLEN-1); THE WATER INDEX CHANGES, BUT IS SYMMETRICAL WITH
4642 ! THAT FOR THE VARYING KP CASE.NOTE THAT THE SPECIAL CASE IS NOT
4643 ! INVOLVED HERE.
4644 ! (FIXED LEVEL) K VARIES FROM (KLEN+1) TO LP1; RESULTS ARE IN
4645 ! EMISSB(I,(KLEN) TO L)
4646 DO 142 K=1,LP1-KLEN
4647 DO 142 I=MYIS,MYIE
4648 DT(I,K)=DTE2(I,KLEN-1)
4649 IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN-1)
4650 142 CONTINUE
4651 !
4652 DO 234 K=1,LP1-KLEN
4653 DO 234 I=MYIS,MYIE
4654 EMISSB(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
4655 +DT(I,K)*T4(IVAL(I,K))
4656 234 CONTINUE
4658 END SUBROUTINE E290
4660 !---------------------------------------------------------------------
4662 SUBROUTINE E2SPEC(EMISS,AVEPHI,FXOSP,DTSP, &
4663 ! T1,T2,T4, &
4664 H16E1,TEN,H28E1,HP1, &
4665 ids,ide, jds,jde, kds,kde, &
4666 ims,ime, jms,jme, kms,kme, &
4667 its,ite, jts,jte, kts,kte )
4668 !---------------------------------------------------------------------
4669 IMPLICIT NONE
4670 !----------------------------------------------------------------------
4671 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4672 ims,ime, jms,jme, kms,kme , &
4673 its,ite, jts,jte, kts,kte
4674 REAL,INTENT(IN ) :: H16E1,TEN,H28E1,HP1
4675 REAL,INTENT(INOUT),DIMENSION(its:ite,kts:kte+1) :: EMISS
4676 REAL,INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI
4677 REAL,INTENT(IN ),DIMENSION(its:ite,2) :: FXOSP,DTSP
4679 ! REAL, INTENT(IN ),DIMENSION(5040) :: T1,T2,T4
4681 ! REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3
4682 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
4683 ! (T4(1),TABLE3(1,1))
4685 INTEGER :: K,I,MYIS,MYIE
4687 REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,FYO,DU
4688 INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL
4690 MYIS=its
4691 MYIE=ite
4693 DO 132 K=1,2
4694 DO 132 I=MYIS,MYIE
4695 TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1
4696 FYO(I,K)=AINT(TMP3(I,K)*TEN)
4697 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4698 IVAL(I,K)=H28E1*FYO(I,K)+FXOSP(I,K)
4699 EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K))+ &
4700 DTSP(I,K)*T4(IVAL(I,K))
4701 132 CONTINUE
4703 END SUBROUTINE E2SPEC
4705 !---------------------------------------------------------------------
4707 ! SUBROUTINE E3V88(EMV,TV,AV,EM3V, &
4708 SUBROUTINE E3V88(EMV,TV,AV, &
4709 TEN,HP1,H28E1,H16E1, &
4710 ids,ide, jds,jde, kds,kde, &
4711 ims,ime, jms,jme, kms,kme, &
4712 its,ite, jts,jte, kts,kte )
4713 !---------------------------------------------------------------------
4714 IMPLICIT NONE
4715 !----------------------------------------------------------------------
4716 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4717 ims,ime, jms,jme, kms,kme , &
4718 its,ite, jts,jte, kts,kte
4719 REAL, INTENT(IN) :: TEN,HP1,H28E1,H16E1
4720 !-----------------------------------------------------------------------
4721 REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte*2+1) :: EMV
4722 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: TV,AV
4723 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
4725 REAL,DIMENSION(its:ite,kts:kte*2+1) ::FXO,TMP3,DT,WW1,WW2,DU,&
4726 FYO
4727 ! REAL, DIMENSION(5040) :: EM3V
4729 ! EQUIVALENCE (EM3V(1),EM3(1,1))
4731 INTEGER,DIMENSION(its:ite,kts:kte*2+1) ::IT
4733 INTEGER :: LLP1,I,K,MYIS,MYIE ,L
4734 L = kte
4735 LLP1 = 2*L + 1
4736 MYIS=its; MYIE=ite
4738 !---THE FOLLOWING LOOP REPLACES A DOUBLE LOOP OVER I (1-IMAX) AND
4739 ! K (1-LLP1)
4741 DO 203 K=1,LLP1
4742 DO 203 I=MYIS,MYIE
4743 FXO(I,K)=AINT(TV(I,K)*HP1)
4744 TMP3(I,K)=LOG10(AV(I,K))+H16E1
4745 DT(I,K)=TV(I,K)-TEN*FXO(I,K)
4746 FYO(I,K)=AINT(TMP3(I,K)*TEN)
4747 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4748 !---OBTAIN INDEX FOR TABLE LOOKUP; THIS VALUE WILL HAVE TO BE
4749 ! DECREMENTED BY 9 TO ACCOUNT FOR TABLE TEMPS STARTING AT 100K.
4750 IT(I,K)=FXO(I,K)+FYO(I,K)*H28E1
4751 WW1(I,K)=TEN-DT(I,K)
4752 WW2(I,K)=HP1-DU(I,K)
4753 EMV(I,K)=WW1(I,K)*WW2(I,K)*EM3V(IT(I,K)-9)+ &
4754 WW2(I,K)*DT(I,K)*EM3V(IT(I,K)-8)+ &
4755 WW1(I,K)*DU(I,K)*EM3V(IT(I,K)+19)+ &
4756 DT(I,K)*DU(I,K)*EM3V(IT(I,K)+20)
4757 203 CONTINUE
4759 END SUBROUTINE E3V88
4760 !-----------------------------------------------------------------------
4762 SUBROUTINE SWR93(FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL, &
4763 DFSWL, &
4764 PRESS,COSZRO,TAUDAR,RH2O,RRCO2,SSOLAR,QO3, &
4765 NCLDS,KTOPSW,KBTMSW,CAMT,CRR,CTT, &
4766 ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, &
4767 ! UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2, &
4768 ABCFF,PWTS, &
4769 H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219, &
4770 HP816,RRAYAV,GINV,CFCO2,CFO3, &
4771 TWO,H235M3,HP26,H129M2,H75826M4,H1036E2, &
4772 H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2, &
4773 H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON, &
4774 ids,ide, jds,jde, kds,kde, &
4775 ims,ime, jms,jme, kms,kme, &
4776 its,ite, jts,jte, kts,kte )
4777 !----------------------------------------------------------------------
4778 IMPLICIT NONE
4779 !----------------------------------------------------------------------
4780 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4781 ims,ime, jms,jme, kms,kme , &
4782 its,ite, jts,jte, kts,kte
4783 REAL,INTENT(IN) :: RRCO2,SSOLAR
4784 REAL,INTENT(IN) :: H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219,HP816,RRAYAV,&
4785 GINV,CFCO2,CFO3
4786 REAL,INTENT(IN) :: TWO,H235M3,HP26,H129M2,H75826M4,H1036E2
4787 REAL,INTENT(IN) :: H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2,H323M4,HM1EZ
4788 REAL,INTENT(IN) :: DIFFCTR,O3DIFCTR,FIFTY,RADCON
4789 !----------------------------------------------------------------------
4790 INTEGER, PARAMETER :: NB=12
4791 REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: PRESS,CAMT
4792 REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte) :: RH2O,QO3
4793 REAL, INTENT(IN ),DIMENSION(its:ite) :: COSZRO,TAUDAR,ALVB,ALVD,ALNB,ALND
4794 INTEGER, INTENT(IN ),DIMENSION(its:ite) :: NCLDS
4795 INTEGER, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) ::KTOPSW,KBTMSW
4796 REAL, INTENT(IN ),DIMENSION(its:ite,NB,kts:kte+1) ::CRR,CTT
4798 REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: &
4799 FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL,DFSWL
4800 REAL, INTENT(OUT),DIMENSION(its:ite) :: GDFVB,GDFVD,GDFNB,GDFND
4801 REAL, INTENT(IN), DIMENSION(NB) :: ABCFF,PWTS
4803 ! REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3
4804 ! REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TUCO2,TUO3,TDO3,TDCO2
4806 REAL, DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3
4807 REAL, DIMENSION(its:ite,kts:kte+1) :: TUCO2,TUO3,TDO3,TDCO2
4809 REAL, DIMENSION(its:ite,kts:kte*2+2) :: TCO2,TO3
4810 REAL, DIMENSION(its:ite,kts:kte+1) :: PP,DP,PR2,DU,DUCO2,DUO3,UD,TTD
4811 REAL, DIMENSION(its:ite,kts:kte+1) :: UDCO2,UDO3,UR,URCO2,URO3,TTU
4812 REAL, DIMENSION(its:ite,kts:kte+1) :: DFN,UFN
4813 REAL, DIMENSION(its:ite,kts:kte+1) :: XAMT,FF,FFCO2,FFO3,CR,CT
4814 REAL, DIMENSION(its:ite,kts:kte+1) :: PPTOP,DPCLD,TTDB1,TTUB1
4815 REAL, DIMENSION(its:ite,kts:kte+1) :: TDCL1,TUCL1,TDCL2,DFNTRN, &
4816 UFNTRN,TCLU,TCLD,ALFA,ALFAU, &
4817 UFNCLU,DFNCLU
4819 REAL, DIMENSION(its:ite,NB) :: DFNTOP
4820 REAL, DIMENSION(its:ite) :: SECZ,TMP1,RRAY,REFL,REFL2,CCMAX
4822 ! EQUIVALENCE &
4823 ! (UDO3,UO3(its,1),DFNCLU), (URO3,UO3(its,kte+2), UFNCLU) &
4824 ! , (UDCO2,UCO2(its,1),TCLD), (URCO2,UCO2(its,kte+2), TCLU) &
4825 ! , (TDO3 ,TO3(its,1),DFNTRN),(TUO3,TO3(its,kte+2), UFNTRN) &
4826 ! , (TDCO2,TCO2(its,1) ),(TUCO2,TCO2(its,kte+2) ) &
4827 ! , (FF , ALFA ), (FFCO2 , ALFAU ), (FFO3 , TTDB1 ) &
4828 ! , (DU , TTUB1), (DUCO2 , TUCL1 ), (DUO3 , TDCL1 ) &
4829 ! , (PR2 , TDCL2)
4831 ! EQUIVALENCE &
4832 ! (UDO3,DFNCLU), (URO3,UFNCLU) &
4833 ! , (UDCO2,TCLD ), (URCO2,TCLU) &
4834 ! , (TDO3 ,DFNTRN),(TUO3,UFNTRN) &
4835 !! , (TDCO2,TCO2(its,1) ),(TUCO2,TCO2(its,kte+2) ) &
4836 ! , (FF , ALFA ), (FFCO2 , ALFAU ), (FFO3 , TTDB1 ) &
4837 ! , (DU , TTUB1), (DUCO2 , TUCL1 ), (DUO3 , TDCL1 ) &
4838 ! , (PR2 , TDCL2)
4840 INTEGER :: K,I,KP,N,IP,MYIS1,KCLDS,NNCLDS,JTOP,KK,J2,J3,J1
4841 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL
4842 REAL :: DENOM,HTEMP,TEMPF,TEMPG
4844 L=kte
4845 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
4846 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
4847 MYIS=its; MYIE=ite
4848 MYIS1=MYIS+1 ! ??
4850 DO 100 I=MYIS,MYIE
4851 SECZ(I) = H35E1/SQRT(H1224E3*COSZRO(I)*COSZRO(I)+ONE)
4852 PP(I,1) = ZERO
4853 PP(I,LP1) = PRESS(I,LP1)
4854 TMP1(I) = ONE/PRESS(I,LP1)
4855 100 CONTINUE
4856 DO 110 K=1,LM1
4857 DO 110 I=MYIS,MYIE
4858 PP(I,K+1) = HAF*(PRESS(I,K+1)+PRESS(I,K))
4859 110 CONTINUE
4860 DO 120 K=1,L
4861 DO 120 I=MYIS,MYIE
4862 DP (I,K) = PP(I,K+1)-PP(I,K)
4863 PR2(I,K) = HAF*(PP(I,K)+PP(I,K+1))
4864 120 CONTINUE
4865 DO 130 K=1,L
4866 DO 130 I=MYIS,MYIE
4867 PR2(I,K) = PR2(I,K)*TMP1(I)
4868 130 CONTINUE
4869 ! CALCULATE ENTERING FLUX AT THE TOP FOR EACH BAND(IN CGS UNITS)
4870 DO 140 N=1,NB
4871 DO 140 IP=MYIS,MYIE
4872 DFNTOP(IP,N) = SSOLAR*H69766E5*COSZRO(IP)*TAUDAR(IP)*PWTS(N)
4873 140 CONTINUE
4874 ! EXECUTE THE LACIS-HANSEN REFLECTIVITY PARAMETERIZATION
4875 ! FOR THE VISIBLE BAND
4876 DO 150 I=MYIS,MYIE
4877 RRAY(I) = HP219/(ONE+HP816*COSZRO(I))
4878 REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVB(I)/ &
4879 (ONE-ALVD(I)*RRAYAV)
4880 150 CONTINUE
4881 DO 155 I=MYIS,MYIE
4882 RRAY(I) = 0.104/(ONE+4.8*COSZRO(I))
4883 REFL2(I)= RRAY(I) + (ONE-RRAY(I))*(ONE-0.093)*ALVB(I)/ &
4884 (ONE-ALVD(I)*0.093)
4885 155 CONTINUE
4886 ! CALCULATE PRESSURE-WEIGHTED OPTICAL PATHS FOR EACH LAYER
4887 ! IN UNITS OF CM-ATM. PRESSURE WEIGHTING IS USING PR2.
4888 ! DU= VALUE FOR H2O;DUCO2 FOR CO2;DUO3 FOR O3.
4889 DO 160 K=1,L
4890 DO 160 I=MYIS,MYIE
4891 DU (I,K) = GINV*RH2O(I,K)*DP(I,K)*PR2(I,K)
4892 DUCO2(I,K) = (RRCO2*GINV*CFCO2)*DP(I,K)*PR2(I,K)
4893 DUO3 (I,K) = (GINV*CFO3)*QO3(I,K)*DP(I,K)
4894 160 CONTINUE
4895 !
4896 ! CALCULATE CLEAR SKY SW FLUX
4897 !
4898 ! OBTAIN THE OPTICAL PATH FROM THE TOP OF THE ATMOSPHERE TO THE
4899 ! FLUX PRESSURE. ANGULAR FACTORS ARE NOW INCLUDED. UD=DOWNWARD
4900 ! PATH FOR H2O,WIGTH UR THE UPWARD PATH FOR H2O. CORRESPONDING
4901 ! QUANTITIES FOR CO2,O3 ARE UDCO2/URCO2 AND UDO3/URO3.
4902 DO 200 IP=MYIS,MYIE
4903 UD (IP,1) = ZERO
4904 UDCO2(IP,1) = ZERO
4905 UDO3 (IP,1) = ZERO
4906 ! SH
4907 UO3 (IP,1) = UDO3 (IP,1)
4908 UCO2 (IP,1) = UDCO2(IP,1)
4910 200 CONTINUE
4911 DO 210 K=2,LP1
4912 DO 210 I=MYIS,MYIE
4913 UD (I,K) = UD (I,K-1)+DU (I,K-1)*SECZ(I)
4914 UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*SECZ(I)
4915 UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*SECZ(I)
4916 ! SH
4917 UO3 (I,K) = UDO3 (I,K)
4918 UCO2 (I,K) = UDCO2(I,K)
4920 210 CONTINUE
4921 DO 220 IP=MYIS,MYIE
4922 UR (IP,LP1) = UD (IP,LP1)
4923 URCO2(IP,LP1) = UDCO2(IP,LP1)
4924 URO3 (IP,LP1) = UDO3 (IP,LP1)
4925 ! SH
4926 UO3 (IP,LP1+LP1) = URO3 (IP,LP1)
4927 UCO2 (IP,LP1+LP1) = URCO2(IP,LP1)
4929 220 CONTINUE
4930 DO 230 K=L,1,-1
4931 DO 230 IP=MYIS,MYIE
4932 UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR
4933 URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR
4934 URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR
4935 ! SH
4936 UO3 (IP,LP1+K) = URO3 (IP,K)
4937 UCO2(IP,LP1+K) = URCO2(IP,K)
4939 230 CONTINUE
4940 ! CALCULATE CO2 ABSORPTIONS . THEY WILL BE USED IN NEAR INFRARED
4941 ! BANDS.SINCE THE ABSORPTION AMOUNT IS GIVEN (IN THE FORMULA USED
4942 ! BELOW, DERIVED FROM SASAMORI) IN TERMS OF THE TOTAL SOLAR FLUX,
4943 ! AND THE ABSORPTION IS ONLY INCLUDED IN THE NEAR IR (50 PERCENT
4944 ! OF THE SOLAR SPECTRUM), THE ABSORPTIONS ARE MULTIPLIED BY 2.
4945 ! SINCE CODE ACTUALLY REQUIRES TRANSMISSIONS, THESE ARE THE
4946 ! VALUES ACTUALLY STORED IN TCO2.
4947 DO 240 K=1,LL
4948 DO 240 I=MYIS,MYIE
4949 TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) &
4950 -H75826M4)
4951 240 CONTINUE
4953 ! SH
4954 DO 241 K=1,L
4955 DO 241 I=MYIS,MYIE
4956 TDCO2(I,K+1)=TCO2(I,K+1)
4957 241 CONTINUE
4958 DO 242 K=1,L
4959 DO 242 I=MYIS,MYIE
4960 TUCO2(I,K)=TCO2(I,LP1+K)
4961 242 CONTINUE
4963 ! NOW CALCULATE OZONE ABSORPTIONS. THESE WILL BE USED IN
4964 ! THE VISIBLE BAND.JUST AS IN THE CO2 CASE, SINCE THIS BAND IS
4965 ! 50 PERCENT OF THE SOLAR SPECTRUM,THE ABSORPTIONS ARE MULTIPLIED
4966 ! BY 2. THE TRANSMISSIONS ARE STORED IN TO3.
4967 HTEMP = H1036E2*H1036E2*H1036E2
4968 DO 250 K=1,LL
4969 DO 250 I=MYIS,MYIE
4970 TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* &
4971 (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ &
4972 H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ &
4973 H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1))))
4974 250 CONTINUE
4976 ! SH
4977 DO 251 K=1,L
4978 DO 251 I=MYIS,MYIE
4979 TDO3(I,K+1)=TO3(I,K+1)
4980 251 CONTINUE
4981 DO 252 K=1,L
4982 DO 252 I=MYIS,MYIE
4983 TUO3(I,K)=TO3(I,LP1+K)
4984 252 CONTINUE
4987 ! START FREQUENCY LOOP (ON N) HERE
4988 !
4989 !--- BAND 1 (VISIBLE) INCLUDES O3 AND H2O ABSORPTION
4990 DO 260 K=1,L
4991 DO 260 I=MYIS,MYIE
4992 TTD(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1)))
4993 TTU(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K)))
4994 DFN(I,K+1) = TTD(I,K+1)*TDO3(I,K+1)
4995 UFN(I,K) = TTU(I,K)*TUO3(I,K)
4996 260 CONTINUE
4997 DO 270 I=MYIS,MYIE
4998 DFN(I,1) = ONE
4999 UFN(I,LP1) = DFN(I,LP1)
5000 270 CONTINUE
5001 ! SCALE VISIBLE BAND FLUXES BY SOLAR FLUX AT THE TOP OF THE
5002 ! ATMOSPHERE (DFNTOP(I,1))
5003 ! DFSW/UFSW WILL BE THE FLUXES, SUMMED OVER ALL BANDS
5004 DO 280 K=1,LP1
5005 DO 280 I=MYIS,MYIE
5006 DFSWL(I,K) = DFN(I,K)*DFNTOP(I,1)
5007 UFSWL(I,K) = REFL(I)*UFN(I,K)*DFNTOP(I,1)
5008 280 CONTINUE
5009 DO 285 I=MYIS,MYIE
5010 GDFVB(I) = DFSWL(I,LP1)*EXP(-0.15746*SECZ(I))
5011 GDFVD(I) = ((ONE-REFL2(I))*DFSWL(I,LP1) - &
5012 (ONE-ALVB(I)) *GDFVB(I)) / (ONE-ALVD(I))
5013 GDFNB(I) = ZERO
5014 GDFND(I) = ZERO
5015 285 CONTINUE
5016 !---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME
5017 ! AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND
5018 ! TRANSMISSION COEFFICIENTS (OBTAINED BELOW) ARE DIFFERENT, AS
5019 ! RAYLEIGH SCATTERING NEED NOT BE CONSIDERED.
5020 DO 350 N=2,NB
5021 IF (N.EQ.2) THEN
5022 ! THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO
5023 ! THAT OF BAND 1 (SAVED AS TTD,TTU)
5024 !--- BAND 2-9 (NEAR-IR) INCLUDES O3, CO2 AND H2O ABSORPTION
5025 DO 290 K=1,L
5026 DO 290 I=MYIS,MYIE
5027 DFN(I,K+1) = TTD(I,K+1)*TDCO2(I,K+1)
5028 UFN(I,K) = TTU(I,K)*TUCO2(I,K)
5029 290 CONTINUE
5030 ELSE
5031 ! CALCULATE WATER VAPOR TRANSMISSION FUNCTIONS FOR NEAR INFRARED
5032 ! BANDS. INCLUDE CO2 TRANSMISSION (TDCO2/TUCO2), WHICH
5033 ! IS THE SAME FOR ALL INFRARED BANDS.
5034 DO 300 K=1,L
5035 DO 300 I=MYIS,MYIE
5036 DFN(I,K+1)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,K+1))) &
5037 *TDCO2(I,K+1)
5038 UFN(I,K)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,K))) &
5039 *TUCO2(I,K)
5040 300 CONTINUE
5041 ENDIF
5042 !---AT THIS POINT,INCLUDE DFN(1),UFN(LP1), NOTING THAT DFN(1)=1 FOR
5043 ! ALL BANDS, AND THAT UFN(LP1)=DFN(LP1) FOR ALL BANDS.
5044 DO 310 I=MYIS,MYIE
5045 DFN(I,1) = ONE
5046 UFN(I,LP1) = DFN(I,LP1)
5047 310 CONTINUE
5048 ! SCALE THE PREVIOUSLY COMPUTED FLUXES BY THE FLUX AT THE TOP
5049 ! AND SUM OVER BANDS
5050 DO 320 K=1,LP1
5051 DO 320 I=MYIS,MYIE
5052 DFSWL(I,K) = DFSWL(I,K) + DFN(I,K)*DFNTOP(I,N)
5053 UFSWL(I,K) = UFSWL(I,K) + ALNB(I)*UFN(I,K)*DFNTOP(I,N)
5054 320 CONTINUE
5055 DO 330 I=MYIS,MYIE
5056 GDFNB(I) = GDFNB(I) + DFN(I,LP1)*DFNTOP(I,N)
5057 330 CONTINUE
5058 350 CONTINUE
5059 DO 360 K=1,LP1
5060 DO 360 I=MYIS,MYIE
5061 FSWL(I,K) = UFSWL(I,K)-DFSWL(I,K)
5062 360 CONTINUE
5063 DO 370 K=1,L
5064 DO 370 I=MYIS,MYIE
5065 HSWL(I,K)=RADCON*(FSWL(I,K+1)-FSWL(I,K))/DP(I,K)
5066 370 CONTINUE
5067 !
5068 !---END OF FREQUENCY LOOP (OVER N)
5069 !
5070 ! CALCULATE CLOUDY SKY SW FLUX
5071 !
5072 KCLDS=NCLDS(MYIS)
5073 DO 400 I=MYIS1,MYIE
5074 KCLDS=MAX(NCLDS(I),KCLDS)
5075 400 CONTINUE
5076 DO 410 K=1,LP1
5077 DO 410 I=MYIS,MYIE
5078 DFSWC(I,K) = DFSWL(I,K)
5079 UFSWC(I,K) = UFSWL(I,K)
5080 FSWC (I,K) = FSWL (I,K)
5081 410 CONTINUE
5082 DO 420 K=1,L
5083 DO 420 I=MYIS,MYIE
5084 HSWC(I,K) = HSWL(I,K)
5085 420 CONTINUE
5086 !*******************************************************************
5087 IF (KCLDS .EQ. 0) RETURN
5088 !*******************************************************************
5089 DO 430 K=1,LP1
5090 DO 430 I=MYIS,MYIE
5091 XAMT(I,K) = CAMT(I,K)
5092 430 CONTINUE
5093 DO 470 I=MYIS,MYIE
5094 NNCLDS = NCLDS(I)
5095 CCMAX(I) = ZERO
5096 IF (NNCLDS .LE. 0) GO TO 470
5097 CCMAX(I) = ONE
5098 DO 450 K=1,NNCLDS
5099 CCMAX(I) = CCMAX(I) * (ONE - CAMT(I,K+1))
5100 450 CONTINUE
5101 CCMAX(I) = ONE - CCMAX(I)
5102 IF (CCMAX(I) .GT. ZERO) THEN
5103 DO 460 K=1,NNCLDS
5104 XAMT(I,K+1) = CAMT(I,K+1)/CCMAX(I)
5105 460 CONTINUE
5106 END IF
5107 470 CONTINUE
5108 DO 480 K=1,LP1
5109 DO 480 I=MYIS,MYIE
5110 FF (I,K) = DIFFCTR
5111 FFCO2(I,K) = DIFFCTR
5112 FFO3 (I,K) = O3DIFCTR
5113 480 CONTINUE
5114 DO 490 IP=MYIS,MYIE
5115 JTOP = KTOPSW(IP,NCLDS(IP)+1)
5116 DO 490 K=1,JTOP
5117 FF (IP,K) = SECZ(IP)
5118 FFCO2(IP,K) = SECZ(IP)
5119 FFO3 (IP,K) = SECZ(IP)
5120 490 CONTINUE
5121 DO 500 I=MYIS,MYIE
5122 RRAY(I) = HP219/(ONE+HP816*COSZRO(I))
5123 REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVD(I)/ &
5124 (ONE-ALVD(I)*RRAYAV)
5125 500 CONTINUE
5126 DO 510 IP=MYIS,MYIE
5127 UD (IP,1) = ZERO
5128 UDCO2(IP,1) = ZERO
5129 UDO3 (IP,1) = ZERO
5130 ! SH
5131 UO3 (IP,1) = UDO3 (IP,1)
5132 UCO2 (IP,1) = UDCO2(IP,1)
5134 510 CONTINUE
5135 DO 520 K=2,LP1
5136 DO 520 I=MYIS,MYIE
5137 UD (I,K) = UD (I,K-1)+DU (I,K-1)*FF (I,K)
5138 UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*FFCO2(I,K)
5139 UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*FFO3 (I,K)
5140 ! SH
5141 UO3 (I,K) = UDO3 (I,K)
5142 UCO2(I,K) = UDCO2(I,K)
5144 520 CONTINUE
5145 DO 530 IP=MYIS,MYIE
5146 UR (IP,LP1) = UD (IP,LP1)
5147 URCO2(IP,LP1) = UDCO2(IP,LP1)
5148 URO3 (IP,LP1) = UDO3 (IP,LP1)
5149 ! SH
5150 UO3 (IP,LP1+LP1) = URO3 (IP,LP1)
5151 UCO2 (IP,LP1+LP1) = URCO2(IP,LP1)
5153 530 CONTINUE
5154 DO 540 K=L,1,-1
5155 DO 540 IP=MYIS,MYIE
5156 UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR
5157 URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR
5158 URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR
5159 ! SH
5160 UO3 (IP,LP1+K) = URO3 (IP,K)
5161 UCO2(IP,LP1+K) = URCO2(IP,K)
5163 540 CONTINUE
5164 DO 550 K=1,LL
5165 DO 550 I=MYIS,MYIE
5166 TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) &
5167 -H75826M4)
5168 550 CONTINUE
5169 ! SH
5170 DO 551 K=1,L
5171 DO 551 I=MYIS,MYIE
5172 TDCO2(I,K+1)=TCO2(I,K+1)
5173 551 CONTINUE
5174 DO 552 K=1,L
5175 DO 552 I=MYIS,MYIE
5176 TUCO2(I,K)=TCO2(I,LP1+K)
5177 552 CONTINUE
5179 DO 560 K=1,LL
5180 DO 560 I=MYIS,MYIE
5181 TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* &
5182 (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ &
5183 H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ &
5184 H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1))))
5185 560 CONTINUE
5186 ! SH
5187 DO 561 K=1,L
5188 DO 561 I=MYIS,MYIE
5189 TDO3(I,K+1)=TO3(I,K+1)
5190 561 CONTINUE
5191 DO 562 K=1,L
5192 DO 562 I=MYIS,MYIE
5193 TUO3(I,K)=TO3(I,LP1+K)
5194 562 CONTINUE
5196 !********************************************************************
5197 !---THE FIRST CLOUD IS THE GROUND; ITS PROPERTIES ARE GIVEN
5198 ! BY REFL (THE TRANSMISSION (0) IS IRRELEVANT FOR NOW!).
5199 !********************************************************************
5200 DO 570 I=MYIS,MYIE
5201 CR(I,1) = REFL(I)
5202 570 CONTINUE
5203 !***OBTAIN CLOUD REFLECTION AND TRANSMISSION COEFFICIENTS FOR
5204 ! REMAINING CLOUDS (IF ANY) IN THE VISIBLE BAND
5205 !---THE MAXIMUM NO OF CLOUDS IN THE ROW (KCLDS) IS USED. THIS CREATES
5206 ! EXTRA WORK (MAY BE REMOVED IN A SUBSEQUENT UPDATE).
5207 DO 581 I=MYIS,MYIE
5208 KCLDS=NCLDS(I)
5209 IF(KCLDS.EQ.0) GO TO 581
5210 DO 580 KK=2,KCLDS+1
5211 CR(I,KK) = CRR(I,1,KK)*XAMT(I,KK)
5212 CT(I,KK) = ONE - (ONE-CTT(I,1,KK))*XAMT(I,KK)
5213 580 CONTINUE
5214 581 CONTINUE
5215 !---OBTAIN THE PRESSURE AT THE TOP,BOTTOM AND THE THICKNESS OF
5216 ! "THICK" CLOUDS (THOSE AT LEAST 2 LAYERS THICK). THIS IS USED
5217 ! LATER IS OBTAINING FLUXES INSIDE THE THICK CLOUDS, FOR ALL
5218 ! FREQUENCY BANDS.
5219 DO 591 I=MYIS,MYIE
5220 KCLDS=NCLDS(I)
5221 IF(KCLDS.EQ.0) GO TO 591
5222 DO 590 KK=1,KCLDS
5223 IF ((KBTMSW(I,KK+1)-1).GT.KTOPSW(I,KK+1)) THEN
5224 PPTOP(I,KK)=PP(I,KTOPSW(I,KK+1))
5225 DPCLD(I,KK)=ONE/(PPTOP(I,KK)-PP(I,KBTMSW(I,KK+1)))
5226 ENDIF
5227 590 CONTINUE
5228 591 CONTINUE
5229 DO 600 K=1,L
5230 DO 600 I=MYIS,MYIE
5231 TTDB1(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1)))
5232 TTUB1(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K)))
5233 TTD (I,K+1) = TTDB1(I,K+1)*TDO3(I,K+1)
5234 TTU (I,K) = TTUB1(I,K)*TUO3(I,K)
5235 600 CONTINUE
5236 DO 610 I=MYIS,MYIE
5237 TTD(I,1) = ONE
5238 TTU(I,LP1) = TTD(I,LP1)
5239 610 CONTINUE
5240 !***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT
5241 ! TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR
5242 ! EACH BAND N. THE REQUIRED QUANTITIES ARE:
5243 ! TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5244 ! TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5245 ! TTD(I,KBTMSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5246 ! AND INVERSES OF THE FIRST TWO. THE ABOVE QUANTITIES ARE
5247 ! STORED IN TDCL1,TUCL1,TDCL2, AND DFNTRN,UFNTRN, RESPECTIVELY,
5248 ! AS THEY HAVE MULTIPLE USE IN THE PGM.
5249 !---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN:
5250 DO 620 I=MYIS,MYIE
5251 TDCL1 (I,1) = TTD(I,LP1)
5252 TUCL1 (I,1) = TTU(I,LP1)
5253 TDCL2 (I,1) = TDCL1(I,1)
5254 DFNTRN(I,1) = ONE/TDCL1(I,1)
5255 UFNTRN(I,1) = DFNTRN(I,1)
5256 620 CONTINUE
5257 DO 631 I=MYIS,MYIE
5258 KCLDS=NCLDS(I)
5259 IF(KCLDS.EQ.0) GO TO 631
5260 DO 630 KK=2,KCLDS+1
5261 TDCL1(I,KK) = TTD(I,KTOPSW(I,KK))
5262 TUCL1(I,KK) = TTU(I,KTOPSW(I,KK))
5263 TDCL2(I,KK) = TTD(I,KBTMSW(I,KK))
5264 630 CONTINUE
5265 631 CONTINUE
5266 !---COMPUTE INVERSES
5267 DO 641 I=MYIS,MYIE
5268 KCLDS=NCLDS(I)
5269 IF(KCLDS.EQ.0) GO TO 641
5270 ! SH
5271 DO 640 KK=2,KCLDS+1
5272 DFNTRN(I,KK) = ONE/TDCL1(I,KK)
5273 UFNTRN(I,KK) = ONE/TUCL1(I,KK)
5274 640 CONTINUE
5275 641 CONTINUE
5276 !---COMPUTE THE TRANSMISSIVITY FROM THE TOP OF CLOUD (K+1) TO THE
5277 ! TOP OF CLOUD (K). THE CLOUD TRANSMISSION (CT) IS INCLUDED. THIS
5278 ! QUANTITY IS CALLED TCLU (INDEX K). ALSO, OBTAIN THE TRANSMISSIVITY
5279 ! FROM THE BOTTOM OF CLOUD (K+1) TO THE TOP OF CLOUD (K)(A PATH
5280 ! ENTIRELY OUTSIDE CLOUDS). THIS QUANTITY IS CALLED TCLD (INDEX K).
5281 DO 651 I=MYIS,MYIE
5282 KCLDS=NCLDS(I)
5283 IF(KCLDS.EQ.0) GO TO 651
5284 DO 650 KK=1,KCLDS
5285 TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1)
5286 TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1)
5287 650 CONTINUE
5288 651 CONTINUE
5289 !***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION
5290 ! COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE
5291 ! FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW
5292 ! THE CLOUD IN QUESTION.
5293 !---ALFAU IS ALFA WITHOUT THE REFLECTION OF THE CLOUD IN QUESTION
5294 DO 660 I=MYIS,MYIE
5295 KCLDS=NCLDS(I)
5296 IF(KCLDS.EQ.0) GO TO 660
5297 ALFA (I,1)=CR(I,1)
5298 ALFAU(I,1)=ZERO
5299 660 CONTINUE
5300 !---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER!
5301 DO 671 I=MYIS,MYIE
5302 KCLDS=NCLDS(I)
5303 IF(KCLDS.EQ.0) GO TO 671
5304 DO 670 KK=2,KCLDS+1
5305 ALFAU(I,KK)= TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/ &
5306 (ONE - TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK))
5307 ALFA (I,KK)= ALFAU(I,KK)+CR(I,KK)
5308 670 CONTINUE
5309 671 CONTINUE
5310 ! CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS
5311 !---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP
5312 ! OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX
5313 ! AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IN THE FIRST
5314 ! CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE
5315 ! HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU
5316 ! EQUALS ALFA. THIS IS ALSO CORRECT.
5317 DO 680 I=MYIS,MYIE
5318 KCLDS=NCLDS(I)
5319 IF(KCLDS.EQ.0) GO TO 680
5320 UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1)
5321 DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1)
5322 680 CONTINUE
5323 !---THIS CALCULATION IS THE REVERSE OF THE RECURSION RELATION USED
5324 ! ABOVE
5325 DO 691 I=MYIS,MYIE
5326 KCLDS=NCLDS(I)
5327 IF(KCLDS.EQ.0) GO TO 691
5328 DO 690 KK=KCLDS,1,-1
5329 UFNCLU(I,KK) = UFNCLU(I,KK+1)*ALFAU(I,KK+1)/(ALFA(I,KK+1)* &
5330 TCLU(I,KK))
5331 DFNCLU(I,KK) = UFNCLU(I,KK)/ALFA(I,KK)
5332 690 CONTINUE
5333 691 CONTINUE
5334 DO 701 I=MYIS,MYIE
5335 KCLDS=NCLDS(I)
5336 IF(KCLDS.EQ.0) GO TO 701
5337 DO 700 KK=1,KCLDS+1
5338 UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK)
5339 DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK)
5340 700 CONTINUE
5341 701 CONTINUE
5342 !---CASE OF KK=1( FROM THE GROUND TO THE BOTTOM OF THE LOWEST CLOUD)
5343 DO 720 I=MYIS,MYIE
5344 KCLDS=NCLDS(I)
5345 IF(KCLDS.EQ.0) GO TO 720
5346 J2=KBTMSW(I,2)
5347 DO 710 K=J2,LP1
5348 UFN(I,K) = UFNTRN(I,1)*TTU(I,K)
5349 DFN(I,K) = DFNTRN(I,1)*TTD(I,K)
5350 710 CONTINUE
5351 720 CONTINUE
5352 !---REMAINING LEVELS (IF ANY!)
5353 DO 760 I=MYIS,MYIE
5354 KCLDS=NCLDS(I)
5355 IF(KCLDS.EQ.0) GO TO 760
5356 DO 755 KK=2,KCLDS+1
5357 J1=KTOPSW(I,KK)
5358 J2=KBTMSW(I,KK+1)
5359 IF (J1.EQ.1) GO TO 755
5360 DO 730 K=J2,J1
5361 UFN(I,K) = UFNTRN(I,KK)*TTU(I,K)
5362 DFN(I,K) = DFNTRN(I,KK)*TTD(I,K)
5363 730 CONTINUE
5364 !---FOR THE THICK CLOUDS, THE FLUX DIVERGENCE THROUGH THE CLOUD
5365 ! LAYER IS ASSUMED TO BE CONSTANT. THE FLUX DERIVATIVE IS GIVEN BY
5366 ! TEMPF (FOR THE UPWARD FLUX) AND TEMPG (FOR THE DOWNWARD FLUX).
5367 J3=KBTMSW(I,KK)
5368 IF ((J3-J1).GT.1) THEN
5369 TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1)
5370 TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1)
5371 DO 740 K=J1+1,J3-1
5372 UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1))
5373 DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1))
5374 740 CONTINUE
5375 ENDIF
5376 755 CONTINUE
5377 760 CONTINUE
5378 DO 770 I=MYIS,MYIE
5379 KCLDS=NCLDS(I)
5380 IF(KCLDS.EQ.0) GO TO 770
5381 DO 771 K=1,LP1
5382 DFSWC(I,K) = DFN(I,K)*DFNTOP(I,1)
5383 UFSWC(I,K) = UFN(I,K)*DFNTOP(I,1)
5384 771 CONTINUE
5385 770 CONTINUE
5386 DO 780 I=MYIS,MYIE
5387 KCLDS=NCLDS(I)
5388 IF(KCLDS.EQ.0) GO TO 780
5389 TMP1(I) = ONE - CCMAX(I)
5390 GDFVB(I) = TMP1(I)*GDFVB(I)
5391 GDFNB(I) = TMP1(I)*GDFNB(I)
5392 GDFVD(I) = TMP1(I)*GDFVD(I) + CCMAX(I)*DFSWC(I,LP1)
5393 780 CONTINUE
5394 !---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME
5395 ! AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND
5396 ! TRANSMISSION COEFFICIENTS ARE DIFFERENT, AS
5397 ! RAYLEIGH SCATTERING NEED NOT BE CONSIDERED.
5398 !
5399 DO 1000 N=2,NB
5400 !YH93
5401 DO 791 I=MYIS,MYIE
5402 KCLDS=NCLDS(I)
5403 IF(KCLDS.EQ.0) GO TO 791
5404 DO 790 K=1,KCLDS+1
5405 CR(I,K) = CRR(I,N,K)*XAMT(I,K)
5406 CT(I,K) = ONE - (ONE-CTT(I,N,K))*XAMT(I,K)
5407 790 CONTINUE
5408 791 CONTINUE
5409 !YH93
5410 IF (N.EQ.2) THEN
5411 ! THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO
5412 ! THAT OF BAND 1 (SAVED AS TTDB1,TTUB1)
5413 DO 800 I=MYIS,MYIE
5414 KCLDS=NCLDS(I)
5415 IF(KCLDS.EQ.0) GO TO 800
5416 DO 801 KK=2,LP1
5417 TTD(I,KK) = TTDB1(I,KK)*TDCO2(I,KK)
5418 801 CONTINUE
5419 DO 802 KK=1,L
5420 TTU(I,KK) = TTUB1(I,KK)*TUCO2(I,KK)
5421 802 CONTINUE
5422 800 CONTINUE
5423 ELSE
5424 DO 810 I=MYIS,MYIE
5425 KCLDS=NCLDS(I)
5426 IF(KCLDS.EQ.0) GO TO 810
5427 DO 811 KK=2,LP1
5428 TTD(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,KK))) &
5429 * TDCO2(I,KK)
5430 811 CONTINUE
5431 DO 812 KK=1,L
5432 TTU(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,KK))) &
5433 * TUCO2(I,KK)
5434 812 CONTINUE
5435 810 CONTINUE
5436 ENDIF
5437 !---AT THIS POINT,INCLUDE TTD(1),TTU(LP1), NOTING THAT TTD(1)=1 FOR
5438 ! ALL BANDS, AND THAT TTU(LP1)=TTD(LP1) FOR ALL BANDS.
5439 DO 820 I=MYIS,MYIE
5440 KCLDS=NCLDS(I)
5441 IF(KCLDS.EQ.0) GO TO 820
5442 TTU(I,LP1) = TTD(I,LP1)
5443 TTD(I,1) = ONE
5444 820 CONTINUE
5445 !***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT
5446 ! TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR
5447 ! EACH BAND N. THE REQUIRED QUANTITIES ARE:
5448 ! TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5449 ! TTD(I,KBTMSW(I,K),N) K RUNS FROM 2 TO NCLDS(I)+1:
5450 ! TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5451 ! AND INVERSES OF THE ABOVE. THE ABOVE QUANTITIES ARE STORED
5452 ! IN TDCL1,TDCL2,TUCL1,AND DFNTRN,UFNTRN,RESPECTIVELY, AS
5453 ! THEY HAVE MULTIPLE USE IN THE PGM.
5454 !---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN:
5455 DO 830 I=MYIS,MYIE
5456 KCLDS=NCLDS(I)
5457 IF(KCLDS.EQ.0) GO TO 830
5458 TDCL1 (I,1) = TTD(I,LP1)
5459 TUCL1 (I,1) = TTU(I,LP1)
5460 TDCL2 (I,1) = TDCL1(I,1)
5461 DFNTRN(I,1) = ONE/TDCL1(I,1)
5462 UFNTRN(I,1) = DFNTRN(I,1)
5463 830 CONTINUE
5464 DO 841 I=MYIS,MYIE
5465 KCLDS=NCLDS(I)
5466 IF(KCLDS.EQ.0) GO TO 841
5467 DO 840 KK=2,KCLDS+1
5468 TDCL1(I,KK) = TTD(I,KTOPSW(I,KK))
5469 TUCL1(I,KK) = TTU(I,KTOPSW(I,KK))
5470 TDCL2(I,KK) = TTD(I,KBTMSW(I,KK))
5471 840 CONTINUE
5472 841 CONTINUE
5473 DO 851 I=MYIS,MYIE
5474 KCLDS=NCLDS(I)
5475 IF(KCLDS.EQ.0) GO TO 851
5476 DO 850 KK=2,KCLDS+1
5477 DFNTRN(I,KK) = ONE/TDCL1(I,KK)
5478 UFNTRN(I,KK) = ONE/TUCL1(I,KK)
5479 850 CONTINUE
5480 851 CONTINUE
5481 DO 861 I=MYIS,MYIE
5482 KCLDS=NCLDS(I)
5483 IF(KCLDS.EQ.0) GO TO 861
5484 DO 860 KK=1,KCLDS
5485 TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1)
5486 TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1)
5487 860 CONTINUE
5488 861 CONTINUE
5489 !***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION
5490 ! COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE
5491 ! FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW
5492 ! THE CLOUD IN QUESTION.
5493 DO 870 I=MYIS,MYIE
5494 KCLDS=NCLDS(I)
5495 IF(KCLDS.EQ.0) GO TO 870
5496 ALFA (I,1) = CR(I,1)
5497 ALFAU(I,1) = ZERO
5498 870 CONTINUE
5499 !---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER!
5500 DO 881 I=MYIS,MYIE
5501 KCLDS=NCLDS(I)
5502 IF(KCLDS.EQ.0) GO TO 881
5503 DO 880 KK=2,KCLDS+1
5504 ALFAU(I,KK) = TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/(ONE - &
5505 TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK))
5506 ALFA (I,KK) = ALFAU(I,KK)+CR(I,KK)
5507 880 CONTINUE
5508 881 CONTINUE
5509 ! CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS
5510 !---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP
5511 ! OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX
5512 ! AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IT THE FIRST
5513 ! CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE
5514 ! HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU
5515 ! EQUALS ALFA. THIS IS ALSO CORRECT.
5516 DO 890 I=MYIS,MYIE
5517 KCLDS=NCLDS(I)
5518 IF(KCLDS.EQ.0) GO TO 890
5519 UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1)
5520 DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1)
5521 890 CONTINUE
5522 DO 901 I=MYIS,MYIE
5523 KCLDS=NCLDS(I)
5524 IF(KCLDS.EQ.0) GO TO 901
5525 DO 900 KK=KCLDS,1,-1
5526 !
5527 !*** ACCOUNT FOR UNREALISTICALLY SMALL CLOUD AMOUNT
5528 !
5529 DENOM=ALFA(I,KK+1)*TCLU(I,KK)
5530 IF(DENOM.GT.RTHRESH)THEN
5531 UFNCLU(I,KK)=UFNCLU(I,KK+1)*ALFAU(I,KK+1)/DENOM
5532 ELSE
5533 UFNCLU(I,KK)=0.
5534 ENDIF
5535 IF(ALFA(I,KK).GT.RTHRESH)THEN
5536 DFNCLU(I,KK)=UFNCLU(I,KK)/ALFA(I,KK)
5537 ELSE
5538 DFNCLU(I,KK)=0.
5539 ENDIF
5540 900 CONTINUE
5541 901 CONTINUE
5542 ! NOW OBTAIN DFN AND UFN FOR LEVELS BETWEEN THE CLOUDS
5543 DO 911 I=MYIS,MYIE
5544 KCLDS=NCLDS(I)
5545 IF(KCLDS.EQ.0) GO TO 911
5546 DO 910 KK=1,KCLDS+1
5547 UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK)
5548 DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK)
5549 910 CONTINUE
5550 911 CONTINUE
5551 DO 930 I=MYIS,MYIE
5552 KCLDS=NCLDS(I)
5553 IF(KCLDS.EQ.0) GO TO 930
5554 J2=KBTMSW(I,2)
5555 DO 920 K=J2,LP1
5556 UFN(I,K) = UFNTRN(I,1)*TTU(I,K)
5557 DFN(I,K) = DFNTRN(I,1)*TTD(I,K)
5558 920 CONTINUE
5559 930 CONTINUE
5560 DO 970 I=MYIS,MYIE
5561 KCLDS=NCLDS(I)
5562 IF(KCLDS.EQ.0) GO TO 970
5563 DO 965 KK=2,KCLDS+1
5564 J1 = KTOPSW(I,KK)
5565 J2 = KBTMSW(I,KK+1)
5566 IF (J1.EQ.1) GO TO 965
5567 DO 940 K=J2,J1
5568 UFN(I,K) = UFNTRN(I,KK)*TTU(I,K)
5569 DFN(I,K) = DFNTRN(I,KK)*TTD(I,K)
5570 940 CONTINUE
5571 J3 = KBTMSW(I,KK)
5572 IF ((J3-J1).GT.1) THEN
5573 TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1)
5574 TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1)
5575 DO 950 K=J1+1,J3-1
5576 UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1))
5577 DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1))
5578 950 CONTINUE
5579 ENDIF
5580 965 CONTINUE
5581 970 CONTINUE
5582 DO 980 I=MYIS,MYIE
5583 KCLDS=NCLDS(I)
5584 IF(KCLDS.EQ.0) GO TO 980
5585 DO 981 K=1,LP1
5586 DFSWC(I,K) = DFSWC(I,K) + DFN(I,K)*DFNTOP(I,N)
5587 UFSWC(I,K) = UFSWC(I,K) + UFN(I,K)*DFNTOP(I,N)
5588 981 CONTINUE
5589 980 CONTINUE
5590 DO 990 I=MYIS,MYIE
5591 KCLDS=NCLDS(I)
5592 IF(KCLDS.EQ.0) GO TO 990
5593 GDFND(I) = GDFND(I) + CCMAX(I)*DFN(I,LP1)*DFNTOP(I,N)
5594 990 CONTINUE
5595 1000 CONTINUE
5596 DO 1100 I=MYIS,MYIE
5597 KCLDS=NCLDS(I)
5598 IF(KCLDS.EQ.0) GO TO 1100
5599 DO 1101 K=1,LP1
5600 DFSWC(I,K) = TMP1(I)*DFSWL(I,K) + CCMAX(I)*DFSWC(I,K)
5601 UFSWC(I,K) = TMP1(I)*UFSWL(I,K) + CCMAX(I)*UFSWC(I,K)
5602 1101 CONTINUE
5603 1100 CONTINUE
5604 DO 1200 I=MYIS,MYIE
5605 KCLDS=NCLDS(I)
5606 IF(KCLDS.EQ.0) GO TO 1200
5607 DO 1201 KK=1,LP1
5608 FSWC(I,KK) = UFSWC(I,KK)-DFSWC(I,KK)
5609 1201 CONTINUE
5610 1200 CONTINUE
5611 DO 1250 I=MYIS,MYIE
5612 KCLDS=NCLDS(I)
5613 IF(KCLDS.EQ.0) GO TO 1250
5614 DO 1251 KK=1, L
5615 HSWC(I,KK) = RADCON*(FSWC(I,KK+1)-FSWC(I,KK))/DP(I,KK)
5616 1251 CONTINUE
5617 1250 CONTINUE
5619 END SUBROUTINE SWR93
5620 !-----------------------------------------------------------------------
5622 SUBROUTINE RADFS &
5624 ! *****************************************************************
5625 ! * *
5626 ! * THE INTERNAL DRIVE FOR GFDL RADIATION *
5627 ! * THIS SUBROUTINE WAS FROM Y.H AND K.A.C (1993) *
5628 ! * AND MODIFIED BY Q. ZHAO FOR USE IN THE ETA MODEL *
5629 ! * NOV. 18, 1993 *
5630 ! * *
5631 ! * UPDATE: THIS SUBROUTINE WAS MODIFIED TO USE CLOUD FRACTION *
5632 ! * ON EACH MODEL LAYER. *
5633 ! * QINGYUN ZHAO 95-3-22 *
5634 ! *****************************************************************
5635 !***
5636 !*** REQUIRED INPUT:
5637 !***
5638 (QS,PP,PPI,QQH2O,TT,O3QO3,TSFC,SLMSK,ALBEDO,XLAT &
5639 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
5640 , CAMT,KTOP,KBTM,NCLDS,EMCLD,RRCL,TTCL &
5641 , COSZRO,TAUDAR,IBEG &
5642 , KO3,KALB &
5643 , ITIMSW,ITIMLW &
5644 !***************************************************************************
5645 !* IX IS THE LENGTH OF A ROW IN THE DOMAIN
5646 !
5647 !* QS(IX): THE SURFACE PRESSURE (PA)
5648 !* PP(IX,L): THE MIDLAYER PRESSURES (PA) (L IS THE VERT. DIMEN.)
5649 !* PPI(IX,LP1) THE INTERFACE PRESSURES (PA)
5650 !* QQH2O(IX,L): THE MIDLAYER WATER VAPOR MIXING RATIO (KG/KG)
5651 !* TT(IX,L): THE MIDLAYER TEMPERATURE (K)
5652 !* O3QO3(IX,L): THE MIDLAYER OZONE MIXING RATIO
5653 !* TSFC(IX): THE SKIN TEMP. (K); NEGATIVE OVER WATER
5654 !* SLMSK(IX): THE SEA MASK (LAND=0,SEA=1)
5655 !* ALBEDO(IX): THE SURFACE ALBEDO (EXPRESSED AS A FRACTION)
5656 !* XLAT(IX): THE GEODETIC LATITUDES OF EACH COLUMN IN DEGREES
5657 !* (N.H.> 0)
5658 !* THE FOLLOWING ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
5659 !* LAYER=1:SURFACE
5660 !* LAYER=2:FIRST LAYER ABOVE GROUND, AND SO ON
5661 !* CAMT(IX,LP1): CLOUD FRACTION OF EACH CLOUD LAYER
5662 !* ITYP(IX,LP1): CLOUD TYPE(=1: STRATIFORM, =2:CONVECTIVE)
5663 !* KTOP(IX,LP1): HEIGHT OF CLOUD TOP OF EACH CLOUD LAYER (IN ETA LEVEL)
5664 !* KBTM(IX,LP1): BOTTOM OF EACH CLOUD LAYER
5665 !* NCLDS(IX): NUMBER OF CLOUD LAYERS
5666 !* EMCLD(IX,LP1): CLOUD EMISSIVITY
5667 !* RRCL(IX,NB,LP1) CLOUD REFLECTTANCES FOR SW SPECTRAL BANDS
5668 !* TTCL(IX,NB,LP1) CLOUD TRANSMITANCES FOR SW SPECTRAL BANDS
5669 !* THE ABOVE ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
5670 !*
5671 !* COSZRO(IX): THE COSINE OF THE SOLAR ZENITH ANGLE
5672 !* TAUDAR: =1.0
5673 !* IBEG: =1
5674 !* KO3: =1 ( READ IN THE QZONE DATA)
5675 !* KALB: =0
5676 !* ITIMSW: =1/0 (SHORTWAVE CALC. ARE DESIRED/NOT DESIRED)
5677 !* ITIMLW: =1/0 (LONGWAVE CALC. ARE DESIRED/NOT DESIRED)
5678 !************************************************************************
5679 !***
5680 !*** GENERATED OUTPUT REQUIRED BY THE ETA MODEL
5681 !***
5682 , SWH,HLW &
5683 , FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC &
5684 , ids,ide, jds,jde, kds,kde &
5685 , ims,ime, jms,jme, kms,kme &
5686 ! begin debugging radiation
5687 , its,ite, jts,jte, kts,kte &
5688 , imd,jmd, Jndx )
5689 ! end debugging radiation
5690 !************************************************************************
5691 !* SWH: ATMOSPHERIC SHORTWAVE HEATING RATES IN K/S.
5692 !* SWH IS A REAL ARRAY DIMENSIONED (NCOL X LM).
5693 !* HLW: ATMOSPHERIC LONGWAVE HEATING RATES IN K/S.
5694 !* HLW IS A REAL ARRAY DIMENSIONED (NCOL X LM).
5695 !* FLWUP: UPWARD LONGWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5696 !* FLWUP IS A REAL ARRAY DIMENSIONED (NCOL).
5697 !* FSWUP: UPWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5698 !* FSWUP IS A REAL ARRAY DIMENSIONED (NCOL).
5699 !* FSWDN: DOWNWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5700 !* FSWDN IS A REAL ARRAY DIMENSIONED (NCOL).
5701 !* FSWDNS: DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5702 !* FSWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
5703 !* FSWUPS: UPWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5704 !* FSWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
5705 !* FLWDNS: DOWNWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
5706 !* FLWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
5707 !* FLWUPS: UPWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
5708 !* FLWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
5709 !* FSWDNSC: CLEAR-SKY DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5710 !* FSWDNSC IS A REAL ARRAY DIMENSIONED (NCOL).
5711 !************************************************************************
5712 !***
5713 !*** THE FOLLOWING OUTPUTS ARE NOT REQUIRED BY THE ETA MODEL
5714 !***
5715 !----------------------------------------------------------------------
5716 IMPLICIT NONE
5717 !----------------------------------------------------------------------
5718 !INTEGER, PARAMETER :: NBLY=15
5719 INTEGER, PARAMETER :: NB=12
5720 INTEGER, PARAMETER :: NBLX=47
5721 INTEGER , PARAMETER:: NBLW = 163
5723 REAL,PARAMETER :: AMOLWT=28.9644
5724 REAL,PARAMETER :: CSUBP=1.00484E7
5725 REAL,PARAMETER :: DIFFCTR=1.66
5726 REAL,PARAMETER :: G=980.665
5727 REAL,PARAMETER :: GINV=1./G
5728 REAL,PARAMETER :: GRAVDR=980.0
5729 REAL,PARAMETER :: O3DIFCTR=1.90
5730 REAL,PARAMETER :: P0=1013250.
5731 REAL,PARAMETER :: P0INV=1./P0
5732 REAL,PARAMETER :: GP0INV=GINV*P0INV
5733 REAL,PARAMETER :: P0XZP2=202649.902
5734 REAL,PARAMETER :: P0XZP8=810600.098
5735 REAL,PARAMETER :: P0X2=2.*1013250.
5736 REAL,PARAMETER :: RADCON=8.427
5737 REAL,PARAMETER :: RADCON1=1./8.427
5738 REAL,PARAMETER :: RATCO2MW=1.519449738
5739 REAL,PARAMETER :: RATH2OMW=.622
5740 REAL,PARAMETER :: RGAS=8.3142E7
5741 REAL,PARAMETER :: RGASSP=8.31432E7
5742 REAL,PARAMETER :: SECPDA=8.64E4
5743 !
5744 !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
5745 ! ARRANGED IN DECREASING ORDER
5746 REAL,PARAMETER :: HUNDRED=100.
5747 REAL,PARAMETER :: HNINETY=90.
5748 REAL,PARAMETER :: HNINE=9.0
5749 REAL,PARAMETER :: SIXTY=60.
5750 REAL,PARAMETER :: FIFTY=50.
5751 REAL,PARAMETER :: TEN=10.
5752 REAL,PARAMETER :: EIGHT=8.
5753 REAL,PARAMETER :: FIVE=5.
5754 REAL,PARAMETER :: FOUR=4.
5755 REAL,PARAMETER :: THREE=3.
5756 REAL,PARAMETER :: TWO=2.
5757 REAL,PARAMETER :: ONE=1.
5758 REAL,PARAMETER :: HAF=0.5
5759 REAL,PARAMETER :: QUARTR=0.25
5760 REAL,PARAMETER :: ZERO=0.
5761 !
5762 !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
5763 ! ARRANGED IN DECREASING ORDER
5764 REAL,PARAMETER :: H83E26=8.3E26
5765 REAL,PARAMETER :: H71E26=7.1E26
5766 REAL,PARAMETER :: H1E15=1.E15
5767 REAL,PARAMETER :: H1E13=1.E13
5768 REAL,PARAMETER :: H1E11=1.E11
5769 REAL,PARAMETER :: H1E8=1.E8
5770 REAL,PARAMETER :: H2E6=2.0E6
5771 REAL,PARAMETER :: H1E6=1.0E6
5772 REAL,PARAMETER :: H69766E5=6.97667E5
5773 REAL,PARAMETER :: H4E5=4.E5
5774 REAL,PARAMETER :: H165E5=1.65E5
5775 REAL,PARAMETER :: H5725E4=57250.
5776 REAL,PARAMETER :: H488E4=48800.
5777 REAL,PARAMETER :: H1E4=1.E4
5778 REAL,PARAMETER :: H24E3=2400.
5779 REAL,PARAMETER :: H20788E3=2078.8
5780 REAL,PARAMETER :: H2075E3=2075.
5781 REAL,PARAMETER :: H18E3=1800.
5782 REAL,PARAMETER :: H1224E3=1224.
5783 REAL,PARAMETER :: H67390E2=673.9057
5784 REAL,PARAMETER :: H5E2=500.
5785 REAL,PARAMETER :: H3082E2=308.2
5786 REAL,PARAMETER :: H3E2=300.
5787 REAL,PARAMETER :: H2945E2=294.5
5788 REAL,PARAMETER :: H29316E2=293.16
5789 REAL,PARAMETER :: H26E2=260.0
5790 REAL,PARAMETER :: H25E2=250.
5791 REAL,PARAMETER :: H23E2=230.
5792 REAL,PARAMETER :: H2E2=200.0
5793 REAL,PARAMETER :: H15E2=150.
5794 REAL,PARAMETER :: H1386E2=138.6
5795 REAL,PARAMETER :: H1036E2=103.6
5796 REAL,PARAMETER :: H8121E1=81.21
5797 REAL,PARAMETER :: H35E1=35.
5798 REAL,PARAMETER :: H3116E1=31.16
5799 REAL,PARAMETER :: H28E1=28.
5800 REAL,PARAMETER :: H181E1=18.1
5801 REAL,PARAMETER :: H18E1=18.
5802 REAL,PARAMETER :: H161E1=16.1
5803 REAL,PARAMETER :: H16E1=16.
5804 REAL,PARAMETER :: H1226E1=12.26
5805 REAL,PARAMETER :: H9P94=9.94
5806 REAL,PARAMETER :: H6P08108=6.081081081
5807 REAL,PARAMETER :: H3P6=3.6
5808 REAL,PARAMETER :: H3P5=3.5
5809 REAL,PARAMETER :: H2P9=2.9
5810 REAL,PARAMETER :: H2P8=2.8
5811 REAL,PARAMETER :: H2P5=2.5
5812 REAL,PARAMETER :: H1P8=1.8
5813 REAL,PARAMETER :: H1P4387=1.4387
5814 REAL,PARAMETER :: H1P41819=1.418191
5815 REAL,PARAMETER :: H1P4=1.4
5816 REAL,PARAMETER :: H1P25892=1.258925411
5817 REAL,PARAMETER :: H1P082=1.082
5818 REAL,PARAMETER :: HP816=0.816
5819 REAL,PARAMETER :: HP805=0.805
5820 REAL,PARAMETER :: HP8=0.8
5821 REAL,PARAMETER :: HP60241=0.60241
5822 REAL,PARAMETER :: HP602409=0.60240964
5823 REAL,PARAMETER :: HP6=0.6
5824 REAL,PARAMETER :: HP526315=0.52631579
5825 REAL,PARAMETER :: HP518=0.518
5826 REAL,PARAMETER :: HP5048=0.5048
5827 REAL,PARAMETER :: HP3795=0.3795
5828 REAL,PARAMETER :: HP369=0.369
5829 REAL,PARAMETER :: HP26=0.26
5830 REAL,PARAMETER :: HP228=0.228
5831 REAL,PARAMETER :: HP219=0.219
5832 REAL,PARAMETER :: HP166666=.166666
5833 REAL,PARAMETER :: HP144=0.144
5834 REAL,PARAMETER :: HP118666=0.118666192
5835 REAL,PARAMETER :: HP1=0.1
5836 ! (NEGATIVE EXPONENTIALS BEGIN HERE)
5837 REAL,PARAMETER :: H658M2=0.0658
5838 REAL,PARAMETER :: H625M2=0.0625
5839 REAL,PARAMETER :: H44871M2=4.4871E-2
5840 REAL,PARAMETER :: H44194M2=.044194
5841 REAL,PARAMETER :: H42M2=0.042
5842 REAL,PARAMETER :: H41666M2=0.0416666
5843 REAL,PARAMETER :: H28571M2=.02857142857
5844 REAL,PARAMETER :: H2118M2=0.02118
5845 REAL,PARAMETER :: H129M2=0.0129
5846 REAL,PARAMETER :: H1M2=.01
5847 REAL,PARAMETER :: H559M3=5.59E-3
5848 REAL,PARAMETER :: H3M3=0.003
5849 REAL,PARAMETER :: H235M3=2.35E-3
5850 REAL,PARAMETER :: H1M3=1.0E-3
5851 REAL,PARAMETER :: H987M4=9.87E-4
5852 REAL,PARAMETER :: H323M4=0.000323
5853 REAL,PARAMETER :: H3M4=0.0003
5854 REAL,PARAMETER :: H285M4=2.85E-4
5855 REAL,PARAMETER :: H1M4=0.0001
5856 REAL,PARAMETER :: H75826M4=7.58265E-4
5857 REAL,PARAMETER :: H6938M5=6.938E-5
5858 REAL,PARAMETER :: H394M5=3.94E-5
5859 REAL,PARAMETER :: H37412M5=3.7412E-5
5860 REAL,PARAMETER :: H15M5=1.5E-5
5861 REAL,PARAMETER :: H1439M5=1.439E-5
5862 REAL,PARAMETER :: H128M5=1.28E-5
5863 REAL,PARAMETER :: H102M5=1.02E-5
5864 REAL,PARAMETER :: H1M5=1.0E-5
5865 REAL,PARAMETER :: H7M6=7.E-6
5866 REAL,PARAMETER :: H4999M6=4.999E-6
5867 REAL,PARAMETER :: H451M6=4.51E-6
5868 REAL,PARAMETER :: H25452M6=2.5452E-6
5869 REAL,PARAMETER :: H1M6=1.E-6
5870 REAL,PARAMETER :: H391M7=3.91E-7
5871 REAL,PARAMETER :: H1174M7=1.174E-7
5872 REAL,PARAMETER :: H8725M8=8.725E-8
5873 REAL,PARAMETER :: H327M8=3.27E-8
5874 REAL,PARAMETER :: H257M8=2.57E-8
5875 REAL,PARAMETER :: H1M8=1.0E-8
5876 REAL,PARAMETER :: H23M10=2.3E-10
5877 REAL,PARAMETER :: H14M10=1.4E-10
5878 REAL,PARAMETER :: H11M10=1.1E-10
5879 REAL,PARAMETER :: H1M10=1.E-10
5880 REAL,PARAMETER :: H83M11=8.3E-11
5881 REAL,PARAMETER :: H82M11=8.2E-11
5882 REAL,PARAMETER :: H8M11=8.E-11
5883 REAL,PARAMETER :: H77M11=7.7E-11
5884 REAL,PARAMETER :: H72M11=7.2E-11
5885 REAL,PARAMETER :: H53M11=5.3E-11
5886 REAL,PARAMETER :: H48M11=4.8E-11
5887 REAL,PARAMETER :: H44M11=4.4E-11
5888 REAL,PARAMETER :: H42M11=4.2E-11
5889 REAL,PARAMETER :: H37M11=3.7E-11
5890 REAL,PARAMETER :: H35M11=3.5E-11
5891 REAL,PARAMETER :: H32M11=3.2E-11
5892 REAL,PARAMETER :: H3M11=3.0E-11
5893 REAL,PARAMETER :: H28M11=2.8E-11
5894 REAL,PARAMETER :: H24M11=2.4E-11
5895 REAL,PARAMETER :: H23M11=2.3E-11
5896 REAL,PARAMETER :: H2M11=2.E-11
5897 REAL,PARAMETER :: H18M11=1.8E-11
5898 REAL,PARAMETER :: H15M11=1.5E-11
5899 REAL,PARAMETER :: H14M11=1.4E-11
5900 REAL,PARAMETER :: H114M11=1.14E-11
5901 REAL,PARAMETER :: H11M11=1.1E-11
5902 REAL,PARAMETER :: H1M11=1.E-11
5903 REAL,PARAMETER :: H96M12=9.6E-12
5904 REAL,PARAMETER :: H93M12=9.3E-12
5905 REAL,PARAMETER :: H77M12=7.7E-12
5906 REAL,PARAMETER :: H74M12=7.4E-12
5907 REAL,PARAMETER :: H65M12=6.5E-12
5908 REAL,PARAMETER :: H62M12=6.2E-12
5909 REAL,PARAMETER :: H6M12=6.E-12
5910 REAL,PARAMETER :: H45M12=4.5E-12
5911 REAL,PARAMETER :: H44M12=4.4E-12
5912 REAL,PARAMETER :: H4M12=4.E-12
5913 REAL,PARAMETER :: H38M12=3.8E-12
5914 REAL,PARAMETER :: H37M12=3.7E-12
5915 REAL,PARAMETER :: H3M12=3.E-12
5916 REAL,PARAMETER :: H29M12=2.9E-12
5917 REAL,PARAMETER :: H28M12=2.8E-12
5918 REAL,PARAMETER :: H24M12=2.4E-12
5919 REAL,PARAMETER :: H21M12=2.1E-12
5920 REAL,PARAMETER :: H16M12=1.6E-12
5921 REAL,PARAMETER :: H14M12=1.4E-12
5922 REAL,PARAMETER :: H12M12=1.2E-12
5923 REAL,PARAMETER :: H8M13=8.E-13
5924 REAL,PARAMETER :: H46M13=4.6E-13
5925 REAL,PARAMETER :: H36M13=3.6E-13
5926 REAL,PARAMETER :: H135M13=1.35E-13
5927 REAL,PARAMETER :: H12M13=1.2E-13
5928 REAL,PARAMETER :: H1M13=1.E-13
5929 REAL,PARAMETER :: H3M14=3.E-14
5930 REAL,PARAMETER :: H15M14=1.5E-14
5931 REAL,PARAMETER :: H14M14=1.4E-14
5932 !
5933 !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
5934 ! ARRANGED IN DESCENDING ORDER
5935 REAL,PARAMETER :: HM2M2=-.02
5936 REAL,PARAMETER :: HM6666M2=-.066667
5937 REAL,PARAMETER :: HMP5=-0.5
5938 REAL,PARAMETER :: HMP575=-0.575
5939 REAL,PARAMETER :: HMP66667=-.66667
5940 REAL,PARAMETER :: HMP805=-0.805
5941 REAL,PARAMETER :: HM1EZ=-1.
5942 REAL,PARAMETER :: HM13EZ=-1.3
5943 REAL,PARAMETER :: HM19EZ=-1.9
5944 REAL,PARAMETER :: HM1E1=-10.
5945 REAL,PARAMETER :: HM1597E1=-15.97469413
5946 REAL,PARAMETER :: HM161E1=-16.1
5947 REAL,PARAMETER :: HM1797E1=-17.97469413
5948 REAL,PARAMETER :: HM181E1=-18.1
5949 REAL,PARAMETER :: HM8E1=-80.
5950 REAL,PARAMETER :: HM1E2=-100.
5951 !
5952 REAL,PARAMETER :: H1M16=1.0E-16
5953 REAL,PARAMETER :: H1M20=1.E-20
5954 REAL,PARAMETER :: Q19001=19.001
5955 REAL,PARAMETER :: DAYSEC=1.1574E-5
5956 REAL,PARAMETER :: HSIGMA=5.673E-8
5957 REAL,PARAMETER :: TWENTY=20.0
5958 REAL,PARAMETER :: HP537=0.537
5959 REAL,PARAMETER :: HP2=0.2
5960 REAL,PARAMETER :: RCO2=3.3E-4
5961 REAL,PARAMETER :: H3M6=3.0E-6
5962 REAL,PARAMETER :: PI=3.1415927
5963 REAL,PARAMETER :: DEGRAD1=180.0/PI
5964 REAL,PARAMETER :: H74E1=74.0
5965 REAL,PARAMETER :: H15E1=15.0
5967 REAL, PARAMETER:: B0 = -.51926410E-4
5968 REAL, PARAMETER:: B1 = -.18113332E-3
5969 REAL, PARAMETER:: B2 = -.10680132E-5
5970 REAL, PARAMETER:: B3 = -.67303519E-7
5971 REAL, PARAMETER:: AWIDE = 0.309801E+01
5972 REAL, PARAMETER:: BWIDE = 0.495357E-01
5973 REAL, PARAMETER:: BETAWD = 0.347839E+02
5974 REAL, PARAMETER:: BETINW = 0.766811E+01
5977 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
5978 ims,ime, jms,jme, kms,kme , &
5979 its,ite, jts,jte, kts,kte
5980 INTEGER, INTENT(IN) :: IBEG,KO3,KALB,ITIMSW,ITIMLW
5981 !----------------------------------------------------------------------
5982 ! ****************************************************************
5983 ! * GENERALIZED FOR PLUG-COMPATIBILITY - *
5984 ! * ORIGINAL CODE WAS CLEANED-UP GFDL CODE...K.CAMPANA MAR89..*
5985 !......* EXAMPLE FOR MRF: *
5986 ! * KO3 =0 AND O3QO3=DUMMY ARRAY. (GFDL CLIMO O3 USED) *
5987 ! * KEMIS=0 AND HI CLD EMIS COMPUTED HERE (CEMIS=DUMMY INPUT)*
5988 ! * KALB =0 AND SFC ALBEDO OVER OPEN WATER COMPUTED BELOW... *
5989 ! * KCCO2=0,CO2 OBTAINED FROM BLOCK DATA *
5990 ! * =1,CO2 COMPUTED IN HERE --- NOT AVAILABLE YET... *
5991 ! * UPDATED FOR YUTAI HOU SIB SW RADIATION....KAC 6 MAR 92 *
5992 ! * OCEAN ALBEDO FOR BEAM SET TO BULK SFCALB, SINCE *
5993 ! * COSINE ZENITH ANGLE EFFECTS ALREADY THERE(REF:PAYNE) *
5994 ! * SLMSK = 0. *
5995 ! * SNOW ICE ALBEDO FOR BEAM NOT ENHANCED VIA COSINE ZENITH *
5996 ! * ANGLE EITHER CAUSE VALU ALREADY HIGH (WE SEE POLAR *
5997 ! * COOLING IF WE DO BEAM CALCULATION)....KAC 17MAR92 *
5998 ! * ALBEDO GE .5 *
5999 ! * UPDATED TO OBTAIN CLEAR SKY FLUXES "ON THE FLY" FOR *
6000 ! * CLOUD FORCING DIAGNOSTICS ELSEWHERE...KAC 7AUG92 *
6001 ! * SEE ##CLR LINES...RADFS,LWR88,FST88,SPA88 ....... *
6002 ! * UPDATED FOR USE NEW CLD SCHEME ......YH DEC 92 *
6003 ! * INPUT CLD MAY BE AS ORIGINAL IN 3 DOMAIN (CLD,MTOP,MBOT) *
6004 ! * OR IN A VERTICAL ARRAY OF 18 MDL LAYERS (CLDARY) *
6005 ! * IEMIS=0 USE THE ORG. CLD EMIS SCHEME *
6006 ! * =1 USE TEMP DEP. CLD EMIS SCHEME *
6007 ! * UPDATED TO COMPUTE CLD LAYER REFLECTTANCE AND TRANSMITTANCE *
6008 ! * INPUT CLD EMISSIVITY AND OPTICAL THICKNESS 'EMIS0,TAUC0' *
6009 ! * ......YH FEB 93 *
6010 ! ****************************************************************
6011 !--------------------------------
6012 ! INTEGER, PARAMETER:: LNGTH=37*kte
6013 !--------------------------------
6015 ! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D
6017 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: PP,TT
6018 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: QQH2O
6019 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: PPI,CAMT,EMCLD
6020 REAL, INTENT(IN), DIMENSION(its:ite):: QS,TSFC,SLMSK,ALBEDO,XLAT
6021 REAL, INTENT(IN), DIMENSION(its:ite):: COSZRO,TAUDAR
6022 REAL, INTENT(OUT), DIMENSION(its:ite):: FLWUPS
6023 INTEGER, INTENT(IN), DIMENSION(its:ite):: NCLDS
6024 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: KTOP,KBTM
6025 REAL, INTENT(INOUT), DIMENSION(its:ite,NB,kts:kte+1):: TTCL,RRCL
6026 REAL, intent(IN), DIMENSION(its:ite,kts:kte):: O3QO3
6027 ! REAL, INTENT(IN), DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW
6028 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
6030 ! REAL, DIMENSION(its:ite)::ALVBR,ALNBR, ALVDR,ALNDR
6032 ! TABLE ???
6034 REAL, DIMENSION(3) :: BO3RND,AO3RND
6035 REAL, DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
6036 BCOMB,BETACM
6038 DATA AO3RND / 0.543368E+02, 0.234676E+04, 0.384881E+02/
6039 DATA BO3RND / 0.526064E+01, 0.922424E+01, 0.496515E+01/
6041 DATA ACOMB / &
6042 0.152070E+05, 0.332194E+04, 0.527177E+03, 0.163124E+03, &
6043 0.268808E+03, 0.534591E+02, 0.268071E+02, 0.123133E+02, &
6044 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, &
6045 0.178110E-01, 0.170166E+00, 0.537083E-02/
6046 DATA BCOMB / &
6047 0.152538E+00, 0.118677E+00, 0.103660E+00, 0.100119E+00, &
6048 0.127518E+00, 0.118409E+00, 0.904061E-01, 0.642011E-01, &
6049 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, &
6050 0.875182E-01, 0.857907E-01, 0.214005E+00/
6051 DATA APCM / &
6052 -0.671879E-03, 0.654345E-02, 0.143657E-01, 0.923593E-02, &
6053 0.117022E-01, 0.159596E-01, 0.181600E-01, 0.145013E-01, &
6054 0.170062E-01, 0.233303E-01, 0.256735E-01, 0.274745E-01, &
6055 0.279259E-01, 0.197002E-01, 0.349782E-01/
6056 DATA BPCM / &
6057 -0.113520E-04, -0.323965E-04, -0.448417E-04, -0.230779E-04, &
6058 -0.361981E-04, -0.145117E-04, 0.198349E-04, -0.486529E-04, &
6059 -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, &
6060 -0.982953E-04, -0.772497E-04, -0.748263E-04/
6061 DATA ATPCM / &
6062 -0.106346E-02, 0.641531E-02, 0.137362E-01, 0.922513E-02, &
6063 0.136162E-01, 0.169791E-01, 0.206959E-01, 0.166223E-01, &
6064 0.171776E-01, 0.229724E-01, 0.275530E-01, 0.302731E-01, &
6065 0.281662E-01, 0.199525E-01, 0.370962E-01/
6066 DATA BTPCM / &
6067 -0.735731E-05, -0.294149E-04, -0.505592E-04, -0.280894E-04, &
6068 -0.492972E-04, -0.341508E-04, -0.362947E-04, -0.250487E-04, &
6069 -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, &
6070 -0.933645E-04, -0.664045E-04, -0.115290E-03/
6071 DATA BETACM / &
6072 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
6073 0.188625E+03, 0.144293E+03, 0.174098E+03, 0.909366E+02, &
6074 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, &
6075 0.589554E+01, 0.495227E+01, 0.000000E+00/
6078 ! *********************************************
6079 !====> * OUTPUT TO CALLING PROGRAM *
6080 ! *********************************************
6082 REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte)::SWH,HLW
6083 REAL, INTENT(OUT), DIMENSION(its:ite):: FSWUP,FSWUPS,FSWDN, &
6084 FSWDNS,FLWUP,FLWDNS,FSWDNSC
6086 ! *********************************************
6087 !====> * POSSIBLE OUTPUT TO CALLING PROGRAM *
6088 ! *********************************************
6090 REAL, DIMENSION(its:ite):: GDFVBR,GDFNBR,GDFVDR,GDFNDR
6092 ! ************************************************************
6093 !====> * ARRAYS NEEDED BY SWR91SIB..FOR CLEAR SKY DATA(EG.FSWL) *
6094 ! ************************************************************
6096 REAL, DIMENSION(its:ite,kts:kte+1)::FSWL,HSWL,UFL,DFL
6098 ! ******************************************************
6099 !====> * ARRAYS NEEDED BY CLO88, LWR88, SWR89 OR SWR91SIB *
6100 ! ******************************************************
6102 REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1)::CLDFAC
6103 REAL, DIMENSION(its:ite,kts:kte+1)::EQCMT,PRESS,TEMP,FSW,HSW,UF,DF
6104 REAL, DIMENSION(its:ite,kts:kte)::RH2O,QO3,HEATRA
6105 REAL, DIMENSION(its:ite):: COSZEN,TAUDA,GRNFLX,TOPFLX,GRDFLX
6106 REAL, DIMENSION(kts:kte+1)::PHALF
6107 !..... ADD PRESSURE INTERFACE
6109 REAL, DIMENSION(NB) :: ABCFF,PWTS
6111 DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190., &
6112 989.,2706.,39011./
6113 DATA PWTS/.5000,.121416,.0698,.1558,.0631,.0362,.0243,.0158,.0087, &
6114 .001467,.002342,.001075/
6116 REAL :: CFCO2,CFO3,REFLO3,RRAYAV
6118 DATA CFCO2,CFO3/508.96,466.64/
6119 DATA REFLO3/1.9/
6120 DATA RRAYAV/0.144/
6122 ! *********************************************
6123 !====> * VECTOR TEMPORARIES FOR CLOUD CALC. *
6124 ! *********************************************
6126 REAL, DIMENSION(its:ite):: TTHAN
6127 REAL, DIMENSION(its:ite,kts:kte):: DO3V,DO3VP
6128 INTEGER, DIMENSION(its:ite):: JJROW
6130 !====> **************************************************************
6131 !-- SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN
6132 ! CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE).
6133 ! DEFINED AS 5 DEG LAT MEANS N.P.->S.P.
6134 ! COMMON /SAVMEM/ &
6135 !- ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL.....
6136 ! DDUO3N(37,L), DDO3N2(37,L), DDO3N3(37,L), DDO3N4(37,L)
6138 REAL, DIMENSION(37,kte) :: DDUO3N,DDO3N2,DDO3N3,DDO3N4
6140 !====> **************************************************************
6141 !
6142 REAL, DIMENSION(21,20) :: ALBD
6143 REAL, DIMENSION(20) :: ZA
6144 REAL, DIMENSION(21) :: TRN
6145 REAL, DIMENSION(19) :: DZA
6147 REAL :: YEAR,TPI,SSOLAR,DATE,TH2,ZEN,DZEN,ALB1,ALB2
6148 INTEGER :: IR,IQ,JX
6149 DATA TRN/.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60,.65, &
6150 .70,.75,.80,.85,.90,.95,1.00/
6152 REAL :: ALB11(21,7),ALB22(21,7),ALB33(21,6)
6154 EQUIVALENCE (ALB11(1,1),ALBD(1,1)),(ALB22(1,1),ALBD(1,8)), &
6155 (ALB33(1,1),ALBD(1,15))
6156 DATA ALB11/ .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, &
6157 .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, &
6158 .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, &
6159 .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, &
6160 .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, &
6161 .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, &
6162 .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, &
6163 .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, &
6164 .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, &
6165 .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, &
6166 .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, &
6167 .246,.235,.222,.211,.205,.200/
6168 DATA ALB22/ .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, &
6169 .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, &
6170 .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, &
6171 .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, &
6172 .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, &
6173 .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, &
6174 .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, &
6175 .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, &
6176 .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, &
6177 .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, &
6178 .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, &
6179 .058,.055,.054,.053,.052,.052/
6180 DATA ALB33/ .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, &
6181 .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, &
6182 .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, &
6183 .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, &
6184 .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, &
6185 .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, &
6186 .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, &
6187 .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, &
6188 .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, &
6189 .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025/
6190 DATA ZA/90.,88.,86.,84.,82.,80.,78.,76.,74.,70.,66.,62.,58.,54., &
6191 50.,40.,30.,20.,10.,0.0/
6192 DATA DZA/8*2.0,6*4.0,5*10.0/
6194 ! ***********************************************************
6195 !
6197 REAL, DIMENSION(its:ite) :: ALVB,ALNB,ALVD,ALND, &
6198 GDFVB, &
6199 GDFNB,GDFVD,GDFND, &
6200 SFCALB
6202 REAL :: RRVCO2,RRCO2,TDUM
6203 REAL :: ALBD0,ALVD1,ALND1
6204 INTEGER :: N
6205 !
6206 !*** The following two lines are for debugging.
6207 integer :: imd,jmd, Jndx
6208 real :: FSWrat,FSWrat1,FSWDNS1
6209 !***
6211 !====> BEGIN HERE .......................
6212 !
6213 !--- SSOLAR IS THE SOLAR CONSTANT SCALED TO A MORE CURRENT VALUE;
6214 ! I.E. IF SOLC=2.0 LY/MIN THEN SSOLAR=1.96 LY/MIN.
6215 REAL,PARAMETER :: H196=1.96
6217 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
6218 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
6220 L=kte
6221 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
6222 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
6223 LLM2 = LL-2; LLM1=LL-1
6224 MYIS=its; MYIE=ite
6226 !******ZHAO
6227 ! NOTE: XLAT IS IN DEGREE HERE
6228 !*****ZHAO
6229 !-- Formerly => SOLC=2./(R1*R1), SSOLAR=0.98*SOLC
6230 SSOLAR=H196/(R1*R1)
6231 !*********************************************************
6232 ! Special note: The solar constant is reduced extra 3 percent to account
6233 ! for the lack of aerosols in the shortwave radiation
6234 ! parameterization. Q. Zhao 96-7-23
6235 ! ### May also be due not accounting for reduction in solar constant due to
6236 ! absorption by ozone above the top of the model domain (Ferrier, Apr-2005)
6237 !*********************************************************
6238 SSOLAR=SSOLAR*0.97
6239 !
6240 DO 40 I=MYIS,MYIE
6241 IR = I + IBEG - 1
6242 TH2=HP2*XLAT(IR)
6243 JJROW(I)=Q19001-TH2
6244 TTHAN(I)=(19-JJROW(I))-TH2
6245 !..... NOTE THAT THE NMC VARIABLES ARE IN MKS (THUS PRESSURE IS IN
6246 ! CENTIBARS)WHILE ALL GFDL VARIABLES ARE IN CGS UNITS
6247 SFCALB(I) = ALBEDO(IR)
6248 !..... NOW PUT SFC TEMP,PRESSURES, ZENITH ANGLE INTO SW COMMON BLOCK...
6249 !***ZHAO
6250 ! NOTE: ALL PRESSURES INPUT FROM THE ETA MODEL ARE IN PA
6251 ! THE UNIT FOR PRESS IS MICRO BAR
6252 ! SURFACE TEMPERATURE ARE NEGATIVE OVER OCEANS IN THE ETA MODEL
6253 !***ZHAO
6254 PRESS(I,LP1)=QS(IR)*10.0
6255 TEMP(I,LP1)=ABS(TSFC(IR))
6256 COSZEN(I) = COSZRO(IR)
6257 TAUDA(I) = TAUDAR(IR)
6258 40 CONTINUE
6259 !***ZHAO
6260 !..... ALL GFDL VARIABLES HAVE K=1 AT THE TOP OF THE ATMOSPHERE.NMC
6261 ! ETA MODEL HAS THE SAME STRUCTURE
6262 !***ZHAO
6263 DO 50 K=1,L
6264 DO 50 I=MYIS,MYIE
6265 IR = I + IBEG - 1
6266 !..... NOW PUT TEMP,PRESSURES, INTO SW COMMON BLOCK..........
6267 TEMP(I,K) = TT(IR,K)
6268 PRESS(I,K) = 10.0 * PP(IR,K)
6269 !.... STORE LYR MOISTURE AND ADD TO SW COMMON BLOCK
6270 RH2O(I,K)=QQH2O(IR,K)
6271 IF(RH2O(I,K).LT.H3M6) RH2O(I,K)=H3M6
6272 50 CONTINUE
6273 !... *************************
6274 IF (KO3.EQ.0) GO TO 65
6275 !... *************************
6276 DO 60 K=1,L
6277 DO 60 I=MYIS,MYIE
6278 QO3(I,K) = O3QO3(I+IBEG-1,K)
6279 60 CONTINUE
6280 65 CONTINUE
6281 !... ************************************
6282 IF (KALB.GT.0) GO TO 110
6283 !... ************************************
6284 !..... THE FOLLOWING CODE GETS ALBEDO FROM PAYNE,1972 TABLES IF
6285 ! 1) OPEN SEA POINT (SLMSK=1);2) KALB=0
6286 IQ=INT(TWENTY*HP537+ONE)
6287 DO 105 I=MYIS,MYIE
6288 IF(COSZEN(I).GT.0.0 .AND. SLMSK(I+IBEG-1).GT.0.5) THEN
6289 ZEN=DEGRAD1*ACOS(MAX(COSZEN(I),0.0))
6290 IF(ZEN.GE.H74E1) JX=INT(HAF*(HNINETY-ZEN)+ONE)
6291 IF(ZEN.LT.H74E1.AND.ZEN.GE.FIFTY) &
6292 JX=INT(QUARTR*(H74E1-ZEN)+HNINE)
6293 IF(ZEN.LT.FIFTY) JX=INT(HP1*(FIFTY-ZEN)+H15E1)
6294 DZEN=-(ZEN-ZA(JX))/DZA(JX)
6295 ALB1=ALBD(IQ,JX)+DZEN*(ALBD(IQ,JX+1)-ALBD(IQ,JX))
6296 ALB2=ALBD(IQ+1,JX)+DZEN*(ALBD(IQ+1,JX+1)-ALBD(IQ+1,JX))
6297 SFCALB(I)=ALB1+TWENTY*(ALB2-ALB1)*(HP537-TRN(IQ))
6298 ENDIF
6299 105 CONTINUE
6300 110 CONTINUE
6301 ! **********************************
6302 IF (KO3.GT.0) GO TO 135
6303 ! **********************************
6304 !.... COMPUTE CLIMATOLOGICAL ZONAL MEAN OZONE,
6305 !.... SEASONAL AND SPATIAL INTERPOLATION DONE BELOW.
6306 DO 125 I=MYIS,MYIE
6308 PHALF(1)=0.
6309 PHALF(LP1)=PPI(I,kme)
6310 DO K=1,LM1
6311 PHALF(K+1)=PP(I,K) ! AETA(K)*PDIF+PT ! BSF index was erroneously L
6312 ENDDO
6314 CALL O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, &
6315 ids,ide, jds,jde, kds,kde, &
6316 ims,ime, jms,jme, kms,kme, &
6317 its,ite, jts,jte, kts,kte )
6319 DO 130 K=1,L
6320 DO3V(I,K) = DDUO3N(JJROW(I),K) + RSIN1*DDO3N2(JJROW(I),K) &
6321 +RCOS1*DDO3N3(JJROW(I),K) &
6322 +RCOS2*DDO3N4(JJROW(I),K)
6323 DO3VP(I,K) = DDUO3N(JJROW(I)+1,K) + RSIN1*DDO3N2(JJROW(I)+1,K) &
6324 +RCOS1*DDO3N3(JJROW(I)+1,K) &
6325 +RCOS2*DDO3N4(JJROW(I)+1,K)
6326 !... NOW LATITUDINAL INTERPOLATION, AND
6327 ! CONVERT O3 INTO MASS MIXING RATIO(ORIGINAL DATA MPY BY 1.E4)
6328 QO3(I,K) = H1M4 * (DO3V(I,K)+TTHAN(I)*(DO3VP(I,K)-DO3V(I,K)))
6329 130 CONTINUE
6330 125 CONTINUE
6331 135 CONTINUE
6332 !.............
6333 DO 195 I=MYIS,MYIE
6334 !..... VISIBLE AND NEAR IR DIFFUSE ALBEDO
6335 ALVD(I) = SFCALB(I)
6336 ALND(I) = SFCALB(I)
6337 !..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO
6338 ALVB(I) = SFCALB(I)
6339 ALNB(I) = SFCALB(I)
6340 !
6341 !--- Remove diurnal variation of land surface albedos (Ferrier, 6/28/05)
6342 !--- Turn back on to mimic NAM 8/17/05
6343 !
6344 !..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO,IF NOT OCEAN NOR SNOW
6345 ! ..FUNCTION OF COSINE SOLAR ZENITH ANGLE..
6346 IF (SLMSK(I+IBEG-1).LT.0.5) THEN
6347 IF (SFCALB(I).LE.0.5) THEN
6348 ALBD0 = -18.0 * (0.5 - ACOS(COSZEN(I))/PI)
6349 ALBD0 = EXP (ALBD0)
6350 ALVD1 = (ALVD(I) - 0.054313) / 0.945687
6351 ALND1 = (ALND(I) - 0.054313) / 0.945687
6352 ALVB(I) = ALVD1 + (1.0 - ALVD1) * ALBD0
6353 ALNB(I) = ALND1 + (1.0 - ALND1) * ALBD0
6354 !-- Put in an upper limit on beam albedos
6355 ALVB(I) = MIN(0.5,ALVB(I))
6356 ALNB(I) = MIN(0.5,ALNB(I))
6357 END IF
6358 END IF
6359 195 CONTINUE
6360 !.....SURFACE VALUES OF RRCL AND TTCL
6361 DO 200 N=1,2
6362 DO 200 I=MYIS,MYIE
6363 RRCL(I,N,1)=ALVD(I)
6364 TTCL(I,N,1)=ZERO
6365 200 CONTINUE
6366 DO 220 N=3,NB
6367 DO 220 I=MYIS,MYIE
6368 RRCL(I,N,1)=ALND(I)
6369 TTCL(I,N,1)=ZERO
6370 220 CONTINUE
6371 !... **************************
6372 !... * END OF CLOUD SECTION *
6373 !... **************************
6374 !... THE FOLLOWING CODE CONVERTS RRVCO2,THE VOLUME MIXING RATIO OF CO2
6375 ! INTO RRCO2,THE MASS MIXING RATIO.
6376 RRVCO2=RCO2
6377 RRCO2=RRVCO2*RATCO2MW
6378 250 IF(ITIMLW .EQ. 0) GO TO 300
6379 !
6380 ! ***********************
6381 !====> * LONG WAVE RADIATION *
6382 ! ***********************
6383 !
6384 !.... ACCOUNT FOR REDUCED EMISSIVITY OF ANY CLDS
6385 DO 240 K=1,LP1
6386 DO 240 I=MYIS,MYIE
6387 EQCMT(I,K)=CAMT(I,K)*EMCLD(I,K)
6388 240 CONTINUE
6389 !.... GET CLD FACTOR FOR LW CALCULATIONS
6390 !....
6392 ! shuhua
6394 CALL CLO89(CLDFAC,EQCMT,NCLDS,KBTM,KTOP, &
6395 ids,ide, jds,jde, kds,kde, &
6396 ims,ime, jms,jme, kms,kme, &
6397 its,ite, jts,jte, kts,kte )
6399 ! shuhua
6400 !===> LONG WAVE RADIATION
6401 ! CALL LWR88(HEATRA,GRNFLX,TOPFLX, &
6402 ! PRESS,TEMP,RH2O,QO3,CLDFAC, &
6403 ! EQCMT,NCLDS,KTOP,KBTM, &
6404 !
6405 !! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
6406 ! BO3RND,AO3RND, &
6407 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
6408 ! ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
6409 ! GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
6410 ! P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
6411 ! TEN,HP1,FOUR,HM1EZ,SKO3R, &
6412 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
6413 ! HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
6414 ! RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, &
6415 ! ids,ide, jds,jde, kds,kde, &
6416 ! ims,ime, jms,jme, kms,kme, &
6417 ! its,ite, jts,jte, kts,kte )
6419 CALL LWR88(HEATRA,GRNFLX,TOPFLX, &
6420 PRESS,TEMP,RH2O,QO3,CLDFAC, &
6421 EQCMT,NCLDS,KTOP,KBTM, &
6422 !
6423 ! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
6424 BO3RND,AO3RND, &
6425 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
6426 ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
6427 GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
6428 P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
6429 TEN,HP1,FOUR,HM1EZ, &
6430 RADCON,QUARTR,TWO, &
6431 HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
6432 RADCON1,H16E1, H28E1,H44194M2,H1P41819, &
6433 ids,ide, jds,jde, kds,kde, &
6434 ims,ime, jms,jme, kms,kme, &
6435 its,ite, jts,jte, kts,kte )
6437 !....
6438 !================================================================================
6439 !--- IMPORTANT!! Y.-T Hou advised Ferrier, Mitchell, & Ek on 7/28/05 to use
6440 ! the following algorithm, because the GFDL code calculates NET longwave flux
6441 ! (GRNFLX, Up - Down) as its fundamental quantity.
6442 !
6443 ! 1. Calculate upward LW at surface (FLWUPS)
6444 ! 2. Calculate downward LW at surface (FLWDNS) = FLWUPS - .001*GRNFLX
6445 !
6446 !--- Note: The following fluxes must be multipled by .001 to convert to mks
6447 ! => GRNFLX, or GRound Net FLuX
6448 ! => TOPFLX, or top of the atmosphere fluxes (FLWUP)
6449 !
6450 !--- IMPORTANT!! If the surface emissivity (SFCEMS) differs from 1.0, then
6451 ! uncomment the line below starting with "!BSF"
6452 !================================================================================
6453 DO 280 I=MYIS,MYIE
6454 IR = I + IBEG - 1
6455 FLWUP(IR) = .001*TOPFLX(I)
6456 ! TDUM=TEMP(I,LP1)
6457 !--- Use an average of the skin & lowest model level temperature
6458 TDUM=.5*(TEMP(I,LP1)+TEMP(I,L))
6459 FLWUPS(IR)=HSIGMA*TDUM*TDUM*TDUM*TDUM
6460 !BSF FLWUPS(IR)=SFCEMS*HSIGMA*TDUM*TDUM*TDUM*TDUM
6461 FLWDNS(IR)=FLWUPS(IR)-.001*GRNFLX(I)
6462 280 CONTINUE
6463 !.... Average LW heating/cooling rates over the lowest 2 atmospheric layers,
6464 ! which may be necessary for when dealing with thin layers near the surface
6465 DO I=MYIS,MYIE
6466 TDUM=.5*(HEATRA(I,L)+HEATRA(I,LM1))
6467 HEATRA(I,L)=TDUM
6468 HEATRA(I,LM1)=TDUM
6469 ENDDO
6470 !.... CONVERT HEATING RATES TO DEG/SEC
6471 DO 290 K=1,L
6472 DO 290 I=MYIS,MYIE
6473 HLW(I+IBEG-1,K)=HEATRA(I,K)*DAYSEC
6474 290 CONTINUE
6475 300 CONTINUE
6476 IF(ITIMSW .EQ. 0) GO TO 350
6477 !SW
6478 CALL SWR93(FSW,HSW,UF,DF,FSWL,HSWL,UFL,DFL, &
6479 PRESS,COSZEN,TAUDA,RH2O,RRCO2,SSOLAR,QO3, &
6480 NCLDS,KTOP,KBTM,CAMT,RRCL,TTCL, &
6481 ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, &
6482 !
6483 ! UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2, &
6484 ABCFF,PWTS, &
6485 H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219, &
6486 HP816,RRAYAV,GINV,CFCO2,CFO3, &
6487 TWO,H235M3,HP26,H129M2,H75826M4,H1036E2, &
6488 H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2, &
6489 H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON, &
6490 ids,ide, jds,jde, kds,kde, &
6491 ims,ime, jms,jme, kms,kme, &
6492 its,ite, jts,jte, kts,kte )
6494 !SW
6495 !
6496 !..... GET SW FLUXES IN WATTS/M**2
6497 DO 320 I=MYIS,MYIE
6498 IR = I + IBEG - 1
6499 FSWUP(IR) = UF(I,1) * 1.E-3
6500 FSWDN(IR) = DF(I,1) * 1.E-3
6501 FSWUPS(IR) = UF(I,LP1) * 1.E-3
6502 !-- FSWDNS is more accurate using array DF than summing the GDFxx arrays
6503 !C..COUPLE W/M2 DIFF, IF FSWDNS(IR)=DF(I,LP1)*1.#E-3
6504 !! FSWDNS(IR) = (GDFVB(I)+GDFNB(I)+GDFVD(I)+GDFND(I)) * 1.E-3
6505 FSWDNS(IR) = DF(I,LP1) * 1.E-3
6506 FSWDNSC(IR) = DFL(I,LP1) * 1.E-3
6507 !... DOWNWARD SFC FLUX FOR THE SIB PARAMETERATION
6508 !..... VISIBLE AND NEAR IR DIFFUSE
6509 GDFVDR(IR) = GDFVD(I) * 1.E-3
6510 GDFNDR(IR) = GDFND(I) * 1.E-3
6511 !..... VISIBLE AND NEAR IR DIRECT BEAM
6512 GDFVBR(IR) = GDFVB(I) * 1.E-3
6513 GDFNBR(IR) = GDFNB(I) * 1.E-3
6514 320 CONTINUE
6515 !.... CONVERT HEATING RATES TO DEG/SEC
6516 DO 330 K=1,L
6517 DO 330 I=MYIS,MYIE
6518 SWH(I+IBEG-1,K)=HSW(I,K)*DAYSEC
6519 330 CONTINUE
6520 350 CONTINUE
6521 ! begin debugging radiation
6523 ! if (Jndx .eq. jmd) then
6524 ! FSWDNS1=(GDFVB(imd)+GDFNB(imd)+GDFVD(imd)+GDFND(imd))*.001
6525 ! write(6,"(3a,2i5,7f9.2)") '{rad2 imd,Jndx,' &
6526 ! ,'GSW=FSWDNS-FSWUPS,RSWIN=FSWDNS,RSWIN_1=FSWDNS1,' &
6527 ! ,'FSWDNS-FSWDNS1,RSWOUT=FSWUPS,RSWINC=FSWDNSC,GLW=FLWDNS = ' &
6528 ! ,imd,Jndx, FSWDNS(imd)-FSWUPS(imd),FSWDNS(imd),FSWDNS1 &
6529 ! ,FSWDNS(imd)-FSWDNS1,FSWUPS(imd),FSWDNSC(imd),FLWDNS(imd)
6530 ! FSWrat=0.
6531 ! if (FSWDNS(imd) .ne. 0.) FSWrat=FSWUPS(imd)/FSWDNS(imd)
6532 ! FSWrat1=0.
6533 ! if (FSWDNS1 .ne. 0.) FSWrat1=FSWUPS(imd)/FSWDNS1
6534 ! write(6,"(2a,10f8.4)") '{rad2a ALBEDO,SFCALB,ALVD,ALND,ALVB,' &
6535 ! ,'ALNB,CZEN,SLMSK,FSWUPS/FSWDNS,FSWUPS/FSWDNS1 = ' &
6536 ! ,ALBEDO(imd),SFCALB(imd),ALVD(imd),ALND(imd),ALVB(imd) &
6537 ! ,ALNB(imd),COSZEN(imd),SLMSK(imd),FSWrat,FSWrat1
6538 ! endif
6539 ! end debugging radiation
6540 RETURN
6541 1000 FORMAT(1H ,' YOU ARE CALLING GFDL RADIATION CODE FOR',I5,' PTS', &
6542 'AND',I4,' LYRS,WITH KDAPRX,KO3,KCZ,KEMIS,KALB = ',5I2)
6544 END SUBROUTINE RADFS
6546 !-----------------------------------------------------------------------
6547 SUBROUTINE O3CLIM
6548 ! (XDUO3N,XDO3N2,XDO3N3,XDO3N4,PRGFDL, &
6549 ! ids,ide, jds,jde, kds,kde, &
6550 ! ims,ime, jms,jme, kms,kme, &
6551 ! its,ite, jts,jte, kts,kte )
6552 !----------------------------------------------------------------------
6553 IMPLICIT NONE
6554 !----------------------------------------------------------------------
6555 ! INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
6556 ! ims,ime, jms,jme, kms,kme , &
6557 ! its,ite, jts,jte, kts,kte
6559 ! ******************************************************************
6560 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
6561 ! . . .
6562 ! SUBPROGRAM: O3CLIM GENERATE SEASONAL OZONE DISTRIBUTION
6563 ! PRGRMMR: GFDL/CAMPANA ORG: W/NP22 DATE: ??-??-??
6564 !
6565 ! ABSTRACT:
6566 ! O3CLIM COMPUTES THE SEASONAL CLIMATOLOGY OF OZONE USING
6567 ! 81-LAYER DATA FROM GFDL.
6568 !
6569 ! PROGRAM HISTORY LOG:
6570 ! ??-??-?? GFDL/KC - ORIGINATOR
6571 ! 96-07-26 BLACK - MODIFIED FOR ETA MODEL
6572 !
6573 ! USAGE: CALL O3CLIM FROM SUBROUTINE RADTN
6574 ! INPUT ARGUMENT LIST:
6575 ! NONE
6576 !
6577 ! OUTPUT ARGUMENT LIST:
6578 ! NONE
6579 !
6580 ! OUTPUT FILES:
6581 ! NONE
6582 !
6583 ! SUBPROGRAMS CALLED:
6584 !
6585 ! UNIQUE:
6586 ! NONE
6587 !
6588 ! LIBRARY:
6589 ! NONE
6590 !
6591 ! COMMON BLOCKS: SEASO3
6592 ! O3DATA
6593 !
6594 ! ATTRIBUTES:
6595 ! LANGUAGE: FORTRAN 90
6596 ! MACHINE : IBM SP
6597 !$$$
6598 !----------------------------------------------------------------------
6599 ! INTEGER :: NL,NLP1,NLGTH,NKK,NK,NKP
6600 INTEGER, PARAMETER :: NL=81,NLP1=NL+1,NLGTH=37*NL,NKK=41,NK=81,NKP=NK+1
6601 !----------------------------------------------------------------------
6602 ! INCLUDE "SEASO3.comm"
6603 !---------------------------------------------------------------------
6604 ! REAL, INTENT(OUT), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
6605 ! REAL, INTENT(OUT), DIMENSION(NL) :: PRGFDL
6607 ! COMMON /SEASO3/
6608 ! ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL.....
6609 ! & XDUO3N(37,NL), XDO3N2(37,NL), XDO3N3(37,NL), XDO3N4(37,NL)
6610 !
6611 ! &,PRGFDL(NL)
6612 !---------------------------------------------------------------------
6613 REAL :: PH1(45),PH2(37),P1(48),P2(33),O3HI1(10,16),O3HI2(10,9) &
6614 ,O3LO1(10,16),O3LO2(10,16),O3LO3(10,16),O3LO4(10,16)
6615 !----------------------------------------------------------------------
6616 REAL :: AVG,A1,B1,B2
6617 INTEGER :: K,N,NCASE,IPLACE,KK,NKM,NKMM,KI,KQ,JJ,KEN,I,iindex,jindex
6618 !----------------------------------------------------------------------
6619 REAL :: PSTD(NL),TEMPN(19),O3O3(37,NL,4),O35DEG(37,NL) &
6620 ,XRAD1(NLGTH),XRAD2(NLGTH),XRAD3(NLGTH),XRAD4(NLGTH) &
6621 ,DDUO3N(19,NL),DUO3N(19,41) &
6622 ,RO3(10,41),RO3M(10,40),RO31(10,41),RO32(10,41) &
6623 ,O3HI(10,25) &
6624 ,RSTD(81),RBAR(NL),RDATA(81) &
6625 ,PHALF(NL),P(81),PH(82)
6626 REAL :: PXX(81),PYY(82) ! fix for nesting
6627 !----------------------------------------------------------------------
6628 !nesting EQUIVALENCE &
6629 !nesting (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
6630 !nesting ,(PH1(1),PH(1)),(PH2(1),PH(46)) &
6631 !nesting ,(P1(1),P(1)),(P2(1),P(49))
6632 EQUIVALENCE &
6633 (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
6634 ,(PH1(1),PYY(1)),(PH2(1),PYY(46)) & ! fix for nesting
6635 ,(P1(1),PXX(1)),(P2(1),PXX(49)) ! fix for nesting
6636 !----------------------------------------------------------------------
6637 ! EQUIVALENCE &
6638 ! (XRAD1(1),XDUO3N(1,1),O3O3(1,1,1)) &
6639 ! ,(XRAD2(1),XDO3N2(1,1)) &
6640 ! ,(XRAD3(1),XDO3N3(1,1)),(XRAD4(1),XDO3N4(1,1),)
6641 EQUIVALENCE &
6642 (XRAD1(1),O3O3(1,1,1)) &
6643 ,(XRAD2(1),O3O3(1,1,2)) &
6644 ,(XRAD3(1),O3O3(1,1,3)),(XRAD4(1),O3O3(1,1,4))
6645 !----------------------------------------------------------------------
6646 !---------------------------------------------------------------------
6647 DATA PH1/ 0., &
6648 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, &
6649 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, &
6650 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, &
6651 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, &
6652 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, &
6653 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, &
6654 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, &
6655 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, &
6656 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, &
6657 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, &
6658 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
6659 DATA PH2/ &
6660 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, &
6661 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, &
6662 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, &
6663 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, &
6664 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, &
6665 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, &
6666 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, &
6667 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, &
6668 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, &
6669 0.1000000E+01/
6670 DATA P1/ &
6671 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, &
6672 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, &
6673 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, &
6674 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, &
6675 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, &
6676 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, &
6677 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, &
6678 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, &
6679 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, &
6680 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, &
6681 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, &
6682 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
6683 DATA P2/ &
6684 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, &
6685 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, &
6686 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, &
6687 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, &
6688 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, &
6689 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, &
6690 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, &
6691 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, &
6692 0.1000000E+01/
6693 DATA O3HI1/ &
6694 .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, &
6695 .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, &
6696 .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, &
6697 .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, &
6698 .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, &
6699 .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, &
6700 .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, &
6701 .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, &
6702 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, &
6703 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, &
6704 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, &
6705 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, &
6706 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, &
6707 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, &
6708 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, &
6709 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/
6710 DATA O3HI2/ &
6711 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, &
6712 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, &
6713 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, &
6714 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, &
6715 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, &
6716 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, &
6717 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
6718 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, &
6719 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
6720 DATA O3LO1/ &
6721 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, &
6722 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, &
6723 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, &
6724 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, &
6725 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, &
6726 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, &
6727 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, &
6728 .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, &
6729 .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, &
6730 .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, &
6731 .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, &
6732 .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, &
6733 .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, &
6734 .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, &
6735 .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, &
6736 .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
6737 DATA O3LO2/ &
6738 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, &
6739 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, &
6740 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, &
6741 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, &
6742 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, &
6743 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, &
6744 .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, &
6745 .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, &
6746 .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, &
6747 .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, &
6748 .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, &
6749 .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, &
6750 .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, &
6751 .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, &
6752 .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, &
6753 .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
6754 DATA O3LO3/ &
6755 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, &
6756 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, &
6757 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, &
6758 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, &
6759 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, &
6760 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, &
6761 .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, &
6762 .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, &
6763 .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, &
6764 .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, &
6765 .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, &
6766 .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, &
6767 .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, &
6768 .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, &
6769 .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, &
6770 .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
6771 DATA O3LO4/ &
6772 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, &
6773 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, &
6774 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, &
6775 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, &
6776 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, &
6777 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, &
6778 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, &
6779 .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, &
6780 .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, &
6781 .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, &
6782 .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, &
6783 .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, &
6784 .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, &
6785 .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, &
6786 .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, &
6787 .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/
6788 !----------------------------------------------------------------------
6789 !***
6790 !*** COMPUTE DETAILED O3 PROFILE FROM THE ORIGINAL GFDL PRESSURES
6791 !*** WHERE OUTPUT FROM O3INT (PSTD) IS TOP DOWN IN MB*1.E3
6792 !*** AND PSFC=1013.25 MB ......K.A.C. DEC94
6793 !***
6794 DO K=1,NK
6795 ! PH(K)=PH(K)*1013250.
6796 ! P(K)=P(K)*1013250.
6797 PH(K)=PYY(K)*1013250. ! fix for nesting
6798 P(K)=PXX(K)*1013250. ! fix for nesting
6799 ENDDO
6800 !
6801 ! PH(NKP)=PH(NKP)*1013250.
6802 PH(NKP)=PYY(NKP)*1013250. ! fix for nesting
6803 !
6804 DO K=1,NL
6805 PSTD(K)=P(K)
6806 ENDDO
6807 !
6808 DO K=1,25
6809 DO N=1,10
6810 RO31(N,K)=O3HI(N,K)
6811 RO32(N,K)=O3HI(N,K)
6812 ENDDO
6813 ENDDO
6814 !----------------------------------------------------------------------
6815 DO 100 NCASE=1,4
6816 !
6817 !*** NCASE=1: SPRING (IN N.H.)
6818 !*** NCASE=2: FALL (IN N.H.)
6819 !*** NCASE=3: WINTER (IN N.H.)
6820 !*** NCASE=4: SUMMER (IN N.H.)
6821 !
6822 IPLACE=2
6823 IF(NCASE.EQ.2)IPLACE=4
6824 IF(NCASE.EQ.3)IPLACE=1
6825 IF(NCASE.EQ.4)IPLACE=3
6826 !
6827 IF(NCASE.EQ.1.OR.NCASE.EQ.2)THEN
6828 DO K=26,41
6829 DO N=1,10
6830 RO31(N,K)=O3LO1(N,K-25)
6831 RO32(N,K)=O3LO2(N,K-25)
6832 ENDDO
6833 ENDDO
6834 ENDIF
6835 !
6836 IF(NCASE.EQ.3.OR.NCASE.EQ.4)THEN
6837 DO K=26,41
6838 DO N=1,10
6839 RO31(N,K)=O3LO3(N,K-25)
6840 RO32(N,K)=O3LO4(N,K-25)
6841 ENDDO
6842 ENDDO
6843 ENDIF
6844 !
6845 DO 25 KK=1,NKK
6846 DO N=1,10
6847 DUO3N(N,KK)=RO31(11-N,KK)
6848 DUO3N(N+9,KK)=RO32(N,KK)
6849 ENDDO
6850 DUO3N(10,KK)=0.5*(RO31(1,KK)+RO32(1,KK))
6851 25 CONTINUE
6852 !
6853 !***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON
6854 !
6855 IF(NCASE.EQ.2.OR.NCASE.EQ.4)THEN
6856 DO 50 KK=1,NKK
6857 DO N=1,19
6858 TEMPN(N)=DUO3N(20-N,KK)
6859 ENDDO
6860 DO N=1,19
6861 DUO3N(N,KK)=TEMPN(N)
6862 ENDDO
6863 50 CONTINUE
6864 ENDIF
6865 !
6866 !*** DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON AT STD PRESSURE
6867 !*** LEVELS
6868 !
6869 !*** BEGIN LATITUDE (10 DEG) LOOP
6870 !
6871 DO 75 N=1,19
6872 !
6873 DO KK=1,NKK
6874 RSTD(KK)=DUO3N(N,KK)
6875 ENDDO
6876 !
6877 NKM=NK-1
6878 NKMM=NK-3
6879 !***
6880 !*** BESSELS HALF-POINT INTERPOLATION FORMULA
6881 !***
6882 DO K=4,NKMM,2
6883 KI=K/2
6884 RDATA(K)=0.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1) &
6885 -RSTD(KI)+RSTD(KI-1))/16.
6886 ENDDO
6887 !
6888 RDATA(2)=0.5*(RSTD(2)+RSTD(1))
6889 RDATA(NKM)=0.5*(RSTD(NKK)+RSTD(NKK-1))
6890 !
6891 !*** PUT UNCHANGED DATA INTO NEW ARRAY
6892 !
6893 DO K=1,NK,2
6894 KQ=(K+1)/2
6895 RDATA(K)=RSTD(KQ)
6896 ENDDO
6897 !
6898 DO KK=1,NL
6899 DDUO3N(N,KK)=RDATA(KK)*.01
6900 ENDDO
6901 !
6902 75 CONTINUE
6903 !
6904 !*** END OF LATITUDE LOOP
6905 !
6906 !----------------------------------------------------------------------
6907 !***
6908 !*** CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF
6909 !*** 10 DEG VALUES
6910 !***
6911 DO 90 KK=1,NL
6912 !
6913 DO N=1,19
6914 O35DEG(2*N-1,KK)=DDUO3N(N,KK)
6915 ENDDO
6916 !
6917 DO N=1,18
6918 O35DEG(2*N,KK)=0.5*(DDUO3N(N,KK)+DDUO3N(N+1,KK))
6919 ENDDO
6920 !
6921 90 CONTINUE
6922 !
6923 DO JJ=1,37
6924 DO KEN=1,NL
6925 O3O3(JJ,KEN,IPLACE)=O35DEG(JJ,KEN)
6926 ENDDO
6927 ENDDO
6928 !
6929 100 CONTINUE
6930 !----------------------------------------------------------------------
6931 !*** END OF LOOP OVER CASES
6932 !----------------------------------------------------------------------
6933 !***
6934 !*** AVERAGE CLIMATOLOGICAL VALUS OF O3 FROM 5 DEG LAT MEANS, SO THAT
6935 !*** TIME AND SPACE INTERPOLATION WILL WORK (SEE SUBR OZON2D)
6936 !***
6937 DO I=1,NLGTH
6938 AVG=0.25*(XRAD1(I)+XRAD2(I)+XRAD3(I)+XRAD4(I))
6939 A1=0.5*(XRAD2(I)-XRAD4(I))
6940 B1=0.5*(XRAD1(I)-XRAD3(I))
6941 B2=0.25*((XRAD1(I)+XRAD3(I))-(XRAD2(I)+XRAD4(I)))
6943 ! XRAD1(I)=AVG
6944 ! XRAD2(I)=A1
6945 ! XRAD3(I)=B1
6946 ! XRAD4(I)=B2
6948 iindex = 1+mod((I-1),37)
6949 jindex = 1+(I-1)/37
6950 XDUO3N(iindex,jindex)=AVG
6951 XDO3N2(iindex,jindex)=A1
6952 XDO3N3(iindex,jindex)=B1
6953 XDO3N4(iindex,jindex)=B2
6954 ENDDO
6955 !***
6956 !*** CONVERT GFDL PRESSURE (MICROBARS) TO PA
6957 !***
6958 DO N=1,NL
6959 PRGFDL(N)=PSTD(N)*1.E-1
6960 ENDDO
6961 !
6962 END SUBROUTINE O3CLIM
6964 !---------------------------------------------------------------------
6965 SUBROUTINE TABLE
6966 ! (TABLE1,TABLE2,TABLE3,EM1,EM1WDE,EM3, &
6967 ! SOURCE,DSRCE )
6968 !---------------------------------------------------------------------
6969 IMPLICIT NONE
6970 !----------------------------------------------------------------------
6972 !INTEGER, PARAMETER :: NBLY=15
6973 INTEGER, PARAMETER :: NB=12
6974 INTEGER, PARAMETER :: NBLX=47
6975 INTEGER , PARAMETER:: NBLW = 163
6977 REAL,PARAMETER :: AMOLWT=28.9644
6978 REAL,PARAMETER :: CSUBP=1.00484E7
6979 REAL,PARAMETER :: DIFFCTR=1.66
6980 REAL,PARAMETER :: G=980.665
6981 REAL,PARAMETER :: GINV=1./G
6982 REAL,PARAMETER :: GRAVDR=980.0
6983 REAL,PARAMETER :: O3DIFCTR=1.90
6984 REAL,PARAMETER :: P0=1013250.
6985 REAL,PARAMETER :: P0INV=1./P0
6986 REAL,PARAMETER :: GP0INV=GINV*P0INV
6987 REAL,PARAMETER :: P0XZP2=202649.902
6988 REAL,PARAMETER :: P0XZP8=810600.098
6989 REAL,PARAMETER :: P0X2=2.*1013250.
6990 REAL,PARAMETER :: RADCON=8.427
6991 REAL,PARAMETER :: RADCON1=1./8.427
6992 REAL,PARAMETER :: RATCO2MW=1.519449738
6993 REAL,PARAMETER :: RATH2OMW=.622
6994 REAL,PARAMETER :: RGAS=8.3142E7
6995 REAL,PARAMETER :: RGASSP=8.31432E7
6996 REAL,PARAMETER :: SECPDA=8.64E4
6997 !
6998 !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
6999 ! ARRANGED IN DECREASING ORDER
7000 REAL,PARAMETER :: HUNDRED=100.
7001 REAL,PARAMETER :: HNINETY=90.
7002 REAL,PARAMETER :: HNINE=9.0
7003 REAL,PARAMETER :: SIXTY=60.
7004 REAL,PARAMETER :: FIFTY=50.
7005 REAL,PARAMETER :: TEN=10.
7006 REAL,PARAMETER :: EIGHT=8.
7007 REAL,PARAMETER :: FIVE=5.
7008 REAL,PARAMETER :: FOUR=4.
7009 REAL,PARAMETER :: THREE=3.
7010 REAL,PARAMETER :: TWO=2.
7011 REAL,PARAMETER :: ONE=1.
7012 REAL,PARAMETER :: HAF=0.5
7013 REAL,PARAMETER :: QUARTR=0.25
7014 REAL,PARAMETER :: ZERO=0.
7015 !
7016 !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
7017 ! ARRANGED IN DECREASING ORDER
7018 REAL,PARAMETER :: H83E26=8.3E26
7019 REAL,PARAMETER :: H71E26=7.1E26
7020 REAL,PARAMETER :: H1E15=1.E15
7021 REAL,PARAMETER :: H1E13=1.E13
7022 REAL,PARAMETER :: H1E11=1.E11
7023 REAL,PARAMETER :: H1E8=1.E8
7024 REAL,PARAMETER :: H2E6=2.0E6
7025 REAL,PARAMETER :: H1E6=1.0E6
7026 REAL,PARAMETER :: H69766E5=6.97667E5
7027 REAL,PARAMETER :: H4E5=4.E5
7028 REAL,PARAMETER :: H165E5=1.65E5
7029 REAL,PARAMETER :: H5725E4=57250.
7030 REAL,PARAMETER :: H488E4=48800.
7031 REAL,PARAMETER :: H1E4=1.E4
7032 REAL,PARAMETER :: H24E3=2400.
7033 REAL,PARAMETER :: H20788E3=2078.8
7034 REAL,PARAMETER :: H2075E3=2075.
7035 REAL,PARAMETER :: H18E3=1800.
7036 REAL,PARAMETER :: H1224E3=1224.
7037 REAL,PARAMETER :: H67390E2=673.9057
7038 REAL,PARAMETER :: H5E2=500.
7039 REAL,PARAMETER :: H3082E2=308.2
7040 REAL,PARAMETER :: H3E2=300.
7041 REAL,PARAMETER :: H2945E2=294.5
7042 REAL,PARAMETER :: H29316E2=293.16
7043 REAL,PARAMETER :: H26E2=260.0
7044 REAL,PARAMETER :: H25E2=250.
7045 REAL,PARAMETER :: H23E2=230.
7046 REAL,PARAMETER :: H2E2=200.0
7047 REAL,PARAMETER :: H15E2=150.
7048 REAL,PARAMETER :: H1386E2=138.6
7049 REAL,PARAMETER :: H1036E2=103.6
7050 REAL,PARAMETER :: H8121E1=81.21
7051 REAL,PARAMETER :: H35E1=35.
7052 REAL,PARAMETER :: H3116E1=31.16
7053 REAL,PARAMETER :: H28E1=28.
7054 REAL,PARAMETER :: H181E1=18.1
7055 REAL,PARAMETER :: H18E1=18.
7056 REAL,PARAMETER :: H161E1=16.1
7057 REAL,PARAMETER :: H16E1=16.
7058 REAL,PARAMETER :: H1226E1=12.26
7059 REAL,PARAMETER :: H9P94=9.94
7060 REAL,PARAMETER :: H6P08108=6.081081081
7061 REAL,PARAMETER :: H3P6=3.6
7062 REAL,PARAMETER :: H3P5=3.5
7063 REAL,PARAMETER :: H2P9=2.9
7064 REAL,PARAMETER :: H2P8=2.8
7065 REAL,PARAMETER :: H2P5=2.5
7066 REAL,PARAMETER :: H1P8=1.8
7067 REAL,PARAMETER :: H1P4387=1.4387
7068 REAL,PARAMETER :: H1P41819=1.418191
7069 REAL,PARAMETER :: H1P4=1.4
7070 REAL,PARAMETER :: H1P25892=1.258925411
7071 REAL,PARAMETER :: H1P082=1.082
7072 REAL,PARAMETER :: HP816=0.816
7073 REAL,PARAMETER :: HP805=0.805
7074 REAL,PARAMETER :: HP8=0.8
7075 REAL,PARAMETER :: HP60241=0.60241
7076 REAL,PARAMETER :: HP602409=0.60240964
7077 REAL,PARAMETER :: HP6=0.6
7078 REAL,PARAMETER :: HP526315=0.52631579
7079 REAL,PARAMETER :: HP518=0.518
7080 REAL,PARAMETER :: HP5048=0.5048
7081 REAL,PARAMETER :: HP3795=0.3795
7082 REAL,PARAMETER :: HP369=0.369
7083 REAL,PARAMETER :: HP26=0.26
7084 REAL,PARAMETER :: HP228=0.228
7085 REAL,PARAMETER :: HP219=0.219
7086 REAL,PARAMETER :: HP166666=.166666
7087 REAL,PARAMETER :: HP144=0.144
7088 REAL,PARAMETER :: HP118666=0.118666192
7089 REAL,PARAMETER :: HP1=0.1
7090 ! (NEGATIVE EXPONENTIALS BEGIN HERE)
7091 REAL,PARAMETER :: H658M2=0.0658
7092 REAL,PARAMETER :: H625M2=0.0625
7093 REAL,PARAMETER :: H44871M2=4.4871E-2
7094 REAL,PARAMETER :: H44194M2=.044194
7095 REAL,PARAMETER :: H42M2=0.042
7096 REAL,PARAMETER :: H41666M2=0.0416666
7097 REAL,PARAMETER :: H28571M2=.02857142857
7098 REAL,PARAMETER :: H2118M2=0.02118
7099 REAL,PARAMETER :: H129M2=0.0129
7100 REAL,PARAMETER :: H1M2=.01
7101 REAL,PARAMETER :: H559M3=5.59E-3
7102 REAL,PARAMETER :: H3M3=0.003
7103 REAL,PARAMETER :: H235M3=2.35E-3
7104 REAL,PARAMETER :: H1M3=1.0E-3
7105 REAL,PARAMETER :: H987M4=9.87E-4
7106 REAL,PARAMETER :: H323M4=0.000323
7107 REAL,PARAMETER :: H3M4=0.0003
7108 REAL,PARAMETER :: H285M4=2.85E-4
7109 REAL,PARAMETER :: H1M4=0.0001
7110 REAL,PARAMETER :: H75826M4=7.58265E-4
7111 REAL,PARAMETER :: H6938M5=6.938E-5
7112 REAL,PARAMETER :: H394M5=3.94E-5
7113 REAL,PARAMETER :: H37412M5=3.7412E-5
7114 REAL,PARAMETER :: H15M5=1.5E-5
7115 REAL,PARAMETER :: H1439M5=1.439E-5
7116 REAL,PARAMETER :: H128M5=1.28E-5
7117 REAL,PARAMETER :: H102M5=1.02E-5
7118 REAL,PARAMETER :: H1M5=1.0E-5
7119 REAL,PARAMETER :: H7M6=7.E-6
7120 REAL,PARAMETER :: H4999M6=4.999E-6
7121 REAL,PARAMETER :: H451M6=4.51E-6
7122 REAL,PARAMETER :: H25452M6=2.5452E-6
7123 REAL,PARAMETER :: H1M6=1.E-6
7124 REAL,PARAMETER :: H391M7=3.91E-7
7125 REAL,PARAMETER :: H1174M7=1.174E-7
7126 REAL,PARAMETER :: H8725M8=8.725E-8
7127 REAL,PARAMETER :: H327M8=3.27E-8
7128 REAL,PARAMETER :: H257M8=2.57E-8
7129 REAL,PARAMETER :: H1M8=1.0E-8
7130 REAL,PARAMETER :: H23M10=2.3E-10
7131 REAL,PARAMETER :: H14M10=1.4E-10
7132 REAL,PARAMETER :: H11M10=1.1E-10
7133 REAL,PARAMETER :: H1M10=1.E-10
7134 REAL,PARAMETER :: H83M11=8.3E-11
7135 REAL,PARAMETER :: H82M11=8.2E-11
7136 REAL,PARAMETER :: H8M11=8.E-11
7137 REAL,PARAMETER :: H77M11=7.7E-11
7138 REAL,PARAMETER :: H72M11=7.2E-11
7139 REAL,PARAMETER :: H53M11=5.3E-11
7140 REAL,PARAMETER :: H48M11=4.8E-11
7141 REAL,PARAMETER :: H44M11=4.4E-11
7142 REAL,PARAMETER :: H42M11=4.2E-11
7143 REAL,PARAMETER :: H37M11=3.7E-11
7144 REAL,PARAMETER :: H35M11=3.5E-11
7145 REAL,PARAMETER :: H32M11=3.2E-11
7146 REAL,PARAMETER :: H3M11=3.0E-11
7147 REAL,PARAMETER :: H28M11=2.8E-11
7148 REAL,PARAMETER :: H24M11=2.4E-11
7149 REAL,PARAMETER :: H23M11=2.3E-11
7150 REAL,PARAMETER :: H2M11=2.E-11
7151 REAL,PARAMETER :: H18M11=1.8E-11
7152 REAL,PARAMETER :: H15M11=1.5E-11
7153 REAL,PARAMETER :: H14M11=1.4E-11
7154 REAL,PARAMETER :: H114M11=1.14E-11
7155 REAL,PARAMETER :: H11M11=1.1E-11
7156 REAL,PARAMETER :: H1M11=1.E-11
7157 REAL,PARAMETER :: H96M12=9.6E-12
7158 REAL,PARAMETER :: H93M12=9.3E-12
7159 REAL,PARAMETER :: H77M12=7.7E-12
7160 REAL,PARAMETER :: H74M12=7.4E-12
7161 REAL,PARAMETER :: H65M12=6.5E-12
7162 REAL,PARAMETER :: H62M12=6.2E-12
7163 REAL,PARAMETER :: H6M12=6.E-12
7164 REAL,PARAMETER :: H45M12=4.5E-12
7165 REAL,PARAMETER :: H44M12=4.4E-12
7166 REAL,PARAMETER :: H4M12=4.E-12
7167 REAL,PARAMETER :: H38M12=3.8E-12
7168 REAL,PARAMETER :: H37M12=3.7E-12
7169 REAL,PARAMETER :: H3M12=3.E-12
7170 REAL,PARAMETER :: H29M12=2.9E-12
7171 REAL,PARAMETER :: H28M12=2.8E-12
7172 REAL,PARAMETER :: H24M12=2.4E-12
7173 REAL,PARAMETER :: H21M12=2.1E-12
7174 REAL,PARAMETER :: H16M12=1.6E-12
7175 REAL,PARAMETER :: H14M12=1.4E-12
7176 REAL,PARAMETER :: H12M12=1.2E-12
7177 REAL,PARAMETER :: H8M13=8.E-13
7178 REAL,PARAMETER :: H46M13=4.6E-13
7179 REAL,PARAMETER :: H36M13=3.6E-13
7180 REAL,PARAMETER :: H135M13=1.35E-13
7181 REAL,PARAMETER :: H12M13=1.2E-13
7182 REAL,PARAMETER :: H1M13=1.E-13
7183 REAL,PARAMETER :: H3M14=3.E-14
7184 REAL,PARAMETER :: H15M14=1.5E-14
7185 REAL,PARAMETER :: H14M14=1.4E-14
7186 !
7187 !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
7188 ! ARRANGED IN DESCENDING ORDER
7189 REAL,PARAMETER :: HM2M2=-.02
7190 REAL,PARAMETER :: HM6666M2=-.066667
7191 REAL,PARAMETER :: HMP5=-0.5
7192 REAL,PARAMETER :: HMP575=-0.575
7193 REAL,PARAMETER :: HMP66667=-.66667
7194 REAL,PARAMETER :: HMP805=-0.805
7195 REAL,PARAMETER :: HM1EZ=-1.
7196 REAL,PARAMETER :: HM13EZ=-1.3
7197 REAL,PARAMETER :: HM19EZ=-1.9
7198 REAL,PARAMETER :: HM1E1=-10.
7199 REAL,PARAMETER :: HM1597E1=-15.97469413
7200 REAL,PARAMETER :: HM161E1=-16.1
7201 REAL,PARAMETER :: HM1797E1=-17.97469413
7202 REAL,PARAMETER :: HM181E1=-18.1
7203 REAL,PARAMETER :: HM8E1=-80.
7204 REAL,PARAMETER :: HM1E2=-100.
7205 !
7206 REAL,PARAMETER :: H1M16=1.0E-16
7207 REAL,PARAMETER :: H1M20=1.E-20
7208 REAL,PARAMETER :: HP98=0.98
7209 REAL,PARAMETER :: Q19001=19.001
7210 REAL,PARAMETER :: DAYSEC=1.1574E-5
7211 REAL,PARAMETER :: HSIGMA=5.673E-5
7212 REAL,PARAMETER :: TWENTY=20.0
7213 REAL,PARAMETER :: HP537=0.537
7214 REAL,PARAMETER :: HP2=0.2
7215 REAL,PARAMETER :: RCO2=3.3E-4
7216 REAL,PARAMETER :: H3M6=3.0E-6
7217 REAL,PARAMETER :: PI=3.1415927
7218 REAL,PARAMETER :: DEGRAD1=180.0/PI
7219 REAL,PARAMETER :: H74E1=74.0
7220 REAL,PARAMETER :: H15E1=15.0
7222 REAL, PARAMETER:: B0 = -.51926410E-4
7223 REAL, PARAMETER:: B1 = -.18113332E-3
7224 REAL, PARAMETER:: B2 = -.10680132E-5
7225 REAL, PARAMETER:: B3 = -.67303519E-7
7226 REAL, PARAMETER:: AWIDE = 0.309801E+01
7227 REAL, PARAMETER:: BWIDE = 0.495357E-01
7228 REAL, PARAMETER:: BETAWD = 0.347839E+02
7229 REAL, PARAMETER:: BETINW = 0.766811E+01
7232 ! REAL, INTENT(OUT) :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), &
7233 ! TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
7234 ! SOURCE(28,NBLY), DSRCE(28,NBLY)
7236 !
7237 REAL :: ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW)
7238 REAL :: BANDLO(NBLW),BANDHI(NBLW)
7240 INTEGER :: IBAND(40)
7242 REAL :: BANDL1(64),BANDL2(64),BANDL3(35)
7243 REAL :: BANDH1(64),BANDH2(64),BANDH3(35)
7244 ! REAL :: AB15WD,SKO2D,SKC1R,SKO3R
7246 ! REAL :: AWIDE,BWIDE,BETAWD,BETINW
7248 ! DATA AWIDE / 0.309801E+01/
7249 ! DATA BWIDE / 0.495357E-01/
7250 ! DATA BETAWD / 0.347839E+02/
7251 ! DATA BETINW / 0.766811E+01/
7253 !
7254 !% #NPADL = #PAGE*#NPAGE - 4*28*180 - 2*181 - 7*28 - 180 ;
7255 !% #NPADL = #NPADL - 11*28 - 2*180 - 2*30 ;
7257 ! PARAMETER (NPADL = #NPADL - 28*NBLX - 2*28*NBLW - 7*NBLW)
7259 REAL :: &
7260 SUM(28,180),PERTSM(28,180),SUM3(28,180), &
7261 SUMWDE(28,180),SRCWD(28,NBLX),SRC1NB(28,NBLW), &
7262 DBDTNB(28,NBLW)
7263 REAL :: &
7264 ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28), &
7265 TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28), &
7266 SUM4(28),SUM6(28),SUM7(28),SUM8(28),SUM4WD(28), &
7267 R1T(28),R2(28),S2(28),T3(28),R1WD(28)
7268 REAL :: EXPO(180),FAC(180)
7269 REAL :: CNUSB(30),DNUSB(30)
7270 REAL :: ALFANB(NBLW),AROTNB(NBLW)
7271 REAL :: ANB(NBLW),BNB(NBLW),CENTNB(NBLW),DELNB(NBLW), &
7272 BETANB(NBLW)
7274 REAL :: AB15(2)
7276 REAL :: ARNDM1(64),ARNDM2(64),ARNDM3(35)
7277 REAL :: BRNDM1(64),BRNDM2(64),BRNDM3(35)
7278 REAL :: BETAD1(64),BETAD2(64),BETAD3(35)
7280 EQUIVALENCE (ARNDM1(1),ARNDM(1)),(ARNDM2(1),ARNDM(65)), &
7281 (ARNDM3(1),ARNDM(129))
7282 EQUIVALENCE (BRNDM1(1),BRNDM(1)),(BRNDM2(1),BRNDM(65)), &
7283 (BRNDM3(1),BRNDM(129))
7284 EQUIVALENCE (BETAD1(1),BETAD(1)),(BETAD2(1),BETAD(65)), &
7285 (BETAD3(1),BETAD(129))
7287 !---------------------------------------------------------------
7288 REAL :: CENT,DEL,BDLO,BDHI,C1,ANU,tmp
7289 INTEGER :: N,I,ICNT,I1,I2E,I2
7290 INTEGER :: J,JP,NSUBDS,NSB,IA
7292 !---------------------------------------------------------------
7294 DATA IBAND / &
7295 2, 1, 2, 2, 1, 2, 1, 3, 2, 2, &
7296 3, 2, 2, 4, 2, 4, 2, 3, 3, 2, &
7297 4, 3, 4, 3, 7, 5, 6, 7, 6, 5, &
7298 7, 6, 7, 8, 6, 6, 8, 8, 8, 8/
7300 DATA BANDL1 / &
7301 0.000000E+00, 0.100000E+02, 0.200000E+02, 0.300000E+02, &
7302 0.400000E+02, 0.500000E+02, 0.600000E+02, 0.700000E+02, &
7303 0.800000E+02, 0.900000E+02, 0.100000E+03, 0.110000E+03, &
7304 0.120000E+03, 0.130000E+03, 0.140000E+03, 0.150000E+03, &
7305 0.160000E+03, 0.170000E+03, 0.180000E+03, 0.190000E+03, &
7306 0.200000E+03, 0.210000E+03, 0.220000E+03, 0.230000E+03, &
7307 0.240000E+03, 0.250000E+03, 0.260000E+03, 0.270000E+03, &
7308 0.280000E+03, 0.290000E+03, 0.300000E+03, 0.310000E+03, &
7309 0.320000E+03, 0.330000E+03, 0.340000E+03, 0.350000E+03, &
7310 0.360000E+03, 0.370000E+03, 0.380000E+03, 0.390000E+03, &
7311 0.400000E+03, 0.410000E+03, 0.420000E+03, 0.430000E+03, &
7312 0.440000E+03, 0.450000E+03, 0.460000E+03, 0.470000E+03, &
7313 0.480000E+03, 0.490000E+03, 0.500000E+03, 0.510000E+03, &
7314 0.520000E+03, 0.530000E+03, 0.540000E+03, 0.550000E+03, &
7315 0.560000E+03, 0.670000E+03, 0.800000E+03, 0.900000E+03, &
7316 0.990000E+03, 0.107000E+04, 0.120000E+04, 0.121000E+04/
7317 DATA BANDL2 / &
7318 0.122000E+04, 0.123000E+04, 0.124000E+04, 0.125000E+04, &
7319 0.126000E+04, 0.127000E+04, 0.128000E+04, 0.129000E+04, &
7320 0.130000E+04, 0.131000E+04, 0.132000E+04, 0.133000E+04, &
7321 0.134000E+04, 0.135000E+04, 0.136000E+04, 0.137000E+04, &
7322 0.138000E+04, 0.139000E+04, 0.140000E+04, 0.141000E+04, &
7323 0.142000E+04, 0.143000E+04, 0.144000E+04, 0.145000E+04, &
7324 0.146000E+04, 0.147000E+04, 0.148000E+04, 0.149000E+04, &
7325 0.150000E+04, 0.151000E+04, 0.152000E+04, 0.153000E+04, &
7326 0.154000E+04, 0.155000E+04, 0.156000E+04, 0.157000E+04, &
7327 0.158000E+04, 0.159000E+04, 0.160000E+04, 0.161000E+04, &
7328 0.162000E+04, 0.163000E+04, 0.164000E+04, 0.165000E+04, &
7329 0.166000E+04, 0.167000E+04, 0.168000E+04, 0.169000E+04, &
7330 0.170000E+04, 0.171000E+04, 0.172000E+04, 0.173000E+04, &
7331 0.174000E+04, 0.175000E+04, 0.176000E+04, 0.177000E+04, &
7332 0.178000E+04, 0.179000E+04, 0.180000E+04, 0.181000E+04, &
7333 0.182000E+04, 0.183000E+04, 0.184000E+04, 0.185000E+04/
7334 DATA BANDL3 / &
7335 0.186000E+04, 0.187000E+04, 0.188000E+04, 0.189000E+04, &
7336 0.190000E+04, 0.191000E+04, 0.192000E+04, 0.193000E+04, &
7337 0.194000E+04, 0.195000E+04, 0.196000E+04, 0.197000E+04, &
7338 0.198000E+04, 0.199000E+04, 0.200000E+04, 0.201000E+04, &
7339 0.202000E+04, 0.203000E+04, 0.204000E+04, 0.205000E+04, &
7340 0.206000E+04, 0.207000E+04, 0.208000E+04, 0.209000E+04, &
7341 0.210000E+04, 0.211000E+04, 0.212000E+04, 0.213000E+04, &
7342 0.214000E+04, 0.215000E+04, 0.216000E+04, 0.217000E+04, &
7343 0.218000E+04, 0.219000E+04, 0.227000E+04/
7345 DATA BANDH1 / &
7346 0.100000E+02, 0.200000E+02, 0.300000E+02, 0.400000E+02, &
7347 0.500000E+02, 0.600000E+02, 0.700000E+02, 0.800000E+02, &
7348 0.900000E+02, 0.100000E+03, 0.110000E+03, 0.120000E+03, &
7349 0.130000E+03, 0.140000E+03, 0.150000E+03, 0.160000E+03, &
7350 0.170000E+03, 0.180000E+03, 0.190000E+03, 0.200000E+03, &
7351 0.210000E+03, 0.220000E+03, 0.230000E+03, 0.240000E+03, &
7352 0.250000E+03, 0.260000E+03, 0.270000E+03, 0.280000E+03, &
7353 0.290000E+03, 0.300000E+03, 0.310000E+03, 0.320000E+03, &
7354 0.330000E+03, 0.340000E+03, 0.350000E+03, 0.360000E+03, &
7355 0.370000E+03, 0.380000E+03, 0.390000E+03, 0.400000E+03, &
7356 0.410000E+03, 0.420000E+03, 0.430000E+03, 0.440000E+03, &
7357 0.450000E+03, 0.460000E+03, 0.470000E+03, 0.480000E+03, &
7358 0.490000E+03, 0.500000E+03, 0.510000E+03, 0.520000E+03, &
7359 0.530000E+03, 0.540000E+03, 0.550000E+03, 0.560000E+03, &
7360 0.670000E+03, 0.800000E+03, 0.900000E+03, 0.990000E+03, &
7361 0.107000E+04, 0.120000E+04, 0.121000E+04, 0.122000E+04/
7362 DATA BANDH2 / &
7363 0.123000E+04, 0.124000E+04, 0.125000E+04, 0.126000E+04, &
7364 0.127000E+04, 0.128000E+04, 0.129000E+04, 0.130000E+04, &
7365 0.131000E+04, 0.132000E+04, 0.133000E+04, 0.134000E+04, &
7366 0.135000E+04, 0.136000E+04, 0.137000E+04, 0.138000E+04, &
7367 0.139000E+04, 0.140000E+04, 0.141000E+04, 0.142000E+04, &
7368 0.143000E+04, 0.144000E+04, 0.145000E+04, 0.146000E+04, &
7369 0.147000E+04, 0.148000E+04, 0.149000E+04, 0.150000E+04, &
7370 0.151000E+04, 0.152000E+04, 0.153000E+04, 0.154000E+04, &
7371 0.155000E+04, 0.156000E+04, 0.157000E+04, 0.158000E+04, &
7372 0.159000E+04, 0.160000E+04, 0.161000E+04, 0.162000E+04, &
7373 0.163000E+04, 0.164000E+04, 0.165000E+04, 0.166000E+04, &
7374 0.167000E+04, 0.168000E+04, 0.169000E+04, 0.170000E+04, &
7375 0.171000E+04, 0.172000E+04, 0.173000E+04, 0.174000E+04, &
7376 0.175000E+04, 0.176000E+04, 0.177000E+04, 0.178000E+04, &
7377 0.179000E+04, 0.180000E+04, 0.181000E+04, 0.182000E+04, &
7378 0.183000E+04, 0.184000E+04, 0.185000E+04, 0.186000E+04/
7379 DATA BANDH3 / &
7380 0.187000E+04, 0.188000E+04, 0.189000E+04, 0.190000E+04, &
7381 0.191000E+04, 0.192000E+04, 0.193000E+04, 0.194000E+04, &
7382 0.195000E+04, 0.196000E+04, 0.197000E+04, 0.198000E+04, &
7383 0.199000E+04, 0.200000E+04, 0.201000E+04, 0.202000E+04, &
7384 0.203000E+04, 0.204000E+04, 0.205000E+04, 0.206000E+04, &
7385 0.207000E+04, 0.208000E+04, 0.209000E+04, 0.210000E+04, &
7386 0.211000E+04, 0.212000E+04, 0.213000E+04, 0.214000E+04, &
7387 0.215000E+04, 0.216000E+04, 0.217000E+04, 0.218000E+04, &
7388 0.219000E+04, 0.220000E+04, 0.238000E+04/
7390 !
7391 !***THE FOLLOWING DATA STATEMENTS ARE BAND PARAMETERS OBTAINED USING
7392 ! THE 1982 AFGL CATALOG ON THE SPECIFIED BANDS
7393 DATA ARNDM1 / &
7394 0.354693E+00, 0.269857E+03, 0.167062E+03, 0.201314E+04, &
7395 0.964533E+03, 0.547971E+04, 0.152933E+04, 0.599429E+04, &
7396 0.699329E+04, 0.856721E+04, 0.962489E+04, 0.233348E+04, &
7397 0.127091E+05, 0.104383E+05, 0.504249E+04, 0.181227E+05, &
7398 0.856480E+03, 0.136354E+05, 0.288635E+04, 0.170200E+04, &
7399 0.209761E+05, 0.126797E+04, 0.110096E+05, 0.336436E+03, &
7400 0.491663E+04, 0.863701E+04, 0.540389E+03, 0.439786E+04, &
7401 0.347836E+04, 0.130557E+03, 0.465332E+04, 0.253086E+03, &
7402 0.257387E+04, 0.488041E+03, 0.892991E+03, 0.117148E+04, &
7403 0.125880E+03, 0.458852E+03, 0.142975E+03, 0.446355E+03, &
7404 0.302887E+02, 0.394451E+03, 0.438112E+02, 0.348811E+02, &
7405 0.615503E+02, 0.143165E+03, 0.103958E+02, 0.725108E+02, &
7406 0.316628E+02, 0.946456E+01, 0.542675E+02, 0.351557E+02, &
7407 0.301797E+02, 0.381010E+01, 0.126319E+02, 0.548010E+01, &
7408 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, &
7409 0.178110E-01, 0.170166E+00, 0.273514E-01, 0.983767E+00/
7410 DATA ARNDM2 / &
7411 0.753946E+00, 0.941763E-01, 0.970547E+00, 0.268862E+00, &
7412 0.564373E+01, 0.389794E+01, 0.310955E+01, 0.128235E+01, &
7413 0.196414E+01, 0.247113E+02, 0.593435E+01, 0.377552E+02, &
7414 0.305173E+02, 0.852479E+01, 0.116780E+03, 0.101490E+03, &
7415 0.138939E+03, 0.324228E+03, 0.683729E+02, 0.471304E+03, &
7416 0.159684E+03, 0.427101E+03, 0.114716E+03, 0.106190E+04, &
7417 0.294607E+03, 0.762948E+03, 0.333199E+03, 0.830645E+03, &
7418 0.162512E+04, 0.525676E+03, 0.137739E+04, 0.136252E+04, &
7419 0.147164E+04, 0.187196E+04, 0.131118E+04, 0.103975E+04, &
7420 0.621637E+01, 0.399459E+02, 0.950648E+02, 0.943161E+03, &
7421 0.526821E+03, 0.104150E+04, 0.905610E+03, 0.228142E+04, &
7422 0.806270E+03, 0.691845E+03, 0.155237E+04, 0.192241E+04, &
7423 0.991871E+03, 0.123907E+04, 0.457289E+02, 0.146146E+04, &
7424 0.319382E+03, 0.436074E+03, 0.374214E+03, 0.778217E+03, &
7425 0.140227E+03, 0.562540E+03, 0.682685E+02, 0.820292E+02, &
7426 0.178779E+03, 0.186150E+03, 0.383864E+03, 0.567416E+01/
7427 DATA ARNDM3 / &
7428 0.225129E+03, 0.473099E+01, 0.753149E+02, 0.233689E+02, &
7429 0.339802E+02, 0.108855E+03, 0.380016E+02, 0.151039E+01, &
7430 0.660346E+02, 0.370165E+01, 0.234169E+02, 0.440206E+00, &
7431 0.615283E+01, 0.304077E+02, 0.117769E+01, 0.125248E+02, &
7432 0.142652E+01, 0.241831E+00, 0.483721E+01, 0.226357E-01, &
7433 0.549835E+01, 0.597067E+00, 0.404553E+00, 0.143584E+01, &
7434 0.294291E+00, 0.466273E+00, 0.156048E+00, 0.656185E+00, &
7435 0.172727E+00, 0.118349E+00, 0.141598E+00, 0.588581E-01, &
7436 0.919409E-01, 0.155521E-01, 0.537083E-02/
7437 DATA BRNDM1 / &
7438 0.789571E-01, 0.920256E-01, 0.696960E-01, 0.245544E+00, &
7439 0.188503E+00, 0.266127E+00, 0.271371E+00, 0.330917E+00, &
7440 0.190424E+00, 0.224498E+00, 0.282517E+00, 0.130675E+00, &
7441 0.212579E+00, 0.227298E+00, 0.138585E+00, 0.187106E+00, &
7442 0.194527E+00, 0.177034E+00, 0.115902E+00, 0.118499E+00, &
7443 0.142848E+00, 0.216869E+00, 0.149848E+00, 0.971585E-01, &
7444 0.151532E+00, 0.865628E-01, 0.764246E-01, 0.100035E+00, &
7445 0.171133E+00, 0.134737E+00, 0.105173E+00, 0.860832E-01, &
7446 0.148921E+00, 0.869234E-01, 0.106018E+00, 0.184865E+00, &
7447 0.767454E-01, 0.108981E+00, 0.123094E+00, 0.177287E+00, &
7448 0.848146E-01, 0.119356E+00, 0.133829E+00, 0.954505E-01, &
7449 0.155405E+00, 0.164167E+00, 0.161390E+00, 0.113287E+00, &
7450 0.714720E-01, 0.741598E-01, 0.719590E-01, 0.140616E+00, &
7451 0.355356E-01, 0.832779E-01, 0.128680E+00, 0.983013E-01, &
7452 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, &
7453 0.875182E-01, 0.857907E-01, 0.358808E+00, 0.178840E+00/
7454 DATA BRNDM2 / &
7455 0.254265E+00, 0.297901E+00, 0.153916E+00, 0.537774E+00, &
7456 0.267906E+00, 0.104254E+00, 0.400723E+00, 0.389670E+00, &
7457 0.263701E+00, 0.338116E+00, 0.351528E+00, 0.267764E+00, &
7458 0.186419E+00, 0.238237E+00, 0.210408E+00, 0.176869E+00, &
7459 0.114715E+00, 0.173299E+00, 0.967770E-01, 0.172565E+00, &
7460 0.162085E+00, 0.157782E+00, 0.886832E-01, 0.242999E+00, &
7461 0.760298E-01, 0.164248E+00, 0.221428E+00, 0.166799E+00, &
7462 0.312514E+00, 0.380600E+00, 0.353828E+00, 0.269500E+00, &
7463 0.254759E+00, 0.285408E+00, 0.159764E+00, 0.721058E-01, &
7464 0.170528E+00, 0.231595E+00, 0.307184E+00, 0.564136E-01, &
7465 0.159884E+00, 0.147907E+00, 0.185666E+00, 0.183567E+00, &
7466 0.182482E+00, 0.230650E+00, 0.175348E+00, 0.195978E+00, &
7467 0.255323E+00, 0.198517E+00, 0.195500E+00, 0.208356E+00, &
7468 0.309603E+00, 0.112011E+00, 0.102570E+00, 0.128276E+00, &
7469 0.168100E+00, 0.177836E+00, 0.105533E+00, 0.903330E-01, &
7470 0.126036E+00, 0.101430E+00, 0.124546E+00, 0.221406E+00/
7471 DATA BRNDM3 / &
7472 0.137509E+00, 0.911365E-01, 0.724508E-01, 0.795788E-01, &
7473 0.137411E+00, 0.549175E-01, 0.787714E-01, 0.165544E+00, &
7474 0.136484E+00, 0.146729E+00, 0.820496E-01, 0.846211E-01, &
7475 0.785821E-01, 0.122527E+00, 0.125359E+00, 0.101589E+00, &
7476 0.155756E+00, 0.189239E+00, 0.999086E-01, 0.480993E+00, &
7477 0.100233E+00, 0.153754E+00, 0.130780E+00, 0.136136E+00, &
7478 0.159353E+00, 0.156634E+00, 0.272265E+00, 0.186874E+00, &
7479 0.192090E+00, 0.135397E+00, 0.131497E+00, 0.127463E+00, &
7480 0.227233E+00, 0.190562E+00, 0.214005E+00/
7481 DATA BETAD1 / &
7482 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7483 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7484 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7485 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7486 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7487 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7488 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7489 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7490 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7491 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7492 0.234879E+03, 0.217419E+03, 0.201281E+03, 0.186364E+03, &
7493 0.172576E+03, 0.159831E+03, 0.148051E+03, 0.137163E+03, &
7494 0.127099E+03, 0.117796E+03, 0.109197E+03, 0.101249E+03, &
7495 0.939031E+02, 0.871127E+02, 0.808363E+02, 0.750349E+02, &
7496 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, &
7497 0.589554E+01, 0.495227E+01, 0.000000E+00, 0.000000E+00/
7498 DATA BETAD2 / &
7499 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7500 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7501 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7502 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7503 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7504 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7505 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7506 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7507 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7508 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7509 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7510 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7511 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7512 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7513 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7514 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00/
7515 DATA BETAD3 / &
7516 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7517 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7518 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7519 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7520 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7521 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7522 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7523 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7524 0.000000E+00, 0.000000E+00, 0.000000E+00/
7525 !---------------------------------------------------------------
7526 ! EQUIVALENCE (BANDL1(1),BANDLO(1)),(BANDL2(1),BANDLO(65)), &
7527 ! (BANDL3(1),BANDLO(129))
7529 ! L = kme-1
7530 ! LP1 = L+1
7531 ! LP1V = LP1*(1+2*L/2)
7532 ! IMAX = ite
7533 ! LP2 = L + 2
7535 DO I = 1,64
7536 BANDLO(I)=BANDL1(I)
7537 ENDDO
7539 DO I = 65,128
7540 BANDLO(I)=BANDL2(I-64)
7541 ENDDO
7543 DO I = 129,163
7544 BANDLO(I)=BANDL3(I-128)
7545 ENDDO
7547 DO I = 1,64
7548 BANDHI(I)=BANDH1(I)
7549 ENDDO
7551 DO I = 65,128
7552 BANDHI(I)=BANDH2(I-64)
7553 ENDDO
7555 DO I = 129,163
7556 BANDHI(I)=BANDH3(I-128)
7557 ENDDO
7559 !****************************************
7560 !***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15
7561 !....FOR NARROW-BANDS...
7562 DO 101 N=1,NBLW
7563 ANB(N)=ARNDM(N)
7564 BNB(N)=BRNDM(N)
7565 CENTNB(N)=HAF*(BANDLO(N)+BANDHI(N))
7566 DELNB(N)=BANDHI(N)-BANDLO(N)
7567 BETANB(N)=BETAD(N)
7568 101 CONTINUE
7569 AB15(1)=ANB(57)*BNB(57)
7570 AB15(2)=ANB(58)*BNB(58)
7571 !....FOR WIDE BANDS...
7572 AB15WD=AWIDE*BWIDE
7573 !
7574 !***COMPUTE INDICES: IND,INDX2,KMAXV
7575 !SH ICNT=0
7576 !SH DO 113 I1=1,L
7577 !SH I2E=LP1-I1
7578 !SH DO 115 I2=1,I2E
7579 !SH ICNT=ICNT+1
7580 !SH INDX2(ICNT)=LP1*(I2-1)+LP2*I1
7581 !SH115 CONTINUE
7582 !SH113 CONTINUE
7583 !SH KMAXV(1)=1
7584 !SH DO 117 I=2,L
7585 !SH KMAXV(I)=KMAXV(I-1)+(LP2-I)
7586 117 CONTINUE
7587 !SH KMAXVM=KMAXV(L)
7588 !***COMPUTE RATIOS OF CONT. COEFFS
7589 SKC1R=BETAWD/BETINW
7590 SKO3R=BETAD(61)/BETINW
7591 SKO2D=ONE/BETINW
7592 !
7593 !****BEGIN TABLE COMPUTATIONS HERE***
7594 !***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES
7595 !---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS
7596 ! WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM
7597 ! 100K TO 370K.
7598 !---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF
7599 ! 180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS
7600 ! ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS.
7601 ZMASS(1)=H1M16
7602 DO 201 J=1,180
7603 JP=J+1
7604 ZROOT(J)=SQRT(ZMASS(J))
7605 ZMASS(JP)=ZMASS(J)*H1P25892
7606 201 CONTINUE
7607 DO 203 I=1,28
7608 XTEMV(I)=HNINETY+TEN*I
7609 TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I)
7610 FORTCU(I)=FOUR*XTEMV(I)*XTEMV(I)*XTEMV(I)
7611 203 CONTINUE
7612 !******THE COMPUTATION OF SOURCE,DSRCE IS NEEDED ONLY
7613 ! FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE
7614 ! MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD)
7615 ! THEN COMBINED (USING IBAND) INTO SOURCE.
7616 DO 205 N=1,NBLY
7617 DO 205 I=1,28
7618 SOURCE(I,N)=ZERO
7619 205 CONTINUE
7620 DO 207 N=1,NBLX
7621 DO 207 I=1,28
7622 SRCWD(I,N)=ZERO
7623 207 CONTINUE
7624 !---BEGIN FREQ. LOOP (ON N)
7625 DO 211 N=1,NBLX
7626 IF (N.LE.46) THEN
7627 !***THE 160-1200 BAND CASES
7628 CENT=CENTNB(N+16)
7629 DEL=DELNB(N+16)
7630 BDLO=BANDLO(N+16)
7631 BDHI=BANDHI(N+16)
7632 ENDIF
7633 IF (N.EQ.NBLX) THEN
7634 !***THE 2270-2380 BAND CASE
7635 CENT=CENTNB(NBLW)
7636 DEL=DELNB(NBLW)
7637 BDLO=BANDLO(NBLW)
7638 BDHI=BANDHI(NBLW)
7639 ENDIF
7640 !***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE
7641 ! ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS.
7642 NSUBDS=(DEL-H1M3)/10+1
7643 DO 213 NSB=1,NSUBDS
7644 IF (NSB.NE.NSUBDS) THEN
7645 CNUSB(NSB)=TEN*(NSB-1)+BDLO+FIVE
7646 DNUSB(NSB)=TEN
7647 ELSE
7648 CNUSB(NSB)=HAF*(TEN*(NSB-1)+BDLO+BDHI)
7649 DNUSB(NSB)=BDHI-(TEN*(NSB-1)+BDLO)
7650 ENDIF
7651 C1=(H37412M5)*CNUSB(NSB)**3
7652 !---BEGIN TEMP. LOOP (ON I)
7653 DO 215 I=1,28
7654 X(I)=H1P4387*CNUSB(NSB)/XTEMV(I)
7655 X1(I)=EXP(X(I))
7656 SRCS(I)=C1/(X1(I)-ONE)
7657 SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB)
7658 215 CONTINUE
7659 213 CONTINUE
7660 211 CONTINUE
7661 !***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE
7662 ! AND DSRCE
7663 DO 221 N=1,40
7664 DO 221 I=1,28
7665 SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N)
7666 221 CONTINUE
7667 DO 223 N=9,NBLY
7668 DO 223 I=1,28
7669 SOURCE(I,N)=SRCWD(I,N+32)
7670 223 CONTINUE
7671 DO 225 N=1,NBLY
7672 DO 225 I=1,27
7673 DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*HP1
7674 225 CONTINUE
7675 DO 231 N=1,NBLW
7676 ALFANB(N)=BNB(N)*ANB(N)
7677 AROTNB(N)=SQRT(ALFANB(N))
7678 231 CONTINUE
7679 !***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR
7680 ! USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE
7681 ! BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ.
7682 ! RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT.
7683 !
7684 DO 301 N=1,NBLW
7685 CENT=CENTNB(N)
7686 DEL=DELNB(N)
7687 !---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT
7688 ! IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR
7689 ! THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY.
7690 #if 0
7691 DO 303 IA=1,3
7692 #else
7693 !jm -- getting floating point exceptions for IA=1, since 2 is only
7694 ! used anyway, I disabled the looping.
7695 DO 303 IA=2,2
7696 #endif
7697 ANU=CENT+HAF*(IA-2)*DEL
7698 C1=(H37412M5)*ANU*ANU*ANU+H1M20
7699 !---TEMPERATURE LOOP---
7700 DO 305 I=1,28
7701 X(I)=H1P4387*ANU/XTEMV(I)
7702 X1(I)=EXP(X(I))
7703 !#$ tmp=max((X1(I)-ONE),H1M20)
7704 !#$ SC(I)=C1/tmp
7705 SC(I)=C1/((X1(I)-ONE)+H1M20)
7706 !#$ DSC(I)=X(I)*SC(I)*SC(I)*X1(I)/(XTEMV(I)*C1)
7707 DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1)
7708 305 CONTINUE
7709 IF (IA.EQ.2) THEN
7710 DO 307 I=1,28
7711 SRC1NB(I,N)=DEL*SC(I)
7712 DBDTNB(I,N)=DEL*DSC(I)
7713 307 CONTINUE
7714 ENDIF
7715 303 CONTINUE
7716 301 CONTINUE
7717 !***NEXT COMPUTE R1T,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION
7718 ! WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A
7719 ! DIFFERENT DEPENDENCE ON (ZMASS).
7720 !---ALSO OBTAIN R1WD, WHICH IS R1T SUMMED OVER THE 160-560 CM-1 RANGE
7721 DO 311 I=1,28
7722 SUM4(I)=ZERO
7723 SUM6(I)=ZERO
7724 SUM7(I)=ZERO
7725 SUM8(I)=ZERO
7726 SUM4WD(I)=ZERO
7727 311 CONTINUE
7728 DO 313 N=1,NBLW
7729 CENT=CENTNB(N)
7730 !***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4
7731 ! SUM6,SUM7,SUM8
7732 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
7733 DO 315 I=1,28
7734 SUM4(I)=SUM4(I)+SRC1NB(I,N)
7735 SUM6(I)=SUM6(I)+DBDTNB(I,N)
7736 SUM7(I)=SUM7(I)+DBDTNB(I,N)*AROTNB(N)
7737 SUM8(I)=SUM8(I)+DBDTNB(I,N)*ALFANB(N)
7738 315 CONTINUE
7739 ENDIF
7740 !***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD
7741 IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
7742 DO 316 I=1,28
7743 SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N)
7744 316 CONTINUE
7745 ENDIF
7746 313 CONTINUE
7747 DO 317 I=1,28
7748 R1T(I)=SUM4(I)/TFOUR(I)
7749 R2(I)=SUM6(I)/FORTCU(I)
7750 S2(I)=SUM7(I)/FORTCU(I)
7751 T3(I)=SUM8(I)/FORTCU(I)
7752 R1WD(I)=SUM4WD(I)/TFOUR(I)
7753 317 CONTINUE
7754 DO 401 J=1,180
7755 DO 401 I=1,28
7756 SUM(I,J)=ZERO
7757 PERTSM(I,J)=ZERO
7758 SUM3(I,J)=ZERO
7759 SUMWDE(I,J)=ZERO
7760 401 CONTINUE
7761 !---FREQUENCY LOOP BEGINS---
7762 DO 411 N=1,NBLW
7763 CENT=CENTNB(N)
7764 !***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1
7765 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
7766 DO 413 J=1,180
7767 X2(J)=AROTNB(N)*ZROOT(J)
7768 EXPO(J)=EXP(-X2(J))
7769 413 CONTINUE
7770 DO 415 J=1,180
7771 IF (X2(J).GE.HUNDRED) THEN
7772 EXPO(J)=ZERO
7773 ENDIF
7774 415 CONTINUE
7775 DO 417 J=121,180
7776 FAC(J)=ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J))
7777 417 CONTINUE
7778 DO 419 J=1,180
7779 DO 419 I=1,28
7780 SUM(I,J)=SUM(I,J)+SRC1NB(I,N)*EXPO(J)
7781 PERTSM(I,J)=PERTSM(I,J)+DBDTNB(I,N)*EXPO(J)
7782 419 CONTINUE
7783 DO 421 J=121,180
7784 DO 421 I=1,28
7785 SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J)
7786 421 CONTINUE
7787 ENDIF
7788 !---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE)
7789 IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
7790 DO 420 J=1,180
7791 DO 420 I=1,28
7792 SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J)
7793 420 CONTINUE
7794 ENDIF
7795 411 CONTINUE
7796 DO 431 J=1,180
7797 DO 431 I=1,28
7798 EM1(I,J)=SUM(I,J)/TFOUR(I)
7799 TABLE1(I,J)=PERTSM(I,J)/FORTCU(I)
7800 431 CONTINUE
7801 DO 433 J=121,180
7802 DO 433 I=1,28
7803 EM3(I,J)=SUM3(I,J)/FORTCU(I)
7804 433 CONTINUE
7805 DO 441 J=1,179
7806 DO 441 I=1,28
7807 TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*TEN
7808 441 CONTINUE
7809 DO 443 J=1,180
7810 DO 443 I=1,27
7811 TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*HP1
7812 443 CONTINUE
7813 DO 445 I=1,28
7814 TABLE2(I,180)=ZERO
7815 445 CONTINUE
7816 DO 447 J=1,180
7817 TABLE3(28,J)=ZERO
7818 447 CONTINUE
7819 DO 449 J=1,2
7820 DO 449 I=1,28
7821 EM1(I,J)=R1T(I)
7822 449 CONTINUE
7823 DO 451 J=1,120
7824 DO 451 I=1,28
7825 EM3(I,J)=R2(I)/TWO-S2(I)*SQRT(ZMASS(J))/THREE+T3(I)*ZMASS(J)/EIGHT
7826 451 CONTINUE
7827 DO 453 J=121,180
7828 DO 453 I=1,28
7829 EM3(I,J)=EM3(I,J)/ZMASS(J)
7830 453 CONTINUE
7831 !***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY.
7832 ! WE USE R1WD AND SUMWDE OBTAINED ABOVE.
7833 DO 501 J=1,180
7834 DO 501 I=1,28
7835 EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I)
7836 501 CONTINUE
7837 DO 503 J=1,2
7838 DO 503 I=1,28
7839 EM1WDE(I,J)=R1WD(I)
7840 503 CONTINUE
7842 END SUBROUTINE TABLE
7844 !---------------------------------------------------------------------
7845 SUBROUTINE SOLARD(IHRST,IDAY,MONTH,JULYR)
7846 !---------------------------------------------------------------------
7847 IMPLICIT NONE
7848 !---------------------------------------------------------------------
7849 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
7850 ! . . . .
7851 ! SUBPROGRAM: SOLARD COMPUTE THE SOLAR-EARTH DISTANCE
7852 ! PRGRMMR: Q.ZHAO ORG: W/NMC2 DATE: 96-7-23
7853 !
7854 ! ABSTRACT:
7855 ! SOLARD CALCULATES THE SOLAR-EARTH DISTANCE ON EACH DAY
7856 ! FOR USE IN SHORT-WAVE RADIATION.
7857 !
7858 ! PROGRAM HISTORY LOG:
7859 ! 96-07-23 Q.ZHAO - ORIGINATOR
7860 ! 98-10-09 Q.ZHAO - CHANGED TO USE IW3JDN IN W3LIB TO
7861 ! CALCULATE JD.
7862 ! 04-11-18 Y.-T. HOU - FIXED ERROR IN JULIAN DAY CALCULATION
7863 !
7864 ! USAGE: CALL SOLARD FROM SUBROUTINE INIT
7865 !
7866 ! INPUT ARGUMENT LIST:
7867 ! NONE
7868 !
7869 ! OUTPUT ARGUMENT LIST:
7870 ! R1 - THE NON-DIMENSIONAL DISTANCE BETWEEN SUN AND THE EARTH
7871 ! (LESS THAN 1.0 IN SUMMER AND LARGER THAN 1.0 IN WINTER).
7872 !
7873 ! INPUT FILES:
7874 ! NONE
7875 !
7876 ! OUTPUT FILES:
7877 ! NONE
7878 !
7879 ! SUBPROGRAMS CALLED:
7880 !
7881 ! UNIQUE: NONE
7882 !
7883 ! LIBRARY: IW3JDN
7884 !
7885 ! COMMON BLOCKS: CTLBLK
7886 !
7887 ! ATTRIBUTES:
7888 ! LANGUAGE: FORTRAN 90
7889 ! MACHINE : IBM SP
7890 !***********************************************************************
7891 REAL, PARAMETER :: PI=3.1415926,PI2=2.*PI
7892 !-----------------------------------------------------------------------
7893 ! INTEGER, INTENT(IN ) :: IHRST,IDAT(3)
7894 INTEGER, INTENT(IN ) :: IHRST,IDAY,MONTH,JULYR
7895 ! REAL , INTENT(OUT) :: R1
7896 !-----------------------------------------------------------------------
7897 INTEGER :: NDM(12),JYR19,JMN
7898 REAL :: CCR
7900 DATA JYR19/1900/, JMN/0/, CCR/1.3E-6/
7901 DATA NDM/0,31,59,90,120,151,181,212,243,273,304,334/
7903 !.....TPP = DAYS BETWEEN EPOCH AND PERIHELION PASSAGE OF 1900
7904 !.....JDOR1 = JD OF DECEMBER 30, 1899 AT 12 HOURS UT
7905 !.....JDOR2 = JD OF EPOCH WHICH IS JANUARY 0, 1990 AT 12 HOURS UT
7906 !
7907 REAL :: TPP
7908 DATA TPP/1.55/
7910 INTEGER :: JDOR2,JDOR1
7911 DATA JDOR2/2415020/, JDOR1/2415019/
7913 REAL :: DAYINC,DAT,T,YEAR,DATE,EM,E,EC,EP,CR,FJD,FJD1
7914 INTEGER :: JHR,JD,ITER
7915 !
7916 ! LIBRARY: IW3JDN
7917 !
7918 ! --------------------------------------------------------------------
7919 ! COMPUTES JULIAN DAY AND FRACTION FROM YEAR, MONTH, DAY AND TIME UT
7920 ! ACCURATE ONLY BETWEEN MARCH 1, 1900 AND FEBRUARY 28, 2100
7921 ! BASED ON JULIAN CALENDAR CORRECTED TO CORRESPOND TO GREGORIAN
7922 ! CALENDAR DURING THIS PERIOD
7923 ! --------------------------------------------------------------------
7925 JHR=IHRST
7926 !
7927 JD=IDAY-32075 &
7928 +1461*(JULYR+4800+(MONTH-14)/12)/4 &
7929 +367*(MONTH-2-(MONTH-14)/12*12)/12 &
7930 -3*((JULYR+4900+(MONTH-14)/12)/100)/4
7931 IF(JHR.LT.12)THEN
7932 JD=JD-1
7933 FJD=.5+.041666667*REAL(JHR)+.00069444444*REAL(JMN)
7934 ELSE
7935 7 FJD=.041666667E0*FLOAT(JHR-12)+.00069444444E0*FLOAT(JMN)
7936 END IF
7937 DAYINC=JHR/24.0
7938 FJD1=JD+FJD+DAYINC
7939 JD=FJD1
7940 FJD=FJD1-JD
7941 !***
7942 !*** CALCULATE THE SOLAR-EARTH DISTANCE
7943 !***
7944 DAT=REAL(JD-JDOR2)-TPP+FJD
7945 !***
7946 ! COMPUTES TIME IN JULIAN CENTURIES AFTER EPOCH
7947 !***
7948 T=FLOAT(JD-JDOR2)/36525.E0
7949 !***
7950 ! COMPUTES LENGTH OF ANOMALISTIC AND TROPICAL YEARS (MINUS 365 DAYS)
7951 !***
7952 YEAR=.25964134E0+.304E-5*T
7953 !***
7954 ! COMPUTES ORBIT ECCENTRICITY FROM T
7955 !***
7956 EC=.01675104E0-(.418E-4+.126E-6*T)*T
7957 YEAR=YEAR+365.E0
7958 !***
7959 ! DATE=DAYS SINCE LAST PERIHELION PASSAGE
7960 !***
7961 DATE = MOD(DAT,YEAR)
7962 !***
7963 ! SOLVE ORBIT EQUATIONS BY NEWTON'S METHOD
7964 !***
7965 EM=PI2*DATE/YEAR
7966 E=1.E0
7967 ITER = 0
7968 31 EP=E-(E-EC*SIN(E)-EM)/(1.E0-EC*COS(E))
7969 CR=ABS(E-EP)
7970 E=EP
7971 ITER = ITER + 1
7972 IF(ITER.GT.10) GOTO 1031
7973 IF(CR.GT.CCR) GO TO 31
7974 1031 CONTINUE
7975 R1=1.E0-EC*COS(E)
7976 !
7977 WRITE(0,1000)JULYR,MONTH,IDAY,IHRST,R1
7978 1000 FORMAT('SUN-EARTH DISTANCE CALCULATION FINISHED IN SOLARD'/ &
7979 'YEAR=',I5,' MONTH=',I3,' DAY=',I3,' HOUR=' &
7980 , I3,' R1=',F9.4)
7981 !***
7982 ! RETURN TO RADTN
7983 !***
7984 END SUBROUTINE SOLARD
7985 !---------------------------------------------------------------------
7986 SUBROUTINE CAL_MON_DAY(JULDAY,julyr,Jmonth,Jday)
7987 !---------------------------------------------------------------------
7988 IMPLICIT NONE
7989 !-----------------------------------------------------------------------
7990 INTEGER, INTENT(IN) :: JULDAY,julyr
7991 INTEGER, INTENT(OUT) :: Jmonth,Jday
7992 LOGICAL :: LEAP,NOT_FIND_DATE
7993 INTEGER :: MONTH (12),itmpday,itmpmon,i
7994 !-----------------------------------------------------------------------
7995 DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
7996 !***********************************************************************
7997 NOT_FIND_DATE = .true.
7999 itmpday = JULDAY
8000 itmpmon = 1
8001 LEAP=.FALSE.
8002 IF(MOD(julyr,4).EQ.0)THEN
8003 MONTH(2)=29
8004 LEAP=.TRUE.
8005 ENDIF
8007 i = 1
8008 DO WHILE (NOT_FIND_DATE)
8009 IF(itmpday.GT.MONTH(i))THEN
8010 itmpday=itmpday-MONTH(i)
8011 ELSE
8012 Jday=itmpday
8013 Jmonth=i
8014 NOT_FIND_DATE = .false.
8015 ENDIF
8016 i = i+1
8017 END DO
8019 END SUBROUTINE CAL_MON_DAY
8020 !!================================================================================
8021 ! CO2 initialization code
8023 FUNCTION ANTEMP(L,Z)
8024 REAL :: ZB(10,7),C(11,7),DELTA(10,7),TSTAR(7)
8025 ! ************** TROPICAL SOUNDING **************************
8026 DATA (ZB(N,1),N=1,10)/ 2.0, 3.0, 16.5, 21.5, 45.0, &
8027 51.0, 70.0, 100., 200., 300./
8028 DATA (C(N,1),N=1,11)/ -6.0, -4.0, -6.7, 4.0, 2.2, &
8029 1.0, -2.8, -.27, 0.0, 0.0, 0.0/
8030 DATA (DELTA(N,1),N=1,10)/.5, .5, .3, .5, 1.0, &
8031 1.0, 1.0, 1.0, 1.0, 1.0/
8032 ! ************** SUB-TROPICAL SUMMER ************************
8033 DATA (ZB(N,2),N=1,10)/ 1.5, 6.5, 13.0, 18.0, 26.0, &
8034 36.0, 48.0, 50.0, 70.0, 100./
8035 DATA (C(N,2),N=1,11)/ -4.0, -6.0, -6.5, 0.0, 1.2, &
8036 2.2, 2.5, 0.0, -3.0, -0.25, 0.0/
8037 DATA (DELTA(N,2),N=1,10)/ .5, 1.0, .5, .5, 1.0, &
8038 1.0, 2.5, .5, 1.0, 1.0/
8039 ! ************** SUB-TROPICAL WINTER ************************
8040 DATA (ZB(N,3),N=1,10)/ 3.0, 10.0, 19.0, 25.0, 32.0, &
8041 44.5, 50.0, 71.0, 98.0, 200.0/
8042 DATA (C(N,3),N=1,11)/ -3.5, -6.0, -0.5, 0.0, 0.4, &
8043 3.2, 1.6, -1.8, -0.7, 0.0, 0.0/
8044 DATA (DELTA(N,3),N=1,10)/ .5, .5, 1.0, 1.0, 1.0, &
8045 1.0, 1.0, 1.0, 1.0, 1.0/
8046 ! ************* SUB-ARCTIC SUMMER *************************
8047 DATA (ZB(N,4),N=1,10)/ 4.7, 10.0, 23.0, 31.8, 44.0, &
8048 50.2, 69.2, 100.0, 102.0, 103.0/
8049 DATA (C(N,4),N=1,11)/ -5.3, -7.0, 0.0, 1.4, 3.0, &
8050 0.7, -3.3, -0.2, 0.0, 0.0, 0.0/
8051 DATA (DELTA(N,4),N=1,10)/ .5, .3, 1.0, 1.0, 2.0, &
8052 1.0, 1.5, 1.0, 1.0, 1.0/
8053 ! ************ SUB-ARCTIC WINTER *****************************
8054 DATA (ZB(N,5),N=1,10)/ 1.0, 3.2, 8.5, 15.5, 25.0, &
8055 30.0, 35.0, 50.0, 70.0, 100.0/
8056 DATA (C(N,5),N=1,11)/ 3.0, -3.2, -6.8, 0.0, -0.6, &
8057 1.0, 1.2, 2.5, -0.7, -1.2, 0.0/
8058 DATA (DELTA(N,5),N=1,10)/ .4, 1.5, .3 , .5, 1.0, &
8059 1.0, 1.0, 1.0, 1.0, 1.0/
8060 ! ************ US STANDARD 1976 ******************************
8061 DATA (ZB(N,6),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, &
8062 71.0, 84.8520, 90.0, 91.0, 92.0/
8063 DATA (C(N,6),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, &
8064 -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/
8065 DATA (DELTA(N,6),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, &
8066 1.0, 1.0, 1.0, 1.0, 1.0/
8067 !
8068 ! ************ ENLARGED US STANDARD 1976 **********************
8069 DATA (ZB(N,7),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, &
8070 71.0, 84.8520, 90.0, 91.0, 92.0/
8071 DATA (C(N,7),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, &
8072 -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/
8073 DATA (DELTA(N,7),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, &
8074 1.0, 1.0, 1.0, 1.0, 1.0/
8075 !
8076 DATA TSTAR/ 300.0, 294.0, 272.2, 287.0, 257.1, 2*288.15/
8077 !
8078 NLAST=10
8079 TEMP=TSTAR(L)+C(1,L)*Z
8080 DO 20 N=1,NLAST
8081 EXPO=(Z-ZB(N,L))/DELTA(N,L)
8082 EXPP=ZB(N,L)/DELTA(N,L)
8083 !JD single-precision change
8084 ! FAC=EXP(EXPP)+EXP(-EXPP)
8085 !mp write(6,*) '.........................................'
8086 !mp what in the hell does the next line do?
8087 !mp
8088 !mp apparently if statement <0 or =0 then 23, else 24
8089 !mp IF(ABS(EXPO)-100.0) 23,23,24
8090 !
8091 ! changed to a more reasonable value for the workstation
8092 !
8093 IF(ABS(EXPO)-50.0) 23,23,24
8094 23 X=EXP(EXPO)
8095 Y=X+1.0/X
8096 ZLOG=ALOG(Y)
8097 GO TO 25
8098 24 ZLOG=ABS(EXPO)
8099 !mp 25 IF(EXPP-100.0) 27,27,28
8100 25 IF(EXPP-50.0) 27,27,28
8101 !JD single-precision change
8102 27 FAC=EXP(EXPP)+EXP(-EXPP)
8103 FACLOG=ALOG(FAC)
8104 GO TO 29
8105 28 FACLOG=EXPP
8106 ! TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)*
8107 ! 1 ALOG((EXP(EXPO)+EXP(-EXPO))/FAC))
8108 29 TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)* &
8109 (ZLOG-FACLOG))
8110 !mp write(6,*) 'ANTEMP pieces (C,C,ZLOG,FACLOG)', C(N+1,L),C(N,L),
8111 !mp + ZLOG,FACLOG
8112 20 CONTINUE
8113 ANTEMP=TEMP
8115 END FUNCTION ANTEMP
8117 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
8119 SUBROUTINE COEINT(RAT,IR)
8120 ! **********************************************************************
8121 !
8122 !
8123 ! THE TRANSMISSION FUNCTION BETWEEN P1 AND P2 IS ASSUMED TO
8124 ! THE FUNCTIONAL FORM
8125 ! TAU(P1,P2)= 1.0-SQRT(C*LOG(1.0+X*PATH)),
8126 ! WHERE
8127 ! PATH(P1,P2)=((P1-P2)**2)*(P1+P2+CORE)/
8128 ! (ETA*(P1+P2+CORE)+(P1-P2))
8129 !
8130 !
8131 ! THE PARAMETERS C AND X ARE FUNCTIONS OF P2, AND ARE TO BE DETER
8132 ! WHILE CORE IS A PRESPECIFIED NUMBER.ETA IS A FUNCTION OF THE TH
8133 ! PRODUCT (CX);IT IS OBTAITED ITERATIVELY. THE DERIVATION OF ALL
8134 ! VALUES WILL BE EXPLAINED IN A FORTHCOMING PAPER.
8135 ! SUBROUTINE COEINT DETERMINES C(I) AND X(I) BY USING THE ACT
8136 ! VALUES OF TAU(P(I-2),P(I)) AND TAU(P(I-1),P(I)) AND THE PREVIOU
8137 ! ITERATION VALUE OF ETA.
8138 ! DEFINE:
8139 ! PATHA=PATH(P(I),P(I-2),CORE,ETA)
8140 ! PATHB=PATH(P(I),P(I-1),CORE,ETA);
8141 ! THEN
8142 ! R=(1-TAU(P(I),P(I-2)))/(1-TAU(P(I),P(I-1)))
8143 ! = SQRT(LOG(1+X*PATHA)/LOG(1+X*PATHB)),
8144 ! SO THAT
8145 ! R**2= LOG(1+X*PATHA)/LOG(1+X*PATHB).
8146 ! THIS EQUATION CAN BE SOLVED BY NEWTON S METHOD FOR X AND THEN T
8147 ! RESULT USED TO FIND C. THIS IS REPEATED FOR EACH VALUE OF I GRE
8148 ! THAN 2 TO GIVE THE ARRAYS X(I) AND C(I).
8149 ! NEWTON S METHOD FOR SOLVING THE EQUATION
8150 ! F(X)=0
8151 ! MAKES USE OF THE LOOP XNEW= XOLD-F(XOLD)/FPRIME(XOLD).
8152 ! THIS IS ITERATED 20 TIMES, WHICH IS PROBABLY EXCESSIVE.
8153 ! THE FIRST GUESS FOR ETA IS 3.2E-4*EXP(-P(I)/1000),WHICH HAS
8154 ! BEEN FOUND TO BE FAIRLY REALISTIC BY EXPERIMENT; WE ITERATE 5 T
8155 ! (AGAIN,PROBABLY EXCESSIVELY) TO OBTAIN THE VALUES FOR C,X,ETA T
8156 ! USED FOR INTERPOLATION.
8157 ! THERE ARE SEVERAL POSSIBLE PITFALLS:
8158 ! 1) IN THE COURSE OF ITERATION, X MAY REACH A VALUE WHICH
8159 ! 1+X*PATHA NEGATIVE; IN THIS CASE THE ITERATION IS STOP
8160 ! AND AN ERROR MESSAGE IS PRINTED OUT.
8161 ! 2) EVEN IF (1) DOES NOT OCCUR, IT IS STILL POSSIBLE THAT
8162 ! BE NEGATIVE AND LARGE ENOUGH TO MAKE 1+X*PATH(P(I),0,C
8163 ! NEGATIVE. THIS IS CHECKED FOR IN A FINAL LOOP, AND IF
8164 ! A WARNING IS PRINTED OUT.
8165 !
8166 ! *********************************************************************
8167 !....
8168 ! IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8169 ! COMMON/PRESS/PA(109)
8170 REAL RAT,SINV
8171 ! REAL PA,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
8172 REAL PA2
8173 ! COMMON/TRAN/ TRANSA(109,109)
8174 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
8175 DIMENSION PATH0(109),ETAP(109),XAP(109),CAP(109)
8176 DIMENSION SINV(4)
8177 INTEGER :: IERR
8178 DATA SINV/2.74992,2.12731,4.38111,0.0832926/
8179 !NOV89 DIMENSION SINV(3)
8180 !NOV89 DATA SINV/2.74992,2.12731,4.38111/
8181 !O222 OLD CODE USED 2.7528 RATHER THAN 2.74992 ---K.A.C. OCTOBER 1988
8182 !O222 WHEN 2.7528 WAS USED,WE EXACTLY REPRODUCED THE MRF CO2 ARRAYS
8183 CORE=5.000
8184 UEXP=0.90
8185 ! P0=0.7
8186 DO 902 I=1,109
8187 PA2=PA(I)*PA(I)
8188 SEXPV(I)=.505+2.0E-5*PA(I)+.035*(PA2-.25)/(PA2+.25)
8189 902 CONTINUE
8190 DO 900 I=1,109
8191 ETA(I)=3.2E-4*EXP(-PA(I)/500.)
8192 ETAP(I)=ETA(I)
8193 900 CONTINUE
8194 DO 1200 NP=1,10
8195 DO 1000 I=3,109
8196 SEXP=SEXPV(I)
8197 R=(1.0D0-TRANSA(I,I-2))/(1.0D0-TRANSA(I,I-1))
8198 REXP=R**(UEXP/SEXP)
8199 arg1=path(pa(i),pa(i-2),core,eta(i))
8200 arg2=path(pa(i),pa(i-1),core,eta(i))
8201 PATHA=(PATH(PA(I),PA(I-2),CORE,ETA(I)))**UEXP
8202 PATHB=(PATH(PA(I),PA(I-1),CORE,ETA(I)))**UEXP
8203 XX=2.0D0*(PATHB*REXP-PATHA)/(PATHB*PATHB*REXP-PATHA*PATHA)
8204 DO 1010 LL=1,20
8205 F1=DLOG(1.0D0+XX*PATHA)
8206 F2=DLOG(1.0D0+XX*PATHB)
8207 F=F1/F2-REXP
8208 FPRIME=(F2*PATHA/(1.0D0+XX*PATHA)-F1*PATHB/(1.0D0+XX*PATHB))/ &
8209 (F2*F2)
8210 XX=XX-F/FPRIME
8211 CHECK=1.0D0+XX*PATHA
8212 !!!! IF (CHECK) 1020,1020,1025
8213 IF(CHECK.LE.0.)THEN
8214 WRITE(errmess,360)I,LL,CHECK
8215 WRITE(errmess,*)' xx=',xx,' patha=',patha
8216 360 FORMAT(' ERROR,I=',I3,'LL=',I3,'CHECK=',F20.10)
8217 CALL wrf_error_fatal ( errmess )
8218 ENDIF
8219 1010 CONTINUE
8220 CA(I)=(1.0D0-TRANSA(I,I-2))**(UEXP/SEXP)/ &
8221 (DLOG(1.0D0+XX*PATHA)+1.0D-20)
8222 XA(I)=XX
8223 1000 CONTINUE
8224 XA(2)=XA(3)
8225 XA(1)=XA(3)
8226 CA(2)=CA(3)
8227 CA(1)=CA(3)
8228 DO 1100 I=3,109
8229 PATH0(I)=(PATH(PA(I),0.,CORE,ETA(I)))**UEXP
8230 PATH0(I)=1.0D0+XA(I)*PATH0(I)
8231 !+++ IF (PATH0(I).LT.0.) WRITE (6,361) I,PATH0(I),XA(I)
8232 1100 CONTINUE
8233 DO 1035 I=1,109
8234 SEXP=SEXPV(I)
8235 ETAP(I)=ETA(I)
8236 ETA(I)=(SINV(IR)/RAT)**(1./SEXP)* &
8237 (CA(I)*XA(I))**(1./UEXP)
8238 1035 CONTINUE
8239 !
8240 ! THE ETA FORMULATION IS DETAILED IN SCHWARZKOPF AND FELS(1985).
8241 ! THE QUANTITY SINV=(G*DELTANU)/(RCO2*D*S)
8242 ! IN CGS UNITS,WITH D,THE DIFFUSICITY FACTOR=2, AND
8243 ! S,THE SUM OF CO2 LINE STRENGTHS OVER THE 15UM CO2 BAND
8244 ! ALSO,THE DENOMINATOR IS MULTIPLIED BY
8245 ! 1000 TO PERMIT USE OF MB UNITS FOR PRESSURE.
8246 ! S IS ACTUALLY WEIGHTED BY B(250) AT 10 CM-1 WIDE INTERVALS,IN
8247 ! ORDER TO BE CONSISTENT WITH THE METHODS USED TO OBTAIN THE LBL
8248 ! 1-BAND CONSOLIDATED TRANCMISSION FUNCTIONS.
8249 ! FOR THE 490-850 INTERVAL (DELTANU=360,IR=1) SINV=2.74992.
8250 ! (SLIGHTLY DIFFERENT FROM 2.7528 USED IN EARLIER VERSIONS)
8251 ! FOR THE 490-670 INTERVAL (IR=2) SINV=2.12731
8252 ! FOR THE 670-850 INTERVAL (IR=3) SINV=4.38111
8253 ! FOR THE 2270-2380 INTERVAL (IR=4) SINV=0.0832926
8254 ! SINV HAS BEEN OBTAINED USING THE 1982 AFGL CATALOG FOR CO2
8255 ! RAT IS THE ACTUAL CO2 MIXING RATIO IN UNITS OF 330 PPMV,
8256 ! LETTING USE OF THIS FORMULATION FOR ANY CO2 CONCENTRATION.
8257 !
8258 ! WRITE (6,366) (NP,I,CA(I),XA(I),ETA(I),SEXPV(I),I=1,109)
8259 !366 FORMAT (2I4,4E20.12)
8260 1200 CONTINUE
8261 361 FORMAT (' **WARNING:** 1+XA*PATH(PA(I),0) IS NEGATIVE,I= ',I3,/ &
8262 20X,'PATH0(I)=',F16.6,' XA(I)=',F16.6)
8263 RETURN
8264 END SUBROUTINE COEINT
8266 !--------------
8269 !CCC PROGRAM CO2INS
8270 SUBROUTINE CO2INS(T22,T23,T66,IQ,L,LP1,iflag)
8271 ! *********************************************************
8272 ! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ******
8273 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988...
8274 ! ..... K.CAMPANA DECEMBER 1988-CLEANED UP FOR LAUNCHER
8275 ! ..... K.CAMPANA NOVEMBER 1989-ALTERED FOR NEW RADIATION
8276 ! *********************************************************
8277 DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3),T66(LP1,LP1,6)
8278 DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
8279 CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
8280 CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
8281 !CC ITIN=22
8282 !CC ITIN1=23
8283 !O222 LATEST CODE HAD IQ=1
8284 !CC IQ=4
8285 1011 FORMAT (4F20.14)
8286 !CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
8287 !CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
8288 !CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
8289 !CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
8290 !CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
8291 !CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
8292 DO 300 J=1,LP1
8293 DO 300 I=1,LP1
8294 CO2PO(I,J) = T22(I,J,1)
8295 !NOV89
8296 IF (IQ.EQ.5) GO TO 300
8297 !NOV89
8298 CO2PO1(I,J) = T22(I,J,2)
8299 CO2PO2(I,J) = T22(I,J,3)
8300 300 CONTINUE
8301 DO 301 J=1,LP1
8302 DO 301 I=1,LP1
8303 CO2800(I,J) = T23(I,J,1)
8304 !NOV89
8305 IF (IQ.EQ.5) GO TO 301
8306 !NOV89
8307 CO2801(I,J) = T23(I,J,2)
8308 CO2802(I,J) = T23(I,J,3)
8309 301 CONTINUE
8310 !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
8311 ! ARE:
8312 ! IQ=1 560-800 (CONSOL.=490-850)
8313 ! IQ=2 560-670 (CONSOL.=490-670)
8314 ! IQ=3 670-800 (CONSOL.=670-850)
8315 ! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850)
8316 !NOV89
8317 ! IQ=5 2270-2380 (CONSOL.=2270-2380)
8318 !NOV89
8319 ! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
8320 ! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
8321 ! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
8322 !NOV89
8323 ! NOTE: ALTHOUGH THE BAND TRANSMISSION FUNCTIONS ARE
8324 ! COMPUTED FOR ALL RADIATIVE BANDS, AS OF 9/28/88, THEY
8325 ! ARE WRITTEN OUT IN FULL ONLY FOR THE FULL 15 UM BAND CASES
8326 ! (IQ=1,4). IN OTHER CASES, THE TRANSMISSIVITIES (1,K) ARE
8327 ! WRITTEN OUT, AS THESE ARE THE ONLY ONES NEEDED FOR CTS
8328 ! CALCULATIONS. ALSO, FOR THE 4.3 UM BAND (IQ=5) THE TEMP.
8329 ! DERIVATIVE TERMS ARE NOT WRITTEN OUT, AS THEY ARE UNUSED.
8330 !NOV89
8331 IF (IQ.EQ.1) THEN
8332 C1=1.5
8333 C2x=0.5
8334 ENDIF
8335 IF (IQ.EQ.2) THEN
8336 C1=18./11.
8337 C2x=7./11.
8338 ENDIF
8339 IF (IQ.EQ.3) THEN
8340 C1=18./13.
8341 C2x=5./13.
8342 ENDIF
8343 IF (IQ.EQ.4) THEN
8344 C1=1.8
8345 C2x=0.8
8346 ENDIF
8347 !NOV89
8348 IF (IQ.EQ.5) THEN
8349 C1=1.0
8350 C2x=0.0
8351 ENDIF
8352 !NOV89
8353 DO 1021 I=1,LP1
8354 DO 1021 J=1,LP1
8355 CO2PO(J,I)=C1*CO2PO(J,I)-C2x
8356 CO2800(J,I)=C1*CO2800(J,I)-C2x
8357 !NOV89
8358 IF (IQ.EQ.5) GO TO 1021
8359 !NOV89
8360 CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
8361 CO2801(J,I)=C1*CO2801(J,I)-C2x
8362 CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
8363 CO2802(J,I)=C1*CO2802(J,I)-C2x
8364 1021 CONTINUE
8365 !NOV89
8366 IF (IQ.GE.1.AND.IQ.LE.4) THEN
8367 !NOV89
8368 DO 1 J=1,LP1
8369 DO 1 I=1,LP1
8370 DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
8371 DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
8372 D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
8373 D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
8374 1 CONTINUE
8375 !NOV89
8376 ENDIF
8377 !NOV89
8378 !O222 *********************************************************
8379 !CC REWIND 66
8380 ! SAVE CDT51,CO251,C2D51,CDT58,CO258,C2D58..ON TEMPO FILE
8381 !CC WRITE (66) DCDT10
8382 !CC WRITE (66) CO2PO
8383 !CC WRITE (66) D2CT10
8384 !CC WRITE (66) DCDT8
8385 !CC WRITE (66) CO2800
8386 !CC WRITE (66) D2CT8
8387 !CC REWIND 66
8388 !NOV89
8389 IF (IQ.EQ.1.OR.IQ.EQ.4) THEN
8390 !NOV89
8391 DO 400 J=1,LP1
8392 DO 400 I=1,LP1
8393 T66(I,J,1) = DCDT10(I,J)
8394 T66(I,J,2) = CO2PO(I,J)
8395 T66(I,J,3) = D2CT10(I,J)
8396 T66(I,J,4) = DCDT8(I,J)
8397 T66(I,J,5) = CO2800(I,J)
8398 T66(I,J,6) = D2CT8(I,J)
8399 400 CONTINUE
8400 !NOV89
8401 ELSE
8402 DO 409 I=1,LP1
8403 T66(I,1,2) = CO2PO(1,I)
8404 T66(I,1,5) = CO2800(1,I)
8405 IF (IQ.EQ.5) GO TO 409
8406 T66(I,1,1) = DCDT10(1,I)
8407 T66(I,1,3) = D2CT10(1,I)
8408 T66(I,1,4) = DCDT8(1,I)
8409 T66(I,1,6) = D2CT8(1,I)
8410 409 CONTINUE
8411 ENDIF
8412 !NOV89
8413 !O222 *********************************************************
8414 RETURN
8415 END SUBROUTINE CO2INS
8416 !O222 PROGRAM CO2INT(INPUT,TAPE5=INPUT)
8417 !NOV89
8418 SUBROUTINE CO2INT(ITAPE,T15A,T15B,T22,RATIO,IR,NMETHD,NLEVLS,NLP1,NLP2)
8419 !NOV89
8420 ! *********************************************************
8421 ! CHANGES TO DATA READ AND FORMAT SEE CO222 ***
8422 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988
8423 ! CHANGES TO PASS ITAPE,AND IF IR=4,READ 1 CO2 REC..KAC NOV89
8424 ! *********************************************************
8425 ! CO2INT INTERPOLATES CARBON DIOXIDE TRANSMISSION FUNCTIONS
8426 ! FROM THE 109 LEVEL GRID,FOR WHICH THE TRANSMISSION FUNCTIONS
8427 ! HAVE BEEN PRE-CALCULATED, TO THE GRID STRUCTURE SPECIFIED BY THE
8428 ! USER.
8429 !
8430 ! METHOD:
8431 !
8432 ! CO2INT IS EMPLOYABLE FOR TWO PURPOSES: 1) TO OBTAIN TRANSMIS-
8433 ! SIVITIES BETWEEN ANY 2 OF AN ARRAY OF USER-DEFINED PRESSURES; AND
8434 ! 2) TO OBTAIN LAYER-MEAN TRANSMISSIVITIES BETWEEN ANY 2 OF AN ARRAY
8435 ! OF USER-DEFINED PRESSURE LAYERS.TO CLARIFY THESE TWO PURPOSES,SEE
8436 ! THE DIAGRAM AND DISCUSSION BELOW.
8437 ! CO2INT MAY BE USED TO EXECUTE ONLY ONE PURPOSE AT ONE TIME.
8438 !
8439 ! LET P BE AN ARRAY OF USER-DEFINED PRESSURES
8440 ! AND PD BE USER-DEFINED PRESSURE LAYERS.
8441 !
8442 ! - - - - - - - - - PD(I-1) ---
8443 ! ^
8444 ! ----------------- P(I) ^ PRESSURE LAYER I (PLM(I))
8445 ! ^
8446 ! - - - - - - - - - PD(I) ---
8447 ! ^
8448 ! ----------------- P(I+1) ^ PRESSURE LAYER I+1 (PLM(I+1))
8449 ! ^
8450 ! - - - - - - - - - PD(I+1)---
8451 ! ... (THE NOTATION USED IS
8452 ! ... CONSISTENT WITH THE CODE)
8453 ! ...
8454 ! - - - - - - - - - PD(J-1)
8455 !
8456 ! ----------------- P(J)
8457 !
8458 ! - - - - - - - - - PD(J)
8459 !
8460 ! PURPOSE 1: THE TRANSMISSIVITY BETWEEN SPECIFIC PRESSURES
8461 ! P(I) AND P(J) ,TAU(P(I),P(J)) IS COMPUTED BY THIS PROGRAM.
8462 ! IN THIS MODE,THERE IS NO REFERENCE TO LAYER PRESSURES PD
8463 ! (PD,PLM ARE NOT INPUTTED).
8464 !
8465 ! PURPOSE 2: THE LAYER-MEAN TRANSMISSIVITY BETWEEN A LAYER-
8466 ! MEAN PRESSURE PLM(J) AND PRESSURE LAYER I IS GIVEN BY
8467 ! TAULM(PLM(I),PLM(J)). IT IS COMPUTED BY THE INTEGRAL
8468 !
8469 ! PD(I)
8470 ! ----
8471 ! 1 ^
8472 ! ------------- * ^ TAU ( P',PLM(J) ) DP'
8473 ! PD(I)-PD(I-1) ^
8474 ! ----
8475 ! PD(I-1)
8476 !
8477 ! THE LAYER-MEAN PRESSURE PLM(I) IS SPECIFIED BY THE USER.
8478 ! FOR MANY PURPOSES,PLM WILL BE CHOSEN TO BE THE AVERAGE
8479 ! PRESSURE IN THE LAYER-IE,PLM(I)=0.5*(PD(I-1)+PD(I)).
8480 ! FOR LAYER-MEAN TRANSMISSIVITIES,THE USER THUS INPUTS
8481 ! A PRESSURE ARRAY (PD) DEFINING THE PRESSURE LAYERS AND AN
8482 ! ARRAY (PLM) DEFINING THE LAYER-MEAN PRESSURES.THE CALCULATION
8483 ! DOES NOT DEPEND ON THE P ARRAY USED FOR PURPOSE 1 (P IS NOT
8484 ! INPUTTED).
8485 !
8486 ! THE FOLLOWING PARAGRAPHS DEPICT THE UTILIZATION OF THIS
8487 ! CODE WHEN USED TO COMPUTE TRANSMISSIVITIES BETWEEN SPECIFIC
8488 ! PRESSURES. LATER PARAGRAPHS DESCRIBE ADDITIONAL FEATURES NEEDED
8489 ! FOR LAYER-MEAN TRANSMISSIVITIES.
8490 !
8491 ! FOR A GIVEN CO2 MIXING RATIO AND STANDARD TEMPERATURE
8492 ! PROFILE,A TABLE OF TRANSMISSION FUNCTIONS FOR A FIXED GRID
8493 ! OF ATMOSPHERIC PRESSURES HAS BEEN PRE-CALCULATED.
8494 ! THE STANDARD TEMPERATURE PROFILE IS COMPUTED FROM THE US
8495 ! STANDARD ATMOSPHERE (1977) TABLE.ADDITIONALLY, THE
8496 ! SAME TRANSMISSION FUNCTIONS HAVE BEEN PRE-CALCULATED FOR A
8497 ! TEMPERATURE PROFILE INCREASED AND DECREASED (AT ALL LEVELS)
8498 ! BY 25 DEGREES.
8499 ! THIS PROGRAM READS IN THE PRESPECIFIED TRANSMISSION FUNCTIONS
8500 ! AND A USER-SUPPLIED PRESSURE GRID (P(I)) AND CALCULATES TRANS-
8501 ! MISSION FUNCTIONS ,TAU(P(I),P(J)), FOR ALL P(I) S AND P(J) S.
8502 ! A LOGARITHMIC INTERPOLATION SCHEME IS USED.
8503 ! THIS METHOD IS REPEATED FOR THE THREE TEMPERATURE PROFILES
8504 ! GIVEN ABOVE .THEREFORE OUTPUTS FROM THE PROGRAM ARE THREE TABLES
8505 ! OF TRANSMISSION FUNCTIONS FOR THE USER-SUPPLIED PRESSURE GRID.
8506 ! THE EXISTENCE OF THE THREE TABLES PERMITS SUBSEQUENT INTERPO-
8507 ! LATION TO A USER-SUPPLIED TEMPERATURE PROFILE USING THE METHOD
8508 ! DESCRIBED IN THE REFERENCE.SEE LIMITATIONS SECTION IF THE
8509 ! USER DESIRES TO OBTAIN ONLY 1 TABLE OF TRANSMISSIVITIES.
8510 !
8511 ! MODIFICATIONS FOR LAYER-MEAN TRANSMISSIVITIES:
8512 ! THE PRESSURES INPUTTED ARE THE LAYER-MEAN PRESSURES,PD,
8513 ! AND THE LAYER-MEAN PRESSURES ,PLM. A SERIES OF TRANSMISSIVITIES
8514 ! (TAU(P'',PLM(J)) ARE COMPUTED AND THE INTEGRAL GIVEN IN THE
8515 ! DISCUSSION OF PURPOSE 2 IS COMPUTED.FOR PLM(I) NOT EQUAL TO
8516 ! PLM(J) SIMPSON S RULE IS USED WITH 5 POINTS. IF PLM(I)=PLM(J)
8517 ! (THE -NEARBY LAYER- CASE) A 49-POINT QUADRATURE IS USED FOR
8518 ! GREATER ACCURACY.THE OUTPUT IS IN TAULM(PLM(I),PLM(J)).
8519 ! NOTE:
8520 ! TAULM IS NOT A SYMMETRICAL MATRIX. FOR THE ARRAY ELEMENT
8521 ! TAULM(PLM(I),PLM(J)),THE INNER(FIRST,MOST RAPIDLY VARYING)
8522 ! DIMENSION IS THE VARYING LAYER-MEAN PRESSURE,PLM(I);THE OUTER
8523 ! (SECOND) DIMENSION IS THE FIXED LAYER-MEAN PRESSURE PLM(J).
8524 ! THUS THE ELEMENT TAULM(2,3) IS THE TRANSMISSION FUNCTION BETWEEN
8525 ! THE FIXED PRESSURE PLM(3) AND THE PRESSURE LAYER HAVING AN AVERAG
8526 ! PRESSURE OF PLM(2).
8527 ! ALSO NOTE THAT NO QUADRATURE IS PERFORMED OVER THE LAYER
8528 ! BETWEEN THE SMALLEST NONZERO PRESSURE AND ZERO PRESSURE;
8529 ! TAULM IS TAULM(0,PLM(J)) IN THIS CASE,AND TAULM(0,0)=1.
8530 !
8531 !
8532 ! REFERENCE:
8533 ! S.B.FELS AND M.D.SCHWARZKOPF,-AN EFFICIENT ACCURATE
8534 ! ALGORITHM FOR CALCULATING CO2 15 UM BAND COOLING RATES-,JOURNAL
8535 ! OF GEOPHYSICAL RESEARCH,VOL.86,NO. C2, PP.1205-1232,1981.
8536 ! MODIFICATIONS TO THE ALGORITHM HAVE BEEN MADE BY THE AUTHORS;
8537 ! CONTACT S.B.F.OR M.D.S. FOR FURTHER DETAILS.A NOTE TO J.G.R.
8538 ! IS PLANNED TO DOCUMENT THESE CHANGES.
8539 !
8540 ! AUTHOR: M.DANIEL SCHWARZKOPF
8541 !
8542 ! DATE: 14 JULY 1983
8543 !
8544 ! ADDRESS:
8545 !
8546 ! G.F.D.L.
8547 ! P.O.BOX 308
8548 ! PRINCETON,N.J.08540
8549 ! U.S.A.
8550 ! TELEPHONE: (609) 452-6521
8551 !
8552 ! INFORMATION ON TAPE: THIS SOURCE IS THE FIRST FILE
8553 ! ON THIS TAPE.THE SIX FILES THAT FOLLOW ARE CO2 TRANS-
8554 ! MISSIVITIES FOR THE 500-850 CM-1 INTERVAL FOR CO2
8555 ! CONCENTRATIONS OF 330 PPMV (1X) ,660 PPMV (2X), AND
8556 ! 1320 PPMV (4X). THE FILES ARE ARRANGED AS FOLLOWS:
8557 ! FILE 2 1X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8558 ! FILE 3 1X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8559 ! FILE 4 2X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8560 ! FILE 5 2X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8561 ! FILE 6 4X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8562 ! FILE 7 4X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8563 ! FILES 2,4,6 ARE RECOMMENDED FOR USE IN OBTAINING
8564 ! TRANSMISSION FUNCTIONS FOR USE IN HEATING RATE
8565 ! COMPUTATIONS;THEY CORRESPOND TO THE TRANSMISSIVITIES
8566 ! DISCUSSED IN THE 1980 PAPER.FILES 3,5,7 ARE PROVIDED
8567 ! TO FACILITATE COMPARISON WITH OBSERVATION AND WITH OTHER
8568 ! CALCULATIONS.
8569 !
8570 ! PROGRAM LANGUAGE: FORTRAN 1977,INCLUDING PARAMETER
8571 ! AND PROGRAM STATEMENTS.THE PROGRAM IS WRITTEN ON A
8572 ! CYBER 170-730.SEE THE SECTION ON LIMITATIONS FOR
8573 ! ADAPTATIONS TO OTHER MACHINES.
8574 !
8575 ! INPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
8576 !
8577 ! UNIT NO VARIABLES FORMAT STATEMENT NO. TYPE
8578 ! 5 P (PURPOSE 1) (5E16.9) 201 CARDS
8579 ! 5 PD (PURPOSE 2) (5E16.9) 201 CARDS
8580 ! 5 PLM(PURPOSE 2) (5E16.9) 201 CARDS
8581 ! 5 NMETHD (I3) 202 CARDS
8582 ! 20 TRANSA (4F20.14) 102 TAPE
8583 !NOV89
8584 ! ITAPE TRANSA (4F20.14) 102 TAPE
8585 !NOV89
8586 !
8587 ! OUTPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
8588 !
8589 ! UNIT NO VARIABLES FORMAT STATEMENT NO.
8590 ! 6 TRNFCT (1X,8F15.8) 301 PRINT
8591 ! 22 TRNFCT (4F20.14) 102 TAPE
8592 !
8593 ! PARAMETER INPUTS:
8594 ! A) NLEVLS : NLEVLS IS AN (INTEGER) PARAMETER DENOTING
8595 ! THE NUMBER OF NONZERO PRESSURE LEVELS FOR PURPOSE 1
8596 ! OR THE NUMBER OF NONZERO LAYER PRESSURES NEEDED TO
8597 ! SPECIFY THE PRESSURE LAYERS(PURPOSE 2) IN THE OUTPUT
8598 ! GRID. FOR EXAMPLE,IN PURPOSE 1,IF P=0,100,1000,NLEVLS=2.
8599 ! IF,IN PURPOSE 2,PD=0,100,500,1000,THE NUMBER OF NONZERO
8600 ! PRESSURE LAYERS=2,SO NLEVLS=2
8601 ! IN THE CODE AS WRITTEN,NLEVLS=40; THE USER SHOULD
8602 ! CHANGE THIS VALUE TO A USER-SPECIFIED VALUE.
8603 ! B) NLP1,NLP2 : INTEGER PARAMETERS DEFINED AS: NLP1=NLEVLS+1;
8604 ! NLP2=NLEVLS+2.
8605 ! SEE LIMITATIONS FOR CODE MODIFICATIONS IF PARAMETER
8606 ! STATEMENTS ARE NOT ALLOWED ON YOUR MACHINE.
8607 !
8608 ! INPUTS:
8609 !
8610 ! A) TRANSA : THE 109X109 GRID OF TRANSMISSION FUNCTIONS
8611 ! TRANSA IS A DOUBLE PRECISION REAL ARRAY.
8612 !
8613 ! TRANSA IS READ FROM FILE 20. THIS FILE CONTAINS 3
8614 ! RECORDS,AS FOLLOWS:
8615 ! 1) TRANSA, STANDARD TEMPERATURE PROFILE
8616 ! 3) TRANSA, STANDARD TEMPERATURES + 25 DEG
8617 ! 5) TRANSA, STANDARD TEMPERATURES - 25 DEG
8618 !
8619 ! B) NMETHD: AN INTEGER WHOSE VALUE IS EITHER 1 (IF CO2INT IS
8620 ! TO BE USED FOR PURPOSE 1) OR 2 (IF CO2INT IS TO BE USED FOR
8621 ! PURPOSE 2).
8622 !
8623 ! C) P,PD,PLM :
8624 ! P IS A REAL ARRAY (LENGTH NLP1) SPECIFYING THE PRESSURE
8625 ! GRID AT WHICH TRANSMISSION FUNCTIONS ARE TO BE COMPUTED FOR
8626 ! PURPOSE 1.THE DIMENSION OF P IS IN MILLIBARS.THE
8627 ! FOLLOWING LIMITATIONS WILL BE EXPLAINED MORE
8628 ! IN THE SECTION ON LIMITATIONS: P(1) MUST BE ZERO; P(NLP1),THE
8629 ! LARGEST PRESSURE, MUST NOT EXCEED 1165 MILLIBARS.
8630 ! PD IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE PRESSURE
8631 ! LAYERS FOR WHICH LAYER-AVERAGED TRANSMISSION FUNCTIONS ARE
8632 ! TO BE COMPUTED.THE DIMENSION OF PD IS MILLIBARS.THE LIMITATIONS
8633 ! FOR PD ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
8634 ! LIMITATIONS.
8635 ! PLM IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE LAYER-MEAN
8636 ! PRESSURES. THE DIMENSION OF PLM IS MILLIBARS. THE LIMITATIONS
8637 ! FOR PLM ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
8638 ! LIMITATIONS.PD IS READ IN BEFORE PLM.
8639 !
8640 ! NOTE: AGAIN,WE NOTE THAT THE USER WILL INPUT EITHER P (FOR
8641 ! PURPOSE 1) OR PD AND PLM(FOR PURPOSE 2) BUT NOT BOTH.
8642 !
8643 !
8644 !
8645 !
8646 ! LIMITATIONS:
8647 ! 1) P(1)=0.,PD(1)=0.,PLM(1)=0. THE TOP PRESSURE LEVEL
8648 ! MUST BE ZERO,OR THE TOP PRESSURE LAYER MUST BE BOUNDED BY ZERO.
8649 ! THE TOP LAYER-MEAN PRESSURE (PLM(1)) MUST BE ZERO; NO
8650 ! QUADRATURE IS DONE ON THE TOP PRESSURE LAYER.EVEN IF ONE IS
8651 ! NOT INTERESTED IN THE TRANSMISSION FUNCTION BETWEEN 0 AND P(J),
8652 ! ONE MUST INCLUDE SUCH A LEVEL.
8653 ! 2) PD(NLP2)=P(NLP1) IS LESS THAN OR EQUAL TO 1165 MB.
8654 ! EXTRAPOLATION TO HIGHER PRESSURES IS NOT POSSIBLE.
8655 ! 3) IF PROGRAM IS NOT PERMITTED ON YOUR COMPILER,
8656 ! SIMPLY DELETE THE LINE.
8657 ! 4) IF PARAMETER IS NOT PERMITTED,DO THE FOLLOWING:
8658 ! 1) DELETE ALL PARAMETER STATEMENTS IN CO2INT
8659 ! 2) AT THE POINT WHERE NMETHOD IS READ IN,ADD:
8660 ! READ (5,202) NLEVLS
8661 ! NLP1=NLEVLS+1
8662 ! NLP2=NLEVLS+2
8663 ! 3) CHANGE DIMENSION AND/OR COMMON STATEMENTS DEFINING
8664 ! ARRAYS TRNS,DELTA,P,PD,TRNFCT,PS,PDS,PLM IN CO2INT.
8665 ! THE NUMERICAL VALUE OF (NLEVLS+1) SHOULD BE INSERTED
8666 ! IN DIMENSION OR COMMON STATEMENTS FOR TRNS,DELTA,
8667 ! P,TRNFCT,PS,PLM; THE NUMERICAL VALUE OF (NLEVLS+2)
8668 ! IN DIMENSION OR COMMON STATEMENTS FOR PD,PDS.
8669 ! 5) PARAMETER (NLEVLS=40) AND THE OTHER PARAMETER
8670 ! STATEMENTS ARE WRITTEN IN CDC FORTRAN; ON OTHER MACHINES THE
8671 ! SAME STATEMENT MAY BE WRITTEN DIFFERENTLY,FOR EXAMPLE AS
8672 ! PARAMETER NLEVLS=40
8673 ! 6) -DOUBLE PRECISION- IS USED INSTEAD OF -REAL*8- ,DUE TO
8674 ! REQUIREMENTS OF CDC FORTAN.
8675 ! 7) THE STATEMENT -DO 400 KKK=1,3- CONTROLS THE NUMBER OF
8676 ! TRANSMISSIVITY OUTPUT MATRICES PORDUCED BY THE PROGRAM.TO
8677 ! PRODUCE 1 OUTPUT MATRIX,DELETE THIS STATEMENT.
8678 !
8679 ! OUTPUT:
8680 ! A) TRNFCT IS AN (NLP1,NLP1) REAL ARRAY OF THE TRANSMISSION
8681 ! FUNCTIONS APPROPRIATE TO YOUR ARRAY. IT IS TO BE SAVED ON FILE 22.
8682 ! THE PROCEDURE FOR SAVING MAY BE MODIFIED; AS GIVEN HERE,THE
8683 ! OUTPUT IS IN CARD IMAGE FORM WITH A FORMAT OF (4F20.14).
8684 !
8685 ! B) PRINTED OUTPUT IS A LISTING OF TRNFCT ON UNIT 6, IN
8686 ! THE FORMAT (1X,8F15.8) (FORMAT STATEMENT 301). THE USER MAY
8687 ! MODIFY OR ELIMINATE THIS AT WILL.
8688 !
8689 ! ************ FUNCTION INTERPOLATER ROUTINE *****************
8690 !
8691 !
8692 ! ****** THE FOLLOWING PARAMETER GIVES THE NUMBER OF *******
8693 ! ****** DATA LEVELS IN THE MODEL *******
8694 ! ****************************************************************
8695 ! ****************************************************************
8696 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
8697 ! COMMON/PRESS/PA(109)
8698 ! COMMON/TRAN/ TRANSA(109,109)
8699 ! COMMON / OUTPUT / TRNS(NLP1,NLP1)
8700 ! COMMON/INPUTP/P(NLP1),PD(NLP2)
8701 DIMENSION TRNS(NLP1,NLP1)
8702 DIMENSION P(NLP1),PD(NLP2)
8703 DIMENSION PS(NLP1),PDS(NLP2),PLM(NLP1)
8704 DIMENSION NRTAB(3)
8705 DIMENSION T15A(NLP2,2),T15B(NLP1)
8706 DIMENSION T22(NLP1,NLP1,3)
8707 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
8708 DATA NRTAB/1,2,4/
8709 !***********************************
8710 ! THE FOLLOWING ARE THE INPUT FORMATS
8711 100 FORMAT (4F20.14)
8712 743 FORMAT (F20.14)
8713 201 FORMAT (5E16.9)
8714 202 FORMAT (I3)
8715 !O222 203 FORMAT (F12.6,I2)
8716 203 FORMAT (F12.6)
8717 ! THE FOLLOWING ARE THE OUTPUT FORMATS
8718 102 FORMAT (4F20.14)
8719 301 FORMAT (1X,8F15.8)
8720 !
8721 !CC REWIND 15
8722 !CC REWIND 20
8723 !NOV89
8724 REWIND ITAPE
8725 !NOV89
8726 !CC REWIND 22
8727 !
8728 ! CALCULATION OF PA -THE -TABLE- OF 109 GRID PRESSURES
8729 ! NOTE-THIS CODE MUST NOT BE CHANGED BY THE USER^^^^^^^^^
8730 PA(1)=0.
8731 FACT15=10.**(1./15.)
8732 FACT30=10.**(1./30.)
8733 PA(2)=1.0E-3
8734 DO 231 I=2,76
8735 PA(I+1)=PA(I)*FACT15
8736 231 CONTINUE
8737 DO 232 I=77,108
8738 PA(I+1)=PA(I)*FACT30
8739 232 CONTINUE
8740 !
8741 N=25
8742 NLV=NLEVLS
8743 NLP1V=NLP1
8744 NLP2V=NLP2
8745 ! READ IN THE CO2 MIXING RATIO(IN UNITS OF 330 PPMV),AND AN INDEX
8746 ! GIVING THE FREQUENCY RANGE OF THE LBL DATA
8747 !O222 READ (5,203) RATIO,IR
8748 !CC IR = 1
8749 !CC READ (5,203) RATIO
8750 !O222 ***********************************
8751 !***VALUES FOR IR*****
8752 ! IR=1 CONSOL. LBL TRANS. =490-850
8753 ! IR=2 CONSOL. LBL TRANS. =490-670
8754 ! IR=3 CONSOL. LBL TRANS. =670-850
8755 ! IR=4 CONSOL. LBL TRANS. =2270-2380
8756 !*** IR MUST BE 1,2,3 OR 4 FOR THE PGM. TO WORK
8757 ! ALSO READ IN THE METHOD NO.(1 OR 2)
8758 !CC READ (5,202) NMETHD
8759 IF (RATIO.EQ.1.0) GO TO 621
8760 CALL wrf_error_fatal( 'SUBROUTINE CO2INT: 8746' )
8761 !NOV89 621 ITAP1=20
8762 621 ITAP1=ITAPE
8763 !NOV89
8764 NTAP=1
8765 IF (NMETHD.EQ.2) GO TO 502
8766 ! *****CARDS FOR PURPOSE 1(NMETHD=1)
8767 !CC READ (15,201) (P(I),I=1,NLP1)
8768 DO 300 I=1,NLP1
8769 P(I)=T15B(I)
8770 300 CONTINUE
8771 DO 801 I=1,NLP1
8772 PS(I)=P(I)
8773 801 CONTINUE
8774 GO TO 503
8775 502 CONTINUE
8776 ! *****CARDS FOR PURPOSE 2(NMETHD=2)
8777 !CC READ (15,201) (PD(I),I=1,NLP2)
8778 !CC READ (15,201) (PLM(I),I=1,NLP1)
8779 DO 303 I=1,NLP2
8780 PD(I)=T15A(I,1)
8781 303 CONTINUE
8782 DO 302 I=1,NLP1
8783 PLM(I)=T15A(I,2)
8784 302 CONTINUE
8785 DO 802 I=1,NLP1
8786 PDS(I)=PD(I+1)
8787 PS(I)=PLM(I)
8788 802 CONTINUE
8789 !
8790 503 CONTINUE
8791 ! *****DO LOOP CONTROLLING NUMBER OF OUTPUT MATRICES
8792 !NOV89
8793 !NOV89 DO 400 KKK=1,3
8794 ICLOOP = 3
8795 IF (IR.EQ.4) ICLOOP = 1
8796 DO 400 KKK=1,ICLOOP
8797 !NOV89
8798 ! **********************
8799 IF (NMETHD.EQ.2) GO TO 505
8800 ! *****CARDS FOR PURPOSE 1(NMETHD=1)
8801 DO 803 I=1,NLP1
8802 P(I)=PS(I)
8803 803 CONTINUE
8804 GO TO 506
8805 505 CONTINUE
8806 ! *****CARDS FOR PURPOSE 2(NMETHD=2)
8807 DO 804 I=1,NLP1
8808 PD(I)=PDS(I)
8809 P(I)=PS(I)
8810 804 CONTINUE
8811 !
8812 506 CONTINUE
8813 IA=108
8814 IAP=IA+1
8815 !NOV89 IF (NTAP.EQ.1) READ (20,100) ((TRANSA(I,J),I=1,109),J=1,109)
8816 !mp IF (NTAP.EQ.1) READ (ITAPE,100) ((TRANSA(I,J),I=1,109),J=1,109)
8817 IF (NTAP.EQ.1) THEN
8818 IF ( wrf_dm_on_monitor() ) READ (ITAPE,743) ((TRANSA(I,J),I=1,109),J=1,109)
8819 CALL wrf_dm_bcast_bytes ( TRANSA , size ( TRANSA ) * RWORDSIZE )
8820 ENDIF
8821 !mp IF (NTAP.EQ.1) READ (ITAPE,100) (tmp(I),I=1,11881
8822 !mp
8823 do J=109,1,-6
8824 !mp write(6,697)(TRANSA(I,J),I=5,105,10)
8825 enddo
8826 ! 697 format(11(f5.3,1x))
8827 !mp
8828 !NOV89
8829 DO 4 I=1,IAP
8830 TRANSA(I,I)=1.0
8831 4 CONTINUE
8832 CALL COEINT(RATIO,IR)
8833 DO 805 I=1,NLP1
8834 DO 805 J=1,NLP1
8835 TRNS(J,I)=1.00
8836 805 CONTINUE
8837 DO 10 I=1,NLP1
8838 DO 20 J=1,I
8839 IF (I.EQ.J) GO TO 20
8840 P1=P(J)
8841 P2=P(I)
8842 CALL SINTR2
8843 TRNS(J,I)=TRNSLO
8844 20 CONTINUE
8845 10 CONTINUE
8846 DO 47 I=1,NLP1
8847 DO 47 J=I,NLP1
8848 TRNS(J,I)=TRNS(I,J)
8849 47 CONTINUE
8850 ! *****THIS IS THE END OF PURPOSE 1 CALCULATIONS
8851 IF (NMETHD.EQ.1) GO TO 2872
8852 !
8853 DO 51 J=1,NLP1
8854 DO 52 I=2,NLP1
8855 IA=I
8856 JA=J
8857 N=25
8858 IF (I.NE.J) N=3
8859 CALL QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
8860 52 CONTINUE
8861 51 CONTINUE
8862 ! *****THIS IS THE END OF PURPOSE 2 CALCULATIONS
8863 2872 CONTINUE
8864 !
8865 !+++ WRITE (6,301) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
8866 !CC WRITE (22,102) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
8867 DO 304 J=1,NLP1
8868 DO 304 I=1,NLP1
8869 T22(I,J,KKK) = TRNS(I,J)
8870 304 CONTINUE
8871 400 CONTINUE
8872 RETURN
8873 END SUBROUTINE CO2INT
8874 !CCC PROGRAM CO2IN1
8875 SUBROUTINE CO2IN1(T20,T21,T66,IQ,L,LP1)
8876 ! CO2IN1=CO2INS FOR METHOD 1
8877 ! *********************************************************
8878 ! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ***
8879 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988
8880 ! ..... K.CAMPANA DECEMBER 88 CLEANED UP FOR LAUNCHER
8881 ! *********************************************************
8882 DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3),T66(L,6)
8883 DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
8884 CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
8885 CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
8886 ITIN=20
8887 ITIN1=21
8888 !O222 LATEST CODE HAS IQ=1
8889 !CC IQ=4
8890 1011 FORMAT (4F20.14)
8891 !CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
8892 !CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
8893 !CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
8894 !CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
8895 !CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
8896 !CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
8897 DO 300 J=1,LP1
8898 DO 300 I=1,LP1
8899 CO2PO(I,J) = T20(I,J,1)
8900 !NOV89
8901 IF (IQ.EQ.5) GO TO 300
8902 !NOV89
8903 CO2PO1(I,J) = T20(I,J,2)
8904 CO2PO2(I,J) = T20(I,J,3)
8905 300 CONTINUE
8906 DO 301 J=1,LP1
8907 DO 301 I=1,LP1
8908 CO2800(I,J) = T21(I,J,1)
8909 !NOV89
8910 IF (IQ.EQ.5) GO TO 301
8911 !NOV89
8912 CO2801(I,J) = T21(I,J,2)
8913 CO2802(I,J) = T21(I,J,3)
8914 301 CONTINUE
8915 !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
8916 ! ARE:
8917 ! IQ=1 560-800 (CONSOL.=490-850)
8918 ! IQ=2 560-670 (CONSOL.=490-670)
8919 ! IQ=3 670-800 (CONSOL.=670-850)
8920 ! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850)
8921 !NOV89
8922 ! IQ=5 2270-2380 (CONSOL.=2270-2380)
8923 !NOV89
8924 ! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
8925 ! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
8926 ! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
8927 IF (IQ.EQ.1) THEN
8928 C1=1.5
8929 C2x=0.5
8930 ENDIF
8931 IF (IQ.EQ.2) THEN
8932 C1=18./11.
8933 C2x=7./11.
8934 ENDIF
8935 IF (IQ.EQ.3) THEN
8936 C1=18./13.
8937 C2x=5./13.
8938 ENDIF
8939 IF (IQ.EQ.4) THEN
8940 C1=1.8
8941 C2x=0.8
8942 ENDIF
8943 !NOV89
8944 IF (IQ.EQ.5) THEN
8945 C1=1.0
8946 C2x=0.0
8947 ENDIF
8948 !NOV89
8949 DO 1021 I=1,LP1
8950 DO 1021 J=1,LP1
8951 CO2PO(J,I)=C1*CO2PO(J,I)-C2x
8952 CO2800(J,I)=C1*CO2800(J,I)-C2x
8953 !NOV89
8954 IF (IQ.EQ.5) GO TO 1021
8955 !NOV89
8956 CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
8957 CO2801(J,I)=C1*CO2801(J,I)-C2x
8958 CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
8959 CO2802(J,I)=C1*CO2802(J,I)-C2x
8960 1021 CONTINUE
8961 !NOV89
8962 IF (IQ.GE.1.AND.IQ.LE.4) THEN
8963 !NOV89
8964 DO 1 J=1,LP1
8965 DO 1 I=1,LP1
8966 DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
8967 DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
8968 D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
8969 D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
8970 1 CONTINUE
8971 !NOV89
8972 ENDIF
8973 !NOV89
8974 !O222 *********************************************************
8975 !CC REWIND 66
8976 ! SAVE CDTM51,CO2M51,C2DM51,CDTM58,CO2M58,C2DM58..ON TEMPO FILE
8977 !CC WRITE (66) (DCDT10(I,I+1),I=1,L)
8978 !CC WRITE (66) (CO2PO(I,I+1),I=1,L)
8979 !CC WRITE (66) (D2CT10(I,I+1),I=1,L)
8980 !CC WRITE (66) (DCDT8(I,I+1),I=1,L)
8981 !CC WRITE (66) (CO2800(I,I+1),I=1,L)
8982 !CC WRITE (66) (D2CT8(I,I+1),I=1,L)
8983 !CC REWIND 66
8984 !O222 *********************************************************
8985 DO 400 I=1,L
8986 T66(I,2) = CO2PO(I,I+1)
8987 T66(I,5) = CO2800(I,I+1)
8988 !NOV89
8989 IF (IQ.EQ.5) GO TO 400
8990 !NOV89
8991 T66(I,1) = DCDT10(I,I+1)
8992 T66(I,3) = D2CT10(I,I+1)
8993 T66(I,4) = DCDT8(I,I+1)
8994 T66(I,6) = D2CT8(I,I+1)
8995 400 CONTINUE
8996 RETURN
8997 END SUBROUTINE CO2IN1
8998 !CCC PROGRAM PTZ - COURTESY OF DAN SCHWARZKOPF,GFDL DEC 1987....
8999 SUBROUTINE CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9000 SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLP2)
9001 !
9002 ! ** THIS PROGRAM CALCULATES TEMPERATURES ,H2O MIXING RATIOS
9003 ! ** AND O3 MIXING RATIOS BY USING AN ANALYTICAL
9004 ! ** FUNCTION WHICH APPROXIMATES
9005 ! ** THE US STANDARD (1976). THIS IS
9006 ! ** CALCULATED IN FUNCTION 'ANTEMP', WHICH IS CALLED BY THE
9007 ! ** MAIN PROGRAM. THE FORM OF THE ANALYTICAL FUNCTION WAS
9008 ! ** SUGGESTED TO ME IN 1971 BY RICHARD S. LINDZEN.
9009 ! ******************************************************************
9010 ! CODE TO SAVE STEMP,GTEMP ON DATA SET,BRACKETED BY CO222 **
9011 ! ....K. CAMPANA MARCH 88,OCTOBER 88
9012 DIMENSION SGTEMP(NLP,2),T41(NLP2,2),T42(NLP), &
9013 T43(NLP2,2),T44(NLP)
9014 DIMENSION SGLVNU(NLP),SIGLNU(NL)
9015 DIMENSION SFULL(NLP),SHALF(NL)
9016 ! ******************************************************************
9017 !
9018 !*****THIS VERSION IS ONLY USABLE FOR 1976 US STD ATM AND OBTAINS
9019 ! QUANTITIES FOR CO2 INTERPOLATION AND INSERTION INTO OPERA-
9020 ! TIONAL RADIATION CODES
9021 !
9022 CHARACTER*20 PROFIL
9023 DIMENSION PRESS(NLP),TEMP(NLP),ALT(NLP),WMIX(NLP),O3MIX(NLP)
9024 DIMENSION WMXINT(NLP,4),WMXOUT(NLP2),OMXINT(NLP,4),OMXOUT(NLP2)
9025 DIMENSION PD(NLP2),GTEMP(NLP)
9026 DIMENSION PRS(NLP),TEMPS(NLP),PRSINT(NLP),TMPINT(NLP,4),A(NLP,4)
9027 DIMENSION PROUT(NLP2),TMPOUT(NLP2),TMPFLX(NLP2),TMPMID(NLP2)
9028 !
9029 !
9030 DATA PROFIL/ &
9031 'US STANDARD 1976'/
9032 DATA PSMAX/1013.250/
9033 !
9034 ! ** NTYPE IS AN INTEGER VARIABLE WHICH HAS THE FOLLOWING
9035 ! ** VALUES: 0 =SIGMA LEVELS ARE USED; 1= SKYHI L40 LEVELS
9036 ! ** ARE USED; 2 = SKYHI L80 LEVELS ARE USED. DEFAULT: 0
9037 !
9038 NTYPE=0
9039 !O222 READ (*,*) NTYPE
9040 5 NLEV=NL
9041 DELZAP=0.5
9042 R=8.31432
9043 G0=9.80665
9044 ZMASS=28.9644
9045 AA=6356.766
9046 ALT(1)=0.0
9047 TEMP(1)=ANTEMP(6,0.0)
9048 !*******DETERMINE THE PRESSURES (PRESS)
9049 PSTAR=PSMAX
9050 !
9051 !*** LTOP COMPUTATION MOVED FROM MODEL INITIALIZATION
9052 !
9053 LTOP(1)=0
9054 LTOP(2)=0
9055 LTOP(3)=0
9056 DO 30 N=1,NL
9057 PCLD=(PSTAR-PPTOP*10.)*SHALF(N)+PPTOP*10.
9058 IF(PCLD.GE.642.)LTOP(1)=N
9059 IF(PCLD.GE.350.)LTOP(2)=N
9060 IF(PCLD.GE.150.)LTOP(3)=N
9061 ! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
9062 30 CONTINUE
9063 !
9064 !O222 IF (NTYPE.EQ.1) CALL SKYP(PSTAR,PD,GTEMP)
9065 !O222 IF (NTYPE.EQ.2) CALL SKY80P(PSTAR,PD,GTEMP)
9066 !O222 IF (NTYPE.EQ.0) CALL SIGP(PSTAR,PD,GTEMP)
9067 !CC---- CALL SIGP(PSTAR,PD,GTEMP)
9068 NLM=NL-1
9069 CALL SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9070 SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLM,NLP2)
9071 PD(NLP2)=PSTAR
9072 DO 40 N=1,NLP
9073 PRSINT(N)=PD(NLP2+1-N)
9074 40 CONTINUE
9075 ! *** CALCULATE TEMPS FOR SEVERAL PRESSURES TO DO QUADRATURE
9076 DO 504 NQ=1,4
9077 DO 505 N=2,NLP
9078 505 PRESS(N)=PRSINT(N)+0.25*(NQ-1)*(PRSINT(N-1)-PRSINT(N))
9079 PRESS(1)=PRSINT(1)
9080 !*********************
9081 DO 100 N=1,NLEV
9082 !
9083 ! ** ESTABLISH COMPUTATATIONAL LEVELS BETWEEN USER LEVELS AT
9084 ! ** INTERVALS OF APPROXIMATELY 'DELZAP' KM.
9085 !
9086 DLOGP=7.0*ALOG(PRESS(N)/PRESS(N+1))
9087 NINT=DLOGP/DELZAP
9088 NINT=NINT+1
9089 ZNINT=NINT
9090 ! G=G0
9091 DZ=R*DLOGP/(7.0*ZMASS*G0*ZNINT)
9092 HT=ALT(N)
9093 !
9094 ! ** CALCULATE HEIGHT AT NEXT USER LEVEL BY MEANS OF
9095 ! ** RUNGE-KUTTA INTEGRATION.
9096 !
9097 DO 200 M=1,NINT
9098 RK1=ANTEMP(6,HT)*DZ
9099 RK2=ANTEMP(6,HT+0.5*RK1)*DZ
9100 RK3=ANTEMP(6,HT+0.5*RK2)*DZ
9101 RK4=ANTEMP(6,HT+RK3)*DZ
9102 !mp write(6,*) 'RK values,DZ ', RK1,RK2,RK3,RK4,DZ
9103 HT=HT+0.16666667*(RK1+RK2+RK2+RK3+RK3+RK4)
9104 200 CONTINUE
9105 ALT(N+1)=HT
9106 TEMP(N+1)=ANTEMP(6,HT)
9107 100 CONTINUE
9108 DO 506 N=1,NLP
9109 TMPINT(N,NQ)=TEMP(N)
9110 A(N,NQ)=ALT(N)
9111 506 CONTINUE
9112 504 CONTINUE
9113 !O222 *****************************************************
9114 !***OUTPUT TEMPERATURES
9115 !O222 *****************************************************
9116 DO 901 N=1,NLP
9117 SGTEMP(N,1) = TMPINT(NLP2-N,1)
9118 901 CONTINUE
9119 !O222 *****************************************************
9120 !***OUTPUT GTEMP
9121 !O222 *****************************************************
9122 DO 902 N=1,NLP
9123 SGTEMP(N,2) = GTEMP(N)
9124 902 CONTINUE
9125 !O222 *****************************************************
9126 RETURN
9127 END SUBROUTINE CO2PTZ
9128 FUNCTION PATH(A,B,C,E)
9129 !....
9130 ! DOUBLE PRECISION XA,CA
9131 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
9132 PEXP=1./SEXP
9133 PATH=((A-B)**PEXP*(A+B+C))/(E*(A+B+C)+(A-B)**(PEXP-1.))
9134 RETURN
9135 END FUNCTION PATH
9136 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9137 SUBROUTINE QINTRP(XM,X0,XP,FM,F0,FP,X,F)
9138 !....
9139 ! DOUBLE PRECISION FM,F0,FP,F,D1,D2,B,A,DEL
9140 D1=(FP-F0)/(XP-X0)
9141 D2=(FM-F0)/(XM-X0)
9142 B=(D1-D2)/(XP-XM)
9143 A=D1-B*(XP-X0)
9144 DEL=(X-X0)
9145 F=F0+DEL*(A+DEL*B)
9146 RETURN
9147 END SUBROUTINE QINTRP
9148 SUBROUTINE QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
9149 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
9150 DIMENSION P(NLP1V),PD(NLP2V),TRNS(NLP1V,NLP1V)
9151 DIMENSION WT(101)
9152 N2=2*N
9153 N2P=2*N+1
9154 ! *****WEIGHTS ARE CALCULATED
9155 WT(1)=1.
9156 DO 21 I=1,N
9157 WT(2*I)=4.
9158 WT(2*I+1)=1.
9159 21 CONTINUE
9160 IF (N.EQ.1) GO TO 25
9161 DO 22 I=2,N
9162 WT(2*I-1)=2.
9163 22 CONTINUE
9164 25 CONTINUE
9165 TRNSNB=0.
9166 DP=(PD(IA)-PD(IA-1))/N2
9167 PFIX=P(JA)
9168 DO 1 KK=1,N2P
9169 PVARY=PD(IA-1)+(KK-1)*DP
9170 IF (PVARY.GE.PFIX) P2=PVARY
9171 IF (PVARY.GE.PFIX) P1=PFIX
9172 IF (PVARY.LT.PFIX) P1=PVARY
9173 IF (PVARY.LT.PFIX) P2=PFIX
9174 CALL SINTR2
9175 TRNSNB=TRNSNB+TRNSLO*WT(KK)
9176 1 CONTINUE
9177 TRNS(IA,JA)=TRNSNB*DP/(3.*(PD(IA)-PD(IA-1)))
9178 RETURN
9179 END SUBROUTINE QUADSR
9180 !---------------------------------------------------------------------
9181 SUBROUTINE SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9182 SIGLV,SIGLY,PPTOP,LREAD,KD,KP,KM,KP2)
9183 DIMENSION Q(KD),QMH(KP),PD(KP2),PLM(KP),GTEMP(KP),PDT(KP2)
9184 DIMENSION SIGLY(KD),SIGLV(KP)
9185 DIMENSION CI(KP),SGLVNU(KP),DEL(KD),SIGLNU(KD),CL(KD),RPI(KM)
9186 DIMENSION IDATE(4)
9187 DIMENSION T41(KP2,2),T42(KP), &
9188 T43(KP2,2),T44(KP)
9189 ! integer :: retval
9190 ! character(50) :: prsmid='prsmid'
9191 !CC 18 LEVEL SIGMAS FOR NMC MRF(NEW) MODEL
9192 !CC DATA Q/.021,.074,.124,.175,.225,.275,.325,.375,.425,.497, &
9193 !CC .594,.688,.777,.856,.920,.960,.981,.995/
9194 ! FOR SIGMA MODELS,Q=SIGMA,QMH=0.5(Q(I)+Q(I+1),
9195 ! PD=Q*PSS,PLM=QMH*PSS.PSS=SURFACE PRESSURE(SPEC.)
9196 !
9197 !..... GET NMC SIGMA STRUCTURE
9198 !CC IF (LREAD.GT.0) GO TO 914
9199 !--- PPTOP IS MODEL TOP PRESSURE IN CB....
9200 ! SIGMA DATA IS BOTTOM OF ATMOSPHERE TO T.O.A.....
9201 !cccc PPTOP=5.0
9202 ! READ(11,PPTOP,END=12321)
9203 12321 CONTINUE
9204 ! WRITE(6,88221)PPTOP,KD,KP
9205 !88221 FORMAT(' ENTER SIGP PPTOP=',E12.5,' KD=',I2,' KP=',I2)
9206 ! open(unit=23,file='fort.23',form='unformatted' &
9207 ! , access='sequential')
9208 ! REWIND 23
9209 ! READ(23)SIGLY
9210 ! DO KKK=1,KD
9211 ! SIGLY(KKK)=1.-(FLOAT(KKK)-0.5)/KD
9212 ! END DO
9213 ! WRITE(6,88222)
9214 !88222 FORMAT(' READ AETA')
9215 ! DO 37821 LLL=1,KD
9216 ! WRITE(6,37820)LLL,SIGLY(LLL)
9217 !37820 FORMAT(' L=',I2,' AETA=',E12.5)
9218 !37821 CONTINUE
9219 ! READ(23)SIGLV
9220 ! DO KKK=1,KP
9221 ! SIGLV(KKK)=1.-(FLOAT(KKK-1))/KD
9222 ! END DO
9223 ! WRITE(6,88223)
9224 !88223 FORMAT(' READ ETA')
9225 ! PRINT 704,(SIGLY(K),K=1,KD)
9226 ! PRINT 704,(SIGLV(K),K=1,KP)
9227 ! DO 37823 LLL=1,KP
9228 ! WRITE(6,37822)LLL,SIGLV(LLL)
9229 !37822 FORMAT(' L=',I2,' ETA=',E12.5)
9230 !37823 CONTINUE
9231 701 FORMAT(F6.2)
9232 702 FORMAT(7F10.6)
9233 IF (PPTOP.LE.0.) GO TO 708
9234 PSFC=100.
9235 !--- IF PTOP NOT EQUAL TO ZERO ADJUST SIGMA SO AS TO GET PROPER STD ATM
9236 ! VERTICAL LOCATION
9237 DO 706 K=1,KD
9238 SIGLY(K) = (SIGLY(K)*(PSFC-PPTOP)+PPTOP)/PSFC
9239 706 CONTINUE
9240 DO 707 K=1,KP
9241 SIGLV(K) = (SIGLV(K)*(PSFC-PPTOP)+PPTOP)/PSFC
9242 707 CONTINUE
9243 708 CONTINUE
9244 ! PRINT 703,PPTOP
9245 ! PRINT 704,(SIGLY(K),K=1,KD)
9246 ! PRINT 704,(SIGLV(K),K=1,KP)
9247 703 FORMAT(1H ,'PTOP =',F6.2)
9248 704 FORMAT(1H ,7F10.6)
9249 DO 913 K=1,KP
9250 SGLVNU(K) = SIGLV(K)
9251 IF (K.LE.KD) SIGLNU(K) = SIGLY(K)
9252 913 CONTINUE
9253 DO 77 K=1,KD
9254 Q(K) = SIGLNU(KD+1-K)
9255 77 CONTINUE
9256 PSS= 1013250.
9257 QMH(1)=0.
9258 QMH(KP)=1.
9259 DO 1 K=2,KD
9260 QMH(K)=0.5*(Q(K-1)+Q(K))
9261 1 CONTINUE
9262 PD(1)=0.
9263 PD(KP2)=PSS
9264 DO 2 K=2,KP
9265 PD(K)=Q(K-1)*PSS
9266 2 CONTINUE
9267 ! call int_get_fresh_handle(retval)
9268 ! close(retval)
9269 ! write(0,*)' before open in CO2O3'
9270 ! open(unit=retval,file=prsmid,form='UNFORMATTED',iostat=ier)
9271 ! write(0,*)' after open1'
9272 ! do k=1,62
9273 ! write(retval)pd(k)
9274 ! enddo
9275 ! close(retval)
9276 PLM(1)=0.
9277 DO 3 K=1,KM
9278 PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
9279 3 CONTINUE
9280 PLM(KP)=PSS
9281 DO 4 K=1,KD
9282 GTEMP(K)=PD(K+1)**0.2*(1.+PD(K+1)/30000.)**0.8/1013250.
9283 4 CONTINUE
9284 GTEMP(KP)=0.
9285 !+++ WRITE (6,100) (GTEMP(K),K=1,KD)
9286 !+++ WRITE (6,100) (PD(K),K=1,KP2)
9287 !+++ WRITE (6,100) (PLM(K),K=1,KP)
9288 !***TAPES 41,42 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM (PS=1013MB)
9289 ! THE FOLLOWING PUTS P-DATA INTO MB
9290 DO 11 I=1,KP
9291 PD(I)=PD(I)*1.0E-3
9292 PLM(I)=PLM(I)*1.0E-3
9293 11 CONTINUE
9294 PD(KP2)=PD(KP2)*1.0E-3
9295 !CC WRITE (41,101) (PD(K),K=1,KP2)
9296 !CC WRITE (41,101) (PLM(K),K=1,KP)
9297 !CC WRITE (42,101) (PLM(K),K=1,KP)
9298 DO 300 K=1,KP2
9299 T41(K,1) = PD(K)
9300 300 CONTINUE
9301 DO 301 K=1,KP
9302 T41(K,2) = PLM(K)
9303 T42(K) = PLM(K)
9304 301 CONTINUE
9305 !***STORE AS PDT,SO THAT RIGHT PD IS RETURNED TO PTZ
9306 DO 12 I=1,KP2
9307 PDT(I)=PD(I)
9308 12 CONTINUE
9309 !***SECOND PASS: PSS=810MB,GTEMP NOT COMPUTED
9310 PSS=0.8*1013250.
9311 QMH(1)=0.
9312 QMH(KP)=1.
9313 DO 201 K=2,KD
9314 QMH(K)=0.5*(Q(K-1)+Q(K))
9315 201 CONTINUE
9316 PD(1)=0.
9317 PD(KP2)=PSS
9318 DO 202 K=2,KP
9319 PD(K)=Q(K-1)*PSS
9320 202 CONTINUE
9321 PLM(1)=0.
9322 DO 203 K=1,KM
9323 PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
9324 203 CONTINUE
9325 PLM(KP)=PSS
9326 !+++ WRITE (6,100) (PD(K),K=1,KP2)
9327 !+++ WRITE (6,100) (PLM(K),K=1,KP)
9328 !***TAPES 43,44 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM(PS=810 MB)
9329 ! THE FOLLOWING PUTS P-DATA INTO MB
9330 DO 211 I=1,KP
9331 PD(I)=PD(I)*1.0E-3
9332 PLM(I)=PLM(I)*1.0E-3
9333 211 CONTINUE
9334 PD(KP2)=PD(KP2)*1.0E-3
9335 !CC WRITE (43,101) (PD(K),K=1,KP2)
9336 !CC WRITE (43,101) (PLM(K),K=1,KP)
9337 !CC WRITE (44,101) (PLM(K),K=1,KP)
9338 DO 302 K=1,KP2
9339 T43(K,1) = PD(K)
9340 302 CONTINUE
9341 DO 303 K=1,KP
9342 T43(K,2) = PLM(K)
9343 T44(K) = PLM(K)
9344 303 CONTINUE
9345 !***RESTORE PD
9346 DO 212 I=1,KP2
9347 PD(I)=PDT(I)
9348 212 CONTINUE
9349 100 FORMAT (1X,5E20.13)
9350 101 FORMAT (5E16.9)
9351 RETURN
9352 END SUBROUTINE SIGP
9353 !---------------------------------------------------------------------
9354 SUBROUTINE SINTR2
9355 !....
9356 ! IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9357 ! REAL P1,P2,PA,TRNSLO,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
9358 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
9359 ! COMMON/PRESS/ PA(109)
9360 ! COMMON/TRAN/ TRANSA(109,109)
9361 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
9362 DO 70 L=1,109
9363 IP1=L
9364 IF (P2-PA(L)) 65,65,70
9365 70 CONTINUE
9366 65 I=IP1-1
9367 IF (IP1.EQ.1) IP1=2
9368 IF (I.EQ.0) I=1
9369 DO 80 L=1,109
9370 JP1=L
9371 IF (P1-PA(L)) 75,75,80
9372 80 CONTINUE
9373 75 J=JP1-1
9374 IF (JP1.EQ.1) JP1=2
9375 IF (J.EQ.0) J=1
9376 JJJ=J
9377 III=I
9378 J=JJJ
9379 JP1=J+1
9380 I=III
9381 IP1=I+1
9382 ! DETERMINE ETAP,THE VALUE OF ETA TO USE BY LINEAR INTERPOLATION
9383 ! FOR PETA(=0.5*(P1+P2))
9384 PETA=P2
9385 DO 90 L=1,109
9386 IETAP1=L
9387 IF (PETA-PA(L)) 85,85,90
9388 90 CONTINUE
9389 85 IETA=IETAP1-1
9390 IF (IETAP1.EQ.1) IETAP1=2
9391 IF (IETA.EQ.0) IETA=1
9392 ETAP=ETA(IETA)+(PETA-PA(IETA))*(ETA(IETAP1)-ETA(IETA))/ &
9393 (PA(IETAP1)-PA(IETA))
9394 SEXP=SEXPV(IETA)+(PETA-PA(IETA))*(SEXPV(IETAP1)- &
9395 SEXPV(IETA))/ (PA(IETAP1)-PA(IETA))
9396 PIPMPI=PA(IP1)-PA(I)
9397 UP2P1=(PATH(P2,P1,CORE,ETAP))**UEXP
9398 IF (I-J) 126,126,127
9399 126 CONTINUE
9400 TRIP=(CA(IP1)*DLOG(1.0D0+XA(IP1)*UP2P1))**(SEXP/UEXP)
9401 TRI=(CA(I)*DLOG(1.0D0+XA(I)*UP2P1))**(SEXP/UEXP)
9402 TRNSLO=1.0D0-((PA(IP1)-P2)*TRI+(P2-PA(I))*TRIP)/PIPMPI
9403 GO TO 128
9404 127 TIJ=TRANSA(I,J)
9405 TIPJ=TRANSA(I+1,J)
9406 TIJP=TRANSA(I,J+1)
9407 TIPJP=TRANSA(I+1,J+1)
9408 UIJ=(PATH(PA(I),PA(J),CORE,ETAP))**UEXP
9409 UIPJ=(PATH(PA(I+1),PA(J),CORE,ETAP))**UEXP
9410 UIJP=(PATH(PA(I),PA(J+1),CORE,ETAP))**UEXP
9411 UIPJP=(PATH(PA(I+1),PA(J+1),CORE,ETAP))**UEXP
9412 PRODI=CA(I)*XA(I)
9413 PRODIP=CA(I+1)*XA(I+1)
9414 PROD=((PA(I+1)-P2)*PRODI+(P2-PA(I))*PRODIP)/PIPMPI
9415 XINT=((PA(I+1)-P2)*XA(I)+(P2-PA(I))*XA(I+1))/PIPMPI
9416 CINT=PROD/XINT
9417 AIJ=(CINT*DLOG(1.0D0+XINT*UIJ))**(SEXP/UEXP)
9418 AIJP=(CINT*DLOG(1.0D0+XINT*UIJP))**(SEXP/UEXP)
9419 AIPJ=(CINT*DLOG(1.0D0+XINT*UIPJ))**(SEXP/UEXP)
9420 AIPJP=(CINT*DLOG(1.0D0+XINT*UIPJP))**(SEXP/UEXP)
9421 EIJ=TIJ+AIJ
9422 EIPJ=TIPJ+AIPJ
9423 EIJP=TIJP+AIJP
9424 EIPJP=TIPJP+AIPJP
9425 DTDJ=(EIJP-EIJ)/(PA(J+1)-PA(J))
9426 DTDPJ=(EIPJP-EIPJ)/(PA(J+1)-PA(J))
9427 EPIP1=EIJ+DTDJ*(P1-PA(J))
9428 EPIPP1=EIPJ+DTDPJ*(P1-PA(J))
9429 EPP2P1=((PA(I+1)-P2)*EPIP1+(P2-PA(I))*EPIPP1)/PIPMPI
9430 TRNSLO=EPP2P1-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
9431 IF (I.GE.108.OR.J.GE.108) GO TO 350
9432 IF (I-J-2) 350,350,355
9433 355 CONTINUE
9434 TIP2J=TRANSA(I+2,J)
9435 TIP2JP=TRANSA(I+2,J+1)
9436 TI2J2=TRANSA(I+2,J+2)
9437 TIJP2=TRANSA(I,J+2)
9438 TIPJP2=TRANSA(I+1,J+2)
9439 UIP2J=(PATH(PA(I+2),PA(J),CORE,ETAP))**UEXP
9440 UIJP2=(PATH(PA(I),PA(J+2),CORE,ETAP))**UEXP
9441 UIPJP2=(PATH(PA(I+1),PA(J+2),CORE,ETAP))**UEXP
9442 UI2J2=(PATH(PA(I+2),PA(J+2),CORE,ETAP))**UEXP
9443 UIP2JP=(PATH(PA(I+2),PA(J+1),CORE,ETAP))**UEXP
9444 AIJP2=(CINT*DLOG(1.0D0+XINT*UIJP2))**(SEXP/UEXP)
9445 AIPJP2=(CINT*DLOG(1.0D0+XINT*UIPJP2))**(SEXP/UEXP)
9446 AIP2J=(CINT*DLOG(1.0D0+XINT*UIP2J))**(SEXP/UEXP)
9447 AIP2JP=(CINT*DLOG(1.0D0+XINT*UIP2JP))**(SEXP/UEXP)
9448 AI2J2=(CINT*DLOG(1.0D0+XINT*UI2J2))**(SEXP/UEXP)
9449 EIP2J=TIP2J+AIP2J
9450 EIP2JP=TIP2JP+AIP2JP
9451 EIJP2=TIJP2+AIJP2
9452 EIPJP2=TIPJP2+AIPJP2
9453 EI2J2=TI2J2+AI2J2
9454 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIJ,EIJP,EIJP2,P1,EI)
9455 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIPJ,EIPJP,EIPJP2,P1,EP)
9456 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIP2J,EIP2JP,EI2J2,P1,EP2)
9457 CALL QINTRP(PA(I),PA(I+1),PA(I+2),EI,EP,EP2,P2,EPSIL)
9458 TRNSLO=EPSIL-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
9459 350 CONTINUE
9460 128 CONTINUE
9461 205 CONTINUE
9462 RETURN
9463 END SUBROUTINE SINTR2
9464 SUBROUTINE CO2O3(SFULL,SHALF,PPTOP,L,LP1,LP2)
9465 !CCC PROGRAM CO2O3 = CONSOLIDATION OF A NUMBER OF DAN SCHWARZKOPF,GFDL
9466 ! CODES TO PRODUCE A FILE OF CO2 HGT DATA
9467 ! FOR ANY VERTICAL COORDINATE (READ BY SUBROUTINE
9468 ! CONRAD IN THE GFDL RADIATION CODES)-K.A.C. JUN89.
9469 !NOV89--UPDATED (NOV 89) FOR LATEST GFDL LW RADIATION.....K.A.C.
9470 LOGICAL :: opened
9471 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
9472 CHARACTER*80 errmess
9473 ! integer :: retval,kk,ka,kb
9474 ! character(50) :: co2='co2'
9475 INTEGER etarad_unit61, etarad_unit62, etarad_unit63,IERROR
9476 DIMENSION SGTEMP(LP1,2),CO2D1D(L,6),CO2D2D(LP1,LP1,6)
9477 !NOV89
9478 DIMENSION CO2IQ2(LP1,LP1,6),CO2IQ3(LP1,LP1,6),CO2IQ5(LP1,LP1,6)
9479 !NOV89
9480 DIMENSION T41(LP2,2),T42(LP1), &
9481 T43(LP2,2),T44(LP1)
9482 DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3)
9483 DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3)
9484 DIMENSION SGLVNU(LP1),SIGLNU(L)
9485 DIMENSION SFULL(LP1),SHALF(L)
9486 ! DIMENSION STEMP(LP1),GTEMP(LP1)
9487 ! DIMENSION CDTM51(L),CO2M51(L),C2DM51(L)
9488 ! DIMENSION CDTM58(L),CO2M58(L),C2DM58(L)
9489 ! DIMENSION CDT51(LP1,LP1),CO251(LP1,LP1),C2D51(LP1,LP1)
9490 ! DIMENSION CDT58(LP1,LP1),CO258(LP1,LP1),C2D58(LP1,LP1)
9491 !NOV89
9492 ! DIMENSION CDT31(LP1),CO231(LP1),C2D31(LP1)
9493 ! DIMENSION CDT38(LP1),CO238(LP1),C2D38(LP1)
9494 ! DIMENSION CDT71(LP1),CO271(LP1),C2D71(LP1)
9495 ! DIMENSION CDT78(LP1),CO278(LP1),C2D78(LP1)
9496 ! DIMENSION CO211(LP1),CO218(LP1)
9497 ! EQUIVALENCE (CDT31(1),CO2IQ2(1,1,1)),(CO231(1),CO2IQ2(1,1,2))
9498 ! EQUIVALENCE (C2D31(1),CO2IQ2(1,1,3)),(CDT38(1),CO2IQ2(1,1,4))
9499 ! EQUIVALENCE (CO238(1),CO2IQ2(1,1,5)),(C2D38(1),CO2IQ2(1,1,6))
9500 ! EQUIVALENCE (CDT71(1),CO2IQ3(1,1,1)),(CO271(1),CO2IQ3(1,1,2))
9501 ! EQUIVALENCE (C2D71(1),CO2IQ3(1,1,3)),(CDT78(1),CO2IQ3(1,1,4))
9502 ! EQUIVALENCE (CO278(1),CO2IQ3(1,1,5)),(C2D78(1),CO2IQ3(1,1,6))
9503 ! EQUIVALENCE (CO211(1),CO2IQ5(1,1,2)),(CO218(1),CO2IQ5(1,1,5))
9504 !NOV89
9505 ! EQUIVALENCE (STEMP(1),SGTEMP(1,1)),(GTEMP(1),SGTEMP(1,2))
9506 ! EQUIVALENCE (CDTM51(1),CO2D1D(1,1)),(CO2M51(1),CO2D1D(1,2))
9507 ! EQUIVALENCE (C2DM51(1),CO2D1D(1,3)),(CDTM58(1),CO2D1D(1,4))
9508 ! EQUIVALENCE (CO2M58(1),CO2D1D(1,5)),(C2DM58(1),CO2D1D(1,6))
9509 ! EQUIVALENCE (CDT51(1,1),CO2D2D(1,1,1)),(CO251(1,1),CO2D2D(1,1,2))
9510 ! EQUIVALENCE (C2D51(1,1),CO2D2D(1,1,3)),(CDT58(1,1),CO2D2D(1,1,4))
9511 ! EQUIVALENCE (CO258(1,1),CO2D2D(1,1,5)),(C2D58(1,1),CO2D2D(1,1,6))
9513 !
9514 ! Deallocate before reading. This is required for nested domain init.
9515 !
9516 IF(ALLOCATED (CO251))DEALLOCATE(CO251)
9517 IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
9518 IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
9519 IF(ALLOCATED (CO258))DEALLOCATE(CO258)
9520 IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
9521 IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
9522 IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
9523 IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
9524 IF(ALLOCATED (CO231))DEALLOCATE(CO231)
9525 IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
9526 IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
9527 IF(ALLOCATED (CO238))DEALLOCATE(CO238)
9528 IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
9529 IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
9530 IF(ALLOCATED (CO271))DEALLOCATE(CO271)
9531 IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
9532 IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
9533 IF(ALLOCATED (CO278))DEALLOCATE(CO278)
9534 IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
9535 IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
9536 IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
9537 IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
9538 IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
9539 IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
9540 IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
9541 IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
9542 !
9543 ALLOCATE(CO251(LP1,LP1))
9544 ALLOCATE(CDT51(LP1,LP1))
9545 ALLOCATE(C2D51(LP1,LP1))
9546 ALLOCATE(CO258(LP1,LP1))
9547 ALLOCATE(CDT58(LP1,LP1))
9548 ALLOCATE(C2D58(LP1,LP1))
9549 ALLOCATE(STEMP(LP1))
9550 ALLOCATE(GTEMP(LP1))
9551 ALLOCATE(CO231(LP1))
9552 ALLOCATE(CDT31(LP1))
9553 ALLOCATE(C2D31(LP1))
9554 ALLOCATE(CO238(LP1))
9555 ALLOCATE(CDT38(LP1))
9556 ALLOCATE(C2D38(LP1))
9557 ALLOCATE(CO271(LP1))
9558 ALLOCATE(CDT71(LP1))
9559 ALLOCATE(C2D71(LP1))
9560 ALLOCATE(CO278(LP1))
9561 ALLOCATE(CDT78(LP1))
9562 ALLOCATE(C2D78(LP1))
9563 ALLOCATE(CO2M51(L))
9564 ALLOCATE(CDTM51(L))
9565 ALLOCATE(C2DM51(L))
9566 ALLOCATE(CO2M58(L))
9567 ALLOCATE(CDTM58(L))
9568 ALLOCATE(C2DM58(L))
9569 IF ( wrf_dm_on_monitor() ) THEN
9570 DO i = 61,99
9571 INQUIRE ( i , OPENED = opened )
9572 IF ( .NOT. opened ) THEN
9573 etarad_unit61 = i
9574 GOTO 2061
9575 ENDIF
9576 ENDDO
9577 etarad_unit61 = -1
9578 2061 CONTINUE
9579 DO i = 62,99
9580 INQUIRE ( i , OPENED = opened )
9581 IF ( .NOT. opened ) THEN
9582 etarad_unit62 = i
9583 GOTO 2062
9584 ENDIF
9585 ENDDO
9586 etarad_unit62 = -1
9587 2062 CONTINUE
9588 DO i = 63,99
9589 INQUIRE ( i , OPENED = opened )
9590 IF ( .NOT. opened ) THEN
9591 etarad_unit63 = i
9592 GOTO 2063
9593 ENDIF
9594 ENDDO
9595 etarad_unit63 = -1
9596 2063 CONTINUE
9597 ENDIF
9598 CALL wrf_dm_bcast_bytes ( etarad_unit61 , IWORDSIZE )
9599 IF ( etarad_unit61 < 0 ) THEN
9600 CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9601 ENDIF
9602 CALL wrf_dm_bcast_bytes ( etarad_unit62 , IWORDSIZE )
9603 IF ( etarad_unit62 < 0 ) THEN
9604 CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9605 ENDIF
9606 CALL wrf_dm_bcast_bytes ( etarad_unit63 , IWORDSIZE )
9607 IF ( etarad_unit63 < 0 ) THEN
9608 CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9609 ENDIF
9610 IF ( wrf_dm_on_monitor() ) THEN
9611 OPEN(etarad_unit61,FILE='tr49t85', &
9612 FORM='FORMATTED',STATUS='OLD',ERR=9061,IOSTAT=IERROR)
9613 ENDIF
9614 IF ( wrf_dm_on_monitor() ) THEN
9615 OPEN(etarad_unit62,FILE='tr49t67', &
9616 FORM='FORMATTED',STATUS='OLD',ERR=9062,IOSTAT=IERROR)
9617 ENDIF
9618 IF ( wrf_dm_on_monitor() ) THEN
9619 OPEN(etarad_unit63,FILE='tr67t85', &
9620 FORM='FORMATTED',STATUS='OLD',ERR=9063,IOSTAT=IERROR)
9621 ENDIF
9623 !===> GET SGTEMP AND OUTPUT WHICH USED TO BE ON UNITS 41,42,43,44....
9624 LREAD = 0
9625 ! DO KKK=1,L
9626 !JD READ(23)SIGLNU(KKK)
9627 ! SIGLNU(KKK)=1.-FLOAT(KKK)/LP1
9628 ! END DO
9629 CALL CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9630 SFULL,SHALF,PPTOP,LREAD,L,LP1,LP2)
9631 ! call int_get_fresh_handle(retval)
9632 ! close(retval)
9633 ! open(unit=retval,file=co2,form='UNFORMATTED',iostat=ier)
9634 ! do kk=1,2
9635 ! write(retval)(sgtemp(k,kk),k=1,61)
9636 ! enddo
9637 DO K=1,LP1
9638 STEMP(K)=SGTEMP(K,1)
9639 GTEMP(K)=SGTEMP(K,2)
9640 ENDDO
9641 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9642 ! IR=1,IQ=1 IS FOR COMMON /CO2BD3/ IN RADIATION CODE...
9643 ! FOR THE CONSOLIDATED 490-850 CM-1 BAND...
9644 !NOV89
9645 ! ICO2TP=61
9646 ICO2TP=etarad_unit61
9647 !NOV89
9648 IR = 1
9649 RATIO = 1.0
9650 NMETHD = 2
9651 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9652 IR = 1
9653 RATIO = 1.0
9654 NMETHD = 1
9655 CALL CO2INT(ICO2TP,T41,T42,T20,RATIO,IR,NMETHD,L,LP1,LP2)
9656 IR = 1
9657 RATIO = 1.0
9658 NMETHD = 2
9659 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9660 IR = 1
9661 RATIO = 1.0
9662 NMETHD = 1
9663 CALL CO2INT(ICO2TP,T43,T44,T21,RATIO,IR,NMETHD,L,LP1,LP2)
9664 !===> FILL UP THE CO2D1D ARRAY
9665 ! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND
9666 ! THEIR DERIVATIVES FOR TAU(I,I+1),I=1,LEVS,
9667 ! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE BUT ARE THE
9668 ! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. THESE
9669 ! ARE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING H2O..
9670 !
9671 IQ = 1
9672 CALL CO2IN1(T20,T21,CO2D1D,IQ,L,LP1)
9673 ! do kk=1,6
9674 ! write(retval)(co2d1d(k,kk),k=1,60)
9675 ! enddo
9676 DO K=1,L
9677 CDTM51(K)=CO2D1D(K,1)
9678 CO2M51(K)=CO2D1D(K,2)
9679 C2DM51(K)=CO2D1D(K,3)
9680 CDTM58(K)=CO2D1D(K,4)
9681 CO2M58(K)=CO2D1D(K,5)
9682 C2DM58(K)=CO2D1D(K,6)
9683 ENDDO
9684 !
9685 !===> FILL UP THE CO2D2D ARRAY
9686 ! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9687 ! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
9688 ! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
9689 ! TO THE MRF VERTICAL COORDINATE,AND RE-CONSOLIDATED TO A
9690 ! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
9691 ! SCHWARZKOPF AND FELS (J.G.R.,1985).
9692 !
9693 CALL CO2INS(T22,T23,CO2D2D,IQ,L,LP1,1)
9694 ! do kk=1,6
9695 ! write(retval)((co2d2d(ka,kb,kk),ka=1,61),kb=1,61)
9696 ! enddo
9697 DO K1=1,LP1
9698 DO K2=1,LP1
9699 CDT51(K1,K2)=CO2D2D(K1,K2,1)
9700 CO251(K1,K2)=CO2D2D(K1,K2,2)
9701 C2D51(K1,K2)=CO2D2D(K1,K2,3)
9702 CDT58(K1,K2)=CO2D2D(K1,K2,4)
9703 CO258(K1,K2)=CO2D2D(K1,K2,5)
9704 C2D58(K1,K2)=CO2D2D(K1,K2,6)
9705 ENDDO
9706 ENDDO
9707 !
9708 !NOV89
9709 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9710 ! IR=2,IQ=2 IS FOR COMMON /CO2BD2/ IN RADIATION CODE...
9711 ! FOR THE CONSOLIDATED 490-670 CM-1 BAND...
9712 ! ICO2TP=62
9713 ICO2TP=etarad_unit62
9714 IR = 2
9715 RATIO = 1.0
9716 NMETHD = 2
9717 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9718 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9719 IQ = 2
9720 CALL CO2INS(T22,T23,CO2IQ2,IQ,L,LP1,2)
9721 ! do kk=1,6
9722 ! write(retval)(co2iq2(k,1,kk),k=1,61)
9723 ! enddo
9724 DO K=1,LP1
9725 CDT31(K)=CO2IQ2(K,1,1)
9726 CO231(K)=CO2IQ2(K,1,2)
9727 C2D31(K)=CO2IQ2(K,1,3)
9728 CDT38(K)=CO2IQ2(K,1,4)
9729 CO238(K)=CO2IQ2(K,1,5)
9730 C2D38(K)=CO2IQ2(K,1,6)
9731 ENDDO
9732 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9733 ! IR=3,IQ=3 IS FOR COMMON /CO2BD4/ IN RADIATION CODE...
9734 ! FOR THE CONSOLIDATED 670-850 CM-1 BAND...
9735 ! ICO2TP=63
9736 ICO2TP=etarad_unit63
9737 IR = 3
9738 RATIO = 1.0
9739 NMETHD = 2
9740 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9741 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9742 IQ = 3
9743 CALL CO2INS(T22,T23,CO2IQ3,IQ,L,LP1,3)
9744 ! do kk=1,6
9745 ! write(retval)(co2iq3(k,1,kk),k=1,61)
9746 ! enddo
9747 ! close(retval)
9748 DO K=1,LP1
9749 CDT71(K)=CO2IQ3(K,1,1)
9750 CO271(K)=CO2IQ3(K,1,2)
9751 C2D71(K)=CO2IQ3(K,1,3)
9752 CDT78(K)=CO2IQ3(K,1,4)
9753 CO278(K)=CO2IQ3(K,1,5)
9754 C2D78(K)=CO2IQ3(K,1,6)
9755 ENDDO
9756 !--- FOLLOWING CODE NOT WORKING AND NOT NEEDED YET
9757 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9758 ! IR=4,IQ=5 IS FOR COMMON /CO2BD5/ IN RADIATION CODE...
9759 ! FOR THE 4.3 MICRON BAND...
9760 ! NOT USED YET ICO2TP=65
9761 ! NOT USED YET IR = 4
9762 ! NOT USED YET RATIO = 1.0
9763 ! DAN SCHWARZ --- USE 300PPMV RATIO = 0.9091 (NOT TESTED YET).....
9764 ! NOT USED YET NMETHD = 2
9765 ! NOT USED YET CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD)
9766 ! NOT USED YET CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD)
9767 ! NOT USED YET IQ = 5
9768 ! NOT USED YET CALL CO2INS(T22,T23,CO2IQ5,IQ)
9769 !NOV89
9770 !... WRITE DATA TO DISK..
9771 ! ...SINCE THESE CODES ARE COMPILED WITH AUTODBL,THE CO2 DATA
9772 ! IS CONVERTED TO SINGLE PRECISION IN A LATER JOB STEP..
9774 ! NOT USED YET WRITE(66) CO211
9775 ! NOT USED YET WRITE(66) CO218
9776 !NOV89
9777 IF ( wrf_dm_on_monitor() ) THEN
9778 CLOSE (etarad_unit61)
9779 CLOSE (etarad_unit62)
9780 CLOSE (etarad_unit63)
9781 ENDIF
9783 RETURN
9784 9061 CONTINUE
9785 WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t85 on unit ',etarad_unit61
9786 write(0,*)' IERROR=',IERROR
9787 CALL wrf_error_fatal(errmess)
9788 9062 CONTINUE
9789 WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t67 on unit ',etarad_unit62
9790 write(0,*)' IERROR=',IERROR
9791 CALL wrf_error_fatal(errmess)
9792 9063 CONTINUE
9793 WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr67t85 on unit ',etarad_unit63
9794 write(0,*)' IERROR=',IERROR
9795 CALL wrf_error_fatal(errmess)
9796 END SUBROUTINE CO2O3
9799 !!================================================================================
9800 !----------------------------------------------------------------------
9801 !----------------------------------------------------------------------
9802 SUBROUTINE CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
9803 !----------------------------------------------------------------------
9804 ! *******************************************************************
9805 ! * C O N R A D *
9806 ! * READ CO2 TRANSMISSION DATA FROM UNIT(NFILE)FOR NEW VERTICAL *
9807 ! * COORDINATE TESTS ... *
9808 ! * THESE ARRAYS USED TO BE IN BLOCK DATA ...K.CAMPANA-MAR 90 *
9809 ! *******************************************************************
9810 !
9811 !----------------------------------------------------------------------
9812 IMPLICIT NONE
9813 !----------------------------------------------------------------------
9814 INTEGER,INTENT(IN) :: KDS,KDE,KMS,KME,KTS,KTE
9815 !----------------------------------------------------------------------
9816 !
9817 INTEGER :: I,I1,I2,IERROR,IRTN,J,K,KK,L,LP1,N,NUNIT_CO2,RSIZE
9818 INTEGER,DIMENSION(3) :: RSZE
9819 !
9820 REAL,DIMENSION(KMS:KME-1,6) :: CO21D
9821 REAL,DIMENSION(KMS:KME,2) :: SGTMP
9822 REAL,DIMENSION(KMS:KME,6) :: CO21D3,CO21D7
9823 REAL,DIMENSION(KMS:KME,KMS:KME,6) :: CO22D
9824 REAL,DIMENSION((KME-KMS+1)*(KME-KMS+1)) :: DATA2
9825 LOGICAL :: OPENED
9826 LOGICAL,EXTERNAL :: wrf_dm_on_monitor
9827 CHARACTER*80 errmess
9828 !
9829 !----------------------------------------------------------------------
9830 !
9831 ! CO2 DATA TABLES FOR USER'S VERTICAL COORDINATE
9832 !
9833 ! THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION
9834 ! FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND
9835 ! SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985),
9836 !----- THE 2-DIMENSIONAL ARRAYS ARE
9837 ! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9838 ! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
9839 ! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
9840 ! TO THE NMC MRF VERTICAL COORDINATTE,AND RE-CONSOLIDATED TO A
9841 ! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
9842 ! SCHWARZKOPF AND FELS (J.G.R.,1985).
9843 !----- THE 1-DIM ARRAYS ARE
9844 ! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9845 ! FOR TAU(I,I+1),I=1,L,
9846 ! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE,BUT ARE THE
9847 ! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES.
9848 ! THESE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING QH2O.
9849 !----- THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/
9850 ! 1013250.,WHERE P(K)=PRESSURE,NMC MRF(NEW) L18 DATA LEVELS FOR
9851 ! PSTAR=1013250.
9852 !----- STEMP IS US STANDARD ATMOSPHERES,1976,AT DATA PRESSURE LEVELS
9853 ! USING NMC MRF SIGMAS,WHERE PSTAR=1013.25 MB (PTZ PROGRAM)
9854 !
9855 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9856 ! AND PRESSURE DERIVATIVES FOR THE 560-800 CM-1 BAND. ALSO INCLUDED
9857 ! ARE THE STANDARD TEMPERATURES AND THE WEIGHTING FUNCTION. THESE
9858 ! DATA ARE IN BLOCK DATA BD3:
9859 ! CO251 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9860 ! WITH P(SFC)=1013.25 MB
9861 ! CO258 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9862 ! WITH P(SFC)= 810 MB
9863 ! CDT51 = FIRST TEMPERATURE DERIVATIVE OF CO251
9864 ! CDT58 = FIRST TEMPERATURE DERIVATIVE OF CO258
9865 ! C2D51 = SECOND TEMPERATURE DERIVATIVE OF CO251
9866 ! C2D58 = SECOND TEMPERATURE DERIVATIVE OF CO251
9867 ! CO2M51 = TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE
9868 ! LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR
9869 ! NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB
9870 ! CO2M58 = SAME AS CO2M51,WITH P(SFC)= 810 MB
9871 ! CDTM51 = FIRST TEMPERATURE DERIVATIVE OF CO2M51
9872 ! CDTM58 = FIRST TEMPERATURE DERIVATIVE OF CO2M58
9873 ! C2DM51 = SECOND TEMPERATURE DERIVATIVE OF CO2M51
9874 ! C2DM58 = SECOND TEMPERATURE DERIVATIVE OF CO2M58
9875 ! STEMP = STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL
9876 ! STRUCTURE WITH P(SFC)=1013.25 MB
9877 ! GTEMP = WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL
9878 ! STRUCTURE WITH P(SFC)=1013.25 MB.
9879 !----- THE FOLLOWING ARE STILL IN BLOCK DATA
9880 ! B0 = TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN.
9881 ! CORRECTION FOR T(K). (SEE REF. 4 AND BD3)
9882 ! B1 = TEMP. COEFFICIENT, USED ALONG WITH B0
9883 ! B2 = TEMP. COEFFICIENT, USED ALONG WITH B0
9884 ! B3 = TEMP. COEFFICIENT, USED ALONG WITH B0
9885 !
9886 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9887 ! AND PRESSURE DERIVATIVES FOR THE 560-670 CM-1 PART OF THE 15 UM
9888 ! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD2.
9889 ! FOR THE 560-670 CM-1 BAND,ONLY THE (1,I) VALUES ARE USED , SINCE
9890 ! THESE ARE USED FOR CTS COMPUTATIONS.
9891 ! CO231 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9892 ! WITH P(SFC)=1013.25 MB
9893 ! CO238 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9894 ! WITH P(SFC)= 810 MB
9895 ! CDT31 = FIRST TEMPERATURE DERIVATIVE OF CO231
9896 ! CDT38 = FIRST TEMPERATURE DERIVATIVE OF CO238
9897 ! C2D31 = SECOND TEMPERATURE DERIVATIVE OF CO231
9898 ! C2D38 = SECOND TEMPERATURE DERIVATIVE OF CO231
9899 !
9900 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9901 ! AND PRESSURE DERIVATIVES FOR THE 670-800 CM-1 PART OF THE 15 UM
9902 ! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD4.
9903 ! CO271 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9904 ! WITH P(SFC)=1013.25 MB
9905 ! CO278 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9906 ! WITH P(SFC)= 810 MB
9907 ! CDT71 = FIRST TEMPERATURE DERIVATIVE OF CO271
9908 ! CDT78 = FIRST TEMPERATURE DERIVATIVE OF CO278
9909 ! C2D71 = SECOND TEMPERATURE DERIVATIVE OF CO271
9910 ! C2D78 = SECOND TEMPERATURE DERIVATIVE OF CO271
9911 !
9912 ! *****THE FOLLOWING NOT USED IN CURRENT VERSION OF RADIATION *******
9913 !
9914 ! --CO2 TRANSMISSION FUNCTIONS FOR THE 2270-
9915 ! 2380 PART OF THE 4.3 UM CO2 BAND.
9916 ! THESE DATA ARE IN BLOCK DATA BD5.
9917 ! CO211 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9918 ! WITH P(SFC)=1013.25 MB
9919 ! CO218 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9920 ! WITH P(SFC)= 810 MB
9921 !
9922 ! *****THE ABOVE NOT USED IN CURRENT VERSION OF RADIATION ***********
9923 !----------------------------------------------------------------------
9924 !
9925 L=KME-KMS
9926 LP1=KME-KMS+1
9927 !
9928 !----------------------------------------------------------------------
9929 IF ( wrf_dm_on_monitor() ) THEN
9930 DO i = 14,99
9931 write(0,*)' in CONRAD i=',i,' opened=',opened
9932 INQUIRE ( i , OPENED = opened )
9933 IF ( .NOT. opened ) THEN
9934 nunit_co2 = i
9935 GOTO 2014
9936 ENDIF
9937 ENDDO
9938 nunit_co2 = -1
9939 2014 CONTINUE
9940 ENDIF
9941 IF ( wrf_dm_on_monitor() ) THEN
9942 OPEN(nunit_co2,FILE='co2_trans', &
9943 FORM='UNFORMATTED',STATUS='OLD',ERR=9014,IOSTAT=IERROR)
9944 REWIND NUNIT_CO2
9945 ENDIF
9947 !----------------------------------------------------------------------
9948 !
9949 !*** READ IN PRE-COMPUTED CO2 TRANSMISSION DATA.
9950 !
9951 RSZE(1) = LP1
9952 RSZE(2) = L
9953 RSZE(3) = LP1*LP1
9954 !----------------------------------------------------------------------
9955 !
9956 RSIZE = RSZE(1)
9957 !
9958 DO KK=1,2
9959 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(SGTMP(I,KK),I=1,RSIZE)
9960 CALL wrf_dm_bcast_real( SGTMP(1,KK), RSIZE )
9961 ENDDO
9962 !
9963 !----------------------------------------------------------------------
9964 !
9965 RSIZE = RSZE(2)
9966 !
9967 DO KK=1,6
9968 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D(I,KK),I=1,RSIZE)
9969 CALL wrf_dm_bcast_real( CO21D(1,KK), RSIZE )
9970 ENDDO
9971 !
9972 !----------------------------------------------------------------------
9973 !
9974 RSIZE = RSZE(3)
9975 !
9976 DO KK=1,6
9977 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(DATA2(I),I=1,RSIZE)
9978 CALL wrf_dm_bcast_real( DATA2(1), RSIZE )
9979 N=0
9980 !
9981 DO I1=1,LP1
9982 DO I2=1,LP1
9983 N=N+1
9984 CO22D(I1,I2,KK)=DATA2(N)
9985 ENDDO
9986 ENDDO
9987 !
9988 ENDDO
9990 !
9991 ! Deallocate before reading. This is required for nested domain init.
9992 !
9993 IF(ALLOCATED (CO251))DEALLOCATE(CO251)
9994 IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
9995 IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
9996 IF(ALLOCATED (CO258))DEALLOCATE(CO258)
9997 IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
9998 IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
9999 IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
10000 IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
10001 IF(ALLOCATED (CO231))DEALLOCATE(CO231)
10002 IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
10003 IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
10004 IF(ALLOCATED (CO238))DEALLOCATE(CO238)
10005 IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
10006 IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
10007 IF(ALLOCATED (CO271))DEALLOCATE(CO271)
10008 IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
10009 IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
10010 IF(ALLOCATED (CO278))DEALLOCATE(CO278)
10011 IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
10012 IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
10013 IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
10014 IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
10015 IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
10016 IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
10017 IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
10018 IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
10019 !
10020 !----------------------------------------------------------------------
10021 !
10022 RSIZE = RSZE(1)
10023 !
10024 DO KK=1,6
10025 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D3(I,KK),I=1,RSIZE)
10026 CALL wrf_dm_bcast_real( CO21D3(1,KK), RSIZE )
10027 ENDDO
10028 !
10029 !----------------------------------------------------------------------
10030 !
10031 DO KK=1,6
10032 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D7(I,KK),I=1,RSIZE)
10033 CALL wrf_dm_bcast_real ( CO21D7(1,KK), RSIZE )
10034 ENDDO
10035 !
10036 !----------------------------------------------------------------------
10037 ALLOCATE(CO251(LP1,LP1))
10038 ALLOCATE(CDT51(LP1,LP1))
10039 ALLOCATE(C2D51(LP1,LP1))
10040 ALLOCATE(CO258(LP1,LP1))
10041 ALLOCATE(CDT58(LP1,LP1))
10042 ALLOCATE(C2D58(LP1,LP1))
10043 ALLOCATE(STEMP(LP1))
10044 ALLOCATE(GTEMP(LP1))
10045 ALLOCATE(CO231(LP1))
10046 ALLOCATE(CDT31(LP1))
10047 ALLOCATE(C2D31(LP1))
10048 ALLOCATE(CO238(LP1))
10049 ALLOCATE(CDT38(LP1))
10050 ALLOCATE(C2D38(LP1))
10051 ALLOCATE(CO271(LP1))
10052 ALLOCATE(CDT71(LP1))
10053 ALLOCATE(C2D71(LP1))
10054 ALLOCATE(CO278(LP1))
10055 ALLOCATE(CDT78(LP1))
10056 ALLOCATE(C2D78(LP1))
10057 ALLOCATE(CO2M51(L))
10058 ALLOCATE(CDTM51(L))
10059 ALLOCATE(C2DM51(L))
10060 ALLOCATE(CO2M58(L))
10061 ALLOCATE(CDTM58(L))
10062 ALLOCATE(C2DM58(L))
10063 !----------------------------------------------------------------------
10064 !
10065 DO K=1,LP1
10066 STEMP(K) = SGTMP(K,1)
10067 GTEMP(K) = SGTMP(K,2)
10068 ENDDO
10069 !
10070 DO K=1,L
10071 CDTM51(K) = CO21D(K,1)
10072 CO2M51(K) = CO21D(K,2)
10073 C2DM51(K) = CO21D(K,3)
10074 CDTM58(K) = CO21D(K,4)
10075 CO2M58(K) = CO21D(K,5)
10076 C2DM58(K) = CO21D(K,6)
10077 ENDDO
10078 !
10079 DO J=1,LP1
10080 DO I=1,LP1
10081 CDT51(I,J) = CO22D(I,J,1)
10082 CO251(I,J) = CO22D(I,J,2)
10083 C2D51(I,J) = CO22D(I,J,3)
10084 CDT58(I,J) = CO22D(I,J,4)
10085 CO258(I,J) = CO22D(I,J,5)
10086 C2D58(I,J) = CO22D(I,J,6)
10087 ENDDO
10088 ENDDO
10089 !
10090 DO K=1,LP1
10091 CDT31(K) = CO21D3(K,1)
10092 CO231(K) = CO21D3(K,2)
10093 C2D31(K) = CO21D3(K,3)
10094 CDT38(K) = CO21D3(K,4)
10095 CO238(K) = CO21D3(K,5)
10096 C2D38(K) = CO21D3(K,6)
10097 ENDDO
10098 !
10099 DO K=1,LP1
10100 CDT71(K) = CO21D7(K,1)
10101 CO271(K) = CO21D7(K,2)
10102 C2D71(K) = CO21D7(K,3)
10103 CDT78(K) = CO21D7(K,4)
10104 CO278(K) = CO21D7(K,5)
10105 C2D78(K) = CO21D7(K,6)
10106 ENDDO
10107 !
10108 !----------------------------------------------------------------------
10109 IF(wrf_dm_on_monitor())WRITE(0,66)NUNIT_CO2
10110 66 FORMAT('----READ CO2 TRANSMISSION FUNCTIONS FROM UNIT ',I2)
10111 !----------------------------------------------------------------------
10112 IF( wrf_dm_on_monitor() )THEN
10113 CLOSE(nunit_co2)
10114 ENDIF
10115 RETURN
10116 !
10117 9014 CONTINUE
10118 WRITE(errmess,'(A51,I4)')'module_ra_gfdleta: error reading co2_trans on unit ',nunit_co2
10119 CALL wrf_error_fatal(errmess)
10120 !----------------------------------------------------------------------
10121 END SUBROUTINE CONRAD
10122 !+---+-----------------------------------------------------------------+
10123 ! Replacement routine to compute saturation vapor pressure over
10124 ! water/ice. This is needed here in case we run microphysics other
10125 ! than ETAMPNEW (Ferrier) because it initializes a lookup table to
10126 ! facilitate calculations of FVPS. For speed, we use the polynomial
10127 ! expansion of Flatau & Walko, 1989.
10128 !+---+-----------------------------------------------------------------+
10129 REAL FUNCTION FPVS_new(T)
10131 IMPLICIT NONE
10132 REAL, INTENT(IN):: T
10134 if (T .ge. 273.16) then
10135 FPVS_new = e_sub_l(T)
10136 else
10137 FPVS_new = e_sub_i(T)
10138 endif
10140 END FUNCTION FPVS_new
10141 !
10142 !+---+-----------------------------------------------------------------+
10143 ! THIS FUNCTION CALCULATES THE LIQUID SATURATION PRESSURE AS
10144 ! A FUNCTION OF TEMPERATURE.
10145 !
10146 REAL FUNCTION e_sub_l(T)
10148 IMPLICIT NONE
10149 REAL, INTENT(IN):: T
10150 REAL:: ESL,X
10151 REAL, PARAMETER:: C0= .611583699E03
10152 REAL, PARAMETER:: C1= .444606896E02
10153 REAL, PARAMETER:: C2= .143177157E01
10154 REAL, PARAMETER:: C3= .264224321E-1
10155 REAL, PARAMETER:: C4= .299291081E-3
10156 REAL, PARAMETER:: C5= .203154182E-5
10157 REAL, PARAMETER:: C6= .702620698E-8
10158 REAL, PARAMETER:: C7= .379534310E-11
10159 REAL, PARAMETER:: C8=-.321582393E-13
10161 X=AMAX1(-80.,T-273.16)
10163 ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
10165 e_sub_l = ESL
10167 END FUNCTION e_sub_l
10168 !
10169 !+---+-----------------------------------------------------------------+
10170 ! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR PRESSURE AS A
10171 ! FUNCTION OF TEMPERATURE.
10172 !
10173 REAL FUNCTION e_sub_i(T)
10175 IMPLICIT NONE
10176 REAL, INTENT(IN):: T
10177 REAL:: ESI,X
10178 REAL, PARAMETER:: C0= .609868993E03
10179 REAL, PARAMETER:: C1= .499320233E02
10180 REAL, PARAMETER:: C2= .184672631E01
10181 REAL, PARAMETER:: C3= .402737184E-1
10182 REAL, PARAMETER:: C4= .565392987E-3
10183 REAL, PARAMETER:: C5= .521693933E-5
10184 REAL, PARAMETER:: C6= .307839583E-7
10185 REAL, PARAMETER:: C7= .105785160E-9
10186 REAL, PARAMETER:: C8= .161444444E-12
10188 X=AMAX1(-80.,T-273.16)
10189 ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
10191 e_sub_i = ESI
10193 END FUNCTION e_sub_i
10195 !
10197 !----------------------------------------------------------------------
10198 !
10199 END MODULE module_RA_GFDLETA
10200 !
10201 !----------------------------------------------------------------------