C SUBROUTINE SPA88 COMPUTES EXACT CTS HEATING RATES AND FLUXES AND
C CORRESPONDING CTS EMISSIVITY QUANTITIES FOR H2O,CO2 AND O3.
C INPUTS: (COMMON BLOCKS)
C ACOMB,BCOMB,APCM,BPCM BDCOMB
C ATPCM,BTPCM,BETACM BDCOMB
C BETINW BDWIDE
C TEMP,PRESS RADISW
C VAR1,VAR2,P,DELP,DELP2 KDACOM
C TOTVO2,TO3SP,TO3SPC TFCOM
C CO2SP1,CO2SP2,CO2SP TFCOM
C CLDFAC CLDCOM
C SKO2D TABCOM
C SORC,CSOUR SRCCOM
C OUTPUTS:
C EXCTS,CTSO3 TFCOM
C GXCTS RDFLUX
C CALLED BY:
C FST88
C CALLS:
C
SUBROUTINE SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR,
1 CLDFAC,TEMP,PRESS,VAR1,VAR2,
2 P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC,
3 CO2SP1,CO2SP2,CO2SP)
C
COMMON/PHYCON/AMOLWT,CSUBP,DIFFCTR,G,GRAVDR,O3DIFCTR,P0,
* P0XZP2,P0XZP8,P0X2,RADCON,RGAS,RGASSP,SECPDA
COMMON/PHYCON/RATCO2MW,RATH2OMW
COMMON/PHYCON/RADCON1
COMMON/PHYCON/GINV,P0INV,GP0INV
save /PHYCON/
COMMON/HCON/HUNDRED,HNINETY,SIXTY,FIFTY,TEN,EIGHT,FIVE,
* FOUR,THREE,TWO,ONE,HAF,QUARTR,ZERO
COMMON/HCON/H83E26,H71E26,H1E15,H1E13,H1E11,H1E8,H4E5,
* H165E5,H5725E4,H488E4,H1E4,H24E3,H20788E3,
* H2075E3,H1224E3,H5E2,H3082E2,H3E2,H2945E2,
* H23E2,H15E2,H35E1,H3P6,H181E1,H18E1,H2P9,H2P8,
* H2P5,H1P8,H1P4387,H1P4,H1P25892,HP8,HP518,
* HP369,HP1
COMMON/HCON/H44871M2,H559M3,H1M3,H987M4,H285M4,H1M4,
* H6938M5,H394M5,H37412M5,H1439M5,H128M5,H1M5,
* H7M6,H4999M6,H25452M6,H1M6,H391M7,H1174M7,
* H8725M8,H327M8,H257M8,H1M8,H23M10,H14M10,
* H11M10,H1M10,H83M11,H82M11,H8M11,H77M11,
* H72M11,H53M11,H48M11,H44M11,H42M11,H37M11,
* H35M11,H32M11,H3M11,H28M11,H24M11,H23M11,
* H2M11,H18M11,H15M11,H14M11,H114M11,H11M11,
* H1M11,H96M12,H93M12,H77M12,H74M12,H65M12,
* H62M12,H6M12,H45M12,H44M12,H4M12,H38M12,
* H37M12,H3M12,H29M12,H28M12,H24M12,H21M12,
* H16M12,H14M12,H12M12,H8M13,H46M13,H36M13,
* H135M13,H12M13,H1M13,H3M14,H15M14,H14M14,
* H1M17,H1M18,H1M19,H1M20,H1M21,H1M22,H1M23,
* H1M24,H26M30,H14M30,H25M31,H21M31,H12M31,
* H9M32,H55M32,H45M32,H4M33,H62M34,H1M60
COMMON/HCON/HMP575,HM13EZ,HM19EZ,HM1E1,HM181E1,HM1E2
COMMON/HCON/H1E6,H2E6,H1M2,HMP66667,HM6666M2,HP166666,
* H41666M2,HMP5,HM2M2,H29316E2,H1226E1,H3116E1,
* H9P94,HP6,H625M2,HP228,HP60241,HM1797E1,
* H8121E1,H2E2,HM1EZ,H26E2,H44194M2,H1P41819
COMMON/HCON/HP219,HP144,HP816,H69766E5,H235M3,HP26,
* H129M2,H75826M4,H1P082,HP805,H1386E2,
* H658M2,H1036E2,H2118M2,H42M2,H323M4,
* H67390E2,HP3795,HP5048,H102M5,H451M6
COMMON/HCON/H16E1,HM161E1,H161E1,H3M3,H101M16,
* HM1597E1,H25E2,HP118666,H15M5,H3P5,H18E3,
* H6P08108,HMP805,HP602409,HP526315,
* H28571M2,H1M16
COMMON/HCON/H3M4
COMMON/HCON/HM8E1
COMMON/HCON/H28E1
save /HCON/
C-----------------------------------------------------------------------
INCLUDE "parmeta"
INCLUDE "mpp.h"
#include "sp.h"
C-----------------------------------------------------------------------
C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE:
C IMAX = NO. POINTS ALONG THE LAT. CIRCLE USED IN CALCS.
C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL
C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS
C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE
C BANDTA FOR DEFINITION
C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS
C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE
C BDCOMB FOR DEFINITION
C INLTE = NO. LEVELS USED FOR NLTE CALCS.
C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS.
C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED
C FROM THE ABOVE PARAMETERS.
PARAMETER (L=LM)
PARAMETER (IMAX=IM,NCOL=IMAX)
PARAMETER (NBLW=163,NBLX=47,NBLY=15)
PARAMETER (NBLM=NBLY-1)
PARAMETER (LP1=L+1,LP2=L+2,LP3=L+3)
PARAMETER (LM1=L-1,LM2=L-2,LM3=L-3)
PARAMETER (LL=2*L,LLP1=LL+1,LLP2=LL+2,LLP3=LL+3)
PARAMETER (LLM1=LL-1,LLM2=LL-2,LLM3=LL-3)
PARAMETER (LP1M=LP1*LP1,LP1M1=LP1M-1)
PARAMETER (LP1V=LP1*(1+2*L/2))
PARAMETER (LP121=LP1*NBLY)
PARAMETER (LL3P=3*L+2)
PARAMETER (NB=12)
PARAMETER (INLTE=3,INLTEP=INLTE+1,NNLTE=56)
PARAMETER (LP1I=IMAX*LP1,LLP1I=IMAX*LLP1,LL3PI=IMAX*LL3P)
PARAMETER (NB1=NB-1)
PARAMETER (KO2=12)
PARAMETER (KO21=KO2+1,KO2M=KO2-1)
C PARAMETER SETTINGS FOR THE LONGWAVE AND SHORTWAVE RADIATION CODE:
C IMAX = NO. POINTS SENT TO RADFS
C L = NO. VERTICAL LEVELS (ALSO LAYERS) IN MODEL
C***NOTE: THE USER NORMALLY WILL MODIFY ONLY THE IMAX AND L PARAMETERS
C NBLW = NO. FREQ. BANDS FOR APPROX COMPUTATIONS. SEE
C BANDTA FOR DEFINITION
C NBLX = NO. FREQ BANDS FOR APPROX CTS COMPUTATIONS
C NBLY = NO. FREQ. BANDS FOR EXACT CTS COMPUTATIONS. SEE
C BDCOMB FOR DEFINITION
C INLTE = NO. LEVELS USED FOR NLTE CALCS.
C NNLTE = INDEX NO. OF FREQ. BAND IN NLTE CALCS.
C NB,KO2 ARE SHORTWAVE PARAMETERS; OTHER QUANTITIES ARE DERIVED
C FROM THE ABOVE PARAMETERS.
C COMMON BLOCK BANDTA CONTAINS RANDOM BAND PARAMETERS FOR THE LW
C CALCULATIONS USING 10 CM-1 WIDE BANDS.THE 15 UM CO2 COMPLEX
C IS 2 BANDS,560-670 AND 670-800 CM-1. OZONE COEFFICIENTS ARE
C IN 3 BANDS,670-800 (14.1 UM),990-1070 AND 1070-1200 (9.6 UM).
C THE (NBLW) BANDS NOW INCLUDE:
C 56 BANDS, 10 CM-1 WIDE 0 - 560 CM-1
C 2 BANDS, 15 UM COMPLEX 560 - 670 CM-1
C 670 - 800 CM-1
C 3 "CONTINUUM" BANDS 800 - 900 CM-1
C 900 - 990 CM-1
C 1070 - 1200 CM-1
C 1 BAND FOR 9.6 UM BAND 990 - 1070 CM-1
C 100 BANDS, 10 CM-1 WIDE 1200 - 2200 CM-1
C 1 BAND FOR 4.3 UM SRC 2270 - 2380 CM-1
C THUS NBLW PRESENTLY EQUALS 163
C ALL BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER
C
C ARNDM = RANDOM "A" PARAMETER FOR (NBLW) BANDS
C BRNDM = RANDOM "B" PARAMETER FOR (NBLW) BANDS
C BETAD = CONTINUUM COEFFICIENTS FOR (NBLW) BANDS
C AP,BP = CAPPHI COEFFICIENTS FOR (NBLW) BANDS
C ATP,BTP = CAPPSI COEFFICIENTS FOR (NBLW) BANDS
C BANDLO = LOWEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS
C BANDHI = HIGHEST FREQUENCY IN EACH OF (NBLW) FREQ. BANDS
C AO3RND = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE
C BANDS
C BO3RND = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE
C BANDS
C AB15 = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS
C REPRESENTING THE 15 UM BAND COMPLEX OF CO2
C DATA FOR ARNDM,BRNDM,AP,BP,ATP,BTP,AO3RND,BO3RND ARE OBTAINED BY
C USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS ARE FROM
C ROBERTS (1976).
COMMON / BANDTA / ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW),AP(NBLW),
1 BP(NBLW),ATP(NBLW),BTP(NBLW),BANDLO(NBLW),
2 BANDHI(NBLW),AO3RND(3),BO3RND(3),AB15(2)
C
C COMMON BLOCK BDWIDE CONTAINS RANDOM BAND PARAMETERS FOR SPECIFIC
C WIDE BANDS. AT PRESENT,THE INFORMATION CONSISTS OF 1) RANDOM
C MODEL PARAMETERS FOR THE 15 UM BAND,560-800 CM-1; 2) THE
C CONTINUUM COEFFICIENT FOR THE 800-990,1070-1200 CM-1 BAND
C SPECIFICALLY:
C AWIDE = RANDOM "A" PARAMETER FOR BAND
C BWIDE = RANDOM "B" PARAMETER FOR BAND
C BETAWD = CONTINUUM COEFFICIENTS FOR BAND
C APWD,BPWD = CAPPHI COEFFICIENTS FOR BAND
C ATPWD,BTPWD = CAPPSI COEFFICIENTS FOR BAND
C BDLOWD = LOWEST FREQUENCY IN EACH FREQ BAND
C BDHIWD = HIGHEST FREQUENCY IN EACH FREQ BAND
C AB15WD = THE PRODUCT ARNDM*BRNDM FOR THE ONE BAND
C REPRESENTING THE 15 UM BAND COMPLEX OF CO2
C BETINW = CONT.COEFFICIENT FOR A SPECIFIED WIDE
C FREQ.BAND (800-990 AND 1070-1200 CM-1).
C SKO2D = 1./BETINW, USED IN SPA88 FOR CONT. COEFFS
C SKC1R = BETAWD/BETINW, USED FOR CONT. COEFF. FOR
C 15 UM BAND IN FST88
C SKO3R = RATIO OF CONT. COEFF. FOR 9.9 UM BAND TO
C BETINW, USED FOR 9.6 UM CONT COEFF IN FST88
C DATA FOR AWIDE,BWIDE,APWD,BPWD,ATPWD,BTPWD,AO3WD,BO3WD ARE
C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS
C ARE FROM ROBERTS (1976).
COMMON / BDWIDE / AWIDE,BWIDE,BETAWD,
1 APWD,BPWD,ATPWD,BTPWD,
2 BDLOWD,BDHIWD,BETINW,
3 AB15WD,SKO2D,SKC1R,SKO3R
C
C COMMON BLOCK BDCOMB CONTAINS RANDOM BAND PARAMETERS FOR THE LW
C CALCULATIONS USING COMBINED WIDE FREQUENCY BANDS BETWEEN 160 AND
C 1200 CM-1,AS WELL AS THE 2270-2380 BAND FOR SOURCE CALC.
C BANDS 1-8: COMBINED WIDE FREQUENCY BANDS FOR 160-560 CM-1
C BANDS 9-14: FREQUENCY BANDS,AS IN BANDTA (NARROW BANDS)
C FOR 560-1200 CM-1
C BAND 15: FREQUENCY BAND 2270-2380 CM-1,USED FOR SOURCE
C CALCULATION ONLY
C THUS NBLY PRESENTLY EQUALS 15
C
C BANDS ARE ARRANGED IN ORDER OF INCREASING WAVENUMBER
C ACOMB = RANDOM "A" PARAMETER FOR (NBLY) BANDS
C BCOMB = RANDOM "B" PARAMETER FOR (NBLY) BANDS
C BETACM = CONTINUUM COEFFICIENTS FOR (NBLY) BANDS
C APCM,BPCM = CAPPHI COEFFICIENTS FOR (NBLY) BANDS
C ATPCM,BTPCM = CAPPSI COEFFICIENTS FOR (NBLY) BANDS
C BDLOCM = LOWEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS
C BDHICM = HIGHEST FREQUENCY IN EACH OF (NBLY) FREQ. BANDS
C AO3CM = RANDOM "A" PARAMETER FOR OZONE IN (3) OZONE
C BANDS
C BO3CM = RANDOM "B" PARAMETER FOR OZONE IN (3) OZONE
C BANDS
C AB15CM = THE PRODUCT ARNDM*BRNDM FOR THE TWO BANDS
C REPRESENTING THE 15 UM BAND COMPLEX OF CO2
C BETINC = CONT.COEFFICIENT FOR A SPECIFIED WIDE
C FREQ.BAND (800-990 AND 1070-1200 CM-1).
C IBAND = INDEX NO OF THE 40 WIDE BANDS USED IN
C COMBINED WIDE BAND CALCULATIONS. IN OTHER
C WORDS,INDEX TELLING WHICH OF THE 40 WIDE
C BANDS BETWEEN 160-560 CM-1 ARE INCLUDED IN
C EACH OF THE FIRST 8 COMBINED WIDE BANDS
C DATA FOR ACOMB,BCOMB,APCM,BPCM,ATPCM,BTPCM,AO3CM,BO3CM ARE
C OBTAINED BY USING THE AFGL 1982 CATALOG. CONTINUUM COEFFICIENTS
C ARE FROM ROBERTS (1976). IBAND INDEX VALUES ARE OBTAINED BY
C EXPERIMENTATION.
COMMON / BDCOMB / IBAND(40),ACOMB(NBLY),BCOMB(NBLY),
1 BETACM(NBLY),APCM(NBLY),BPCM(NBLY),ATPCM(NBLY),
2 BTPCM(NBLY),BDLOCM(NBLY),BDHICM(NBLY),BETINC,
3 AO3CM(3),BO3CM(3),AB15CM(2)
C
DIMENSION SORC(IDIM1:IDIM2,LP1,NBLY),CSOUR(IDIM1:IDIM2,LP1)
DIMENSION CLDFAC(IDIM1:IDIM2,LP1,LP1)
DIMENSION TEMP(IDIM1:IDIM2,LP1),PRESS(IDIM1:IDIM2,LP1)
DIMENSION VAR1(IDIM1:IDIM2,L),VAR2(IDIM1:IDIM2,L)
DIMENSION P(IDIM1:IDIM2,LP1),DELP(IDIM1:IDIM2,L),
1 DELP2(IDIM1:IDIM2,L)
DIMENSION TOTVO2(IDIM1:IDIM2,LP1),TO3SPC(IDIM1:IDIM2,L),
1 TO3SP(IDIM1:IDIM2,LP1)
DIMENSION CO2SP1(IDIM1:IDIM2,LP1),CO2SP2(IDIM1:IDIM2,LP1),
1 CO2SP(IDIM1:IDIM2,LP1)
DIMENSION EXCTS(IDIM1:IDIM2,L),CTSO3(IDIM1:IDIM2,L),
1 GXCTS(IDIM1:IDIM2)
C
DIMENSION PHITMP(IDIM1:IDIM2,L),PSITMP(IDIM1:IDIM2,L),
1 TT(IDIM1:IDIM2,L),
2 FAC1(IDIM1:IDIM2,L),FAC2(IDIM1:IDIM2,L),
3 CTMP(IDIM1:IDIM2,LP1),X(IDIM1:IDIM2,L),
4 Y(IDIM1:IDIM2,L),
5 TOPM(IDIM1:IDIM2,L),TOPPHI(IDIM1:IDIM2,L),
6 CTMP3(IDIM1:IDIM2,LP1),CTMP2(IDIM1:IDIM2,LP1)
DIMENSION F(IDIM1:IDIM2,L),FF(IDIM1:IDIM2,L),
1 AG(IDIM1:IDIM2,L),AGG(IDIM1:IDIM2,L)
C
EQUIVALENCE (F,AG,PHITMP)
EQUIVALENCE (FF,AGG,PSITMP)
C---COMPUTE TEMPERATURE QUANTITIES FOR USE IN PROGRAM
DO 101 K=1,L
DO 101 I=MYIS,MYIE
X(I,K)=TEMP(I,K)-H25E2
Y(I,K)=X(I,K)*X(I,K)
101 CONTINUE
C---INITIALIZE CTMP(I,1),CTMP2(I,1),CTMP3(I,1) TO UNITY; THESE ARE
C TRANSMISSION FCTNS AT THE TOP.
DO 345 I=MYIS,MYIE
CTMP(I,1)=ONE
CTMP2(I,1)=1.
CTMP3(I,1)=1.
345 CONTINUE
C***BEGIN LOOP ON FREQUENCY BANDS (1)***
C
C---CALCULATION FOR BAND 1 (COMBINED BAND 1)
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 301 K=1,L
DO 301 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(1)*X(I,K)+BPCM(1)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(1)*X(I,K)+BTPCM(1)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
301 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 315 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
315 CONTINUE
DO 319 K=2,L
DO 317 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
317 CONTINUE
319 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 321 K=1,L
DO 321 I=MYIS,MYIE
FAC1(I,K)=ACOMB(1)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(1)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
321 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 353 K=1,L
DO 353 I=MYIS,MYIE
EXCTS(I,K)=SORC(I,K,1)*(CTMP(I,K+1)-CTMP(I,K))
353 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 361 I=MYIS,MYIE
GXCTS(I)=CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,1)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,1)-SORC(I,L,1)))
361 CONTINUE
C
C
C-----CALCULATION FOR BAND 2 (COMBINED BAND 2)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 401 K=1,L
DO 401 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(2)*X(I,K)+BPCM(2)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(2)*X(I,K)+BTPCM(2)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
401 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 415 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
415 CONTINUE
DO 419 K=2,L
DO 417 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
417 CONTINUE
419 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 421 K=1,L
DO 421 I=MYIS,MYIE
FAC1(I,K)=ACOMB(2)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(2)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
421 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 453 K=1,L
DO 453 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,2)*
1 (CTMP(I,K+1)-CTMP(I,K))
453 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 461 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,2)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,2)-SORC(I,L,2)))
461 CONTINUE
C
C-----CALCULATION FOR BAND 3 (COMBINED BAND 3)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 501 K=1,L
DO 501 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(3)*X(I,K)+BPCM(3)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(3)*X(I,K)+BTPCM(3)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
501 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 515 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
515 CONTINUE
DO 519 K=2,L
DO 517 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
517 CONTINUE
519 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 521 K=1,L
DO 521 I=MYIS,MYIE
FAC1(I,K)=ACOMB(3)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(3)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
521 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 553 K=1,L
DO 553 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,3)*
1 (CTMP(I,K+1)-CTMP(I,K))
553 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 561 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,3)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,3)-SORC(I,L,3)))
561 CONTINUE
C
C-----CALCULATION FOR BAND 4 (COMBINED BAND 4)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 601 K=1,L
DO 601 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(4)*X(I,K)+BPCM(4)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(4)*X(I,K)+BTPCM(4)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
601 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 615 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
615 CONTINUE
DO 619 K=2,L
DO 617 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
617 CONTINUE
619 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 621 K=1,L
DO 621 I=MYIS,MYIE
FAC1(I,K)=ACOMB(4)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(4)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
621 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 653 K=1,L
DO 653 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,4)*
1 (CTMP(I,K+1)-CTMP(I,K))
653 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 661 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,4)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,4)-SORC(I,L,4)))
661 CONTINUE
C
C-----CALCULATION FOR BAND 5 (COMBINED BAND 5)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 701 K=1,L
DO 701 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(5)*X(I,K)+BPCM(5)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(5)*X(I,K)+BTPCM(5)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
701 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 715 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
715 CONTINUE
DO 719 K=2,L
DO 717 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
717 CONTINUE
719 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 721 K=1,L
DO 721 I=MYIS,MYIE
FAC1(I,K)=ACOMB(5)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(5)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+
1 BETACM(5)*TOTVO2(I,K+1)*SKO2D))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
721 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 753 K=1,L
DO 753 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,5)*
1 (CTMP(I,K+1)-CTMP(I,K))
753 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 761 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,5)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,5)-SORC(I,L,5)))
761 CONTINUE
C
C-----CALCULATION FOR BAND 6 (COMBINED BAND 6)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 801 K=1,L
DO 801 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(6)*X(I,K)+BPCM(6)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(6)*X(I,K)+BTPCM(6)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
801 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 815 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
815 CONTINUE
DO 819 K=2,L
DO 817 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
817 CONTINUE
819 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 821 K=1,L
DO 821 I=MYIS,MYIE
FAC1(I,K)=ACOMB(6)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(6)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+
1 BETACM(6)*TOTVO2(I,K+1)*SKO2D))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
821 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 853 K=1,L
DO 853 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,6)*
1 (CTMP(I,K+1)-CTMP(I,K))
853 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 861 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,6)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,6)-SORC(I,L,6)))
861 CONTINUE
C
C-----CALCULATION FOR BAND 7 (COMBINED BAND 7)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 901 K=1,L
DO 901 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(7)*X(I,K)+BPCM(7)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(7)*X(I,K)+BTPCM(7)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
901 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 915 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
915 CONTINUE
DO 919 K=2,L
DO 917 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
917 CONTINUE
919 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 921 K=1,L
DO 921 I=MYIS,MYIE
FAC1(I,K)=ACOMB(7)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(7)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+
1 BETACM(7)*TOTVO2(I,K+1)*SKO2D))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
921 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 953 K=1,L
DO 953 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,k,7)*
1 (CTMP(I,K+1)-CTMP(I,K))
953 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 961 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,7)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,7)-SORC(I,L,7)))
961 CONTINUE
C
C-----CALCULATION FOR BAND 8 (COMBINED BAND 8)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 1001 K=1,L
DO 1001 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(8)*X(I,K)+BPCM(8)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(8)*X(I,K)+BTPCM(8)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1001 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 1015 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
1015 CONTINUE
DO 1019 K=2,L
DO 1017 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1017 CONTINUE
1019 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 1021 K=1,L
DO 1021 I=MYIS,MYIE
FAC1(I,K)=ACOMB(8)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(8)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+
1 BETACM(8)*TOTVO2(I,K+1)*SKO2D))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1021 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 1053 K=1,L
DO 1053 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,8)*
1 (CTMP(I,K+1)-CTMP(I,K))
1053 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 1061 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,8)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,8)-SORC(I,L,8)))
1061 CONTINUE
C
C-----CALCULATION FOR BAND 9 ( 560-670 CM-1; INCLUDES CO2)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 1101 K=1,L
DO 1101 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(9)*X(I,K)+BPCM(9)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(9)*X(I,K)+BTPCM(9)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1101 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 1115 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
1115 CONTINUE
DO 1119 K=2,L
DO 1117 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1117 CONTINUE
1119 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 1121 K=1,L
DO 1121 I=MYIS,MYIE
FAC1(I,K)=ACOMB(9)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(9)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+
1 BETACM(9)*TOTVO2(I,K+1)*SKO2D))*CO2SP1(I,K+1)
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1121 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 1153 K=1,L
DO 1153 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,9)*
1 (CTMP(I,K+1)-CTMP(I,K))
1153 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 1161 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,9)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,9)-SORC(I,L,9)))
1161 CONTINUE
C
C-----CALCULATION FOR BAND 10 (670-800 CM-1; INCLUDES CO2)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 1201 K=1,L
DO 1201 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(10)*X(I,K)+BPCM(10)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(10)*X(I,K)+BTPCM(10)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1201 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 1215 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
1215 CONTINUE
DO 1219 K=2,L
DO 1217 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1217 CONTINUE
1219 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 1221 K=1,L
DO 1221 I=MYIS,MYIE
FAC1(I,K)=ACOMB(10)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(10)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+
1 BETACM(10)*TOTVO2(I,K+1)*SKO2D))*CO2SP2(I,K+1)
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1221 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 1253 K=1,L
DO 1253 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,10)*
1 (CTMP(I,K+1)-CTMP(I,K))
1253 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 1261 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,10)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,10)-SORC(I,L,10)))
1261 CONTINUE
C
C-----CALCULATION FOR BAND 11 (800-900 CM-1)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 1301 K=1,L
DO 1301 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(11)*X(I,K)+BPCM(11)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(11)*X(I,K)+BTPCM(11)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1301 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 1315 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
1315 CONTINUE
DO 1319 K=2,L
DO 1317 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1317 CONTINUE
1319 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 1321 K=1,L
DO 1321 I=MYIS,MYIE
FAC1(I,K)=ACOMB(11)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(11)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+
1 BETACM(11)*TOTVO2(I,K+1)*SKO2D))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1321 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 1353 K=1,L
DO 1353 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,11)*
1 (CTMP(I,K+1)-CTMP(I,K))
1353 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 1361 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,11)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,11)-SORC(I,L,11)))
1361 CONTINUE
C
C-----CALCULATION FOR BAND 12 (900-990 CM-1)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 1401 K=1,L
DO 1401 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(12)*X(I,K)+BPCM(12)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(12)*X(I,K)+BTPCM(12)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1401 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 1415 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
1415 CONTINUE
DO 1419 K=2,L
DO 1417 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1417 CONTINUE
1419 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 1421 K=1,L
DO 1421 I=MYIS,MYIE
FAC1(I,K)=ACOMB(12)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(12)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+
1 BETACM(12)*TOTVO2(I,K+1)*SKO2D))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1421 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 1453 K=1,L
DO 1453 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,12)*
1 (CTMP(I,K+1)-CTMP(I,K))
1453 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 1461 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,12)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,12)-SORC(I,L,12)))
1461 CONTINUE
C
C-----CALCULATION FOR BAND 13 (990-1070 CM-1; INCLUDES O3))
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 1501 K=1,L
DO 1501 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(13)*X(I,K)+BPCM(13)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(13)*X(I,K)+BTPCM(13)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1501 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 1515 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
1515 CONTINUE
DO 1519 K=2,L
DO 1517 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1517 CONTINUE
1519 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 1521 K=1,L
DO 1521 I=MYIS,MYIE
FAC1(I,K)=ACOMB(13)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(13)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+
1 BETACM(13)*TOTVO2(I,K+1)*SKO2D+TO3SPC(I,K)))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1521 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 1553 K=1,L
DO 1553 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,13)*
1 (CTMP(I,K+1)-CTMP(I,K))
1553 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 1561 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,13)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,13)-SORC(I,L,13)))
1561 CONTINUE
C
C-----CALCULATION FOR BAND 14 (1070-1200 CM-1)
C
C
C---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
C BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
C OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
DO 1601 K=1,L
DO 1601 I=MYIS,MYIE
F(I,K)=H44194M2*(APCM(14)*X(I,K)+BPCM(14)*Y(I,K))
FF(I,K)=H44194M2*(ATPCM(14)*X(I,K)+BTPCM(14)*Y(I,K))
AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
1601 CONTINUE
C---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
C P(K) (TOPM,TOPPHI)
DO 1615 I=MYIS,MYIE
TOPM(I,1)=PHITMP(I,1)
TOPPHI(I,1)=PSITMP(I,1)
1615 CONTINUE
DO 1619 K=2,L
DO 1617 I=MYIS,MYIE
TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
1617 CONTINUE
1619 CONTINUE
C---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
DO 1621 K=1,L
DO 1621 I=MYIS,MYIE
FAC1(I,K)=ACOMB(14)*TOPM(I,K)
FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(14)*TOPPHI(I,K))
TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+
1 BETACM(14)*TOTVO2(I,K+1)*SKO2D))
CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
1621 CONTINUE
C---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
DO 1653 K=1,L
DO 1653 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,14)*
1 (CTMP(I,K+1)-CTMP(I,K))
1653 CONTINUE
C---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
DO 1661 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,14)+
1 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) +
2 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) *
3 (SORC(I,LP1,14)-SORC(I,L,14)))
1661 CONTINUE
C
C
C OBTAIN CTS FLUX AT THE TOP BY INTEGRATION OF HEATING RATES AND
C USING CTS FLUX AT THE BOTTOM (CURRENT VALUE OF GXCTS). NOTE
C THAT THE PRESSURE QUANTITIES AND CONVERSION FACTORS HAVE NOT
C BEEN INCLUDED EITHER IN EXCTS OR IN GXCTS. THESE CANCEL OUT, THUS
C REDUCING COMPUTATIONS!
DO 1731 K=1,L
DO 1731 I=MYIS,MYIE
GXCTS(I)=GXCTS(I)-EXCTS(I,K)
1731 CONTINUE
C
C NOW SCALE THE COOLING RATE (EXCTS) BY INCLUDING THE PRESSURE
C FACTOR (DELP) AND THE CONVERSION FACTOR (RADCON)
DO 1741 K=1,L
DO 1741 I=MYIS,MYIE
EXCTS(I,K)=EXCTS(I,K)*RADCON*DELP(I,K)
1741 CONTINUE
C---THIS IS THE END OF THE EXACT CTS COMPUTATIONS; AT THIS POINT
C EXCTS HAS ITS APPROPRIATE VALUE.
C
C*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS
C (CTSO3)
DO 1711 K=1,L
DO 1711 I=MYIS,MYIE
CTMP2(I,K+1)=CO2SP(I,K+1)*CLDFAC(I,K+1,1)
CTMP3(I,K+1)=TO3SP(I,K)*CLDFAC(I,K+1,1)
1711 CONTINUE
DO 1701 K=1,L
DO 1701 I=MYIS,MYIE
CTSO3(I,K)=RADCON*DELP(I,K)*
1 (CSOUR(I,K)*(CTMP2(I,K+1)-CTMP2(I,K)) +
2 SORC(I,K,13)*(CTMP3(I,K+1)-CTMP3(I,K)))
1701 CONTINUE
RETURN
END