C path: /stormrc1/aer_lblrtm/src/SCCS/s.postsub.f
C revision: 5.11
C created: 12/13/99 10:59:48
C presently: 12/13/99 11:00:22
C
C --------------------------------------------------------------
SUBROUTINE SCANFN (IFILE,JFILE) 1,22
C
IMPLICIT REAL*8 (V)
C
C DRIVER FOR CONVOLVING INSTRUMENTAL SCANNING FUNCTION
C WITH SPECTRUM
C
COMMON S(3850),R1(5000),N1(5000)
C
character*8 XID, HMOLID, YID,SCANID
real*8 SECANT, XALTZ
C
COMMON /HVERSN/ HVRLBL,HVRCNT,HVRFFT,HVRATM,HVRLOW,HVRNCG,
* HVROPR,HVRPST,HVRPLT,HVRTST,HVRUTL,HVRXMR
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
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 /SCINF/ HWHM,JEMIT,JFN,SAMPLE,SCANID,NPTS,XF(6018)
COMMON /FLFORM/ CFORM
COMMON /RCTSV/ JDUM,SDUM,JFLG,RNJDM,NB,IPC,VLFT,VCNT,VRGT,
* WGTL,WGTR
C
CHARACTER*12 BCD,HTRANS,HABSRB,HRADIA
CHARACTER*11 CFORM
CHARACTER*8 HSCNID(0:6)
CHARACTER*8 HVRLBL,HVRCNT,HVRFFT,HVRATM,HVRLOW,HVRNCG,HVROPR,
* HVRPLT,HVRPST,HVRTST,HVRUTL,HVRXMR
CHARACTER SCNOUT*7,SCNINF*7,CTAPE*4
LOGICAL OP
C
DIMENSION FILHDR(2),SUMR(4)
DIMENSION HWJ(0:6),DXJ(0:6),NJ(0:6),NJMX(0:6),SMPLJ(0:6),
* XSCAL(0:6)
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
DATA HTRANS / 'TRANSMISSION'/,HABSRB / ' ABSORPTION '/,
* HRADIA / ' RADIANCE '/
DATA SCNOUT / ' '/,SCNINF / 'SCNINTF'/,CTAPE / 'TAPE'/
C
DATA HSCNID(0) / 'RECTANGL'/,HWJ(0) / 1. /,
* DXJ(0) / 0.0 /,NJ(0) / 0 /,NJMX(0) / 0 /,
* SMPLJ(0) / .5 /,XSCAL(0) / 0. /
DATA HSCNID(1) / 'TRIANGLE'/,HWJ(1) / 2. /,
* DXJ(1) / 0.02 /,NJ(1) / 101 /,NJMX(1) / 251 /,
* SMPLJ(1) / 2. /,XSCAL(1) / 0. /
DATA HSCNID(2) / 'GAUSS '/,HWJ(2) / 4. /,
* DXJ(2) / 0.02 /,NJ(2) / 201 /,NJMX(2) / 251 /,
* SMPLJ(2) / 4. /,XSCAL(2) / 0. /
C
C SINCSQ: 54.18 HALFWIDTHS CORRESPONDS TO 24 ZERO CROSSINGS
C PI CORRESPONDS TO X=2.257609141
C
DATA HSCNID(3) / 'SINCSQ '/,HWJ(3) / 54.1826 /,
* DXJ(3) / 0.02 /,NJ(3) / 2710 /,NJMX(3) / 2760 /,
* SMPLJ(3) / 4. /,XSCAL(3) / 1.391557377 /
C
C SINC: 119.33 HALFWIDTHS CORRESPONDS TO 72 ZERO CROSSINGS
C PI CORRESPONDS TO X=1.657400255
C
DATA HSCNID(4) / 'SINC '/,HWJ(4) / 119.332818 /,
* DXJ(4) / 0.02 /,NJ(4) / 5968 /,NJMX(4) / 6018 /,
* SMPLJ(4) / 4. /,XSCAL(4) / 1.89549425 /
DATA HSCNID(5) / 'VRCTCENT'/,HWJ(5) / 1. /,
* DXJ(5) / 0.0 /,NJ(5) / 0 /,NJMX(5) / 0 /,
* SMPLJ(5) / .5 /,XSCAL(5) / 0. /
DATA HSCNID(6) / 'VRCTLEFT'/,HWJ(6) / 1. /,
* DXJ(6) / 0.0 /,NJ(6) / 0 /,NJMX(6) / 0 /,
* SMPLJ(6) / .5 /,XSCAL(6) / 0. /
C
C----------------------------------------------------------------------
C
C ADDITIONAL SCANNING FUNCTIONS MAY READILY BE ADDED TO THOSE
C CURRENTLY IMPLEMENTED IN THIS VERSION OF LBLRTM:
C
C A SHAPE SUBROUTINE FOR THE DESIRED FUNCTION MUST BE CREATED-
C THIS SUBROUTINE PRECALCULATES THE FUNCTION FOR SUBSEQUENT
C LOOKUP. SEE FOR EXAMPLE SUBROUTINE SHAPEG FOR THE GAUSSIAN
C
C THE SHAPE SUBROUTINE SETS UP THE SYMMETRIC FUNCTION IN ARRAY FG
C AT EQUAL INCREMENTS OF THE HALFWIDTH, 'DXF'. THE VALUE OF 'DXF'
C IS SET IN THIS SUBROUTINE BY THE VALUE OF 'DXJ(?)'
C
C A DATA CARD MUST BE CREATED FOR EACH SCANNING FUNCTION DEFINING
C THE FOLLOWING QUANTITIES:
C
C HWJ(?) EXTENT OF THE FUNCTION (BOUND) FROM THE CENTER IN UNITS
C OF HALFWIDTH
C
C DXJ(?) INCREMENT AT WHICH THE FUNCTION IS STORED IN UNITS
C OF HALFWIDTH
C
C NJ(?) THE NUMBER OF POINTS FROM THE CENTER TO THE FUNCTION
C BOUND
C
C NJMAX(?) SIZE OF THE ARRAY IN WHICH THE FUNCTION IS STORED
C FUNCTION VALUES BETWEEN NJ AND NJMAX ARE ZERO
C
C SMPL(?) DEFAULT VALUE OF THE SAMPLING INCREMENT IN RECIPRICAL
C HALFWIDTH UNITS: E.G. A VALUE OF FOUR MEANS THAT THE
C OUTPUT SPACING, 'DV', IN WAVENUMBERS WILL BE 1/4 THE
C HALFWIDTH VALUE IN WAVENUMBERS, 'HWHM'.
C
C XSCAL(?) REQUIRED FOR PERIODIC FUNTIONS. THE VALUE OF THE
C FUNCTION ARGUMENT IN RADIANS FOR WHICH THE
C FUNCTION VALUE IS 0.5, E.G.
C SINX/X = 0.5 FOR X = 1.89549425, XSCAL(4)
C
C CONSIDERATION MUST BE GIVEN TO THE ISSUE OF FUNCTION
C NORMALIZATION FOR FUNCTIONS THAT DO NOT HAVE RAPID
C CONVERGENCE TO ZERO (SINX/X)
C
C SAC
C
C----------------------------------------------------------------------
C
C
C ASSIGN SCCS VERSION NUMBER TO MODULE
C
HVRPST = '5.11'
C
PI = 2.*ASIN(1.)
C
C SET THE MAXIMIM NUMBER OF AVAILABLE FUNCTIONS:
C
NFNMAX = 6
C
C NLIMF IS ONE MORE THAN THE SIZE OF OUTPUT (CONVOLVED) ARRAY
C
NLIMF = 2401
NREN = 0
NSHIFT = 32
IFLSAV = 0
IPRT = 1
C
10 CONTINUE
SUMOUT = 0.
SMIN = 999999.
SMAX = -99999.
DVOSAV = 0.
SUMR(1) = SUMOUT
SUMR(2) = SMIN
SUMR(3) = SMAX
SUMR(4) = DVOSAV
C
IEOFT = 1
C
C READ IN CONTROL PARAMETERS: SEE INSTRUCTIONS FO DEFINITIONS
C
READ (IRD,900,END=80) HWHM,V1,V2,JEMIT,JFN,JVAR,SAMPL,IUNIT,
* IFILST,NIFILS,JUNIT,NPTS
C
IF (HWHM.LE.0.) GO TO 70
C
C JEMIT=-1 SCANFN CONVOLVED WITH ABSORPTION
C JEMIT=0 SCANFN CONVOLVED WITH TRANSMISSION
C JEMIT=1 SCANFN CONVOLVED WITH EMISSION
C
JABS = 0
IDABS = 0
IF (JEMIT.LT.0) THEN
JABS = 1
JEMIT = 0
IDABS = -1
ENDIF
IDABST = IDABS
C
C JVAR=1 FOR A VARIABLE SLIT FUNCTION (NOT FOR JFN=0)
C THE CODING IN CNVSCN RESULTS IN HWHM=1./ (VI-V1)**2
C HWHM IS CONSTANT FOR EACH PANEL AS PROGRAMMED
C
IFN = ABS(JFN)
IF (IFN.GT.NFNMAX) THEN
WRITE (IPR,*) 'SCANF; JFN GT LIMIT'
STOP 'SCANF; JFN GT LIMIT'
ENDIF
C
READ (HSCNID(IFN),905) SCANID
C
HWF = HWJ(IFN)
DXF = DXJ(IFN)
NF = NJ(IFN)
NFMAX = NJMX(IFN)
SAMPLE = SMPLJ(IFN)
XSCALE = XSCAL(IFN)
C
C CHECK FOR NEGATIVE JFN OR NEGATIVE SAMPL
C
C FOR NEGATIVE JFN, USER IS SUPPLYING FIRST ZERO CROSSING FOR THE
C PERIODIC FUNCTION IN HWHM. SET HWHM=(FIRST ZERO)/(PI/XSCALE)
C
C For JFN=5,6 user is supplying instrument field of view half angle
C in degrees in HWHM. Trap if JFN=-5,-6.
C
IF (JFN.LT.0) THEN
JFN = ABS(JFN)
IF ((JFN.EQ.3).OR.(JFN.EQ.4)) THEN
HWHM = HWHM/(PI/XSCALE)
ELSE
WRITE (IPR,910) JFN
STOP 'SCANFN; INVALID JFN'
ENDIF
ENDIF
C
C SET DVINT TO DETERMINE IF INTERPOLATION IS NECESSARY
C - For JFN = 5,6, set DVINT to 1/12 the width of the first box.
C HWHM should carry the value of the field of view half angle
C (in degrees). This is converted to radians. The box width
C formula is
C
C width = V1*(1/2 angle FOV)**2/2
C
C and the degrees-to-radians formula is
C
C rad = deg*3.141592654/180.
C
C - For JFN not equal to 5 or 6, set DVINT to 1/12 the value of
C HWHM. HWHM should carry the true value of the Half Width
C at Half Maximum of the scanning function at this point.
C
IF ((JFN.EQ.5).OR.(JFN.EQ.6)) THEN
DVINT = V1*(HWHM*3.141592654/180.)**2/24
ELSE
DVINT = HWHM/12.
ENDIF
C
C - For positive SAMPL, set SAMPLE equal to SAMPL (the number
C of points per half width).
C - For negative SAMPL, user is supplying desired DELVO
C (outgoing spectral spacing). SAMPLE (the number of sample
C points per half width) is set such that SAMPLE=HWHM/DELVO
C (Half Width at Half Max over user input outgoing spectral
C spacing), and the outgoing spectral spacing DVO will be
C recalculated using HWHM and SAMPLE below.
C
IF (SAMPL.LT.0.) THEN
SAMPLE = HWHM/(-SAMPL)
ELSEIF (SAMPL.GT.0.) THEN
SAMPLE = SAMPL
ENDIF
C
C SET UP SELECTED SCANNING FUNCTION:
C
IF (JFN.EQ.1) CALL SHAPET
(XF)
IF (JFN.EQ.2) CALL SHAPEG (XF)
IF (JFN.EQ.3) CALL SINCSQ (XF,XSCALE)
IF (JFN.EQ.4) CALL SINC (XF,XSCALE)
C
IF (IUNIT.LE.0) IUNIT = IFILE
IFILE = IUNIT
IFILST = MAX(IFILST,1)
IF (NIFILS.LE.0) NIFILS = 99
C
C SKIP TO SELECTED 'FILE'
C
REWIND IFILE
IF (IFILST.GT.1) CALL SKIPFL (IFILST-1,IFILE,IEOF)
C
C READ FILE HEADER FOR SELECTED 'FILE'
C
20 CALL BUFIN (IFILE,IEOF,FILHDR(1),NFHDRF)
IF (IEOF.EQ.0) GO TO 10
IDABS = IDABST
C
WRITE (IPR,915) XID,(YID(M),M=1,2)
WRITE (IPR,920) LAYR1,LAYER
WRITE (IPR,925) SECANT,PAVE,TAVE,DV,V1C,V2C
WRITE (IPR,930) WBROAD,(HMOLID(M),WK(M),M=1,NMOL)
C
C CHECK FOR INTERPOLATION AND OPEN OUTPUT FILE IF NECESSARY
C
C IFILE INTERPOLATED ONTO JFILE
C
IF (JUNIT.LE.0) JUNIT = JFILE
JFILE = JUNIT
C
C IF DV NOT FINE ENOUGH, FIRST INTERPOLATE
C
IF (DV.GT.DVINT) THEN
IFLSAV = IFILE
JFLSAV = JFILE
IEOFSC = 1
JFILE = 77
INQUIRE (UNIT=JFILE,OPENED=OP)
IF (OP) CLOSE (JFILE)
SCNOUT = SCNINF
OPEN (JFILE,FILE=SCNOUT,STATUS='UNKNOWN',FORM=CFORM)
REWIND JFILE
IBUF = 0
C
C INTERPOLATE:
C
CALL SCNINT (IFILE,JFILE,DVINT,JEMIT,NPTS,IBUF)
C
IEOFSV = IEOFSC
WRITE (IPR,935)
IFILE = JFILE
REWIND IFILE
CALL BUFIN (IFILE,IEOF,FILHDR(1),NFHDRF)
JFILE = JFLSAV
ELSE
IFLSAV = 0
ENDIF
INQUIRE (UNIT=JFILE,OPENED=OP)
IF (.NOT.OP) THEN
WRITE (SCNOUT,940) CTAPE,JFILE
OPEN (JFILE,FILE=SCNOUT,STATUS='UNKNOWN',FORM=CFORM)
REWIND JFILE
ENDIF
C
ISCAN = ISCHDR
IF (ISCAN.LE.0.OR.XSCID.EQ.-99.) ISCAN = 0
IF (ISCHDR.GE.1000.AND.ISCAN.EQ.0) ISCAN = ISCHDR
ISCHDR = ISCAN+1
JTREM = -1
IF ((IEMIT.EQ.0).AND.(JEMIT.EQ.0)) JTREM = 0
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.0)) JTREM = 2
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.1)) JTREM = 1
ISCANT = MOD(ISCAN,1000)
IF ((ISCANT.GE.1).AND.(JEMIT.EQ.0)) JTREM = 2
IF (JTREM.LT.0) THEN
WRITE(IPR,*) ' SCANF; JTREM LT 0'
STOP ' SCANF; JTREM LT 0'
ENDIF
WRITE (IPR,945) SCANID,IFILE,IFILST,NIFILS,JEMIT,JFN,JVAR,JABS
C
C JTREM=0 SCANFN CONVOLVED WITH EXPONENTIATED
C ABSORPTION COEFFICIENT
C JTREM=1 SCANFN CONVOLVED WITH EMISSION
C JTREM=2 SCANFN CONVOLVED WITH TRANSMISSION
C
DVI = DV
DVSAV = DVI
C
C Compute output spectral spacing. For JFN not 5 or 6, at this
C point HWHM always contains the value of the Half Width at Half
C Maximum of the scanning function, and SAMPLE always contains
C the number of points per half width of the scanning function.
C
C For JFN = 5,6 at this point, HWHM contains the value of the
C field of view half angle (in degrees), and SAMPLE contains
C the ratio of the field of view half angle to the specified
C output spectral spacing (the quotient of HWHM and SAMPLE
C results in the circuitous calculation of the previously input
C DVO).
C
DVO = HWHM/SAMPLE
IF (JFN.EQ.0) THEN
IRATIO = DVO/DVI+0.5
DVO = FLOAT(IRATIO)*DVI
IF (IRATIO.LT.2) THEN
WRITE (IPR,950)
GO TO 10
ENDIF
ENDIF
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
SCIND = JVAR+10*(JFN+10*(JEMIT))
XSCID = SCIND+0.01
XHWHM = HWHM
CALL BUFOUT (JFILE,FILHDR(1),NFHDRF)
WRITE (IPR,955) HWHM,BOUND,JFILE,V1,V2,DVO
NBOUND = (2.*HWF)*SAMPLE+0.01
C
C NBOUND IS THE NUMBER OF SPECTRAL VALUES SPANNED
C BY THE FULL SCANNING FUNCTION
C
C RESET BOUND BASED ON NBOUND
C
BOUND = FLOAT(NBOUND)*DVO/2.
MAXF = NLIMF+2*NBOUND+NSHIFT
C
TIMRDF = 0.
TIMCNV = 0.
TIMPNL = 0.
IEOFSC = 1
NLO = NSHIFT+1
SUMIN = 0.
NHI = NLIMF+NSHIFT-1
DO 30 I = 1, MAXF
N1(I) = 0.
R1(I) = 0.
30 CONTINUE
INIT = 0
IDATA = -1
IPANEL = -1
JFLG = -1
VFT = V1-FLOAT(NSHIFT)*DV
VBOT = V1-BOUND
VTOP = V2+BOUND
C
IF (JEMIT.EQ.0.AND.IDABS.EQ.0) BCD = HTRANS
IF (JEMIT.EQ.0.AND.IDABS.EQ.-1) BCD = HABSRB
IF (JEMIT.EQ.1) BCD = HRADIA
IF (NPTS.GT.0) WRITE (IPR,960) BCD
C
40 CALL CPUTIM (TIME0)
C
IF (IEOFSC.LE.0) GO TO 60
C
C READ DATA TO BE CONVOLVE FROM IFILE AND PUT INTO ARRAY S
C
CALL RDSCAN (S,JTREM,IFILE,ISCAN,IPRT)
C
CPRT WRITE(IPR,965) IEOFSC,IDATA
C
CALL CPUTIM (TIME)
TIMRDF = TIMRDF+TIME-TIME0
C
IF (IEOFSC.LE.0) GO TO 60
C
C SHRKSC MAY SHRINK (COMPRESS) THE DATA; DVI IS MODIFIED ACCORDINGL
C
IF ((JFN.NE.0).AND.(JFN.NE.5).AND.(JFN.NE.6)) THEN
CALL SHRKSC (INIT,HWHM)
ENDIF
C
50 CONTINUE
C
C PERFORM THE CONVOLUTION OF XF ON S TO GIVE R1
C
IF (JFN.EQ.0) THEN
CALL CNVRCT (S,HWHM,R1,XF)
ELSEIF (JFN.EQ.5) THEN
CALL CNVVRC (S,HWHM,R1,XF)
ELSEIF (JFN.EQ.6) THEN
CALL CNVVRL (S,HWHM,R1,XF)
ELSE
CALL CONVSC (S,HWHM,R1,XF)
ENDIF
C
CPRT WRITE(IPR,965) IEOFSC,IDATA,IPANEL
C
IF (IPANEL.EQ.0) GO TO 40
C
60 CONTINUE
C
C OUTPUT PANEL TO JFILE, NPTS VALUES OF R1
C
IF (JFN.EQ.0.OR.JFN.EQ.5.OR.JFN.EQ.6) THEN
CALL PNLRCT (R1,JFILE,SUMR,NPTS)
ELSE
CALL PANLSC (R1,JFILE,SUMR,NPTS)
ENDIF
C
IF ((ISTOP.NE.1).AND.(IEOFSC.LT.0)) GO TO 60
IF ((ISTOP.NE.1).AND.(IEOFSC.GT.0)) GO TO 50
CALL CPUTIM (TIME)
WRITE (IPR,970) TIME,TIMRDF,TIMCNV,TIMPNL
CALL ENDFIL (JFILE)
C
SUMIN = SUMIN*DVSAV
C
WRITE (IPR,975) SUMIN
C
IF (IFLSAV.NE.0) THEN
IFILE = IFLSAV
IEOFSC = IEOFSV
ENDIF
IF (IEOFSC.EQ.1) CALL SKIPFL (1,IFILE,IEOFSC)
C
IEOFT = IEOFT+1
C
SUMOUT = SUMR(1)
SMIN = SUMR(2)
SMAX = SUMR(3)
DVOSAV = SUMR(4)
C
SUMOUT = SUMOUT*DVOSAV
WRITE (IPR,980) SUMOUT,SMIN,SMAX
C
IF (IEOFT.LE.NIFILS.AND.IEOFSC.LT.0) GO TO 20
C
GO TO 10
C
70 CONTINUE
C
80 RETURN
C
900 FORMAT (3F10.3,3(3X,I2),F10.4,4(3X,I2),I5)
905 FORMAT (A8)
910 FORMAT (//,' ***** INVALID VALUE FOR JFN = ',I2,' *****',/)
915 FORMAT ('1',' **SCANFN** ',/,'0',10A8,2X,2(1X,A8,1X))
920 FORMAT (//,' INITIAL LAYER = ',I5,' FINAL LAYER =',I5)
925 FORMAT ('0 SECANT =',F15.5,/'0 PRESS(MB) =',F12.5/'0 TEMP(K) =',
* F11.2,/'0 DV(CM-1) = ',F12.8,/'0 V1(CM-1) = ',F12.6,/
* '0 V2(CM-1) = ',F12.6)
930 FORMAT ('0 COLUMN DENSITY (MOLECULES/CM**2)'//5X,'WBROAD = ',
* 1PE10.3,/(5X,A6,' = ',1PE10.3))
935 FORMAT ('0',' **SCANFN** ',/)
940 FORMAT (A4,I2.2)
945 FORMAT ('0','***',A8,'***',//6X,'INPUT FILE NUMBER =',I3,
* ' ,IFILST = ',I5,' ,NIFILS = ',I5,',JEMIT =',I2,
* ' ,JFN =',I2,' ,JVAR =',I2,' ,JABS =',I2)
950 FORMAT ('0',60X,'****** IRATIO LESS THAN 2, NO SCANFN ******')
955 FORMAT (1X,' HWHM OF INSTRUMENT FUNCTION =',F12.8,' CM-1'/,
* 5X,'BOUND OF INSTRUMENT FUNCTION =',F12.8,' CM-1'/,6X,
* 'OUTPUT FILE NUMBER =',I3,', V1 =',F12.5,', V2 =',
* F12.5,5X,' DV OUT',F12.8)
960 FORMAT (///,'0',5X,A12,/)
965 FORMAT ('0',5X,'IEOFSC =',I3,' IDATA =',I3,' IPANEL =',I3,/)
970 FORMAT ('0',5X,'TIME =',F7.3,', READ =',F6.3,', CONV. =',F7.3,
* ', PANEL =',F6.3)
975 FORMAT ('0 SUMIN =',1P,E16.9)
980 FORMAT ('0 SUMOUT =',1P,E16.9,' MIN =',E16.9,' MAX =',E16.9)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE SCANRD (DVINT,IEMIT) 4,4
C
IMPLICIT REAL*8 (V)
C
C READ CONTROL CARD FOR SCANNING WITH WEIGHTING FUNCTIONS
C
COMMON S(3850),R1(5000)
C
character*8 XID, HMOLID, YID,SCANID
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
COMMON /RSCAN/ V1I,V2I,DVI,NNI
COMMON /SCSHAP/ HWFS,DXFS,NFS,NFMAXS
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 /SCINF/ HWHM,JEMIT,JFN,SAMPLE,SCANID,NPTS,XF(6018)
COMMON /FLFORM/ CFORM
C
CHARACTER*8 HSCNID(0:6)
CHARACTER CFORM*11,TAPE13*6,CTAPE*4
LOGICAL OP
C
DIMENSION FILHDR(2)
DIMENSION HWJ(0:6),DXJ(0:6),NJ(0:6),NJMX(0:6),SMPLJ(0:6),
* XSCAL(0:6)
C
EQUIVALENCE (FILHDR(1),XID(1)) , (FSCDID(6),ISCHDR),
* (FSCDID(12),XSCID) , (FSCDID(13),XHWHM),
* (FSCDID(14),IDABS) , (FSCDID(16),LAYR1)
C
DATA HSCNID(0) / 'RECTANGL'/,HWJ(0) / 1. /,
* DXJ(0) / 0.0 /,NJ(0) / 0 /,NJMX(0) / 0 /,
* SMPLJ(0) / .5 /,XSCAL(0) / 0. /
DATA HSCNID(1) / 'TRIANGLE'/,HWJ(1) / 2. /,
* DXJ(1) / 0.02 /,NJ(1) / 101 /,NJMX(1) / 251 /,
* SMPLJ(1) / 2. /,XSCAL(1) / 0. /
DATA HSCNID(2) / 'GAUSS '/,HWJ(2) / 4. /,
* DXJ(2) / 0.02 /,NJ(2) / 201 /,NJMX(2) / 251 /,
* SMPLJ(2) / 4. /,XSCAL(2) / 0. /
C
C SINCSQ: 54.18 HALFWIDTHS CORRESPONDS TO 24 ZERO CROSSINGS
C PI CORRESPONDS TO X=2.257609141
C
DATA HSCNID(3) / 'SINCSQ '/,HWJ(3) / 54.1826 /,
* DXJ(3) / 0.02 /,NJ(3) / 2710 /,NJMX(3) / 2760 /,
* SMPLJ(3) / 4. /,XSCAL(3) / 1.391557377 /
C
C SINC: 119.33 HALFWIDTHS CORRESPONDS TO 72 ZERO CROSSINGS
C PI CORRESPONDS TO X=1.657400255
C
DATA HSCNID(4) / 'SINC '/,HWJ(4) / 119.332818 /,
* DXJ(4) / 0.02 /,NJ(4) / 5968 /,NJMX(4) / 6018 /,
* SMPLJ(4) / 4. /,XSCAL(4) / 1.89549425 /
DATA HSCNID(5) / 'VRCTCENT'/,HWJ(5) / 1. /,
* DXJ(5) / 0.0 /,NJ(5) / 0 /,NJMX(5) / 0 /,
* SMPLJ(5) / .5 /,XSCAL(5) / 0. /
DATA HSCNID(6) / 'VRCTLEFT'/,HWJ(6) / 1. /,
* DXJ(6) / 0.0 /,NJ(6) / 0 /,NJMX(6) / 0 /,
* SMPLJ(6) / .5 /,XSCAL(6) / 0. /
C
DATA TAPE13 / ' '/,CTAPE / 'TAPE'/
C
PI = 2.*ASIN(1.)
C
C SET THE MAXIMIM NUMBER OF AVAILABLE FUNCTIONS:
C
NFNMAX = 6
C
NLIMF = 2401
NSHIFT = 32
READ (IRD,900,END=10) HWHM,V1,V2,JEMIT,JFN,JVAR,SAMPL,NNFILE,NPTS
C
IF (HWHM.LE.0.) THEN
WRITE(IPR,*) ' SCANRD * HWHM NEGATIVE '
STOP ' SCANRD * HWHM NEGATIVE '
ENDIF
C
C JEMIT=-1 SCANFN CONVOLVED WITH ABSORPTION
C JEMIT=0 SCANFN CONVOLVED WITH TRANSMISSION
C JEMIT=1 SCANFN CONVOLVED WITH EMISSION
C
JABS = 0
C
C THE FOLLOWING CARDS HAVE BEEN RETRAINED
C FOR POSSIBLE FUTURE CODE ENHANCEMENTS
C
CC IF (JEMIT.LT.0) THEN
CC JABS=1
CC JEMIT=0
CC ENDIF
C
C JVAR=1 FOR A VARIABLE SLIT FUNCTION (NOT FOR JFN=0)
C THE CODING IN CNVSCN RESULTS IN HWHM=1./ (VI-V1)**2
C HWHM IS CONSTANT FOR EACH PANEL AS PROGRAMMED
C FOLLOWING VALUES INITIALIZE FOR RECTANGLE
C
IFN = ABS(JFN)
IF (IFN.GT.NFNMAX) THEN
WRITE(IPR,*)' SCANF; JFN GT LIMIT'
STOP ' SCANF; JFN GT LIMIT'
ENDIF
C
READ (HSCNID(IFN),905) SCANID
C
C JVAR=1 FOR A VARIABLE SLIT FUNCTION (NOT FOR JFN=0)
C THE CODING IN CNVSCN RESULTS IN HWHM=1./ (VI-V1)**2
C HWHM IS CONSTANT FOR EACH PANEL AS PROGRAMMED
C FOLLOWING VALUES INITIALIZE FOR RECTANGLE
C
HWF = HWJ(IFN)
DXF = DXJ(IFN)
NF = NJ(IFN)
NFMAX = NJMX(IFN)
SAMPLE = SMPLJ(IFN)
XSCALE = XSCAL(IFN)
C
C Set values of HWFS, DXFS, NFS, & NFMAXS to HWF, DXF, NF,
C & NFMAX for use when entering HIRAC1 between SCANRD and
C SCNMRG.
C
HWFS = HWF
DXFS = DXF
NFS = NFS
NFMAXS = NFMAX
C
C CHECK FOR NEGATIVE JFN OR NEGATIVE SAMPL
C
C FOR NEGATIVE JFN, USER IS SUPPLYING FIRST ZERO CROSSING FOR THE
C PERIODIC FUNCTION IN HWHM. SET HWHM=(FIRST ZERO)/(PI/XSCALE)
C
C For JFN=5,6 user is supplying instrument field of view half angle
C in degrees in HWHM.
C
C FOR NEGATIVE SAMPL, USER IS SUPPLYING DESIRED DELVO.
C SET SAMPLE=HWHM/DELVO.
C
IF (JFN.LT.0) THEN
JFN = ABS(JFN)
IF ((JFN.EQ.3).OR.(JFN.EQ.4)) THEN
HWHM = HWHM/(PI/XSCALE)
ELSE
WRITE (IPR,910) JFN
STOP 'SCANRD; INVALID JFN'
ENDIF
ENDIF
C
IF (SAMPL.LT.0.) SAMPLE = HWHM/(-SAMPL)
IF (SAMPL.GT.0.) SAMPLE = SAMPL
C
IF (JFN.EQ.1) CALL SHAPET (XF)
IF (JFN.EQ.2) CALL SHAPEG (XF)
IF (JFN.EQ.3) CALL SINCSQ (XF,XSCALE)
IF (JFN.EQ.4) CALL SINC (XF,XSCALE)
C
IF (NNFILE.NE.NFILE.AND.NNFILE.GT.0) THEN
INQUIRE (UNIT=NFILE,OPENED=OP)
IF (OP) CLOSE (NFILE)
NFILE = NNFILE
INQUIRE (UNIT=NFILE,OPENED=OP)
IF (.NOT.OP) THEN
WRITE (TAPE13,915) CTAPE,NFILE
OPEN (NFILE,FILE=TAPE13,STATUS='UNKNOWN',FORM=CFORM)
REWIND NFILE
ENDIF
ENDIF
C
WRITE (IPR,920) SCANID,JEMIT,JFN,JVAR,SAMPL,NPTS
IEMIT = JEMIT
C
C BOUND AT THIS POINT IS THE WAVENUMBER VALUE
C OF HALF THE SCANNING FUNCTION
C
DVO = HWHM/SAMPLE
DVINT = HWHM/12.
BOUND = HWF*HWHM
V1C = V1
V2C = V2
XHWHM = HWHM
WRITE (IPR,925) HWHM,BOUND,NFILE,V1,V2
RETURN
10 PRINT 930
STOP
C
900 FORMAT (3F10.3,3(3X,I2),F10.4,15X,2I5)
905 FORMAT (A8)
910 FORMAT (//,' ***** INVALID VALUE FOR JFN = ',I2,' *****',/)
915 FORMAT (A4,I2.2)
920 FORMAT ('1',5X,'SCANRD',5X,'***',A8,'***',/,/,' JEMIT =',I2,
* ' JFN =',I2,' ,JVAR =',I2,' ,SAMPL =',F10.4,' ,NPTS =',
* I5)
925 FORMAT (1X,' HWHM OF INSTRUMENT FUNCTION =',F12.8,' CM-1'/,
* 5X,'BOUND OF INSTRUMENT FUNCTION =',F12.8,' CM-1'/,6X,
* 'OUTPUT FILE NUMBER =',I3,', V1 =',F12.5,', V2 =',
* F12.5)
930 FORMAT (' END OF FILE TAPE5',/,' (NOTE TAPE10 ALREADY CREATED )')
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE SCNINT (IFILE,JFILE,DVINT,JEMIT,NPTS,IBUF) 5,7
C
IMPLICIT REAL*8 (V)
C
C**********************************************************************
C
C INTERPOLATION FUNCTION DRIVER FOR WEIGHTING FUNCTIONS
C
C FOUR-POINT VERSION (MARCH 1990)
C
C**********************************************************************
C
C THE INPUT DATA WILL BE PUT INTO T(5) = S(1) WITH THE LAST
C 4 POINTS OF THE PREVIOUS PANEL PUT INTO T(1 TO 4).
C THIS SCHEME PERMITS 6 POINT INTERPOLATION.
C
C S IS NOMINALLY 2401 POINTS BUT MAY NEED TO BE EXTENDED BY
C 2 POINTS TO PERMIT 4 POINT INTERPOLATION UP TO THE LAST
C DATA POINT.
C
COMMON T(2410),R(2401)
DIMENSION S(2406)
EQUIVALENCE (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,WN2 ,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
COMMON /INPNL/ V1I,V2I,DVI,NNI
COMMON /OUTPNL/ V1J,V2J,DVJ,NNJ
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
C
DIMENSION FILHDR(2),RSTAT(3)
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
CHARACTER*12 BCD,HTRANS,HABSRB,HRADIA
C
DATA HTRANS / 'TRANSMISSION'/,HABSRB / ' ABSORPTION '/,
* HRADIA / ' RADIANCE '/
C
C----------------------------------------------------------------------
C JEMIT=-1 INTERPOLATE ABSORPTION
C JEMIT=0 INTERPOLATE TRANSMISSION
C JEMIT=1 INTERPOLATE EMISSION
C JEMIT=2 INTERPOLATE OPTICAL DEPTH
C----------------------------------------------------------------------
C
WRITE (IPR,900)
CALL CPUTIM (TIME1)
TIMRDF = 0.0
TIMCNV = 0.0
TIMPNL = 0.0
C
V1SAV = V1
V2SAV = V2
DVSAV = DV
DVOSAV = 0.
C
DVO = DVINT
C
C I4PT = 1 FOR FOUR POINT INTERPOLATION
C
I4PT = 1
ICNVRT = 1
IF (DVO.LE.0.) GO TO 40
C
IF (IBUF.EQ.1) REWIND IFILE
REWIND JFILE
C
C BUFFER IN THE FILE HEADER ON UNIT (IFILE)
C BUFFER OUT ON UNIT (JFILE)
C
IF (IBUF.EQ.1) THEN
CALL BUFIN (IFILE,IEOF,FILHDR(1),NFHDRF)
IF (IEOF.EQ.0) GO TO 30
JABS = 0
IDABS = 0
IF (JEMIT.LT.0) THEN
JABS = 1
JEMIT = 0
IDABS = -1
ENDIF
ENDIF
V1 = V1C
V2 = V2C
DVI = DV
C
C V2 IS ONLY APPROXIMATE
C
NUM = (((V2-V1)/DVO)+0.5)
V2 = V1+FLOAT(NUM)*DVO
NUM = NUM+1
WRITE (IPR,905) V1,V2,DVO,NUM,JEMIT,I4PT,IFILE,JFILE,NPTS
C
ISCAN = ISCHDR
IF (ISCAN.LE.0.OR.XSCID.EQ.-99.) ISCAN = 0
IF (ISCHDR.GE.1000.AND.ISCAN.EQ.0) ISCAN = ISCHDR
ISCHDR = ISCAN+10
V1C = V1
V2C = V2
DV = DVO
C
SCNID = 100*JEMIT
XSCID = SCNID+0.01
C
CALL BUFOUT (JFILE,FILHDR(1),NFHDRF)
C
JTREM = -1
IF ((IEMIT.EQ.0).AND.(JEMIT.EQ.0)) JTREM = 0
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.0)) JTREM = 2
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.2)) JTREM = 2
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.1)) JTREM = 1
ISCANT = MOD(ISCAN,1000)
IF ((ISCANT.GE.1).AND.(JEMIT.EQ.0)) JTREM = 2
IF (JTREM.LT.0) THEN
WRITE(IPR,*) ' JTREM.LT.0 AT I07570'
STOP ' JTREM.LT.0 AT I07570'
ENDIF
WRITE (IPR,910) IFILE,IEMIT,JEMIT,JTREM,JABS
C
IDATA = -1
C
C NEED TO SAVE LAST IBOUND POINTS OF EACH PANEL TO ATTACH TO NEXT
C
IBOUND = 4
C
C VBOT IS LOWEST NEEDED WAVENUMBER, VTOP IS HIGHEST
C
BOUND = FLOAT(IBOUND)*DV
VBOT = V1-BOUND
VTOP = V2+BOUND
C
IF (JEMIT.EQ.0.AND.IDABS.EQ.0) BCD = HTRANS
IF (JEMIT.EQ.0.AND.IDABS.EQ.-1) BCD = HABSRB
IF (JEMIT.EQ.1) BCD = HRADIA
IF (NPTS.GT.0) WRITE (IPR,915) BCD
C
C ZERO OUT T(1 TO IBOUND)
C
DO 10 II = 1, IBOUND
T(II) = 0.0
10 CONTINUE
C
C READ FROM IFILE UNTIL THE FIRST REQUIRED POINT IS REACHED
C AND LOAD DATA INTO S
C
CALL RDPANL (S,JTREM,IFILE,ISCAN,JEMIT,ICNVRT)
IF (IEOFSC.LE.0) GO TO 20
C
C DO INTERPOLATION
C
CALL INTERP (IFILE,JFILE,I4PT,IBOUND,NPTS,JTREM,ISCAN,JEMIT,
* RSTAT,ICNVRT)
C
CALL CPUTIM (TIME2)
CALL ENDFIL (JFILE)
C
C WRITE STATISTICS
C
WRITE (IPR,920) RSTAT(1),RSTAT(2),RSTAT(3)
TIMTOT = TIME2-TIME1
TIMCNV = TIMTOT-TIMRDF-TIMPNL
WRITE (IPR,925) TIMTOT,TIMRDF,TIMCNV,TIMPNL
C
GO TO 30
C
20 CONTINUE
WRITE (IPR,930) IFILE
C
30 CONTINUE
V1 = V1SAV
V2 = V2SAV
DV = DVSAV
RETURN
C
40 CONTINUE
WRITE (IPR,935) DVINT
C
RETURN
C
900 FORMAT (/,'0***SCNINT***',/)
905 FORMAT (5X,'V1=',F14.8,' V2=',F14.8,' DVO=',E14.6,' NUM=',I8,/,
* 5X,'JEMIT=',I3,' I4PT=',I3,' IUNIT=',I3,' JUNIT=',I3,
* ' NPTS=',I5)
910 FORMAT (5X,'INPUT FILE NUMBER =',I3,' IEMIT=',I3,' JEMIT=',I3,
* ' JTREM=',I3,' JABS=',I3)
915 FORMAT (///,'0',5X,A12,/)
920 FORMAT ('0 SUMOUT =',1P,E16.9,' MIN =',E16.9,' MAX =',E16.9)
925 FORMAT (/,5X,'SCNINT TIME: TOTAL = ',F8.3,' READ = ',F8.3,
* ' INTERP = ',F8.3,' WRITE = ',F8.3,/)
930 FORMAT (/,5X,'SCNINT- ERROR: EOF ON INPUT UNIT ',I4,
* ' BEFORE V1 WAS REACHED',/)
935 FORMAT (/,5X,'SCNINT- ERROR: DVINT .LT. ZERO ; DVINT =',F12.4,/)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE SCNMRG (IFILE,JFILE) 5,14
C
IMPLICIT REAL*8 (V)
C
C DRIVER FOR CONVOLVING INSTRUMENTAL SCANNING FUNCTION
C WITH SPECTRUM
C
COMMON S(3850),R1(5000)
C
character*8 XID, HMOLID, YID,SCANID
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
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 /SCINF/ HWHM,JEMIT,JFN,SAMPLE,SCANID,NPTS,XF(6018)
COMMON /RCTSV/ JJ,SUMJ,JFLG,RNJ,NB,IPC,VLFT,VCNT,VRGT,WGTL,WGTR
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
CHARACTER*12 BCD,HTRANS,HABSRB,HRADIA
C
DATA HTRANS / 'TRANSMISSION'/,HABSRB / ' ABSORPTION '/,
* HRADIA / ' RADIANCE '/
C
C IUNIT INPUT FILE
C JUNIT OUTPUT FILE
C
IUNIT = IFILE
JUNIT = JFILE
NREN = 0
IPRT = 1
IDABS = 0
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
NSHIFT = 32
C
REWIND IUNIT
CALL BUFIN (IUNIT,IEOF,FILHDR(1),NFHDRF)
IF (IEOF.EQ.0) GO TO 50
C
DVSAV = DV
IDABS = IDABST
C
WRITE (IPR,900) XID,(YID(M),M=1,2)
WRITE (IPR,905) LAYR1,LAYER
WRITE (IPR,910) SECANT,PAVE,TAVE,DV,V1C,V2C
WRITE (IPR,915) WBROAD,(HMOLID(M),WK(M),M=1,NMOL)
C
ISCAN = ISCHDR
IF (ISCAN.LE.0.OR.XSCID.EQ.-99.) ISCAN = 0
IF (ISCHDR.GE.1000.AND.ISCAN.EQ.0) ISCAN = ISCHDR
ISCHDR = ISCAN+1
JTREM = -1
IF ((IEMIT.EQ.0).AND.(JEMIT.EQ.0)) JTREM = 0
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.0)) JTREM = 2
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.1)) JTREM = 1
ISCANT = MOD(ISCAN,1000)
IF ((ISCANT.GE.1).AND.(JEMIT.EQ.0)) JTREM = 2
C
IF (JTREM.LT.0) THEN
WRITE(IPR,*) ' SCANF; JTREM LT 0'
STOP ' SCANF; JTREM LT 0'
ENDIF
C
WRITE (IPR,920) SCANID,IUNIT,IFILST,NIFILS,JEMIT,JFN,JVAR,JABS
C
C JTREM=0 SCANFN CONVOLVED WITH EXPONENTIATED
C ABSORPTION COEFFICIENT
C JTREM=1 SCANFN CONVOLVED WITH EMISSION
C JTREM=2 SCANFN CONVOLVED WITH TRANSMISSION
C
DVI = DV
DVO = HWHM/SAMPLE
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
SCIND = JVAR+10*(JFN+10*(JEMIT))
XSCID = SCIND+0.01
XHWHM = HWHM
CALL BUFOUT (JUNIT,FILHDR(1),NFHDRF)
WRITE (IPR,925) HWHM,BOUND,JUNIT,V1,V2,DVO
NBOUND = (2.*HWF)*SAMPLE+0.01
C
C BOUND AT THIS POINT IS THE WAVENUMBER VALUE OF THE
C FULL SCANNING FUNCTION
C
BOUND = FLOAT(NBOUND)*DVO/2.
MAXF = NLIMF+2*NBOUND+NSHIFT
C
TIMRDF = 0.
TIMCNV = 0.
TIMPNL = 0.
IEOFSC = 1
NLO = NSHIFT+1
SUMIN = 0.
NHI = NLIMF+NSHIFT-1
DO 10 I = 1, MAXF
R1(I) = 0.
10 CONTINUE
INIT = 0
IDATA = -1
IPANEL = -1
JFLG = -1
VFT = V1-FLOAT(NSHIFT)*DV
VBOT = V1-BOUND
VTOP = V2+BOUND
C
IF (JEMIT.EQ.0.AND.IDABS.EQ.0) BCD = HTRANS
IF (JEMIT.EQ.0.AND.IDABS.EQ.-1) BCD = HABSRB
IF (JEMIT.EQ.1) BCD = HRADIA
IF (NPTS.GT.0) WRITE (IPR,930) BCD
20 CALL CPUTIM (TIME0)
IF (IEOFSC.LE.0) GO TO 40
CALL RDSCAN (S,JTREM,IUNIT,ISCAN,IPRT)
C
CPRT WRITE(IPR,935) IEOFSC,IDATA
C
CALL CPUTIM (TIME)
TIMRDF = TIMRDF+TIME-TIME0
C
IF (IEOFSC.LE.0) GO TO 40
IF (JFN.NE.0) CALL SHRKSC (INIT,HWHM)
C
C SHRKSC MAY SHRINK (COMPRESS) THE DATA;
C DVI IS MODIFIED ACCORDINGLY
C
30 CONTINUE
IF (JFN.EQ.0) THEN
CALL CNVRCT (S,HWHM,R1,XF)
ELSEIF (JFN.EQ.5) THEN
CALL CNVVRC (S,HWHM,R1,XF)
ELSEIF (JFN.EQ.6) THEN
CALL CNVVRL (S,HWHM,R1,XF)
ELSE
CALL CONVSC (S,HWHM,R1,XF)
ENDIF
C
CPRT WRITE(IPR,935) IEOFSC,IDATA,IPANEL
C
IF (IPANEL.EQ.0) GO TO 20
C
40 CONTINUE
IF (JFN.EQ.0.OR.JFN.EQ.5.OR.JFN.EQ.6) THEN
CALL PNLRCT (R1,JUNIT,SUMR,NPTS)
ELSE
CALL PANLSC (R1,JUNIT,SUMR,NPTS)
ENDIF
IF ((ISTOP.NE.1).AND.(IEOFSC.GT.0)) GO TO 30
CALL CPUTIM (TIME)
WRITE (IPR,940) TIME,TIMRDF,TIMCNV,TIMPNL
C
SUMIN = SUMIN*DVSAV
C
WRITE (IPR,945) SUMIN
C
IF (IEOFSC.EQ.1) CALL SKIPFL (1,IUNIT,IEOFSC)
C
IEOFT = IEOFT+1
C
C
SUMOUT = SUMR(1)
SMIN = SUMR(2)
SMAX = SUMR(3)
DVOSAV = SUMR(4)
C
SUMOUT = SUMOUT*DVOSAV
WRITE (IPR,950) SUMOUT,SMIN,SMAX
C
50 RETURN
C
900 FORMAT ('0',' **SCNMRG** ',/,'0',10A8,2X,2(1X,A8,1X))
905 FORMAT (//,' INITIAL LAYER = ',I5,' FINAL LAYER =',I5)
910 FORMAT ('0 SECANT =',F15.5,/'0 PRESS(MB) =',F12.5/'0 TEMP(K) =',
* F11.2,/'0 DV(CM-1) = ',F12.8,/'0 V1(CM-1) = ',F12.6,/,
* '0 V2(CM-1) = ',F12.6)
915 FORMAT ('0 COLUMN DENSITY (MOLECULES/CM**2)'//5X,'WBROAD = ',
* 1PE10.3,/(5X,A6,' = ',1PE10.3))
920 FORMAT ('0','***',A8,'***',//6X,'INPUT FILE NUMBER =',I3,
* ' ,IFILST = ',I5,' ,NIFILS = ',I5,',JEMIT =',I2,
* ' ,JFN =',I2,' ,JVAR =',I2,' ,JABS =',I2)
925 FORMAT (1X,' HWHM OF INSTRUMENT FUNCTION =',F12.8,' CM-1'/,
* 5X,'BOUND OF INSTRUMENT FUNCTION =',F12.8,' CM-1'/,6X,
* 'OUTPUT FILE NUMBER =',I3,', V1 =',F12.5,', V2 =',
* F12.5,5X,' DV OUT',F12.8)
930 FORMAT (///,'0',5X,A12,/)
935 FORMAT ('0',5X,'IEOFSC =',I3,' IDATA =',I3,' IPANEL =',I3,/)
940 FORMAT ('0',5X,'TIME =',F7.3,', READ =',F6.3,', CONV. =',F7.3,
* ', PANEL =',F6.3)
945 FORMAT ('0 SUMIN =',1P,E16.9)
950 FORMAT ('0 SUMOUT =',1P,E16.9,' MIN =',E16.9,' MAX =',E16.9)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE SHRKSC (INIT,HWHM) 3,2
C
IMPLICIT REAL*8 (V)
C
C THIS SUBROUTINE COMPRESSES (SHRINKS) THE INPUT TO THE CONVOLUTION
C ROUTINE FOR THE SCANNING FUNCTION TO ACCELERATE THE CALCULATION
C
COMMON S(3850),R1(5000),SS(200)
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
COMMON /RSCAN/ V1I,V2I,DVI,NLIM
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
DIMENSION JRATIO(24)
C
DATA JRATIO / 1,2,3,4,5,6,8,10,12,15,16,20,24,25,30,32,40,48,50,
* 60,75,80,100,120 /
C
CALL CPUTIM (TIME0)
NLIMS = NLIM
IF (NREN.GT.0) THEN
DO 10 I = 1, NREN
S(I) = SS(I)
10 CONTINUE
ENDIF
NREN = 0
IF (INIT.EQ.0) THEN
DVSC = HWHM/12.
IRATSH = DVSC/DVI+0.5
DO 20 I = 2, 24
IF (JRATIO(I).GT.IRATSH) THEN
IRATSH = JRATIO(I-1)
GO TO 30
ENDIF
20 CONTINUE
30 IF (IRATSH.GT.JRATIO(24)) IRATSH = JRATIO(24)
IF (IRATSH.LE.1) RETURN
DVSC = FLOAT(IRATSH)*DVI
V1SHFT = FLOAT(IRATSH-1)*DVI/2.
WRITE (IPR,900) IRATSH
SRATIO = IRATSH
IRATM1 = IRATSH-1
INIT = 1
ENDIF
IF (IRATSH.LE.1) RETURN
NREN = NLIM-(NLIM/IRATSH)*IRATSH
C
CPRT WRITE(IPR,905) V1I,V1SHFT,DVSC,NREN
C
V1I = V1I+V1SHFT
IMIN = 1
IMAX = NLIM-IRATM1-NREN
C
K = 0
DO 50 I = IMIN, IMAX, IRATSH
SUMK = 0.
JHI = I+IRATM1
K = K+1
DO 40 J = I, JHI
SUMK = SUMK+S(J)
40 CONTINUE
S(K) = SUMK/SRATIO
50 CONTINUE
C
V2I = V1I+DVSC*FLOAT(K-1)
NLIM = K
DVI = DVSC
ILO = ((VBOT-V1I)/DVI)+1.5
ILO = MAX(ILO,1)
IHI = ((VTOP-V1I)/DVI)+1.5
IHI = MIN(IHI,NLIM)
C
CPRT WRITE(IPR,910) ILO,IHI
C
IF (NREN.GT.0) THEN
DO 60 I = 1, NREN
II = NLIMS-NREN+I
SS(I) = S(II)
60 CONTINUE
ENDIF
CALL CPUTIM (TIME)
TIMCNV = TIMCNV+TIME-TIME0
C
RETURN
C
900 FORMAT (' SHRINK RATIO = ',I5)
905 FORMAT (' V1I =',F10.3,' V1SHFT =',F10.3,' DVSC =',F12.5,
C ' NREN =',I4)
910 FORMAT (' ILO =',I4,' IHI =',I4)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE SHAPET (XF) 2
C
C SUBROUTINE SHAPET SETS UP THE TRIANGULAR 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
XTRIAN(X) = 1.-0.5*X
DO 10 I = 1, NFMAX
XF(I) = 0.
10 CONTINUE
XF(1) = 0.5
SUM = XF(1)
DO 20 I = 2, NF
X = FLOAT(I-1)*DXF
XF(I) = 0.5*XTRIAN(X)
SUM = SUM+2.*XF(I)
20 CONTINUE
SUM = SUM*DXF
C
CPRT WRITE(IPR,900) NF,DXF,SUM
C
RETURN
C
900 FORMAT ('0',5X,'NF =',I5,', DXF =',F7.5,', SUM =',F18.15)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE RDSCAN (S,JTREM,IFILE,ISCAN,IPRT) 5,8
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE RDSCAN INPUTS PANELS FROM IFILE RESULTING
C FROM THE LBLRTM CALCULATION FOR CONVOLUTION
C WITH THE SELECTED SCANNING FUNCTION
C
COMMON /LAMCHN/ ONEPL,ONEMI,EXPMIN,ARGMIN
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 /RSCAN/ VMIN,VMAX,DVI,NNI
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
DIMENSION DUMMY(2),PNLHDR(2)
DIMENSION S(*)
C
EQUIVALENCE (PNLHDR(1),VMIN)
C
CPRT WRITE(IPR,900) VBOT,VTOP
C
IDUM1 = 0
IDUM2 = 0
ISCANT = MOD(ISCAN,1000)
IF(JTREM.EQ.0.AND.ISCANT.GE.1) GO TO 60
IF (ISCAN.LT.1) THEN
IF (JTREM.EQ.1) IDUM1 = 1
IF (JTREM.EQ.2) IDUM2 = 1
ENDIF
10 CALL BUFIN (IFILE,IEOFSC,PNLHDR(1),NPHDRF)
IF (IEOFSC.LE.0) GO TO 50
NLOW = NREN+1
IF (NREN.LE.0) NLOW = 1
VMIN = VMIN-(NLOW-1)*DVI
NNB = NNI
NNI = NNI+NLOW-1
IF ((IDATA.EQ.-1).AND.(VMIN.GT.VBOT).AND.(IPRT.EQ.1))
* WRITE (IPR,905)
IDATA = 0
IF (VMAX.GE.VBOT) GO TO 20
IF (IDUM2.EQ.1) CALL BUFIN (IFILE,IEOFSC,DUMMY(1),1)
CALL BUFIN (IFILE,IEOFSC,DUMMY(1),2)
IF (IDUM1.EQ.1) CALL BUFIN (IFILE,IEOFSC,DUMMY(1),1)
GO TO 10
20 IF (JTREM.EQ.0) THEN
CALL BUFIN (IFILE,IEOFSC,S(NLOW),NNB)
DO 30 I = NLOW, NNI
SI = S(I)
S(I) = 1.
IF (SI.GT.1.0E-04) THEN
IF (SI.LT.ARGMIN) THEN
S(I) = EXP(-SI)
ELSE
S(I) = EXPMIN
ENDIF
ELSE
S(I) = 1.-SI
ENDIF
30 CONTINUE
ELSE
C
IF (IDUM2.EQ.1) CALL BUFIN (IFILE,IEOFSC,DUMMY(1),1)
CALL BUFIN (IFILE,IEOFSC,S(NLOW),NNB)
IF (IDUM1.EQ.1) CALL BUFIN (IFILE,IEOFSC,DUMMY(1),1)
ENDIF
C
CPRT WRITE(IPR,910) VMIN,VMAX,DVI,NLOW,NNI
C
IF (JABS.NE.0) THEN
DO 40 I = NLOW, NNI
S(I) = 1.-S(I)
40 CONTINUE
ENDIF
ILO = 1
IHI = NNI
DIF = (VMIN-VBOT)/DVI
IF (DIF.LT.0.) ILO = -DIF+1.5
IF (VMAX.LE.VTOP) RETURN
IHI = (VTOP-VMIN)/DVI+1.5
IDATA = 1
RETURN
50 IF (IPRT.EQ.1) WRITE (IPR,915)
RETURN
C
60 WRITE(IPR,920) JTREM,ISCAN
RETURN
C
900 FORMAT ('0',/,'0 READING SPECTRUM, VBOT =',F10.3,', VTOP =',
* F10.3)
905 FORMAT ('0 ********** FIRST VALUE USED ON IFILE; CHECK IFILE ')
910 FORMAT (10X,'VMIN =',F10.3,', VMAX =',F10.3,', DVI=',F7.5,',
* NLOW=',I4,', NNI=',I4)
915 FORMAT ('0 ********** END OF FILE ENCOUNTERED; CHECK IFILE ')
920 FORMAT(' ERROR IN INPUT',/,' JTREM =',I2,' ISCAN=',I5)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE CONVSC (S,HWHMV1,R1,XF) 3,2
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE CONVSC PERFORMS THE CONVOLUTION WITH THE SELECTED
C SCANNING FUNCTION
C
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
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
DIMENSION S(*),R1(*),XF(*)
C
CALL CPUTIM (TIME0)
IF (ILO.GT.IHI) GO TO 60
RATIO = DVI/DVO
DVODX = DVO/DXF
HWBND = HWF/DVO
ZINT = ((V1I-VFT)/DVO)
HWHM = HWHMV1
ITST = -1
C
DO 50 I = ILO, IHI
IF ( IF (I.LT.ITST) GO TO 20
ITST = 9999
IF (JVAR.EQ.0) GO TO 10
VI = FLOAT(I-1)*DVI+V1I
HWHM = HWHMV1*(VI/V1)**2
ITST = I+IFIX(1./DVI)
10 CONTINUE
ZSLOPE = DVODX/HWHM
ZBOUND = HWBND*HWHM
XNORM = DVI/HWHM
C
CPRT WRITE(IPR,900) VI,HWHM
C
20 CONTINUE
ZPEAK = FLOAT(I-1)*RATIO+ZINT
JMAX = ZPEAK+ZBOUND+1.5
IF (JMAX.LE.MAXF) GO TO 30
ILAST = I-1
GO TO 60
C
30 JMIN = ZPEAK-ZBOUND+1.5
JMIN = MAX(JMIN,1)
SUMIN = SUMIN+S(I)
SI = XNORM*S(I)
ZF = (FLOAT(JMIN-1)-ZPEAK)*ZSLOPE
DO 40 JF = JMIN, JMAX
IT = ABS(ZF)+1.5
R1(JF) = R1(JF)+SI*XF(IT)
ZF = ZF+ZSLOPE
40 CONTINUE
C
50 CONTINUE
ILAST = IHI
IPANEL = IDATA
GO TO 70
C
60 IPANEL = 1
70 CALL CPUTIM (TIME)
TIMCNV = TIMCNV+TIME-TIME0
ILO = ILAST+1
C
RETURN
C
900 FORMAT ('0 AVE PANEL WAVENUMBER = ',F12.4,5X,'HWHM = ',F10.5)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE PANLSC (R1,JFILE,SUMR,NPTS) 2,4
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE PANLSC OUTPUTS THE RESULTS OF THE SCANNING FUNCTION
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
COMMON /SPANEL/ V1P,V2P,DV,NLIM
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) ISTOP = 1
IF (ISTOP.EQ.1) NHI = NNHI
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)
VFT = VFT+FLOAT(NLIMF-1)*DV
IF (NPTS.GT.0) THEN
WRITE (IPR,900) V1P,V2P,DVO,NLIM
WRITE (IPR,905)
NNPTS = NPTS
IF (NPTS.GT.(NLIM/2)+1) NNPTS = NLIM/2+1
IJLIM = NLIM-NNPTS+1
DO 10 IJ = 1, NNPTS
IK = IJ+IJLIM-1
VI = V1P+FLOAT(IJ-1)*DVO
VK = V1P+FLOAT(IK-1)*DVO
JJ = NLO+IJ-1
KK = NLO+IK-1
WRITE (IPR,910) IJ,VI,R1(JJ),IK,VK,R1(KK)
10 CONTINUE
ENDIF
NLIMHI = NLIM+NLO-1
DO 20 I = NLO, NLIMHI
SMIN = MIN(SMIN,R1(I))
SMAX = MAX(SMAX,R1(I))
SUMOUT = SUMOUT+R1(I)
20 CONTINUE
IF (ISTOP.EQ.1) GO TO 50
DO 30 J = NLIMF, MAXF
R1(J-NLIMF+1) = R1(J)
30 CONTINUE
DO 40 J = MAXF-NLIMF+2, MAXF
R1(J) = 0.
40 CONTINUE
NLO = NSHIFT+1
50 SUMR(1) = SUMOUT
SUMR(2) = SMIN
SUMR(3) = SMAX
SUMR(4) = DVO
CALL CPUTIM (TIME)
TIMPNL = TIMPNL+TIME-TIME0
C
RETURN
C
900 FORMAT ('0 V1P =',F12.5,' V2P =',F12.5,' DVOUT =',F12.8,' NLIM ='
* ,I10)
905 FORMAT ('0')
910 FORMAT (I5,0PF12.5,1PE12.5,I15,0PF12.5,1PE12.5)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE PNLRCT (R1,JFILE,SUMR,NPTS) 2,4
IMPLICIT REAL*8 (V)
C
C SUBROUTINE PNLRCT OUTPUTS THE RESULTS OF THE SCANNING FUNCTION
C TO FILE JFILE
C
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LBL4FL,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
COMMON /SPANEL/ V1P,V2P,DV,NLIM
DIMENSION PNLHDR(2)
DIMENSION R1(*),SUMR(*)
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) ISTOP = 1
IF (ISTOP.EQ.1) NHI = NNHI
NLIM = NHI-NLO+1
C
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)
VFT = VFT+FLOAT(NLIMF-1)*DV
IF (NPTS.GT.0) THEN
WRITE (IPR,900) V1P,V2P,DVO,NLIM
WRITE (IPR,905)
NNPTS = NPTS
IF (NPTS.GT.(NLIM/2)+1) NNPTS = NLIM/2+1
IJLIM = NLIM-NNPTS+1
DO 10 IJ = 1, NNPTS
IK = IJ+IJLIM-1
VI = V1P+FLOAT(IJ-1)*DVO
VK = V1P+FLOAT(IK-1)*DVO
JJ = NLO+IJ-1
KK = NLO+IK-1
WRITE (IPR,910) IJ,VI,R1(JJ),IK,VK,R1(KK)
10 CONTINUE
ENDIF
NLIMHI = NLIM+NLO-1
DO 20 I = NLO, NLIMHI
SMIN = MIN(SMIN,R1(I))
SMAX = MAX(SMAX,R1(I))
SUMOUT = SUMOUT+R1(I)
20 CONTINUE
C
IF (ISTOP.EQ.1) GO TO 50
DO 30 J = NLIMF, MAXF
R1(J-NLIMF+1) = R1(J)
30 CONTINUE
DO 40 J = MAXF-NLIMF+2, MAXF
R1(J) = 0.
40 CONTINUE
NLO = NSHIFT+1
50 SUMR(1) = SUMOUT
IPANEL = -1
SUMR(2) = SMIN
SUMR(3) = SMAX
SUMR(4) = DVO
CALL CPUTIM (TIME)
TIMPNL = TIMPNL+TIME-TIME0
RETURN
C
900 FORMAT('0 V1P =',F12.5,' V2P =',F12.5,' DVOUT =',F12.8,
* ' NLIM =',I10)
905 FORMAT('0')
910 FORMAT(I5,0PF12.5,1PE12.5,I15,0PF12.5,1PE12.5)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE CNVRCT (S,HWHM,R1,XF) 2,1
IMPLICIT REAL*8 (V) I
C
C SUBROUTINE CNVRCT PERFORMS THE CONVOLUTION WITH AN ALTERNATE
C RECTANGULAR SCANNING FUNCTION (ADJACENT BOXES OF ONE SIZE,
C EQUAL TO 2*HWHM)
C
C THE CONVOLUTION IS A WEIGHTED SUM THAT PROPERLY WEIGHS THE INPUT
C POINTS WITH THE FRACTION OF THAT POINT THAT COMPLETELY FALLS WITHIN
C THE OUTPUT BOX. OUTPUT RADIANCE IS THE SUMMED RADIANCE DIVIDED
C BY THE SUM OF THE WEIGHTS.
C
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 /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LBL4FL,LNGTH4
COMMON /CONTRL/ IEOFSC,IPANEL,ISTOP,IDATA,JVAR,JABS
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL
COMMON /RSCAN/ V1I,V2I,DVI,NNI
COMMON /RCTSV/ JN,SUMJ,JFLG,RNJ,NB,IPC,VLFT,VCNT,VRGT,WGTL,WGTR
DIMENSION S(*),R1(*),XF(*)
C
C LBLRTM flags
C JFLG = -1: first time through; increment NB when box is full
C JFLG = 0: subsequent calls:increment NB when box full
C JFLG = 1: out of data, return for more; do not increment NB
C IDATA =-1: first time through; or, need more data
C IDATA = 0: data present
C IDATA = 1: no data present
C IPANEL=-1: first time through; or, after panel written
C IPANEL= 0: panel not full
C IPANEL= 1: panel is full
C
CALL CPUTIM (TIME0)
RATIO = DVO/DVI
C
C During first call or if entering after writing a panel,
C initialize: SUMJ (radiance sum), and
C RNJ (accumulator for number of input points in
C current box, i.e. the sum of the weights)
C JN (box counter from 1 at VFT)
C During first call only,
C initialize: NB (box counter from 1 at V1),
C IPC (output panel counter).
C
IF (IPANEL.EQ.-1) THEN
SUMJ = 0.
RNJ = 0.
JN = NLO
IF (JFLG.EQ.-1) THEN
NB = 1
IPC = 1
ENDIF
ENDIF
C
C Check that number of points in current panel, NNI, is correct.
C
NNIV2 = (V2I-V1I)/DVI+1.0001
IF (NNI.GT.NNIV2) NNI = NNIV2
C
C Top of loop over NB boxes
C
10 IF (NLO.LE.NHI) THEN
VCNT = V1+(NB-1)*DVO
IF (VCNT.GT.V2) THEN
IPANEL = 1
RETURN
ENDIF
C
VLFT = VCNT-HWHM
VRGT = VCNT+HWHM
C
C Find lbl panel indices for points which fall within current
C box.
C
RL = (VLFT-V1I)/DVI+1
RR = (VRGT-V1I)/DVI+1
C
IL = INT(RL+0.5)
IH = INT(RR+0.5)
C
C Calculate weight for each end point, inner points weighted
C as 1. NEP is the number of endpoints in use.
C
VLBLR = (V1I+(IL-1)*DVI)+DVI/2.
WGTL = (VLBLR-VLFT)/DVI
VLBLL = (V1I+(IH-1)*DVI)-DVI/2.
WGTR = (VRGT-VLBLL)/DVI
NEP = 2
C
C Set flag if last data point on current input panel reached
C
IF (IH.GT.NNI) THEN
IH = NNI
JFLG = 1
C
C If retrieving next panel while box sum is in progress, then
C use weight of 1. for temp. right endpoint at IH = NNI = 2400
C calculate partial sum below, then return. If only one point
C is included in this sum (IL = IH = NNI), use weight of 0
C for right point, and add only left endpoint to sum.
VLBLL = (V1I+(IH-1)*DVI)-DVI/2.
WGTR = 1.
IF (IL.EQ.IH) THEN
WGTR = 0.
NEP = 1
ENDIF
ENDIF
C
C If returning with new panel to partially summed box, then set
C weight for temporary left endpoint to 1. If it's the last
C point going into the box, then count it as final right endpoint,
C and use weight of 0 for left point (since IL = IH = 1).
C
IF (IL.LE.1) THEN
IL = 1
VLBLR = (V1I+(IL-1)*DVI)+DVI/2.
WGTL = 1.
IF (IL.GE.IH) THEN
WGTL = 0.
NEP = 1
ENDIF
ENDIF
C
C If retrieving next panel while box sum is not progress, then
C check that left edge of current output box is beyond last data on
C panel (IL.GT.NNI), if so, go back for new panel without summing
C
IF (JFLG.EQ.1.AND.IDATA.EQ.0.AND.IL.GT.NNI) THEN
IPANEL = 0
JFLG = 0
RETURN
ENDIF
C
C If last point on current input panel is reached, and there is
C no more data to retrieve, then return
C
IF (JFLG.EQ.1.AND.IDATA.EQ.1) RETURN
C
C Compute sum for current box number NB, for all points but
C the end points
C
DO 20 I = IL+1, IH-1
SUMJ = SUMJ+S(I)
20 CONTINUE
C
C Add weighted end points to sum
SUMJ = SUMJ+S(IL)*WGTL
SUMJ = SUMJ+S(IH)*WGTR
C
C Define sum of the weights, where all inner points are weighted
C as 1, and the end points are weighted with the fraction that
C occurs within the box.
C
RNJ = RNJ+(IH-IL+1-NEP)+WGTL+WGTR
C
C If out of data on current input panel, go back for more;
C partial SUMJ, current NB, and JFLG are saved in COMMON RCTSV
C
IF (JFLG.EQ.1.AND.IDATA.EQ.0) THEN
IPANEL = 0
JFLG = 0
RETURN
ENDIF
C
C IPANEL=IDATA
C
SUMIN = SUMIN+SUMJ
C
C Compute average radiance for completed box
C
R1(JN) = SUMJ/RNJ
C
ILPR = IH+1
C
C Increment current box counters, initialize SUMJ and RNJ
JN = JN+1
SUMJ = 0.
RNJ = 0.
C
C Output panel when number of boxes, NB, reaches a multiple of
C 2400, using then incrementing current output panel number, IPC.
C
IF (NB.EQ.IPC*(NHI-NLO+1)) THEN
IPANEL = 1
IPC = IPC+1
NB = NB+1
RETURN
ENDIF
C
C Increment NB
NB = NB+1
C Go back to top of loop over NB boxes
C
GO TO 10
ENDIF
C
RETURN
END
C
C --------------------------------------------------------------
C
SUBROUTINE CNVVRC (S,AFOV,R1,XF) 2,1
IMPLICIT REAL*8 (V)
C
C SUBROUTINE CNVVRC PERFORMS THE CONVOLUTION WITH A RECTANGULAR
C SCANNING FUNCTION OF VARIABLE SIZE, WHERE THE BOX SIZE IS
C WAVENUMBER DEPENDENT. V1, V2, AND DVO ARE USED TO DEFINE THE
C CENTER OF THE OUTPUT BOXES. BOXES OVERLAP WHERE NECESSARY TO
C INSURE A CONSTANT DVO.
C
C BFOV is used to determine the resolution (box size), which is
C spectrally variable.
C
C AFOV is passed in from calls to CNVVRC from SCANFN and SCNMRG
C as HWHM, since the value of HWHM on Record 8.1 on TAPE5 holds
C the place of the half angle of the instrument field of view in
C degrees.
C
C BOX WIDTH EQUALS V*B**2/2, AND THE SHIFT EQUALS HALF THE BOX WIDTH
C V*(1-B**2/4), WHERE B IS THE HALF ANGLE OF THE INSTRUMENT FIELD
C OF VIEW IN RADIANS.
C
C THE CONVOLUTION IS A WEIGHTED SUM THAT PROPERLY WEIGHS THE INPUT
C POINTS WITH THE FRACTION OF THAT POINT THAT COMPLETELY FALLS WITHIN
C THE OUTPUT BOX. OUTPUT RADIANCE IS THE SUMMED RADIANCE DIVIDED
C BY THE SUM OF THE WEIGHTS.
C
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 /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LBL4FL,LNGTH4
COMMON /CONTRL/ IEOFSC,IPANEL,ISTOP,IDATA,JVAR,JABS
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL
COMMON /RSCAN/ V1I,V2I,DVI,NNI
COMMON /RCTSV/ JN,SUMJ,JFLG,RNJ,NB,IPC,VLFT,VCNT,VRGT,WGTL,WGTR
DIMENSION S(*),R1(*),XF(*)
C
C LBLRTM flags
C JFLG = -1: first time through; increment NB when box is full
C JFLG = 0: subsequent calls:increment NB when box full
C JFLG = 1: out of data, return for more; do not increment NB
C IDATA =-1: first time through; or, need more data
C IDATA = 0: data present
C IDATA = 1: no data present
C IPANEL=-1: first time through; or, after panel written
C IPANEL= 0: panel not full
C IPANEL= 1: panel is full
C
CALL CPUTIM (TIME0)
C
C Convert AFOV to BFOV, the half angle of the instrument field of
C view in radians. (For IRIS-D, AFOV equals 2.5 degrees)
BFOV = AFOV*3.141592654/180.
C
RATIO = DVO/DVI
C
C During first call or if entering after writing a panel,
C initialize: SUMJ (radiance sum), and
C RNJ (accumulator for number of input points in
C current box, i.e. the sum of the weights)
C JN (box counter from 1 at VFT)
C During first call only,
C initialize: NB (box counter from 1 at V1),
C IPC (output panel counter).
C
IF (IPANEL.EQ.-1) THEN
SUMJ = 0.
RNJ = 0.
JN = NLO
IF (JFLG.EQ.-1) THEN
NB = 1
IPC = 1
ENDIF
ENDIF
C
C Check that number of points in current panel, NNI, is correct.
C
NNIV2 = (V2I-V1I)/DVI+1.0001
IF (NNI.GT.NNIV2) NNI = NNIV2
C
C Top of loop over NB boxes
C
10 IF (NLO.LE.NHI) THEN
C For current box find wavenumber at center and left/right edges.
C For first box, VCNT equals V1. When current box exceeds V2,
C then exit.
VCNT = V1+(NB-1)*DVO
IF (VCNT.GT.V2) THEN
IPANEL = 1
RETURN
ENDIF
VLFT = VCNT*(1-BFOV**2/4)
VRGT = VCNT*(1+BFOV**2/4)
C Find lbl panel indices for points which fall within current box.
RL = (VLFT-V1I)/DVI+1
RR = (VRGT-V1I)/DVI+1
C
IL = INT(RL+0.5)
IH = INT(RR+0.5)
C
C Calculate weight for each end point, inner points weighted as 1.
C NEP is the number of endpoints in use.
C
VLBLR = (V1I+(IL-1)*DVI)+DVI/2.
WGTL = (VLBLR-VLFT)/DVI
VLBLL = (V1I+(IH-1)*DVI)-DVI/2.
WGTR = (VRGT-VLBLL)/DVI
NEP = 2
C
C Set flag if last data point on current input panel reached
C
IF (IH.GT.NNI) THEN
IH = NNI
JFLG = 1
C
C If retrieving next panel while box sum is in progress, then
C use weight of 1. for temp. right endpoint at IH = NNI = 2400
C calculate partial sum below, then return. If only one point
C is included in this sum (IL = IH = NNI), use weight of 0
C for right point, and add only left endpoint to sum.
VLBLL = (V1I+(IH-1)*DVI)-DVI/2.
WGTR = 1.
IF (IL.EQ.IH) THEN
WGTR = 0.
NEP = 1
ENDIF
ENDIF
C
C If returning with new panel to partially summed box, then set
C weight for temporary left endpoint to 1. If it's the last
C point going into the box, then count it as final right endpoint,
C and use weight of 0 for left point (since IL = IH = 1).
C
IF (IL.LE.1) THEN
IL = 1
VLBLR = (V1I+(IL-1)*DVI)+DVI/2.
WGTL = 1.
IF (IL.GE.IH) THEN
WGTL = 0.
NEP = 1
ENDIF
ENDIF
C
C If retrieving next panel while box sum is not progress, then
C check that left edge of current output box is beyond last data on
C panel (IL.GT.NNI), if so, go back for new panel without summing
C
IF (JFLG.EQ.1.AND.IDATA.EQ.0.AND.IL.GT.NNI) THEN
IPANEL = 0
JFLG = 0
RETURN
ENDIF
C
C If last point on current input panel is reached, and there is
C no more data to retrieve, then return
C
IF (JFLG.EQ.1.AND.IDATA.EQ.1) RETURN
C
C Compute sum for current box number NB, for all points but
C the end points
C
DO 20 I = IL+1, IH-1
SUMJ = SUMJ+S(I)
20 CONTINUE
C
C Add weighted end points to sum
SUMJ = SUMJ+S(IL)*WGTL
SUMJ = SUMJ+S(IH)*WGTR
C
C Define sum of the weights, where all inner points are weighted
C as 1, and the end points are weighted with the fraction that
C occurs within the box.
C
RNJ = RNJ+(IH-IL+1-NEP)+WGTL+WGTR
C
C If out of data on current input panel, go back for more;
C partial SUMJ, current NB, and JFLG are saved in COMMON RCTSV
C
IF (JFLG.EQ.1.AND.IDATA.EQ.0) THEN
IPANEL = 0
JFLG = 0
RETURN
ENDIF
C
C IPANEL=IDATA
C
SUMIN = SUMIN+SUMJ
C
C
C Compute average radiance for completed box
C
R1(JN) = SUMJ/RNJ
C
C Increment current box counters, initialize SUMJ and RNJ
JN = JN+1
SUMJ = 0.
RNJ = 0.
C
C Output panel when number of boxes, NB, reaches a multiple of
C 2400, using then incrementing current output panel number, IPC.
C
IF (NB.EQ.IPC*(NHI-NLO+1)) THEN
IPANEL = 1
IPC = IPC+1
NB = NB+1
RETURN
ENDIF
C Increment NB
NB = NB+1
C
C Go back to top of loop over NB boxes
C
GO TO 10
ENDIF
C
RETURN
END
C
C --------------------------------------------------------------
C
SUBROUTINE CNVVRL (S,AFOV,R1,XF) 2,1
IMPLICIT REAL*8 (V)
C
C SUBROUTINE CNVVRL PERFORMS THE CONVOLUTION WITH A RECTANGULAR
C SCANNING FUNCTION OF VARIABLE SIZE, WHERE THE BOX SIZE IS
C WAVENUMBER DEPENDANT. V1, V2, AND DVO ARE USED TO DEFINE THE
C LEFT EDGE OF THE OUTPUT BOXES. BOXES OVERLAP WHERE NECESSARY
C TO INSURE A CONSTANT DVO.
C
C BFOV is used to determine the resolution (box size), which is
C spectrally variable.
C
C AFOV is passed in from calls to CNVVRL from SCANFN and SCNMRG
C as HWHM, since the value of HWHM on Record 8.1 on TAPE5 holds
C the place of the half angle of the instrument field of view in
C degrees.
C
C BOX WIDTH EQUALS V*B**2/2, AND THE SHIFT EQUALS HALF THE BOX WIDTH
C V*(1-B**2/4), WHERE B IS THE HALF ANGLE OF THE INSTRUMENT FIELD
C OF VIEW IN RADIANS.
C
C THE CONVOLUTION IS A WEIGHTED SUM THAT PROPERLY WEIGHS THE INPUT
C POINTS WITH THE FRACTION OF THAT POINT THAT COMPLETELY FALLS WITHIN
C THE OUTPUT BOX. OUTPUT RADIANCE IS THE SUMMED RADIANCE DIVIDED
C BY THE SUM OF THE WEIGHTS.
C
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 /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LBL4FL,LNGTH4
COMMON /CONTRL/ IEOFSC,IPANEL,ISTOP,IDATA,JVAR,JABS
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL
COMMON /RSCAN/ V1I,V2I,DVI,NNI
COMMON /RCTSV/ JN,SUMJ,JFLG,RNJ,NB,IPC,VLFT,VCNT,VRGT,WGTL,WGTR
DIMENSION S(*),R1(*),XF(*)
C
C LBLRTM flags
C JFLG = -1: first time through; increment NB when box is full
C JFLG = 0: subsequent calls:increment NB when box full
C JFLG = 1: out of data, return for more; do not increment NB
C IDATA =-1: first time through; or, need more data
C IDATA = 0: data present
C IDATA = 1: no data present
C IPANEL=-1: first time through; or, after panel written
C IPANEL= 0: panel not full
C IPANEL= 1: panel is full
C
CALL CPUTIM (TIME0)
C
C Convert AFOV to BFOV, the half angle of the instrument field of
C view in radians. (For IRIS-D, AFOV equals 2.5 degrees)
BFOV = AFOV*3.141592654/180.
RATIO = DVO/DVI
C
C During first call or if entering after writing a panel,
C initialize: SUMJ (radiance sum), and
C RNJ (accumulator for number of input points in
C current box, i.e. the sum of the weights)
C JN (box counter from 1 at VFT)
C During first call only,
C initialize: NB (box counter from 1 at V1),
C IPC (output panel counter).
C
IF (IPANEL.EQ.-1) THEN
SUMJ = 0.
RNJ = 0.
JN = NLO
IF (JFLG.EQ.-1) THEN
NB = 1
IPC = 1
ENDIF
ENDIF
C
C Check that number of points in current panel, NNI, is correct.
C
NNIV2 = (V2I-V1I)/DVI+1.0001
IF (NNI.GT.NNIV2) NNI = NNIV2
C
C Top of loop over NB boxes
C
10 IF (NLO.LE.NHI) THEN
C
C For current box find wavenumber at the left and right edges.
C For first box, VLFT equals V1. When current box exceeds V2,
C then exit.
C
VLFT = V1+(NB-1)*DVO
IF (VLFT.GT.V2) THEN
IPANEL = 1
RETURN
ENDIF
C
VCNT = VLFT*(1+BFOV**2/4)
VRGT = VLFT*(1+BFOV**2/2)
C
C Find lbl panel indices for points which fall within current box.
C
RL = (VLFT-V1I)/DVI+1
RR = (VRGT-V1I)/DVI+1
C
IL = INT(RL+0.5)
IH = INT(RR+0.5)
C
C Calculate weight for each end point, inner points weighted as 1,
C NEP is the number of endpoints in use.
C
VLBLR = (V1I+(IL-1)*DVI)+DVI/2.
WGTL = (VLBLR-VLFT)/DVI
VLBLL = (V1I+(IH-1)*DVI)-DVI/2.
WGTR = (VRGT-VLBLL)/DVI
NEP = 2
C
C Set flag if last data point on current input panel reached
C
IF (IH.GT.NNI) THEN
IH = NNI
JFLG = 1
C
C If retrieving next panel while box sum is in progress, then
C use weight of 1. for temp. right endpoint at IH = NNI,
C calculate partial sum below, then return. If only one point
C is included in this sum (IL = IH = NNI), use weight of 0
C for right point, and add only left endpoint to sum.
VLBLL = (V1I+(IH-1)*DVI)-DVI/2.
WGTR = 1.
IF (IL.EQ.IH) THEN
WGTR = 0.
NEP = 1
ENDIF
ENDIF
C
C If returning with new panel to partially summed box, then set
C weight for temporary left endpoint to 1. If it's the last
C point going into the box, then count it as final right endpoint,
C and use weight of 0 for left point (since IL = IH = 1).
C
IF (IL.LE.1) THEN
IL = 1
VLBLR = (V1I+(IL-1)*DVI)+DVI/2.
WGTL = 1.
IF (IL.GE.IH) THEN
WGTL = 0.
NEP = 1
ENDIF
ENDIF
C
C If retrieving next panel while box sum is not in progress, then
C check that left edge of current output box is beyond last data on
C panel (IL.GT.NNI), if so, go back for new panel without summing
C
IF (JFLG.EQ.1.AND.IDATA.EQ.0.AND.IL.GT.NNI) THEN
IPANEL = 0
JFLG = 0
RETURN
ENDIF
C
C If last point on current input panel is reached, and there is
C no more data to retrieve, then return
C
IF (JFLG.EQ.1.AND.IDATA.EQ.1) RETURN
C
C Compute sum for current box number NB, using a weight of 1.0
C for all points but the end points, which use WGTL and WGTR
C
DO 20 I = IL+1, IH-1
SUMJ = SUMJ+S(I)
20 CONTINUE
C
C Add weighted end points to sum
SUMJ = SUMJ+S(IL)*WGTL
SUMJ = SUMJ+S(IH)*WGTR
C
C Define sum of the weights, where all inner points are weighted
C as 1, and the end points are weighted with the fraction that
C occurs within the box.
C
RNJ = RNJ+(IH-IL+1-NEP)+WGTL+WGTR
C
C If out of data on current input panel, go back for more;
C partial SUMJ, current NB, and JFLG are saved in COMMON RCTSV
C
IF (JFLG.EQ.1.AND.IDATA.EQ.0) THEN
IPANEL = 0
JFLG = 0
RETURN
ENDIF
C
C IPANEL=IDATA
C
SUMIN = SUMIN+SUMJ
C
C Compute average radiance for completed box
C
R1(JN) = SUMJ/RNJ
C
C Increment current box counters, initialize SUMJ and RNJ
JN = JN+1
SUMJ = 0.
RNJ = 0.
C
C Output panel when number of boxes, NB, reaches a multiple of
C 2400, using then incrementing current output panel number, IPC.
C
IF (NB.EQ.IPC*(NHI-NLO+1)) THEN
IPANEL = 1
IPC = IPC+1
NB = NB+1
RETURN
ENDIF
C
C Increment NB
NB = NB+1
C
C Go back to top of loop over NB boxes
C
GO TO 10
C
ENDIF
C
RETURN
END
C
C --------------------------------------------------------------
C
SUBROUTINE SINCSQ (XF,XSCALE) 2
C
C SUBROUTINE SINCSQ SETS UP THE SINCSQ 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
C DATA XSCALE / 1.391557377 /
C
XSINC2(X) = (SIN(X)/X)**2
PI = 2.*ASIN(1.)
C
C PI CORRESPONDS TO X=2.257609141
C
XNORM = XSCALE/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*XSINC2(X*XSCALE)
SUM = SUM+2.*XF(I)
20 CONTINUE
SUM = SUM*DXF
C
CPRT WRITE(IPR,900) NF,DXF,SUM
C
RETURN
C
900 FORMAT ('0',5X,'NF =',I5,', DXF =',F7.5,', SUM =',F18.15)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE SINC (XF,XSCALE) 2
C
C SUBROUTINE SINC SETS UP THE SINC 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
C DATA XSCALE / 1.89549425 /
C
XSINC(X) = (SIN(X)/X)
PI = 2.*ASIN(1.)
C
C PI CORRESPONDS TO X=1.657400255
C
XNORM = XSCALE/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*XSINC(X*XSCALE)
SUM = SUM+2.*XF(I)
20 CONTINUE
SUM = SUM*DXF
C
CPRT WRITE(IPR,900) NF,DXF,SUM
C
RETURN
C
900 FORMAT ('0',5X,'NF =',I5,', DXF =',F7.5,', SUM =',F18.15)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE INTRPL (IFILE,JFILE) 1,8
C
IMPLICIT REAL*8 (V)
C
C**********************************************************************
C
C INTERPOLATION FUNCTION DRIVER: FOUR POINT VERSION
C
C A.E.R. INC. (MARCH 1990)
C
C**********************************************************************
C
C THE INPUT DATA WILL BE PUT INTO T(5) WITH THE LAST
C 4 POINTS OF THE PREVIOUS PANEL PUT INTO T(1 TO 4).
C THIS SCHEME PERMITS 6 POINT INTERPOLATION.
C
C S IS NOMINALLY 2401 POINTS BUT MAY NEED TO BE EXTENDED BY TWO (2)
C POINTS TO PERMIT 4 POINT INTERPOLATION UP TO THE LAST DATA POINT.
C
COMMON T(2410),R(2401)
DIMENSION S(2406)
EQUIVALENCE (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 /SCNHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WN2 ,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
COMMON /INPNL/ V1I,V2I,DVI,NNI
COMMON /OUTPNL/ V1J,V2J,DVJ,NNJ
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /FLFORM/ CFORM
C
DIMENSION FILHDR(2),RSTAT(3)
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
CHARACTER*12 BCD,HTRANS,HABSRB,HRADIA
CHARACTER CFORM*11,SCNOUT*6,CTAPE*4
CHARACTER*8 HVRLBL,HVRCNT,HVRFFT,HVRATM,HVRLOW,HVRNCG,HVROPR,
* HVRPLT,HVRPST,HVRTST,HVRUTL,HVRXMR
LOGICAL OP
C
DATA HTRANS / 'TRANSMISSION'/,HABSRB / ' ABSORPTION '/,
* HRADIA / ' RADIANCE '/
DATA SCNOUT / ' '/,CTAPE / 'TAPE'/
C
C----------------------------------------------------------------------
C JEMIT=-1 INTERPOLATE ABSORPTION
C JEMIT=0 INTERPOLATE TRANSMISSION
C JEMIT=1 INTERPOLATE EMISSION
C JEMIT=2 INTERPOLATE OPTICAL DEPTH
C----------------------------------------------------------------------
C
C
C ASSIGN SCCS VERSION NUMBER TO MODULE
C
HVRPST = '5.11'
C
10 CONTINUE
CALL CPUTIM (TIME1)
TIMRDF = 0.0
TIMCNV = 0.0
TIMPNL = 0.0
C
READ (IRD,900,END=50) DVO,V1,V2,JEMIT,I4PT,IUNIT,IFILST,NIFILS,
* JUNIT,NPTS
IF (DVO.LE.0.) GO TO 40
C
C V2 IS ONLY APPROXIMATE
C
NUM = (((V2-V1)/DVO)+0.5)
V2 = V1+FLOAT(NUM)*DVO
NUM = NUM+1
WRITE (IPR,905) V1,V2,DVO,NUM,JEMIT,I4PT,IUNIT,IFILST,JUNIT,NPTS
C
C SET INPUT(IFILE), OUTPUT(JFILE) UNITS.
C
IF (IUNIT.LE.0) IUNIT = IFILE
IFILE = IUNIT
INQUIRE (UNIT=IFILE,OPENED=OP)
IF (.NOT.OP) THEN
WRITE (SCNOUT,910) CTAPE,IFILE
OPEN (IFILE,FILE=SCNOUT,STATUS='UNKNOWN',FORM=CFORM)
ENDIF
IFILST = MAX(IFILST,1)
IF (NIFILS.LE.0) NIFILS = 99
IF (JUNIT.LE.0) JUNIT = JFILE
JFILE = JUNIT
INQUIRE (UNIT=JFILE,OPENED=OP)
IF (.NOT.OP) THEN
WRITE (SCNOUT,910) CTAPE,JFILE
OPEN (JFILE,FILE=SCNOUT,STATUS='UNKNOWN',FORM=CFORM)
REWIND JFILE
ENDIF
C
REWIND IFILE
IF (IFILST.GT.1) CALL SKIPFL (IFILST-1,IFILE,IEOF)
C
C BUFFER IN THE FILE HEADER ON UNIT (IFILE)
C BUFFER OUT ON UNIT (JFILE)
C
CALL BUFIN (IFILE,IEOF,FILHDR(1),NFHDRF)
IF (IEOF.EQ.0) GO TO 10
C
WRITE (IPR,915) XID,(YID(M),M=1,2)
WRITE (IPR,920) LAYR1,LAYER
WRITE (IPR,925) SECANT,PAVE,TAVE,DV,V1C,V2C
WRITE (IPR,930) WN2,(HMOLID(M),WK(M),M=1,NMOL)
C
JABS = 0
IDABS = 0
IF (JEMIT.LT.0) THEN
JABS = 1
JEMIT = 0
IDABS = -1
ENDIF
C
ISCAN = ISCHDR
IF (ISCAN.LE.0.OR.XSCID.EQ.-99.) ISCAN = 0
IF (ISCHDR.GE.1000.AND.ISCAN.EQ.0) ISCAN = ISCHDR
ISCHDR = ISCAN+10
V1C = V1
V2C = V2
DV = DVO
C
SCNID = 100*JEMIT
XSCID = SCNID+0.01
C
CALL BUFOUT (JFILE,FILHDR(1),NFHDRF)
C
ICNVRT = 0
JTREM = -1
IF ((IEMIT.EQ.0).AND.(JEMIT.EQ.0)) JTREM = 0
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.0)) JTREM = 2
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.2)) JTREM = 2
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.1)) JTREM = 1
ISCANT = MOD(ISCAN,1000)
IF ((ISCANT.GE.1).AND.(JEMIT.EQ.0)) JTREM = 2
IF (JTREM.LT.0) STOP 71048
WRITE (IPR,935) IEMIT,JEMIT,JTREM
WRITE (IPR,940) IFILE,IFILST,NIFILS,JEMIT,JABS
C
IDATA = -1
C
C NEED TO SAVE LAST IBOUND POINTS OF EACH PANEL TO ATTACH TO NEXT
C
IBOUND = 4
C
C VBOT IS LOWEST NEEDED WAVENUMBER, VTOP IS HIGHEST
C
BOUND = FLOAT(IBOUND)*DV
VBOT = V1-BOUND
VTOP = V2+BOUND
C
IF (JEMIT.EQ.0.AND.IDABS.EQ.0) BCD = HTRANS
IF (JEMIT.EQ.0.AND.IDABS.EQ.-1) BCD = HABSRB
IF (JEMIT.EQ.1) BCD = HRADIA
IF (NPTS.GT.0) WRITE (IPR,945) BCD
C
C ZERO OUT T(1 TO IBOUND)
C
DO 20 II = 1, IBOUND
T(II) = 0.0
20 CONTINUE
C
C READ FROM IFILE UNTIL THE FIRST REQUIRED POINT IS REACHED
C AND LOAD DATA INTO S
C
CALL RDPANL (S,JTREM,IFILE,ISCAN,JEMIT,ICNRT)
IF (IEOFSC.LE.0) GO TO 30
C
C DO INTERPOLATION
C
CALL INTERP (IFILE,JFILE,I4PT,IBOUND,NPTS,JTREM,ISCAN,JEMIT,
* RSTAT,ICNVRT)
C
CALL CPUTIM (TIME2)
CALL ENDFIL (JFILE)
C
C WRITE STATISTICS
C
WRITE (IPR,950) RSTAT(1),RSTAT(2),RSTAT(3)
TIMTOT = TIME2-TIME1
TIMCNV = TIMTOT-TIMRDF-TIMPNL
WRITE (IPR,955) TIMTOT,TIMRDF,TIMCNV,TIMPNL
GO TO 10
C
30 CONTINUE
WRITE (IPR,960) IFILE
C
GO TO 10
C
40 CONTINUE
WRITE (IPR,965)
C
RETURN
C
50 CONTINUE
WRITE (IPR,970) IRD
STOP ' INTRPL'
C
900 FORMAT (3F10.3,2I5,15X,5I5)
905 FORMAT (5X,'V1=',F14.8,' V2=',F14.8,' DVO=',E14.6,' NUM=',I8,/5X,
* 'JEMIT=',I3,' I4PT=',I3,' IUNIT=',I3,' IFILST=',I3,/5X,
* 'JUNIT=',I3,' NPTS=',I5)
910 FORMAT (A4,I2.2)
915 FORMAT (//,' ***INTRPL***',/,'0',10A8,2X,2(1X,A8,1X))
920 FORMAT (//,' INITIAL LAYER = ',I5,' FINAL LAYER =',I5)
925 FORMAT (' SECANT =',F15.5,/' PRESS(MB) =',F12.5/' TEMP(K) =',
* F11.2,/' DV(CM-1) = ',F12.8,/,' V1(CM-1) = ',F12.6,/,
* ' V2(CM-1) = ',F12.6)
930 FORMAT (/,' COLUMN DENSITY (MOLECULES/CM**2)',/,5X,'WBROAD = ',
* 1PE10.3,/(5X,A6,' = ',1PE10.3))
935 FORMAT (5X,'IEMIT=',I5,' JEMIT=',I5,' JTREM=',I5)
940 FORMAT (5X,'INPUT FILE NUMBER =',I3,' ,IFILST = ',I3,
* ' ,NIFILS = ',I3,',JEMIT =',I2,' ,JABS =',I2)
945 FORMAT (///,'0',5X,A12,/)
950 FORMAT (/,5X,'SUMOUT =',1P,E16.9,' MIN =',E16.9,' MAX =',E16.9)
955 FORMAT (/,5X,'TIME: TOTAL = ',F8.3,' READ = ',F8.3,' INTERP = ',
* F8.3,' WRITE = ',F8.3)
960 FORMAT (/,5X,'INTRPL- ERROR: EOF ON INPUT UNIT ',I4,
* ' BEFORE V1 WAS REACHED')
965 FORMAT (/,5X,'END OF INTERPOLATION REQUESTS')
970 FORMAT (/,5X,' INTRP - ERROR: EOF ON STANDARD INPUT, UNIT = ',I4)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE RDPANL (S,JTREM,IFILE,ISCAN,JEMIT,ICNVRT) 4,10
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE RDPANL INPUTS PANELS FROM IFILE RESULTING FROM THE
C LBLRTM CALCULATION
C
COMMON /LAMCHN/ ONEPL,ONEMI,EXPMIN,ARGMIN
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
COMMON /CONTRL/ IEOFSC,IPANEL,ISTOP,IDATA,JVAR,JABS
COMMON /INPNL/ VMIN,VMAX,DVI,NNI
COMMON /RPANL/ V1P,V2P,DVP,NLIMP
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
DIMENSION DUMMY(2),PNLHDR(2)
DIMENSION S(*)
C
EQUIVALENCE (PNLHDR(1),V1P)
C
C----------------------------------------------------------------------
C
CALL CPUTIM (TIME1)
IDUM1 = 0
IDUM2 = 0
ISCANT = MOD(ISCAN,1000)
IF (JTREM.EQ.0.AND.ISCANT.GE.1) GO TO 70
IF (ISCAN.LT.1) THEN
IF (JTREM.EQ.1) IDUM1 = 1
IF (JTREM.EQ.2) IDUM2 = 1
ENDIF
10 CALL BUFIN (IFILE,IEOFSC,PNLHDR(1),NPHDRF)
IF (IEOFSC.LE.0) THEN
WRITE (IPR,900)
GO TO 60
ELSE
VMIN = V1P
VMAX = V2P
DVI = DVP
NNI = NLIMP
ENDIF
C
IF ((IDATA.EQ.-1).AND.(VMIN.GT.VBOT)) WRITE (IPR,905)
IDATA = 0
IF (VMAX.GE.VBOT) GO TO 20
IF (IDUM2.EQ.1) CALL BUFIN (IFILE,IEOFSC,DUMMY(1),2)
CALL BUFIN (IFILE,IEOFSC,DUMMY(1),2)
IF (IDUM1.EQ.1) CALL BUFIN (IFILE,IEOFSC,DUMMY(1),2)
GO TO 10
C
20 IF (JTREM.EQ.0) THEN
CALL BUFIN (IFILE,IEOFSC,S(1),NNI)
IF (JEMIT.NE.2.AND.ICNVRT.EQ.0) THEN
DO 30 I = 1, NNI
SI = S(I)
S(I) = 1.
IF (SI.GT.0.) THEN
IF (SI.GE.ARGMIN) THEN
S(I) = EXPMIN
ELSE
S(I) = EXP(-SI)
ENDIF
ENDIF
30 CONTINUE
ENDIF
ELSE
C
IF (IDUM2.EQ.1) CALL BUFIN (IFILE,IEOFSC,DUMMY(1),2)
CALL BUFIN (IFILE,IEOFSC,S(1),NNI)
IF (IDUM1.EQ.1) CALL BUFIN (IFILE,IEOFSC,DUMMY(1),2)
ENDIF
C
IF (JABS.EQ.1.AND.ICNVRT.EQ.0) THEN
DO 40 I = 1, NNI
S(I) = 1.-S(I)
40 CONTINUE
ENDIF
IF (JEMIT.EQ.2.AND.ICNVRT.EQ.0) THEN
DO 50 I = 1, NNI
S(I) = -ALOG( 50 CONTINUE
ENDIF
C
VMIN = VMIN-4.0*DVI
NNI = NNI+4
ILO = 1
IHI = NNI
DIF = (VMIN-VBOT)/DVI
IF (DIF.LT.0.) ILO = -DIF+1.5
IF (VMAX.GT.VTOP) THEN
IHI = (VTOP-VMIN)/DVI+1.5
IDATA = 1
ENDIF
C
60 CALL CPUTIM (TIME2)
TIMRDF = TIMRDF+TIME2-TIME1
C
RETURN
C
70 WRITE (IPR,910) JTREM,ISCAN
C
RETURN
C
900 FORMAT ('0 ********** END OF FILE ENCOUNTERED; CHECK IFILE ')
905 FORMAT ('0 ********** FIRST VALUE USED ON IFILE; CHECK IFILE ')
910 FORMAT (' ERROR IN INPUT',/,' JTREM =',I2,' ISCAN=',I5)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE OTPANL (R1,JFILE,NPTS) 3,4
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE OTPANL OUTPUTS THE RESULTS OF THE INTERPOLATION ON
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 /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL
COMMON /OUTPNL/ V1P,V2P,DVP,NLIM
DIMENSION PNLHDR(2),R1(*)
C
EQUIVALENCE (PNLHDR(1),V1P)
C
C----------------------------------------------------------------------
C
CALL CPUTIM (TIME1)
IF (NLIM.LE.0) GO TO 20
C
CALL BUFOUT (JFILE,PNLHDR(1),NPHDRF)
CALL BUFOUT (JFILE,R1(1),NLIM)
C
IF (NPTS.GT.0) THEN
WRITE (IPR,900) V1P,V2P,DVP,NLIM
WRITE (IPR,905)
NNPTS = NPTS
IF (NPTS.GT.(NLIM/2)+1) NNPTS = NLIM/2+1
IJLIM = NLIM-NNPTS+1
DO 10 IJ = 1, NNPTS
IK = IJ+IJLIM-1
VIJ = V1P+FLOAT(IJ-1)*DVP
VIK = V1P+FLOAT(IK-1)*DVP
WRITE (IPR,910) IJ,VIJ,R1(IJ),IK,VIK,R1(IK)
10 CONTINUE
ENDIF
C
20 CALL CPUTIM (TIME2)
TIMPNL = TIMPNL+TIME2-TIME1
C
RETURN
C
900 FORMAT ('0 V1P =',F12.5,' V2P =',F12.5,' DVP =',F12.8,' NLIM =',
* I8)
905 FORMAT ('0')
910 FORMAT (I5,0PF12.5,1PE12.5,I15,0PF12.5,1PE12.5)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE INTERP (IFILE,JFILE,I4PT,IBOUND,NPTS,JTREM,ISCAN, 3,6
* JEMIT,RSTAT,ICNVRT)
C
IMPLICIT REAL*8 (V)
C
C**********************************************************************
C THIS SUBROUTINE INTERPOLATES THE SPECTRAL DATA FROM IFILE, ON
C A GRID DEFINED BY V1I,V2I,DVI, AND NNI, ONTO THE GRID FROM
C V1 TO V2 WITH A DV OF DVO AND WRITES THE RESULT TO JFILE.
C THE INTERPOLATION IS EITHER LINEAR (I4PT = 0) OR 4 POINT (I4PT
C = 1). IBOUND IS THE NUMBER OF POINTS NEEDED FROM THE PREVIOUS
C INPUT PANEL, WHILE NPTS IS THE NUMBER OF POINTS TO BE PRINTED
C AT THE BEGINNING AND END OF EACH OUTPUT PANEL. JTREM,ISCAN, AND
C JEMIT RELATE TO THE INPUT DATA AND ARE NEEDED BY RDPANL.
C RSTAT(3) RETURNS THE SUM, MIN, AND MAX OF THE INTERPOLATED
C SPECTRUM.
C**********************************************************************
C
C THE INPUT DATA WILL BE PUT INTO T(5) WITH THE LAST
C IBOUND POINTS OF THE PREVIOUS PANEL PUT INTO T(1-4)
C
COMMON T(2410),R(2401)
DIMENSION S(2406)
EQUIVALENCE (C
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 /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /CONTRL/ IEOFSC,IPANEL,ISTOP,IDATA,JVAR,JABS
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL
COMMON /INPNL/ V1I,V2I,DVI,NNI
COMMON /OUTPNL/ V1J,V2J,DVJ,NNJ
DIMENSION C1(0:202),C2(0:202),C3(0:202),C4(0:202),RSTAT(3)
C
DATA NUMCOF / 201 /
C
CALL CPUTIM (TIME1)
C
C SET UP FOUR POINT INTERPOLATION COEFICIENTS FOR P FOR 201
C POINTS BETWEEN 0 AND 1.0, with an extra point at each end
C
IF (I4PT.NE.0) THEN
XNUMCF = FLOAT(NUMCOF)
DO 10 IP = 0, NUMCOF+1
P = (FLOAT(IP)-1.0)/(XNUMCF-1.0)
PP = P**2
C1(IP) = -P/2.0*(1-P)**2
C2(IP) = 1.0-PP*(3.0-2.0*P)+PP/2.0*(1.0-P)
C3(IP) = PP*(3.0-2.0*P)+P/2.0*(1.0-P)**2
C4(IP) = -PP/2*(1.0-P)
10 CONTINUE
ENDIF
C
C V1 IS REQUESTED LOWER V, VBOT = V1-VBOUND. VBOUND ALLOWS FOR
C 4 POINT INTERPOLATION OF THE FIRST DATA POINT.
C THE FIRST PANEL OF DATA IS STORED IN T, STARTING AT T(5)
C WITH A CORRESPONDING WAVENUMBER V1I.
C T(1-4) ARE USED TO STORE THE LAST IBOUND POINTS FROM THE
C PREVIOUS PANEL, BUT ARE ZEROED OUT FOR THE FIRST PANEL.
C THE INTERPOLATED POINTS ARE STORED IN THE ARRAY R.
C THE INDEX I REFERS TO THE INPUT POINTS, J TO THE OUTPUT POINTS.
C P VARIES FROM 0 TO 1 AND IS THE FRACTIONAL DISTANCE OF THE
C CURRENT OUTPUT WAVENUMBER VJ TO THE NEXT LOWEST INPUT WAVENUMBER
C RELATIVE TO THE INPUT DV: P = (VJ-VI(II))/DVI
C INRANG IS 0 IF VJ IS WITHIN THE RANGE OF THE INPUT DATA, -1
C IF VJ IS LESS THAN THE INPUT DATA, AND 1 IF IT IS GREATER
C
C INITIALIZE THE VARIABLES
C
V1J = V1
DVJ = DVO
VRATIO = DVJ/DVI
VJ = V1J
C
RMIN = 1.0E15
RMAX = -1.0
RSUM = 0.0
C
C EXTRAPOLATE DOWN TO V1I-DVI SO THAT THE POINT I=4 IS AVAILABLE
C FOR THE FIRST PANEL. THIS ALLOWS 4 POINT INTERPOLATION BETWEEN
C V1I AND V1I+DVI
C
T(4) = 2.0*T(5)-T(6)
C
C LOOP OVER THE OUTPUT PANELS
C
C IF V1J .LT. V1I, THEN ZERO FILL UP TO V1I.
C
20 IF (V1J.LT.V1I) THEN
J1 = 1
J2 = MIN(INT((V1I-V1J)/DVJ)+1,2400)
C
C FILL IN
C
DO 30 J = J1, J2
R(J) = 0.0
30 CONTINUE
C
V2J = V1J+DVJ*(J2-1)
NNJ = J2
CALL OTPANL (R,JFILE,NPTS)
V1J = V2J+DVJ
VJ = V1J
C
GO TO 20
ENDIF
C
C AT THIS POINT, VJ >= V1I
C
40 CONTINUE
C
C I INDEXES THE LARGEST VI .LE. VJ
C AND AT THIS POINT SHOULD .GE. 1.
C
I = (VJ-V1I)/DVI+1.00001
IF (I.LT.1) THEN
WRITE (IPR,*) ' INTERP-ERROR: I SHOULD >= 1, IS ',I
ENDIF
VI = V1I+DVI*FLOAT(I-1)
C
C P IS INCREMENTED BY ADDING DVJ/DVI BUT WILL BE REINITIALIZED
C HERE FOR EACH OUTPUT PANEL TO AVOID THE ACCUMULATION OF
C TRUNCATION ERRORS
C
P = (VJ-VI)/DVI
C
J1 = INT((VJ-V1J)/DVJ+1.001)
J2 = MIN(INT((V2-V1J)/DVJ+1.001),INT((V2I-DVI-V1J)/DVJ+1.),2400)
C
C LOOP OVER A SINGLE OUTPUT PANEL
C
IF (I4PT.GT.0) THEN
C
C 4 POINT INTERPOLATION
C
DO 50 J = J1, J2
C
C PERFORM INTERPOLATION
C
IP = P*XNUMCF+1.00001
R(J) = C1(IP)*T(I-1)+C2(IP)*T(I)+C3(IP)*T(I+1)+
* C4(IP)*T(I+2)
C
C ACCUMULATE STATISTICS
C
RMIN = MIN(RMIN,R(J))
RMAX = MAX(RMAX,R(J))
RSUM = RSUM+R(J)
C
C INCREMENT P AND I
C
P = P+VRATIO
IF (P.GE.1.0) THEN
I = I+P
P = P-FLOAT(INT(P))
ENDIF
C
50 CONTINUE
C
ELSE
C
C LINEAR INTERPOLATION
C
DO 60 J = J1, J2
C
C PERFORM INTERPOLATION
C
R(J) = T(I)*(1.0-P)+T(I+1)*P
C
C ACCUMULATE STATISTICS
C
RMIN = MIN(RMIN,R(J))
RMAX = MAX(RMAX,R(J))
RSUM = RSUM+R(J)
C
C INCREMENT P AND I
C
P = P+VRATIO
IF (P.GE.1.0) THEN
I = I+P
P = P-FLOAT(INT(P))
ENDIF
60 CONTINUE
C
ENDIF
C
C VJ IS THE FREQUENCY OF THE NEXT OUTPUT POINT (NOT THE LAST
C POINT IS THE CURRENT PANEL)
C
VJ = V1J+DVJ*J2
C
C IF THE OUTPUT PANEL IS FULL OR IF V2 REACHED,
C WRITE OUT THE PANEL
C
IF (J2.GE.2400.OR.VJ.GE.V2) THEN
NNJ = J2
V2J = V1J+DVJ*(J2-1)
CALL OTPANL (R,JFILE,NPTS)
V1J = V2J+DVJ
J2 = 0
ENDIF
C
C IF REACHED V2, THEN FINISH
C
IF (VJ.GE.V2) GO TO 100
C
C IF THE INPUT FILE REACHED AN EOF, THEN ZERO FILL TO END
C
IF (IEOFSC.LE.0) GO TO 80
C
C IF THE DATA FROM CURRENT INPUT PANEL IS EXHAUSTED, GET MORE
C
IF (I.GE.NNI-2) THEN
C
C SHIFT THE LAST IBOUND POINTS DOWN TO T(1-4)
C
DO 70 II = 1, IBOUND
T(II) = T(II+NNI-IBOUND)
70 CONTINUE
C
C GET THE NEXT PANEL OF DATA AND RESET I
C
CALL RDPANL (S,JTREM,IFILE,ISCAN,JEMIT,ICNVRT)
IF (IEOFSC.LE.0) THEN
C
C IF EOF ON INPUT FILE, THEN EXTRAPOLATE OUT TWO MORE
C POINTS BEYOND I=NNI SO THAT 4 POINT INTERPOLATION CAN
C BE PERFORMED UP TO VJ=V2I. (ACTUALLY, ONLY T(NNI+1) NEED
C BE EXTRAPOLATED, T(NNI+2) NEED ONLY BE DEFINED.)
C EXTEND THE INPUT PANEL BY ONE POINT AND LOOP AROUND THE
C INTERPOLATION ONE LAST TIME
C
T(NNI+1) = 2.0*T(NNI)-T(NNI-1)
T(NNI+2) = 0.0
V2I = V2I+DVI
ENDIF
ENDIF
C
C LOOP BACK
C
GO TO 40
C
80 CONTINUE
J1 = J2+1
J2 = MIN(INT((V2-V1J)/DVJ+1.0001),2400)
C
DO 90 J = J1, J2
R(J) = 0.0
90 CONTINUE
VJ = V1J+DVJ*J2
C
C IF THE OUTPUT PANEL IS FULL OR IF V2 REACHED,
C WRITE OUT THE PANEL
C
IF (J2.GE.2400.OR.VJ.GE.V2) THEN
NNJ = J2
V2J = V1J+DVJ*(J2-1)
CALL OTPANL (R,JFILE,NPTS)
V1J = V2J+DVJ
J2 = 0
ENDIF
C
C IF REACHED V2, THEN FINISH
C
IF (VJ.LT.V2) GO TO 80
C
100 CONTINUE
C
RSTAT(1) = RSUM*DVJ
RSTAT(2) = RMIN
RSTAT(3) = RMAX
C
CALL CPUTIM (TIME2)
TIMCNV = TIMCNV+TIME2-TIME1
C
RETURN
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE FLTRFN (IFILE) 1,9
C
C NFLTPT sets the maximum number of points in the incoming filter
C
PARAMETER (NFLTPT = 3001)
C
IMPLICIT REAL*8 (V)
C
COMMON S(4650),R1(5750)
C
character*8 XID, HMOLID, YID
real*8 SECANT, XALTZ
logical op
C
COMMON /HVERSN/ HVRLBL,HVRCNT,HVRFFT,HVRATM,HVRLOW,HVRNCG,
* HVROPR,HVRPST,HVRPLT,HVRTST,HVRUTL,HVRXMR
COMMON /SCNHDR/ XID(10),SECANT,PAVE,TAVE,HMOLID(60),XALTZ(4),
* WK(60),PZL,PZU,TZL,TZU,WBROAD,DVC,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
COMMON /RSCAN/ V1I,V2I,DVI,NNI
COMMON /COMFLT/ V1F,V2F,DVF,NPTS,NPTF,JEMIT,IUNIT,IFILST,NIFILS,
* HEDDR(9),XF(NFLTPT),SUMFLT
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /FLFORM/ CFORM
DIMENSION FILHDR(2)
CHARACTER*80 CVAR
CHARACTER*11 CFORM
CHARACTER*8 HVRLBL,HVRCNT,HVRFFT,HVRATM,HVRLOW,HVRNCG,HVROPR,
* HVRPLT,HVRPST,HVRTST,HVRUTL,HVRXMR
character ctape*4,fltinf*7,fltout*7
integer*4 itest,itest2
C
EQUIVALENCE (FILHDR(1),XID(1)) , (FSCDID(5),IEMIT),
* (FSCDID(6),ISCAN) , (FSCDID(7),IPLOT),
* (FSCDID(8),IPATHL) , (FSCDID(9),JRAD),
* (FSCDID(12),SCNID) , (FSCDID(13),HWHM),
* (FSCDID(16),LAYR1)
DATA FLTINF / ' '/,FLTOUT / ' ' /,
* CTAPE / 'TAPE'/
data itest / 0 /, itest2 / 0 /
save itest
save itest2
C
C
C ASSIGN SCCS VERSION NUMBER TO MODULE
C
HVRPST = '5.11'
C
NLIMF = 2401
NREN = 0
IPRT = 1
NSHIFT = 0
10 READ (IRD,900) V1F,DVF,NPTF,JEMIT,IUNIT,IFILST,NIFILS,junit,HEDDR
C
C Test to ensure NPTF is less than NFLTPT, the maximum number
C of filter points allowed
C
IF (NPTF.GT.NFLTPT) THEN
WRITE(IPR,*) 'FLTRFN: NPTS > NFLTPT limit', NFLTPT
STOP 'FLTRFN: NPTS > NFLTPT limit'
ENDIF
C
JABS = 0
IF (JEMIT.GE.0) GO TO 20
JEMIT = 0
JABS = 1
20 IEOFT = 1
IF (IUNIT.LE.0) IUNIT = IFILE
IFILE = IUNIT
IF (NIFILS.LE.0) NIFILS = 99
C
IF (V1F.LT.0) RETURN
c
c DVF < 0 option flags V1F value to be the center frequency
c Check that there NPTF is odd (to ensure a center frequency),
c save center frequency value, and reset V1F to endpoint value.
if (DVF.lt.0.) then
dvf = abs(dvf)
if (mod((nptf-1),2).ne.0) then
write(*,*) 'Use of V1F as center frequency requires odd
* number of points'
write(ipr,*) 'Use of V1F as center frequency requires odd
* number of points, stopping in FLTFRN'
stop 'FLTRFN'
endif
V1F_center = V1F
nptf_half = (abs(nptf)-1)/2
V1F = V1F_center - DVF*float(nptf_half)
write(ipr,*) ' ``````````````````````````````'
write(ipr,*) ' Use of V1F as center frequency:'
write(ipr,*) ' V center = ',V1F_center
write(ipr,*) ' V1F = ',V1F
write(ipr,*) " ''''''''''''''''''''''''''''''"
endif
C
WRITE (IPR,905)
REWIND IFILE
inquire(ifile,opened=op)
IF (.NOT.OP) THEN
WRITE (FLTINF,970) CTAPE,IFILE
OPEN (IFILE,FILE=FLTINF,STATUS='UNKNOWN',FORM=CFORM)
REWIND IFILE
ENDIF
JFILE = junit
if (jfile.ne.0) then
inquire(jfile,opened=op)
if (itest.eq.0) then
if (op) close(jfile)
itest = 1
fltout = 'FLT_OUT'
OPEN (JFILE,FILE=FLTOUT,STATUS='UNKNOWN')
rewind jfile
endif
endif
IF (IFILST.GT.1) CALL SKIPFL (IFILST-1,IFILE,IEOF)
IEOFSC = 0
ISTOP = 0
C
IF (NPTF.LE.0) GO TO 30
NPTS = NPTF
30 V2F = V1F+DVF*FLOAT(NPTS-1)
WRITE (IPR,910) V1F,V2F,DVF,NPTF,JEMIT,JABS,IUNIT,IFILST,NIFILS,
* HEDDR
V1 = V1F
V2 = V2F
DV = DVF
IF (NPTF.LE.0) GO TO 40
READ (IRD,915) CVAR
READ (IRD,CVAR) (XF(I),I=1,NPTS)
WRITE (IPR,CVAR) (XF(I),I=1,NPTS)
C
C MAKE ADJUSTMENT FOR END POINT CORRECTIONS
C
XF(1) = 0.5*XF(1)
XF(NPTS) = 0.5*XF(NPTS)
40 SUMFLT = 0.0
DO 50 I = 1, NPTS
SUMFLT = SUMFLT+XF(I)
50 CONTINUE
SUMFLT = SUMFLT*DVF
C
60 RFILTR = 0.0
VFT = V1
VBOT = V1
VTOP = V2
TIMRDF = 0.0
TIMCNV = 0.0
CALL BUFIN (IFILE,IEOF,FILHDR(1),NFHDRF)
ISCHDR = ISCAN
IF (ISCAN.LE.0.OR.SCNID.EQ.-99.) ISCAN = 0
IF (ISCHDR.GE.1000.AND.ISCAN.EQ.0) ISCAN = ISCHDR
IF (MOD(ISCAN,1000).EQ.0) GO TO 70
JEMSCN = SCNID/100.
IF (JEMIT.EQ.JEMSCN) GO TO 70
WRITE (*,920)
WRITE (IPR,920)
CALL SKIPFL (1,IFILE,IEOF)
IF (IEOF.EQ.0) GO TO 10
GO TO 60
70 CONTINUE
IF (IEOF.LT.1) GO TO 10
C
C JEMIT=-1 FILTER PASSED OVER ABSORPTION
C JEMIT=0 FILTER PASSED OVER TRANSMISSION
C JEMIT=1 FILTER PASSED OVER EMISSION
C
JTREM = -1
IF ((IEMIT.EQ.0).AND.(JEMIT.EQ.0)) JTREM = 0
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.0)) JTREM = 2
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.1)) JTREM = 1
ISCANT = MOD(ISCAN,1000)
IF ((ISCANT.GE.1).AND.(JEMIT.EQ.0)) JTREM = 2
IF (JTREM.LT.0) GO TO 10
WRITE (IPR,925) XID,(YID(M),M=1,2)
WRITE (IPR,930) LAYR1,LAYER
WRITE (IPR,935) SECANT,PAVE,TAVE,DVC,V1C,V2C
WRITE (IPR,940) WBROAD,(HMOLID(M),WK(M),M=1,NMOL)
WRITE (IPR,945) V1F,V2F,DVF,NPTF,IEMIT,JEMIT,JABS,IUNIT,IFILST,
* NIFILS,HEDDR
if ((jfile.ne.0).and.(itest2.eq.0)) then
WRITE (jfile,925) XID,(YID(M),M=1,2)
WRITE (jfile,935) SECANT,PAVE,TAVE,DVC,V1C,V2C
WRITE (jfile,940) WBROAD,(HMOLID(M),WK(M),M=1,NMOL)
WRITE(jfile,980)
itest2 = 1
endif
IDATA = -1
80 CALL CPUTIM (TIMEO)
CALL RDSCAN (S,JTREM,IFILE,ISCAN,IPRT)
CALL CPUTIM (TIME)
TIMRDF = TIMRDF+TIME-TIMEO
IF (IEOFSC.NE.1) GO TO 90
CALL CNVFLT (S,RFILTR,XF)
IF (IDATA.EQ.1) GO TO 90
GO TO 80
90 CALL CPUTIM (TIME)
WRITE (IPR,950) TIME,TIMRDF,TIMCNV
IF (JEMIT.EQ.1) GO TO 100
TRNSM = RFILTR
RFILTR = RFILTR*DVC/SUMFLT
IF (JABS.EQ.0) WRITE (IPR,955) RFILTR,SUMFLT,TRNSM
IF (JABS.EQ.1) WRITE (IPR,960) RFILTR,SUMFLT,TRNSM
if (jfile.ne.0) then
write(JFILE,975) RFILTR
endif
GO TO 110
100 RFILTR = RFILTR*DVC
WRITE (IPR,965) RFILTR,SUMFLT
if (jfile.ne.0) then
write(JFILE,975) RFILTR
endif
110 IF (IEOFSC.EQ.1) CALL SKIPFL (1,IFILE,IEOFSC)
IEOFT = IEOFT+1
IF (IEOFT.GT.NIFILS) GO TO 10
IF (IEOFSC.LT.0) GO TO 60
GO TO 10
C
900 FORMAT (2F10.4,6I5,8A4,A3)
905 FORMAT ('1',/' *** FILTER ***',8(' ********** '))
910 FORMAT ('0 V1F=',F10.4,' V2F=',F10.4,',DVF=',F10.4,',NPTF =',
* I5,/,'0',10X,', JEMIT= ',I2,', JABS= ',I2,
* ', INPUT FILE= ',I3,' ,IFILST =',I5,' ,NIFILS =',I5,2X,
* 8A4,A3)
915 FORMAT (A80)
920 FORMAT ('0 RESULT FROM SCANNING FUNCTION INCONSISTENT WITH ',
* 'FILTER REQUEST')
925 FORMAT ('0',//,8(' ------- '),/,'0',10A8,2X,2(1X,A8,1X))
930 FORMAT (//,' INITIAL LAYER = ',I5,' FINAL LAYER =',I5)
935 FORMAT ('0 SECANT =',F15.5,/'0 PRESS(MB) =',F12.5/'0 TEMP(K) =',
* F11.2,/'0 DV(CM-1) = ',F12.8,/'0 V1(CM-1) = ',F12.6,/
* '0 V2(CM-1) = ',F12.6)
940 FORMAT ('0 COLUMN DENSITY (MOLECULES/CM**2)'//5X,'WBROAD = ',
* 1PE10.3,/(5X,A6,' = ',1PE10.3))
945 FORMAT ('0 V1F=',F10.4,' V2F=',F10.4,',DVF=',F10.4,',NPTF =',
* I5,/'0 , IEMIT= ',I2,', JEMIT= ',I2,', JABS= ',I2,
* ', INPUT FILE= ',I3,' ,IFILST =',I5,' ,NIFILS =',I5,2X,
* 8A4,A3)
950 FORMAT ('0',5X,'TIME =',F7.3,', READ =',F6.3,', CONV. =',F7.3)
955 FORMAT ('0 INTEGRATED TRANSMISSION = ',1PE14.5,
* ' NORMALIZATION OF THE FILTER = ',E14.5,/
* '0 UNNORMALIZED INTEGRATED TRANSMISSION = ',E14.5)
960 FORMAT ('0 INTEGRATED ABSORPTION = ',1PE14.5,
* ' NORMALIZATION OF THE FILTER = ',E14.5,/
* '0 UNNORMALIZED INTEGRATED ABSORPTION = ',E14.5)
965 FORMAT ('0 INTEGRATED EMISSION = ',1PE14.5,
* ' NORMALIZATION OF THE',' FILTER = ',E14.5)
970 format (a4,i2.2)
975 format (1p,e14.5,0p)
980 format (' Filter output:')
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE FLTRRD (IFILE) 3,1
C
C NFLTPT sets the maximum number of points in the incoming filter
C
PARAMETER (NFLTPT = 3001)
C
IMPLICIT REAL*8 (V)
C
C READ CONTROL CARD FOR FILTER WITH WEIGHTING FUNCTIONS
C
COMMON S(4650),R1(5750)
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,DVC,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
COMMON /RSCAN/ V1I,V2I,DVI,NNI
COMMON /COMFLT/ V1F,V2F,DVF,NPTS,NPTF,JEMIT,IUNIT,IFILST,NIFILS,
* HEDDR(9),XF(NFLTPT),SUMFLT
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /FLFORM/ CFORM
DIMENSION FILHDR(2)
C
CHARACTER*80 CVAR
CHARACTER CFORM*11,TAPE13*6,CTAPE*4
LOGICAL OP
C
EQUIVALENCE (FILHDR(1),XID(1)) , (FSCDID(5),IEMIT),
* (FSCDID(6),ISCAN) , (FSCDID(7),IPLOT),
* (FSCDID(8),IPATHL) , (FSCDID(9),JRAD),
* (FSCDID(12),SCNID) , (FSCDID(13),HWHM),
* (FSCDID(16),LAYR1)
C
DATA TAPE13 / ' '/,CTAPE / 'TAPE'/
C
NLIMF = 2401
NSHIFT = 0
READ (IRD,900) V1F,DVF,NPTF,JEMIT,NNFILE,HEDDR
C
JABS = 0
IEOFT = 1
IUNIT = IFILE
IFILE = IUNIT
IFILST = 1
NIFILS = 1
IF (NNFILE.NE.NFILE.AND.NNFILE.GT.0) THEN
INQUIRE (UNIT=NFILE,OPENED=OP)
IF (OP) CLOSE (NFILE)
NFILE = NNFILE
INQUIRE (UNIT=NFILE,OPENED=OP)
IF (.NOT.OP) THEN
WRITE (TAPE13,905) CTAPE,NFILE
OPEN (NFILE,FILE=TAPE13,STATUS='UNKNOWN',FORM=CFORM)
REWIND NFILE
ENDIF
ENDIF
C
IF (V1F.LT.0) RETURN
WRITE (IPR,910)
REWIND IFILE
IF (IFILST.GT.1) CALL SKIPFL (IFILST-1,IFILE,IEOF)
IEOFSC = 0
ISTOP = 0
C
IF (NPTF.LE.0) GO TO 10
NPTS = NPTF
10 V2F = V1F+DVF*FLOAT(NPTS-1)
WRITE (IPR,915) V1F,V2F,DVF,NPTF,JEMIT,JABS,IUNIT,IFILST,NIFILS,
* NFILE,HEDDR
V1 = V1F
V2 = V2F
DV = DVF
IF (NPTF.LE.0) GO TO 20
READ (IRD,920) CVAR
READ (IRD,CVAR) (XF(I),I=1,NPTS)
WRITE (IPR,CVAR) (XF(I),I=1,NPTS)
C
C MAKE ADJUSTMENT FOR END POINT CORRECTIONS
C
XF(1) = 0.5*XF(1)
XF(NPTS) = 0.5*XF(NPTS)
20 SUMFLT = 0.0
DO 30 I = 1, NPTS
SUMFLT = SUMFLT+XF(I)
30 CONTINUE
SUMFLT = SUMFLT*DVF
C
RETURN
C
900 FORMAT (2F10.4,I5,I5,I5,10X,8A4,A3)
905 FORMAT (A4,I2.2)
910 FORMAT ('1',/' *** FILTER ***',8(' ********** '))
915 FORMAT ('0 V1F=',F10.4,' V2F=',F10.4,',DVF=',F10.4,
* ',NPTF =',I5,/,'0',10X,', JEMIT= ',I2,', JABS= ',
* I2,', INPUT FILE= ',I3,' ,IFILST =',I5,' ,NIFILS =',
* I5,', OUTPUT FILE= ',I3,2X,8A4,A3)
920 FORMAT (A80)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE FLTMRG (IFILE,JFILE) 4,11
C
C NFLTPT sets the maximum number of points in the incoming filter
C
PARAMETER (NFLTPT = 3001)
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE FLTMRG CALCULATES AND OUTPUTS THE RESULTS
C OF THE FILTER TO FILE JFILE
C
COMMON S(4650),R1(5750)
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,DVC,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 /MANE/ P0,TEMP0,NLAYER,DVXM,H2OSLF,WTOT,ALBAR,ADBAR,AVBAR,
* AVFIX,LAYMA,SECNT0,SAMPLE,DVSET,ALFAL0,AVMASS,
* DPTMIN,DPTFAC,ALTAV,AVTRAT,TDIFF1,TDIFF2,ALTD1,
* ALTD2,ANGLE,IANT,LTGNT,LH1,LH2,IPFLAG,PLAY,TLAY,
* EXTID(10)
COMMON /CONTRL/ IEOFSC,IPANEL,ISTOP,IDATA,JVAR,JABS
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL
COMMON /RSCAN/ V1I,V2I,DVI,NNI
COMMON /COMFLT/ V1F,V2F,DVF,NPTS,NPTF,JEMIT,IUNIT,IFILST,NIFILS,
* HEDDR(9),XF(NFLTPT),SUMFLT
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /SPANEL/ V1P,V2P,DV,NLIM
DIMENSION FILHDR(2),PNLHDR(2),RF(4)
EQUIVALENCE (FILHDR(1),XID(1)) , (FSCDID(5),IEMIT),
* (FSCDID(6),ISCNHD) , (FSCDID(7),IPLOT),
* (FSCDID(8),IPATHL) , (FSCDID(9),JRAD),
* (FSCDID(12),SCNID) , (FSCDID(13),HWHM),
* (FSCDID(16),LAYR1) , (PNLHDR(1),V1P)
C
NLIMF = 2401
NREN = 0
IPRT = 1
NSHIFT = 0
IUNIT = IFILE
REWIND IFILE
C
10 RFILTR = 0.0
VFT = V1
VBOT = V1
VTOP = V2
TIMRDF = 0.0
TIMCNV = 0.0
C
CALL BUFIN (IFILE,IEOF,FILHDR(1),NFHDRF)
C
ISCAN = ISCNHD
IF (ISCAN.LE.0.OR.SCNID.EQ.-99.) ISCAN = 0
IF (ISCNHD.GE.1000.AND.ISCAN.EQ.0) ISCAN = ISCNHD
ISCNHD = ISCAN+100
IF (MOD(ISCAN,1000).EQ.0) GO TO 20
JEMSCN = SCNID/100.
IF (JEMIT.EQ.JEMSCN) GO TO 20
WRITE (*,900)
WRITE (IPR,900)
CALL SKIPFL (1,IFILE,IEOF)
C
IF (IEOF.EQ.0) RETURN
C
GO TO 10
20 CONTINUE
C
IF (IEOF.LT.1) RETURN
C
C JEMIT=-1 FILTER PASSED OVER ABSORPTION
C JEMIT=0 FILTER PASSED OVER TRANSMISSION
C JEMIT=1 FILTER PASSED OVER EMISSION
C
JTREM = -1
IF ((IEMIT.EQ.0).AND.(JEMIT.EQ.0)) JTREM = 0
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.0)) JTREM = 2
IF ((IEMIT.EQ.1).AND.(JEMIT.EQ.1)) JTREM = 1
ISCANT = MOD(ISCAN,1000)
IF ((ISCANT.GE.1).AND.(JEMIT.EQ.0)) JTREM = 2
C
IF (JTREM.LT.0) RETURN
C
WRITE (IPR,905) XID,(YID(M),M=1,2)
WRITE (IPR,910) LAYR1,LAYER
WRITE (IPR,915) SECANT,PAVE,TAVE,DVC,V1C,V2C
WRITE (IPR,920) WBROAD,(HMOLID(M),WK(M),M=1,NMOL)
WRITE (IPR,925) V1F,V2F,DVF,NPTF,IEMIT,JEMIT,JABS,IUNIT,IFILST,
* NIFILS,HEDDR
C
XSCID = 100*JEMIT
SCNID = XSCID+0.01
C
CALL BUFOUT (JFILE,FILHDR(1),NFHDRF)
IDATA = -1
30 CALL CPUTIM (TIMEO)
CALL RDSCAN (S,JTREM,IFILE,ISCAN,IPRT)
CALL CPUTIM (TIME)
TIMRDF = TIMRDF+TIME-TIMEO
IF (IEOFSC.NE.1) GO TO 40
CALL CNVFLT (S,RFILTR,XF)
IF (IDATA.EQ.1) GO TO 40
GO TO 30
C
40 CALL CPUTIM (TIME)
WRITE (IPR,930) TIME,TIMRDF,TIMCNV
IF (JEMIT.EQ.1) GO TO 50
TRNSM = RFILTR
RFILTR = RFILTR*DVC/SUMFLT
RF(1) = RFILTR
RF(2) = SUMFLT
RF(3) = TRNSM
RF(4) = PLAY
IF (JABS.EQ.0) WRITE (IPR,935) RFILTR,SUMFLT,TRNSM
IF (JABS.EQ.1) WRITE (IPR,940) RFILTR,SUMFLT,TRNSM
C
C V1P IS FIRST FREQ OF PANEL
C V2P IS LAST FREQ OF PANEL
C
V1P = V1F
V2P = V2F
DVP = DVF
NLIM = 4
CALL BUFOUT (JFILE,PNLHDR(1),NPHDRF)
CALL BUFOUT (JFILE,RF(1),NLIM)
GO TO 60
C
50 RFILTR = RFILTR*DVC
WRITE (IPR,945) RFILTR,SUMFLT
C
60 IF (IEOFSC.EQ.1) CALL SKIPFL (1,IFILE,IEOFSC)
IEOFT = IEOFT+1
IF (IEOFT.GT.NIFILS) RETURN
IF (IEOFSC.LT.0) GO TO 10
C
RETURN
C
900 FORMAT ('0 RESULT FROM SCANNING FUNCTION INCONSISTENT WITH ',
* 'FILTER REQUEST')
905 FORMAT ('0',//,8(' ------- '),/,'0',10A8,2X,2(1X,A8,1X))
910 FORMAT (//,' INITIAL LAYER = ',I5,' FINAL LAYER =',I5)
915 FORMAT ('0 SECANT =',F15.5,/'0 PRESS(MB) =',F12.5/'0 TEMP(K) =',
* F11.2,/'0 DV(CM-1) = ',F12.8,/'0 V1(CM-1) = ',F12.6,/
* '0 V2(CM-1) = ',F12.6)
920 FORMAT ('0 COLUMN DENSITY (MOLECULES/CM**2)'//5X,'WBROAD = ',
* 1PE10.3,/(5X,A6,' = ',1PE10.3))
925 FORMAT ('0 V1F=',F10.4,' V2F=',F10.4,',DVF=',F10.4,',NPTF =',
* I5,/,'0 , IEMIT= ',I2,', JEMIT= ',I2,', JABS= ',I2,
* ', INPUT FILE= ',I3,' ,IFILST =',I5,' ,NIFILS =',I5,2X,
* 8A4,A3)
930 FORMAT ('0',5X,'TIME =',F7.3,', READ =',F6.3,', CONV. =',F7.3)
935 FORMAT ('0 INTEGRATED TRANSMISSION = ',1PE14.5,
* ' NORMALIZATION OF THE FILTER = ',E14.5,/
* '0 UNNORMALIZED INTEGRATED TRANSMISSION = ',E14.5)
940 FORMAT ('0 INTEGRATED ABSORPTION = ',1PE14.5,
* ' NORMALIZATION OF THE FILTER = ',E14.5,/
* '0 UNNORMALIZED INTEGRATED ABSORPTION = ',E14.5)
945 FORMAT ('0 INTEGRATED EMISSION = ',1PE14.5,
* ' NORMALIZATION OF THE FILTER = ',E14.5)
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE CNVFLT (S,RFILTR,XF) 2,2
C
C NFLTPT sets the maximum number of points in the incoming filter
C
PARAMETER (NFLTPT = 3001)
C
IMPLICIT REAL*8 (V)
C
COMMON /CONTRL/ IEOFSC,IPANEL,ISTOP,IDATA,JVAR,JABS
COMMON /RSCAN/ V1I,V2I,DVI,NNI
COMMON /COMFLT/ V1F,V2F,DVF,NPTS,NPTF,JEMIT,IUNIT,IFILST,NIFILS,
* HEDDR(9),XFS(NFLTPT),SUMFLT
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
C
DIMENSION XF(*),S(*)
C
CALL CPUTIM (TIMEO)
IMIN = (V1F-V1I)/DVI+1.0001
c IMIN = (V1F-V1I)/DVI+1.5
IMIN = MAX(IMIN,ILO)
IMAX = (V2F+V1F-V1I)/DVI+1.0001
c IMAX = (V2F+V1F-V1I)/DVI+1.5
IMAX = MIN(IMAX,IHI)
XIF0 = (V1I-V1F)/DVF+1.0001
c XIF0 = (V1I-V1F)/DVF+1.5
XDVIF = DVI/DVF
DO 10 I = IMIN, IMAX
IFL = XIF0+XDVIF*FLOAT(I)
c IFL = XIF0+XDVIF*FLOAT(I-1)
c
c Linearly interpolate filter function XF to avoid
c discontinuities in output spectrum
c
v1s = v1i+(i-1)*dvi
v2s = v1i+i*dvi
vxf1 = v1f + (ifl-1)*dvf
vxf2 = v1f + (ifl)*dvf
p = (vxf2-v2s)/(vxf2-vxf1)
RFILTR = RFILTR+S(I)*(p*XF(IFL)+(1.-p)*xf(IFL+1))
c write(88,*) v1s,xf(ifl),(p*XF(IFL)+(1.-p)*xf(IFL+1))
c write(89,*) i,v1i,dvi,v2s,xif0
c write(89,*) ifl,v1f,dvf,vxf1,vxf2,p
10 CONTINUE
IF (IMAX.LT.IHI) VFT = VFT+((FLOAT(IHI)-FLOAT(ILO))+1.0)*DVI
CALL CPUTIM (TIME)
TIMCNV = TIMCNV+TIME-TIMEO
C
RETURN
C
END
C
C --------------------------------------------------------------
C
SUBROUTINE FLTPRT (IFILE) 1,5
C
C NFLTPT sets the maximum number of points in the incoming filter
C
PARAMETER (NFLTPT = 3001)
C
IMPLICIT REAL*8 (V)
C
C SUBROUTINE FLTPRT READS FROM IFILE AND FORMATS OUT THE RESULTS
C OF THE FILTERED WEIGHTING FUNCTION TO IPR
C
COMMON S(4650),R1(5750)
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,DVC,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 /MANE/ P0,TEMP0,NLAYER,DVXM,H2OSLF,WTOT,ALBAR,ADBAR,AVBAR,
* AVFIX,LAYMA,SECNT0,SAMPLE,DVSET,ALFAL0,AVMASS,
* DPTMIN,DPTFAC,ALTAV,AVTRAT,TDIFF1,TDIFF2,ALTD1,
* ALTD2,ANGLE,IANT,LTGNT,LH1,LH2,IPFLAG,PLAY,TLAY,
* EXTID(10)
COMMON /CONTRL/ IEOFSC,IPANEL,ISTOP,IDATA,JVAR,JABS
COMMON /XTIME/ TIME,TIMRDF,TIMCNV,TIMPNL
COMMON /RSCAN/ V1I,V2I,DVI,NNI
COMMON /COMFLT/ V1F,V2F,DVF,NPTS,NPTF,JEMIT,IUNIT,IFILST,NIFILS,
* HEDDR(9),XF(NFLTPT),SUMFLT
COMMON /IFIL/ IRD,IPR,IPU,NOPR,NFHDRF,NPHDRF,NFHDRL,NPHDRL,
* NLNGTH,KFILE,KPANEL,LINFIL,NFILE,IAFIL,IEXFIL,
* NLTEFL,LNFIL4,LNGTH4
COMMON /SPANEL/ V1P,V2P,DV,NLIM
DIMENSION FILHDR(2),PNLHDR(2),RF(4)
C
EQUIVALENCE (FILHDR(1),XID(1)) , (FSCDID(5),IEMIT),
* (FSCDID(6),ISCAN) , (FSCDID(7),IPLOT),
* (FSCDID(8),IPATHL) , (FSCDID(9),JRAD),
* (FSCDID(12),SCNID) , (FSCDID(13),HWHM),
* (FSCDID(16),LAYR1) , (PNLHDR(1),V1P)
C
NLIMF = 2401
NSHIFT = 0
IUNIT = IFILE
REWIND IFILE
C
WRITE (IPR,900)
OLDTRN = 1.0
TIMRDF = 0.0
CALL CPUTIM (TIMEO)
10 CONTINUE
CALL BUFIN (IFILE,IEOF,FILHDR(1),NFHDRF)
IF (IEOF.EQ.-99) GO TO 10
IF (IEOF.EQ.0) GO TO 20
C
CALL BUFIN (IFILE,IEOF,PNLHDR(1),NPHDRF)
CALL BUFIN (IFILE,IEOF,RF(1),NLIM)
C
RFILTR = RF(1)
SUMFLT = RF(2)
TRNSM = RF(3)
PLAY = RF(4)
DTAU = OLDTRN-RFILTR
OLDTRN = RFILTR
WRITE (IPR,905) LAYER,PLAY,DTAU,RFILTR,TRNSM
C
IF (IEOF.EQ.1) GO TO 10
20 WRITE (IPR,910) SUMFLT
CALL CPUTIM (TIME)
TIMRDF = TIMRDF+TIME-TIMEO
WRITE (IPR,915) TIME,TIMRDF
C
RETURN
C
900 FORMAT ('1',15X,
* 'FORMATTED RESULTS OF FILTERED WEIGHTING FUNCTIONS',
* 2(/),10X,'LAYER',5X,'PRESSURE',4X,'TRANSMISSION',6X,
* 'INTEGRATED',6X,'UNNORMALIZED',/,10X,' # ',5X,
* ' (MB) ',5X,'(N-1) - (N)',5X,'TRANSMISSION',5X,
* ' INT TRANS ',/)
905 FORMAT (10X,I3,5X,F8.3,5X,1PE13.6,4X,1PE13.6,4X,1PE13.6)
910 FORMAT ('0',5X,'NORMALIZATION OF THE FILTER =',1PE13.6)
915 FORMAT ('0',5X,'TIME =',F7.3,', IN FLTPRT =',F7.3)
C
END