SUBROUTINE TABLE #include "sp.h" C SUBROUTINE TABLE COMPUTES TABLE ENTRIES USED IN THE LONGWAVE RADIA C PROGRAM. ALSO CALCULATED ARE INDICES USED IN STRIP-MINING AND FOR C SOME PRE-COMPUTABLE FUNCTIONS. C INPUTS: C OUTPUTS: C EM1,EM1WDE,TABLE1,TABLE2,TABLE3 TABCOM C EM3,SOURCE,DSRCE,IND,INDX2,KMAXV TABCOM C KMAXVM, TABCOM C AO3RND,BO3RND,AB15 BANDTA C AB15WD,SKC1R,SKO3R,SKO2D BDWIDE 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 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 C----------------------------------------------------------------------- INCLUDE "parmeta" INCLUDE "mpp.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 C COMMON BLOCK TABCOM CONTAINS QUANTITIES PRECOMPUTED IN SUBROUTINE C TABLE FOR USE IN THE LONGWAVE RADIATION PROGRAM: C EM1 = E1 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C EM1WDE = E1 FUNCTION, EVALUATED OVER THE 160-560 CM-1 C INTERVAL C TABLE1 = E2 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C TABLE2 = TEMPERATURE DERIVATIVE OF TABLE1 C TABLE3 = MASS DERIVATIVE OF TABLE1 C EM3 = E3 FUNCTION, EVALUATED OVER THE 0-560 AND C 1200-2200 CM-1 INTERVALS C SOURCE = PLANCK FUNCTION, EVALUATED AT SPECIFIED TEMPS. FOR C BANDS USED IN CTS CALCULATIONS C DSRCE = TEMPERATURE DERIVATIVE OF SOURCE C IND = INDEX, WITH VALUE IND(I)=I. USED IN FST88 C INDX2 = INDEX VALUES USED IN OBTAINING "LOWER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXV = INDEX VALUES USED IN OBTAINING "UPPER TRIANGLE" C ELEMENTS OF AVEPHI,ETC.,IN FST88 C KMAXVM = KMAXV(L),USED FOR DO LOOP INDICES C COMMON / TABCOM / IND(IMAX),INDX2(LP1V),KMAXV(LP1), 1 KMAXVM COMMON/TABCOM/EM1(28,180),EM1WDE(28,180),TABLE1(28,180), 1 TABLE2(28,180),TABLE3(28,180),EM3(28,180),SOURCE(28,NBLY), 2 DSRCE(28,NBLY) C C% #NPADL = #PAGE*#NPAGE - 4*28*180 - 2*181 - 7*28 - 180 ; C% #NPADL = #NPADL - 11*28 - 2*180 - 2*30 ; C PARAMETER (NPADL = #NPADL - 28*NBLX - 2*28*NBLW - 7*NBLW) COMMON /SCRTCH/ SUM(28,180),PERTSM(28,180),SUM3(28,180), 1 SUMWDE(28,180),SRCWD(28,NBLX),SRC1NB(28,NBLW),DBDTNB(28,NBLW) COMMON /SCRTCH/ ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28), 1 TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28), 2 SUM4(28),SUM6(28),SUM7(28),SUM8(28),SUM4WD(28), 3 R1(28),R2(28),S2(28),T3(28),R1WD(28) COMMON /SCRTCH/ EXPO(180),FAC(180) COMMON/SCRTCH/CNUSB(30),DNUSB(30) COMMON/SCRTCH/ALFANB(NBLW),AROTNB(NBLW) COMMON/SCRTCH/ANB(NBLW),BNB(NBLW),CENTNB(NBLW),DELNB(NBLW), 1 BETANB(NBLW) C COMMON/SCRTCH/PADLOC(NPADL) COMMON/TBLTMP/ DELCM(NBLY) C**************************************** C***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15 C....FOR NARROW-BANDS... DO 101 N=1,NBLW ANB(N)=ARNDM(N) BNB(N)=BRNDM(N) CENTNB(N)=HAF*(BANDLO(N)+BANDHI(N)) DELNB(N)=BANDHI(N)-BANDLO(N) BETANB(N)=BETAD(N) 101 CONTINUE AB15(1)=ANB(57)*BNB(57) AB15(2)=ANB(58)*BNB(58) C....FOR WIDE BANDS... AB15WD=AWIDE*BWIDE C C***COMPUTE INDICES: IND,INDX2,KMAXV DO 111 I=1,IMAX IND(I)=I 111 CONTINUE ICNT=0 DO 113 I1=1,L I2E=LP1-I1 DO 115 I2=1,I2E ICNT=ICNT+1 INDX2(ICNT)=LP1*(I2-1)+LP2*I1 115 CONTINUE 113 CONTINUE KMAXV(1)=1 DO 117 I=2,L KMAXV(I)=KMAXV(I-1)+(LP2-I) 117 CONTINUE KMAXVM=KMAXV(L) C***COMPUTE RATIOS OF CONT. COEFFS SKC1R=BETAWD/BETINW SKO3R=BETAD(61)/BETINW SKO2D=ONE/BETINW C C****BEGIN TABLE COMPUTATIONS HERE*** C***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES C---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS C WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM C 100K TO 370K. C---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF C 180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS C ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS. ZMASS(1)=H1M16 DO 201 J=1,180 JP=J+1 ZROOT(J)=SQRT(ZMASS(J)) ZMASS(JP)=ZMASS(J)*H1P25892 201 CONTINUE DO 203 I=1,28 XTEMV(I)=HNINETY+TEN*I TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I) FORTCU(I)=FOUR*XTEMV(I)*XTEMV(I)*XTEMV(I) 203 CONTINUE C******THE COMPUTATION OF SOURCE,DSRCE IS NEEDED ONLY C FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE C MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD) C THEN COMBINED (USING IBAND) INTO SOURCE. DO 205 N=1,NBLY DO 205 I=1,28 SOURCE(I,N)=ZERO 205 CONTINUE DO 207 N=1,NBLX DO 207 I=1,28 SRCWD(I,N)=ZERO 207 CONTINUE C---BEGIN FREQ. LOOP (ON N) DO 211 N=1,NBLX IF (N.LE.46) THEN C***THE 160-1200 BAND CASES CENT=CENTNB(N+16) DEL=DELNB(N+16) BDLO=BANDLO(N+16) BDHI=BANDHI(N+16) ENDIF IF (N.EQ.NBLX) THEN C***THE 2270-2380 BAND CASE CENT=CENTNB(NBLW) DEL=DELNB(NBLW) BDLO=BANDLO(NBLW) BDHI=BANDHI(NBLW) ENDIF C***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE C ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS. NSUBDS=(DEL-H1M3)/10+1 DO 213 NSB=1,NSUBDS IF (NSB.NE.NSUBDS) THEN CNUSB(NSB)=TEN*(NSB-1)+BDLO+FIVE DNUSB(NSB)=TEN ELSE CNUSB(NSB)=HAF*(TEN*(NSB-1)+BDLO+BDHI) DNUSB(NSB)=BDHI-(TEN*(NSB-1)+BDLO) ENDIF C1=(H37412M5)*CNUSB(NSB)**3 C---BEGIN TEMP. LOOP (ON I) DO 215 I=1,28 X(I)=H1P4387*CNUSB(NSB)/XTEMV(I) X1(I)=EXP(X(I)) SRCS(I)=C1/(X1(I)-ONE) SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB) 215 CONTINUE 213 CONTINUE 211 CONTINUE C***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE C AND DSRCE DO 221 N=1,40 DO 221 I=1,28 SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N) 221 CONTINUE DO 223 N=9,NBLY DO 223 I=1,28 SOURCE(I,N)=SRCWD(I,N+32) 223 CONTINUE DO 225 N=1,NBLY DO 225 I=1,27 DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*HP1 225 CONTINUE DO 231 N=1,NBLW ALFANB(N)=BNB(N)*ANB(N) AROTNB(N)=SQRT(ALFANB(N)) 231 CONTINUE C***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR C USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE C BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ. C RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT. C DO 301 N=1,NBLW CENT=CENTNB(N) DEL=DELNB(N) C---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT C IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR C THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY. DO 303 IA=1,3 ANU=CENT+HAF*(IA-2)*DEL C1=(H37412M5)*ANU*ANU*ANU+H1M20 C---TEMPERATURE LOOP--- DO 305 I=1,28 X(I)=H1P4387*ANU/XTEMV(I) X1(I)=EXP(X(I)) SC(I)=C1/((X1(I)-ONE)+H1M20) DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1) 305 CONTINUE IF (IA.EQ.2) THEN DO 307 I=1,28 SRC1NB(I,N)=DEL*SC(I) DBDTNB(I,N)=DEL*DSC(I) 307 CONTINUE ENDIF 303 CONTINUE 301 CONTINUE C***NEXT COMPUTE R1,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION C WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A C DIFFERENT DEPENDENCE ON (ZMASS). C---ALSO OBTAIN R1WD, WHICH IS R1 SUMMED OVER THE 160-560 CM-1 RANGE DO 311 I=1,28 SUM4(I)=ZERO SUM6(I)=ZERO SUM7(I)=ZERO SUM8(I)=ZERO SUM4WD(I)=ZERO 311 CONTINUE DO 313 N=1,NBLW CENT=CENTNB(N) C***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4 C SUM6,SUM7,SUM8 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN DO 315 I=1,28 SUM4(I)=SUM4(I)+SRC1NB(I,N) SUM6(I)=SUM6(I)+DBDTNB(I,N) SUM7(I)=SUM7(I)+DBDTNB(I,N)*AROTNB(N) SUM8(I)=SUM8(I)+DBDTNB(I,N)*ALFANB(N) 315 CONTINUE ENDIF C***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD IF (CENT.GT.160. .AND. CENT.LT.560.) THEN DO 316 I=1,28 SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N) 316 CONTINUE ENDIF 313 CONTINUE DO 317 I=1,28 R1(I)=SUM4(I)/TFOUR(I) R2(I)=SUM6(I)/FORTCU(I) S2(I)=SUM7(I)/FORTCU(I) T3(I)=SUM8(I)/FORTCU(I) R1WD(I)=SUM4WD(I)/TFOUR(I) 317 CONTINUE DO 401 J=1,180 DO 401 I=1,28 SUM(I,J)=ZERO PERTSM(I,J)=ZERO SUM3(I,J)=ZERO SUMWDE(I,J)=ZERO 401 CONTINUE C---FREQUENCY LOOP BEGINS--- DO 411 N=1,NBLW CENT=CENTNB(N) C***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN DO 413 J=1,180 X2(J)=AROTNB(N)*ZROOT(J) EXPO(J)=EXP(-X2(J)) 413 CONTINUE DO 415 J=1,180 IF (X2(J).GE.HUNDRED) THEN EXPO(J)=ZERO ENDIF 415 CONTINUE DO 417 J=121,180 FAC(J)=ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J)) 417 CONTINUE DO 419 J=1,180 DO 419 I=1,28 SUM(I,J)=SUM(I,J)+SRC1NB(I,N)*EXPO(J) PERTSM(I,J)=PERTSM(I,J)+DBDTNB(I,N)*EXPO(J) 419 CONTINUE DO 421 J=121,180 DO 421 I=1,28 SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J) 421 CONTINUE ENDIF C---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE) IF (CENT.GT.160. .AND. CENT.LT.560.) THEN DO 420 J=1,180 DO 420 I=1,28 SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J) 420 CONTINUE ENDIF 411 CONTINUE DO 431 J=1,180 DO 431 I=1,28 EM1(I,J)=SUM(I,J)/TFOUR(I) TABLE1(I,J)=PERTSM(I,J)/FORTCU(I) 431 CONTINUE DO 433 J=121,180 DO 433 I=1,28 EM3(I,J)=SUM3(I,J)/FORTCU(I) 433 CONTINUE DO 441 J=1,179 DO 441 I=1,28 TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*TEN 441 CONTINUE DO 443 J=1,180 DO 443 I=1,27 TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*HP1 443 CONTINUE DO 445 I=1,28 TABLE2(I,180)=ZERO 445 CONTINUE DO 447 J=1,180 TABLE3(28,J)=ZERO 447 CONTINUE DO 449 J=1,2 DO 449 I=1,28 EM1(I,J)=R1(I) 449 CONTINUE DO 451 J=1,120 DO 451 I=1,28 EM3(I,J)=R2(I)/TWO-S2(I)*SQRT(ZMASS(J))/THREE+T3(I)*ZMASS(J)/EIGHT 451 CONTINUE DO 453 J=121,180 DO 453 I=1,28 EM3(I,J)=EM3(I,J)/ZMASS(J) 453 CONTINUE C***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY. C WE USE R1WD AND SUMWDE OBTAINED ABOVE. DO 501 J=1,180 DO 501 I=1,28 EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I) 501 CONTINUE DO 503 J=1,2 DO 503 I=1,28 EM1WDE(I,J)=R1WD(I) 503 CONTINUE RETURN END