C path: /stormrc1/aer_lblrtm/src/SCCS/s.oprop.f
C revision: 5.12
C created: 03/28/00 10:58:04
C presently: 03/28/00 11:05:14
SUBROUTINE HIRAC1 (MPTS) 2,50
C
IMPLICIT REAL*8 (V)
C
C
C**********************************************************************
C*
C*
C* CALCULATES MONOCHROMATIC ABSORPTION COEFFICIENT FOR SINGLE LAYER
C*
C*
C* USES APPROXIMATE VOIGT ALGORITHM
C*
C*
C* VAN VLECK WEISSKOPF LINE SHAPE
C*
C**********************************************************************
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C IMPLEMENTATION: R.D. WORSHAM
C
C ALGORITHM REVISIONS: S.A. CLOUGH
C R.D. WORSHAM
C J.L. MONCET
C
C
C ATMOSPHERIC AND ENVIRONMENTAL RESEARCH INC.
C 840 MEMORIAL DRIVE, CAMBRIDGE, MA 02139
C
C----------------------------------------------------------------------
C
C WORK SUPPORTED BY: THE ARM PROGRAM
C OFFICE OF ENERGY RESEARCH
C DEPARTMENT OF ENERGY
C
C
C SOURCE OF ORIGINAL ROUTINE: AFGL LINE-BY-LINE MODEL
C
C FASCOD3
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C Common blocks from analytic derivatives
C -------------------------
COMMON /ADRPNM/ CDUM1,PTHODI,PTHODT,PTHRDR
C -------------------------
COMMON /RCNTRL/ ILNFLG
COMMON VNU(250),SP(250),ALFA0(250),EPP(250),MOL(250),HWHMS(250),
* TMPALF(250),PSHIFT(250),IFLG(250),SPPSP(250),RECALF(250),
* ZETAI(250),IZETA(250)
C
C DIMENSION RR1 = NBOUND + 1 + DIM(R1)
C DIMENSION RR2 = NBOUND/2 + 1 + DIM(R2)
C DIMENSION RR3 = NBOUND/4 + 1 + DIM(R3)
C
COMMON RR1(6099),RR2(2075),RR3(429)
COMMON /IOU/ IOUT(250)
COMMON /ABSORB/ V1ABS,V2ABS,DVABS,NPTABS,ABSRB(2030)
COMMON /ADRIVE/ LOWFLG,IREAD,MODEL,ITYPE,NOZERO,NP,H1F,H2F,
* ANGLEF,RANGEF,BETAF,LENF,AV1,AV2,RO,IPUNCH,
* XVBAR, HMINF,PHIF,IERRF,HSPACE
COMMON /MANE/ P0,TEMP0,NLAYRS,DVXM,H2OSLF,WTOT,ALBAR,ADBAR,AVBAR,
* AVFIX,LAYRFX,SECNT0,SAMPLE,DVSET,ALFAL0,AVMASS,
* DPTMIN,DPTFAC,ALTAV,AVTRAT,TDIFF1,TDIFF2,ALTD1,
* ALTD2,ANGLE,IANT,LTGNT,LH1,LH2,IPFLAG,PLAY,TLAY,
* EXTID(10)
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SECANT, XALTZ
C
COMMON /HVERSN/ HVRLBL,HVRCNT,HVRFFT,HVRATM,HVRLOW,HVRNCG,
* HVROPR,HVRPST,HVRPLT,HVRTST,HVRUTL,HVRXMR
COMMON /FILHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DV ,V1 ,V2 ,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
COMMON /CONSTS/ PI,PLANCK,BOLTZ,CLIGHT,AVOG,RADCN1,RADCN2
COMMON /XSUB/ VBOT,VTOP,VFT,LIMIN,ILO,IHI,IEOF,IPANEL,ISTOP,IDATA
COMMON /LBLF/ V1R4,V2R4,DVR4,NPTR4,BOUND4,R4(2502),RR4(2502)
COMMON /CMSHAP/ HWF1,DXF1,NX1,N1MAX,HWF2,DXF2,NX2,N2MAX,
* HWF3,DXF3,NX3,N3MAX
COMMON /SUB1/ MAX1,MAX2,MAX3,NLIM1,NLIM2,NLIM3,NLO,NHI,DVR2,DVR3,
* N1R1,N2R1,N1R2,N2R2,N1R3,N2R3
COMMON /XPANEL/ V1P,V2P,DVP,NLIM,RMIN,RMAX,NPNLXP,NSHIFT,NPTS
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL,TF4,TF4RDF,TF4CNV,
* TF4PNL,TXS,TXSRDF,TXSCNV,TXSPNL
COMMON /VOICOM/ AVRAT(102),CGAUSS(102),CF1(102),CF2(102),
* CF3(102),CER(102)
C
PARAMETER (NFPTS=2001,NFMX=1.3*NFPTS)
C
COMMON /FNSH/ IFN,F1(NFMX),F2(NFMX),F3(NFMX),FG(NFMX),XVER(NFMX)
COMMON /R4SUB/ VLOF4,VHIF4,ILOF4,IST,IHIF4,LIMIN4,LIMOUT,ILAST,
* DPTMN4,DPTFC4,ILIN4,ILIN4T
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
C
PARAMETER (NTMOL=36,NSPECI=85)
C
COMMON /ISVECT/ ISOVEC(NTMOL),ISO82(NSPECI),ISONM(NTMOL),
* SMASSI(NSPECI)
COMMON /LNC1/ RHOSLF(NSPECI),ALFD1(NSPECI),SCOR(NSPECI),ALFMAX,
* BETACR,DELTMP,DPTFC,DPTMN,XKT,NMINUS,NPLUS,NLIN,
* LINCNT,NCHNG,SUMALF,SUMZET,TRATIO,RHORAT,PAVP0,
* PAVP2,RECTLC,TMPDIF,ILC
COMMON /FLFORM/ CFORM
COMMON /L4TIMG/ L4TIM,L4TMR,L4TMS,L4NLN,L4NLS,LOTHER
COMMON /IODFLG/ DVOUT
C
REAL L4TIM,L4TMR,L4TMS,LOTHER
CHARACTER*55 CDUM1,PTHODI,PTHODT,PTHRDR
CHARACTER*10 HFMODL
CHARACTER CFORM*11,KODLYR*57,PTHODE*55,PTHODD*55
CHARACTER*8 HVRLBL,HVRCNT,HVRFFT,HVRATM,HVRLOW,HVRNCG,HVROPR,
* HVRPLT,HVRPST,HVRTST,HVRUTL,HVRXMR
LOGICAL OP
C
DIMENSION MEFDP(64),FILHDR(2),IWD(2)
DIMENSION R1(4050),R2(1050),R3(300)
C
EQUIVALENCE (IHIRAC,FSCDID(1)) , (ILBLF4,FSCDID(2)),
* (IXSCNT,FSCDID(3)) , (IAERSL,FSCDID(4)),
* (JRAD,FSCDID(9)) , (IMRG,FSCDID(11)),
* (IATM,FSCDID(15)) , (YI1,IOD) , (XID(1),FILHDR(1)),
* (V1P,IWD(1)) , (NPNLXP,LSTWDX)
EQUIVALENCE (R1(1), RR1(2049)),(R2(1),RR2(1025)),(R3(1),RR3(129))
C
C
C NOTE that DXFF1 = (HWFF1/(NFPTS-1))
C and DXFF2 = (HWFF2/(NFPTS-1))
C and DXFF3 = (HWFF3/(NFPTS-1))
C
DATA HWFF1 / 4. /,DXFF1 / 0.002 /,NXF1 / NFPTS /,NF1MAX / NFMX /
DATA HWFF2 / 16. /,DXFF2 / 0.008 /,NXF2 / NFPTS /,NF2MAX / NFMX /
DATA HWFF3 / 64. /,DXFF3 / 0.032 /,NXF3 / NFPTS /,NF3MAX / NFMX /
C
DATA MEFDP / 64*0 /
C
PTHODE = 'ODexact_'
PTHODD = 'ODdeflt_'
DATA KODLYR /
* ' '/
DATA HFMODL /' '/
C
CALL CPUTIM
(TIMEH0)
C
C ASSIGN SCCS VERSION NUMBER TO MODULE
C
HVROPR = '5.12'
C
C Initialize timing for the group "OTHER" in the TAPE6 output
C
TLNCOR = 0.0
TXINT = 0.0
TSHAPE = 0.0
TLOOPS = 0.0
TODFIL = 0.0
TMOLEC = 0.0
C
LSTWDX = -654321
NPNLXP = NWDL(IWD,LSTWDX)
ICNTNM = MOD(IXSCNT,10)
IXSECT = IXSCNT/10
C
C SET INPUT FLAG FOR USE BY X-SECTIONS
C
IFST = -99
IR4 = 0
IENTER = 0
C
C SET COMMON BLOCK CMSHAP
C
HWF1 = HWFF1
DXF1 = DXFF1
NX1 = NXF1
N1MAX = NF1MAX
HWF2 = HWFF2
DXF2 = DXFF2
NX2 = NXF2
N2MAX = NF2MAX
HWF3 = HWFF3
DXF3 = DXFF3
NX3 = NXF3
N3MAX = NF3MAX
C
DPTMN = DPTMIN
IF (JRAD.NE.1) DPTMN = DPTMIN/RADFN(V2,TAVE/RADCN2)
DPTFC = DPTFAC
ILIN4 = 0
ILIN4T = 0
NPTS = MPTS
LIMIN = 250
NSHIFT = 32
C
C SAMPLE IS AVERAGE ALPHA / DV
C
NBOUND = 4.*(2.*HWF3)*SAMPLE+0.01
NLIM1 = 2401
NLIM2 = (NLIM1/4)+1
NLIM3 = (NLIM2/4)+1
C
IF (IFN.EQ.0) THEN
CALL CPUTIM(TPAT0)
CALL SHAPEL (F1,F2,F3)
CALL SHAPEG (FG)
CALL VERFN (XVER)
IFN = IFN+1
CALL CPUTIM(TPAT1)
TSHAPE = TSHAPE+TPAT1-TPAT0
ENDIF
C
CALL CPUTIM(TPAT0)
CALL MOLEC (1,SCOR,RHOSLF,ALFD1)
CALL CPUTIM(TPAT1)
TMOLEC = TMOLEC+TPAT1-TPAT0
REWIND LINFIL
TIMRDF = 0.
TIMCNV = 0.
TIMPNL = 0.
TF4 = 0.
TF4RDF = 0.
TF4CNV = 0.
TF4PNL = 0.
TXS = 0.
TXSRDF = 0.
TXSCNV = 0.
TXSPNL = 0.
IEOF = 0
ILO = 0
IHI = -999
NMINUS = 0
NPLUS = 0
C
C NOTE (DXF3/DXF1) IS 16 AND (DXF3/DXF2) IS 4
C
DVP = DV
DVR2 = (DXF2/DXF1)*DV
DVR3 = (DXF3/DXF1)*DV
MAX1 = NSHIFT+NLIM1+(NBOUND/2)
MAX2 = MAX1/4
MAX3 = MAX1/16
MAX1 = MAX1+NSHIFT+1+16
MAX2 = MAX2+NSHIFT+1+4
MAX3 = MAX3+NSHIFT+1+1
C
C FOR CONSTANTS IN PROGRAM MAX1=4018 MAX2=1029 MAX3=282
C
CALL CPUTIM(TPAT0)
BOUND = FLOAT(NBOUND)*DV/2.
BOUNF3 = BOUND/2.
ALFMAX = BOUND/HWF3
NLO = NSHIFT+1
NHI = NLIM1+NSHIFT-1
DO 10 I = 1, MAX1
R1(I) = 0.
10 CONTINUE
DO 20 I = 1, MAX2
R2(I) = 0.
20 CONTINUE
DO 30 I = 1, MAX3
R3(I) = 0.
30 CONTINUE
IF (ILBLF4.EQ.0) THEN
DO 40 I = 1, 2502
R4(I) = 0.
40 CONTINUE
ENDIF
C
IF (IATM.GE.1.AND.IATM.LE.5) CALL YDIH1 (H1F,H2F,ANGLEF,YID)
CALL CPUTIM(TPAT1)
TLOOPS = TLOOPS + TPAT1-TPAT0
C
C ---------------------------------------------------------------
C
C - If IOD = 1 or 4 then calculate optical depths for each
C layer with DV = DVOUT (using DVSET if IOD=4) and maintain
C separately. Use PTHODI as the name of the optical depth files.
C This requires the format HFMODL, which is produced by
C calling the SUBROUTINE QNTIFY.
C
C - If IOD = 2 and IMERGE = 1 then calculate optical depths
C for each layer using the exact DV of each layer
C Use PTHODE as the name of the optical depth files.
C This requires the format HFMODL, which is produced by
C calling the SUBROUTINE QNTIFY.
C
C - If calculating layer optical depths and cumulative layer
C optical depths for an analytic derivative calculation
C (IOD=3, IMRG=10), or when using the same criteria but not
C calculating the cumulative optical depths (IOD=3),
C then use PTHODI as the name of the optical depth files.
C This requires the format HFMODL, which is produced by
C calling the SUBROUTINE QNTIFY.
C
C - If calculating layer absorptance coefficients for an
C analytic derivative calculation (IEMIT=3, IOD=3, and
C IMRG>40), then use TAPE10 as the name of the layer
C absorptance coefficient files.
C
C - If calculating optical depths using the default procedure,
C sending output to a different file for each layer (IEMIT=0,
C IOD=0, and IMRG=1), then use PTHODI for the optical depth
C pathnames.
C
C - Otherwise, use TAPE10. For IOD=1, calculate optical depths
C for each layer with DV = DVOUT (from DVSET in TAPE5, carried
C in by COMMON BLOCK /IODFLG/ (interpolation in PNLINT).
C
CALL CPUTIM(TPAT0)
IF ((IOD.EQ.1).OR.(IOD.EQ.4)) THEN
CALL QNTIFY(PTHODI,HFMODL)
WRITE (KODLYR,HFMODL) PTHODI,LAYER
INQUIRE (UNIT=KFILE,OPENED=OP)
IF (OP) CLOSE (KFILE)
OPEN (KFILE,FILE=KODLYR,FORM=CFORM,STATUS='UNKNOWN')
REWIND KFILE
DVSAV = DV
IF (DVOUT.NE.0.) DV = DVOUT
CALL BUFOUT (KFILE,FILHDR(1),NFHDRF)
DV = DVSAV
IF (NOPR.EQ.0) WRITE (IPR,900) KFILE,DV,BOUNF3
ELSEIF (IOD.EQ.2) THEN
CALL QNTIFY(PTHODE,HFMODL)
WRITE(KODLYR,HFMODL) PTHODE,LAYER
INQUIRE (UNIT=KFILE,OPENED=OP)
IF (OP) CLOSE (KFILE)
OPEN (KFILE,FILE=KODLYR,FORM=CFORM,STATUS='UNKNOWN')
REWIND KFILE
DVOUT = DV
CALL BUFOUT (KFILE,FILHDR(1),NFHDRF)
IF (NOPR.EQ.0) WRITE (IPR,900) KFILE,DVOUT,BOUNF3
ELSEIF (IOD.EQ.3) THEN
IF ((IMRG.EQ.10).OR.(IMRG.EQ.1)) THEN
CALL QNTIFY(PTHODI,HFMODL)
WRITE (KODLYR,HFMODL) PTHODI,LAYER
INQUIRE (UNIT=KFILE,OPENED=OP)
IF (OP) CLOSE (KFILE)
OPEN (KFILE,FILE=KODLYR,FORM=CFORM,STATUS='UNKNOWN')
REWIND KFILE
DVSAV = DV
DV = DVOUT
CALL BUFOUT (KFILE,FILHDR(1),NFHDRF)
DV = DVSAV
IF (NOPR.EQ.0) WRITE (IPR,900) KFILE,DV,BOUNF3
ELSEIF (IMRG.GE.40) THEN
DVSAV = DV
DV = DVOUT
CALL BUFOUT (KFILE,FILHDR(1),NFHDRF)
DV = DVSAV
IF (NOPR.EQ.0) WRITE (IPR,900) KFILE,DV,BOUNF3
ENDIF
ELSE
IF (IMRG.EQ.1) THEN
CALL QNTIFY(PTHODD,HFMODL)
WRITE (KODLYR,HFMODL) PTHODD,LAYER
INQUIRE (UNIT=KFILE,OPENED=OP)
IF (OP) CLOSE (KFILE)
OPEN (KFILE,FILE=KODLYR,FORM=CFORM,STATUS='UNKNOWN')
REWIND KFILE
ENDIF
IF (IOD.EQ.1) THEN
DVSAV = DV
IF (DVOUT.NE.0.) DV = DVOUT
CALL BUFOUT (KFILE,FILHDR(1),NFHDRF)
DV = DVSAV
ELSE
DVOUT = 0.0
CALL BUFOUT (KFILE,FILHDR(1),NFHDRF)
ENDIF
IF (NOPR.EQ.0) WRITE (IPR,900) KFILE,DV,BOUNF3
ENDIF
CALL CPUTIM(TPAT1)
TODFIL = TODFIL + TPAT1-TPAT0
C
IF (IHIRAC.EQ.9) THEN
DO 50 M = 1, NMOL
WK(M) = 0.
50 CONTINUE
ENDIF
C
C ---------------------------------------------------------------
C
VFT = V1-FLOAT(NSHIFT)*DV
VBOT = V1-BOUND
VTOP = V2+BOUND
C
LINCNT = 0
NLIN = 0
AVALF = 0.
AVZETA = 0.
SUMALF = 0.
SUMZET = 0.
NCHNG = 0
NLNCR = 0
C
V1R4ST = V1R4
V2R4ST = V2R4
IF (ILBLF4.GE.1) CALL LBLF4 (JRAD,V1R4ST,V2R4ST)
C
IFPAN = 1
C
60 CONTINUE
C
CALL CPUTIM (TIME0)
IF (IEOF.NE.0) GO TO 80
C
C THERE ARE (LIMIN * 9) QUANTITIES READ IN:
C VNU,SP,ALFA0,EPP,MOL,HWHMS,TMPALF,PSHIFT,IFLG
C
CALL RDLIN
C
CALL CPUTIM (TIME)
TIMRDF = TIMRDF+TIME-TIME0
C
IF (IEOF.NE.0) GO TO 80
C
C MODIFY LINE DATA FOR TEMPERATURE, PRESSURE, AND COLUMN DENSITY
C
CALL CPUTIM(TPAT0)
CALL LNCOR1 (NLNCR,IHI,ILO,MEFDP)
CALL CPUTIM(TPAT1)
TLNCOR = TLNCOR+TPAT1-TPAT0
C
70 CONTINUE
C
CALL CNVFNV (VNU,SP,SPPSP,RECALF,R1,R2,R3,F1,F2,F3,FG,XVER,ZETAI,
* IZETA)
C
IF (IPANEL.EQ.0) GO TO 60
C
80 CONTINUE
C
C FOR FIRST PANEL N1R1= 1 N1R2= 1 N1R3= 1
C FOR SUBSEQUENT PANELS N1R1= 33 *N1R2= 13 *N1R3= 6
C FOR ALL PANELS N2R1=2432 *N2R2=612 *N2R3=155
C
C NOTE: THE VALUES FOR N1R2, N1R3, N2R2 AND N2R3 WHICH
C ARE MARKED WITH AN ASTERISK, CONTAIN A 4 POINT
C OFFSET WHICH PROVIDES THE NECESSARY OVERLAP FOR
C THE INTERPOLATION OF R3 INTO R2, AND R2 INTO R1.
C
IF (IFPAN.EQ.1) THEN
IFPAN = 0
N1R1 = 1
N1R2 = 1
N1R3 = 1
ELSE
N1R1 = NSHIFT+1
N1R2 = (NSHIFT/4)+1+4
N1R3 = (NSHIFT/16)+1+3
ENDIF
N2R1 = NLIM1+NSHIFT-1
N2R2 = NLIM2+(NSHIFT/4)-1+4
N2R3 = NLIM3+(NSHIFT/16)-1+3
C
IF (VFT.LE.0.) THEN
CALL RSYM (R1,DV,VFT)
CALL RSYM (R2,DVR2,VFT)
CALL RSYM (R3,DVR3,VFT)
ENDIF
C
IF (IXSECT.GE.1.AND.IR4.EQ.0) THEN
CALL CPUTIM (TIME0)
CALL XSECTM (IFST,IR4)
CALL CPUTIM (TIME)
TXS = TXS+TIME-TIME0
ENDIF
C
CALL CPUTIM(TPAT0)
IF (ILBLF4.GE.1)
* CALL XINT (V1R4,V2R4,DVR4,R4,1.0,VFT,DVR3,R3,N1R3,N2R3)
IF (ICNTNM.GE.1)
* CALL XINT (V1ABS,V2ABS,DVABS,ABSRB,1.,VFT,DVR3,R3,N1R3,N2R3)
CALL CPUTIM(TPAT1)
TXINT = TXINT + TPAT1-TPAT0
C
CALL PANEL (R1,R2,R3,KFILE,JRAD,IENTER)
C
IF (ISTOP.NE.1) THEN
IF (ILBLF4.GE.1) THEN
VF1 = VFT-2.*DVR4
VF2 = VFT+2.*DVR4+FLOAT(N2R3+4)*DVR3
IF (VF2.GT.V2R4.AND.V2R4.NE.V2R4ST) THEN
CALL LBLF4 (JRAD,VF1,V2R4ST)
IF (IXSECT.GE.1.AND.IR4.EQ.1) THEN
CALL CPUTIM (TIME0)
CALL XSECTM (IFST,IR4)
CALL CPUTIM (TIME)
TXS = TXS+TIME-TIME0
ENDIF
ENDIF
ENDIF
GO TO 70
ENDIF
C
CALL CPUTIM (TIMEH1)
TIME = TIMEH1-TIMEH0-TF4-TXS
C
IF (NOPR.NE.1) THEN
IF (ILBLF4.GE.1) WRITE (IPR,905) DVR4,BOUND4
IF (NMINUS.GT.0) WRITE (IPR,910) NMINUS
IF (NPLUS.GT.0) WRITE (IPR,915) NPLUS
TOTHHI = TLNCOR+TXINT+TSHAPE+TLOOPS+TODFIL+TMOLEC
WRITE (IPR,920) L4TIM,L4TMR,L4TMS,LOTHER,L4NLN,L4NLS,
* TXS,TXSRDF,TXSCNV,TXSPNL,
* TF4,TF4RDF,TF4CNV,TF4PNL,ILIN4T,ILIN4,
* TIME,TIMRDF,TIMCNV,TIMPNL,TOTHHI,
* NLIN,LINCNT,NCHNG
WRITE(IPR,935)
IF (LINCNT.GE.1) THEN
AVALF = SUMALF/FLOAT(LINCNT)
AVZETA = SUMZET/FLOAT(LINCNT)
ENDIF
WRITE (IPR,925) AVALF,AVZETA
C
DO 90 M = 1, NMOL
IF (MEFDP(M).GT.0) WRITE (IPR,930) MEFDP(M),M
90 CONTINUE
ENDIF
C
RETURN
C
900 FORMAT ('0 * HIRAC1 * OUTPUT ON FILE ',I5,10X,' DV = ',F12.8,
* 10X,' BOUNDF3(CM-1) = ',F8.4)
905 FORMAT ('0 DV FOR LBLF4 = ',F10.5,5X,'BOUND FOR LBLF4 =',F10.4)
910 FORMAT ('0 -------------------------',I5,' HALF WIDTH CHANGES')
915 FORMAT ('0 +++++++++++++++++++++++++',I5,' HALF WIDTH CHANGES')
920 FORMAT ('0',20X,'TIME',11X,'READ',4X,'CONVOLUTION',10X,'PANEL',
* 9X,'OTHER+',
* 6X,'NO. LINES',3X,'AFTER REJECT',5X,'HW CHANGES',/,
* 2x,'LINF4',3X,2F15.3,15X,2F15.3,2I15,/,
* 2X,'XSECT ',2X,4F15.3,/,2X,'LBLF4 ',2X,4F15.3,15X,2I15,/,
* 2X,'HIRAC1',2X,5F15.3,3I15)
925 FORMAT ('0 * HIRAC1 * AVERAGE WIDTH = ',F8.6,
* ', AVERAGE ZETA = ',F8.6)
930 FORMAT ('0 ******** HIRAC1 ********',I5,' STRENGTHS FOR',
* ' TRANSITIONS WITH UNKNOWN EPP FOR MOL =',I5,
* ' SET TO ZERO')
935 FORMAT (/,'0 + OTHER timing includes:',/,
* '0 In LINF4: MOLEC, BUFIN, BUFOUT, ',
* 'NWDL, ENDFIL, and SHRINK',/,
* '0 In HIRAC: LNCOR, XINT, SHAPEL, ',
* 'SHAPEG, VERFN, MOLEC, and other loops and ',
* 'file maintenance within HIRAC',/)
C
END
BLOCK DATA BHIRAC
C
PARAMETER (NFPTS=2001,NFMX=1.3*NFPTS)
C
COMMON /FNSH/ IFN,F1(NFMX),F2(NFMX),F3(NFMX),FG(NFMX),XVER(NFMX)
C
DATA IFN / 0 /
C
END
SUBROUTINE RDLIN 1,3
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE RDLIN INPUTS LINE DATA FROM FILE LINFIL
C
CHARACTER*8 HLINID,BMOLID,HID1
CHARACTER*1 CNEGEPP(8)
integer *4 molcnt,mcntlc,
* mcntnl,linmol,
* lincnt,ilinlc,ilinnl,irec,irectl
real *4 sumstr,flinlo,flinhi
c
COMMON /LINHDR/ HLINID(10),BMOLID(64),MOLCNT(64),MCNTLC(64),
* MCNTNL(64),SUMSTR(64),LINMOL,FLINLO,FLINHI,
* LINCNT,ILINLC,ILINNL,IREC,IRECTL,HID1(2),LSTWDL
COMMON VNU(250),SP(250),ALFA0(250),EPP(250),MOL(250),HWHMS(250),
* TMPALF(250),PSHIFT(250),IFLG(250),SPPSP(250),RECALF(250),
* ZETAI(250),IZETA(250)
dimension amol(250)
equivalence (mol(1),amol(1))
common /rdlnpnl/ vmin,vmax,nrec,nwds
integer *4 nrec,nwds,lnfl,leof,npnlhd
common /rdlnbuf/ vlin(250),str(250),hw_f(250),e_low(250),
* mol_id(250),hw_s(250),hw_T(250),shft(250),jflg(250)
dimension xmol(250)
equivalence (vmin,rdpnl(1)),(mol_id(1),xmol(1))
real *4 str,hw_f,e_low,xmol,hw_s,hw_T,shft,rdpnl(2),dum(2)
integer *4 mol_id,jflg,n_one
COMMON /XSUB/ VBOT,VTOP,VFT,LIMIN,ILO,IHI,IEOF,IPANEL,ISTOP,IDATA
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /IOU/ IOUT(250)
common /eppinfo/ negepp_flag
common /bufid2/ n_negepp(64),n_resetepp(64),xspace(4096),lstwdl2
integer *4 negepp_flag,n_negepp,n_resetepp
real *4 xspace
C
**************************************************************************
c
data n_one/ 1/ npnlhd/ 6/
lnfl = linfil
C
C THERE ARE (LIMIN * 9) QUANTITIES READ IN:
C VNU,SP,ALFA0,EPP,MOL,HWHMS,TMPALF,PSHIFT,IFLG
C
ILNGTH = NLNGTH*LIMIN
IDATA = 0
C
C BUFFER PAST FILE HEADER if necessary
C
IF (ILO.LE.0) THEN
REWIND LNFL
read (lnfl) HLINID
READ (HLINID(7),950) CNEGEPP
IF (CNEGEPP(8).eq.'^') THEN
read (lnfl) n_negepp,n_resetepp,xspace
endif
ENDIF
C
10 CALL BUFINln (Lnfl,LEOF,rdpnl(1),npnlhd)
IF (LEOF.EQ.0) THEN
IF (NOPR.EQ.0) WRITE (IPR,900)
IEOF = 1
RETURN
ENDIF
C
IF (NREC.GT.LIMIN) STOP 'RDLIN; NREC GT LIMIN'
c
IF (VMAX.LT.VBOT) THEN
CALL BUFINln (Lnfl,LEOF,DUM(1),n_one)
GO TO 10
ENDIF
c
CALL BUFINln (Lnfl,LEOF,vlin(1),NWDS)
c
c precision conversion occurs here:
c incoming on right: vlin is real*8, others real*4 and integer*4
c
do 15 i=1,nrec
IFLG(i) = jflg(i)
VNU(i) = vlin(i)
SP(i) = str(i)
ALFA0(i) = hw_f(i)
EPP(i) = e_low(i)
if (iflg(i) .ge. 0) then
MOL(i) = mol_id(i)
else
amol(i) = xmol(i)
endif
HWHMS(i) = hw_s(i)
TMPALF(i)= hw_T(i)
PSHIFT(i)= shft(i)
15 continue
IF ((ILO.EQ.0).AND.(VMIN.GT.VBOT)) WRITE (IPR,905)
ILO = 1
C
IJ = 0
DO 20 I = 1, NREC
IF (IFLG(I).GE.0) THEN
IJ = IJ+1
IOUT(IJ) = I
ENDIF
20 CONTINUE
C
DO 30 I = IJ+1, 250
IOUT(I) = NREC
30 CONTINUE
C
IF (VMIN.LT.VBOT) THEN
DO 40 J = 1, IJ
I = IOUT(J)
ILO = J
IF (VNU(I).GE.VBOT) GO TO 50
40 CONTINUE
ENDIF
C
50 CONTINUE
DO 60 J = ILO, IJ
I = IOUT(J)
IF (MOL(I).GT.0) THEN
IHI = J
IF (VNU(I).GT.VTOP) GO TO 70
ENDIF
60 CONTINUE
c the following test is to see if more data is required
c idata = 1 means data requirements have been met
70 IF (IHI.LT.IJ) IDATA = 1
C
RETURN
C
900 FORMAT (' EOF ON LINFIL (MORE LINES MAY BE REQUIRED) ')
905 FORMAT (
* ' FIRST LINE ON LINFIL USED (MORE LINES MAY BE REQUIRED) ')
950 FORMAT (8a1)
C
END
SUBROUTINE LNCOR1 (NLNCR,IHI,ILO,MEFDP) 1,1
C
IMPLICIT REAL*8 (V)
C
CHARACTER*1 FREJ(250),HREJ,HNOREJ
COMMON /RCNTRL/ ILNFLG
COMMON VNU(250),S(250),ALFA0(250),EPP(250),MOL(250),HWHMS(250),
* TMPALF(250),PSHIFT(250),IFLG(250),SPPSP(250),RECALF(250),
* ZETAI(250),IZETA(250)
COMMON /IOU/ IOUT(250)
COMMON /MANE/ P0,TEMP0,NLAYRS,DVXM,H2OSLF,WTOT,ALBAR,ADBAR,AVBAR,
* AVFIX,LAYRFX,SECNT0,SAMPLE,DVSET,ALFAL0,AVMASS,
* DPTMIN,DPTFAC,ALTAV,AVTRAT,TDIFF1,TDIFF2,ALTD1,
* ALTD2,ANGLE,IANT,LTGNT,LH1,LH2,IPFLAG,PLAY,TLAY,
* EXTID(10)
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SECANT, XALTZ
C
COMMON /FILHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DV ,V1 ,V2 ,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
COMMON /XSUB/ VBOT,VTOP,VFT,DUM(7)
COMMON /LAMCHN/ ONEPL,ONEMI,EXPMIN,ARGMIN
COMMON /CONSTS/ PI,PLANCK,BOLTZ,CLIGHT,AVOG,RADCN1,RADCN2
COMMON /LBLF/ V1R4,V2R4,DVR4,NPTR4,BOUND4,R4(2502),RR4(2502)
COMMON /CMSHAP/ HWF1,DXF1,NX1,N1MAX,HWF2,DXF2,NX2,N2MAX,
* HWF3,DXF3,NX3,N3MAX
COMMON /VOICOM/ AVRAT(102),CGAUSS(102),CF1(102),CF2(102),
* CF3(102),CER(102)
C
PARAMETER (NTMOL=36,NSPECI=85)
C
COMMON /ISVECT/ ISOVEC(NTMOL),ISO82(NSPECI),ISONM(NTMOL),
* SMASSI(NSPECI)
COMMON /LNC1/ RHOSLF(NSPECI),ALFD1(NSPECI),SCOR(NSPECI),ALFMAX,
* BETACR,DELTMP,DPTFC,DPTMN,XKT,NMINUS,NPLUS,NLIN,
* LINCNT,NCHNG,SUMALF,SUMZET,TRATIO,RHORAT,PAVP0,
* PAVP2,RECTLC,TMPDIF,ILC
DIMENSION MEFDP(64),FILHDR(2),AMOL(250),SP(250)
DIMENSION A(4),B(4),TEMPLC(4)
C
EQUIVALENCE (MOL(1),AMOL(1)) , ( EQUIVALENCE (IHIRAC,FSCDID(1)) , (ILBLF4,FSCDID(2)),
* (IXSCNT,FSCDID(3)) , (IAERSL,FSCDID(4)),
* (JRAD,FSCDID(9)) , (XID(1),FILHDR(1))
C
C TEMPERATURES FOR LINE COUPLING COEFFICIENTS
C
DATA TEMPLC / 200.0,250.0,296.0,340.0 /
DATA HREJ /'0'/,HNOREJ /'1'/
DATA NWDTH /0/
C
NLNCR = NLNCR+1
IF (NLNCR.EQ.1) THEN
C
XKT0 = TEMP0/RADCN2
XKT = TAVE/RADCN2
DELTMP = ABS(TAVE-TEMP0)
BETACR = (1./XKT)-(1./XKT0)
CALL MOLEC (2,SCOR,RHOSLF,ALFD1)
C
TRATIO = TAVE/TEMP0
RHORAT = (PAVE/P0)*(TEMP0/TAVE)
C
PAVP0 = PAVE/P0
PAVP2 = PAVP0*PAVP0
C
C FIND CORRECT TEMPERATURE AND INTERPOLATE FOR Y AND G
C
DO 10 IL = 1, 3
ILC = IL
IF (TAVE.LT.TEMPLC(ILC+1)) GO TO 20
10 CONTINUE
20 IF (ILC.EQ.4) ILC = 3
C
RECTLC = 1.0/(TEMPLC(ILC+1)-TEMPLC(ILC))
TMPDIF = TAVE-TEMPLC(ILC)
C
ENDIF
C
IF (ILNFLG.EQ.2) READ(15)(FREJ(J),J=ILO,IHI)
C
DO 30 J = ILO, IHI
YI = 0.
GI = 0.
GAMMA1 = 0.
GAMMA2 = 0.
I = IOUT(J)
IFLAG = IFLG(I)
M = MOD(MOL(I),100)
C
C ISO=(MOD(MOL(I),1000)-M)/100 IS PROGRAMMED AS:
C
ISO = MOD(MOL(I),1000)/100
ILOC = ISOVEC(M)+ISO
C
IF ((M.GT.NMOL).OR.(M.LT.1)) GO TO 25
C
MOL(I) = M
SUI = S(I)*WK(M)
C
IF (SUI.EQ.0.) GO TO 25
C
NLIN = NLIN+1
C
C Y'S AND G'S ARE STORED IN I+1 POSTION OF VNU,S,ALFA0,EPP...
C A(1-4), B(1-4) CORRESPOND TO TEMPERATURES TEMPLC(1-4) ABOVE
C
IF (IFLAG.EQ.1.OR.IFLAG.EQ.3) THEN
A(1) = VNU(I+1)
B(1) = S(I+1)
A(2) = ALFA0(I+1)
B(2) = EPP(I+1)
A(3) = AMOL(I+1)
B(3) = HWHMS(I+1)
A(4) = TMPALF(I+1)
B(4) = PSHIFT(I+1)
C
C CALCULATE SLOPE AND EVALUATE
C
SLOPEA = ( SLOPEB = (C
IF (IFLAG.EQ.1) THEN
YI = A(ILC)+SLOPEA*TMPDIF
GI = B(ILC)+SLOPEB*TMPDIF
ELSE
GAMMA1 = A(ILC)+SLOPEA*TMPDIF
GAMMA2 = B(ILC)+SLOPEB*TMPDIF
ENDIF
ENDIF
C
C IFLAG = 2 IS RESERVED FOR LINE COUPLING COEFFICIENTS ASSOCIATED
C WITH AN EXACT TREATMENT (NUMERICAL DIAGONALIZATION)
C
C IFLAG = 3 TREATS LINE COUPLING IN TERMS OF REDUCED WIDTHS
C
VNU(I) = VNU(I)+RHORAT*PSHIFT(I)
C
C TEMPERATURE CORRECTION OF THE HALFWIDTH
C SELF TEMP DEPENDENCE TAKEN THE SAME AS FOREIGN
C
TMPCOR = TRATIO**TMPALF(I)
ALFA0I = ALFA0(I)*TMPCOR
HWHMSI = HWHMS(I)*TMPCOR
ALFL = ALFA0I*(RHORAT-RHOSLF(ILOC))+HWHMSI*RHOSLF(ILOC)
C
IF (IFLAG.EQ.3) ALFL = ALFL*(1.0-GAMMA1*PAVP0-GAMMA2*PAVP2)
C
ALFAD = VNU(I)*ALFD1(ILOC)
ZETA = ALFL/(ALFL+ALFAD)
ZETAI(I) = ZETA
FZETA = 100.*ZETA
IZ = FZETA + ONEPL
IZETA(I) = IZ
ZETDIF = FZETA - FLOAT(IZ-1)
ALFV = (AVRAT(IZ)+ZETDIF*(AVRAT(IZ+1)-AVRAT(IZ)))*(ALFL+ALFAD)
IF (ALFV.LT.DV) THEN
ALFV = DV
NMINAD = 1
ELSE
NMINAD = 0
ENDIF
IF (ALFV.GT.ALFMAX) THEN
ALFV = ALFMAX
NPLSAD = 1
ELSE
NPLSAD = 0
ENDIF
C
IF (HWF3*ALFV+VNU(I) .LT. VFT) GO TO 25
C
RECALF(I) = 1./ALFV
C
C TREAT TRANSITIONS WITH UNKNOWN EPP AS SPECIAL CASE
C
IF (EPP(I).LT.0.) THEN
IF (DELTMP.LE.10.) THEN
EPP(I) = 0.
ELSE
MEFDP(M) = MEFDP(M)+1
GO TO 25
ENDIF
ENDIF
IF (JRAD.NE.1) SUI = SUI*SCOR(ILOC)*
* EXP(-EPP(I)*BETACR)*(1.+EXP(-VNU(I)/XKT))
IF (JRAD.EQ.1) SUI = SUI*SCOR(ILOC)*VNU(I)*
* EXP(-EPP(I)*BETACR)*(1.-EXP(-VNU(I)/XKT))
C
IF (IFLAG.EQ.0) THEN
IF (ILNFLG.LE.1) THEN
FREJ(J) = HNOREJ
SPEAK = SUI*RECALF(I)
IF (DVR4.LE.0.) THEN
IF (SPEAK.LE.DPTMN) THEN
FREJ(J) = HREJ
GO TO 25
ENDIF
ELSE
JJ = (VNU(I)-V1R4)/DVR4+1.
JJ = MAX(JJ,1)
JJ = MIN(JJ,NPTR4)
IF (SPEAK.LE.(DPTMN+DPTFC*R4(JJ))) THEN
FREJ(J) = HREJ
GO TO 25
ENDIF
ENDIF
ELSE
C "ELSE" IS TRUE WHEN "ILNFLG" EQUALS 2
C
IF (FREJ(J).EQ.HREJ) GO TO 25
ENDIF
ENDIF
C
NMINUS = NMINUS+NMINAD
NPLUS = NPLUS+NPLSAD
SUMALF = SUMALF+ALFV
SUMZET = SUMZET+ZETA
LINCNT = LINCNT+1
C
SP(I) = SUI*(1.+GI*PAVP2)
SPPI = SUI*YI*PAVP0
SPPSP(I) = SPPI/SP(I)
C
GO TO 30
C
25 SP(I) = 0.
SPPSP(I) = 0.
C
30 CONTINUE
C
NCHNG = NMINUS+NPLUS
IF (ILNFLG.EQ.1) WRITE(15)(FREJ(J),J=ILO,IHI)
C
RETURN
C
END
SUBROUTINE CNVFNV (VNU,SP,SPPSP,RECALF,R1,R2,R3,F1,F2,F3,FG, 1,2
* XVER,ZETAI,IZETA)
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE CNVFNV PERFORMS THE CONVOLUTION OF THE LINE DATA WITH
C THE VOIGT LINE SHAPE (APPROXIMATED)
C
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
C IMPLEMENTATION: R.D. WORSHAM
C
C ALGORITHM REVISIONS: S.A. CLOUGH
C R.D. WORSHAM
C J.L. MONCET
C
C
C ATMOSPHERIC AND ENVIRONMENTAL RESEARCH INC.
C 840 MEMORIAL DRIVE, CAMBRIDGE, MA 02139
C
C ------------------------------------------------------------------
C
C WORK SUPPORTED BY: THE ARM PROGRAM
C OFFICE OF ENERGY RESEARCH
C DEPARTMENT OF ENERGY
C
C
C SOURCE OF ORIGINAL ROUTINE: AFGL LINE-BY-LINE MODEL
C
C FASCOD3
C
C
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SECANT, XALTZ
C
COMMON /FILHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DV ,V1 ,V2 ,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
COMMON /XSUB/ VBOT,VTOP,VFT,LIMIN,ILO,IHI,IEOF,IPANEL,ISTOP,IDATA
COMMON /XPANEL/ V1P,V2P,DVP,NLIM,RMIN,RMAX,NPNLXP,NSHIFT,NPTS
COMMON /CMSHAP/ HWF1,DXF1,NX1,N1MAX,HWF2,DXF2,NX2,N2MAX,
* HWF3,DXF3,NX3,N3MAX
COMMON /SUB1/ MAX1,MAX2,MAX3,NLIM1,NLIM2,NLIM3,NLO,NHI,DVR2,DVR3,
* N1R1,N2R1,N1R2,N2R2,N1R3,N2R3
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL,TF4,TF4RDF,TF4CNV,
* TF4PNL,TXS,TXSRDF,TXSCNV,TXSPNL
COMMON /VOICOM/ AVRAT(102),CGAUSS(102),CF1(102),CF2(102),
* CF3(102),CER(102)
COMMON /IOU/ IOUT(250)
C
DIMENSION VNU(*),SP(*),SPPSP(*),RECALF(*)
DIMENSION R1(*),R2(*),R3(*)
DIMENSION F1(*),F2(*),F3(*)
DIMENSION FG(*),XVER(*)
DIMENSION IZETA(*),ZETAI(*)
C
CALL CPUTIM (TIME0)
C
CLC1 = 4./(FLOAT(NX1-1))
CLC2 = 16./(FLOAT(NX2-1))
CLC3 = 64./(FLOAT(NX3-1))
WAVDXF = DV/DXF1
HWDXF = HWF1/DXF1
CONF2 = DV/DVR2
CONF3 = DV/DVR3
ILAST = ILO-1
C
IF (ILO.LE.IHI) THEN
DO 30 J = ILO, IHI
I = IOUT(J)
IF (SP(I).NE.0.) THEN
DEPTHI = SP(I)*RECALF(I)
IZM = IZETA(I)
ZETDIF = 100.*ZETAI(I)-FLOAT(IZM-1)
STRF1 = DEPTHI*(CF1(IZM)+ZETDIF*(CF1(IZM+1)-CF1(IZM)))
STRF2 = DEPTHI*(CF2(IZM)+ZETDIF*(CF2(IZM+1)-CF2(IZM)))
STRF3 = DEPTHI*(CF3(IZM)+ZETDIF*(CF3(IZM+1)-CF3(IZM)))
STRD = DEPTHI*(CGAUSS(IZM)+ZETDIF*(CGAUSS(IZM+1)-
* CGAUSS(IZM)))
STRVER = DEPTHI*(CER(IZM)+ZETDIF*(CER(IZM+1)-CER(IZM)) )
C
ZSLOPE = RECALF(I)*WAVDXF
ZINT = (VNU(I)-VFT)/DV
BHWDXF = HWDXF/ZSLOPE
JMAX1 = ZINT+BHWDXF+1.5
IF (JMAX1.GT.MAX1) THEN
ILAST = J-1
IPANEL = 1
GO TO 40
ENDIF
JMIN1 = ZINT-BHWDXF+1.5
RSHFT = 0.5
IF (ZINT.LT.0.0) RSHFT = -RSHFT
J2SHFT = ZINT*(1.-CONF2)+RSHFT
J3SHFT = ZINT*(1.-CONF3)+RSHFT
JMIN2 = JMIN1-J2SHFT
JMIN3 = JMIN1-J3SHFT
ZF1L = (FLOAT(JMIN1-2)-ZINT)*ZSLOPE
ZF2L = (FLOAT(JMIN2-2)-ZINT*CONF2)*ZSLOPE
ZF3L = (FLOAT(JMIN3-2)-ZINT*CONF3)*ZSLOPE
ZF1 = ZF1L
ZF2 = ZF2L
ZF3 = ZF3L
DO 10 J1 = JMIN1, JMAX1
J2 = J1-J2SHFT
J3 = J1-J3SHFT
ZF3 = ZF3+ZSLOPE
ZF2 = ZF2+ZSLOPE
ZF1 = ZF1+ZSLOPE
IZ3 = ABS(ZF3)+1.5
IZ2 = ABS(ZF2)+1.5
IZ1 = ABS(ZF1)+1.5
R3(J3) = R3(J3)+STRF3*F3(IZ3)
R2(J2) = R2(J2)+STRF2*F2(IZ2)
R1(J1) = R1(J1)+STRF1*F1(IZ1)+STRD*FG(IZ1)+STRVER*XVER
* (IZ1)
10 CONTINUE
C
IF (SPPSP(I).NE.0.) THEN
C
C THE FOLLOWING DOES LINE COUPLING
C
C SPPSP(I) = SPP(I)/SP(I)
C
DPTRAT = SPPSP(I)
STRF3 = STRF3*CLC3*DPTRAT
STRF2 = STRF2*CLC2*DPTRAT
STRF1 = STRF1*CLC1*DPTRAT
STRD = STRD*CLC1*DPTRAT
STRVER = STRVER*CLC1*DPTRAT
C
C
DO 20 J1 = JMIN1, JMAX1
J2 = J1-J2SHFT
J3 = J1-J3SHFT
ZF3L = ZF3L+ZSLOPE
ZF2L = ZF2L+ZSLOPE
ZF1L = ZF1L+ZSLOPE
IZ3 = ABS(ZF3L)+1.5
IZ2 = ABS(ZF2L)+1.5
IZ1 = ABS(ZF1L)+1.5
R3(J3) = R3(J3)+STRF3*F3(IZ3)*ZF3L
R2(J2) = R2(J2)+STRF2*F2(IZ2)*ZF2L
R1(J1) = R1(J1)+(STRF1*F1(IZ1)+STRD*FG(IZ1)+STRVER*
* XVER(IZ1))*ZF1L
20 CONTINUE
C
ENDIF
ENDIF
C
30 CONTINUE
ILAST = IHI
C
C IDATA=0 FOR MORE DATA REQUIRED
C IDATA=1 IF NO MORE DATA REQUIRED
C
IPANEL = IDATA
ELSE
IPANEL = 1
ENDIF
C
40 ILO = ILAST+1
CALL CPUTIM (TIME)
TIMCNV = TIMCNV+TIME-TIME0
RETURN
C
END
SUBROUTINE PANEL (R1,R2,R3,KFILE,JRAD,IENTER) 1,7
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE PANEL COMBINES RESULTS OF R3, R2, AND R1 INTO R1 ARRAY
C AND OUTPUTS THE ARRAY R1
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C LAST MODIFICATION: 28 AUGUST 1992
C
C IMPLEMENTATION: R.D. WORSHAM
C
C ALGORITHM REVISIONS: S.A. CLOUGH
C R.D. WORSHAM
C J.L. MONCET
C
C
C ATMOSPHERIC AND ENVIRONMENTAL RESEARCH INC.
C 840 MEMORIAL DRIVE, CAMBRIDGE, MA 02139
C
C----------------------------------------------------------------------
C
C WORK SUPPORTED BY: THE ARM PROGRAM
C OFFICE OF ENERGY RESEARCH
C DEPARTMENT OF ENERGY
C
C
C SOURCE OF ORIGINAL ROUTINE: AFGL LINE-BY-LINE MODEL
C
C FASCOD3
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SECANT, XALTZ
C
COMMON /FILHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DV ,V1 ,V2 ,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
COMMON /CONSTS/ PI,PLANCK,BOLTZ,CLIGHT,AVOG,RADCN1,RADCN2
COMMON /XSUB/ VBOT,VTOP,VFT,LIMIN,ILO,IHI,IEOF,IPANEL,ISTOP,IDATA
COMMON /SUB1/ MAX1,MAX2,MAX3,NLIM1,NLIM2,NLIM3,NLO,NHI,DVR2,DVR3,
* N1R1,N2R1,N1R2,N2R2,N1R3,N2R3
COMMON /XPANEL/ V1P,V2P,DVP,NLIM,RMIN,RMAX,NPNLXP,NSHIFT,NPTS
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL,TF4,TF4RDF,TF4CNV,
* TF4PNL,TXS,TXSRDF,TXSCNV,TXSPNL
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KDUMM,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /IODFLG/ DVOUT
DIMENSION R1(*),R2(*),R3(*)
DIMENSION PNLHDR(2)
C
EQUIVALENCE (V1P,PNLHDR(1))
C
CALL CPUTIM (TIME0)
X00 = -7./128.
X01 = 105./128.
X02 = 35./128.
X03 = -5./128.
X10 = -1./16.
X11 = 9./16.
ISTOP = 0
C
C Test for last panel. If last, set the last point to one point
C greater than V1 specified on TAPE5 (to ensure last point for
C every layer is the same)
C
IF ((VFT+(NHI-1)*DVP).GT.V2) THEN
NHI = (V2-VFT)/DVP + 1.
V2P = VFT+FLOAT(NHI-1)*DVP
IF (V2P.LT.V2) THEN
V2P = V2P+DVP
NHI = NHI+1
ENDIF
ISTOP = 1
ELSE
V2P = VFT+FLOAT(NHI-1)*DV
ENDIF
NLIM = NHI-NLO+1
V1P = VFT+FLOAT(NLO-1)*DV
C
LIMLO = N1R2
IF (N1R2.EQ.1) LIMLO = LIMLO+4
LIMHI = (NHI/4)+1
C
DO 10 J = LIMLO, LIMHI, 4
J3 = (J-1)/4+1
R2(J) = R2(J)+R3(J3)
R2(J+1) = R2(J+1)+X00*R3(J3-1)+X01*R3(J3)+X02*R3(J3+1)+
* X03*R3(J3+2)
R2(J+2) = R2(J+2)+X10*(R3(J3-1)+R3(J3+2))+
* X11*(R3(J3)+R3(J3+1))
R2(J+3) = R2(J+3)+X03*R3(J3-1)+X02*R3(J3)+X01*R3(J3+1)+
* X00*R3(J3+2)
10 CONTINUE
DO 20 J = NLO, NHI, 4
J2 = (J-1)/4+1
R1(J) = R1(J)+R2(J2)
R1(J+1) = R1(J+1)+X00*R2(J2-1)+X01*R2(J2)+X02*R2(J2+1)+
* X03*R2(J2+2)
R1(J+2) = R1(J+2)+X10*(R2(J2-1)+R2(J2+2))+
* X11*(R2(J2)+R2(J2+1))
R1(J+3) = R1(J+3)+X03*R2(J2-1)+X02*R2(J2)+X01*R2(J2+1)+
* X00*R2(J2+2)
20 CONTINUE
C
C IN THE FOLLOWING SECTION THE ABSORPTION COEFFICIENT IS MULTIPIIED
C BY THE RADIATION FIELD
C
IF (JRAD.EQ.0) THEN
C
XKT = TAVE/RADCN2
VI = V1P-DV
VITST = VI
RDLAST = -1.
NPTSI1 = NLO-1
NPTSI2 = NLO-1
C
30 NPTSI1 = NPTSI2+1
C
VI = VFT+FLOAT(NPTSI1-1)*DV
RADVI = RADFNI(VI,DV,XKT,VITST,RDEL,RDLAST)
C
NPTSI2 = (VITST-VFT)/DV+1.001
NPTSI2 = MIN(NPTSI2,NHI)
C
DO 40 I = NPTSI1, NPTSI2
C VI = VI+DV
R1(I) = R1(I)*RADVI
RADVI = RADVI+RDEL
40 CONTINUE
C
IF (NPTSI2.LT.NHI) GO TO 30
C
ENDIF
C
C V1P IS FIRST FREQ OF PANEL
C V2P IS LAST FREQ OF PANEL
C
C If DVOUT (carried in from COMMON BLOCK /IODFLG/) is zero,
C then no interpolation is necessary. For nozero DVOUT
C (in case of IOD=1,3), call PNLINT.
C
IF (DVOUT.EQ.0.) THEN
CALL BUFOUT (KFILE,PNLHDR(1),NPHDRF)
CALL BUFOUT (KFILE,R1(NLO),NLIM)
C
IF (NPTS.GT.0) CALL R1PRNT (V1P,DVP,NLIM,R1,NLO,NPTS,KFILE,
* IENTER)
ELSE
CALL PNLINT (R1(NLO),IENTER)
ENDIF
C
VFT = VFT+FLOAT(NLIM1-1)*DV
IF (ISTOP.NE.1) THEN
DO 50 J = NLIM1, MAX1
R1(J-NLIM1+1) = R1(J)
50 CONTINUE
DO 60 J = MAX1-NLIM1+2, MAX1
R1(J) = 0.
60 CONTINUE
DO 70 J = NLIM2, MAX2
R2(J-NLIM2+1) = R2(J)
70 CONTINUE
DO 80 J = MAX2-NLIM2+2, MAX2
R2(J) = 0.
80 CONTINUE
DO 90 J = NLIM3, MAX3
R3(J-NLIM3+1) = R3(J)
90 CONTINUE
DO 100 J = MAX3-NLIM3+2, MAX3
R3(J) = 0.
100 CONTINUE
NLO = NSHIFT+1
ENDIF
CALL CPUTIM (TIME)
TIMPNL = TIMPNL+TIME-TIME0
C
RETURN
C
END
SUBROUTINE PNLINT (R1,IENTER) 1,8
C
IMPLICIT REAL*8 (V)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C LAST MODIFICATION: 6 May 1994 pdb
C LAST MODIFICATION: 9 APRIL 1991
C
C IMPLEMENTATION: R.D. WORSHAM
C
C ALGORITHM: R.D. WORSHAM
C S.A. CLOUGH
C J.L. MONCET
C
C
C ATMOSPHERIC AND ENVIRONMENTAL RESEARCH INC.
C 840 MEMORIAL DRIVE, CAMBRIDGE, MA 02139
C
C----------------------------------------------------------------------
C
C WORK SUPPORTED BY: THE ARM PROGRAM
C OFFICE OF ENERGY RESEARCH
C DEPARTMENT OF ENERGY
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SECANT, XALTZ
C
COMMON /FILHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),
* WK(60),PZ1,PZ2,TZ1,TZ2,WBROAD,DV ,V1 ,V2 ,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
COMMON /XSUB/ VBOT,VTOP,VFT,LIMIN,ILO,IHI,IEOF,IPANEL,ISTOP,IDATA
COMMON /XPANEL/ V1P,V2P,DVP,NLIM,RMIN,RMAX,NPNLXP,NSHIFT,NPTS
COMMON /XPANO/ V1PO,V2PO,DVPO,NLIM2,RMINO,RMAXO,NPNXPO
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /R1SAV/ R1OUT(2410)
COMMON /IODFLG/ DVOUT
C
C SAVE statement to preserve value of NLIM1 when returning to
C subroutine
C
SAVE NLIM1
C
DIMENSION A1(0:100),A2(0:100),A3(0:100),A4(0:100)
DIMENSION R1(*)
DIMENSION PNLHDR(2),PNLHDO(2)
C
EQUIVALENCE (PNLHDR(1),V1P),(PNLHDO(1),V1PO)
C
DATA LIMOUT / 2400 /
C
C The data for NM1 and N0 are used instead of directly inserting
C '-1' and '0' into the subscripts for R1 (lines 1158-9) to avoid
C compiler warnings 'CONSTANT SUBSCRIPT IS OUT OF BOUNDS'
C
DATA NM1/-1/,N0/0/
C
C CALL CPUTIM (TIME)
C WRITE (IPR,900) TIME
C
C The value of DVOUT is carried from COMMON BLOCK /IODFLG/
C
NPNXPO = NPNLXP
DVPO = DVOUT
NPPANL = 1
ATYPE = 9.999E09
IF (DVP.EQ.DVOUT) ATYPE = 0.
IF (DVOUT.GT.DVP) ATYPE = DVP/(DVOUT-DVP)+0.5
IF (DVOUT.LT.DVP) ATYPE = -DVOUT/(DVP-DVOUT)-0.5
IF (ABS(DVOUT-DVP).LT.1.E-8) ATYPE = 0.
C
C
C 1/1 ratio only
C
IF (ATYPE.EQ.0.) THEN
CALL PMNMX (R1,NLIM,RMIN,RMAX)
CALL BUFOUT (KFILE,PNLHDR(1),NPHDRF)
CALL BUFOUT (KFILE,R1(1),NLIM)
C
IF (NPTS.GT.0) CALL R1PRNT (V1P,DVP,NLIM,R1,1,NPTS,KFILE,
* IENTER)
C
GO TO 40
ENDIF
C
C All ratios except 1/1
C
DO 10 JP = 0, 100
APG = JP
P = 0.01*APG
C
C Constants for the Lagrange 4 point interpolation
C
A1(JP) = -P*(P-1.0)*(P-2.0)/6.0
A2(JP) = (P**2-1.0)*(P-2.0)*0.5
A3(JP) = -P*(P+1.0)*(P-2.0)*0.5
A4(JP) = P*(P**2-1.0)/6.0
10 CONTINUE
C
C Zero point of first panel
C
IF (V1PO.EQ.0.0) THEN
R1(NM1) = R1(1)
R1(N0) = R1(1)
V1PO = V1P
NLIM1 = 1
ENDIF
C
C Add points to end of last panel for interpolation
C
IF (ISTOP.EQ.1) THEN
R1(NLIM+1) = R1(NLIM)
R1(NLIM+2) = R1(NLIM)
NLIM = NLIM + 2
V2P = V2P + 2.*DVP
ENDIF
C
C *** BEGINNING OF LOOP THAT DOES INTERPOLATION ***
C
20 CONTINUE
C
C Determine potential last point for the outgoing panel (2400 pts.)
C
V2PO = V1PO+FLOAT(LIMOUT)*DVOUT
C
IF (V2P.LE.V2PO+DVP.AND.ILAST.EQ.0.AND.NPPANL.LE.0) GO TO 40
C
C Four possibilities:
C 1a. Last panel to be done, set the appropriate
C final output point and total number of points in panel.
C
C 1b. Would be last panel, but need more incoming points to
C fill panel.
C
C 2a. More panels to come, set last point in panel.
C
C 2b. More panels to come, but need more incoming points to
C fill panel.
C
IF ((V1PO+(LIMOUT-1)*DVOUT).GT.V2) THEN
NLIM2 = (V2-V1PO)/DVOUT + 1.
V2PO = V1PO+FLOAT(NLIM2-1)*DVOUT
IF (V2PO.LT.V2) THEN
V2PO = V2PO+DVOUT
NLIM2 = NLIM2+1
ENDIF
ILAST = 1
IF (V2PO.GT.V2P-DVP) THEN
NLIM2 = ((V2P-DVP-V1PO)/DVOUT) + 1.
V2PO = V1PO+FLOAT(NLIM2-1)*DVOUT
IF (V2PO+DVOUT.LT.V2P-DVP) THEN
NLIM2 = NLIM2+1
V2PO = V2PO+DVOUT
ENDIF
ILAST = 0
ENDIF
ELSE
NLIM2 = LIMOUT
V2PO = V1PO+FLOAT(NLIM2-1)*DVOUT
IF (V2PO.GT.V2P-DVP) THEN
NLIM2 = ((V2P-DVP-V1PO)/DVOUT) + 1.
V2PO = V1PO+FLOAT(NLIM2-1)*DVOUT
IF (V2PO+DVOUT.LT.V2P-DVP) THEN
NLIM2 = NLIM2+1
V2PO = V2PO+DVOUT
ENDIF
ENDIF
ILAST = 0
ENDIF
C
RATDV = DVOUT/DVP
C
C FJJ is offset by 2. for rounding purposes
C
FJ1DIF = (V1PO-V1P)/DVP+1.+2.
C
C Interpolate R1 to DVOUT
C
DO 30 II = NLIM1, NLIM2
FJJ = FJ1DIF+RATDV*FLOAT(II-1)
JJ = IFIX(FJJ)-2
JP = (FJJ-FLOAT(JJ))*100.-199.5
R1OUT(II) = A1(JP)*R1(JJ-1)+A2(JP)*R1(JJ)+A3(JP)*R1(JJ+1)+
* A4(JP)*R1(JJ+2)
30 CONTINUE
C
C Two possibilities:
C 1. Buffer out whole panel (NLIM2 = 2400) or the remaining
C interpolated points
C
C 2. Return to PANEL to obtain more incoming points to fill
C outgoing panel
C
IF (NLIM2.EQ.LIMOUT.OR.ILAST.EQ.1) THEN
CALL PMNMX (R1OUT,NLIM2,RMINO,RMAXO)
CALL BUFOUT (KFILE,PNLHDO(1),NPHDRF)
CALL BUFOUT (KFILE,R1OUT(1),NLIM2)
IF (NPTS.GT.0) CALL R1PRNT (V1PO,DVOUT,NLIM2,R1OUT,1,NPTS,
* KFILE,IENTER)
NLIM1 = 1
NPPANL = 0
V1PO = V2PO+DVOUT
IF ((V1PO+FLOAT(LIMOUT)*DVOUT).GT.(V2P-DVP)) NPPANL = 1
ELSE
NLIM1 = NLIM2+1
NPPANL = -1
ENDIF
C
C If not at last point, continue interpolation
C
IF (ILAST.NE.1) GO TO 20
C
C Reset variables
C
V1PO = 0.0
NPPANL = 1
40 CONTINUE
C
C CALL CPUTIM (TIME1)
C TIM = TIME1-TIME
C WRITE (IPR,905) TIME1,TIM
C
RETURN
C
C 900 FORMAT ('0 THE TIME AT THE START OF PNLINT IS ',F12.3)
C 905 FORMAT ('0 THE TIME AT THE END OF PNLINT IS ',F12.3/F12.3,
C * ' SECS WERE REQUIRED FOR THIS INTERPOLATION ')
C
END
SUBROUTINE PMNMX (R1,NLIM,RMIN,RMAX) 2
C
DIMENSION R1(NLIM)
C
RMIN = R1(1)
RMAX = R1(1)
C
DO 10 I = 2, NLIM
RMIN = MIN(RMIN,R1(I))
RMAX = MAX(RMAX,R1(I))
10 CONTINUE
C
RETURN
C
END
SUBROUTINE SHAPEL (F1,F2,F3) 1
C
C SUBROUTINE SHAPEL CONSTRUCTS THE SUB-FUNCTIONS FOR THE
C LORENTZ LINE SHAPE
C
COMMON /CMSHAP/ HWF1,DXF1,NX1,N1MAX,HWF2,DXF2,NX2,N2MAX,
* HWF3,DXF3,NX3,N3MAX
DIMENSION F1(*),F2(*),F3(*)
C
XLORNZ(XSQ) = 1./(1.+XSQ)
Q1FN(XSQ) = A1+B1*XSQ
Q2FN(XSQ) = A2+B2*XSQ
Q3FN(XSQ) = A3+B3*XSQ
C
A(Z0) = (1.+2.*Z0*Z0)/(1.+Z0*Z0)**2
B(Z0) = -1./(1.+Z0*Z0)**2
RECPI = 1./(2.*ASIN(1.))
TOTAL = 0.
A1 = A(HWF1)
B1 = B(HWF1)
C
A2 = A(HWF2)
B2 = B(HWF2)
C
A3 = A(HWF3)
B3 = B(HWF3)
C
DO 10 I = 1, N1MAX
F1(I) = 0.
10 CONTINUE
F1(1) = RECPI*(XLORNZ(0.)-Q1FN(0.))
SUM = F1(1)
DO 20 JJ = 2, NX1
X = FLOAT(JJ-1)*DXF1
XSQ = X*X
F1(JJ) = RECPI*(XLORNZ(XSQ)-Q1FN(XSQ))
SUM = SUM+F1(JJ)*2.
20 CONTINUE
F1(NX1) = 0.
SUM = SUM*DXF1
TOTAL = TOTAL+SUM
C
DO 30 I = 1, N2MAX
F2(I) = 0.
30 CONTINUE
F2(1) = RECPI*(Q1FN(0.)-Q2FN(0.))
SUM = F2(1)
J1LIM = HWF1/DXF2+1.001
DO 40 JJ = 2, J1LIM
X = FLOAT(JJ-1)*DXF2
XSQ = X*X
F2(JJ) = RECPI*(Q1FN(XSQ)-Q2FN(XSQ))
SUM = SUM+F2(JJ)*2.
40 CONTINUE
J1LIMP = J1LIM+1
DO 50 JJ = J1LIMP, NX2
X = FLOAT(JJ-1)*DXF2
XSQ = X*X
F2(JJ) = RECPI*(XLORNZ(XSQ)-Q2FN(XSQ))
SUM = SUM+F2(JJ)*2.
50 CONTINUE
F2(NX2) = 0.
SUM = SUM*DXF2
TOTAL = TOTAL+SUM
C
DO 60 I = 1, N3MAX
F3(I) = 0.
60 CONTINUE
F3(1) = RECPI*(Q2FN(0.)-Q3FN(0.))
SUM = F3(1)
J2LIM = HWF2/DXF3+1.001
DO 70 JJ = 2, J2LIM
X = FLOAT(JJ-1)*DXF3
XSQ = X*X
F3(JJ) = RECPI*(Q2FN(XSQ)-Q3FN(XSQ))
SUM = SUM+F3(JJ)*2.
70 CONTINUE
J2LIMP = J2LIM+1
DO 80 JJ = J2LIMP, NX3
X = FLOAT(JJ-1)*DXF3
XSQ = X*X
F3(JJ) = RECPI*(XLORNZ(XSQ)-Q3FN(XSQ))
SUM = SUM+F3(JJ)*2.
80 CONTINUE
SUM = SUM*DXF3
TOTAL = TOTAL+SUM
C
RETURN
C
END
SUBROUTINE SHAPEG (FG) 3
C
C SUBROUTINE SHAPEG CONSTRUCTS THE FUNCTION FOR THE DOPPLER PROFILE
C
COMMON /CMSHAP/ HWF1,DXF1,NX1,N1MAX,HWF2,DXF2,NX2,N2MAX,
* HWF3,DXF3,NX3,N3MAX
DIMENSION FG(*)
C
FGAUSS(XSQ) = EXP(-FLN2*XSQ)
FLN2 = ALOG(2.)
RECPI = 1./(2.*ASIN(1.))
FGNORM = SQRT(FLN2*RECPI)
TOTAL = 0.
DO 10 I = 1, N1MAX
FG(I) = 0.
10 CONTINUE
FG(1) = FGNORM*FGAUSS(0.)
SUM = FG(1)
DO 20 JJ = 2, NX1
X = FLOAT(JJ-1)*DXF1
XSQ = X*X
FG(JJ) = FGNORM*FGAUSS(XSQ)
SUM = SUM+FG(JJ)*2.
20 CONTINUE
FG(NX1) = 0.
SUM = SUM*DXF1
TOTAL = TOTAL+SUM
C
RETURN
C
END
SUBROUTINE VERFN (XVER) 1
C
C VERFN IS A FUNCTION USED TO IMPROVE THE ACCURACY OF THE
C VOIGT APPROXIMATION IN THE DOMAIN 0 - 4 HALFWIDTHS.
C
COMMON /CMSHAP/ HWF1,DXF1,NX1,N1MAX,HWF2,DXF2,NX2,N2MAX,
* HWF3,DXF3,NX3,N3MAX
DIMENSION XVER(*)
C
C FOR ZETA = 0.3
C
DATA CEXP,CE0,CE2,CE4 / 0.45,1.,-.20737285249,-.00872684335747 /
DATA SUM0,SUM2,SUM4,SUMER / 4*0. /
C
ERFN(Z2) = (1./(CE0+CE2+CE4))*(CE0+CE2*AE2*Z2+CE4*AE4*Z2*Z2)*XE0
C
IF (SUMER.NE.0.) RETURN
PI = 2.*ASIN(1.)
SE0 = SQRT(CEXP/PI)
AE0 = 1.
AE2 = 2.*CEXP
AE4 = AE2*AE2/3.
FACTOR = 1.
C
DO 10 I = 1, N1MAX
XVER(I) = 0.
10 CONTINUE
C
DO 20 I = 1, N1MAX
Z = DXF1*FLOAT(I-1)
Z2 = Z*Z
XE0 = SE0*EXP(-CEXP*Z2)
XE2 = AE2*Z2*XE0
XE4 = AE4*Z2*Z2*XE0
XVER(I) = ERFN(Z2)
SUM0 = SUM0+FACTOR*DXF1*XE0
SUM2 = SUM2+FACTOR*DXF1*XE2
SUM4 = SUM4+FACTOR*DXF1*XE4
SUMER = SUMER+FACTOR*DXF1*XVER(I)
FACTOR = 2.
20 CONTINUE
C
CPRT WRITE (IPR,900) Z,SUM0,SUM2,SUM4,SUMER
C
RETURN
C
900 FORMAT (F10.3,6F15.10)
C
END
BLOCK DATA VOICON
C
C AVRAT CONTAINS THE PARAMTERS AS A FUNCTION OF ZETA USED TO
C OBTAIN THE VOIGTS' WIDTH FROM THE LORENTZ AND DOPPLER WIDTHS.
C
C COMMON /VOICOM/ AVRAT(102),
C C CGAUSS(102),CF1(102),CF2(102),CF3(102),CER(102)
C
COMMON /VOICOM/ AV01(50),AV51(52),CG01(50),CG51(52),CFA01(50),
* CFA51(52),CFB01(50),CFB51(52),CFC01(50),
* CFC51(52),CER01(50),CER51(52)
C
DATA AV01/
* .10000E+01, .99535E+00, .99073E+00, .98613E+00, .98155E+00,
* .97700E+00, .97247E+00, .96797E+00, .96350E+00, .95905E+00,
* .95464E+00, .95025E+00, .94589E+00, .94156E+00, .93727E+00,
* .93301E+00, .92879E+00, .92460E+00, .92045E+00, .91634E+00,
* .91227E+00, .90824E+00, .90425E+00, .90031E+00, .89641E+00,
* .89256E+00, .88876E+00, .88501E+00, .88132E+00, .87768E+00,
* .87410E+00, .87058E+00, .86712E+00, .86372E+00, .86039E+00,
* .85713E+00, .85395E+00, .85083E+00, .84780E+00, .84484E+00,
* .84197E+00, .83919E+00, .83650E+00, .83390E+00, .83141E+00,
* .82901E+00, .82672E+00, .82454E+00, .82248E+00, .82053E+00/
DATA AV51/
* .81871E+00, .81702E+00, .81547E+00, .81405E+00, .81278E+00,
* .81166E+00, .81069E+00, .80989E+00, .80925E+00, .80879E+00,
* .80851E+00, .80842E+00, .80852E+00, .80882E+00, .80932E+00,
* .81004E+00, .81098E+00, .81214E+00, .81353E+00, .81516E+00,
* .81704E+00, .81916E+00, .82154E+00, .82418E+00, .82708E+00,
* .83025E+00, .83370E+00, .83742E+00, .84143E+00, .84572E+00,
* .85029E+00, .85515E+00, .86030E+00, .86573E+00, .87146E+00,
* .87747E+00, .88376E+00, .89035E+00, .89721E+00, .90435E+00,
* .91176E+00, .91945E+00, .92741E+00, .93562E+00, .94409E+00,
* .95282E+00, .96179E+00, .97100E+00, .98044E+00, .99011E+00,
* .10000E+01, .10000E+01/
DATA CG01 /
* 1.00000E+00, 1.01822E+00, 1.03376E+00, 1.04777E+00, 1.06057E+00,
* 1.07231E+00, 1.08310E+00, 1.09300E+00, 1.10204E+00, 1.11025E+00,
* 1.11766E+00, 1.12429E+00, 1.13014E+00, 1.13523E+00, 1.13955E+00,
* 1.14313E+00, 1.14595E+00, 1.14803E+00, 1.14936E+00, 1.14994E+00,
* 1.14978E+00, 1.14888E+00, 1.14723E+00, 1.14484E+00, 1.14170E+00,
* 1.13782E+00, 1.13319E+00, 1.12782E+00, 1.12171E+00, 1.11485E+00,
* 1.10726E+00, 1.09893E+00, 1.08986E+00, 1.08006E+00, 1.06953E+00,
* 1.05828E+00, 1.04631E+00, 1.03363E+00, 1.02024E+00, 1.00617E+00,
* 9.91403E-01, 9.75966E-01, 9.59868E-01, 9.43123E-01, 9.25745E-01,
* 9.07752E-01, 8.89162E-01, 8.69994E-01, 8.50272E-01, 8.30017E-01/
DATA CG51 /
* 8.09256E-01, 7.88017E-01, 7.66327E-01, 7.44219E-01, 7.21726E-01,
* 6.98886E-01, 6.75729E-01, 6.52299E-01, 6.28637E-01, 6.04787E-01,
* 5.80794E-01, 5.56704E-01, 5.32565E-01, 5.08428E-01, 4.84343E-01,
* 4.60364E-01, 4.36543E-01, 4.12933E-01, 3.89589E-01, 3.66564E-01,
* 3.43913E-01, 3.21688E-01, 2.99940E-01, 2.78720E-01, 2.58077E-01,
* 2.38056E-01, 2.18701E-01, 2.00053E-01, 1.82148E-01, 1.65021E-01,
* 1.48701E-01, 1.33213E-01, 1.18579E-01, 1.04815E-01, 9.19338E-02,
* 7.99428E-02, 6.88453E-02, 5.86399E-02, 4.93211E-02, 4.08796E-02,
* 3.33018E-02, 2.65710E-02, 2.06669E-02, 1.55667E-02, 1.12449E-02,
* 7.67360E-03, 4.82345E-03, 2.66344E-03, 1.16151E-03, 2.84798E-04,
* 0. , 0. /
DATA CFA01 /
* 0. ,-2.56288E-03,-3.05202E-03,-2.50689E-03,-1.18504E-03,
* 7.84668E-04, 3.32528E-03, 6.38605E-03, 9.93124E-03, 1.39345E-02,
* 1.83758E-02, 2.32392E-02, 2.85120E-02, 3.41837E-02, 4.02454E-02,
* 4.66897E-02, 5.35099E-02, 6.07003E-02, 6.82556E-02, 7.61711E-02,
* 8.44422E-02, 9.30647E-02, 1.02034E-01, 1.11348E-01, 1.21000E-01,
* 1.30988E-01, 1.41307E-01, 1.51952E-01, 1.62921E-01, 1.74208E-01,
* 1.85808E-01, 1.97716E-01, 2.09927E-01, 2.22436E-01, 2.35236E-01,
* 2.48321E-01, 2.61684E-01, 2.75318E-01, 2.89215E-01, 3.03367E-01,
* 3.17764E-01, 3.32399E-01, 3.47260E-01, 3.62338E-01, 3.77620E-01,
* 3.93096E-01, 4.08752E-01, 4.24575E-01, 4.40550E-01, 4.56665E-01/
DATA CFA51 /
* 4.72901E-01, 4.89244E-01, 5.05675E-01, 5.22177E-01, 5.38731E-01,
* 5.55315E-01, 5.71913E-01, 5.88502E-01, 6.05059E-01, 6.21561E-01,
* 6.37986E-01, 6.54308E-01, 6.70504E-01, 6.86549E-01, 7.02417E-01,
* 7.18083E-01, 7.33520E-01, 7.48703E-01, 7.63607E-01, 7.78204E-01,
* 7.92472E-01, 8.06384E-01, 8.19918E-01, 8.33050E-01, 8.45759E-01,
* 8.58025E-01, 8.69828E-01, 8.81151E-01, 8.91979E-01, 9.02298E-01,
* 9.12097E-01, 9.21366E-01, 9.30098E-01, 9.38289E-01, 9.45935E-01,
* 9.53036E-01, 9.59594E-01, 9.65613E-01, 9.71101E-01, 9.76064E-01,
* 9.80513E-01, 9.84460E-01, 9.87919E-01, 9.90904E-01, 9.93432E-01,
* 9.95519E-01, 9.97184E-01, 9.98445E-01, 9.99322E-01, 9.99834E-01,
* 1.00000E+00, 1.00000E+00/
DATA CFB01 /
* 0. , 1.15907E-02, 2.32978E-02, 3.51022E-02, 4.69967E-02,
* 5.89773E-02, 7.10411E-02, 8.31858E-02, 9.54097E-02, 1.07711E-01,
* 1.20089E-01, 1.32541E-01, 1.45066E-01, 1.57663E-01, 1.70330E-01,
* 1.83065E-01, 1.95868E-01, 2.08737E-01, 2.21669E-01, 2.34664E-01,
* 2.47718E-01, 2.60830E-01, 2.73998E-01, 2.87219E-01, 3.00491E-01,
* 3.13812E-01, 3.27178E-01, 3.40587E-01, 3.54035E-01, 3.67520E-01,
* 3.81037E-01, 3.94583E-01, 4.08155E-01, 4.21747E-01, 4.35356E-01,
* 4.48978E-01, 4.62606E-01, 4.76237E-01, 4.89864E-01, 5.03482E-01,
* 5.17086E-01, 5.30669E-01, 5.44225E-01, 5.57746E-01, 5.71226E-01,
* 5.84657E-01, 5.98032E-01, 6.11342E-01, 6.24580E-01, 6.37736E-01/
DATA CFB51 /
* 6.50802E-01, 6.63769E-01, 6.76626E-01, 6.89365E-01, 7.01974E-01,
* 7.14444E-01, 7.26764E-01, 7.38924E-01, 7.50912E-01, 7.62717E-01,
* 7.74328E-01, 7.85735E-01, 7.96925E-01, 8.07888E-01, 8.18612E-01,
* 8.29087E-01, 8.39302E-01, 8.49246E-01, 8.58910E-01, 8.68284E-01,
* 8.77358E-01, 8.86125E-01, 8.94577E-01, 9.02706E-01, 9.10506E-01,
* 9.17972E-01, 9.25100E-01, 9.31885E-01, 9.38325E-01, 9.44419E-01,
* 9.50166E-01, 9.55568E-01, 9.60625E-01, 9.65340E-01, 9.69718E-01,
* 9.73763E-01, 9.77481E-01, 9.80878E-01, 9.83962E-01, 9.86741E-01,
* 9.89223E-01, 9.91419E-01, 9.93337E-01, 9.94989E-01, 9.96385E-01,
* 9.97536E-01, 9.98452E-01, 9.99146E-01, 9.99628E-01, 9.99909E-01,
* 1.00000E+00, 1.00000E+00/
DATA CFC01 /
* 0. , 9.88700E-03, 1.98515E-02, 2.99036E-02, 4.00474E-02,
* 5.02856E-02, 6.06200E-02, 7.10521E-02, 8.15830E-02, 9.22137E-02,
* 1.02945E-01, 1.13778E-01, 1.24712E-01, 1.35749E-01, 1.46889E-01,
* 1.58132E-01, 1.69478E-01, 1.80928E-01, 1.92480E-01, 2.04136E-01,
* 2.15894E-01, 2.27754E-01, 2.39716E-01, 2.51780E-01, 2.63943E-01,
* 2.76205E-01, 2.88564E-01, 3.01020E-01, 3.13571E-01, 3.26214E-01,
* 3.38948E-01, 3.51771E-01, 3.64679E-01, 3.77670E-01, 3.90741E-01,
* 4.03888E-01, 4.17108E-01, 4.30397E-01, 4.43750E-01, 4.57162E-01,
* 4.70628E-01, 4.84142E-01, 4.97700E-01, 5.11293E-01, 5.24915E-01,
* 5.38560E-01, 5.52218E-01, 5.65882E-01, 5.79542E-01, 5.93190E-01/
DATA CFC51 /
* 6.06816E-01, 6.20408E-01, 6.33957E-01, 6.47451E-01, 6.60877E-01,
* 6.74223E-01, 6.87477E-01, 7.00624E-01, 7.13651E-01, 7.26544E-01,
* 7.39288E-01, 7.51868E-01, 7.64268E-01, 7.76474E-01, 7.88470E-01,
* 8.00240E-01, 8.11768E-01, 8.23041E-01, 8.34042E-01, 8.44756E-01,
* 8.55171E-01, 8.65271E-01, 8.75044E-01, 8.84478E-01, 8.93562E-01,
* 9.02285E-01, 9.10639E-01, 9.18616E-01, 9.26210E-01, 9.33414E-01,
* 9.40227E-01, 9.46644E-01, 9.52666E-01, 9.58293E-01, 9.63528E-01,
* 9.68373E-01, 9.72833E-01, 9.76915E-01, 9.80625E-01, 9.83973E-01,
* 9.86967E-01, 9.89617E-01, 9.91935E-01, 9.93933E-01, 9.95622E-01,
* 9.97015E-01, 9.98125E-01, 9.98965E-01, 9.99549E-01, 9.99889E-01,
* 1.00000E+00, 1.00000E+00/
DATA CER01 /
* 0. ,-2.11394E-02,-4.08818E-02,-5.97585E-02,-7.79266E-02,
* -9.54663E-02,-1.12425E-01,-1.28834E-01,-1.44713E-01,-1.60076E-01,
* -1.74933E-01,-1.89289E-01,-2.03149E-01,-2.16515E-01,-2.29388E-01,
* -2.41768E-01,-2.53653E-01,-2.65043E-01,-2.75936E-01,-2.86328E-01,
* -2.96217E-01,-3.05601E-01,-3.14476E-01,-3.22839E-01,-3.30686E-01,
* -3.38015E-01,-3.44822E-01,-3.51105E-01,-3.56859E-01,-3.62083E-01,
* -3.66773E-01,-3.70928E-01,-3.74546E-01,-3.77625E-01,-3.80164E-01,
* -3.82161E-01,-3.83618E-01,-3.84534E-01,-3.84911E-01,-3.84749E-01,
* -3.84051E-01,-3.82821E-01,-3.81062E-01,-3.78778E-01,-3.75976E-01,
* -3.72663E-01,-3.68845E-01,-3.64532E-01,-3.59733E-01,-3.54461E-01/
DATA CER51 /
* -3.48726E-01,-3.42543E-01,-3.35927E-01,-3.28893E-01,-3.21461E-01,
* -3.13650E-01,-3.05477E-01,-2.96967E-01,-2.88142E-01,-2.79029E-01,
* -2.69652E-01,-2.60040E-01,-2.50221E-01,-2.40225E-01,-2.30084E-01,
* -2.19829E-01,-2.09493E-01,-1.99109E-01,-1.88712E-01,-1.78335E-01,
* -1.68014E-01,-1.57782E-01,-1.47673E-01,-1.37721E-01,-1.27957E-01,
* -1.18414E-01,-1.09120E-01,-1.00105E-01,-9.13939E-02,-8.30122E-02,
* -7.49818E-02,-6.73226E-02,-6.00518E-02,-5.31840E-02,-4.67313E-02,
* -4.07029E-02,-3.51053E-02,-2.99424E-02,-2.52153E-02,-2.09229E-02,
* -1.70614E-02,-1.36249E-02,-1.06056E-02,-7.99360E-03,-5.77750E-03,
* -3.94443E-03,-2.48028E-03,-1.36995E-03,-5.97540E-04,-1.46532E-04,
* 0. , 0. /
C
END
SUBROUTINE RSYM (R,DV,VFT) 3
C
IMPLICIT REAL*8 (V)
C
DIMENSION R(*)
C
IP = (-VFT/DV)+1.-.000001
IP = IP+1
P = (FLOAT(IP-1)+VFT/DV)*2.
PST = P
IF (P.GT.1.) P = P-1.
C
C VFT/DV- INT(VFT/DV)= 0. TO 0.5
C
WN1 = -P*(P-1.)*(P-2.)/6.
W0 = (P*P-1.)*(P-2.)/2.
W1 = -P*(P+1.)*(P-2.)/2.
W2 = P*(P*P-1.)/6.
K = IP
IPMAX = IP+IP-1
IF (PST.LE.1.) GO TO 20
B1 = R(IP-2)
B2 = R(IP-1)
C1 = R(K)
DO 10 I = IP, IPMAX
K = K-1
C2 = C1
IF (K.LT.1) GO TO 40
C1 = R(K)
R(K) = R(K)+WN1*R(I+1)+W0*R(I)+W1*B2+W2*B1
B1 = B2
B2 = R(I)
IF (K.LE.2) GO TO 10
R(I) = R(I)+WN1*C2+W0*C1+W1*R(K-1)+W2*R(K-2)
10 CONTINUE
GO TO 40
C
C VFT/DV- INT(VFT/DV) = 0.5 TO 1.0
C
20 C1 = R(IP)
C2 = R(IP+1)
B2 = R(IP-1)
DO 30 I = IP, IPMAX
K = K-1
B1 = B2
B2 = R(I)
IF (K.LE.1) GO TO 40
R(I) = R(I)+WN1*C2+W0*C1+W1*R(K)+W2*R(K-1)
C2 = C1
C1 = R(K)
R(K) = R(K)+WN1*R(I+2)+W0*R(I+1)+W1*B2+W2*B1
30 CONTINUE
C
40 RETURN
C
END
SUBROUTINE XINT (V1A,V2A,DVA,A,AFACT,VFT,DVR3,R3,N1R3,N2R3) 20
C
IMPLICIT REAL*8 (V)
C
C THIS SUBROUTINE INTERPOLATES THE A ARRAY STORED
C FROM V1A TO V2A IN INCREMENTS OF DVA USING A MULTIPLICATIVE
C FACTOR AFACT, INTO THE R3 ARRAY FROM LOCATION N1R3 TO N2R3 IN
C INCREMENTS OF DVR3
C
COMMON /LAMCHN/ ONEPL,ONEMI,EXPMIN,ARGMIN
DIMENSION A(*),R3(*)
C
RECDVA = 1./DVA
ILO = (V1A+DVA-VFT)/DVR3+1.+ONEMI
ILO = MAX(ILO,N1R3)
IHI = (V2A-DVA-VFT)/DVR3+ONEMI
IHI = MIN(IHI,N2R3)
C
DO 10 I = ILO, IHI
VI = VFT+DVR3*FLOAT(I-1)
J = (VI-V1A)*RECDVA+ONEPL
VJ = V1A+DVA*FLOAT(J-1)
P = RECDVA*(VI-VJ)
C = (3.-2.*P)*P*P
B = 0.5*P*(1.-P)
B1 = B*(1.-P)
B2 = B*P
CONTI = -A(J-1)*B1+A(J)*(1.-C+B2)+A(J+1)*(C+B1)-A(J+2)*B2
R3(I) = R3(I)+CONTI*AFACT
10 CONTINUE
C
RETURN
C
END
FUNCTION RADFN (VI,XKT) 19
C
IMPLICIT REAL*8 (V)
C
C FUNCTION RADFN CALCULATES THE RADIATION TERM FOR THE LINE SHAPE
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C LAST MODIFICATION: 12 AUGUST 1991
C
C IMPLEMENTATION: R.D. WORSHAM
C
C ALGORITHM REVISIONS: S.A. CLOUGH
C R.D. WORSHAM
C J.L. MONCET
C
C
C ATMOSPHERIC AND ENVIRONMENTAL RESEARCH INC.
C 840 MEMORIAL DRIVE, CAMBRIDGE, MA 02139
C
C----------------------------------------------------------------------
C
C WORK SUPPORTED BY: THE ARM PROGRAM
C OFFICE OF ENERGY RESEARCH
C DEPARTMENT OF ENERGY
C
C
C SOURCE OF ORIGINAL ROUTINE: AFGL LINE-BY-LINE MODEL
C
C FASCOD3
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
COMMON /LAMCHN/ ONEPL,ONEMI,EXPMIN,ARGMIN
C
C IN THE SMALL XVIOKT REGION 0.5 IS REQUIRED
C
XVI = VI
C
IF (XKT.GT.0.0) THEN
C
XVIOKT = XVI/XKT
C
IF (XVIOKT.LE.0.01) THEN
RADFN = 0.5*XVIOKT*XVI
C
ELSEIF (XVIOKT.LE.10.0) THEN
EXPVKT = EXP(-XVIOKT)
RADFN = XVI*(1.-EXPVKT)/(1.+EXPVKT)
C
ELSE
RADFN = XVI
ENDIF
C
ELSE
RADFN = XVI
ENDIF
C
RETURN
C
END
FUNCTION RADFNI (VI,DVI,XKT,VINEW,RDEL,RDLAST) 49
C
IMPLICIT REAL*8 (V)
C
C FUNCTION RADFNI CALCULATES THE RADIATION TERM FOR THE LINE SHAPE
C OVER INTERVAL VI TO VINEW
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C LAST MODIFICATION: 23 AUGUST 1991
C
C IMPLEMENTATION: R.D. WORSHAM
C
C ALGORITHM REVISIONS: S.A. CLOUGH
C R.D. WORSHAM
C J.L. MONCET
C
C
C ATMOSPHERIC AND ENVIRONMENTAL RESEARCH INC.
C 840 MEMORIAL DRIVE, CAMBRIDGE, MA 02139
C
C----------------------------------------------------------------------
C
C WORK SUPPORTED BY: THE ARM PROGRAM
C OFFICE OF ENERGY RESEARCH
C DEPARTMENT OF ENERGY
C
C
C SOURCE OF ORIGINAL ROUTINE: AFGL LINE-BY-LINE MODEL
C
C FASCOD3
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
COMMON /LAMCHN/ ONEPL,ONEMI,EXPMIN,ARGMIN
DATA FACT1 / 3.0E-03 /
C
C RADFNI IS COMPUTED AT VI AND AND CALCULATES THE
C WAVENUMBER VALUE (VINEW) FOR NEXT RADFNI CALC.
C
C IN THE SMALL XVIOKT REGION 0.5 IS REQUIRED
C
XVI = VI
C
C IF FIRST CALL, INITIALIZE RDLAST
C
IF (RDLAST.LT.0.) THEN
IF (XKT.GT.0.0) THEN
XVIOKT = XVI/XKT
C
IF (XVIOKT.LE.0.01) THEN
RDLAST = 0.5*XVIOKT*XVI
C
ELSEIF (XVIOKT.LE.10.0) THEN
EXPVKT = EXP(-XVIOKT)
RDLAST = XVI*(1.-EXPVKT)/(1.+EXPVKT)
C
ELSE
RDLAST = XVI
ENDIF
ELSE
RDLAST = XVI
ENDIF
ENDIF
C
C SET RADFNI EQUAL TO RADIATION FUNCTION AT VI
C
C RDLAST IS RADFNI(VI) FOR EACH SUBSEQUENT CALL
C
RADFNI = RDLAST
C
INTVLS = 1
IF (XKT.GT.0.0) THEN
C
XVIOKT = XVI/XKT
C
IF (XVIOKT.LE.0.01) THEN
IF (VINEW.GE.0.0) THEN
VINEW = VI+FACT1*0.5*XVI
INTVLS = (VINEW-VI)/DVI
INTVLS = MAX(INTVLS,1)
VINEW = VI+DVI*FLOAT(INTVLS)
ELSE
VINEW = ABS(VINEW)
INTVLS = (VINEW-VI)/DVI
INTVLS = MAX(INTVLS,1)
ENDIF
XVINEW = VINEW
C
RDNEXT = 0.5*XVIOKT*XVINEW
C
ELSEIF (XVIOKT.LE.10.0) THEN
EXPVKT = EXP(-XVIOKT)
XMINUS = 1.-EXPVKT
XPLUS = 1.+EXPVKT
IF (VINEW.GE.0.0) THEN
CVIKT = XVIOKT*EXPVKT
VINEW = VI+FACT1*XVI/(1.+(CVIKT/XMINUS+CVIKT/XPLUS))
INTVLS = (VINEW-VI)/DVI
INTVLS = MAX(INTVLS,1)
VINEW = VI+DVI*FLOAT(INTVLS)
ELSE
VINEW = ABS(VINEW)
INTVLS = (VINEW-VI)/DVI
INTVLS = MAX(INTVLS,1)
ENDIF
XVINEW = VINEW
C
RDNEXT = XVINEW*XMINUS/XPLUS
C
ELSE
IF (VINEW.GE.0.0) THEN
VINEW = VI+(FACT1*XVI)
INTVLS = (VINEW-VI)/DVI
INTVLS = MAX(INTVLS,1)
VINEW = VI+DVI*FLOAT(INTVLS)
ELSE
VINEW = ABS(VINEW)
INTVLS = (VINEW-VI)/DVI
INTVLS = MAX(INTVLS,1)
ENDIF
XVINEW = VINEW
C
RDNEXT = XVINEW
ENDIF
ELSE
IF (VINEW.GE.0.0) THEN
VINEW = VI+(FACT1*XVI)
INTVLS = (VINEW-VI)/DVI
INTVLS = MAX(INTVLS,1)
VINEW = VI+DVI*FLOAT(INTVLS)
ELSE
VINEW = ABS(VINEW)
INTVLS = (VINEW-VI)/DVI
INTVLS = MAX(INTVLS,1)
ENDIF
XVINEW = VINEW
C
RDNEXT = XVI
ENDIF
C
RDEL = (RDNEXT-RADFNI)/FLOAT(INTVLS)
C
RDLAST = RDNEXT
C
RETURN
C
END
SUBROUTINE MOLEC (IND,SCOR,RHOSLF,ALFD1) 4,3
C
IMPLICIT REAL*8 (V)
C
PARAMETER (NTMOL=36,Nspeci=85)
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /ISVECT/ ISOVEC(NTMOL),ISO82(NSPECI),ISONM(NTMOL),
* SMASSI(NSPECI)
COMMON /QTOT/ QCOEF(NSPECI,3,5),Q296(NSPECI),AQ(NSPECI),
* BQ(NSPECI),GJ(NSPECI)
COMMON /MANE/ P0,TEMP0,NLAYRS,DVXM,H2OSLF,WTOT,ALBAR,ADBAR,AVBAR,
* AVFIX,LAYRFX,SECNT0,SAMPLE,DVSET,ALFAL0,AVMASS,
* DPTMIN,DPTFAC,ALTAV,AVTRAT,TDIFF1,TDIFF2,ALTD1,
* ALTD2,ANGLE,IANT,LTGNT,LH1,LH2,IPFLAG,PLAY,TLAY,
* EXTID(10)
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SECANT, XALTZ
C
COMMON /FILHDR/ XID(10),SECANT,P ,TEMP,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DV ,V1 ,V2 ,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
COMMON /CONSTS/ PI,PLANCK,BOLTZ,CLIGHT,AVOG,RADCN1,RADCN2
DIMENSION SCOR(*),RHOSLF(*),ALFD1(*)
COMMON /SMOLEC/ W(42,9),ND(42,9),FAD
COMMON /XMOLEC/ NV(42),IVIB(42,2,9),XR(42),ROTFAC(42),QV0(42)
COMMON /MOLNAM/ MOLID(0:NTMOL)
CHARACTER*6 MOLID
C
C IS EQUIV. TO THE FOLLOWING DIMENSION AND EQUIVALENT STATEMENTS
C
DIMENSION IV(2)
EQUIVALENCE (IV(1),IVIB(1,1,1))
C
DATA MDIM / 42 /,NVDIM / 9 /
C
c
c
c Program TIPS written by R.R. Gamache
c
c This is an updated version of TIPS: TIPS_97
c obtained from R.R. Gamache on 28 April 1998
c
c***************
c
c Modifications have been made to the partition sums for
c hno3, c2h6, sf6, o, and clono2 by tony clough on 30 april 98,
c based on data provided by R. Gamache.
c
c***************
c
c This program enables the user to calculate the Total Internal
c Partition Sum (TIPS) for a given molecule, isotopic variant, and
c temperature. Current limitations are the molecular species on the
c HITRAN molecular database and the temperature range 70 - 3000 K.
c
c...This program calculates the TIPS by the formula
c... Q(T) = A + B*T + C*T*T + D*T*T*T + E*T*T*T*T
c...Reference: R.R. Gamache, R.L. Hawkins, and L.S. Rothman,
c J.Mol.Spectrosc. 142, 205-219 (1990)
c
c Program modified by Tony Clough
c
c Converted to single precision
c
c Substantive changes have retained original record as comment with c%
c
C THIS PROGRAM ENABLES THE USER TO CALCULATE THE TOTAL INTERNAL
C PARTITION SUM (TIPS) FOR A GIVEN MOLECULE, ISOTOPIC SPECIES,
C AND TEMPERATURE. CURRENT LIMITATIONS ARE THE MOLECULAR SPECIES
C ON THE HITRAN MOLECULAR DATABASE AND THE TEMPERATURE RANGE
C 70 - 3000 K.
C
C MOLEC MAKES THE MOLECULAR IDENTIFICATIONS
C
C SCOR IS THE FACTOR BY WHICH THE LINE INTENSITY IS CHANGED DUE TO
C TEMPERATURE DEPENDENCE OF THE VIB AND ROT PARTITION SUMS
C
C RHOSLF IS A QUANTITY ('PARTIAL DENSITY') FOR CORRECTING THE
C COLLISION WIDTH FOR SELF BROADENING
C
C ALFD1 CONTAINS THE DOPPLER WIDTHS AT 1 CM-1
C
IF (IND.EQ.1) THEN
c
c...Set up molecule isotope vectors:
c
CALL vecIso
c
c 5 WRITE (IPR,'(8x,A,/,8x,A////////////)')
c + 'This program calculates the Total Internal Partition Sum'
c +,' for the molecular species on the HITRAN database.'
c%%
C
DO 10 M = 1, NMOL
READ (MOLID(M),900) HMOLID(M)
10 CONTINUE
C
FLN2 = ALOG(2.)
FAD = FLN2*2.*AVOG*BOLTZ/(CLIGHT*CLIGHT)
XKT0 = TEMP0/RADCN2
C
DO 30 M = 1, MDIM
DO 20 K = 1, NVDIM
LOC = 2*MDIM*(K-1)+2*(M-1)
W(M,K) = IV(LOC+1)
ND(M,K) = IV(LOC+2)
20 CONTINUE
NVM = NV(M)
30 CONTINUE
RETURN
ELSE
C
RHORAT = (P/P0)*(TEMP0/TEMP)
XKT = TEMP/RADCN2
C
DO 50 M = 1, NMOL
C
DO 40 ISO = 1, ISONM(M)
ILOC = ISOVEC(M)+ISO
c
CALL QOFT (M,ISO,296.,QT_296)
CALL QOFT (M,ISO,TEMP,QT)
SCOR(iloc) = QT_296/QT
c Stop program if covering a molecule and isotope
c not valid for T > 500K.
if ((iloc.ge.29).and.(wk(m).gt.0.).and.
* (TEMP.GT.500.)) then
write(ipr,*) 'TIPS calculation of Isotope ',
* iso82(iloc),' for molecule ',m,
* ' not valid for T = ',TEMP
write(*,*) 'TIPS calculation of Isotope ',
* iso82(iloc),' for molecule ',m,
* ' not valid for T = ',TEMP
stop 'SUBROUTINE MOLEC'
endif
c Stop program if covering a molecule of nonzero amount
c and which has an isotope with no TIPs coefficients.
if ((scor(iloc).lt.0.).and.(wk(m).gt.0.)) then
write(ipr,*) 'Isotope ',iso82(iloc),' for molecule ',
* m,' not included in TIPs'
write(*,*) 'Isotope ',iso82(iloc),' for molecule ',
* m,' not included in TIPs'
stop 'SUBROUTINE MOLEC'
endif
RHOSLF(ILOC) = RHORAT*WK(M)/WTOT
ALFD1(ILOC) = SQRT(FAD*TEMP/SMASSI(ILOC))
40 CONTINUE
50 CONTINUE
C RETURN
C
ENDIF
C
900 FORMAT (A6)
C
END
BLOCK DATA BMOLEC
C
COMMON /XMOLEC/
2 NV1(7),NV2(7),NV3(7),NV4(7),NV5(7),NV6(7),
3 IV11(14),IV12(14),IV13(14),IV14(14),IV15(14),IV16(14),
4 IV21(14),IV22(14),IV23(14),IV24(14),IV25(14),IV26(14),
5 IV31(14),IV32(14),IV33(14),IV34(14),IV35(14),IV36(14),
6 IV41(14),IV42(14),IV43(14),IV44(14),IV45(14),IV46(14),
7 IV51(14),IV52(14),IV53(14),IV54(14),IV55(14),IV56(14),
8 IV61(14),IV62(14),IV63(14),IV64(14),IV65(14),IV66(14),
9 IV71(14),IV72(14),IV73(14),IV74(14),IV75(14),IV76(14),
* IV81(14),IV82(14),IV83(14),IV84(14),IV85(14),IV86(14),
1 IV91(14),IV92(14),IV93(14),IV94(14),IV95(14),IV96(14),
2 XR1(7),XR2(7),XR3(7),XR4(7),XR5(7),XR6(7),
3 ROTFC1(7),ROTFC2(7),ROTFC3(7),ROTFC4(7),ROTFC5(7),ROTFC6(7),
4 QV0(42)
C
DATA NV1,IV11,IV21,IV31,IV41,IV51,IV61,IV71,IV81,IV91,XR1,ROTFC1/
C
C H2O CO2 O3 N2O CO CH4 O2
C 3 , 3 , 3 , 3 , 1 , 4 , 1 ,
1 3657,1 , 1388,1 , 1103,1 , 1285,1 , 2143,1 , 2917,1 , 1556,1 ,
2 1595,1 , 667,2 , 701,1 , 589,2 , 0,0 , 1533,2 , 0,0 ,
3 3756,1 , 2349,1 , 1042,1 , 2224,1 , 0,0 , 3019,3 , 0,0 ,
4 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 1311,3 , 0,0 ,
5 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
6 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
7 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
8 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
9 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
X 0.5 , 0.25, 0.5 , 0.5 , 0.5 , 0.5 , 0.5 ,
Y 1.5 , 1.0 , 1.5 , 1.0 , 1.0 , 1.5 , 1.0 /
C
DATA NV2,IV12,IV22,IV32,IV42,IV52,IV62,IV72,IV82,IV92,XR2,ROTFC2/
C
C NO SO2 NO2 NH3 HNO3 OH HF
C 1 , 3 , 3 , 4 , 9 , 1 , 1 ,
1 1876,1 , 1152,1 , 1318,1 , 3337,1 , 3550,1 , 3569,1 , 3961,1 ,
2 0,0 , 518,1 , 750,1 , 950,1 , 1710,1 , 0,0 , 0,0 ,
3 0,0 , 1362,1 , 1617,1 , 3444,2 , 1331,1 , 0,0 , 0,0 ,
4 0,0 , 0,0 , 0,0 , 1627,2 , 1325,1 , 0,0 , 0,0 ,
5 0,0 , 0,0 , 0,0 , 0,0 , 879,1 , 0,0 , 0,0 ,
6 0,0 , 0,0 , 0,0 , 0,0 , 647,1 , 0,0 , 0,0 ,
7 0,0 , 0,0 , 0,0 , 0,0 , 579,1 , 0,0 , 0,0 ,
8 0,0 , 0,0 , 0,0 , 0,0 , 762,1 , 0,0 , 0,0 ,
9 0,0 , 0,0 , 0,0 , 0,0 , 456,1 , 0,0 , 0,0 ,
X 0.5 , 0.5 , 0.5 , 0.5 , 0.5 , 0.5 , 0.5 ,
Y 1.0 , 1.5 , 1.5 , 1.5 , 1.5 , 1.0 , 1.0 /
C
DATA NV3,IV13,IV23,IV33,IV43,IV53,IV63,IV73,IV83,IV93,XR3,ROTFC3/
C
C HCL HBR HI CLO OCS H2CO HOCL
C 1 , 1 , 1 , 1 , 3 , 6 , 3 ,
1 2885,1 , 2558,1 , 2229,1 , 842,1 , 859,1 , 2782,1 , 3609,1 ,
2 0,0 , 0,0 , 0,0 , 0,0 , 520,2 , 1746,1 , 1238,1 ,
3 0,0 , 0,0 , 0,0 , 0,0 , 2062,1 , 1500,1 , 740,1 ,
4 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 1167,1 , 0,0 ,
5 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 2843,1 , 0,0 ,
6 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 1249,1 , 0,0 ,
7 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
8 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
9 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
X 0.5 , 0.5 , 0.5 , 0.25, 0.5 , 0.5 , 0.5 ,
Y 1.0 , 1.0 , 1.0 , 1.0 , 1.0 , 1.5 , 1.5 /
C
DATA NV4,IV14,IV24,IV34,IV44,IV54,IV64,IV74,IV84,IV94,XR4,ROTFC4/
C
C N2 HCN CH3CL H2O2 C2H2 C2H6 PH3
C 1 , 3 , 6 , 6 , 5 , 9 , 4 ,
1 2330,1 , 2089,1 , 2968,1 , 3607,1 , 3374,1 , 2899,1 , 2327,1 ,
2 0,0 , 713,2 , 1355,1 , 1394,1 , 1974,1 , 1375,1 , 992,1 ,
3 0,0 , 3311,1 , 732,1 , 864,1 , 3295,1 , 993,1 , 1118,2 ,
4 0,0 , 0,0 , 3039,2 , 317,1 , 612,2 , 275,1 , 2421,2 ,
5 0,0 , 0,0 , 1455,2 , 3608,1 , 730,2 , 2954,1 , 0,0 ,
6 0,0 , 0,0 , 1015,2 , 1269,1 , 0,0 , 1379,1 , 0,0 ,
7 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 2994,2 , 0,0 ,
8 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 1486,1 , 0,0 ,
9 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 822,2 , 0,0 ,
X 0.5 , 0.5 , 0.5 , 0.5 , 0.5 , 0.5 , 0.5 ,
Y 1.0 , 1.0 , 1.5 , 1.5 , 1.0 , 1.5 , 1.5 /
C
DATA NV5,IV15,IV25,IV35,IV45,IV55,IV65,IV75,IV85,IV95,XR5,ROTFC5/
C
C COF2 SF6 H2S HCOOH HO2 O CLONO2
C 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
1 0000,1 , 0000,0 , 0000,0 , 0000,0 , 0000,0 , 0000,0 , 0000,0 ,
2 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
3 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
4 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
5 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
6 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
7 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
8 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
9 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
X 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 ,
Y 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 /
C
DATA NV6,IV16,IV26,IV36,IV46,IV56,IV66,IV76,IV86,IV96,XR6,ROTFC6/
C
C NO+ ??? ??? ??? ??? ??? ???
C 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
1 0000,1 , 0000,0 , 0000,0 , 0000,0 , 0000,0 , 0000,0 , 0000,0 ,
2 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
3 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
4 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
5 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
6 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
7 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
8 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
9 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 , 0,0 ,
X 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 ,
Y 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 , 0.0 /
C
END
FUNCTION QV (M,XKT,W,ND,NV,MDIM,NVDIM)
C
C FUNCTION QV CALCULATES THE VIBRATIONAL PARTITION SUM
C
DIMENSION W(MDIM,NVDIM),ND(MDIM,NVDIM)
QV = 1.
DO 10 I = 1, NV
SV = 1.-EXP(-W(M,I)/XKT)
IF (ND(M,I).GT.1) SV = SV**ND(M,I)
QV = QV/SV
10 CONTINUE
C
RETURN
C
END
c***********************************************
SUBROUTINE vecIso 2
c***********************************************
c
PARAMETER (NMOL=36,Nspeci=85)
COMMON /ISVECT/ ISOVEC(NMOL),ISO82(Nspeci),ISONM(NMOL),
* sdum(Nspeci)
c
c...Isotope vector information
c Set up ISOVEC:
ISOVEC(1) = 0
DO 20 I = 2,NMOL
ISOVEC(I) = 0
DO 10 J = 1,I-1
ISOVEC(I) = ISOVEC(I)+ISONM(J)
10 CONTINUE
20 CONTINUE
c
RETURN
END
c ****************************************
BLOCK DATA Isotop
c ****************************************
C$$ IMPLICIT DOUBLE PRECISION (a-h,o-z)
c
PARAMETER (NMOL=36,Nspeci=85)
COMMON /ISVECT/ ISOVEC(NMOL),ISO82(Nspeci),ISONM(NMOL),
* smassi(Nspeci)
c
c The number of isotopes for a particular molecule:
DATA (ISONM(I),I=1,NMOL)/
c H2O, CO2, O3, N2O, CO, CH4, O2,
+ 4, 8, 5, 5, 6, 3, 3,
c NO, SO2, NO2, NH3, HNO3, OH, HF, HCl, HBr, HI,
+ 3, 2, 1, 2, 1, 3, 1, 2, 2, 1,
c ClO, OCS, H2CO, HOCl, N2, HCN, CH3Cl, H2O2, C2H2, C2H6, PH3
+ 2, 4, 3, 2, 1, 3, 2, 1, 2, 1, 1,
c COF2, SF6, H2S, HCOOH, HO2, O, ClONO2, NO+
+ 1, 1, 3, 1, 1, 1, 2, 1/
c
DATA ISO82/
c H2O
+ 161,181,171,162,
c CO2
+ 626,636,628,627,638,637,828,728,
c O3
+ 666,668,686,667,676,
c N2O
+ 446,456,546,448,447,
c CO, CH4
+ 26,36,28,27,38,37, 211,311,212,
c O2, NO, SO2
+ 66,68,67, 46,56,48 ,626,646,
c NO2, NH3, HNO3
+ 646, 4111,5111, 146,
c OH, HF, HCl, HBr, HI
+ 61,81,62, 19, 15,17, 19,11, 17,
c ClO, OCS, H2CO
+ 56,76, 622,624,632,822, 126,136,128,
c HOCl, N2, HCN
+ 165,167, 44, 124,134,125
c CH3Cl, H2O2, C2H2, C2H6, PH3
+,215,217, 1661, 1221,1231, 1221, 1111,
c COF2, SF6, H2S, HCOOH, HO2, O, ClONO2 NO+
+ 269, 29, 121,141,131, 126, 166, 6, 5646,7646, 46/
c
C
C MOLECULAR MASSES FOR EACH ISOTOPE
C
DATA SMASSI/
C H2O: 161, 181, 171, 162
* 18.01, 20.01, 19.01, 19.01,
C CO2: 626, 636, 628, 627, 638, 637, 828, 728
* 43.98, 44.98, 45.98, 44.98, 46.98, 45.98, 47.98, 46.98,
C O3: 666, 668, 686 667 676
* 47.97, 49.97, 49.97, 48.99, 48.99,
C N2O: 446, 456, 546, 448, 447
* 43.99, 44.99, 44.99, 45.99, 44.99,
C CO: 26, 36, 28, 27, 38 37
* 27.99, 28.99, 29.99, 28.99, 30.99, 30.00,
C CH4: 211, 311, 212; O2: 66, 68, 67
* 16.04, 17.04, 17.04, 31.98, 33.98, 32.98,
C NO: 46, 56, 48; SO2: 626, 646
* 29.99, 30.99, 31.99, 63.95, 65.95,
C NO2: 646; NH3: 4111, 5111; HNO3: 146
* 45.98, 17.03, 18.03, 62.98,
C OH: 61, 81, 62; HF: 19
* 17.00, 19.00, 18.00, 20.01,
C HCL: 15, 17; HBR: 19, 11; HI: 17
* 35.98, 37.98, 79.92, 81.92, 127.91,
C CLO: 56, 76; OCS: 622, 624, 632, 822
* 50.96, 52.96, 59.96, 61.96, 60.96, 61.96,
C H2CO: 126, 136, 128; HOCL: 165, 167
* 30.01, 31.01, 32.01, 51.97, 53.97,
C N2: 44; HCN: 124, 134, 125
* 28.00, 27.01, 28.01, 28.01,
C CH3CL: 215, 217; H2O2: 1661; C2H2: 1221, 1231
* 50.00, 52.00, 34.00, 26.02, 27.02,
C C2H6: 1221; PH3: 1111; COF2: 269; SF6: 29
* 30.06, 34.00, 65.99, 145.97,
C H2S: 121 141 131; HCOOH: 126; HO2: 166
* 33.99, 35.98, 34.99, 46.00, 33.00,
C O: 6 ClONO2:5646 7646; NO+: 46
* 15.99, 96.96, 98.95, 30.00 /
C
END
c
C*******************************************
SUBROUTINE QofT(Mol, Iso, Tout, QT) 2
C*******************************************
c...date last changed: September 19, 1997
c
c...input - Mol, Iso, and a temperature Tout
c...output - Total internal partition sum, QT, at T=Tout
c
c$$$ IMPLICIT DOUBLE PRECISION (a-h,o-z)
c
c++
PARAMETER (NMOL=36,Nspeci=85)
c++
COMMON /ISVECT/ ISOVEC(NMOL),ISO82(Nspeci),ISONM(NMOL),
* sdum(Nspeci)
c++: bd-QT
common/Qtot/ Qcoef(Nspeci,3,5), Q296(Nspeci), aQ(Nspeci),
+ bQ(Nspeci), gj(Nspeci)
c
ivec = isovec(Mol) + iso
c
c...value depends on temperature range
IF (Tout.lt.70. .OR. Tout.gt.3005.) THEN
QT = -1.
WRITE (*,*) ' OUT OF TEMPERATURE RANGE'
GOTO 99
ENDIF
IF (Tout .ge. 70. .and. Tout .le. 500.) irange = 1
IF (Tout .gt. 500. .and. Tout .le. 1500.) irange = 2
IF (Tout .gt. 1500.) irange = 3
c
QT = Qcoef(ivec,irange,1)
+ + Qcoef(ivec,irange,2)*Tout
+ + Qcoef(ivec,irange,3)*Tout*Tout
+ + Qcoef(ivec,irange,4)*Tout*Tout*Tout
+ + Qcoef(ivec,irange,5)*Tout*Tout*Tout*Tout
c
99 RETURN
END
c**************************************
BLOCK DATA QTdata
c**************************************
c$$$ IMPLICIT DOUBLE PRECISION (a-h,o-z)
c
c
c++
PARAMETER (NMOL=36,Nspeci=85)
c++: bd-QT
common/Qtot/ Qcoef(Nspeci,3,5), Q296(Nspeci), aQ(Nspeci),
+ bQ(Nspeci), gj(Nspeci)
c
c...State independent degeneracy factors: gj
c...(includes general nuclear factor (P(2I+1)), (2S+1), and (2-dl0)
c... when applicable)
c H2O CO2 O3
DATA gj/1.,1.,6.,6., 1.,2.,1.,6.,2.,12.,1.,6., 1.,1.,1.,6.,6.,
c N2O CO CH4 O2
+ 9.,6.,6.,9.,54., 1.,2.,1.,6.,2.,12., 1.,2.,3., 1.,1.,6.,
c NO SO2 NO2 NH3 HNO3 OH HF HCl
+ 1.,1.,1., 1.,1., 3., 3.,2., 6., 1.,1.,1., 4., 8.,8.,
c HBr HI ClO OCS H2CO HOCl N2
+ 8.,8., 12., 1.,1., 1.,1.,2.,1., 1.,2.,1., 8.,8., 1,
c HCN CH3Cl H2O2 C2H2 C2H6 PH3
+ 6.,12.,4., 4.,4., 1., 1.,8., 64., 2.,
c COF2, SF6, H2S, HCOOH
+ 1., 1., 1.,1.,4., 4.,
c HO2, O, ClONO2 NO+
+ 2., 1., 12.,12., 3./
c
c...Total internal partition sums for T<=70 to <=500 K range:
c... H2O -- 161
DATA (Qcoef( 1,1,j),j=1,5)/-.44405E+01, .27678E+00,
+ .12536E-02,-.48938E-06, 0. /
c... H2O -- 181
DATA (Qcoef( 2,1,j),j=1,5)/-.43624E+01, .27647E+00,
+ .12802E-02,-.52046E-06, 0. /
c... H2O -- 171
DATA (Qcoef( 3,1,j),j=1,5)/-.25767E+02, .16458E+01,
+ .76905E-02,-.31668E-05, 0. /
c... H2O -- 162
DATA (Qcoef( 4,1,j),j=1,5)/-.23916E+02, .13793E+01,
+ .61246E-02,-.21530E-05, 0. /
c... CO2 -- 626
DATA (Qcoef( 5,1,j),j=1,5)/-.13617E+01, .94899E+00,
+ -.69259E-03, .25974E-05, 0. /
c... CO2 -- 636
DATA (Qcoef( 6,1,j),j=1,5)/-.20631E+01, .18873E+01,
+ -.13669E-02, .54032E-05, 0. /
c... CO2 -- 628
DATA (Qcoef( 7,1,j),j=1,5)/-.29175E+01, .20114E+01,
+ -.14786E-02, .55941E-05, 0. /
c... CO2 -- 627
DATA (Qcoef( 8,1,j),j=1,5)/-.16558E+02, .11733E+02,
+ -.85844E-02, .32379E-04, 0. /
c... CO2 -- 638
DATA (Qcoef( 9,1,j),j=1,5)/-.44685E+01, .40330E+01,
+ -.29590E-02, .11770E-04, 0. /
c... CO2 -- 637
DATA (Qcoef(10,1,j),j=1,5)/-.26263E+02, .23350E+02,
+ -.17032E-01, .67532E-04, 0. /
c... CO2 -- 828
DATA (Qcoef(11,1,j),j=1,5)/-.14811E+01, .10667E+01,
+ -.78758E-03, .30133E-05, 0. /
c... CO2 -- 728
DATA (Qcoef(12,1,j),j=1,5)/-.17600E+02, .12445E+02,
+ -.91837E-02, .34915E-04, 0. /
c... O3 -- 666
DATA (Qcoef(13,1,j),j=1,5)/-.16443E+03, .69047E+01,
+ .10396E-01, .26669E-04, 0. /
c... O3 -- 668
DATA (Qcoef(14,1,j),j=1,5)/-.35222E+03, .14796E+02,
+ .21475E-01, .59891E-04, 0. /
c... O3 -- 686
DATA (Qcoef(15,1,j),j=1,5)/-.17466E+03, .72912E+01,
+ .10093E-01, .29991E-04, 0. /
c... O3 -- 667
DATA (Qcoef(16,1,j),j=1,5)/-.20540E+04, .85998E+02,
+ .12667E+00, .33026E-03, 0. /
c... O3 -- 676
DATA (Qcoef(17,1,j),j=1,5)/-.10148E+04, .42494E+02,
+ .62586E-01, .16319E-03, 0. /
c... N2O -- 446
DATA (Qcoef(18,1,j),j=1,5)/ .24892E+02, .14979E+02,
+ -.76213E-02, .46310E-04, 0. /
c... N2O -- 456
DATA (Qcoef(19,1,j),j=1,5)/ .36318E+02, .95497E+01,
+ -.23943E-02, .26842E-04, 0. /
c... N2O -- 546
DATA (Qcoef(20,1,j),j=1,5)/ .24241E+02, .10179E+02,
+ -.43002E-02, .30425E-04, 0. /
c... N2O -- 448
DATA (Qcoef(21,1,j),j=1,5)/ .67708E+02, .14878E+02,
+ -.10730E-02, .34254E-04, 0. /
c... N2O -- 447
DATA (Qcoef(22,1,j),j=1,5)/ .50069E+03, .84526E+02,
+ .83494E-02, .17154E-03, 0. /
c... CO -- 26
DATA (Qcoef(23,1,j),j=1,5)/ .27758E+00, .36290E+00,
+ -.74669E-05, .14896E-07, 0. /
c... CO -- 36
DATA (Qcoef(24,1,j),j=1,5)/ .53142E+00, .75953E+00,
+ -.17810E-04, .35160E-07, 0. /
c... CO -- 28
DATA (Qcoef(25,1,j),j=1,5)/ .26593E+00, .38126E+00,
+ -.92083E-05, .18086E-07, 0. /
c... CO -- 27
DATA (Qcoef(26,1,j),j=1,5)/ .16376E+01, .22343E+01,
+ -.49025E-04, .97389E-07, 0. /
c... CO -- 38
DATA (Qcoef(27,1,j),j=1,5)/ .51216E+00, .79978E+00,
+ -.21784E-04, .42749E-07, 0. /
c... CO -- 37
DATA (Qcoef(28,1,j),j=1,5)/ .32731E+01, .46577E+01,
+ -.69833E-04, .18853E-06, 0. /
c... CH4 -- 211
DATA (Qcoef(29,1,j),j=1,5)/-.26479E+02, .11557E+01,
+ .26831E-02, .15117E-05, 0. /
c... CH4 -- 311
DATA (Qcoef(30,1,j),j=1,5)/-.52956E+02, .23113E+01,
+ .53659E-02, .30232E-05, 0. /
c... CH4 -- 212
DATA (Qcoef(31,1,j),j=1,5)/-.21577E+03, .93318E+01,
+ .21779E-01, .12183E-04, 0. /
c... O2 -- 66
DATA (Qcoef(32,1,j),j=1,5)/ .35923E+00, .73534E+00,
+ -.64870E-04, .13073E-06, 0. /
c... O2 -- 68
DATA (Qcoef(33,1,j),j=1,5)/-.40039E+01, .15595E+01,
+ -.15357E-03, .30969E-06, 0. /
c... O2 -- 67
DATA (Qcoef(34,1,j),j=1,5)/-.23325E+02, .90981E+01,
+ -.84435E-03, .17062E-05, 0. /
c... NO -- 46
DATA (Qcoef(35,1,j),j=1,5)/-.25296E+02, .26349E+01,
+ .58517E-02,-.52020E-05, 0. /
c... NO -- 56
DATA (Qcoef(36,1,j),j=1,5)/-.14990E+02, .18240E+01,
+ .40261E-02,-.35648E-05, 0. /
c... NO -- 48
DATA (Qcoef(37,1,j),j=1,5)/-.26853E+02, .27816E+01,
+ .61493E-02,-.54410E-05, 0. /
c... SO2 -- 626
DATA (Qcoef(38,1,j),j=1,5)/-.24056E+03, .11101E+02,
+ .22164E-01, .52334E-04, 0. /
c... SO2 -- 646
DATA (Qcoef(39,1,j),j=1,5)/-.24167E+03, .11151E+02,
+ .22270E-01, .52550E-04, 0. /
c... NO2 -- 646
DATA (Qcoef(40,1,j),j=1,5)/-.53042E+03, .24216E+02,
+ .66856E-01, .43823E-04, 0. /
c... NH3 -- 4111
DATA (Qcoef(41,1,j),j=1,5)/-.42037E+02, .25976E+01,
+ .13073E-01,-.62230E-05, 0. /
c... NH3 -- 5111
DATA (Qcoef(42,1,j),j=1,5)/-.28609E+02, .17272E+01,
+ .87529E-02,-.41714E-05, 0. /
c**********
c... HNO3 -- 146
c DATA (Qcoef(43,1,j),j=1,5)/-.10000E+01, .00000E+00,
c + .00000E+00, .00000E+00, 0. /
DATA (Qcoef(43,1,j),j=1,5)/ -6.672718E+4, 1.462506E+3,
+ -5.981021E+0, 1.414328E-2, 0. /
c 1.414328E-2*x^3 + -5.981021E+0*x^2 + 1.462506E+3*x + -6.672718E+4
c... OH -- 61
DATA (Qcoef(44,1,j),j=1,5)/ .87390E+01, .15977E+00,
+ .38291E-03,-.35669E-06, 0. /
c... OH -- 81
DATA (Qcoef(45,1,j),j=1,5)/ .86770E+01, .16175E+00,
+ .38223E-03,-.35466E-06, 0. /
c... OH -- 62
DATA (Qcoef(46,1,j),j=1,5)/ .10239E+02, .43783E+00,
+ .10477E-02,-.94570E-06, 0. /
c... HF -- 19
DATA (Qcoef(47,1,j),j=1,5)/ .15486E+01, .13350E+00,
+ .59154E-05,-.46889E-08, 0. /
c... HCl -- 15
DATA (Qcoef(48,1,j),j=1,5)/ .28627E+01, .53122E+00,
+ .67464E-05,-.16730E-08, 0. /
c... HCl -- 17
DATA (Qcoef(49,1,j),j=1,5)/ .28617E+01, .53203E+00,
+ .66553E-05,-.15168E-08, 0. /
c... HBr -- 19
DATA (Qcoef(50,1,j),j=1,5)/ .27963E+01, .66532E+00,
+ .34255E-05, .52274E-08, 0. /
c... HBr -- 11
DATA (Qcoef(51,1,j),j=1,5)/ .27953E+01, .66554E+00,
+ .32931E-05, .54823E-08, 0. /
c... HI -- 17
DATA (Qcoef(52,1,j),j=1,5)/ .40170E+01, .13003E+01,
+ -.11409E-04, .40026E-07, 0. /
c... ClO -- 56
DATA (Qcoef(53,1,j),j=1,5)/ .90968E+02, .70918E+01,
+ .11639E-01, .30145E-05, 0. /
c... ClO -- 76
DATA (Qcoef(54,1,j),j=1,5)/ .92598E+02, .72085E+01,
+ .11848E-01, .31305E-05, 0. /
c... OCS -- 622
DATA (Qcoef(55,1,j),j=1,5)/-.93697E+00, .36090E+01,
+ -.34552E-02, .17462E-04, 0. /
c... OCS -- 624
DATA (Qcoef(56,1,j),j=1,5)/-.11536E+01, .37028E+01,
+ -.35582E-02, .17922E-04, 0. /
c... OCS -- 632
DATA (Qcoef(57,1,j),j=1,5)/-.61015E+00, .72200E+01,
+ -.70044E-02, .36708E-04, 0. /
c... OCS -- 822
DATA (Qcoef(58,1,j),j=1,5)/-.21569E+00, .38332E+01,
+ -.36783E-02, .19177E-04, 0. /
c... H2CO -- 126
DATA (Qcoef(59,1,j),j=1,5)/-.11760E+03, .46885E+01,
+ .15088E-01, .35367E-05, 0. /
c... H2CO -- 136
DATA (Qcoef(60,1,j),j=1,5)/-.24126E+03, .96134E+01,
+ .30938E-01, .72579E-05, 0. /
c... H2CO -- 128
DATA (Qcoef(61,1,j),j=1,5)/-.11999E+03, .52912E+01,
+ .14686E-01, .43505E-05, 0. /
c... HOCl -- 165
DATA (Qcoef(62,1,j),j=1,5)/-.73640E+03, .34149E+02,
+ .93554E-01, .67409E-04, 0. /
c... HOCl -- 167
DATA (Qcoef(63,1,j),j=1,5)/-.74923E+03, .34747E+02,
+ .95251E-01, .68523E-04, 0. /
c... N2 -- 44
DATA (Qcoef(64,1,j),j=1,5)/ .13684E+01, .15756E+01,
+ -.18511E-04, .38960E-07, 0. /
c... HCN -- 124
DATA (Qcoef(65,1,j),j=1,5)/-.13992E+01, .29619E+01,
+ -.17464E-02, .65937E-05, 0. /
c... HCN -- 134
DATA (Qcoef(66,1,j),j=1,5)/-.25869E+01, .60744E+01,
+ -.35719E-02, .13654E-04, 0. /
c... HCN -- 125
DATA (Qcoef(67,1,j),j=1,5)/-.11408E+01, .20353E+01,
+ -.12159E-02, .46375E-05, 0. /
c... CH3Cl -- 215
DATA (Qcoef(68,1,j),j=1,5)/-.91416E+03, .34081E+02,
+ .75461E-02, .17933E-03, 0. /
c... CH3Cl -- 217
DATA (Qcoef(69,1,j),j=1,5)/-.92868E+03, .34621E+02,
+ .76674E-02, .18217E-03, 0. /
c... H2O2 -- 1661
DATA (Qcoef(70,1,j),j=1,5)/-.36499E+03, .13712E+02,
+ .38658E-01, .23052E-04, 0. /
c... C2H2 -- 1221
DATA (Qcoef(71,1,j),j=1,5)/-.83088E+01, .14484E+01,
+ -.25946E-02, .84612E-05, 0. /
c... C2H2 -- 1231
DATA (Qcoef(72,1,j),j=1,5)/-.66736E+02, .11592E+02,
+ -.20779E-01, .67719E-04, 0. /
c**********
c... C2H6 -- 1221
c DATA (Qcoef(73,1,j),j=1,5)/-.10000E+01, .00000E+00,
c + .00000E+00, .00000E+00, 0. /
DATA (Qcoef(73,1,j),j=1,5)/-1.198174E+4, 2.799115E+2,
+ -7.416173E-1, 1.846289E-3, 0. /
c 1.846289E-3*x^3 + -7.416173E-1*x^2 + 2.799115E+2*x + -1.198174E+4
c... PH3 -- 1111
DATA (Qcoef(74,1,j),j=1,5)/-.15068E+03, .64718E+01,
+ .12588E-01, .14759E-04, 0. /
c... COF2 -- 269
DATA (Qcoef(75,1,j),j=1,5)/-.54180E+04, .18868E+03,
+ -.33139E+00, .18650E-02, 0. /
c**********
c... SF6 -- 29
c DATA (Qcoef(76,1,j),j=1,5)/-.10000E+01, .00000E+00,
c + .00000E+00, .00000E+00, 0. /
DATA (Qcoef(76,1,j),j=1,5)/7.892502E+6, -1.839926E+5,
+ 1.433742E+3, -4.510500E+0, 5.163613E-3/
c 5.163613E-3*x^4 + -4.510500E+0*x^3 + 1.433742E+3*x^2 + -1.839926E+5*x + 7.892502E+6
c... H2S -- 121
DATA (Qcoef(77,1,j),j=1,5)/-.15521E+02, .83130E+00,
+ .33656E-02,-.85691E-06, 0. /
c... H2S -- 141
DATA (Qcoef(78,1,j),j=1,5)/-.15561E+02, .83337E+00,
+ .33744E-02,-.85937E-06, 0. /
c... H2S -- 131
DATA (Qcoef(79,1,j),j=1,5)/-.62170E+02, .33295E+01,
+ .13480E-01,-.34323E-05, 0. /
c... HCOOH -- 126
DATA (Qcoef(80,1,j),j=1,5)/-.29550E+04, .10349E+03,
+ -.13146E+00, .87787E-03, 0. /
c... HO2 -- 166
DATA (Qcoef(81,1,j),j=1,5)/-.15684E+03, .74450E+01,
+ .26011E-01,-.92704E-06, 0. /
c**********
c... O -- 6
c DATA (Qcoef(82,1,j),j=1,5)/-.10000E+01, .00000E+00,
c + .00000E+00, .00000E+00, 0. /
DATA (Qcoef(82,1,j),j=1,5)/ 1.0 , .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c**********
c...ClONO2 -- 5646
c DATA (Qcoef(83,1,j),j=1,5)/-.10000E+01, .00000E+00,
c + .00000E+00, .00000E+00, 0. /
DATA (Qcoef(83,1,j),j=1,5)/2.516742E+6, -5.996989E+4,
+ 5.111204E+2, -1.665663E+0, 2.399248E-3/
c 2.399248E-3*x^4 + -1.665663E+0*x^3 + 5.111204E+2*x^2 + -5.996989E+4*x + 2.516742E+6
c**********
c...ClONO2 -- 7646
c DATA (Qcoef(84,1,j),j=1,5)/-.10000E+01, .00000E+00,
c + .00000E+00, .00000E+00, 0. /
DATA (Qcoef(84,1,j),j=1,5)/2.601684E+6, -6.187640E+4,
+ 5.260888E+2, -1.711186E+0, 2.461028E-3/
c 2.461028E-3*x^4 + -1.711186E+0*x^3 + 5.260888E+2*x^2 + -6.187640E+4*x + 2.601684E+6
c... NO+ -- 46
DATA (Qcoef(85,1,j),j=1,5)/ .91798E+00, .10416E+01,
+ -.11614E-04, .24499E-07, 0. /
c
c...Total internal partition sums for T>500 to <=1500 K range:
c... H2O -- 161
DATA (Qcoef( 1,2,j),j=1,5)/-.94327E+02, .81903E+00,
+ .74005E-04, .42437E-06, 0. /
c... H2O -- 181
DATA (Qcoef( 2,2,j),j=1,5)/-.95686E+02, .82839E+00,
+ .68311E-04, .42985E-06, 0. /
c... H2O -- 171
DATA (Qcoef( 3,2,j),j=1,5)/-.57133E+03, .49480E+01,
+ .41517E-03, .25599E-05, 0. /
c... H2O -- 162
DATA (Qcoef( 4,2,j),j=1,5)/-.53366E+03, .44246E+01,
+ -.46935E-03, .29548E-05, 0. /
c... CO2 -- 626
DATA (Qcoef( 5,2,j),j=1,5)/-.50925E+03, .32766E+01,
+ -.40601E-02, .40907E-05, 0. /
c... CO2 -- 636
DATA (Qcoef( 6,2,j),j=1,5)/-.11171E+04, .70346E+01,
+ -.89063E-02, .88249E-05, 0. /
c... CO2 -- 628
DATA (Qcoef( 7,2,j),j=1,5)/-.11169E+04, .71299E+01,
+ -.89194E-02, .89268E-05, 0. /
c... CO2 -- 627
DATA (Qcoef( 8,2,j),j=1,5)/-.66816E+04, .42402E+02,
+ -.53269E-01, .52774E-04, 0. /
c... CO2 -- 638
DATA (Qcoef( 9,2,j),j=1,5)/-.25597E+04, .15855E+02,
+ -.20440E-01, .19855E-04, 0. /
c... CO2 -- 637
DATA (Qcoef(10,2,j),j=1,5)/-.14671E+05, .91204E+02,
+ -.11703E+00, .11406E-03, 0. /
c... CO2 -- 828
DATA (Qcoef(11,2,j),j=1,5)/-.63775E+03, .40047E+01,
+ -.50950E-02, .50023E-05, 0. /
c... CO2 -- 728
DATA (Qcoef(12,2,j),j=1,5)/-.73235E+04, .46140E+02,
+ -.58473E-01, .57573E-04, 0. /
c... O3 -- 666
DATA (Qcoef(13,2,j),j=1,5)/-.11725E+05, .66515E+02,
+ -.96010E-01, .94001E-04, 0. /
c... O3 -- 668
DATA (Qcoef(14,2,j),j=1,5)/-.25409E+05, .14393E+03,
+ -.20850E+00, .20357E-03, 0. /
c... O3 -- 686
DATA (Qcoef(15,2,j),j=1,5)/-.12624E+05, .71391E+02,
+ -.10383E+00, .10106E-03, 0. /
c... O3 -- 667
DATA (Qcoef(16,2,j),j=1,5)/-.14000E+06, .79825E+03,
+ -.11465E+01, .11372E-02, 0. /
c... O3 -- 676
DATA (Qcoef(17,2,j),j=1,5)/-.69175E+05, .39442E+03,
+ -.56650E+00, .56189E-03, 0. /
c... N2O -- 446
DATA (Qcoef(18,2,j),j=1,5)/-.12673E+05, .75128E+02,
+ -.10092E+00, .95557E-04, 0. /
c... N2O -- 456
DATA (Qcoef(19,2,j),j=1,5)/-.90045E+04, .52833E+02,
+ -.71771E-01, .67297E-04, 0. /
c... N2O -- 546
DATA (Qcoef(20,2,j),j=1,5)/-.89960E+04, .53096E+02,
+ -.71784E-01, .67592E-04, 0. /
c... N2O -- 448
DATA (Qcoef(21,2,j),j=1,5)/-.13978E+05, .82338E+02,
+ -.11167E+00, .10507E-03, 0. /
c... N2O -- 447
DATA (Qcoef(22,2,j),j=1,5)/-.79993E+05, .47265E+03,
+ -.63804E+00, .60218E-03, 0. /
c... CO -- 26
DATA (Qcoef(23,2,j),j=1,5)/ .90723E+01, .33263E+00,
+ .11806E-04, .27035E-07, 0. /
c... CO -- 36
DATA (Qcoef(24,2,j),j=1,5)/ .20651E+02, .68810E+00,
+ .34217E-04, .55823E-07, 0. /
c... CO -- 28
DATA (Qcoef(25,2,j),j=1,5)/ .98497E+01, .34713E+00,
+ .15290E-04, .28766E-07, 0. /
c... CO -- 27
DATA (Qcoef(26,2,j),j=1,5)/ .58498E+02, .20351E+01,
+ .87684E-04, .16554E-06, 0. /
c... CO -- 38
DATA (Qcoef(27,2,j),j=1,5)/ .23511E+02, .71565E+00,
+ .46681E-04, .58223E-07, 0. /
c... CO -- 37
DATA (Qcoef(28,2,j),j=1,5)/ .11506E+03, .42727E+01,
+ .17494E-03, .34413E-06, 0. /
c... CH4 -- 211
DATA (Qcoef(29,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... CH4 -- 311
DATA (Qcoef(30,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... CH4 -- 212
DATA (Qcoef(31,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... O2 -- 66
DATA (Qcoef(32,2,j),j=1,5)/ .36539E+02, .57015E+00,
+ .16332E-03, .45568E-07, 0. /
c... O2 -- 68
DATA (Qcoef(33,2,j),j=1,5)/ .77306E+02, .11818E+01,
+ .38661E-03, .89415E-07, 0. /
c... O2 -- 67
DATA (Qcoef(34,2,j),j=1,5)/ .44281E+03, .69531E+01,
+ .21669E-02, .53053E-06, 0. /
c... NO -- 46
DATA (Qcoef(35,2,j),j=1,5)/-.78837E+02, .39173E+01,
+ .80657E-03, .22042E-06, 0. /
c... NO -- 56
DATA (Qcoef(36,2,j),j=1,5)/-.67000E+02, .27874E+01,
+ .45181E-03, .21161E-06, 0. /
c... NO -- 48
DATA (Qcoef(37,2,j),j=1,5)/-.98460E+02, .42347E+01,
+ .71550E-03, .32213E-06, 0. /
c... SO2 -- 626
DATA (Qcoef(38,2,j),j=1,5)/-.21162E+05, .11846E+03,
+ -.16648E+00, .16825E-03, 0. /
c... SO2 -- 646
DATA (Qcoef(39,2,j),j=1,5)/-.21251E+05, .11896E+03,
+ -.16717E+00, .16895E-03, 0. /
c... NO2 -- 646
DATA (Qcoef(40,2,j),j=1,5)/-.27185E+05, .16489E+03,
+ -.19540E+00, .22024E-03, 0. /
c... NH3 -- 4111
DATA (Qcoef(41,2,j),j=1,5)/-.47139E+03, .54035E+01,
+ .64491E-02,-.72674E-06, 0. /
c... NH3 -- 5111
DATA (Qcoef(42,2,j),j=1,5)/-.31638E+03, .36086E+01,
+ .43087E-02,-.48207E-06, 0. /
c**********
c... HNO3 -- 146
c DATA (Qcoef(43,2,j),j=1,5)/-.10000E+01, .00000E+00,
c + .00000E+00, .00000E+00, 0. /
DATA (Qcoef(43,2,j),j=1,5)/-2.155375E+8, 8.804353E+5,
+ -1.165682E+3, 5.170532E-1, 0. /
c 5.170532E-1*x^3 + -1.165682E+3*x^2 + 8.804353E+5*x + -2.155375E+8
c... OH -- 61
DATA (Qcoef(44,2,j),j=1,5)/-.88840E+01, .30202E+00,
+ -.15565E-04, .14330E-07, 0. /
c... OH -- 81
DATA (Qcoef(45,2,j),j=1,5)/-.51535E+01, .29076E+00,
+ -.72340E-05, .20702E-07, 0. /
c... OH -- 62
DATA (Qcoef(46,2,j),j=1,5)/-.41683E+02, .83890E+00,
+ -.36063E-04, .38083E-07, 0. /
c... HF -- 19
DATA (Qcoef(47,2,j),j=1,5)/-.36045E-01, .14220E+00,
+ -.10755E-04, .65523E-08, 0. /
c... HCl -- 15
DATA (Qcoef(48,2,j),j=1,5)/ .25039E+01, .54430E+00,
+ -.38656E-04, .39793E-07, 0. /
c... HCl -- 17
DATA (Qcoef(49,2,j),j=1,5)/ .14998E+01, .54847E+00,
+ -.42209E-04, .41029E-07, 0. /
c... HBr -- 19
DATA (Qcoef(50,2,j),j=1,5)/ .67229E+01, .66356E+00,
+ -.33749E-04, .54818E-07, 0. /
c... HBr -- 11
DATA (Qcoef(51,2,j),j=1,5)/ .67752E+01, .66363E+00,
+ -.33655E-04, .54823E-07, 0. /
c... HI -- 17
DATA (Qcoef(52,2,j),j=1,5)/ .29353E+02, .12220E+01,
+ .10209E-04, .10719E-06, 0. /
c... ClO -- 56
DATA (Qcoef(53,2,j),j=1,5)/ .22662E+03, .61093E+01,
+ .14454E-01, .16928E-06, 0. /
c... ClO -- 76
DATA (Qcoef(54,2,j),j=1,5)/ .23304E+03, .61805E+01,
+ .14797E-01, .16629E-06, 0. /
c... OCS -- 622
DATA (Qcoef(55,2,j),j=1,5)/-.54125E+04, .29749E+02,
+ -.44698E-01, .38878E-04, 0. /
c... OCS -- 624
DATA (Qcoef(56,2,j),j=1,5)/-.55472E+04, .30489E+02,
+ -.45809E-01, .39847E-04, 0. /
c... OCS -- 632
DATA (Qcoef(57,2,j),j=1,5)/-.11863E+05, .64745E+02,
+ -.98318E-01, .84563E-04, 0. /
c... OCS -- 822
DATA (Qcoef(58,2,j),j=1,5)/-.61288E+04, .33520E+02,
+ -.50734E-01, .43792E-04, 0. /
c... H2CO -- 126
DATA (Qcoef(59,2,j),j=1,5)/-.17628E+05, .91794E+02,
+ -.13055E+00, .89336E-04, 0. /
c... H2CO -- 136
DATA (Qcoef(60,2,j),j=1,5)/-.36151E+05, .18825E+03,
+ -.26772E+00, .18321E-03, 0. /
c... H2CO -- 128
DATA (Qcoef(61,2,j),j=1,5)/-.17628E+05, .91794E+02,
+ -.13055E+00, .89336E-04, 0. /
c... HOCl -- 165
DATA (Qcoef(62,2,j),j=1,5)/-.24164E+05, .15618E+03,
+ -.13206E+00, .21900E-03, 0. /
c... HOCl -- 167
DATA (Qcoef(63,2,j),j=1,5)/-.24592E+05, .15895E+03,
+ -.13440E+00, .22289E-03, 0. /
c... N2 -- 44
DATA (Qcoef(64,2,j),j=1,5)/ .27907E+02, .14972E+01,
+ -.70424E-05, .11734E-06, 0. /
c... HCN -- 124
DATA (Qcoef(65,2,j),j=1,5)/-.78078E+03, .61725E+01,
+ -.53816E-02, .73379E-05, 0. /
c... HCN -- 134
DATA (Qcoef(66,2,j),j=1,5)/-.16309E+04, .12801E+02,
+ -.11242E-01, .15268E-04, 0. /
c... HCN -- 125
DATA (Qcoef(67,2,j),j=1,5)/-.56301E+03, .43794E+01,
+ -.38928E-02, .52467E-05, 0. /
c... CH3Cl -- 215
DATA (Qcoef(68,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... CH3Cl -- 217
DATA (Qcoef(69,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... H2O2 -- 1661
DATA (Qcoef(70,2,j),j=1,5)/-.27583E+05, .15064E+03,
+ -.19917E+00, .16977E-03, 0. /
c... C2H2 -- 1221
DATA (Qcoef(71,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... C2H2 -- 1231
DATA (Qcoef(72,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c**********
c... C2H6 -- 1221
DATA (Qcoef(73,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... PH3 -- 1111
DATA (Qcoef(74,2,j),j=1,5)/-.28390E+05, .14463E+03,
+ -.21473E+00, .14346E-03, 0. /
c... COF2 -- 269
DATA (Qcoef(75,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... SF6 -- 29
DATA (Qcoef(76,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... H2S -- 121
DATA (Qcoef(77,2,j),j=1,5)/-.37572E+03, .29157E+01,
+ -.98642E-03, .24113E-05, 0. /
c... H2S -- 141
DATA (Qcoef(78,2,j),j=1,5)/-.37668E+03, .29231E+01,
+ -.98894E-03, .24174E-05, 0. /
c... H2S -- 131
DATA (Qcoef(79,2,j),j=1,5)/-.15049E+04, .11678E+02,
+ -.39510E-02, .96579E-05, 0. /
c... HCOOH -- 126
DATA (Qcoef(80,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... HO2 -- 166
DATA (Qcoef(81,2,j),j=1,5)/-.32576E+04, .25539E+02,
+ -.12803E-01, .29358E-04, 0. /
c**********
c... O -- 6
c DATA (Qcoef(82,2,j),j=1,5)/-.10000E+01, .00000E+00,
c + .00000E+00, .00000E+00, 0. /
DATA (Qcoef(82,2,j),j=1,5)/ 1.0 , .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c...ClONO2 -- 5646
DATA (Qcoef(83,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c...ClONO2 -- 7646
DATA (Qcoef(84,2,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... NO+ -- 46
DATA (Qcoef(85,2,j),j=1,5)/ .17755E+02, .99262E+00,
+ -.70814E-05, .76699E-07, 0. /
c
c...total internal partition sums for T>1500 <=3005 K range:
c... H2O -- 161
DATA (Qcoef( 1,3,j),j=1,5)/-.11727E+04, .29261E+01,
+ -.13299E-02, .74356E-06, 0. /
c... H2O -- 181
DATA (Qcoef( 2,3,j),j=1,5)/-.17914E+04, .39835E+01,
+ -.19288E-02, .86144E-06, 0. /
c... H2O -- 171
DATA (Qcoef( 3,3,j),j=1,5)/-.10665E+05, .23729E+02,
+ -.11474E-01, .51294E-05, 0. /
c... H2O -- 162
DATA (Qcoef( 4,3,j),j=1,5)/-.12585E+05, .26707E+02,
+ -.14454E-01, .59457E-05, 0. /
c... CO2 -- 626
DATA (Qcoef( 5,3,j),j=1,5)/-.34938E+05, .66965E+02,
+ -.44010E-01, .12662E-04, 0. /
c... CO2 -- 636
DATA (Qcoef( 6,3,j),j=1,5)/-.76420E+05, .14638E+03,
+ -.96343E-01, .27589E-04, 0. /
c... CO2 -- 628
DATA (Qcoef( 7,3,j),j=1,5)/-.76677E+05, .14693E+03,
+ -.96622E-01, .27746E-04, 0. /
c... CO2 -- 627
DATA (Qcoef( 8,3,j),j=1,5)/-.44040E+06, .84397E+03,
+ -.55484E+00, .15946E-03, 0. /
c... CO2 -- 638
DATA (Qcoef( 9,3,j),j=1,5)/-.16856E+06, .32278E+03,
+ -.21259E+00, .60747E-04, 0. /
c... CO2 -- 637
DATA (Qcoef(10,3,j),j=1,5)/-.96531E+06, .18487E+04,
+ -.12172E+01, .34817E-03, 0. /
c... CO2 -- 828
DATA (Qcoef(11,3,j),j=1,5)/-.42074E+05, .80599E+02,
+ -.53035E-01, .15202E-04, 0. /
c... CO2 -- 728
DATA (Qcoef(12,3,j),j=1,5)/-.48298E+06, .92535E+03,
+ -.60873E+00, .17463E-03, 0. /
c... O3 -- 666
DATA (Qcoef(13,3,j),j=1,5)/-.61205E+06, .11896E+04,
+ -.80924E+00, .24833E-03, 0. /
c... O3 -- 668
DATA (Qcoef(14,3,j),j=1,5)/-.13289E+07, .25826E+04,
+ -.17574E+01, .53877E-03, 0. /
c... O3 -- 686
DATA (Qcoef(15,3,j),j=1,5)/-.66163E+06, .12857E+04,
+ -.87521E+00, .26802E-03, 0. /
c... O3 -- 667
DATA (Qcoef(16,3,j),j=1,5)/-.70636E+07, .13772E+05,
+ -.94024E+01, .29276E-02, 0. /
c... O3 -- 676
DATA (Qcoef(17,3,j),j=1,5)/-.34902E+07, .68051E+04,
+ -.46459E+01, .14466E-02, 0. /
c... N2O -- 446
DATA (Qcoef(18,3,j),j=1,5)/-.83406E+06, .15951E+04,
+ -.10534E+01, .29849E-03, 0. /
c... N2O -- 456
DATA (Qcoef(19,3,j),j=1,5)/-.59281E+06, .11334E+04,
+ -.74907E+00, .21164E-03, 0. /
c... N2O -- 546
DATA (Qcoef(20,3,j),j=1,5)/-.59301E+06, .11339E+04,
+ -.74918E+00, .21193E-03, 0. /
c... N2O -- 448
DATA (Qcoef(21,3,j),j=1,5)/-.92317E+06, .17651E+04,
+ -.11664E+01, .32984E-03, 0. /
c... N2O -- 447
DATA (Qcoef(22,3,j),j=1,5)/-.52739E+07, .10085E+05,
+ -.66623E+01, .18858E-02, 0. /
c... CO -- 26
DATA (Qcoef(23,3,j),j=1,5)/ .63418E+02, .20760E+00,
+ .10895E-03, .19844E-08, 0. /
c... CO -- 36
DATA (Qcoef(24,3,j),j=1,5)/ .13265E+03, .43434E+00,
+ .22794E-03, .41523E-08, 0. /
c... CO -- 28
DATA (Qcoef(25,3,j),j=1,5)/ .66581E+02, .21800E+00,
+ .11441E-03, .20839E-08, 0. /
c... CO -- 27
DATA (Qcoef(26,3,j),j=1,5)/ .39033E+03, .12780E+01,
+ .67066E-03, .12218E-07, 0. /
c... CO -- 38
DATA (Qcoef(27,3,j),j=1,5)/ .13959E+03, .45717E+00,
+ .23991E-03, .43712E-08, 0. /
c... CO -- 37
DATA (Qcoef(28,3,j),j=1,5)/ .81756E+03, .26767E+01,
+ .14046E-02, .25378E-07, 0. /
c... CH4 -- 211
DATA (Qcoef(29,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... CH4 -- 311
DATA (Qcoef(30,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... CH4 -- 212
DATA (Qcoef(31,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... O2 -- 66
DATA (Qcoef(32,3,j),j=1,5)/ .76324E+01, .58006E+00,
+ .18941E-03, .27822E-07, 0. /
c... O2 -- 68
DATA (Qcoef(33,3,j),j=1,5)/ .16157E+02, .12282E+01,
+ .40112E-03, .58919E-07, 0. /
c... O2 -- 67
DATA (Qcoef(34,3,j),j=1,5)/ .94397E+02, .71717E+01,
+ .23423E-02, .34425E-06, 0. /
c... NO -- 46
DATA (Qcoef(35,3,j),j=1,5)/ .52033E+03, .26381E+01,
+ .17177E-02, .17933E-07, 0. /
c... NO -- 56
DATA (Qcoef(36,3,j),j=1,5)/ .35655E+03, .18125E+01,
+ .12126E-02, .12110E-07, 0. /
c... NO -- 48
DATA (Qcoef(37,3,j),j=1,5)/ .54190E+03, .27581E+01,
+ .18694E-02, .18266E-07, 0. /
c... SO2 -- 626
DATA (Qcoef(38,3,j),j=1,5)/-.10718E+07, .20831E+04,
+ -.14138E+01, .43806E-03, 0. /
c... SO2 -- 646
DATA (Qcoef(39,3,j),j=1,5)/-.10762E+07, .20918E+04,
+ -.14196E+01, .43988E-03, 0. /
c... NO2 -- 646
DATA (Qcoef(40,3,j),j=1,5)/-.12837E+07, .25067E+04,
+ -.16761E+01, .53904E-03, 0. /
c... NH3 -- 4111
DATA (Qcoef(41,3,j),j=1,5)/-.17334E+04, .80988E+01,
+ .44771E-02,-.24084E-06, 0. /
c... NH3 -- 5111
DATA (Qcoef(42,3,j),j=1,5)/-.11656E+04, .54254E+01,
+ .29809E-02,-.15750E-06, 0. /
c**********
c... HNO3 -- 146
c DATA (Qcoef(43,3,j),j=1,5)/-.10000E+01, .00000E+00,
c + .00000E+00, .00000E+00, 0. /
DATA (Qcoef(43,3,j),j=1,5)/-1.425802E+11, 2.311441E+8,
+ -1.248681E+5, 2.268254E+1 , 0. /
c 2.268254E+1*x^3 + -1.248681E+5*x^2 + 2.311441E+8*x + -1.425802E+11
c... OH -- 61
DATA (Qcoef(44,3,j),j=1,5)/ .33750E+02, .22130E+00,
+ .35953E-04, .32366E-08, 0. /
c... OH -- 81
DATA (Qcoef(45,3,j),j=1,5)/ .42716E+02, .18843E+00,
+ .67175E-04, .23903E-08, 0. /
c... OH -- 62
DATA (Qcoef(46,3,j),j=1,5)/ .72913E+02, .62430E+00,
+ .99073E-04, .94503E-08, 0. /
c... HF -- 19
DATA (Qcoef(47,3,j),j=1,5)/ .18423E+02, .10799E+00,
+ .10568E-04, .20752E-08, 0. /
c... HCl -- 15
DATA (Qcoef(48,3,j),j=1,5)/ .92445E+02, .35539E+00,
+ .96272E-04, .71602E-08, 0. /
c... HCl -- 17
DATA (Qcoef(49,3,j),j=1,5)/ .92519E+02, .35592E+00,
+ .96492E-04, .71775E-08, 0. /
c... HBr -- 19
DATA (Qcoef(50,3,j),j=1,5)/ .11692E+03, .42161E+00,
+ .14690E-03, .92595E-08, 0. /
c... HBr -- 11
DATA (Qcoef(51,3,j),j=1,5)/ .11700E+03, .42161E+00,
+ .14703E-03, .92525E-08, 0. /
c... HI -- 17
DATA (Qcoef(52,3,j),j=1,5)/ .22138E+03, .78595E+00,
+ .34579E-03, .20348E-07, 0. /
c... ClO -- 56
DATA (Qcoef(53,3,j),j=1,5)/ .37348E+03, .56800E+01,
+ .14805E-01, .23168E-06, 0. /
c... ClO -- 76
DATA (Qcoef(54,3,j),j=1,5)/ .38100E+03, .57530E+01,
+ .15142E-01, .23652E-06, 0. /
c... OCS -- 622
DATA (Qcoef(55,3,j),j=1,5)/-.37301E+06, .71169E+03,
+ -.47328E+00, .13049E-03, 0. /
c... OCS -- 624
DATA (Qcoef(56,3,j),j=1,5)/-.38232E+06, .72945E+03,
+ -.48509E+00, .13375E-03, 0. /
c... OCS -- 632
DATA (Qcoef(57,3,j),j=1,5)/-.82204E+06, .15682E+04,
+ -.10435E+01, .28668E-03, 0. /
c... OCS -- 822
DATA (Qcoef(58,3,j),j=1,5)/-.42390E+06, .80869E+03,
+ -.53803E+00, .14798E-03, 0. /
c... H2CO -- 126
DATA (Qcoef(59,3,j),j=1,5)/-.24906E+07, .45519E+04,
+ -.28336E+01, .64198E-03, 0. /
c... H2CO -- 136
DATA (Qcoef(60,3,j),j=1,5)/-.51075E+07, .93349E+04,
+ -.58110E+01, .13165E-02, 0. /
c... H2CO -- 128
DATA (Qcoef(61,3,j),j=1,5)/-.24906E+07, .45519E+04,
+ -.28336E+01, .64198E-03, 0. /
c... HOCl -- 165
DATA (Qcoef(62,3,j),j=1,5)/-.11326E+07, .22197E+04,
+ -.14357E+01, .49952E-03, 0. /
c... HOCl -- 167
DATA (Qcoef(63,3,j),j=1,5)/-.11527E+07, .22590E+04,
+ -.14612E+01, .50838E-03, 0. /
c... N2 -- 44
DATA (Qcoef(64,3,j),j=1,5)/ .27986E+03, .93070E+00,
+ .42409E-03, .95573E-08, 0. /
c... HCN -- 124
DATA (Qcoef(65,3,j),j=1,5)/-.51989E+05, .10057E+03,
+ -.64310E-01, .19844E-04, 0. /
c... HCN -- 134
DATA (Qcoef(66,3,j),j=1,5)/-.10838E+06, .20960E+03,
+ -.13411E+00, .41345E-04, 0. /
c... HCN -- 125
DATA (Qcoef(67,3,j),j=1,5)/-.37363E+05, .72225E+02,
+ -.46251E-01, .14237E-04, 0. /
c... CH3Cl -- 215
DATA (Qcoef(68,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... CH3Cl -- 217
DATA (Qcoef(69,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... H2O2 -- 1661
DATA (Qcoef(70,3,j),j=1,5)/-.26863E+07, .49815E+04,
+ -.31584E+01, .78351E-03, 0. /
c... C2H2 -- 1221
DATA (Qcoef(71,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... C2H2 -- 1231
DATA (Qcoef(72,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c**********
c... C2H6 -- 1221
DATA (Qcoef(73,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... PH3 -- 1111
DATA (Qcoef(74,3,j),j=1,5)/-.44074E+07, .80563E+04,
+ -.50179E+01, .11272E-02, 0. /
c... COF2 -- 269
DATA (Qcoef(75,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... SF6 -- 29
DATA (Qcoef(76,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... H2S -- 121
DATA (Qcoef(77,3,j),j=1,5)/-.10043E+05, .20827E+02,
+ -.12249E-01, .48236E-05, 0. /
c... H2S -- 141
DATA (Qcoef(78,3,j),j=1,5)/-.10069E+05, .20881E+02,
+ -.12280E-01, .48359E-05, 0. /
c... H2S -- 131
DATA (Qcoef(79,3,j),j=1,5)/-.40225E+05, .83420E+02,
+ -.49061E-01, .19320E-04, 0. /
c... HCOOH -- 126
DATA (Qcoef(80,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... HO2 -- 166
DATA (Qcoef(81,3,j),j=1,5)/-.13056E+06, .26188E+03,
+ -.16161E+00, .61250E-04, 0. /
c**********
c... O -- 6
c DATA (Qcoef(82,3,j),j=1,5)/-.10000E+01, .00000E+00,
c + .00000E+00, .00000E+00, 0. /
DATA (Qcoef(82,3,j),j=1,5)/ 1.0 , .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c...ClONO2 -- 5646
DATA (Qcoef(83,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c...ClONO2 -- 7646
DATA (Qcoef(84,3,j),j=1,5)/-.10000E+01, .00000E+00,
+ .00000E+00, .00000E+00, 0. /
c... NO+ -- 46
DATA (Qcoef(85,3,j),j=1,5)/ .18634E+03, .61771E+00,
+ .27607E-03, .45828E-08, 0. /
c
c H2O 161, 181, 171,
DATA q296/ .174626E+03, .176141E+03, .105306E+04,
c 162; CO2 626, 636, 628, 627,
+ .865122E+03, .286219E+03, .576928E+03, .607978E+03, .354389E+04,
c 638, 637, 828, 728; O3 666,
+ .123528E+04, .714432E+04, .323407E+03, .376700E+04, .348186E+04,
c 668, 686, 667, 676; N2O 446,
+ .746207E+04, .364563E+04, .430647E+05, .212791E+05, .499183E+04,
c 456, 546, 448, 447; CO 26,
+ .334938E+04, .344940E+04, .526595E+04, .307008E+05, .107428E+03,
c 36, 28, 27, 38, 37;
+ .224704E+03, .112781E+03, .661209E+03, .236447E+03, .138071E+04,
c CH4 211, 311, 212; O2 66, 68,
+ .589908E+03, .117974E+04, .477061E+04, .215726E+03, .452188E+03,
c 67; NO 46, 56, 48; SO2 626,
+ .263998E+04, .113243E+04, .785200E+03, .119417E+04, .634449E+04,
c 646; NO2 646; NH3 4111, 5111; HNO3 146;
+ .637321E+04, .136318E+05, .171089E+04, .114134E+04, .213822E+06,
c OH 61, 81, 62; HF 19; HCl 15,
+ .803295E+02, .808460E+02, .207108E+03, .414625E+02, .160650E+03,
c 17; HBr 19, 11; HI 17; ClO 56,
+ .160887E+03, .200165E+03, .200227E+03, .388948E+03, .328810E+04,
c 76; OCS 622, 624, 632, 822;
+ .334560E+04, .121746E+04, .124793E+04, .247482E+04, .130948E+04,
c H2CO 126, 136, 128; HOCl 165, 167;
+ .268388E+04, .550322E+04, .284573E+04, .193166E+05, .196584E+05,
c N2 44; HCN 124, 134, 125; CH3Cl 215,
+ .467136E+03, .893323E+03, .183657E+04, .615046E+03, .144858E+05,
c 217; H2O2 1661; C2H2 1221, 1231, C2H6 1221;
+ .147153E+05, .767871E+04, .412519E+03, .330014E+04, .546265E+05,
c PH3 1111; COF2 269; SF6 29; H2S 121, 141,
+ .325067E+04, .697632E+05, .162242E+07, .503204E+03, .504486E+03,
c 131; HCOOH 126; HO2 166; O 6; ClONO2 5646,
+ .201546E+04, .389257E+05, .430184E+04,-.100000E+01, .212829E+07,
c 7646; NO+ 46;
+ .218246E+07, .308855E+03/
END
BLOCK DATA BDMOL
C
C LAST MODIFIED JANUARY 17, 1991
C
PARAMETER (NTMOL=36,NSPECI=85)
CHARACTER*6 MOLID
COMMON /MOLNAM/ MOLID(0:NTMOL)
C
DATA (MOLID(I),I=0,NTMOL)/ ' ALL ',
* ' H2O ',' CO2 ',' O3 ',' N2O ',' CO ',' CH4 ',' O2 ',
* ' NO ',' SO2 ',' NO2 ',' NH3 ',' HNO3 ',' OH ',' HF ',
* ' HCL ',' HBR ',' HI ',' CLO ',' OCS ',' H2CO ',' HOCL ',
* ' N2 ',' HCN ','CH3CL ',' H2O2 ',' C2H2 ',' C2H6 ',' PH3 ',
* ' COF2 ',' SF6 ',' H2S ','HCOOH ',' HO2 ',' O ','CLONO2',
* ' NO+ ' /
C
END
SUBROUTINE R1PRNT (V1P,DVP,NLIM,R1,JLO,NPTS,MFILE,IENTER) 3
C
IMPLICIT REAL*8 (V)
C
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
DIMENSION R1(*)
C
C THIS SUBROUTINE PRINTS THE FIRST NPTS VALUES STARTING AT JLO
C AND THE LAST NPTS VALUES ENDING AT NLIM OF THE R1 ARRAY
C
IF (NPTS.LE.0) RETURN
IF (IENTER.LT.1) WRITE (IPR,900)
WRITE (IPR,905)
IENTER = IENTER+1
JHI = JLO+NLIM-1
NNPTS = NPTS
IF (NPTS.GT.(NLIM/2)+1) NNPTS = (NLIM/2)+1
JLOLIM = JLO+NNPTS-1
JHILIM = JHI-NNPTS+1
DO 10 KK = 1, NNPTS
J = JLO+KK-1
VJ = V1P+FLOAT(J-JLO)*DVP
IK = JHILIM+KK-1
VK = V1P+FLOAT(IK-JLO)*DVP
WRITE (IPR,910) J,VJ,R1(J),IK,VK,R1(IK)
10 CONTINUE
C
RETURN
C
900 FORMAT ('0 ','LOCATION WAVENUMBER',2X,'OPT. DEPTH',27X,
* 'LOCATION WAVENUMBER',2X,'OPT. DEPTH')
905 FORMAT (' ')
910 FORMAT (I8,2X,F12.6,1P,E15.7,0P,20X,I8,2X,F12.6,1P,E15.7)
C
END
SUBROUTINE LINF4 (V1L4,V2L4) 1,25
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE LINF4 READS THE LINES AND SHRINKS THE LINES FOR LBLF4
C
PARAMETER (NTMOL=36,NSPECI=85)
C
COMMON /ISVECT/ ISOVEC(NTMOL),ISO82(NSPECI),ISONM(NTMOL),
* SMASSI(NSPECI)
COMMON /LAMCHN/ ONEPL,ONEMI,EXPMIN,ARGMIN
C
REAL*8 HID,HMOLIL,HID1,HLINHD
C
COMMON /BUFID/ HID(10),HMOLIL(64),MOLCNT(64),MCNTLC(64),
* MCNTNL(64),SUMSTR(64),NMOI,FLINLO,FLINHI,
* ILIN,ILINLC,ILINNL,IREC,IRECTL,HID1(2),LSTWDL
C
COMMON VNU(1250),SP(1250),ALFA0(1250),EPP(1250),MOL(1250),
* SPP(1250)
C
COMMON /IOU/ IOUT(250)
COMMON /MANE/ P0,TEMP0,NLAYRS,DVXM,H2OSLF,WTOT,ALBAR,ADBAR,AVBAR,
* AVFIX,LAYRFX,SECNT0,SAMPLE,DVSET,ALFAL0,AVMASS,
* DPTMIN,DPTFAC,ALTAV,AVTRAT,TDIFF1,TDIFF2,ALTD1,
* ALTD2,ANGLE,IANT,LTGNT,LH1,LH2,IPFLAG,PLAY,TLAY,
* EXTID(10)
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SEC , XALTZ
C
COMMON /FILHDR/ XID(10),SEC ,PAVE,TAVE,HMOLID(60),XALTZ(4),
* W(60),PZL,PZU,TZL,TZU,WBROAD,DVO,V1 ,V2 ,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
COMMON /CONSTS/ PI,PLANCK,BOLTZ,CLIGHT,AVOG,RADCN1,RADCN2
COMMON /R4SUB/ VLO,VHI,ILO,IST,IHI,LIMIN,LIMOUT,ILAST,DPTMN,
* DPTFC,ILIN4,ILIN4T
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /TPANEL/ VNULO,VNUHI,JLIN,NLNGT4
COMMON /BUFR/ VNUB(250),SB(250),ALB(250),EPPB(250),MOLB(250),
* HWHMB(250),TMPALB(250),PSHIFB(250),IFLG(250)
COMMON /NGT4/ VD,SD,AD,EPD,MOLD,SPPD,ILS2D
COMMON /L4TIMG/ L4TIM,L4TMR,L4TMS,L4NLN,L4NLS,LOTHER
C
REAL L4TIM,L4TMR,L4TMS,LOTHER
DIMENSION MEFDP(64)
DIMENSION SCOR(NSPECI),RHOSLF(NSPECI),ALFD1(NSPECI)
DIMENSION ALFAL(1250),ALFAD(1250),A(4),B(4),TEMPLC(4)
DIMENSION RCDHDR(2),IWD(2),IWD3(2),HLINHD(2),AMOLB(250)
C
EQUIVALENCE (ALFA0(1),ALFAL(1)) , (EPP(1),ALFAD(1))
EQUIVALENCE (IHIRAC,FSCDID(1)) , (ILBLF4,FSCDID(2))
EQUIVALENCE (VNULO,RCDHDR(1)) , (IWD3(1),VD),
* (HLINHD(1),HID(1),IWD(1)) , (MOLB(1),AMOLB(1))
DATA MEFDP / 64*0 /
C
C TEMPERATURES FOR LINE COUPLING COEFFICIENTS
C
DATA TEMPLC / 200.0,250.0,296.0,340.0 /
C
C Initialize timing for the group "OTHER" in the TAPE6 output
C
LOTHER = 0.0
TSHRNK = 0.0
TBUFFR = 0.0
TMOLN4 = 0.0
C
CALL CPUTIM (TIMEL0)
C
ILS2D = -654321
NLNGT4 = NWDL(IWD3,ILS2D)*1250
LNGTH4 = NLNGT4
PAVP0 = PAVE/P0
PAVP2 = PAVP0*PAVP0
DPTMN = DPTMIN/RADFN(V2,TAVE/RADCN2)
DPTFC = DPTFAC
LIMIN = 1000
CALL CPUTIM(TPAT0)
CALL MOLEC (1,SCOR,RHOSLF,ALFD1)
CALL CPUTIM(TPAT1)
TMOLN4 = TMOLN4 + TPAT1-TPAT0
C
TIMR = 0.
TIMS = 0.
SUMS = 0.
ILAST = 0
ILINLO = 0
ILINHI = 0
ILO = 1
IST = 1
NLINS = 0
NLIN = 0
C
VLO = V1L4
VHI = V2L4
C
CALL CPUTIM(TPAT0)
c
call lnfilhd_4(linfil,lnfil4,v1,v2)
c
CALL CPUTIM(TPAT1)
TBUFFR = TBUFFR + TPAT1-TPAT0
C
C TEMPERATURE CORRECTION TO INTENSITY
C TEMPERATURE AND PRESSURE CORRECTION TO HALF-WIDTH
C
TRATIO = TAVE/TEMP0
RHORAT = (PAVE/P0)*(TEMP0/TAVE)
C
BETA = RADCN2/TAVE
BETA0 = RADCN2/TEMP0
BETACR = BETA-BETA0
DELTMP = ABS(TAVE-TEMP0)
CALL CPUTIM(TPAT0)
CALL MOLEC (2,SCOR,RHOSLF,ALFD1)
CALL CPUTIM(TPAT1)
TMOLN4 = TMOLN4 + TPAT1-TPAT0
C
C FIND CORRECT TEMPERATURE AND INTERPOLATE FOR Y AND G
C
DO 10 ILC = 1, 4
IF (TAVE.LE.TEMPLC(ILC)) GO TO 20
10 CONTINUE
20 IF (ILC.EQ.1) ILC = 2
IF (ILC.EQ.5) ILC = 4
RECTLC = 1.0/(TEMPLC(ILC)-TEMPLC(ILC-1))
TMPDIF = TAVE-TEMPLC(ILC)
C
IJ = 0
30 CALL CPUTIM (TIM0)
CALL RDLNFL (IEOF,ILINLO,ILINHI)
CALL CPUTIM (TIM1)
TIMR = TIMR+TIM1-TIM0
C
IF (IEOF.GE.1) GO TO 60
C
DO 50 J = ILINLO, ILINHI
YI = 0.
GI = 0.
GAMMA1 = 0.
GAMMA2 = 0.
I = IOUT(J)
IFLAG = IFLG(I)
IF (I.LE.0) GO TO 50
C
M = MOD(MOLB(I),100)
C
C ISO=(MOD(MOLB(I),1000)-M)/100 IS PROGRAMMED AS:
C
ISO = MOD(MOLB(I),1000)/100
ILOC = ISOVEC(M)+ISO
IF ((M.GT.NMOL).OR.(M.LT.1)) GO TO 50
SUI = SB(I)*W(M)
IF (SUI.EQ.0.) GO TO 50
IF (VNUB(I).LT.VLO) GO TO 50
IJ = IJ+1
C
C Y'S AND G'S ARE STORED IN I+1 POSTION OF VNU,S,ALFA0,EPP...
C A(1-4), B(1-4) CORRESPOND TO TEMPERATURES TEMPLC(1-4) ABOVE
C
IF (IFLAG.EQ.1.OR.IFLAG.EQ.3) THEN
A(1) = VNUB(I+1)
B(1) = SB(I+1)
A(2) = ALB(I+1)
B(2) = EPPB(I+1)
A(3) = AMOLB(I+1)
B(3) = HWHMB(I+1)
A(4) = TMPALB(I+1)
B(4) = PSHIFB(I+1)
C
C CALCULATE SLOPE AND EVALUATE
C
SLOPEY = ( SLOPEG = ( IF (IFLAG.EQ.1) THEN
YI = A(ILC)+SLOPEY*TMPDIF
GI = B(ILC)+SLOPEG*TMPDIF
ELSE
GAMMA1 = A(ILC)+SLOPEY*TMPDIF
GAMMA2 = B(ILC)+SLOPEG*TMPDIF
ENDIF
ENDIF
C
C IFLAG = 2 IS RESERVED FOR LINE COUPLING COEFFICIENTS ASSOCIATED
C WITH AN EXACT TREATMENT (NUMERICAL DIAGONALIZATION)
C
C IFLAG = 3 TREATS LINE COUPLING IN TERMS OF REDUCED WIDTHS
C
VNU(IJ) = VNUB(I)+RHORAT*PSHIFB(I)
ALFA0(IJ) = ALB(I)
EPP(IJ) = EPPB(I)
MOL(IJ) = M
C
IF (VNU(IJ).EQ.0.) SUI = 2.*SUI
C
C TREAT TRANSITIONS WITH UNKNOWN EPP AS SPECIAL CASE
C
IF (EPP(IJ).GE.0.) GO TO 40
IF (DELTMP.LE.10.) EPP(IJ) = 0.
IF (DELTMP.GT.10.) MEFDP(M) = MEFDP(M)+1
IF (DELTMP.GT.10.) SUI = 0.
40 SUI = SUI*SCOR(ILOC)*EXP(-EPP(IJ)*BETACR)*
* (1.+EXP(-VNU(IJ)*BETA))
C
SUMS = SUMS+SUI
C
C TEMPERATURE CORRECTION OF THE HALFWIDTH
C SELF TEMP DEPENDENCE TAKEN THE SAME AS FOREIGN
C
TMPCOR = TRATIO**TMPALB(I)
ALFA0I = ALFA0(IJ)*TMPCOR
HWHMSI = HWHMB(I)*TMPCOR
ALFAL(IJ) = ALFA0I*(RHORAT-RHOSLF(ILOC))+HWHMSI*RHOSLF(ILOC)
C
IF (IFLAG.EQ.3)
* ALFAL(IJ) = ALFAL(IJ)*(1.0-GAMMA1*PAVP0-GAMMA2*PAVP2)
C
ALFAD(IJ) = VNU(IJ)*ALFD1(ILOC)
NLIN = NLIN+1
SP(IJ) = SUI*(1.+GI*PAVP2)
SPP(IJ) = SUI*YI*PAVP0
IF (VNU(IJ).GT.VHI) THEN
IEOF = 1
GO TO 60
ENDIF
50 CONTINUE
IF (IJ.LT.LIMIN.AND.IEOF.EQ.0) THEN
CALL CPUTIM (TIM2)
TIMS = TIMS+TIM2-TIM1
GO TO 30
ENDIF
60 CALL CPUTIM (TIM2)
IHI = IJ
TIMS = TIMS+TIM2-TIM1
C
CALL CPUTIM(TPAT0)
CALL SHRINK
CALL CPUTIM(TPAT1)
TSHRNK = TSHRNK + TPAT1-TPAT0
IJ = ILO-1
IF (IHI.LT.LIMIN.AND.IEOF.EQ.0) GO TO 30
C
VNULO = VNU(1)
VNUHI = VNU(IHI)
JLIN = IHI
C
IF (JLIN.GT.0) THEN
CALL CPUTIM(TPAT0)
CALL BUFOUT (LNFIL4,RCDHDR(1),NPHDRL)
CALL BUFOUT (LNFIL4,VNU(1),NLNGT4)
CALL CPUTIM(TPAT1)
TBUFFR = TBUFFR + TPAT1-TPAT0
ENDIF
NLINS = NLINS+IHI-IST+1
C
IF (IEOF.EQ.1) GO TO 70
IJ = 0
ILO = 1
GO TO 30
70 CONTINUE
C
DO 80 M = 1, NMOL
IF (MEFDP(M).GT.0) WRITE (IPR,905) MEFDP(M),M
80 CONTINUE
CALL CPUTIM (TIMEL1)
TIME = TIMEL1-TIMEL0
IF (NOPR.EQ.0) THEN
WRITE (IPR,910) TIME,TIMR,TIMS,NLIN,NLINS
L4TIM=TIME
L4TMR=TIMR
L4TMS=TIMS
L4NLN=NLIN
L4NLS=NLINS
LOTHER = TSHRNK+TBUFFR+TMOLN4
ENDIF
RETURN
C
905 FORMAT ('0*************************',I5,' STRENGTHS FOR',
* ' TRANSITIONS WITH UNKNOWN EPP FOR MOL =',I5,
* ' SET TO ZERO')
910 FORMAT ('0',20X,'TIME',11X,'READ',9X,'SHRINK',6X,'NO. LINES',3X,
* 'AFTER SHRINK',/,2X,'LINF4 ',2X,3F15.3,2I15)
C
END
c***********************************************************************
subroutine lnfilhd_4(linfil,linfil4,v1,v2) 1,1
c
c this subroutine buffers past the file header for LINF4
c
IMPLICIT REAL*8 (V)
c
CHARACTER*8 HLINID,BMOLID,HID1
CHARACTER*1 CNEGEPP(8)
C
integer *4 molcnt,mcntlc,
* mcntnl,linmol,
* lincnt,ilinlc,ilinnl,irec,irectl
c
COMMON /LINHDR/ HLINID(10),BMOLID(64),MOLCNT(64),MCNTLC(64),
* MCNTNL(64),SUMSTR(64),LINMOL,FLINLO,FLINHI,
* LINCNT,ILINLC,ILINNL,IREC,IRECTL,HID1(2),LSTWDL
common /bufid2/ n_negepp(64),n_resetepp(64),xspace(4096),lstwdl2
COMMON /IFIL/ Idum1,IPR,Idum2,Ndum1,Ndum2F,Ndum3,Ndum4,Ndum5,
* Ndum6,Kdum1,Kdum2,Ldum1,Ndum7,Idum3,Idum4,
* Ndum8,Ldum2,Ldum3
common /eppinfo/ negepp_flag
real *4 sumstr,flinlo,flinhi
integer *4 negepp_flag,n_negepp,n_resetepp
real *4 xspace
C
lnfil = linfil
lnfil4= linfil4
c
REWIND lnfil
c
read (lnfil,end=777) HLINID,BMOLID,MOLCNT,MCNTLC,
* MCNTNL,SUMSTR,LINMOL,FLINLO,FLINHI,
* LINCNT,ILINLC,ILINNL,IREC,IRECTL,HID1
c
READ (HLINID(7),950) CNEGEPP
IF (CNEGEPP(8).eq.'^') THEN
read (lnfil) n_negepp,n_resetepp,xspace
endif
go to 5
c
777 STOP 'Linf4: LINFIL DOES NOT EXIST'
c
5 continue
C
IF (V1.GT.FLINHI.OR.V2.LT.FLINLO) THEN
CALL ENDFIL_4 (LNFIL4)
WRITE (IPR,900) V1,V2,FLINLO,FLINHI
RETURN
ENDIF
c
write (lnfil4) HLINID,BMOLID,MOLCNT,MCNTLC,
* MCNTNL,SUMSTR,LINMOL,FLINLO,FLINHI,
* LINCNT,ILINLC,ILINNL,IREC,IRECTL,HID1
IF (CNEGEPP(8).eq.'^') THEN
write (lnfil4) n_negepp,n_resetepp,xspace
negepp_flag = 1
endif
C
return
c
900 FORMAT ('0 ***** LINF4 - VNU LIMITS DO NOT INTERSECT WITH ',
* 'LINFIL - LINF4 NOT USED *****',/,' VNU = ',F10.3,
* ' - ',F10.3,' CM-1 LINFIL = ',F10.3,' - ',F10.3,
* ' CM-1')
950 FORMAT (8a1)
c
end
c*******************************************************************
SUBROUTINE RDLNFL (IEOF,ILO,IHI) 1,3
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE RDLNFL INPUTS THE LINE DATA FROM LINFIL
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SEC , XALTZ
C
COMMON /FILHDR/ XID(10),SEC ,PAV ,TAV ,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DV ,V1 ,V2 ,TBOUND,
* EMIS ,FSCDID(17),NMOL,LAYRS ,YID1,YID(10),LSTWDF
COMMON /R4SUB/ VLO,VHI,ILD,IST,IHD,LIMIN,LIMOUT,ILAST,DPTMN,
* DPTFC,ILIN4,ILIN4T
COMMON /BUFR/ VNUB(250),SB(250),ALB(250),EPPB(250),MOLB(250),
* HWHMB(250),TMPALB(250),PSHIFB(250),IFLG(250)
c
dimension amolb(250)
equivalence (molb(1),amolb(1))
c
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /IOU/ IOUT(250)
c
common /rdlnpnl/ vmin,vmax,nrec,nwds
integer *4 nrec,nwds,lnfl,leof,npnlhd
c
common /rdlnbuf/ vlin(250),str(250),hw_f(250),e_low(250),
* mol_id(250),hw_s(250),hw_T(250),shft(250),jflg(250)
real *4 str,hw_f,e_low,hw_s,hw_T,shft,rdpnl(2),dum(2),xmol(2)
integer *4 mol_id,jflg
equivalence (vmin,rdpnl(1)), (mol_id(1),xmol(1))
c
IPASS = 1
IF (ILO.GT.0) IPASS = 2
C
ILNGTH = NLNGTH*250
C
IEOF = 0
ILO = 1
IHI = 0
c
lnfl = linfil
npnlhd = 6
c
10 CALL BUFINln (Lnfl,LEOF,rdpnl(1),npnlhd)
c
IF (LEOF.EQ.0) GO TO 30
IF (VMAX.LT.VLO) THEN
CALL BUFINln (lnfl,LEOF,dum(1),1)
GO TO 10
ELSE
CALL BUFINln (Lnfl,LEOF,vlin(1),NWDS)
ENDIF
c
IF ((IPASS.EQ.1).AND.(Vlin(1).GT.VLO)) WRITE (IPR,900)
C
IJ = 0
C
c precision conversion occurs here:
c incoming on right: vlin is real*8; others are real*4 and integer*4
c
do 15 i=1,nrec
IFLG(i) = jflg(i)
VNUB(i) = vlin(i)
SB(i) = str(i)
ALB(i) = hw_f(i)
EPPB(i) = e_low(i)
if (iflg(i) .ge. 0) then
MOLB(i) = mol_id(i)
else
amolb(i) = xmol(i)
endif
HWHMB(i) = hw_s(i)
TMPALB(i)= hw_T(i)
PSHIFB(i)= shft(i)
15 continue
c
DO 20 J = 1, NREC
IF (IFLG(J).GE.0) THEN
IJ = IJ+1
IOUT(IJ) = J
ENDIF
20 CONTINUE
IHI = IJ
RETURN
30 IF (NOPR.EQ.0) WRITE (IPR,905)
IEOF = 1
RETURN
C
900 FORMAT ('0 FIRST LINE USED IN RDLNFL--- CHECK THE LINEFIL ')
905 FORMAT ('0 EOF ON LINFIL IN RDLNFL -- CHECK THE LINFIL ')
C
END
SUBROUTINE SHRINK 1
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE SHRINK COMBINES LINES FALLING IN A WAVENUMBER INTERVAL
C DVR4/2 INTO A SINGLE EFFECTIVE LINE TO REDUCE COMPUTATION
C
COMMON VNU(1250),S(1250),ALFAL(1250),ALFAD(1250),MOL(1250),
* SPP(1250)
COMMON /R4SUB/ VLO,VHI,ILO,IST,IHI,LIMIN,LIMOUT,ILAST,DPTMN,
* DPTFC,ILIN4,ILIN4T
COMMON /LBLF/ V1R4,V2R4,DVR4,NPTR4,BOUND4,R4(2502),RR4(2502)
C
J = ILO-1
DV = DVR4/2.
VLMT = VNU(ILO)+DV
C
C INITIALIZE NON-CO2 SUMS
C
SUMAL = 0.
SUMAD = 0.
SUMS = 0.
SUMV = 0.
SUMC = 0.
C
C INITIALIZE CO2 SUMS
C
SUMAL2 = 0.
SUMAD2 = 0.
SUMS2 = 0.
SUMV2 = 0.
SUMC2 = 0.
C
DO 20 I = ILO, IHI
C
C IF LINE COUPLING, DON'T SHRINK LINE
C
IF (SPP(I).NE.0.0) THEN
J = J+1
VNU(J) = VNU(I)
S(J) = S(I)
ALFAL(J) = ALFAL(I)
ALFAD(J) = ALFAD(I)
SPP(J) = SPP(I)
MOL(J) = MOL(I)
c
GO TO 10
ENDIF
C
C NON-CO2 LINES OF MOLECULAR INDEX IT.NE.2 ARE LOADED
C INTO SUMS IF THE FREQUENCY WITHIN DV GROUP
C
IF (MOL(I).NE.2) THEN
SUMV = SUMV+VNU(I)*S(I)
SUMS = SUMS+S(I)
SUMAL = SUMAL+S(I)*ALFAL(I)
SUMAD = SUMAD+S(I)*ALFAD(I)
SUMC = SUMC+SPP(I)
ELSE
C
C CO2 LINES LOADED (MOL .EQ. 2)
C
SUMV2 = SUMV2+VNU(I)*S(I)
SUMS2 = SUMS2+S(I)
SUMAL2 = SUMAL2+S(I)*ALFAL(I)
SUMAD2 = SUMAD2+S(I)*ALFAD(I)
SUMC2 = SUMC2+SPP(I)
ENDIF
C
C IF LAST LINE OR VNU GREATER THAN LIMIT THEN STORE SUMS
C
10 IF (I.LT.IHI) THEN
IF (VNU(I+1).LE.VLMT) GO TO 20
ENDIF
C
VLMT = VNU(I)+DV
C
C ASSIGN NON-CO2 LINE AVERAGES TO 'GROUP' LINE J
C
IF (SUMS.GT.0.) THEN
J = J+1
S(J) = SUMS
ALFAL(J) = SUMAL/SUMS
ALFAD(J) = SUMAD/SUMS
VNU(J) = SUMV/SUMS
SPP(J) = SUMC
MOL(J) = 0
SUMAL = 0.
SUMAD = 0.
SUMS = 0.
SUMV = 0.
SUMC = 0.
ENDIF
C
C ASSIGN CO2 LINE AVERAGES
C
IF (SUMS2.GT.0.) THEN
J = J+1
S(J) = SUMS2
ALFAL(J) = SUMAL2/SUMS2
ALFAD(J) = SUMAD2/SUMS2
VNU(J) = SUMV2/SUMS2
MOL(J) = 2
SPP(J) = SUMC2
SUMAL2 = 0.
SUMAD2 = 0.
SUMS2 = 0.
SUMV2 = 0.
SUMC2 = 0.
ENDIF
C
20 CONTINUE
C
ILO = J+1
IHI = J
C
RETURN
C
END
SUBROUTINE LBLF4 (JRAD,V1,V2) 2,10
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE LBLF4 DOES A LINE BY LINE CALCULATION
C USING FUNCTION F4.
C
COMMON /LAMCHN/ ONEPL,ONEMI,EXPMIN,ARGMIN
COMMON /BUF/ VNU(1250),S(1250),ALFAL(1250),ALFAD(1250),MOL(1250),
* SPP(1250)
COMMON /MANE/ P0,TEMP0,NLAYRS,DVXM,H2OSLF,WTOT,ALBAR,ADBAR,AVBAR,
* AVFIX,LAYRFX,SECNT0,SAMPLE,DVSET,ALFAL0,AVMASS,
* DPTMIN,DPTFAC,ALTAV,AVTRAT,TDIFF1,TDIFF2,ALTD1,
* ALTD2,ANGLE,IANT,LTGNT,LH1,LH2,IPFLAG,PLAY,TLAY,
* EXTID(10)
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SEC , XALTZ
C
COMMON /FILHDR/ XID(10),SEC ,PAVE,TAVE,HMOLID(60),XALTZ(4),
* W(60),PZL,PZU,TZL,TZU,WBROAD,DVO,V1H,V2H,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
COMMON /CONSTS/ PI,PLANCK,BOLTZ,CLIGHT,AVOG,RADCN1,RADCN2
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL,TF4,TF4RDF,TF4CNV,
* TF4PNL,TXS,TXSRDF,TXSCNV,TXSPNL
COMMON /R4SUB/ VLO,VHI,ILO,IST,IHI,LIMIN,LIMOUT,ILAST,DPTMN,
* DPTFC,ILIN4,ILIN4T
COMMON /LBLF/ V1R4,V2R4,DVR4,NPTR4,BOUND4,R4(2502),RR4(2502)
COMMON /VOICOM/ AVRAT(102),DUMMY(5,102)
COMMON /CONVF/ CHI(251),RDVCHI,RECPI,ZSQBND,A3,B3,JCNVF4
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIO,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
C
EQUIVALENCE (IHIRAC,FSCDID(1)) , (ILBLF4,FSCDID(2))
C
DATA JLBLF4 / 0 /
C
CALL CPUTIM (TIM00)
C
DPTMN = DPTMIN/RADFN(V2,TAVE/RADCN2)
DPTFC = DPTFAC
LIMIN = 1000
LIMOUT = 2500
JLBLF4 = 1
C
C SET IEOF EQUAL TO -1 FOR FIRST READ
C
IEOF = -1
C
V1R4 = V1
V2R4 = V2
NPTR4 = (V2R4-V1R4)/DVR4+ONEPL
NPTR4 = MIN(NPTR4,LIMOUT)
V2R4 = V1R4+DVR4*FLOAT(NPTR4-1)
C
LIMP2 = LIMOUT+2
DO 10 I = 1, LIMP2
R4(I) = 0.
10 CONTINUE
BETA = RADCN2/TAVE
VLO = V1R4-BOUND4
VHI = V2R4+BOUND4
20 CALL CPUTIM (TIM0)
CALL RDLIN4 (IEOF)
CALL CPUTIM (TIM1)
C
IF (IEOF.EQ.2) THEN
TF4 = TF4+TIM1-TIM00
RETURN
ENDIF
C
TF4RDF = TF4RDF+TIM1-TIM0
TIM2 = TIM1
IF (IEOF.EQ.1.AND.IHI.EQ.0) GO TO 30
C
CALL CONVF4 (VNU,S,ALFAL,ALFAD,MOL,SPP)
C
CALL CPUTIM (TIM3)
TF4CNV = TF4CNV+TIM3-TIM2
C
C IF IHI EQUALS -1 THEN END OF CONVOLUTION
C
IF (IHI.EQ.-1) GO TO 30
GO TO 20
C
30 CALL CPUTIM (TIM4)
C
IF (JRAD.EQ.1) THEN
C
C RADIATION FIELD
C
XKT = 1./BETA
VITST = V1R4-DVR4
RDLAST = -1.
NPTSI1 = 0
NPTSI2 = 0
C
40 NPTSI1 = NPTSI2+1
C
VI = V1R4+DVR4*FLOAT(NPTSI1-1)
RADVI = RADFNI(VI,DVR4,XKT,VITST,RDEL,RDLAST)
C
NPTSI2 = (VITST-V1R4)/DVR4+1.001
NPTSI2 = MIN(NPTSI2,NPTR4)
C
DO 50 I = NPTSI1, NPTSI2
VI = VI+DVR4
R4(I) = R4(I)*RADVI
RADVI = RADVI+RDEL
50 CONTINUE
C
IF (NPTSI2.LT.NPTR4) GO TO 40
ENDIF
C
CALL CPUTIM (TIM5)
TF4PNL = TF4PNL+TIM5-TIM4
TF4 = TF4+TIM5-TIM00
C
RETURN
C
END
SUBROUTINE RDLIN4 (IEOF) 1,5
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE RDLIN4 INPUTS THE LINE DATA FROM LNFIL4
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SEC , XALTZ
C
COMMON /FILHDR/ XID(10),SEC ,PAV ,TAV ,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DV ,V1 ,V2 ,TBOUND,
* EMIS ,FSCDID(17),NMOL,LAYRS ,YID1,YID(10),LSTWDF
COMMON /R4SUB/ VLO,VHI,ILO,IST,IHI,LIMIN,LIMOUT,ILAST,DPTMN,
* DPTFC,ILIN4,ILIN4T
COMMON /BUF/ VNU(1250),S(1250),ALFAL(1250),ALFAD(1250),MOL(1250),
* SPP(1250)
COMMON /BUF2/ VMIN,VMAX,NREC,NWDS
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINDUM,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
common /eppinfo/ negepp_flag
integer*4 negepp_flag
DIMENSION DUM(2),LINPNL(2)
C
EQUIVALENCE (VMIN,LINPNL(1))
C
IF (IEOF.EQ.-1) THEN
C
C BUFFER PAST FILE HEADER
C
REWIND LNFIL4
ILIN4T = 0
CALL BUFIN (LNFIL4,LEOF,DUM(1),1)
IF (LEOF.EQ.0) STOP 'RDLIN4; TAPE9 EMPTY'
IF (LEOF.EQ.-99) THEN
IEOF = 2
C
RETURN
C
ENDIF
if (negepp_flag.eq.1) CALL BUFIN (LNFIL4,LEOF,DUM(1),1)
ENDIF
IEOF = 0
ILO = 1
IHI = 0
C
10 CALL BUFIN (LNFIL4,LEOF,LINPNL(1),NPHDRL)
IF (LEOF.EQ.0) GO TO 20
ILIN4T = ILIN4T+NREC
IF (VMAX.LT.VLO) THEN
CALL BUFIN (LNFIL4,LEOF,DUM(1),1)
GO TO 10
ELSE
CALL BUFIN (LNFIL4,LEOF,VNU(1),NWDS)
ENDIF
IHI = NREC
IF (VNU(NREC).GT.VHI) GO TO 20
C
RETURN
C
20 IEOF = 1
C
950 FORMAT (8a1)
RETURN
C
END
SUBROUTINE CONVF4 (VNU,S,ALFAL,ALFAD,MOL,SPP) 1
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE CONVF4 CONVOLVES THE LINE DATA WITH FUNCTION F4
C
CHARACTER*1 FREJ(1250),HREJ,HNOREJ
COMMON /RCNTRL/ ILNFLG
COMMON /LAMCHN/ ONEPL,ONEMI,EXPMIN,ARGMIN
COMMON /R4SUB/ VLO,VHI,ILO,IST,IHI,LIMIN,LIMOUT,ILAST,DPTMN,
* DPTFC,ILIN4,ILIN4T
COMMON /LBLF/ V1R4,V2R4,DVR4,NPTR4,BOUND4,R4(2502),RR4(2502)
COMMON /VOICOM/ AVRAT(102),DUMMY(5,102)
COMMON /CONVF/ CHI(251),RDVCHI,RECPI,ZSQBND,A3,B3,JCNVF4
C
DIMENSION VNU(*),S(*),ALFAL(*),ALFAD(*),MOL(*),SPP(*)
C
DATA ZBND / 64. /
DATA ASUBL / 0.623 /,BSUBL / 0.410 /
DATA HREJ /'0'/,HNOREJ /'1'/
C
VNULST = V2R4+BOUND4
C
IF (JCNVF4.NE.0) GO TO 20
JCNVF4 = 1
C
C SET UP CHI SUB-LORENTZIAN FORM FACTOR FOR CARBON DIOXIDE
C POLYNOMIAL MATCHED TO AN EXPONENTIAL AT X0 = 8 CM-1
C
X0 = 8.
Y0 = EXP(-ASUBL*X0**BSUBL)
F = ASUBL*BSUBL*X0**(BSUBL-1)
Y1 = -F*Y0
Y2 = Y1*((BSUBL-1)/X0-F)
Z0 = (Y0-1)/X0**2
Z1 = Y1/(2*X0)
Z2 = Y2/2.
C6 = (Z0-Z1+(Z2-Z1)/4.)/X0**4
C4 = (Z1-Z0)/X0**2-2.*X0**2*C6
C2 = Z0-X0**2*C4-X0**4*C6
DVCHI = 0.1
RDVCHI = 1./DVCHI
C
DO 10 ISUBL = 1, 251
FI = DVCHI*FLOAT(ISUBL-1)
IF (FI.LT.X0) THEN
CHI(ISUBL) = 1.+C2*FI**2+C4*FI**4+C6*FI**6
ELSE
FNI = ASUBL*(FI**BSUBL)
CHI(ISUBL) = EXP(-FNI)
ENDIF
10 CONTINUE
C
C CONSTANTS FOR FOURTH FUNCTION LINE SHAPE
C
RECPI = 1./(2.*ASIN(1.))
ZSQBND = ZBND*ZBND
A3 = (1.+2.*ZSQBND)/(1.+ZSQBND)**2
B3 = -1./(1.+ZSQBND)**2
C
20 CONTINUE
C
BNDSQ = BOUND4*BOUND4
C
C START OF LOOP OVER LINES
C
IF (ILNFLG.EQ.2) READ(16)(FREJ(I),I=ILO,IHI)
C
DO 60 I = ILO, IHI
C
IF ( ALFADI = ALFAD(I)
ALFALI = ALFAL(I)
ZETAI = ALFALI/(ALFALI+ALFADI)
IZ = 100.*ZETAI + ONEPL
ZETDIF = 100.*ZETAI - FLOAT(IZ-1)
ALFAVI = ( AVRAT(IZ) + ZETDIF*(AVRAT(IZ+1)-AVRAT(IZ)) ) *
x (ALFALI+ALFADI)
RALFVI = 1./ALFAVI
SIL = S(I)*RECPI*ALFALI
SIV = (ALFALI*RALFVI)*S(I)*RECPI*RALFVI
C
IF (SPP(I).EQ.0.) THEN
SPEAK = A3*(ABS(SIV))
ELSE
SILX = SPP(I)*RECPI
SIVX = ((ALFALI*RALFVI)*SPP(I)*RECPI*RALFVI)*RALFVI
SPEAK = A3*(ABS(SIV)+ABS(SIVX))
ENDIF
C
JJ = (VNU(I)-V1R4)/DVR4+1.
JJ = MAX(JJ,1)
JJ = MIN(JJ,NPTR4)
C
IF (ILNFLG.LE.1) THEN
FREJ(I) = HNOREJ
IF (SPEAK.LE.(DPTMN+DPTFC*R4(JJ))) THEN
FREJ(I) = HREJ
GO TO 60
ENDIF
ELSE
IF (FREJ(I).EQ.HREJ) GOTO 60
ENDIF
C
ILIN4 = ILIN4+1
C
VNUI = VNU(I)
C
30 CONTINUE
C
XNUI = VNUI-V1R4
JMIN = (XNUI-BOUND4)/DVR4+2.
C
IF (VNUI.GE.VNULST) GO TO 70
IF (JMIN.GT.NPTR4) GO TO 60
JMIN = MAX(JMIN,1)
JMAX = (XNUI+BOUND4)/DVR4+1.
IF (JMAX.LT.JMIN) GO TO 50
JMAX = MIN(JMAX,NPTR4)
ALFLI2 = ALFALI*ALFALI
ALFVI2 = ALFAVI*ALFAVI
XJJ = FLOAT(JMIN-1)*DVR4
F4BND = SIL/(ALFLI2+BNDSQ)
IF (SPP(I).NE.0.) F4BNDX = SILX/(ALFLI2+BNDSQ)
C
C FOURTH FUNCTION CONVOLUTION
C
DO 40 JJ = JMIN, JMAX
XM = (XJJ-XNUI)
XMSQ = XM*XM
ZVSQ = XMSQ/ALFVI2
C
IF (ZVSQ.LE.ZSQBND) THEN
F4FN = SIV*(A3+ZVSQ*B3)-F4BND
IF (SPP(I).NE.0.)
* F4FN = F4FN+XM*(SIVX*(A3+ZVSQ*B3)-F4BNDX)
ELSE
F4FN = SIL/(ALFLI2+XMSQ)-F4BND
IF (SPP(I).NE.0.)
* F4FN = F4FN+XM*(SILX/(ALFLI2+XMSQ)-F4BNDX)
ENDIF
C
IF (MOL(I).EQ.2.AND.SPP(I).EQ.0.) THEN
C
C ASSIGN ARGUMENT ISUBL OF THE FORM FACTOR FOR CO2 LINES
C
ISUBL = RDVCHI*ABS(XM)+1.5
ISUBL = MIN(ISUBL,251)
C
R4(JJ) = R4(JJ)+F4FN*CHI(ISUBL)
ELSE
R4(JJ) = R4(JJ)+F4FN
ENDIF
C
C
XJJ = XJJ+DVR4
40 CONTINUE
C
50 IF (VNUI.GT.0..AND.VNUI.LE.25.) THEN
C
C THE CALCULATION FOR NEGATIVE VNU(I) IS FOR VAN VLECK WEISSKOPF
C
VNUI = -VNU(I)
SIVX = -SIVX
SILX = -SILX
GO TO 30
C
ENDIF
C
60 CONTINUE
C
IF (ILNFLG.EQ.1) WRITE(16)(FREJ(I),I=ILO,IHI)
RETURN
C
C IF END OF CONVOLUTION, SET IHI=-1 AND RETURN
C
70 CONTINUE
IF (ILNFLG.EQ.1) WRITE(16)(FREJ(I),I=ILO,IHI)
IHI = -1
C
RETURN
C
END
SUBROUTINE XSREAD (XV1,XV2) 2,2
C
IMPLICIT REAL*8 (V)
C
C**********************************************************************
C THIS SUBROUTINE READS IN THE DESIRED "CROSS-SECTION"
C MOLECULES WHICH ARE THEN MATCHED TO THE DATA CONTAINED
C ON INPUT FILE FSCDXS.
C**********************************************************************
C
C IFIL CARRIES FILE INFORMATION
C
PARAMETER (MXFSC=200, MXLAY=MXFSC+3,MXZMD=3400,
* MXPDIM=MXLAY+MXZMD,IM2=MXPDIM-2,MXMOL=35,MXTRAC=22)
C
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
C
C IXMAX=MAX NUMBER OF X-SECTION MOLECULES, IXMOLS=NUMBER OF THESE
C MOLECULES SELECTED, IXINDX=INDEX VALUES OF SELECTED MOLECULES
C (E.G. 1=CLONO2), XAMNT(I,L)=LAYER AMOUNTS FOR I'TH MOLECULE FOR
C L'TH LAYER, ANALOGOUS TO AMOUNT IN /PATHD/ FOR THE STANDARD
C MOLECULES.
C
COMMON /PATHX/ IXMAX,IXMOLS,IXINDX(35),XAMNT(35,MXLAY)
C
C COMMON BLOCKS AND PARAMETERS FOR THE PROFILES AND DENSITIES
C FOR THE CROSS-SECTION MOLECULES.
C XSNAME=NAMES, ALIAS=ALIASES OF THE CROSS-SECTION MOLECULES
C
CHARACTER*10 XSFILE,XSNAME,ALIAS,XNAME,XFILS(6),BLANK
COMMON /XSECTF/ XSFILE(6,5,35),XSNAME(35),ALIAS(4,35)
COMMON /XSECTR/ V1FX(5,35),V2FX(5,35),DVFX(5,35),WXM(35),
* NTEMPF(5,35),NSPECR(35),IXFORM(5,35),
* XSMASS(35),XDOPLR(5,35),NUMXS,IXSBIN
C
DIMENSION IXFLG(35)
C
CHARACTER*120 XSREC
CHARACTER*1 CFLG,CASTSK,CPRCNT,CFRM,CN,CF
EQUIVALENCE (CFLG,XSREC)
C
DATA CASTSK / '*'/,CPRCNT / '%'/,CN / 'N'/,CF / 'F'/
DATA BLANK / ' '/
C
C T296 IS TEMPERATURE FOR INITAL CALCULATIN OF DOPPLER WIDTHS
C
DATA T296 / 296.0 /
C
IXMAX = 35
DO 10 I = 1, IXMAX
XSNAME(I) = BLANK
10 CONTINUE
C
C READ IN THE NAMES OF THE MOLECULES
C
IF (IXMOLS.GT.7) THEN
READ (IRD,'(7A10)') (XSNAME(I),I=1,7)
READ (IRD,'(8A10)') (XSNAME(I),I=8,IXMOLS)
ELSE
READ (IRD,'(7A10)') (XSNAME(I),I=1,IXMOLS)
ENDIF
C
C Left-justify all inputed names
C
DO 15 I=1,IXMOLS
CALL CLJUST (XSNAME(I),10)
15 CONTINUE
C
CPRT WRITE(IPR,'(/,'' THE FOLLOWING MOLECULES ARE REQUESTED:'',//,
CPRT 1 (5X,I5,2X,A))') (I,XSNAME(I),I=1,IXMOLS)
C
C MATCH THE NAMES READ IN AGAINST THE NAMES STORED IN ALIAS
C AND DETERMINE THE INDEX VALUE. STOP IF NO MATCH IS FOUND.
C NAME MUST BE ALL IN CAPS.
C
DO 40 I = 1, IXMOLS
DO 20 J = 1, IXMAX
IF ((XSNAME(I).EQ.ALIAS(1,J)) .OR.
* (XSNAME(I).EQ.ALIAS(2,J)) .OR.
* (XSNAME(I).EQ.ALIAS(3,J)) .OR.
* (XSNAME(I).EQ.ALIAS(4,J))) THEN
IXINDX(I) = J
GO TO 30
ENDIF
20 CONTINUE
C
C NO MATCH FOUND
C
WRITE (IPR,900) XSNAME(I)
STOP 'STOPPED IN XSREAD'
C
30 CONTINUE
IXFLG(I) = 0
40 CONTINUE
C
C READ IN "CROSS SECTION" MASTER FILE FSCDXS
C
IXFIL = 8
OPEN (IXFIL,FILE='FSCDXS',STATUS='OLD',FORM='FORMATTED')
REWIND IXFIL
READ (IXFIL,905)
C
50 READ (IXFIL,910,END=80) XSREC
C
IF (CFLG.EQ.CASTSK) GO TO 50
IF (CFLG.EQ.CPRCNT) GO TO 80
C
READ (XSREC,915) XNAME,V1X,V2X,DVX,NTEMP,IFRM,CFRM,
* (XFILS(I),I=1,NTEMP)
C
C LEFT-JUSTIFY INPUTED NAME
C
CALL CLJUST (XNAME,10)
C
C CHECK MASTER FILE FOR CROSS SECTION AND STORE DATA
C
NUMXS = IXMOLS
DO 70 I = 1, IXMOLS
IF ((XNAME.EQ.ALIAS(1,IXINDX(I))) .OR.
* (XNAME.EQ.ALIAS(2,IXINDX(I))) .OR.
* (XNAME.EQ.ALIAS(3,IXINDX(I))) .OR.
* (XNAME.EQ.ALIAS(4,IXINDX(I)))) THEN
IXFLG(I) = 1
IF (V2X.GT.XV1.AND.V1X.LT.XV2) THEN
NSPECR(I) = NSPECR(I)+1
IF (NSPECR(I).GT.6) THEN
WRITE (IPR,920) I,XSNAME(I),NSPECR(I)
STOP ' XSREAD - NSPECR .GT. 6'
ENDIF
IXFORM(NSPECR(I),I) = 91
IF (IFRM.EQ.86) IXFORM(NSPECR(I),I) = IFRM
IF (CFRM.NE.CN)
* IXFORM(NSPECR(I),I) = IXFORM(NSPECR(I),I)+100
IF (CFRM.EQ.CF)
* IXFORM(NSPECR(I),I) = -IXFORM(NSPECR(I),I)
NTEMPF(NSPECR(I),I) = NTEMP
V1FX(NSPECR(I),I) = V1X
V2FX(NSPECR(I),I) = V2X
C
C 3.58115E-07 = SQRT( 2.*ALOG(2.)*AVOG*BOLTZ/(CLIGHT*CLIGHT) )
C
XDOPLR(NSPECR(I),I)=3.58115E-07*(0.5*(V1X+V2X))*
* SQRT(T296/XSMASS(IXINDX(I)))
C
DO 60 J = 1, NTEMP
XSFILE(J,NSPECR(I),I) = XFILS(J)
60 CONTINUE
ENDIF
ENDIF
70 CONTINUE
C
GO TO 50
C
80 IXFLAG = 0
DO 90 I = 1, IXMOLS
IF (IXFLG(I).EQ.0) THEN
WRITE (IPR,925) XSNAME(I)
IXFLAG = 1
ENDIF
90 CONTINUE
IF (IXFLAG.EQ.1) STOP ' IXFLAG - XSREAD '
C
RETURN
C
900 FORMAT (/,' THE NAME: ',A10, ' IS NOT ONE OF THE ',
* 'CROSS SECTION MOLECULES. CHECK THE SPELLING.')
905 FORMAT (/)
910 FORMAT (A120)
915 FORMAT (A10,2F10.4,F10.8,I5,5X,I5,A1,4X,6A10)
920 FORMAT (/,'******* ERROR IN XSREAD ** MOLECULE SECLECTED -',A10,
* '- HAS ',I2,' SPECTRAL REGIONS ON FILE FSCDXS, BUT THE',
* ' MAXIMUM ALLOWED IS 6 *******',/)
925 FORMAT (/,'******* MOLECULE SELECTED -',A10,'- IS NOT FOUND ON',
* ' FILE FSCDXS *******',/)
C
END
BLOCK DATA BXSECT
C
IMPLICIT REAL*8 (V)
C
C** XSNAME=NAMES, ALIAS=ALIASES OF THE CROSS-SECTION MOLECULES
C** (NOTE: ALL NAMES ARE LEFT-JUSTIFIED)
C
CHARACTER*10 XSFILE,XSNAME,ALIAS
COMMON /XSECTI/ XSMAX(6,5,35),XSTEMP(6,5,35),NPTSFX(5,35),
* NFILEX(5,35),NLIMX
COMMON /XSECTF/ XSFILE(6,5,35),XSNAME(35),ALIAS(4,35)
COMMON /XSECTR/ V1FX(5,35),V2FX(5,35),DVFX(5,35),WXM(35),
* NTEMPF(5,35),NSPECR(35),IXFORM(5,35),
* XSMASS(35),XDOPLR(5,35),NUMXS,IXSBIN
COMMON /XSECTS/ JINPUT,NMODES,NPANEL,NDUM,V1XS,V2XS,DVXS,NPTSXS
C
DATA NMODES / 1 /,NPANEL / 0 /,V1XS / 0.0 /,V2XS / 0.0 /,
* DVXS / 0.0 /,NPTSXS / 0 /
DATA XSMAX / 1050*0.0 /
DATA (ALIAS(1,I),I=1,35)/
* 'CLONO2 ', 'HNO4 ', 'CHCL2F ', 'CCL4 ',
* 'CCL3F ', 'CCL2F2 ', 'C2CL2F4 ', 'C2CL3F3 ',
* 'N2O5 ', 'HNO3 ', 'CF4 ', 'CHCLF2 ',
* 'CCLF3 ', 'C2CLF5 ', 21*' ZZZZZZZZ ' /
DATA (ALIAS(2,I),I=1,35)/
* 'CLNO3 ', ' ZZZZZZZZ ', 'CFC21 ', ' ZZZZZZZZ ',
* 'CFCL3 ', 'CF2CL2 ', 'C2F4CL2 ', 'C2F3CL3 ',
* ' ZZZZZZZZ ', ' ZZZZZZZZ ', ' ZZZZZZZZ ', 'CHF2CL ',
* ' ZZZZZZZZ ', ' ZZZZZZZZ ', 21*' ZZZZZZZZ ' /
DATA (ALIAS(3,I),I=1,35)/
* ' ZZZZZZZZ ', ' ZZZZZZZZ ', 'CFC21 ', ' ZZZZZZZZ ',
* 'CFC11 ', 'CFC12 ', 'CFC114 ', 'CFC113 ',
* ' ZZZZZZZZ ', ' ZZZZZZZZ ', 'CFC14 ', 'CFC22 ',
* 'CFC13 ', 'CFC115 ', 21*' ZZZZZZZZ ' /
DATA (ALIAS(4,I),I=1,35)/
* ' ZZZZZZZZ ', ' ZZZZZZZZ ', 'F21 ', ' ZZZZZZZZ ',
* 'F11 ', 'F12 ', 'F114 ', 'F113 ',
* ' ZZZZZZZZ ', ' ZZZZZZZZ ', 'F14 ', 'F22 ',
* 'F13 ', 'F115 ', 21*' ZZZZZZZZ ' /
C
C XSMASS IS MASS OF EACH CROSS-SECTION
C
DATA XSMASS/
1 97.46 , 79.01 , 102.92 , 153.82 ,
2 137.37 , 120.91 , 170.92 , 187.38 ,
3 108.01 , 63.01 , 88.00 , 86.47 ,
4 104.46 , 154.47 , 21*0.00 /
C
DATA V1FX / 175*0.0 /,V2FX / 175*0.0 /,DVFX / 175*0.0 /,
* WXM / 35*0.0 /
DATA NTEMPF / 175*0 /,NSPECR / 35*0 /,IXFORM / 175*0 /,
* NUMXS / 0 /
C
END
SUBROUTINE CLJUST (CNAME,NCHAR) 7
C
C THIS SUBROUTINE LEFT-JUSTIFIES THE CHARACTER CNAME
C
CHARACTER*(*) CNAME
CHARACTER*25 CTEMP
CHARACTER*1 CTEMP1(25),BLANK
EQUIVALENCE (CTEMP,CTEMP1(1))
C
DATA BLANK / ' '/
C
CTEMP = CNAME
JJ=0
DO 10 J = 1, NCHAR
IF (CTEMP1(J).NE.BLANK) THEN
JJ = J
IF (JJ.EQ.1) GO TO 50
GO TO 20
ENDIF
10 CONTINUE
IF (JJ .EQ. 0) GO TO 50
C
20 KCNT = 0
DO 30 K = JJ, NCHAR
KCNT = KCNT+1
CTEMP1(KCNT) = CTEMP1(K)
30 CONTINUE
C
KK = NCHAR-JJ+2
DO 40 L = KK,NCHAR
CTEMP1(L) = BLANK
40 CONTINUE
CNAME = CTEMP
50 CONTINUE
C
RETURN
C
END
SUBROUTINE XSECTM (IFST,IR4) 2,23
C
IMPLICIT REAL*8 (V)
C
C THIS SUBROUTINE MOVES THE CROSS SECTIONS INTO
C THE APPROPRIATE ARRAY R1, R2, R3, R4, OR ABSRB
C
C A.E.R. INC. (AUGUST 1990)
C
COMMON VNU(250),SP(250),ALFA0(250),EPP(250),MOL(250),HWHMS(250),
* TMPALF(250),PSHIFT(250),IFLG(250),SPPSP(250),RECALF(250),
* ZETAI(250),IZETA(250)
COMMON RR1(6099),RR2(2075),RR3(429)
COMMON /IOU/ IOUT(250)
COMMON /ABSORB/ V1ABS,V2ABS,DVABS,NPTABS,ABSRB(2030)
COMMON /MANE/ P0,TEMP0,NLAYRS,DVXM,H2OSLF,WTOT,ALBAR,ADBAR,AVBAR,
* AVFIX,LAYRFX,SECNT0,SAMPLE,DVSET,ALFAL0,AVMASS,
* DPTMIN,DPTFAC,ALTAV,AVTRAT,TDIFF1,TDIFF2,ALTD1,
* ALTD2,ANGLE,IANT,LTGNT,LH1,LH2,IPFLAG,PLAY,TLAY,
* EXTID(10)
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SECANT, XALTZ
C
COMMON /FILHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DV ,V1 ,V2 ,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
COMMON /CONSTS/ PI,PLANCK,BOLTZ,CLIGHT,AVOG,RADCN1,RADCN2
COMMON /XSUB/ VBOT,VTOP,VFT,LIMIN,ILO,IHI,IEOF,IPANEL,ISTOP,IDATA
COMMON /LBLF/ V1R4,V2R4,DVR4,NPTR4,BOUND4,R4(2502),RR4(2502)
COMMON /CMSHAP/ HWF1,DXF1,NX1,N1MAX,HWF2,DXF2,NX2,N2MAX,
* HWF3,DXF3,NX3,N3MAX
COMMON /SUB1/ MAX1,MAX2,MAX3,NLIM1,NLIM2,NLIM3,NLO,NHI,DVR2,DVR3,
* N1R1,N2R1,N1R2,N2R2,N1R3,N2R3
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL,TF4,TF4RDF,TF4CNV,
* TF4PNL,TXS,TXSRDF,TXSCNV,TXSPNL
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /XSHEAD/ HEADT1(35)
COMMON /XSTMPR/ PF,TF,PDX(6,5,35),DVXPR(5,35),IXBIN(5,35),
* IXSBN(5,35)
COMMON /XSECTP/ V1X,V2X,DVX,NPTSX,RX(13000)
COMMON /XSECTD/ V1DX,V2DX,DVDX,NPTSDX,RDX1(520),RDX2(520)
COMMON /XSECTF/ XSFILE(6,5,35),XSNAME(35),ALIAS(4,35)
COMMON /XSECTR/ V1FX(5,35),V2FX(5,35),DVFX(5,35),WXM(35),
* NTEMPF(5,35),NSPECR(35),IXFORM(5,35),
* XSMASS(35),XDOPLR(5,35),NUMXS,IXSBIN
COMMON /XSECTI/ XSMAX(6,5,35),XSTEMP(6,5,35),NPTSFX(5,35),
* NFILEX(5,35),NLIMX
COMMON /XSECTS/ JINPUT,NMODES,NPANEL,NDUM,V1XS,V2XS,DVXS,NPTSXS
CHARACTER*10 XSFILE,XSNAME,ALIAS
CHARACTER HEADT1*100
C
DIMENSION R1(4050),R2(1050),R3(300)
DIMENSION FILHDR(2)
LOGICAL OPCL
C
EQUIVALENCE (R1(1),RR1(2049)),(R2(1),RR2(1025)),(R3(1),RR3(129))
EQUIVALENCE (IHIRAC,FSCDID(1)) , (ILBLF4,FSCDID(2)),
* (IXSCNT,FSCDID(3)) , (IAERSL,FSCDID(4)),
* (JRAD,FSCDID(9)) , (IATM,FSCDID(15)),
* (XID(1),FILHDR(1))
C
DATA IFILE,JFILE / 91,92 /
C
C**********************************************************************
C NUMXS IS THE NUMBER OF 'CROSS SECTION' MOLECULES TO BE USED
C
C XSFILE(ITEMP,ISPEC,NXS) IS THE NAME OF THE FILE CONTAINING THE
C 'CROSS SECTION' DATA. THE THREE INDICES
C ARE DEFINED AS FOLLOWS:
C
C ITEMP - DENOTES THE TEMPERATURE FOR WHICH
C THE 'CROSS SECTION' IS VALID
C (IMPLEMENTED FOR HITRAN 91 TAPE)
C ISPEC - DENOTES THE SECTRAL REGION FOR
C WHICH THE FILE PERTAINS
C NXS - IS THE INCREMENT FOR THE 'CROSS
C SECTION' INDEX
C
C NTEMPF(ISPEC,NXS) IS THE NUMBER OF TEMPERATURE FILES TO BE USED
C FOR EACH SPECTRAL REGION OF EACH MOLECULE
C
C NSPECR(NXS) IS THE NUMBER OF SPECTRAL REGIONS FOR THE MOLECULE NX
C**********************************************************************
C
NLIMX = 510
LIMOUT = 13000
IRPEAT = 0
C
PF = PAVE
TF = TAVE
C
C IF FIRST ENTRANCE, RESET QUANTITES
C
IF (IFST.EQ.-99) THEN
IFST = 0
JINPUT = -1
NMODES = 1
C
V1X = V1XS
V2X = V2XS
DVX = DVXS
NPTSX = NPTSXS
C
DO 10 NI = 1, NUMXS
DO 9 NS = 1, NSPECR(NI)
IXBIN(NS,NI) = 1
IXSBN(NS,NI) = 0
NFILEX(NS,NI) = ABS(NFILEX(NS,NI))
9 continue
10 CONTINUE
ENDIF
C
C CHECK V1X FOR INPUT
C
20 VFX2 = VFT+2.*DVX+FLOAT(NHI)*DV
IF (IR4.EQ.1) VFX2 = V2R4+2.*DVX
IF (V1X.GT.VFX2) GO TO 140
C
IF (JINPUT.EQ.-1) THEN
JINPUT = 1
ELSE
VFX2 = MIN(VFX2,V2+2.*DVX)
IF (VFX2.GT.V2X) THEN
JINPUT = 1
IF (IRPEAT.EQ.1) THEN
V1X = V2X-2.*DVX
ELSE
V1X = VFT-2.*DVX
IF (IR4.EQ.1) V1X = V1R4-2.*DVX
ENDIF
V2X = V1X+FLOAT(LIMOUT-1)*DVX
IF (V2X.GT.V2) V2X = V1X+FLOAT(INT((V2-V1X)/DVX)+3)*DVX
NPTSX = (V2X-V1X)/DVX+1
ENDIF
IFL = 0
V1XT = V1X+2.*DVX
V2XT = V2X-2.*DVX
IF (V1XT.GT.V2XT) GO TO 140
DO 30 NI = 1, NUMXS
DO 29 NS = 1, NSPECR(NI)
IF (NFILEX(NS,NI).EQ.0) GO TO 30
IF (V1FX(NS,NI).LE.V1XT.AND.V2FX(NS,NI).GE.V1XT) IFL = 1
IF (V1FX(NS,NI).LE.V2XT.AND.V2FX(NS,NI).GE.V2XT) IFL = 1
IF (V1FX(NS,NI).GE.V1XT.AND.V2FX(NS,NI).LE.V2XT) IFL = 1
29 CONTINUE 40
30 CONTINUE
IF (IFL.EQ.0) GO TO 140
ENDIF
C
C READ IN CROSS SECTION
C
IF (JINPUT.EQ.1) THEN
JINPUT = 0
DO 40 I = 1, LIMOUT
RX(I) = 0.0
40 CONTINUE
DO 50 I = 1, NLIMX+10
RDX1(I) = 0.0
RDX2(I) = 0.0
50 CONTINUE
C
C FOR NPANEL = 0, READ IN FILE HEADERS
C
IF (NPANEL.EQ.0) THEN
DVXMIN = V2-V1
V1XMIN = V2
IMAX = 0
NT2 = 0
NMODE = 0
DO 60 NI = 1, NUMXS
DO 59 NS = 1, NSPECR(NI)
DO 58 NT1 = 1, NTEMPF(NS,NI)
NFILEX(NS,NI) = 1
CALL CPUTIM (TIME0)
CALL XSECIN (NPANEL,NI,NS,NT1,NT2,NMODE,NSKIP,
* IMAX,NEOF)
CALL CPUTIM (TIME)
TXSRDF = TXSRDF+TIME-TIME0
C
C CHECK FOR WAVENUMBER BOUNDS AND SMALLEST DV
C
IF (V1DX.GT.V2.OR.V2DX.LT.V1.OR.NEOF.EQ.1) THEN
NFILEX(NS,NI) = 0
ELSE
DVXMIN = MIN(DVXMIN,DVDX)
V1XMIN = MIN(V1XMIN,V1DX)
V1FX(NS,NI) = V1DX
V2FX(NS,NI) = V2DX
DVFX(NS,NI) = DVDX
NPTSFX(NS,NI) = NPTSDX
ENDIF
C
Cmji CHECK FOR TEMPERATURES; MUST BE IN ASCENDING ORDER
C
IF (NT1.GT.1.AND.XSTEMP(NT1,NS,NI).LT.
* XSTEMP(NT1-1,NS,NI)) THEN
WRITE(IPR,900)
STOP 'XSTEMP - XSECTM'
ENDIF
58 CONTINUE
59 CONTINUE 00
60 CONTINUE
DVX = DVXMIN
V1X = MAX(VFT,V1XMIN)
V1X = V1X-2.*DVX
V2X = V1X+FLOAT(LIMOUT-1)*DVX
IF (V2X.GT.V2) V2X = V1X+FLOAT(INT((V2-V1X)/DVX)+2)*DVX
NPTSX = (V2X-V1X)/DVX+1
V1XS = V1X
V2XS = V2X
DVXS = DVX
NPTSXS = NPTSX
IF (V1X.GT.VFX2) THEN
JINPUT = 1
NPANEL = -1
GO TO 140
ENDIF
ENDIF
C
NFILET = 0
NMODES = 0
C
DO 110 NI = 1, NUMXS
DO 109 NS = 1, NSPECR(NI)
NPANEL = -1
IF (NFILEX(NS,NI).LE.0) GO TO 105
IF (V1FX(NS,NI).GT.V2X) GO TO 105
IF (V2FX(NS,NI).LT.V1X) THEN
NFILEX(NS,NI) = -NFILEX(NS,NI)
GO TO 105
ENDIF
C
C DETERMINE TEMPERATURE FILES AND TEST ON DPTMIN
C
CALL XSNTMP (NI,NS,NT1,NT2,NMODE)
C
C DPTMIN TEST - IF NMODE = 0, SKIP CROSS SECTION
C
IF (NMODE.EQ.0) GO TO 105
NMODES = NMODES+NMODE
C
C FOR PRESSURE BROADENED CROSS-SECTION
C CREATE TEMPERATURE AVERAGED BINARY FILE
C
IF (IXSBIN.EQ.0.AND.IXBIN(NS,NI).EQ.1) THEN
CALL CPUTIM (TIME0)
CALL XSBINF (NI,NS,NT1,NT2,NMODE)
CALL CPUTIM (TIME)
TXSCNV = TXSCNV+TIME-TIME0
IXBIN(NS,NI) = 0
ENDIF
IF (IXSBN(NS,NI).EQ.1) THEN
DVFXX = DVXPR(NS,NI)
ELSE
DVFXX = DVFX(NS,NI)
ENDIF
NFILET = NFILET+NFILEX(NS,NI)
C
NNSKIP = (V1X-V1FX(NS,NI))/DVFXX
NSKIP = (NNSKIP-3)/10
NSKIP = MAX(NSKIP,0)
NRSKIP = NSKIP*10
NBSKIP = NSKIP
C
C FOR BLOCKED DATA, V1FP MUST REFLECT SHORT RECORD
C
IAFORM = ABS(IXFORM(NS,NI))
IF (IXSBN(NS,NI).EQ.1) IAFORM = IAFORM+100
IF (IAFORM.GT.100) THEN
NBSKIP = NSKIP/51
NRSKIP = (NBSKIP-1)*510+500
NRSKIP = MAX(NRSKIP,0)
ENDIF
V1FP = V1FX(NS,NI)+FLOAT(NRSKIP)*DVFXX
V2FP = V2X+2.0*DVFXX
V2FP = MIN(V2FP,V2FX(NS,NI))
NMAX = (V2FP-V1FP)/DVFXX+1.
NPAN = (NMAX+NLIMX-1)/NLIMX
IF (IAFORM.GT.100.AND.NPANEL.LE.0.AND.NBSKIP.EQ.0) THEN
NPTST = NMAX-500-(NPAN-1)*NLIMX
IF (NPTST.GT.0) NPAN = NPAN+1
IF (NMAX.GT.500) NMAX = NMAX+10
ENDIF
N2RX = ((V1FP-4.*DVFXX-V1X)/DVX+0.999)-1.
N2RX = MAX(N2RX,0)
C
C IMAX = -4 TO PLACE THE FIRST PANEL V1 AT ARRAY LOCATION 1
C
IMAX = -4
DO 100 NP = 1, NPAN
V1FP = V1FP+FLOAT(IMAX)*DVFXX
IMAX = NMAX-(NP-1)*NLIMX
IF (IAFORM.GT.100.AND.NPANEL.LE.0.AND.
* NBSKIP.EQ.0.AND.IMAX.GT.500) IMAX = 500
IMAX = MIN(IMAX,NLIMX)
C
C FOR V2FP IMAX + 3 GIVES US ARRAY LOCATION 514
C (504 FOR FIRST PANEL OF BLOCKED DATA)
C
V2FP = V1FP+FLOAT(IMAX+3)*DVFXX
C
IF (NP.GT.1) THEN
DO 70 JI = 1, 4
RDX1(JI) = RDX1(JI+IMAXSV)
RDX2(JI) = RDX2(JI+IMAXSV)
70 CONTINUE
ENDIF
IMAXSV = IMAX
C
CALL CPUTIM (TIME0)
CALL XSECIN (NPANEL,NI,NS,NT1,NT2,NMODE,NSKIP,IMAX,
* NEOF)
CALL CPUTIM (TIME)
TXSRDF = TXSRDF+TIME-TIME0
C
IF (NP.EQ.1) THEN
DO 80 JI = 1, 4
RDX1(JI) = RDX1(5)
RDX2(JI) = RDX2(5)
80 CONTINUE
NPANEL = ABS(NPANEL)
NSKIP = 0
ENDIF
C
C IF LAST PANEL OF FILE, FILL IN ADDITIONAL POINTS
C TO ENSURE ENDPOINT CAPTURE
C
IF (NP.EQ.NPAN) THEN
JMAX = IMAX+4
DO 90 JI = 1, 4
KI = JMAX+JI
RDX1(KI) = RDX1(JMAX)
RDX2(KI) = RDX2(JMAX)
90 CONTINUE
C
V2FP = V2FP+3.*DVFXX
ENDIF
C
N1RX = MAX(1,N2RX+1)
N2RX = (V2FP-DVFXX-V1X)/DVX+.999
N2RX = MIN(N2RX,LIMOUT)
C
WXM1 = WXM(NI)
C
C FOR TWO TEMPERATURES LINEARLY INTERPOLATE FACTOR
C
CALL CPUTIM (TIME0)
IF (NMODE.EQ.2.AND.IXBIN(NS,NI).EQ.1) THEN
TFACT2 = (TAVE-XSTEMP(NT1,NS,NI))/
* (XSTEMP(NT2,NS,NI)-XSTEMP(NT1,NS,NI))
TFACT1 = 1.-TFACT2
WXM1 = WXM(NI)*TFACT1
WXM2 = WXM(NI)*TFACT2
CALL XINT (V1FP,V2FP,DVFXX,RDX2,WXM2,V1X,DVX,RX,
* N1RX,N2RX)
ENDIF
CALL XINT (V1FP,V2FP,DVFXX,RDX1,WXM1,V1X,DVX,RX,N1RX,
* N2RX)
CALL CPUTIM (TIME)
TXSPNL = TXSPNL+TIME-TIME0
C
100 CONTINUE
C
C Continue for GOTO statements at E04540, E04550, E04580, &
C E04670.
C
105 CONTINUE
C
109 CONTINUE 20
110 CONTINUE
IF (NFILET.EQ.0) GO TO 140
C
C FACTOR OUT RADIATION FIELD IF REQUIRED
C
IF (JRAD.EQ.0) THEN
CALL CPUTIM (TIME0)
XKT = TAVE/RADCN2
VI = V1X-DVX
VITST = VI
RDLAST = -1.
NPTSI1 = 0
NPTSI2 = 0
C
120 NPTSI1 = NPTSI2+1
NPTSX = (V2X-V1X)/DVX+1
C
VI = V1X+FLOAT(NPTSI1-1)*DVX
RADVI = RADFNI(VI,DVX,XKT,VITST,RDEL,RDLAST)
C
NPTSI2 = (VITST-V1X)/DVX+1.001
NPTSI2 = MIN(NPTSI2,NPTSX)
C
DO 130 I = NPTSI1, NPTSI2
VI = VI+DVX
RX(I) = RX(I)/RADVI
RADVI = RADVI+RDEL
130 CONTINUE
C
IF (NPTSI2.LT.NPTSX) GO TO 120
CALL CPUTIM (TIME)
TXSPNL = TXSPNL+TIME-TIME0
C
ENDIF
ENDIF
IF (NMODES.EQ.0) GO TO 140
C
C DETERMINE TARGET ARRAY
C
C ===> R1
C
CALL CPUTIM (TIME0)
IF (DVX.LT.DVR2) THEN
CALL XINT (V1X,V2X,DVX,RX,1.0,VFT,DV,R1,N1R1,N2R1)
IR4 = 0
C
C ===> R2
C
ELSEIF (DVX.LT.DVR3) THEN
CALL XINT (V1X,V2X,DVX,RX,1.0,VFT,DVR2,R2,N1R2,N2R2)
IR4 = 0
C
C ===> R3
C
ELSEIF (DVX.LT.DVR4.OR.ILBLF4.EQ.0) THEN
CALL XINT (V1X,V2X,DVX,RX,1.0,VFT,DVR3,R3,N1R3,N2R3)
IR4 = 0
C
C ===> R4
C
ELSE
CALL XINT (V1X,V2X,DVX,RX,1.0,V1R4,DVR4,R4,1,NPTR4)
IF (IR4.EQ.0) VFX2 = V2R4+2.*DVX
IR4 = 1
ENDIF
CALL CPUTIM (TIME)
TXSPNL = TXSPNL+TIME-TIME0
C
IRPEAT = 1
IF (VFX2.GT.V2X) GO TO 20
C
140 INQUIRE (UNIT=IFILE,OPENED=OPCL)
IF (OPCL) CLOSE (IFILE)
INQUIRE (UNIT=JFILE,OPENED=OPCL)
IF (OPCL) CLOSE (JFILE)
IF (NMODES.EQ.0) IR4 = 1
C
900 FORMAT(/,'******* ERROR IN XSECTM *******',/
* 'CROSS-SECTION FILES MUST BE IN ASCENDING ORDER ',
* 'BY TEMPERATURE IN FSCDXS.')
RETURN
C
END
SUBROUTINE XSECIN (NPANEL,NI,NS,NT1,NT2,NMODE,NSKIP,NMAX,IEOF) 3,14
C
IMPLICIT REAL*8 (V)
C
C THIS SUBROUTINE READS IN THE DESIRED CROSS SECTIONS
C
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
C
CHARACTER*8 XI1, HMOLI1, YID1
Real*8 SECAN1, XALT1
C
COMMON /FXSHDR/ XI1(10),SECAN1,PAV1,TAV1,HMOLI1(60),XALT1(4),
* W1(60),P1L,P1U,T1L,T1U,WBROA1,DVB,V1B,V2B,TBOUN1,
* EMISI1,FSCDI1(17),NMO1,LAYER1,Y11,YID1(10),LSTWD1
COMMON /PXSHDR/ V1PX,V2PX,DVPX,NLIMPX,RBX(2050)
COMMON /XSECTP/ V1X,V2X,DVX,NPTSX,RX(13000)
COMMON /XSECTD/ V1DX,V2DX,DVDX,NPTSDX,RDX1(520),RDX2(520)
COMMON /XSECTF/ XSFILE(6,5,35),XSNAME(35),ALIAS(4,35)
COMMON /XSECTR/ V1FX(5,35),V2FX(5,35),DVFX(5,35),WXM(35),
* NTEMPF(5,35),NSPECR(35),IXFORM(5,35),
* XSMASS(35),XDOPLR(5,35),NUMXS,IXSBIN
COMMON /XSECTI/ XSMAX(6,5,35),XSTEMP(6,5,35),NPTSFX(5,35),
* NFILEX(5,35),NLIMX
COMMON /XSHEAD/ HEADT1(35)
COMMON /XSTMPR/ PF,TF,PDX(6,5,35),DVXPR(5,35),IXBIN(5,35),
* IXSBN(5,35)
COMMON /FLFORM/ CFORM
C
CHARACTER*10 XSFILE,XSNAME,ALIAS,SOURCE(3),CTORR
CHARACTER AMOL*8,BMOL*6,HEADER*100,HEADT1*100
CHARACTER XSFIL1*10,XSFIL2*10,XSTMP*4,XSNUM*3,CI*1
CHARACTER CFORM*11,BFRM*10,UNBFRM*10,BLKFRM*10,BFORM*9
LOGICAL OP,OPCL
DIMENSION RDXX1(516),RDXX2(516),RDXA1(510),RDXA2(510),RDXH1(500),
* RDXH2(500),FILHDR(2),PNLHDR(2),DUM(2)
C
EQUIVALENCE (RDX1(5),RDXX1(1),RDXA1(1),RDXH1(1)),
* (RDX2(5),RDXX2(1),RDXA2(1),RDXH2(1)),
* (XI1(1),FILHDR(1)) , (V1PX,PNLHDR(1))
C
DATA XSTMP / 'TMPX'/,LIMXX / 516 /,BFORM / 'FORMATTED'/
DATA IFILE,JFILE / 91,92 /
DATA UNBFRM / '(10E10.3)'/,BLKFRM / '(510E10.3)'/
DATA CTORR / ' TORR'/
C
C DEFINE PRESSURE CONVERSIONS
C
C PTORMB = 1013. MB / 760. TORR (TORR TO MILLIBARS)
C PATMMB = 1013. MB / 1.0 ATM (ATMOPHERES TO MILLIBARS)
C
PTORMB = 1013./760.
PATMMB = 1013.
C
IEOF = 0
ISFORM = IXFORM(NS,NI)
NXMODE = NMODE
IF (IXSBN(NS,NI).EQ.1) THEN
IF (ABS(ISFORM).LT.100) ISFORM = ABS(ISFORM)+100
ISFORM = -ISFORM
NXMODE = 1
ENDIF
IAFORM = ABS(ISFORM)
IMFORM = MOD(IAFORM,100)
C
C IF NPANEL <= 0, OPEN FILE AND READ HEADER
C
IF (NPANEL.LE.0) THEN
IF (IXSBN(NS,NI).EQ.0) THEN
XSFIL1 = XSFILE(NT1,NS,NI)
ELSE
WRITE (XSNUM,'(I1,I2.2)') NS,NI
XSFIL1 = XSTMP//XSNUM
ENDIF
C
INQUIRE (FILE=XSFIL1,OPENED=OP)
INQUIRE (UNIT=IFILE,OPENED=OPCL)
IF (.NOT.OP.AND.OPCL) CLOSE (IFILE)
IF (.NOT.OP) THEN
IF (ISFORM.GT.0) THEN
OPEN (IFILE,FILE=XSFIL1,STATUS='OLD',FORM=BFORM)
ELSE
OPEN (IFILE,FILE=XSFIL1,STATUS='OLD',FORM=CFORM)
ENDIF
ENDIF
REWIND IFILE
IF (NXMODE.EQ.2) THEN
XSFIL2 = XSFILE(NT2,NS,NI)
C
INQUIRE (FILE=XSFIL2,OPENED=OP)
INQUIRE (UNIT=JFILE,OPENED=OPCL)
IF (.NOT.OP.AND.OPCL) CLOSE (JFILE)
IF (.NOT.OP) THEN
IF (ISFORM.GT.0) THEN
OPEN (JFILE,FILE=XSFIL2,STATUS='OLD',FORM=BFORM)
ELSE
OPEN (JFILE,FILE=XSFIL2,STATUS='OLD',FORM=CFORM)
ENDIF
ENDIF
REWIND JFILE
ENDIF
C
C HEADER: 86 FORMAT
C
C AMOL,V1,V2,NPTS,BMOL,PRES,ICM,ITEMP,SOURCE
C
C HEADER: 91 FORMAT
C
C AMOL,V1,V2,NPTS,TEMP,PRES,SMAX,SOURCE
C
C
C IAFORM < 100, UNBLOCKED DATA (100 CHARACTERS/RECORD)
C
IF (IAFORM.LT.100) THEN
READ (IFILE,900,END=30) HEADER
HEADT1(NI) = HEADER
IF (IMFORM.EQ.86) THEN
READ (HEADER,905) AMOL,V1DX,V2DX,NPTSDX,BMOL,PRES,ICM,
* ITEMP,SOURCE
IF (NPANEL.EQ.0) THEN
XSTEMP(NT1,NS,NI) = FLOAT(ITEMP)+273.15
XSMAX(NT1,NS,NI) = 0.0
PDX(NT1,NS,NI) = PRES*PTORMB
ENDIF
ELSE
READ (HEADER,910) AMOL,V1DX,V2DX,NPTSDX,TEMP,PRES,SMAX,
* SOURCE
IF (NPANEL.EQ.0) THEN
XSTEMP(NT1,NS,NI) = TEMP
XSMAX(NT1,NS,NI) = SMAX
IF (SOURCE(3).EQ.CTORR) THEN
PDX(NT1,NS,NI) = PRES*PTORMB
ELSE
PDX(NT1,NS,NI) = PRES
ENDIF
ENDIF
ENDIF
IF (NXMODE.EQ.2) THEN
READ (JFILE,900,END=30) HEADER
IF (IMFORM.EQ.86) THEN
READ (HEADER,905) AMOL,V1DX,V2DX,NPTSDX,BMOL,PRES,
* ICM,ITEMP,SOURCE
IF (NPANEL.EQ.0) THEN
XSTEMP(NT2,NS,NI) = FLOAT(ITEMP)+273.15
XSMAX(NT2,NS,NI) = 0.0
PDX(NT2,NS,NI) = PRES*PTORMB
ENDIF
ELSE
READ (HEADER,910) AMOL,V1DX,V2DX,NPTSDX,TEMP,PRES,
* SMAX,SOURCE
IF (NPANEL.EQ.0) THEN
XSTEMP(NT2,NS,NI) = TEMP
XSMAX(NT2,NS,NI) = SMAX
IF (SOURCE(3).EQ.CTORR) THEN
PDX(NT2,NS,NI) = PRES*PTORMB
ELSE
PDX(NT2,NS,NI) = PRES
ENDIF
ENDIF
ENDIF
ENDIF
ELSE
C
C IAFORM > 100, BLOCKED DATA (51*100 CHARACTERS/RECORD)
C
IF (ISFORM.GT.0) THEN
READ (IFILE,915,END=30) HEADER,(RDXX1(J),J=1,500)
ELSE
CALL BUFIN (IFILE,IEOF,FILHDR(1),NFHDRF)
IF (IEOF.LE.0) GO TO 30
WRITE (HEADER,'(10A8)') XI1
CALL BUFIN (IFILE,IEOF,PNLHDR(1),NPHDRF)
IF (IEOF.LE.0) GO TO 30
CALL BUFIN (IFILE,IEOF,RDXH1(1),NLIMPX)
ENDIF
HEADT1(NI) = HEADER
IF (IMFORM.EQ.86) THEN
READ (HEADER,905) AMOL,V1DX,V2DX,NPTSDX,BMOL,PRES,ICM,
* ITEMP,SOURCE
IF (NPANEL.EQ.0) THEN
XSTEMP(NT1,NS,NI) = FLOAT(ITEMP)+273.15
XSMAX(NT1,NS,NI) = 0.0
PDX(NT1,NS,NI) = PRES*PTORMB
ENDIF
ELSE
READ (HEADER,910) AMOL,V1DX,V2DX,NPTSDX,TEMP,PRES,SMAX,
* SOURCE
IF (NPANEL.EQ.0) THEN
XSTEMP(NT1,NS,NI) = TEMP
XSMAX(NT1,NS,NI) = SMAX
IF (SOURCE(3).EQ.CTORR) THEN
PDX(NT1,NS,NI) = PRES*PTORMB
ELSE
PDX(NT1,NS,NI) = PRES
ENDIF
ENDIF
ENDIF
IF (NXMODE.EQ.2) THEN
IF (ISFORM.GT.0) THEN
READ (JFILE,915,END=30) HEADER,(RDXX2(J),J=1,500)
ELSE
CALL BUFIN (JFILE,JEOF,FILHDR(1),NFHDRF)
IF (JEOF.LE.0) GO TO 30
WRITE (HEADER,'(10A8)') XI1
CALL BUFIN (JFILE,JEOF,PNLHDR(1),NPHDRF)
IF (JEOF.LE.0) GO TO 30
CALL BUFIN (JFILE,JEOF,RDXH2(1),NLIMPX)
ENDIF
IF (IMFORM.EQ.86) THEN
READ (HEADER,905) AMOL,V1DX,V2DX,NPTSDX,BMOL,PRES,
* ICM,ITEMP,SOURCE
IF (NPANEL.EQ.0) THEN
XSTEMP(NT2,NS,NI) = FLOAT(ITEMP)+273.15
XSMAX(NT2,NS,NI) = 0.0
PDX(NT2,NS,NI) = PRES*PTORMB
ENDIF
ELSE
READ (HEADER,910) AMOL,V1DX,V2DX,NPTSDX,TEMP,PRES,
* SMAX,SOURCE
IF (NPANEL.EQ.0) THEN
XSTEMP(NT2,NS,NI) = TEMP
XSMAX(NT2,NS,NI) = SMAX
IF (SOURCE(3).EQ.CTORR) THEN
PDX(NT2,NS,NI) = PRES*PTORMB
ELSE
PDX(NT2,NS,NI) = PRES
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
DVDX = (V2DX-V1DX)/FLOAT(NPTSDX-1)
C
C FOR NPANEL = -1, SKIP REQUIRED NUMBER OF RECORDS
C
IF (NPANEL.EQ.-1) THEN
NSTRT = 1
IF (IAFORM.GT.100) THEN
NSKIP = NSKIP/51
NSTRT = 2
IF (NSKIP.EQ.0) RETURN
ENDIF
C
DO 10 I = NSTRT, NSKIP
IF (ISFORM.GT.0) THEN
READ (IFILE,920,END=30) CI
IF (NXMODE.EQ.2) READ (JFILE,920,END=30) CI
ELSE
CALL BUFIN (IFILE,IEOF,PNLHDR(1),NPHDRF)
IF (IEOF.LE.0) GO TO 30
CALL BUFIN (IFILE,IEOF,DUM(1),1)
IF (NXMODE.EQ.2) THEN
CALL BUFIN (JFILE,JEOF,PNLHDR(1),NPHDRF)
IF (JEOF.LE.0) GO TO 30
CALL BUFIN (JFILE,JEOF,DUM(1),1)
ENDIF
ENDIF
10 CONTINUE
ENDIF
ENDIF
C
C FOR ABS(NPANEL) > 0, READ IN MORE DATA
C
IF (ABS(NPANEL).GT.0) THEN
BFRM = UNBFRM
IF (IAFORM.GT.100) BFRM = BLKFRM
IF (ISFORM.GT.0) THEN
READ (IFILE,BFRM,END=30) (RDXX1(J),J=1,NMAX)
IF (NXMODE.EQ.2)
* READ (JFILE,BFRM,END=30) (RDXX2(J),J=1,NMAX)
ELSE
CALL BUFIN (IFILE,IEOF,PNLHDR(1),NPHDRF)
IF (IEOF.LE.0) GO TO 30
CALL BUFIN (IFILE,IEOF,RDXA1(1),NLIMPX)
IF (NXMODE.EQ.2) THEN
CALL BUFIN (JFILE,JEOF,PNLHDR(1),NPHDRF)
IF (JEOF.LE.0) GO TO 30
CALL BUFIN (JFILE,JEOF,RDXA2(1),NLIMPX)
ENDIF
ENDIF
ENDIF
C
DO 20 I = NMAX+1, LIMXX
RDXX1(I) = 0.0
IF (NXMODE.EQ.2) RDXX2(I) = 0.0
20 CONTINUE
C
RETURN
C
30 IEOF = 1
C
DO 40 I = NMAX+1, LIMXX
RDXX1(I) = 0.0
IF (NXMODE.EQ.2) RDXX2(I) = 0.0
40 CONTINUE
C
RETURN
C
900 FORMAT (A100)
905 FORMAT (A8,2F10.4,I10,1X,A6,F4.2,5X,I4,3X,I5,3A10)
910 FORMAT (A10,2F10.4,I10,3G10.3,3A10)
915 FORMAT (A100,50(10E10.3))
920 FORMAT (A1)
C
END
SUBROUTINE XSNTMP (NI,NS,NT1,NT2,NMODE) 1,2
C
IMPLICIT REAL*8 (V)
C
C THIS SUBROUTINE DETERMINES THE CORRECT MODE
C AND BRACKETS THE LAYER TEMPERATURE
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SECANT, XALTZ
C
COMMON /FILHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DV ,V1 ,V2 ,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
COMMON /MANE/ P0,TEMP0,NLAYRS,DVXM,H2OSLF,WTOT,ALBAR,ADBAR,AVBAR,
* AVFIX,LAYRFX,SECNT0,SAMPLE,DVSET,ALFAL0,AVMASS,
* DPTMIN,DPTFAC,ALTAV,AVTRAT,TDIFF1,TDIFF2,ALTD1,
* ALTD2,ANGLE,IANT,LTGNT,LH1,LH2,IPFLAG,PLAY,TLAY,
* EXTID(10)
COMMON /CONSTS/ PI,PLANCK,BOLTZ,CLIGHT,AVOG,RADCN1,RADCN2
COMMON /XSECTP/ V1X,V2X,DVX,NPTSX,RX(13000)
COMMON /XSECTD/ V1DX,V2DX,DVDX,NPTSDX,RDX1(520),RDX2(520)
COMMON /XSECTF/ XSFILE(6,5,35),XSNAME(35),ALIAS(4,35)
COMMON /XSECTR/ V1FX(5,35),V2FX(5,35),DVFX(5,35),WXM(35),
* NTEMPF(5,35),NSPECR(35),IXFORM(5,35),
* XSMASS(35),XDOPLR(5,35),NUMXS,IXSBIN
COMMON /XSECTI/ XSMAX(6,5,35),XSTEMP(6,5,35),NPTSFX(5,35),
* NFILEX(5,35),NLIMX
CHARACTER*10 XSFILE,XSNAME,ALIAS
C
EQUIVALENCE (JRAD,FSCDID(9))
C
NT1 = 0
NT2 = 0
C
IF (NTEMPF(NS,NI).LE.1) THEN
NMODE = 1
NT1 = 1
NT2 = 1
ELSE
NMODE = 2
DO 10 I = 2, NTEMPF(NS,NI)
IF (TAVE.LT.XSTEMP(I,NS,NI)) THEN
NT1 = I-1
NT2 = I
GO TO 20
ENDIF
10 CONTINUE
ENDIF
C
20 IF (NT1.EQ.0) THEN
NT2 = NTEMPF(NS,NI)
NT1 = NT2-1
ENDIF
C
C CHECK VERSUS DPTMIN
C
IF (XSMAX(NT1,NS,NI).NE.0.0) THEN
WXM1 = WXM(NI)*XSMAX(NT1,NS,NI)
IF (WXM1.LT.DPTMIN) IDPTMN = IDPTMN+1
WXM2 = 0.0
IF (NMODE.EQ.2) THEN
WXM2 = WXM(NI)*XSMAX(NT2,NS,NI)
IF (WXM2.LT.DPTMIN) IDPTMN = IDPTMN+1
ENDIF
IF (JRAD.EQ.0) THEN
XKT1 = XSTEMP(NT1,NS,NI)/RADCN2
IF (NMODE.EQ.2) XKT2 = XSTEMP(NT2,NS,NI)/RADCN2
VI = V1FX(NS,NI)
C
RADVI1 = RADFN(VI,XKT1)
IF (NMODE.EQ.2) RADVI2 = RADFN(VI,XKT2)
WXM1 = WXM(NI)*XSMAX(NT1,NS,NI)/RADVI1
IF (NMODE.EQ.2) WXM2 = WXM(NI)*XSMAX(NT2,NS,NI)/RADVI2
ENDIF
C
C DETERMINE IDPTMN --- IF IDPTMN = NMODE ==> BELOW THRESHOLD
C SKIP CROSS SECTION
C
IDPTMN = 0
IF (IDPTMN.EQ.NMODE) NMODE = 0
ENDIF
C
RETURN
C
END
SUBROUTINE XSBINF (NI,NS,NT1,NT2,NMODE) 1,10
C
IMPLICIT REAL*8 (V)
C
C THIS SUBROUTINE PERFORMS A TEMPERATURE DEPENDENT CONVOLUTION
C ON THE CROSS-SECTIONS PRODUCING A BINARY INTERMEDIATE FILE
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SECANT, XALTZ
C
COMMON /FILHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DV0,V10,V20,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
C
CHARACTER*8 XI1, HMOLI1, YID1
Real*8 SECAN1, XALT1
C
COMMON /FXSHDR/ XI1(10),SECAN1,PAV1,TAV1,HMOLI1(60),XALT1(4),
* W1(60),P1L,P1U,T1L,T1U,WBROA1,DVB,V1B,V2B,TBOUN1,
* EMISI1,FSCDI1(17),NMO1,LAYER1,Y11,YID1(10),LSTWD1
COMMON /PXSHDR/ V1PX,V2PX,DVPX,NLIMPX,RBX(2050)
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /SSUBS/ VFT,VBOT,VTOP,V1,V2,DVO,NLIMF,NSHIFT,MAXF,ILO,IHI,
* NLO,NHI,RATIO,SUMIN,IRATSH,SRATIO,IRATM1,NREN,
* DVSC,XDUM,V1SHFT
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL,TF4,TF4RDF,TF4CNV,
* TF4PNL,TXS,TXSRDF,TXSCNV,TXSPNL
COMMON /CONTRL/ IEOFSC,IPANEL,ISTOP,IDATA,JVAR,JABS
COMMON /LAMCHN/ ONEPL,ONEMI,EXPMIN,ARGMIN
COMMON /CMSHAP/ HWF,DXF,NF,NFMAX,HWF2,DXF2,NX2,N2MAX,
* HWF3,DXF3,NX3,N3MAX
COMMON /XSCINF/ HWHM,JEMIT,JFN,SAMPLE,SCANID,NPTS,XF(851)
C
COMMON /CONSTS/ PI,PLANCK,BOLTZ,CLIGHT,AVOG,RADCN1,RADCN2
COMMON /XSECTP/ V1X,V2X,DVX,NPTSX,RX(13000)
COMMON /XSECTD/ V1DX,V2DX,DVDX,NPTSDX,RDX1(520),RDX2(520)
COMMON /XSECTF/ XSFILE(6,5,35),XSNAME(35),ALIAS(4,35)
COMMON /XSECTR/ V1FX(5,35),V2FX(5,35),DVFX(5,35),WXM(35),
* NTEMPF(5,35),NSPECR(35),IXFORM(5,35),
* XSMASS(35),XDOPLR(5,35),NUMXS,IXSBIN
COMMON /XSECTI/ XSMAX(6,5,35),XSTEMP(6,5,35),NPTSFX(5,35),
* NFILEX(5,35),NLIMX
COMMON /XSTMPR/ PF,TF,PDX(6,5,35),DVXPR(5,35),IXBIN(5,35),
* IXSBN(5,35)
COMMON /XSHEAD/ HEADT1(35)
COMMON /FLFORM/ CFORM
C
CHARACTER*10 XSFILE,XSNAME,ALIAS
CHARACTER HEADT1*100,CFORM*11,XSFIL*10,XSTMP*4,XSNUM*3
LOGICAL OP,OPCL
DIMENSION FILHDR(2),PNLHDR(2),FILHDS(2)
C
EQUIVALENCE (IHIRAC,FSCDI1(1)) , (ILBLF4,FSCDI1(2)),
* (IXSCNT,FSCDI1(3)) , (IAERSL,FSCDI1(4)),
* (IEMIT,FSCDI1(5)) , (ISCHDR,FSCDI1(6)),
* (JRAD,FSCDI1(9)) , (XSCID,FSCDI1(12)),
* (XHWHM,FSCDI1(13)) , (IDABS,FSCDI1(14)),
* (IATM,FSCDI1(15)) , (LAYR1,FSCDI1(16)),
* (XI1(1),FILHDR(1)) , (V1PX,PNLHDR(1)),
* (XID(1),FILHDS(1))
C
DATA HWJ / 16. /,DXJ / 0.02 /,NJ / 801 /,NJMX / 851 /,
* SMPLJ / 4. /,XSCAL / 0. /
C
DATA XSTMP / 'TMPX'/
DATA IFILEO,JFILEO / 93,91 /
C
C STANDARD PRESSURE AND TEMPERATURE
C
DATA P0 / 1013. /,T0 / 273.15 /
C
C ASSUMED MEAN HALFWIDTH AT P0 IS 0.10
C DOPPLER VALUES ARE INITIALIZED AT T296.
C
DATA HWHM0 / 0.10 /, T296 / 296.0 /
C
C INITIALIZE IXSBN AND TEMPERATURE RATIO
C
IXSBN(NS,NI) = 0
C
FAC1 = 1.0
FAC2 = 0.0
IF (NMODE.EQ.2) THEN
FAC2 = (TAVE-XSTEMP(NT1,NS,NI))/
* (XSTEMP(NT2,NS,NI)-XSTEMP(NT1,NS,NI))
FAC1 = 1.0-FAC2
ENDIF
PD = PDX(NT1,NS,NI)*FAC1+PDX(NT2,NS,NI)*FAC2
C
C NOTE THAT AT THIS POINT, THE CROSS-SECTIONS HAVE BEEN
C LINEARLY INTERPOLATED IN TEMPERATURE (HENCE TD=TF),
C AND THE CONVOLUTION WILL BE DONE ONLY FOR PRESSURE
C
HWHMF = HWHM0*(PF/P0)*(T0/TF)
HWHMD = HWHM0*(PD/P0)*(T0/TF)
C
C SET MINIMUM HALF-WIDTH TO DOPPLER
C
HDOPLR=XDOPLR(NS,NI)*SQRT(TF/T296)
HWHMD=MAX(HDOPLR,HWHMD)
HWHMSC = HWHMF-HWHMD
IF (HWHMSC/HWHMD.LT.0.1) GO TO 30
HWHM = HWHMSC
C
C BOUND AT THIS POINT IS THE WAVENUMBER VALUE
C OF HALF THE SCANNING FUNCTION
C
DVO = HWHMF/2.0
IF (HWHMSC/2.0.LT.DVFX(NS,NI)) GO TO 30
SAMPLE = HWHM/DVO
XHWHM = HWHM
C
C OPEN FILE AND SET FILHDR
C
INQUIRE (FILE='TMPXBIN',OPENED=OP)
INQUIRE (UNIT=IFILEO,OPENED=OPCL)
IF (.NOT.OP) THEN
IF (OPCL) CLOSE (IFILEO)
OPEN (IFILEO,FILE='TMPXBIN',STATUS='UNKNOWN',FORM=CFORM)
REWIND IFILEO
CALL BUFOUT (IFILEO,FILHDS(1),NFHDRF)
REWIND IFILEO
CALL BUFIN (IFILEO,IEOF,FILHDR(1),NFHDRF)
READ (HEADT1(NI),'(10A8)') XI1
ENDIF
REWIND IFILEO
C
NLIMX = 510
IOTPAN = 1
LPMAX = 0
C
NPAN = (NPTSFX(NS,NI)+9)/NLIMX+1
V1PX = V1FX(NS,NI)
NPANEL = -1
NSKIP = 0
C
DO 20 NP = 1, NPAN
IF (NP.NE.1) NPANEL = 1
NMAX = 510
IF (NP.EQ.1) NMAX = 500
V2PX = V1PX+FLOAT(LPMAX+NMAX-1)*DVFX(NS,NI)
V2PX = MIN(V2PX,V2FX(NS,NI))
NMAX = ((V2PX-V1PX)/DVFX(NS,NI)+ONEPL)-LPMAX
C
IMAX = MIN(NMAX,NLIMX)
C
CALL CPUTIM (TIME0)
CALL XSECIN (NPANEL,NI,NS,NT1,NT2,NMODE,NSKIP,IMAX,NEOF)
CALL CPUTIM (TIME)
TXSRDF = TXSRDF+TIME-TIME0
TXSCNV = TXSCNV-TIME+TIME0
C
DO 10 JI = 1, NMAX
JJ = JI+4
RBX(JI+LPMAX) = FAC1*RDX1(JJ)
IF (NMODE.EQ.2) RBX(JI+LPMAX) = RBX(JI+LPMAX)+FAC2*RDX2(JJ)
10 CONTINUE
C
LPMAX = LPMAX+NMAX
IOTPAN = IOTPAN+1
C
IF (NP.EQ.1) THEN
V1B = V1FX(NS,NI)
V2B = V2FX(NS,NI)
DVB = DVFX(NS,NI)
XSCID = -99
ISCHDR = 0
IEMIT = 0
CALL BUFOUT (IFILEO,FILHDR(1),NFHDRF)
ENDIF
C
IF (IOTPAN.EQ.5.OR.NP.EQ.NPAN) THEN
IOTPAN = 1
DVPX = DVFX(NS,NI)
NLIMPX = LPMAX
CALL BUFOUT (IFILEO,PNLHDR(1),NPHDRF)
CALL BUFOUT (IFILEO,RBX(1),NLIMPX)
LPMAX = 0
V1PX = V2PX+DVFX(NS,NI)
ENDIF
C
20 CONTINUE
C
NSHIFT = 0
C
V1 = V1FX(NS,NI)
V2 = V2FX(NS,NI)
C
JEMIT = 0
JABS = 0
C
HWFSV = HWF
DXFSV = DXF
NFSV = NF
NFMXSV = NFMAX
C
HWF = HWJ
DXF = DXJ
NF = NJ
NFMAX = NJMX
CCP XSCALE = XSCAL
CALL SLRENZ (XF)
C
WRITE (XSNUM,'(I1,I2.2)') NS,NI
XSFIL = XSTMP//XSNUM
C
INQUIRE (FILE=XSFIL,OPENED=OP)
INQUIRE (UNIT=JFILEO,OPENED=OPCL)
IF (.NOT.OP.AND.OPCL) CLOSE (JFILEO)
IF (.NOT.OP) OPEN (JFILEO,FILE=XSFIL,STATUS='UNKNOWN',FORM=CFORM)
REWIND JFILEO
C
CALL XSCNVN (IFILEO,JFILEO,NS,NI)
C
CLOSE (IFILEO)
CLOSE (JFILEO)
C
HWF = HWFSV
DXF = DXFSV
NF = NFSV
NFMAX = NFMXSV
C
IXSBN(NS,NI) = 1
C
30 RETURN
C
END
SUBROUTINE XSCNVN (IFILE,JFILE,NS,NI) 1,10
C
IMPLICIT REAL*8 (V)
C
C DRIVER FOR CONVOLVING SPECTRUM WITH INSTRUMENTAL SCANNING FUNCTIO
C
COMMON /XSCONV/ S(2050),R1(1025)
C
CHARACTER*8 XID, HMOLID, YID
Real*8 SECANT, XALTZ
C
COMMON /SCNHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DV ,V1C,V2C,TBOUND,
* EMISIV,FSCDID(17),NMOL,LAYER ,YI1,YID(10),LSTWDF
COMMON /SSUBS/ VFT,VBOT,VTOP,V1,V2,DVO,NLIMF,NSHIFT,MAXF,ILO,IHI,
* NLO,NHI,RATIO,SUMIN,IRATSH,SRATIO,IRATM1,NREN,
* DVSC,XDUM,V1SHFT
COMMON /CONTRL/ IEOFSC,IPANEL,ISTOP,IDATA,JVAR,JABS
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL,tdum(8)
COMMON /RSCAN/ V1I,V2I,DVI,NNI
COMMON /CMSHAP/ HWF,DXF,NF,NFMAX,HWF2,DXF2,NX2,N2MAX,
* HWF3,DXF3,NX3,N3MAX
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /XSCINF/ HWHM,JEMIT,JFN,SAMPLE,SCANID,NPTS,XF(851)
C
DIMENSION FILHDR(2)
DIMENSION SUMR(4)
C
EQUIVALENCE (FILHDR(1),XID(1)) , (FSCDID(5),IEMIT),
* (FSCDID(6),ISCHDR) , (FSCDID(12),XSCID),
* (FSCDID(13),XHWHM) , (FSCDID(14),IDABS),
* (FSCDID(16),LAYR1)
C
C IUNIT INPUT FILE
C JUNIT OUTPUT FILE
C
IUNIT = IFILE
JUNIT = JFILE
NREN = 0
IDABS = 0
JVAR = 0
IPRT = 0
C
IF (JEMIT.LT.0) THEN
JABS = 1
JEMIT = 0
IDABS = -1
ENDIF
IDABST = IDABS
IFILST = 1
NIFILS = 9999
C
SUMOUT = 0.
SMIN = 999999.
SMAX = -99999.
DVOSAV = 0.
SUMR(1) = SUMOUT
SUMR(2) = SMIN
SUMR(3) = SMAX
SUMR(4) = DVOSAV
C
REWIND IUNIT
CALL BUFIN (IUNIT,IEOF,FILHDR(1),NFHDRF)
IF (IEOF.EQ.0) GO TO 50
C
DVSAV = DV
IDABS = IDABST
C
ISCAN = ISCHDR
JTREM = 3
C
C JTREM=3 SCANFN CONVOLVED WITH OPTICAL DEPTH
C
DVI = DV
C
C BOUND AT THIS POINT IS THE WAVENUMBER VALUE
C OF HALF THE SCANNING FUNCTION
C
BOUND = HWF*HWHM
DV = DVO
V1C = V1
V2C = V2
XHWHM = HWHM
IEMIT = 0
CALL BUFOUT (JUNIT,FILHDR(1),NFHDRF)
NBOUND = (2.*HWF)*SAMPLE+0.01
C
C BOUND AT THIS POINT IS THE WAVENUMBER VALUE
C OF THE FULL SCANNING FUNCTION
C
BOUND = FLOAT(NBOUND)*DVO/2.
C
NXPAN = 500
NLO = NBOUND+1
NLIMF = NLO+NXPAN-NSHIFT
NHI = NLIMF+NSHIFT-1
MAXF = NLIMF+2*NBOUND
C
TIMRDF = 0.
TIMCNV = 0.
TIMPNL = 0.
IEOFSC = 1
SUMIN = 0.
DO 10 I = 1, MAXF
R1(I) = 0.
10 CONTINUE
INIT = 0
IDATA = -1
VFT = V1-2.*BOUND
VBOT = V1-BOUND
VTOP = V2+BOUND
C
20 CALL CPUTIM (TIME0)
IF (IEOFSC.LE.0) GO TO 40
CALL RDSCAN (S,JTREM,IUNIT,ISCAN,IPRT)
C
CALL CPUTIM (TIME)
TIMRDF = TIMRDF+TIME-TIME0
C
IF (IEOFSC.LE.0) GO TO 40
CALL SHRKSC (INIT,HWHM)
C
C SHRKSC MAY SHRINK (COMPRESS) THE DATA;
C DVI IS MODIFIED ACCORDINGLY
C
30 CONTINUE
CALL CONVSC (S,HWHM,R1,XF)
C
IF (IPANEL.EQ.0) GO TO 20
C
40 CALL PNLCNV (R1,JUNIT,SUMR,NPTS,NS,NI)
IF ((ISTOP.NE.1).AND.(IEOFSC.GT.0)) GO TO 30
IF (ISTOP.NE.1) GO TO 40
CALL CPUTIM (TIME)
C
SUMIN = SUMIN*DVSAV
C
IF (IEOFSC.EQ.1) CALL SKIPFL (1,IUNIT,IEOFSC)
C
IEOFT = IEOFT+1
C
SUMOUT = SUMR(1)
SMIN = SUMR(2)
SMAX = SUMR(3)
DVOSAV = SUMR(4)
C
SUMOUT = SUMOUT*DVOSAV
C
50 RETURN
C
END
SUBROUTINE PNLCNV (R1,JFILE,SUMR,NPTS,NS,NI) 1,4
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE PNLCNV OUTPUTS THE RESULTS OF THE CONVOLUTION
C TO FILE JFILE
C
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /SSUBS/ VFT,VBOT,VTOP,V1,V2,DVO,NLIMF,NSHIFT,MAXF,ILO,IHI,
* NLO,NHI,RATIO,SUMIN,IRATSH,SRATIO,IRATM1,NREN,
* DVSC,XDUM,V1SHFT
COMMON /CONTRL/ IEOFSC,IPANEL,ISTOP,IDATA,JVAR,JABS
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL,tdum(8)
COMMON /SPANEL/ V1P,V2P,DV,NLIM
COMMON /XSTMPR/ PF,TF,PDX(6,5,35),DVXPR(5,35),IXBIN(5,35),
* IXSBN(5,35)
COMMON /XSHEAD/ HEADT1(35)
CHARACTER HEADT1*100
DIMENSION PNLHDR(2)
DIMENSION R1(*),SUMR(*)
C
EQUIVALENCE (PNLHDR(1),V1P)
C
CALL CPUTIM (TIME0)
C
SUMOUT = SUMR(1)
SMIN = SUMR(2)
SMAX = SUMR(3)
DV = DVO
ISTOP = 0
NNHI = (V2-VFT)/DV+1.5
IF (NHI.GE.NNHI) THEN
ISTOP = 1
NHI = NNHI
ENDIF
NLIM = NHI-NLO+1
V1P = VFT+FLOAT(NLO-1)*DV
V2P = VFT+FLOAT(NHI-1)*DV
C
C V1P IS FIRST FREQ OF PANEL
C V2P IS LAST FREQ OF PANEL
C
CALL BUFOUT (JFILE,PNLHDR(1),NPHDRF)
CALL BUFOUT (JFILE,R1(NLO),NLIM)
C
VFT = VFT+FLOAT(NLIMF-1)*DV
DVXPR(NS,NI) = DV
NLIMHI = NLIM+NLO-1
DO 10 I = NLO, NLIMHI
SMIN = MIN(SMIN,R1(I))
SMAX = MAX(SMAX,R1(I))
SUMOUT = SUMOUT+R1(I)
10 CONTINUE
IF (ISTOP.EQ.1) GO TO 40
JF = 1
DO 20 J = NLIMF, MAXF
R1(JF) = R1(J)
JF = JF+1
20 CONTINUE
DO 30 J = JF, MAXF
R1(J) = 0.
30 CONTINUE
NLIMF = 511
NLO = NSHIFT+1
NHI = NLIMF+NSHIFT-1
40 SUMR(1) = SUMOUT
SUMR(2) = SMIN
SUMR(3) = SMAX
SUMR(4) = DVO
CALL CPUTIM (TIME)
TIMPNL = TIMPNL+TIME-TIME0
C
RETURN
C
END
SUBROUTINE SLRENZ (XF) 1
CCP SUBROUTINE SLRENZ (XF,XSCALE)
C
C SUBROUTINE SLRENZ SETS UP THE LORENZ SCANNING FUNCTION
C
COMMON /CMSHAP/ HWF,DXF,NF,NFMAX,HWF2,DXF2,NX2,N2MAX,
* HWF3,DXF3,NX3,N3MAX
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
DIMENSION XF(*)
C
PI = 2.*ASIN(1.)
XNORM = 1.0/PI
DO 10 I = 1, NFMAX
XF(I) = 0.
10 CONTINUE
XF(1) = XNORM
SUM = XF(1)
DO 20 I = 2, NF
X = FLOAT(I-1)*DXF
XF(I) = XNORM*(1./(1.+X**2))
SUM = SUM+2.*XF(I)
20 CONTINUE
SUM = SUM*DXF
C
C RENORMALIZE
C
XNORM = 1.0/SUM
DO 30 I = 1, NF
XF(I) = XNORM*XF(I)
30 CONTINUE
C
C WRITE(IPR,900) NF,DXF,SUM
C
RETURN
C
END