!MNH_LIC Copyright 1989-2020 CNRS, Meteo-France and Universite Paul Sabatier
!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!MNH_LIC for details. version 1.
!-----------------------------------------------------------------
C**FILE: svode.f
C**AUTHOR: Karsten Suhre
C**DATE: Fri Nov 10 09:17:45 GMT 1995
C**PURPOSE: solver SVODE
C**ORIGINAL: original from Peter N. Brown, Alan C. Hindmarsh, George D. Byrne
C**MODIFIED: K. Suhre: added Fortran90 Interface and some slight changes
C indicated by "*KS:"
C**MODIFIED: 01/12/03 (Gazen) change Chemical scheme interface
C**MODIFIED: 25/03/2008 (M.Leriche & J.P.Pinty):add "MIN(100.,...)" threshold
C** in exponential calculation --> problem with "ifort -O2" compiler
C**MODIFIED: 22/02/2011 (J.Escobar) remove erroneous 'CALL ABORT'
C**MODIFIED: 19/06/2014 (J.Escobar & M.Leriche) write(kout,...) to OUTPUT_LISTING file
C & correct IN_LUN = 11 => IN_LUN = 78 to avoid fort.11 creation
C**MODIFIED: 10/01/2019 (P.Wautelet) use newunit argument to open files
C + bug corrections: some files were not closed
C**MODIFIED: 10/01/2019 (P.Wautelet) replace double precision declarations by
C real(kind(0.0d0)) (to allow compilation by NAG compiler)
C**MODIFIED: 08/02/2019 (P.Wautelet) bug fixes: missing argument
C + wrong use of an non initialized value
C P. Wautelet 17/08/2020: small correction in call to LEPOLY
C!
C!
C!
C!
C! WARNING : MAJOR CHANGE FOR COMPATIBILITY WITH MESO-NH
C! TPK is passed as argument
C! CALL F(...,TPK)
C! CALL JAC(...,TPK)
C! Look for *UPG*MNH
C!
C!
C!
C!
C!
C==============================================================================
C BEGIN ORIGINAL FORTRAN77 CODE
C==============================================================================
CDECK SVODE
SUBROUTINE SVODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK,
1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF,
2 RPAR, IPAR, KMI, KINDEX)
C
C
EXTERNAL F, JAC
!
C
C*UPG*MNH
C
INTEGER KMI, KINDEX
C
C*UPG*MNH
C
REAL Y, T, TOUT, RTOL, ATOL, RWORK, RPAR
INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW,
1 MF, IPAR
DIMENSION Y(*), RTOL(*), ATOL(*), RWORK(LRW), IWORK(LIW),
1 RPAR(*), IPAR(*)
C-----------------------------------------------------------------------
C SVODE.. Variable-coefficient Ordinary Differential Equation solver,
C with fixed-leading coefficient implementation.
C This version is in single precision.
C
C SVODE solves the initial value problem for stiff or nonstiff
C systems of first order ODEs,
C dy/dt = f(t,y) , or, in component form,
C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ).
C SVODE is a package based on the EPISODE and EPISODEB packages, and
C on the ODEPACK user interface standard, with minor modifications.
C-----------------------------------------------------------------------
C Revision History (YYMMDD)
C 890615 Date Written
C 890922 Added interrupt/restart ability, minor changes throughout.
C 910228 Minor revisions in line format, prologue, etc.
C 920227 Modifications by D. Pang:
C (1) Applied subgennam to get generic intrinsic names.
C (2) Changed intrinsic names to generic in comments.
C (3) Added *DECK lines before each routine.
C 920721 Names of routines and labeled Common blocks changed, so as
C to be unique in combined single/double precision code (ACH).
C 920722 Minor revisions to prologue (ACH).
C-----------------------------------------------------------------------
C References..
C
C 1. P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, "VODE: A Variable
C Coefficient ODE Solver," SIAM J. Sci. Stat. Comput., 10 (1989),
C pp. 1038-1051. Also, LLNL Report UCRL-98412, June 1988.
C 2. G. D. Byrne and A. C. Hindmarsh, "A Polyalgorithm for the
C Numerical Solution of Ordinary Differential Equations,"
C ACM Trans. Math. Software, 1 (1975), pp. 71-96.
C 3. A. C. Hindmarsh and G. D. Byrne, "EPISODE: An Effective Package
C for the Integration of Systems of Ordinary Differential
C Equations," LLNL Report UCID-30112, Rev. 1, April 1977.
C 4. G. D. Byrne and A. C. Hindmarsh, "EPISODEB: An Experimental
C Package for the Integration of Systems of Ordinary Differential
C Equations with Banded Jacobians," LLNL Report UCID-30132, April
C 1976.
C 5. A. C. Hindmarsh, "ODEPACK, a Systematized Collection of ODE
C Solvers," in Scientific Computing, R. S. Stepleman et al., eds.,
C North-Holland, Amsterdam, 1983, pp. 55-64.
C 6. K. R. Jackson and R. Sacks-Davis, "An Alternative Implementation
C of Variable Step-Size Multistep Formulas for Stiff ODEs," ACM
C Trans. Math. Software, 6 (1980), pp. 295-318.
C-----------------------------------------------------------------------
C Authors..
C
C Peter N. Brown and Alan C. Hindmarsh
C Computing and Mathematics Research Division, L-316
C Lawrence Livermore National Laboratory
C Livermore, CA 94550
C and
C George D. Byrne
C Exxon Research and Engineering Co.
C Clinton Township
C Route 22 East
C Annandale, NJ 08801
C-----------------------------------------------------------------------
C Summary of usage.
C
C Communication between the user and the SVODE package, for normal
C situations, is summarized here. This summary describes only a subset
C of the full set of options available. See the full description for
C details, including optional communication, nonstandard options,
C and instructions for special situations. See also the example
C problem (with program and output) following this summary.
C
C A. First provide a subroutine of the form..
C
C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR)
C REAL T, Y, YDOT, RPAR
C DIMENSION Y(NEQ), YDOT(NEQ)
C
C which supplies the vector function f by loading YDOT(i) with f(i).
C
C B. Next determine (or guess) whether or not the problem is stiff.
C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue
C whose real part is negative and large in magnitude, compared to the
C reciprocal of the t span of interest. If the problem is nonstiff,
C use a method flag MF = 10. If it is stiff, there are four standard
C choices for MF (21, 22, 24, 25), and SVODE requires the Jacobian
C matrix in some form. In these cases (MF .gt. 0), SVODE will use a
C saved copy of the Jacobian matrix. If this is undesirable because of
C storage limitations, set MF to the corresponding negative value
C (-21, -22, -24, -25). (See full description of MF below.)
C The Jacobian matrix is regarded either as full (MF = 21 or 22),
C or banded (MF = 24 or 25). In the banded case, SVODE requires two
C half-bandwidth parameters ML and MU. These are, respectively, the
C widths of the lower and upper parts of the band, excluding the main
C diagonal. Thus the band consists of the locations (i,j) with
C i-ML .le. j .le. i+MU, and the full bandwidth is ML+MU+1.
C
C C. If the problem is stiff, you are encouraged to supply the Jacobian
C directly (MF = 21 or 24), but if this is not feasible, SVODE will
C compute it internally by difference quotients (MF = 22 or 25).
C If you are supplying the Jacobian, provide a subroutine of the form..
C
C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, RPAR, IPAR)
C REAL T, Y, PD, RPAR
C DIMENSION Y(NEQ), PD(NROWPD,NEQ)
C
C which supplies df/dy by loading PD as follows..
C For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j),
C the partial derivative of f(i) with respect to y(j). (Ignore the
C ML and MU arguments in this case.)
C For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with
C df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of
C PD from the top down.
C In either case, only nonzero elements need be loaded.
C
C D. Write a main program which calls subroutine SVODE once for
C each point at which answers are desired. This should also provide
C for possible use of logical unit 6 for output of error messages
C by SVODE. On the first call to SVODE, supply arguments as follows..
C F = Name of subroutine for right-hand side vector f.
C This name must be declared external in calling program.
C NEQ = Number of first order ODE-s.
C Y = Array of initial values, of length NEQ.
C T = The initial value of the independent variable.
C TOUT = First point where output is desired (.ne. T).
C ITOL = 1 or 2 according as ATOL (below) is a scalar or array.
C RTOL = Relative tolerance parameter (scalar).
C ATOL = Absolute tolerance parameter (scalar or array).
C The estimated local error in Y(i) will be controlled so as
C to be roughly less (in magnitude) than
C EWT(i) = RTOL*abs(Y(i)) + ATOL if ITOL = 1, or
C EWT(i) = RTOL*abs(Y(i)) + ATOL(i) if ITOL = 2.
C Thus the local error test passes if, in each component,
C either the absolute error is less than ATOL (or ATOL(i)),
C or the relative error is less than RTOL.
C Use RTOL = 0.0 for pure absolute error control, and
C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error
C control. Caution.. Actual (global) errors may exceed these
C local tolerances, so choose them conservatively.
C ITASK = 1 for normal computation of output values of Y at t = TOUT.
C ISTATE = Integer flag (input and output). Set ISTATE = 1.
C IOPT = 0 to indicate no optional input used.
C RWORK = Real work array of length at least..
C 20 + 16*NEQ for MF = 10,
C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22,
C 22 + 11*NEQ + (3*ML + 2*MU)*NEQ for MF = 24 or 25.
C LRW = Declared length of RWORK (in user's DIMENSION statement).
C IWORK = Integer work array of length at least..
C 30 for MF = 10,
C 30 + NEQ for MF = 21, 22, 24, or 25.
C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower
C and upper half-bandwidths ML,MU.
C LIW = Declared length of IWORK (in user's DIMENSION).
C JAC = Name of subroutine for Jacobian matrix (MF = 21 or 24).
C If used, this name must be declared external in calling
C program. If not used, pass a dummy name.
C MF = Method flag. Standard values are..
C 10 for nonstiff (Adams) method, no Jacobian used.
C 21 for stiff (BDF) method, user-supplied full Jacobian.
C 22 for stiff method, internally generated full Jacobian.
C 24 for stiff method, user-supplied banded Jacobian.
C 25 for stiff method, internally generated banded Jacobian.
C RPAR,IPAR = user-defined real and integer arrays passed to F and JAC.
C Note that the main program must declare arrays Y, RWORK, IWORK,
C and possibly ATOL, RPAR, and IPAR.
C
C E. The output from the first call (or any call) is..
C Y = Array of computed values of y(t) vector.
C T = Corresponding value of independent variable (normally TOUT).
C ISTATE = 2 if SVODE was successful, negative otherwise.
C -1 means excess work done on this call. (Perhaps wrong MF.)
C -2 means excess accuracy requested. (Tolerances too small.)
C -3 means illegal input detected. (See printed message.)
C -4 means repeated error test failures. (Check all input.)
C -5 means repeated convergence failures. (Perhaps bad
C Jacobian supplied or wrong choice of MF or tolerances.)
C -6 means error weight became zero during problem. (Solution
C component i vanished, and ATOL or ATOL(i) = 0.)
C
C F. To continue the integration after a successful return, simply
C reset TOUT and call SVODE again. No other parameters need be reset.
C
C-----------------------------------------------------------------------
C EXAMPLE PROBLEM
C
C The following is a simple example problem, with the coding
C needed for its solution by SVODE. The problem is from chemical
C kinetics, and consists of the following three rate equations..
C dy1/dt = -.04*y1 + 1.e4*y2*y3
C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2
C dy3/dt = 3.e7*y2**2
C on the interval from t = 0.0 to t = 4.e10, with initial conditions
C y1 = 1.0, y2 = y3 = 0. The problem is stiff.
C
C The following coding solves this problem with SVODE, using MF = 21
C and printing results at t = .4, 4., ..., 4.e10. It uses
C ITOL = 2 and ATOL much smaller for y2 than y1 or y3 because
C y2 has much smaller values.
C At the end of the run, statistical quantities of interest are
C printed. (See optional output in the full description below.)
C To generate Fortran source code, replace C in column 1 with a blank
C in the coding below.
C
C EXTERNAL FEX, JEX
C REAL ATOL, RPAR, RTOL, RWORK, T, TOUT, Y
C DIMENSION Y(3), ATOL(3), RWORK(67), IWORK(33)
C NEQ = 3
C Y(1) = 1.0E0
C Y(2) = 0.0E0
C Y(3) = 0.0E0
C T = 0.0E0
C TOUT = 0.4E0
C ITOL = 2
C RTOL = 1.E-4
C ATOL(1) = 1.E-8
C ATOL(2) = 1.E-14
C ATOL(3) = 1.E-6
C ITASK = 1
C ISTATE = 1
C IOPT = 0
C LRW = 67
C LIW = 33
C MF = 21
C DO 40 IOUT = 1,12
C CALL SVODE(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE,
C 1 IOPT,RWORK,LRW,IWORK,LIW,JEX,MF,RPAR,IPAR)
C WRITE(6,20)T,Y(1),Y(2),Y(3)
C 20 FORMAT(' At t =',E12.4,' y =',3E14.6)
C IF (ISTATE .LT. 0) GO TO 80
C 40 TOUT = TOUT*10.
C WRITE(6,60) IWORK(11),IWORK(12),IWORK(13),IWORK(19),
C 1 IWORK(20),IWORK(21),IWORK(22)
C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4,
C 1 ' No. J-s =',I4,' No. LU-s =',I4/
C 2 ' No. nonlinear iterations =',I4/
C 3 ' No. nonlinear convergence failures =',I4/
C 4 ' No. error test failures =',I4/)
C STOP
C 80 WRITE(6,90)ISTATE
C 90 FORMAT(///' Error halt.. ISTATE =',I3)
C STOP
C END
C
C SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR)
C REAL RPAR, T, Y, YDOT
C DIMENSION Y(NEQ), YDOT(NEQ)
C YDOT(1) = -.04E0*Y(1) + 1.E4*Y(2)*Y(3)
C YDOT(3) = 3.E7*Y(2)*Y(2)
C YDOT(2) = -YDOT(1) - YDOT(3)
C RETURN
C END
C
C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR)
C REAL PD, RPAR, T, Y
C DIMENSION Y(NEQ), PD(NRPD,NEQ)
C PD(1,1) = -.04E0
C PD(1,2) = 1.E4*Y(3)
C PD(1,3) = 1.E4*Y(2)
C PD(2,1) = .04E0
C PD(2,3) = -PD(1,3)
C PD(3,2) = 6.E7*Y(2)
C PD(2,2) = -PD(1,2) - PD(3,2)
C RETURN
C END
C
C The following output was obtained from the above program on a
C Cray-1 computer with the CFT compiler.
C
C At t = 4.0000e-01 y = 9.851680e-01 3.386314e-05 1.479817e-02
C At t = 4.0000e+00 y = 9.055255e-01 2.240539e-05 9.445214e-02
C At t = 4.0000e+01 y = 7.158108e-01 9.184883e-06 2.841800e-01
C At t = 4.0000e+02 y = 4.505032e-01 3.222940e-06 5.494936e-01
C At t = 4.0000e+03 y = 1.832053e-01 8.942690e-07 8.167938e-01
C At t = 4.0000e+04 y = 3.898560e-02 1.621875e-07 9.610142e-01
C At t = 4.0000e+05 y = 4.935882e-03 1.984013e-08 9.950641e-01
C At t = 4.0000e+06 y = 5.166183e-04 2.067528e-09 9.994834e-01
C At t = 4.0000e+07 y = 5.201214e-05 2.080593e-10 9.999480e-01
C At t = 4.0000e+08 y = 5.213149e-06 2.085271e-11 9.999948e-01
C At t = 4.0000e+09 y = 5.183495e-07 2.073399e-12 9.999995e-01
C At t = 4.0000e+10 y = 5.450996e-08 2.180399e-13 9.999999e-01
C
C No. steps = 595 No. f-s = 832 No. J-s = 13 No. LU-s = 112
C No. nonlinear iterations = 831
C No. nonlinear convergence failures = 0
C No. error test failures = 22
C-----------------------------------------------------------------------
C Full description of user interface to SVODE.
C
C The user interface to SVODE consists of the following parts.
C
C i. The call sequence to subroutine SVODE, which is a driver
C routine for the solver. This includes descriptions of both
C the call sequence arguments and of user-supplied routines.
C Following these descriptions is
C * a description of optional input available through the
C call sequence,
C * a description of optional output (in the work arrays), and
C * instructions for interrupting and restarting a solution.
C
C ii. Descriptions of other routines in the SVODE package that may be
C (optionally) called by the user. These provide the ability to
C alter error message handling, save and restore the internal
C COMMON, and obtain specified derivatives of the solution y(t).
C
C iii. Descriptions of COMMON blocks to be declared in overlay
C or similar environments.
C
C iv. Description of two routines in the SVODE package, either of
C which the user may replace with his own version, if desired.
C these relate to the measurement of errors.
C
C-----------------------------------------------------------------------
C Part i. Call Sequence.
C
C The call sequence parameters used for input only are
C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF,
C and those used for both input and output are
C Y, T, ISTATE.
C The work arrays RWORK and IWORK are also used for conditional and
C optional input and optional output. (The term output here refers
C to the return from subroutine SVODE to the user's calling program.)
C
C The legality of input parameters will be thoroughly checked on the
C initial call for the problem, but not checked thereafter unless a
C change in input parameters is flagged by ISTATE = 3 in the input.
C
C The descriptions of the call arguments are as follows.
C
C F = The name of the user-supplied subroutine defining the
C ODE system. The system must be put in the first-order
C form dy/dt = f(t,y), where f is a vector-valued function
C of the scalar t and the vector y. Subroutine F is to
C compute the function f. It is to have the form
C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR)
C REAL T, Y, YDOT, RPAR
C DIMENSION Y(NEQ), YDOT(NEQ)
C where NEQ, T, and Y are input, and the array YDOT = f(t,y)
C is output. Y and YDOT are arrays of length NEQ.
C (In the DIMENSION statement above, NEQ can be replaced by
C * to make Y and YDOT assumed size arrays.)
C Subroutine F should not alter Y(1),...,Y(NEQ).
C F must be declared EXTERNAL in the calling program.
C
C Subroutine F may access user-defined real and integer
C work arrays RPAR and IPAR, which are to be dimensioned
C in the main program.
C
C If quantities computed in the F routine are needed
C externally to SVODE, an extra call to F should be made
C for this purpose, for consistent and accurate results.
C If only the derivative dy/dt is needed, use SVINDY instead.
C
C NEQ = The size of the ODE system (number of first order
C ordinary differential equations). Used only for input.
C NEQ may not be increased during the problem, but
C can be decreased (with ISTATE = 3 in the input).
C
C Y = A real array for the vector of dependent variables, of
C length NEQ or more. Used for both input and output on the
C first call (ISTATE = 1), and only for output on other calls.
C On the first call, Y must contain the vector of initial
C values. In the output, Y contains the computed solution
C evaluated at T. If desired, the Y array may be used
C for other purposes between calls to the solver.
C
C This array is passed as the Y argument in all calls to
C F and JAC.
C
C T = The independent variable. In the input, T is used only on
C the first call, as the initial point of the integration.
C In the output, after each call, T is the value at which a
C computed solution Y is evaluated (usually the same as TOUT).
C On an error return, T is the farthest point reached.
C
C TOUT = The next value of t at which a computed solution is desired.
C Used only for input.
C
C When starting the problem (ISTATE = 1), TOUT may be equal
C to T for one call, then should .ne. T for the next call.
C For the initial T, an input value of TOUT .ne. T is used
C in order to determine the direction of the integration
C (i.e. the algebraic sign of the step sizes) and the rough
C scale of the problem. Integration in either direction
C (forward or backward in t) is permitted.
C
C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after
C the first call (i.e. the first call with TOUT .ne. T).
C Otherwise, TOUT is required on every call.
C
C If ITASK = 1, 3, or 4, the values of TOUT need not be
C monotone, but a value of TOUT which backs up is limited
C to the current internal t interval, whose endpoints are
C TCUR - HU and TCUR. (See optional output, below, for
C TCUR and HU.)
C
C ITOL = An indicator for the type of error control. See
C description below under ATOL. Used only for input.
C
C RTOL = A relative error tolerance parameter, either a scalar or
C an array of length NEQ. See description below under ATOL.
C Input only.
C
C ATOL = An absolute error tolerance parameter, either a scalar or
C an array of length NEQ. Input only.
C
C The input parameters ITOL, RTOL, and ATOL determine
C the error control performed by the solver. The solver will
C control the vector e = (e(i)) of estimated local errors
C in Y, according to an inequality of the form
C rms-norm of ( e(i)/EWT(i) ) .le. 1,
C where EWT(i) = RTOL(i)*abs(Y(i)) + ATOL(i),
C and the rms-norm (root-mean-square norm) here is
C rms-norm(v) = sqrt(sum v(i)**2 / NEQ). Here EWT = (EWT(i))
C is a vector of weights which must always be positive, and
C the values of RTOL and ATOL should all be non-negative.
C The following table gives the types (scalar/array) of
C RTOL and ATOL, and the corresponding form of EWT(i).
C
C ITOL RTOL ATOL EWT(i)
C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL
C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i)
C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL
C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i)
C
C When either of these parameters is a scalar, it need not
C be dimensioned in the user's calling program.
C
C If none of the above choices (with ITOL, RTOL, and ATOL
C fixed throughout the problem) is suitable, more general
C error controls can be obtained by substituting
C user-supplied routines for the setting of EWT and/or for
C the norm calculation. See Part iv below.
C
C If global errors are to be estimated by making a repeated
C run on the same problem with smaller tolerances, then all
C components of RTOL and ATOL (i.e. of EWT) should be scaled
C down uniformly.
C
C ITASK = An index specifying the task to be performed.
C Input only. ITASK has the following values and meanings.
C 1 means normal computation of output values of y(t) at
C t = TOUT (by overshooting and interpolating).
C 2 means take one step only and return.
C 3 means stop at the first internal mesh point at or
C beyond t = TOUT and return.
C 4 means normal computation of output values of y(t) at
C t = TOUT but without overshooting t = TCRIT.
C TCRIT must be input as RWORK(1). TCRIT may be equal to
C or beyond TOUT, but not behind it in the direction of
C integration. This option is useful if the problem
C has a singularity at or beyond t = TCRIT.
C 5 means take one step, without passing TCRIT, and return.
C TCRIT must be input as RWORK(1).
C
C Note.. If ITASK = 4 or 5 and the solver reaches TCRIT
C (within roundoff), it will return T = TCRIT (exactly) to
C indicate this (unless ITASK = 4 and TOUT comes before TCRIT,
C in which case answers at T = TOUT are returned first).
C
C ISTATE = an index used for input and output to specify the
C the state of the calculation.
C
C In the input, the values of ISTATE are as follows.
C 1 means this is the first call for the problem
C (initializations will be done). See note below.
C 2 means this is not the first call, and the calculation
C is to continue normally, with no change in any input
C parameters except possibly TOUT and ITASK.
C (If ITOL, RTOL, and/or ATOL are changed between calls
C with ISTATE = 2, the new values will be used but not
C tested for legality.)
C 3 means this is not the first call, and the
C calculation is to continue normally, but with
C a change in input parameters other than
C TOUT and ITASK. Changes are allowed in
C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU,
C and any of the optional input except H0.
C (See IWORK description for ML and MU.)
C Note.. A preliminary call with TOUT = T is not counted
C as a first call here, as no initialization or checking of
C input is done. (Such a call is sometimes useful to include
C the initial conditions in the output.)
C Thus the first call for which TOUT .ne. T requires
C ISTATE = 1 in the input.
C
C In the output, ISTATE has the following values and meanings.
C 1 means nothing was done, as TOUT was equal to T with
C ISTATE = 1 in the input.
C 2 means the integration was performed successfully.
C -1 means an excessive amount of work (more than MXSTEP
C steps) was done on this call, before completing the
C requested task, but the integration was otherwise
C successful as far as T. (MXSTEP is an optional input
C and is normally 500.) To continue, the user may
C simply reset ISTATE to a value .gt. 1 and call again.
C (The excess work step counter will be reset to 0.)
C In addition, the user may increase MXSTEP to avoid
C this error return. (See optional input below.)
C -2 means too much accuracy was requested for the precision
C of the machine being used. This was detected before
C completing the requested task, but the integration
C was successful as far as T. To continue, the tolerance
C parameters must be reset, and ISTATE must be set
C to 3. The optional output TOLSF may be used for this
C purpose. (Note.. If this condition is detected before
C taking any steps, then an illegal input return
C (ISTATE = -3) occurs instead.)
C -3 means illegal input was detected, before taking any
C integration steps. See written message for details.
C Note.. If the solver detects an infinite loop of calls
C to the solver with illegal input, it will cause
C the run to stop.
C -4 means there were repeated error test failures on
C one attempted step, before completing the requested
C task, but the integration was successful as far as T.
C The problem may have a singularity, or the input
C may be inappropriate.
C -5 means there were repeated convergence test failures on
C one attempted step, before completing the requested
C task, but the integration was successful as far as T.
C This may be caused by an inaccurate Jacobian matrix,
C if one is being used.
C -6 means EWT(i) became zero for some i during the
C integration. Pure relative error control (ATOL(i)=0.0)
C was requested on a variable which has now vanished.
C The integration was successful as far as T.
C
C Note.. Since the normal output value of ISTATE is 2,
C it does not need to be reset for normal continuation.
C Also, since a negative input value of ISTATE will be
C regarded as illegal, a negative output value requires the
C user to change it, and possibly other input, before
C calling the solver again.
C
C IOPT = An integer flag to specify whether or not any optional
C input is being used on this call. Input only.
C The optional input is listed separately below.
C IOPT = 0 means no optional input is being used.
C Default values will be used in all cases.
C IOPT = 1 means optional input is being used.
C
C RWORK = A real working array (single precision).
C The length of RWORK must be at least
C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM where
C NYH = the initial value of NEQ,
C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a
C smaller value is given as an optional input),
C LWM = length of work space for matrix-related data..
C LWM = 0 if MITER = 0,
C LWM = 2*NEQ**2 + 2 if MITER = 1 or 2, and MF.gt.0,
C LWM = NEQ**2 + 2 if MITER = 1 or 2, and MF.lt.0,
C LWM = NEQ + 2 if MITER = 3,
C LWM = (3*ML+2*MU+2)*NEQ + 2 if MITER = 4 or 5, and MF.gt.0,
C LWM = (2*ML+MU+1)*NEQ + 2 if MITER = 4 or 5, and MF.lt.0.
C (See the MF description for METH and MITER.)
C Thus if MAXORD has its default value and NEQ is constant,
C this length is..
C 20 + 16*NEQ for MF = 10,
C 22 + 16*NEQ + 2*NEQ**2 for MF = 11 or 12,
C 22 + 16*NEQ + NEQ**2 for MF = -11 or -12,
C 22 + 17*NEQ for MF = 13,
C 22 + 18*NEQ + (3*ML+2*MU)*NEQ for MF = 14 or 15,
C 22 + 17*NEQ + (2*ML+MU)*NEQ for MF = -14 or -15,
C 20 + 9*NEQ for MF = 20,
C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22,
C 22 + 9*NEQ + NEQ**2 for MF = -21 or -22,
C 22 + 10*NEQ for MF = 23,
C 22 + 11*NEQ + (3*ML+2*MU)*NEQ for MF = 24 or 25.
C 22 + 10*NEQ + (2*ML+MU)*NEQ for MF = -24 or -25.
C The first 20 words of RWORK are reserved for conditional
C and optional output.
C
C The following word in RWORK is a conditional input..
C RWORK(1) = TCRIT = critical value of t which the solver
C is not to overshoot. Required if ITASK is
C 4 or 5, and ignored otherwise. (See ITASK.)
C
C LRW = The length of the array RWORK, as declared by the user.
C (This will be checked by the solver.)
C
C IWORK = An integer work array. The length of IWORK must be at least
C 30 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or
C 30 + NEQ otherwise (abs(MF) = 11,12,14,15,21,22,24,25).
C The first 30 words of IWORK are reserved for conditional and
C optional input and optional output.
C
C The following 2 words in IWORK are conditional input..
C IWORK(1) = ML These are the lower and upper
C IWORK(2) = MU half-bandwidths, respectively, of the
C banded Jacobian, excluding the main diagonal.
C The band is defined by the matrix locations
C (i,j) with i-ML .le. j .le. i+MU. ML and MU
C must satisfy 0 .le. ML,MU .le. NEQ-1.
C These are required if MITER is 4 or 5, and
C ignored otherwise. ML and MU may in fact be
C the band parameters for a matrix to which
C df/dy is only approximately equal.
C
C LIW = the length of the array IWORK, as declared by the user.
C (This will be checked by the solver.)
C
C Note.. The work arrays must not be altered between calls to SVODE
C for the same problem, except possibly for the conditional and
C optional input, and except for the last 3*NEQ words of RWORK.
C The latter space is used for internal scratch space, and so is
C available for use by the user outside SVODE between calls, if
C desired (but not for use by F or JAC).
C
C JAC = The name of the user-supplied routine (MITER = 1 or 4) to
C compute the Jacobian matrix, df/dy, as a function of
C the scalar t and the vector y. It is to have the form
C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD,
C RPAR, IPAR)
C REAL T, Y, PD, RPAR
C DIMENSION Y(NEQ), PD(NROWPD, NEQ)
C where NEQ, T, Y, ML, MU, and NROWPD are input and the array
C PD is to be loaded with partial derivatives (elements of the
C Jacobian matrix) in the output. PD must be given a first
C dimension of NROWPD. T and Y have the same meaning as in
C Subroutine F. (In the DIMENSION statement above, NEQ can
C be replaced by * to make Y and PD assumed size arrays.)
C In the full matrix case (MITER = 1), ML and MU are
C ignored, and the Jacobian is to be loaded into PD in
C columnwise manner, with df(i)/dy(j) loaded into PD(i,j).
C In the band matrix case (MITER = 4), the elements
C within the band are to be loaded into PD in columnwise
C manner, with diagonal lines of df/dy loaded into the rows
C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j).
C ML and MU are the half-bandwidth parameters. (See IWORK).
C The locations in PD in the two triangular areas which
C correspond to nonexistent matrix elements can be ignored
C or loaded arbitrarily, as they are overwritten by SVODE.
C JAC need not provide df/dy exactly. A crude
C approximation (possibly with a smaller bandwidth) will do.
C In either case, PD is preset to zero by the solver,
C so that only the nonzero elements need be loaded by JAC.
C Each call to JAC is preceded by a call to F with the same
C arguments NEQ, T, and Y. Thus to gain some efficiency,
C intermediate quantities shared by both calculations may be
C saved in a user COMMON block by F and not recomputed by JAC,
C if desired. Also, JAC may alter the Y array, if desired.
C JAC must be declared external in the calling program.
C Subroutine JAC may access user-defined real and integer
C work arrays, RPAR and IPAR, whose dimensions are set by the
C user in the main program.
C
C MF = The method flag. Used only for input. The legal values of
C MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25,
C -11, -12, -14, -15, -21, -22, -24, -25.
C MF is a signed two-digit integer, MF = JSV*(10*METH + MITER).
C JSV = SIGN(MF) indicates the Jacobian-saving strategy..
C JSV = 1 means a copy of the Jacobian is saved for reuse
C in the corrector iteration algorithm.
C JSV = -1 means a copy of the Jacobian is not saved
C (valid only for MITER = 1, 2, 4, or 5).
C METH indicates the basic linear multistep method..
C METH = 1 means the implicit Adams method.
C METH = 2 means the method based on backward
C differentiation formulas (BDF-s).
C MITER indicates the corrector iteration method..
C MITER = 0 means functional iteration (no Jacobian matrix
C is involved).
C MITER = 1 means chord iteration with a user-supplied
C full (NEQ by NEQ) Jacobian.
C MITER = 2 means chord iteration with an internally
C generated (difference quotient) full Jacobian
C (using NEQ extra calls to F per df/dy value).
C MITER = 3 means chord iteration with an internally
C generated diagonal Jacobian approximation
C (using 1 extra call to F per df/dy evaluation).
C MITER = 4 means chord iteration with a user-supplied
C banded Jacobian.
C MITER = 5 means chord iteration with an internally
C generated banded Jacobian (using ML+MU+1 extra
C calls to F per df/dy evaluation).
C If MITER = 1 or 4, the user must supply a subroutine JAC
C (the name is arbitrary) as described above under JAC.
C For other values of MITER, a dummy argument can be used.
C
C RPAR User-specified array used to communicate real parameters
C to user-supplied subroutines. If RPAR is a vector, then
C it must be dimensioned in the user's main program. If it
C is unused or it is a scalar, then it need not be
C dimensioned.
C
C IPAR User-specified array used to communicate integer parameter
C to user-supplied subroutines. The comments on dimensioning
C RPAR apply to IPAR.
C-----------------------------------------------------------------------
C Optional Input.
C
C The following is a list of the optional input provided for in the
C call sequence. (See also Part ii.) For each such input variable,
C this table lists its name as used in this documentation, its
C location in the call sequence, its meaning, and the default value.
C The use of any of this input requires IOPT = 1, and in that
C case all of this input is examined. A value of zero for any
C of these optional input variables will cause the default value to be
C used. Thus to use a subset of the optional input, simply preload
C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and
C then set those of interest to nonzero values.
C
C NAME LOCATION MEANING AND DEFAULT VALUE
C
C H0 RWORK(5) The step size to be attempted on the first step.
C The default value is determined by the solver.
C
C HMAX RWORK(6) The maximum absolute step size allowed.
C The default value is infinite.
C
C HMIN RWORK(7) The minimum absolute step size allowed.
C The default value is 0. (This lower bound is not
C enforced on the final step before reaching TCRIT
C when ITASK = 4 or 5.)
C
C MAXORD IWORK(5) The maximum order to be allowed. The default
C value is 12 if METH = 1, and 5 if METH = 2.
C If MAXORD exceeds the default value, it will
C be reduced to the default value.
C If MAXORD is changed during the problem, it may
C cause the current order to be reduced.
C
C MXSTEP IWORK(6) Maximum number of (internally defined) steps
C allowed during one call to the solver.
C The default value is 500.
C
C MXHNIL IWORK(7) Maximum number of messages printed (per problem)
C warning that T + H = T on a step (H = step size).
C This must be positive to result in a non-default
C value. The default value is 10.
C
C-----------------------------------------------------------------------
C Optional Output.
C
C As optional additional output from SVODE, the variables listed
C below are quantities related to the performance of SVODE
C which are available to the user. These are communicated by way of
C the work arrays, but also have internal mnemonic names as shown.
C Except where stated otherwise, all of this output is defined
C on any successful return from SVODE, and on any return with
C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return
C (ISTATE = -3), they will be unchanged from their existing values
C (if any), except possibly for TOLSF, LENRW, and LENIW.
C On any error return, output relevant to the error will be defined,
C as noted below.
C
C NAME LOCATION MEANING
C
C HU RWORK(11) The step size in t last used (successfully).
C
C HCUR RWORK(12) The step size to be attempted on the next step.
C
C TCUR RWORK(13) The current value of the independent variable
C which the solver has actually reached, i.e. the
C current internal mesh point in t. In the output,
C TCUR will always be at least as far from the
C initial value of t as the current argument T,
C but may be farther (if interpolation was done).
C
C TOLSF RWORK(14) A tolerance scale factor, greater than 1.0,
C computed when a request for too much accuracy was
C detected (ISTATE = -3 if detected at the start of
C the problem, ISTATE = -2 otherwise). If ITOL is
C left unaltered but RTOL and ATOL are uniformly
C scaled up by a factor of TOLSF for the next call,
C then the solver is deemed likely to succeed.
C (The user may also ignore TOLSF and alter the
C tolerance parameters in any other way appropriate.)
C
C NST IWORK(11) The number of steps taken for the problem so far.
C
C NFE IWORK(12) The number of f evaluations for the problem so far.
C
C NJE IWORK(13) The number of Jacobian evaluations so far.
C
C NQU IWORK(14) The method order last used (successfully).
C
C NQCUR IWORK(15) The order to be attempted on the next step.
C
C IMXER IWORK(16) The index of the component of largest magnitude in
C the weighted local error vector ( e(i)/EWT(i) ),
C on an error return with ISTATE = -4 or -5.
C
C LENRW IWORK(17) The length of RWORK actually required.
C This is defined on normal returns and on an illegal
C input return for insufficient storage.
C
C LENIW IWORK(18) The length of IWORK actually required.
C This is defined on normal returns and on an illegal
C input return for insufficient storage.
C
C NLU IWORK(19) The number of matrix LU decompositions so far.
C
C NNI IWORK(20) The number of nonlinear (Newton) iterations so far.
C
C NCFN IWORK(21) The number of convergence failures of the nonlinear
C solver so far.
C
C NETF IWORK(22) The number of error test failures of the integrator
C so far.
C
C The following two arrays are segments of the RWORK array which
C may also be of interest to the user as optional output.
C For each array, the table below gives its internal name,
C its base address in RWORK, and its description.
C
C NAME BASE ADDRESS DESCRIPTION
C
C YH 21 The Nordsieck history array, of size NYH by
C (NQCUR + 1), where NYH is the initial value
C of NEQ. For j = 0,1,...,NQCUR, column j+1
C of YH contains HCUR**j/factorial(j) times
C the j-th derivative of the interpolating
C polynomial currently representing the
C solution, evaluated at t = TCUR.
C
C ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated
C corrections on each step, scaled in the output
C to represent the estimated local error in Y
C on the last step. This is the vector e in
C the description of the error control. It is
C defined only on a successful return from SVODE.
C
C-----------------------------------------------------------------------
C Interrupting and Restarting
C
C If the integration of a given problem by SVODE is to be
C interrrupted and then later continued, such as when restarting
C an interrupted run or alternating between two or more ODE problems,
C the user should save, following the return from the last SVODE call
C prior to the interruption, the contents of the call sequence
C variables and internal COMMON blocks, and later restore these
C values before the next SVODE call for that problem. To save
C and restore the COMMON blocks, use subroutine SVSRCO, as
C described below in part ii.
C
C In addition, if non-default values for either LUN or MFLAG are
C desired, an extra call to XSETUN and/or XSETF should be made just
C before continuing the integration. See Part ii below for details.
C
C-----------------------------------------------------------------------
C Part ii. Other Routines Callable.
C
C The following are optional calls which the user may make to
C gain additional capabilities in conjunction with SVODE.
C (The routines XSETUN and XSETF are designed to conform to the
C SLATEC error handling package.)
C
C FORM OF CALL FUNCTION
C CALL XSETUN(LUN) Set the logical unit number, LUN, for
C output of messages from SVODE, if
C the default is not desired.
C The default value of LUN is 6.
C
C CALL XSETF(MFLAG) Set a flag to control the printing of
C messages by SVODE.
C MFLAG = 0 means do not print. (Danger..
C This risks losing valuable information.)
C MFLAG = 1 means print (the default).
C
C Either of the above calls may be made at
C any time and will take effect immediately.
C
C CALL SVSRCO(RSAV,ISAV,JOB) Saves and restores the contents of
C the internal COMMON blocks used by
C SVODE. (See Part iii below.)
C RSAV must be a real array of length 49
C or more, and ISAV must be an integer
C array of length 40 or more.
C JOB=1 means save COMMON into RSAV/ISAV.
C JOB=2 means restore COMMON from RSAV/ISAV.
C SVSRCO is useful if one is
C interrupting a run and restarting
C later, or alternating between two or
C more problems solved with SVODE.
C
C CALL SVINDY(,,,,,) Provide derivatives of y, of various
C (See below.) orders, at a specified point T, if
C desired. It may be called only after
C a successful return from SVODE.
C
C The detailed instructions for using SVINDY are as follows.
C The form of the call is..
C
C CALL SVINDY (T, K, RWORK(21), NYH, DKY, IFLAG)
C
C The input parameters are..
C
C T = Value of independent variable where answers are desired
C (normally the same as the T last returned by SVODE).
C For valid results, T must lie between TCUR - HU and TCUR.
C (See optional output for TCUR and HU.)
C K = Integer order of the derivative desired. K must satisfy
C 0 .le. K .le. NQCUR, where NQCUR is the current order
C (see optional output). The capability corresponding
C to K = 0, i.e. computing y(T), is already provided
C by SVODE directly. Since NQCUR .ge. 1, the first
C derivative dy/dt is always available with SVINDY.
C RWORK(21) = The base address of the history array YH.
C NYH = Column length of YH, equal to the initial value of NEQ.
C
C The output parameters are..
C
C DKY = A real array of length NEQ containing the computed value
C of the K-th derivative of y(t).
C IFLAG = Integer flag, returned as 0 if K and T were legal,
C -1 if K was illegal, and -2 if T was illegal.
C On an error return, a message is also written.
C-----------------------------------------------------------------------
C Part iii. COMMON Blocks.
C If SVODE is to be used in an overlay situation, the user
C must declare, in the primary overlay, the variables in..
C (1) the call sequence to SVODE,
C (2) the two internal COMMON blocks
C /SVOD01/ of length 81 (48 single precision words
C followed by 33 integer words),
C /SVOD02/ of length 9 (1 single precision word
C followed by 8 integer words),
C
C If SVODE is used on a system in which the contents of internal
C COMMON blocks are not preserved between calls, the user should
C declare the above two COMMON blocks in his main program to insure
C that their contents are preserved.
C
C-----------------------------------------------------------------------
C Part iv. Optionally Replaceable Solver Routines.
C
C Below are descriptions of two routines in the SVODE package which
C relate to the measurement of errors. Either routine can be
C replaced by a user-supplied version, if desired. However, since such
C a replacement may have a major impact on performance, it should be
C done only when absolutely necessary, and only with great caution.
C (Note.. The means by which the package version of a routine is
C superseded by the user's version may be system-dependent.)
C
C (a) SEWSET.
C The following subroutine is called just before each internal
C integration step, and sets the array of error weights, EWT, as
C described under ITOL/RTOL/ATOL above..
C SUBROUTINE SEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT)
C where NEQ, ITOL, RTOL, and ATOL are as in the SVODE call sequence,
C YCUR contains the current dependent variable vector, and
C EWT is the array of weights set by SEWSET.
C
C If the user supplies this subroutine, it must return in EWT(i)
C (i = 1,...,NEQ) a positive quantity suitable for comparison with
C errors in Y(i). The EWT array returned by SEWSET is passed to the
C SVNORM routine (See below.), and also used by SVODE in the computation
C of the optional output IMXER, the diagonal Jacobian approximation,
C and the increments for difference quotient Jacobians.
C
C In the user-supplied version of SEWSET, it may be desirable to use
C the current values of derivatives of y. Derivatives up to order NQ
C are available from the history array YH, described above under
C Optional Output. In SEWSET, YH is identical to the YCUR array,
C extended to NQ + 1 columns with a column length of NYH and scale
C factors of h**j/factorial(j). On the first call for the problem,
C given by NST = 0, NQ is 1 and H is temporarily set to 1.0.
C NYH is the initial value of NEQ. The quantities NQ, H, and NST
C can be obtained by including in SEWSET the statements..
C REAL RVOD, H, HU
C COMMON /SVOD01/ RVOD(48), IVOD(33)
C COMMON /SVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C NQ = IVOD(28)
C H = RVOD(21)
C Thus, for example, the current value of dy/dt can be obtained as
C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is
C unnecessary when NST = 0).
C
C (b) SVNORM.
C The following is a real function routine which computes the weighted
C root-mean-square norm of a vector v..
C D = SVNORM (N, V, W)
C where..
C N = the length of the vector,
C V = real array of length N containing the vector,
C W = real array of length N containing weights,
C D = sqrt( (1/N) * sum(V(i)*W(i))**2 ).
C SVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where
C EWT is as set by subroutine SEWSET.
C
C If the user supplies this function, it should return a non-negative
C value of SVNORM suitable for use in the error control in SVODE.
C None of the arguments should be altered by SVNORM.
C For example, a user-supplied SVNORM routine might..
C -substitute a max-norm of (V(i)*W(i)) for the rms-norm, or
C -ignore some components of V in the norm, with the effect of
C suppressing the error control on those components of Y.
C-----------------------------------------------------------------------
C Other Routines in the SVODE Package.
C
C In addition to subroutine SVODE, the SVODE package includes the
C following subroutines and function routines..
C SVHIN computes an approximate step size for the initial step.
C SVINDY computes an interpolated value of the y vector at t = TOUT.
C SVSTEP is the core integrator, which does one step of the
C integration and the associated error control.
C SVSET sets all method coefficients and test constants.
C SVNLSD solves the underlying nonlinear system -- the corrector.
C SVJAC computes and preprocesses the Jacobian matrix J = df/dy
C and the Newton iteration matrix P = I - (h/l1)*J.
C SVSOL manages solution of linear system in chord iteration.
C SVJUST adjusts the history array on a change of order.
C SEWSET sets the error weight vector EWT before each step.
C SVNORM computes the weighted r.m.s. norm of a vector.
C SVSRCO is a user-callable routines to save and restore
C the contents of the internal COMMON blocks.
C SACOPY is a routine to copy one two-dimensional array to another.
C SGEFA and SGESL are routines from LINPACK for solving full
C systems of linear algebraic equations.
C SGBFA and SGBSL are routines from LINPACK for solving banded
C linear systems.
C SAXPY, SSCAL, and CH_SCOPY are basic linear algebra modules (BLAS).
C R1MACH sets the unit roundoff of the machine.
C XERRWV, XSETUN, XSETF, LUNSAV, and MFLGSV handle the printing of all
C error messages and warnings. XERRWV is machine-dependent.
C Note.. SVNORM, R1MACH, LUNSAV, and MFLGSV are function routines.
C All the others are subroutines.
C
C The intrinsic and external routines used by the SVODE package are..
C ABS, MAX, MIN, REAL, SIGN, SQRT, and WRITE.
C
C-----------------------------------------------------------------------
C
C Type declarations for labeled COMMON block SVOD01 --------------------
C
REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL,
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU, TQ, TN, UROUND
INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
4 NSLP, NYH
C
C Type declarations for labeled COMMON block SVOD02 --------------------
C
REAL HU
INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C
C Type declarations for local variables --------------------------------
C
EXTERNAL SVNLSD
LOGICAL IHIT
REAL ATOLI, BIG, EWTI, FOUR, H0, HMAX, HMX, HUN, ONE,
1 PT2, RH, RTOLI, SIZE, TCRIT, TNEXT, TOLSF, TP, TWO, ZERO
INTEGER I, IER, IFLAG, IMXER, JCO, KGO, LENIW, LENJ, LENP, LENRW,
1 LENWM, LF0, MBAND, ML, MORD, MU, MXHNL0, MXSTP0, NITER, NSLAST
CHARACTER*80 MSG
C
C Type declaration for function subroutines called ---------------------
C
REAL R1MACH, SVNORM
C
DIMENSION MORD(2)
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to SVODE.
C-----------------------------------------------------------------------
SAVE MORD, MXHNL0, MXSTP0
SAVE ZERO, ONE, TWO, FOUR, PT2, HUN
C-----------------------------------------------------------------------
C The following internal COMMON blocks contain variables which are
C communicated between subroutines in the SVODE package, or which are
C to be saved between calls to SVODE.
C In each block, real variables precede integers.
C The block /SVOD01/ appears in subroutines SVODE, SVINDY, SVSTEP,
C SVSET, SVNLSD, SVJAC, SVSOL, SVJUST and SVSRCO.
C The block /SVOD02/ appears in subroutines SVODE, SVINDY, SVSTEP,
C SVNLSD, SVJAC, and SVSRCO.
C
C The variables stored in the internal COMMON blocks are as follows..
C
C ACNRM = Weighted r.m.s. norm of accumulated correction vectors.
C CCMXJ = Threshhold on DRC for updating the Jacobian. (See DRC.)
C CONP = The saved value of TQ(5).
C CRATE = Estimated corrector convergence rate constant.
C DRC = Relative change in H*RL1 since last SVJAC call.
C EL = Real array of integration coefficients. See SVSET.
C ETA = Saved tentative ratio of new to old H.
C ETAMAX = Saved maximum value of ETA to be allowed.
C H = The step size.
C HMIN = The minimum absolute value of the step size H to be used.
C HMXI = Inverse of the maximum absolute value of H to be used.
C HMXI = 0.0 is allowed and corresponds to an infinite HMAX.
C HNEW = The step size to be attempted on the next step.
C HSCAL = Stepsize in scaling of YH array.
C PRL1 = The saved value of RL1.
C RC = Ratio of current H*RL1 to value on last SVJAC call.
C RL1 = The reciprocal of the coefficient EL(1).
C TAU = Real vector of past NQ step sizes, length 13.
C TQ = A real vector of length 5 in which SVSET stores constants
C used for the convergence test, the error test, and the
C selection of H at a new order.
C TN = The independent variable, updated on each step taken.
C UROUND = The machine unit roundoff. The smallest positive real number
C such that 1.0 + UROUND .ne. 1.0
C ICF = Integer flag for convergence failure in SVNLSD..
C 0 means no failures.
C 1 means convergence failure with out of date Jacobian
C (recoverable error).
C 2 means convergence failure with current Jacobian or
C singular matrix (unrecoverable error).
C INIT = Saved integer flag indicating whether initialization of the
C problem has been done (INIT = 1) or not.
C IPUP = Saved flag to signal updating of Newton matrix.
C JCUR = Output flag from SVJAC showing Jacobian status..
C JCUR = 0 means J is not current.
C JCUR = 1 means J is current.
C JSTART = Integer flag used as input to SVSTEP..
C 0 means perform the first step.
C 1 means take a new step continuing from the last.
C -1 means take the next step with a new value of MAXORD,
C HMIN, HMXI, N, METH, MITER, and/or matrix parameters.
C On return, SVSTEP sets JSTART = 1.
C JSV = Integer flag for Jacobian saving, = sign(MF).
C KFLAG = A completion code from SVSTEP with the following meanings..
C 0 the step was succesful.
C -1 the requested error could not be achieved.
C -2 corrector convergence could not be achieved.
C -3, -4 fatal error in VNLS (can not occur here).
C KUTH = Input flag to SVSTEP showing whether H was reduced by the
C driver. KUTH = 1 if H was reduced, = 0 otherwise.
C L = Integer variable, NQ + 1, current order plus one.
C LMAX = MAXORD + 1 (used for dimensioning).
C LOCJS = A pointer to the saved Jacobian, whose storage starts at
C WM(LOCJS), if JSV = 1.
C LYH, LEWT, LACOR, LSAVF, LWM, LIWM = Saved integer pointers
C to segments of RWORK and IWORK.
C MAXORD = The maximum order of integration method to be allowed.
C METH/MITER = The method flags. See MF.
C MSBJ = The maximum number of steps between J evaluations, = 50.
C MXHNIL = Saved value of optional input MXHNIL.
C MXSTEP = Saved value of optional input MXSTEP.
C N = The number of first-order ODEs, = NEQ.
C NEWH = Saved integer to flag change of H.
C NEWQ = The method order to be used on the next step.
C NHNIL = Saved counter for occurrences of T + H = T.
C NQ = Integer variable, the current integration method order.
C NQNYH = Saved value of NQ*NYH.
C NQWAIT = A counter controlling the frequency of order changes.
C An order change is about to be considered if NQWAIT = 1.
C NSLJ = The number of steps taken as of the last Jacobian update.
C NSLP = Saved value of NST as of last Newton matrix update.
C NYH = Saved value of the initial value of NEQ.
C HU = The step size in t last used.
C NCFN = Number of nonlinear convergence failures so far.
C NETF = The number of error test failures of the integrator so far.
C NFE = The number of f evaluations for the problem so far.
C NJE = The number of Jacobian evaluations so far.
C NLU = The number of matrix LU decompositions so far.
C NNI = Number of nonlinear iterations so far.
C NQU = The method order last used.
C NST = The number of steps taken for the problem so far.
C-----------------------------------------------------------------------
COMMON /SVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13),
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU(13), TQ(5), TN, UROUND,
3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
7 NSLP, NYH
COMMON /SVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C
DATA MORD(1) /12/, MORD(2) /5/, MXSTP0 /500/, MXHNL0 /10/
DATA ZERO /0.0E0/, ONE /1.0E0/, TWO /2.0E0/, FOUR /4.0E0/,
1 PT2 /0.2E0/, HUN /100.0E0/
C-----------------------------------------------------------------------
C Block A.
C This code block is executed on every call.
C It tests ISTATE and ITASK for legality and branches appropriately.
C If ISTATE .gt. 1 but the flag INIT shows that initialization has
C not yet been done, an error return occurs.
C If ISTATE = 1 and TOUT = T, return immediately.
C-----------------------------------------------------------------------
IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601
IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602
IF (ISTATE .EQ. 1) GO TO 10
IF (INIT .NE. 1) GO TO 603
IF (ISTATE .EQ. 2) GO TO 200
GO TO 20
10 INIT = 0
IF (TOUT .EQ. T) RETURN
C-----------------------------------------------------------------------
C Block B.
C The next code block is executed for the initial call (ISTATE = 1),
C or for a continuation call with parameter changes (ISTATE = 3).
C It contains checking of all input and various initializations.
C
C First check legality of the non-optional input NEQ, ITOL, IOPT,
C MF, ML, and MU.
C-----------------------------------------------------------------------
20 IF (NEQ .LE. 0) GO TO 604
IF (ISTATE .EQ. 1) GO TO 25
IF (NEQ .GT. N) GO TO 605
25 N = NEQ
IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606
IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607
JSV = SIGN(1,MF)
MF = ABS(MF)
METH = MF/10
MITER = MF - 10*METH
IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608
IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608
IF (MITER .LE. 3) GO TO 30
ML = IWORK(1)
MU = IWORK(2)
IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609
IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610
30 CONTINUE
C Next process and check the optional input. ---------------------------
IF (IOPT .EQ. 1) GO TO 40
MAXORD = MORD(METH)
MXSTEP = MXSTP0
MXHNIL = MXHNL0
IF (ISTATE .EQ. 1) H0 = ZERO
HMXI = ZERO
HMIN = ZERO
GO TO 60
40 MAXORD = IWORK(5)
IF (MAXORD .LT. 0) GO TO 611
IF (MAXORD .EQ. 0) MAXORD = 100
MAXORD = MIN(MAXORD,MORD(METH))
MXSTEP = IWORK(6)
IF (MXSTEP .LT. 0) GO TO 612
IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0
MXHNIL = IWORK(7)
IF (MXHNIL .LT. 0) GO TO 613
IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0
IF (ISTATE .NE. 1) GO TO 50
H0 = RWORK(5)
IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614
50 HMAX = RWORK(6)
IF (HMAX .LT. ZERO) GO TO 615
HMXI = ZERO
IF (HMAX .GT. ZERO) HMXI = ONE/HMAX
HMIN = RWORK(7)
IF (HMIN .LT. ZERO) GO TO 616
C-----------------------------------------------------------------------
C Set work array pointers and check lengths LRW and LIW.
C Pointers to segments of RWORK and IWORK are named by prefixing L to
C the name of the segment. E.g., the segment YH starts at RWORK(LYH).
C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR.
C Within WM, LOCJS is the location of the saved Jacobian (JSV .gt. 0).
C-----------------------------------------------------------------------
60 LYH = 21
IF (ISTATE .EQ. 1) NYH = N
LWM = LYH + (MAXORD + 1)*NYH
JCO = MAX(0,JSV)
IF (MITER .EQ. 0) LENWM = 0
IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN
LENWM = 2 + (1 + JCO)*N*N
LOCJS = N*N + 3
ENDIF
IF (MITER .EQ. 3) LENWM = 2 + N
IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN
MBAND = ML + MU + 1
LENP = (MBAND + ML)*N
LENJ = MBAND*N
LENWM = 2 + LENP + JCO*LENJ
LOCJS = LENP + 3
ENDIF
LEWT = LWM + LENWM
LSAVF = LEWT + N
LACOR = LSAVF + N
LENRW = LACOR + N - 1
IWORK(17) = LENRW
LIWM = 1
LENIW = 30 + N
IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 30
IWORK(18) = LENIW
IF (LENRW .GT. LRW) GO TO 617
IF (LENIW .GT. LIW) GO TO 618
C Check RTOL and ATOL for legality. ------------------------------------
RTOLI = RTOL(1)
ATOLI = ATOL(1)
DO 70 I = 1,N
IF (ITOL .GE. 3) RTOLI = RTOL(I)
IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I)
IF (RTOLI .LT. ZERO) GO TO 619
IF (ATOLI .LT. ZERO) GO TO 620
70 CONTINUE
IF (ISTATE .EQ. 1) GO TO 100
C If ISTATE = 3, set flag to signal parameter changes to SVSTEP. -------
JSTART = -1
IF (NQ .LE. MAXORD) GO TO 90
C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. ---------
CALL CH_SCOPY (N, RWORK(LWM), 1, RWORK(LSAVF), 1)
C Reload WM(1) = RWORK(LWM), since LWM may have changed. ---------------
90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND)
C-----------------------------------------------------------------------
C Block C.
C The next block is for the initial call only (ISTATE = 1).
C It contains all remaining initializations, the initial call to F,
C and the calculation of the initial step size.
C The error weights in EWT are inverted after being loaded.
C-----------------------------------------------------------------------
100 UROUND = R1MACH(4)
TN = T
IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110
TCRIT = RWORK(1)
IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625
IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO)
1 H0 = TCRIT - T
110 JSTART = 0
IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND)
CCMXJ = PT2
MSBJ = 50
NHNIL = 0
NST = 0
NJE = 0
NNI = 0
NCFN = 0
NETF = 0
NLU = 0
NSLJ = 0
NSLAST = 0
HU = ZERO
NQU = 0
C Initial call to F. (LF0 points to YH(*,2).) -------------------------
LF0 = LYH + NYH
C
C*UPG*MNH
C
CALL F (N, T, Y, RWORK(LF0), RPAR, IPAR, KMI, KINDEX)
C
C*UPG*MNH
C
NFE = 1
C Load the initial value vector in YH. ---------------------------------
CALL CH_SCOPY (N, Y, 1, RWORK(LYH), 1)
C Load and invert the EWT array. (H is temporarily set to 1.0.) -------
NQ = 1
H = ONE
CALL SEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT))
DO 120 I = 1,N
IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621
120 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1)
IF (H0 .NE. ZERO) GO TO 180
C Call SVHIN to set initial step size H0 to be attempted. --------------
CALL SVHIN (N, T, RWORK(LYH), RWORK(LF0), F, RPAR, IPAR, TOUT,
1 UROUND, RWORK(LEWT), ITOL, ATOL, Y, RWORK(LACOR), H0,
2 NITER, IER, KMI, KINDEX)
NFE = NFE + NITER
IF (IER .NE. 0) GO TO 622
C Adjust H0 if necessary to meet HMAX bound. ---------------------------
180 RH = ABS(H0)*HMXI
IF (RH .GT. ONE) H0 = H0/RH
C Load H with H0 and scale YH(*,2) by H0. ------------------------------
H = H0
CALL SSCAL (N, H0, RWORK(LF0), 1)
GO TO 270
C-----------------------------------------------------------------------
C Block D.
C The next code block is for continuation calls only (ISTATE = 2 or 3)
C and is to check stop conditions before taking a step.
C-----------------------------------------------------------------------
200 NSLAST = NST
KUTH = 0
GO TO (210, 250, 220, 230, 240), ITASK
210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250
CALL SVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG)
IF (IFLAG .NE. 0) GO TO 627
T = TOUT
GO TO 420
220 TP = TN - HU*(ONE + HUN*UROUND)
IF ((TP - TOUT)*H .GT. ZERO) GO TO 623
IF ((TN - TOUT)*H .LT. ZERO) GO TO 250
GO TO 400
230 TCRIT = RWORK(1)
IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624
IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625
IF ((TN - TOUT)*H .LT. ZERO) GO TO 245
CALL SVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG)
IF (IFLAG .NE. 0) GO TO 627
T = TOUT
GO TO 420
240 TCRIT = RWORK(1)
IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624
245 HMX = ABS(TN) + ABS(H)
IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX
IF (IHIT) GO TO 400
TNEXT = TN + HNEW*(ONE + FOUR*UROUND)
IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250
H = (TCRIT - TN)*(ONE - FOUR*UROUND)
KUTH = 1
C-----------------------------------------------------------------------
C Block E.
C The next block is normally executed for all calls and contains
C the call to the one-step core integrator SVSTEP.
C
C This is a looping point for the integration steps.
C
C First check for too many steps being taken, update EWT (if not at
C start of problem), check for too much accuracy being requested, and
C check for H below the roundoff level in T.
C-----------------------------------------------------------------------
250 CONTINUE
IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500
CALL SEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT))
DO 260 I = 1,N
IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510
260 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1)
270 TOLSF = UROUND*SVNORM (N, RWORK(LYH), RWORK(LEWT))
IF (TOLSF .LE. ONE) GO TO 280
TOLSF = TOLSF*TWO
IF (NST .EQ. 0) GO TO 626
GO TO 520
280 IF ((TN + H) .NE. TN) GO TO 290
CKS: strange things happen on HP f90 (this error message is
CKS: often printed but results are the same than on Linux)
CKS: let's jump over these prints
GOTO 290
NHNIL = NHNIL + 1
IF (NHNIL .GT. MXHNIL) GO TO 290
MSG = 'SVODE-- Warning..internal T (=R1) and H (=R2) are'
CALL XERRWV (MSG, 50, 101, 1, 0, 0, 0, 0, ZERO, ZERO)
MSG=' such that in the machine, T + H = T on the next step '
CALL XERRWV (MSG, 60, 101, 1, 0, 0, 0, 0, ZERO, ZERO)
MSG = ' (H = step size). solver will continue anyway'
CALL XERRWV (MSG, 50, 101, 1, 0, 0, 0, 2, TN, H)
IF (NHNIL .LT. MXHNIL) GO TO 290
MSG = 'SVODE-- Above warning has been issued I1 times. '
CALL XERRWV (MSG, 50, 102, 1, 0, 0, 0, 0, ZERO, ZERO)
MSG = ' it will not be issued again for this problem'
CALL XERRWV (MSG, 50, 102, 1, 1, MXHNIL, 0, 0, ZERO, ZERO)
290 CONTINUE
C-----------------------------------------------------------------------
C CALL SVSTEP (Y, YH, NYH, YH, EWT, SAVF, VSAV, ACOR,
C WM, IWM, F, JAC, F, SVNLSD, RPAR, IPAR)
C-----------------------------------------------------------------------
CALL SVSTEP (Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT),
1 RWORK(LSAVF), Y, RWORK(LACOR), RWORK(LWM), IWORK(LIWM),
2 F, JAC, F, SVNLSD, RPAR, IPAR, KMI, KINDEX)
KGO = 1 - KFLAG
C Branch on KFLAG. Note..In this version, KFLAG can not be set to -3.
C KFLAG .eq. 0, -1, -2
GO TO (300, 530, 540), KGO
C-----------------------------------------------------------------------
C Block F.
C The following block handles the case of a successful return from the
C core integrator (KFLAG = 0). Test for stop conditions.
C-----------------------------------------------------------------------
300 INIT = 1
KUTH = 0
GO TO (310, 400, 330, 340, 350), ITASK
C ITASK = 1. If TOUT has been reached, interpolate. -------------------
310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250
CALL SVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG)
T = TOUT
GO TO 420
C ITASK = 3. Jump to exit if TOUT was reached. ------------------------
330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400
GO TO 250
C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary.
340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345
CALL SVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG)
T = TOUT
GO TO 420
345 HMX = ABS(TN) + ABS(H)
IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX
IF (IHIT) GO TO 400
TNEXT = TN + HNEW*(ONE + FOUR*UROUND)
IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250
H = (TCRIT - TN)*(ONE - FOUR*UROUND)
KUTH = 1
GO TO 250
C ITASK = 5. See if TCRIT was reached and jump to exit. ---------------
350 HMX = ABS(TN) + ABS(H)
IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX
C-----------------------------------------------------------------------
C Block G.
C The following block handles all successful returns from SVODE.
C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly.
C ISTATE is set to 2, and the optional output is loaded into the work
C arrays before returning.
C-----------------------------------------------------------------------
400 CONTINUE
CALL CH_SCOPY (N, RWORK(LYH), 1, Y, 1)
T = TN
IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420
IF (IHIT) T = TCRIT
420 ISTATE = 2
RWORK(11) = HU
RWORK(12) = HNEW
RWORK(13) = TN
IWORK(11) = NST
IWORK(12) = NFE
IWORK(13) = NJE
IWORK(14) = NQU
IWORK(15) = NEWQ
IWORK(19) = NLU
IWORK(20) = NNI
IWORK(21) = NCFN
IWORK(22) = NETF
RETURN
C-----------------------------------------------------------------------
C Block H.
C The following block handles all unsuccessful returns other than
C those for illegal input. First the error message routine is called.
C if there was an error test or convergence test failure, IMXER is set.
C Then Y is loaded from YH, T is set to TN, and the illegal input
C The optional output is loaded into the work arrays before returning.
C-----------------------------------------------------------------------
C The maximum number of steps was taken before reaching TOUT. ----------
500 MSG = 'SVODE-- At current T (=R1), MXSTEP (=I1) steps '
CALL XERRWV (MSG, 50, 201, 1, 0, 0, 0, 0, ZERO, ZERO)
MSG = ' taken on this call before reaching TOUT '
CALL XERRWV (MSG, 50, 201, 1, 1, MXSTEP, 0, 1, TN, ZERO)
ISTATE = -1
GO TO 580
C EWT(i) .le. 0.0 for some i (not at start of problem). ----------------
510 EWTI = RWORK(LEWT+I-1)
MSG = 'SVODE-- At T (=R1), EWT(I1) has become R2 .le. 0.'
CALL XERRWV (MSG, 50, 202, 1, 1, I, 0, 2, TN, EWTI)
ISTATE = -6
GO TO 580
C Too much accuracy requested for machine precision. -------------------
520 MSG = 'SVODE-- At T (=R1), too much accuracy requested '
CALL XERRWV (MSG, 50, 203, 1, 0, 0, 0, 0, ZERO, ZERO)
MSG = ' for precision of machine.. see TOLSF (=R2) '
CALL XERRWV (MSG, 50, 203, 1, 0, 0, 0, 2, TN, TOLSF)
RWORK(14) = TOLSF
ISTATE = -2
GO TO 580
C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. -----
530 MSG = 'SVODE-- At T(=R1) and step size H(=R2), the error'
CALL XERRWV (MSG, 50, 204, 1, 0, 0, 0, 0, ZERO, ZERO)
MSG = ' test failed repeatedly or with abs(H) = HMIN'
CALL XERRWV (MSG, 50, 204, 1, 0, 0, 0, 2, TN, H)
ISTATE = -4
GO TO 560
C KFLAG = -2. Convergence failed repeatedly or with abs(H) = HMIN. ----
540 MSG = 'SVODE-- At T (=R1) and step size H (=R2), the '
CALL XERRWV (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO)
MSG = ' corrector convergence failed repeatedly '
CALL XERRWV (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO)
MSG = ' or with abs(H) = HMIN '
CALL XERRWV (MSG, 30, 205, 1, 0, 0, 0, 2, TN, H)
ISTATE = -5
C Compute IMXER if relevant. -------------------------------------------
560 BIG = ZERO
IMXER = 1
DO 570 I = 1,N
SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1))
IF (BIG .GE. SIZE) GO TO 570
BIG = SIZE
IMXER = I
570 CONTINUE
IWORK(16) = IMXER
C Set Y vector, T, and optional output. --------------------------------
580 CONTINUE
CALL CH_SCOPY (N, RWORK(LYH), 1, Y, 1)
T = TN
RWORK(11) = HU
RWORK(12) = H
RWORK(13) = TN
IWORK(11) = NST
IWORK(12) = NFE
IWORK(13) = NJE
IWORK(14) = NQU
IWORK(15) = NQ
IWORK(19) = NLU
IWORK(20) = NNI
IWORK(21) = NCFN
IWORK(22) = NETF
RETURN
C-----------------------------------------------------------------------
C Block I.
C The following block handles all error returns due to illegal input
C (ISTATE = -3), as detected before calling the core integrator.
C First the error message routine is called. If the illegal input
C is a negative ISTATE, the run is aborted (apparent infinite loop).
C-----------------------------------------------------------------------
601 MSG = 'SVODE-- ISTATE (=I1) illegal '
CALL XERRWV (MSG, 30, 1, 1, 1, ISTATE, 0, 0, ZERO, ZERO)
IF (ISTATE .LT. 0) GO TO 800
GO TO 700
602 MSG = 'SVODE-- ITASK (=I1) illegal '
CALL XERRWV (MSG, 30, 2, 1, 1, ITASK, 0, 0, ZERO, ZERO)
GO TO 700
603 MSG='SVODE-- ISTATE (=I1) .gt. 1 but SVODE not initialized '
CALL XERRWV (MSG, 60, 3, 1, 1, ISTATE, 0, 0, ZERO, ZERO)
GO TO 700
604 MSG = 'SVODE-- NEQ (=I1) .lt. 1 '
CALL XERRWV (MSG, 30, 4, 1, 1, NEQ, 0, 0, ZERO, ZERO)
GO TO 700
605 MSG = 'SVODE-- ISTATE = 3 and NEQ increased (I1 to I2) '
CALL XERRWV (MSG, 50, 5, 1, 2, N, NEQ, 0, ZERO, ZERO)
GO TO 700
606 MSG = 'SVODE-- ITOL (=I1) illegal '
CALL XERRWV (MSG, 30, 6, 1, 1, ITOL, 0, 0, ZERO, ZERO)
GO TO 700
607 MSG = 'SVODE-- IOPT (=I1) illegal '
CALL XERRWV (MSG, 30, 7, 1, 1, IOPT, 0, 0, ZERO, ZERO)
GO TO 700
608 MSG = 'SVODE-- MF (=I1) illegal '
CALL XERRWV (MSG, 30, 8, 1, 1, MF, 0, 0, ZERO, ZERO)
GO TO 700
609 MSG = 'SVODE-- ML (=I1) illegal.. .lt.0 or .ge.NEQ (=I2)'
CALL XERRWV (MSG, 50, 9, 1, 2, ML, NEQ, 0, ZERO, ZERO)
GO TO 700
610 MSG = 'SVODE-- MU (=I1) illegal.. .lt.0 or .ge.NEQ (=I2)'
CALL XERRWV (MSG, 50, 10, 1, 2, MU, NEQ, 0, ZERO, ZERO)
GO TO 700
611 MSG = 'SVODE-- MAXORD (=I1) .lt. 0 '
CALL XERRWV (MSG, 30, 11, 1, 1, MAXORD, 0, 0, ZERO, ZERO)
GO TO 700
612 MSG = 'SVODE-- MXSTEP (=I1) .lt. 0 '
CALL XERRWV (MSG, 30, 12, 1, 1, MXSTEP, 0, 0, ZERO, ZERO)
GO TO 700
613 MSG = 'SVODE-- MXHNIL (=I1) .lt. 0 '
CALL XERRWV (MSG, 30, 13, 1, 1, MXHNIL, 0, 0, ZERO, ZERO)
GO TO 700
614 MSG = 'SVODE-- TOUT (=R1) behind T (=R2) '
CALL XERRWV (MSG, 40, 14, 1, 0, 0, 0, 2, TOUT, T)
MSG = ' integration direction is given by H0 (=R1) '
CALL XERRWV (MSG, 50, 14, 1, 0, 0, 0, 1, H0, ZERO)
GO TO 700
615 MSG = 'SVODE-- HMAX (=R1) .lt. 0.0 '
CALL XERRWV (MSG, 30, 15, 1, 0, 0, 0, 1, HMAX, ZERO)
GO TO 700
616 MSG = 'SVODE-- HMIN (=R1) .lt. 0.0 '
CALL XERRWV (MSG, 30, 16, 1, 0, 0, 0, 1, HMIN, ZERO)
GO TO 700
617 CONTINUE
MSG='SVODE-- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)'
CALL XERRWV (MSG, 60, 17, 1, 2, LENRW, LRW, 0, ZERO, ZERO)
GO TO 700
618 CONTINUE
MSG='SVODE-- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)'
CALL XERRWV (MSG, 60, 18, 1, 2, LENIW, LIW, 0, ZERO, ZERO)
GO TO 700
619 MSG = 'SVODE-- RTOL(I1) is R1 .lt. 0.0 '
CALL XERRWV (MSG, 40, 19, 1, 1, I, 0, 1, RTOLI, ZERO)
GO TO 700
620 MSG = 'SVODE-- ATOL(I1) is R1 .lt. 0.0 '
CALL XERRWV (MSG, 40, 20, 1, 1, I, 0, 1, ATOLI, ZERO)
GO TO 700
621 EWTI = RWORK(LEWT+I-1)
MSG = 'SVODE-- EWT(I1) is R1 .le. 0.0 '
CALL XERRWV (MSG, 40, 21, 1, 1, I, 0, 1, EWTI, ZERO)
GO TO 700
622 CONTINUE
MSG='SVODE-- TOUT (=R1) too close to T(=R2) to start integration'
CALL XERRWV (MSG, 60, 22, 1, 0, 0, 0, 2, TOUT, T)
GO TO 700
623 CONTINUE
MSG='SVODE-- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) '
CALL XERRWV (MSG, 60, 23, 1, 1, ITASK, 0, 2, TOUT, TP)
GO TO 700
624 CONTINUE
MSG='SVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) '
CALL XERRWV (MSG, 60, 24, 1, 0, 0, 0, 2, TCRIT, TN)
GO TO 700
625 CONTINUE
MSG='SVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) '
CALL XERRWV (MSG, 60, 25, 1, 0, 0, 0, 2, TCRIT, TOUT)
GO TO 700
626 MSG = 'SVODE-- At start of problem, too much accuracy '
CALL XERRWV (MSG, 50, 26, 1, 0, 0, 0, 0, ZERO, ZERO)
MSG=' requested for precision of machine.. see TOLSF (=R1) '
CALL XERRWV (MSG, 60, 26, 1, 0, 0, 0, 1, TOLSF, ZERO)
RWORK(14) = TOLSF
GO TO 700
627 MSG='SVODE-- Trouble from SVINDY. ITASK = I1, TOUT = R1. '
CALL XERRWV (MSG, 60, 27, 1, 1, ITASK, 0, 1, TOUT, ZERO)
C
700 CONTINUE
ISTATE = -3
RETURN
C
800 MSG = 'SVODE-- Run aborted.. apparent infinite loop '
CALL XERRWV (MSG, 50, 303, 2, 0, 0, 0, 0, ZERO, ZERO)
RETURN
END SUBROUTINE SVODE
C
C#######################################################################
C
CDECK SVHIN
C ###############################################################
SUBROUTINE SVHIN (N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND,
1 EWT, ITOL, ATOL, Y, TEMP, H0, NITER, IER, KMI, KINDEX)
C ###############################################################
EXTERNAL F
REAL T0, Y0, YDOT, RPAR, TOUT, UROUND, EWT, ATOL, Y,
1 TEMP, H0
INTEGER N, IPAR, ITOL, NITER, IER
DIMENSION Y0(*), YDOT(*), EWT(*), ATOL(*), Y(*),
1 TEMP(*), RPAR(*), IPAR(*)
INTEGER KMI, KINDEX
C-----------------------------------------------------------------------
C Call sequence input -- N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND,
C EWT, ITOL, ATOL, Y, TEMP
C Call sequence output -- H0, NITER, IER
C COMMON block variables accessed -- None
C
C Subroutines called by SVHIN.. F
C Function routines called by SVHIN.. SVNORM
C-----------------------------------------------------------------------
C This routine computes the step size, H0, to be attempted on the
C first step, when the user has not supplied a value for this.
C
C First we check that TOUT - T0 differs significantly from zero. Then
C an iteration is done to approximate the initial second derivative
C and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1.
C A bias factor of 1/2 is applied to the resulting h.
C The sign of H0 is inferred from the initial values of TOUT and T0.
C
C Communication with SVHIN is done with the following variables..
C
C N = Size of ODE system, input.
C T0 = Initial value of independent variable, input.
C Y0 = Vector of initial conditions, input.
C YDOT = Vector of initial first derivatives, input.
C F = Name of subroutine for right-hand side f(t,y), input.
C RPAR, IPAR = Dummy names for user's real and integer work arrays.
C TOUT = First output value of independent variable
C UROUND = Machine unit roundoff
C EWT, ITOL, ATOL = Error weights and tolerance parameters
C as described in the driver routine, input.
C Y, TEMP = Work arrays of length N.
C H0 = Step size to be attempted, output.
C NITER = Number of iterations (and of f evaluations) to compute H0,
C output.
C IER = The error flag, returned with the value
C IER = 0 if no trouble occurred, or
C IER = -1 if TOUT and T0 are considered too close to proceed.
C-----------------------------------------------------------------------
C
C Type declarations for local variables --------------------------------
C
REAL AFI, ATOLI, DELYI, HALF, HG, HLB, HNEW, HRAT,
1 HUB, HUN, PT1, T1, TDIST, TROUND, TWO, YDDNRM
INTEGER I, ITER
C
C Type declaration for function subroutines called ---------------------
C
REAL SVNORM
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this integrator.
C-----------------------------------------------------------------------
SAVE HALF, HUN, PT1, TWO
DATA HALF /0.5E0/, HUN /100.0E0/, PT1 /0.1E0/, TWO /2.0E0/
C
NITER = 0
TDIST = ABS(TOUT - T0)
TROUND = UROUND*MAX(ABS(T0),ABS(TOUT))
IF (TDIST .LT. TWO*TROUND) GO TO 100
C
C Set a lower bound on h based on the roundoff level in T0 and TOUT. ---
HLB = HUN*TROUND
C Set an upper bound on h based on TOUT-T0 and the initial Y and YDOT. -
HUB = PT1*TDIST
ATOLI = ATOL(1)
DO 10 I = 1, N
IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I)
DELYI = PT1*ABS(Y0(I)) + ATOLI
AFI = ABS(YDOT(I))
IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI
10 CONTINUE
C
C Set initial guess for h as geometric mean of upper and lower bounds. -
ITER = 0
HG = SQRT(HLB*HUB)
C If the bounds have crossed, exit with the mean value. ----------------
IF (HUB .LT. HLB) THEN
H0 = HG
GO TO 90
ENDIF
C
C Looping point for iteration. -----------------------------------------
50 CONTINUE
C Estimate the second derivative as a difference quotient in f. --------
T1 = T0 + HG
DO 60 I = 1, N
60 Y(I) = Y0(I) + HG*YDOT(I)
C
C*UPG*MNH
C
CALL F (N, T1, Y, TEMP, RPAR, IPAR, KMI, KINDEX)
C
C*UPG*MNH
C
DO 70 I = 1, N
70 TEMP(I) = (TEMP(I) - YDOT(I))/HG
YDDNRM = SVNORM (N, TEMP, EWT)
C Get the corresponding new value of h. --------------------------------
IF (YDDNRM*HUB*HUB .GT. TWO) THEN
HNEW = SQRT(TWO/YDDNRM)
ELSE
HNEW = SQRT(HG*HUB)
ENDIF
ITER = ITER + 1
C-----------------------------------------------------------------------
C Test the stopping conditions.
C Stop if the new and previous h values differ by a factor of .lt. 2.
C Stop if four iterations have been done. Also, stop with previous h
C if HNEW/HG .gt. 2 after first iteration, as this probably means that
C the second derivative value is bad because of cancellation error.
C-----------------------------------------------------------------------
IF (ITER .GE. 4) GO TO 80
HRAT = HNEW/HG
IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80
IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN
HNEW = HG
GO TO 80
ENDIF
HG = HNEW
GO TO 50
C
C Iteration done. Apply bounds, bias factor, and sign. Then exit. ----
80 H0 = HNEW*HALF
IF (H0 .LT. HLB) H0 = HLB
IF (H0 .GT. HUB) H0 = HUB
90 H0 = SIGN(H0, TOUT - T0)
NITER = ITER
IER = 0
RETURN
C Error return for TOUT - T0 too small. --------------------------------
100 IER = -1
RETURN
END SUBROUTINE SVHIN
C
C#######################################################################
C
CDECK SVINDY
C ##############################################
SUBROUTINE SVINDY (T, K, YH, LDYH, DKY, IFLAG)
C ##############################################
REAL T, YH, DKY
INTEGER K, LDYH, IFLAG
DIMENSION YH(LDYH,*), DKY(*)
C-----------------------------------------------------------------------
C Call sequence input -- T, K, YH, LDYH
C Call sequence output -- DKY, IFLAG
C COMMON block variables accessed..
C /SVOD01/ -- H, TN, UROUND, L, N, NQ
C /SVOD02/ -- HU
C
C Subroutines called by SVINDY.. SSCAL, XERRWV
C Function routines called by SVINDY.. None
C-----------------------------------------------------------------------
C SVINDY computes interpolated values of the K-th derivative of the
C dependent variable vector y, and stores it in DKY. This routine
C is called within the package with K = 0 and T = TOUT, but may
C also be called by the user for any K up to the current order.
C (See detailed instructions in the usage documentation.)
C-----------------------------------------------------------------------
C The computed values in DKY are gotten by interpolation using the
C Nordsieck history array YH. This array corresponds uniquely to a
C vector-valued polynomial of degree NQCUR or less, and DKY is set
C to the K-th derivative of this polynomial at T.
C The formula for DKY is..
C q
C DKY(i) = sum c(j,K) * (T - TN)**(j-K) * H**(-j) * YH(i,j+1)
C j=K
C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, TN = TCUR, H = HCUR.
C The quantities NQ = NQCUR, L = NQ+1, N, TN, and H are
C communicated by COMMON. The above sum is done in reverse order.
C IFLAG is returned negative if either K or T is out of bounds.
C
C Discussion above and comments in driver explain all variables.
C-----------------------------------------------------------------------
C
C Type declarations for labeled COMMON block SVOD01 --------------------
C
REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL,
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU, TQ, TN, UROUND
INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
4 NSLP, NYH
C
C Type declarations for labeled COMMON block SVOD02 --------------------
C
REAL HU
INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C
C Type declarations for local variables --------------------------------
C
REAL C, HUN, R, S, TFUZZ, TN1, TP, ZERO
INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1
CHARACTER*80 MSG
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this integrator.
C-----------------------------------------------------------------------
SAVE HUN, ZERO
C
COMMON /SVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13),
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU(13), TQ(5), TN, UROUND,
3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
7 NSLP, NYH
COMMON /SVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C
DATA HUN /100.0E0/, ZERO /0.0E0/
C
IFLAG = 0
IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80
TFUZZ = HUN*UROUND*(TN + HU)
TP = TN - HU - TFUZZ
TN1 = TN + TFUZZ
IF ((T-TP)*(T-TN1) .GT. ZERO) GO TO 90
C
S = (T - TN)/H
IC = 1
IF (K .EQ. 0) GO TO 15
JJ1 = L - K
DO 10 JJ = JJ1, NQ
10 IC = IC*JJ
15 C = REAL(IC)
DO 20 I = 1, N
20 DKY(I) = C*YH(I,L)
IF (K .EQ. NQ) GO TO 55
JB2 = NQ - K
DO 50 JB = 1, JB2
J = NQ - JB
JP1 = J + 1
IC = 1
IF (K .EQ. 0) GO TO 35
JJ1 = JP1 - K
DO 30 JJ = JJ1, J
30 IC = IC*JJ
35 C = REAL(IC)
DO 40 I = 1, N
40 DKY(I) = C*YH(I,JP1) + S*DKY(I)
50 CONTINUE
IF (K .EQ. 0) RETURN
55 R = H**(-K)
CALL SSCAL (N, R, DKY, 1)
RETURN
C
80 MSG = 'SVINDY-- K (=I1) illegal '
CALL XERRWV (MSG, 30, 51, 1, 1, K, 0, 0, ZERO, ZERO)
IFLAG = -1
RETURN
90 MSG = 'SVINDY-- T (=R1) illegal '
CALL XERRWV (MSG, 30, 52, 1, 0, 0, 0, 1, T, ZERO)
MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) '
CALL XERRWV (MSG, 60, 52, 1, 0, 0, 0, 2, TP, TN)
IFLAG = -2
RETURN
END SUBROUTINE SVINDY
c
C#######################################################################
C
CDECK SVSTEP
C
C ###########################################################
SUBROUTINE SVSTEP (Y, YH, LDYH, YH1, EWT, SAVF, VSAV, ACOR,
1 WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR, KMI, KINDEX)
C ###########################################################
C
EXTERNAL F, JAC, PSOL, VNLS
REAL Y, YH, YH1, EWT, SAVF, VSAV, ACOR, WM, RPAR
INTEGER LDYH, IWM, IPAR
DIMENSION Y(*), YH(LDYH,*), YH1(*), EWT(*), SAVF(*), VSAV(*),
1 ACOR(*), WM(*), IWM(*), RPAR(*), IPAR(*)
INTEGER KMI, KINDEX
C-----------------------------------------------------------------------
C Call sequence input -- Y, YH, LDYH, YH1, EWT, SAVF, VSAV,
C ACOR, WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR
C Call sequence output -- YH, ACOR, WM, IWM
C COMMON block variables accessed..
C /SVOD01/ ACNRM, EL(13), H, HMIN, HMXI, HNEW, HSCAL, RC, TAU(13),
C TQ(5), TN, JCUR, JSTART, KFLAG, KUTH,
C L, LMAX, MAXORD, MITER, N, NEWQ, NQ, NQWAIT
C /SVOD02/ HU, NCFN, NETF, NFE, NQU, NST
C
C Subroutines called by SVSTEP.. F, SAXPY, CH_SCOPY, SSCAL,
C SVJUST, VNLS, SVSET
C Function routines called by SVSTEP.. SVNORM
C-----------------------------------------------------------------------
C SVSTEP performs one step of the integration of an initial value
C problem for a system of ordinary differential equations.
C SVSTEP calls subroutine VNLS for the solution of the nonlinear system
C arising in the time step. Thus it is independent of the problem
C Jacobian structure and the type of nonlinear system solution method.
C SVSTEP returns a completion flag KFLAG (in COMMON).
C A return with KFLAG = -1 or -2 means either ABS(H) = HMIN or 10
C consecutive failures occurred. On a return with KFLAG negative,
C the values of TN and the YH array are as of the beginning of the last
C step, and H is the last step size attempted.
C
C Communication with SVSTEP is done with the following variables..
C
C Y = An array of length N used for the dependent variable vector.
C YH = An LDYH by LMAX array containing the dependent variables
C and their approximate scaled derivatives, where
C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate
C j-th derivative of y(i), scaled by H**j/factorial(j)
C (j = 0,1,...,NQ). On entry for the first step, the first
C two columns of YH must be set from the initial values.
C LDYH = A constant integer .ge. N, the first dimension of YH.
C N is the number of ODEs in the system.
C YH1 = A one-dimensional array occupying the same space as YH.
C EWT = An array of length N containing multiplicative weights
C for local error measurements. Local errors in y(i) are
C compared to 1.0/EWT(i) in various error tests.
C SAVF = An array of working storage, of length N.
C also used for input of YH(*,MAXORD+2) when JSTART = -1
C and MAXORD .lt. the current order NQ.
C VSAV = A work array of length N passed to subroutine VNLS.
C ACOR = A work array of length N, used for the accumulated
C corrections. On a successful return, ACOR(i) contains
C the estimated one-step local error in y(i).
C WM,IWM = Real and integer work arrays associated with matrix
C operations in VNLS.
C F = Dummy name for the user supplied subroutine for f.
C JAC = Dummy name for the user supplied Jacobian subroutine.
C PSOL = Dummy name for the subroutine passed to VNLS, for
C possible use there.
C VNLS = Dummy name for the nonlinear system solving subroutine,
C whose real name is dependent on the method used.
C RPAR, IPAR = Dummy names for user's real and integer work arrays.
C-----------------------------------------------------------------------
C
C Type declarations for labeled COMMON block SVOD01 --------------------
C
REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL,
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU, TQ, TN, UROUND
INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
4 NSLP, NYH
C
C Type declarations for labeled COMMON block SVOD02 --------------------
C
REAL HU
INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C
C Type declarations for local variables --------------------------------
C
REAL ADDON, BIAS1,BIAS2,BIAS3, CNQUOT, DDN, DSM, DUP,
1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF,
2 ETAQ, ETAQM1, ETAQP1, FLOTL, ONE, ONEPSM,
3 R, THRESH, TOLD, ZERO
INTEGER I, I1, I2, IBACK, J, JB, KFC, KFH, MXNCF, NCF, NFLAG
C
C Type declaration for function subroutines called ---------------------
C
REAL SVNORM
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this integrator.
C-----------------------------------------------------------------------
SAVE ADDON, BIAS1, BIAS2, BIAS3,
1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF,
2 KFC, KFH, MXNCF, ONEPSM, THRESH, ONE, ZERO
C-----------------------------------------------------------------------
COMMON /SVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13),
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU(13), TQ(5), TN, UROUND,
3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
7 NSLP, NYH
COMMON /SVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C
DATA KFC/-3/, KFH/-7/, MXNCF/10/
DATA ADDON /1.0E-6/, BIAS1 /6.0E0/, BIAS2 /6.0E0/,
1 BIAS3 /10.0E0/, ETACF /0.25E0/, ETAMIN /0.1E0/,
2 ETAMXF /0.2E0/, ETAMX1 /1.0E4/, ETAMX2 /10.0E0/,
3 ETAMX3 /10.0E0/, ONEPSM /1.00001E0/, THRESH /1.5E0/
DATA ONE/1.0E0/, ZERO/0.0E0/
C
KFLAG = 0
TOLD = TN
NCF = 0
JCUR = 0
NFLAG = 0
IF (JSTART .GT. 0) GO TO 20
IF (JSTART .EQ. -1) GO TO 100
C-----------------------------------------------------------------------
C On the first call, the order is set to 1, and other variables are
C initialized. ETAMAX is the maximum ratio by which H can be increased
C in a single step. It is normally 1.5, but is larger during the
C first 10 steps to compensate for the small initial H. If a failure
C occurs (in corrector convergence or error test), ETAMAX is set to 1
C for the next increase.
C-----------------------------------------------------------------------
LMAX = MAXORD + 1
NQ = 1
L = 2
NQNYH = NQ*LDYH
TAU(1) = H
PRL1 = ONE
RC = ZERO
ETAMAX = ETAMX1
NQWAIT = 2
HSCAL = H
GO TO 200
C-----------------------------------------------------------------------
C Take preliminary actions on a normal continuation step (JSTART.GT.0).
C If the driver changed H, then ETA must be reset and NEWH set to 1.
C If a change of order was dictated on the previous step, then
C it is done here and appropriate adjustments in the history are made.
C On an order decrease, the history array is adjusted by SVJUST.
C On an order increase, the history array is augmented by a column.
C On a change of step size H, the history array YH is rescaled.
C-----------------------------------------------------------------------
20 CONTINUE
IF (KUTH .EQ. 1) THEN
ETA = MIN(ETA,H/HSCAL)
NEWH = 1
ENDIF
50 IF (NEWH .EQ. 0) GO TO 200
IF (NEWQ .EQ. NQ) GO TO 150
IF (NEWQ .LT. NQ) THEN
CALL SVJUST (YH, LDYH, -1)
NQ = NEWQ
L = NQ + 1
NQWAIT = L
GO TO 150
ENDIF
IF (NEWQ .GT. NQ) THEN
CALL SVJUST (YH, LDYH, 1)
NQ = NEWQ
L = NQ + 1
NQWAIT = L
GO TO 150
ENDIF
C-----------------------------------------------------------------------
C The following block handles preliminaries needed when JSTART = -1.
C If N was reduced, zero out part of YH to avoid undefined references.
C If MAXORD was reduced to a value less than the tentative order NEWQ,
C then NQ is set to MAXORD, and a new H ratio ETA is chosen.
C Otherwise, we take the same preliminary actions as for JSTART .gt. 0.
C In any case, NQWAIT is reset to L = NQ + 1 to prevent further
C changes in order for that many steps.
C The new H ratio ETA is limited by the input H if KUTH = 1,
C by HMIN if KUTH = 0, and by HMXI in any case.
C Finally, the history array YH is rescaled.
C-----------------------------------------------------------------------
100 CONTINUE
LMAX = MAXORD + 1
IF (N .EQ. LDYH) GO TO 120
I1 = 1 + (NEWQ + 1)*LDYH
I2 = (MAXORD + 1)*LDYH
IF (I1 .GT. I2) GO TO 120
DO 110 I = I1, I2
110 YH1(I) = ZERO
120 IF (NEWQ .LE. MAXORD) GO TO 140
FLOTL = REAL(LMAX)
IF (MAXORD .LT. NQ-1) THEN
DDN = SVNORM (N, SAVF, EWT)/TQ(1)
ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON)
ENDIF
IF (MAXORD .EQ. NQ .AND. NEWQ .EQ. NQ+1) ETA = ETAQ
IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ+1) THEN
ETA = ETAQM1
CALL SVJUST (YH, LDYH, -1)
ENDIF
IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ) THEN
DDN = SVNORM (N, SAVF, EWT)/TQ(1)
ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON)
CALL SVJUST (YH, LDYH, -1)
ENDIF
ETA = MIN(ETA,ONE)
NQ = MAXORD
L = LMAX
140 IF (KUTH .EQ. 1) ETA = MIN(ETA,ABS(H/HSCAL))
IF (KUTH .EQ. 0) ETA = MAX(ETA,HMIN/ABS(HSCAL))
ETA = ETA/MAX(ONE,ABS(HSCAL)*HMXI*ETA)
NEWH = 1
NQWAIT = L
IF (NEWQ .LE. MAXORD) GO TO 50
C Rescale the history array for a change in H by a factor of ETA. ------
150 R = ONE
DO 180 J = 2, L
R = R*ETA
CALL SSCAL (N, R, YH(1,J), 1 )
180 CONTINUE
H = HSCAL*ETA
HSCAL = H
RC = RC*ETA
NQNYH = NQ*LDYH
C-----------------------------------------------------------------------
C This section computes the predicted values by effectively
C multiplying the YH array by the Pascal triangle matrix.
C SVSET is called to calculate all integration coefficients.
C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1.
C-----------------------------------------------------------------------
200 TN = TN + H
I1 = NQNYH + 1
DO 220 JB = 1, NQ
I1 = I1 - LDYH
DO 210 I = I1, NQNYH
210 YH1(I) = YH1(I) + YH1(I+LDYH)
220 CONTINUE
CALL SVSET
RL1 = ONE/EL(2)
RC = RC*(RL1/PRL1)
PRL1 = RL1
C
C Call the nonlinear system solver. ------------------------------------
C
CALL VNLS (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM,
1 F, JAC, PSOL, NFLAG, RPAR, IPAR, KMI, KINDEX)
C
IF (NFLAG .EQ. 0) GO TO 450
C-----------------------------------------------------------------------
C The VNLS routine failed to achieve convergence (NFLAG .NE. 0).
C The YH array is retracted to its values before prediction.
C The step size H is reduced and the step is retried, if possible.
C Otherwise, an error exit is taken.
C-----------------------------------------------------------------------
NCF = NCF + 1
NCFN = NCFN + 1
ETAMAX = ONE
TN = TOLD
I1 = NQNYH + 1
DO 430 JB = 1, NQ
I1 = I1 - LDYH
DO 420 I = I1, NQNYH
420 YH1(I) = YH1(I) - YH1(I+LDYH)
430 CONTINUE
IF (NFLAG .LT. -1) GO TO 680
IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 670
IF (NCF .EQ. MXNCF) GO TO 670
ETA = ETACF
ETA = MAX(ETA,HMIN/ABS(H))
NFLAG = -1
GO TO 150
C-----------------------------------------------------------------------
C The corrector has converged (NFLAG = 0). The local error test is
C made and control passes to statement 500 if it fails.
C-----------------------------------------------------------------------
450 CONTINUE
DSM = ACNRM/TQ(2)
IF (DSM .GT. ONE) GO TO 500
C-----------------------------------------------------------------------
C After a successful step, update the YH and TAU arrays and decrement
C NQWAIT. If NQWAIT is then 1 and NQ .lt. MAXORD, then ACOR is saved
C for use in a possible order increase on the next step.
C If ETAMAX = 1 (a failure occurred this step), keep NQWAIT .ge. 2.
C-----------------------------------------------------------------------
KFLAG = 0
NST = NST + 1
HU = H
NQU = NQ
DO 470 IBACK = 1, NQ
I = L - IBACK
470 TAU(I+1) = TAU(I)
TAU(1) = H
DO 480 J = 1, L
CALL SAXPY (N, EL(J), ACOR, 1, YH(1,J), 1 )
480 CONTINUE
NQWAIT = NQWAIT - 1
IF ((L .EQ. LMAX) .OR. (NQWAIT .NE. 1)) GO TO 490
CALL CH_SCOPY (N, ACOR, 1, YH(1,LMAX), 1 )
CONP = TQ(5)
490 IF (ETAMAX .NE. ONE) GO TO 560
IF (NQWAIT .LT. 2) NQWAIT = 2
NEWQ = NQ
NEWH = 0
ETA = ONE
HNEW = H
GO TO 690
C-----------------------------------------------------------------------
C The error test failed. KFLAG keeps track of multiple failures.
C Restore TN and the YH array to their previous values, and prepare
C to try the step again. Compute the optimum step size for the
C same order. After repeated failures, H is forced to decrease
C more rapidly.
C-----------------------------------------------------------------------
500 KFLAG = KFLAG - 1
NETF = NETF + 1
NFLAG = -2
TN = TOLD
I1 = NQNYH + 1
DO 520 JB = 1, NQ
I1 = I1 - LDYH
DO 510 I = I1, NQNYH
510 YH1(I) = YH1(I) - YH1(I+LDYH)
520 CONTINUE
IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 660
ETAMAX = ONE
IF (KFLAG .LE. KFC) GO TO 530
C Compute ratio of new H to current H at the current order. ------------
FLOTL = REAL(L)
ETA = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON)
ETA = MAX(ETA,HMIN/ABS(H),ETAMIN)
IF ((KFLAG .LE. -2) .AND. (ETA .GT. ETAMXF)) ETA = ETAMXF
GO TO 150
C-----------------------------------------------------------------------
C Control reaches this section if 3 or more consecutive failures
C have occurred. It is assumed that the elements of the YH array
C have accumulated errors of the wrong order. The order is reduced
C by one, if possible. Then H is reduced by a factor of 0.1 and
C the step is retried. After a total of 7 consecutive failures,
C an exit is taken with KFLAG = -1.
C-----------------------------------------------------------------------
530 IF (KFLAG .EQ. KFH) GO TO 660
IF (NQ .EQ. 1) GO TO 540
ETA = MAX(ETAMIN,HMIN/ABS(H))
CALL SVJUST (YH, LDYH, -1)
L = NQ
NQ = NQ - 1
NQWAIT = L
GO TO 150
540 ETA = MAX(ETAMIN,HMIN/ABS(H))
H = H*ETA
HSCAL = H
TAU(1) = H
C
C*UPG*MNH
C
CALL F (N, TN, Y, SAVF, RPAR, IPAR, KMI, KINDEX)
C
C*UPG*MNH
C
NFE = NFE + 1
DO 550 I = 1, N
550 YH(I,2) = H*SAVF(I)
NQWAIT = 10
GO TO 200
C-----------------------------------------------------------------------
C If NQWAIT = 0, an increase or decrease in order by one is considered.
C Factors ETAQ, ETAQM1, ETAQP1 are computed by which H could
C be multiplied at order q, q-1, or q+1, respectively.
C The largest of these is determined, and the new order and
C step size set accordingly.
C A change of H or NQ is made only if H increases by at least a
C factor of THRESH. If an order change is considered and rejected,
C then NQWAIT is set to 2 (reconsider it after 2 steps).
C-----------------------------------------------------------------------
C Compute ratio of new H to current H at the current order. ------------
560 FLOTL = REAL(L)
ETAQ = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON)
IF (NQWAIT .NE. 0) GO TO 600
NQWAIT = 2
ETAQM1 = ZERO
IF (NQ .EQ. 1) GO TO 570
C Compute ratio of new H to current H at the current order less one. ---
DDN = SVNORM (N, YH(1,L), EWT)/TQ(1)
ETAQM1 = ONE/((BIAS1*DDN)**(ONE/(FLOTL - ONE)) + ADDON)
570 ETAQP1 = ZERO
IF (L .EQ. LMAX) GO TO 580
C Compute ratio of new H to current H at current order plus one. -------
CNQUOT = (TQ(5)/CONP)*(H/TAU(2))**L
DO 575 I = 1, N
575 SAVF(I) = ACOR(I) - CNQUOT*YH(I,LMAX)
DUP = SVNORM (N, SAVF, EWT)/TQ(3)
ETAQP1 = ONE/((BIAS3*DUP)**(ONE/(FLOTL + ONE)) + ADDON)
580 IF (ETAQ .GE. ETAQP1) GO TO 590
IF (ETAQP1 .GT. ETAQM1) GO TO 620
GO TO 610
590 IF (ETAQ .LT. ETAQM1) GO TO 610
600 ETA = ETAQ
NEWQ = NQ
GO TO 630
610 ETA = ETAQM1
NEWQ = NQ - 1
GO TO 630
620 ETA = ETAQP1
NEWQ = NQ + 1
CALL CH_SCOPY (N, ACOR, 1, YH(1,LMAX), 1)
C Test tentative new H against THRESH, ETAMAX, and HMXI, then exit. ----
630 IF (ETA .LT. THRESH .OR. ETAMAX .EQ. ONE) GO TO 640
ETA = MIN(ETA,ETAMAX)
ETA = ETA/MAX(ONE,ABS(H)*HMXI*ETA)
NEWH = 1
HNEW = H*ETA
GO TO 690
640 NEWQ = NQ
NEWH = 0
ETA = ONE
HNEW = H
GO TO 690
C-----------------------------------------------------------------------
C All returns are made through this section.
C On a successful return, ETAMAX is reset and ACOR is scaled.
C-----------------------------------------------------------------------
660 KFLAG = -1
GO TO 720
670 KFLAG = -2
GO TO 720
680 IF (NFLAG .EQ. -2) KFLAG = -3
IF (NFLAG .EQ. -3) KFLAG = -4
GO TO 720
690 ETAMAX = ETAMX3
IF (NST .LE. 10) ETAMAX = ETAMX2
700 R = ONE/TQ(2)
CALL SSCAL (N, R, ACOR, 1)
720 JSTART = 1
RETURN
END SUBROUTINE SVSTEP
C#######################################################################
C
CDECK SVSET
C ################
SUBROUTINE SVSET
C ################
C-----------------------------------------------------------------------
C Call sequence communication.. None
C COMMON block variables accessed..
C /SVOD01/ -- EL(13), H, TAU(13), TQ(5), L(= NQ + 1),
C METH, NQ, NQWAIT
C
C Subroutines called by SVSET.. None
C Function routines called by SVSET.. None
C-----------------------------------------------------------------------
C SVSET is called by SVSTEP and sets coefficients for use there.
C
C For each order NQ, the coefficients in EL are calculated by use of
C the generating polynomial lambda(x), with coefficients EL(i).
C lambda(x) = EL(1) + EL(2)*x + ... + EL(NQ+1)*(x**NQ).
C For the backward differentiation formulas,
C NQ-1
C lambda(x) = (1 + x/xi*(NQ)) * product (1 + x/xi(i) ) .
C i = 1
C For the Adams formulas,
C NQ-1
C (d/dx) lambda(x) = c * product (1 + x/xi(i) ) ,
C i = 1
C lambda(-1) = 0, lambda(0) = 1,
C where c is a normalization constant.
C In both cases, xi(i) is defined by
C H*xi(i) = t sub n - t sub (n-i)
C = H + TAU(1) + TAU(2) + ... TAU(i-1).
C
C
C In addition to variables described previously, communication
C with SVSET uses the following..
C TAU = A vector of length 13 containing the past NQ values
C of H.
C EL = A vector of length 13 in which vset stores the
C coefficients for the corrector formula.
C TQ = A vector of length 5 in which vset stores constants
C used for the convergence test, the error test, and the
C selection of H at a new order.
C METH = The basic method indicator.
C NQ = The current order.
C L = NQ + 1, the length of the vector stored in EL, and
C the number of columns of the YH array being used.
C NQWAIT = A counter controlling the frequency of order changes.
C An order change is about to be considered if NQWAIT = 1.
C-----------------------------------------------------------------------
C
C Type declarations for labeled COMMON block SVOD01 --------------------
C
REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL,
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU, TQ, TN, UROUND
INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
4 NSLP, NYH
C
C Type declarations for local variables --------------------------------
C
REAL AHATN0, ALPH0, CNQM1, CORTES, CSUM, ELP, EM,
1 EM0, FLOTI, FLOTL, FLOTNQ, HSUM, ONE, RXI, RXIS, S, SIX,
2 T1, T2, T3, T4, T5, T6, TWO, XI, ZERO
INTEGER I, IBACK, J, JP1, NQM1, NQM2
C
DIMENSION EM(13)
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this integrator.
C-----------------------------------------------------------------------
SAVE CORTES, ONE, SIX, TWO, ZERO
C
COMMON /SVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13),
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU(13), TQ(5), TN, UROUND,
3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
7 NSLP, NYH
C
DATA CORTES /0.1E0/
DATA ONE /1.0E0/, SIX /6.0E0/, TWO /2.0E0/, ZERO /0.0E0/
C
FLOTL = REAL(L)
NQM1 = NQ - 1
NQM2 = NQ - 2
GO TO (100, 200), METH
C
C Set coefficients for Adams methods. ----------------------------------
100 IF (NQ .NE. 1) GO TO 110
EL(1) = ONE
EL(2) = ONE
TQ(1) = ONE
TQ(2) = TWO
TQ(3) = SIX*TQ(2)
TQ(5) = ONE
GO TO 300
110 HSUM = H
EM(1) = ONE
FLOTNQ = FLOTL - ONE
DO 115 I = 2, L
115 EM(I) = ZERO
DO 150 J = 1, NQM1
IF ((J .NE. NQM1) .OR. (NQWAIT .NE. 1)) GO TO 130
S = ONE
CSUM = ZERO
DO 120 I = 1, NQM1
CSUM = CSUM + S*EM(I)/REAL(I+1)
120 S = -S
TQ(1) = EM(NQM1)/(FLOTNQ*CSUM)
130 RXI = H/HSUM
DO 140 IBACK = 1, J
I = (J + 2) - IBACK
140 EM(I) = EM(I) + EM(I-1)*RXI
HSUM = HSUM + TAU(J)
150 CONTINUE
C Compute integral from -1 to 0 of polynomial and of x times it. -------
S = ONE
EM0 = ZERO
CSUM = ZERO
DO 160 I = 1, NQ
FLOTI = REAL(I)
EM0 = EM0 + S*EM(I)/FLOTI
CSUM = CSUM + S*EM(I)/(FLOTI+ONE)
160 S = -S
C In EL, form coefficients of normalized integrated polynomial. --------
S = ONE/EM0
EL(1) = ONE
DO 170 I = 1, NQ
170 EL(I+1) = S*EM(I)/REAL(I)
XI = HSUM/H
TQ(2) = XI*EM0/CSUM
TQ(5) = XI/EL(L)
IF (NQWAIT .NE. 1) GO TO 300
C For higher order control constant, multiply polynomial by 1+x/xi(q). -
RXI = ONE/XI
DO 180 IBACK = 1, NQ
I = (L + 1) - IBACK
180 EM(I) = EM(I) + EM(I-1)*RXI
C Compute integral of polynomial. --------------------------------------
S = ONE
CSUM = ZERO
DO 190 I = 1, L
CSUM = CSUM + S*EM(I)/REAL(I+1)
190 S = -S
TQ(3) = FLOTL*EM0/CSUM
GO TO 300
C
C Set coefficients for BDF methods. ------------------------------------
200 DO 210 I = 3, L
210 EL(I) = ZERO
EL(1) = ONE
EL(2) = ONE
ALPH0 = -ONE
AHATN0 = -ONE
HSUM = H
RXI = ONE
RXIS = ONE
IF (NQ .EQ. 1) GO TO 240
DO 230 J = 1, NQM2
C In EL, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------
HSUM = HSUM + TAU(J)
RXI = H/HSUM
JP1 = J + 1
ALPH0 = ALPH0 - ONE/REAL(JP1)
DO 220 IBACK = 1, JP1
I = (J + 3) - IBACK
220 EL(I) = EL(I) + EL(I-1)*RXI
230 CONTINUE
ALPH0 = ALPH0 - ONE/REAL(NQ)
RXIS = -EL(2) - ALPH0
HSUM = HSUM + TAU(NQM1)
RXI = H/HSUM
AHATN0 = -EL(2) - RXI
DO 235 IBACK = 1, NQ
I = (NQ + 2) - IBACK
235 EL(I) = EL(I) + EL(I-1)*RXIS
240 T1 = ONE - AHATN0 + ALPH0
T2 = ONE + REAL(NQ)*T1
TQ(2) = ABS(ALPH0*T2/T1)
TQ(5) = ABS(T2/(EL(L)*RXI/RXIS))
IF (NQWAIT .NE. 1) GO TO 300
CNQM1 = RXIS/EL(L)
T3 = ALPH0 + ONE/REAL(NQ)
T4 = AHATN0 + RXI
ELP = T3/(ONE - T4 + T3)
TQ(1) = ABS(ELP/CNQM1)
HSUM = HSUM + TAU(NQ)
RXI = H/HSUM
T5 = ALPH0 - ONE/REAL(NQ+1)
T6 = AHATN0 - RXI
ELP = T2/(ONE - T6 + T5)
TQ(3) = ABS(ELP*RXI*(FLOTL + ONE)*T5)
300 TQ(4) = CORTES*TQ(2)
RETURN
END
C#######################################################################
C
CDECK SVJUST
C ##################################
SUBROUTINE SVJUST (YH, LDYH, IORD)
C ##################################
REAL YH
INTEGER LDYH, IORD
DIMENSION YH(LDYH,*)
C-----------------------------------------------------------------------
C Call sequence input -- YH, LDYH, IORD
C Call sequence output -- YH
C COMMON block input -- NQ, METH, LMAX, HSCAL, TAU(13), N
C COMMON block variables accessed..
C /SVOD01/ -- HSCAL, TAU(13), LMAX, METH, N, NQ,
C
C Subroutines called by SVJUST.. SAXPY
C Function routines called by SVJUST.. None
C-----------------------------------------------------------------------
C This subroutine adjusts the YH array on reduction of order,
C and also when the order is increased for the stiff option (METH = 2).
C Communication with SVJUST uses the following..
C IORD = An integer flag used when METH = 2 to indicate an order
C increase (IORD = +1) or an order decrease (IORD = -1).
C HSCAL = Step size H used in scaling of Nordsieck array YH.
C (If IORD = +1, SVJUST assumes that HSCAL = TAU(1).)
C See References 1 and 2 for details.
C-----------------------------------------------------------------------
C
C Type declarations for labeled COMMON block SVOD01 --------------------
C
REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL,
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU, TQ, TN, UROUND
INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
4 NSLP, NYH
C
C Type declarations for local variables --------------------------------
C
REAL ALPH0, ALPH1, HSUM, ONE, PROD, T1, XI,XIOLD, ZERO
INTEGER I, IBACK, J, JP1, LP1, NQM1, NQM2, NQP1
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this integrator.
C-----------------------------------------------------------------------
SAVE ONE, ZERO
C
COMMON /SVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13),
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU(13), TQ(5), TN, UROUND,
3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
7 NSLP, NYH
C
DATA ONE /1.0E0/, ZERO /0.0E0/
C
IF ((NQ .EQ. 2) .AND. (IORD .NE. 1)) RETURN
NQM1 = NQ - 1
NQM2 = NQ - 2
GO TO (100, 200), METH
C-----------------------------------------------------------------------
C Nonstiff option...
C Check to see if the order is being increased or decreased.
C-----------------------------------------------------------------------
100 CONTINUE
IF (IORD .EQ. 1) GO TO 180
C Order decrease. ------------------------------------------------------
DO 110 J = 1, LMAX
110 EL(J) = ZERO
EL(2) = ONE
HSUM = ZERO
DO 130 J = 1, NQM2
C Construct coefficients of x*(x+xi(1))*...*(x+xi(j)). -----------------
HSUM = HSUM + TAU(J)
XI = HSUM/HSCAL
JP1 = J + 1
DO 120 IBACK = 1, JP1
I = (J + 3) - IBACK
120 EL(I) = EL(I)*XI + EL(I-1)
130 CONTINUE
C Construct coefficients of integrated polynomial. ---------------------
DO 140 J = 2, NQM1
140 EL(J+1) = REAL(NQ)*EL(J)/REAL(J)
C Subtract correction terms from YH array. -----------------------------
DO 170 J = 3, NQ
DO 160 I = 1, N
160 YH(I,J) = YH(I,J) - YH(I,L)*EL(J)
170 CONTINUE
RETURN
C Order increase. ------------------------------------------------------
C Zero out next column in YH array. ------------------------------------
180 CONTINUE
LP1 = L + 1
DO 190 I = 1, N
190 YH(I,LP1) = ZERO
RETURN
C-----------------------------------------------------------------------
C Stiff option...
C Check to see if the order is being increased or decreased.
C-----------------------------------------------------------------------
200 CONTINUE
IF (IORD .EQ. 1) GO TO 300
C Order decrease. ------------------------------------------------------
DO 210 J = 1, LMAX
210 EL(J) = ZERO
EL(3) = ONE
HSUM = ZERO
DO 230 J = 1,NQM2
C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). ---------------
HSUM = HSUM + TAU(J)
XI = HSUM/HSCAL
JP1 = J + 1
DO 220 IBACK = 1, JP1
I = (J + 4) - IBACK
220 EL(I) = EL(I)*XI + EL(I-1)
230 CONTINUE
C Subtract correction terms from YH array. -----------------------------
DO 250 J = 3,NQ
DO 240 I = 1, N
240 YH(I,J) = YH(I,J) - YH(I,L)*EL(J)
250 CONTINUE
RETURN
C Order increase. ------------------------------------------------------
300 DO 310 J = 1, LMAX
310 EL(J) = ZERO
EL(3) = ONE
ALPH0 = -ONE
ALPH1 = ONE
PROD = ONE
XIOLD = ONE
HSUM = HSCAL
IF (NQ .EQ. 1) GO TO 340
DO 330 J = 1, NQM1
C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). ---------------
JP1 = J + 1
HSUM = HSUM + TAU(JP1)
XI = HSUM/HSCAL
PROD = PROD*XI
ALPH0 = ALPH0 - ONE/REAL(JP1)
ALPH1 = ALPH1 + ONE/XI
DO 320 IBACK = 1, JP1
I = (J + 4) - IBACK
320 EL(I) = EL(I)*XIOLD + EL(I-1)
XIOLD = XI
330 CONTINUE
340 CONTINUE
T1 = (-ALPH0 - ALPH1)/PROD
C Load column L + 1 in YH array. ---------------------------------------
LP1 = L + 1
DO 350 I = 1, N
350 YH(I,LP1) = T1*YH(I,LMAX)
C Add correction terms to YH array. ------------------------------------
NQP1 = NQ + 1
DO 370 J = 3, NQP1
CALL SAXPY (N, EL(J), YH(1,LP1), 1, YH(1,J), 1 )
370 CONTINUE
RETURN
END SUBROUTINE SVJUST
C
C#######################################################################
C
CDECK SVNLSD
C ###############################################################
SUBROUTINE SVNLSD (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM,
1 F, JAC, PDUM, NFLAG, RPAR, IPAR, KMI, KINDEX)
C ###############################################################
EXTERNAL F, JAC, PDUM
REAL Y, YH, VSAV, SAVF, EWT, ACOR, WM, RPAR
INTEGER LDYH, IWM, NFLAG, IPAR
DIMENSION Y(*), YH(LDYH,*), VSAV(*), SAVF(*), EWT(*), ACOR(*),
1 IWM(*), WM(*), RPAR(*), IPAR(*)
INTEGER KMI,KINDEX
C-----------------------------------------------------------------------
C Call sequence input -- Y, YH, LDYH, SAVF, EWT, ACOR, IWM, WM,
C F, JAC, NFLAG, RPAR, IPAR
C Call sequence output -- YH, ACOR, WM, IWM, NFLAG
C COMMON block variables accessed..
C /SVOD01/ ACNRM, CRATE, DRC, H, RC, RL1, TQ(5), TN, ICF,
C JCUR, METH, MITER, N, NSLP
C /SVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C
C Subroutines called by SVNLSD.. F, SAXPY, CH_SCOPY, SSCAL, SVJAC, SVSOL
C Function routines called by SVNLSD.. SVNORM
C-----------------------------------------------------------------------
C Subroutine SVNLSD is a nonlinear system solver, which uses functional
C iteration or a chord (modified Newton) method. For the chord method
C direct linear algebraic system solvers are used. Subroutine SVNLSD
C then handles the corrector phase of this integration package.
C
C Communication with SVNLSD is done with the following variables. (For
C more details, please see the comments in the driver subroutine.)
C
C Y = The dependent variable, a vector of length N, input.
C YH = The Nordsieck (Taylor) array, LDYH by LMAX, input
C and output. On input, it contains predicted values.
C LDYH = A constant .ge. N, the first dimension of YH, input.
C VSAV = Unused work array.
C SAVF = A work array of length N.
C EWT = An error weight vector of length N, input.
C ACOR = A work array of length N, used for the accumulated
C corrections to the predicted y vector.
C WM,IWM = Real and integer work arrays associated with matrix
C operations in chord iteration (MITER .ne. 0).
C F = Dummy name for user supplied routine for f.
C JAC = Dummy name for user supplied Jacobian routine.
C PDUM = Unused dummy subroutine name. Included for uniformity
C over collection of integrators.
C NFLAG = Input/output flag, with values and meanings as follows..
C INPUT
C 0 first call for this time step.
C -1 convergence failure in previous call to SVNLSD.
C -2 error test failure in SVSTEP.
C OUTPUT
C 0 successful completion of nonlinear solver.
C -1 convergence failure or singular matrix.
C -2 unrecoverable error in matrix preprocessing
C (cannot occur here).
C -3 unrecoverable error in solution (cannot occur
C here).
C RPAR, IPAR = Dummy names for user's real and integer work arrays.
C
C IPUP = Own variable flag with values and meanings as follows..
C 0, do not update the Newton matrix.
C MITER .ne. 0, update Newton matrix, because it is the
C initial step, order was changed, the error
C test failed, or an update is indicated by
C the scalar RC or step counter NST.
C
C For more details, see comments in driver subroutine.
C-----------------------------------------------------------------------
C Type declarations for labeled COMMON block SVOD01 --------------------
C
REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL,
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU, TQ, TN, UROUND
INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
4 NSLP, NYH
C
C Type declarations for labeled COMMON block SVOD02 --------------------
C
REAL HU
INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C
C Type declarations for local variables --------------------------------
C
REAL CCMAX, CRDOWN, CSCALE, DCON, DEL, DELP, ONE,
1 RDIV, TWO, ZERO
INTEGER I, IERPJ, IERSL, M, MAXCOR, MSBP
C
C Type declaration for function subroutines called ---------------------
C
REAL SVNORM
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this integrator.
C-----------------------------------------------------------------------
SAVE CCMAX, CRDOWN, MAXCOR, MSBP, RDIV, ONE, TWO, ZERO
C
COMMON /SVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13),
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU(13), TQ(5), TN, UROUND,
3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
7 NSLP, NYH
COMMON /SVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C
DATA CCMAX /0.3E0/, CRDOWN /0.3E0/, MAXCOR /3/, MSBP /20/,
1 RDIV /2.0E0/
DATA ONE /1.0E0/, TWO /2.0E0/, ZERO /0.0E0/
C-----------------------------------------------------------------------
C On the first step, on a change of method order, or after a
C nonlinear convergence failure with NFLAG = -2, set IPUP = MITER
C to force a Jacobian update when MITER .ne. 0.
C-----------------------------------------------------------------------
IF (JSTART .EQ. 0) NSLP = 0
IF (NFLAG .EQ. 0) ICF = 0
IF (NFLAG .EQ. -2) IPUP = MITER
IF ( (JSTART .EQ. 0) .OR. (JSTART .EQ. -1) ) IPUP = MITER
C If this is functional iteration, set CRATE .eq. 1 and drop to 220
IF (MITER .EQ. 0) THEN
CRATE = ONE
GO TO 220
ENDIF
C-----------------------------------------------------------------------
C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1.
C When RC differs from 1 by more than CCMAX, IPUP is set to MITER
C to force SVJAC to be called, if a Jacobian is involved.
C In any case, SVJAC is called at least every MSBP steps.
C-----------------------------------------------------------------------
DRC = ABS(RC-ONE)
IF (DRC .GT. CCMAX .OR. NST .GE. NSLP+MSBP) IPUP = MITER
C-----------------------------------------------------------------------
C Up to MAXCOR corrector iterations are taken. A convergence test is
C made on the r.m.s. norm of each correction, weighted by the error
C weight vector EWT. The sum of the corrections is accumulated in the
C vector ACOR(i). The YH array is not altered in the corrector loop.
C-----------------------------------------------------------------------
220 M = 0
DELP = ZERO
CALL CH_SCOPY (N, YH(1,1), 1, Y, 1 )
C
C*UPG*MNH
C
CALL F (N, TN, Y, SAVF, RPAR, IPAR, KMI, KINDEX)
C
C*UPG*MNH
C
NFE = NFE + 1
IF (IPUP .LE. 0) GO TO 250
C-----------------------------------------------------------------------
C If indicated, the matrix P = I - h*rl1*J is reevaluated and
C preprocessed before starting the corrector iteration. IPUP is set
C to 0 as an indicator that this has been done.
C-----------------------------------------------------------------------
CALL SVJAC (Y, YH, LDYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, IERPJ,
1 RPAR, IPAR, KMI, KINDEX)
IPUP = 0
RC = ONE
DRC = ZERO
CRATE = ONE
NSLP = NST
C If matrix is singular, take error return to force cut in step size. --
IF (IERPJ .NE. 0) GO TO 430
250 DO 260 I = 1,N
260 ACOR(I) = ZERO
C This is a looping point for the corrector iteration. -----------------
270 IF (MITER .NE. 0) GO TO 350
C-----------------------------------------------------------------------
C In the case of functional iteration, update Y directly from
C the result of the last function evaluation.
C-----------------------------------------------------------------------
DO 280 I = 1,N
280 SAVF(I) = RL1*(H*SAVF(I) - YH(I,2))
DO 290 I = 1,N
290 Y(I) = SAVF(I) - ACOR(I)
DEL = SVNORM (N, Y, EWT)
DO 300 I = 1,N
300 Y(I) = YH(I,1) + SAVF(I)
CALL CH_SCOPY (N, SAVF, 1, ACOR, 1)
GO TO 400
C-----------------------------------------------------------------------
C In the case of the chord method, compute the corrector error,
C and solve the linear system with that as right-hand side and
C P as coefficient matrix. The correction is scaled by the factor
C 2/(1+RC) to account for changes in h*rl1 since the last SVJAC call.
C-----------------------------------------------------------------------
350 DO 360 I = 1,N
360 Y(I) = (RL1*H)*SAVF(I) - (RL1*YH(I,2) + ACOR(I))
CALL SVSOL (WM, IWM, Y, IERSL)
NNI = NNI + 1
IF (IERSL .GT. 0) GO TO 410
IF (METH .EQ. 2 .AND. RC .NE. ONE) THEN
CSCALE = TWO/(ONE + RC)
CALL SSCAL (N, CSCALE, Y, 1)
ENDIF
DEL = SVNORM (N, Y, EWT)
CALL SAXPY (N, ONE, Y, 1, ACOR, 1)
DO 380 I = 1,N
380 Y(I) = YH(I,1) + ACOR(I)
C-----------------------------------------------------------------------
C Test for convergence. If M .gt. 0, an estimate of the convergence
C rate constant is stored in CRATE, and this is used in the test.
C-----------------------------------------------------------------------
400 IF (M .NE. 0) CRATE = MAX(CRDOWN*CRATE,DEL/DELP)
DCON = DEL*MIN(ONE,CRATE)/TQ(4)
IF (DCON .LE. ONE) GO TO 450
M = M + 1
IF (M .EQ. MAXCOR) GO TO 410
IF (M .GE. 2 .AND. DEL .GT. RDIV*DELP) GO TO 410
DELP = DEL
C
C*UPG*MNH
C
CALL F (N, TN, Y, SAVF, RPAR, IPAR, KMI, KINDEX)
C
C*UPG*MNH
C
NFE = NFE + 1
GO TO 270
C
410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430
ICF = 1
IPUP = MITER
GO TO 220
C
430 CONTINUE
NFLAG = -1
ICF = 2
IPUP = MITER
RETURN
C
C Return for successful step. ------------------------------------------
450 NFLAG = 0
JCUR = 0
ICF = 0
IF (M .EQ. 0) ACNRM = DEL
IF (M .GT. 0) ACNRM = SVNORM (N, ACOR, EWT)
RETURN
END SUBROUTINE SVNLSD
C
C#######################################################################
C
CDECK SVJAC
C ################################################################
SUBROUTINE SVJAC (Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, F, JAC,
1 IERPJ, RPAR, IPAR, KMI, KINDEX)
C ################################################################
EXTERNAL F, JAC
REAL Y, YH, EWT, FTEM, SAVF, WM, RPAR
INTEGER LDYH, IWM, IERPJ, IPAR
DIMENSION Y(*), YH(LDYH,*), EWT(*), FTEM(*), SAVF(*),
1 WM(*), IWM(*), RPAR(*), IPAR(*)
INTEGER KMI, KINDEX
C-----------------------------------------------------------------------
C Call sequence input -- Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM,
C F, JAC, RPAR, IPAR
C Call sequence output -- WM, IWM, IERPJ
C COMMON block variables accessed..
C /SVOD01/ CCMXJ, DRC, H, RL1, TN, UROUND, ICF, JCUR, LOCJS,
C MSBJ, NSLJ
C /SVOD02/ NFE, NST, NJE, NLU
C
C Subroutines called by SVJAC.. F, JAC, SACOPY, CH_SCOPY, SGBFA, SGEFA,
C SSCAL
C Function routines called by SVJAC.. SVNORM
C-----------------------------------------------------------------------
C SVJAC is called by SVSTEP to compute and process the matrix
C P = I - h*rl1*J , where J is an approximation to the Jacobian.
C Here J is computed by the user-supplied routine JAC if
C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5.
C If MITER = 3, a diagonal approximation to J is used.
C If JSV = -1, J is computed from scratch in all cases.
C If JSV = 1 and MITER = 1, 2, 4, or 5, and if the saved value of J is
C considered acceptable, then P is constructed from the saved J.
C J is stored in wm and replaced by P. If MITER .ne. 3, P is then
C subjected to LU decomposition in preparation for later solution
C of linear systems with P as coefficient matrix. This is done
C by SGEFA if MITER = 1 or 2, and by SGBFA if MITER = 4 or 5.
C
C Communication with SVJAC is done with the following variables. (For
C more details, please see the comments in the driver subroutine.)
C Y = Vector containing predicted values on entry.
C YH = The Nordsieck array, an LDYH by LMAX array, input.
C LDYH = A constant .ge. N, the first dimension of YH, input.
C EWT = An error weight vector of length N.
C SAVF = Array containing f evaluated at predicted y, input.
C WM = Real work space for matrices. In the output, it containS
C the inverse diagonal matrix if MITER = 3 and the LU
C decomposition of P if MITER is 1, 2 , 4, or 5.
C Storage of matrix elements starts at WM(3).
C Storage of the saved Jacobian starts at WM(LOCJS).
C WM also contains the following matrix-related data..
C WM(1) = SQRT(UROUND), used in numerical Jacobian step.
C WM(2) = H*RL1, saved for later use if MITER = 3.
C IWM = Integer work space containing pivot information,
C starting at IWM(31), if MITER is 1, 2, 4, or 5.
C IWM also contains band parameters ML = IWM(1) and
C MU = IWM(2) if MITER is 4 or 5.
C F = Dummy name for the user supplied subroutine for f.
C JAC = Dummy name for the user supplied Jacobian subroutine.
C RPAR, IPAR = Dummy names for user's real and integer work arrays.
C RL1 = 1/EL(2) (input).
C IERPJ = Output error flag, = 0 if no trouble, 1 if the P
C matrix is found to be singular.
C JCUR = Output flag to indicate whether the Jacobian matrix
C (or approximation) is now current.
C JCUR = 0 means J is not current.
C JCUR = 1 means J is current.
C-----------------------------------------------------------------------
C
C Type declarations for labeled COMMON block SVOD01 --------------------
C
REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL,
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU, TQ, TN, UROUND
INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
4 NSLP, NYH
C
C Type declarations for labeled COMMON block SVOD02 --------------------
C
REAL HU
INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C
C Type declarations for local variables --------------------------------
C
REAL CON, DI, FAC, HRL1, ONE, PT1, R, R0, SRUR, THOU,
1 YI, YJ, YJJ, ZERO
INTEGER I, I1, I2, IER, II, J, J1, JJ, JOK, LENP, MBA, MBAND,
1 MEB1, MEBAND, ML, ML3, MU, NP1
C
C Type declaration for function subroutines called ---------------------
C
REAL SVNORM
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this subroutine.
C-----------------------------------------------------------------------
SAVE ONE, PT1, THOU, ZERO
C-----------------------------------------------------------------------
COMMON /SVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13),
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU(13), TQ(5), TN, UROUND,
3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
7 NSLP, NYH
COMMON /SVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST
C
DATA ONE /1.0E0/, THOU /1000.0E0/, ZERO /0.0E0/, PT1 /0.1E0/
C
IERPJ = 0
HRL1 = H*RL1
C See whether J should be evaluated (JOK = -1) or not (JOK = 1). -------
JOK = JSV
IF (JSV .EQ. 1) THEN
IF (NST .EQ. 0 .OR. NST .GT. NSLJ+MSBJ) JOK = -1
IF (ICF .EQ. 1 .AND. DRC .LT. CCMXJ) JOK = -1
IF (ICF .EQ. 2) JOK = -1
ENDIF
C End of setting JOK. --------------------------------------------------
C
IF (JOK .EQ. -1 .AND. MITER .EQ. 1) THEN
C If JOK = -1 and MITER = 1, call JAC to evaluate Jacobian. ------------
NJE = NJE + 1
NSLJ = NST
JCUR = 1
LENP = N*N
DO 110 I = 1,LENP
110 WM(I+2) = ZERO
C
C*UPG*MNH
C
CALL JAC (N, TN, Y, 0, 0, WM(3), N, RPAR, IPAR, KMI, KINDEX)
C
C*UPG*MNH
C
IF (JSV .EQ. 1) CALL CH_SCOPY (LENP, WM(3), 1, WM(LOCJS), 1)
ENDIF
C
IF (JOK .EQ. -1 .AND. MITER .EQ. 2) THEN
C If MITER = 2, make N calls to F to approximate the Jacobian. ---------
NJE = NJE + 1
NSLJ = NST
JCUR = 1
FAC = SVNORM (N, SAVF, EWT)
R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC
IF (R0 .EQ. ZERO) R0 = ONE
SRUR = WM(1)
J1 = 2
DO 230 J = 1,N
YJ = Y(J)
R = MAX(SRUR*ABS(YJ),R0/EWT(J))
Y(J) = Y(J) + R
FAC = ONE/R
C
C*UPG*MNH
C
CALL F (N, TN, Y, FTEM, RPAR, IPAR, KMI, KINDEX)
C
C*UPG*MNH
C
DO 220 I = 1,N
220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC
Y(J) = YJ
J1 = J1 + N
230 CONTINUE
NFE = NFE + N
LENP = N*N
IF (JSV .EQ. 1) CALL CH_SCOPY (LENP, WM(3), 1, WM(LOCJS), 1)
ENDIF
C
IF (JOK .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN
JCUR = 0
LENP = N*N
CALL CH_SCOPY (LENP, WM(LOCJS), 1, WM(3), 1)
ENDIF
C
IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN
C Multiply Jacobian by scalar, add identity, and do LU decomposition. --
CON = -HRL1
CALL SSCAL (LENP, CON, WM(3), 1)
J = 3
NP1 = N + 1
DO 250 I = 1,N
WM(J) = WM(J) + ONE
250 J = J + NP1
NLU = NLU + 1
CALL SGEFA (WM(3), N, N, IWM(31), IER)
IF (IER .NE. 0) IERPJ = 1
RETURN
ENDIF
C End of code block for MITER = 1 or 2. --------------------------------
C
IF (MITER .EQ. 3) THEN
C If MITER = 3, construct a diagonal approximation to J and P. ---------
NJE = NJE + 1
JCUR = 1
WM(2) = HRL1
R = RL1*PT1
DO 310 I = 1,N
310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2))
C
C*UPG*MNH
C
CALL F (N, TN, Y, WM(3), RPAR, IPAR, KMI, KINDEX)
C
C*UPG*MNH
C
NFE = NFE + 1
DO 320 I = 1,N
R0 = H*SAVF(I) - YH(I,2)
DI = PT1*R0 - H*(WM(I+2) - SAVF(I))
WM(I+2) = ONE
IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320
IF (ABS(DI) .EQ. ZERO) GO TO 330
WM(I+2) = PT1*R0/DI
320 CONTINUE
RETURN
330 IERPJ = 1
RETURN
ENDIF
C End of code block for MITER = 3. -------------------------------------
C
C Set constants for MITER = 4 or 5. ------------------------------------
ML = IWM(1)
MU = IWM(2)
ML3 = ML + 3
MBAND = ML + MU + 1
MEBAND = MBAND + ML
LENP = MEBAND*N
C
IF (JOK .EQ. -1 .AND. MITER .EQ. 4) THEN
C If JOK = -1 and MITER = 4, call JAC to evaluate Jacobian. ------------
NJE = NJE + 1
NSLJ = NST
JCUR = 1
DO 410 I = 1,LENP
410 WM(I+2) = ZERO
C
C*UPG*MNH
C
CALL JAC (N, TN, Y, ML, MU, WM(ML3), MEBAND, RPAR, IPAR,
1 KMI, KINDEX)
C
C*UPG*MNH
C
IF (JSV .EQ. 1)
1 CALL SACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND)
ENDIF
C
IF (JOK .EQ. -1 .AND. MITER .EQ. 5) THEN
C If MITER = 5, make N calls to F to approximate the Jacobian. ---------
NJE = NJE + 1
NSLJ = NST
JCUR = 1
MBA = MIN(MBAND,N)
MEB1 = MEBAND - 1
SRUR = WM(1)
FAC = SVNORM (N, SAVF, EWT)
R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC
IF (R0 .EQ. ZERO) R0 = ONE
DO 560 J = 1,MBA
DO 530 I = J,N,MBAND
YI = Y(I)
R = MAX(SRUR*ABS(YI),R0/EWT(I))
530 Y(I) = Y(I) + R
C
C*UPG*MNH
C
CALL F (N, TN, Y, FTEM, RPAR, IPAR, KMI, KINDEX)
C
C*UPG*MNH
C
DO 550 JJ = J,N,MBAND
Y(JJ) = YH(JJ,1)
YJJ = Y(JJ)
R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ))
FAC = ONE/R
I1 = MAX(JJ-MU,1)
I2 = MIN(JJ+ML,N)
II = JJ*MEB1 - ML + 2
DO 540 I = I1,I2
540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC
550 CONTINUE
560 CONTINUE
NFE = NFE + MBA
IF (JSV .EQ. 1)
1 CALL SACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND)
ENDIF
C
IF (JOK .EQ. 1) THEN
JCUR = 0
CALL SACOPY (MBAND, N, WM(LOCJS), MBAND, WM(ML3), MEBAND)
ENDIF
C
C Multiply Jacobian by scalar, add identity, and do LU decomposition.
CON = -HRL1
CALL SSCAL (LENP, CON, WM(3), 1 )
II = MBAND + 2
DO 580 I = 1,N
WM(II) = WM(II) + ONE
580 II = II + MEBAND
NLU = NLU + 1
CALL SGBFA (WM(3), MEBAND, N, ML, MU, IWM(31), IER)
IF (IER .NE. 0) IERPJ = 1
RETURN
C End of code block for MITER = 4 or 5. --------------------------------
C
END SUBROUTINE SVJAC
C
C#######################################################################
C
CDECK SACOPY
C ##################################################
SUBROUTINE SACOPY (NROW, NCOL, A, NROWA, B, NROWB)
C ##################################################
REAL A, B
INTEGER NROW, NCOL, NROWA, NROWB
DIMENSION A(NROWA,NCOL), B(NROWB,NCOL)
C-----------------------------------------------------------------------
C Call sequence input -- NROW, NCOL, A, NROWA, NROWB
C Call sequence output -- B
C COMMON block variables accessed -- None
C
C Subroutines called by SACOPY.. CH_SCOPY
C Function routines called by SACOPY.. None
C-----------------------------------------------------------------------
C This routine copies one rectangular array, A, to another, B,
C where A and B may have different row dimensions, NROWA and NROWB.
C The data copied consists of NROW rows and NCOL columns.
C-----------------------------------------------------------------------
INTEGER IC
C
DO 20 IC = 1,NCOL
CALL CH_SCOPY (NROW, A(1,IC), 1, B(1,IC), 1)
20 CONTINUE
C
RETURN
END SUBROUTINE SACOPY
C#######################################################################
C
CDECK SVSOL
C ####################################
SUBROUTINE SVSOL (WM, IWM, X, IERSL)
C ####################################
REAL WM, X
INTEGER IWM, IERSL
DIMENSION WM(*), IWM(*), X(*)
C-----------------------------------------------------------------------
C Call sequence input -- WM, IWM, X
C Call sequence output -- X, IERSL
C COMMON block variables accessed..
C /SVOD01/ -- H, RL1, MITER, N
C
C Subroutines called by SVSOL.. SGESL, SGBSL
C Function routines called by SVSOL.. None
C-----------------------------------------------------------------------
C This routine manages the solution of the linear system arising from
C a chord iteration. It is called if MITER .ne. 0.
C If MITER is 1 or 2, it calls SGESL to accomplish this.
C If MITER = 3 it updates the coefficient H*RL1 in the diagonal
C matrix, and then computes the solution.
C If MITER is 4 or 5, it calls SGBSL.
C Communication with SVSOL uses the following variables..
C WM = Real work space containing the inverse diagonal matrix if
C MITER = 3 and the LU decomposition of the matrix otherwise.
C Storage of matrix elements starts at WM(3).
C WM also contains the following matrix-related data..
C WM(1) = SQRT(UROUND) (not used here),
C WM(2) = HRL1, the previous value of H*RL1, used if MITER = 3.
C IWM = Integer work space containing pivot information, starting at
C IWM(31), if MITER is 1, 2, 4, or 5. IWM also contains band
C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5.
C X = The right-hand side vector on input, and the solution vector
C on output, of length N.
C IERSL = Output flag. IERSL = 0 if no trouble occurred.
C IERSL = 1 if a singular matrix arose with MITER = 3.
C-----------------------------------------------------------------------
C
C Type declarations for labeled COMMON block SVOD01 --------------------
C
REAL ACNRM, CCMXJ, CONP, CRATE, DRC, EL,
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU, TQ, TN, UROUND
INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
4 NSLP, NYH
C
C Type declarations for local variables --------------------------------
C
INTEGER I, MEBAND, ML, MU
REAL DI, HRL1, ONE, PHRL1, R, ZERO
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this integrator.
C-----------------------------------------------------------------------
SAVE ONE, ZERO
C
COMMON /SVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13),
1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1,
2 RC, RL1, TAU(13), TQ(5), TN, UROUND,
3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH,
4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM,
5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP,
6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ,
7 NSLP, NYH
C
DATA ONE /1.0E0/, ZERO /0.0E0/
C
IERSL = 0
GO TO (100, 100, 300, 400, 400), MITER
100 CALL SGESL (WM(3), N, N, IWM(31), X, 0)
RETURN
C
300 PHRL1 = WM(2)
HRL1 = H*RL1
WM(2) = HRL1
IF (HRL1 .EQ. PHRL1) GO TO 330
R = HRL1/PHRL1
DO 320 I = 1,N
DI = ONE - R*(ONE - ONE/WM(I+2))
IF (ABS(DI) .EQ. ZERO) GO TO 390
320 WM(I+2) = ONE/DI
C
330 DO 340 I = 1,N
340 X(I) = WM(I+2)*X(I)
RETURN
390 IERSL = 1
RETURN
C
400 ML = IWM(1)
MU = IWM(2)
MEBAND = 2*ML + MU + 1
CALL SGBSL (WM(3), MEBAND, N, ML, MU, IWM(31), X, 0)
RETURN
END SUBROUTINE SVSOL
C#######################################################################
C
CDECK SVSRCO
C ###################################
SUBROUTINE SVSRCO (RSAV, ISAV, JOB)
C ###################################
REAL RSAV
INTEGER ISAV, JOB
DIMENSION RSAV(*), ISAV(*)
C-----------------------------------------------------------------------
C Call sequence input -- RSAV, ISAV, JOB
C Call sequence output -- RSAV, ISAV
C COMMON block variables accessed -- All of /SVOD01/ and /SVOD02/
C
C Subroutines/functions called by SVSRCO.. None
C-----------------------------------------------------------------------
C This routine saves or restores (depending on JOB) the contents of the
C COMMON blocks SVOD01 and SVOD02, which are used internally by SVODE.
C
C RSAV = real array of length 49 or more.
C ISAV = integer array of length 41 or more.
C JOB = flag indicating to save or restore the COMMON blocks..
C JOB = 1 if COMMON is to be saved (written to RSAV/ISAV).
C JOB = 2 if COMMON is to be restored (read from RSAV/ISAV).
C A call with JOB = 2 presumes a prior call with JOB = 1.
C-----------------------------------------------------------------------
REAL RVOD1, RVOD2
INTEGER IVOD1, IVOD2
INTEGER I, LENIV1, LENIV2, LENRV1, LENRV2
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this integrator.
C-----------------------------------------------------------------------
SAVE LENRV1, LENIV1, LENRV2, LENIV2
C
COMMON /SVOD01/ RVOD1(48), IVOD1(33)
COMMON /SVOD02/ RVOD2(1), IVOD2(8)
DATA LENRV1/48/, LENIV1/33/, LENRV2/1/, LENIV2/8/
C
IF (JOB .EQ. 2) GO TO 100
DO 10 I = 1,LENRV1
10 RSAV(I) = RVOD1(I)
DO 15 I = 1,LENRV2
15 RSAV(LENRV1+I) = RVOD2(I)
C
DO 20 I = 1,LENIV1
20 ISAV(I) = IVOD1(I)
DO 25 I = 1,LENIV2
25 ISAV(LENIV1+I) = IVOD2(I)
C
RETURN
C
100 CONTINUE
DO 110 I = 1,LENRV1
110 RVOD1(I) = RSAV(I)
DO 115 I = 1,LENRV2
115 RVOD2(I) = RSAV(LENRV1+I)
C
DO 120 I = 1,LENIV1
120 IVOD1(I) = ISAV(I)
DO 125 I = 1,LENIV2
125 IVOD2(I) = ISAV(LENIV1+I)
C
RETURN
END SUBROUTINE SVSRCO
C#######################################################################
C
CDECK SEWSET
C ##################################################
SUBROUTINE SEWSET (N, ITOL, RTOL, ATOL, YCUR, EWT)
C ##################################################
REAL RTOL, ATOL, YCUR, EWT
INTEGER N, ITOL
DIMENSION RTOL(*), ATOL(*), YCUR(N), EWT(N)
C-----------------------------------------------------------------------
C Call sequence input -- N, ITOL, RTOL, ATOL, YCUR
C Call sequence output -- EWT
C COMMON block variables accessed -- None
C
C Subroutines/functions called by SEWSET.. None
C-----------------------------------------------------------------------
C This subroutine sets the error weight vector EWT according to
C EWT(i) = RTOL(i)*abs(YCUR(i)) + ATOL(i), i = 1,...,N,
C with the subscript on RTOL and/or ATOL possibly replaced by 1 above,
C depending on the value of ITOL.
C-----------------------------------------------------------------------
INTEGER I
C
GO TO (10, 20, 30, 40), ITOL
10 CONTINUE
DO 15 I = 1, N
15 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(1)
RETURN
20 CONTINUE
DO 25 I = 1, N
25 EWT(I) = RTOL(1)*ABS(YCUR(I)) + ATOL(I)
RETURN
30 CONTINUE
DO 35 I = 1, N
35 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(1)
RETURN
40 CONTINUE
DO 45 I = 1, N
45 EWT(I) = RTOL(I)*ABS(YCUR(I)) + ATOL(I)
RETURN
END SUBROUTINE SEWSET
C#######################################################################
C
CDECK SVNORM
C ##############################
FUNCTION SVNORM (N, V, W)
C ##############################
REAL SVNORM
REAL V, W
INTEGER N
DIMENSION V(N), W(N)
C-----------------------------------------------------------------------
C Call sequence input -- N, V, W
C Call sequence output -- None
C COMMON block variables accessed -- None
C
C Subroutines/functions called by SVNORM.. None
C-----------------------------------------------------------------------
C This function routine computes the weighted root-mean-square norm
C of the vector of length N contained in the array V, with weights
C contained in the array W of length N..
C SVNORM = sqrt( (1/N) * sum( V(i)*W(i) )**2 )
C-----------------------------------------------------------------------
REAL SUM
INTEGER I
C
SUM = 0.0E0
DO 10 I = 1, N
10 SUM = SUM + (V(I)*W(I))**2
SVNORM = SQRT(SUM/REAL(N))
RETURN
END
C#######################################################################
C
CDECK XERRWV
C ##################################################################
SUBROUTINE XERRWV (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2)
C ##################################################################
REAL R1, R2
INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR
C
CKS: changed to adapt to Fortran90
C CHARACTER*1 MSG(NMES)
CHARACTER*(*) MSG
C-----------------------------------------------------------------------
C Subroutines XERRWV, XSETF, XSETUN, and the two function routines
C MFLGSV and LUNSAV, as given here, constitute a simplified version of
C the SLATEC error handling package.
C Written by A. C. Hindmarsh and P. N. Brown at LLNL.
C Version of 13 April, 1989.
C This version is in single precision.
C
C All arguments are input arguments.
C
C MSG = The message (character array).
C NMES = The length of MSG (number of characters).
C NERR = The error number (not used).
C LEVEL = The error level..
C 0 or 1 means recoverable (control returns to caller).
C 2 means fatal (run is aborted--see note below).
C NI = Number of integers (0, 1, or 2) to be printed with message.
C I1,I2 = Integers to be printed, depending on NI.
C NR = Number of reals (0, 1, or 2) to be printed with message.
C R1,R2 = Reals to be printed, depending on NR.
C
C Note.. this routine is machine-dependent and specialized for use
C in limited context, in the following ways..
C 1. The argument MSG is assumed to be of type CHARACTER, and
C the message is printed with a format of (1X,80A1).
C 2. The message is assumed to take only one line.
C Multi-line messages are generated by repeated calls.
C 3. If LEVEL = 2, control passes to the statement STOP
C to abort the run. This statement may be machine-dependent.
C 4. R1 and R2 are assumed to be in single precision and are printed
C in E21.13 format.
C
C For a different default logical unit number, change the data
C statement in function routine LUNSAV.
C For a different run-abort command, change the statement following
C statement 100 at the end.
C-----------------------------------------------------------------------
C Subroutines called by XERRWV.. None
C Function routines called by XERRWV.. MFLGSV, LUNSAV
C-----------------------------------------------------------------------
C
INTEGER I, LUNIT, LUNSAV, MESFLG, MFLGSV
C
C Get message print flag and logical unit number. ----------------------
MESFLG = MFLGSV (0,.FALSE.)
LUNIT = LUNSAV (0,.FALSE.)
IF (MESFLG .EQ. 0) GO TO 100
C Write the message. ---------------------------------------------------
CKS: changed to adapt to Fortran90
C WRITE (LUNIT,10) (MSG(I),I=1,NMES)
C10 FORMAT(1X,80A1)
WRITE (LUNIT,'(A)') MSG
IF (NI .EQ. 1) WRITE (LUNIT, 20) I1
20 FORMAT(6X,'In above message, I1 =',I10)
IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2
30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10)
IF (NR .EQ. 1) WRITE (LUNIT, 40) R1
40 FORMAT(6X,'In above message, R1 =',E21.13)
IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2
50 FORMAT(6X,'In above, R1 =',E21.13,3X,'R2 =',E21.13)
C Abort the run if LEVEL = 2. ------------------------------------------
100 IF (LEVEL .NE. 2) RETURN
C callabortstop
CALL ABORT
STOP
END
C####################### End of Subroutine XERRWV ######################
C
CDECK XSETF
C ########################
SUBROUTINE XSETF (MFLAG)
C ########################
C-----------------------------------------------------------------------
C This routine resets the print control flag MFLAG.
C
C Subroutines called by XSETF.. None
C Function routines called by XSETF.. MFLGSV
C-----------------------------------------------------------------------
INTEGER MFLAG, JUNK, MFLGSV
C
IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = MFLGSV (MFLAG,.TRUE.)
RETURN
END
C####################### End of Subroutine XSETF #######################
C
CDECK XSETUN
C #######################
SUBROUTINE XSETUN (LUN)
C #######################
C-----------------------------------------------------------------------
C This routine resets the logical unit number for messages.
C
C Subroutines called by XSETUN.. None
C Function routines called by XSETUN.. LUNSAV
C-----------------------------------------------------------------------
INTEGER LUN, JUNK, LUNSAV
C
IF (LUN .GT. 0) JUNK = LUNSAV (LUN,.TRUE.)
RETURN
C----------------------- End of Subroutine XSETUN ----------------------
END
CDECK MFLGSV
C ##############################
FUNCTION MFLGSV (IVALUE, ISET)
C ##############################
INTEGER MFLGSV
LOGICAL ISET
INTEGER IVALUE
C-----------------------------------------------------------------------
C MFLGSV saves and recalls the parameter MESFLG which controls the
C printing of the error messages.
C
C Saved local variable..
C
C MESFLG = Print control flag..
C 1 means print all messages (the default).
C 0 means no printing.
C
C On input..
C
C IVALUE = The value to be set for the MESFLG parameter,
C if ISET is .TRUE. .
C
C ISET = Logical flag to indicate whether to read or write.
C If ISET=.TRUE., the MESFLG parameter will be given
C the value IVALUE. If ISET=.FALSE., the MESFLG
C parameter will be unchanged, and IVALUE is a dummy
C parameter.
C
C On return..
C
C The (old) value of the MESFLG parameter will be returned
C in the function value, MFLGSV.
C
C This is a modification of the SLATEC library routine J4SAVE.
C
C Subroutines/functions called by MFLGSV.. None
C-----------------------------------------------------------------------
INTEGER MESFLG
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this integrator.
C-----------------------------------------------------------------------
SAVE MESFLG
DATA MESFLG/1/
C
MFLGSV = MESFLG
IF (ISET) MESFLG = IVALUE
RETURN
C----------------------- End of Function MFLGSV ------------------------
END
CDECK LUNSAV
C ##############################
FUNCTION LUNSAV (IVALUE, ISET)
C ##############################
INTEGER LUNSAV
LOGICAL ISET
INTEGER IVALUE
C-----------------------------------------------------------------------
C LUNSAV saves and recalls the parameter LUNIT which is the logical
C unit number to which error messages are printed.
C
C Saved local variable..
C
C LUNIT = Logical unit number for messages.
C The default is 6 (machine-dependent).
C
C On input..
C
C IVALUE = The value to be set for the LUNIT parameter,
C if ISET is .TRUE. .
C
C ISET = Logical flag to indicate whether to read or write.
C If ISET=.TRUE., the LUNIT parameter will be given
C the value IVALUE. If ISET=.FALSE., the LUNIT
C parameter will be unchanged, and IVALUE is a dummy
C parameter.
C
C On return..
C
C The (old) value of the LUNIT parameter will be returned
C in the function value, LUNSAV.
C
C This is a modification of the SLATEC library routine J4SAVE.
C
C Subroutines/functions called by LUNSAV.. None
C-----------------------------------------------------------------------
INTEGER LUNIT
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this integrator.
C-----------------------------------------------------------------------
SAVE LUNIT
DATA LUNIT/6/
C
LUNSAV = LUNIT
IF (ISET) LUNIT = IVALUE
RETURN
C----------------------- End of Function LUNSAV ------------------------
END
subroutine ch_scopy(n,sx,incx,sy,incy)
c
c copies a vector, x, to a vector, y.
c uses unrolled loops for increments equal to 1.
c jack dongarra, linpack, 3/11/78.
c modified 12/3/93, array(1) declarations changed to array(*)
c modified 12/12/00 change name to avoid confusion with spline routine
c
real sx(*),sy(*)
integer i,incx,incy,ix,iy,m,mp1,n
c
if(n.le.0)return
if(incx.eq.1.and.incy.eq.1)go to 20
c
c code for unequal increments or equal increments
c not equal to 1
c
ix = 1
iy = 1
if(incx.lt.0)ix = (-n+1)*incx + 1
if(incy.lt.0)iy = (-n+1)*incy + 1
do 10 i = 1,n
sy(iy) = sx(ix)
ix = ix + incx
iy = iy + incy
10 continue
return
c
c code for both increments equal to 1
c
c
c clean-up loop
c
20 m = mod(n,7)
if( m .eq. 0 ) go to 40
do 30 i = 1,m
sy(i) = sx(i)
30 continue
if( n .lt. 7 ) return
40 mp1 = m + 1
do 50 i = mp1,n,7
sy(i) = sx(i)
sy(i + 1) = sx(i + 1)
sy(i + 2) = sx(i + 2)
sy(i + 3) = sx(i + 3)
sy(i + 4) = sx(i + 4)
sy(i + 5) = sx(i + 5)
sy(i + 6) = sx(i + 6)
50 continue
return
end
subroutine sscal(n,sa,sx,incx)
c
c scales a vector by a constant.
c uses unrolled loops for increment equal to 1.
c jack dongarra, linpack, 3/11/78.
c modified 3/93 to return if incx .le. 0.
c modified 12/3/93, array(1) declarations changed to array(*)
c
real sa,sx(*)
integer i,incx,m,mp1,n,nincx
c
if( n.le.0 .or. incx.le.0 )return
if(incx.eq.1)go to 20
c
c code for increment not equal to 1
c
nincx = n*incx
do 10 i = 1,nincx,incx
sx(i) = sa*sx(i)
10 continue
return
c
c code for increment equal to 1
c
c
c clean-up loop
c
20 m = mod(n,5)
if( m .eq. 0 ) go to 40
do 30 i = 1,m
sx(i) = sa*sx(i)
30 continue
if( n .lt. 5 ) return
40 mp1 = m + 1
do 50 i = mp1,n,5
sx(i) = sa*sx(i)
sx(i + 1) = sa*sx(i + 1)
sx(i + 2) = sa*sx(i + 2)
sx(i + 3) = sa*sx(i + 3)
sx(i + 4) = sa*sx(i + 4)
50 continue
return
end
subroutine sgefa(a,lda,n,ipvt,info)
integer lda,n,ipvt(1),info
real a(lda,1)
c
c sgefa factors a real matrix by gaussian elimination.
c
c sgefa is usually called by sgeco, but it can be called
c directly with a saving in time if rcond is not needed.
c (time for sgeco) = (1 + 9/n)*(time for sgefa) .
c
c on entry
c
c a real(lda, n)
c the matrix to be factored.
c
c lda integer
c the leading dimension of the array a .
c
c n integer
c the order of the matrix a .
c
c on return
c
c a an upper triangular matrix and the multipliers
c which were used to obtain it.
c the factorization can be written a = l*u where
c l is a product of permutation and unit lower
c triangular matrices and u is upper triangular.
c
c ipvt integer(n)
c an integer vector of pivot indices.
c
c info integer
c = 0 normal value.
c = k if u(k,k) .eq. 0.0 . this is not an error
c condition for this subroutine, but it does
c indicate that sgesl or sgedi will divide by zero
c if called. use rcond in sgeco for a reliable
c indication of singularity.
c
c linpack. this version dated 08/14/78 .
c cleve moler, university of new mexico, argonne national lab.
c
c subroutines and functions
c
c blas saxpy,sscal,isamax
c
c internal variables
c
real t
integer isamax,j,k,kp1,l,nm1
c
c
c gaussian elimination with partial pivoting
c
info = 0
nm1 = n - 1
if (nm1 .lt. 1) go to 70
do 60 k = 1, nm1
kp1 = k + 1
c
c find l = pivot index
c
l = isamax(n-k+1,a(k,k),1) + k - 1
ipvt(k) = l
c
c zero pivot implies this column already triangularized
c
if (a(l,k) .eq. 0.0e0) go to 40
c
c interchange if necessary
c
if (l .eq. k) go to 10
t = a(l,k)
a(l,k) = a(k,k)
a(k,k) = t
10 continue
c
c compute multipliers
c
t = -1.0e0/a(k,k)
call sscal(n-k,t,a(k+1,k),1)
c
c row elimination with column indexing
c
do 30 j = kp1, n
t = a(l,j)
if (l .eq. k) go to 20
a(l,j) = a(k,j)
a(k,j) = t
20 continue
call saxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
30 continue
go to 50
40 continue
info = k
50 continue
60 continue
70 continue
ipvt(n) = n
if (a(n,n) .eq. 0.0e0) info = n
return
end
subroutine sgbfa(abd,lda,n,ml,mu,ipvt,info)
integer lda,n,ml,mu,ipvt(1),info
real abd(lda,1)
c
c sgbfa factors a real band matrix by elimination.
c
c sgbfa is usually called by sgbco, but it can be called
c directly with a saving in time if rcond is not needed.
c
c on entry
c
c abd real(lda, n)
c contains the matrix in band storage. the columns
c of the matrix are stored in the columns of abd and
c the diagonals of the matrix are stored in rows
c ml+1 through 2*ml+mu+1 of abd .
c see the comments below for details.
c
c lda integer
c the leading dimension of the array abd .
c lda must be .ge. 2*ml + mu + 1 .
c
c n integer
c the order of the original matrix.
c
c ml integer
c number of diagonals below the main diagonal.
c 0 .le. ml .lt. n .
c
c mu integer
c number of diagonals above the main diagonal.
c 0 .le. mu .lt. n .
c more efficient if ml .le. mu .
c on return
c
c abd an upper triangular matrix in band storage and
c the multipliers which were used to obtain it.
c the factorization can be written a = l*u where
c l is a product of permutation and unit lower
c triangular matrices and u is upper triangular.
c
c ipvt integer(n)
c an integer vector of pivot indices.
c
c info integer
c = 0 normal value.
c = k if u(k,k) .eq. 0.0 . this is not an error
c condition for this subroutine, but it does
c indicate that sgbsl will divide by zero if
c called. use rcond in sgbco for a reliable
c indication of singularity.
c
c band storage
c
c if a is a band matrix, the following program segment
c will set up the input.
c
c ml = (band width below the diagonal)
c mu = (band width above the diagonal)
c m = ml + mu + 1
c do 20 j = 1, n
c i1 = max0(1, j-mu)
c i2 = min0(n, j+ml)
c do 10 i = i1, i2
c k = i - j + m
c abd(k,j) = a(i,j)
c 10 continue
c 20 continue
c
c this uses rows ml+1 through 2*ml+mu+1 of abd .
c in addition, the first ml rows in abd are used for
c elements generated during the triangularization.
c the total number of rows needed in abd is 2*ml+mu+1 .
c the ml+mu by ml+mu upper left triangle and the
c ml by ml lower right triangle are not referenced.
c
c linpack. this version dated 08/14/78 .
c cleve moler, university of new mexico, argonne national lab.
c
c subroutines and functions
c
c blas saxpy,sscal,isamax
c fortran max0,min0
c
c internal variables
c
real t
integer i,isamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1
c
c
m = ml + mu + 1
info = 0
c
c zero initial fill-in columns
c
j0 = mu + 2
j1 = min0(n,m) - 1
if (j1 .lt. j0) go to 30
do 20 jz = j0, j1
i0 = m + 1 - jz
do 10 i = i0, ml
abd(i,jz) = 0.0e0
10 continue
20 continue
30 continue
jz = j1
ju = 0
c
c gaussian elimination with partial pivoting
c
nm1 = n - 1
if (nm1 .lt. 1) go to 130
do 120 k = 1, nm1
kp1 = k + 1
c
c zero next fill-in column
c
jz = jz + 1
if (jz .gt. n) go to 50
if (ml .lt. 1) go to 50
do 40 i = 1, ml
abd(i,jz) = 0.0e0
40 continue
50 continue
c
c find l = pivot index
c
lm = min0(ml,n-k)
l = isamax(lm+1,abd(m,k),1) + m - 1
ipvt(k) = l + k - m
c
c zero pivot implies this column already triangularized
c
if (abd(l,k) .eq. 0.0e0) go to 100
c
c interchange if necessary
c
if (l .eq. m) go to 60
t = abd(l,k)
abd(l,k) = abd(m,k)
abd(m,k) = t
60 continue
c
c compute multipliers
c
t = -1.0e0/abd(m,k)
call sscal(lm,t,abd(m+1,k),1)
c
c row elimination with column indexing
c
ju = min0(max0(ju,mu+ipvt(k)),n)
mm = m
if (ju .lt. kp1) go to 90
do 80 j = kp1, ju
l = l - 1
mm = mm - 1
t = abd(l,j)
if (l .eq. mm) go to 70
abd(l,j) = abd(mm,j)
abd(mm,j) = t
70 continue
call saxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1)
80 continue
90 continue
go to 110
100 continue
info = k
110 continue
120 continue
130 continue
ipvt(n) = n
if (abd(m,n) .eq. 0.0e0) info = n
return
end
subroutine sgbsl(abd,lda,n,ml,mu,ipvt,b,job)
integer lda,n,ml,mu,ipvt(1),job
real abd(lda,1),b(1)
c
c sgbsl solves the real band system
c a * x = b or trans(a) * x = b
c using the factors computed by sgbco or sgbfa.
c
c on entry
c
c abd real(lda, n)
c the output from sgbco or sgbfa.
c
c lda integer
c the leading dimension of the array abd .
c
c n integer
c the order of the original matrix.
c
c ml integer
c number of diagonals below the main diagonal.
c
c mu integer
c number of diagonals above the main diagonal.
c
c ipvt integer(n)
c the pivot vector from sgbco or sgbfa.
c
c b real(n)
c the right hand side vector.
c
c job integer
c = 0 to solve a*x = b ,
c = nonzero to solve trans(a)*x = b , where
c trans(a) is the transpose.
c
c on return
c
c b the solution vector x .
c
c error condition
c
c a division by zero will occur if the input factor contains a
c zero on the diagonal. technically this indicates singularity
c but it is often caused by improper arguments or improper
c setting of lda . it will not occur if the subroutines are
c called correctly and if sgbco has set rcond .gt. 0.0
c or sgbfa has set info .eq. 0 .
c
c to compute inverse(a) * c where c is a matrix
c with p columns
c call sgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
c if (rcond is too small) go to ...
c do 10 j = 1, p
c call sgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0)
c 10 continue
c
c linpack. this version dated 08/14/78 .
c cleve moler, university of new mexico, argonne national lab.
c
c subroutines and functions
c
c blas saxpy,sdot
c fortran min0
c
c internal variables
c
real sdot,t
integer k,kb,l,la,lb,lm,m,nm1
c
m = mu + ml + 1
nm1 = n - 1
if (job .ne. 0) go to 50
c
c job = 0 , solve a * x = b
c first solve l*y = b
c
if (ml .eq. 0) go to 30
if (nm1 .lt. 1) go to 30
do 20 k = 1, nm1
lm = min0(ml,n-k)
l = ipvt(k)
t = b(l)
if (l .eq. k) go to 10
b(l) = b(k)
b(k) = t
10 continue
call saxpy(lm,t,abd(m+1,k),1,b(k+1),1)
20 continue
30 continue
c
c now solve u*x = y
c
do 40 kb = 1, n
k = n + 1 - kb
b(k) = b(k)/abd(m,k)
lm = min0(k,m) - 1
la = m - lm
lb = k - lm
t = -b(k)
call saxpy(lm,t,abd(la,k),1,b(lb),1)
40 continue
go to 100
50 continue
c
c job = nonzero, solve trans(a) * x = b
c first solve trans(u)*y = b
c
do 60 k = 1, n
lm = min0(k,m) - 1
la = m - lm
lb = k - lm
t = sdot(lm,abd(la,k),1,b(lb),1)
b(k) = (b(k) - t)/abd(m,k)
60 continue
c
c now solve trans(l)*x = y
c
if (ml .eq. 0) go to 90
if (nm1 .lt. 1) go to 90
do 80 kb = 1, nm1
k = n - kb
lm = min0(ml,n-k)
b(k) = b(k) + sdot(lm,abd(m+1,k),1,b(k+1),1)
l = ipvt(k)
if (l .eq. k) go to 70
t = b(l)
b(l) = b(k)
b(k) = t
70 continue
80 continue
90 continue
100 continue
return
end
function sdot(n,sx,incx,sy,incy)
c
c forms the dot product of two vectors.
c uses unrolled loops for increments equal to one.
c jack dongarra, linpack, 3/11/78.
c modified 12/3/93, array(1) declarations changed to array(*)
c
real sdot
real sx(*),sy(*),stemp
integer i,incx,incy,ix,iy,m,mp1,n
c
stemp = 0.0e0
sdot = 0.0e0
if(n.le.0)return
if(incx.eq.1.and.incy.eq.1)go to 20
c
c code for unequal increments or equal increments
c not equal to 1
c
ix = 1
iy = 1
if(incx.lt.0)ix = (-n+1)*incx + 1
if(incy.lt.0)iy = (-n+1)*incy + 1
do 10 i = 1,n
stemp = stemp + sx(ix)*sy(iy)
ix = ix + incx
iy = iy + incy
10 continue
sdot = stemp
return
c
c code for both increments equal to 1
c
c
c clean-up loop
c
20 m = mod(n,5)
if( m .eq. 0 ) go to 40
do 30 i = 1,m
stemp = stemp + sx(i)*sy(i)
30 continue
if( n .lt. 5 ) go to 60
40 mp1 = m + 1
do 50 i = mp1,n,5
stemp = stemp + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) +
* sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4)
50 continue
60 sdot = stemp
return
end
function isamax(n,sx,incx)
c
c finds the index of element having max. absolute value.
c jack dongarra, linpack, 3/11/78.
c modified 3/93 to return if incx .le. 0.
c modified 12/3/93, array(1) declarations changed to array(*)
c
integer isamax
real sx(*),smax
integer i,incx,ix,n
c
isamax = 0
if( n.lt.1 .or. incx.le.0 ) return
isamax = 1
if(n.eq.1)return
if(incx.eq.1)go to 20
c
c code for increment not equal to 1
c
ix = 1
smax = abs(sx(1))
ix = ix + incx
do 10 i = 2,n
if(abs(sx(ix)).le.smax) go to 5
isamax = i
smax = abs(sx(ix))
5 ix = ix + incx
10 continue
return
c
c code for increment equal to 1
c
20 smax = abs(sx(1))
do 30 i = 2,n
if(abs(sx(i)).le.smax) go to 30
isamax = i
smax = abs(sx(i))
30 continue
return
end
*======= BEGIN of TUV 5.3.1 =======*
* M.LERICHE Update Feb. 2018
CCC FILE TUV.f
*----------------------------------------------------------------------------
subroutine tuvmain (asza, idate,
+ albnew, dobnew,
+ nlevel, zin, lwc,
+ njout, jout, jlabelout,
+ kout )
*-----------------------------------------------------------------------------*
*= Tropospheric Ultraviolet-Visible (TUV) radiation model =*
*= Version 5.3 =*
*= June 2016 =*
*-----------------------------------------------------------------------------*
*= Developed by Sasha Madronich with important contributions from: =*
*= Chris Fischer, Siri Flocke, Julia Lee-Taylor, Bernhard Meyer, =*
*= Irina Petropavlovskikh, Xuexi Tie, and Jun Zen. =*
*= Special thanks to Knut Stamnes and co-workers for the development of the =*
*= Discrete Ordinates code, and to Warren Wiscombe and co-workers for the =*
*= development of the solar zenith angle subroutine. Citations for the many =*
*= data bases (e.g. extraterrestrial irradiances, molecular spectra) may be =*
*= found in the data files headers and/or in the subroutines that read them. =*
*= To contact the author, write to: =*
*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
*= send email to: sasha@ucar.edu or tuv@acd.ucar.edu =*
*-----------------------------------------------------------------------------*
*= This program is free software; you can redistribute it and/or modify =*
*= it under the terms of the GNU General Public License as published by the =*
*= Free Software Foundation; either version 2 of the license, or (at your =*
*= option) any later version. =*
*= The TUV package is distributed in the hope that it will be useful, but =*
*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
*= License for more details. =*
*= To obtain a copy of the GNU General Public License, write to: =*
*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
*-----------------------------------------------------------------------------*
*= Copyright (C) 1994-2016 by the University Corporation for Atmospheric =*
*= Research, extending to all called subroutines, functions, and data unless =*
*= another source is specified. =*
*-----------------------------------------------------------------------------*
*= Adapted to MesoNH : ONLY JVALUES are computed
IMPLICIT NONE
SAVE
* Include parameter file
c INCLUDE 'params'
*
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
*_________________________________________________
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* More physical constants:
*_________________________________________________________________
* Na = 6.022142E23 mol-1 = Avogadro constant
* kb = 1.38065E-23 J K-1 = Boltzmann constant
* R = 8.31447 J mol-1 K-1 = molar gas constant
* h = 6.626068E-34 J s = Planck constant
* c = 2.99792458E8 m s-1 = speed of light in vacuum
* G = 6.673E-11 m3 kg-1 s-2 = Netwonian constant of gravitation
* sb = 5.67040E-8 W m-2 K-4 = Stefan-Boltzmann constant
*_________________________________________________________________
* (1) From NIST Reference on Constants, Units, and Uncertainty
* http://physics.nist.gov/cuu/index.html Oct. 2001.
* (2) These constants are not assigned to variable names; in other
* words this is not Fortran code, but only a text table for quick
* reference. To use, you must declare a variable name/type and
* assign the value to that variable. Or assign as parameter (see
* example for pi above).
* Wavelength grid:
INTEGER nw, iw, nwint
REAL wl(kw), wc(kw), wu(kw)
REAL wstart, wstop
* Altitude grid
INTEGER nz, nzm1, iz, izout
REAL z(kz), zstart, zstop, zout
* Solar zenith angle and azimuth
* slant pathlengths in spherical geometry
REAL sza, zen
INTEGER nid(0:kz)
REAL dsdh(0:kz,kz)
* Extra terrestrial solar flux and earth-Sun distance ^-2
REAL f(kw), etf(kw)
REAL esfact
* Ozone absorption cross section
INTEGER mabs
REAL o3xs(kz,kw)
* O2 absorption cross section
REAL o2xs(kz,kw), o2xs1(kw)
* SO2 absorption cross section
REAL so2xs(kw)
* NO2 absorption cross section
REAL no2xs(kz,kw)
* Atmospheric optical parameters
REAL tlev(kz), tlay(kz)
REAL aircon(kz), aircol(kz), vcol(kz), scol(kz)
REAL dtrl(kz,kw)
REAL co3(kz)
REAL dto3(kz,kw), dto2(kz,kw), dtso2(kz,kw), dtno2(kz,kw)
REAL dtcld(kz,kw), omcld(kz,kw), gcld(kz,kw)
REAL dtaer(kz,kw), omaer(kz,kw), gaer(kz,kw)
REAL dtsnw(kz,kw), omsnw(kz,kw), gsnw(kz,kw)
REAL albedo(kw)
* Spectral irradiance and actinic flux (scalar irradiance)
REAL edir(kz), edn(kz), eup(kz)
REAL sirrad(kz,kw)
REAL fdir(kz), fdn(kz), fup(kz)
REAL saflux(kz,kw)
* Photolysis coefficients (j-values)
INTEGER nj, ij
REAL sj(kj,kz,kw), valj(kj,kz)
REAL djdw
CHARACTER*50 jlabel(kj)
INTEGER tpflag(kj)
**** Re-scaling factors (can be read from input file)
* New surface albedo and surface pressure (milli bar)
* Total columns of O3, SO2, NO2 (Dobson Units)
* Cloud optical depth, altitude of base and top
* Aerosol optical depth at 550 nm, single scattering albedo, Angstrom alpha
REAL alsurf, psurf
REAL o3_tc, so2_tc, no2_tc
REAL taucld, zbase, ztop
REAL tauaer, ssaaer, alpha
* Location: Lat and Lon (deg.), surface elev (km)
* Altitude, temperature and pressure for specific outputs
REAL lat, lon
REAL zaird, ztemp
* Time and/or solar zenith angle
INTEGER iyear, imonth, iday
INTEGER it, nt
REAL t, tstart, tstop
REAL tmzone
LOGICAL lzenit
* number of radiation streams
INTEGER nstr
* input/output control
LOGICAL intrct
CHARACTER*6 inpfil, outfil
INTEGER iout
REAL dirsun, difdn, difup
CHARACTER*1 again
* Save arrays for output:
LOGICAL laflux, ljvals, lmmech
INTEGER isfix, ijfix, itfix, izfix, iwfix, i
INTEGER nmj, imj(kj)
* Planetary boundary layer height and pollutant concentrations
INTEGER ipbl
REAL zpbl
REAL o3pbl, so2pbl, no2pbl, aod330
* Other user-defined variables here:
C method:
C
C on first call, all necessary data will be read from the files
C in directories DATAE1, DATAJ1;
C all variables are saved for future calls to TUV
C
REAL, INTENT(IN) :: asza
INTEGER, INTENT(IN) :: idate
INTEGER, INTENT(IN) :: nlevel
REAL, INTENT(IN) :: dobnew, albnew
REAL, INTENT(IN) :: zin(nlevel)
REAL, INTENT(IN) :: lwc(nlevel)
INTEGER, INTENT(IN) :: njout
REAL, INTENT(OUT) :: jout(nlevel,njout)
CHARACTER*40, INTENT(OUT) :: jlabelout(njout)
C
LOGICAL LFIRSTCALL
DATA LFIRSTCALL /.TRUE./
C
* --- END OF DECLARATIONS ---------------------------------------------
* re-entry point
1000 CONTINUE
* ___ SECTION 1: SIMPLE INPUT VARIABLES --------------------------------
* Input and output files:
* inpfil = input file name
* outfil = output file name
* Radiative transfer scheme:
* nstr = number of streams
* If nstr < 2, will use 2-stream Delta Eddington
* If nstr > 1, will use nstr-stream discrete ordinates
nstr = 1
* Location (geographic):
* lat = LATITUDE (degrees, North = positive)
* lon = LONGITUDE (degrees, East = positive)
* tmzone = Local time zone difference (hrs) from Universal Time (ut):
* ut = timloc - tmzone
* Date:
* iyear = year (1950 to 2050)
* imonth = month (1 to 12)
* iday = day of month
* Time of day grid:
* tstart = starting time, local hours
* tstop = stopping time, local hours
* nt = number of time steps
* lzenit = switch for solar zenith angle (sza) grid rather than time
* grid. If lzenit = .TRUE. then
* tstart = first sza in deg.,
* tstop = last sza in deg.,
* nt = number of sza steps.
* esfact = 1. (Earth-sun distance = 1.000 AU)
lzenit=.TRUE.
* Vertical grid:
* zstart = surface elevation above sea level, km
* zstop = top of the atmosphere (exospheric), km
* nz = number of vertical levels, equally spaced
* (nz will increase by +1 if zout does not match altitude grid)
* Wavlength grid:
* wstart = starting wavelength, nm
* wstop = final wavelength, nm
* nwint = number of wavelength intervals, equally spaced
* if nwint < 0, the standard atmospheric wavelength grid, not
* equally spaced, from 120 to 735 nm, will be used. In this
* case, wstart and wstop values are ignored.
* Surface condition:
* alsurf = surface albedo, wavelength independent
* psurf = surface pressure, mbar. Set to negative value to use
* US Standard Atmosphere, 1976 (USSA76)
psurf = -1.
* Column amounts of absorbers (in Dobson Units, from surface to space):
* Vertical profile for O3 from USSA76. For SO2 and NO2, vertical
* concentration profile is 2.69e10 molec cm-3 between 0 and
* 1 km above sea level, very small residual (10/largest) above 1 km.
* o3_tc = ozone (O3)
* so2_tc = sulfur dioxide (SO2)
* no2_tc = nitrogen dioxide (NO2)
* Cloud, assumed horizontally uniform, total coverage, single scattering
* albedo = 0.9999, asymmetry factor = 0.85, indep. of wavelength,
* and also uniform vertically between zbase and ztop:
* taucld = vertical optical depth, independent of wavelength
* zbase = altitude of base, km above sea level
* ztop = altitude of top, km above sea level
* Aerosols, assumed vertical provile typical of continental regions from
* Elterman (1968):
* tauaer = aerosol vertical optical depth at 550 nm, from surface to space.
* If negative, will default to Elterman's values (ca. 0.235
* at 550 nm).
* ssaaer = single scattering albedo of aerosols, wavelength-independent.
* alpha = Angstrom coefficient = exponent for wavelength dependence of
* tauaer, so that tauaer1/tauaer2 = (w2/w1)**alpha.
* Directional components of radiation, weighting factors:
* dirsun = direct sun
* difdn = down-welling diffuse
* difup = up-welling diffuse
* e.g. use:
* dirsun = difdn = 1.0, difup = 0 for total down-welling irradiance
* dirsun = difdn = difup = 1.0 for actinic flux from all directions
* dirsun = difdn = 1.0, difup = -1 for net irradiance
dirsun = 1.0
difdn = 1.0
difup = 1.0
* Output altitude:
* zout = altitude, km, for desired output.
* If not within 1 m of altitude grid, an additional
* level will be inserted and nz will be increased by +1.
* zaird = air density (molec. cm-3) at zout. Set to negative value for
* default USSA76 value interpolated to zout.
* ztemp = air temperature (K) at zout. Set to negative value for
* default USSA76 value interpolated to zout.
* Output options, logical switches:
* laflux = output spectral actinic flux
* lmmech = output for NCAR Master Mechanism use
laflux =.FALSE.
lmmech =.FALSE.
* Output options, integer selections:
* ijfix: if > 0, output j-values for reaction ij=ijfix, tabulated
* for different times and altitudes.
* iwfix: if > 0, output spectral irradiance and/or spectral actinic
* flux at wavelength iw=iwfix, tabulated for different times
* and altitudes.
* itfix: if > 0, output spectral irradiance and/or spectral actinic
* flux at time it=itfix, tabulated for different altitudes
* and wavelengths.
* izfix: if > 0, output spectral irradiance and/or spectral actinic
* flux at altitude iz=izfix, tabulated for different times
* and wavelengths.
* nmj: number of j-values that will be reported. Selections must be
* made interactively, or by editing input file.
izfix = 1
IF (LFIRSTCALL) THEN
WRITE(kout,*) 'running TUVMAIN, version 5.3.1'
IF(nstr .LT. 2) THEN
WRITE(kout,*) 'Delta-Eddington 2-stream radiative transfer'
ELSE
WRITE(kout,*) 'Discrete ordinates ',
$ nstr, '-stream radiative transfer'
ENDIF
* ___ SECTION 2: SET GRIDS _________________________________________________
* altitudes (creates altitude grid, locates index for selected output, izout)
CALL gridz(zin,nlevel, zstart, zstop, nz, z, zout, izout,kout)
if(izfix .gt. 0) izout = izfix
* time/zenith (creates time/zenith angle grid, starting at tstart)
c CALL gridt(lat, lon, tmzone,
c $ iyear, imonth, iday,
c $ lzenit, tstart, tstop,
c $ nt, t, sza, esfact)
sza = asza
* wavelength grid, user-set range and spacing.
* NOTE: Wavelengths are in vacuum, and therefore independent of altitude.
* To use wavelengths in air, see options in subroutine gridw
CALL gridw(wstart, wstop, nwint,
$ nw, wl, wc, wu, kout)
* ___ SECTION 3: SET UP VERTICAL PROFILES OF TEMPERATURE, AIR DENSITY, and OZONE______
***** Temperature vertical profile, Kelvin
* can overwrite temperature at altitude z(izout)
CALL vptmp(nz,z, tlev,tlay,kout)
c IF(ztemp .GT. nzero) tlev(izout) = ztemp
***** Air density (molec cm-3) vertical profile
* can overwrite air density at altitude z(izout)
CALL vpair(psurf, nz, z,
$ aircon, aircol, kout)
c IF(zaird .GT. nzero) aircon(izout) = zaird
*****
*! PBL pollutants will be added if zpbl > 0.
* CAUTIONS:
* 1. The top of the PBL, zpbl in km, should be on one of the z-grid altitudes.
* 2. Concentrations, column increments, and optical depths
* will be overwritten between surface and zpbl.
* 3. Inserting PBL constituents may change their total column amount.
* 4. Above pbl, the following are used:
* for O3: USSA or other profile
* for NO2 and SO2: set to zero.
* for aerosols: Elterman
* Turning on pbl will affect subroutines:
* vpo3, setno2, setso2, and setaer. See there for details
zpbl = -999.
* locate z-index for top of pbl
ipbl = 0
IF(zpbl. GT. 0.) THEN
DO iz = 1, nz-1
IF(z(iz+1) .GT. z(1) + zpbl*1.00001) GO TO 19
ENDDO
19 CONTINUE
ipbl = iz - 1
write(*,*) 'top of PBL index, height (km) ', ipbl, z(ipbl)
* specify pbl concetrations, in parts per billion
o3pbl = 100.
so2pbl = 10.
no2pbl = 50.
* PBL aerosol optical depth at 330 nm
* (to change ssa and g of pbl aerosols, go to subroutine setair.f)
aod330 = 0.8
ENDIF
***** Ozone vertical profile
o3_tc = dobnew
CALL vpo3(ipbl, zpbl, o3pbl,
$ o3_tc, nz, z, aircol, co3, kout )
* ___ SECTION 4: READ SPECTRAL DATA ____________________________
* read (and grid) extra terrestrial flux data:
CALL rdetfl(nw,wl, f, kout )
* read cross section data for
* O2 (will overwrite at Lyman-alpha and SRB wavelengths
* see subroutine la_srb.f)
* O3 (temperature-dependent)
* SO2
* NO2
nzm1 = nz - 1
CALL rdo2xs(nw,wl, o2xs1,kout)
mabs = 1
CALL rdo3xs(mabs,nzm1,tlay,nw,wl, o3xs,kout)
CALL rdso2xs(nw,wl, so2xs,kout)
CALL rdno2xs(nz,tlay,nw,wl, no2xs,kout)
****** Spectral weighting functions
* (Some of these depend on temperature T and pressure P, and therefore
* on altitude z. Therefore they are computed only after the T and P profiles
* are set above with subroutines settmp and setair.)
* Photo-chemical set in swchem.f (cross sections x quantum yields)
* Chemical weighting functions (product of cross-section x quantum yield)
* for many photolysis reactions are known to depend on temperature
* and/or pressure, and therefore are functions of wavelength and altitude.
* Output:
* from swchem: sj(kj,kz,kw) - for each reaction jlabel(kj)
* For swchem, need to know temperature and pressure profiles.
CALL swchem(nw,wl,nz,tlev,aircon, nj,sj,jlabel,tpflag,kout)
******
* ___ SECTION 5: SET ATMOSPHERIC OPTICAL DEPTH INCREMENTS _____________________
* Rayleigh optical depth increments:
CALL odrl(nz, z, nw, wl, aircol, dtrl,kout)
* O2 vertical profile and O2 absorption optical depths
* For now, O2 densitiy assumed as 20.95% of air density, can be changed
* in subroutine.
* Optical depths in Lyman-alpha and SRB will be over-written
* in subroutine la_srb.f
CALL seto2(nz,z,nw,wl,aircol,o2xs1, dto2, kout)
* Ozone optical depths
CALL odo3(nz,z,nw,wl,o3xs,co3, dto3,kout)
* SO2 vertical profile and optical depths
so2_tc = 0.
CALL setso2(ipbl, zpbl, so2pbl,
$ so2_tc, nz, z, nw, wl, so2xs,
$ tlay, aircol,
$ dtso2,kout)
* NO2 vertical profile and optical depths
no2_tc = 0.
CALL setno2(ipbl, zpbl, no2pbl,
$ no2_tc, nz, z, nw, wl, no2xs,
$ tlay, aircol,
$ dtno2,kout)
* Aerosol vertical profile, optical depths, single scattering albedo, asymmetry factor
tauaer = -1.0
alpha = 1.0
tauaer = 0.235
ssaaer = 0.990
CALL setaer(ipbl, zpbl, aod330,
$ tauaer, ssaaer, alpha,
$ nz, z, nw, wl,
$ dtaer, omaer, gaer, kout )
* Snowpack physical and optical depths, single scattering albedo, asymmetry factor
CALL setsnw(
$ nz,z,nw,wl,
$ dtsnw,omsnw,gsnw,kout)
LFIRSTCALL = .FALSE.
ENDIF
C________________________________________________________________________
C END OF INITIALIZATION (only executed on firstcall of tuvmain)
C________________________________________________________________________
* Surface albedo
if (albnew .ge. 0.) then
C WRITE(kout,*)'wavelength-independent albedo = ', albnew
DO iw = 1, nw - 1
albedo(iw) = albnew
enddo
else
CALL setalb(alsurf,nw,wl,
$ albedo,kout)
endif
C cloud optical depth (may be modified at each call, so it has ben moved
C outside the if(firstcall) section:
* Cloud vertical profile, optical depths, single scattering albedo, asymmetry factor
CALL setcld(nz,z,nw,wl,
$ lwc,nlevel,
$ dtcld,omcld,gcld,kout)
* ___ SECTION 6: TIME/SZA LOOP _____________________________________
* Initialize any time-integrated quantities here
zen = asza
* Loop over time or solar zenith angle (zen):
c DO 20, it = 1, nt
c
c zen = sza(it)
c
c WRITE(*,200) it, zen, esfact(it)
c WRITE(kout,200) it, zen, esfact(it)
c 200 FORMAT('step = ', I4,' sza = ', F9.3,
c $ ' Earth-sun factor = ', F10.7)
c
* correction for earth-sun distance
DO iw = 1, nw - 1
etf(iw) = f(iw)
ENDDO
* ____ SECTION 7: CALCULATE ZENITH ANGLE-DEPENDENT QUANTITIES __________
* slant path lengths for spherical geometry
CALL sphers(nz,z,zen, dsdh,nid, kout)
CALL airmas(nz, dsdh,nid, aircol,vcol,scol, kout)
* Recalculate effective O2 optical depth and cross sections for Lyman-alpha
* and Schumann-Runge bands, must know zenith angle
* Then assign O2 cross section to sj(1,*,*)
CALL la_srb(nz,z,tlev,nw,wl,vcol,scol,o2xs1,
$ dto2,o2xs,kout)
CALL sjo2(nz,nw,o2xs,1, sj,kout)
* ____ SECTION 8: WAVELENGTH LOOP ______________________________________
* initialize for wavelength integration
CALL zero2(valj,kj,kz)
***** Main wavelength loop:
DO 10, iw = 1, nw-1
** monochromatic radiative transfer. Outputs are:
* normalized irradiances edir(iz), edn(iz), eup(iz)
* normalized actinic fluxes fdir(iz), fdn(zi), fup(iz)
* where
* dir = direct beam, dn = down-welling diffuse, up = up-welling diffuse
CALL rtlink(nstr, nz,
$ iw, albedo(iw), zen,
$ dsdh,nid,
$ dtrl,
$ dto3,
$ dto2,
$ dtso2,
$ dtno2,
$ dtcld, omcld, gcld,
$ dtaer,omaer,gaer,
$ dtsnw,omsnw,gsnw,
$ edir, edn, eup, fdir, fdn, fup,
$ kout)
* Spectral actinic flux, quanta s-1 nm-1 cm-2, all directions:
* units conversion: 1.e-4 * (wc*1e-9) / hc
DO iz = 1, nz
saflux(iz,iw) = etf(iw) * (1.e-13 * wc(iw) / hc) *
$ (dirsun*fdir(iz) + difdn*fdn(iz) + difup*fup(iz))
ENDDO
*** Accumulate weighted integrals over wavelength, at all altitudes:
DO iz = 1, nz
* Photolysis rate coefficients (J-values) s-1
DO ij = 1, nj
djdw = saflux(iz,iw) * sj(ij,iz,iw)
valj(ij,iz) = valj(ij,iz) + djdw * (wu(iw) - wl(iw))
ENDDO
ENDDO
10 CONTINUE
*^^^^^^^^^^^^^^^^ end wavelength loop
* ____ SECTION 9: OUTPUT ______________________________________________
C copy labels into output array
if (njout .ne. 42) then
WRITE(kout,*) 'There should be 42 J-Values to be updated!'
WRITE(kout,*) 'We better stop here ... in tuvmain.f'
C callabortstop
CALL ABORT
STOP 1
endif
DO ij = 1, njout
jlabelout(ij) = jlabel(ij)
ENDDO
C
C return J values on AZ grid
C
C for each individual J value do..
DO ij = 1, njout
DO iz = 1, nlevel
jout(iz,ij) = max(valj(ij,iz),1.E-36)
ENDDO
ENDDO
C
*_______________________________________________________________________
c IF(intrct) THEN
c WRITE(*,*) 'do you want to do another calculation?'
c WRITE(*,*) 'y = yes'
c WRITE(*,*) 'any other key = no'
c READ(*,1001) again
c 1001 FORMAT(A1)
c IF(again .EQ. 'y' .OR. again .EQ. 'Y') GO TO 1000
c ENDIF
c CLOSE(iout)
C CLOSE(kout)
END
CCC FILE functs.f
* This file contains the following user-defined fortran functions:
* fo3qy
* fo3qy2
* fsum
*=============================================================================*
FUNCTION fo3qy(w,t)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
* function to calculate the quantum yield O3 + hv -> O(1D) + O2, =*
* according to JPL 2000 recommendation: =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
REAL w, t, kt, fo3qy
REAL a(3), w0(3), nu(3), om(3)
DATA a/ 0.887, 2.35, 57./
DATA w0/ 302., 311.1, 313.9/
DATA nu/ 0., 820., 1190./
DATA om/ 7.9, 2.2, 7.4/
fo3qy = 0.
kt = 0.695 * t
IF(w .LE. 300.) THEN
fo3qy = 0.95
ELSEIF(w .GT. 300. .AND. w .LE. 330.) THEN
fo3qy = 0.06 +
$ a(1) *EXP(-((w-w0(1))/om(1))**4)+
$ a(2)*(T/300.)**4*EXP(-nu(2)/kT)*EXP(-((w-w0(2))/om(2))**2)+
$ a(3) *EXP(-nu(3)/kT)*EXP(-((w-w0(3))/om(3))**2)
ELSEIF(w .GT. 330. .AND. w .LE. 345.) THEN
fo3qy = 0.06
ELSEIF(w .GT. 345.) THEN
fo3qy = 0.
ENDIF
END
FUNCTION fo3qy2(w,t)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
* function to calculate the quantum yield O3 + hv -> O(1D) + O2, =*
* according to:
* Matsumi, Y., F. J. Comes, G. Hancock, A. Hofzumanhays, A. J. Hynes,
* M. Kawasaki, and A. R. Ravishankara, QUantum yields for production of O(1D)
* in the ultraviolet photolysis of ozone: Recommendation based on evaluation
* of laboratory data, J. Geophys. Res., 107, 10.1029/2001JD000510, 2002.
*-----------------------------------------------------------------------------*
IMPLICIT NONE
REAL w, t, kt, fo3qy2
REAL A(3), X(3), om(3)
REAL q1, q2
DATA A/ 0.8036, 8.9061, 0.1192/
DATA X/ 304.225, 314.957, 310.737/
DATA om/ 5.576, 6.601, 2.187/
fo3qy2 = 0.
kt = 0.695 * t
q1 = 1.
q2 = exp(-825.518/kt)
IF(w .LE. 305.) THEN
fo3qy2 = 0.90
ELSEIF(w .GT. 305. .AND. w .LE. 328.) THEN
fo3qy2 = 0.0765 +
$ a(1)* (q1/(q1+q2))*EXP(-((x(1)-w)/om(1))**4)+
$ a(2)*(T/300.)**2 *(q2/(q1+q2))*EXP(-((x(2)-w)/om(2))**2)+
$ a(3)*(T/300.)**1.5 *EXP(-((x(3)-w)/om(3))**2)
ELSEIF(w .GT. 328. .AND. w .LE. 340.) THEN
fo3qy2 = 0.08
ELSEIF(w .GT. 340.) THEN
fo3qy2 = 0.
ENDIF
END
*=============================================================================*
FUNCTION fsum(n,x)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Compute the sum of the first N elements of a floating point vector. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= N - INTEGER, number of elements to sum (I)=*
*= X - REAL, vector whose components are to be summed (I)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
* input:
INTEGER n
REAL x(n)
* function value:
REAL fsum
* local:
INTEGER i
fsum = 0.
DO 10, i = 1, n
fsum=fsum+x(i)
10 CONTINUE
RETURN
END
CCC FILE grids.f
* This file contains the following subroutine, related to setting up
* grids for numerical calculations:
* gridw
* gridz
* buildz
* gridt
* gridck
*=============================================================================*
SUBROUTINE gridw(wstart, wstop, nwint,
$ nw,wl,wc,wu,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Create the wavelength grid for all interpolations and radiative transfer =*
*= calculations. Grid may be irregularly spaced. Wavelengths are in nm. =*
*= No gaps are allowed within the wavelength grid. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of wavelength grid _points_ (O)=*
*= WL - REAL, vector carrying the lower limit of each wavel. interval (O)=*
*= WC - REAL, vector carrying the center wavel of each wavel. interval (O)=*
*= (wc(i) = 0.5*(wl(i)+wu(i), i = 1..NW-1) =*
*= WU - REAL, vector carrying the upper limit of each wavel. interval (O)=*
*=
*= MOPT- INTEGER OPTION for wave-length IF 3 good for JO2 (O)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input:
REAL wstart, wstop
INTEGER nwint
* output:
REAL wl(kw), wc(kw), wu(kw)
INTEGER nw
integer wn(kw)
* local:
INTEGER mopt
REAL wincr
INTEGER iw, i
CHARACTER*40 fi
CHARACTER*20 wlabel
REAL airout
INTEGER mrefr
REAL dum
LOGICAL ok
*_______________________________________________________________________
**** chose wavelength grid
* some pre-set options
* mopt = 1 equal spacing
* mopt = 2 grid defined in data table
* mopt = 3 user-defined
* mopt = 4 fast-TUV, troposheric wavelengths only
* mopt = 5 high resolution grid for O3 isotopologue study
* mopt = 6 create uniform grid in air-wavelength scale
* mopt = 10 Landgraf and Crutzen, 1998
* mopt = 11 fastJ, Wild et al. 2000
* mopt = 12 fastJ2, Bian and Prather, 2002
* mopt = 13 UV-b, UV-a, Visible
mopt = 2
IF(nwint .EQ. -156) mopt = 2
IF(nwint .EQ. -7) mopt = 4
IF(nwint .eq. -10) mopt = 10
IF(nwint .eq. -11) mopt = 11
IF(nwint .eq. -12) mopt = 12
IF(nwint .eq. -13) mopt = 13
IF (mopt .EQ. 1) GO TO 1
IF (mopt .EQ. 2) GO TO 2
IF (mopt .EQ. 3) GO TO 3
IF (mopt .EQ. 4) GO TO 4
IF (mopt .EQ. 5) GO TO 5
IF (mopt .EQ. 6) GO TO 6
IF (mopt .EQ. 10) GO TO 10
IF (mopt .EQ. 11) GO TO 11
IF (mopt .EQ. 12) GO TO 12
IF (mopt .EQ. 13) GO TO 13
*_______________________________________________________________________
1 CONTINUE
wlabel = 'equal spacing'
nw = nwint + 1
wincr = (wstop - wstart) / FLOAT (nwint)
DO iw = 1, nw-1
wl(iw) = wstart + wincr*FLOAT(iw-1)
wu(iw) = wl(iw) + wincr
wc(iw) = ( wl(iw) + wu(iw) )/2.
ENDDO
wl(nw) = wu(nw-1)
GO TO 9
*_______________________________________________________________________
2 CONTINUE
* Input from table. In this example:
* Wavelength grid will be read from a file.
* First line of table is: nw = number of wavelengths (no. of intervals + 1)
* Then, nw wavelengths are read in, and assigned to wl(iw)
* Finally, wu(iw) and wc(iw) are computed from wl(iw)
c wlabel = 'isaksen.grid'
wlabel = 'combined.grid'
fi = 'DATAE1/GRIDS/'//wlabel
OPEN(newunit=ilu,file=fi,status='old')
READ(ilu,*) nw
DO iw = 1, nw
READ(ilu,*) wl(iw)
ENDDO
CLOSE(ilu)
DO iw = 1, nw-1
wu(iw) = wl(iw+1)
wc(iw) = 0.5*(wl(iw) + wu(iw))
ENDDO
GO TO 9
*_______________________________________________________________________
3 CONTINUE
* user-defined grid. In this example, a single calculation is used to
* obtain results for two 1 nm wide intervals centered at 310 and 400 nm:
* interval 1 : 1 nm wide, centered at 310 nm
* interval 3 : 2 nm wide, centered at 400 nm
* (inteval 2 : 310.5 - 399.5 nm, required to connect intervals 1 & 3)
nw = 4
wl(1) = 309.5
wl(2) = 310.5
wl(3) = 399.5
wl(4) = 400.5
DO iw = 1, nw-1
wu(iw) = wl(iw+1)
wc(iw) = 0.5*(wl(iw) + wu(iw))
ENDDO
GO TO 9
*_______________________________________________________________________
4 CONTINUE
wlabel = 'fast-TUV tropospheric grid'
fi = 'DATAE1/GRIDS/fast_tuv.grid'
OPEN(NEWUNIT=ilu,FILE=fi,STATUS='old')
DO iw = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
* skip wavelength shorter than 289.9 nm
DO iw = 1, 10
READ(UNIT=ilu,FMT=*)
ENDDO
nw = 8
DO iw = 1, nw-1
READ(UNIT=ilu,FMT=*) dum, wl(iw), dum, dum
ENDDO
CLOSE(UNIT=ilu)
wl(nw) = dum
DO iw = 1, nw-1
wu(iw) = wl(iw+1)
wc(iw) = 0.5*(wl(iw) + wu(iw))
ENDDO
GO TO 9
*_______________________________________________________________________
5 continue
* use standard grid up to 205.8 nm
* elsewhere, use 10 cm-1 grid to 1000 nm
wlabel = 'combined.grid'
fi = 'DATAE1/GRIDS/'//wlabel
OPEN(newunit=ilu,file=fi,status='old')
READ(ilu,*)
DO iw = 1, 38
READ(ilu,*) wl(iw)
ENDDO
CLOSE(ilu)
DO i = 1, 3859
iw = 3859 - i + 39
wn(iw) = 10000 + 10*(i-1)
wl(iw) = 1.E7/float(wn(iw))
ENDDO
nw = 3859 + 38
nwint = nw - 1
DO iw = 1, nwint
wu(iw) = wl(iw+1)
wc(iw) = (wl(iw) + wu(iw))/2.
ENDDO
GO TO 9
*_______________________________________________________________________
6 CONTINUE
***** Correction for air-vacuum wavelength shift:
* The TUV code assumes that all working wavelengths are strictly IN-VACUUM. This is for ALL
* spectral data including extraterrestrial fluxes, ozone (and other) absorption cross sections,
* and various weighting functons (action spectra, photolysis cross sections, instrument spectral
* response functions). If the original data are specified in-air, conversion to in-vacuum must be
* made when reading those data.
* Occasionally, users may want their results to be given for wavelengths measured IN-AIR.
* The shift between IN-VACUUM and IN-AIR wavelengths depends on the index of refraction
* of air, which in turn depends on the local density of air, which in turn depends on
* altitude, temperature, etc.
* Here, we provide users with the option to use a wavelength grid IN-AIR, at the air density
* corresponding to the selected altitude, airout.
* The actual radiative transfer calculations will be done strictly with IN-VACUUM values.
* create grid that will be nicely spaced in air wavelengths.
wlabel = 'grid in air wavelengths'
nw = nwint + 1
wincr = (wstop - wstart) / FLOAT (nwint)
DO iw = 1, nw-1
wl(iw) = wstart + wincr*FLOAT(iw-1)
wu(iw) = wl(iw) + wincr
wc(iw) = ( wl(iw) + wu(iw) )/2.
ENDDO
wl(nw) = wu(nw-1)
* shift by refractive index to vacuum wavelengths, for use in tuv
airout = 2.45e19
mrefr = 1
CALL wshift(mrefr, nw, wl, airout, kout)
CALL wshift(mrefr, nwint, wc, airout, kout)
CALL wshift(mrefr, nwint, wu, airout, kout)
GO TO 9
*_______________________________________________________________________
* Landgraf and Crutzen 1998
10 CONTINUE
nw = 6
wl(1) = 289.0
wl(2) = 305.5
wl(3) = 313.5
wl(4) = 337.5
wl(5) = 422.5
wl(6) = 752.5
DO iw = 1, nw-1
wu(iw) = wl(iw+1)
wc(iw) = 0.5*(wl(iw) + wu(iw))
ENDDO
GO TO 9
*_______________________________________________________________________
* Wild 2000
11 CONTINUE
nw = 8
wl(1) = 289.00
wl(2) = 298.25
wl(3) = 307.45
wl(4) = 312.45
wl(5) = 320.30
wl(6) = 345.0
wl(7) = 412.5
wl(8) = 850.0
DO iw = 1, nw-1
wu(iw) = wl(iw+1)
wc(iw) = 0.5*(wl(iw) + wu(iw))
ENDDO
GO TO 9
*_______________________________________________________________________
* Bian and Prather 2002
12 CONTINUE
nw = 8
wl(1) = 291.0
wl(2) = 298.3
wl(3) = 307.5
wl(4) = 312.5
wl(5) = 320.3
wl(6) = 345.0
wl(7) = 412.5
wl(8) = 850.0
DO iw = 1, nw-1
wu(iw) = wl(iw+1)
wc(iw) = 0.5*(wl(iw) + wu(iw))
ENDDO
GO TO 9
*_______________________________________________________________________
*_______________________________________________________________________
* UV-b, UV-A, Vis
13 CONTINUE
nw = 4
wl(1) = 280.0
wl(2) = 315.0
wl(3) = 400.0
wl(4) = 700.0
DO iw = 1, nw-1
wu(iw) = wl(iw+1)
wc(iw) = 0.5*(wl(iw) + wu(iw))
ENDDO
GO TO 9
*_______________________________________________________________________
9 CONTINUE
* check grid for assorted improprieties:
CALL gridck(kw,nw,wl,ok,kout)
IF (.NOT. ok) THEN
WRITE(*,*)'STOP in GRIDW: The w-grid does not make sense'
STOP
ENDIF
*_______________________________________________________________________
RETURN
END
*=============================================================================*
SUBROUTINE gridz(zin,nlevel,zstart, zstop, nz, z,
& zout, izout, kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Create the altitude grid for all interpolations and radiative transfer =*
*= calculations. Grid may be irregularly spaced. All altitudes are in =*
*= kilometers (km). The altitude at index 1 specifies the surface elevation=*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= nz - INTEGER, number of altitude points (levels) (O)=*
*= z - REAL, vector of altitude levels (in km) (O)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
REAL zstart, zstop, zout
REAL zin(*)
INTEGER nlevel
* output: altitude working grid, index for output
REAL z(kz)
INTEGER nz
INTEGER izout
* local:
REAL zincr
INTEGER i, n, nlev
LOGICAL ok
*_______________________________________________________________________
* Set vertical grid of the atmosphere: atmospheric level altitudes
* (in real km), including top-most level.
* User specifies grid (surface at lowest km value), increasing
* upwards:
* - nz = total number of user levels
* - z(I) = altitude in km for each level.
* z(1) is the elevation of the surface (km asl), and can be specified either
* here or in the main program.
* Non-uniform spacing is possible:
* - zincr = altitude increment between current and previous level (km)
* - nlev = number of levels in current equally-spaced section
* - n = index of top level of equally-spaced section
* Note "levels" are vertical points
* "layers" are vertical distances between levels
* Grid selection options:
* 1 = standard equally spaced grid, manual
* 2 = standard equally spaced grid, auto generated
* 3 = variable spacing grid, example for snow
* 4 = mirage z-grid for Mexico City
* 5 = arbitrary user-defined grid
GO TO 5
*-----grid option 2: manual -----------------
* entire grid (nz levels) in increments zincr
1 CONTINUE
WRITE(*,*) 'equally spaced z-grid'
zincr = (zstop - zstart) / FLOAT(nz - 1)
z(1) = zstart
DO i = 2, nz
z(i) = z(1) + zincr*FLOAT(i-1)
ENDDO
GOTO 10
*-----grid option 3: automatic -----------------
* entire grid (nz levels) in increments zincr
2 CONTINUE
WRITE(*,*) 'equally spaced z-grid'
zincr = (zstop - zstart) / FLOAT(nz - 1)
nlev = nz-1
n = 1
CALL buildz(zincr, nlev, n, z)
GOTO 10
*-----grid option 4: variable grid example----------------------
*-----copy & edit this section for non-uniform grid----
* the example provided below is high vertical resolution in
* snow, with atmosphere above it.
3 CONTINUE
WRITE(*,*) 'snow-atmosphere grid'
* 0.-10. cm from ground, in 1 cm increments ( 1 cm = 1e-5 km):
zincr = 1.e-5
nlev = 10
n = 1
CALL buildz(zincr,nlev,n,z)
* 10-90 cm from ground, in 10 cm increments ( 1 cm = 1e-5 km):
zincr = 1.e-4
nlev = 8
CALL buildz(zincr,nlev,n,z)
* 90-95 cm from ground, in 1x 5 cm increment ( 1 cm = 1e-5 km):
zincr = 5.e-5
nlev = 1
CALL buildz(zincr,nlev,n,z)
* 95-99 cm from ground, in 4x 1 cm increments ( 1 cm = 1e-5 km):
zincr = 1.e-5
nlev = 4
CALL buildz(zincr,nlev,n,z)
* 99-99.5 cm from ground, in 1x 0.5 cm increment ( 1 cm = 1e-5 km):
zincr = 5.e-6
nlev = 1
CALL buildz(zincr,nlev,n,z)
* 99.5 centimeters - 1m, in 0.1 cm increments (1 cm = 1e-5 km):
zincr = 1.e-6
nlev = 5
CALL buildz(zincr,nlev,n,z)
*atmosphere
* 1.-10. m in 1 m increments
zincr = 1.e-3
nlev = 9
CALL buildz(zincr,nlev,n,z)
* 10.-100 m in 10 m increments
zincr = 1.e-2
nlev = 9
CALL buildz(zincr,nlev,n,z)
* 100.- 1000. meters, in 100 m increments
zincr = 1.e-1
nlev = 9
CALL buildz(zincr,nlev,n,z)
* 1.-2. km in 1 km increments
zincr = 1.
nlev = 1
CALL buildz(zincr,nlev,n,z)
* 2.-80. km in 2 km increments
zincr = 2.
nlev = 39
CALL buildz(zincr,nlev,n,z)
GOTO 10
*-----grid option 4: grid for Mexico City
4 CONTINUE
WRITE(*,*) 'mirage z-grid'
* grid for mirage km: incr(range)i
* 0.1(0-4) 2-41
* 0.2(4-8) 42-61
* 1(8-30) 62-83
* 2(30-50) 84-93
* 5(50-80) 94-99
nz = 99
z(1) = zstart
DO i = 2, 41
z(i) = z(1) + 0.1*FLOAT(i-1)
ENDDO
DO i = 42, 61
z(i) = z(41) + 0.2*FLOAT(i-41)
ENDDO
DO i = 62, 83
z(i) = z(61) + 1.*FLOAT(i-61)
ENDDO
DO i = 84, 93
z(i) = z(83) + 2.*FLOAT(i-83)
ENDDO
DO i = 94, 99
z(i) = z(93) + 5.*FLOAT(i-93)
ENDDO
GOTO 10
*-----grid option 5: user defined
5 CONTINUE
* insert your grid values here:
* specify:
* nz = total number of altitudes
* Table: z(iz), where iz goes from 1 to nz
C use model levels for vertical grid where available
do 12, i = 1, nlevel
z(i) = zin(i) *1E-3
12 continue
nz = nlevel
C fill up between model top and 50km with 1km grid spacing
20 continue
if (z(nz) .ge. 50.) goto 30
nz = nz + 1
if (nz .gt. kz) stop "GRIDZ: not enough memory, increase kz"
z(nz) = z(nz-1) + 1.
goto 20
C
30 continue
C
GOTO 10
*-----end of user options.
*-----grid option 6: high resolution window
6 CONTINUE
* insert your grid values here:
* specify:
* nz = total number of altutudes
* Table: z(iz), where iz goes from 1 to nz
WRITE(*,*) 'user-defined grid, named...'
goto 10
*-----end of user options.
*------------------------------------------------
10 CONTINUE
* Insert additional altitude for selected outputs.
c DO i = 1, nz
c IF(ABS(z(i) - zout) .LT. 0.001) THEN
c izout = i
c GO TO 24
c ENDIF
c ENDDO
* locate index for new altitude
c izout = 0
c DO i = 1, nz
c IF(z(i) .GT. zout) THEN
c izout = i
c GO TO 22
c ENDIF
c ENDDO
c 22 CONTINUE
c IF(izout .LE. 1) STOP 'zout not in range - '
c
* shift overlying levels and insert new point
c nz = nz + 1
c DO i = nz, izout + 1, -1
c z(i) = z(i-1)
c ENDDO
c z(izout) = zout
c 24 CONTINUE
* check grid for assorted improprieties:
c 99 CONTINUE
CALL gridck(kz,nz,z,ok,kout)
IF (.NOT. ok) THEN
WRITE(*,*)'STOP in GRIDZ: The z-grid does not make sense'
STOP
ENDIF
*_______________________________________________________________________
RETURN
END
*=============================================================================*
SUBROUTINE buildz(zincr,nlev,n,z)
*-----------------------------------------------------------------------------*
*= Purpose: to construct the altitude grid from parameters in gridz =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
REAL zincr ! i
INTEGER nlev ! i
INTEGER n ! i/o
REAL z(kz) ! i/o
INTEGER i, j ! internal
j = 0
DO i = n + 1, n + nlev
j = j + 1
z(i) = z(n) + FLOAT(j)*zincr
ENDDO
n = n + nlev
RETURN
END
*=============================================================================*
c SUBROUTINE gridt(lat, lon, tmzone,
c $ iyear, imonth, iday,
c $ lzenit, tstart, tstop,
c $ nt, t, sza, esrm2)
c
c *-----------------------------------------------------------------------------*
c *= Subroutine to create time (or solar zenith angle) grid =*
c *= Also computes earth-sun distance (1/R**2) correction. =*
c *-----------------------------------------------------------------------------*
c
c IMPLICIT NONE
c
c c INCLUDE 'params'
c
c * BROADLY USED PARAMETERS:
c *_________________________________________________
c * i/o file unit numbers
c INTEGER :: ilu
c INTEGER kout
c * output
c PARAMETER(kout=6)
c *_________________________________________________
c * altitude, wavelength, time (or solar zenith angle) grids
c INTEGER kz, kw
c * altitude
c PARAMETER(kz=151)
c * wavelength
c PARAMETER(kw=157)
c *_________________________________________________
c * number of weighting functions
c INTEGER kj
c * wavelength and altitude dependent
c PARAMETER(kj=90)
c
c * delta for adding points at beginning or end of data grids
c REAL deltax
c PARAMETER (deltax = 1.E-5)
c
c * some constants...
c
c * pi:
c REAL pi
c PARAMETER(pi=3.1415926535898)
c
c * radius of the earth, km:
c REAL radius
c PARAMETER(radius=6.371E+3)
c
c * Planck constant x speed of light, J m
c
c REAL hc
c PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
c
c * largest number of the machine:
c REAL largest
c PARAMETER(largest=1.E+36)
c
c * small numbers (positive and negative)
c REAL pzero, nzero
c PARAMETER(pzero = +10./largest)
c PARAMETER(nzero = -10./largest)
c
c * machine precision
c
c REAL precis
c PARAMETER(precis = 1.e-7)
c
c * INPUTS
c
c REAL lat, lon, tmzone
c INTEGER iyear, imonth, iday
c LOGICAL lzenit
c INTEGER nt
c REAL tstart, tstop
c
c
c * OUTPUTS
c
c REAL t, sza, esrm2
c
c * INTERNAL
c
c INTEGER it
c REAL ut, dt
c
c INTEGER jday, nday
c LOGICAL oky, okm, okd
c
c REAL az, el, soldia, soldst
c
c * switch for refraction correction to solar zenith angle. Because
c * this is only for the observed sza at the surface, do not use.
c
c LOGICAL lrefr
c DATA lrefr /.FALSE./
c
c ***************
c
c IF(nt .EQ. 1) THEN
c dt = 0.
c ELSE
c dt = (tstop - tstart) / FLOAT(nt - 1)
c ENDIF
c
c DO 10 it = 1, nt
c t(it) = tstart + dt * FLOAT(it - 1)
c
c * solar zenith angle calculation:
c * If lzenit = .TRUE., use selected solar zenith angles, also
c * set Earth-Sun distance to 1 AU.
c
c IF (lzenit) THEN
c sza(it) = t(it)
c esrm2(it) = 1.
c
c * If lzenit = .FALSE., compute solar zenith angle for specified
c * location, date, time of day. Assume no refraction (lrefr = .FALSE.)
c * Also calculate corresponding
c * Earth-Sun correcton factor.
c
c ELSE
c CALL calend(iyear, imonth, iday,
c $ jday, nday, oky, okm, okd)
c IF( oky .AND. okm .AND. okd) THEN
c
c ut = t(it) - tmzone
c CALL sunae(iyear, jday, ut, lat, lon, lrefr,
c & az, el, soldia, soldst )
c sza(it) = 90. - el
c esrm2(it) = 1./(soldst*soldst)
c ELSE
c WRITE(*,*) '**** incorrect date specification'
c STOP ' in gridt '
c ENDIF
c ENDIF
c
c 10 CONTINUE
c RETURN
c END
*=============================================================================*
SUBROUTINE gridck(k,n,x,ok, kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Check a grid X for various improperties. The values in X have to comply =*
*= with the following rules: =*
*= 1) Number of actual points cannot exceed declared length of X =*
*= 2) Number of actual points has to be greater than or equal to 2 =*
*= 3) X-values must be non-negative =*
*= 4) X-values must be unique =*
*= 5) X-values must be in ascending order =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= K - INTEGER, length of X as declared in the calling program (I)=*
*= N - INTEGER, number of actual points in X (I)=*
*= X - REAL, vector (grid) to be checked (I)=*
*= OK - LOGICAL, .TRUE. -> X agrees with rules 1)-5) (O)=*
*= .FALSE.-> X violates at least one of 1)-5) =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input:
INTEGER k, n
REAL x(k)
* output:
LOGICAL ok
* local:
INTEGER i
*_______________________________________________________________________
ok = .TRUE.
* check if dimension meaningful and within bounds
IF (n .GT. k) THEN
ok = .false.
WRITE(kout,100)
RETURN
ENDIF
100 FORMAT('Number of data exceeds dimension')
IF (n .LT. 2) THEN
ok = .FALSE.
WRITE(kout,101)
RETURN
ENDIF
101 FORMAT('Too few data, number of data points must be >= 2')
* disallow negative grid values
IF(x(1) .LT. 0.) THEN
ok = .FALSE.
WRITE(kout,105)
RETURN
ENDIF
105 FORMAT('Grid cannot start below zero')
* check sorting
DO 10, i = 2, n
IF( x(i) .LE. x(i-1)) THEN
ok = .FALSE.
WRITE(kout,110)
RETURN
ENDIF
10 CONTINUE
110 FORMAT('Grid is not sorted or contains multiple values')
*_______________________________________________________________________
RETURN
END
CCC FILE la_srb.f
* This file contains the following subroutines, related to the calculation
* of radiation at Lyman-alpha and Schumann-Runge wavelengths:
* la_srb
* lymana
* schum
* effxs
* calc_params
* init_xs
* sjo2
* and the following functions
* chebev
*=============================================================================*
SUBROUTINE la_srb(nz,z,tlev,nw,wl,vcol,scol,o2xs1,dto2,o2xs,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Compute equivalent optical depths for O2 absorption, and O2 effective =*
*= absorption cross sections, parameterized in the Lyman-alpha and SR bands =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lxower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= CZ - REAL, number of air molecules per cm^2 at each specified (I)=*
*= altitude layer =*
*= ZEN - REAL, solar zenith angle (I)=*
*= =*
*= O2XS1 - REAL, O2 cross section from rdo2xs (I)=*
*= =*
*= DTO2 - REAL, optical depth due to O2 absorption at each specified (O)=*
*= vertical layer at each specified wavelength =*
*= O2XS - REAL, molecular absorption cross section in SR bands at (O)=*
*= each specified altitude and wavelength. Includes Herzberg =*
*= continuum. =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
REAL wl(kw)
REAL z(kz)
INTEGER nz, nw, iz, iw
REAL vcol(kz), scol(kz)
REAL o2col(kz)
REAL o2xs1(kw)
REAL dto2(kz,kw), o2xs(kz,kw)
REAL secchi(kz)
REAL tlev(kz)
* Lyman-alpha variables
* O2 optical depth and equivalent cross section in the Lyman-alpha region
INTEGER ila, nla, kla
PARAMETER (kla = 2)
REAL wlla(kla)
REAL dto2la(kz, kla-1), o2xsla(kz, kla-1)
SAVE ila
* grid on which Koppers' parameterization is defined
* O2 optical depth and equivalent cross section on Koppers' grid
INTEGER isrb, nsrb, ksrb
PARAMETER(ksrb = 18)
REAL wlsrb(ksrb)
REAL dto2k(kz, ksrb-1), o2xsk(kz, ksrb-1)
SAVE isrb
INTEGER i
LOGICAL call1
DATA call1/.TRUE./
SAVE call1
* Wavelengths for Lyman alpha and SRB parameterizations:
DATA nla /1/
DATA wlla/ 121.4, 121.9/
DATA nsrb /17/
DATA wlsrb/174.4, 177.0, 178.6, 180.2, 181.8, 183.5, 185.2, 186.9,
$ 188.7, 190.5, 192.3, 194.2, 196.1, 198.0, 200.0, 202.0,
$ 204.1, 205.8/
*----------------------------------------------------------------------
* initalize O2 cross sections
*----------------------------------------------------------------------
DO iz = 1, nz
DO iw =1, nw - 1
o2xs(iz,iw) = o2xs1(iw)
ENDDO
ENDDO
IF(wl(1) .GT. wlsrb(nsrb)) RETURN
*----------------------------------------------------------------------
* Slant O2 column and x-sections.
*----------------------------------------------------------------------
DO iz = 1, nz
o2col(iz) = 0.2095 * scol(iz)
ENDDO
*----------------------------------------------------------------------
* On first call, check that the user wavelength grid, WL(IW), is compatible
* with the wavelengths for the parameterizations of the Lyman-alpha and SRB.
* Also compute and save corresponding grid indices (ILA, ISRB)
*----------------------------------------------------------------------
IF (call1) THEN
** locate Lyman-alpha wavelengths on grid
ila = 0
DO iw = 1, nw
IF(ABS(wl(iw) - wlla(1)) .LT. 10.*precis) THEN
ila = iw
GO TO 5
ENDIF
ENDDO
5 CONTINUE
* check
IF(ila .EQ. 0) THEN
WRITE(*,*) 'For wavelengths below 205.8 nm, only the'
WRITE(*,*) 'pre-specified wavelength grid is permitted'
WRITE(*,*) 'Use nwint=-156, or edit subroutine gridw.f'
STOP ' Lyman alpha grid mis-match - 1'
ENDIF
DO i = 2, nla + 1
IF(ABS(wl(ila + i - 1) - wlla(i)) .GT. 10.*precis) THEN
WRITE(*,*) 'Lyman alpha grid mis-match - 2'
STOP
ENDIF
ENDDO
** locate Schumann-Runge wavelengths on grid
isrb = 0
DO iw = 1, nw
IF(ABS(wl(iw) - wlsrb(1)) .LT. 10.*precis) THEN
isrb = iw
GO TO 6
ENDIF
ENDDO
6 CONTINUE
* check
IF(isrb .EQ. 0) THEN
WRITE(*,*) 'For wavelengths below 205.8 nm, only the'
WRITE(*,*) 'pre-specified wavelength grid is permitted'
WRITE(*,*) 'Use nwint=-156, or edit subroutine gridw.f'
STOP ' SRB grid mis-match - 1'
ENDIF
DO i = 2, nsrb + 1
IF(ABS(wl(isrb + i - 1) - wlsrb(i)) .GT. 10.* precis) THEN
WRITE(*,*) ' SRB grid mismatch - w'
STOP
ENDIF
ENDDO
IF (call1) call1 = .FALSE.
ENDIF
*----------------------------------------------------------------------
* Effective secant of solar zenith angle.
* Use 2.0 if no direct sun (value for isotropic radiation)
* For nz, use value at nz-1
*----------------------------------------------------------------------
DO i = 1, nz - 1
secchi(i) = scol(i)/vcol(i)
IF(scol(i) .GT. largest/10.) secchi(i) = 2.
ENDDO
secchi(nz) = secchi(nz-1)
*---------------------------------------------------------------------
* Lyman-Alpha parameterization, output values of O2 optical depth
* and O2 effective (equivalent) cross section
*----------------------------------------------------------------------
CALL lymana(nz,o2col,secchi,dto2la,o2xsla,kout)
DO iw = ila, ila + nla - 1
DO iz = 1, nz
dto2(iz,iw) = dto2la(iz, iw - ila + 1)
o2xs(iz,iw) = o2xsla(iz, iw - ila + 1)
ENDDO
ENDDO
*------------------------------------------------------------------------------
* Koppers' parameterization of the SR bands, output values of O2
* optical depth and O2 equivalent cross section
*------------------------------------------------------------------------------
CALL schum(nz,o2col,tlev,secchi,dto2k,o2xsk,kout)
DO iw = isrb, isrb + nsrb - 1
DO iz = 1, nz
dto2(iz,iw) = dto2k(iz, iw - isrb + 1)
o2xs(iz,iw) = o2xsk(iz, iw - isrb + 1)
ENDDO
ENDDO
RETURN
END
*=============================================================================*
SUBROUTINE lymana(nz,o2col,secchi,dto2la,o2xsla,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Calculate the effective absorption cross section of O2 in the Lyman-Alpha=*
*= bands and an effective O2 optical depth at all altitudes. Parameterized =*
*= after: Chabrillat, S., and G. Kockarts, Simple parameterization of the =*
*= absorption of the solar Lyman-Alpha line, Geophysical Research Letters, =*
*= Vol.24, No.21, pp 2659-2662, 1997. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= O2COL - REAL, slant overhead O2 column (molec/cc) at each specified (I)=*
*= altitude =*
*= DTO2LA - REAL, optical depth due to O2 absorption at each specified (O)=*
*= vertical layer =*
*= O2XSLA - REAL, molecular absorption cross section in LA bands (O)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
* input:
c c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input:
INTEGER nz
REAL o2col(kz)
REAL secchi(kz)
* output
REAL dto2la(kz,*), o2xsla(kz,*)
* local variables
REAL(kind(0.0d0)) :: rm(kz), ro2(kz)
REAL(kind(0.0d0)) :: b(3), c(3), d(3), e(3)
DATA b/ 6.8431D-01, 2.29841D-01, 8.65412D-02/,
> c/8.22114D-21, 1.77556D-20, 8.22112D-21/,
> d/ 6.0073D-21, 4.28569D-21, 1.28059D-20/,
> e/8.21666D-21, 1.63296D-20, 4.85121D-17/
INTEGER iz, i
REAL xsmin
*------------------------------------------------------------------------------*
*sm: set minimum cross section
xsmin = 1.e-20
* calculate reduction factors at every altitude
DO iz = 1, nz
rm(iz) = 0.D+00
ro2(iz) = 0.D+00
DO i = 1, 3
rm(iz) = rm(iz) + b(i) * EXP(-c(i) * DBLE(o2col(iz)))
ro2(iz) = ro2(iz) + d(i) * EXP(-e(i) * DBLE(o2col(iz)))
ENDDO
ENDDO
* calculate effective O2 optical depths and effective O2 cross sections
DO iz = 1, nz-1
IF (rm(iz) .GT. 1.0D-100) THEN
IF (ro2(iz) .GT. 1.D-100) THEN
o2xsla(iz,1) = ro2(iz)/rm(iz)
ELSE
o2xsla(iz,1) = xsmin
ENDIF
IF (rm(iz+1) .GT. 0.) THEN
dto2la(iz,1) = LOG(rm(iz+1)) / secchi(iz+1)
$ - LOG(rm(iz)) / secchi(iz)
ELSE
dto2la(iz,1) = 1000.
ENDIF
ELSE
dto2la(iz,1) = 1000.
o2xsla(iz,1) = xsmin
ENDIF
ENDDO
* do top layer separately
dto2la(nz,1) = 0.
IF(rm(nz) .GT. 1.D-100) THEN
o2xsla(nz,1) = ro2(nz)/rm(nz)
ELSE
o2xsla(nz,1) = xsmin
ENDIF
*----------------------------------------------------------------------------*
END
*=============================================================================*
SUBROUTINE schum(nz, o2col, tlev, secchi, dto2, o2xsk,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Calculate the equivalent absorption cross section of O2 in the SR bands. =*
*= The algorithm is based on parameterization of G.A. Koppers, and =*
*= D.P. Murtagh [ref. Ann.Geophys., 14 68-79, 1996] =*
*= Final values do include effects from the Herzberg continuum. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= O2COL - REAL, slant overhead O2 column (molec/cc) at each specified (I)=*
*= altitude =*
*= TLEV - tmeperature at each level (I)=*
*= SECCHI - ratio of slant to vertical o2 columns (I)=*
*= DTO2 - REAL, optical depth due to O2 absorption at each specified (O)=*
*= vertical layer at each specified wavelength =*
*= O2XSK - REAL, molecular absorption cross section in SR bands at (O)=*
*= each specified wavelength. Includes Herzberg continuum =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
*----------
INTEGER nz
REAL o2col(kz), o2col1(kz)
REAL tlev(kz), secchi(kz)
REAL dto2(kz,17), o2xsk(kz,17)
INTEGER i, k, ktop, ktop1, kbot
REAL XS(17), X
REAL xslod(17)
LOGICAL firstcall
SAVE firstcall
DATA firstcall /.TRUE./
DATA xslod /6.2180730E-21, 5.8473627E-22, 5.6996334E-22,
$ 4.5627094E-22, 1.7668250E-22, 1.1178808E-22,
$ 1.2040544E-22, 4.0994668E-23, 1.8450616E-23,
$ 1.5639540E-23, 8.7961075E-24, 7.6475608E-24,
$ 7.6260556E-24, 7.5565696E-24, 7.6334338E-24,
$ 7.4371992E-24, 7.3642966E-24/
c------------------------------------------
*sm Initialize cross sections to values
*sm at large optical depth
c------------------------------------------
DO k = 1, nz
DO i = 1, 17
o2xsk(k,i) = xslod(i)
ENDDO
ENDDO
c------------------------------------------
c Loads Chebyshev polynomial Coeff.
c------------------------------------------
IF (firstcall) THEN
CALL INIT_XS
firstcall = .FALSE.
ENDIF
c------------------------------------------
c Calculate cross sections
*sm: Set smallest O2col = exp(38.) molec cm-2
*sm to stay in range of parameterization
*sm given by Koppers et al. at top of atm.
c------------------------------------------
ktop = 121
kbot = 0
DO k=1,nz !! loop for alt
o2col1(k) = MAX(o2col(k),EXP(38.))
x = ALOG(o2col1(k))
IF (x .LT. 38.0) THEN
ktop1 = k-1
ktop = MIN(ktop1,ktop)
ELSE IF (x .GT. 56.0) THEN
kbot = k
ELSE
CALL effxs( x, tlev(k), xs )
DO i=1,17
o2xsk(k,i) = xs(i)
END DO
ENDIF
END DO !! finish loop for alt
c------------------------------------------
c fill in cross section where X is out of range
c by repeating edge table values
c------------------------------------------
*sm do not allow kbot = nz to avoid division by zero in
* no light case.
IF(kbot .EQ. nz) kbot = nz - 1
DO k=1,kbot
DO i=1,17
o2xsk(k,i) = o2xsk(kbot+1,i)
END DO
END DO
DO k=ktop+1,nz
DO i=1,17
o2xsk(k,i) = o2xsk(ktop,i)
END DO
END DO
c------------------------------------------
c Calculate incremental optical depths
c------------------------------------------
DO i=1,17 ! loop over wavelength
DO k=1,nz-1 ! loop for alt
c... calculate an optical depth weighted by density
*sm: put in mean value estimate, if in shade
IF (ABS(1. - o2col1(k+1)/o2col1(k)) .LE. 2.*precis) THEN
dto2(k,i) = o2xsk(k+1,i)*o2col1(k+1)/(nz-1)
ELSE
dto2(k,i) = ABS(
$ ( o2xsk(k+1,i)*o2col1(k+1) - o2xsk(k,i)*o2col1(k) )
$ / ( 1. + ALOG(o2xsk(k+1,i)/o2xsk(k,i))
$ / ALOG(o2col1(k+1)/o2col1(k)) ) )
c... change to vertical optical depth
dto2(k,i) = 2. * dto2(k,i) / (secchi(k)+secchi(k+1))
ENDIF
END DO
dto2(nz,i) = 0.0 ! set optical depth to zero at top
END DO
RETURN
END
*=============================================================================*
SUBROUTINE EFFXS( X, T, XS )
C Subroutine for evaluating the effective cross section
C of O2 in the Schumann-Runge bands using parameterization
C of G.A. Koppers, and D.P. Murtagh [ref. Ann.Geophys., 14
C 68-79, 1996]
C
C method:
C ln(xs) = A(X)[T-220]+B(X)
C X = log of slant column of O2
C A,B calculated from Chebyshev polynomial coeffs
C AC and BC using NR routine chebev. Assume interval
C is 38<ln(NO2)<56.
C
C Revision History:
C
C drm 2/97 initial coding
C
C-------------------------------------------------------------
IMPLICIT NONE
REAL NO2, T, X
REAL XS(17)
REAL A(17), B(17)
INTEGER I
CALL CALC_PARAMS( X, A, B )
DO I = 1,17
XS(I) = EXP( A(I)*( T - 220.) + B(I) )
ENDDO
RETURN
END
*=============================================================================*
SUBROUTINE CALC_PARAMS( X, A, B )
C-------------------------------------------------------------
C
C calculates coefficients (A,B), used in calculating the
C effective cross section, for 17 wavelength intervals
C as a function of log O2 column density (X)
C Wavelength intervals are defined in WMO1985
C
C-------------------------------------------------------------
IMPLICIT NONE
REAL X
REAL A(17), B(17)
REAL CHEBEV
REAL(kind(0.0d0)) :: AC(20,17)
REAL(kind(0.0d0)) :: BC(20,17) ! Chebyshev polynomial coeffs
REAL WAVE_NUM(17)
COMMON /XS_COEFFS/ AC, BC, WAVE_NUM
INTEGER I
C call Chebyshev Evaluation routine to calc A and B from
C set of 20 coeficients for each wavelength
DO I=1,17
A(I) = CHEBEV(38.0 , 56.0, AC(1,I), 20, X)
B(I) = CHEBEV(38.0 , 56.0, BC(1,I), 20, X)
ENDDO
RETURN
END
*=============================================================================*
SUBROUTINE INIT_XS
C-------------------------------------------------------------
C loads COMMON block XS_COEFFS containing the Chebyshev
C polynomial coeffs necessary to calculate O2 effective
C cross-sections
C
C-------------------------------------------------------------
REAL(kind(0.0d0)) :: AC(20,17)
REAL(kind(0.0d0)) :: BC(20,17) ! Chebyshev polynomial coeffs
REAL WAVE_NUM(17)
COMMON /XS_COEFFS/ AC, BC, WAVE_NUM
C locals
INTEGER IN_LUN ! file unit number
INTEGER IOST ! i/o status
INTEGER I, J
IN_LUN = -1
OPEN (NEWUNIT=IN_LUN, FILE=
$ 'DATAE1/O2/effxstex.txt',FORM='FORMATTED')
READ( IN_LUN, 901 )
DO I = 1,20
READ( IN_LUN, 903 ) ( AC(I,J), J=1,17 )
ENDDO
READ( IN_LUN, 901 )
DO I = 1,20
READ( IN_LUN, 903 ) ( BC(I,J), J=1,17 )
ENDDO
901 FORMAT( / )
903 FORMAT( 17(E23.14,1x))
998 CLOSE (IN_LUN)
DO I=1,17
WAVE_NUM(18-I) = 48250. + (500.*I)
ENDDO
END
*=============================================================================*
FUNCTION chebev(a,b,c,m,x)
C-------------------------------------------------------------
C
C Chebyshev evaluation algorithm
C See Numerical recipes p193
C
C-------------------------------------------------------------
INTEGER M
REAL CHEBEV,A,B,X
REAL(kind(0.0d0)) :: C(M)
INTEGER J
REAL D,DD,SV,Y,Y2
IF ((X-A)*(X-B).GT.0.) THEN
c WRITE(6,*) 'X NOT IN RANGE IN CHEBEV', X
CHEBEV = 0.0
RETURN
ENDIF
D=0.
DD=0.
Y=(2.*X-A-B)/(B-A)
Y2=2.*Y
DO 11 J=M,2,-1
SV=D
D=Y2*D-DD+C(J)
DD=SV
11 CONTINUE
CHEBEV=Y*D-DD+0.5*C(1)
RETURN
END
*=============================================================================*
SUBROUTINE sjo2(nz,nw,xso2,nj,sq,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Update the weighting function (cross section x quantum yield) for O2 =*
*= photolysis. The strong spectral variations in the O2 cross sections are =*
*= parameterized into a few bands for Lyman-alpha (121.4-121.9 nm, one band)=*
*= and Schumann-Runge (174.4-205.8, 17 bands) regions. The parameterizations=*
*= depend on the overhead O2 column, and therefore on altitude and solar =*
*= zenith angle, so they need to be updated at each time/zenith step. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= XSO2 - REAL, molecular absorption cross section in SR bands at (I)=*
*= each specified altitude and wavelength. Includes Herzberg =*
*= continuum. =*
*= NJ - INTEGER, index of O2 photolysis in array SQ (I)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction, at each wavelength and each altitude level =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* calling parameters
INTEGER nz, nw, nj
REAL xso2(kz,kw)
REAL sq(kj,kz,kw)
* local
INTEGER iw, iz
*______________________________________________________________________________
* O2 + hv -> O + O
* quantum yield assumed to be unity
* assign cross section values at all wavelengths and at all altitudes
* qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(nj,iz,iw) = xso2(iz,iw)
ENDDO
ENDDO
*______________________________________________________________________________
RETURN
END
CCC FILE numer.f
* This file contains the following subroutines, related to interpolations
* of input data, addition of points to arrays, and zeroing of arrays:
* inter1
* inter2
* inter3
* inter4
* addpnt
* zero1
* zero2
*=============================================================================*
SUBROUTINE inter1(ng,xg,yg, n,x,y)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Map input data given on single, discrete points, onto a discrete target =*
*= grid. =*
*= The original input data are given on single, discrete points of an =*
*= arbitrary grid and are being linearly interpolated onto a specified =*
*= discrete target grid. A typical example would be the re-gridding of a =*
*= given data set for the vertical temperature profile to match the speci- =*
*= fied altitude grid. =*
*= Some caution should be used near the end points of the grids. If the =*
*= input data set does not span the range of the target grid, the remaining =*
*= points will be set to zero, as extrapolation is not permitted. =*
*= If the input data does not encompass the target grid, use ADDPNT to =*
*= expand the input array. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NG - INTEGER, number of points in the target grid (I)=*
*= XG - REAL, target grid (e.g. altitude grid) (I)=*
*= YG - REAL, y-data re-gridded onto XG (O)=*
*= N - INTEGER, number of points in the input data set (I)=*
*= X - REAL, grid on which input data are defined (I)=*
*= Y - REAL, input y-data (I)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
* input:
INTEGER n, ng
REAL xg(ng)
REAL x(n), y(n)
* output:
REAL yg(ng)
* local:
REAL slope
INTEGER jsave, i, j
*_______________________________________________________________________
jsave = 1
DO 20, i = 1, ng
yg(i) = 0.
j = jsave
10 CONTINUE
IF ((x(j) .GT. xg(i)) .OR. (xg(i) .GE. x(j+1))) THEN
j = j+1
IF (j .LE. n-1) GOTO 10
* ---- end of loop 10 ----
ELSE
slope = (y(j+1)-y(j)) / (x(j+1)-x(j))
yg(i) = y(j) + slope * (xg(i) - x(j))
jsave = j
ENDIF
20 CONTINUE
*_______________________________________________________________________
RETURN
END
*=============================================================================*
SUBROUTINE inter2(ng,xg,yg,n,x,y,ierr)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Map input data given on single, discrete points onto a set of target =*
*= bins. =*
*= The original input data are given on single, discrete points of an =*
*= arbitrary grid and are being linearly interpolated onto a specified set =*
*= of target bins. In general, this is the case for most of the weighting =*
*= functions (action spectra, molecular cross section, and quantum yield =*
*= data), which have to be matched onto the specified wavelength intervals. =*
*= The average value in each target bin is found by averaging the trapezoi- =*
*= dal area underneath the input data curve (constructed by linearly connec-=*
*= ting the discrete input values). =*
*= Some caution should be used near the endpoints of the grids. If the =*
*= input data set does not span the range of the target grid, an error =*
*= message is printed and the execution is stopped, as extrapolation of the =*
*= data is not permitted. =*
*= If the input data does not encompass the target grid, use ADDPNT to =*
*= expand the input array. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NG - INTEGER, number of bins + 1 in the target grid (I)=*
*= XG - REAL, target grid (e.g., wavelength grid); bin i is defined (I)=*
*= as [XG(i),XG(i+1)] (i = 1..NG-1) =*
*= YG - REAL, y-data re-gridded onto XG, YG(i) specifies the value for (O)=*
*= bin i (i = 1..NG-1) =*
*= N - INTEGER, number of points in input grid (I)=*
*= X - REAL, grid on which input data are defined (I)=*
*= Y - REAL, input y-data (I)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
* input:
INTEGER ng, n
REAL x(n), y(n), xg(ng)
* output:
REAL yg(ng)
* local:
REAL area, xgl, xgu
REAL darea, slope
REAL a1, a2, b1, b2
INTEGER ngintv
INTEGER i, k, jstart
INTEGER ierr
*_______________________________________________________________________
ierr = 0
* test for correct ordering of data, by increasing value of x
DO 10, i = 2, n
IF (x(i) .LE. x(i-1)) THEN
ierr = 1
WRITE(*,*)'data not sorted'
RETURN
ENDIF
10 CONTINUE
DO i = 2, ng
IF (xg(i) .LE. xg(i-1)) THEN
ierr = 2
WRITE(0,*) '>>> ERROR (inter2) <<< xg-grid not sorted!'
RETURN
ENDIF
ENDDO
* check for xg-values outside the x-range
IF ( (x(1) .GT. xg(1)) .OR. (x(n) .LT. xg(ng)) ) THEN
WRITE(0,*) '>>> ERROR (inter2) <<< Data do not span '//
> 'grid. '
WRITE(0,*) ' Use ADDPNT to '//
> 'expand data and re-run.'
STOP
ENDIF
* find the integral of each grid interval and use this to
* calculate the average y value for the interval
* xgl and xgu are the lower and upper limits of the grid interval
jstart = 1
ngintv = ng - 1
DO 50, i = 1,ngintv
* initalize:
area = 0.0
xgl = xg(i)
xgu = xg(i+1)
* discard data before the first grid interval and after the
* last grid interval
* for internal grid intervals, start calculating area by interpolating
* between the last point which lies in the previous interval and the
* first point inside the current interval
k = jstart
IF (k .LE. n-1) THEN
* if both points are before the first grid, go to the next point
30 CONTINUE
IF (x(k+1) .LE. xgl) THEN
jstart = k - 1
k = k+1
IF (k .LE. n-1) GO TO 30
ENDIF
* if the last point is beyond the end of the grid, complete and go to the next
* grid
40 CONTINUE
IF ((k .LE. n-1) .AND. (x(k) .LT. xgu)) THEN
jstart = k-1
* compute x-coordinates of increment
a1 = MAX(x(k),xgl)
a2 = MIN(x(k+1),xgu)
* if points coincide, contribution is zero
IF (x(k+1).EQ.x(k)) THEN
darea = 0.e0
ELSE
slope = (y(k+1) - y(k))/(x(k+1) - x(k))
b1 = y(k) + slope*(a1 - x(k))
b2 = y(k) + slope*(a2 - x(k))
darea = (a2 - a1)*(b2 + b1)/2.
ENDIF
* find the area under the trapezoid from a1 to a2
area = area + darea
* go to next point
k = k+1
GO TO 40
ENDIF
ENDIF
* calculate the average y after summing the areas in the interval
yg(i) = area/(xgu - xgl)
50 CONTINUE
*_______________________________________________________________________
RETURN
END
*=============================================================================*
SUBROUTINE inter3(ng,xg,yg, n,x,y, FoldIn)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Map input data given on a set of bins onto a different set of target =*
*= bins. =*
*= The input data are given on a set of bins (representing the integral =*
*= of the input quantity over the range of each bin) and are being matched =*
*= onto another set of bins (target grid). A typical example would be an =*
*= input data set spcifying the extra-terrestrial flux on wavelength inter- =*
*= vals, that has to be matched onto the working wavelength grid. =*
*= The resulting area in a given bin of the target grid is calculated by =*
*= simply adding all fractional areas of the input data that cover that =*
*= particular target bin. =*
*= Some caution should be used near the endpoints of the grids. If the =*
*= input data do not span the full range of the target grid, the area in =*
*= the "missing" bins will be assumed to be zero. If the input data extend =*
*= beyond the upper limit of the target grid, the user has the option to =*
*= integrate the "overhang" data and fold the remaining area back into the =*
*= last target bin. Using this option is recommended when re-gridding =*
*= vertical profiles that directly affect the total optical depth of the =*
*= model atmosphere. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NG - INTEGER, number of bins + 1 in the target grid (I)=*
*= XG - REAL, target grid (e.g. working wavelength grid); bin i (I)=*
*= is defined as [XG(i),XG(i+1)] (i = 1..NG-1) =*
*= YG - REAL, y-data re-gridded onto XG; YG(i) specifies the (O)=*
*= y-value for bin i (i = 1..NG-1) =*
*= N - INTEGER, number of bins + 1 in the input grid (I)=*
*= X - REAL, input grid (e.g. data wavelength grid); bin i is (I)=*
*= defined as [X(i),X(i+1)] (i = 1..N-1) =*
*= Y - REAL, input y-data on grid X; Y(i) specifies the (I)=*
*= y-value for bin i (i = 1..N-1) =*
*= FoldIn - Switch for folding option of "overhang" data (I)=*
*= FoldIn = 0 -> No folding of "overhang" data =*
*= FoldIn = 1 -> Integerate "overhang" data and fold back into =*
*= last target bin =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
* input:
INTEGER n, ng
REAL xg(ng)
REAL x(n), y(n)
INTEGER FoldIn
* output:
REAL yg(ng)
* local:
REAL a1, a2, sum
REAL tail
INTEGER jstart, i, j, k
*_______________________________________________________________________
* check whether flag given is legal
IF ((FoldIn .NE. 0) .AND. (FoldIn .NE. 1)) THEN
WRITE(0,*) '>>> ERROR (inter3) <<< Value for FOLDIN invalid. '
WRITE(0,*) ' Must be 0 or 1'
STOP
ENDIF
* do interpolation
jstart = 1
DO 30, i = 1, ng - 1
yg(i) = 0.
sum = 0.
j = jstart
IF (j .LE. n-1) THEN
20 CONTINUE
IF (x(j+1) .LT. xg(i)) THEN
jstart = j
j = j+1
IF (j .LE. n-1) GO TO 20
ENDIF
25 CONTINUE
IF ((x(j) .LE. xg(i+1)) .AND. (j .LE. n-1)) THEN
a1 = AMAX1(x(j),xg(i))
a2 = AMIN1(x(j+1),xg(i+1))
sum = sum + y(j) * (a2-a1)/(x(j+1)-x(j))
j = j+1
GO TO 25
ENDIF
yg(i) = sum
ENDIF
30 CONTINUE
* if wanted, integrate data "overhang" and fold back into last bin
IF (FoldIn .EQ. 1) THEN
j = j-1
a1 = xg(ng) ! upper limit of last interpolated bin
a2 = x(j+1) ! upper limit of last input bin considered
* do folding only if grids don't match up and there is more input
IF ((a2 .GT. a1) .OR. (j+1 .LT. n)) THEN
tail = y(j) * (a2-a1)/(x(j+1)-x(j))
DO k = j+1, n-1
tail = tail + y(k) * (x(k+1)-x(k))
ENDDO
yg(ng-1) = yg(ng-1) + tail
ENDIF
ENDIF
*_______________________________________________________________________
RETURN
END
*=============================================================================*
SUBROUTINE inter4(ng,xg,yg, n,x,y, FoldIn)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Map input data given on a set of bins onto a different set of target =*
*= bins. =*
*= The input data are given on a set of bins (representing the integral =*
*= of the input quantity over the range of each bin) and are being matched =*
*= onto another set of bins (target grid). A typical example would be an =*
*= input data set spcifying the extra-terrestrial flux on wavelength inter- =*
*= vals, that has to be matched onto the working wavelength grid. =*
*= The resulting area in a given bin of the target grid is calculated by =*
*= simply adding all fractional areas of the input data that cover that =*
*= particular target bin. =*
*= Some caution should be used near the endpoints of the grids. If the =*
*= input data do not span the full range of the target grid, the area in =*
*= the "missing" bins will be assumed to be zero. If the input data extend =*
*= beyond the upper limit of the target grid, the user has the option to =*
*= integrate the "overhang" data and fold the remaining area back into the =*
*= last target bin. Using this option is recommended when re-gridding =*
*= vertical profiles that directly affect the total optical depth of the =*
*= model atmosphere. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NG - INTEGER, number of bins + 1 in the target grid (I)=*
*= XG - REAL, target grid (e.g. working wavelength grid); bin i (I)=*
*= is defined as [XG(i),XG(i+1)] (i = 1..NG-1) =*
*= YG - REAL, y-data re-gridded onto XG; YG(i) specifies the (O)=*
*= y-value for bin i (i = 1..NG-1) =*
*= N - INTEGER, number of bins + 1 in the input grid (I)=*
*= X - REAL, input grid (e.g. data wavelength grid); bin i is (I)=*
*= defined as [X(i),X(i+1)] (i = 1..N-1) =*
*= Y - REAL, input y-data on grid X; Y(i) specifies the (I)=*
*= y-value for bin i (i = 1..N-1) =*
*= FoldIn - Switch for folding option of "overhang" data (I)=*
*= FoldIn = 0 -> No folding of "overhang" data =*
*= FoldIn = 1 -> Integerate "overhang" data and fold back into =*
*= last target bin =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
* input:
INTEGER n, ng
REAL xg(ng)
REAL x(n), y(n)
INTEGER FoldIn
* output:
REAL yg(ng)
* local:
REAL a1, a2, sum
REAL tail
INTEGER jstart, i, j, k
*_______________________________________________________________________
* check whether flag given is legal
IF ((FoldIn .NE. 0) .AND. (FoldIn .NE. 1)) THEN
WRITE(0,*) '>>> ERROR (inter3) <<< Value for FOLDIN invalid. '
WRITE(0,*) ' Must be 0 or 1'
STOP
ENDIF
* do interpolation
jstart = 1
DO 30, i = 1, ng - 1
yg(i) = 0.
sum = 0.
j = jstart
IF (j .LE. n-1) THEN
20 CONTINUE
IF (x(j+1) .LT. xg(i)) THEN
jstart = j
j = j+1
IF (j .LE. n-1) GO TO 20
ENDIF
25 CONTINUE
IF ((x(j) .LE. xg(i+1)) .AND. (j .LE. n-1)) THEN
a1 = AMAX1(x(j),xg(i))
a2 = AMIN1(x(j+1),xg(i+1))
sum = sum + y(j) * (a2-a1)
j = j+1
GO TO 25
ENDIF
yg(i) = sum /(xg(i+1)-xg(i))
ENDIF
30 CONTINUE
* if wanted, integrate data "overhang" and fold back into last bin
IF (FoldIn .EQ. 1) THEN
j = j-1
a1 = xg(ng) ! upper limit of last interpolated bin
a2 = x(j+1) ! upper limit of last input bin considered
* do folding only if grids don't match up and there is more input
IF ((a2 .GT. a1) .OR. (j+1 .LT. n)) THEN
tail = y(j) * (a2-a1)/(x(j+1)-x(j))
DO k = j+1, n-1
tail = tail + y(k) * (x(k+1)-x(k))
ENDDO
yg(ng-1) = yg(ng-1) + tail
ENDIF
ENDIF
*_______________________________________________________________________
RETURN
END
*=============================================================================*
SUBROUTINE addpnt ( x, y, ld, n, xnew, ynew )
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Add a point <xnew,ynew> to a set of data pairs <x,y>. x must be in =*
*= ascending order =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= X - REAL vector of length LD, x-coordinates (IO)=*
*= Y - REAL vector of length LD, y-values (IO)=*
*= LD - INTEGER, dimension of X, Y exactly as declared in the calling (I)=*
*= program =*
*= N - INTEGER, number of elements in X, Y. On entry, it must be: (IO)=*
*= N < LD. On exit, N is incremented by 1. =*
*= XNEW - REAL, x-coordinate at which point is to be added (I)=*
*= YNEW - REAL, y-value of point to be added (I)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
* calling parameters
INTEGER ld, n
REAL x(ld), y(ld)
REAL xnew, ynew
* local variables
INTEGER insert
INTEGER i
*-----------------------------------------------------------------------
* check n<ld to make sure x will hold another point
IF (n .GE. ld) THEN
WRITE(0,*) '>>> ERROR (ADDPNT) <<< Cannot expand array '
WRITE(0,*) ' All elements used.'
STOP
ENDIF
insert = 1
i = 2
* check, whether x is already sorted.
* also, use this loop to find the point at which xnew needs to be inserted
* into vector x, if x is sorted.
10 CONTINUE
IF (i .LT. n) THEN
IF (x(i) .LT. x(i-1)) THEN
WRITE(0,*) '>>> ERROR (ADDPNT) <<< x-data must be '//
> 'in ascending order!'
STOP
ELSE
IF (xnew .GT. x(i)) insert = i + 1
ENDIF
i = i+1
GOTO 10
ENDIF
* if <xnew,ynew> needs to be appended at the end, just do so,
* otherwise, insert <xnew,ynew> at position INSERT
IF ( xnew .GT. x(n) ) THEN
x(n+1) = xnew
y(n+1) = ynew
ELSE
* shift all existing points one index up
DO i = n, insert, -1
x(i+1) = x(i)
y(i+1) = y(i)
ENDDO
* insert new point
x(insert) = xnew
y(insert) = ynew
ENDIF
* increase total number of elements in x, y
n = n+1
END
*=============================================================================*
SUBROUTINE zero1(x,m)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Initialize all elements of a floating point vector with zero. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= X - REAL, vector to be initialized (O)=*
*= M - INTEGER, number of elements in X (I)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
INTEGER i, m
REAL x(m)
DO 1 i = 1, m
x(i) = 0.
1 CONTINUE
RETURN
END
*=============================================================================*
SUBROUTINE zero2(x,m,n)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Initialize all elements of a 2D floating point array with zero. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= X - REAL, array to be initialized (O)=*
*= M - INTEGER, number of elements along the first dimension of X, (I)=*
*= exactly as specified in the calling program =*
*= N - INTEGER, number of elements along the second dimension of X, (I)=*
*= exactly as specified in the calling program =*
*-----------------------------------------------------------------------------*
IMPLICIT none
* m,n : dimensions of x, exactly as specified in the calling program
INTEGER i, j, m, n
REAL x(m,n)
DO 1 j = 1, n
DO 2 i = 1, m
x(i,j) = 0.
2 CONTINUE
1 CONTINUE
RETURN
END
CCC FILE odo3.f
*=============================================================================*
SUBROUTINE odo3(nz,z,nw,wl,o3xs,c, dto3,kout)
*-----------------------------------------------------------------------------*
*= NAME: Optical Depths of O3
*= PURPOSE: =*
*= Compute ozone optical depths as a function of altitude and wavelength +*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= O3XS - REAL, molecular absoprtion cross section (cm^2) of O3 at (I)=*
*= each specified wavelength and altitude =*
*= C - REAL, ozone vertical column increments, molec cm-2, for each (I)=*
*= layer =*
*= DTO3 - REAL, optical depth due to ozone absorption at each (O)=*
*= specified altitude at each specified wavelength =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
********
* input:
********
* grids:
INTEGER nw
INTEGER nz
REAL wl(kw)
REAL z(kz)
* ozone absorption cross section, functions of wavelength and altitude
REAL o3xs(kz,kw)
* ozone vertical column increments
REAL c(kz)
********
* output:
********
REAL dto3(kz,kw)
********
* internal:
********
INTEGER iw, iz
*_______________________________________________________________________
* calculate ozone optical depth for each layer, with temperature
* correction. Output, dto3(kz,kw)
DO 20, iw = 1, nw-1
DO 10, iz = 1, nz - 1
dto3(iz,iw) = c(iz) * o3xs(iz,iw)
10 CONTINUE
20 CONTINUE
*_______________________________________________________________________
RETURN
END
CCC FILE odrl.f
*=============================================================================*
SUBROUTINE odrl(nz,z,nw,wl, c,
$ dtrl,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Compute Rayleigh optical depths as a function of altitude and wavelength =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= C - REAL, number of air molecules per cm^2 at each specified (O)=*
*= altitude layer =*
*= DTRL - REAL, Rayleigh optical depth at each specified altitude (O)=*
*= and each specified wavelength =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input:
INTEGER nw, nz
REAL wl(kw), z(kz)
REAL c(kz)
* output:
* Rayleigh optical depths
REAL dtrl(kz,kw)
* other:
REAL srayl, wc, wmicrn, xx
INTEGER iz, iw
*_______________________________________________________________________
* compute Rayleigh cross sections and depths:
DO 10, iw = 1, nw - 1
wc = (wl(iw) + wl(iw+1))/2.
* Rayleigh scattering cross section from WMO 1985 (originally from
* Nicolet, M., On the molecular scattering in the terrestrial atmosphere:
* An empirical formula for its calculation in the homoshpere, Planet.
* Space Sci., 32, 1467-1468, 1984.
wmicrn = wc/1.E3
IF( wmicrn .LE. 0.55) THEN
xx = 3.6772 + 0.389*wmicrn + 0.09426/wmicrn
ELSE
xx = 4. + 0.04
ENDIF
srayl = 4.02e-28/(wmicrn)**xx
* alternate (older) expression from
* Frohlich and Shaw, Appl.Opt. v.11, p.1773 (1980).
C xx = 3.916 + 0.074*wmicrn + 0.050/wmicrn
C srayl(iw) = 3.90e-28/(wmicrn)**xx
DO 20, iz = 1, nz - 1
dtrl(iz,iw) = c(iz)*srayl
20 CONTINUE
10 CONTINUE
*_______________________________________________________________________
RETURN
END
CCC FILE orbit.f
* This file contains the following subroutines, related to the orbit and
* rotation of the Earth:
* calend
* sunae
*=============================================================================*
c SUBROUTINE calend(iyear, imonth, iday,
c $ jday, nday, oky, okm, okd)
c
c*-----------------------------------------------------------------------------*
c*= calculates julian day corresponding to specified year, month, day =*
c*= also checks validity of date =*
c*-----------------------------------------------------------------------------*
c
c IMPLICIT NONE
c
c* input:
c
c INTEGER iyear, imonth, iday
c
c* output:
c
c INTEGER jday, nday
c LOGICAL oky, okm, okd
c
c* internal
c
c INTEGER mday, month, imn(12)
c DATA imn/31,28,31,30,31,30,31,31,30,31,30,31/
c
c oky = .TRUE.
c okm = .TRUE.
c okd = .TRUE.
c
c IF(iyear .LT. 1950 .OR. iyear .GT. 2050) THEN
c WRITE(*,*) 'Year must be between 1950 and 2050)'
c oky = .FALSE.
c ENDIF
c
c IF(imonth .LT. 1 .OR. imonth .GT. 12) THEN
c WRITE(*,*) 'Month must be between 1 and 12'
c okm = .FALSE.
c ENDIF
c
c IF ( MOD(iyear,4) .EQ. 0) THEN
c imn(2) = 29
c ELSE
c imn(2) = 28
c ENDIF
c
c IF (iday. GT. imn(imonth)) THEN
c WRITE(*,*) 'Day in date exceeds days in month'
c WRITE(*,*) 'month = ', imonth
c WRITE(*,*) 'day = ', iday
c okd = .FALSE.
c ENDIF
c
c mday = 0
c DO 12, month = 1, imonth-1
c mday = mday + imn(month)
c 12 CONTINUE
c jday = mday + iday
c
c nday = 365
c IF(imn(2) .EQ. 29) nday = 366
c
c RETURN
c END
c
c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c
c SUBROUTINE SUNAE( YEAR, DAY, HOUR, LAT, LONG, lrefr,
c & AZ, EL, SOLDIA, SOLDST )
c
c Calculates the local solar azimuth and elevation angles, and
c the distance to and angle subtended by the Sun, at a specific
c location and time using approximate formulas in The Astronomical
c Almanac. Accuracy of angles is 0.01 deg or better (the angular
c width of the Sun is about 0.5 deg, so 0.01 deg is more than
c sufficient for most applications).
c
c Unlike many GCM (and other) sun angle routines, this
c one gives slightly different sun angles depending on
c the year. The difference is usually down in the 4th
c significant digit but can slowly creep up to the 3rd
c significant digit after several decades to a century.
c
c A refraction correction appropriate for the "US Standard
c Atmosphere" is added, so that the returned sun position is
c the APPARENT one. The correction is below 0.1 deg for solar
c elevations above 9 deg. To remove it, comment out the code
c block where variable REFRAC is set, and replace it with
c REFRAC = 0.0.
c
c References:
c
c Michalsky, J., 1988: The Astronomical Almanac's algorithm for
c approximate solar position (1950-2050), Solar Energy 40,
c 227-235 (but the version of this program in the Appendix
c contains errors and should not be used)
c
c The Astronomical Almanac, U.S. Gov't Printing Office, Washington,
c D.C. (published every year): the formulas used from the 1995
c version are as follows:
c p. A12: approximation to sunrise/set times
c p. B61: solar elevation ("altitude") and azimuth
c p. B62: refraction correction
c p. C24: mean longitude, mean anomaly, ecliptic longitude,
c obliquity of ecliptic, right ascension, declination,
c Earth-Sun distance, angular diameter of Sun
c p. L2: Greenwich mean sidereal time (ignoring T^2, T^3 terms)
c
c
c Authors: Dr. Joe Michalsky (joe@asrc.albany.edu)
c Dr. Lee Harrison (lee@asrc.albany.edu)
c Atmospheric Sciences Research Center
c State University of New York
c Albany, New York
c
c Modified by: Dr. Warren Wiscombe (wiscombe@climate.gsfc.nasa.gov)
c NASA Goddard Space Flight Center
c Code 913
c Greenbelt, MD 20771
c
c
c WARNING: Do not use this routine outside the year range
c 1950-2050. The approximations become increasingly
c worse, and the calculation of Julian date becomes
c more involved.
c
c Input:
c
c YEAR year (INTEGER; range 1950 to 2050)
c
c DAY day of year at LAT-LONG location (INTEGER; range 1-366)
c
c HOUR hour of DAY [GMT or UT] (REAL; range -13.0 to 36.0)
c = (local hour) + (time zone number)
c + (Daylight Savings Time correction; -1 or 0)
C where (local hour) range is 0 to 24,
c (time zone number) range is -12 to +12, and
c (Daylight Time correction) is -1 if on Daylight Time
c (summer half of year), 0 otherwise;
c Example: 8:30 am Eastern Daylight Time would be
c
c HOUR = 8.5 + 5 - 1 = 12.5
c
c LAT latitude [degrees]
c (REAL; range -90.0 to 90.0; north is positive)
c
c LONG longitude [degrees]
c (REAL; range -180.0 to 180.0; east is positive)
c
c
c Output:
c
c AZ solar azimuth angle (measured east from north,
c 0 to 360 degs)
c
c EL solar elevation angle [-90 to 90 degs];
c solar zenith angle = 90 - EL
c
c SOLDIA solar diameter [degs]
c
c SOLDST distance to sun [Astronomical Units, AU]
c (1 AU = mean Earth-sun distance = 1.49597871E+11 m
c in IAU 1976 System of Astronomical Constants)
c
c
c Local Variables:
c
c DEC Declination (radians)
c
c ECLONG Ecliptic longitude (radians)
c
c GMST Greenwich mean sidereal time (hours)
c
c HA Hour angle (radians, -pi to pi)
c
c JD Modified Julian date (number of days, including
c fractions thereof, from Julian year J2000.0);
c actual Julian date is JD + 2451545.0
c
c LMST Local mean sidereal time (radians)
c
c MNANOM Mean anomaly (radians, normalized to 0 to 2*pi)
c
c MNLONG Mean longitude of Sun, corrected for aberration
c (deg; normalized to 0-360)
c
c OBLQEC Obliquity of the ecliptic (radians)
c
c RA Right ascension (radians)
c
c REFRAC Refraction correction for US Standard Atmosphere (degs)
c
c --------------------------------------------------------------------
c Uses double precision for safety and because Julian dates can
c have a large number of digits in their full form (but in practice
c this version seems to work fine in single precision if you only
c need about 3 significant digits and aren't doing precise climate
c change or solar tracking work).
c --------------------------------------------------------------------
c
c Why does this routine require time input as Greenwich Mean Time
c (GMT; also called Universal Time, UT) rather than "local time"?
c Because "local time" (e.g. Eastern Standard Time) can be off by
c up to half an hour from the actual local time (called "local mean
c solar time"). For society's convenience, "local time" is held
c constant across each of 24 time zones (each technically 15 longitude
c degrees wide although some are distorted, again for societal
c convenience). Local mean solar time varies continuously around a
c longitude belt; it is not a step function with 24 steps.
c Thus it is far simpler to calculate local mean solar time from GMT,
c by adding 4 min for each degree of longitude the location is
c east of the Greenwich meridian or subtracting 4 min for each degree
c west of it.
c
c --------------------------------------------------------------------
c
c TIME
c
c The measurement of time has become a complicated topic. A few
c basic facts are:
c
c (1) The Gregorian calendar was introduced in 1582 to replace
c Julian calendar; in it, every year divisible by four is a leap
c year just as in the Julian calendar except for centurial years
c which must be exactly divisible by 400 to be leap years. Thus
c 2000 is a leap year, but not 1900 or 2100.
c
c (2) The Julian day begins at Greenwich noon whereas the calendar
c day begins at the preceding midnight; and Julian years begin on
c "Jan 0" which is really Greenwich noon on Dec 31. True Julian
c dates are a continous count of day numbers beginning with JD 0 on
c 1 Jan 4713 B.C. The term "Julian date" is widely misused and few
c people understand it; it is best avoided unless you want to study
c the Astronomical Almanac and learn to use it correctly.
c
c (3) Universal Time (UT), the basis of civil timekeeping, is
c defined by a formula relating UT to GMST (Greenwich mean sidereal
c time). UTC (Coordinated Universal Time) is the time scale
c distributed by most broadcast time services. UT, UTC, and other
c related time measures are within a few sec of each other and are
c frequently used interchangeably.
c
c (4) Beginning in 1984, the "standard epoch" of the astronomical
c coordinate system is Jan 1, 2000, 12 hr TDB (Julian date
c 2,451,545.0, denoted J2000.0). The fact that this routine uses
c 1949 as a point of reference is merely for numerical convenience.
c --------------------------------------------------------------------
c
c .. Scalar Arguments ..
c
c LOGICAL lrefr
c
c
c INTEGER YEAR, DAY
c REAL AZ, EL, HOUR, LAT, LONG, SOLDIA, SOLDST
c ..
c .. Local Scalars ..
c
c LOGICAL PASS1
c INTEGER DELTA, LEAP
c REAL DEC, DEN, ECLONG, GMST, HA, JD, LMST,
c & MNANOM, MNLONG, NUM, OBLQEC, PI, RA,
c & RPD, REFRAC, TIME, TWOPI
c ..
c .. Intrinsic Functions ..
c
c INTRINSIC AINT, ASIN, ATAN, COS, MOD, SIN, TAN
c ..
c .. Data statements ..
c
c SAVE PASS1, PI, TWOPI, RPD
c DATA PASS1 /.True./
c ..
c
c IF( YEAR.LT.1950 .OR. YEAR.GT.2050 )
c & STOP 'SUNAE--bad input variable YEAR'
c IF( DAY.LT.1 .OR. DAY.GT.366 )
c & STOP 'SUNAE--bad input variable DAY'
c IF( HOUR.LT.-13.0 .OR. HOUR.GT.36.0 )
c & STOP 'SUNAE--bad input variable HOUR'
c IF( LAT.LT.-90.0 .OR. LAT.GT.90.0 )
c & STOP 'SUNAE--bad input variable LAT'
c IF( LONG.LT.-180.0 .OR. LONG.GT.180.0 )
c & STOP 'SUNAE--bad input variable LONG'
c
c IF(PASS1) THEN
c PI = 2.*ASIN( 1.0 )
c TWOPI = 2.*PI
c RPD = PI / 180.
c PASS1 = .False.
c ENDIF
c
c ** current Julian date (actually add 2,400,000
c ** for true JD); LEAP = leap days since 1949;
c ** 32916.5 is midnite 0 jan 1949 minus 2.4e6
c
c DELTA = YEAR - 1949
c LEAP = DELTA / 4
c JD = 32916.5 + (DELTA*365 + LEAP + DAY) + HOUR / 24.
c
c ** last yr of century not leap yr unless divisible
c ** by 400 (not executed for the allowed YEAR range,
c ** but left in so our successors can adapt this for
c ** the following 100 years)
c
c IF( MOD( YEAR, 100 ).EQ.0 .AND.
c & MOD( YEAR, 400 ).NE.0 ) JD = JD - 1.
c
c ** ecliptic coordinates
c ** 51545.0 + 2.4e6 = noon 1 jan 2000
c
c TIME = JD - 51545.0
c
c ** force mean longitude between 0 and 360 degs
c
c MNLONG = 280.460 + 0.9856474*TIME
c MNLONG = MOD( MNLONG, 360.D0 )
c IF( MNLONG.LT.0. ) MNLONG = MNLONG + 360.
c
c ** mean anomaly in radians between 0 and 2*pi
c
c MNANOM = 357.528 + 0.9856003*TIME
c MNANOM = MOD( MNANOM, 360.D0 )
c IF( MNANOM.LT.0.) MNANOM = MNANOM + 360.
c
c MNANOM = MNANOM*RPD
c
c ** ecliptic longitude and obliquity
c ** of ecliptic in radians
c
c ECLONG = MNLONG + 1.915*SIN( MNANOM ) + 0.020*SIN( 2.*MNANOM )
c ECLONG = MOD( ECLONG, 360.D0 )
c IF( ECLONG.LT.0. ) ECLONG = ECLONG + 360.
c
c OBLQEC = 23.439 - 0.0000004*TIME
c ECLONG = ECLONG*RPD
c OBLQEC = OBLQEC*RPD
c
c ** right ascension
c
c NUM = COS( OBLQEC )*SIN( ECLONG )
c DEN = COS( ECLONG )
c RA = ATAN( NUM / DEN )
c
c ** Force right ascension between 0 and 2*pi
c
c IF( DEN.LT.0.0 ) THEN
c RA = RA + PI
c ELSE IF( NUM.LT.0.0 ) THEN
c RA = RA + TWOPI
c END IF
c
c ** declination
c
c DEC = ASIN( SIN( OBLQEC )*SIN( ECLONG ) )
c
c ** Greenwich mean sidereal time in hours
c
c GMST = 6.697375 + 0.0657098242*TIME + HOUR
c
c ** Hour not changed to sidereal time since
c ** 'time' includes the fractional day
c
c GMST = MOD( GMST, 24.D0)
c IF( GMST.LT.0. ) GMST = GMST + 24.
c
c ** local mean sidereal time in radians
c
c LMST = GMST + LONG / 15.
c LMST = MOD( LMST, 24.D0 )
c IF( LMST.LT.0. ) LMST = LMST + 24.
c
c LMST = LMST*15.*RPD
c
c ** hour angle in radians between -pi and pi
c
c HA = LMST - RA
c
c IF( HA.LT.- PI ) HA = HA + TWOPI
c IF( HA.GT.PI ) HA = HA - TWOPI
c
c ** solar azimuth and elevation
c
c EL = ASIN( SIN( DEC )*SIN( LAT*RPD ) +
c & COS( DEC )*COS( LAT*RPD )*COS( HA ) )
c
c AZ = ASIN( - COS( DEC )*SIN( HA ) / COS( EL ) )
c
c ** Put azimuth between 0 and 2*pi radians
c
c IF( SIN( DEC ) - SIN( EL )*SIN( LAT*RPD ).GE.0. ) THEN
c
c IF( SIN(AZ).LT.0.) AZ = AZ + TWOPI
c
c ELSE
c
c AZ = PI - AZ
c
c END IF
c
c ** Convert elevation and azimuth to degrees
c EL = EL / RPD
c AZ = AZ / RPD
c
c ======== Refraction correction for U.S. Standard Atmos. ==========
c (assumes elevation in degs) (3.51823=1013.25 mb/288 K)
c
c IF( EL.GE.19.225 ) THEN
c
c REFRAC = 0.00452*3.51823 / TAN( EL*RPD )
c
c ELSE IF( EL.GT.-0.766 .AND. EL.LT.19.225 ) THEN
c
c REFRAC = 3.51823 * ( 0.1594 + EL*(0.0196 + 0.00002*EL) ) /
c & ( 1. + EL*(0.505 + 0.0845*EL) )
c
c ELSE IF( EL.LE.-0.766 ) THEN
c
c REFRAC = 0.0
c
c END IF
c
c* sm: switch off refraction:
c
c IF(lrefr) THEN
c EL = EL + REFRAC
c ENDIF
c
cc ===================================================================
c
c ** distance to sun in A.U. & diameter in degs
c
c SOLDST = 1.00014 - 0.01671*COS(MNANOM) - 0.00014*COS( 2.*MNANOM )
c SOLDIA = 0.5332 / SOLDST
c
c IF( EL.LT.-90.0 .OR. EL.GT.90.0 )
c & STOP 'SUNAE--output argument EL out of range'
c IF( AZ.LT.0.0 .OR. AZ.GT.360.0 )
c & STOP 'SUNAE--output argument AZ out of range'
c
c RETURN
c
c END
c
CCC FILE qys.f
* This file contains subroutines used for calculation of quantum yields for
* various photoreactions:
* qyacet - q.y. for acetone, based on Blitz et al. (2004)
********************************************************************************
SUBROUTINE qyacet(w, T, M, fco, fac)
* Compute acetone quantum yields according to the parameterization of:
* Blitz, M. A., D. E. Heard, M. J. Pilling, S. R. Arnold, and M. P. Chipperfield
* (2004), Pressure and temperature-dependent quantum yields for the
* photodissociation of acetone between 279 and 327.5 nm, Geophys.
* Res. Lett., 31, L06111, doi:10.1029/2003GL018793.
IMPLICIT NONE
* input:
* w = wavelength, nm
* T = temperature, K
* m = air number density, molec. cm-3
REAL w, T, M
* internal:
REAL a0, a1, a2, a3, a4
REAL b0, b1, b2, b3, b4
REAL c3
REAL cA0, cA1, cA2, cA3, cA4
real dumexp
* output
* fco = quantum yield for product CO
* fac = quantum yield for product CH3CO (acetyl radical)
REAL fco, fac
*** set out-of-range values:
* use low pressure limits for shorter wavelengths
* set to zero beyound 327.5
IF(w .LT. 279.) THEN
fco = 0.05
fac = 0.95
RETURN
ENDIF
IF(w .GT. 327.5 ) THEN
fco = 0.
fac = 0.
RETURN
ENDIF
*** CO (carbon monoxide) quantum yields:
a0 = 0.350 * (T/295.)**(-1.28)
b0 = 0.068 * (T/295.)**(-2.65)
**SM: prevent exponent overflow in rare cases:
dumexp = b0*(w - 248.)
if (dumexp .gt. 80.) then
cA0 = 5.e34
else
cA0 = exp(dumexp) * a0 / (1. - a0)
endif
fco = 1. / (1. + cA0)
*** CH3CO (acetyl radical) quantum yields:
IF(w .GE. 279. .AND. w .LT. 302.) THEN
a1 = 1.600E-19 * (T/295.)**(-2.38)
b1 = 0.55E-3 * (T/295.)**(-3.19)
cA1 = a1 * EXP(-b1*((1.e7/w) - 33113.))
fac = (1. - fco) / (1 + cA1 * M)
ENDIF
IF(w .GE. 302. .AND. w .LT. 327.5) THEN
a2 = 1.62E-17 * (T/295.)**(-10.03)
b2 = 1.79E-3 * (T/295.)**(-1.364)
cA2 = a2 * EXP(-b2*((1.e7/w) - 30488.))
a3 = 26.29 * (T/295.)**(-6.59)
b3 = 5.72E-7 * (T/295.)**(-2.93)
c3 = 30006 * (T/295.)**(-0.064)
ca3 = a3 * EXP(-b3*((1.e7/w) - c3)**2)
a4 = 1.67E-15 * (T/295.)**(-7.25)
b4 = 2.08E-3 * (T/295.)**(-1.16)
cA4 = a4 * EXP(-b4*((1.e7/w) - 30488.))
fac = (1. - fco) * (1. + cA3 + cA4 * M) /
$ ((1. + cA3 + cA2 * M)*(1. + cA4 * M))
ENDIF
RETURN
END
********************************************************************************
* This file contains the following subroutines, related to reading the
* extraterrestrial spectral irradiances:
* rdetfl
* read1
* read2
*=============================================================================*
SUBROUTINE rdetfl(nw,wl,f, kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read and re-grid extra-terrestrial flux data. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= F - REAL, spectral irradiance at the top of the atmosphere at (O)=*
*= each specified wavelength =*
*-----------------------------------------------------------------------------*
*-----------------------------------------------------------------------------*
*= This program is free software; you can redistribute it and/or modify =*
*= it under the terms of the GNU General Public License as published by the =*
*= Free Software Foundation; either version 2 of the license, or (at your =*
*= option) any later version. =*
*= The TUV package is distributed in the hope that it will be useful, but =*
*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
*= License for more details. =*
*= To obtain a copy of the GNU General Public License, write to: =*
*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
*-----------------------------------------------------------------------------*
*= To contact the authors, please mail to: =*
*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
*= send email to: sasha@ucar.edu =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
integer kdata
parameter(kdata=900000)
* input: (wavelength grid)
INTEGER nw
REAL wl(kw)
INTEGER iw
* output: (extra terrestrial solar flux)
REAL f(kw)
* INTERNAL:
* work arrays for input data files:
CHARACTER*40 fil
REAL x1(kdata)
REAL y1(kdata)
INTEGER nhead, n, i, ierr
REAL dum
* data gridded onto wl(kw) grid:
REAL yg1(kw)
REAL yg2(kw)
REAL yg3(kw)
REAL yg4(kw)
INTEGER msun
*_______________________________________________________________________
* select desired extra-terrestrial solar irradiance, using msun:
* 1 = extsol.flx: De Luisi, JGR 80, 345-354, 1975
* 280-400 nm, 1 nm steps.
* 2 = lowsun3.flx: Lowtran (John Bahr, priv. comm.)
* 173.974-500000 nm, ca. 0.1 nm steps in UV-B
* 3 = modtran1.flx: Modtran (Gail Anderson, priv. comm.)
* 200.55-949.40, 0.05 nm steps
* 4 = nicolarv.flx: wvl<300 nm from Nicolet, Plan. Sp. Sci., 29, 951-974, 1981.
* wvl>300 nm supplied by Thekaekera, Arvesen Applied Optics 8,
* 11, 2215-2232, 1969 (also see Thekaekera, Applied Optics, 13,
* 3, 518, 1974) but with corrections recommended by:
* Nicolet, Plan. Sp. Sci., 37, 1249-1289, 1989.
* 270.0-299.0 nm in 0.5 nm steps
* 299.6-340.0 nm in ca. 0.4 nm steps
* 340.0-380.0 nm in ca. 0.2 nm steps
* 380.0-470.0 nm in ca. 0.1 nm steps
* 5 = solstice.flx: From: MX%"ROTTMAN@virgo.hao.ucar.edu" 12-OCT-1994 13:03:01.62
* Original data gave Wavelength in vacuum
* (Converted to wavelength in air using Pendorf, 1967, J. Opt. Soc. Am.)
* 279.5 to 420 nm, 0.24 nm spectral resolution, approx 0.07 nm steps
* 6 = suntoms.flx: (from TOMS CD-ROM). 280-340 nm, 0.05 nm steps.
* 7 = neckel.flx: H.Neckel and D.Labs, "The Solar Radiation Between 3300 and 12500 A",
* Solar Physics v.90, pp.205-258 (1984).
* 1 nm between 330.5 and 529.5 nm
* 2 nm between 631.0 and 709.0 nm
* 5 nm between 872.5 and 1247.4 nm
* Units: must convert to W m-2 nm-1 from photons cm-2 s-1 nm-1
* 8 = atlas3.flx: ATLAS3-SUSIM 13 Nov 94 high resolution (0.15 nm FWHM)
* available by ftp from susim.nrl.navy.mil
* atlas3_1994_317_a.dat, downloaded 30 Sept 98.
* 150-407.95 nm, in 0.05 nm steps
* (old version from Dianne Prinz through Jim Slusser)
* orig wavelengths in vac, correct here to air.
* 9 = solstice.flx: solstice 1991-1996, average
* 119.5-420.5 nm in 1 nm steps
* 10 = susim_hi.flx: SUSIM SL2 high resolution
* 120.5-400.0 in 0.05 nm intervals (0.15 nm resolution)
* 11 = wmo85.flx: from WMO 1985 Atmospheric Ozone (report no. 16)
* on variable-size bins. Original values are per bin, not
* per nm.
* 12 = combine susim_hi.flx for .lt. 350 nm, neckel.flx for .gt. 350 nm.
*
* 13 = combine
* for wl(iw) .lt. 150.01 susim_hi.flx
* for wl(iw) .ge. 150.01 and wl(iw) .le. 400 atlas3.flx
* for wl(iw) .gt. 400 Neckel & Labs
*
* 14 = combine
* for wl(iw) .le. 350 susim_hi.flx
* for wl(iw) .gt. 350 Neckel & Labs
*
* 15 = combine
* for wl(iw) .lt. 150.01 susim_hi.flx
* for wl(iw) .ge. 150.01 .and. wl(iw) .lt. 200.07 atlas3.flx
* for wl(iw) .ge. 200.07 .and. wl(iw) .le. 1000.99 Chance and Kurucz 2010
* for wl(iw) .gt. 1000.99 Neckel & Labs
msun = 14
* simple files are read and interpolated here in-line. Reading of
* more complex files may be done with longer code in a read#.f subroutine.
IF (msun .EQ. 1) THEN
fil = 'DATAE1/SUN/extsol.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 3
n =121
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) x1(i), y1(i)
ENDDO
CLOSE (ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 2) THEN
fil = 'DATAE1/SUN/lowsun3.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 3
n = 4327
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) x1(i), y1(i)
ENDDO
CLOSE (ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 3) THEN
fil = 'DATAE1/SUN/modtran1.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 6
n = 14980
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) x1(i), y1(i)
ENDDO
CLOSE (ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 4) THEN
fil = 'DATAE1/SUN/nicolarv.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 8
n = 1260
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) x1(i), y1(i)
ENDDO
CLOSE (ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 5) THEN
* unofficial - do not use
fil = 'DATAE2/SUN/solstice.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 11
n = 2047
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) x1(i), y1(i)
ENDDO
CLOSE (ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 6) THEN
* unofficial - do not use
fil = 'DATAE2/SUN/suntoms.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 3
n = 1200
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) x1(i), y1(i)
y1(i) = y1(i)* 1.e-3
ENDDO
CLOSE (ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 7) THEN
fil = 'DATAE1/SUN/neckel.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 11
n = 496
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) dum, y1(i)
if (dum .lt. 630.0) x1(i) = dum - 0.5
if (dum .gt. 630.0 .and. dum .lt. 870.0) x1(i) = dum - 1.0
if (dum .gt. 870.0) x1(i) = dum - 2.5
y1(i) = y1(i) * 1.E4 * hc / (dum * 1.E-9)
ENDDO
CLOSE (ilu)
x1(n+1) = x1(n) + 2.5
do i = 1, n
y1(i) = y1(i) * (x1(i+1)-x1(i))
enddo
call inter3(nw,wl,yg2,n+1,x1,y1,0)
do iw = 1, nw-1
yg1(iw) = yg1(iw) / (wl(iw+1)-wl(iw))
enddo
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 8) THEN
nhead = 5
fil = 'DATAE1/SUN/atlas3_1994_317_a.dat'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 13
n = 5160
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-3
ENDDO
CLOSE (ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 9) THEN
fil = 'DATAE1/SUN/solstice.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 2
n = 302
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) x1(i), y1(i)
ENDDO
CLOSE (ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 10) THEN
WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
CALL read1(nw,wl,yg1,kout)
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 11) THEN
WRITE(kout,*) 'DATAE1/SUN/wmo85.flx'
CALL read2(nw,wl,yg1,kout)
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 12) THEN
WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
CALL read1(nw,wl,yg1,kout)
fil = 'DATAE1/SUN/neckel.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 11
n = 496
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) dum, y1(i)
if (dum .lt. 630.0) x1(i) = dum - 0.5
if (dum .gt. 630.0 .and. dum .lt. 870.0) x1(i) = dum - 1.0
if (dum .gt. 870.0) x1(i) = dum - 2.5
y1(i) = y1(i) * 1.E4 * hc / (dum * 1.E-9)
ENDDO
CLOSE (ilu)
x1(n+1) = x1(n) + 2.5
do i = 1, n
y1(i) = y1(i) * (x1(i+1)-x1(i))
enddo
call inter3(nw,wl,yg2,n+1,x1,y1,0)
do iw = 1, nw-1
yg2(iw) = yg2(iw) / (wl(iw+1)-wl(iw))
enddo
DO iw = 1, nw-1
IF (wl(iw) .GT. 350.) THEN
f(iw) = yg2(iw)
ELSE
f(iw) = yg1(iw)
ENDIF
ENDDO
ELSEIF (msun .EQ. 13) THEN
WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
CALL read1(nw,wl,yg1,kout)
nhead = 5
fil = 'DATAE1/SUN/atlas3_1994_317_a.dat'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
n = 5160
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-3
ENDDO
CLOSE (ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
fil = 'DATAE1/SUN/neckel.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 11
n = 496
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) dum, y1(i)
if (dum .lt. 630.0) x1(i) = dum - 0.5
if (dum .gt. 630.0 .and. dum .lt. 870.0) x1(i) = dum - 1.0
if (dum .gt. 870.0) x1(i) = dum - 2.5
y1(i) = y1(i) * 1.E4 * hc / (dum * 1.E-9)
ENDDO
CLOSE (ilu)
x1(n+1) = x1(n) + 2.5
call inter4(nw,wl,yg3,n+1,x1,y1,0)
DO iw = 1, nw-1
IF (wl(iw) .LT. 150.01) THEN
f(iw) = yg1(iw)
ELSE IF ((wl(iw) .GE. 150.01) .AND. wl(iw) .LE. 400.) THEN
f(iw) = yg2(iw)
ELSE IF (wl(iw) .GT. 400.) THEN
f(iw) = yg3(iw)
ENDIF
ENDDO
ELSEIF (msun .EQ. 14) THEN
WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
CALL read1(nw,wl,yg1,kout)
fil = 'DATAE1/SUN/neckel.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 11
n = 496
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) dum, y1(i)
if (dum .lt. 630.0) x1(i) = dum - 0.5
if (dum .gt. 630.0 .and. dum .lt. 870.0) x1(i) = dum - 1.0
if (dum .gt. 870.0) x1(i) = dum - 2.5
y1(i) = y1(i) * 1.E4 * hc / (dum * 1.E-9)
ENDDO
CLOSE (ilu)
x1(n+1) = x1(n) + 2.5
call inter4(nw,wl,yg3,n+1,x1,y1,0)
DO iw = 1, nw-1
IF (wl(iw) .LE. 350.) THEN
f(iw) = yg1(iw)
ELSE
f(iw) = yg3(iw)
ENDIF
ENDDO
ELSEIF (msun .EQ. 15) THEN
WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
CALL read1(nw,wl,yg1,kout)
nhead = 5
fil = 'DATAE1/SUN/atlas3_1994_317_a.dat'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
n = 5160
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-3
ENDDO
CLOSE (ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
fil = 'DATAE1/SUN/neckel.flx'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
nhead = 11
n = 496
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) dum, y1(i)
if (dum .lt. 630.0) x1(i) = dum - 0.5
if (dum .gt. 630.0 .and. dum .lt. 870.0) x1(i) = dum - 1.0
if (dum .gt. 870.0) x1(i) = dum - 2.5
y1(i) = y1(i) * 1.E4 * hc / (dum * 1.E-9)
ENDDO
CLOSE (ilu)
x1(n+1) = x1(n) + 2.5
call inter4(nw,wl,yg3,n+1,x1,y1,0)
nhead = 8
fil = 'DATAE1/SUN/sao2010.solref.converted'
write(kout,*) fil
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
n = 80099 - nhead
DO i = 1, nhead
READ(ilu,*)
ENDDO
DO i = 1, n
READ(ilu,*) x1(i), dum, y1(i), dum
c y1(i) = y1(i) * 1.E4 * hc / (x1(i) * 1.E-9)
ENDDO
CLOSE (ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg4,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
* for wl(iw) .lt. 150.01 susim_hi.flx
* for wl(iw) .ge. 150.01 .and. wl(iw) .lt. 200.07 atlas3.flx
* for wl(iw) .ge. 200.07 .and. wl(iw) .le. 1000.99 Chance and Kurucz 2010
* for wl(iw) .gt. 1000.99 Neckel & Labs
DO iw = 1, nw-1
IF (wl(iw) .LT. 150.01) THEN
f(iw) = yg1(iw)
ELSE IF ((wl(iw) .GE. 150.01) .AND. wl(iw) .LT. 200.07) THEN
f(iw) = yg2(iw)
ELSE IF ((wl(iw) .GE. 200.07) .AND. wl(iw) .LT. 1000.99)THEN
f(iw) = yg4(iw)
ELSE IF (wl(iw) .GT. 1000.99) THEN
f(iw) = yg3(iw)
ENDIF
ENDDO
ENDIF
RETURN
END
*=============================================================================*
SUBROUTINE read1(nw,wl,f,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read extra-terrestrial flux data. Re-grid data to match specified =*
*= working wavelength grid. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= F - REAL, spectral irradiance at the top of the atmosphere at (O)=*
*= each specified wavelength =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input: (wavelength grid)
INTEGER nw
REAL wl(kw)
* output: (extra terrestrial solar flux)
REAL f(kw)
* local:
REAL lambda_hi(10000),irrad_hi(10000)
REAL lambda
INTEGER ierr
INTEGER i, j, n
CHARACTER*40 FIL
*_______________________________________________________________________
******* SUSIM irradiance
*_______________________________________________________________________
* VanHoosier, M. E., J.-D. F. Bartoe, G. E. Brueckner, and
* D. K. Prinz, Absolute solar spectral irradiance 120 nm -
* 400 nm (Results from the Solar Ultraviolet Spectral Irradiance
* Monitor - SUSIM- Experiment on board Spacelab 2),
* Astro. Lett. and Communications, 1988, vol. 27, pp. 163-168.
* SUSIM SL2 high resolution (0.15nm) Solar Irridance data.
* Irradiance values are given in milliwatts/m^2/nanomenters
* and are listed at 0.05nm intervals. The wavelength given is
* the center wavelength of the 0.15nm triangular bandpass.
* Normalized to 1 astronomical unit.
* DATA for wavelengths > 350 nm are unreliable
* (Van Hoosier, personal communication, 1994).
*_______________________________________________________________________
** high resolution
fil = 'DATAE1/SUN/susim_hi.flx'
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
DO 11, i = 1, 7
READ(ilu,*)
11 CONTINUE
DO 12, i = 1, 559
READ(ilu,*)lambda,(irrad_hi(10*(i-1)+j), j=1, 10)
12 CONTINUE
CLOSE (ilu)
* compute wavelengths, convert from mW to W
n = 559*10
DO 13, i = 1, n
lambda_hi(i)=120.5 + FLOAT(i-1)*.05
irrad_hi(i) = irrad_hi(i) / 1000.
13 CONTINUE
*_______________________________________________________________________
CALL addpnt(lambda_hi,irrad_hi,10000,n,
> lambda_hi(1)*(1.-deltax),0.)
CALL addpnt(lambda_hi,irrad_hi,10000,n, 0.,0.)
CALL addpnt(lambda_hi,irrad_hi,10000,n,
> lambda_hi(n)*(1.+deltax),0.)
CALL addpnt(lambda_hi,irrad_hi,10000,n, 1.e38,0.)
CALL inter2(nw,wl,f,n,lambda_hi,irrad_hi,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
RETURN
END
*=============================================================================*
SUBROUTINE read2(nw,wl,f,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read extra-terrestrial flux data. Re-grid data to match specified =*
*= working wavelength grid. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= F - REAL, spectral irradiance at the top of the atmosphere at (O)=*
*= each specified wavelength =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input: (wavelength grid)
INTEGER nw
REAL wl(kw)
REAL yg(kw)
*
INTEGER iw
* output: (extra terrestrial solar flux)
REAL f(kw)
* local:
REAL x1(1000), y1(1000)
REAL x2(1000)
REAL x3(1000)
INTEGER i, n
REAL DUM
INTEGER IDUM
*_______________________________________________________________________
*********WMO 85 irradiance
OPEN(NEWUNIT=ilu,FILE='DATAE1/SUN/wmo85.flx',STATUS='old')
DO 11, i = 1, 3
READ(ilu,*)
11 CONTINUE
n = 158
DO 12, i = 1, n
READ(ilu,*) idum, x1(i),x2(i),y1(i), dum, dum, dum
x3(i) = 0.5 * (x1(i) + x2(i))
C average value needs to be calculated only if inter2 is
C used to interpolate onto wavelength grid (see below)
C y1(i) = y1(i) / (x2(i) - x1(i))
12 CONTINUE
CLOSE (ilu)
x1(n+1) = x2(n)
C inter2: INPUT : average value in each bin
C OUTPUT: average value in each bin
C inter3: INPUT : total area in each bin
C OUTPUT: total area in each bin
CALL inter3(nw,wl,yg, n+1,x1,y1,0)
C CALL inter2(nw,wl,yg,n,x3,y1,ierr)
DO 10, iw = 1, nw-1
* from quanta s-1 cm-2 bin-1 to watts m-2 nm-1
* 1.e4 * ([hc =] 6.62E-34 * 2.998E8)/(wc*1e-9)
C the scaling by bin width needs to be done only if
C inter3 is used for interpolation
yg(iw) = yg(iw) / (wl(iw+1)-wl(iw))
f(iw) = yg(iw) * 1.e4 * (6.62E-34 * 2.998E8) /
$ ( 0.5 * (wl(iw+1)+wl(iw)) * 1.e-9)
10 CONTINUE
RETURN
END
CCC FILE rdxs.f
* This file contains subroutines related to reading the
* absorption cross sections of gases that contribute to atmospheric transmission:
* Some of these subroutines are also called from rxn.f when loading photolysis cross sections
* for these same gases. It is possible to have different cross sections for
* transmission and for photolysis, e.g. for ozone, Bass et al. could be used
* for transmission while Molina and Molina could be used for photolysis.
* This flexibility can be useful but users should be aware.
* For xsections that are temperature dependent, caution should be used in passing the proper
* temperature to the data routines. Usually, transmission is for layers, TLAY(NZ-1), while
* photolysis is at levels, T(NZ).
* The following subroutines are her:
* rdo3xs
* o3_mol
* o3_rei
* o3_bas
* o3_wmo
* o3_jpl
* rdo2xs
* rdno2xs
* no2xs_d
* no2xs_jpl94
* no2xs_har
* rdso2xs
*=============================================================================*
SUBROUTINE rdo3xs(mabs, nz,t,nw,wl, xs, kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read ozone molecular absorption cross section. Re-grid data to match =*
*= specified wavelength working grid. Interpolate in temperature as needed =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= MABS - INTEGER, option for splicing different combinations of (I)=*
*= absorption cross secttions =*
*= NZ - INTEGER, number of altitude levels or layers (I)=*
*= T - REAL, temperature of levels or layers (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid. In vacuum, nm =*
*= XS - REAL, molecular absoprtion cross section (cm^2) of O3 at (O)=*
*= each specified wavelength (WMO value at 273) =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input: (altitude working grid)
INTEGER iw, nw
REAL wl(kw)
INTEGER iz, nz
REAL t(kz)
* internal
INTEGER mabs
REAL tc
* output:
* ozone absorption cross sections interpolated to
* working wavelength grid (iw)
* working altitude grid (iz) for temperature of layer or level (specified in call)
* Units are cm2 molecule-1 in vacuum
REAL xs(kz,kw)
* wavelength-interpolated values from different O3 data sources
* also values of significant wavelengths, converted to vacuum
REAL rei218(kw), rei228(kw), rei243(kw), rei295(kw)
REAL v195, v345, v830
REAL wmo203(kw), wmo273(kw)
REAL v176, v850
REAL jpl295(kw), jpl218(kw)
REAL v186, v825
REAL mol226(kw), mol263(kw), mol298(kw)
REAL v185, v240, v350
REAL c0(kw), c1(kw), c2(kw)
REAL vb245, vb342
*_______________________________________________________________________
* read data from different sources
* rei = Reims group (Malicet et al., Brion et al.)
* jpl = JPL 2006 evaluation
* wmo = WMO 1985 O3 assessment
* mol = Molina and Molina
* bas = Bass et al.
CALL o3_rei(nw,wl, rei218,rei228,rei243,rei295,
$ v195,v345,v830,kout)
CALL o3_jpl(nw,wl, jpl218,jpl295, v186,v825,kout)
CALL o3_wmo(nw,wl, wmo203,wmo273, v176,v850,kout)
CALL o3_mol(nw,wl, mol226,mol263,mol298, v185,v240,
$ v350,kout)
CALL o3_bas(nw,wl, c0,c1,c2, vb245,vb342,kout)
****** option 1:
IF(mabs. EQ. 1) THEN
* assign according to wavelength range:
* 175.439 - 185.185 1985WMO (203, 273 K)
* 185.185 - 195.00 2006JPL_O3 (218, 295 K)
* 195.00 - 345.00 Reims group (218, 228, 243, 295 K)
* 345.00 - 830.00 Reims group (295 K)
* no extrapolations in temperature allowed
DO 10 iw = 1, nw-1
DO 20 iz = 1, nz
IF(wl(iw) .LT. v185) THEN
xs(iz,iw) = wmo203(iw) +
$ (wmo273(iw) - wmo203(iw))*(t(iz) - 203.)/(273. - 203.)
IF (t(iz) .LE. 203.) xs(iz,iw) = wmo203(iw)
IF (t(iz) .GE. 273.) xs(iz,iw) = wmo273(iw)
ENDIF
IF(wl(iw) .GE. v185 .AND. wl(iw) .LE. v195) THEN
xs(iz,iw) = jpl218(iw) +
$ (jpl295(iw) - jpl218(iw))*(t(iz) - 218.)/(295. - 218.)
IF (t(iz) .LE. 218.) xs(iz,iw) = jpl218(iw)
IF (t(iz) .GE. 295.) xs(iz,iw) = jpl295(iw)
ENDIF
IF(wl(iw) .GE. v195 .AND. wl(iw) .LT. v345) THEN
IF (t(iz) .GE. 218. .AND. t(iz) .LT. 228.) THEN
xs(iz,iw) = rei218(iw) +
$ (t(iz)-218.)*(rei228(iw)-rei218(iw))/(228.-218.)
ELSEIF (t(iz) .GE. 228. .AND. t(iz) .LT. 243.) THEN
xs(iz,iw) = rei228(iw) +
$ (t(iz)-228.)*(rei243(iw)-rei228(iw))/(243.-228.)
ELSEIF (t(iz) .GE. 243. .AND. t(iz) .LT. 295.) THEN
xs(iz,iw) = rei243(iw) +
$ (t(iz)-243.)*(rei295(iw)-rei243(iw))/(295.-243.)
ENDIF
IF (t(iz) .LT. 218.) xs(iz,iw) = rei218(iw)
IF (t(iz) .GE. 295.) xs(iz,iw) = rei295(iw)
ENDIF
IF(wl(iw) .GE. v345) THEN
xs(iz,iw) = rei295(iw)
ENDIF
20 CONTINUE
10 CONTINUE
ELSEIF(mabs .EQ. 2) THEN
* use exclusively JPL-2006
DO iw = 1, nw-1
DO iz = 1, nz
xs(iz,iw) = jpl218(iw) +
$ (jpl295(iw) - jpl218(iw))*(t(iz) - 218.)/(295. - 218.)
IF (t(iz) .LE. 218.) xs(iz,iw) = jpl218(iw)
IF (t(iz) .GE. 295.) xs(iz,iw) = jpl295(iw)
ENDDO
ENDDO
ELSEIF(mabs .EQ. 3) THEN
* use exclusively Molina and Molina
DO iw = 1, nw-1
DO iz = 1, nz
IF(wl(iw) .LT. v240) THEN
xs(iz,iw) = mol226(iw) +
$ (t(iz)-226.)*(mol298(iw)-mol226(iw))/(298.-226.)
ELSE
IF(t(iz) .LT. 263.) THEN
xs(iz,iw) = mol226(iw) +
$ (t(iz)-226.)*(mol263(iw)-mol226(iw))/(263.-226.)
ELSE
xs(iz,iw) = mol263(iw) +
$ (t(iz)-263.)*(mol298(iw)-mol263(iw))/(298.-263.)
ENDIF
ENDIF
IF (t(iz) .LE. 226.) xs(iz,iw) = mol226(iw)
IF (t(iz) .GE. 298.) xs(iz,iw) = mol298(iw)
ENDDO
ENDDO
ELSEIF(mabs .EQ. 4) THEN
* use exclusively Bass et al.
* note limited wavelength range 245-342
DO iw = 1, nw-1
DO iz = 1, nz
tc = t(iz) - 273.15
xs(iz,iw) = c0(iw) + c1(iw)*tc + c2(iw)*tc*tc
ENDDO
ENDDO
ELSE
STOP 'mabs not set in rdxs.f'
ENDIF
RETURN
END
*=============================================================================*
SUBROUTINE o3_rei(nw,wl,
$ rei218,rei228,rei243,rei295, v195,v345,v830,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read and interpolate the O3 cross section from Reims group =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= REI218 - REAL, cross section (cm^2) for O3 at 218K (O)=*
*= REI228 - REAL, cross section (cm^2) for O3 at 218K (O)=*
*= REI243 - REAL, cross section (cm^2) for O3 at 218K (O)=*
*= REI295 - REAL, cross section (cm^2) for O3 at 218K (O)=*
*= V195 - REAL, exact wavelength in vacuum for data breaks (O)=*
*= e.g. start, stop, or other change =*
*= V345 - REAL, exact wavelength in vacuum for data breaks (O)=*
*= V830 - REAL, exact wavelength in vacuum for data breaks (O)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw, iw
REAL wl(kw)
** internal
INTEGER kdata
PARAMETER (kdata = 70000)
INTEGER n1, n2, n3, n4
REAL x1(kdata), x2(kdata), x3(kdata), x4(kdata)
REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata)
INTEGER i
INTEGER ierr
* used for air-to-vacuum wavelength conversion
REAL refrac, ri(kdata)
EXTERNAL refrac
* output:
REAL rei218(kw), rei228(kw), rei243(kw), rei295(kw)
REAL v195, v345, v830
* data from the Reims group:
*= For Hartley and Huggins bands, use temperature-dependent values from =*
*= Malicet et al., J. Atmos. Chem. v.21, pp.263-273, 1995. =*
*= over 345.01 - 830.00, use values from Brion, room temperature only
OPEN(NEWUNIT=ilu,FILE='DATAE1/O3/1995Malicet_O3.txt',STATUS='old')
DO i = 1, 2
READ(ilu,*)
ENDDO
n1 = 15001
n2 = 15001
n3 = 15001
n4 = 15001
DO i = 1, n1
READ(ilu,*) x1(i), y1(i), y2(i), y3(i), y4(i)
x2(i) = x1(i)
x3(i) = x1(i)
x4(i) = x1(i)
ENDDO
CLOSE (ilu)
*= over 345.01 - 830.00, use values from Brion, room temperature only
* skip datum at 345.00 because already read in from 1995Malicet
OPEN(NEWUNIT=ilu,FILE='DATAE1/O3/1998Brion_295.txt',STATUS='old')
DO i = 1, 15
READ(ilu,*)
ENDDO
DO i = 1, 48515-15
n1 = n1 + 1
READ(ilu,*) x1(n1), y1(n1)
ENDDO
CLOSE (ilu)
DO i = 1, n1
ri(i) = refrac(x1(i), 2.45E19)
ENDDO
DO i = 1, n1
x1(i) = x1(i) * ri(i)
ENDDO
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,rei295,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 xsect - Reims 295K'
STOP
ENDIF
DO i = 1, n2
ri(i) = refrac(x2(i), 2.45E19)
ENDDO
DO i = 1, n2
x2(i) = x2(i) * ri(i)
x3(i) = x2(i)
x4(i) = x2(i)
ENDDO
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,rei243,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 xsect - Reims 243K'
STOP
ENDIF
CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 0.,0.)
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1.e+38,0.)
CALL inter2(nw,wl,rei228,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 xsect - Reims 228K'
STOP
ENDIF
CALL addpnt(x4,y4,kdata,n4,x4(1)*(1.-deltax),0.)
CALL addpnt(x4,y4,kdata,n4, 0.,0.)
CALL addpnt(x4,y4,kdata,n4,x4(n4)*(1.+deltax),0.)
CALL addpnt(x4,y4,kdata,n4, 1.e+38,0.)
CALL inter2(nw,wl,rei218,n4,x4,y4,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 xsect - Reims 218K'
STOP
ENDIF
* wavelength breaks must be converted to vacuum:
v195 = 195.00 * refrac(195.00, 2.45E19)
v345 = 345.00 * refrac(345.00, 2.45E19)
v830 = 830.00 * refrac(830.00, 2.45E19)
RETURN
END
*=============================================================================*
SUBROUTINE o3_wmo(nw,wl, wmo203,wmo273, v176,v850,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read and interpolate the O3 cross section =*
*= data from WMO 85 Ozone Assessment =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WMO203 - REAL, cross section (cm^2) for O3 at 203K (O)=*
*= WMO273 - REAL, cross section (cm^2) for O3 at 273K (O)=*
*= V176 - REAL, exact wavelength in vacuum for data breaks (O)=*
*= e.g. start, stop, or other change =*
*= V850 - REAL, exact wavelength in vacuum for data breaks (O)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw, iw
REAL wl(kw)
* internal
INTEGER kdata
PARAMETER (kdata = 200)
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
INTEGER i, idum
REAL a1, a2, dum
INTEGER ierr
* used for air-to-vacuum wavelength conversion
REAL refrac, ri(kdata)
EXTERNAL refrac
* output
REAL wmo203(kw), wmo273(kw)
REAL v176, v850
*----------------------------------------------------------
* cross sections from WMO 1985 Ozone Assessment
* from 175.439 to 847.500 nm
OPEN(NEWUNIT=ilu,FILE='DATAE1/wmo85',STATUS='old')
DO i = 1, 3
read(UNIT=ilu,FMT=*)
ENDDO
n1 = 158
n2 = 158
DO i = 1, n1
READ(UNIT=ilu,FMT=*) idum, a1, a2, dum, dum, dum, y1(i), y2(i)
x1(i) = (a1+a2)/2.
x2(i) = (a1+a2)/2.
ENDDO
CLOSE (UNIT=ilu)
* convert wavelengths to vacuum
DO i = 1, n1
ri(i) = refrac(x1(i), 2.45E19)
ENDDO
DO i = 1, n1
x1(i) = x1(i) * ri(i)
x2(i) = x2(i) * ri(i)
ENDDO
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,wmo203,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 cross section - WMO - 203K'
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,wmo273,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 cross section - WMO - 273K'
STOP
ENDIF
* wavelength breaks must be converted to vacuum:
a1 = (175.438 + 176.991) / 2.
v176 = a1 * refrac(a1,2.45E19)
a1 = (847.5 + 852.5) / 2.
v850 = a1 * refrac(a1, 2.45E19)
RETURN
END
*=============================================================================*
SUBROUTINE o3_jpl(nw,wl, jpl218,jpl295, v186,v825,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read and interpolate the O3 cross section from JPL 2006 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= JPL218 - REAL, cross section (cm^2) for O3 at 218K (O)=*
*= JPL295 - REAL, cross section (cm^2) for O3 at 295K (O)=*
*= V186 - REAL, exact wavelength in vacuum for data breaks (O)=*
*= e.g. start, stop, or other change =*
*= V825 - REAL, exact wavelength in vacuum for data breaks (O)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw, iw
REAL wl(kw)
* internal
INTEGER kdata
PARAMETER (kdata = 200)
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
INTEGER i
REAL dum
INTEGER ierr
* used for air-to-vacuum wavelength conversion
REAL refrac, ri(kdata)
EXTERNAL refrac
* output
REAL jpl295(kw), jpl218(kw)
REAL v186, v825
***********
OPEN(NEWUNIT=ilu,FILE='DATAE1/O3/2006JPL_O3.txt',STATUS='old')
DO i = 1, 2
read(ilu,*)
ENDDO
n1 = 167
n2 = 167
DO i = 1, n1
READ(ilu,*) dum, dum, x1(i), y1(i), y2(i)
y1(i) = y1(i) * 1.e-20
y2(i) = y2(i) * 1.e-20
ENDDO
CLOSE (ilu)
* convert wavelengths to vacuum
DO i = 1, n1
ri(i) = refrac(x1(i), 2.45E19)
ENDDO
DO i = 1, n1
x1(i) = x1(i) * ri(i)
x2(i) = x1(i)
ENDDO
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,jpl295,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 cross section - WMO - 295K'
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,jpl218,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 cross section - WMO - 218K'
STOP
ENDIF
* wavelength breaks must be converted to vacuum:
v186 = 186.051 * refrac(186.051, 2.45E19)
v825 = 825. * refrac(825. , 2.45E19)
RETURN
END
*=============================================================================*
SUBROUTINE o3_mol(nw,wl, mol226,mol263,mol298,
& v185,v240,v350,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read and interpolate the O3 cross section from Molina and Molina 1986 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= MOL226 - REAL, cross section (cm^2) for O3 at 226 K (O)=*
*= MOL263 - REAL, cross section (cm^2) for O3 at 263 K (O)=*
*= MOL298 - REAL, cross section (cm^2) for O3 at 298 K (O)=*
*= V185 - REAL, exact wavelength in vacuum for data breaks (O)=*
*= e.g. start, stop, or other change =*
*= V240 - REAL, exact wavelength in vacuum for data breaks (O)=*
*= V350 - REAL, exact wavelength in vacuum for data breaks (O)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw, iw
REAL wl(kw)
* internal
INTEGER i
INTEGER ierr
INTEGER kdata
PARAMETER (kdata = 335)
INTEGER n1, n2, n3
REAL x1(kdata), x2(kdata), x3(kdata)
REAL y1(kdata), y2(kdata), y3(kdata)
* used for air-to-vacuum wavelength conversion
REAL refrac, ri(kdata)
EXTERNAL refrac
* output
REAL mol226(kw), mol263(kw), mol298(kw)
REAL v185, v240, v350
*----------------------------------------------------------
OPEN(NEWUNIT=ilu,FILE='DATAE1/O3/1986Molina.txt',STATUS='old')
DO i = 1, 10
READ(ilu,*)
ENDDO
n1 = 0
n2 = 0
n3 = 0
DO i = 1, 121-10
n1 = n1 + 1
n3 = n3 + 1
READ(ilu,*) x1(n1), y1(n1), y3(n3)
x3(n3) = x1(n1)
ENDDO
DO i = 1, 341-122
n1 = n1 + 1
n2 = n2 + 1
n3 = n3 + 1
READ(ilu,*) x1(n1), y1(n1), y2(n2), y3(n3)
x2(n2) = x1(n1)
x3(n3) = x1(n1)
ENDDO
CLOSE (ilu)
* convert all wavelengths from air to vacuum
DO i = 1, n1
ri(i) = refrac(x1(i), 2.45E19)
ENDDO
DO i = 1, n1
x1(i) = x1(i) * ri(i)
ENDDO
DO i = 1, n2
ri(i) = refrac(x2(i), 2.45E19)
ENDDO
DO i = 1, n2
x2(i) = x2(i) * ri(i)
ENDDO
DO i = 1, n3
ri(i) = refrac(x3(i), 2.45E19)
ENDDO
DO i = 1, n3
x3(i) = x3(i) * ri(i)
ENDDO
* convert wavelength breaks from air to vacuum
v185 = 185. * refrac(185. , 2.45E19)
v240 = 240.5 * refrac(240.5, 2.45E19)
v350 = 350. * refrac(350. , 2.45E19)
* interpolate to working grid
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,mol226,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 xsect - 226K Molina'
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,mol263,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 xsect - 263K Molina'
STOP
ENDIF
CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 0.,0.)
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1.e+38,0.)
CALL inter2(nw,wl,mol298,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 xsect - 298K Molina'
STOP
ENDIF
RETURN
END
*=============================================================================*
SUBROUTINE o3_bas(nw,wl, c0,c1,c2, vb245,vb342,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read and interpolate the O3 cross section from Bass 1985 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= c0 - REAL, coefficint for polynomial fit to cross section (cm^2) (O)=*
*= c1 - REAL, coefficint for polynomial fit to cross section (cm^2) (O)=*
*= c2 - REAL, coefficint for polynomial fit to cross section (cm^2) (O)=*
*= Vb245 - REAL, exact wavelength in vacuum for data breaks (O)=*
*= e.g. start, stop, or other change =*
*= Vb342 - REAL, exact wavelength in vacuum for data breaks (O)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input:
INTEGER nw, iw
REAL wl(kw)
* internal:
INTEGER kdata
PARAMETER (kdata = 2000)
INTEGER i
INTEGER ierr
INTEGER n1, n2, n3
REAL x1(kdata), x2(kdata), x3(kdata)
REAL y1(kdata), y2(kdata), y3(kdata)
* used for air-to-vacuum wavelength conversion
REAL refrac, ri(kdata)
EXTERNAL refrac
* output:
REAL c0(kw), c1(kw), c2(kw)
REAL vb245, vb342
*******************
OPEN(NEWUNIT=ilu,FILE='DATAE1/O3/1985Bass_O3.txt',STATUS='old')
DO i = 1, 8
READ(UNIT=ilu,FMT=*)
ENDDO
n1 = 1915
n2 = 1915
n3 = 1915
DO i = 1, n1
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i), y3(i)
y1(i) = 1.e-20 * y1(i)
y2(i) = 1.e-20 * y2(i)
y3(i) = 1.e-20 * y3(i)
ENDDO
CLOSE (UNIT=ilu)
* convert all wavelengths from air to vacuum
DO i = 1, n1
ri(i) = refrac(x1(i), 2.45E19)
ENDDO
DO i = 1, n1
x1(i) = x1(i) * ri(i)
x2(i) = x1(i)
x3(i) = x1(i)
ENDDO
* convert wavelength breaks to vacuum
vb245 = 245.018 * refrac(245.018, 2.45E19)
vb342 = 341.981 * refrac(341.981, 2.45E19)
* interpolate to working grid
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,c0,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 xsect - c0 Bass'
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,c1,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 xsect - c1 Bass'
STOP
ENDIF
CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 0.,0.)
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1.e+38,0.)
CALL inter2(nw,wl,c2,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O3 xsect - c2 Bass'
STOP
ENDIF
RETURN
END
*=============================================================================*
SUBROUTINE rdo2xs(nw,wl,o2xs1,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Compute equivalent O2 cross section, except =*
*= the SR bands and the Lyman-alpha line. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS:
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid
*= vertical layer at each specified wavelength =*
*= O2XS1 - REAL, O2 molecular absorption cross section =*
*=
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* Input
INTEGER nw
REAL wl(kw)
* Output O2 xsect, temporary, will be over-written in Lyman-alpha and
* Schumann-Runge wavelength bands.
REAL o2xs1(kw)
* Internal
INTEGER i, n, kdata
PARAMETER (kdata = 200)
REAL x1(kdata), y1(kdata)
REAL x, y
INTEGER ierr
*-----------------------------------------------------
* Read O2 absorption cross section data:
* 116.65 to 203.05 nm = from Brasseur and Solomon 1986
* 205 to 240 nm = Yoshino et al. 1988
* Note that subroutine la_srb.f will over-write values in the spectral regions
* corresponding to:
* - Lyman-alpha (LA: 121.4-121.9 nm, Chabrillat and Kockarts parameterization)
* - Schumann-Runge bands (SRB: 174.4-205.8 nm, Koppers parameteriaztion)
n = 0
OPEN(NEWUNIT=ilu,FILE='DATAE1/O2/O2_brasseur.abs')
DO i = 1, 7
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, 78
READ(UNIT=ilu,FMT=*) x, y
IF (x .LE. 204.) THEN
n = n + 1
x1(n) = x
y1(n) = y
ENDIF
ENDDO
CLOSE(UNIT=ilu)
OPEN(NEWUNIT=ilu,FILE='DATAE1/O2/O2_yoshino.abs',STATUS='old')
DO i = 1, 8
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, 36
n = n + 1
READ(UNIT=ilu,FMT=*) x, y
y1(n) = y*1.E-24
x1(n) = x
END DO
CLOSE (UNIT=ilu)
* Add termination points and interpolate onto the
* user grid (set in subroutine gridw):
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n,0. ,y1(1))
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.E+38,0.)
CALL inter2(nw,wl,o2xs1, n,x1,y1, ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, 'O2 -> O + O'
STOP
ENDIF
*------------------------------------------------------
RETURN
END
*=============================================================================*
SUBROUTINE rdno2xs(nz,tlay,nw,wl,no2xs,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read NO2 molecular absorption cross section. Re-grid data to match =*
*= specified wavelength working grid. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NO2XS - REAL, molecular absoprtion cross section (cm^2) of NO2 at (O)=*
*= each specified wavelength =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input: (altitude working grid)
INTEGER nz
REAL tlay(kz)
INTEGER nw
REAL wl(kw)
INTEGER mabs
* output:
REAL no2xs(kz,kw)
*_______________________________________________________________________
* options for NO2 cross section:
* 1 = Davidson et al. (1988), indepedent of T
* 2 = JPL 1994 (same as JPL 1997, JPL 2002)
* 3 = Harder et al.
* 4 = JPL 2006, interpolating between midpoints of bins
* 5 = JPL 2006, bin-to-bin interpolation
mabs = 4
IF (mabs. EQ. 1) CALL no2xs_d(nz,tlay,nw,wl, no2xs,kout)
IF (mabs .EQ. 2) CALL no2xs_jpl94(nz,tlay,nw,wl, no2xs,kout)
IF (mabs .EQ. 3) CALL no2xs_har(nz,tlay,nw,wl, no2xs,kout)
IF (mabs .EQ. 4) CALL no2xs_jpl06a(nz,tlay,nw,wl, no2xs,kout)
IF (mabs .EQ. 5) CALL no2xs_jpl06b(nz,tlay,nw,wl, no2xs,kout)
*_______________________________________________________________________
RETURN
END
*=============================================================================*
SUBROUTINE no2xs_d(nz,t,nw,wl, no2xs,kout)
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* read and interpolate NO2 xs from Davidson et al. (1988).
* input:
INTEGER nz, iz
REAL t(nz)
INTEGER nw, iw
REAL wl(nw)
* output:
REAL no2xs(kz,kw)
* local:
INTEGER kdata
PARAMETER (kdata=1000)
REAL x1(kdata)
REAL y1(kdata)
REAL yg(kw)
REAL dum
INTEGER ierr
INTEGER i, n, idum
CHARACTER*40 fil
************* NO2 absorption cross sections
* measurements by:
* Davidson, J. A., C. A. Cantrell, A. H. McDaniel, R. E. Shetter,
* S. Madronich, and J. G. Calvert, Visible-ultraviolet absorption
* cross sections for NO2 as a function of temperature, J. Geophys.
* Res., 93, 7105-7112, 1988.
* Values at 273K from 263.8 to 648.8 nm in approximately 0.5 nm intervals
fil = 'DATAE1/NO2/NO2_ncar_00.abs'
OPEN(NEWUNIT=ilu,FILE=fil,STATUS='old')
n = 750
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), dum, dum, idum
ENDDO
CLOSE(UNIT=ilu)
* interpolate to wavelength grid
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
* assign, same at all altitudes (no temperature effect)
DO iz = 1, nz
DO iw = 1, nw-1
no2xs(iz,iw) = yg(iw)
ENDDO
ENDDO
*_______________________________________________________________________
RETURN
END
*=============================================================================*
SUBROUTINE no2xs_jpl94(nz,t,nw,wl, no2xs,kout)
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* read and interpolate NO2 xs from JPL 1994
* input:
INTEGER nz, iz
REAL t(nz)
INTEGER nw, iw
REAL wl(nw)
* output:
REAL no2xs(kz,kw)
* local:
INTEGER kdata
PARAMETER (kdata=100)
INTEGER i, idum, n, n1
REAL x1(kdata), x2(kdata), x3(kdata)
REAL y1(kdata), y2(kdata), y3(kdata)
REAL dum
REAL yg1(nw), yg2(nw)
* cross section data from JPL 94 recommendation
* JPL 97 and JPL 2002 recommendations are identical
OPEN(NEWUNIT=ilu,FILE='DATAE1/NO2/NO2_jpl94.abs',STATUS='old')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
* read in wavelength bins, cross section at T0 and temperature correction
* coefficient a; see input file for details.
* data need to be scaled to total area per bin so that they can be used with
* inter3
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), x3(i), y1(i), dum, y2(i)
y1(i) = (x3(i)-x1(i)) * y1(i)*1.E-20
y2(i) = (x3(i)-x1(i)) * y2(i)*1.E-22
x2(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
x1(n+1) = x3(n)
x2(n+1) = x3(n)
n = n+1
n1 = n
CALL inter3(nw,wl,yg1,n,x1,y1,0)
CALL inter3(nw,wl,yg2,n1,x2,y2,0)
* yg1, yg2 are per nm, so rescale by bin widths
DO iw = 1, nw-1
yg1(iw) = yg1(iw)/(wl(iw+1)-wl(iw))
yg2(iw) = yg2(iw)/(wl(iw+1)-wl(iw))
ENDDO
DO iw = 1, nw-1
DO iz = 1, nz
no2xs(iz,iw) = yg1(iw) + yg2(iw)*(t(iz)-273.15)
ENDDO
ENDDO
RETURN
END
*=============================================================================*
SUBROUTINE no2xs_har(nz,t,nw,wl, no2xs,kout)
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* read and interpolate NO2 xs from Harder et al.
* input:
INTEGER nz, iz
REAL t(nz)
INTEGER nw, iw
REAL wl(nw)
* output:
REAL no2xs(kz,kw)
* local:
INTEGER kdata
PARAMETER (kdata=150)
INTEGER i, n, idum, ierr
REAL x1(kdata), y1(kdata)
REAL yg1(kw)
***
OPEN(NEWUNIT=ilu,FILE='DATAE1/NO2/NO2_Har.abs',status='old')
DO i = 1, 9
READ(UNIT=ilu,FMT=*)
ENDDO
n = 135
DO i = 1, n
READ(UNIT=ilu,FMT=*) idum, y1(i)
x1(i) = FLOAT(idum)
ENDDO
CLOSe(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
DO iw = 1, nw-1
DO i = 1, nz
no2xs(i,iw) = yg1(iw)
ENDDO
ENDDO
RETURN
END
*=============================================================================*
SUBROUTINE no2xs_jpl06a(nz,t,nw,wl, no2xs,kout)
* read and interpolate NO2 xs from JPL2006
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input:
INTEGER nz, iz
REAL t(nz)
INTEGER nw, iw
REAL wl(nw)
* output:
REAL no2xs(kz,kw)
* local
INTEGER kdata
PARAMETER (kdata=80)
INTEGER i, n1, n2, ierr
REAL x1(kdata), x2(kdata), y1(kdata), y2(kdata)
REAL dum1, dum2
REAL yg1(kw), yg2(kw)
* NO2 absorption cross section from JPL2006
* with interpolation of bin midpoints
OPEN(NEWUNIT=ilu,FILE='DATAE1/NO2/NO2_jpl2006.abs',STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n1 = 73
DO i = 1, n1
READ(UNIT=ilu,FMT=*) dum1, dum2, y1(i), y2(i)
x1(i) = 0.5 * (dum1 + dum2)
x2(i) = x1(i)
y1(i) = y1(i)*1.E-20
y2(i) = y2(i)*1.E-20
ENDDO
CLOSE(UNIT=ilu)
n2 = n1
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax), 0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38, 0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax), 0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38, 0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
DO iw = 1, nw-1
DO iz = 1, nz
no2xs(iz,iw) = yg1(iw) +
$ (yg2(iw)-yg1(iw))*(t(iz)-220.)/74.
ENDDO
ENDDO
RETURN
END
*=============================================================================*
SUBROUTINE no2xs_jpl06b(nz,t,nw,wl, no2xs,kout)
* read and interpolate NO2 xs from Harder et al.
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input:
INTEGER nz, iz
REAL t(nz)
INTEGER nw, iw
REAL wl(nw)
* output:
REAL no2xs(kz,kw)
* local
INTEGER kdata
PARAMETER (kdata=100)
INTEGER i, n, n1, n2, ierr
REAL x1(kdata), x2(kdata), y1(kdata), y2(kdata)
REAL x3(kdata), y3(kdata)
REAL dum1, dum2
REAL yg1(kw), yg2(kw)
OPEN(NEWUNIT=ilu,FILE='DATAE1/NO2/NO2_jpl2006.abs',STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 81
do i = 1, n
read(UNIT=ilu,FMT=*) x1(i), x3(i), y1(i), y2(i)
y1(i) = (x3(i)-x1(i)) * y1(i)*1.E-20
y2(i) = (x3(i)-x1(i)) * y2(i)*1.E-20
x2(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
x1(n+1) = x3(n)
x2(n+1) = x3(n)
n = n+1
n1 = n
CALL inter3(nw,wl,yg1,n,x1,y1,0)
CALL inter3(nw,wl,yg2,n1,x2,y2,0)
* yg1, yg2 are per nm, so rescale by bin widths
DO iw = 1, nw-1
yg1(iw) = yg1(iw)/(wl(iw+1)-wl(iw))
yg2(iw) = yg2(iw)/(wl(iw+1)-wl(iw))
ENDDO
DO iw = 1, nw-1
DO iz = 1, nz
no2xs(iz,iw) = yg1(iw) +
$ (yg2(iw)-yg1(iw))*(t(iz)-220.)/74.
ENDDO
ENDDO
RETURN
END
*=============================================================================*
SUBROUTINE rdso2xs(nw,wl,so2xs,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read SO2 molecular absorption cross section. Re-grid data to match =*
*= specified wavelength working grid. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= SO2XS - REAL, molecular absoprtion cross section (cm^2) of SO2 at (O)=*
*= each specified wavelength =*
*-----------------------------------------------------------------------------*
*= EDIT HISTORY: =*
*= 02/97 Changed offset for grid-end interpolation to relative number =*
*= (x * (1 +- deltax) =*
*-----------------------------------------------------------------------------*
*= This program is free software; you can redistribute it and/or modify =*
*= it under the terms of the GNU General Public License as published by the =*
*= Free Software Foundation; either version 2 of the license, or (at your =*
*= option) any later version. =*
*= The TUV package is distributed in the hope that it will be useful, but =*
*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
*= License for more details. =*
*= To obtain a copy of the GNU General Public License, write to: =*
*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
*-----------------------------------------------------------------------------*
*= To contact the authors, please mail to: =*
*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
*= send email to: sasha@ucar.edu =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER kdata
PARAMETER(kdata=1000)
* input: (altitude working grid)
INTEGER nw
REAL wl(kw)
* output:
REAL so2xs(kw)
* local:
REAL x1(kdata)
REAL y1(kdata)
REAL yg(kw)
REAL dum
INTEGER ierr
INTEGER i, l, n, idum
CHARACTER*40 fil
*_______________________________________________________________________
************* absorption cross sections:
* SO2 absorption cross sections from J. Quant. Spectrosc. Radiat. Transfer
* 37, 165-182, 1987, T. J. McGee and J. Burris Jr.
* Angstrom vs. cm2/molecule, value at 221 K
fil = 'DATA/McGee87'
OPEN(NEWUNIT=ilu,FILE='DATAE1/SO2/SO2xs.all',STATUS='old')
DO 11, i = 1,3
read(UNIT=ilu,FMT=*)
11 CONTINUE
c n = 681
n = 704
DO 12, i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
x1(i) = x1(i)/10.
12 CONTINUE
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
DO 13, l = 1, nw-1
so2xs(l) = yg(l)
13 CONTINUE
*_______________________________________________________________________
RETURN
END
*=============================================================================*
CCC FILE rtrans.f
* This file contains the following subroutines, related to the solution of
* the equation of radiative transfer in multiple homogeneous layers.
* rtlink
* ps2str
* tridag
* psndo
* asymtx
* chekin
* fluxes
* lepoly
* pravin
* prtinp
* prtint
* qgausn
* setdis
* setmtx
* soleig
* solve0
* surfac
* solvec
* upbeam
* zeroal
* zeroit
* errmsg
* sgbco
* sgbfa
* sgbsl
* sgeco
* sgefa
* sgesl
* saxpy
* sscal
* sswap
* t665d
* t665r
* and the functions
* dref
* ratio
* wrtbad
* wrtdim
* tstbad
* sasum
* sdot
* isamax
* d1mach
* r1mach
*=============================================================================*
SUBROUTINE rtlink(nstr, nz,
$ iw, ag, zen,
$ dsdh, nid,
$ dtrl,
$ dto3,
$ dto2,
$ dtso2,
$ dtno2,
$ dtcld, omcld, gcld,
$ dtaer, omaer, gaer,
$ dtsnw, omsnw, gsnw,
$ edir, edn, eup, fdir, fdn, fup,
$ kout)
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nstr
INTEGER nz, iw
REAL ag
REAL zen
REAL dsdh(0:kz,kz)
INTEGER nid(0:kz)
REAL dtrl(kz,kw)
REAL dto3(kz,kw), dto2(kz,kw), dtso2(kz,kw), dtno2(kz,kw)
REAL dtcld(kz,kw), omcld(kz,kw), gcld(kz,kw)
REAL dtaer(kz,kw), omaer(kz,kw), gaer(kz,kw)
REAL dtsnw(kz,kw), omsnw(kz,kw), gsnw(kz,kw)
* output
REAL edir(kz), edn(kz), eup(kz)
REAL fdir(kz), fdn(kz), fup(kz)
* program constants:
REAL dr
PARAMETER (dr = pi/180.)
* local:
REAL dt(kz), om(kz), g(kz)
REAL dtabs,dtsct,dscld,dsaer,dssnw,dacld,daaer,dasnw
INTEGER i, ii
* specific two ps2str
REAL ediri(kz), edni(kz), eupi(kz)
REAL fdiri(kz), fdni(kz), fupi(kz)
LOGICAL delta
DATA delta /.true./
* specific to psndo:
REAL pmcld, pmray, pmaer, pmsnw
REAL om1
INTEGER istr, iu
INTEGER MAXCLY, MAXULV, MAXUMU, MAXCMU, MAXPHI
PARAMETER(MAXCLY=151,MAXULV=151)
PARAMETER(MAXUMU=32,MAXCMU=32)
PARAMETER(MAXPHI=3)
INTEGER NLYR, NUMU
REAL ALBEDO, DTAUC( MAXCLY ),
$ PMOM( 0:MAXCMU, MAXCLY ),
$ SSALB( MAXCLY ),
$ UMU( MAXUMU ), CWT( MAXUMU ), UMU0
REAL RFLDIR( MAXULV ), RFLDN( MAXULV ), FLUP( MAXULV ),
$ U0U( MAXUMU, MAXULV ),
$ uavgso( maxulv ), uavgup( maxulv ), uavgdn( maxulv ),
$ sindir( maxulv ), sinup( maxulv ), sindn( maxulv )
*bm added array LDIF for convenience (sky radiance)
*bm sine weighted intensity
REAL irrad
REAL ldif(MAXUMU, kz)
REAL sdir(kz), sdn(kz), sup(kz)
*_______________________________________________________________________
* initialize:
DO 5 i = 1, nz
fdir(i) = 0.
fup(i) = 0.
fdn(i) = 0.
edir(i) = 0.
eup(i) = 0.
edn(i) = 0.
sdir(i) = 0.
sup(i) = 0.
sdn(i) = 0.
5 CONTINUE
UMU0 = cos(zen*dr)
NLYR = nz - 1
ALBEDO = ag
DO 10 i = 1, nz - 1
dscld = dtcld(i,iw)*omcld(i,iw)
dacld = dtcld(i,iw)*(1.-omcld(i,iw))
dsaer = dtaer(i,iw)*omaer(i,iw)
daaer = dtaer(i,iw)*(1.-omaer(i,iw))
dssnw = dtsnw(i,iw)*omsnw(i,iw)
dasnw = dtsnw(i,iw)*(1.-omsnw(i,iw))
dtsct = dtrl(i,iw) + dscld + dsaer + dssnw
dtabs = dtso2(i,iw) + dto2(i,iw) + dto3 (i,iw) +
> dtno2(i,iw) + dacld + daaer + dasnw
dtabs = amax1(dtabs,1./largest)
dtsct = amax1(dtsct,1./largest)
* invert z-coordinate:
ii = nz - i
dt(ii) = dtsct + dtabs
om(ii) = dtsct/(dtsct + dtabs)
IF(dtsct .EQ. 1./largest) om(ii) = 1./largest
g(ii) = (gcld(i,iw)*dscld +
$ gsnw(i,iw)*dssnw +
$ gaer(i,iw)*dsaer)/dtsct
IF(nstr .LT. 2) GO TO 10
* DISORD parameters
OM1 = AMIN1(OM(ii),1.-PRECIS)
SSALB( II ) = AMAX1(OM1,PRECIS)
DTAUC( II ) = AMAX1(DT(ii),PRECIS)
* phase function - assume Henyey-Greenstein for cloud and aerosol
* and Rayleigh for molecular scattering
PMOM(0,II) = 1.0
DO 15 ISTR = 1, NSTR
PMCLD = GCLD(i,iw)**(ISTR)
PMAER = GAER(i,iw)**(ISTR)
PMSNW = GSNW(i,iw)**(ISTR)
IF(ISTR .EQ. 2) THEN
PMRAY = 0.1
ELSE
PMRAY = 0.
ENDIF
PMOM(ISTR,II) = (PMCLD*DSCLD +
$ PMAER*DSAER +
$ PMSNW*DSSNW +
$ PMRAY*DTRL(i,iw)) / DTSCT
15 CONTINUE
10 CONTINUE
* call rt routine:
IF( nstr .LT. 2 ) THEN
CALL ps2str(nz,zen,ag,dt,om,g,
$ dsdh, nid, delta,
$ fdiri, fupi, fdni, ediri, eupi, edni,
$ kout)
ELSE
CALL PSNDO( dsdh, nid,
$ NLYR, DTAUC, SSALB, PMOM,
$ ALBEDO, NSTR,
$ NUMU, UMU, CWT, UMU0,
$ MAXCLY, MAXULV, MAXUMU, MAXCMU, MAXPHI,
$ RFLDIR,RFLDN, FLUP, U0U,
$ uavgso, uavgup, uavgdn,
$ sindir, sinup, sindn,
$ kout)
ENDIF
* output (invert z-coordinate)
DO 20 i = 1, nz
ii = nz - i + 1
IF( nstr .LT. 2 ) THEN
fdir(i) = fdiri(ii)
fup(i) = fupi(ii)
fdn(i) = fdni(ii)
edir(i) = ediri(ii)
eup(i) = eupi(ii)
edn(i) = edni(ii)
ELSE
edir(i) = RFLDIR(II)
edn(i) = RFLDN(II)
eup(i) = FLUP(II)
fdir(i) = 4.* pi * uavgso(ii)
fdn(i) = 4.* pi * uavgdn(ii)
fup(i) = 4.* pi * uavgup(ii)
sdir(i) = sindir(ii)
sdn(i) = sindn(ii)
sup(i) = sinup(ii)
*bm azimutally averaged radiances at computational angles:
*bm ldif(iu,i) is the radiance at level i and cosine of polar angle UMU(iu);
*bm the polar angle is measured from the upward direction, implying that
*bm positive mu is upwelling and negative mu down-welling radiation.
DO iu = 1, numu
ldif(iu,i) = u0u (iu, ii)
ENDDO
ENDIF
20 CONTINUE
*bm example output:
c DO iu = 1, numu
c WRITE (*,*) 'rad',iu,umu(iu),ldif(iu,1)
c ENDDO
*bm example for an integral, irradiance
c irrad = 0.
c DO iu = 1, NUMU/2
c irrad = irrad + ldif(iu,1)*cwt(iu)*umu(iu)
c ENDDO
c irrad = irrad * 2. * pi
c WRITE (*,*) edn(1),' = ',irrad,' ?'
RETURN
END
*=============================================================================*
SUBROUTINE ps2str(nlevel,zen,rsfc,tauu,omu,gu,
$ dsdh, nid, delta,
$ fdr, fup, fdn, edr, eup, edn,
$ kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Solve two-stream equations for multiple layers. The subroutine is based =*
*= on equations from: Toon et al., J.Geophys.Res., v94 (D13), Nov 20, 1989.=*
*= It contains 9 two-stream methods to choose from. A pseudo-spherical =*
*= correction has also been added. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NLEVEL - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= ZEN - REAL, solar zenith angle (degrees) (I)=*
*= RSFC - REAL, surface albedo at current wavelength (I)=*
*= TAUU - REAL, unscaled optical depth of each layer (I)=*
*= OMU - REAL, unscaled single scattering albedo of each layer (I)=*
*= GU - REAL, unscaled asymmetry parameter of each layer (I)=*
*= DSDH - REAL, slant path of direct beam through each layer crossed (I)=*
*= when travelling from the top of the atmosphere to layer i; =*
*= DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1 =*
*= NID - INTEGER, number of layers crossed by the direct beam when (I)=*
*= travelling from the top of the atmosphere to layer i; =*
*= NID(i), i = 0..NZ-1 =*
*= DELTA - LOGICAL, switch to use delta-scaling (I)=*
*= .TRUE. -> apply delta-scaling =*
*= .FALSE.-> do not apply delta-scaling =*
*= FDR - REAL, contribution of the direct component to the total (O)=*
*= actinic flux at each altitude level =*
*= FUP - REAL, contribution of the diffuse upwelling component to (O)=*
*= the total actinic flux at each altitude level =*
*= FDN - REAL, contribution of the diffuse downwelling component to (O)=*
*= the total actinic flux at each altitude level =*
*= EDR - REAL, contribution of the direct component to the total (O)=*
*= spectral irradiance at each altitude level =*
*= EUP - REAL, contribution of the diffuse upwelling component to (O)=*
*= the total spectral irradiance at each altitude level =*
*= EDN - REAL, contribution of the diffuse downwelling component to (O)=*
*= the total spectral irradiance at each altitude level =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER nrows
PARAMETER(nrows=2*kz)
*******
* input:
*******
INTEGER nlevel
REAL zen, rsfc
REAL tauu(kz), omu(kz), gu(kz)
REAL dsdh(0:kz,kz)
INTEGER nid(0:kz)
LOGICAL delta
*******
* output:
*******
REAL fup(kz),fdn(kz),fdr(kz)
REAL eup(kz),edn(kz),edr(kz)
*******
* local:
*******
REAL tausla(0:kz), tauc(0:kz)
REAL mu2(0:kz), mu, sum
* internal coefficients and matrix
REAL lam(kz),taun(kz),bgam(kz)
REAL e1(kz),e2(kz),e3(kz),e4(kz)
REAL cup(kz),cdn(kz),cuptn(kz),cdntn(kz)
REAL mu1(kz)
INTEGER row
REAL a(nrows),b(nrows),d(nrows),e(nrows),y(nrows)
*******
* other:
*******
REAL pifs, fdn0, surfem
REAL gi(kz), omi(kz), tempg
REAL f, g, om
REAL gam1, gam2, gam3, gam4
* For calculations of Associated Legendre Polynomials for GAMA1,2,3,4
* in delta-function, modified quadrature, hemispheric constant,
* Hybrid modified Eddington-delta function metods, p633,Table1.
* W.E.Meador and W.R.Weaver, GAS,1980,v37,p.630
* W.J.Wiscombe and G.W. Grams, GAS,1976,v33,p2440,
* uncomment the following two lines and the appropriate statements further
* down.
C REAL YLM0, YLM2, YLM4, YLM6, YLM8, YLM10, YLM12, YLMS, BETA0,
C > BETA1, BETAn, amu1, subd
REAL expon, expon0, expon1, divisr, temp, up, dn
REAL ssfc
INTEGER nlayer, mrows, lev
INTEGER i, j
* Some additional program constants:
REAL eps
PARAMETER (eps = 1.E-3)
*_______________________________________________________________________
* MU = cosine of solar zenith angle
* RSFC = surface albedo
* TAUU = unscaled optical depth of each layer
* OMU = unscaled single scattering albedo
* GU = unscaled asymmetry factor
* KLEV = max dimension of number of layers in atmosphere
* NLAYER = number of layers in the atmosphere
* NLEVEL = nlayer + 1 = number of levels
* initial conditions: pi*solar flux = 1; diffuse incidence = 0
pifs = 1.
fdn0 = 0.
* emission at surface (for night light pollution, set pifs = 0, surfem = 1.)
surfem = 0.
nlayer = nlevel - 1
mu = COS(zen*pi/180.)
************** compute coefficients for each layer:
* GAM1 - GAM4 = 2-stream coefficients, different for different approximations
* EXPON0 = calculation of e when TAU is zero
* EXPON1 = calculation of e when TAU is TAUN
* CUP and CDN = calculation when TAU is zero
* CUPTN and CDNTN = calc. when TAU is TAUN
* DIVISR = prevents division by zero
do j = 0, kz
tauc(j) = 0.
tausla(j) = 0.
mu2(j) = 1./SQRT(largest)
end do
IF( .NOT. delta ) THEN
DO i = 1, nlayer
gi(i) = gu(i)
omi(i) = omu(i)
taun(i) = tauu(i)
ENDDO
ELSE
* delta-scaling. Have to be done for delta-Eddington approximation,
* delta discrete ordinate, Practical Improved Flux Method, delta function,
* and Hybrid modified Eddington-delta function methods approximations
DO i = 1, nlayer
f = gu(i)*gu(i)
gi(i) = (gu(i) - f)/(1 - f)
omi(i) = (1 - f)*omu(i)/(1 - omu(i)*f)
taun(i) = (1 - omu(i)*f)*tauu(i)
ENDDO
END IF
*
* calculate slant optical depth at the top of the atmosphere when zen>90.
* in this case, higher altitude of the top layer is recommended which can
* be easily changed in gridz.f.
*
IF(zen .GT. 90.0) THEN
IF(nid(0) .LT. 0) THEN
tausla(0) = largest
ELSE
sum = 0.0
DO j = 1, nid(0)
sum = sum + 2.*taun(j)*dsdh(0,j)
END DO
tausla(0) = sum
END IF
END IF
*
DO 11, i = 1, nlayer
g = gi(i)
om = omi(i)
tauc(i) = tauc(i-1) + taun(i)
* stay away from 1 by precision. For g, also stay away from -1
tempg = AMIN1(abs(g),1. - precis)
g = SIGN(tempg,g)
om = AMIN1(om,1.-precis)
* calculate slant optical depth
*
IF(nid(i) .LT. 0) THEN
tausla(i) = largest
ELSE
sum = 0.0
DO j = 1, MIN(nid(i),i)
sum = sum + taun(j)*dsdh(i,j)
ENDDO
DO j = MIN(nid(i),i)+1,nid(i)
sum = sum + 2.*taun(j)*dsdh(i,j)
ENDDO
tausla(i) = sum
IF(tausla(i) .EQ. tausla(i-1)) THEN
mu2(i) = SQRT(largest)
ELSE
mu2(i) = (tauc(i)-tauc(i-1))/(tausla(i)-tausla(i-1))
mu2(i) = SIGN( AMAX1(ABS(mu2(i)),1./SQRT(largest)),
$ mu2(i) )
END IF
END IF
*
*** the following gamma equations are from pg 16,289, Table 1
*** save mu1 for each approx. for use in converting irradiance to actinic flux
* Eddington approximation(Joseph et al., 1976, JAS, 33, 2452):
gam1 = (7. - om*(4. + 3.*g))/4.
gam2 = -(1. - om*(4. - 3.*g))/4.
gam3 = (2. - 3.*g*mu)/4.
gam4 = 1. - gam3
mu1(i) = 0.5
* quadrature (Liou, 1973, JAS, 30, 1303-1326; 1974, JAS, 31, 1473-1475):
c gam1 = 1.7320508*(2. - om*(1. + g))/2.
c gam2 = 1.7320508*om*(1. - g)/2.
c gam3 = (1. - 1.7320508*g*mu)/2.
c gam4 = 1. - gam3
c mu1(i) = 1./sqrt(3.)
* hemispheric mean (Toon et al., 1089, JGR, 94, 16287):
c gam1 = 2. - om*(1. + g)
c gam2 = om*(1. - g)
c gam3 = (2. - g*mu)/4.
c gam4 = 1. - gam3
c mu1(i) = 0.5
* PIFM (Zdunkovski et al.,1980, Conrib.Atmos.Phys., 53, 147-166):
c GAM1 = 0.25*(8. - OM*(5. + 3.*G))
c GAM2 = 0.75*OM*(1.-G)
c GAM3 = 0.25*(2.-3.*G*MU)
c GAM4 = 1. - GAM3
c mu1(i) = 0.5
* delta discrete ordinates (Schaller, 1979, Contrib.Atmos.Phys, 52, 17-26):
c GAM1 = 0.5*1.7320508*(2. - OM*(1. + G))
c GAM2 = 0.5*1.7320508*OM*(1.-G)
c GAM3 = 0.5*(1.-1.7320508*G*MU)
c GAM4 = 1. - GAM3
c mu1(i) = 1./sqrt(3.)
* Calculations of Associated Legendre Polynomials for GAMA1,2,3,4
* in delta-function, modified quadrature, hemispheric constant,
* Hybrid modified Eddington-delta function metods, p633,Table1.
* W.E.Meador and W.R.Weaver, GAS,1980,v37,p.630
* W.J.Wiscombe and G.W. Grams, GAS,1976,v33,p2440
c YLM0 = 2.
c YLM2 = -3.*G*MU
c YLM4 = 0.875*G**3*MU*(5.*MU**2-3.)
c YLM6=-0.171875*G**5*MU*(15.-70.*MU**2+63.*MU**4)
c YLM8=+0.073242*G**7*MU*(-35.+315.*MU**2-693.*MU**4
c *+429.*MU**6)
c YLM10=-0.008118*G**9*MU*(315.-4620.*MU**2+18018.*MU**4
c *-25740.*MU**6+12155.*MU**8)
c YLM12=0.003685*G**11*MU*(-693.+15015.*MU**2-90090.*MU**4
c *+218790.*MU**6-230945.*MU**8+88179.*MU**10)
c YLMS=YLM0+YLM2+YLM4+YLM6+YLM8+YLM10+YLM12
c YLMS=0.25*YLMS
c BETA0 = YLMS
c
c amu1=1./1.7320508
c YLM0 = 2.
c YLM2 = -3.*G*amu1
c YLM4 = 0.875*G**3*amu1*(5.*amu1**2-3.)
c YLM6=-0.171875*G**5*amu1*(15.-70.*amu1**2+63.*amu1**4)
c YLM8=+0.073242*G**7*amu1*(-35.+315.*amu1**2-693.*amu1**4
c *+429.*amu1**6)
c YLM10=-0.008118*G**9*amu1*(315.-4620.*amu1**2+18018.*amu1**4
c *-25740.*amu1**6+12155.*amu1**8)
c YLM12=0.003685*G**11*amu1*(-693.+15015.*amu1**2-90090.*amu1**4
c *+218790.*amu1**6-230945.*amu1**8+88179.*amu1**10)
c YLMS=YLM0+YLM2+YLM4+YLM6+YLM8+YLM10+YLM12
c YLMS=0.25*YLMS
c BETA1 = YLMS
c
c BETAn = 0.25*(2. - 1.5*G-0.21875*G**3-0.085938*G**5
c *-0.045776*G**7)
* Hybrid modified Eddington-delta function(Meador and Weaver,1980,JAS,37,630):
c subd=4.*(1.-G*G*(1.-MU))
c GAM1 = (7.-3.*G*G-OM*(4.+3.*G)+OM*G*G*(4.*BETA0+3.*G))/subd
c GAM2 =-(1.-G*G-OM*(4.-3.*G)-OM*G*G*(4.*BETA0+3.*G-4.))/subd
c GAM3 = BETA0
c GAM4 = 1. - GAM3
c mu1(i) = (1. - g*g*(1.- mu) )/(2. - g*g)
*****
* delta function (Meador, and Weaver, 1980, JAS, 37, 630):
c GAM1 = (1. - OM*(1. - beta0))/MU
c GAM2 = OM*BETA0/MU
c GAM3 = BETA0
c GAM4 = 1. - GAM3
c mu1(i) = mu
*****
* modified quadrature (Meador, and Weaver, 1980, JAS, 37, 630):
c GAM1 = 1.7320508*(1. - OM*(1. - beta1))
c GAM2 = 1.7320508*OM*beta1
c GAM3 = BETA0
c GAM4 = 1. - GAM3
c mu1(i) = 1./sqrt(3.)
* hemispheric constant (Toon et al., 1989, JGR, 94, 16287):
c GAM1 = 2.*(1. - OM*(1. - betan))
c GAM2 = 2.*OM*BETAn
c GAM3 = BETA0
c GAM4 = 1. - GAM3
c mu1(i) = 0.5
*****
* lambda = pg 16,290 equation 21
* big gamma = pg 16,290 equation 22
* checked limit for gam2/gam1 <<1: bgam -> (1/2)*gma2/gam1
* so if if gam2 = 0., then bgam = 0.
lam(i) = sqrt(gam1*gam1 - gam2*gam2)
IF( gam2 .NE. 0.) THEN
bgam(i) = (gam1 - lam(i))/gam2
ELSE
bgam(i) = 0.
ENDIF
expon = EXP(-lam(i)*taun(i))
* e1 - e4 = pg 16,292 equation 44
e1(i) = 1. + bgam(i)*expon
e2(i) = 1. - bgam(i)*expon
e3(i) = bgam(i) + expon
e4(i) = bgam(i) - expon
* the following sets up for the C equations 23, and 24
* found on page 16,290
* prevent division by zero (if LAMBDA=1/MU, shift 1/MU^2 by EPS = 1.E-3
* which is approx equiv to shifting MU by 0.5*EPS* (MU)**3
expon0 = EXP(-tausla(i-1))
expon1 = EXP(-tausla(i))
divisr = lam(i)*lam(i) - 1./(mu2(i)*mu2(i))
temp = AMAX1(eps,abs(divisr))
divisr = SIGN(temp,divisr)
up = om*pifs*((gam1 - 1./mu2(i))*gam3 + gam4*gam2)/divisr
dn = om*pifs*((gam1 + 1./mu2(i))*gam4 + gam2*gam3)/divisr
* cup and cdn are when tau is equal to zero
* cuptn and cdntn are when tau is equal to taun
cup(i) = up*expon0
cdn(i) = dn*expon0
cuptn(i) = up*expon1
cdntn(i) = dn*expon1
11 CONTINUE
***************** set up matrix ******
* ssfc = pg 16,292 equation 37 where pi Fs is one (unity).
ssfc = rsfc*mu*EXP(-tausla(nlayer))*pifs + surfem
* MROWS = the number of rows in the matrix
mrows = 2*nlayer
* the following are from pg 16,292 equations 39 - 43.
* set up first row of matrix:
i = 1
a(1) = 0.
b(1) = e1(i)
d(1) = -e2(i)
e(1) = fdn0 - cdn(i)
row=1
* set up odd rows 3 thru (MROWS - 1):
i = 0
DO 20, row = 3, mrows - 1, 2
i = i + 1
a(row) = e2(i)*e3(i) - e4(i)*e1(i)
b(row) = e1(i)*e1(i + 1) - e3(i)*e3(i + 1)
d(row) = e3(i)*e4(i + 1) - e1(i)*e2(i + 1)
e(row) = e3(i)*(cup(i + 1) - cuptn(i)) +
$ e1(i)*(cdntn(i) - cdn(i + 1))
20 CONTINUE
* set up even rows 2 thru (MROWS - 2):
i = 0
DO 30, row = 2, mrows - 2, 2
i = i + 1
a(row) = e2(i + 1)*e1(i) - e3(i)*e4(i + 1)
b(row) = e2(i)*e2(i + 1) - e4(i)*e4(i + 1)
d(row) = e1(i + 1)*e4(i + 1) - e2(i + 1)*e3(i + 1)
e(row) = (cup(i + 1) - cuptn(i))*e2(i + 1) -
$ (cdn(i + 1) - cdntn(i))*e4(i + 1)
30 CONTINUE
* set up last row of matrix at MROWS:
row = mrows
i = nlayer
a(row) = e1(i) - rsfc*e3(i)
b(row) = e2(i) - rsfc*e4(i)
d(row) = 0.
e(row) = ssfc - cuptn(i) + rsfc*cdntn(i)
* solve tri-diagonal matrix:
CALL tridag(a, b, d, e, y, mrows,kout)
**** unfold solution of matrix, compute output fluxes:
row = 1
lev = 1
j = 1
* the following equations are from pg 16,291 equations 31 & 32
fdr(lev) = pifs * EXP( -tausla(0) )
edr(lev) = mu * fdr(lev)
edn(lev) = fdn0
eup(lev) = y(row)*e3(j) - y(row + 1)*e4(j) + cup(j)
fdn(lev) = edn(lev)/mu1(lev)
fup(lev) = eup(lev)/mu1(lev)
DO 60, lev = 2, nlayer + 1
fdr(lev) = pifs * EXP(-tausla(lev-1))
edr(lev) = mu *fdr(lev)
edn(lev) = y(row)*e3(j) + y(row + 1)*e4(j) + cdntn(j)
eup(lev) = y(row)*e1(j) + y(row + 1)*e2(j) + cuptn(j)
fdn(lev) = edn(lev)/mu1(j)
fup(lev) = eup(lev)/mu1(j)
row = row + 2
j = j + 1
60 CONTINUE
*_______________________________________________________________________
RETURN
END
*=============================================================================*
SUBROUTINE tridag(a,b,c,r,u,n,kout)
*_______________________________________________________________________
* solves tridiagonal system. From Numerical Recipies, p. 40
*_______________________________________________________________________
IMPLICIT NONE
* input:
INTEGER n
REAL a, b, c, r
DIMENSION a(n),b(n),c(n),r(n)
* output:
REAL u
DIMENSION u(n)
* local:
INTEGER j
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
REAL bet, gam
DIMENSION gam(2*kz)
*_______________________________________________________________________
IF (b(1) .EQ. 0.) STOP 1001
bet = b(1)
u(1) = r(1)/bet
DO 11, j = 2, n
gam(j) = c(j - 1)/bet
bet = b(j) - a(j)*gam(j)
IF (bet .EQ. 0.) STOP 2002
u(j) = (r(j) - a(j)*u(j - 1))/bet
11 CONTINUE
DO 12, j = n - 1, 1, -1
u(j) = u(j) - gam(j + 1)*u(j + 1)
12 CONTINUE
*_______________________________________________________________________
RETURN
END
*=============================================================================*
c Note: CDIR$ and CFPP$ comment lines are relevant only when running
c on Cray computers. They cause better optimization of loops
c immediately following.
C SUBROUTINE DISORT( dsdh, nid,
SUBROUTINE PSNDO( dsdh, nid,
& NLYR, DTAUC, SSALB, PMOM,
& ALBEDO, NSTR,
& NUMU, UMU, CWT, UMU0,
& MAXCLY, MAXULV, MAXUMU, MAXCMU, MAXPHI,
$ RFLDIR, RFLDN, FLUP, U0U,
& uavgso, uavgup, uavgdn,
& sindir, sinup, sindn,
& kout )
c Improved handling of numerical instabilities. Bernhard Mayer on 5/3/99.
c disort seems to produce unstable results for certain combinations
c of single scattering albedo and phase function. A temporary fix has been
c introduced to avoid this problem: The original instability check in
c UPBEAM fails on certain compiler/machine combinations (e.g., gcc/LINUX,
c or xlf/IBM RS6000). This check has therefore been replaced by a new one.
c Whenever UPBEAM reports an instability, the single scattering albedo
c of the respective layer is changed by a small amount, and the
c calculation is repeated until numerically stable conditions are reached
c (all the necessary changes are confined to the new subroutine SOLVEC
c and the slighly changed subroutine UPBEAM). To check for potential
c instabilities, the variable 'RCOND' returned by SGECO is compared to
c a machine-dependent constant, 'MINRCOND'. The value of this constant
c determines (a) if really all instabilities are caught; and (b) the
c amount by which the single scattering albedo has to be changed. The
c value of 'MINRCOND' is therefore a compromise between numerical
c stability on the one hand and uncertainties introduced by changing
c the atmospheric conditions and increased computational time on the
c other hand (an increase of MINRCOND will lead to the detection of
c more potential numerical instabilities, and thus to an increase in
c computational time; by changing the atmospheric conditions, that is,
c the single scattering albedo, the result might however be changed
c unfavourably, if the change is too large). From a limited number
c of experiments we found that 'MINRCOND = 5000. * R1MACH(4)' seems
c to be a good choice if high accuracy is required (more tests are
c definitely neccessary!). If an instability is encountered, a message
c is printed telling about neccessary changes to the single scattering
c albedo. This message may be switched off by setting 'DEBUG = .FALSE.'
c in subroutine SOLVEC.
c
c
c modified to calculate sine-weighted intensities. Bernhard Mayer on 2/12/99.
c modified to handle some numerical instabilities. Chris Fischer on 1/22/99.
c modified by adding pseudo-spherical correction. Jun Zeng on 3/11/97.
c dsdh: slant path of direct beam through each layer crossed
c when travelling from the top of the atmosphere to layer i;
c dsdh(i,j), i = 0..nlyr, j = 1..nlyr;
c nid: number of layers crossed by the direct beam when
c travelling from the top of the atmosphere to layer i;
c NID(i), i = 0..nlyr.
c uavgso, uvagup, and uvagdn are direct, downward diffuse, and upward
c diffuse actinic flux (mean intensity).
c u0u is the azimuthally averaged intensity, check DISORT.doc for details.
c *******************************************************************
c Plane-parallel discrete ordinates radiative transfer program
c V E R S I O N 1.1
c ( see DISORT.DOC for complete documentation )
c *******************************************************************
c +------------------------------------------------------------------+
c Calling Tree (omitting calls to ERRMSG):
c (routines in parentheses are not in this file)
c DISORT-+-(R1MACH)
c +-ZEROIT
c +-CHEKIN-+-(WRTBAD)
c | +-(WRTDIM)
c | +-DREF
c +-ZEROAL
c +-SETDIS-+-QGAUSN (1)-+-(D1MACH)
c +-PRTINP
c +-LEPOLY see 2
c +-SURFAC-+-QGAUSN see 1
c | +-LEPOLY see 2
c | +-ZEROIT
c +-SOLEIG see 3
c +-UPBEAM-+-(SGECO)
c | +-(SGESL)
c +-TERPEV
c +-TERPSO
c +-SETMTX see 4
c +-SOLVE0-+-ZEROIT
c | +-(SGBCO)
c | +-(SGBSL)
c +-FLUXES--ZEROIT
c +-PRAVIN
c +-RATIO--(R1MACH)
c +-PRTINT
c *** Intrinsic Functions used in DISORT package which take
c non-negligible amount of time:
c EXP : Called by- ALBTRN, ALTRIN, CMPINT, FLUXES, SETDIS,
c SETMTX, SPALTR, USRINT, PLKAVG
c SQRT : Called by- ASYMTX, LEPOLY, SOLEIG
c +-------------------------------------------------------------------+
c Index conventions (for all DO-loops and all variable descriptions):
c IU : for user polar angles
c IQ,JQ,KQ : for computational polar angles ('quadrature angles')
c IQ/2 : for half the computational polar angles (just the ones
c in either 0-90 degrees, or 90-180 degrees)
c J : for user azimuthal angles
c K,L : for Legendre expansion coefficients or, alternatively,
c subscripts of associated Legendre polynomials
c LU : for user levels
c LC : for computational layers (each having a different
c single-scatter albedo and/or phase function)
c LEV : for computational levels
c MAZIM : for azimuthal components in Fourier cosine expansion
c of intensity and phase function
c +------------------------------------------------------------------+
c I N T E R N A L V A R I A B L E S
c AMB(IQ/2,IQ/2) First matrix factor in reduced eigenvalue problem
c of Eqs. SS(12), STWJ(8E) (used only in SOLEIG)
c APB(IQ/2,IQ/2) Second matrix factor in reduced eigenvalue problem
c of Eqs. SS(12), STWJ(8E) (used only in SOLEIG)
c ARRAY(IQ,IQ) Scratch matrix for SOLEIG, UPBEAM and UPISOT
c (see each subroutine for definition)
c B() Right-hand side vector of Eq. SC(5) going into
c SOLVE0,1; returns as solution vector
c vector L, the constants of integration
c BDR(IQ/2,0:IQ/2) Bottom-boundary bidirectional reflectivity for a
c given azimuthal component. First index always
c refers to a computational angle. Second index:
c if zero, refers to incident beam angle UMU0;
c if non-zero, refers to a computational angle.
c BEM(IQ/2) Bottom-boundary directional emissivity at compu-
c tational angles.
c BPLANK Intensity emitted from bottom boundary
c CBAND() Matrix of left-hand side of the linear system
c Eq. SC(5), scaled by Eq. SC(12); in banded
c form required by LINPACK solution routines
c CC(IQ,IQ) C-sub-IJ in Eq. SS(5)
c CMU(IQ) Computational polar angles (Gaussian)
c CWT(IQ) Quadrature weights corresponding to CMU
c DELM0 Kronecker delta, delta-sub-M0, where M = MAZIM
c is the number of the Fourier component in the
c azimuth cosine expansion
c DITHER Small quantity subtracted from single-scattering
c albedos of unity, in order to avoid using special
c case formulas; prevents an eigenvalue of exactly
c zero from occurring, which would cause an
c immediate overflow
c DTAUCP(LC) Computational-layer optical depths (delta-M-scaled
c if DELTAM = TRUE, otherwise equal to DTAUC)
c EMU(IU) Bottom-boundary directional emissivity at user
c angles.
c EVAL(IQ) Temporary storage for eigenvalues of Eq. SS(12)
c EVECC(IQ,IQ) Complete eigenvectors of SS(7) on return from
c SOLEIG; stored permanently in GC
c EXPBEA(LC) Transmission of direct beam in delta-M optical
c depth coordinates
c FLYR(LC) Truncated fraction in delta-M method
c GL(K,LC) Phase function Legendre polynomial expansion
c coefficients, calculated from PMOM by
c including single-scattering albedo, factor
c 2K+1, and (if DELTAM=TRUE) the delta-M
c scaling
c GC(IQ,IQ,LC) Eigenvectors at polar quadrature angles,
c g in Eq. SC(1)
c GU(IU,IQ,LC) Eigenvectors interpolated to user polar angles
c ( g in Eqs. SC(3) and S1(8-9), i.e.
c G without the L factor )
c HLPR() Legendre coefficients of bottom bidirectional
c reflectivity (after inclusion of 2K+1 factor)
c IPVT(LC*IQ) Integer vector of pivot indices for LINPACK
c routines
c KK(IQ,LC) Eigenvalues of coeff. matrix in Eq. SS(7)
c KCONV Counter in azimuth convergence test
c LAYRU(LU) Computational layer in which user output level
c UTAU(LU) is located
c LL(IQ,LC) Constants of integration L in Eq. SC(1),
c obtained by solving scaled version of Eq. SC(5)
c LYRCUT TRUE, radiation is assumed zero below layer
c NCUT because of almost complete absorption
c NAZ Number of azimuthal components considered
c NCUT Computational layer number in which absorption
c optical depth first exceeds ABSCUT
c OPRIM(LC) Single scattering albedo after delta-M scaling
c PASS1 TRUE on first entry, FALSE thereafter
c PKAG(0:LC) Integrated Planck function for internal emission
c PSI(IQ) Sum just after square bracket in Eq. SD(9)
c RMU(IU,0:IQ) Bottom-boundary bidirectional reflectivity for a
c given azimuthal component. First index always
c refers to a user angle. Second index:
c if zero, refers to incident beam angle UMU0;
c if non-zero, refers to a computational angle.
c TAUC(0:LC) Cumulative optical depth (un-delta-M-scaled)
c TAUCPR(0:LC) Cumulative optical depth (delta-M-scaled if
c DELTAM = TRUE, otherwise equal to TAUC)
c TPLANK Intensity emitted from top boundary
c UUM(IU,LU) Expansion coefficients when the intensity
c (u-super-M) is expanded in Fourier cosine series
c in azimuth angle
c U0C(IQ,LU) Azimuthally-averaged intensity
c UTAUPR(LU) Optical depths of user output levels in delta-M
c coordinates; equal to UTAU(LU) if no delta-M
c WK() scratch array
c XR0(LC) X-sub-zero in expansion of thermal source func-
c tion preceding Eq. SS(14) (has no mu-dependence)
c XR1(LC) X-sub-one in expansion of thermal source func-
c tion; see Eqs. SS(14-16)
c YLM0(L) Normalized associated Legendre polynomial
c of subscript L at the beam angle (not saved
c as function of superscipt M)
c YLMC(L,IQ) Normalized associated Legendre polynomial
c of subscript L at the computational angles
c (not saved as function of superscipt M)
c YLMU(L,IU) Normalized associated Legendre polynomial
c of subscript L at the user angles
c (not saved as function of superscipt M)
c Z() scratch array used in SOLVE0,1 to solve a
c linear system for the constants of integration
c Z0(IQ) Solution vectors Z-sub-zero of Eq. SS(16)
c Z0U(IU,LC) Z-sub-zero in Eq. SS(16) interpolated to user
c angles from an equation derived from SS(16)
c Z1(IQ) Solution vectors Z-sub-one of Eq. SS(16)
c Z1U(IU,LC) Z-sub-one in Eq. SS(16) interpolated to user
c angles from an equation derived from SS(16)
c ZBEAM(IU,LC) Particular solution for beam source
c ZJ(IQ) Right-hand side vector X-sub-zero in
c Eq. SS(19), also the solution vector
c Z-sub-zero after solving that system
c ZZ(IQ,LC) Permanent storage for the beam source vectors ZJ
c ZPLK0(IQ,LC) Permanent storage for the thermal source
c vectors Z0 obtained by solving Eq. SS(16)
c ZPLK1(IQ,LC) Permanent storage for the thermal source
c vectors Z1 obtained by solving Eq. SS(16)
c +-------------------------------------------------------------------+
c LOCAL SYMBOLIC DIMENSIONS (have big effect on storage requirements):
c MXCLY = Max no. of computational layers
c MXULV = Max no. of output levels
c MXCMU = Max no. of computation polar angles
c MXUMU = Max no. of output polar angles
c MXPHI = Max no. of output azimuthal angles
c +-------------------------------------------------------------------+
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
c .. Parameters ..
INTEGER MXCLY, MXULV, MXCMU, MXUMU, MXPHI, MI, MI9M2, NNLYRI
PARAMETER ( MXCLY = 151, MXULV = 151, MXCMU = 32, MXUMU = 32,
& MXPHI = 3, MI = MXCMU / 2, MI9M2 = 9*MI - 2,
& NNLYRI = MXCMU*MXCLY )
c ..
c .. Scalar Arguments ..
CHARACTER HEADER*127
LOGICAL DELTAM, LAMBER, ONLYFL, PLANK, USRANG, USRTAU
INTEGER IBCND, MAXCLY, MAXCMU, MAXPHI, MAXULV, MAXUMU, NLYR,
& NPHI, NSTR, NTAU, NUMU
REAL ACCUR, ALBEDO, BTEMP, FBEAM, FISOT, PHI0, TEMIS, TTEMP,
& UMU0, WVNMHI, WVNMLO
c sherical geometry
REAL dsdh(0:kz,kz)
INTEGER nid(0:kz)
REAL tausla(0:kz), tauslau(0:kz), mu2(0:kz)
c ..
c .. Array Arguments ..
LOGICAL PRNT( 7 )
REAL ALBMED( MAXUMU ), DFDT( MAXULV ), DTAUC( MAXCLY ),
& FLUP( MAXULV ), HL( 0:MAXCMU ), PHI( MAXPHI ),
& PMOM( 0:MAXCMU, MAXCLY ), RFLDIR( MAXULV ),
& RFLDN( MAXULV ), SSALB( MAXCLY ), TEMPER( 0:MAXCLY ),
& TRNMED( MAXUMU ), U0U( MAXUMU, MAXULV ), UAVG( MAXULV ),
& UMU( MAXUMU ), CWT( MAXCMU ), UTAU( MAXULV ),
& UU( MAXUMU, MAXULV, MAXPHI ),
& uavgso( maxulv ), uavgup( maxulv ), uavgdn( maxulv ),
& sindir( maxulv ), sinup( maxulv ), sindn ( maxulv )
c ..
c .. Local Scalars ..
LOGICAL COMPAR, LYRCUT, PASS1
INTEGER IQ, IU, J, KCONV, L, LC, LEV, LU, MAZIM, NAZ, NCOL,
& NCOS, NCUT, NN
REAL ANGCOS, AZERR, AZTERM, BPLANK, COSPHI, DELM0, DITHER,
& DUM, RPD, SGN, TPLANK
c ..
c .. Local Arrays ..
INTEGER IPVT( NNLYRI ), LAYRU( MXULV )
REAL AMB( MI, MI ), APB( MI, MI ), ARRAY( MXCMU, MXCMU ),
& B( NNLYRI ), BDR( MI, 0:MI ), BEM( MI ),
& CBAND( MI9M2, NNLYRI ), CC( MXCMU, MXCMU ),
& CMU( MXCMU ), DTAUCP( MXCLY ),
& EMU( MXUMU ), EVAL( MI ), EVECC( MXCMU, MXCMU ),
& EXPBEA( 0:MXCLY ), FLDIR( MXULV ), FLDN( MXULV ),
& FLYR( MXCLY ), GC( MXCMU, MXCMU, MXCLY ),
& GL( 0:MXCMU, MXCLY ), GU( MXUMU, MXCMU, MXCLY ),
& HLPR( 0:MXCMU ), KK( MXCMU, MXCLY ), LL( MXCMU, MXCLY ),
& OPRIM( MXCLY ), PHIRAD( MXPHI ), PKAG( 0:MXCLY ),
& PSI( MXCMU ), RMU( MXUMU, 0:MI ), TAUC( 0:MXCLY ),
& TAUCPR( 0:MXCLY ), U0C( MXCMU, MXULV ), UTAUPR( MXULV ),
& UUM( MXUMU, MXULV ), WK( MXCMU ), XR0( MXCLY ),
& XR1( MXCLY ), YLM0( 0:MXCMU ), YLMC( 0:MXCMU, MXCMU ),
& YLMU( 0:MXCMU, MXUMU ), Z( NNLYRI ), Z0( MXCMU ),
& Z0U( MXUMU, MXCLY ), Z1( MXCMU ), Z1U( MXUMU, MXCLY ),
& ZBEAM( MXUMU, MXCLY ), ZJ( MXCMU ),
& ZPLK0( MXCMU, MXCLY ), ZPLK1( MXCMU, MXCLY ),
& ZZ( MXCMU, MXCLY )
cgy added glsave and dgl to allow adjustable dimensioning in SOLVEC
REAL GLSAVE( 0:MXCMU ), DGL( 0:MXCMU )
REAL AAD( MI, MI ), EVALD( MI ), EVECCD( MI, MI ),
& WKD( MXCMU )
c ..
c .. External Functions ..
REAL PLKAVG, R1MACH, RATIO
EXTERNAL R1MACH, RATIO
c ..
c .. External Subroutines ..
EXTERNAL CHEKIN, FLUXES, LEPOLY, PRAVIN, PRTINP,
& PRTINT, SETDIS, SETMTX, SOLEIG, SOLVE0, SURFAC,
& UPBEAM, ZEROAL, ZEROIT
c ..
c .. Intrinsic Functions ..
INTRINSIC ABS, ASIN, COS, LEN, MAX
c ..
SAVE PASS1, DITHER, RPD
DATA PASS1 / .TRUE. /
* Discrete ordinate constants:
* For pseudo-spherical DISORT, PLANK, USRTAU and USRANG must be .FALSE.;
* ONLYFL must be .TRUE.; FBEAM = 1.; FISOT = 0.; IBCND = 0
data LAMBER /.TRUE./
data USRTAU /.FALSE./
data PLANK /.FALSE./
data USRANG /.FALSE./
data ONLYFL /.TRUE./
data PRNT /.FALSE.,.FALSE.,.FALSE.,.FALSE.,.FALSE.,
$ .FALSE.,.FALSE./
data ACCUR /0.0001/
data HEADER /' '/
data NPHI /0/
data IBCND /0/
data FBEAM /1./
data FISOT /0.0/
data PHI0 /0.0/
* delat-M scaling option
data DELTAM /.true./
IF( PASS1 ) THEN
DITHER = 10.*R1MACH( 4 )
c ** Must dither more on Cray (14-digit prec)
IF( DITHER.LT.1.E-10 ) DITHER = 10.*DITHER
RPD = PI / 180.0
PASS1 = .FALSE.
END IF
10 CONTINUE
c ** Calculate cumulative optical depth
c and dither single-scatter albedo
c to improve numerical behavior of
c eigenvalue/vector computation
CALL ZEROIT( TAUC, MXCLY + 1 )
DO 20 LC = 1, NLYR
IF( SSALB( LC ).EQ.1.0 ) SSALB( LC ) = 1.0 - DITHER
TAUC( LC ) = TAUC( LC - 1 ) + DTAUC( LC )
20 CONTINUE
c ** Check input dimensions and variables
CALL CHEKIN( NLYR, DTAUC, SSALB, PMOM, TEMPER, WVNMLO, WVNMHI,
& USRTAU, NTAU, UTAU, NSTR, USRANG, NUMU, UMU, NPHI,
& PHI, IBCND, FBEAM, UMU0, PHI0, FISOT, LAMBER, ALBEDO,
& HL, BTEMP, TTEMP, TEMIS, PLANK, ONLYFL, ACCUR, TAUC,
& MAXCLY, MAXULV, MAXUMU, MAXCMU, MAXPHI, MXCLY, MXULV,
& MXUMU, MXCMU, MXPHI )
c ** Zero internal and output arrays
CALL ZEROAL( MXCLY, EXPBEA(1), FLYR, OPRIM, TAUCPR(1), XR0, XR1,
$ MXCMU, CMU, CWT, PSI, WK, Z0, Z1, ZJ,
$ MXCMU+1, HLPR, YLM0,
$ MXCMU**2, ARRAY, CC, EVECC,
$ (MXCMU+1)*MXCLY, GL,
$ (MXCMU+1)*MXCMU, YLMC,
$ (MXCMU+1)*MXUMU, YLMU,
$ MXCMU*MXCLY, KK, LL, ZZ, ZPLK0, ZPLK1,
$ MXCMU**2*MXCLY, GC,
$ MXULV, LAYRU, UTAUPR,
$ MXUMU*MXCMU*MXCLY, GU,
$ MXUMU*MXCLY, Z0U, Z1U, ZBEAM,
$ MI, EVAL,
$ MI**2, AMB, APB,
$ NNLYRI, IPVT, Z,
$ MAXULV, RFLDIR, RFLDN, FLUP, UAVG, DFDT,
$ MAXUMU, ALBMED, TRNMED,
$ MAXUMU*MAXULV, U0U,
$ MAXUMU*MAXULV*MAXPHI, UU )
c ** Perform various setup operations
CALL SETDIS( dsdh, nid, tausla, tauslau, mu2,
& CMU, CWT, DELTAM, DTAUC, DTAUCP, EXPBEA, FBEAM, FLYR,
& GL, HL, HLPR, IBCND, LAMBER, LAYRU, LYRCUT, MAXUMU,
& MAXCMU, MXCMU, NCUT, NLYR, NTAU, NN, NSTR, PLANK,
& NUMU, ONLYFL, OPRIM, PMOM, SSALB, TAUC, TAUCPR, UTAU,
& UTAUPR, UMU, UMU0, USRTAU, USRANG, kout )
c ** Print input information
IF ( PRNT(1) )
$ CALL PRTINP( NLYR, DTAUC, DTAUCP, SSALB, PMOM, TEMPER,
$ WVNMLO, WVNMHI, NTAU, UTAU, NSTR, NUMU, UMU,
$ NPHI, PHI, IBCND, FBEAM, UMU0, PHI0, FISOT,
$ LAMBER, ALBEDO, HL, BTEMP, TTEMP, TEMIS,
$ DELTAM, PLANK, ONLYFL, ACCUR, FLYR, LYRCUT,
$ OPRIM, TAUC, TAUCPR, MAXCMU, PRNT(7) )
c ** Handle special case for getting albedo
c and transmissivity of medium for many
c beam angles at once
c ** Calculate Planck functions
BPLANK = 0.0
TPLANK = 0.0
CALL ZEROIT( PKAG, MXCLY + 1 )
c ======== BEGIN LOOP TO SUM AZIMUTHAL COMPONENTS OF INTENSITY =======
c (EQ STWJ 5)
KCONV = 0
NAZ = NSTR - 1
c ** Azimuth-independent case
IF( FBEAM.EQ.0.0 .OR. ( 1.- UMU0 ).LT.1.E-5 .OR. ONLYFL .OR.
& ( NUMU.EQ.1 .AND. ( 1.- UMU(1) ).LT.1.E-5 ) )
& NAZ = 0
DO 160 MAZIM = 0, NAZ
IF( MAZIM.EQ.0 ) DELM0 = 1.0
IF( MAZIM.GT.0 ) DELM0 = 0.0
c ** Get normalized associated Legendre
c polynomials for
c (a) incident beam angle cosine
c (b) computational and user polar angle
c cosines
IF( FBEAM.GT.0.0 ) THEN
NCOS = 1
ANGCOS = -UMU0
CALL LEPOLY( NCOS, MAZIM, MXCMU, NSTR - 1, [ANGCOS], YLM0 )
END IF
IF( .NOT.ONLYFL .AND. USRANG )
& CALL LEPOLY( NUMU, MAZIM, MXCMU, NSTR-1, UMU, YLMU )
CALL LEPOLY( NN, MAZIM, MXCMU, NSTR-1, CMU, YLMC )
c ** Get normalized associated Legendre polys.
c with negative arguments from those with
c positive arguments; Dave/Armstrong Eq. (15)
SGN = - 1.0
DO 50 L = MAZIM, NSTR - 1
SGN = - SGN
DO 40 IQ = NN + 1, NSTR
YLMC( L, IQ ) = SGN*YLMC( L, IQ - NN )
40 CONTINUE
50 CONTINUE
c ** Specify users bottom reflectivity
c and emissivity properties
IF ( .NOT.LYRCUT )
$ CALL SURFAC( ALBEDO, DELM0, FBEAM, HLPR, LAMBER,
$ MI, MAZIM, MXCMU, MXUMU, NN, NUMU, NSTR, ONLYFL,
$ UMU, USRANG, YLM0, YLMC, YLMU, BDR, EMU, BEM,
$ RMU )
c =================== BEGIN LOOP ON COMPUTATIONAL LAYERS =============
DO 60 LC = 1, NCUT
CALL SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL( 0,LC ), MI,
& MAZIM, MXCMU, NN, NSTR, YLM0, YLMC, CC,
& EVECC, EVAL, KK( 1,LC ), GC( 1,1,LC ), AAD, EVECCD,
& EVALD, WK, WKD, DELM0, FBEAM, IPVT, PI, UMU0,
& ZJ, ZZ(1,LC), OPRIM(LC), LC, DITHER, mu2(lc),
& glsave, dgl)
cgy added glsave and dgl to call to allow adjustable dimensioning
60 CONTINUE
c =================== END LOOP ON COMPUTATIONAL LAYERS ===============
c ** Set coefficient matrix of equations combining
c boundary and layer interface conditions
CALL SETMTX( BDR, CBAND, CMU, CWT, DELM0, DTAUCP, GC, KK,
& LAMBER, LYRCUT, MI, MI9M2, MXCMU, NCOL, NCUT,
& NNLYRI, NN, NSTR, TAUCPR, WK )
c ** Solve for constants of integration in homo-
c geneous solution (general boundary conditions)
CALL SOLVE0( B, BDR, BEM, BPLANK, CBAND, CMU, CWT, EXPBEA,
& FBEAM, FISOT, IPVT, LAMBER, LL, LYRCUT, MAZIM, MI,
& MI9M2, MXCMU, NCOL, NCUT, NN, NSTR, NNLYRI, PI,
& TPLANK, TAUCPR, UMU0, Z, ZZ, ZPLK0, ZPLK1 )
c ** Compute upward and downward fluxes
IF ( MAZIM.EQ.0 )
$ CALL FLUXES( tausla, tauslau,
$ CMU, CWT, FBEAM, GC, KK, LAYRU, LL, LYRCUT,
$ MAXULV, MXCMU, MXULV, NCUT, NN, NSTR, NTAU,
$ PI, PRNT, SSALB, TAUCPR, UMU0, UTAU, UTAUPR,
$ XR0, XR1, ZZ, ZPLK0, ZPLK1, DFDT, FLUP,
$ FLDN, FLDIR, RFLDIR, RFLDN, UAVG, U0C,
$ uavgso, uavgup, uavgdn,
$ sindir, sinup, sindn)
IF( ONLYFL ) THEN
IF( MAXUMU.GE.NSTR ) THEN
c ** Save azimuthal-avg intensities
c at quadrature angles
DO 80 LU = 1, NTAU
DO 70 IQ = 1, NSTR
U0U( IQ, LU ) = U0C( IQ, LU )
70 CONTINUE
80 CONTINUE
END IF
GO TO 170
END IF
CALL ZEROIT( UUM, MXUMU*MXULV )
IF( MAZIM.EQ.0 ) THEN
c ** Save azimuthally averaged intensities
DO 110 LU = 1, NTAU
DO 100 IU = 1, NUMU
U0U( IU, LU ) = UUM( IU, LU )
DO 90 J = 1, NPHI
UU( IU, LU, J ) = UUM( IU, LU )
90 CONTINUE
100 CONTINUE
110 CONTINUE
c ** Print azimuthally averaged intensities
c at user angles
IF( PRNT( 4 ) ) CALL PRAVIN( UMU, NUMU, MAXUMU, UTAU, NTAU,
& U0U )
IF( NAZ.GT.0 ) THEN
CALL ZEROIT( PHIRAD, MXPHI )
DO 120 J = 1, NPHI
PHIRAD( J ) = RPD*( PHI( J ) - PHI0 )
120 CONTINUE
END IF
ELSE
c ** Increment intensity by current
c azimuthal component (Fourier
c cosine series); Eq SD(2)
AZERR = 0.0
DO 150 J = 1, NPHI
COSPHI = COS( MAZIM*PHIRAD( J ) )
DO 140 LU = 1, NTAU
DO 130 IU = 1, NUMU
AZTERM = UUM( IU, LU )*COSPHI
UU( IU, LU, J ) = UU( IU, LU, J ) + AZTERM
AZERR = MAX( AZERR,
& RATIO( ABS(AZTERM), ABS(UU(IU,LU,J)) ) )
130 CONTINUE
140 CONTINUE
150 CONTINUE
IF( AZERR.LE.ACCUR ) KCONV = KCONV + 1
IF( KCONV.GE.2 ) GO TO 170
END IF
160 CONTINUE
c =================== END LOOP ON AZIMUTHAL COMPONENTS ===============
c ** Print intensities
170 CONTINUE
IF( PRNT( 5 ) .AND. .NOT.ONLYFL ) CALL PRTINT( UU, UTAU, NTAU,
& UMU, NUMU, PHI, NPHI, MAXULV, MAXUMU )
END
SUBROUTINE ASYMTX( AA, EVEC, EVAL, M, IA, IEVEC, IER, WKD, AAD,
& EVECD, EVALD )
c ======= D O U B L E P R E C I S I O N V E R S I O N ======
c Solves eigenfunction problem for real asymmetric matrix
c for which it is known a priori that the eigenvalues are real.
c This is an adaptation of a subroutine EIGRF in the IMSL
c library to use real instead of complex arithmetic, accounting
c for the known fact that the eigenvalues and eigenvectors in
c the discrete ordinate solution are real. Other changes include
c putting all the called subroutines in-line, deleting the
c performance index calculation, updating many DO-loops
c to Fortran77, and in calculating the machine precision
c TOL instead of specifying it in a data statement.
c EIGRF is based primarily on EISPACK routines. The matrix is
c first balanced using the Parlett-Reinsch algorithm. Then
c the Martin-Wilkinson algorithm is applied.
c References:
c Dongarra, J. and C. Moler, EISPACK -- A Package for Solving
c Matrix Eigenvalue Problems, in Cowell, ed., 1984:
c Sources and Development of Mathematical Software,
c Prentice-Hall, Englewood Cliffs, NJ
c Parlett and Reinsch, 1969: Balancing a Matrix for Calculation
c of Eigenvalues and Eigenvectors, Num. Math. 13, 293-304
c Wilkinson, J., 1965: The Algebraic Eigenvalue Problem,
c Clarendon Press, Oxford
c I N P U T V A R I A B L E S:
c AA : input asymmetric matrix, destroyed after solved
c M : order of AA
c IA : first dimension of AA
c IEVEC : first dimension of EVEC
c O U T P U T V A R I A B L E S:
c EVEC : (unnormalized) eigenvectors of AA
c ( column J corresponds to EVAL(J) )
c EVAL : (unordered) eigenvalues of AA ( dimension at least M )
c IER : if .NE. 0, signals that EVAL(IER) failed to converge;
c in that case eigenvalues IER+1,IER+2,...,M are
c correct but eigenvalues 1,...,IER are set to zero.
c S C R A T C H V A R I A B L E S:
c WKD : work area ( dimension at least 2*M )
c AAD : double precision stand-in for AA
c EVECD : double precision stand-in for EVEC
c EVALD : double precision stand-in for EVAL
c Called by- SOLEIG
c Calls- D1MACH, ERRMSG
c +-------------------------------------------------------------------+
c .. Scalar Arguments ..
INTEGER IA, IER, IEVEC, M
c ..
c .. Array Arguments ..
REAL AA( IA, M ), EVAL( M ), EVEC( IEVEC, M )
REAL AAD( IA, M ), EVALD( M ), EVECD( IA, M ),
& WKD( * )
c ..
c .. Local Scalars ..
LOGICAL NOCONV, NOTLAS
INTEGER I, II, IN, J, K, KA, KKK, L, LB, LLL, N, N1, N2
REAL C1, C2, C3, C4, C5, C6, COL, DISCRI, F, G, H,
& ONE, P, Q, R, REPL, RNORM, ROW, S, SCALE, SGN, T,
& TOL, UU, VV, W, X, Y, Z, ZERO
c ..
c .. External Functions ..
REAL D1MACH
EXTERNAL D1MACH
c ..
c .. External Subroutines ..
EXTERNAL ERRMSG
c ..
c .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MIN, SIGN, SQRT
c ..
DATA C1 / 0.4375D0 / , C2 / 0.5D0 / , C3 / 0.75D0 / ,
& C4 / 0.95D0 / , C5 / 16.D0 / , C6 / 256.D0 / ,
& ZERO / 0.D0 / , ONE / 1.D0 /
IER = 0
TOL = D1MACH( 4 )
IF( M.LT.1 .OR. IA.LT.M .OR. IEVEC.LT.M )
& CALL ERRMSG( 'ASYMTX--bad input variable(s)', .TRUE. )
c ** Handle 1x1 and 2x2 special cases
IF( M.EQ.1 ) THEN
EVAL( 1 ) = AA( 1, 1 )
EVEC( 1, 1 ) = 1.0
RETURN
ELSE IF( M.EQ.2 ) THEN
DISCRI = ( AA( 1,1 ) - AA( 2,2 ) )**2 +
& 4.*AA( 1, 2 )*AA( 2, 1 )
IF( DISCRI.LT.0.0 )
& CALL ERRMSG( 'ASYMTX--complex evals in 2x2 case',.TRUE. )
SGN = 1.0
IF( AA( 1,1 ).LT.AA( 2,2 ) ) SGN = - 1.0
EVAL( 1 ) = 0.5*( AA( 1,1 ) + AA( 2,2 ) + SGN*SQRT( DISCRI ) )
EVAL( 2 ) = 0.5*( AA( 1,1 ) + AA( 2,2 ) - SGN*SQRT( DISCRI ) )
EVEC( 1, 1 ) = 1.0
EVEC( 2, 2 ) = 1.0
IF( AA( 1,1 ).EQ.AA( 2,2 ) .AND.
& ( AA( 2,1 ).EQ.0.0 .OR. AA( 1,2 ).EQ.0.0 ) ) THEN
RNORM = ABS( AA( 1,1 ) ) + ABS( AA( 1,2 ) ) +
& ABS( AA( 2,1 ) ) + ABS( AA( 2,2 ) )
W = TOL*RNORM
EVEC( 2, 1 ) = AA( 2, 1 ) / W
EVEC( 1, 2 ) = - AA( 1, 2 ) / W
ELSE
EVEC( 2, 1 ) = AA( 2, 1 ) / ( EVAL( 1 ) - AA( 2,2 ) )
EVEC( 1, 2 ) = AA( 1, 2 ) / ( EVAL( 2 ) - AA( 1,1 ) )
END IF
RETURN
END IF
c ** Put s.p. matrix into d.p. matrix
DO 20 J = 1, M
DO 10 K = 1, M
AAD( J, K ) = DBLE( AA( J,K ) )
10 CONTINUE
20 CONTINUE
c ** Initialize output variables
IER = 0
DO 40 I = 1, M
EVALD( I ) = ZERO
DO 30 J = 1, M
EVECD( I, J ) = ZERO
30 CONTINUE
EVECD( I, I ) = ONE
40 CONTINUE
c ** Balance the input matrix and reduce its norm by
c diagonal similarity transformation stored in WK;
c then search for rows isolating an eigenvalue
c and push them down
RNORM = ZERO
L = 1
K = M
50 CONTINUE
KKK = K
DO 90 J = KKK, 1, -1
ROW = ZERO
DO 60 I = 1, K
IF( I.NE.J ) ROW = ROW + ABS( AAD( J,I ) )
60 CONTINUE
IF( ROW.EQ.ZERO ) THEN
WKD( K ) = J
IF( J.NE.K ) THEN
DO 70 I = 1, K
REPL = AAD( I, J )
AAD( I, J ) = AAD( I, K )
AAD( I, K ) = REPL
70 CONTINUE
DO 80 I = L, M
REPL = AAD( J, I )
AAD( J, I ) = AAD( K, I )
AAD( K, I ) = REPL
80 CONTINUE
END IF
K = K - 1
GO TO 50
END IF
90 CONTINUE
c ** Search for columns isolating an
c eigenvalue and push them left
100 CONTINUE
LLL = L
DO 140 J = LLL, K
COL = ZERO
DO 110 I = L, K
IF( I.NE.J ) COL = COL + ABS( AAD( I,J ) )
110 CONTINUE
IF( COL.EQ.ZERO ) THEN
WKD( L ) = J
IF( J.NE.L ) THEN
DO 120 I = 1, K
REPL = AAD( I, J )
AAD( I, J ) = AAD( I, L )
AAD( I, L ) = REPL
120 CONTINUE
DO 130 I = L, M
REPL = AAD( J, I )
AAD( J, I ) = AAD( L, I )
AAD( L, I ) = REPL
130 CONTINUE
END IF
L = L + 1
GO TO 100
END IF
140 CONTINUE
c ** Balance the submatrix in rows L through K
DO 150 I = L, K
WKD( I ) = ONE
150 CONTINUE
160 CONTINUE
NOCONV = .FALSE.
DO 220 I = L, K
COL = ZERO
ROW = ZERO
DO 170 J = L, K
IF( J.NE.I ) THEN
COL = COL + ABS( AAD( J,I ) )
ROW = ROW + ABS( AAD( I,J ) )
END IF
170 CONTINUE
F = ONE
G = ROW / C5
H = COL + ROW
180 CONTINUE
IF( COL.LT.G ) THEN
F = F*C5
COL = COL*C6
GO TO 180
END IF
G = ROW*C5
190 CONTINUE
IF( COL.GE.G ) THEN
F = F / C5
COL = COL / C6
GO TO 190
END IF
c ** Now balance
IF( ( COL + ROW ) / F.LT.C4*H ) THEN
WKD( I ) = WKD( I )*F
NOCONV = .TRUE.
DO 200 J = L, M
AAD( I, J ) = AAD( I, J ) / F
200 CONTINUE
DO 210 J = 1, K
AAD( J, I ) = AAD( J, I )*F
210 CONTINUE
END IF
220 CONTINUE
IF( NOCONV ) GO TO 160
c ** Is A already in Hessenberg form?
IF( K-1 .LT. L+1 ) GO TO 370
c ** Transfer A to a Hessenberg form
DO 310 N = L + 1, K - 1
H = ZERO
WKD( N + M ) = ZERO
SCALE = ZERO
c ** Scale column
DO 230 I = N, K
SCALE = SCALE + ABS( AAD( I,N - 1 ) )
230 CONTINUE
IF( SCALE.NE.ZERO ) THEN
DO 240 I = K, N, -1
WKD( I + M ) = AAD( I, N - 1 ) / SCALE
H = H + WKD( I + M )**2
240 CONTINUE
G = - SIGN( SQRT( H ), WKD( N + M ) )
H = H - WKD( N + M )*G
WKD( N + M ) = WKD( N + M ) - G
c ** Form (I-(U*UT)/H)*A
DO 270 J = N, M
F = ZERO
DO 250 I = K, N, -1
F = F + WKD( I + M )*AAD( I, J )
250 CONTINUE
DO 260 I = N, K
AAD( I, J ) = AAD( I, J ) - WKD( I + M )*F / H
260 CONTINUE
270 CONTINUE
c ** Form (I-(U*UT)/H)*A*(I-(U*UT)/H)
DO 300 I = 1, K
F = ZERO
DO 280 J = K, N, -1
F = F + WKD( J + M )*AAD( I, J )
280 CONTINUE
DO 290 J = N, K
AAD( I, J ) = AAD( I, J ) - WKD( J + M )*F / H
290 CONTINUE
300 CONTINUE
WKD( N + M ) = SCALE*WKD( N + M )
AAD( N, N - 1 ) = SCALE*G
END IF
310 CONTINUE
DO 360 N = K - 2, L, -1
N1 = N + 1
N2 = N + 2
F = AAD( N + 1, N )
IF( F.NE.ZERO ) THEN
F = F*WKD( N + 1 + M )
DO 320 I = N + 2, K
WKD( I + M ) = AAD( I, N )
320 CONTINUE
IF( N + 1.LE.K ) THEN
DO 350 J = 1, M
G = ZERO
DO 330 I = N + 1, K
G = G + WKD( I + M )*EVECD( I, J )
330 CONTINUE
G = G / F
DO 340 I = N + 1, K
EVECD( I, J ) = EVECD( I, J ) + G*WKD( I + M )
340 CONTINUE
350 CONTINUE
END IF
END IF
360 CONTINUE
370 CONTINUE
N = 1
DO 390 I = 1, M
DO 380 J = N, M
RNORM = RNORM + ABS( AAD( I,J ) )
380 CONTINUE
N = I
IF( I.LT.L .OR. I.GT.K ) EVALD( I ) = AAD( I, I )
390 CONTINUE
N = K
T = ZERO
c ** Search for next eigenvalues
400 CONTINUE
IF( N.LT.L ) GO TO 550
IN = 0
N1 = N - 1
N2 = N - 2
c ** Look for single small sub-diagonal element
410 CONTINUE
DO 420 I = L, N
LB = N + L - I
IF( LB.EQ.L ) GO TO 430
S = ABS( AAD( LB - 1,LB - 1 ) ) + ABS( AAD( LB,LB ) )
IF( S.EQ.ZERO ) S = RNORM
IF( ABS( AAD( LB, LB-1 ) ).LE. TOL*S ) GO TO 430
420 CONTINUE
430 CONTINUE
X = AAD( N, N )
IF( LB.EQ.N ) THEN
c ** One eigenvalue found
AAD( N, N ) = X + T
EVALD( N ) = AAD( N, N )
N = N1
GO TO 400
END IF
C next line has been included to avoid run time error caused by xlf
IF ( ( N1.LE.0 ).OR.( N.LE.0 ) ) THEN
WRITE(0,*) 'Subscript out of bounds in ASYMTX'
STOP 9999
ENDIF
Y = AAD( N1, N1 )
W = AAD( N, N1 )*AAD( N1, N )
IF( LB.EQ.N1 ) THEN
c ** Two eigenvalues found
P = ( Y - X )*C2
Q = P**2 + W
Z = SQRT( ABS( Q ) )
AAD( N, N ) = X + T
X = AAD( N, N )
AAD( N1, N1 ) = Y + T
c ** Real pair
Z = P + SIGN( Z, P )
EVALD( N1 ) = X + Z
EVALD( N ) = EVALD( N1 )
IF( Z.NE.ZERO ) EVALD( N ) = X - W / Z
X = AAD( N, N1 )
c ** Employ scale factor in case
c X and Z are very small
R = SQRT( X*X + Z*Z )
P = X / R
Q = Z / R
c ** Row modification
DO 440 J = N1, M
Z = AAD( N1, J )
AAD( N1, J ) = Q*Z + P*AAD( N, J )
AAD( N, J ) = Q*AAD( N, J ) - P*Z
440 CONTINUE
c ** Column modification
DO 450 I = 1, N
Z = AAD( I, N1 )
AAD( I, N1 ) = Q*Z + P*AAD( I, N )
AAD( I, N ) = Q*AAD( I, N ) - P*Z
450 CONTINUE
c ** Accumulate transformations
DO 460 I = L, K
Z = EVECD( I, N1 )
EVECD( I, N1 ) = Q*Z + P*EVECD( I, N )
EVECD( I, N ) = Q*EVECD( I, N ) - P*Z
460 CONTINUE
N = N2
GO TO 400
END IF
IF( IN.EQ.30 ) THEN
c ** No convergence after 30 iterations; set error
c indicator to the index of the current eigenvalue
IER = N
GO TO 700
END IF
c ** Form shift
IF( IN.EQ.10 .OR. IN.EQ.20 ) THEN
T = T + X
DO 470 I = L, N
AAD( I, I ) = AAD( I, I ) - X
470 CONTINUE
S = ABS( AAD( N,N1 ) ) + ABS( AAD( N1,N2 ) )
X = C3*S
Y = X
W = -C1*S**2
END IF
IN = IN + 1
c ** Look for two consecutive small sub-diagonal elements
C inhibit vectorization by CF77, as this will cause a run time error
CDIR$ NEXTSCALAR
DO 480 J = LB, N2
I = N2 + LB - J
Z = AAD( I, I )
R = X - Z
S = Y - Z
P = ( R*S - W ) / AAD( I + 1, I ) + AAD( I, I + 1 )
Q = AAD( I + 1, I + 1 ) - Z - R - S
R = AAD( I + 2, I + 1 )
S = ABS( P ) + ABS( Q ) + ABS( R )
P = P / S
Q = Q / S
R = R / S
IF( I.EQ.LB ) GO TO 490
UU = ABS( AAD( I, I-1 ) )*( ABS( Q ) + ABS( R ) )
VV = ABS( P ) * ( ABS( AAD( I-1, I-1 ) ) + ABS( Z ) +
& ABS( AAD( I+1, I+1 ) ) )
IF( UU .LE. TOL*VV ) GO TO 490
480 CONTINUE
490 CONTINUE
AAD( I+2, I ) = ZERO
c ** fpp vectorization of this loop triggers
c array bounds errors, so inhibit
CFPP$ NOVECTOR L
DO 500 J = I + 3, N
AAD( J, J - 2 ) = ZERO
AAD( J, J - 3 ) = ZERO
500 CONTINUE
c ** Double QR step involving rows K to N and columns M to N
DO 540 KA = I, N1
NOTLAS = KA.NE.N1
IF( KA.EQ.I ) THEN
S = SIGN( SQRT( P*P + Q*Q + R*R ), P )
IF( LB.NE.I ) AAD( KA, KA - 1 ) = -AAD( KA, KA - 1 )
ELSE
P = AAD( KA, KA - 1 )
Q = AAD( KA + 1, KA - 1 )
R = ZERO
IF( NOTLAS ) R = AAD( KA + 2, KA - 1 )
X = ABS( P ) + ABS( Q ) + ABS( R )
IF( X.EQ.ZERO ) GO TO 540
P = P / X
Q = Q / X
R = R / X
S = SIGN( SQRT( P*P + Q*Q + R*R ), P )
AAD( KA, KA - 1 ) = -S*X
END IF
P = P + S
X = P / S
Y = Q / S
Z = R / S
Q = Q / P
R = R / P
c ** Row modification
DO 510 J = KA, M
P = AAD( KA, J ) + Q*AAD( KA + 1, J )
IF( NOTLAS ) THEN
P = P + R*AAD( KA + 2, J )
AAD( KA + 2, J ) = AAD( KA + 2, J ) - P*Z
END IF
AAD( KA + 1, J ) = AAD( KA + 1, J ) - P*Y
AAD( KA, J ) = AAD( KA, J ) - P*X
510 CONTINUE
c ** Column modification
DO 520 II = 1, MIN( N, KA + 3 )
P = X*AAD( II, KA ) + Y*AAD( II, KA + 1 )
IF( NOTLAS ) THEN
P = P + Z*AAD( II, KA + 2 )
AAD( II, KA + 2 ) = AAD( II, KA + 2 ) - P*R
END IF
AAD( II, KA + 1 ) = AAD( II, KA + 1 ) - P*Q
AAD( II, KA ) = AAD( II, KA ) - P
520 CONTINUE
c ** Accumulate transformations
DO 530 II = L, K
P = X*EVECD( II, KA ) + Y*EVECD( II, KA + 1 )
IF( NOTLAS ) THEN
P = P + Z*EVECD( II, KA + 2 )
EVECD( II, KA + 2 ) = EVECD( II, KA + 2 ) - P*R
END IF
EVECD( II, KA + 1 ) = EVECD( II, KA + 1 ) - P*Q
EVECD( II, KA ) = EVECD( II, KA ) - P
530 CONTINUE
540 CONTINUE
GO TO 410
c ** All evals found, now backsubstitute real vector
550 CONTINUE
IF( RNORM.NE.ZERO ) THEN
DO 580 N = M, 1, -1
N2 = N
AAD( N, N ) = ONE
DO 570 I = N - 1, 1, -1
W = AAD( I, I ) - EVALD( N )
IF( W.EQ.ZERO ) W = TOL*RNORM
R = AAD( I, N )
DO 560 J = N2, N - 1
R = R + AAD( I, J )*AAD( J, N )
560 CONTINUE
AAD( I, N ) = -R / W
N2 = I
570 CONTINUE
580 CONTINUE
c ** End backsubstitution vectors of isolated evals
DO 600 I = 1, M
IF( I.LT.L .OR. I.GT.K ) THEN
DO 590 J = I, M
EVECD( I, J ) = AAD( I, J )
590 CONTINUE
END IF
600 CONTINUE
c ** Multiply by transformation matrix
IF( K.NE.0 ) THEN
DO 630 J = M, L, -1
DO 620 I = L, K
Z = ZERO
DO 610 N = L, MIN( J, K )
Z = Z + EVECD( I, N )*AAD( N, J )
610 CONTINUE
EVECD( I, J ) = Z
620 CONTINUE
630 CONTINUE
END IF
END IF
DO 650 I = L, K
DO 640 J = 1, M
EVECD( I, J ) = EVECD( I, J )*WKD( I )
640 CONTINUE
650 CONTINUE
c ** Interchange rows if permutations occurred
DO 670 I = L-1, 1, -1
J = WKD( I )
IF( I.NE.J ) THEN
DO 660 N = 1, M
REPL = EVECD( I, N )
EVECD( I, N ) = EVECD( J, N )
EVECD( J, N ) = REPL
660 CONTINUE
END IF
670 CONTINUE
DO 690 I = K + 1, M
J = WKD( I )
IF( I.NE.J ) THEN
DO 680 N = 1, M
REPL = EVECD( I, N )
EVECD( I, N ) = EVECD( J, N )
EVECD( J, N ) = REPL
680 CONTINUE
END IF
690 CONTINUE
c ** Put results into output arrays
700 CONTINUE
DO 720 J = 1, M
EVAL( J ) = EVALD( J )
DO 710 K = 1, M
EVEC( J, K ) = EVECD( J, K )
710 CONTINUE
720 CONTINUE
END
SUBROUTINE CHEKIN( NLYR, DTAUC, SSALB, PMOM, TEMPER, WVNMLO,
& WVNMHI, USRTAU, NTAU, UTAU, NSTR, USRANG, NUMU,
& UMU, NPHI, PHI, IBCND, FBEAM, UMU0, PHI0,
& FISOT, LAMBER, ALBEDO, HL, BTEMP, TTEMP, TEMIS,
& PLANK, ONLYFL, ACCUR, TAUC, MAXCLY, MAXULV,
& MAXUMU, MAXCMU, MAXPHI, MXCLY, MXULV, MXUMU,
& MXCMU, MXPHI )
c Checks the input dimensions and variables
c Calls- WRTBAD, WRTDIM, DREF, ERRMSG
c Called by- DISORT
c --------------------------------------------------------------------
c .. Scalar Arguments ..
LOGICAL LAMBER, ONLYFL, PLANK, USRANG, USRTAU
INTEGER IBCND, MAXCLY, MAXCMU, MAXPHI, MAXULV, MAXUMU, MXCLY,
& MXCMU, MXPHI, MXULV, MXUMU, NLYR, NPHI, NSTR, NTAU, NUMU
REAL ACCUR, ALBEDO, BTEMP, FBEAM, FISOT, PHI0, TEMIS, TTEMP,
& UMU0, WVNMHI, WVNMLO
c ..
c .. Array Arguments ..
REAL DTAUC( MAXCLY ), HL( 0:MAXCMU ), PHI( MAXPHI ),
& PMOM( 0:MAXCMU, MAXCLY ), SSALB( MAXCLY ),
& TAUC( 0:MXCLY ), TEMPER( 0:MAXCLY ), UMU( MAXUMU ),
& UTAU( MAXULV )
c ..
c .. Local Scalars ..
LOGICAL INPERR
INTEGER IRMU, IU, J, K, LC, LU
REAL FLXALB, RMU
c ..
c .. External Functions ..
LOGICAL WRTBAD, WRTDIM
REAL DREF
EXTERNAL WRTBAD, WRTDIM, DREF
c ..
c .. External Subroutines ..
EXTERNAL ERRMSG
c ..
c .. Intrinsic Functions ..
INTRINSIC ABS, MOD
c ..
INPERR = .FALSE.
IF( NLYR.LT.1 ) INPERR = WRTBAD( 'NLYR' )
IF( NLYR.GT.MAXCLY ) INPERR = WRTBAD( 'MAXCLY' )
DO 20 LC = 1, NLYR
IF( DTAUC( LC ).LT.0.0 ) INPERR = WRTBAD( 'DTAUC' )
IF( SSALB( LC ).LT.0.0 .OR. SSALB( LC ).GT.1.0 )
& INPERR = WRTBAD( 'SSALB' )
IF( PLANK .AND. IBCND.NE.1 ) THEN
IF( LC.EQ.1 .AND. TEMPER( 0 ).LT.0.0 )
& INPERR = WRTBAD( 'TEMPER' )
IF( TEMPER( LC ).LT.0.0 ) INPERR = WRTBAD( 'TEMPER' )
END IF
DO 10 K = 0, NSTR
IF( PMOM( K,LC ).LT.-1.0 .OR. PMOM( K,LC ).GT.1.0 )
& INPERR = WRTBAD( 'PMOM' )
10 CONTINUE
20 CONTINUE
IF( IBCND.EQ.1 ) THEN
IF( MAXULV.LT.2 ) INPERR = WRTBAD( 'MAXULV' )
ELSE IF( USRTAU ) THEN
IF( NTAU.LT.1 ) INPERR = WRTBAD( 'NTAU' )
IF( MAXULV.LT.NTAU ) INPERR = WRTBAD( 'MAXULV' )
DO 30 LU = 1, NTAU
IF( ABS( UTAU( LU ) - TAUC( NLYR ) ).LE. 1.E-4 )
& UTAU( LU ) = TAUC( NLYR )
IF( UTAU( LU ).LT.0.0 .OR. UTAU( LU ).GT. TAUC( NLYR ) )
& INPERR = WRTBAD( 'UTAU' )
30 CONTINUE
ELSE
IF( MAXULV.LT.NLYR + 1 ) INPERR = WRTBAD( 'MAXULV' )
END IF
IF( NSTR.LT.2 .OR. MOD( NSTR,2 ).NE.0 ) INPERR = WRTBAD( 'NSTR' )
c IF( NSTR.EQ.2 )
c & CALL ERRMSG( 'CHEKIN--2 streams not recommended;'//
c & ' use specialized 2-stream code instead',.False.)
IF( NSTR.GT.MAXCMU ) INPERR = WRTBAD( 'MAXCMU' )
IF( USRANG ) THEN
IF( NUMU.LT.0 ) INPERR = WRTBAD( 'NUMU' )
IF( .NOT.ONLYFL .AND. NUMU.EQ.0 ) INPERR = WRTBAD( 'NUMU' )
IF( NUMU.GT.MAXUMU ) INPERR = WRTBAD( 'MAXUMU' )
IF( IBCND.EQ.1 .AND. 2*NUMU.GT.MAXUMU )
& INPERR = WRTBAD( 'MAXUMU' )
DO 40 IU = 1, NUMU
IF( UMU( IU ).LT.-1.0 .OR. UMU( IU ).GT.1.0 .OR.
& UMU( IU ).EQ.0.0 ) INPERR = WRTBAD( 'UMU' )
IF( IBCND.EQ.1 .AND. UMU( IU ).LT.0.0 )
& INPERR = WRTBAD( 'UMU' )
IF( IU.GT.1 ) THEN
IF( UMU( IU ).LT.UMU( IU-1 ) ) INPERR = WRTBAD( 'UMU' )
END IF
40 CONTINUE
ELSE
IF( MAXUMU.LT.NSTR ) INPERR = WRTBAD( 'MAXUMU' )
END IF
IF( .NOT.ONLYFL .AND. IBCND.NE.1 ) THEN
IF( NPHI.LE.0 ) INPERR = WRTBAD( 'NPHI' )
IF( NPHI.GT.MAXPHI ) INPERR = WRTBAD( 'MAXPHI' )
DO 50 J = 1, NPHI
IF( PHI( J ).LT.0.0 .OR. PHI( J ).GT.360.0 )
& INPERR = WRTBAD( 'PHI' )
50 CONTINUE
END IF
IF( IBCND.LT.0 .OR. IBCND.GT.1 ) INPERR = WRTBAD( 'IBCND' )
IF( IBCND.EQ.0 ) THEN
IF( FBEAM.LT.0.0 ) INPERR = WRTBAD( 'FBEAM' )
IF( FBEAM.GT.0.0 .AND. abs(UMU0).GT.1.0 )
& INPERR = WRTBAD( 'UMU0' )
IF( FBEAM.GT.0.0 .AND. ( PHI0.LT.0.0 .OR.PHI0.GT.360.0 ) )
& INPERR = WRTBAD( 'PHI0' )
IF( FISOT.LT.0.0 ) INPERR = WRTBAD( 'FISOT' )
IF( LAMBER ) THEN
IF( ALBEDO.LT.0.0 .OR. ALBEDO.GT.1.0 )
& INPERR = WRTBAD( 'ALBEDO' )
ELSE
c ** Make sure flux albedo at dense mesh of incident
c angles does not assume unphysical values
DO 60 IRMU = 0, 100
RMU = IRMU*0.01
FLXALB = DREF( RMU, HL, NSTR )
IF( FLXALB.LT.0.0 .OR. FLXALB.GT.1.0 )
& INPERR = WRTBAD( 'HL' )
60 CONTINUE
END IF
ELSE IF( IBCND.EQ.1 ) THEN
IF( ALBEDO.LT.0.0 .OR. ALBEDO.GT.1.0 )
& INPERR = WRTBAD( 'ALBEDO' )
END IF
IF( PLANK .AND. IBCND.NE.1 ) THEN
IF( WVNMLO.LT.0.0 .OR. WVNMHI.LE.WVNMLO )
& INPERR = WRTBAD( 'WVNMLO,HI' )
IF( TEMIS.LT.0.0 .OR. TEMIS.GT.1.0 ) INPERR = WRTBAD( 'TEMIS' )
IF( BTEMP.LT.0.0 ) INPERR = WRTBAD( 'BTEMP' )
IF( TTEMP.LT.0.0 ) INPERR = WRTBAD( 'TTEMP' )
END IF
IF( ACCUR.LT.0.0 .OR. ACCUR.GT.1.E-2 ) INPERR = WRTBAD( 'ACCUR' )
IF( MXCLY.LT.NLYR ) INPERR = WRTDIM( 'MXCLY', NLYR )
IF( IBCND.NE.1 ) THEN
IF( USRTAU .AND. MXULV.LT.NTAU )
& INPERR = WRTDIM( 'MXULV',NTAU )
IF( .NOT.USRTAU .AND. MXULV .LT. NLYR + 1 )
& INPERR = WRTDIM( 'MXULV', NLYR + 1 )
ELSE
IF( MXULV.LT.2 ) INPERR = WRTDIM( 'MXULV', 2 )
END IF
IF( MXCMU.LT.NSTR ) INPERR = WRTDIM( 'MXCMU', NSTR )
IF( USRANG .AND. MXUMU.LT.NUMU ) INPERR = WRTDIM( 'MXUMU', NUMU )
IF( USRANG .AND. IBCND.EQ.1 .AND.MXUMU.LT.2*NUMU )
& INPERR = WRTDIM( 'MXUMU', NUMU )
IF( .NOT.USRANG .AND. MXUMU.LT.NSTR )
& INPERR = WRTDIM( 'MXUMU', NSTR )
IF( .NOT.ONLYFL .AND. IBCND.NE.1 .AND. MXPHI.LT.NPHI )
& INPERR = WRTDIM( 'MXPHI', NPHI )
IF( INPERR )
& CALL ERRMSG( 'DISORT--input and/or dimension errors',.True.)
IF( PLANK ) THEN
DO 70 LC = 1, NLYR
IF( ABS( TEMPER( LC ) - TEMPER( LC-1 ) ).GT. 20.0 )
& CALL ERRMSG('CHEKIN--vertical temperature step may'
& // ' be too large for good accuracy',
& .False.)
70 CONTINUE
END IF
END
SUBROUTINE FLUXES( tausla, tauslau,
& CMU, CWT, FBEAM, GC, KK, LAYRU, LL, LYRCUT,
& MAXULV, MXCMU, MXULV, NCUT, NN, NSTR, NTAU, PI,
& PRNT, SSALB, TAUCPR, UMU0, UTAU, UTAUPR, XR0,
& XR1, ZZ, ZPLK0, ZPLK1, DFDT, FLUP, FLDN, FLDIR,
& RFLDIR, RFLDN, UAVG, U0C,
& uavgso, uavgup, uavgdn,
$ sindir, sinup, sindn)
c Calculates the radiative fluxes, mean intensity, and flux
c derivative with respect to optical depth from the m=0 intensity
c components (the azimuthally-averaged intensity)
c I N P U T V A R I A B L E S:
c CMU : Abscissae for Gauss quadrature over angle cosine
c CWT : Weights for Gauss quadrature over angle cosine
c GC : Eigenvectors at polar quadrature angles, SC(1)
c KK : Eigenvalues of coeff. matrix in Eq. SS(7)
c LAYRU : Layer number of user level UTAU
c LL : Constants of integration in Eq. SC(1), obtained
c by solving scaled version of Eq. SC(5);
c exponential term of Eq. SC(12) not included
c LYRCUT : Logical flag for truncation of comput. layer
c NN : Order of double-Gauss quadrature (NSTR/2)
c NCUT : Number of computational layer where absorption
c optical depth exceeds ABSCUT
c TAUCPR : Cumulative optical depth (delta-M-scaled)
c UTAUPR : Optical depths of user output levels in delta-M
c coordinates; equal to UTAU if no delta-M
c XR0 : Expansion of thermal source function in Eq. SS(14)
c XR1 : Expansion of thermal source function Eqs. SS(16)
c ZZ : Beam source vectors in Eq. SS(19)
c ZPLK0 : Thermal source vectors Z0, by solving Eq. SS(16)
c ZPLK1 : Thermal source vectors Z1, by solving Eq. SS(16)
c (remainder are DISORT input variables)
c O U T P U T V A R I A B L E S:
c U0C : Azimuthally averaged intensities
c ( at polar quadrature angles )
c (RFLDIR, RFLDN, FLUP, DFDT, UAVG are DISORT output variables)
c I N T E R N A L V A R I A B L E S:
c DIRINT : Direct intensity attenuated
c FDNTOT : Total downward flux (direct + diffuse)
c FLDIR : Direct-beam flux (delta-M scaled)
c FLDN : Diffuse down-flux (delta-M scaled)
c FNET : Net flux (total-down - diffuse-up)
c FACT : EXP( - UTAUPR / UMU0 )
c PLSORC : Planck source function (thermal)
c ZINT : Intensity of m = 0 case, in Eq. SC(1)
c Called by- DISORT
c Calls- ZEROIT
c +-------------------------------------------------------------------+
c .. Scalar Arguments ..
LOGICAL LYRCUT
INTEGER MAXULV, MXCMU, MXULV, NCUT, NN, NSTR, NTAU
REAL FBEAM, PI, UMU0
c ..
c .. Array Arguments ..
LOGICAL PRNT( * )
INTEGER LAYRU( MXULV )
REAL CMU( MXCMU ), CWT( MXCMU ), DFDT( MAXULV ),
& FLDIR( MXULV ), FLDN( MXULV ), FLUP( MAXULV ),
& GC( MXCMU, MXCMU, * ), KK( MXCMU, * ), LL( MXCMU, * ),
& RFLDIR( MAXULV ), RFLDN( MAXULV ), SSALB( * ),
& TAUCPR( 0:* ), U0C( MXCMU, MXULV ), UAVG( MAXULV ),
& UTAU( MAXULV ), UTAUPR( MXULV ), XR0( * ), XR1( * ),
& ZPLK0( MXCMU, * ), ZPLK1( MXCMU, * ), ZZ( MXCMU, * ),
& uavgso(*),uavgup(*), uavgdn(*),
& sindir(*),sinup(*), sindn(*)
REAL tausla(0:*), tauslau(0:*)
c ..
c .. Local Scalars ..
INTEGER IQ, JQ, LU, LYU
REAL ANG1, ANG2, DIRINT, FACT, FDNTOT, FNET, PLSORC, ZINT
c ..
c .. External Subroutines ..
EXTERNAL ZEROIT
c ..
c .. Intrinsic Functions ..
INTRINSIC ACOS, EXP
c ..
IF( PRNT( 2 ) ) WRITE( *, 9000 )
c ** Zero DISORT output arrays
CALL ZEROIT( U0C, MXULV*MXCMU )
CALL ZEROIT( FLDIR, MXULV )
CALL ZEROIT( FLDN, MXULV )
call zeroit( uavgso, maxulv )
call zeroit( uavgup, maxulv )
call zeroit( uavgdn, maxulv )
call zeroit( sindir, maxulv )
call zeroit( sinup, maxulv )
call zeroit( sindn, maxulv )
c ** Loop over user levels
DO 80 LU = 1, NTAU
LYU = LAYRU( LU )
IF( LYRCUT .AND. LYU.GT.NCUT ) THEN
c ** No radiation reaches
c ** this level
FDNTOT = 0.0
FNET = 0.0
PLSORC = 0.0
GO TO 70
END IF
IF( FBEAM.GT.0.0 ) THEN
FACT = EXP( - tausla(LU-1) )
DIRINT = FBEAM*FACT
FLDIR( LU ) = UMU0*( FBEAM*FACT )
RFLDIR( LU ) = UMU0*FBEAM * EXP( -tauslau(lu-1) )
sindir( LU ) = SQRT(1.-UMU0*UMU0)*FBEAM *
$ EXP( -tauslau(lu-1) )
ELSE
DIRINT = 0.0
FLDIR( LU ) = 0.0
RFLDIR( LU ) = 0.0
sindir( LU ) = 0.0
END IF
DO 30 IQ = 1, NN
ZINT = 0.0
DO 10 JQ = 1, NN
ZINT = ZINT + GC( IQ, JQ, LYU )*LL( JQ, LYU )*
& EXP( -KK( JQ,LYU )*( UTAUPR( LU ) -
& TAUCPR( LYU ) ) )
10 CONTINUE
DO 20 JQ = NN + 1, NSTR
ZINT = ZINT + GC( IQ, JQ, LYU )*LL( JQ, LYU )*
& EXP( -KK( JQ,LYU )*( UTAUPR( LU ) -
& TAUCPR( LYU - 1 ) ) )
20 CONTINUE
U0C( IQ, LU ) = ZINT
IF( FBEAM.GT.0.0 ) U0C( IQ, LU ) = ZINT + ZZ( IQ, LYU )*FACT
U0C( IQ, LU ) = U0C( IQ, LU ) + ZPLK0( IQ, LYU ) +
& ZPLK1( IQ, LYU )*UTAUPR( LU )
UAVG( LU ) = UAVG( LU ) + CWT( NN + 1 - IQ )*U0C( IQ, LU )
uavgdn(lu) = uavgdn(lu) + cwt(nn+1-iq) * u0c( iq,lu )
sindn(lu) = sindn(lu) + cwt(nn+1-iq) *
& SQRT(1.-CMU(NN+1-IQ)*CMU(NN+1-IQ))*
& U0C( IQ, LU )
FLDN( LU ) = FLDN( LU ) + CWT( NN + 1 - IQ )*
& CMU( NN + 1 - IQ )*U0C( IQ, LU )
30 CONTINUE
DO 60 IQ = NN + 1, NSTR
ZINT = 0.0
DO 40 JQ = 1, NN
ZINT = ZINT + GC( IQ, JQ, LYU )*LL( JQ, LYU )*
& EXP( -KK( JQ,LYU )*( UTAUPR( LU ) -
& TAUCPR( LYU ) ) )
40 CONTINUE
DO 50 JQ = NN + 1, NSTR
ZINT = ZINT + GC( IQ, JQ, LYU )*LL( JQ, LYU )*
& EXP( -KK( JQ,LYU )*( UTAUPR( LU ) -
& TAUCPR( LYU - 1 ) ) )
50 CONTINUE
U0C( IQ, LU ) = ZINT
IF( FBEAM.GT.0.0 ) U0C( IQ, LU ) = ZINT + ZZ( IQ, LYU )*FACT
U0C( IQ, LU ) = U0C( IQ, LU ) + ZPLK0( IQ, LYU ) +
& ZPLK1( IQ, LYU )*UTAUPR( LU )
UAVG( LU ) = UAVG( LU ) + CWT( IQ - NN )*U0C( IQ, LU )
uavgup(lu) = uavgup(lu) + cwt(iq-nn) * u0c( iq,lu )
sinup (lu) = sinup(lu) + cwt(iq-nn) *
& SQRT(1.-CMU(IQ-NN)*CMU(IQ-NN))*
& U0C( IQ, LU )
FLUP( LU ) = FLUP( LU ) + CWT( IQ - NN )*CMU( IQ - NN )*
& U0C( IQ, LU )
60 CONTINUE
FLUP( LU ) = 2.*PI*FLUP( LU )
FLDN( LU ) = 2.*PI*FLDN( LU )
FDNTOT = FLDN( LU ) + FLDIR( LU )
FNET = FDNTOT - FLUP( LU )
RFLDN( LU ) = FDNTOT - RFLDIR( LU )
UAVG( LU ) = ( 2.*PI*UAVG( LU ) + DIRINT ) / ( 4.*PI )
uavgso( lu ) = dirint / (4.*pi)
uavgup( lu ) = (2.0 * pi * uavgup(lu) )/ (4.*pi)
uavgdn( lu) = (2.0 * pi * uavgdn(lu) )/ (4.*pi)
sindn ( lu ) = 2.*PI*sindn ( LU )
sinup ( lu ) = 2.*PI*sinup ( LU )
PLSORC = XR0( LYU ) + XR1( LYU )*UTAUPR( LU )
DFDT( LU ) = ( 1.- SSALB( LYU ) ) * 4.*PI *
& ( UAVG( LU ) - PLSORC )
70 CONTINUE
IF( PRNT( 2 ) ) WRITE( *, FMT = 9010 ) UTAU( LU ), LYU,
& RFLDIR( LU ), RFLDN( LU ), FDNTOT, FLUP( LU ), FNET,
& UAVG( LU ), PLSORC, DFDT( LU )
80 CONTINUE
IF( PRNT( 3 ) ) THEN
WRITE( *, FMT = 9020 )
DO 100 LU = 1, NTAU
WRITE( *, FMT = 9030 ) UTAU( LU )
DO 90 IQ = 1, NN
ANG1 = 180./ PI* ACOS( CMU( 2*NN - IQ + 1 ) )
ANG2 = 180./ PI* ACOS( CMU( IQ ) )
WRITE( *, 9040 ) ANG1, CMU(2*NN-IQ+1), U0C(IQ,LU),
$ ANG2, CMU(IQ), U0C(IQ+NN,LU)
90 CONTINUE
100 CONTINUE
END IF
9000 FORMAT( //, 21X,
$ '<----------------------- FLUXES ----------------------->', /,
$ ' Optical Compu Downward Downward Downward ',
$ ' Upward Mean Planck d(Net Flux)', /,
$ ' Depth Layer Direct Diffuse Total ',
$ 'Diffuse Net Intensity Source / d(Op Dep)', / )
9010 FORMAT( F10.4, I7, 1P, 7E12.3, E14.3 )
9020 FORMAT( / , / , ' ******** AZIMUTHALLY AVERAGED INTENSITIES',
& ' ( at polar quadrature angles ) *******' )
9030 FORMAT( /, ' Optical depth =', F10.4, //,
$ ' Angle (deg) cos(Angle) Intensity',
$ ' Angle (deg) cos(Angle) Intensity' )
9040 FORMAT( 2( 0P,F16.4,F13.5,1P,E14.3 ) )
END
SUBROUTINE LEPOLY( NMU, M, MAXMU, TWONM1, MU, YLM )
c Computes the normalized associated Legendre polynomial,
c defined in terms of the associated Legendre polynomial
c Plm = P-sub-l-super-m as
c Ylm(MU) = sqrt( (l-m)!/(l+m)! ) * Plm(MU)
c for fixed order m and all degrees from l = m to TWONM1.
c When m.GT.0, assumes that Y-sub(m-1)-super(m-1) is available
c from a prior call to the routine.
c REFERENCE: Dave, J.V. and B.H. Armstrong, Computations of
c High-Order Associated Legendre Polynomials,
c J. Quant. Spectrosc. Radiat. Transfer 10,
c 557-562, 1970. (hereafter D/A)
c METHOD: Varying degree recurrence relationship.
c NOTE 1: The D/A formulas are transformed by
c setting M = n-1; L = k-1.
c NOTE 2: Assumes that routine is called first with M = 0,
c then with M = 1, etc. up to M = TWONM1.
c NOTE 3: Loops are written in such a way as to vectorize.
c I N P U T V A R I A B L E S:
c NMU : Number of arguments of YLM
c M : Order of YLM
c MAXMU : First dimension of YLM
c TWONM1 : Max degree of YLM
c MU(i) : Arguments of YLM (i = 1 to NMU)
c If M.GT.0, YLM(M-1,i) for i = 1 to NMU is assumed to exist
c from a prior call.
c O U T P U T V A R I A B L E:
c YLM(l,i) : l = M to TWONM1, normalized associated Legendre
c polynomials evaluated at argument MU(i)
c Called by- DISORT, ALBTRN, SURFAC
c Calls- ERRMSG
c +-------------------------------------------------------------------+
c .. Parameters ..
INTEGER MAXSQT
PARAMETER ( MAXSQT = 1000 )
c ..
c .. Scalar Arguments ..
INTEGER M, MAXMU, NMU, TWONM1
c ..
c .. Array Arguments ..
REAL MU( * ), YLM( 0:MAXMU, * )
c ..
c .. Local Scalars ..
LOGICAL PASS1
INTEGER I, L, NS
REAL TMP1, TMP2
c ..
c .. Local Arrays ..
REAL SQT( MAXSQT )
c ..
c .. External Subroutines ..
EXTERNAL ERRMSG
c ..
c .. Intrinsic Functions ..
INTRINSIC FLOAT, SQRT
c ..
SAVE SQT, PASS1
DATA PASS1 / .TRUE. /
IF( PASS1 ) THEN
PASS1 = .FALSE.
DO 10 NS = 1, MAXSQT
SQT( NS ) = SQRT( FLOAT( NS ) )
10 CONTINUE
END IF
IF( 2*TWONM1.GT.MAXSQT )
& CALL ERRMSG('LEPOLY--need to increase param MAXSQT',.True.)
IF( M.EQ.0 ) THEN
c ** Upward recurrence for ordinary
c Legendre polynomials
DO 20 I = 1, NMU
YLM( 0, I ) = 1.0
YLM( 1, I ) = MU( I )
20 CONTINUE
DO 40 L = 2, TWONM1
DO 30 I = 1, NMU
YLM( L, I ) = ( ( 2*L - 1 )*MU( I )*YLM( L - 1, I ) -
& ( L - 1 )*YLM( L - 2, I ) ) / L
30 CONTINUE
40 CONTINUE
ELSE
DO 50 I = 1, NMU
c ** Y-sub-m-super-m; derived from
c ** D/A Eqs. (11,12)
YLM( M, I ) = - SQT( 2*M - 1 ) / SQT( 2*M )*
& SQRT( 1.- MU(I)**2 )*YLM( M - 1, I )
c ** Y-sub-(m+1)-super-m; derived from
c ** D/A Eqs.(13,14) using Eqs.(11,12)
YLM( M + 1, I ) = SQT( 2*M + 1 )*MU( I )*YLM( M, I )
50 CONTINUE
c ** Upward recurrence; D/A EQ.(10)
DO 70 L = M + 2, TWONM1
TMP1 = SQT( L - M )*SQT( L + M )
TMP2 = SQT( L - M - 1 )*SQT( L + M - 1 )
DO 60 I = 1, NMU
YLM( L, I ) = ( ( 2*L - 1 )*MU( I )*YLM( L-1, I ) -
& TMP2*YLM( L-2, I ) ) / TMP1
60 CONTINUE
70 CONTINUE
END IF
END
SUBROUTINE PRAVIN( UMU, NUMU, MAXUMU, UTAU, NTAU, U0U )
c Print azimuthally averaged intensities at user angles
c Called by- DISORT
c LENFMT Max number of polar angle cosines UMU that can be
c printed on one line, as set in FORMAT statement
c --------------------------------------------------------------------
c .. Scalar Arguments ..
INTEGER MAXUMU, NTAU, NUMU
c ..
c .. Array Arguments ..
REAL U0U( MAXUMU, NTAU ), UMU( NUMU ), UTAU( NTAU )
c ..
c .. Local Scalars ..
INTEGER IU, IUMAX, IUMIN, LENFMT, LU, NP, NPASS
c ..
c .. Intrinsic Functions ..
INTRINSIC MIN
c ..
IF( NUMU.LT.1 ) RETURN
WRITE( *, '(//,A)' )
& ' ******* AZIMUTHALLY AVERAGED INTENSITIES ' //
& '(at user polar angles) ********'
LENFMT = 8
NPASS = 1 + (NUMU-1) / LENFMT
WRITE( *,'(/,A,/,A)') ' Optical Polar Angle Cosines',
& ' Depth'
DO 20 NP = 1, NPASS
IUMIN = 1 + LENFMT * ( NP - 1 )
IUMAX = MIN( LENFMT*NP, NUMU )
WRITE( *,'(/,10X,8F14.5)') ( UMU(IU), IU = IUMIN, IUMAX )
DO 10 LU = 1, NTAU
WRITE( *, '(0P,F10.4,1P,8E14.4)' ) UTAU( LU ),
& ( U0U( IU,LU ), IU = IUMIN, IUMAX )
10 CONTINUE
20 CONTINUE
END
SUBROUTINE PRTINP( NLYR, DTAUC, DTAUCP, SSALB, PMOM, TEMPER,
& WVNMLO, WVNMHI, NTAU, UTAU, NSTR, NUMU, UMU,
& NPHI, PHI, IBCND, FBEAM, UMU0, PHI0, FISOT,
& LAMBER, ALBEDO, HL, BTEMP, TTEMP, TEMIS,
& DELTAM, PLANK, ONLYFL, ACCUR, FLYR, LYRCUT,
& OPRIM, TAUC, TAUCPR, MAXCMU, PRTMOM )
c Print values of input variables
c Called by- DISORT
c --------------------------------------------------------------------
c .. Scalar Arguments ..
LOGICAL DELTAM, LAMBER, LYRCUT, ONLYFL, PLANK, PRTMOM
INTEGER IBCND, MAXCMU, NLYR, NPHI, NSTR, NTAU, NUMU
REAL ACCUR, ALBEDO, BTEMP, FBEAM, FISOT, PHI0, TEMIS, TTEMP,
& UMU0, WVNMHI, WVNMLO
c ..
c .. Array Arguments ..
REAL DTAUC( * ), DTAUCP( * ), FLYR( * ), HL( 0:MAXCMU ),
& OPRIM( * ), PHI( * ), PMOM( 0:MAXCMU, * ), SSALB( * ),
& TAUC( 0:* ), TAUCPR( 0:* ), TEMPER( 0:* ), UMU( * ),
& UTAU( * )
c ..
c .. Local Scalars ..
INTEGER IU, J, K, LC, LU
REAL YESSCT
c ..
WRITE( *, '(/,A,I4,A,I4)' ) ' No. streams =', NSTR,
& ' No. computational layers =', NLYR
IF( IBCND.NE.1 ) WRITE( *, '(I4,A,10F10.4,/,(26X,10F10.4))' )
& NTAU,' User optical depths :', ( UTAU(LU), LU = 1, NTAU )
IF( .NOT.ONLYFL ) WRITE( *, '(I4,A,10F9.5,/,(31X,10F9.5))' )
& NUMU,' User polar angle cosines :',( UMU(IU), IU = 1, NUMU )
IF( .NOT.ONLYFL .AND. IBCND.NE.1 )
& WRITE( *, '(I4,A,10F9.2,/,(28X,10F9.2))' )
& NPHI,' User azimuthal angles :',( PHI(J), J = 1, NPHI )
IF( .NOT.PLANK .OR. IBCND.EQ.1 )
& WRITE( *, '(A)' ) ' No thermal emission'
WRITE( *, '(A,I2)' ) ' Boundary condition flag: IBCND =', IBCND
IF( IBCND.EQ.0 ) THEN
WRITE( *, '(A,1P,E11.3,A,0P,F8.5,A,F7.2,/,A,1P,E11.3)' )
& ' Incident beam with intensity =', FBEAM,
& ' and polar angle cosine = ', UMU0,
& ' and azimuth angle =', PHI0,
& ' plus isotropic incident intensity =', FISOT
IF( LAMBER ) WRITE( *, '(A,0P,F8.4)' )
& ' Bottom albedo (Lambertian) =', ALBEDO
IF( .NOT.LAMBER ) WRITE( *, '(A,/,(10X,10F9.5))' )
& ' Legendre coeffs of bottom bidirectional reflectivity :',
& ( HL( K ), K = 0, NSTR )
IF( PLANK ) WRITE( *, '(A,2F14.4,/,A,F10.2,A,F10.2,A,F8.4)' )
& ' Thermal emission in wavenumber interval :', WVNMLO,
& WVNMHI,
& ' Bottom temperature =', BTEMP,
& ' Top temperature =', TTEMP,
& ' Top emissivity =',TEMIS
ELSE IF( IBCND.EQ.1 ) THEN
WRITE(*,'(A)') ' Isotropic illumination from top and bottom'
WRITE( *, '(A,0P,F8.4)' )
& ' Bottom albedo (Lambertian) =', ALBEDO
END IF
IF( DELTAM ) WRITE( *, '(A)' ) ' Uses delta-M method'
IF( .NOT.DELTAM ) WRITE( *, '(A)' ) ' Does not use delta-M method'
IF( IBCND.EQ.1 ) THEN
WRITE( *, '(A)' ) ' Calculate albedo and transmissivity of'//
& ' medium vs. incident beam angle'
ELSE IF( ONLYFL ) THEN
WRITE( *, '(A)' )
& ' Calculate fluxes and azim-averaged intensities only'
ELSE
WRITE( *, '(A)' ) ' Calculate fluxes and intensities'
END IF
WRITE( *, '(A,1P,E11.2)' )
& ' Relative convergence criterion for azimuth series =',
& ACCUR
IF( LYRCUT ) WRITE( *, '(A)' )
& ' Sets radiation = 0 below absorption optical depth 10'
c ** Print layer variables
IF( PLANK ) WRITE( *, FMT = 9180 )
IF( .NOT.PLANK ) WRITE( *, FMT = 9190 )
YESSCT = 0.0
DO 10 LC = 1, NLYR
YESSCT = YESSCT + SSALB( LC )
IF( PLANK )
& WRITE(*,'(I4,2F10.4,F10.5,F12.5,2F10.4,F10.5,F9.4,F14.3)')
& LC, DTAUC( LC ), TAUC( LC ), SSALB( LC ), FLYR( LC ),
& DTAUCP( LC ), TAUCPR( LC ), OPRIM( LC ), PMOM(1,LC),
& TEMPER( LC-1 )
IF( .NOT.PLANK )
& WRITE(*,'(I4,2F10.4,F10.5,F12.5,2F10.4,F10.5,F9.4)')
& LC, DTAUC( LC ), TAUC( LC ), SSALB( LC ), FLYR( LC ),
& DTAUCP( LC ), TAUCPR( LC ), OPRIM( LC ), PMOM( 1,LC )
10 CONTINUE
IF( PLANK ) WRITE( *, '(85X,F14.3)' ) TEMPER( NLYR )
IF( PRTMOM .AND. YESSCT.GT.0.0 ) THEN
WRITE( *, '(/,A)' ) ' Layer Phase Function Moments'
DO 20 LC = 1, NLYR
IF( SSALB( LC ).GT.0.0 )
& WRITE( *, '(I6,10F11.6,/,(6X,10F11.6))' )
& LC, ( PMOM( K, LC ), K = 0, NSTR )
20 CONTINUE
END IF
c ** (Read every other line in these formats)
9180 FORMAT( /, 37X, '<------------- Delta-M --------------->', /,
&' Total Single ',
& 'Total Single', /,
&' Optical Optical Scatter Truncated ',
& 'Optical Optical Scatter Asymm', /,
&' Depth Depth Albedo Fraction ',
& 'Depth Depth Albedo Factor Temperature' )
9190 FORMAT( /, 37X, '<------------- Delta-M --------------->', /,
&' Total Single ',
& 'Total Single', /,
&' Optical Optical Scatter Truncated ',
& 'Optical Optical Scatter Asymm', /,
&' Depth Depth Albedo Fraction ',
& 'Depth Depth Albedo Factor' )
END
SUBROUTINE PRTINT( UU, UTAU, NTAU, UMU, NUMU, PHI, NPHI, MAXULV,
& MAXUMU )
c Prints the intensity at user polar and azimuthal angles
c All arguments are DISORT input or output variables
c Called by- DISORT
c LENFMT Max number of azimuth angles PHI that can be printed
c on one line, as set in FORMAT statement
c +-------------------------------------------------------------------+
c .. Scalar Arguments ..
INTEGER MAXULV, MAXUMU, NPHI, NTAU, NUMU
c ..
c .. Array Arguments ..
REAL PHI( * ), UMU( * ), UTAU( * ), UU( MAXUMU, MAXULV, * )
c ..
c .. Local Scalars ..
INTEGER IU, J, JMAX, JMIN, LENFMT, LU, NP, NPASS
c ..
c .. Intrinsic Functions ..
INTRINSIC MIN
c ..
IF( NPHI.LT.1 ) RETURN
WRITE( *, '(//,A)' )
& ' ********* I N T E N S I T I E S *********'
LENFMT = 10
NPASS = 1 + (NPHI-1) / LENFMT
WRITE( *, '(/,A,/,A,/,A)' )
& ' Polar Azimuth angles (degrees)',
& ' Optical Angle',
& ' Depth Cosine'
DO 30 LU = 1, NTAU
DO 20 NP = 1, NPASS
JMIN = 1 + LENFMT * ( NP - 1 )
JMAX = MIN( LENFMT*NP, NPHI )
WRITE( *, '(/,18X,10F11.2)' ) ( PHI(J), J = JMIN, JMAX )
IF( NP.EQ.1 ) WRITE( *, '(F10.4,F8.4,1P,10E11.3)' )
& UTAU(LU), UMU(1), (UU(1, LU, J), J = JMIN, JMAX)
IF( NP.GT.1 ) WRITE( *, '(10X,F8.4,1P,10E11.3)' )
& UMU(1), (UU(1, LU, J), J = JMIN, JMAX)
DO 10 IU = 2, NUMU
WRITE( *, '(10X,F8.4,1P,10E11.3)' )
& UMU( IU ), ( UU( IU, LU, J ), J = JMIN, JMAX )
10 CONTINUE
20 CONTINUE
30 CONTINUE
END
SUBROUTINE QGAUSN( M, GMU, GWT )
c Compute weights and abscissae for ordinary Gaussian quadrature
c on the interval (0,1); that is, such that
c sum(i=1 to M) ( GWT(i) f(GMU(i)) )
c is a good approximation to
c integral(0 to 1) ( f(x) dx )
c INPUT : M order of quadrature rule
c OUTPUT : GMU(I) array of abscissae (I = 1 TO M)
c GWT(I) array of weights (I = 1 TO M)
c REFERENCE: Davis, P.J. and P. Rabinowitz, Methods of Numerical
c Integration, Academic Press, New York, pp. 87, 1975
c METHOD: Compute the abscissae as roots of the Legendre
c polynomial P-sub-M using a cubically convergent
c refinement of Newton's method. Compute the
c weights from EQ. 2.7.3.8 of Davis/Rabinowitz. Note
c that Newton's method can very easily diverge; only a
c very good initial guess can guarantee convergence.
c The initial guess used here has never led to divergence
c even for M up to 1000.
c ACCURACY: relative error no better than TOL or computer
c precision (machine epsilon), whichever is larger
c INTERNAL VARIABLES:
c ITER : number of Newton Method iterations
c MAXIT : maximum allowed iterations of Newton Method
c PM2,PM1,P : 3 successive Legendre polynomials
c PPR : derivative of Legendre polynomial
c P2PRI : 2nd derivative of Legendre polynomial
c TOL : convergence criterion for Legendre poly root iteration
c X,XI : successive iterates in cubically-convergent version
c of Newtons Method (seeking roots of Legendre poly.)
c Called by- SETDIS, SURFAC
c Calls- D1MACH, ERRMSG
c +-------------------------------------------------------------------+
c .. Scalar Arguments ..
INTEGER M
c ..
c .. Array Arguments ..
REAL GMU( M ), GWT( M )
c ..
c .. Local Scalars ..
INTEGER ITER, K, LIM, MAXIT, NN, NP1
REAL CONA, PI, T
REAL(kind(0.0d0)) :: EN, NNP1, ONE, P, P2PRI, PM1, PM2, PPR,
& PROD, TMP, TOL, TWO, X, XI
c ..
c .. External Functions ..
REAL(kind(0.0d0)) :: D1MACH
EXTERNAL D1MACH
c ..
c .. External Subroutines ..
EXTERNAL ERRMSG
c ..
c .. Intrinsic Functions ..
INTRINSIC ABS, ASIN, COS, FLOAT, MOD, TAN
c ..
SAVE PI, TOL
DATA PI / 0.0 / , MAXIT / 1000 / , ONE / 1.D0 / ,
& TWO / 2.D0 /
IF( PI.EQ.0.0 ) THEN
PI = 2.*ASIN( 1.0 )
TOL = 10.*D1MACH( 4 )
END IF
IF( M.LT.1 ) CALL ERRMSG( 'QGAUSN--Bad value of M',.True.)
IF( M.EQ.1 ) THEN
GMU( 1 ) = 0.5
GWT( 1 ) = 1.0
RETURN
END IF
EN = M
NP1 = M + 1
NNP1 = M*NP1
CONA = FLOAT( M - 1 ) / ( 8*M**3 )
LIM = M / 2
DO 30 K = 1, LIM
c ** Initial guess for k-th root
c of Legendre polynomial, from
c Davis/Rabinowitz (2.7.3.3a)
T = ( 4*K - 1 )*PI / ( 4*M + 2 )
X = COS( T + CONA / TAN( T ) )
ITER = 0
c ** Upward recurrence for
c Legendre polynomials
10 CONTINUE
ITER = ITER + 1
PM2 = ONE
PM1 = X
DO 20 NN = 2, M
P = ( ( 2*NN - 1 )*X*PM1 - ( NN - 1 )*PM2 ) / NN
PM2 = PM1
PM1 = P
20 CONTINUE
c ** Newton Method
TMP = ONE / ( ONE - X**2 )
PPR = EN*( PM2 - X*P )*TMP
P2PRI = ( TWO*X*PPR - NNP1*P )*TMP
XI = X - ( P / PPR )*( ONE +
& ( P / PPR )*P2PRI / ( TWO*PPR ) )
c ** Check for convergence
IF( ABS( XI - X ).GT.TOL ) THEN
IF( ITER.GT.MAXIT )
& CALL ERRMSG( 'QGAUSN--max iteration count',.True.)
X = XI
GO TO 10
END IF
c ** Iteration finished--calculate weights,
c abscissae for (-1,1)
GMU( K ) = -X
GWT( K ) = TWO / ( TMP*( EN*PM2 )**2 )
GMU( NP1 - K ) = -GMU( K )
GWT( NP1 - K ) = GWT( K )
30 CONTINUE
c ** Set middle abscissa and weight
c for rules of odd order
IF( MOD( M,2 ).NE.0 ) THEN
GMU( LIM + 1 ) = 0.0
PROD = ONE
DO 40 K = 3, M, 2
PROD = PROD * K / ( K - 1 )
40 CONTINUE
GWT( LIM + 1 ) = TWO / PROD**2
END IF
c ** Convert from (-1,1) to (0,1)
DO 50 K = 1, M
GMU( K ) = 0.5*GMU( K ) + 0.5
GWT( K ) = 0.5*GWT( K )
50 CONTINUE
END
SUBROUTINE SETDIS( dsdh, nid, tausla, tauslau, mu2,
& CMU, CWT, DELTAM, DTAUC, DTAUCP, EXPBEA, FBEAM,
& FLYR, GL, HL, HLPR, IBCND, LAMBER, LAYRU,
& LYRCUT, MAXUMU, MAXCMU, MXCMU, NCUT, NLYR,
& NTAU, NN, NSTR, PLANK, NUMU, ONLYFL, OPRIM,
& PMOM, SSALB, TAUC, TAUCPR, UTAU, UTAUPR, UMU,
& UMU0, USRTAU, USRANG, kout )
c Perform miscellaneous setting-up operations
c INPUT : all are DISORT input variables (see DOC file)
c OUTPUT: NTAU,UTAU if USRTAU = FALSE
c NUMU,UMU if USRANG = FALSE
c CMU,CWT computational polar angles and
c corresponding quadrature weights
c EXPBEA transmission of direct beam
c FLYR truncated fraction in delta-M method
c GL phase function Legendre coefficients multi-
c plied by (2L+1) and single-scatter albedo
c HLPR Legendre moments of surface bidirectional
c reflectivity, times 2K+1
c LAYRU Computational layer in which UTAU falls
c LYRCUT flag as to whether radiation will be zeroed
c below layer NCUT
c NCUT computational layer where absorption
c optical depth first exceeds ABSCUT
c NN NSTR / 2
c OPRIM delta-M-scaled single-scatter albedo
c TAUCPR delta-M-scaled optical depth
c UTAUPR delta-M-scaled version of UTAU
c Called by- DISORT
c Calls- QGAUSN, ERRMSG
c ----------------------------------------------------------------------
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
c .. Scalar Arguments ..
LOGICAL DELTAM, LAMBER, LYRCUT, ONLYFL, PLANK, USRANG, USRTAU
INTEGER IBCND, MAXCMU, MAXUMU, MXCMU, NCUT, NLYR, NN, NSTR,
& NTAU, NUMU
REAL FBEAM, UMU0
c geometry
REAL dsdh(0:kz,kz)
INTEGER nid(0:kz)
REAL tausla(0:kz), tauslau(0:kz), mu2(0:kz)
REAL sum, sumu
c ..
c .. Array Arguments ..
INTEGER LAYRU( * )
REAL CMU( MXCMU ), CWT( MXCMU ), DTAUC( * ), DTAUCP( * ),
& EXPBEA( 0:* ), FLYR( * ), GL( 0:MXCMU, * ),
& HL( 0:MAXCMU ), HLPR( 0:MXCMU ), OPRIM( * ),
& PMOM( 0:MAXCMU, * ), SSALB( * ), TAUC( 0:* ),
& TAUCPR( 0:* ), UMU( MAXUMU ), UTAU( * ), UTAUPR( * )
c ..
c .. Local Scalars ..
INTEGER IQ, IU, K, LC, LU
REAL ABSCUT, ABSTAU, F
REAL R1MACH
EXTERNAL R1MACH
c ..
c .. External Subroutines ..
EXTERNAL ERRMSG, QGAUSN
c ..
c .. Intrinsic Functions ..
INTRINSIC ABS, EXP
c ..
DATA ABSCUT / 10. /
IF( .NOT.USRTAU ) THEN
c ** Set output levels at computational
c layer boundaries
NTAU = NLYR + 1
DO 10 LC = 0, NTAU - 1
UTAU( LC + 1 ) = TAUC( LC )
10 CONTINUE
END IF
c ** Apply delta-M scaling and move description
c of computational layers to local variables
EXPBEA( 0 ) = 1.0
TAUCPR( 0 ) = 0.0
ABSTAU = 0.0
do i = 0, kz
tausla( i ) = 0.0
tauslau( i ) = 0.0
mu2(i) = 1./largest
end do
DO 40 LC = 1, NLYR
PMOM( 0, LC ) = 1.0
IF( ABSTAU.LT.ABSCUT ) NCUT = LC
ABSTAU = ABSTAU + ( 1.- SSALB( LC ) )*DTAUC( LC )
IF( .NOT.DELTAM ) THEN
OPRIM( LC ) = SSALB( LC )
DTAUCP( LC ) = DTAUC( LC )
TAUCPR( LC ) = TAUC( LC )
DO 20 K = 0, NSTR - 1
GL( K, LC ) = ( 2*K + 1 )*OPRIM( LC )*PMOM( K, LC )
20 CONTINUE
F = 0.0
ELSE
c ** Do delta-M transformation
F = PMOM( NSTR, LC )
OPRIM(LC) = SSALB(LC) * ( 1.- F ) / ( 1.- F * SSALB(LC) )
DTAUCP( LC ) = ( 1.- F*SSALB( LC ) )*DTAUC( LC )
TAUCPR( LC ) = TAUCPR( LC-1 ) + DTAUCP( LC )
DO 30 K = 0, NSTR - 1
GL( K, LC ) = ( 2*K + 1 ) * OPRIM( LC ) *
& ( PMOM( K,LC ) - F ) / ( 1.- F )
30 CONTINUE
END IF
FLYR( LC ) = F
EXPBEA( LC ) = 0.0
40 CONTINUE
c
* calculate slant optical depth
*
IF(umu0 .LT. 0.0) THEN
IF(nid(0) .LT. 0) THEN
tausla(0) = largest
tauslau(0) = largest
ELSE
sum = 0.0
sumu = 0.0
DO lc = 1, nid(0)
sum = sum + 2.*dtaucp(lc)*dsdh(0,lc)
sumu = sumu + 2.*dtauc(lc)*dsdh(0,lc)
END DO
tausla(0) = sum
tauslau(0) = sumu
END IF
END IF
expbea( 0 ) = EXP( -tausla( 0 ) )
*
DO 41, lc = 1, nlyr
IF(nid(lc) .LT. 0) THEN
tausla(lc) = largest
tauslau(lc) = largest
ELSE
sum = 0.0
sumu = 0.0
DO lu = 1, MIN(nid(lc),lc)
sum = sum + dtaucp(lu)*dsdh(lc,lu)
sumu = sumu + dtauc(lu)*dsdh(lc,lu)
ENDDO
DO lu = MIN(nid(lc),lc)+1,nid(lc)
sum = sum + 2.*dtaucp(lu)*dsdh(lc,lu)
sumu = sumu + 2.*dtauc(lu)*dsdh(lc,lu)
ENDDO
tausla(lc) = sum
tauslau(lc) = sumu
IF(tausla(lc) .EQ. tausla(lc-1)) THEN
mu2(lc) = largest
ELSE
mu2(lc) = (taucpr(lc)-taucpr(lc-1))
$ /(tausla(lc)-tausla(lc-1))
mu2(lc) = SIGN( AMAX1(ABS(mu2(lc)),1./largest),
$ mu2(lc) )
END IF
END IF
expbea(lc) = EXP( -tausla( lc ) )
41 CONTINUE
c ** If no thermal emission, cut off medium below
c absorption optical depth = ABSCUT ( note that
c delta-M transformation leaves absorption
c optical depth invariant ). Not worth the
c trouble for one-layer problems, though.
LYRCUT = .FALSE.
IF( ABSTAU.GE.ABSCUT .AND. .NOT.PLANK .AND. IBCND.NE.1 .AND.
& NLYR.GT.1 ) LYRCUT = .TRUE.
IF( .NOT.LYRCUT ) NCUT = NLYR
c ** Set arrays defining location of user
c ** output levels within delta-M-scaled
c ** computational mesh
DO 70 LU = 1, NTAU
DO 50 LC = 1, NLYR
IF( UTAU( LU ).GE.TAUC( LC - 1 ) .AND.
& UTAU( LU ).LE.TAUC( LC ) ) GO TO 60
50 CONTINUE
LC = NLYR
60 CONTINUE
UTAUPR( LU ) = UTAU( LU )
IF( DELTAM ) UTAUPR( LU ) = TAUCPR( LC - 1 ) +
& ( 1.- SSALB( LC )*FLYR( LC ) )*
& ( UTAU( LU ) - TAUC( LC-1 ) )
LAYRU( LU ) = LC
70 CONTINUE
c ** Calculate computational polar angle cosines
c and associated quadrature weights for Gaussian
c quadrature on the interval (0,1) (upward)
NN = NSTR / 2
CALL QGAUSN( NN, CMU, CWT )
c ** Downward (neg) angles and weights
DO 80 IQ = 1, NN
CMU( IQ + NN ) = - CMU( IQ )
CWT( IQ + NN ) = CWT( IQ )
80 CONTINUE
c IF( FBEAM.GT.0.0 ) THEN
c ** Compare beam angle to comput. angles
DO 90 IQ = 1, NN
C ** Dither mu2 if it is close to one of the
C quadrature angles.
DO lc = 1, nlyr
IF ( ABS(mu2(lc)) .lt. 1.E5 ) THEN
IF( ABS( 1. - ABS(mu2(lc))/CMU( IQ ) ) .LT. 0.05 )
& mu2(lc) = mu2(lc)*0.999
ENDIF
END DO
90 CONTINUE
c END IF
IF( .NOT.USRANG .OR. ( ONLYFL .AND. MAXUMU.GE.NSTR ) ) THEN
c ** Set output polar angles to
c computational polar angles
NUMU = NSTR
DO 100 IU = 1, NN
UMU( IU ) = - CMU( NN + 1 - IU )
100 CONTINUE
DO 110 IU = NN + 1, NSTR
UMU( IU ) = CMU( IU - NN )
110 CONTINUE
END IF
IF( USRANG .AND. IBCND.EQ.1 ) THEN
c ** Shift positive user angle cosines to
c upper locations and put negatives
c in lower locations
DO 120 IU = 1, NUMU
UMU( IU + NUMU ) = UMU( IU )
120 CONTINUE
DO 130 IU = 1, NUMU
UMU( IU ) = -UMU( 2*NUMU + 1 - IU )
130 CONTINUE
NUMU = 2*NUMU
END IF
IF( .NOT.LYRCUT .AND. .NOT.LAMBER ) THEN
DO 140 K = 0, NSTR
HLPR( K ) = ( 2*K + 1 )*HL( K )
140 CONTINUE
END IF
END
SUBROUTINE SETMTX( BDR, CBAND, CMU, CWT, DELM0, DTAUCP, GC, KK,
& LAMBER, LYRCUT, MI, MI9M2, MXCMU, NCOL, NCUT,
& NNLYRI, NN, NSTR, TAUCPR, WK )
c Calculate coefficient matrix for the set of equations
c obtained from the boundary conditions and the continuity-
c of-intensity-at-layer-interface equations; store in the
c special banded-matrix format required by LINPACK routines
c I N P U T V A R I A B L E S:
c BDR : Surface bidirectional reflectivity
c CMU : Abscissae for Gauss quadrature over angle cosine
c CWT : Weights for Gauss quadrature over angle cosine
c DELM0 : Kronecker delta, delta-sub-m0
c GC : Eigenvectors at polar quadrature angles, SC(1)
c KK : Eigenvalues of coeff. matrix in Eq. SS(7)
c LYRCUT : Logical flag for truncation of comput. layer
c NN : Number of streams in a hemisphere (NSTR/2)
c NCUT : Total number of computational layers considered
c TAUCPR : Cumulative optical depth (delta-M-scaled)
c (remainder are DISORT input variables)
c O U T P U T V A R I A B L E S:
c CBAND : Left-hand side matrix of linear system Eq. SC(5),
c scaled by Eq. SC(12); in banded form required
c by LINPACK solution routines
c NCOL : Counts of columns in CBAND
c I N T E R N A L V A R I A B L E S:
c IROW : Points to row in CBAND
c JCOL : Points to position in layer block
c LDA : Row dimension of CBAND
c NCD : Number of diagonals below or above main diagonal
c NSHIFT : For positioning number of rows in band storage
c WK : Temporary storage for EXP evaluations
c Called by- DISORT, ALBTRN
c Calls- ZEROIT
c +--------------------------------------------------------------------+
c .. Scalar Arguments ..
LOGICAL LAMBER, LYRCUT
INTEGER MI, MI9M2, MXCMU, NCOL, NCUT, NN, NNLYRI, NSTR
REAL DELM0
c ..
c .. Array Arguments ..
REAL BDR( MI, 0:MI ), CBAND( MI9M2, NNLYRI ), CMU( MXCMU ),
& CWT( MXCMU ), DTAUCP( * ), GC( MXCMU, MXCMU, * ),
& KK( MXCMU, * ), TAUCPR( 0:* ), WK( MXCMU )
c ..
c .. Local Scalars ..
INTEGER IQ, IROW, JCOL, JQ, K, LC, LDA, NCD, NNCOL, NSHIFT
REAL EXPA, SUM
c ..
c .. External Subroutines ..
EXTERNAL ZEROIT
c ..
c .. Intrinsic Functions ..
INTRINSIC EXP
c ..
CALL ZEROIT( CBAND, MI9M2*NNLYRI )
NCD = 3*NN - 1
LDA = 3*NCD + 1
NSHIFT = LDA - 2*NSTR + 1
NCOL = 0
c ** Use continuity conditions of Eq. STWJ(17)
c to form coefficient matrix in STWJ(20);
c employ scaling transformation STWJ(22)
DO 60 LC = 1, NCUT
DO 10 IQ = 1, NN
WK( IQ ) = EXP( KK( IQ,LC )*DTAUCP( LC ) )
10 CONTINUE
JCOL = 0
DO 30 IQ = 1, NN
NCOL = NCOL + 1
IROW = NSHIFT - JCOL
DO 20 JQ = 1, NSTR
CBAND( IROW + NSTR, NCOL ) = GC( JQ, IQ, LC )
CBAND( IROW, NCOL ) = - GC( JQ, IQ, LC )*WK( IQ )
IROW = IROW + 1
20 CONTINUE
JCOL = JCOL + 1
30 CONTINUE
DO 50 IQ = NN + 1, NSTR
NCOL = NCOL + 1
IROW = NSHIFT - JCOL
DO 40 JQ = 1, NSTR
CBAND( IROW + NSTR, NCOL ) = GC( JQ, IQ, LC )*
& WK( NSTR + 1 - IQ )
CBAND( IROW, NCOL ) = - GC( JQ, IQ, LC )
IROW = IROW + 1
40 CONTINUE
JCOL = JCOL + 1
50 CONTINUE
60 CONTINUE
c ** Use top boundary condition of STWJ(20a) for
c first layer
JCOL = 0
DO 80 IQ = 1, NN
EXPA = EXP( KK( IQ,1 )*TAUCPR( 1 ) )
IROW = NSHIFT - JCOL + NN
DO 70 JQ = NN, 1, -1
CBAND( IROW, JCOL + 1 ) = GC( JQ, IQ, 1 )*EXPA
IROW = IROW + 1
70 CONTINUE
JCOL = JCOL + 1
80 CONTINUE
DO 100 IQ = NN + 1, NSTR
IROW = NSHIFT - JCOL + NN
DO 90 JQ = NN, 1, -1
CBAND( IROW, JCOL + 1 ) = GC( JQ, IQ, 1 )
IROW = IROW + 1
90 CONTINUE
JCOL = JCOL + 1
100 CONTINUE
c ** Use bottom boundary condition of
c STWJ(20c) for last layer
NNCOL = NCOL - NSTR
JCOL = 0
DO 130 IQ = 1, NN
NNCOL = NNCOL + 1
IROW = NSHIFT - JCOL + NSTR
DO 120 JQ = NN + 1, NSTR
IF( LYRCUT .OR. ( LAMBER .AND. DELM0.EQ.0 ) ) THEN
c ** No azimuthal-dependent intensity if Lam-
c bert surface; no intensity component if
c truncated bottom layer
CBAND( IROW, NNCOL ) = GC( JQ, IQ, NCUT )
ELSE
SUM = 0.0
DO 110 K = 1, NN
SUM = SUM + CWT( K )*CMU( K )*BDR( JQ - NN, K )*
& GC( NN + 1 - K, IQ, NCUT )
110 CONTINUE
CBAND( IROW, NNCOL ) = GC( JQ, IQ, NCUT ) -
& ( 1.+ DELM0 )*SUM
END IF
IROW = IROW + 1
120 CONTINUE
JCOL = JCOL + 1
130 CONTINUE
DO 160 IQ = NN + 1, NSTR
NNCOL = NNCOL + 1
IROW = NSHIFT - JCOL + NSTR
EXPA = WK( NSTR + 1 - IQ )
DO 150 JQ = NN + 1, NSTR
IF( LYRCUT .OR. ( LAMBER .AND. DELM0.EQ.0 ) ) THEN
CBAND( IROW, NNCOL ) = GC( JQ, IQ, NCUT )*EXPA
ELSE
SUM = 0.0
DO 140 K = 1, NN
SUM = SUM + CWT( K )*CMU( K )*BDR( JQ - NN, K )*
& GC( NN + 1 - K, IQ, NCUT )
140 CONTINUE
CBAND( IROW, NNCOL ) = ( GC( JQ,IQ,NCUT ) -
& ( 1.+ DELM0 )*SUM )*EXPA
END IF
IROW = IROW + 1
150 CONTINUE
JCOL = JCOL + 1
160 CONTINUE
END
SUBROUTINE SOLEIG( AMB, APB, ARRAY, CMU, CWT, GL, MI, MAZIM,
& MXCMU, NN, NSTR, YLMC, CC, EVECC, EVAL, KK, GC,
& AAD, EVECCD, EVALD, WKD )
c Solves eigenvalue/vector problem necessary to construct
c homogeneous part of discrete ordinate solution; STWJ(8b)
c ** NOTE ** Eigenvalue problem is degenerate when single
c scattering albedo = 1; present way of doing it
c seems numerically more stable than alternative
c methods that we tried
c I N P U T V A R I A B L E S:
c GL : Delta-M scaled Legendre coefficients of phase function
c (including factors 2l+1 and single-scatter albedo)
c CMU : Computational polar angle cosines
c CWT : Weights for quadrature over polar angle cosine
c MAZIM : Order of azimuthal component
c NN : Half the total number of streams
c YLMC : Normalized associated Legendre polynomial
c at the quadrature angles CMU
c (remainder are DISORT input variables)
c O U T P U T V A R I A B L E S:
c CC : C-sub-ij in Eq. SS(5); needed in SS(15&18)
c EVAL : NN eigenvalues of Eq. SS(12) on return from ASYMTX
c but then square roots taken
c EVECC : NN eigenvectors (G+) - (G-) on return
c from ASYMTX ( column j corresponds to EVAL(j) )
c but then (G+) + (G-) is calculated from SS(10),
c G+ and G- are separated, and G+ is stacked on
c top of G- to form NSTR eigenvectors of SS(7)
c GC : Permanent storage for all NSTR eigenvectors, but
c in an order corresponding to KK
c KK : Permanent storage for all NSTR eigenvalues of SS(7),
c but re-ordered with negative values first ( square
c roots of EVAL taken and negatives added )
c I N T E R N A L V A R I A B L E S:
c AMB,APB : Matrices (alpha-beta), (alpha+beta) in reduced
c eigenvalue problem
c ARRAY : Complete coefficient matrix of reduced eigenvalue
c problem: (alfa+beta)*(alfa-beta)
c GPPLGM : (G+) + (G-) (cf. Eqs. SS(10-11))
c GPMIGM : (G+) - (G-) (cf. Eqs. SS(10-11))
c WKD : Scratch array required by ASYMTX
c Called by- DISORT, ALBTRN
c Calls- ASYMTX, ERRMSG
c +-------------------------------------------------------------------+
c .. Scalar Arguments ..
INTEGER MAZIM, MI, MXCMU, NN, NSTR
c ..
c .. Array Arguments ..
REAL AMB( MI, MI ), APB( MI, MI ), ARRAY( MI, * ),
& CC( MXCMU, MXCMU ), CMU( MXCMU ), CWT( MXCMU ),
& EVAL( MI ), EVECC( MXCMU, MXCMU ), GC( MXCMU, MXCMU ),
& GL( 0:MXCMU ), KK( MXCMU ), YLMC( 0:MXCMU, MXCMU )
REAL(kind(0.0d0)) :: AAD( MI, MI ), EVALD( MI ), EVECCD( MI, MI ),
& WKD( MXCMU )
c ..
c .. Local Scalars ..
INTEGER IER, IQ, JQ, KQ, L
REAL ALPHA, BETA, GPMIGM, GPPLGM, SUM
c ..
c .. External Subroutines ..
EXTERNAL ASYMTX, ERRMSG
c ..
c .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
c ..
c ** Calculate quantities in Eqs. SS(5-6)
DO 40 IQ = 1, NN
DO 20 JQ = 1, NSTR
SUM = 0.0
DO 10 L = MAZIM, NSTR - 1
SUM = SUM + GL( L )*YLMC( L, IQ )*YLMC( L, JQ )
10 CONTINUE
CC( IQ, JQ ) = 0.5*SUM*CWT( JQ )
20 CONTINUE
DO 30 JQ = 1, NN
c ** Fill remainder of array using symmetry
c relations C(-mui,muj) = C(mui,-muj)
c and C(-mui,-muj) = C(mui,muj)
CC( IQ + NN, JQ ) = CC( IQ, JQ + NN )
CC( IQ + NN, JQ + NN ) = CC( IQ, JQ )
c ** Get factors of coeff. matrix
c of reduced eigenvalue problem
ALPHA = CC( IQ, JQ ) / CMU( IQ )
BETA = CC( IQ, JQ + NN ) / CMU( IQ )
AMB( IQ, JQ ) = ALPHA - BETA
APB( IQ, JQ ) = ALPHA + BETA
30 CONTINUE
AMB( IQ, IQ ) = AMB( IQ, IQ ) - 1.0 / CMU( IQ )
APB( IQ, IQ ) = APB( IQ, IQ ) - 1.0 / CMU( IQ )
40 CONTINUE
c ** Finish calculation of coefficient matrix of
c reduced eigenvalue problem: get matrix
c product (alfa+beta)*(alfa-beta); SS(12)
DO 70 IQ = 1, NN
DO 60 JQ = 1, NN
SUM = 0.
DO 50 KQ = 1, NN
SUM = SUM + APB( IQ, KQ )*AMB( KQ, JQ )
50 CONTINUE
ARRAY( IQ, JQ ) = SUM
60 CONTINUE
70 CONTINUE
c ** Find (real) eigenvalues and eigenvectors
CALL ASYMTX( ARRAY, EVECC, EVAL, NN, MI, MXCMU, IER, WKD, AAD,
& EVECCD, EVALD )
IF( IER.GT.0 ) THEN
WRITE( *, FMT = '(//,A,I4,A)' ) ' ASYMTX--eigenvalue no. ',
& IER, ' didnt converge. Lower-numbered eigenvalues wrong.'
CALL ERRMSG( 'ASYMTX--convergence problems',.True.)
END IF
CDIR$ IVDEP
DO 80 IQ = 1, NN
EVAL( IQ ) = SQRT( ABS( EVAL( IQ ) ) )
KK( IQ + NN ) = EVAL( IQ )
c ** Add negative eigenvalue
KK( NN + 1 - IQ ) = -EVAL( IQ )
80 CONTINUE
c ** Find eigenvectors (G+) + (G-) from SS(10)
c and store temporarily in APB array
DO 110 JQ = 1, NN
DO 100 IQ = 1, NN
SUM = 0.
DO 90 KQ = 1, NN
SUM = SUM + AMB( IQ, KQ )*EVECC( KQ, JQ )
90 CONTINUE
APB( IQ, JQ ) = SUM / EVAL( JQ )
100 CONTINUE
110 CONTINUE
DO 130 JQ = 1, NN
CDIR$ IVDEP
DO 120 IQ = 1, NN
GPPLGM = APB( IQ, JQ )
GPMIGM = EVECC( IQ, JQ )
c ** Recover eigenvectors G+,G- from
c their sum and difference; stack them
c to get eigenvectors of full system
c SS(7) (JQ = eigenvector number)
EVECC( IQ, JQ ) = 0.5*( GPPLGM + GPMIGM )
EVECC( IQ + NN, JQ ) = 0.5*( GPPLGM - GPMIGM )
c ** Eigenvectors corresponding to
c negative eigenvalues (corresp. to
c reversing sign of 'k' in SS(10) )
GPPLGM = - GPPLGM
EVECC(IQ, JQ+NN) = 0.5 * ( GPPLGM + GPMIGM )
EVECC(IQ+NN,JQ+NN) = 0.5 * ( GPPLGM - GPMIGM )
GC( IQ+NN, JQ+NN ) = EVECC( IQ, JQ )
GC( NN+1-IQ, JQ+NN ) = EVECC( IQ+NN, JQ )
GC( IQ+NN, NN+1-JQ ) = EVECC( IQ, JQ+NN )
GC( NN+1-IQ, NN+1-JQ ) = EVECC( IQ+NN, JQ+NN )
120 CONTINUE
130 CONTINUE
END
SUBROUTINE SOLVE0( B, BDR, BEM, BPLANK, CBAND, CMU, CWT, EXPBEA,
& FBEAM, FISOT, IPVT, LAMBER, LL, LYRCUT, MAZIM,
& MI, MI9M2, MXCMU, NCOL, NCUT, NN, NSTR, NNLYRI,
& PI, TPLANK, TAUCPR, UMU0, Z, ZZ, ZPLK0, ZPLK1 )
c Construct right-hand side vector B for general boundary
c conditions STWJ(17) and solve system of equations obtained
c from the boundary conditions and the continuity-of-
c intensity-at-layer-interface equations.
c Thermal emission contributes only in azimuthal independence.
c I N P U T V A R I A B L E S:
c BDR : Surface bidirectional reflectivity
c BEM : Surface bidirectional emissivity
c BPLANK : Bottom boundary thermal emission
c CBAND : Left-hand side matrix of linear system Eq. SC(5),
c scaled by Eq. SC(12); in banded form required
c by LINPACK solution routines
c CMU : Abscissae for Gauss quadrature over angle cosine
c CWT : Weights for Gauss quadrature over angle cosine
c EXPBEA : Transmission of incident beam, EXP(-TAUCPR/UMU0)
c LYRCUT : Logical flag for truncation of comput. layer
c MAZIM : Order of azimuthal component
c ncol : Counts of columns in CBAND
c NN : Order of double-Gauss quadrature (NSTR/2)
c NCUT : Total number of computational layers considered
c TPLANK : Top boundary thermal emission
c TAUCPR : Cumulative optical depth (delta-M-scaled)
c ZZ : Beam source vectors in Eq. SS(19)
c ZPLK0 : Thermal source vectors Z0, by solving Eq. SS(16)
c ZPLK1 : Thermal source vectors Z1, by solving Eq. SS(16)
c (remainder are DISORT input variables)
c O U T P U T V A R I A B L E S:
c B : Right-hand side vector of Eq. SC(5) going into
c SGBSL; returns as solution vector of Eq. SC(12),
c constants of integration without exponential term
c
c LL : Permanent storage for B, but re-ordered
c I N T E R N A L V A R I A B L E S:
c IPVT : Integer vector of pivot indices
c IT : Pointer for position in B
c NCD : Number of diagonals below or above main diagonal
c RCOND : Indicator of singularity for CBAND
c Z : Scratch array required by SGBCO
c Called by- DISORT
c Calls- ZEROIT, SGBCO, ERRMSG, SGBSL
c +-------------------------------------------------------------------+
c .. Scalar Arguments ..
LOGICAL LAMBER, LYRCUT
INTEGER MAZIM, MI, MI9M2, MXCMU, NCOL, NCUT, NN, NNLYRI, NSTR
REAL BPLANK, FBEAM, FISOT, PI, TPLANK, UMU0
c ..
c .. Array Arguments ..
INTEGER IPVT( * )
REAL B( NNLYRI ), BDR( MI, 0:MI ), BEM( MI ),
& CBAND( MI9M2, NNLYRI ), CMU( MXCMU ), CWT( MXCMU ),
& EXPBEA( 0:* ), LL( MXCMU, * ), TAUCPR( 0:* ),
& Z( NNLYRI ), ZPLK0( MXCMU, * ), ZPLK1( MXCMU, * ),
& ZZ( MXCMU, * )
c ..
c .. Local Scalars ..
INTEGER IPNT, IQ, IT, JQ, LC, NCD
REAL RCOND, SUM
c ..
c .. External Subroutines ..
EXTERNAL ERRMSG, SGBCO, SGBSL, ZEROIT
c ..
CALL ZEROIT( B, NNLYRI )
c ** Construct B, STWJ(20a,c) for
c parallel beam + bottom reflection +
c thermal emission at top and/or bottom
IF( MAZIM.GT.0 .AND. FBEAM.GT.0.0 ) THEN
c ** Azimuth-dependent case
c (never called if FBEAM = 0)
IF( LYRCUT .OR. LAMBER ) THEN
c ** No azimuthal-dependent intensity for Lambert surface;
c no intensity component for truncated bottom layer
DO 10 IQ = 1, NN
c ** Top boundary
B( IQ ) = - ZZ( NN + 1 - IQ, 1 )*EXPBEA( 0 )
c ** Bottom boundary
B( NCOL - NN + IQ ) = -ZZ( IQ + NN, NCUT )*EXPBEA( NCUT )
10 CONTINUE
ELSE
DO 30 IQ = 1, NN
B( IQ ) = - ZZ( NN + 1 - IQ, 1 )*EXPBEA( 0 )
SUM = 0.
DO 20 JQ = 1, NN
SUM = SUM + CWT( JQ )*CMU( JQ )*BDR( IQ, JQ )*
& ZZ( NN + 1 - JQ, NCUT )*EXPBEA( NCUT )
20 CONTINUE
B( NCOL - NN + IQ ) = SUM
IF( FBEAM.GT.0.0 ) B( NCOL - NN + IQ ) = SUM +
& ( BDR( IQ,0 )*UMU0*FBEAM / PI - ZZ( IQ + NN,NCUT ) )*
& EXPBEA( NCUT )
30 CONTINUE
END IF
c ** Continuity condition for layer
c interfaces of Eq. STWJ(20b)
IT = NN
DO 50 LC = 1, NCUT - 1
DO 40 IQ = 1, NSTR
IT = IT + 1
B( IT ) = ( ZZ( IQ, LC+1 ) - ZZ( IQ, LC ) )*EXPBEA( LC )
40 CONTINUE
50 CONTINUE
ELSE
c ** Azimuth-independent case
IF( FBEAM.EQ.0.0 ) THEN
DO 60 IQ = 1, NN
c ** Top boundary
B( IQ ) = -ZPLK0( NN + 1 - IQ, 1 ) + FISOT + TPLANK
60 CONTINUE
IF( LYRCUT ) THEN
c ** No intensity component for truncated
c bottom layer
DO 70 IQ = 1, NN
c ** Bottom boundary
B( NCOL - NN + IQ ) = - ZPLK0( IQ + NN, NCUT ) -
& ZPLK1( IQ + NN, NCUT )*
& TAUCPR( NCUT )
70 CONTINUE
ELSE
DO 90 IQ = 1, NN
SUM = 0.
DO 80 JQ = 1, NN
SUM = SUM + CWT( JQ )*CMU( JQ )*BDR( IQ, JQ )*
& ( ZPLK0( NN + 1 - JQ,NCUT ) +
& ZPLK1( NN + 1 - JQ,NCUT )*TAUCPR( NCUT ) )
80 CONTINUE
B( NCOL - NN + IQ ) = 2.*SUM + BEM( IQ )*BPLANK -
& ZPLK0( IQ + NN, NCUT ) -
& ZPLK1( IQ + NN, NCUT )*
& TAUCPR( NCUT )
90 CONTINUE
END IF
c ** Continuity condition for layer
c interfaces, STWJ(20b)
IT = NN
DO 110 LC = 1, NCUT - 1
DO 100 IQ = 1, NSTR
IT = IT + 1
B( IT ) = ZPLK0( IQ, LC + 1 ) - ZPLK0( IQ, LC ) +
& ( ZPLK1( IQ, LC + 1 ) - ZPLK1( IQ, LC ) )*
& TAUCPR( LC )
100 CONTINUE
110 CONTINUE
ELSE
DO 120 IQ = 1, NN
B( IQ ) = - ZZ( NN + 1 - IQ, 1 )*EXPBEA( 0 ) -
& ZPLK0( NN + 1 - IQ, 1 ) + FISOT + TPLANK
120 CONTINUE
IF( LYRCUT ) THEN
DO 130 IQ = 1, NN
B(NCOL-NN+IQ) = - ZZ(IQ+NN, NCUT) * EXPBEA(NCUT)
& - ZPLK0(IQ+NN, NCUT)
& - ZPLK1(IQ+NN, NCUT) * TAUCPR(NCUT)
130 CONTINUE
ELSE
DO 150 IQ = 1, NN
SUM = 0.
DO 140 JQ = 1, NN
SUM = SUM + CWT(JQ) * CMU(JQ) * BDR(IQ,JQ)
& * ( ZZ(NN+1-JQ, NCUT) * EXPBEA(NCUT)
& + ZPLK0(NN+1-JQ, NCUT)
& + ZPLK1(NN+1-JQ, NCUT) * TAUCPR(NCUT))
140 CONTINUE
B(NCOL-NN+IQ) = 2.*SUM + ( BDR(IQ,0) * UMU0*FBEAM/PI
& - ZZ(IQ+NN, NCUT) ) * EXPBEA(NCUT)
& + BEM(IQ) * BPLANK
& - ZPLK0(IQ+NN, NCUT)
& - ZPLK1(IQ+NN, NCUT) * TAUCPR(NCUT)
150 CONTINUE
END IF
IT = NN
DO 170 LC = 1, NCUT - 1
DO 160 IQ = 1, NSTR
IT = IT + 1
B(IT) = ( ZZ(IQ,LC+1) - ZZ(IQ,LC) ) * EXPBEA(LC)
& + ZPLK0(IQ,LC+1) - ZPLK0(IQ,LC) +
& ( ZPLK1(IQ,LC+1) - ZPLK1(IQ,LC) ) * TAUCPR(LC)
160 CONTINUE
170 CONTINUE
END IF
END IF
c ** Find L-U (lower/upper triangular) decomposition
c of band matrix CBAND and test if it is nearly
c singular (note: CBAND is destroyed)
c (CBAND is in LINPACK packed format)
RCOND = 0.0
NCD = 3*NN - 1
CALL SGBCO( CBAND, MI9M2, NCOL, NCD, NCD, IPVT, RCOND, Z )
IF( 1.0 + RCOND.EQ.1.0 )
& CALL ERRMSG('SOLVE0--SGBCO says matrix near singular',.FALSE.)
c ** Solve linear system with coeff matrix CBAND
c and R.H. side(s) B after CBAND has been L-U
c decomposed. Solution is returned in B.
CALL SGBSL( CBAND, MI9M2, NCOL, NCD, NCD, IPVT, B, 0 )
c ** Zero CBAND (it may contain 'foreign'
c elements upon returning from LINPACK);
c necessary to prevent errors
CALL ZEROIT( CBAND, MI9M2*NNLYRI )
DO 190 LC = 1, NCUT
IPNT = LC*NSTR - NN
DO 180 IQ = 1, NN
LL( NN + 1 - IQ, LC ) = B( IPNT + 1 - IQ )
LL( IQ + NN, LC ) = B( IQ + IPNT )
180 CONTINUE
190 CONTINUE
RETURN
END
SUBROUTINE SURFAC( ALBEDO, DELM0, FBEAM, HLPR, LAMBER, MI, MAZIM,
& MXCMU, MXUMU, NN, NUMU, NSTR, ONLYFL, UMU,
& USRANG, YLM0, YLMC, YLMU, BDR, EMU, BEM, RMU )
c Specifies user's surface bidirectional properties, STWJ(21)
c I N P U T V A R I A B L E S:
c DELM0 : Kronecker delta, delta-sub-m0
c HLPR : Legendre moments of surface bidirectional reflectivity
c (with 2K+1 factor included)
c MAZIM : Order of azimuthal component
c NN : Order of double-Gauss quadrature (NSTR/2)
c YLM0 : Normalized associated Legendre polynomial
c at the beam angle
c YLMC : Normalized associated Legendre polynomials
c at the quadrature angles
c YLMU : Normalized associated Legendre polynomials
c at the user angles
c (remainder are DISORT input variables)
c O U T P U T V A R I A B L E S:
c BDR : Surface bidirectional reflectivity (computational angles)
c RMU : Surface bidirectional reflectivity (user angles)
c BEM : Surface directional emissivity (computational angles)
c EMU : Surface directional emissivity (user angles)
c I N T E R N A L V A R I A B L E S:
c DREF Directional reflectivity
c NMUG : Number of angle cosine quadrature points on (0,1) for
c integrating bidirectional reflectivity to get
c directional emissivity (it is necessary to use a
c quadrature set distinct from the computational
c angles, because the computational angles may not be
c dense enough--NSTR may be too small--to give an
c accurate approximation for the integration).
c GMU : The NMUG angle cosine quadrature points on (0,1)
c GWT : The NMUG angle cosine quadrature weights on (0,1)
c YLMG : Normalized associated Legendre polynomials
c at the NMUG quadrature angles
c Called by- DISORT
c Calls- QGAUSN, LEPOLY, ZEROIT, ERRMSG
c +-------------------------------------------------------------------+
c .. Parameters ..
INTEGER NMUG, MAXSTR
PARAMETER ( NMUG = 10, MAXSTR = 100 )
c ..
c .. Scalar Arguments ..
LOGICAL LAMBER, ONLYFL, USRANG
INTEGER MAZIM, MI, MXCMU, MXUMU, NN, NSTR, NUMU
REAL ALBEDO, DELM0, FBEAM
c ..
c .. Array Arguments ..
REAL BDR( MI, 0:MI ), BEM( MI ), EMU( MXUMU ),
& HLPR( 0:MXCMU ), RMU( MXUMU, 0:MI ), UMU( * ),
& YLM0( 0:MXCMU ), YLMC( 0:MXCMU, MXCMU ),
& YLMU( 0:MXCMU, MXUMU )
c ..
c .. Local Scalars ..
LOGICAL PASS1
INTEGER IQ, IU, JG, JQ, K
REAL DREF, SGN, SUM
c ..
c .. Local Arrays ..
REAL GMU( NMUG ), GWT( NMUG ), YLMG( 0:MAXSTR, NMUG )
c ..
c .. External Subroutines ..
EXTERNAL ERRMSG, LEPOLY, QGAUSN, ZEROIT
c ..
SAVE PASS1, GMU, GWT, YLMG
DATA PASS1 / .TRUE. /
IF( PASS1 ) THEN
PASS1 = .FALSE.
CALL QGAUSN( NMUG, GMU, GWT )
CALL LEPOLY( NMUG, 0, MAXSTR, MAXSTR, GMU, YLMG )
c ** Convert Legendre polys. to negative GMU
SGN = - 1.0
DO 20 K = 0, MAXSTR
SGN = - SGN
DO 10 JG = 1, NMUG
YLMG( K, JG ) = SGN*YLMG( K, JG )
10 CONTINUE
20 CONTINUE
END IF
CALL ZEROIT( BDR, MI*( MI + 1 ) )
CALL ZEROIT( BEM, MI )
IF( LAMBER .AND. MAZIM.EQ.0 ) THEN
DO 40 IQ = 1, NN
BEM( IQ ) = 1.- ALBEDO
DO 30 JQ = 0, NN
BDR( IQ, JQ ) = ALBEDO
30 CONTINUE
40 CONTINUE
ELSE IF( .NOT.LAMBER ) THEN
c ** Compute surface bidirectional
c properties at computational angles
DO 80 IQ = 1, NN
DO 60 JQ = 1, NN
SUM = 0.0
DO 50 K = MAZIM, NSTR - 1
SUM = SUM + HLPR( K )*YLMC( K, IQ )*
& YLMC( K, JQ + NN )
50 CONTINUE
BDR( IQ, JQ ) = ( 2.- DELM0 )*SUM
60 CONTINUE
IF( FBEAM.GT.0.0 ) THEN
SUM = 0.0
DO 70 K = MAZIM, NSTR - 1
SUM = SUM + HLPR( K )*YLMC( K, IQ )*YLM0( K )
70 CONTINUE
BDR( IQ, 0 ) = ( 2.- DELM0 )*SUM
END IF
80 CONTINUE
IF( MAZIM.EQ.0 ) THEN
IF( NSTR.GT.MAXSTR )
& CALL ERRMSG('SURFAC--parameter MAXSTR too small',.True.)
c ** Integrate bidirectional reflectivity
c at reflection polar angles CMU and
c incident angles GMU to get
c directional emissivity at
c computational angles CMU.
DO 110 IQ = 1, NN
DREF = 0.0
DO 100 JG = 1, NMUG
SUM = 0.0
DO 90 K = 0, NSTR - 1
SUM = SUM + HLPR( K )*YLMC( K, IQ )*
& YLMG( K, JG )
90 CONTINUE
DREF = DREF + 2.*GWT( JG )*GMU( JG )*SUM
100 CONTINUE
BEM( IQ ) = 1.- DREF
110 CONTINUE
END IF
END IF
c ** Compute surface bidirectional
c properties at user angles
IF( .NOT.ONLYFL .AND. USRANG ) THEN
CALL ZEROIT( EMU, MXUMU )
CALL ZEROIT( RMU, MXUMU*( MI + 1 ) )
DO 180 IU = 1, NUMU
IF( UMU( IU ).GT.0.0 ) THEN
IF( LAMBER .AND. MAZIM.EQ.0 ) THEN
DO 120 IQ = 0, NN
RMU( IU, IQ ) = ALBEDO
120 CONTINUE
EMU( IU ) = 1.- ALBEDO
ELSE IF( .NOT.LAMBER ) THEN
DO 140 IQ = 1, NN
SUM = 0.0
DO 130 K = MAZIM, NSTR - 1
SUM = SUM + HLPR( K )*YLMU( K, IU )*
& YLMC( K, IQ + NN )
130 CONTINUE
RMU( IU, IQ ) = ( 2.- DELM0 )*SUM
140 CONTINUE
IF( FBEAM.GT.0.0 ) THEN
SUM = 0.0
DO 150 K = MAZIM, NSTR - 1
SUM = SUM + HLPR( K )*YLMU( K, IU )*YLM0( K )
150 CONTINUE
RMU( IU, 0 ) = ( 2.- DELM0 )*SUM
END IF
IF( MAZIM.EQ.0 ) THEN
c ** Integrate bidirectional reflectivity
c at reflection angles UMU and
c incident angles GMU to get
c directional emissivity at
c user angles UMU.
DREF = 0.0
DO 170 JG = 1, NMUG
SUM = 0.0
DO 160 K = 0, NSTR - 1
SUM = SUM + HLPR( K )*YLMU( K, IU )*
& YLMG( K, JG )
160 CONTINUE
DREF = DREF + 2.*GWT( JG )*GMU( JG )*SUM
170 CONTINUE
EMU( IU ) = 1.- DREF
END IF
END IF
END IF
180 CONTINUE
END IF
END
*bm SOLVEC calls SOLEIG and UPBEAM; if UPBEAM reports a potenially
*bm unstable solution, the calculation is repeated with a slightly
*bm changed single scattering albedo; this process is iterates
*bm until a stable solution is found; as stable solutions may be
*bm reached either by increasing or by decreasing the single
*bm scattering albedo, both directions are explored ('upward' and
*bm 'downward' iteration); the solution which required the smaller
*bm change in the single scattering albedo is finally returned
*bm by SOLVEC.
SUBROUTINE SOLVEC( AMB, APB, ARRAY, CMU, CWT, GL, MI,
& MAZIM, MXCMU, NN, NSTR, YLM0, YLMC, CC,
& EVECC, EVAL, KK, GC, AAD, EVECCD, EVALD,
& WK, WKD, DELM0, FBEAM, IPVT, PI, UMU0, ZJ, ZZ,
& OPRIM, LC, DITHER, mu2, glsave, dgl)
cgy added glsave and dgl to call to allow adjustable dimensioning
c .. Scalar Arguments ..
INTEGER MAZIM, MI, MXCMU, NN, NSTR, LC
REAL DELM0, FBEAM, PI, UMU0, OPRIM, DITHER
REAL mu2
c ..
c .. Array Arguments ..
INTEGER IPVT( * )
REAL AMB( MI, MI ), APB( MI, MI ), ARRAY( MI, * ),
& CC( MXCMU, MXCMU ), CMU( MXCMU ), CWT( MXCMU ),
& EVAL( MI ), EVECC( MXCMU, MXCMU ), GC( MXCMU, MXCMU ),
& GL( 0:MXCMU ), KK( MXCMU ),
& YLM0( 0:MXCMU ), YLMC( 0:MXCMU, MXCMU ),
& WK( MXCMU ), ZJ( MXCMU ), ZZ( MXCMU )
REAL(kind(0.0d0)) :: AAD( MI, MI ), EVALD( MI ), EVECCD( MI, MI ),
& WKD( MXCMU )
*bm Variables for instability fix
INTEGER UAGAIN, DAGAIN
REAL MINRCOND, ADD, UADD, DADD, SSA, DSSA, FACTOR
REAL GLSAVE( 0:MXCMU ), DGL( 0:MXCMU )
LOGICAL DONE, NOUP, NODN, DEBUG, INSTAB
*bm reset parameters
DONE = .FALSE.
NOUP = .FALSE.
NODN = .FALSE.
*bm flag for printing debugging output
* DEBUG = .TRUE.
DEBUG = .FALSE.
*bm instability parameter; the solution is considered
*bm unstable, if the RCOND reported by SGECO is smaller
*bm than MINRCOND
MINRCOND = 5000. * R1MACH(4)
*bm if an instability is detected, the single scattering albedo
*bm is iterated downwards in steps of DADD and upwards in steps
*bm of UADD; in practice, MINRCOND and -MINRCOND should
*bm be reasonable choices for these parameters
DADD = -MINRCOND
UADD = MINRCOND
UAGAIN = 0
DAGAIN = 0
ADD = DADD
*bm save array GL( ) because it will be
*bm changed if an iteration should be neccessary
DO K = MAZIM, NSTR - 1
GLSAVE( K ) = GL( K )
ENDDO
SSA = OPRIM
*bm in case of an instability reported by UPBEAM (INSTAB)
*bm the single scattering albedo will be changed by a small
*bm amount (ADD); this is indicated by DAGAIN or UAGAIN
*bm being larger than 0; a change in the single scattering
*bm albedo is equivalent to scaling the array GL( )
666 IF ( DAGAIN .GT. 0 .OR. UAGAIN .GT. 0) THEN
FACTOR = (SSA + ADD) / SSA
DO K = MAZIM, NSTR - 1
GL( K ) = GL( K ) * FACTOR
ENDDO
SSA = SSA + ADD
*bm if the single scattering albedo is now smaller than 0
*bm the downward iteration is stopped and upward iteration
*bm is forced instead
IF( SSA .LT. DITHER) THEN
NODN = .TRUE.
DAGAIN = -1
goto 778
ENDIF
*bm if the single scattering albedo is now larger than its maximum
*bm allowed value (1.0 - DITHER), the upward iteration is
*bm stopped and downward iteration is forced instead
IF( SSA .GT. 1.0 - DITHER) THEN
NOUP = .TRUE.
UAGAIN = -1
goto 888
ENDIF
ENDIF
c ** Solve eigenfunction problem in Eq. STWJ(8B);
c return eigenvalues and eigenvectors
777 CALL SOLEIG( AMB, APB, ARRAY, CMU, CWT, GL, MI,
& MAZIM, MXCMU, NN, NSTR, YLMC, CC, EVECC, EVAL,
& KK, GC, AAD, EVECCD, EVALD,
& WKD )
c ** Calculate particular solutions of
c q.SS(18) for incident beam source
IF ( FBEAM.GT.0.0 ) THEN
CALL UPBEAM( mu2,
$ ARRAY, CC, CMU, DELM0, FBEAM, GL,
$ IPVT, MAZIM, MXCMU, NN, NSTR, PI, UMU0, WK,
$ YLM0, YLMC, ZJ, ZZ, MINRCOND, INSTAB)
ENDIF
c ** Calculate particular solutions of
c Eq. SS(15) for thermal emission source
c (not available in psndo.f)
*bm finished if the result is stable on the first try
IF ( (.NOT. INSTAB) .AND.
$ (UAGAIN .EQ. 0) .AND. (DAGAIN .EQ. 0)) THEN
goto 999
ENDIF
*bm downward iteration
IF( INSTAB .AND. UAGAIN .EQ. 0 ) THEN
DAGAIN = DAGAIN + 1
GOTO 666
ENDIF
*bm upward iteration
IF( INSTAB .AND. UAGAIN .GT. 0 ) THEN
UAGAIN = UAGAIN + 1
GOTO 666
ENDIF
*bm ( DAGAIN .NE. 0 ) at this place means that the downward
*bm iteration is finished
778 IF (DAGAIN .NE. 0 .AND. UAGAIN .EQ. 0) THEN
*bm save downward iteration data for later use and
*bm restore original input data
DO K = MAZIM, NSTR - 1
DGL( K ) = GL( K )
GL( K ) = GLSAVE( K )
ENDDO
DSSA = SSA
SSA = OPRIM
*bm start upward iteration
ADD = UADD
UAGAIN = UAGAIN + 1
GOTO 666
ENDIF
*bm both iterations finished
888 IF (DONE) THEN
goto 998
ENDIF
*bm if neither upward nor downward iteration converged, the
*bm original conditions are restored and SOLEIG/UPBEAM
*bm is called for the last time
IF (NOUP .AND. NODN) THEN
DO K = MAZIM, NSTR - 1
GL( K ) = GLSAVE( K )
ENDDO
SSA = OPRIM
IF (DEBUG) THEN
write (*,*) '! *** Neither upward nor downward iteration'
write (*,*) '! *** converged; using original result.'
ENDIF
DONE = .TRUE.
GOTO 777
ENDIF
*bm if upward iteration did not converge, the stable downward conditions
*bm are restored and SOLEIG/UPBEAM is called for the last time
IF (NOUP) THEN
DO K = MAZIM, NSTR - 1
GL( K ) = DGL( K )
ENDDO
SSA = DSSA
IF (DEBUG) THEN
write (*,*) '! *** The upward iteration did not converge.'
write (*,*) '! *** Had to iterate ', DAGAIN,
$ ' times in layer LC =', LC,';'
write (*,*) '! *** changed SSA from ',
$ OPRIM, ' to ', SSA,','
write (*,*) '! *** by a factor of ', SSA/OPRIM
ENDIF
DONE = .TRUE.
GOTO 777
ENDIF
*bm if downward iteration did not converge, we are done
*bm (the result of the upward iteration will be used)
IF (NODN) THEN
IF (DEBUG) THEN
write (*,*) '! *** The downward iteration did not converge.'
write (*,*) '! *** Had to iterate ', UAGAIN,
$ ' times in layer LC =', LC,';'
write (*,*) '! *** changed SSA from ',
$ OPRIM, ' to ', SSA,','
write (*,*) '! *** by a factor of ', SSA/OPRIM
ENDIF
DONE = .TRUE.
GOTO 998
ENDIF
*bm if both iterations converged, and if the upward iteration
*bm required more steps than the downward iteration, the stable
*bm downward conditions are restored and SOLEIG/UPBEAM is
*bm called for the last time
IF (UAGAIN .GT. DAGAIN) THEN
DO K = MAZIM, NSTR - 1
GL( K ) = DGL( K )
ENDDO
SSA = DSSA
IF (DEBUG) THEN
write (*,*) '! *** Both iterations converged;',
$ ' using downward.'
write (*,*) '! *** Had to iterate ', DAGAIN,
$ ' times in layer LC =', LC,';'
write (*,*) '! *** changed SSA from ',
$ OPRIM, ' to ', SSA,','
write (*,*) '! *** by a factor of ', SSA/OPRIM
ENDIF
DONE = .TRUE.
GOTO 777
ELSE
IF (DEBUG) THEN
write (*,*) '! *** Both iterations converged;',
$ ' using upward.'
write (*,*) '! *** Had to iterate ', UAGAIN,
$ ' times in layer LC =', LC,';'
write (*,*) '! *** changed SSA from ',
$ OPRIM, ' to ', SSA,','
write (*,*) '! *** by a factor of ', SSA/OPRIM
ENDIF
DONE = .TRUE.
goto 998
ENDIF
*bm finally restore original input data
998 DO K = MAZIM, NSTR - 1
GL( K ) = GLSAVE( K )
ENDDO
999 CONTINUE
END
SUBROUTINE UPBEAM( mu2,
& ARRAY, CC, CMU, DELM0, FBEAM, GL, IPVT, MAZIM,
& MXCMU, NN, NSTR, PI, UMU0, WK, YLM0, YLMC, ZJ,
& ZZ, MINRCOND, INSTAB )
c Finds the incident-beam particular solution of SS(18)
c I N P U T V A R I A B L E S:
c CC : C-sub-ij in Eq. SS(5)
c CMU : Abscissae for Gauss quadrature over angle cosine
c DELM0 : Kronecker delta, delta-sub-m0
c GL : Delta-M scaled Legendre coefficients of phase function
c (including factors 2L+1 and single-scatter albedo)
c MAZIM : Order of azimuthal component
c YLM0 : Normalized associated Legendre polynomial
c at the beam angle
c YLMC : Normalized associated Legendre polynomial
c at the quadrature angles
c (remainder are DISORT input variables)
c O U T P U T V A R I A B L E S:
c ZJ : Right-hand side vector X-sub-zero in SS(19); also the
c solution vector Z-sub-zero after solving that system
c ZZ : Permanent storage for ZJ, but re-ordered
c I N T E R N A L V A R I A B L E S:
c ARRAY : Coefficient matrix in left-hand side of Eq. SS(19)
c IPVT : Integer vector of pivot indices required by LINPACK
c WK : Scratch array required by LINPACK
c Called by- DISORT
c Calls- SGECO, ERRMSG, SGESL
c +-------------------------------------------------------------------+
c .. Scalar Arguments ..
INTEGER MAZIM, MXCMU, NN, NSTR
LOGICAL INSTAB
REAL MINRCOND
REAL DELM0, FBEAM, PI, UMU0
REAL mu2
c ..
c .. Array Arguments ..
INTEGER IPVT( * )
REAL ARRAY( MXCMU, MXCMU ), CC( MXCMU, MXCMU ), CMU( MXCMU ),
& GL( 0:MXCMU ), WK( MXCMU ), YLM0( 0:MXCMU ),
& YLMC( 0:MXCMU, * ), ZJ( MXCMU ), ZZ( MXCMU )
c ..
c .. Local Scalars ..
INTEGER IQ, JOB, JQ, K
REAL RCOND, SUM
c ..
c .. External Subroutines ..
EXTERNAL ERRMSG, SGECO, SGESL
c ..
DO 30 IQ = 1, NSTR
DO 10 JQ = 1, NSTR
ARRAY( IQ, JQ ) = -CC( IQ, JQ )
10 CONTINUE
ARRAY( IQ, IQ ) = 1.+ CMU( IQ ) / mu2 + ARRAY( IQ, IQ )
SUM = 0.
DO 20 K = MAZIM, NSTR - 1
SUM = SUM + GL( K )*YLMC( K, IQ )*YLM0( K )
20 CONTINUE
ZJ( IQ ) = ( 2.- DELM0 )*FBEAM*SUM / ( 4.*PI )
30 CONTINUE
c ** Find L-U (lower/upper triangular) decomposition
c of ARRAY and see if it is nearly singular
c (NOTE: ARRAY is destroyed)
RCOND = 0.0
CALL SGECO( ARRAY, MXCMU, NSTR, IPVT, RCOND, WK )
*bm IF( 1.0 + RCOND.EQ.1.0 )
*bm & CALL ERRMSG('UPBEAM--SGECO says matrix near singular',.FALSE.)
*bm
*bm replaced original check of RCOND by the following:
INSTAB = .FALSE.
IF( ABS(RCOND) .LT. MINRCOND ) THEN
INSTAB = .TRUE.
RETURN
ENDIF
c ** Solve linear system with coeff matrix ARRAY
c (assumed already L-U decomposed) and R.H. side(s)
c ZJ; return solution(s) in ZJ
JOB = 0
CALL SGESL( ARRAY, MXCMU, NSTR, IPVT, ZJ, JOB )
CDIR$ IVDEP
DO 40 IQ = 1, NN
ZZ( IQ + NN ) = ZJ( IQ )
ZZ( NN + 1 - IQ ) = ZJ( IQ + NN )
40 CONTINUE
END
SUBROUTINE ZEROAL( ND1, EXPBEA, FLYR, OPRIM, TAUCPR, XR0, XR1,
& ND2, CMU, CWT, PSI, WK, Z0, Z1, ZJ,
& ND3, HLPR, YLM0,
& ND4, ARRAY, CC, EVECC,
& ND5, GL,
& ND6, YLMC,
& ND7, YLMU,
& ND8, KK, LL, ZZ, ZPLK0, ZPLK1,
& ND9, GC,
& ND10, LAYRU, UTAUPR,
& ND11, GU,
& ND12, Z0U, Z1U, ZBEAM,
& ND13, EVAL,
& ND14, AMB, APB,
& ND15, IPVT, Z,
& ND16, RFLDIR, RFLDN, FLUP, UAVG, DFDT,
& ND17, ALBMED, TRNMED,
& ND18, U0U,
& ND19, UU )
c ZERO ARRAYS; NDn is dimension of all arrays following
c it in the argument list
c Called by- DISORT
c --------------------------------------------------------------------
c .. Scalar Arguments ..
INTEGER ND1, ND10, ND11, ND12, ND13, ND14, ND15, ND16, ND17,
& ND18, ND19, ND2, ND3, ND4, ND5, ND6, ND7, ND8, ND9
c ..
c .. Array Arguments ..
INTEGER IPVT( * ), LAYRU( * )
REAL ALBMED( * ), AMB( * ), APB( * ), ARRAY( * ), CC( * ),
& CMU( * ), CWT( * ), DFDT( * ), EVAL( * ), EVECC( * ),
& EXPBEA( * ), FLUP( * ), FLYR( * ), GC( * ), GL( * ),
& GU( * ), HLPR( * ), KK( * ), LL( * ), OPRIM( * ),
& PSI( * ), RFLDIR( * ), RFLDN( * ), TAUCPR( * ),
& TRNMED( * ), U0U( * ), UAVG( * ), UTAUPR( * ), UU( * ),
& WK( * ), XR0( * ), XR1( * ), YLM0( * ), YLMC( * ),
& YLMU( * ), Z( * ), Z0( * ), Z0U( * ), Z1( * ), Z1U( * ),
& ZBEAM( * ), ZJ( * ), ZPLK0( * ), ZPLK1( * ), ZZ( * )
c ..
c .. Local Scalars ..
INTEGER N
c ..
DO 10 N = 1, ND1
EXPBEA( N ) = 0.0
FLYR( N ) = 0.0
OPRIM( N ) = 0.0
TAUCPR( N ) = 0.0
XR0( N ) = 0.0
XR1( N ) = 0.0
10 CONTINUE
DO 20 N = 1, ND2
CMU( N ) = 0.0
CWT( N ) = 0.0
PSI( N ) = 0.0
WK( N ) = 0.0
Z0( N ) = 0.0
Z1( N ) = 0.0
ZJ( N ) = 0.0
20 CONTINUE
DO 30 N = 1, ND3
HLPR( N ) = 0.0
YLM0( N ) = 0.0
30 CONTINUE
DO 40 N = 1, ND4
ARRAY( N ) = 0.0
CC( N ) = 0.0
EVECC( N ) = 0.0
40 CONTINUE
DO 50 N = 1, ND5
GL( N ) = 0.0
50 CONTINUE
DO 60 N = 1, ND6
YLMC( N ) = 0.0
60 CONTINUE
DO 70 N = 1, ND7
YLMU( N ) = 0.0
70 CONTINUE
DO 80 N = 1, ND8
KK( N ) = 0.0
LL( N ) = 0.0
ZZ( N ) = 0.0
ZPLK0( N ) = 0.0
ZPLK1( N ) = 0.0
80 CONTINUE
DO 90 N = 1, ND9
GC( N ) = 0.0
90 CONTINUE
DO 100 N = 1, ND10
LAYRU( N ) = 0
UTAUPR( N ) = 0.0
100 CONTINUE
DO 110 N = 1, ND11
GU( N ) = 0.0
110 CONTINUE
DO 120 N = 1, ND12
Z0U( N ) = 0.0
Z1U( N ) = 0.0
ZBEAM( N ) = 0.0
120 CONTINUE
DO 130 N = 1, ND13
EVAL( N ) = 0.0
130 CONTINUE
DO 140 N = 1, ND14
AMB( N ) = 0.0
APB( N ) = 0.0
140 CONTINUE
DO 150 N = 1, ND15
IPVT( N ) = 0
Z( N ) = 0.0
150 CONTINUE
DO 160 N = 1, ND16
RFLDIR( N ) = 0.
RFLDN( N ) = 0.
FLUP( N ) = 0.
UAVG( N ) = 0.
DFDT( N ) = 0.
160 CONTINUE
DO 170 N = 1, ND17
ALBMED( N ) = 0.
TRNMED( N ) = 0.
170 CONTINUE
DO 180 N = 1, ND18
U0U( N ) = 0.
180 CONTINUE
DO 190 N = 1, ND19
UU( N ) = 0.
190 CONTINUE
END
SUBROUTINE ZEROIT( A, LENGTH )
c Zeros a real array A having LENGTH elements
c --------------------------------------------------------------------
c .. Scalar Arguments ..
INTEGER LENGTH
c ..
c .. Array Arguments ..
REAL A( LENGTH )
c ..
c .. Local Scalars ..
INTEGER L
c ..
DO 10 L = 1, LENGTH
A( L ) = 0.0
10 CONTINUE
END
c REAL FUNCTION DREF( MU, HL, NSTR )
C ##############################
FUNCTION DREF( MU, HL, NSTR )
C ##############################
c Exact flux albedo for given angle of incidence, given
c a bidirectional reflectivity characterized by its
c Legendre coefficients ( NOTE** these will only agree
c with bottom-boundary albedos calculated by DISORT in
c the limit as number of streams go to infinity, because
c DISORT evaluates the integral 'CL' only approximately,
c by quadrature, while this routine calculates it exactly.)
c INPUT : MU Cosine of incidence angle
c HL Legendre coefficients of bidirectional reflectivity
c NSTR Number of elements of HL to consider
c INTERNAL VARIABLES (P-sub-L is the L-th Legendre polynomial) :
c CL Integral from 0 to 1 of MU * P-sub-L(MU)
c (vanishes for L = 3, 5, 7, ... )
c PL P-sub-L
c PLM1 P-sub-(L-1)
c PLM2 P-sub-(L-2)
c Called by- CHEKIN
c Calls- ERRMSG
c +-------------------------------------------------------------------+
IMPLICIT NONE
REAL DREF
c .. Parameters ..
INTEGER MAXTRM
PARAMETER ( MAXTRM = 100 )
c ..
c .. Scalar Arguments ..
INTEGER NSTR
REAL MU
c ..
c .. Array Arguments ..
REAL HL( 0:NSTR )
c ..
c .. Local Scalars ..
LOGICAL PASS1
INTEGER L
REAL CL, PL, PLM1, PLM2
c ..
c .. Local Arrays ..
REAL C( MAXTRM )
c ..
c .. External Subroutines ..
EXTERNAL ERRMSG
c ..
c .. Intrinsic Functions ..
INTRINSIC MOD
c ..
SAVE PASS1, C
DATA PASS1 / .TRUE. /
c ..
IF( PASS1 ) THEN
PASS1 = .FALSE.
CL = 0.125
C( 2 ) = 10.*CL
DO 10 L = 4, MAXTRM, 2
CL = - CL*( L - 3 ) / ( L + 2 )
C( L ) = 2.*( 2*L + 1 )*CL
10 CONTINUE
END IF
IF( NSTR.LT.2 .OR. ABS(MU).GT.1.0 )
& CALL ERRMSG( 'DREF--input argument error(s)',.True. )
IF( NSTR.GT.MAXTRM )
& CALL ERRMSG( 'DREF--parameter MAXTRM too small',.True. )
DREF = HL( 0 ) - 2.*HL( 1 )*MU
PLM2 = 1.0
PLM1 = - MU
DO 20 L = 2, NSTR - 1
c ** Legendre polynomial recurrence
PL = ( ( 2*L - 1 )*( -MU )*PLM1 - ( L-1 )*PLM2 ) / L
IF( MOD( L,2 ).EQ.0 ) DREF = DREF + C( L )*HL( L )*PL
PLM2 = PLM1
PLM1 = PL
20 CONTINUE
IF( DREF.LT.0.0 .OR. DREF.GT.1.0 )
& CALL ERRMSG( 'DREF--albedo value not in (0,1)',.False. )
END
c REAL FUNCTION RATIO( A, B )
C ##############################
FUNCTION RATIO( A, B )
C ##############################
c Calculate ratio A/B with over- and under-flow protection
c (thanks to Prof. Jeff Dozier for some suggestions here).
c Since this routine takes two logs, it is no speed demon,
c but it is invaluable for comparing results from two runs
c of a program under development.
c NOTE: In Fortran90, built-in functions TINY and HUGE
c can replace the R1MACH calls.
c ---------------------------------------------------------------
IMPLICIT NONE
REAL RATIO
c .. Scalar Arguments ..
REAL A, B
c ..
c .. Local Scalars ..
LOGICAL PASS1
REAL ABSA, ABSB, HUGE, POWA, POWB, POWMAX, POWMIN, TINY
c ..
c .. External Functions ..
REAL R1MACH
EXTERNAL R1MACH
c ..
c .. Intrinsic Functions ..
INTRINSIC ABS, LOG10, SIGN
c ..
SAVE PASS1, TINY, HUGE, POWMAX, POWMIN
DATA PASS1 / .TRUE. /
c ..
IF( PASS1 ) THEN
TINY = R1MACH( 1 )
HUGE = R1MACH( 2 )
POWMAX = LOG10( HUGE )
POWMIN = LOG10( TINY )
PASS1 = .FALSE.
END IF
IF( A.EQ.0.0 ) THEN
IF( B.EQ.0.0 ) THEN
RATIO = 1.0
ELSE
RATIO = 0.0
END IF
ELSE IF( B.EQ.0.0 ) THEN
RATIO = SIGN( HUGE, A )
ELSE
ABSA = ABS( A )
ABSB = ABS( B )
POWA = LOG10( ABSA )
POWB = LOG10( ABSB )
IF( ABSA.LT.TINY .AND. ABSB.LT.TINY ) THEN
RATIO = 1.0
ELSE IF( POWA - POWB.GE.POWMAX ) THEN
RATIO = HUGE
ELSE IF( POWA - POWB.LE.POWMIN ) THEN
RATIO = TINY
ELSE
RATIO = ABSA / ABSB
END IF
c ** DONT use old trick of determining sign
c ** from A*B because A*B may (over/under)flow
IF( ( A.GT.0.0 .AND. B.LT.0.0 ) .OR.
& ( A.LT.0.0 .AND. B.GT.0.0 ) ) RATIO = -RATIO
END IF
END
c
c-------------------------------------------------------------------------
c
SUBROUTINE ErrMsg( MESSAG, FATAL )
c Print out a warning or error message; abort if error
c after making symbolic dump (machine-specific)
LOGICAL FATAL, MsgLim, Cray
CHARACTER*(*) MESSAG
INTEGER MaxMsg, NumMsg
SAVE MaxMsg, NumMsg, MsgLim
DATA NumMsg / 0 /, MaxMsg / 100 /, MsgLim / .FALSE. /
IF ( FATAL ) THEN
WRITE ( *, '(//,2A,//)' ) ' ******* ERROR >>>>>> ', MESSAG
STOP
END IF
NumMsg = NumMsg + 1
IF( MsgLim ) RETURN
IF ( NumMsg.LE.MaxMsg ) THEN
WRITE ( *, '(/,2A,/)' ) ' ******* WARNING >>>>>> ', MESSAG
ELSE
WRITE ( *,99 )
MsgLim = .True.
ENDIF
RETURN
99 FORMAT( //,' >>>>>> TOO MANY WARNING MESSAGES -- ',
$ 'They will no longer be printed <<<<<<<', // )
END
c -------------------------------------------------------------------------
c LOGICAL FUNCTION WrtBad ( VarNam )
C ##############################
FUNCTION WrtBad(VarNam)
C ##############################
c Write names of erroneous variables and return 'TRUE'
c INPUT : VarNam = Name of erroneous variable to be written
c ( CHARACTER, any length )
IMPLICIT NONE
CHARACTER*(*) VarNam
LOGICAL WrtBad
INTEGER MaxMsg, NumMsg
SAVE NumMsg, MaxMsg
DATA NumMsg / 0 /, MaxMsg / 50 /
WrtBad = .TRUE.
NumMsg = NumMsg + 1
WRITE ( *, '(3A)' ) ' **** Input variable ', VarNam,
$ ' in error ****'
IF ( NumMsg.EQ.MaxMsg )
$ CALL ErrMsg ( 'Too many input errors. Aborting...', .TRUE. )
RETURN
END
c LOGICAL FUNCTION WrtDim ( DimNam, MinVal )
C ##############################
FUNCTION WrtDim(DimNam,MinVal)
C ##############################
c Write name of too-small symbolic dimension and
c the value it should be increased to; return 'TRUE'
c INPUT : DimNam = Name of symbolic dimension which is too small
c ( CHARACTER, any length )
c Minval = Value to which that dimension should be
c increased (at least)
IMPLICIT NONE
CHARACTER*(*) DimNam
INTEGER MinVal
LOGICAL WrtDim
WRITE ( *, '(3A,I7)' ) ' **** Symbolic dimension ', DimNam,
$ ' should be increased to at least ', MinVal
WrtDim = .TRUE.
RETURN
END
c LOGICAL FUNCTION TstBad( VarNam, RelErr )
C ##############################
FUNCTION TstBad(VarNam, RelErr)
C ##############################
c Write name (VarNam) of variable failing self-test and its
c percent error from the correct value; return 'FALSE'.
IMPLICIT NONE
CHARACTER*(*) VarNam
REAL RelErr
LOGICAL TstBad
TstBad = .FALSE.
WRITE( *, '(/,3A,1P,E11.2,A)' )
$ ' Output variable ', VarNam,' differed by ', 100.*RelErr,
$ ' per cent from correct value. Self-test failed.'
RETURN
END
C
SUBROUTINE SGBCO( ABD, LDA, N, ML, MU, IPVT, RCOND, Z )
C FACTORS A REAL BAND MATRIX BY GAUSSIAN ELIMINATION
C AND ESTIMATES THE CONDITION OF THE MATRIX.
C REVISION DATE: 8/1/82
C AUTHOR: MOLER, C. B., (U. OF NEW MEXICO)
C IF RCOND IS NOT NEEDED, SGBFA IS SLIGHTLY FASTER.
C TO SOLVE A*X = B , FOLLOW SBGCO BY SGBSL.
C INPUT:
C ABD REAL(LDA, N)
C CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS
C OF THE MATRIX ARE STORED IN THE COLUMNS OF ABD AND
C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS
C ML+1 THROUGH 2*ML+MU+1 OF ABD .
C SEE THE COMMENTS BELOW FOR DETAILS.
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY ABD .
C LDA MUST BE .GE. 2*ML + MU + 1 .
C N INTEGER
C THE ORDER OF THE ORIGINAL MATRIX.
C ML INTEGER
C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C 0 .LE. ML .LT. N .
C MU INTEGER
C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C 0 .LE. MU .LT. N .
C MORE EFFICIENT IF ML .LE. MU .
C ON RETURN
C ABD AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND
C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE
C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR.
C IPVT INTEGER(N)
C AN INTEGER VECTOR OF PIVOT INDICES.
C RCOND REAL
C AN ESTIMATE OF THE RECIPROCAL CONDITION OF A .
C FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS
C IN A AND B OF SIZE EPSILON MAY CAUSE
C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND .
C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION
C 1.0 + RCOND .EQ. 1.0
C IS TRUE, THEN A MAY BE SINGULAR TO WORKING
C PRECISION. IN PARTICULAR, RCOND IS ZERO IF
C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C UNDERFLOWS.
C Z REAL(N)
C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS
C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C BAND STORAGE
C IF A IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT
C WILL SET UP THE INPUT.
C ML = (BAND WIDTH BELOW THE DIAGONAL)
C MU = (BAND WIDTH ABOVE THE DIAGONAL)
C M = ML + MU + 1
C DO 20 J = 1, N
C I1 = MAX0(1, J-MU)
C I2 = MIN0(N, J+ML)
C DO 10 I = I1, I2
C K = I - J + M
C ABD(K,J) = A(I,J)
C 10 CONTINUE
C 20 CONTINUE
C THIS USES ROWS ML+1 THROUGH 2*ML+MU+1 OF ABD .
C IN ADDITION, THE FIRST ML ROWS IN ABD ARE USED FOR
C ELEMENTS GENERATED DURING THE TRIANGULARIZATION.
C THE TOTAL NUMBER OF ROWS NEEDED IN ABD IS 2*ML+MU+1 .
C THE ML+MU BY ML+MU UPPER LEFT TRIANGLE AND THE
C ML BY ML LOWER RIGHT TRIANGLE ARE NOT REFERENCED.
C EXAMPLE: IF THE ORIGINAL MATRIX IS
C 11 12 13 0 0 0
C 21 22 23 24 0 0
C 0 32 33 34 35 0
C 0 0 43 44 45 46
C 0 0 0 54 55 56
C 0 0 0 0 65 66
C THEN N = 6, ML = 1, MU = 2, LDA .GE. 5 AND ABD SHOULD CONTAIN
C * * * + + + , * = NOT USED
C * * 13 24 35 46 , + = USED FOR PIVOTING
C * 12 23 34 45 56
C 11 22 33 44 55 66
C 21 32 43 54 65 *
C ROUTINES CALLED: FROM LINPACK: SGBFA
C FROM BLAS: SAXPY, SDOT, SSCAL, SASUM
C FROM FORTRAN: ABS, AMAX1, MAX0, MIN0, SIGN
EXTERNAL SGBFA, SAXPY, SDOT, SASUM, SSCAL
INTEGER LDA, N, ML, MU, IPVT(*)
REAL ABD(LDA,*), Z(*)
REAL RCOND
REAL SDOT, EK, T, WK, WKM
REAL ANORM, S, SASUM, SM, YNORM
INTEGER IS, INFO, J, JU, K, KB, KP1, L, LA, LM, LZ, M, MM
C ** COMPUTE 1-NORM OF A
ANORM = 0.0E0
L = ML + 1
IS = L + MU
DO 10 J = 1, N
ANORM = AMAX1(ANORM, SASUM(L,ABD(IS,J), 1))
IF (IS .GT. ML + 1) IS = IS - 1
IF (J .LE. MU) L = L + 1
IF (J .GE. N - ML) L = L - 1
10 CONTINUE
C ** FACTOR
CALL SGBFA(ABD, LDA, N, ML, MU, IPVT, INFO)
C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E .
C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE
C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE
C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C OVERFLOW.
C ** SOLVE TRANS(U)*W = E
EK = 1.0E0
DO 20 J = 1, N
Z(J) = 0.0E0
20 CONTINUE
M = ML + MU + 1
JU = 0
DO 100 K = 1, N
IF (Z(K) .NE. 0.0E0) EK = SIGN(EK, -Z(K))
IF (ABS(EK-Z(K)) .GT. ABS(ABD(M,K))) THEN
S = ABS(ABD(M,K))/ABS(EK-Z(K))
CALL SSCAL(N, S, Z, 1)
EK = S*EK
ENDIF
WK = EK - Z(K)
WKM = -EK - Z(K)
S = ABS(WK)
SM = ABS(WKM)
IF (ABD(M,K) .NE. 0.0E0) THEN
WK = WK /ABD(M,K)
WKM = WKM/ABD(M,K)
ELSE
WK = 1.0E0
WKM = 1.0E0
ENDIF
KP1 = K + 1
JU = MIN0(MAX0(JU, MU+IPVT(K)), N)
MM = M
IF (KP1 .LE. JU) THEN
DO 60 J = KP1, JU
MM = MM - 1
SM = SM + ABS(Z(J)+WKM*ABD(MM,J))
Z(J) = Z(J) + WK*ABD(MM,J)
S = S + ABS(Z(J))
60 CONTINUE
IF (S .LT. SM) THEN
T = WKM - WK
WK = WKM
MM = M
DO 70 J = KP1, JU
MM = MM - 1
Z(J) = Z(J) + T*ABD(MM,J)
70 CONTINUE
ENDIF
ENDIF
Z(K) = WK
100 CONTINUE
S = 1.0E0 / SASUM(N, Z, 1)
CALL SSCAL(N, S, Z, 1)
C ** SOLVE TRANS(L)*Y = W
DO 120 KB = 1, N
K = N + 1 - KB
LM = MIN0(ML, N-K)
IF (K .LT. N) Z(K) = Z(K) + SDOT(LM, ABD(M+1,K), 1, Z(K+1), 1)
IF (ABS(Z(K)) .GT. 1.0E0) THEN
S = 1.0E0 / ABS(Z(K))
CALL SSCAL(N, S, Z, 1)
ENDIF
L = IPVT(K)
T = Z(L)
Z(L) = Z(K)
Z(K) = T
120 CONTINUE
S = 1.0E0 / SASUM(N, Z, 1)
CALL SSCAL(N, S, Z, 1)
YNORM = 1.0E0
C ** SOLVE L*V = Y
DO 140 K = 1, N
L = IPVT(K)
T = Z(L)
Z(L) = Z(K)
Z(K) = T
LM = MIN0(ML, N-K)
IF (K .LT. N) CALL SAXPY(LM, T, ABD(M+1,K), 1, Z(K+1), 1)
IF (ABS(Z(K)) .GT. 1.0E0) THEN
S = 1.0E0 / ABS(Z(K))
CALL SSCAL(N, S, Z, 1)
YNORM = S*YNORM
ENDIF
140 CONTINUE
S = 1.0E0/SASUM(N, Z, 1)
CALL SSCAL(N, S, Z, 1)
YNORM = S*YNORM
C ** SOLVE U*Z = W
DO 160 KB = 1, N
K = N + 1 - KB
IF (ABS(Z(K)) .GT. ABS(ABD(M,K))) THEN
S = ABS(ABD(M,K)) / ABS(Z(K))
CALL SSCAL(N, S, Z, 1)
YNORM = S*YNORM
ENDIF
IF (ABD(M,K) .NE. 0.0E0) Z(K) = Z(K)/ABD(M,K)
IF (ABD(M,K) .EQ. 0.0E0) Z(K) = 1.0E0
LM = MIN0(K, M) - 1
LA = M - LM
LZ = K - LM
T = -Z(K)
CALL SAXPY(LM, T, ABD(LA,K), 1, Z(LZ), 1)
160 CONTINUE
C ** MAKE ZNORM = 1.0
S = 1.0E0 / SASUM(N, Z, 1)
CALL SSCAL(N, S, Z, 1)
YNORM = S*YNORM
IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
RETURN
END
SUBROUTINE SGBFA( ABD, LDA, N, ML, MU, IPVT, INFO )
C FACTORS A REAL BAND MATRIX BY ELIMINATION.
C REVISION DATE: 8/1/82
C AUTHOR: MOLER, C. B., (U. OF NEW MEXICO)
C SGBFA IS USUALLY CALLED BY SBGCO, BUT IT CAN BE CALLED
C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED.
C INPUT: SAME AS 'SGBCO'
C ON RETURN:
C ABD,IPVT SAME AS 'SGBCO'
C INFO INTEGER
C = 0 NORMAL VALUE.
C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR
C CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C INDICATE THAT SGBSL WILL DIVIDE BY ZERO IF
C CALLED. USE RCOND IN SBGCO FOR A RELIABLE
C INDICATION OF SINGULARITY.
C (SEE 'SGBCO' FOR DESCRIPTION OF BAND STORAGE MODE)
C ROUTINES CALLED: FROM BLAS: SAXPY, SSCAL, ISAMAX
C FROM FORTRAN: MAX0, MIN0
EXTERNAL SAXPY, SSCAL, ISAMAX
INTEGER LDA, N, ML, MU, IPVT(*), INFO
REAL ABD(LDA,*)
REAL T
INTEGER I,ISAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1
M = ML + MU + 1
INFO = 0
C ** ZERO INITIAL FILL-IN COLUMNS
J0 = MU + 2
J1 = MIN0(N, M) - 1
DO 20 JZ = J0, J1
I0 = M + 1 - JZ
DO 10 I = I0, ML
ABD(I,JZ) = 0.0E0
10 CONTINUE
20 CONTINUE
JZ = J1
JU = 0
C ** GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
NM1 = N - 1
DO 120 K = 1, NM1
KP1 = K + 1
C ** ZERO NEXT FILL-IN COLUMN
JZ = JZ + 1
IF (JZ .LE. N) THEN
DO 40 I = 1, ML
ABD(I,JZ) = 0.0E0
40 CONTINUE
ENDIF
C ** FIND L = PIVOT INDEX
LM = MIN0(ML, N-K)
L = ISAMAX(LM+1, ABD(M,K), 1) + M - 1
IPVT(K) = L + K - M
IF (ABD(L,K) .EQ. 0.0E0) THEN
C ** ZERO PIVOT IMPLIES THIS COLUMN
C ** ALREADY TRIANGULARIZED
INFO = K
ELSE
C ** INTERCHANGE IF NECESSARY
IF (L .NE. M) THEN
T = ABD(L,K)
ABD(L,K) = ABD(M,K)
ABD(M,K) = T
ENDIF
C ** COMPUTE MULTIPLIERS
T = -1.0E0 / ABD(M,K)
CALL SSCAL(LM, T, ABD(M+1,K), 1)
C ** ROW ELIMINATION WITH COLUMN INDEXING
JU = MIN0(MAX0(JU, MU+IPVT(K)), N)
MM = M
DO 80 J = KP1, JU
L = L - 1
MM = MM - 1
T = ABD(L,J)
IF (L .NE. MM) THEN
ABD(L,J) = ABD(MM,J)
ABD(MM,J) = T
ENDIF
CALL SAXPY(LM, T, ABD(M+1,K), 1, ABD(MM+1,J), 1)
80 CONTINUE
ENDIF
120 CONTINUE
IPVT(N) = N
IF (ABD(M,N) .EQ. 0.0E0) INFO = N
RETURN
END
SUBROUTINE SGBSL( ABD, LDA, N, ML, MU, IPVT, B, JOB )
C SOLVES THE REAL BAND SYSTEM
C A * X = B OR TRANSPOSE(A) * X = B
C USING THE FACTORS COMPUTED BY SBGCO OR SGBFA.
C REVISION DATE: 8/1/82
C AUTHOR: MOLER, C. B., (U. OF NEW MEXICO)
C INPUT:
C ABD REAL(LDA, N)
C THE OUTPUT FROM SBGCO OR SGBFA.
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY ABD .
C N INTEGER
C THE ORDER OF THE ORIGINAL MATRIX.
C ML INTEGER
C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C MU INTEGER
C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C IPVT INTEGER(N)
C THE PIVOT VECTOR FROM SBGCO OR SGBFA.
C B REAL(N)
C THE RIGHT HAND SIDE VECTOR.
C JOB INTEGER
C = 0 TO SOLVE A*X = B ,
C = NONZERO TO SOLVE TRANS(A)*X = B , WHERE
C TRANS(A) IS THE TRANSPOSE.
C ON RETURN
C B THE SOLUTION VECTOR X .
C ERROR CONDITION
C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C ZERO ON THE DIAGONAL. TECHNICALLY, THIS INDICATES SINGULARITY,
C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C CALLED CORRECTLY AND IF SBGCO HAS SET RCOND .GT. 0.0
C OR SGBFA HAS SET INFO .EQ. 0 .
C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX
C WITH P COLUMNS
C CALL SGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)
C IF (RCOND IS TOO SMALL) GO TO ...
C DO 10 J = 1, P
C CALL SGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0)
C 10 CONTINUE
C ROUTINES CALLED: FROM BLAS: SAXPY, SDOT
C FROM FORTRAN: MIN0
EXTERNAL SAXPY, SDOT
INTEGER LDA, N, ML, MU, IPVT(*), JOB
REAL ABD(LDA,*), B(*)
REAL SDOT,T
INTEGER K,KB,L,LA,LB,LM,M,NM1
M = MU + ML + 1
NM1 = N - 1
IF (JOB .EQ. 0) THEN
C ** JOB = 0 , SOLVE A * X = B
C ** FIRST SOLVE L*Y = B
IF (ML .NE. 0) THEN
DO 20 K = 1, NM1
LM = MIN0(ML, N-K)
L = IPVT(K)
T = B(L)
IF (L .NE. K) THEN
B(L) = B(K)
B(K) = T
ENDIF
CALL SAXPY( LM, T, ABD(M+1,K), 1, B(K+1), 1 )
20 CONTINUE
ENDIF
C ** NOW SOLVE U*X = Y
DO 40 KB = 1, N
K = N + 1 - KB
B(K) = B(K) / ABD(M,K)
LM = MIN0(K, M) - 1
LA = M - LM
LB = K - LM
T = -B(K)
CALL SAXPY(LM, T, ABD(LA,K), 1, B(LB), 1)
40 CONTINUE
ELSE
C ** JOB = NONZERO, SOLVE TRANS(A) * X = B
C ** FIRST SOLVE TRANS(U)*Y = B
DO 60 K = 1, N
LM = MIN0(K, M) - 1
LA = M - LM
LB = K - LM
T = SDOT(LM, ABD(LA,K), 1, B(LB), 1)
B(K) = (B(K) - T)/ABD(M,K)
60 CONTINUE
C ** NOW SOLVE TRANS(L)*X = Y
IF (ML .NE. 0) THEN
DO 80 KB = 1, NM1
K = N - KB
LM = MIN0(ML, N-K)
B(K) = B(K) + SDOT(LM, ABD(M+1,K), 1, B(K+1), 1)
L = IPVT(K)
IF (L .NE. K) THEN
T = B(L)
B(L) = B(K)
B(K) = T
ENDIF
80 CONTINUE
ENDIF
ENDIF
RETURN
END
SUBROUTINE SGECO( A, LDA, N,IPVT, RCOND, Z )
C FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION
C AND ESTIMATES THE CONDITION OF THE MATRIX.
C REVISION DATE: 8/1/82
C AUTHOR: MOLER, C. B., (U. OF NEW MEXICO)
C IF RCOND IS NOT NEEDED, SGEFA IS SLIGHTLY FASTER.
C TO SOLVE A*X = B , FOLLOW SGECO BY SGESL.
C ON ENTRY
C A REAL(LDA, N)
C THE MATRIX TO BE FACTORED.
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY A .
C N INTEGER
C THE ORDER OF THE MATRIX A .
C ON RETURN
C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C WHICH WERE USED TO OBTAIN IT.
C THE FACTORIZATION CAN BE WRITTEN A = L*U , WHERE
C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR.
C IPVT INTEGER(N)
C AN INTEGER VECTOR OF PIVOT INDICES.
C RCOND REAL
C AN ESTIMATE OF THE RECIPROCAL CONDITION OF A .
C FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS
C IN A AND B OF SIZE EPSILON MAY CAUSE
C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND .
C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION
C 1.0 + RCOND .EQ. 1.0
C IS TRUE, THEN A MAY BE SINGULAR TO WORKING
C PRECISION. IN PARTICULAR, RCOND IS ZERO IF
C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C UNDERFLOWS.
C Z REAL(N)
C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS
C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C ROUTINES CALLED: FROM LINPACK: SGEFA
C FROM BLAS: SAXPY, SDOT, SSCAL, SASUM
C FROM FORTRAN: ABS, AMAX1, SIGN
EXTERNAL SGEFA, SAXPY, SDOT, SSCAL, SASUM
INTEGER LDA, N, IPVT(*)
REAL A(LDA,*), Z(*)
REAL RCOND
REAL SDOT,EK,T,WK,WKM
REAL ANORM,S,SASUM,SM,YNORM
INTEGER INFO,J,K,KB,KP1,L
C ** COMPUTE 1-NORM OF A
ANORM = 0.0E0
DO 10 J = 1, N
ANORM = AMAX1( ANORM, SASUM(N,A(1,J),1) )
10 CONTINUE
C ** FACTOR
CALL SGEFA(A,LDA,N,IPVT,INFO)
C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E .
C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE
C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE
C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C OVERFLOW.
C ** SOLVE TRANS(U)*W = E
EK = 1.0E0
DO 20 J = 1, N
Z(J) = 0.0E0
20 CONTINUE
DO 100 K = 1, N
IF (Z(K) .NE. 0.0E0) EK = SIGN(EK, -Z(K))
IF (ABS(EK-Z(K)) .GT. ABS(A(K,K))) THEN
S = ABS(A(K,K)) / ABS(EK-Z(K))
CALL SSCAL(N, S, Z, 1)
EK = S*EK
ENDIF
WK = EK - Z(K)
WKM = -EK - Z(K)
S = ABS(WK)
SM = ABS(WKM)
IF (A(K,K) .NE. 0.0E0) THEN
WK = WK / A(K,K)
WKM = WKM / A(K,K)
ELSE
WK = 1.0E0
WKM = 1.0E0
ENDIF
KP1 = K + 1
IF (KP1 .LE. N) THEN
DO 60 J = KP1, N
SM = SM + ABS(Z(J)+WKM*A(K,J))
Z(J) = Z(J) + WK*A(K,J)
S = S + ABS(Z(J))
60 CONTINUE
IF (S .LT. SM) THEN
T = WKM - WK
WK = WKM
DO 70 J = KP1, N
Z(J) = Z(J) + T*A(K,J)
70 CONTINUE
ENDIF
ENDIF
Z(K) = WK
100 CONTINUE
S = 1.0E0 / SASUM(N, Z, 1)
CALL SSCAL(N, S, Z, 1)
C ** SOLVE TRANS(L)*Y = W
DO 120 KB = 1, N
K = N + 1 - KB
IF (K .LT. N) Z(K) = Z(K) + SDOT(N-K, A(K+1,K), 1, Z(K+1), 1)
IF (ABS(Z(K)) .GT. 1.0E0) THEN
S = 1.0E0/ABS(Z(K))
CALL SSCAL(N, S, Z, 1)
ENDIF
L = IPVT(K)
T = Z(L)
Z(L) = Z(K)
Z(K) = T
120 CONTINUE
S = 1.0E0 / SASUM(N, Z, 1)
CALL SSCAL(N, S, Z, 1)
C ** SOLVE L*V = Y
YNORM = 1.0E0
DO 140 K = 1, N
L = IPVT(K)
T = Z(L)
Z(L) = Z(K)
Z(K) = T
IF (K .LT. N) CALL SAXPY(N-K, T, A(K+1,K), 1, Z(K+1), 1)
IF (ABS(Z(K)) .GT. 1.0E0) THEN
S = 1.0E0/ABS(Z(K))
CALL SSCAL(N, S, Z, 1)
YNORM = S*YNORM
ENDIF
140 CONTINUE
S = 1.0E0 / SASUM(N, Z, 1)
CALL SSCAL(N, S, Z, 1)
C ** SOLVE U*Z = V
YNORM = S*YNORM
DO 160 KB = 1, N
K = N + 1 - KB
IF (ABS(Z(K)) .GT. ABS(A(K,K))) THEN
S = ABS(A(K,K))/ABS(Z(K))
CALL SSCAL(N, S, Z, 1)
YNORM = S*YNORM
ENDIF
IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0
T = -Z(K)
CALL SAXPY(K-1, T, A(1,K), 1, Z(1), 1)
160 CONTINUE
C ** MAKE ZNORM = 1.0
S = 1.0E0 / SASUM(N, Z, 1)
CALL SSCAL(N, S, Z, 1)
YNORM = S*YNORM
IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
RETURN
END
SUBROUTINE SGEFA( A, LDA, N, IPVT, INFO )
C FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION.
C REVISION DATE: 8/1/82
C AUTHOR: MOLER, C. B., (U. OF NEW MEXICO)
C SGEFA IS USUALLY CALLED BY SGECO, BUT IT CAN BE CALLED
C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED.
C (TIME FOR SGECO) = (1 + 9/N)*(TIME FOR SGEFA) .
C INPUT: SAME AS 'SGECO'
C ON RETURN:
C A,IPVT SAME AS 'SGECO'
C INFO INTEGER
C = 0 NORMAL VALUE.
C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR
C CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C INDICATE THAT SGESL OR SGEDI WILL DIVIDE BY ZERO
C IF CALLED. USE RCOND IN SGECO FOR A RELIABLE
C INDICATION OF SINGULARITY.
C ROUTINES CALLED: FROM BLAS: SAXPY, SSCAL, ISAMAX
EXTERNAL SAXPY, SSCAL, ISAMAX
INTEGER LDA, N, IPVT(*), INFO
REAL A(LDA,*)
REAL T
INTEGER ISAMAX,J,K,KP1,L,NM1
C ** GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
INFO = 0
NM1 = N - 1
DO 60 K = 1, NM1
KP1 = K + 1
C ** FIND L = PIVOT INDEX
L = ISAMAX( N-K+1, A(K,K), 1) + K-1
IPVT(K) = L
IF (A(L,K) .EQ. 0.0E0) THEN
C ** ZERO PIVOT IMPLIES THIS COLUMN
C ** ALREADY TRIANGULARIZED
INFO = K
ELSE
C ** INTERCHANGE IF NECESSARY
IF (L .NE. K) THEN
T = A(L,K)
A(L,K) = A(K,K)
A(K,K) = T
ENDIF
C ** COMPUTE MULTIPLIERS
T = -1.0E0 / A(K,K)
CALL SSCAL( N-K, T, A(K+1,K), 1 )
C ** ROW ELIMINATION WITH COLUMN INDEXING
DO 30 J = KP1, N
T = A(L,J)
IF (L .NE. K) THEN
A(L,J) = A(K,J)
A(K,J) = T
ENDIF
CALL SAXPY( N-K, T, A(K+1,K), 1, A(K+1,J), 1 )
30 CONTINUE
ENDIF
60 CONTINUE
IPVT(N) = N
IF (A(N,N) .EQ. 0.0E0) INFO = N
RETURN
END
SUBROUTINE SGESL( A, LDA, N,IPVT, B, JOB )
C SOLVES THE REAL SYSTEM
C A * X = B OR TRANS(A) * X = B
C USING THE FACTORS COMPUTED BY SGECO OR SGEFA.
C REVISION DATE: 8/1/82
C AUTHOR: MOLER, C. B., (U. OF NEW MEXICO)
C ON ENTRY
C A REAL(LDA, N)
C THE OUTPUT FROM SGECO OR SGEFA.
C LDA INTEGER
C THE LEADING DIMENSION OF THE ARRAY A .
C N INTEGER
C THE ORDER OF THE MATRIX A .
C IPVT INTEGER(N)
C THE PIVOT VECTOR FROM SGECO OR SGEFA.
C B REAL(N)
C THE RIGHT HAND SIDE VECTOR.
C JOB INTEGER
C = 0 TO SOLVE A*X = B ,
C = NONZERO TO SOLVE TRANS(A)*X = B WHERE
C TRANS(A) IS THE TRANSPOSE.
C ON RETURN
C B THE SOLUTION VECTOR X .
C ERROR CONDITION
C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C ZERO ON THE DIAGONAL. TECHNICALLY, THIS INDICATES SINGULARITY,
C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C CALLED CORRECTLY AND IF SGECO HAS SET RCOND .GT. 0.0
C OR SGEFA HAS SET INFO .EQ. 0 .
C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX
C WITH P COLUMNS
C CALL SGECO(A,LDA,N,IPVT,RCOND,Z)
C IF (RCOND IS TOO SMALL) GO TO ...
C DO 10 J = 1, P
C CALL SGESL(A,LDA,N,IPVT,C(1,J),0)
C 10 CONTINUE
C ROUTINES CALLED: FROM BLAS: SAXPY, SDOT
EXTERNAL SAXPY, SDOT
INTEGER LDA, N, IPVT(*), JOB
REAL A(LDA,*), B(*)
REAL SDOT,T
INTEGER K,KB,L,NM1
NM1 = N - 1
IF (JOB .EQ. 0) THEN
C ** JOB = 0 , SOLVE A * X = B
C ** FIRST SOLVE L*Y = B
DO 20 K = 1, NM1
L = IPVT(K)
T = B(L)
IF (L .NE. K) THEN
B(L) = B(K)
B(K) = T
ENDIF
CALL SAXPY( N-K, T, A(K+1,K), 1, B(K+1), 1 )
20 CONTINUE
C ** NOW SOLVE U*X = Y
DO 40 KB = 1, N
K = N + 1 - KB
B(K) = B(K) / A(K,K)
T = -B(K)
CALL SAXPY( K-1, T, A(1,K), 1, B(1), 1 )
40 CONTINUE
ELSE
C ** JOB = NONZERO, SOLVE TRANS(A) * X = B
C ** FIRST SOLVE TRANS(U)*Y = B
DO 60 K = 1, N
T = SDOT( K-1, A(1,K), 1, B(1), 1 )
B(K) = (B(K) - T) / A(K,K)
60 CONTINUE
C ** NOW SOLVE TRANS(L)*X = Y
DO 80 KB = 1, NM1
K = N - KB
B(K) = B(K) + SDOT( N-K, A(K+1,K), 1, B(K+1), 1 )
L = IPVT(K)
IF (L .NE. K) THEN
T = B(L)
B(L) = B(K)
B(K) = T
ENDIF
80 CONTINUE
ENDIF
RETURN
END
c REAL FUNCTION SASUM( N, SX, INCX )
C ##############################
FUNCTION SASUM(N,SX,INCX)
C ##############################
C --INPUT-- N NUMBER OF ELEMENTS IN VECTOR TO BE SUMMED
C SX SING-PREC ARRAY, LENGTH 1+(N-1)*INCX, CONTAINING VECTOR
C INCX SPACING OF VECTOR ELEMENTS IN 'SX'
C --OUTPUT-- SASUM SUM FROM 0 TO N-1 OF ABS(SX(1+I*INCX))
IMPLICIT NONE
REAL SASUM
REAL SX(*)
INTEGER N, INCX
INTEGER I, M
SASUM = 0.0
IF( N.LE.0 ) RETURN
IF( INCX.NE.1 ) THEN
C ** NON-UNIT INCREMENTS
DO 10 I = 1, 1+(N-1)*INCX, INCX
SASUM = SASUM + ABS(SX(I))
10 CONTINUE
ELSE
C ** UNIT INCREMENTS
M = MOD(N,6)
IF( M.NE.0 ) THEN
C ** CLEAN-UP LOOP SO REMAINING VECTOR
C ** LENGTH IS A MULTIPLE OF 6.
DO 30 I = 1, M
SASUM = SASUM + ABS(SX(I))
30 CONTINUE
ENDIF
C ** UNROLL LOOP FOR SPEED
DO 50 I = M+1, N, 6
SASUM = SASUM + ABS(SX(I)) + ABS(SX(I+1)) + ABS(SX(I+2))
$ + ABS(SX(I+3)) + ABS(SX(I+4)) + ABS(SX(I+5))
50 CONTINUE
ENDIF
RETURN
END
SUBROUTINE SAXPY( N, SA, SX, INCX, SY, INCY )
C Y = A*X + Y (X, Y = VECTORS, A = SCALAR)
C --INPUT--
C N NUMBER OF ELEMENTS IN INPUT VECTORS 'X' AND 'Y'
C SA SINGLE PRECISION SCALAR MULTIPLIER 'A'
C SX SING-PREC ARRAY CONTAINING VECTOR 'X'
C INCX SPACING OF ELEMENTS OF VECTOR 'X' IN 'SX'
C SY SING-PREC ARRAY CONTAINING VECTOR 'Y'
C INCY SPACING OF ELEMENTS OF VECTOR 'Y' IN 'SY'
C --OUTPUT--
C SY FOR I = 0 TO N-1, OVERWRITE SY(LY+I*INCY) WITH
C SA*SX(LX+I*INCX) + SY(LY+I*INCY),
C WHERE LX = 1 IF INCX .GE. 0,
C = (-INCX)*N IF INCX .LT. 0
C AND LY IS DEFINED IN A SIMILAR WAY USING INCY.
REAL SX(*), SY(*), SA
IF( N.LE.0 .OR. SA.EQ.0.0 ) RETURN
IF ( INCX.EQ.INCY .AND. INCX.GT.1 ) THEN
DO 10 I = 1, 1+(N-1)*INCX, INCX
SY(I) = SY(I) + SA * SX(I)
10 CONTINUE
ELSE IF ( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN
C ** EQUAL, UNIT INCREMENTS
M = MOD(N,4)
IF( M .NE. 0 ) THEN
C ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
C ** IS A MULTIPLE OF 4.
DO 20 I = 1, M
SY(I) = SY(I) + SA * SX(I)
20 CONTINUE
ENDIF
C ** UNROLL LOOP FOR SPEED
DO 30 I = M+1, N, 4
SY(I) = SY(I) + SA * SX(I)
SY(I+1) = SY(I+1) + SA * SX(I+1)
SY(I+2) = SY(I+2) + SA * SX(I+2)
SY(I+3) = SY(I+3) + SA * SX(I+3)
30 CONTINUE
ELSE
C ** NONEQUAL OR NONPOSITIVE INCREMENTS.
IX = 1
IY = 1
IF( INCX.LT.0 ) IX = 1 + (N-1)*(-INCX)
IF( INCY.LT.0 ) IY = 1 + (N-1)*(-INCY)
DO 40 I = 1, N
SY(IY) = SY(IY) + SA*SX(IX)
IX = IX + INCX
IY = IY + INCY
40 CONTINUE
ENDIF
RETURN
END
c REAL FUNCTION SDOT( N, SX, INCX, SY, INCY )
C ##############################
FUNCTION SDOT( N, SX, INCX, SY, INCY )
C ##############################
C S.P. DOT PRODUCT OF VECTORS 'X' AND 'Y'
C --INPUT--
C N NUMBER OF ELEMENTS IN INPUT VECTORS 'X' AND 'Y'
C SX SING-PREC ARRAY CONTAINING VECTOR 'X'
C INCX SPACING OF ELEMENTS OF VECTOR 'X' IN 'SX'
C SY SING-PREC ARRAY CONTAINING VECTOR 'Y'
C INCY SPACING OF ELEMENTS OF VECTOR 'Y' IN 'SY'
C --OUTPUT--
C SDOT SUM FOR I = 0 TO N-1 OF SX(LX+I*INCX) * SY(LY+I*INCY),
C WHERE LX = 1 IF INCX .GE. 0,
C = (-INCX)*N IF INCX .LT. 0,
C AND LY IS DEFINED IN A SIMILAR WAY USING INCY.
IMPLICIT NONE
INTEGER N,INCX,INCY
REAL SX(*), SY(*)
REAL SDOT
INTEGER I,M, IX, IY
SDOT = 0.0
IF( N.LE.0 ) RETURN
IF ( INCX.EQ.INCY .AND. INCX.GT.1 ) THEN
DO 10 I = 1, 1+(N-1)*INCX, INCX
SDOT = SDOT + SX(I) * SY(I)
10 CONTINUE
ELSE IF ( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN
C ** EQUAL, UNIT INCREMENTS
M = MOD(N,5)
IF( M .NE. 0 ) THEN
C ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
C ** IS A MULTIPLE OF 4.
DO 20 I = 1, M
SDOT = SDOT + SX(I) * SY(I)
20 CONTINUE
ENDIF
C ** UNROLL LOOP FOR SPEED
DO 30 I = M+1, N, 5
SDOT = SDOT + SX(I)*SY(I) + SX(I+1)*SY(I+1)
$ + SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3)
$ + SX(I+4)*SY(I+4)
30 CONTINUE
ELSE
C ** NONEQUAL OR NONPOSITIVE INCREMENTS.
IX = 1
IY = 1
IF( INCX.LT.0 ) IX = 1 + (N-1)*(-INCX)
IF( INCY.LT.0 ) IY = 1 + (N-1)*(-INCY)
DO 40 I = 1, N
SDOT = SDOT + SX(IX) * SY(IY)
IX = IX + INCX
IY = IY + INCY
40 CONTINUE
ENDIF
RETURN
END
SUBROUTINE SSCAL( N, SA, SX, INCX )
C CALCULATE X = A*X (X = VECTOR, A = SCALAR)
C --INPUT-- N NUMBER OF ELEMENTS IN VECTOR
C SA SINGLE PRECISION SCALE FACTOR
C SX SING-PREC ARRAY, LENGTH 1+(N-1)*INCX, CONTAINING VECTOR
C INCX SPACING OF VECTOR ELEMENTS IN 'SX'
C --OUTPUT-- SX REPLACE SX(1+I*INCX) WITH SA * SX(1+I*INCX)
C FOR I = 0 TO N-1
REAL SA, SX(*)
IF( N.LE.0 ) RETURN
IF( INCX.NE.1 ) THEN
DO 10 I = 1, 1+(N-1)*INCX, INCX
SX(I) = SA * SX(I)
10 CONTINUE
ELSE
M = MOD(N,5)
IF( M.NE.0 ) THEN
C ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
C ** IS A MULTIPLE OF 5.
DO 30 I = 1, M
SX(I) = SA * SX(I)
30 CONTINUE
ENDIF
C ** UNROLL LOOP FOR SPEED
DO 50 I = M+1, N, 5
SX(I) = SA * SX(I)
SX(I+1) = SA * SX(I+1)
SX(I+2) = SA * SX(I+2)
SX(I+3) = SA * SX(I+3)
SX(I+4) = SA * SX(I+4)
50 CONTINUE
ENDIF
RETURN
END
SUBROUTINE SSWAP( N, SX, INCX, SY, INCY )
C INTERCHANGE S.P VECTORS X AND Y
C --INPUT--
C N NUMBER OF ELEMENTS IN INPUT VECTORS 'X' AND 'Y'
C SX SING-PREC ARRAY CONTAINING VECTOR 'X'
C INCX SPACING OF ELEMENTS OF VECTOR 'X' IN 'SX'
C SY SING-PREC ARRAY CONTAINING VECTOR 'Y'
C INCY SPACING OF ELEMENTS OF VECTOR 'Y' IN 'SY'
C --OUTPUT--
C SX INPUT VECTOR SY (UNCHANGED IF N .LE. 0)
C SY INPUT VECTOR SX (UNCHANGED IF N .LE. 0)
C FOR I = 0 TO N-1, INTERCHANGE SX(LX+I*INCX) AND SY(LY+I*INCY),
C WHERE LX = 1 IF INCX .GE. 0,
C = (-INCX)*N IF INCX .LT. 0
C AND LY IS DEFINED IN A SIMILAR WAY USING INCY.
REAL SX(*), SY(*), STEMP1, STEMP2, STEMP3
IF( N.LE.0 ) RETURN
IF ( INCX.EQ.INCY .AND. INCX.GT.1 ) THEN
DO 10 I = 1, 1+(N-1)*INCX, INCX
STEMP1 = SX(I)
SX(I) = SY(I)
SY(I) = STEMP1
10 CONTINUE
ELSE IF ( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN
C ** EQUAL, UNIT INCREMENTS
M = MOD(N,3)
IF( M .NE. 0 ) THEN
C ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
C ** IS A MULTIPLE OF 3.
DO 20 I = 1, M
STEMP1 = SX(I)
SX(I) = SY(I)
SY(I) = STEMP1
20 CONTINUE
ENDIF
C ** UNROLL LOOP FOR SPEED
DO 30 I = M+1, N, 3
STEMP1 = SX(I)
STEMP2 = SX(I+1)
STEMP3 = SX(I+2)
SX(I) = SY(I)
SX(I+1) = SY(I+1)
SX(I+2) = SY(I+2)
SY(I) = STEMP1
SY(I+1) = STEMP2
SY(I+2) = STEMP3
30 CONTINUE
ELSE
C ** NONEQUAL OR NONPOSITIVE INCREMENTS.
IX = 1
IY = 1
IF( INCX.LT.0 ) IX = 1 + (N-1)*(-INCX)
IF( INCY.LT.0 ) IY = 1 + (N-1)*(-INCY)
DO 40 I = 1, N
STEMP1 = SX(IX)
SX(IX) = SY(IY)
SY(IY) = STEMP1
IX = IX + INCX
IY = IY + INCY
40 CONTINUE
ENDIF
RETURN
END
c INTEGER FUNCTION ISAMAX( N, SX, INCX )
C ##############################
FUNCTION ISAMAX( N, SX, INCX )
C ##############################
C --INPUT-- N NUMBER OF ELEMENTS IN VECTOR OF INTEREST
C SX SING-PREC ARRAY, LENGTH 1+(N-1)*INCX, CONTAINING VECTOR
C INCX SPACING OF VECTOR ELEMENTS IN 'SX'
C --OUTPUT-- ISAMAX FIRST I, I = 1 TO N, TO MAXIMIZE
C ABS(SX(1+(I-1)*INCX))
IMPLICIT NONE
INTEGER ISAMAX, N, INCX
REAL SX(*), SMAX, XMAG
INTEGER II, I
IF( N.LE.0 ) THEN
ISAMAX = 0
ELSE IF( N.EQ.1 ) THEN
ISAMAX = 1
ELSE
SMAX = 0.0
II = 1
DO 20 I = 1, 1+(N-1)*INCX, INCX
XMAG = ABS(SX(I))
IF( SMAX.LT.XMAG ) THEN
SMAX = XMAG
ISAMAX = II
ENDIF
II = II + 1
20 CONTINUE
ENDIF
RETURN
END
C ##############################
FUNCTION D1MACH(i)
C ##############################
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= D1MACH calculates various machine constants in single precision. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= I - INTEGER, identifies the machine constant (0<I<5) (I) =*
*= D1MACH - REAL, machine constant in single precision (O) =*
*= I=1 - the smallest non-vanishing normalized floating-point =*
*= power of the radix, i.e., D1MACH=FLOAT(IBETA)**MINEXP =*
*= I=2 - the largest finite floating-point number. In =*
*= particular D1MACH=(1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP =*
*= Note - on some machines D1MACH will be only the =*
*= second, or perhaps third, largest number, being =*
*= too small by 1 or 2 units in the last digit of =*
*= the significand. =*
*= I=3 - A small positive floating-point number such that =*
*= 1.0-D1MACH .NE. 1.0. In particular, if IBETA = 2 =*
*= or IRND = 0, D1MACH = FLOAT(IBETA)**NEGEPS. =*
*= Otherwise, D1MACH = (IBETA**NEGEPS)/2. Because =*
*= NEGEPS is bounded below by -(IT+3), D1MACH may not =*
*= be the smallest number that can alter 1.0 by =*
*= subtraction. =*
*= I=4 - the smallest positive floating-point number such =*
*= that 1.0+D1MACH .NE. 1.0. In particular, if either =*
*= IBETA = 2 or IRND = 0, D1MACH=FLOAT(IBETA)**MACHEP. =*
*= Otherwise, D1MACH=(FLOAT(IBETA)**MACHEP)/2 =*
*= (see routine T665D for more information on different constants) =*
*-----------------------------------------------------------------------------*
EXTERNAL t665d
REAL(kind(0.0d0)) :: d1mach
INTEGER i
LOGICAL doinit
DATA doinit/.TRUE./
SAVE doinit
REAL(kind(0.0d0)) :: dmach(4)
SAVE dmach
IF (( i .GE. 1 ) .AND. ( i .LE. 4 )) THEN
* compute constants at first call only
IF (doinit) THEN
CALL t665d(dmach)
doinit = .FALSE.
ENDIF
d1mach = dmach(i)
ELSE
WRITE(0,*) '>>> ERROR (D1MACH) <<< invalid argument'
STOP
ENDIF
*!csm
*!!! over-ride by sm on 5/26/03. For some compilers than don't allow
* calculation of d1mach(4). Use value found on ACD server.
c if( i .eq. 4) d1mach = 2.22e-15
END
C ALGORITHM 665, COLLECTED ALGORITHMS FROM ACM.
C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C VOL. 14, NO. 4, PP. 303-311.
SUBROUTINE T665D(DMACH)
C-----------------------------------------------------------------------
C This subroutine is a double precision version of subroutine T665R.
C See code of T665R for detailed comments and explanation
C-----------------------------------------------------------------------
REAL(kind(0.0d0)) :: DMACH(4)
INTEGER I,IBETA,IEXP,IRND,IT,ITEMP,IZ,J,K,MACHEP,MAXEXP,
1 MINEXP,MX,NEGEP,NGRD,NXRES
CS REAL A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA,
CS 1 TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO
REAL(kind(0.0d0)) :: A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,
1 T,TEMP,TEMPA,TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO
C-----------------------------------------------------------------------
CS CONV(I) = REAL(I)
CONV(I) = DBLE(I)
ONE = CONV(1)
TWO = ONE + ONE
ZERO = ONE - ONE
C-----------------------------------------------------------------------
C Determine IBETA, BETA ala Malcolm.
C-----------------------------------------------------------------------
A = ONE
10 A = A + A
TEMP = A+ONE
TEMP1 = TEMP-A
IF (TEMP1-ONE .EQ. ZERO) GO TO 10
B = ONE
20 B = B + B
TEMP = A+B
ITEMP = INT(TEMP-A)
IF (ITEMP .EQ. 0) GO TO 20
IBETA = ITEMP
BETA = CONV(IBETA)
C-----------------------------------------------------------------------
C Determine IT, IRND.
C-----------------------------------------------------------------------
IT = 0
B = ONE
100 IT = IT + 1
B = B * BETA
TEMP = B+ONE
TEMP1 = TEMP-B
IF (TEMP1-ONE .EQ. ZERO) GO TO 100
IRND = 0
BETAH = BETA / TWO
TEMP = A+BETAH
IF (TEMP-A .NE. ZERO) IRND = 1
TEMPA = A + BETA
TEMP = TEMPA+BETAH
IF ((IRND .EQ. 0) .AND. (TEMP-TEMPA .NE. ZERO)) IRND = 2
C-----------------------------------------------------------------------
C Determine NEGEP, EPSNEG.
C-----------------------------------------------------------------------
NEGEP = IT + 3
BETAIN = ONE / BETA
A = ONE
DO 200 I = 1, NEGEP
A = A * BETAIN
200 CONTINUE
B = A
210 TEMP = ONE-A
IF (TEMP-ONE .NE. ZERO) GO TO 220
A = A * BETA
NEGEP = NEGEP - 1
GO TO 210
220 NEGEP = -NEGEP
EPSNEG = A
IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 300
A = (A*(ONE+A)) / TWO
TEMP = ONE-A
IF (TEMP-ONE .NE. ZERO) EPSNEG = A
C-----------------------------------------------------------------------
C Determine MACHEP, EPS.
C-----------------------------------------------------------------------
300 MACHEP = -IT - 3
A = B
310 TEMP = ONE+A
IF (TEMP-ONE .NE. ZERO) GO TO 320
A = A * BETA
MACHEP = MACHEP + 1
GO TO 310
320 EPS = A
TEMP = TEMPA+BETA*(ONE+EPS)
IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 350
A = (A*(ONE+A)) / TWO
TEMP = ONE+A
IF (TEMP-ONE .NE. ZERO) EPS = A
C-----------------------------------------------------------------------
C Determine NGRD.
C-----------------------------------------------------------------------
350 NGRD = 0
TEMP = ONE+EPS
IF ((IRND .EQ. 0) .AND. (TEMP*ONE-ONE .NE. ZERO)) NGRD = 1
C-----------------------------------------------------------------------
C Determine IEXP, MINEXP, XMIN.
C
C Loop to determine largest I and K = 2**I such that
C (1/BETA) ** (2**(I))
C does not underflow.
C Exit from loop is signaled by an underflow.
C-----------------------------------------------------------------------
I = 0
K = 1
Z = BETAIN
T = ONE + EPS
NXRES = 0
400 Y = Z
Z = Y * Y
C-----------------------------------------------------------------------
C Check for underflow here.
C-----------------------------------------------------------------------
A = Z * ONE
TEMP = Z * T
IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410
TEMP1 = TEMP * BETAIN
IF (TEMP1*BETA .EQ. Z) GO TO 410
I = I + 1
K = K + K
GO TO 400
410 IF (IBETA .EQ. 10) GO TO 420
IEXP = I + 1
MX = K + K
GO TO 450
C-----------------------------------------------------------------------
C This segment is for decimal machines only.
C-----------------------------------------------------------------------
420 IEXP = 2
IZ = IBETA
430 IF (K .LT. IZ) GO TO 440
IZ = IZ * IBETA
IEXP = IEXP + 1
GO TO 430
440 MX = IZ + IZ - 1
C-----------------------------------------------------------------------
C Loop to determine MINEXP, XMIN.
C Exit from loop is signaled by an underflow.
C-----------------------------------------------------------------------
450 XMIN = Y
Y = Y * BETAIN
C-----------------------------------------------------------------------
C Check for underflow here.
C-----------------------------------------------------------------------
A = Y * ONE
TEMP = Y * T
IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460
K = K + 1
TEMP1 = TEMP * BETAIN
IF (TEMP1*BETA .NE. Y) GO TO 450
NXRES = 3
XMIN = Y
460 MINEXP = -K
C-----------------------------------------------------------------------
C Determine MAXEXP, XMAX.
C-----------------------------------------------------------------------
IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500
MX = MX + MX
IEXP = IEXP + 1
500 MAXEXP = MX + MINEXP
C-----------------------------------------------------------------
C Adjust IRND to reflect partial underflow.
C-----------------------------------------------------------------
IRND = IRND + NXRES
C-----------------------------------------------------------------
C Adjust for IEEE-style machines.
C-----------------------------------------------------------------
IF ((IRND .EQ. 2) .OR. (IRND .EQ. 5)) MAXEXP = MAXEXP - 2
C-----------------------------------------------------------------
C Adjust for non-IEEE machines with partial underflow.
C-----------------------------------------------------------------
IF ((IRND .EQ. 3) .OR. (IRND .EQ. 4)) MAXEXP = MAXEXP - IT
C-----------------------------------------------------------------
C Adjust for machines with implicit leading bit in binary
C significand, and machines with radix point at extreme
C right of significand.
C-----------------------------------------------------------------
I = MAXEXP + MINEXP
IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1
IF (I .GT. 20) MAXEXP = MAXEXP - 1
IF (A .NE. Y) MAXEXP = MAXEXP - 2
XMAX = ONE - EPSNEG
IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG
XMAX = XMAX / (BETA * BETA * BETA * XMIN)
I = MAXEXP + MINEXP + 3
IF (I .LE. 0) GO TO 520
DO 510 J = 1, I
IF (IBETA .EQ. 2) XMAX = XMAX + XMAX
IF (IBETA .NE. 2) XMAX = XMAX * BETA
510 CONTINUE
DMACH(1) = XMIN
DMACH(2) = XMAX
DMACH(3) = EPSNEG
DMACH(4) = EPS
520 RETURN
C---------- LAST CARD OF T665D ----------
END
FUNCTION R1MACH(i)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= R1MACH calculates various machine constants in single precision. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= I - INTEGER, identifies the machine constant (0<I<5) (I) =*
*= R1MACH - REAL, machine constant in single precision (O) =*
*= I=1 - the smallest non-vanishing normalized floating-point =*
*= power of the radix, i.e., R1MACH=FLOAT(IBETA)**MINEXP =*
*= I=2 - the largest finite floating-point number. In =*
*= particular R1MACH=(1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP =*
*= Note - on some machines R1MACH will be only the =*
*= second, or perhaps third, largest number, being =*
*= too small by 1 or 2 units in the last digit of =*
*= the significand. =*
*= I=3 - A small positive floating-point number such that =*
*= 1.0-R1MACH .NE. 1.0. In particular, if IBETA = 2 =*
*= or IRND = 0, R1MACH = FLOAT(IBETA)**NEGEPS. =*
*= Otherwise, R1MACH = (IBETA**NEGEPS)/2. Because =*
*= NEGEPS is bounded below by -(IT+3), R1MACH may not =*
*= be the smallest number that can alter 1.0 by =*
*= subtraction. =*
*= I=4 - the smallest positive floating-point number such =*
*= that 1.0+R1MACH .NE. 1.0. In particular, if either =*
*= IBETA = 2 or IRND = 0, R1MACH=FLOAT(IBETA)**MACHEP. =*
*= Otherwise, R1MACH=(FLOAT(IBETA)**MACHEP)/2 =*
*= (see routine T665R for more information on different constants) =*
*-----------------------------------------------------------------------------*
REAL r1mach
INTEGER i
LOGICAL doinit
DATA doinit/.TRUE./
SAVE doinit
REAL rmach(4)
SAVE rmach
IF (( i .GE. 1 ) .AND. ( i .LE. 4 )) THEN
* compute constants at first call only
IF (doinit) THEN
CALL t665r(rmach)
doinit = .FALSE.
ENDIF
r1mach = rmach(i)
ELSE
WRITE(0,*) '>>> ERROR (R1MACH) <<< invalid argument'
STOP
ENDIF
END
C ALGORITHM 665, COLLECTED ALGORITHMS FROM ACM.
C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C VOL. 14, NO. 4, PP. 303-311.
SUBROUTINE T665R(RMACH)
C-----------------------------------------------------------------------
C This Fortran 77 subroutine is intended to determine the parameters
C of the floating-point arithmetic system specified below. The
C determination of the first three uses an extension of an algorithm
C due to M. Malcolm, CACM 15 (1972), pp. 949-951, incorporating some,
C but not all, of the improvements suggested by M. Gentleman and S.
C Marovich, CACM 17 (1974), pp. 276-277. An earlier version of this
C program was published in the book Software Manual for the
C Elementary Functions by W. J. Cody and W. Waite, Prentice-Hall,
C Englewood Cliffs, NJ, 1980.
C
C The program as given here must be modified before compiling. If
C a single (double) precision version is desired, change all
C occurrences of CS (CD) in columns 1 and 2 to blanks.
C
C Parameter values reported are as follows:
C
C IBETA - the radix for the floating-point representation
C IT - the number of base IBETA digits in the floating-point
C significand
C IRND - 0 if floating-point addition chops
C 1 if floating-point addition rounds, but not in the
C IEEE style
C 2 if floating-point addition rounds in the IEEE style
C 3 if floating-point addition chops, and there is
C partial underflow
C 4 if floating-point addition rounds, but not in the
C IEEE style, and there is partial underflow
C 5 if floating-point addition rounds in the IEEE style,
C and there is partial underflow
C NGRD - the number of guard digits for multiplication with
C truncating arithmetic. It is
C 0 if floating-point arithmetic rounds, or if it
C truncates and only IT base IBETA digits
C participate in the post-normalization shift of the
C floating-point significand in multiplication;
C 1 if floating-point arithmetic truncates and more
C than IT base IBETA digits participate in the
C post-normalization shift of the floating-point
C significand in multiplication.
C MACHEP - the largest negative integer such that
C 1.0+FLOAT(IBETA)**MACHEP .NE. 1.0, except that
C MACHEP is bounded below by -(IT+3)
C NEGEPS - the largest negative integer such that
C 1.0-FLOAT(IBETA)**NEGEPS .NE. 1.0, except that
C NEGEPS is bounded below by -(IT+3)
C IEXP - the number of bits (decimal places if IBETA = 10)
C reserved for the representation of the exponent
C (including the bias or sign) of a floating-point
C number
C MINEXP - the largest in magnitude negative integer such that
C FLOAT(IBETA)**MINEXP is positive and normalized
C MAXEXP - the smallest positive power of BETA that overflows
C EPS - the smallest positive floating-point number such
C that 1.0+EPS .NE. 1.0. In particular, if either
C IBETA = 2 or IRND = 0, EPS = FLOAT(IBETA)**MACHEP.
C Otherwise, EPS = (FLOAT(IBETA)**MACHEP)/2
C EPSNEG - A small positive floating-point number such that
C 1.0-EPSNEG .NE. 1.0. In particular, if IBETA = 2
C or IRND = 0, EPSNEG = FLOAT(IBETA)**NEGEPS.
C Otherwise, EPSNEG = (IBETA**NEGEPS)/2. Because
C NEGEPS is bounded below by -(IT+3), EPSNEG may not
C be the smallest number that can alter 1.0 by
C subtraction.
C XMIN - the smallest non-vanishing normalized floating-point
C power of the radix, i.e., XMIN = FLOAT(IBETA)**MINEXP
C XMAX - the largest finite floating-point number. In
C particular XMAX = (1.0-EPSNEG)*FLOAT(IBETA)**MAXEXP
C Note - on some machines XMAX will be only the
C second, or perhaps third, largest number, being
C too small by 1 or 2 units in the last digit of
C the significand.
C
C Latest revision - April 20, 1987
C
C Author - W. J. Cody
C Argonne National Laboratory
C
C-----------------------------------------------------------------------
REAL rmach(4)
INTEGER I,IBETA,IEXP,IRND,IT,ITEMP,IZ,J,K,MACHEP,MAXEXP,
1 MINEXP,MX,NEGEP,NGRD,NXRES
REAL A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA,
1 TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO
CD REAL A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,
CD 1 T,TEMP,TEMPA,TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO
C-----------------------------------------------------------------------
CONV(I) = REAL(I)
CD CONV(I) = DBLE(I)
ONE = CONV(1)
TWO = ONE + ONE
ZERO = ONE - ONE
C-----------------------------------------------------------------------
C Determine IBETA, BETA ala Malcolm.
C-----------------------------------------------------------------------
A = ONE
10 A = A + A
TEMP = A+ONE
TEMP1 = TEMP-A
IF (TEMP1-ONE .EQ. ZERO) GO TO 10
B = ONE
20 B = B + B
TEMP = A+B
ITEMP = INT(TEMP-A)
IF (ITEMP .EQ. 0) GO TO 20
IBETA = ITEMP
BETA = CONV(IBETA)
C-----------------------------------------------------------------------
C Determine IT, IRND.
C-----------------------------------------------------------------------
IT = 0
B = ONE
100 IT = IT + 1
B = B * BETA
TEMP = B+ONE
TEMP1 = TEMP-B
IF (TEMP1-ONE .EQ. ZERO) GO TO 100
IRND = 0
BETAH = BETA / TWO
TEMP = A+BETAH
IF (TEMP-A .NE. ZERO) IRND = 1
TEMPA = A + BETA
TEMP = TEMPA+BETAH
IF ((IRND .EQ. 0) .AND. (TEMP-TEMPA .NE. ZERO)) IRND = 2
C-----------------------------------------------------------------------
C Determine NEGEP, EPSNEG.
C-----------------------------------------------------------------------
NEGEP = IT + 3
BETAIN = ONE / BETA
A = ONE
DO 200 I = 1, NEGEP
A = A * BETAIN
200 CONTINUE
B = A
210 TEMP = ONE-A
IF (TEMP-ONE .NE. ZERO) GO TO 220
A = A * BETA
NEGEP = NEGEP - 1
GO TO 210
220 NEGEP = -NEGEP
EPSNEG = A
IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 300
A = (A*(ONE+A)) / TWO
TEMP = ONE-A
IF (TEMP-ONE .NE. ZERO) EPSNEG = A
C-----------------------------------------------------------------------
C Determine MACHEP, EPS.
C-----------------------------------------------------------------------
300 MACHEP = -IT - 3
A = B
310 TEMP = ONE+A
IF (TEMP-ONE .NE. ZERO) GO TO 320
A = A * BETA
MACHEP = MACHEP + 1
GO TO 310
320 EPS = A
TEMP = TEMPA+BETA*(ONE+EPS)
IF ((IBETA .EQ. 2) .OR. (IRND .EQ. 0)) GO TO 350
A = (A*(ONE+A)) / TWO
TEMP = ONE+A
IF (TEMP-ONE .NE. ZERO) EPS = A
C-----------------------------------------------------------------------
C Determine NGRD.
C-----------------------------------------------------------------------
350 NGRD = 0
TEMP = ONE+EPS
IF ((IRND .EQ. 0) .AND. (TEMP*ONE-ONE .NE. ZERO)) NGRD = 1
C-----------------------------------------------------------------------
C Determine IEXP, MINEXP, XMIN.
C
C Loop to determine largest I and K = 2**I such that
C (1/BETA) ** (2**(I))
C does not underflow.
C Exit from loop is signaled by an underflow.
C-----------------------------------------------------------------------
I = 0
K = 1
Z = BETAIN
T = ONE + EPS
NXRES = 0
400 Y = Z
Z = Y * Y
C-----------------------------------------------------------------------
C Check for underflow here.
C-----------------------------------------------------------------------
A = Z * ONE
TEMP = Z * T
IF ((A+A .EQ. ZERO) .OR. (ABS(Z) .GE. Y)) GO TO 410
TEMP1 = TEMP * BETAIN
IF (TEMP1*BETA .EQ. Z) GO TO 410
I = I + 1
K = K + K
GO TO 400
410 IF (IBETA .EQ. 10) GO TO 420
IEXP = I + 1
MX = K + K
GO TO 450
C-----------------------------------------------------------------------
C This segment is for decimal machines only.
C-----------------------------------------------------------------------
420 IEXP = 2
IZ = IBETA
430 IF (K .LT. IZ) GO TO 440
IZ = IZ * IBETA
IEXP = IEXP + 1
GO TO 430
440 MX = IZ + IZ - 1
C-----------------------------------------------------------------------
C Loop to determine MINEXP, XMIN.
C Exit from loop is signaled by an underflow.
C-----------------------------------------------------------------------
450 XMIN = Y
Y = Y * BETAIN
C-----------------------------------------------------------------------
C Check for underflow here.
C-----------------------------------------------------------------------
A = Y * ONE
TEMP = Y * T
IF (((A+A) .EQ. ZERO) .OR. (ABS(Y) .GE. XMIN)) GO TO 460
K = K + 1
TEMP1 = TEMP * BETAIN
IF (TEMP1*BETA .NE. Y) GO TO 450
NXRES = 3
XMIN = Y
460 MINEXP = -K
C-----------------------------------------------------------------------
C Determine MAXEXP, XMAX.
C-----------------------------------------------------------------------
IF ((MX .GT. K+K-3) .OR. (IBETA .EQ. 10)) GO TO 500
MX = MX + MX
IEXP = IEXP + 1
500 MAXEXP = MX + MINEXP
C-----------------------------------------------------------------
C Adjust IRND to reflect partial underflow.
C-----------------------------------------------------------------
IRND = IRND + NXRES
C-----------------------------------------------------------------
C Adjust for IEEE-style machines.
C-----------------------------------------------------------------
IF ((IRND .EQ. 2) .OR. (IRND .EQ. 5)) MAXEXP = MAXEXP - 2
C-----------------------------------------------------------------
C Adjust for non-IEEE machines with partial underflow.
C-----------------------------------------------------------------
IF ((IRND .EQ. 3) .OR. (IRND .EQ. 4)) MAXEXP = MAXEXP - IT
C-----------------------------------------------------------------
C Adjust for machines with implicit leading bit in binary
C significand, and machines with radix point at extreme
C right of significand.
C-----------------------------------------------------------------
I = MAXEXP + MINEXP
IF ((IBETA .EQ. 2) .AND. (I .EQ. 0)) MAXEXP = MAXEXP - 1
IF (I .GT. 20) MAXEXP = MAXEXP - 1
IF (A .NE. Y) MAXEXP = MAXEXP - 2
XMAX = ONE - EPSNEG
IF (XMAX*ONE .NE. XMAX) XMAX = ONE - BETA * EPSNEG
XMAX = XMAX / (BETA * BETA * BETA * XMIN)
I = MAXEXP + MINEXP + 3
IF (I .LE. 0) GO TO 520
DO 510 J = 1, I
IF (IBETA .EQ. 2) XMAX = XMAX + XMAX
IF (IBETA .NE. 2) XMAX = XMAX * BETA
510 CONTINUE
RMACH(1) = XMIN
RMACH(2) = XMAX
RMACH(3) = EPSNEG
RMACH(4) = EPS
520 RETURN
C---------- LAST CARD OF T665R ----------
END
CCC FILE rxn.f
* This file contains the following subroutines, related to reading/loading
* the product (cross section) x (quantum yield) for photo-reactions:
* r01 through r47
* r101 through r148
* r149, r150, r151 and r152 added from original TUV code
*=============================================================================*
SUBROUTINE r01(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product of (cross section) x (quantum yield) for the two =*
*= O3 photolysis reactions: =*
*= (a) O3 + hv -> O2 + O(1D) =*
*= (b) O3 + hv -> O2 + O(3P) =*
*= Cross section: Combined data from WMO 85 Ozone Assessment (use 273K =*
*= value from 175.439-847.5 nm) and data from Molina and =*
*= Molina (use in Hartley and Huggins bans (240.5-350 nm) =*
*= Quantum yield: Choice between =*
*= (1) data from Michelsen et al, 1994 =*
*= (2) JPL 87 recommendation =*
*= (3) JPL 90/92 recommendation (no "tail") =*
*= (4) data from Shetter et al., 1996 =*
*= (5) JPL 97 recommendation =*
*= (6) JPL 00 recommendation =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER n1, n2, n3, n4, n5
INTEGER kdata
PARAMETER (kdata = 500)
REAL x1(kdata), x2(kdata), x3(kdata), x4(kdata)
REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata)
* local
INTEGER mabs
REAL xs(kz,kw)
REAL yg(kw), yg1(kw), yg2(kw), yg3(kw), yg4(kw)
REAL qy1d, qy3p
REAL tau, tau2, tau3
REAL a, b, c
REAL a0, a1, a2, a3, a4, a5, a6, a7
REAL xl, xl0
REAL so3
REAL dum
INTEGER myld
INTEGER kmich, kjpl87, kjpl92, kshet, kjpl97, kjpl00, kmats
INTEGER i, iw, n, idum
INTEGER ierr
REAL fo3qy, fo3qy2
EXTERNAL fo3qy, fo3qy2
****************************************************************
************* jlabel(j) = 'O3 -> O2 + O(1D)'
************* jlabel(j) = 'O3 -> O2 + O(3P)'
j = j + 1
jlabel(j) = 'O3 -> O2 + O(1D)'
j = j + 1
jlabel(j) = 'O3 -> O2 + O(3P)'
* call cross section read/interpolate routine
* cross sections from WMO 1985 Ozone Assessment
* from 175.439 to 847.500 nm. Using value at 273 K.
* Values are over-written in Hartly and Huggins bands, using different
* options depending on value of mopt:
* mabs = 1 = mostly Reims grp (Malicet, Brion)
* mabs = 2 = JPL 2006
mabs = 1
CALL rdo3xs(mabs, nz,tlev,nw,wl, xs, kout)
******* quantum yield:
kmich = 1
kjpl87 = 2
kjpl92 = 3
kshet = 4
kjpl97 = 5
kjpl00 = 6
kmats = 7
* choose quantum yield recommendation:
* kjpl87: JPL recommendation 1987 - JPL 87, 90, 92 do not "tail"
* kjpl92: JPL recommendations 1990/92 (identical) - still with no "tail"
* kjpl97: JPL recommendation 1997, includes tail, similar to Shetter et al.
* kmich : Michelsen et al., 1994
* kshet : Shetter et al., 1996
* kjpl00: JPL 2000
* kmats: Matsumi et al., 2002
c myld = kjpl87
c myld = kjpl92
c myld = kshet
c myld = kmich
c myld = kjpl97
c myld = kjpl00
myld = kmats
* read parameters from JPL'97
IF (myld .EQ. kjpl97) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/YLD/O3.param_jpl97.yld',
& STATUS='old')
READ(UNIT=ilu,FMT=*)
READ(UNIT=ilu,FMT=*)
READ(UNIT=ilu,FMT=*)
n1 = 21
n2 = n1
DO i = 1, n1
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
x2(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n1, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),y1(n1))
CALL addpnt(x1,y1,kdata,n1, 1.e+38,y1(n1))
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),y2(1))
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),y2(n2))
CALL addpnt(x2,y2,kdata,n2, 1.e+38,y2(n2))
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* read parameters from Michelsen, H. A., R.J. Salawitch, P. O. Wennber,
* and J. G. Anderson, Geophys. Res. Lett., 21, 2227-2230, 1994.
IF (myld .EQ. kmich) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/YLD/O3.param.yld',STATUS='old')
READ(UNIT=ilu,FMT=*)
READ(UNIT=ilu,FMT=*)
READ(UNIT=ilu,FMT=*)
n1 = 21
n2 = n1
DO i = 1, n1
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
x2(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n1, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),y1(n1))
CALL addpnt(x1,y1,kdata,n1, 1.e+38,y1(n1))
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),y2(1))
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),y2(n2))
CALL addpnt(x2,y2,kdata,n2, 1.e+38,y2(n2))
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yield data from
* Shetter et al, J.Geophys.Res., v 101 (D9), pg. 14,631-14,641, June 20, 1996
IF (myld .EQ. kshet) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/YLD/O3_shetter.yld',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
n = n-2
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i),y3(i),y4(i),y1(i),y2(i)
x2(i) = x1(i)
x3(i) = x1(i)
x4(i) = x1(i)
ENDDO
DO i = n+1, n+2
READ(UNIT=ilu,FMT=*) x3(i),y3(i),y4(i)
x4(i) = x3(i)
ENDDO
CLOSE(UNIT=ilu)
n1 = n
n2 = n
n3 = n+2
n4 = n+2
* coefficients for exponential fit:
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax), y1(1))
CALL addpnt(x1,y1,kdata,n1, 0., y1(1))
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
CALL inter2(nw,wl,yg1, n1,x1,y1, ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),y2(1))
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
CALL inter2(nw,wl,yg2, n2,x2,y2, ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* phi data at 298 and 230 K
CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),y3(1))
CALL addpnt(x3,y3,kdata,n3, 0.,y3(1))
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1E38,0.)
CALL inter2(nw,wl,yg3, n3,x3,y3, ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr,jlabel(j)
STOP
ENDIF
CALL addpnt(x4,y4,kdata,n4,x4(1)*(1.-deltax),y4(1))
CALL addpnt(x4,y4,kdata,n4, 0.,y4(1))
CALL addpnt(x4,y4,kdata,n4,x4(n4)*(1.+deltax),0.)
CALL addpnt(x4,y4,kdata,n4, 1E38,0.)
CALL inter2(nw,wl,yg4, n4,x4,y4, ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr,jlabel(j)
STOP
ENDIF
ENDIF
* compute cross sections and yields at different wavelengths, altitudes:
DO 10 iw = 1, nw-1
DO 20 i = 1, nz
* quantum yields
* coefficients from jpl 87:
IF (myld .EQ. kjpl87) THEN
tau = tlev(i) - 230.
tau2 = tau*tau
tau3 = tau2*tau
xl = wc(iw)
xl0 = 308.2 + 4.4871e-2*tau + 6.938e-5*tau2 -
> 2.5452e-6*tau3
a = 0.9*(0.369 + 2.85e-4*tau + 1.28e-5*tau2 +
> 2.57e-8*tau3)
b = -0.575 + 5.59e-3*tau - 1.439e-5*tau2 -
> 3.27e-8*tau3
c = 0.9*(0.518 + 9.87e-4*tau - 3.94e-5*tau2 +
> 3.91e-7*tau3)
qy1d = a*atan(b*(xl-xl0)) + c
qy1d = amax1(0.,qy1d)
qy1d = amin1(0.9,qy1d)
ENDIF
* from jpl90, jpl92:
* (caution: error in JPL92 for first term of a3)
IF (myld .EQ. kjpl92) THEN
tau = 298. - tlev(i)
tau2 = tau*tau
xl0 = wc(iw) - 305.
a0 = .94932 - 1.7039e-4*tau + 1.4072E-6*tau2
a1 = -2.4052e-2 + 1.0479e-3*tau - 1.0655e-5*tau2
a2 = 1.8771e-2 - 3.6401e-4*tau - 1.8587e-5*tau2
a3 = -1.4540e-2 - 4.7787e-5*tau + 8.1277e-6*tau2
a4 = 2.3287e-3 + 1.9891e-5*tau - 1.1801e-6*tau2
a5 = -1.4471e-4 - 1.7188e-6*tau + 7.2661e-8*tau2
a6 = 3.1830e-6 + 4.6209e-8*tau - 1.6266e-9*tau2
qy1d = a0 + a1*xl0 + a2*(xl0)**2 + a3*(xl0)**3 +
> a4*(xl0)**4 + a5*(xl0)**5 + a6*(xl0)**6
IF (wc(iw) .LT. 305.) qy1d = 0.95
IF (wc(iw) .GT. 320.) qy1d = 0.
IF (qy1d .LT. 0.02) qy1d = 0.
ENDIF
* from JPL'97
IF (myld .EQ. kjpl97) THEN
IF (wc(iw) .LT. 271.) THEN
qy1d = 0.87
ELSE IF (wc(iw) .GE. 271. .AND. wc(iw) .LT. 290.) THEN
qy1d = 0.87 + (wc(iw)-271.)*(.95-.87)/(290.-271.)
ELSE IF (wc(iw) .GE. 290. .AND. wc(iw) .LT. 305.) THEN
qy1d = 0.95
ELSE IF (wc(iw) .GE. 305. .AND. wc(iw) .LE. 325.) THEN
qy1d = yg1(iw) * EXP ( -yg2(iw) /tlev(i) )
ELSE
qy1d = 0.
ENDIF
ENDIF
* from Michelsen, H. A., R.J. Salawitch, P. O. Wennber, and J. G. Anderson
* Geophys. Res. Lett., 21, 2227-2230, 1994.
IF (myld .EQ. kmich) THEN
IF (wc(iw) .LT. 271.) THEN
qy1d = 0.87
ELSE IF (wc(iw) .GE. 271. .AND. wc(iw) .LT. 305.) THEN
qy1d = 1.98 - 301./wc(iw)
ELSE IF (wc(iw) .GE. 305. .AND. wc(iw) .LE. 325.) THEN
qy1d = yg1(iw) * EXP (-yg2(iw) /(0.6951*tlev(i)))
ELSE
qy1d = 0.
ENDIF
ENDIF
* Shetter et al.:
* phi = A * exp(-B/T), A and B are based on meas. at 298 and 230 K
* do linear interpolation between phi(298) and phi(230) for wavelengths > 321
* as phi(230)=0. for those wavelengths, so there are no A and B factors
IF (myld .EQ. kshet) THEN
IF (wl(iw+1) .LE. 321.) THEN
qy1d = yg1(iw) * EXP(-1. * yg2(iw)/tlev(i))
ELSE
qy1d = (yg3(iw) - yg4(iw))/(298.-230.) * (tlev(i)-230.) +
> yg4(iw)
ENDIF
ENDIF
* JPL 2000:
IF (myld .EQ. kjpl00) THEN
qy1d = fo3qy(wc(iw),tlev(i))
ENDIF
* Matsumi et al.
IF (myld .EQ. kmats) THEN
qy1d = fo3qy2(wc(iw),tlev(i))
ENDIF
* compute product
sq(j-1,i,iw) = qy1d*xs(i,iw)
qy3p = 1.0 - qy1d
sq(j,i,iw) = qy3p*xs(i,iw)
20 CONTINUE
10 CONTINUE
* declare temperature dependence
tpflag(j-1) = 1
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r02(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for NO2 =*
*= photolysis: =*
*= NO2 + hv -> NO + O(3P) =*
*= Cross section from JPL94 (can also have Davidson et al.) =*
*= Quantum yield from Gardiner, Sperry, and Calvert =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw, iw
REAL wl(kw), wc(kw)
INTEGER nz, iz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
INTEGER n1, n2
REAL x1(kdata), x2(kdata), x3(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg1(kw), yg2(kw)
REAL no2xs(kz,kw), qy(kz,kw)
REAL dum, dum1, dum2
INTEGER i, n, idum, ierr
INTEGER mabs, myld
**************** NO2 photodissociation
j = j + 1
jlabel(j) = 'NO2 -> NO + O(3P)'
* options for NO2 cross section:
* 1 = Davidson et al. (1988), indepedent of T
* 2 = JPL 1994 (same as JPL 1997, JPL 2002)
* 3 = Harder et al.
* 4 = JPL 2006, interpolating between midpoints of bins
* 5 = JPL 2006, bin-to-bin interpolation
mabs = 4
IF (mabs. EQ. 1) CALL no2xs_d(nz,tlev,nw,wl, no2xs, kout)
IF (mabs .EQ. 2) CALL no2xs_jpl94(nz,tlev,nw,wl, no2xs, kout)
IF (mabs .EQ. 3) CALL no2xs_har(nz,tlev,nw,wl, no2xs, kout)
IF (mabs .EQ. 4) CALL no2xs_jpl06a(nz,tlev,nw,wl, no2xs, kout)
IF (mabs .EQ. 5) CALL no2xs_jpl06b(nz,tlev,nw,wl, no2xs, kout)
* quantum yields
* myld = 1 NO2_calvert.yld (same as JPL2002)
* myld = 2 NO2_jpl2006.yld
myld = 2
IF (myld .EQ. 1) THEN
* from Gardiner, Sperry, and Calvert
OPEN(NEWUNIT=ilu,FILE='DATAJ1/YLD/NO2_calvert.yld',STATUS='old')
DO i = 1, 8
READ(UNIT=ilu,FMT=*)
ENDDO
n = 66
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i),y1(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
do iw = 1, nw - 1
do iz = 1, nz
qy(iz,iw) = yg1(iw)
enddo
enddo
else if(myld. eq. 2) then
* from jpl 2011
OPEN(NEWUNIT=ilu,FILE='DATAJ1/YLD/NO2_jpl11.yld',STATUS='old')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 25
n2 = n
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i),y1(i),y2(i)
x2(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),y2(1))
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax), 0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38, 0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
DO iw = 1, nw - 1
DO iz = 1, nz
qy(iz,iw) = yg1(iw) +
$ (yg1(iw)-yg2(iw)) * (tlev(iz)-298)/50.
qy(iz,iw) = amax1(qy(iz,iw),0.)
ENDDO
ENDDO
ENDIF
* combine
DO iw = 1, nw - 1
DO iz = 1, nz
sq(j,iz,iw) = no2xs(iz,iw)*qy(iz,iw)
ENDDO
ENDDO
* declare temperature dependence
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r03(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (absorptioon cross section) x (quantum yield) for =*
*= both channels of NO3 photolysis: =*
*= (a) NO3 + hv -> NO2 + O(3P) =*
*= (b) NO3 + hv -> NO + O2 =*
*= Cross section combined from Graham and Johnston (<600 nm) and JPL 94 =*
*= Quantum yield from Madronich (1988) =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=350)
REAL x(kdata), x1(kdata)
REAL y1(kdata)
real q1_298(kdata), q1_230(kdata), q1_190(kdata)
real q2_298(kdata), q2_230(kdata), q2_190(kdata)
* local
REAL yg(kw), yg1(kw)
REAL qy,qy1, qy2
real yg1_298(kw), yg1_230(kw), yg1_190(kw)
real yg2_298(kw), yg2_230(kw), yg2_190(kw)
INTEGER irow, icol
INTEGER i, iw, iz, n, idum
INTEGER ierr
integer mabs, myld
**************** jlabel(j) = 'NO3 -> NO2 + O(3P)'
**************** jlabel(j) = 'NO3 -> NO + O2'
j = j + 1
jlabel(j) = 'NO3 -> NO + O2'
j = j + 1
jlabel(j) = 'NO3 -> NO2 + O(3P)'
* mabs = 1: Graham and Johnston 1978
* mabs = 2: JPL94
* mabs = 3: JPL11
mabs = 3
* myld = 1 from Madronich (1988) see CEC NO3 book.
* myld = 2 from JPL-2011
myld = 2
* cross section
IF(mabs. eq. 1) then
* cross section
* measurements of Graham and Johnston 1978
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/NO3_gj78.abs',STATUS='old')
DO i = 1, 9
READ(UNIT=ilu,FMT=*)
ENDDO
n = 305
DO irow = 1, 30
READ(UNIT=ilu,FMT=*) ( y1(10*(irow-1) + icol), icol = 1, 10 )
ENDDO
READ(UNIT=ilu,FMT=*) ( y1(300 + icol), icol = 1, 5 )
CLOSE (UNIT=ilu)
DO i = 1, n
y1(i) = y1(i) * 1.E-19
x1(i) = 400. + 1.*FLOAT(i-1)
ENDDO
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 2) THEN
* cross section from JPL94:
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/NO3_jpl94.abs',STATUS='old')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i)*1E-20
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* use JPL94 for wavelengths longer than 600 nm
DO iw = 1, nw-1
IF(wl(iw) .GT. 600.) yg(iw) = yg1(iw)
ENDDO
* cross sections from JPL2011
ELSEIF(MABS .EQ. 3) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/NO3_jpl11.abs',STATUS='old')
DO i = 1, 6
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, 289
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i)*1E-20
ENDDO
CLOSE (UNIT=ilu)
n = 289
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yield:
if (myld .eq. 1) then
* for NO3 ->NO+O2
DO iw = 1, nw - 1
IF (wc(iw).LT.584.) THEN
qy = 0.
ELSEIF (wc(iw).GE.640.) THEN
qy = 0.
ELSEIF (wc(iw).GE.595.) THEN
qy = 0.35*(1.-(wc(iw)-595.)/45.)
ELSE
qy = 0.35*(wc(iw)-584.)/11.
ENDIF
DO i = 1, nz
sq(j,i,iw) = yg(iw)*qy
ENDDO
ENDDO
* for NO3 ->NO2+O
DO iw = 1, nw - 1
IF (wc(iw).LT.584.) THEN
qy = 1.
ELSEIF (wc(iw).GT.640.) THEN
qy = 0.
ELSEIF (wc(iw).GT.595.) THEN
qy = 0.65*(1-(wc(iw)-595.)/45.)
ELSE
qy = 1.-0.35*(wc(iw)-584.)/11.
ENDIF
DO i = 1, nz
sq(j,i,iw) = yg(iw)*qy
ENDDO
ENDDO
* yields from JPL2011:
ELSEIF(myld .EQ. 2) THEN
open(newunit=ilu,file='DATAJ1/YLD/NO3_jpl2011.qy',status='old')
do i = 1, 5
read(UNIT=ilu,FMT=*)
enddo
do i = 1, 56
read(UNIT=ilu,FMT=*) x(i), q1_298(i), q1_230(i), q1_190(i),
$ q2_298(i), q2_230(i), q2_190(i)
q1_298(i) = q1_298(i)/1000.
q1_230(i) = q1_230(i)/1000.
q1_190(i) = q1_190(i)/1000.
q2_298(i) = q2_298(i)/1000.
q2_230(i) = q2_230(i)/1000.
q2_190(i) = q2_190(i)/1000.
enddo
close(UNIT=ilu)
n = 56
do i = 1, n
x1(i) = x(i)
enddo
CALL addpnt(x1,q1_298,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,q1_298,kdata,n, 0.,0.)
CALL addpnt(x1,q1_298,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,q1_298,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1_298,n,x1,q1_298,ierr)
n = 56
do i = 1, n
x1(i) = x(i)
enddo
CALL addpnt(x1,q1_230,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,q1_230,kdata,n, 0.,0.)
CALL addpnt(x1,q1_230,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,q1_230,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1_230,n,x1,q1_230,ierr)
n = 56
do i = 1, n
x1(i) = x(i)
enddo
CALL addpnt(x1,q1_190,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,q1_190,kdata,n, 0.,0.)
CALL addpnt(x1,q1_190,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,q1_190,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1_190,n,x1,q1_190,ierr)
n = 56
do i = 1, n
x1(i) = x(i)
enddo
CALL addpnt(x1,q2_298,kdata,n,x1(1)*(1.-deltax),1.)
CALL addpnt(x1,q2_298,kdata,n, 0.,1.)
CALL addpnt(x1,q2_298,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,q2_298,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg2_298,n,x1,q2_298,ierr)
n = 56
do i = 1, n
x1(i) = x(i)
enddo
CALL addpnt(x1,q2_230,kdata,n,x1(1)*(1.-deltax),1.)
CALL addpnt(x1,q2_230,kdata,n, 0.,1.)
CALL addpnt(x1,q2_230,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,q2_230,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg2_230,n,x1,q2_230,ierr)
n = 56
do i = 1, n
x1(i) = x(i)
enddo
CALL addpnt(x1,q2_190,kdata,n,x1(1)*(1.-deltax),1.)
CALL addpnt(x1,q2_190,kdata,n, 0.,1.)
CALL addpnt(x1,q2_190,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,q2_190,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg2_190,n,x1,q2_190,ierr)
* compute T-dependent quantum yields
DO iw = 1, nw-1
DO iz = 1, nz
if(tlev(iz) .le. 190.) then
qy1 = yg1_190(iw)
qy2 = yg2_190(iw)
elseif(tlev(iz) .gt. 190. .and. tlev(iz) .le. 230.) then
qy1 = yg1_190(iw) + (yg1_230(iw) - yg1_190(iw))*
$ (tlev(iz) - 190.)/(230.-190.)
qy2 = yg2_190(iw) + (yg2_230(iw) - yg2_190(iw))*
$ (tlev(iz) - 190.)/(230.-190.)
elseif(tlev(iz) .gt. 230. .and. tlev(iz) .le. 298.) then
qy1 = yg1_230(iw) + (yg1_298(iw) - yg1_230(iw))*
$ (tlev(iz) - 230.)/(298.-230.)
qy2 = yg2_230(iw) + (yg2_298(iw) - yg2_230(iw))*
$ (tlev(iz) - 230.)/(298.-230.)
elseif(tlev(iz) .gt. 298.) then
qy1 = yg1_298(iw)
qy2 = yg2_298(iw)
endif
sq(j-1, iz, iw) = qy1 * yg1(iw)
sq(j, iz, iw) = qy2 * yg1(iw)
ENDDO
ENDDO
ENDIF
* declare temperature dependence for both channels:
tpflag(j-1) = 1
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r04(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product of (cross section) x (quantum yiels) for N2O5 photolysis =*
*= reactions: =*
*= (a) N2O5 + hv -> NO3 + NO + O(3P) =*
*= (b) N2O5 + hv -> NO3 + NO2 =*
*= Cross section from JPL97: use tabulated values up to 280 nm, use expon. =*
*= expression for >285nm, linearly interpolate =*
*= between s(280) and s(285,T) in between =*
*= Quantum yield: Analysis of data in JPL94 (->DATAJ1/YLD/N2O5.qy) =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
REAL x1(kdata), x2(kdata)
REAL y1(kdata), A(kdata), B(kdata)
INTEGER n1, n2
* local
REAL yg1(kw), yg2(kw)
INTEGER i, iz, iw
INTEGER ierr
REAL t, xs, dum
**************** N2O5 photodissociation
j = j + 1
jlabel(j) = 'N2O5 -> NO3 + NO + O(3P)'
j = j + 1
jlabel(j) = 'N2O5 -> NO3 + NO2'
* cross section from jpl2011, at 300 K
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/N2O5_jpl11.abs',STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n1 = 103
DO i = 1, n1
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
* read temperature dependence coefficients:
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n2 = 8
DO i = 1, n2
READ(UNIT=ilu,FMT=*) x2(i), A(i), B(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata, n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata, n1, 0.,0.)
CALL addpnt(x1,y1,kdata, n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata, n1, 1.E36 ,0.)
CALL inter2(nw,wl,yg1, n1,x1,y1, ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr,jlabel(j)
STOP
ENDIF
CALL addpnt(x2,B,kdata, n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,B,kdata, n2, 0.,0.)
CALL addpnt(x2,B,kdata, n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,B,kdata, n2, 1.E36 ,0.)
CALL inter2(nw,wl,yg2, n2,x2,B, ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr,jlabel(j)
STOP
ENDIF
DO iw = 1, nw - 1
DO iz = 1, nz
* temperature dependence only valid for 233 - 295 K. Extend to 300.
t = MAX(233.,MIN(tlev(iz),300.))
* Apply temperature correction to 300K values. Do not use A-coefficients
* because they are inconsistent with the values at 300K.
dum = 1000.*yg2(iw)*((1./t) - (1./300.))
xs = yg1(iw) * 10.**(dum)
* quantum yield = 1 for NO2 + NO3, zero for other channels
sq(j-1, iz, iw) = 0. * xs
sq(j , iz, iw) = 1. * xs
ENDDO
ENDDO
* declare temperature dependence
tpflag(j-1) = 1
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r05(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for HNO2 photolysis=*
*= HNO2 + hv -> NO + OH =*
*= Cross section: from JPL97 =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
*= EDIT HISTORY: =*
*= 05/98 Original, adapted from former JSPEC1 subroutine =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n
INTEGER ierr
INTEGER mabs
**************** HNO2 photodissociation
* mabs = 2: JPL 2011 recommendation
* mabs = 1: earlier JPL recommendations
mabs = 2
* cross section from JPL92
* (from Bongartz et al., identical to JPL94, JPL97 recommendation)
j = j + 1
jlabel(j) = 'HNO2 -> OH + NO'
IF(mabs .eq. 1) then
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HNO2_jpl92.abs',STATUS='old')
DO i = 1, 13
READ(UNIT=ilu,FMT=*)
ENDDO
n = 91
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .eq. 2) then
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HONO_jpl11.abs',STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 192
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = yg(iw)*qy
ENDDO
ENDDO
* no t or p dependence
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r06(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product of (cross section) x (quantum yield) for HNO3 photolysis =*
*= HNO3 + hv -> OH + NO2 =*
*= Cross section: Burkholder et al., 1993 =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg1(kw), yg2(kw)
INTEGER i, iw
INTEGER ierr
**************** HNO3 photodissociation
j = j + 1
jlabel(j) = 'HNO3 -> OH + NO2'
C* cross section from JPL85
C
C OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HNO3.abs',STATUS='old')
C DO i = 1, 9
C READ(UNIT=ilu,FMT=*)
C ENDDO
C n = 29
C DO i = 1, n
C READ(UNIT=ilu,FMT=*) x1(i), y1(i)
C y1(i) = y1(i) * 1.E-20
C ENDDO
C CLOSE (UNIT=ilu)
C
C CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 0.,0.)
C CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
C CALL inter2(nw,wl,yg,n,x1,y1,ierr)
C IF (ierr .NE. 0) THEN
C WRITE(*,*) ierr, jlabel(j)
C STOP
C ENDIF
C
C* quantum yield = 1
C
C qy = 1.
C DO iw = 1, nw - 1
C DO i = 1, nz
C sq(j,i,iw) = yg(iw)*qy
C ENDDO
C ENDDO
* HNO3 cross section parameters from Burkholder et al. 1993
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HNO3_burk.abs',STATUS='old')
DO i = 1, 6
READ(UNIT=ilu,FMT=*)
END DO
n1 = 83
n2 = n1
DO i = 1, n1
READ(UNIT=ilu,FMT=*) y1(i), y2(i)
x1(i) = 184. + i*2.
x2(i) = x1(i)
END DO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),y2(1))
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),y2(n2))
CALL addpnt(x2,y2,kdata,n2, 1.e+38,y2(n2))
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield = 1
* correct for temperature dependence
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = yg1(iw) * 1.E-20
$ * exp( yg2(iw)/1.e3*(tlev(i)-298.) )
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r07(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product of (cross section) x (quantum yield) for HNO4 photolysis =*
*= HNO4 + hv -> HO2 + NO2 =*
*= Cross section: from JPL97 =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
C* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n
INTEGER ierr
**************** HNO4 photodissociation
* cross section from JPL2011
j = j + 1
jlabel(j) = 'HNO4 -> HO2 + NO2'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HNO4_jpl11.abs',STATUS='old')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 54
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = yg(iw)*qy
ENDDO
ENDDO
* no T or P dependence
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r08(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product of (cross section) x (quantum yield) for H2O2 photolysis =*
*= H2O2 + hv -> 2 OH =*
*= Cross section: From JPL97, tabulated values @ 298K for <260nm, T-depend.=*
*= parameterization for 260-350nm =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=600)
C INTEGER n1, n2, n3, n4, n5
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
REAL a0, a1, a2, a3, a4, a5, a6, a7
REAL b0, b1, b2, b3, b4
REAL xs
REAL t
INTEGER i, iw, n, idum
INTEGER ierr
REAL lambda
REAL sumA, sumB, chi
**************** H2O2 photodissociation
* cross section from Lin et al. 1978
j = j + 1
jlabel(j) = 'H2O2 -> 2 OH'
C OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/H2O2_lin.abs',STATUS='old')
C DO i = 1, 7
C READ(UNIT=ilu,FMT=*)
C ENDDO
C n = 32
C DO i = 1, n
C READ(UNIT=ilu,FMT=*) x1(i), y1(i)
C y1(i) = y1(i) * 1.E-20
C ENDDO
C CLOSE (UNIT=ilu)
C
C CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 0.,0.)
C CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
C CALL inter2(nw,wl,yg,n,x1,y1,ierr)
C IF (ierr .NE. 0) THEN
C WRITE(*,*) ierr, jlabel(j)
C STOP
C ENDIF
* cross section from JPL94 (identical to JPL97)
* tabulated data up to 260 nm
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/H2O2_jpl94.abs',STATUS='old')
READ(UNIT=ilu,FMT=*) idum,n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
CLOSE (UNIT=ilu)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/H2O2_Kahan.abs',STATUS='old')
DO i = 1, 494
n = n + 1
READ(UNIT=ilu,FMT=*) x1(n), y1(n)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
A0 = 6.4761E+04
A1 = -9.2170972E+02
A2 = 4.535649
A3 = -4.4589016E-03
A4 = -4.035101E-05
A5 = 1.6878206E-07
A6 = -2.652014E-10
A7 = 1.5534675E-13
B0 = 6.8123E+03
B1 = -5.1351E+01
B2 = 1.1522E-01
B3 = -3.0493E-05
B4 = -1.0924E-07
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
* Parameterization (JPL94)
* Range 260-350 nm; 200-400 K
IF ((wl(iw) .GE. 260.) .AND. (wl(iw) .LT. 350.)) THEN
lambda = wc(iw)
sumA = ((((((A7*lambda + A6)*lambda + A5)*lambda +
> A4)*lambda +A3)*lambda + A2)*lambda +
> A1)*lambda + A0
sumB = (((B4*lambda + B3)*lambda + B2)*lambda +
> B1)*lambda + B0
DO i = 1, nz
t = MIN(MAX(tlev(i),200.),400.)
chi = 1./(1.+EXP(-1265./t))
xs = (chi * sumA + (1.-chi)*sumB)*1E-21
sq(j,i,iw) = xs*qy
ENDDO
ELSE
DO i = 1, nz
sq(j,i,iw) = yg(iw)*qy
ENDDO
ENDIF
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r09(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product of (cross section) x (quantum yield) for CHBr3 photolysis=*
*= CHBr3 + hv -> Products =*
*= Cross section: Choice of data from Atlas (?Talukdar???) or JPL97 =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
INTEGER n1, n2, n3, n4, n5
REAL x1(kdata), x2(kdata), x3(kdata), x4(kdata), x5(kdata)
REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata), y5(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw), yg3(kw), yg4(kw), yg5(kw)
real t
real qy
INTEGER i, iw, n
INTEGER ierr
INTEGER iz
integer kopt
*_______________________________________________________________________
DO 5, iw = 1, nw - 1
wc(iw) = (wl(iw) + wl(iw+1))/2.
5 CONTINUE
**************** CHBr3 photodissociation
j = j + 1
jlabel(j) = 'CHBr3 -> Products'
* option:
* kopt = 1: cross section from Elliot Atlas, 1997
* kopt = 2: cross section from JPL 1997
kopt = 2
if (kopt .eq. 1) then
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CHBr3.abs',STATUS='old')
DO i = 1, 5
READ(UNIT=ilu,FMT=*)
ENDDO
n5 = 25
n4 = 27
n3 = 29
n2 = 31
n1 = 39
DO i = 1, n5
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i), y3(i), y4(i), y5(i)
ENDDO
do i = n5 + 1, n4
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i), y3(i), y4(i)
enddo
do i = n4 + 1, n3
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i), y3(i)
enddo
do i = n3 + 1, n2
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
enddo
do i = n2 + 1, n1
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
enddo
CLOSE (UNIT=ilu)
do i = 1, n1
y1(i) = y1(i) * 1.e-23
enddo
do i = 1, n2
x2(i) = x1(i)
y2(i) = y2(i) * 1.e-23
enddo
do i = 1, n3
x3(i) = x1(i)
y3(i) = y3(i) * 1.e-23
enddo
do i = 1, n4
x4(i) = x1(i)
y4(i) = y4(i) * 1.e-23
enddo
do i = 1, n5
x5(i) = x1(i)
y5(i) = y5(i) * 1.e-23
enddo
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n1, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),y2(1))
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),y3(1))
CALL addpnt(x3,y3,kdata,n3, 0.,y3(1))
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1.e+38,0.)
CALL inter2(nw,wl,yg3,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
ENDIF
CALL addpnt(x4,y4,kdata,n4,x4(1)*(1.-deltax),y4(1))
CALL addpnt(x4,y4,kdata,n4, 0.,y4(1))
CALL addpnt(x4,y4,kdata,n4,x4(n4)*(1.+deltax),0.)
CALL addpnt(x4,y4,kdata,n4, 1.e+38,0.)
CALL inter2(nw,wl,yg4,n4,x4,y4,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x5,y5,kdata,n5,x5(1)*(1.-deltax),y5(1))
CALL addpnt(x5,y5,kdata,n5, 0.,y5(1))
CALL addpnt(x5,y5,kdata,n5,x5(n5)*(1.+deltax),0.)
CALL addpnt(x5,y5,kdata,n5, 1.e+38,0.)
CALL inter2(nw,wl,yg5,n5,x5,y5,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
DO iz = 1, nz
t = tlev(iz)
if (t .ge. 296.) then
yg(iw) = yg1(iw)
else if(t .ge. 286.) then
yg(iw) = yg1(iw) + (t-286.)*(yg2(iw)-yg1(iw))/10.
else if(t .ge. 276.) then
yg(iw) = yg2(iw) + (t-276.)*(yg3(iw)-yg2(iw))/10.
else if(t .ge. 266.) then
yg(iw) = yg3(iw) + (t-266.)*(yg4(iw)-yg3(iw))/10.
else if(t .ge. 256.) then
yg(iw) = yg4(iw) + (t-256.)*(yg5(iw)-yg4(iw))/10.
else if(t .lt. 256.) then
yg(iw) = yg5(iw)
endif
sq(j,iz,iw) = yg(iw)*qy
ENDDO
ENDDO
* jpl97, with temperature dependence formula,
*w = 290 nm to 340 nm,
*T = 210K to 300 K
*sigma, cm2 = exp((0.06183-0.000241*w)*(273.-T)-(2.376+0.14757*w))
ELSEIF (kopt .EQ. 2) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CHBr3.jpl97',STATUS='old')
DO i = 1, 6
READ(UNIT=ilu,FMT=*)
ENDDO
n1 = 87
DO i = 1, n1
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n1, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
DO iz = 1, nz
t = tlev(iz)
yg(iw) = yg1(iw)
IF (wc(iw) .GT. 290. .AND. wc(iw) .LT. 340.
$ .AND. t .GT. 210 .AND. t .LT. 300) THEN
yg(iw) = EXP((0.06183-0.000241*wc(iw))*(273.-T)-
$ (2.376+0.14757*wc(iw)))
ENDIF
sq(j,iz,iw) = yg(iw)*qy
ENDDO
ENDDO
ENDIF
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r10(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product of (cross section) x (quantum yield) for CH2O photolysis =*
*= (a) CH2O + hv -> H + HCO =*
*= (b) CH2O + hv -> H2 + CO =*
*= Cross section: Choice between =*
*= 1) Bass et al., 1980 (resolution: 0.025 nm) =*
*= 2) Moortgat and Schneider (resolution: 1 nm) =*
*= 3) Cantrell et al. (orig res.) for > 301 nm, =*
*= IUPAC 92, 97 elsewhere =*
*= 4) Cantrell et al. (2.5 nm res.) for > 301 nm, =*
*= IUPAC 92, 97 elsewhere =*
*= 5) Rogers et al., 1990 =*
*= 6) new NCAR recommendation, based on averages of =*
*= Cantrell et al., Moortgat and Schneider, and Rogers =*
*= et al. =*
*= Quantum yield: Choice between =*
*= 1) Evaluation by Madronich 1991 (unpublished) =*
*= 2) IUPAC 89, 92, 97 =*
*= 3) Madronich, based on 1), updated 1998. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER kdata
PARAMETER(kdata=16000)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j, iz, iw
* data arrays
INTEGER n
real x(kdata), y(kdata)
real xl(kdata), xc(kdata), xu(kdata)
INTEGER n1, n2, n3, n4, n5
REAL x1(kdata), x2(kdata), x3(kdata), x4(kdata), x5(kdata)
REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata), y5(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw), yg3(kw), yg4(kw), yg5(kw)
REAL a, b, c
REAL a0, a1, a2, a3, a4, a5, a6, a7
REAL b0, b1, b2, b3, b4
REAL phi1, phi2, phi20, ak300, akt
REAL qy, qy1, qy2, qy3
REAL sigma, sig, slope
REAL xs
REAL t
REAL dum
INTEGER idum
INTEGER i
INTEGER irow, icol, irev
INTEGER ierr
INTEGER mopt1, mopt2
*_______________________________________________________________________
DO 5, iw = 1, nw - 1
wc(iw) = (wl(iw) + wl(iw+1))/2.
5 CONTINUE
****************************************************************
**************** CH2O photodissociatation
j = j+1
jlabel(j) = 'CH2O -> H + HCO'
j = j+1
jlabel(j) = 'CH2O -> H2 + CO'
* working grid arrays:
* yg1 = cross section at a specific temperature
* yg2, yg3 = cross sections at different temp or slope, for calculating
* temperature depedence
* yg4 = quantum yield data for radical channel
* yg5 = quantum yield data for molecular channel
* Input data options:
* mopt1 for absorption:
* 1: DATAJ1/CH2O/CH2O_nbs.abs'
* from Bass et al., Planet. Space. Sci. 28, 675, 1980.
* over 258.750-359.525 in 0.025 nm steps
* 2: DATAJ1/CH2O_iupac1.abs
* Moortgat and Schneider, personal communication as reported in IUPAC 89, 92, 97
* at 285K. Over 240-360 nm in 1 nm bins (note that IUPAC 89,92,97 incorectly
* claims 0.5 nm intervals in footnote)
* 3: DATAJ1/CH2O/ch2o_can_hr.abs for wc > 301 nm, temperature dependent
* DATAJ1/CH2O/ch2o_iupac1.abs elsewhere
* from Cantrell et al. 1990 for wc > 301 nm. Original data from Cantrell,
* at high resolution
* 4: DATAJ1/CH2O/CH2O_can_lr.abs for wc > 301 nm, temperature dependent
* DATAJ1/CH2O/CH2O_iupac1.abs elsewhere
* from Cantrell et al. 1990 for wc > 301 nm. Data from Cantrell et al., as
* reported by IUPAC'92,'97. On 2.5 nm intervals.
* 5: DATAJ1/CH2O/CH2O_rog.abs'
* from Rogers et al., J. Phys. Chem. 94, 4011, 1990.
* 6: DATAJ2/CH2O_ncar.abs
* new NCAR recommendation, based on averages of Moortgat and Schneider, Cantrell et al.,
* and Rogers.
* mopt2 for quantum yields:
* 1: DATAJ1/CH2O/CH2O_i_mad.yld and
* DATAJ1/CH2O/CH2O_ii_mad.yld
* evaluated by Madronich, 1991, unpublished
* 2: DATAJ1/CH2O/CH2O_iupac.yld
* from IUPAC'89, '92, '97
* 3: DATAJ1/CH2O/CH2O_jpl97.dat'
* based on Madronich 1991 unpublished evaluation, updated Jan 1998.
mopt1 = 6
mopt2 = 1
IF (mopt1 .EQ. 1) THEN
* read NBS/Bass data
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O/CH2O_nbs.abs'
$ ,STATUS='old')
n = 4032
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j-1)
STOP
ENDIF
ELSEIF (mopt1 .EQ. 2 .OR. mopt1 .EQ. 3 .OR. mopt1 .EQ. 4) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O_iupac1.abs',STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 121
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j-1)
STOP
ENDIF
IF(mopt1 .EQ. 3) THEN
* data are on wavenumber grid (cm-1), so convert to wavelength in nm:
* grid was on increasing wavenumbers, so need to reverse to get increasing
* wavelengths
* cross section assumed to be zero for wavelengths longer than 360 nm
* if y1 < 0, then make = 0 (some negative cross sections, actually 273 K intercepts
* are in the original data, Here, make equal to zero)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O/CH2O_can_hr.abs',
& STATUS='old')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
x1(i) = 1./x1(i) * 1E7
IF (x1(i) .GT. 360.) THEN
y1(i) = 0.
y2(i) = 0.
ENDIF
ENDDO
CLOSE(UNIT=ilu)
DO i = 1, n/2
irev = n+1-i
dum = x1(i)
x1(i) = x1(irev)
x1(irev) = dum
dum = y1(i)
y1(i) = y1(irev)
y1(irev) = dum
dum = y2(i)
y2(i) = y2(irev)
y2(irev) = dum
ENDDO
DO i = 1, n
x2(i) = x1(i)
y1(i) = max(y1(i),0.)
ENDDO
n1 = n
n2 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
CALL inter2(nw,wl,yg2,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
CALL inter2(nw,wl,yg3,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mopt1 .eq. 4) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O/CH2O_can_lr.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 23
DO i = 1, n
READ(UNIT=ilu,FMT=*) x2(i), y2(i), y3(i), dum, dum
x3(i) = x2(i)
ENDDO
CLOSE(UNIT=ilu)
n2 = n
n3 = n
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 0.,0.)
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1E38,0.)
CALL inter2(nw,wl,yg3,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
ELSEIF (mopt1 .EQ. 5) THEN
* read Rodgers data
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O/CH2O_rog.abs'
$ ,STATUS='old')
DO i = 1, 10
READ(UNIT=ilu,FMT=*)
ENDDO
n = 261
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i), dum
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j-1)
STOP
ENDIF
ELSEIF(mopt1 .EQ. 6) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O/CH2O_ncar.abs',
& STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 126
DO i = 1, n
READ(UNIT=ilu,FMT=*) x2(i), y2(i), y3(i)
x3(i) = x2(i)
ENDDO
CLOSE(UNIT=ilu)
n2 = n
n3 = n
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 0.,0.)
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1E38,0.)
CALL inter2(nw,wl,yg3,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yield
IF (mopt2 .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O/CH2O_i_mad.yld',
& STATUS='old')
DO i = 1, 11
READ(UNIT=ilu,FMT=*)
ENDDO
n = 20
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),y(1))
CALL addpnt(x,y,kdata,n, 0.,y(1))
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg4,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j-1)
STOP
ENDIF
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O/CH2O_ii_mad.yld',
& STATUS='old')
DO i = 1, 9
READ(UNIT=ilu,FMT=*)
ENDDO
n = 33
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),y(1))
CALL addpnt(x,y,kdata,n, 0.,y(1))
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg5,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mopt2 .EQ. 2) then
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O/CH2O_iupac.yld',
& STATUS='old')
DO i = 1, 7
READ(UNIT=ilu,FMT=*)
ENDDO
n = 13
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
x2(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
n1 = n
n2 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n1, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg4,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),y2(1))
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg5,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* box-filling interpolation.
c DO i = 1, n
c READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
c x1(i) = x1(i) - 5.0
c x2(i) = x1(i)
c ENDDO
c n = n + 1
c x1(n) = x1(n-1) + 5.0
c x2(n) = x1(n)
c CLOSE(UNIT=ilu)
c DO i = 1, n-1
c y1(i) = y1(i) * (x1(i+1)-x1(i))
c ENDDO
c CALL inter3(nw,wl,yg4,n,x1,y1,0)
c DO iw = 1, nw-1
c yg4(iw) = yg4(iw)/(wl(iw+1)-wl(iw))
c ENDDO
c DO i = 1, n-1
c y2(i) = y2(i) * (x2(i+1)-x2(i))
c ENDDO
c CALL inter3(nw,wl,yg5,n,x2,y2,0)
c DO iw = 1, nw-1
c yg5(iw) = yg5(iw)/(wl(iw+1)-wl(iw))
c ENDDO
ELSE IF(mopt2 .EQ. 3) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O/CH2O_jpl97.dat',
& STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 23
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), dum, dum, dum, dum, y1(i), y2(i)
x2(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
n1 = n
n2 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n1, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg4,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),y2(1))
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg5,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* combine
* y1 = xsect
* y2 = xsect(223), Cantrell et al.
* y3 = xsect(293), Cantrell et al.
* y4 = qy for radical channel
* y5 = qy for molecular channel
* pressure and temperature dependent for w > 330.
DO iw = 1, nw - 1
IF (mopt1 .eq. 6) THEN
sig = yg2(iw)
ELSE
sig = yg1(iw)
ENDIF
DO i = 1, nz
* correct cross section for temperature dependence for > 301. nm
IF (wl(iw) .GE. 301.) THEN
t = MAX(223.15, MIN(tlev(i), 293.15))
IF (mopt1 .EQ. 3 .OR. mopt1 .EQ. 6) THEN
sig = yg2(iw) + yg3(iw) * (t - 273.15)
ELSEIF (mopt1 .EQ. 4) THEN
slope = (yg3(iw) - yg2(iw)) / (293. - 223.)
sig = yg2(iw) + slope * (t - 223.)
ENDIF
ENDIF
sig = MAX(sig, 0.)
* quantum yields:
* temperature and pressure dependence beyond 330 nm
qy1 = yg4(iw)
IF ( (wc(iw) .GE. 330.) .AND. (yg5(iw) .GT. 0.) ) THEN
phi1 = yg4(iw)
phi2 = yg5(iw)
phi20 = 1. - phi1
ak300=((1./phi2)-(1./phi20))/2.54E+19
akt=ak300*(1.+61.69*(1.-tlev(i)/300.)*(wc(iw)/329.-1.))
qy2 = 1. / ( (1./phi20) + airden(i)*akt)
ELSE
qy2 = yg5(iw)
ENDIF
qy2 = MAX(0.,qy2)
qy2 = MIN(1.,qy2)
sq(j-1,i,iw) = sig * qy1
sq(j ,i,iw) = sig * qy2
ENDDO
ENDDO
* declare T and P dependence
tpflag(j) = 3
RETURN
END
*=============================================================================*
SUBROUTINE r11(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CH3CHO photolysis: =*
*= (a) CH3CHO + hv -> CH3 + HCO =*
*= (b) CH3CHO + hv -> CH4 + CO =*
*= (c) CH3CHO + hv -> CH3CO + H =*
*= Cross section: Choice between =*
*= (1) IUPAC 97 data, from Martinez et al. =*
*= (2) Calvert and Pitts =*
*= (3) Martinez et al., Table 1 scanned from paper =*
*= (4) KFA tabulations =*
*= Quantum yields: Choice between =*
*= (1) IUPAC 97, pressure correction using Horowith and =*
*= Calvert, 1982 =*
*= (2) NCAR data file, from Moortgat, 1986 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER i, n
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw), yg3(kw), yg4(kw)
REAL qy1, qy2, qy3
REAL sig
REAL dum
INTEGER ierr
INTEGER iz, iw
REAL qy1_n0, qy1_0, x
INTEGER mabs, myld
****************************************************************
************************* CH3CHO photolysis
* 1: CH3 + HCO
* 2: CH4 + CO
* 3: CH3CO + H
j = j+1
jlabel(j) = 'CH3CHO -> CH3 + HCO'
j = j+1
jlabel(j) = 'CH3CHO -> CH4 + CO'
j = j+1
jlabel(j) = 'CH3CHO -> CH3CO + H'
* options
* mabs for cross sections
* myld for quantum yields
* Absorption:
* 1: IUPAC-97 data, from Martinez et al.
* 2: Calvert and Pitts
* 3: Martinez et al., Table 1 scanned from paper
* 4: KFA tabulations, 6 choices, see file OPEN statements
* 5: JPL2011
* Quantum yield
* 1: DATAJ1/CH3CHO/CH3CHO_iup.yld
* pressure correction using Horowitz and Calvert 1982, based on slope/intercept
* of Stern-Volmer plots
* 2: ncar data file, from Moortgat 1986.
* DATAJ1/CH3CHO/d021_i.yld
* DATAJ1/CH3CHO/d021_i.yld
* DATAJ1/CH3CHO/d021_i.yld
mabs = 5
myld = 1
IF (mabs .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3CHO/CH3CHO_iup.abs',
& STATUS='old')
do i = 1, 4
read(UNIT=ilu,FMT=*)
enddo
n = 106
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 2) THEN
* cross section from Calvert and Pitts
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3CHO/d021_cp.abs',
& STATUS='old')
DO i = 1, 14
READ(UNIT=ilu,FMT=*)
ENDDO
n = 54
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
x1(i) = x1(i)/10.
y1(i) = y1(i) * 3.82E-21
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 3) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3CHO/CH3CHO_mar.abs',
& STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 106
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 4) THEN
* cross section from KFA tables
* ch3cho.001 - Calvert and Pitts 1966
* ch3cho.002 - Meyrahn thesis 1984
* ch3cho.003 - Schneider and Moortgat, priv comm. MPI Mainz 1989, 0.012 nm resol.
* ch3cho.004 - Schneider and Moortgat, priv comm. MPI Mainz 1989, 0.08 nm resol.
* ch3cho.005 - IUPAC'92
* ch3cho.006 - Libuda, thesis Wuppertal 1992
c OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/ch3cho.001',STATUS='old')
C n = 217
c OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/ch3cho.002',STATUS='old')
c n = 63
c OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/ch3cho.003',STATUS='old')
c n = 13738
c OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/ch3cho.004',STATUS='old')
c n = 2053
OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/ch3cho.005',STATUS='old')
n = 18
c OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/ch3cho.006',STATUS='old')
c n = 1705
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (mabs .EQ. 5) THEN
OPEN(NEWUNIT=ilu,
$ FILE='DATAJ1/CH3CHO/CH3CHO_jpl11.abs',STATUS='old')
do i = 1, 2
read(UNIT=ilu,FMT=*)
enddo
n = 101
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yields
IF (myld .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3CHO/CH3CHO_iup.yld',
& STATUS='old')
do i = 1, 4
read(UNIT=ilu,FMT=*)
enddo
n = 12
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y2(i), y1(i)
x2(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
n1 = n
n2 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
DO iw = 1, nw-1
yg3(iw) = 0.
ENDDO
ELSEIF (myld .EQ. 2) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3CHO/d021_i.yld',STATUS='old')
DO i = 1, 18
READ(UNIT=ilu,FMT=*)
ENDDO
n = 10
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3CHO/d021_ii.yld',
& STATUS='old')
DO i = 1, 10
READ(UNIT=ilu,FMT=*)
ENDDO
n = 9
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3CHO/d021_iii.yld',
& STATUS='old')
DO i = 1, 10
READ(UNIT=ilu,FMT=*)
ENDDO
n = 9
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg3,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* pressure-dependence parameters
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3CHO/CH3CHO_press.yld',
$ STATUS='old')
do i = 1, 4
read(UNIT=ilu,FMT=*)
enddo
n = 5
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), dum, dum, y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg4,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* combine:
DO iw = 1, nw - 1
sig = yg(iw)
* quantum yields:
* input yields at n0 = 1 atm
qy1_n0 = yg1(iw)
qy2 = yg2(iw)
qy3 = yg3(iw)
* Pressure correction for CH3 + CHO channel:
* Assume pressure-dependence only for qy1, not qy2 or qy2.
* Assume total yield 1 at zero pressure
qy1_0 = 1. - qy2 - qy3
* compute coefficient:
* Stern-Volmer: 1/q = 1/q0 + k N and N0 = 1 atm,
* then x = K N0 q0 = qy_0/qy_N0 - 1
if (qy1_n0 .gt. 0.) then
x = qy1_0/qy1_n0 - 1.
else
x = 0.
endif
* use instead slope/intercept ratio from Horowitz and Calvert 1982,
c x = yg4(iw)
DO i = 1, nz
qy1 = qy1_n0 * (1. + x) / (1. + x * airden(i)/2.465E19 )
qy1 = MIN(1., qy1)
qy1 = MAX(0., qy1)
sq(j-2,i,iw) = sig * qy1
sq(j-1,i,iw) = sig * qy2
sq(j ,i,iw) = sig * qy3
ENDDO
ENDDO
* declare P dependence for channel 1
tpflag(j-2) = 2
tpflag(j) = 0
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r12(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for C2H5CHO =*
*= photolysis: =*
*= C2H5CHO + hv -> C2H5 + HCO =*
*= =*
*= Cross section: Choice between =*
*= (1) IUPAC 97 data, from Martinez et al. =*
*= (2) Calvert and Pitts, as tabulated by KFA =*
*= Quantum yield: IUPAC 97 recommendation =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER i, n
INTEGER n1
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw), yg1(kw)
REAL qy1
REAL sig
INTEGER ierr
INTEGER iw
INTEGER mabs, myld
************************* C2H5CHO photolysis
* 1: C2H5 + HCO
j = j+1
jlabel(j) = 'C2H5CHO -> C2H5 + HCO'
* options
* mabs for cross sections
* myld for quantum yields
* Absorption:
* 1: IUPAC-97 data, from Martinez et al.
* 2: Calvert and Pitts, as tabulated by KFA.
* Quantum yield
* 1: IUPAC-97 data
mabs = 1
myld = 1
IF (mabs .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/C2H5CHO/C2H5CHO_iup.abs',
$ STATUS='old')
do i = 1, 4
read(UNIT=ilu,FMT=*)
enddo
n = 106
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 2) THEN
* cross section from KFA tables
* c2h5cho.001 - Calvert and Pitts 1966
OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/c2h5cho.001',STATUS='old')
n = 83
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yields
IF (myld .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/C2H5CHO/C2H5CHO_iup.yld',
$ STATUS='old')
do i = 1, 4
read(UNIT=ilu,FMT=*)
enddo
n = 5
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE(UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,340.,0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (myld .EQ. 2) THEN
STOP
ENDIF
* combine:
DO iw = 1, nw - 1
DO i = 1, nz
sig = yg(iw)
* quantum yields:
* use Ster-Volmer pressure dependence:
IF (yg1(iw) .LT. pzero) THEN
qy1 = 0.
ELSE
qy1 = 1./(1. + (1./yg1(iw) - 1.)*airden(i)/2.45e19)
ENDIF
qy1 = MIN(qy1,1.)
sq(j,i,iw) = sig * qy1
ENDDO
ENDDO
tpflag(j) = 2
RETURN
END
*=============================================================================*
SUBROUTINE r13(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for CHOCHO =*
*= photolysis: =*
*= CHOCHO + hv -> Products =*
*= =*
*= Cross section: Choice between =*
*= (1) Plum et al., as tabulated by IUPAC 97 =*
*= (2) Plum et al., as tabulated by KFA. =*
*= (3) Orlando et al. =*
*= (4) Horowitz et al., 2001 =*
*= Quantum yield: IUPAC 97 recommendation =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=500)
INTEGER i, n, n1, n2, n3
REAL x(kdata), x1(kdata), x2(kdata), x3(kdata)
REAL y1(kdata), y2(kdata), y3(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw), yg3(kw)
REAL qyI, qyII, qyIII
REAL sig, dum
INTEGER ierr
INTEGER iw
INTEGER mabs, myld
************************* CHOCHO photolysis
* see review by Madronich, Chapter VII in "The Mechansims of
* Atmospheric Oxidation of the Alkanes, Calvert et al, Oxford U.
* Press, 2000.
* Four possible channels:
* I H2 + 2 CO
* II 2 HCO
* III HCHO + CO
* IV HCO + H + CO
*
* Based on that review, the following quantum yield assignments are made:
*
* qy_I = 0
* qy_II = 0.63 for radiation between 280 and 380 nm
* qy_III = 0.2 for radiation between 280 and 380 nm
* qy_IV = 0
* The yields for channels II and III were determined by Bauerle et al. (personal
* communication from G. Moortgat, still unpublished as of Dec 2000).
* Bauerle et al. used broad-band irradiation 280-380 nm.
* According to Zhu et al., the energetic threshold (for II) is 417 nm. Therefore,
* here the quantum yields were set to zero for wc > 417. Furthermore, the
* qys of Bauerle et al. were reduced to give the same J values when using full solar
* spectrum. The reduction factor was calculated by comparing the J-values (for
* high sun) using the 380 and 417 cut offs. The reduction factor is 7.1
j = j+1
jlabel(j) = 'CHOCHO -> HCO + HCO'
j = j + 1
jlabel(j) = 'CHOCHO -> H2 + 2CO'
j = j + 1
jlabel(j) = 'CHOCHO -> CH2O + CO'
* options
* mabs for cross sections
* myld for quantum yields
* Absorption:
* 1: Plum et al., as tabulated by IUPAC-97
* 2: Plum et al., as tabulated by KFA.
* 3: Orlando, J. J.; G. S. Tyndall, 2001: The atmospheric chemistry of the
* HC(O)CO radical. Int. J. Chem. Kinet., 33, 149-156.
* 4: Horowitz, A., R. Meller, and G. K. Moortgat,
* The UV-VIS absorption cross sectiono of the a-dicarbonyl compounds:
* pyruvic acid, biacetyl, and glyoxal.
* J. Photochem. Photobiol. A:Chemistry, v.146, pp.19-27, 2001.
* 5: From JPL 2011, derived mostly from Volkamer et al.
* Quantum yield
* 1: IUPAC-97 data
* 2: JPL 2011
mabs = 5
myld = 2
IF (mabs .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CHOCHO/CHOCHO_iup.abs',
$ STATUS='old')
DO i = 1, 4
read(UNIT=ilu,FMT=*)
ENDDO
n = 110
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 2) THEN
* cross section from KFA tables
* chocho.001 - Plum et al. 1983
OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/chocho.001',STATUS='old')
n = 219
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 3) THEN
* cross section from Orlando et la.
* Orlando, J. J.; G. S. Tyndall, 2001: The atmospheric chemistry of the
* HC(O)CO radical. Int. J. Chem. Kinet., 33, 149-156.
OPEN(NEWUNIT=ilu,
$ FILE='DATAJ1/CHOCHO/glyoxal_orl.abs',STATUS='old')
do i = 1, 6
read(UNIT=ilu,FMT=*)
enddo
n = 481
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 4) THEN
OPEN(NEWUNIT=ilu,
$ FILE='DATAJ1/CHOCHO/glyoxal_horowitz.abs',STATUS='old')
DO i = 1, 8
read(UNIT=ilu,FMT=*)
ENDDO
n = 270
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .eq. 5) then
open(newunit=ilu,
$ FILE='DATAJ1/CHOCHO/glyoxal_jpl11.abs',STATUS='old')
DO i = 1, 2
read(UNIT=ilu,FMT=*)
ENDDO
n = 277
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yields
IF(myld .eq. 2) then
open(newunit=ilu,
$ FILE='DATAJ1/CHOCHO/glyoxal_jpl11.qy',STATUS='old')
DO i = 1, 3
read(UNIT=ilu,FMT=*)
ENDDO
n = 40
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), dum, y1(i), y2(i), y3(i)
ENDDO
CLOSE (UNIT=ilu)
n1 = n
do i = 1, n
x1(i) = x(i)
enddo
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),y1(1))
CALL addpnt(x1,y1,kdata,n1, 0.,y1(1))
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
n2 = n
do i = 1, n
x1(i) = x(i)
enddo
CALL addpnt(x1,y2,kdata,n2,x1(1)*(1.-deltax),y2(1))
CALL addpnt(x1,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x1,y2,kdata,n2,x1(n2)*(1.+deltax),0.)
CALL addpnt(x1,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n2,x1,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
n3 = n
do i = 1, n
x1(i) = x(i)
enddo
CALL addpnt(x1,y3,kdata,n3,x1(1)*(1.-deltax),y3(1))
CALL addpnt(x1,y3,kdata,n3, 0.,y3(1))
CALL addpnt(x1,y3,kdata,n3,x1(n3)*(1.+deltax),0.)
CALL addpnt(x1,y3,kdata,n3, 1.e+38,0.)
CALL inter2(nw,wl,yg3,n3,x1,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* combine:
DO iw = 1, nw - 1
sig = yg(iw)
* quantum yields:
IF(myld .EQ. 1) THEN
* Use values from Bauerle, but corrected to cutoff at 417 rather than 380.
* this correction is a reduction by 7.1.
* so that qyI = 0.63/7.1 and qyII = 0.2/7.1
qyII = 0.
if(wc(iw) .lt. 417. ) then
qyI = 0.089
qyIII = 0.028
else
qyI = 0.
qyIII = 0.
endif
DO i = 1, nz
sq(j-2,i,iw) = sig * qyI
sq(j-1,i,iw) = sig * qyII
sq(j, i,iw) = sig * qyIII
ENDDO
ELSEIF(myld .EQ. 2) THEN
DO i = 1, nz
sq(j-2,i,iw) = sig * yg1(iw)
sq(j-1,i,iw) = sig * yg2(iw)
sq(j, i,iw) = sig * yg3(iw)
ENDDO
ENDIF
ENDDO
tpflag(j-2) = 0
tpflag(j-1) = 0
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r14(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for CH3COCHO =*
*= photolysis: =*
*= CH3COCHO + hv -> CH3CO + HCO =*
*= =*
*= Cross section: Choice between =*
*= (1) from Meller et al., 1991, as tabulated by IUPAC 97 =*
*= 5 nm resolution (table 1) for < 402 nm =*
*= 2 nm resolution (table 2) for > 402 nm =*
*= (2) average at 1 nm of Staffelbach et al., 1995, and =*
*= Meller et al., 1991 =*
*= (3) Plum et al., 1983, as tabulated by KFA =*
*= (4) Meller et al., 1991 (0.033 nm res.), as tab. by KFA =*
*= (5) Meller et al., 1991 (1.0 nm res.), as tab. by KFA =*
*= (6) Staffelbach et al., 1995, as tabulated by KFA =*
*= Quantum yield: Choice between =*
*= (1) Plum et al., fixed at 0.107 =*
*= (2) Plum et al., divided by 2, fixed at 0.0535 =*
*= (3) Staffelbach et al., 0.45 for < 300 nm, 0 for > 430 nm=*
*= linear interp. in between =*
*= (4) Koch and Moortgat, prv. comm., 1997 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=500)
INTEGER i, n
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
real x(kdata), y(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw)
REAL qy
REAL sig
INTEGER ierr
INTEGER iw
INTEGER mabs, myld
REAL phi0, kq
************************* CH3COCHO photolysis
* 1: CH3COCHO
j = j+1
jlabel(j) = 'CH3COCHO -> CH3CO + HCO'
* options
* mabs for cross sections
* myld for quantum yields
* Absorption:
* 1: from Meller et al. (1991), as tabulated by IUPAC-97
* for wc < 402, use coarse data (5 nm, table 1)
* for wc > 402, use finer data (2 nm, table 2)
* 2: average at 1nm of Staffelbach et al. 1995 and Meller et al. 1991
* Cross section from KFA tables:
* 3: ch3cocho.001 - Plum et al. 1983
* 4: ch3cocho.002 - Meller et al. 1991, 0.033 nm resolution
* 5: ch3cocho.003 - Meller et al. 1991, 1.0 nm resolution
* 6: ch3cocho.004 - Staffelbach et al. 1995
* 7: use synthetic spectrum, average of CHOCHO and CH3COCOCH3:
* 8: cross section from JPL2011
* Quantum yield
* 1: Plum et al., 0.107
* 2: Plum et al., divided by two = 0.0535
* 3: Staffelbach et al., 0.45 at wc .le. 300, 0 for wc .gt. 430, linear
* interpl in between
* 4: Koch and Moortgat, prv. comm. 1997. - pressure-dependent
* 5: Chen, Y., W. Wang, and L. Zhu, Wavelength-dependent photolysis of methylglyoxal
* in the 290-440 nm region, J Phys Chem A, 104, 11126-11131, 2000.
mabs = 8
myld = 5
IF (mabs .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCHO/CH3COCHO_iup1.abs',
$ STATUS='old')
do i = 1, 4
read(UNIT=ilu,FMT=*)
enddo
n = 38
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCHO/CH3COCHO_iup2.abs',
$ STATUS='old')
do i = 1, 4
read(UNIT=ilu,FMT=*)
enddo
n = 75
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
DO iw = 1, nw-1
IF(wc(iw) .LT. 402.) THEN
yg(iw) = yg1(iw)
ELSE
yg(iw) = yg2(iw)
ENDIF
ENDDO
ELSEIF(mabs .EQ. 2) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCHO/CH3COCHO_ncar.abs',
$ STATUS='old')
n = 271
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .GT. 2 .and. mabs .lt. 7) THEN
* cross section from KFA tables
* ch3cocho.001 - Plum et al. 1983
* ch3cocho.002 - Meller et al. 1991, 0.033 nm resolution
* ch3cocho.003 - Meller et al. 1991, 1.0 nm resolution
* ch3cocho.004 - Staffelbach et al. 1995
IF(mabs .EQ. 3) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/ch3cocho.001',
& STATUS='old')
n = 136
ELSEIF(mabs .EQ. 4) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/ch3cocho.002',
& STATUS='old')
n = 8251
ELSEIF(mabs .EQ. 5) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/ch3cocho.003',
& STATUS='old')
n = 275
ELSEIF(mabs .EQ. 6) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ2/KFA/ch3cocho.004',
& STATUS='old')
n = 162
ENDIF
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 7) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCOCH3/biacetyl_plum.abs',
$ STATUS='old')
DO i = 1, 7
READ(UNIT=ilu,FMT=*)
ENDDO
n = 55
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
OPEN(NEWUNIT=ilu,
$ FILE='DATAJ1/CHOCHO/glyoxal_orl.abs',STATUS='old')
do i = 1, 6
read(UNIT=ilu,FMT=*)
enddo
n = 481
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
do iw = 1, nw-1
yg(iw) = 0.5*(yg1(iw) + yg2(iw))
enddo
ELSEIF(mabs .eq. 8) then
OPEN(NEWUNIT=ilu,
$ FILE='DATAJ1/CH3COCHO/CH3COCHO_jpl11.abs',STATUS='old')
do i = 1, 2
read(UNIT=ilu,FMT=*)
enddo
n = 294
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yields
IF(myld .EQ. 4) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCHO/CH3COCHO_km.yld',
$ STATUS='old')
DO i = 1, 5
READ(UNIT=ilu,FMT=*)
ENDDO
n = 5
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
x2(i) = x1(i)
ENDDO
CLOSE (UNIT=ilu)
n1 = n
n2 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),1.)
CALL addpnt(x1,y1,kdata,n1, 0.,1.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),1.)
CALL addpnt(x2,y2,kdata,n2, 0.,1.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* combine:
DO iw = 1, nw - 1
sig = yg(iw)
DO i = 1, nz
* quantum yields:
IF (myld .EQ. 1) THEN
qy = 0.107
ELSEIF(myld .EQ. 2) THEN
qy = 0.107/2.
ELSEIF(myld .EQ. 3) THEN
IF(wc(iw) .LE. 300.) THEN
qy = 0.45
ELSE IF (wc(iw) .GE. 430.) THEN
qy = 0.
ELSE
qy = 0.45 + (0-0.45)*(wc(iw)-300.)/(430.-300.)
ENDIF
ELSEIF(myld .EQ. 4) THEN
IF (yg1(iw) .GT. 0.) THEN
qy = yg2(iw)/( 1. + (airden(i)/2.465E19)
$ * ( (yg2(iw)/yg1(iw)) - 1.))
ELSE
qy = 0.
ENDIF
ELSEIF(myld .EQ. 5) THEN
* zero pressure yield:
* 1.0 for wc < 380 nm
* 0.0 for wc > 440 nm
* linear in between:
phi0 = 1. - (wc(iw) - 380.)/60.
phi0 = MIN(phi0,1.)
phi0 = MAX(phi0,0.)
* Pressure correction: quenching coefficient, torr-1
* in air, Koch and Moortgat:
kq = 1.36e8 * EXP(-8793/wc(iw))
* in N2, Chen et al:
c kq = 1.93e4 * EXP(-5639/wc(iw))
IF(phi0 .GT. 0.) THEN
IF (wc(iw) .GE. 380. .AND. wc(iw) .LE. 440.) THEN
qy = phi0 / (phi0 + kq * airden(i) * 760./2.456E19)
ELSE
qy = phi0
ENDIF
ELSE
qy = 0.
ENDIF
ENDIF
sq(j,i,iw) = sig * qy
ENDDO
ENDDO
tpflag(j) = 2
RETURN
END
*=============================================================================*
SUBROUTINE r15(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CH3COCH3 photolysis=*
*= CH3COCH3 + hv -> Products =*
*= =*
*= Cross section: Choice between =*
*= (1) Calvert and Pitts =*
*= (2) Martinez et al., 1991, alson in IUPAC 97 =*
*= (3) NOAA, 1998, unpublished as of 01/98 =*
*= Quantum yield: Choice between =*
*= (1) Gardiner et al, 1984 =*
*= (2) IUPAC 97 =*
*= (3) McKeen et al., 1997 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER i, n
INTEGER n1, n2, n3, n4
REAL x1(kdata), x2(kdata), x3(kdata), x4(kdata)
REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw), yg3(kw), yg4(kw)
REAL qy
REAL sig
INTEGER ierr
INTEGER iw
REAL a, b, t, m, w
real fco, fac
INTEGER mabs, myld
**************** CH3COCH3 photodissociation
j = j + 1
jlabel(j) = 'CH3COCH3 -> CH3CO + CH3'
* options
* mabs for cross sections
* myld for quantum yields
* Absorption:
* 1: cross section from Calvert and Pitts
* 2: Martinez et al. 1991, also in IUPAC'97
* 3: NOAA 1998, unpublished as of Jan 98.
* 4: JPL-2011
* Quantum yield
* 1: Gardiner et al. 1984
* 2: IUPAC 97
* 3: McKeen, S. A., T. Gierczak, J. B. Burkholder, P. O. Wennberg, T. F. Hanisco,
* E. R. Keim, R.-S. Gao, S. C. Liu, A. R. Ravishankara, and D. W. Fahey,
* The photochemistry of acetone in the upper troposphere: a source of
* odd-hydrogen radicals, Geophys. Res. Lett., 24, 3177-3180, 1997.
* 4: Blitz, M. A., D. E. Heard, M. J. Pilling, S. R. Arnold, and M. P. Chipperfield
* (2004), Pressure and temperature-dependent quantum yields for the
* photodissociation of acetone between 279 and 327.5 nm, Geophys.
* Res. Lett., 31, L06111, doi:10.1029/2003GL018793.
mabs = 4
myld = 4
IF (mabs .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCH3/CH3COCH3_cp.abs',
$ STATUS='old')
DO i = 1, 6
READ(UNIT=ilu,FMT=*)
ENDDO
n = 35
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 3.82E-21
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 2) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCH3/CH3COCH3_iup.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 96
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 3) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCH3/CH3COCH3_noaa.abs',
$ STATUS='old')
DO i = 1, 12
READ(UNIT=ilu,FMT=*)
ENDDO
n = 135
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i), y3(i)
x2(i) = x1(i)
x3(i) = x1(i)
ENDDO
CLOSE (UNIT=ilu)
n1 = n
n2 = n
n3 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 0.,0.)
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1.e+38,0.)
CALL inter2(nw,wl,yg3,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs.eq.4) then
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCH3/CH3COCH3_jpl11.abs',
$ STATUS='old')
DO i = 1, 5
READ(UNIT=ilu,FMT=*)
ENDDO
n = 135
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i), y3(i), y4(i)
x2(i) = x1(i)
x3(i) = x1(i)
x4(i) = x1(i)
y1(i) = y1(i) * 1.e-20
y2(i) = y2(i) / 1.e3
y3(i) = y3(i) / 1.e5
y4(i) = y4(i) / 1.e8
ENDDO
CLOSE (UNIT=ilu)
n1 = n
n2 = n
n3 = n
n4 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 0.,0.)
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1.e+38,0.)
CALL inter2(nw,wl,yg3,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x4,y4,kdata,n4,x4(1)*(1.-deltax),0.)
CALL addpnt(x4,y4,kdata,n4, 0.,0.)
CALL addpnt(x4,y4,kdata,n4,x4(n4)*(1.+deltax),0.)
CALL addpnt(x4,y4,kdata,n4, 1.e+38,0.)
CALL inter2(nw,wl,yg4,n4,x4,y4,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
IF (myld .EQ. 2) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCH3/CH3COCH3_iup.yld',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 9
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
DO iw = 1, nw - 1
DO i = 1, nz
sig = yg(iw)
IF(mabs .EQ. 3) THEN
*!!! this definition of t is not consistent with JPL2011
t = 298. - tlev(i)
t = MIN(t, 298.-235.)
t = MAX(t, 0.)
sig = yg(iw)*(1. + yg2(iw)*t + yg3(iw)*t*t
$ + yg4(iw)*t*t*t)
ELSEIF (mabs .eq. 4)THEN
t = MIN(MAX(tlev(i), 235.),298.)
sig = yg(iw)*(1. + yg2(iw)*t + yg3(iw)*t*t
$ + yg4(iw)*t*t*t)
ENDIF
IF (myld .EQ. 1) THEN
qy = 0.0766 + 0.09415*EXP(-airden(i)/3.222e18)
ELSEIF (myld .EQ. 2) THEN
qy = yg1(iw)
ELSEIF (myld .EQ. 3) THEN
IF (wc(iw) .LE. 292.) THEN
qy = 1.
ELSEIF (wc(iw) .GE. 292. .AND. wc(iw) .LT. 308. ) THEN
a = -15.696 + 0.05707*wc(iw)
b = EXP(-88.81+0.15161*wc(iw))
qy = 1./(a + b*airden(i))
ELSEIF (wc(iw) .GE. 308. .AND. wc(iw) .LT. 337. ) THEN
a = -130.2 + 0.42884*wc(iw)
b = EXP(-55.947+0.044913*wc(iw))
qy = 1./(a + b*airden(i))
ELSEIF (wc(iw) .GE. 337.) THEN
qy = 0.
ENDIF
qy = max(0., qy)
qy = min(1., qy)
ELSEIF (myld .eq. 4) then
w = wc(iw)
t = tlev(i)
m = airden(i)
CALL qyacet(w, t, m, fco, fac)
qy = min(1., max(0.,fac))
ENDIF
sq(j,i,iw) = sig*qy
ENDDO
ENDDO
* both T and P
tpflag(j) = 3
RETURN
END
*=============================================================================*
SUBROUTINE r16(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CH3OOH photolysis: =*
*= CH3OOH + hv -> CH3O + OH =*
*= =*
*= Cross section: Choice between =*
*= (1) JPL 97 recommendation (based on Vaghjiana and =*
*= Ravishankara, 1989), 10 nm resolution =*
*= (2) IUPAC 97 (from Vaghjiana and Ravishankara, 1989), =*
*= 5 nm resolution =*
*= (3) Cox and Tyndall, 1978; only for wavelengths < 280 nm =*
*= (4) Molina and Arguello, 1979; might be 40% too high =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER i, n
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER ierr
INTEGER idum
INTEGER iw
INTEGER mabs
**************** CH3OOH photodissociation
j = j + 1
jlabel(j) = 'CH3OOH -> CH3O + OH'
* mabs: Absorption cross section options:
* 1: JPL data base (1985,92,94,97). 1997 is from Vaghjiani and Ravishankara (1989), at
* 10 nm resolution
* 2: IUPAC97 (from Vaghjiani and Ravishankara (1989) at 5 nm resolution).
* 3: Cox and Tyndall (1978), only for wavelengths < 280 nm
* 4: Molina and Arguello (1979). According to Vaghjiani and Ravishankara (1989),
* Molina and Arguello had a problem measuring CH3OOH, cross sections 40% too high.
* 5: JPL2011
mabs = 5
IF (mabs .EQ. 1) THEN
c OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3OOH/CH3OOH_jpl85.abs',
c $ STATUS='old')
c OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3OOH/CH3OOH_jpl92.abs',
c $ STATUS='old')
c OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3OOH/CH3OOH_jpl94.abs',
c $ STATUS='old')
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3OOH/CH3OOH_jpl94.abs',
$ STATUS='old')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (mabs .EQ. 2) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3OOH/CH3OOH_iup.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 32
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (mabs .EQ. 3) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3OOH/CH3OOH_ct.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 12
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (mabs .EQ. 4) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3OOH/CH3OOH_ma.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 15
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (mabs .EQ. 5) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3OOH/CH3OOH_jpl11.abs',
$ STATUS='old')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 40
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = yg(iw)*qy
ENDDO
ENDDO
* no T or P dep
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r17(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CH3ONO2 =*
*= photolysis: =*
*= CH3ONO2 + hv -> CH3O + NO2 =*
*= =*
*= Cross section: Choice between =*
*= (1) Calvert and Pitts, 1966 =*
*= (2) Talukdar, Burkholder, Hunter, Gilles, Roberts, =*
*= Ravishankara, 1997 =*
*= (3) IUPAC 97, table of values for 198K =*
*= (4) IUPAC 97, temperature-dependent equation =*
*= (5) Taylor et al, 1980 =*
*= (6) fit from Roberts and Fajer, 1989 =*
*= (7) Rattigan et al., 1992 =*
*= (8) Libuda and Zabel, 1995 =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER (kdata = 2000)
INTEGER i, n
INTEGER iw
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg1(kw)
REAL qy
REAL sig
INTEGER ierr
INTEGER mabs, myld
**************** CH3ONO2 photodissociation
j = j + 1
jlabel(j) = 'CH3ONO2 -> CH3O + NO2'
* mabs: absorption cross section options:
* 1: Calvert and Pitts 1966
* 2: Talukdar, Burkholder, Hunter, Gilles, Roberts, Ravishankara, 1997.
* 3: IUPAC-97, table of values for 298K.
* 4: IUPAC-97, temperature-dependent equation
* 5: Taylor et al. 1980
* 6: fit from Roberts and Fajer, 1989
* 7: Rattigan et al. 1992
* 8: Libuda and Zabel 1995
* 9: JPL2011 including T-dependence
mabs = 9
IF (mabs .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/CH3ONO2_cp.abs',
& STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 15
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 2) THEN
* sigma(T,lambda) = sigma(298,lambda) * exp(B * (T-298))
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/CH3ONO2_tal.abs',
& STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 55
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
x2(i) = x1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE (UNIT=ilu)
n1 = n
n2 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),y2(1))
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),y2(n2))
CALL addpnt(x2,y2,kdata,n2, 1.e+38,y2(n2))
CALL inter2(nw,wl,yg1,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (mabs .EQ. 3) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/CH3ONO2_iup1.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 13
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i)*1e-20
ENDDO
CLOSE (UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 4) THEN
* sigma(T,lambda) = sigma(298,lambda) * 10**(B * T)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/CH3ONO2_iup2.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 7
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
x2(i) = x1(i)
y1(i) = y1(i) * 1.e-21
y2(i) = y2(i) * 1.e-3
ENDDO
CLOSE (UNIT=ilu)
n1 = n
n2 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),-36.)
CALL addpnt(x1,y1,kdata,n1, 0.,-36.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),-36.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,-36.)
CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),y2(1))
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),y2(n2))
CALL addpnt(x2,y2,kdata,n2, 1.e+38,y2(n2))
CALL inter2(nw,wl,yg1,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (mabs .EQ. 5) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/CH3ONO2_tay.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 13
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (mabs .EQ. 6) THEN
DO iw = 1, nw-1
IF(wc(iw) .GT. 284.) THEN
yg(iw) = EXP(-1.044e-3*wc(iw)*wc(iw) +
$ 0.5309*wc(iw) - 112.4)
ELSE
yg(iw) = 0.
ENDIF
ENDDO
ELSEIF (mabs .EQ. 7) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/CH3ONO2_rat.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 24
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (mabs .EQ. 8) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/CH3ONO2_lib.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 1638
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE (UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (mabs. eq. 9) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/CH3ONO2_jpl11.abs',
$ STATUS='old')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 65
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
y1(i) = y1(i) * 1.e-20
x2(i) = x1(i)
y2(i) = y2(i) * 1.e-3
ENDDO
CLOSE (UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
n2 = n
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
sig = yg(iw)
DO i = 1, nz
IF(mabs .EQ. 2 .OR. mabs .EQ. 9) THEN
sig = yg(iw) * exp (yg1(iw) * (tlev(i)-298.))
ELSEIF (mabs .EQ. 4) THEN
sig = yg(iw)*10.**(yg1(iw)*tlev(i))
ENDIF
sq(j,i,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r18(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for PAN photolysis: =*
*= PAN + hv -> Products =*
*= =*
*= Cross section: from Talukdar et al., 1995 =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER iw
INTEGER i, n
INTEGER n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg2(kw)
real qyNO2, qyNO3
REAL sig
INTEGER ierr
**************** PAN photodissociation
j = j+1
jlabel(j) = 'CH3CO(OONO2) -> CH3CO(OO) + NO2'
j = j+1
jlabel(j) = 'CH3CO(OONO2) -> CH3CO(O) + NO3'
* cross section from Senum et al., 1984, J.Phys.Chem. 88/7, 1269-1270
C OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/PAN_senum.abs',STATUS='OLD')
C DO i = 1, 14
C READ(UNIT=ilu,FMT=*)
C ENDDO
C n = 21
C DO i = 1, n
C READ(UNIT=ilu,FMT=*) x1(i), y1(i)
C y1(i) = y1(i) * 1.E-20
C ENDDO
C CLOSE(UNIT=ilu)
C CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 0.,0.)
C CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
C CALL inter2(nw,wl,yg,n,x1,y1,ierr)
C IF (ierr .NE. 0) THEN
C WRITE(*,*) ierr, jlabel(j)
C STOP
C ENDIF
* cross section from
* Talukdar et al., 1995, J.Geophys.Res. 100/D7, 14163-14174
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/PAN_talukdar.abs',
& STATUS='old')
DO i = 1, 14
READ(UNIT=ilu,FMT=*)
ENDDO
n = 78
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
y1(i) = y1(i) * 1.E-20
y2(i) = y2(i) * 1E-3
x2(i) = x1(i)
ENDDO
n2 = n
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield:
* from JPL 2011 values for >300 nm.
qyNO2 = 0.7
qyNO3 = 0.3
DO iw = 1, nw-1
DO i = 1, nz
sig = yg(iw) * EXP(yg2(iw)*(tlev(i)-298.))
sq(j-1,i,iw) = qyNO2 * sig
sq(j,i,iw) = qyNO3 * sig
ENDDO
ENDDO
tpflag(j-1) = 1
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r19(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CCl2O photolysis: =*
*= CCl2O + hv -> Products =*
*= =*
*= Cross section: JPL 94 recommendation =*
*= Quantum yield: Unity (Calvert and Pitts) =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
************* CCl2O photodissociation
j = j+1
jlabel(j) = 'CCl2O -> Products'
*** cross sections from JPL94 recommendation
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CCl2O_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
*** quantum yield unity (Calvert and Pitts)
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r20(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CCl4 photolysis: =*
*= CCl4 + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
INTEGER mabs
REAL b0, b1, b2, b3, b4, tcoeff, sig
REAL w1, w2, w3, w4, temp
**************************************************************
************* CCl4 photodissociation
j = j+1
jlabel(j) = 'CCl4 -> Products'
* mabs = 1: jpl 1997 recommendation
* mabs = 2: jpl 2011 recommendation, with T dependence
mabs = 2
*** cross sections from JPL97 recommendation (identical to 94 data)
IF(mabs .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CCl4_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 2) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CCl4_jpl11.abs',STATUS='OLD')
DO i = 1, 5
READ(UNIT=ilu,FMT=*)
ENDDO
n = 44
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* compute temperature correction factors:
b0 = 1.0739
b1 = -1.6275e-2
b2 = 8.8141e-5
b3 = -1.9811e-7
b4 = 1.5022e-10
*** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
* compute temperature correction coefficients:
tcoeff = 0.
IF(wc(iw) .GT. 194. .AND. wc(iw) .LT. 250.) THEN
w1 = wc(iw)
w2 = w1**2
w3 = w1**3
w4 = w1**4
tcoeff = b0 + b1*w1 + b2*w2 + b3*w3 + b4*w4
ENDIF
DO iz = 1, nz
IF(mabs .EQ. 1) THEN
sig = yg(iw)
ELSEIF (mabs .EQ. 2) THEN
temp = tlev(iz)
temp = min(max(temp,210.),300.)
sig = yg(iw) * 10.**(tcoeff*(temp-295.))
ENDIF
sq(j,iz,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r21(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CClFO photolysis: =*
*= CClFO + hv -> Products =*
*= Cross section: from JPL 97 =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CClFO photodissociation
j = j+1
jlabel(j) = 'CClFO -> Products'
*** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CClFO_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
*** quantum yield unity
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r22(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CF2O photolysis: =*
*= CF2O + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: unity (Nolle et al.) =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CF2O photodissociation
j = j+1
jlabel(j) = 'CF2O -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CF2O_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
*** quantum yield unity (Nolle et al.)
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r23(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CFC-113 photolysis:=*
*= CF2ClCFCl2 + hv -> Products =*
*= Cross section: from JPL 97 recommendation, linear interp. between =*
*= values at 210 and 295K =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg1(kw), yg2(kw)
REAL qy
REAL t
INTEGER i, iw, n, idum
INTEGER iz
INTEGER ierr
REAL slope
**************************************************************
************* CF2ClCFCl2 (CFC-113) photodissociation
j = j+1
jlabel(j) = 'CF2ClCFCl2 (CFC-113) -> Products'
*** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CFC-113_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
y1(i) = y1(i) * 1E-20
y2(i) = y2(i) * 1E-20
x2(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
n1 = n
n2 = n
** sigma @ 295 K
CALL addpnt(x1,y1,kdata,n1, x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* sigma @ 210 K
CALL addpnt(x2,y2,kdata,n2, x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
*** quantum yield assumed to be unity
qy = 1.
DO iz = 1, nz
t = MAX(210.,MIN(tlev(iz),295.))
slope = (t-210.)/(295.-210.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * (yg2(iw) + slope*(yg1(iw)-yg2(iw)))
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r24(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CFC-144 photolysis:=*
*= CF2ClCF2Cl + hv -> Products =*
*= Cross section: from JPL 97 recommendation, linear interp. between values =*
*= at 210 and 295K =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg1(kw), yg2(kw)
REAL qy
REAL t
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
REAL slope
**************************************************************
************* CF2ClCF2Cl (CFC-114) photodissociation
j = j+1
jlabel(j) = 'CF2ClCF2Cl (CFC-114) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CFC-114_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
y1(i) = y1(i) * 1E-20
y2(i) = y2(i) * 1E-20
x2(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
n1 = n
n2 = n
** sigma @ 295 K
CALL addpnt(x1,y1,kdata,n1, x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* sigma @ 210 K
CALL addpnt(x2,y2,kdata,n2, x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
*** quantum yield assumed to be unity
qy = 1.
DO iz = 1, nz
t = MAX(210.,MIN(tlev(iz),295.))
slope = (t-210.)/(295.-210.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * (yg2(iw) + slope*(yg1(iw)-yg2(iw)))
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r25(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CFC-115 photolysis =*
*= CF3CF2Cl + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CF3CF2Cl (CFC-115) photodissociation
j = j+1
jlabel(j) = 'CF3CF2Cl (CFC-115) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CFC-115_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r26(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CFC-111 photolysis =*
*= CCl3F + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
REAL t
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CCl3F (CFC-11) photodissociation
j = j+1
jlabel(j) = 'CCl3F (CFC-11) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CFC-11_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
** sigma @ 298 K
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iz = 1, nz
t = 1E-04 * (tlev(iz)-298.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * yg(iw) * EXP((wc(iw)-184.9) * t)
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r27(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CFC-112 photolysis:=*
*= CCl2F2 + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
REAL t
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CCl2F2 (CFC-12) photodissociation
j = j+1
jlabel(j) = 'CCl2F2 (CFC-12) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CFC-12_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
** sigma @ 298 K
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iz = 1, nz
t = 1E-04 * (tlev(iz)-298.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * yg(iw) * EXP((wc(iw)-184.9) * t)
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r28(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CH3Br photolysis: =*
*= CH3Br + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CH3Br photodissociation
* data from JPL97 (identical to 94 recommendation)
j = j+1
jlabel(j) = 'CH3Br -> Products'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CH3Br_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r29(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CH3CCl3 photolysis =*
*= CH3CCl3 + hv -> Products =*
*= Cross section: from JPL 97 recommendation, piecewise linear interp. =*
*= of data at 210, 250, and 295K =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER n1, n2, n3
REAL x1(kdata), x2(kdata), x3(kdata)
REAL y1(kdata), y2(kdata), y3(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw), yg3(kw)
REAL qy
REAL t
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
REAL slope
**************************************************************
************* CH3CCl3 photodissociation
j = j+1
jlabel(j) = 'CH3CCl3 -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CH3CCl3_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i), y3(i)
y1(i) = y1(i) * 1E-20
y2(i) = y2(i) * 1E-20
y3(i) = y3(i) * 1E-20
x2(i) = x1(i)
x3(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
n1 = n
n2 = n
n3 = n
** sigma @ 295 K
CALL addpnt(x1,y1,kdata,n1, x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
** sigma @ 250 K
CALL addpnt(x2,y2,kdata,n2, x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
** sigma @ 210 K
CALL addpnt(x3,y3,kdata,n3, x3(1)*(1.-deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 0.,0.)
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1E38,0.)
CALL inter2(nw,wl,yg3,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iz = 1, nz
t = MIN(295.,MAX(tlev(iz),210.))
IF (t .LE. 250.) THEN
slope = (t-210.)/(250.-210.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * (yg3(iw) + slope*(yg2(iw)-yg3(iw)))
ENDDO
ELSE
slope = (t-250.)/(295.-250.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * (yg2(iw) + slope*(yg1(iw)-yg2(iw)))
ENDDO
ENDIF
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r30(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CH3Cl photolysis: =*
*= CH3Cl + hv -> Products =*
*= Cross section: from JPL 97 recommendation, piecewise linear interp. =*
*= from values at 255, 279, and 296K =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER n1, n2, n3
REAL x1(kdata), x2(kdata), x3(kdata)
REAL y1(kdata), y2(kdata), y3(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw), yg3(kw)
REAL qy
REAL t
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
REAL slope
**************************************************************
************* CH3Cl photodissociation
j = j+1
jlabel(j) = 'CH3Cl -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CH3Cl_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i), y3(i)
y1(i) = y1(i) * 1E-20
y2(i) = y2(i) * 1E-20
y3(i) = y3(i) * 1E-20
x2(i) = x1(i)
x3(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
n1 = n
n2 = n
n3 = n
** sigma @ 296 K
CALL addpnt(x1,y1,kdata,n1, x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
** sigma @ 279 K
CALL addpnt(x2,y2,kdata,n2, x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
** sigma @ 255 K
CALL addpnt(x3,y3,kdata,n3, x3(1)*(1.-deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 0.,0.)
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1E38,0.)
CALL inter2(nw,wl,yg3,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iz = 1, nz
t = MAX(255.,MIN(tlev(i),296.))
IF (t .LE. 279.) THEN
slope = (t-255.)/(279.-255.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * (yg3(iw)+slope*(yg2(iw)-yg3(iw)))
ENDDO
ELSE
slope = (t-279.)/(296.-279.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * (yg2(iw)+slope*(yg1(iw)-yg2(iw)))
ENDDO
ENDIF
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r31(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for ClOO photolysis: =*
*= ClOO + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
C INTEGER n1, n2, n3, n4, n5
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* ClOO photodissociation
j = j+1
jlabel(j) = 'ClOO -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/ClOO_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r32(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for HCFC-123 photolysis=*
*= CF3CHCl2 + hv -> Products =*
*= Cross section: from Orlando et al., 1991 =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* local
REAL qy
REAL t
INTEGER i, iw, idum
INTEGER iz, k
REAL lambda, sum
CHARACTER*120 inline
REAL coeff(4,3), TBar, LBar
**************************************************************
************* CF3CHCl2 (HCFC-123) photodissociation
j = j+1
jlabel(j) = 'CF3CHCl2 (HCFC-123) -> Products'
**** cross sections from JPL94 recommendation
C OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HCFC-123_jpl94.abs',STATUS='OLD')
C READ(UNIT=ilu,FMT=*) idum, n
C DO i = 1, idum-2
C READ(UNIT=ilu,FMT=*)
C ENDDO
C DO i = 1, n
C READ(UNIT=ilu,FMT=*) x1(i), y1(i)
C y1(i) = y1(i) * 1E-20
C ENDDO
C CLOSE(UNIT=ilu)
C CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 0.,0.)
C CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 1E38,0.)
C CALL inter2(nw,wl,yg,n,x1,y1,ierr)
C IF (ierr .NE. 0) THEN
C WRITE(*,*) ierr, jlabel(j)
C STOP
C ENDIF
**** quantum yield assumed to be unity
C qy = 1.
C DO iw = 1, nw-1
C DO iz = 1, nz
C sq(j,iz,iw) = qy * yg(iw)
C ENDDO
C ENDDO
**** cross section from Orlando et al., 1991
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
READ(UNIT=ilu,FMT=100) inline
100 FORMAT(A120)
READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3)
READ(UNIT=ilu,FMT=*) i,(coeff(i,k),k=1,3)
READ(UNIT=ilu,FMT=*) i,(coeff(i,k),k=1,3)
READ(UNIT=ilu,FMT=*) i,(coeff(i,k),k=1,3)
CLOSE(UNIT=ilu)
LBar = 206.214
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
lambda = wc(iw)
C use parameterization only up to 220 nm, as the error bars associated with
C the measurements beyond 220 nm are very large (Orlando, priv.comm.)
IF (lambda .GE. 190. .AND. lambda .LE. 220.) THEN
DO iz = 1, nz
t = MIN(295.,MAX(tlev(i),203.))-TBar
sum = 0.
DO i = 1, 4
sum = (coeff(i,1)+t*(coeff(i,2)+t*coeff(i,3))) *
> (lambda-LBar)**(i-1) + sum
ENDDO
sq(j,iz,iw) = qy * EXP(sum)
ENDDO
ELSE
DO iz = 1, nz
sq(j,iz,iw) = 0.
ENDDO
ENDIF
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r33(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for HCFC-124 photolysis=*
*= CF3CHFCl + hv -> Products =*
*= Cross section: from Orlando et al., 1991 =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
* local
REAL qy
REAL t
INTEGER i, iw, n, idum
INTEGER iz, k
REAL lambda, sum
CHARACTER*120 inline
REAL coeff(4,3), TBar, LBar
**************************************************************
************* CF3CHFCl (HCFC-124) photodissociation
j = j+1
jlabel(j) = 'CF3CHFCl (HCFC-124) -> Products'
**** cross sections from JPL94 recommendation
C OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HCFC-124_jpl94.abs',STATUS='OLD')
C READ(UNIT=ilu,FMT=*) idum, n
C DO i = 1, idum-2
C READ(UNIT=ilu,FMT=*)
C ENDDO
C DO i = 1, n
C READ(UNIT=ilu,FMT=*) x1(i), y1(i)
C y1(i) = y1(i) * 1E-20
C ENDDO
C CLOSE(UNIT=ilu)
C CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 0.,0.)
C CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 1E38,0.)
C CALL inter2(nw,wl,yg,n,x1,y1,ierr)
C IF (ierr .NE. 0) THEN
C WRITE(*,*) ierr, jlabel(j)
C STOP
C ENDIF
**** quantum yield assumed to be unity
C qy = 1.
C DO iw = 1, nw-1
C DO iz = 1, nz
C sq(j,iz,iw) = qy * yg(iw)
C ENDDO
C ENDDO
**** cross section from Orlando et al., 1991
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum
idum = idum+5
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
READ(UNIT=ilu,FMT=100) inline
100 FORMAT(A120)
READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3)
READ(UNIT=ilu,FMT=*) i,(coeff(i,k),k=1,3)
READ(UNIT=ilu,FMT=*) i,(coeff(i,k),k=1,3)
READ(UNIT=ilu,FMT=*) i,(coeff(i,k),k=1,3)
CLOSE(UNIT=ilu)
LBar = 206.214
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
lambda = wc(iw)
IF (lambda .GE. 190. .AND. lambda .LE. 230.) THEN
DO iz = 1, nz
t = MIN(295.,MAX(tlev(i),203.))-TBar
sum = 0.
DO i = 1, 4
sum = (coeff(i,1)+t*(coeff(i,2)+t*coeff(i,3))) *
> (lambda-LBar)**(i-1) + sum
ENDDO
sq(j,iz,iw) = qy * EXP(sum)
ENDDO
ELSE
DO iz = 1, nz
sq(j,iz,iw) = 0.
ENDDO
ENDIF
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r34(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for HCFC-141b =*
*= photolysis: =*
*= CH3CFCl2 + hv -> Products =*
*= Cross section: from JPL97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CH3CFCl2 (HCFC-141b) photodissociation
j = j+1
jlabel(j) = 'CH3CFCl2 (HCFC-141b) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HCFC-141b_jpl94.abs',
& STATUS='old')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r35(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for HCFC-142b =*
*= photolysis: =*
*= CH3CF2Cl + hv -> Products =*
*= Cross section: from Orlando et al., 1991 =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* local
REAL qy
REAL t
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz, k
REAL lambda, sum
CHARACTER*80 inline
REAL coeff(4,3), TBar, LBar
**************************************************************
************* CH3CF2Cl (HCFC-142b) photodissociation
j = j+1
jlabel(j) = 'CH3CF2Cl (HCFC-142b) -> Products'
**** cross sections from JPL94 recommendation
C OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HCFC-142b_jpl94.abs',STATUS='OLD')
C READ(UNIT=ilu,FMT=*) idum, n
C DO i = 1, idum-2
C READ(UNIT=ilu,FMT=*)
C ENDDO
C DO i = 1, n
C READ(UNIT=ilu,FMT=*) x1(i), y1(i)
C y1(i) = y1(i) * 1E-20
C ENDDO
C CLOSE(UNIT=ilu)
C CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 0.,0.)
C CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
C CALL addpnt(x1,y1,kdata,n, 1E38,0.)
C CALL inter2(nw,wl,yg,n,x1,y1,ierr)
C IF (ierr .NE. 0) THEN
C WRITE(*,*) ierr, jlabel(j)
C STOP
C ENDIF
**** quantum yield assumed to be unity
C qy = 1.
C DO iw = 1, nw-1
C DO iz = 1, nz
C sq(j,iz,iw) = qy * yg(iw)
C ENDDO
C ENDDO
**** cross section from Orlando et al., 1991
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum
idum = idum+10
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
READ(UNIT=ilu,FMT=100) inline
100 FORMAT(A80)
READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3)
READ(UNIT=ilu,FMT=*) i,(coeff(i,k),k=1,3)
READ(UNIT=ilu,FMT=*) i,(coeff(i,k),k=1,3)
READ(UNIT=ilu,FMT=*) i,(coeff(i,k),k=1,3)
CLOSE(UNIT=ilu)
LBar = 206.214
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
lambda = wc(iw)
IF (lambda .GE. 190. .AND. lambda .LE. 230.) THEN
DO iz = 1, nz
t = MIN(295.,MAX(tlev(i),203.))-TBar
sum = 0.
DO i = 1, 4
sum = (coeff(i,1)+t*(coeff(i,2)+t*coeff(i,3))) *
> (lambda-LBar)**(i-1) + sum
ENDDO
* offeset exponent by 40 (exp(-40.) = 4.248e-18) to prevent exp. underflow errors
* on some machines.
c sq(j,iz,iw) = qy * EXP(sum)
sq(j,iz,iw) = qy * 4.248e-18 * EXP(sum + 40.)
ENDDO
ELSE
DO iz = 1, nz
sq(j,iz,iw) = 0.
ENDDO
ENDIF
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r36(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for HCFC-225ca =*
*= photolysis: =*
*= CF3CF2CHCl2 + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CF3CF2CHCl2 (HCFC-225ca) photodissociation
j = j+1
jlabel(j) = 'CF3CF2CHCl2 (HCFC-225ca) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HCFC-225ca_jpl94.abs',
& STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r37(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for HCFC-225cb =*
*= photolysis: =*
*= CF2ClCF2CHFCl + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CF2ClCF2CHFCl (HCFC-225cb) photodissociation
j = j+1
jlabel(j) = 'CF2ClCF2CHFCl (HCFC-225cb) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HCFC-225cb_jpl94.abs',
& STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r38(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for HCFC-22 photolysis =*
*= CHClF2 + hv -> Products =*
*= Cross section: from JPL 97 recommendation, piecewise linear interp. =*
*= from values at 210, 230, 250, 279, and 295 K =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER n1, n2, n3, n4, n5
REAL x1(kdata), x2(kdata), x3(kdata), x4(kdata), x5(kdata)
REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata), y5(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw), yg3(kw), yg4(kw), yg5(kw)
REAL qy
REAL t
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
REAL slope
**************************************************************
************* CHClF2 (HCFC-22) photodissociation
j = j+1
jlabel(j) = 'CHClF2 (HCFC-22) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HCFC-22_jpl94.abs',STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i), y3(i), y4(i), y5(i)
y1(i) = y1(i) * 1E-20
y2(i) = y2(i) * 1E-20
y3(i) = y3(i) * 1E-20
y4(i) = y4(i) * 1E-20
y5(i) = y5(i) * 1E-20
x2(i) = x1(i)
x3(i) = x1(i)
x4(i) = x1(i)
x5(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
n1 = n
n2 = n
n3 = n
n4 = n
n5 = n
** sigma @ 295 K
CALL addpnt(x1,y1,kdata,n1, x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
** sigma @ 270 K
CALL addpnt(x2,y2,kdata,n2, x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
** sigma @ 250 K
CALL addpnt(x3,y3,kdata,n3, x3(1)*(1.-deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 0.,0.)
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1E38,0.)
CALL inter2(nw,wl,yg3,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
** sigma @ 230 K
CALL addpnt(x4,y4,kdata,n4, x4(1)*(1.-deltax),0.)
CALL addpnt(x4,y4,kdata,n4, 0.,0.)
CALL addpnt(x4,y4,kdata,n4,x4(n4)*(1.+deltax),0.)
CALL addpnt(x4,y4,kdata,n4, 1E38,0.)
CALL inter2(nw,wl,yg4,n4,x4,y4,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
** sigma @ 210 K
CALL addpnt(x5,y5,kdata,n5, x5(1)*(1.-deltax),0.)
CALL addpnt(x5,y5,kdata,n5, 0.,0.)
CALL addpnt(x5,y5,kdata,n5,x5(n5)*(1.+deltax),0.)
CALL addpnt(x5,y5,kdata,n5, 1E38,0.)
CALL inter2(nw,wl,yg5,n5,x5,y5,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iz = 1, nz
t = MIN(295.,MAX(tlev(iz),210.))
IF (t .LE. 230.) THEN
slope = (t-210.)/(230.-210.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * (yg5(iw)+slope*(yg4(iw)-yg5(iw)))
ENDDO
ELSEIF (t .LE. 250.) THEN
slope = (t-230.)/(250.-230.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * (yg4(iw)+slope*(yg3(iw)-yg4(iw)))
ENDDO
ELSEIF (t .LE. 270.) THEN
slope = (t-250.)/(270.-250.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * (yg3(iw)+slope*(yg2(iw)-yg3(iw)))
ENDDO
ELSE
slope = (t-270.)/(295.-270.)
DO iw = 1, nw-1
sq(j,iz,iw) = qy * (yg2(iw)+slope*(yg1(iw)-yg2(iw)))
ENDDO
ENDIF
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r39(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for HO2 photolysis: =*
*= HO2 + hv -> OH + O =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed shape based on work by Lee, 1982; normalized =*
*= to unity at 248 nm =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* HO2 photodissociation
j = j+1
jlabel(j) = 'HO2 -> OH + O'
**** cross sections from JPL11 recommendation
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HO2_jpl11.abs',STATUS='OLD')
DO i = 1, 10
READ(UNIT=ilu,FMT=*)
ENDDO
n = 15
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield: absolute quantum yield has not been reported yet, but
**** Lee measured a quantum yield for O(1D) production at 248
**** nm that was 15 time larger than at 193 nm
**** here: a quantum yield of unity is assumed at 248 nm and beyond, for
**** shorter wavelengths a linear decrease with lambda is assumed
DO iw = 1, nw-1
IF (wc(iw) .GE. 248.) THEN
qy = 1.
ELSE
qy = 1./15. + (wc(iw)-193.)*(14./15.)/(248.-193.)
qy = MAX(qy,0.)
ENDIF
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r40(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) Halon-1202 photolysis: =*
*= CF2Br2 + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: unity (Molina and Molina) =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CF2Br2 (Halon-1202) photodissociation
j = j+1
jlabel(j) = 'CF2Br2 (Halon-1202) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Halon-1202_jpl97.abs',
& STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield unity (Molina and Molina)
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r41(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for Halon-1211 =*
*= photolysis: =*
*= CF2ClBr + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CF2BrCl (Halon-1211) photodissociation
j = j+1
jlabel(j) = 'CF2BrCl (Halon-1211) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Halon-1211_jpl97.abs',
& STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r42(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for Halon-1301 =*
*= photolysis: =*
*= CF3Br + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CF3Br (Halon-1301) photodissociation
j = j+1
jlabel(j) = 'CF3Br (Halon-1301) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Halon-1301_jpl97.abs',
& STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r43(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for Halon-2402 =*
*= photolysis: =*
*= CF2BrCF2Br + hv -> Products =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
**************************************************************
************* CF2BrCF2Br (Halon-2402) photodissociation
j = j+1
jlabel(j) = 'CF2BrCF2Br (Halon-2402) -> Products'
**** cross sections from JPL97 recommendation (identical to 94 recommendation)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Halon-2402_jpl97.abs',
& STATUS='OLD')
READ(UNIT=ilu,FMT=*) idum, n
DO i = 1, idum-2
READ(UNIT=ilu,FMT=*)
ENDDO
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
**** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
DO iz = 1, nz
sq(j,iz,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r44(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for N2O photolysis: =*
*= N2O + hv -> N2 + O(1D) =*
*= Cross section: from JPL 97 recommendation =*
*= Quantum yield: assumed to be unity, based on Greenblatt and Ravishankara =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* local
REAL qy
REAL a, b, c
REAL a0, a1, a2, a3, a4
REAL b0, b1, b2, b3
REAL t
INTEGER iw, iz
REAL lambda
**************************************************************
************* N2O photodissociation
j = j+1
jlabel(j) = 'N2O -> N2 + O(1D)'
**** cross sections according to JPL97 recommendation (identical to 94 rec.)
**** see file DATAJ1/ABS/N2O_jpl94.abs for detail
A0 = 68.21023
A1 = -4.071805
A2 = 4.301146E-02
A3 = -1.777846E-04
A4 = 2.520672E-07
B0 = 123.4014
B1 = -2.116255
B2 = 1.111572E-02
B3 = -1.881058E-05
**** quantum yield of N(4s) and NO(2Pi) is less than 1% (Greenblatt and
**** Ravishankara), so quantum yield of O(1D) is assumed to be unity
qy = 1.
DO iw = 1, nw-1
lambda = wc(iw)
IF (lambda .GE. 173. .AND. lambda .LE. 240.) THEN
DO iz = 1, nz
t = MAX(194.,MIN(tlev(iz),320.))
A = (((A4*lambda+A3)*lambda+A2)*lambda+A1)*lambda+A0
B = (((B3*lambda+B2)*lambda+B1)*lambda+B0)
B = (t-300.)*EXP(B)
sq(j,iz,iw) = qy * EXP(A+B)
ENDDO
ELSE
DO iz = 1, nz
sq(j,iz,iw) = 0.
ENDDO
ENDIF
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r45(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for ClONO2 photolysis: =*
*= ClONO2 + hv -> Products =*
*= =*
*= Cross section: JPL 97 recommendation =*
*= Quantum yield: JPL 97 recommendation =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
REAL x1(kdata),x2(kdata),x3(kdata)
REAL y1(kdata),y2(kdata),y3(kdata)
INTEGER n1, n2, n3
* local
REAL yg1(kw), yg2(kw), yg3(kw)
REAL qy1, qy2
REAL xs
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
************* ClONO2 photodissociation
j = j+1
jlabel(j) = 'ClONO2 -> Cl + NO3'
j = j+1
jlabel(j) = 'ClONO2 -> ClO + NO2'
*** cross sections from JPL97 recommendation. Same in JPL-2011.
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/ClONO2_jpl97.abs',STATUS='OLD')
n = 119
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i), y3(i)
y1(i) = y1(i) * 1E-20
x2(i) = x1(i)
x3(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
n2 = n
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
n3 = n
CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 0.,0.)
CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
CALL addpnt(x3,y3,kdata,n3, 1E38,0.)
CALL inter2(nw,wl,yg3,n3,x3,y3,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
DO iw = 1, nw-1
*** quantum yields (from jpl97, same in jpl2011)
IF( wc(iw) .LT. 308.) THEN
qy1 = 0.6
ELSEIF( (wc(iw) .GE. 308) .AND. (wc(iw) .LE. 364.) ) THEN
qy1 = 7.143e-3 * wc(iw) - 1.6
ELSEIF( wc(iw) .GT. 364. ) THEN
qy1 = 1.0
ENDIF
qy2 = 1. - qy1
* compute T-dependent cross section
DO iz = 1, nz
xs = yg1(iw)*( 1. +
$ yg2(iw)*(tlev(iz)-296) +
$ yg3(iw)*(tlev(iz)-296)*(tlev(iz)-296))
sq(j-1,iz,iw) = qy1 * xs
sq(j,iz,iw) = qy2 * xs
ENDDO
ENDDO
tpflag(j-1) = 1
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r46(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for BrONO2 photolysis: =*
*= BrONO2 + hv -> Products =*
*= =*
*= Cross section: JPL 03 recommendation =*
*= Quantum yield: JPL 03 recommendation =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
INTEGER n1, n2, n3
* local
REAL yg1(kw)
REAL qyNO2, qyNO3
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
************* BrONO2 photodissociation
j = j+1
jlabel(j) = 'BrONO2 -> BrO + NO2'
j = j+1
jlabel(j) = 'BrONO2 -> Br + NO3'
*** cross sections from JPL03 recommendation
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/BrONO2_jpl03.abs',STATUS='OLD')
DO i = 1, 13
READ(UNIT=ilu,FMT=*)
ENDDO
n = 61
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
*** quantum yields (from jpl97)
qyNO2 = 0.15
qyNO3 = 0.85
DO iw = 1, nw-1
DO iz = 1, nz
sq(j-1,iz,iw) = qyNO2 * yg1(iw)
sq(j,iz,iw) = qyNO3 * yg1(iw)
ENDDO
ENDDO
tpflag(j-1) = 0
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r47(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for Cl2 photolysis: =*
*= Cl2 + hv -> 2 Cl =*
*= =*
*= Cross section: JPL 97 recommendation =*
*= Quantum yield: 1 (Calvert and Pitts, 1966) =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER i, n
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER iz, iw
INTEGER ierr
integer mabs
real aa, bb, ex1, ex2, sig, alpha(kz)
************* CL2 photodissociation
j = j+1
jlabel(j) = 'Cl2 -> Cl + Cl'
* mabs = 1: Finlayson-Pitts and Pitts
* mabs = 2: JPL2011 formula
mabs = 2
IF (mabs .EQ. 1) THEN
*** cross sections from JPL97 recommendation (as tab by Finlayson-Pitts
* and Pitts, 1999.
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CL2_fpp.abs',STATUS='OLD')
do i = 1, 5
read(UNIT=ilu,FMT=*)
enddo
n = 22
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 2) THEN
DO iz = 1, nz
aa = 402.7/tlev(iz)
bb = exp(aa)
alpha(iz) = (bb - 1./bb) / (bb + 1./bb)
ENDDO
ENDIF
*** quantum yield = 1 (Calvert and Pitts, 1966)
qy = 1.
DO iw = 1, nw-1
if(mabs .eq. 1) sig = yg(iw)
DO iz = 1, nz
if (mabs .eq. 2) then
ex1 = 27.3 * exp(-99.0 * alpha(iz) * (log(329.5/wc(iw)))**2)
ex2 = 0.932 * exp(-91.5 * alpha(iz) * (log(406.5/wc(iw)))**2)
sig = 1e-20 * alpha(iz)**0.5 * (ex1 + ex2)
ENDIF
sq(j,iz,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r101(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for CH2(OH)CHO =*
*= (glycolaldehye, hydroxy acetaldehyde) photolysis: =*
*= CH2(OH)CHO + hv -> Products =*
*= =*
*= Cross section from =*
*= The Atmospheric Chemistry of Glycolaldehyde, C. Bacher, G. S. Tyndall =*
*= and J. J. Orlando, J. Atmos. Chem., 39 (2001) 171-189. =*
*= =*
*= Quantum yield about 50% =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=300)
INTEGER i, n
REAL x(kdata), y(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER ierr
INTEGER iw
INTEGER mabs
real qy1, qy2, qy3
************************* CH2(OH)CHO photolysis
* 1: CH2(OH)CHO
j = j+1
jlabel(j) = 'HOCH2CHO -> CH2OH + HCO'
j = j+1
jlabel(j) = 'HOCH2CHO -> CH3OH + CO'
j = j+1
jlabel(j) = 'HOCH2CHO -> CH2CHO + OH'
mabs = 2
IF(mabs .EQ. 1) THEN
*= Cross section from =*
*= The Atmospheric Chemistry of Glycolaldehyde, C. Bacher, G. S. Tyndall =*
*= and J. J. Orlando, J. Atmos. Chem., 39 (2001) 171-189. =*
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2OHCHO/glycolaldehyde.abs',
$ STATUS='old')
DO i = 1, 15
READ(UNIT=ilu,FMT=*)
ENDDO
n = 131
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 2) THEN
OPEN(NEWUNIT=ilu,
$ FILE='DATAJ1/CH2OHCHO/glycolaldehyde_jpl11.abs',
$ STATUS='old')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 63
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* combine:
qy1 = 0.83
qy2 = 0.10
qy3 = 0.07
DO iw = 1, nw - 1
DO i = 1, nz
sq(j-2,i,iw) = yg(iw) * qy1
sq(j-1,i,iw) = yg(iw) * qy2
sq(j ,i,iw) = yg(iw) * qy3
ENDDO
ENDDO
tpflag(j-2) = 0
tpflag(j-1) = 0
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r102(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for CH3COCOCH3 =*
*= (biacetyl) photolysis: =*
*= CH3COCOCH3 + hv -> Products =*
*= =*
*= Cross section from either =*
*= 1. Plum et al., Environ. Sci. Technol., Vol. 17, No. 8, 1983, p.480 =*
*= 2. Horowitz et al., J. Photochem Photobio A, 146, 19-27, 2001. =*
*= =*
*= Quantum yield =0.158 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=300)
INTEGER i, n
REAL x(kdata), y(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER ierr
INTEGER iw
INTEGER mabs
************************* CH3COCOCH3 photolysis
* 1: CH3COCOCH3
* Cross section data bases:
* mabs = 1 Plum et al.
* mabs = 2 Horowitz et al.
mabs = 2
j = j+1
jlabel(j) = 'CH3COCOCH3 -> Products'
IF( mabs. EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCOCH3/biacetyl_plum.abs',
$ STATUS='old')
DO i = 1, 7
READ(UNIT=ilu,FMT=*)
ENDDO
n = 55
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs. EQ. 2) THEN
OPEN(NEWUNIT=ilu,
$ FILE='DATAJ1/CH3COCOCH3/biacetyl_horowitz.abs',
$ STATUS='old')
DO i = 1, 8
READ(UNIT=ilu,FMT=*)
ENDDO
n = 287
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yield from Plum et al.
qy = 0.158
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = yg(iw) * qy
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r103(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for CH3COCHCH2 =*
*= Methyl vinyl ketone photolysis: =*
*= CH3COCHCH2 + hv -> Products =*
*= =*
*= Cross section from =*
*= W. Schneider and G. K. Moorgat, priv. comm, MPI Mainz 1989 as reported by =*
*= Roeth, E.-P., R. Ruhnke, G. Moortgat, R. Meller, and W. Schneider, =*
*= UV/VIS-Absorption Cross Sections and QUantum Yields for Use in =*
*= Photochemistry and Atmospheric Modeling, Part 2: Organic Substances, =*
*= Forschungszentrum Julich, Report Jul-3341, 1997. =*
*= =*
*= Quantum yield assumed unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=20000)
INTEGER i, n
REAL x(kdata), y(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER ierr
INTEGER iw
INTEGER mabs
************************* CH3COCHCH2 photolysis
j = j+1
jlabel(j) = 'CH3COCHCH2 -> Products'
* mabs = 1: Schneider and moortgat
* mabs = 2: jpl 2011
mabs = 2
IF(mabs .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/MVK_schneider.abs',
$ STATUS='old')
DO i = 1, 9
READ(UNIT=ilu,FMT=*)
ENDDO
n = 19682
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .EQ. 2) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/MVK_jpl11.abs',
$ STATUS='old')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 146
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yield from
* Gierczak, T., J. B. Burkholder, R. K. Talukdar, A. Mellouki, S. B. Barone,
* and A. R. Ravishankara, Atmospheric fate of methyl vinyl ketone and methacrolein,
* J. Photochem. Photobiol A: Chemistry, 110 1-10, 1997.
* depends on pressure and wavelength, set upper limit to 1.0
DO iw = 1, nw - 1
DO i = 1, nz
qy = exp(-0.055*(wc(iw)-308.)) /
$ (5.5 + 9.2e-19*airden(i))
qy = min(qy, 1.)
sq(j,i,iw) = yg(iw) * qy
ENDDO
ENDDO
tpflag(j) = 2
RETURN
END
*=============================================================================*
SUBROUTINE r104(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CH2=C(CH3)CHO =*
*= (methacrolein) photolysis: =*
*= CH2=C(CH3)CHO + hv -> Products =*
*= =*
*= Cross section: from JPL 2006 (originally from Gierczak et al. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER iw
INTEGER i, n
INTEGER n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg2(kw)
real qy
REAL sig
INTEGER ierr
**************** methacrolein photodissociation
j = j+1
jlabel(j) = 'CH2=C(CH3)CHO -> Products'
* cross section from
* JPL 2006 (originally from Gierczak et al.)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Methacrolein_jpl11.abs',
$ STATUS='OLD')
DO i = 1, 7
READ(UNIT=ilu,FMT=*)
ENDDO
n = 146
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed to be 0.01 (upper limit)
qy = 0.01
DO iw = 1, nw-1
DO i = 1, nz
sig = yg(iw)
sq(j,i,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r105(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for CH3COCO(OH) =*
*= pyruvic acid photolysis: =*
*= CH3COCO(OH) + hv -> Products =*
*= =*
*= Cross section from =*
*= Horowitz, A., R. Meller, and G. K. Moortgat, The UV-VIS absorption cross =*
*= section of the a-dicarbonyl compounds: pyruvic acid, biacetyl, and =*
*= glyoxal. J. Photochem. Photobiol. A:Chemistry, v.146, pp.19-27, 2001. =*
*= =*
*= Quantum yield assumed unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=20000)
INTEGER i, n
REAL x(kdata), y(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER ierr
INTEGER iw, mabs
************************* CH3COCO(OH) photolysis
j = j+1
jlabel(j) = 'CH3COCO(OH) -> Products'
mabs = 2
* mabs = 1: Horowitz et al.
* mabs = 2: JPL2011
IF (mabs .EQ. 1) THEN
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCOOH/pyruvic_horowitz.abs',
$ STATUS='old')
DO i = 1, 8
READ(UNIT=ilu,FMT=*)
ENDDO
n = 148
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF (mabs .eq. 2) then
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH3COCOOH/pyruvic_jpl11.abs',
$ STATUS='old')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 139
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* quantum yield = 1 (sum of all channels)
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = yg(iw) * qy
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r106(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for CH3CH2ONO2 =*
*= ethyl nitrate photolysis: =*
*= CH3CH2ONO2 + hv -> CH3CH2O + NO2 =*
*= =*
*= Absorption cross sections of several organic from =*
*= Talukdar, R. K., J. B. Burkholder, M. Hunter, M. K. Gilles, =*
*= J. M Roberts, and A. R. Ravishankara, Atmospheric fate of several =*
*= alkyl nitrates, J. Chem. Soc., Faraday Trans., 93(16) 2797-2805, 1997. =*
*= =*
*= Quantum yield assumed unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
INTEGER i, n1, n2
REAL x1(kdata), y1(kdata)
REAL x2(kdata), y2(kdata)
* local
REAL dum
REAL yg1(kw), yg2(kw)
REAL qy, sig
INTEGER ierr
INTEGER iw
************************* CH3CH2ONO2 photolysis
j = j+1
jlabel(j) = 'CH3CH2ONO2 -> CH3CH2O + NO2'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/RONO2_talukdar.abs',
$ STATUS='old')
DO i = 1, 10
READ(UNIT=ilu,FMT=*)
ENDDO
n1 = 0
n2 = 0
DO i = 1, 63
READ(UNIT=ilu,FMT=*) x1(i), dum, dum, y1(i), y2(i), dum, dum
if (y1(i) .gt. 0.) n1 = n1 + 1
if (y2(i) .gt. 0.) n2 = n2 + 1
x2(i) = x1(i)
y1(i) = y1(i) * 1.e-20
y2(i) = y2(i) * 1.e-3
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2, 1.e+38,y2(n2))
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sig = yg1(iw)*exp(yg2(iw)*(tlev(i)-298.))
sq(j,i,iw) = sig * qy
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r107(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for CH3CHONO2CH3 =*
*= isopropyl nitrate photolysis: =*
*= CH3CHONO2CH3 + hv -> CH3CHOCH3 + NO2 =*
*= =*
*= Absorption cross sections of several organic from =*
*= Talukdar, R. K., J. B. Burkholder, M. Hunter, M. K. Gilles, =*
*= J. M Roberts, and A. R. Ravishankara, Atmospheric fate of several =*
*= alkyl nitrates, J. Chem. Soc., Faraday Trans., 93(16) 2797-2805, 1997. =*
*= =*
*= Quantum yield assumed unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
INTEGER i, n1, n2
REAL x1(kdata), y1(kdata)
REAL x2(kdata), y2(kdata)
* local
REAL dum
REAL yg1(kw), yg2(kw)
REAL qy, sig
INTEGER ierr
INTEGER iw
************************* CH3CHONO2CH3 photolysis
j = j+1
jlabel(j) = 'CH3CHONO2CH3 -> CH3CHOCH3 + NO2'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/RONO2_talukdar.abs',
$ STATUS='old')
DO i = 1, 10
READ(UNIT=ilu,FMT=*)
ENDDO
n1 = 0
n2 = 0
DO i = 1, 63
READ(UNIT=ilu,FMT=*) x1(i), dum, dum, dum, dum, y1(i), y2(i)
if (y1(i) .gt. 0.) n1 = n1 + 1
if (y2(i) .gt. 0.) n2 = n2 + 1
x2(i) = x1(i)
y1(i) = y1(i) * 1.e-20
y2(i) = y2(i) * 1.e-3
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2, 0.,y2(1))
CALL addpnt(x2,y2,kdata,n2, 1.e+38,y2(n2))
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sig = yg1(iw)*exp(yg2(iw)*(tlev(i)-298.))
sq(j,i,iw) = sig * qy
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r108(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for =*
*= nitroxy ethanol CH2(OH)CH2(ONO2) + hv -> CH2(OH)CH2(O.) + NO2 =*
*= =*
*= Cross section from Roberts, J. R. and R. W. Fajer, UV absorption cross =*
*= sections of organic nitrates of potential atmospheric importance and =*
*= estimation of atmospheric lifetimes, Env. Sci. Tech., 23, 945-951, =*
*= 1989.
*= =*
*= Quantum yield assumed unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* local
REAL qy, sig
INTEGER iw, i
REAL a, b, c
************************* CH2(OH)CH2(ONO2) photolysis
j = j+1
jlabel(j) = 'CH2(OH)CH2(ONO2) -> CH2(OH)CH2(O.) + NO2'
* coefficients from Roberts and Fajer 1989, over 270-306 nm
a = -2.359E-3
b = 1.2478
c = -210.4
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
IF (wc(iw) .GE. 270. .AND. wc(iw) .LE. 306.) THEN
sig = EXP(a*wc(iw)*wc(iw) + b*wc(iw) + c)
ELSE
sig = 0.
ENDIF
DO i = 1, nz
sq(j,i,iw) = sig * qy
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r109(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for =*
*= nitroxy acetone CH3COCH2(ONO2) + hv -> CH3COCH2(O.) + NO2 =*
*= =*
*= Cross section from Roberts, J. R. and R. W. Fajer, UV absorption cross =*
*= sections of organic nitrates of potential atmospheric importance and =*
*= estimation of atmospheric lifetimes, Env. Sci. Tech., 23, 945-951, =*
*= 1989.
*= =*
*= Quantum yield assumed unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* local
REAL qy, sig
INTEGER iw, i
REAL a, b, c
************************* CH3COCH2(ONO2) photolysis
j = j+1
jlabel(j) = 'CH3COCH2(ONO2) -> CH3COCH2(O.) + NO2'
* coefficients from Roberts and Fajer 1989, over 284-335 nm
a = -1.365E-3
b = 0.7834
c = -156.8
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
IF (wc(iw) .GE. 284. .AND. wc(iw) .LE. 335.) THEN
sig = EXP(a*wc(iw)*wc(iw) + b*wc(iw) + c)
ELSE
sig = 0.
ENDIF
DO i = 1, nz
sq(j,i,iw) = sig * qy
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r110(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for =*
*= t-butyl nitrate C(CH3)3(ONO2) + hv -> C(CH3)(O.) + NO2 =*
*= =*
*= Cross section from Roberts, J. R. and R. W. Fajer, UV absorption cross =*
*= sections of organic nitrates of potential atmospheric importance and =*
*= estimation of atmospheric lifetimes, Env. Sci. Tech., 23, 945-951, =*
*= 1989.
*= =*
*= Quantum yield assumed unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* local
REAL qy, sig
INTEGER iw, i
REAL a, b, c
************************* C(CH3)3(ONO2) photolysis
j = j+1
jlabel(j) = 'C(CH3)3(ONO2) -> C(CH3)3(O.) + NO2'
* coefficients from Roberts and Fajer 1989, over 270-330 nm
a = -0.993E-3
b = 0.5307
c = -115.5
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
IF (wc(iw) .GE. 270. .AND. wc(iw) .LE. 330.) THEN
sig = EXP(a*wc(iw)*wc(iw) + b*wc(iw) + c)
ELSE
sig = 0.
ENDIF
DO i = 1, nz
sq(j,i,iw) = sig * qy
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r111(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for ClOOCl =*
*= ClO dimer photolysis: =*
*= ClOOCl + hv -> Cl + ClOO =*
*= =*
*= Cross section from JPL2002 =*
*= =*
*= Quantum yield assumed unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=20000)
INTEGER i, n
REAL x(kdata), y(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER ierr
INTEGER iw
************************* ClOOCl photolysis
* from JPL-2011
j = j+1
jlabel(j) = 'ClOOCl -> Cl + ClOO'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CLOOCL_jpl11.abs',
$ STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 111
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = yg(iw) * qy
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r112(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for hydroxyacetone =*
*= CH2(OH)COCH3 photolysis: =*
*= CH2(OH)COCH3 -> CH3CO + CH2OH
*= -> CH2(OH)CO + CH3 =*
*= =*
*= Cross section from Orlando et al. (1999) =*
*= =*
*= Quantum yield assumed 0.325 for each channel (J. Orlando, priv.comm.2003)=*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=20000)
INTEGER i, n
REAL x(kdata), y(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER ierr
INTEGER iw, mabs
************************* CH2(OH)COCH3 photolysis
* from Orlando et al. 1999
j = j+1
jlabel(j) = 'CH2(OH)COCH3 -> CH3CO + CH2(OH)'
j = j+1
jlabel(j) = 'CH2(OH)COCH3 -> CH2(OH)CO + CH3'
* mabs = 1: from Orlando et al. 1999
* mabs = 2: from jpl 2011
mabs = 2
if (mabs.eq.1) then
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Hydroxyacetone.abs',
$ STATUS='old')
DO i = 1, 8
READ(UNIT=ilu,FMT=*)
ENDDO
n = 101
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ELSEIF(mabs .eq. 2) then
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Hydroxyacetone_jpl11.abs',
$ STATUS='old')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 96
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
ENDIF
* Total quantum yield = 0.65, from Orlando et al. Assume equal for each of
* the two channels
qy = 0.325
DO iw = 1, nw - 1
DO i = 1, nz
sq(j-1,i,iw) = yg(iw) * qy
sq(j,i,iw) = yg(iw) * qy
ENDDO
ENDDO
tpflag(j-1) = 0
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r113(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for HOBr =*
*= HOBr -> OH + Br =*
*= Cross section from JPL 2003 =*
*= Quantum yield assumed unity as in JPL2003 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j, i
* data arrays
* local
REAL qy, sig
INTEGER iw
************************* HOBr photolysis
* from JPL2003
j = j+1
jlabel(j) = 'HOBr -> OH + Br'
qy = 1.
DO iw = 1, nw - 1
sig = 24.77 * EXP( -109.80*(LOG(284.01/wc(iw)))**2 ) +
$ 12.22 * exp( -93.63*(LOG(350.57/wc(iw)))**2 ) +
$ 2.283 * exp(- 242.40*(LOG(457.38/wc(iw)))**2 )
sig = sig * 1.e-20
IF(wc(iw) .LT. 250. .OR. wc(iw) .GT. 550.) sig = 0.
DO i = 1, nz
sq(j,i,iw) = sig * qy
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r114(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for BrO =*
*= BrO -> Br + O =*
*= Cross section from JPL 2003 =*
*= Quantum yield assumed unity as in JPL2003 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* output weighting functions
INTEGER j
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* data arrays
INTEGER n, i
REAL x(20), y(20)
* local
INTEGER iw
REAL qy, yg(kw), dum
************************* HOBr photolysis
* from JPL2003
j = j+1
jlabel(j) = 'BrO -> Br + O'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/BrO.jpl03',
$ STATUS='old')
DO i = 1, 14
READ(UNIT=ilu,FMT=*)
ENDDO
n = 15
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), dum, y(i)
y(i) = y(i) * 1.e-20
ENDDO
n = n + 1
x(n) = dum
CLOSE(UNIT=ilu)
* use bin-to-bin interpolation
CALL inter4(nw,wl,yg,n,x,y,1)
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = yg(iw) * qy
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r115(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for BrO =*
*= Br2 -> Br + Br =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* output weighting functions
INTEGER j
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* data arrays
INTEGER kdata
PARAMETER(kdata=50)
INTEGER n, i
REAL x(kdata), y(kdata)
* local
INTEGER iw, ierr
REAL qy, yg(kw)
************************* Br2 photolysis
j = j + 1
jlabel(j) = 'Br2 -> Br + Br'
* Absorption cross section from:
* Seery, D.J. and D. Britton, The continuous absorption spectra of chlorine,
* bromine, bromine chloride, iodine chloride, and iodine bromide, J. Phys.
* Chem. 68, p. 2263 (1964).
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Br2.abs',
$ STATUS='old')
DO i = 1, 6
READ(UNIT=ilu,FMT=*)
ENDDO
n = 29
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = yg(iw) * qy
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r118(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= NO3-(aq) photolysis for snow simulations =*
*= a) NO3-(aq) + hv -> NO2 + O- =*
*= b) NO3-(aq) + hv -> NO2- + O(3P) =*
*= Cross section: =*
*= Burley & Johnston, Geophys. Res. Lett., 19, 1359-1362 (1992) =*
*= Quantum yield: =*
*= Warneck & Wurzinger, J. Phys. Chem., 92, 6278-6283 (1988) =*
*= Chu & Anastasio, J. Phys. Chem. A, 107, 9594-9602 (2003) =*
*-----------------------------------------------------------------------------*
*= NOTE: user may have to manually add these reactions to the end of the =*
*= reaction list in file usrinp to include these reactions for a snow run: =*
*= T 74 NO3-(aq) -> NO2 + O- =*
*= T 75 NO3-(aq) -> NO2- + O(3P) =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw,nz
REAL wl(kw), wc(kw), tlev(kz), airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=50)
REAL x1(kdata),x2(kdata)
REAL y1(kdata),y2(kdata) ! y1 = 20'C, y2 = -20'C
* local
REAL yg(kw),yg1(kw),yg2(kw), dum
REAL qy1(kz), qy2, qy3
INTEGER i, iw, n, n1, n2, idum, ierr, iz
integer mabs
*** NO3-(aq) quantum yields
* O- (OH and NO2) production
j = j + 1
jlabel(j) = 'NO3-(aq) -> NO2(aq) + O-'
DO iz = 1, nz
* qy1(iz) = 9.3e-3 ! Warneck & Wurzinger 1988
qy1(iz) = exp(-2400./tlev(iz) + 3.6) ! Chu & Anastasio, 2003
ENDDO
* O(3P) (NO2-(aq) ....> NO) production
j = j + 1
jlabel(j) = 'NO3-(aq) -> NO2-(aq) + O(3P)'
qy2 = 1.1e-3 ! Warneck & Wurzinger '88
* NO2- with qy=1
j = j + 1
jlabel(j) = 'NO3-(aq) with qy=1'
qy3 = 1.
* options for cross section
mabs = 2
if (mabs .eq. 1) then
*** NO3-(aq) cross sections from Burley & Johnston (header lines = 24,
* data lines = 19)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/NO3-_BJ92.abs',STATUS='OLD')
n = 24
DO i = 1, n
READ(UNIT=ilu,FMT=*)
ENDDO
n = 19
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
x2(i) = x1(i)
y1(i)=y1(i)*1e-20
y2(i)=y2(i)*1e-20
ENDDO
CLOSE(UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
n2 = n
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
elseif (mabs .eq. 2) then
*** NO3-(aq) cross sections from Chu and Anastasio 2003:
* convert from molar abs log10 to cm2 per molec
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/NO3-_CA03.abs',STATUS='OLD')
n = 7
do i = 1, n
read(UNIT=ilu,FMT=*)
enddo
n = 43
DO i = 1, n
read(UNIT=ilu,FMT=*) x1(i), y1(i), dum, dum, dum, dum
y1(i) = y1(i) * 3.82e-21
enddo
CLOSE(UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
CALL inter2(nw,wl,yg2,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
endif
DO iw = 1, nw-1
! yg(iw)=yg1(iw) ! for 20'C
yg(iw)=yg2(iw) ! for -20'C
DO iz = 1, nz
sq(j-2,iz,iw) = qy1(iz)*yg(iw)
sq(j-1,iz,iw) = qy2*yg(iw)
sq(j, iz,iw) = qy3*yg(iw)
ENDDO
ENDDO
* chu and anastasio qy is T dependent:
tpflag(j-2) = 1
tpflag(j-1) = 1
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r119(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for =*
*= methylethylketone =*
*= CH3COCH2CH3 photolysis: =*
*= CH3COCH2CH3 -> CH3CO + CH2CH3 =*
*= =*
*= Cross section from Martinez et al. (1992) =*
*= =*
*= Quantum yield assumed 0.325 for each channel (J. Orlando, priv.comm.2003)=*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=20000)
INTEGER i, n
REAL x(kdata), y(kdata)
* local
REAL yg(kw), dum, ptorr
REAL qy
INTEGER ierr
INTEGER iw
************************* CH3COCH2CH3 photolysis
j = j+1
jlabel(j) = 'CH3COCH2CH3 -> CH3CO + CH2CH3'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Martinez.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 96
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), dum, y(i), dum, dum
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* Quantum Yields from
* Raber, W.H. (1992) PhD Thesis, Johannes Gutenberg-Universitaet, Mainz, Germany.
* other channels assumed negligible (less than 10%).
* Total quantum yield = 0.38 at 760 Torr.
* Stern-Volmer form given: 1/phi = 0.96 + 2.22e-3*P(torr)
* compute local pressure in torr
DO i = 1, nz
ptorr = 760.*airden(i)/2.69e19
qy = 1./(0.96 + 2.22E-3*ptorr)
qy = MIN(qy, 1.0)
DO iw = 1, nw-1
sq(j,i,iw) = yg(iw) * qy
ENDDO
ENDDO
tpflag(j) = 2
RETURN
END
*=============================================================================*
SUBROUTINE r120(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for PPN photolysis: =*
*= PPN + hv -> Products =*
*= =*
*= Cross section: from JPL 2006 (originally from Harwood et al. 2003) =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER iw
INTEGER i, n
INTEGER n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg2(kw)
real qyNO2, qyNO3
REAL sig
INTEGER ierr
**************** PPN photodissociation
j = j+1
jlabel(j) = 'CH3CH2CO(OONO2) -> CH3CH2CO(OO) + NO2'
j = j+1
jlabel(j) = 'CH3CH2CO(OONO2) -> CH3CH2CO(O) + NO3'
* cross section from
* JPL 2011 (originally from Harwood et al. 2003)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/PPN_Harwood.txt',STATUS='OLD')
DO i = 1, 10
READ(UNIT=ilu,FMT=*)
ENDDO
n = 66
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
y1(i) = y1(i) * 1.E-20
y2(i) = y2(i) * 1E-3
x2(i) = x1(i)
ENDDO
n2 = n
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields from Harwood et al., at 308 nm
qyNO2 = 0.61
qyNO3 = 0.39
DO iw = 1, nw-1
DO i = 1, nz
sig = yg(iw) * EXP(yg2(iw)*(tlev(i)-298.))
sq(j-1,i,iw) = qyNO2 * sig
sq(j,i,iw) = qyNO3 * sig
ENDDO
ENDDO
tpflag(j-1) = 0
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r121(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CH2(OH)(OOH) =*
*= (hydroxy methyl hydroperoxide) photolysis: =*
*= CH2(OH)(OOH) + hv -> CH2(OH)(O.) + OH =*
*= =*
*= Cross section: from JPL 2006 (originally from Bauerle and Moortgat 1999 =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER iw
INTEGER i, n
INTEGER n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg2(kw)
real qy
REAL sig
INTEGER ierr
**************** hydroxy methyl hydroperoxide photodissociation
j = j+1
jlabel(j) = 'HOCH2OOH -> HOCH2O. + OH'
* cross section from
* JPL 2006 (originally from Bauerle and Moortgat 1999)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HOCH2OOH.txt',STATUS='OLD')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 32
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sig = yg(iw)
sq(j,i,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r122(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CH2=CHCHO =*
*= (acrolein) photolysis: =*
*= CH2=CHCHO + hv -> Products =*
*= =*
*= Cross section: from JPL 2006 (originally from Magneron et al. =*
*= Quantum yield: P-dependent, JPL 2006 orig. from Gardner et al. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER iw
INTEGER i, n
INTEGER n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg2(kw)
real qy, qym1
REAL sig
INTEGER ierr
**************** acrolein photodissociation
j = j+1
jlabel(j) = 'CH2=CHCHO -> Products'
* cross section from
* JPL 2006 (originally from Magneron et al.)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Acrolein.txt',STATUS='OLD')
DO i = 1, 6
READ(UNIT=ilu,FMT=*)
ENDDO
n = 55
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields are pressure dependent between air number densities
* of 8e17 and 2.6e19, Gardner et al.:
DO iw = 1, nw-1
DO i = 1, nz
if(airden(i) .gt. 2.6e19) then
qy = 0.004
elseif(airden(i) .gt. 8.e17 .and. airden(i) .lt. 2.6e19) then
qym1 = 0.086 + 1.613e-17 * airden(i)
qy = 0.004 + 1./qym1
elseif(airden(i) .lt. 8.e17) then
qym1 = 0.086 + 1.613e-17 * 8.e17
qy = 0.004 + 1./qym1
endif
sig = yg(iw)
sq(j,i,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 2
RETURN
END
*=============================================================================*
SUBROUTINE r123(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for peracetic acid =*
*= photolysis: =*
*= CH3CO(OOH) + hv -> Products =*
*= =*
*= Cross section: from JPL 2006 (originally from Orlando and Tyndall 2003 =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER iw
INTEGER i, n
INTEGER n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg2(kw)
real qy
REAL sig
INTEGER ierr
**************** peracetic acid photodissociation
j = j+1
jlabel(j) = 'CH3CO(OOH) -> Products'
* cross section from
* JPL 2006 (originally from Orlando and Tyndall 2003)
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Peracetic_acid.txt',
& STATUS='OLD')
DO i = 1, 6
READ(UNIT=ilu,FMT=*)
ENDDO
n = 66
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sig = yg(iw)
sq(j,i,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r124(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for dimethyl nitroso =*
*= amine photolysis: =*
*= (CH3)2NNO + hv -> Products =*
*= =*
*= Cross section: from Lindley 1978 (cited by Calvert et al. 2009)
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER iw
INTEGER i, n
REAL x1(kdata)
REAL y1(kdata)
INTEGER ierr
* local
REAL yg(kw)
REAL qy
**************** dmna photodissociation
j = j+1
jlabel(j) = '(CH3)2NNO -> Products'
* cross section from
* Lindley (1978, PhD Thesis Ohio State U., Jack Calvert advisor), cited by Calvert et al. (2009).
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/dmna.abs',STATUS='OLD')
DO i = 1, 5
READ(UNIT=ilu,FMT=*)
ENDDO
n = 132
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-19
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r125(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for ClO photolysis =*
*= ClO + hv -> Cl + O =*
*= =*
*= Cross section: from Maric and Burrows 1999 =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=500)
INTEGER iw
INTEGER i, n
REAL x1(kdata)
REAL y1(kdata)
INTEGER ierr
* local
REAL yg(kw)
REAL qy1, qy2
real tmp(12), x(kdata), y(kdata,12), tx
real xdum
integer m, nn, ii
real ygt(kw, 12), yy
INTEGER m1, m2
**************** ClO photodissociation
j = j+1
jlabel(j) = 'ClO -> Cl + O(1D)'
j = j+1
jlabel(j) = 'ClO -> Cl + O(3P)'
* cross section from
* Maric D. and J.P. Burrows, J. Quantitative Spectroscopy and
* Radiative Transfer 62, 345-369, 1999. Data was downloaded from
* their web site on 15 Septmeber 2009.
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/ClO_spectrum.prn',STATUS='OLD')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
nn = 453
DO ii = 1, nn
i = nn - ii + 1
READ(UNIT=ilu,FMT=*) xdum, x(i), xdum, (y(i,m), m = 1, 12)
ENDDO
CLOSE(UNIT=ilu)
DO m = 1, 12
tmp(m) = 190. + 10.*FLOAT(m-1)
IF(m .EQ. 1) tmp(m) = 180.
DO i = 1, nn
x1(i) = x(i)
y1(i) = y(i,m)
ENDDO
n = nn
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
DO iw = 1, nw-1
ygt(iw,m) = yg(iw)
ENDDO
ENDDO
DO i = 1, nz
tx = tlev(i)
* locate temperature indices for interpolation:
m1 = 1 + INT((tx - 190.)/10.)
m1 = MAX(1 ,m1)
m1 = MIN(11,m1)
m2 = m1 + 1
DO iw = 1, nw-1
yy = ygt(iw,m1) + (ygt(iw,m2)-ygt(iw,m1))
$ *(tx-tmp(m1))/(tmp(m2)-tmp(m1))
* threshold for O(1D) productionis 263.4 nm:
if(wc(iw) .lt. 263.4) then
qy1 = 1.
else
qy1 = 0.
endif
qy2 = 1. - qy1
sq(j-1,i,iw) = qy1 * yy
sq(j,i,iw) = qy2 * yy
ENDDO
ENDDO
tpflag(j-1) = 1
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r126(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for nitryl chloride =*
*= ClNO2 -> Cl + NO2 =*
*= =*
*= Cross section: from JPL 2006 =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER iw
INTEGER i, n
REAL x1(kdata)
REAL y1(kdata)
INTEGER ierr
* local
REAL yg(kw)
REAL qy
integer mabs
**************** ClNO2 photodissociation
j = j+1
jlabel(j) = 'ClNO2 -> Cl + NO2'
* cross section from
* mabs = 1: JPL 2006, same as JPL-2011
* mabs = 2: IUPAC 2007
mabs = 1
if(mabs.eq.1) then
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/ClNO2.abs',STATUS='OLD')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 26
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
elseif (mabs .eq. 2) then
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/ClNO2_iupac.abs',
& STATUS='OLD')
DO i = 1, 6
READ(UNIT=ilu,FMT=*)
ENDDO
n = 17
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
endif
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r127(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for nitrosyl bromide =*
*= BrNO -> Br + NO =*
*= =*
*= Cross section: from JPL 2006 =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER iw
INTEGER i, n
REAL x1(kdata)
REAL y1(kdata)
INTEGER ierr
* local
REAL yg(kw)
REAL qy
******************** BrNO photodissociation
j = j+1
jlabel(j) = 'BrNO -> Br + NO'
* cross section from
* JPL 2006
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/BrNO.abs',STATUS='OLD')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 27
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r128(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for bromine nitritee =*
*= BrNO2 -> Br + NO2 =*
*= =*
*= Cross section: from JPL 2006 =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER iw
INTEGER i, n
REAL x1(kdata)
REAL y1(kdata)
INTEGER ierr
* local
REAL yg(kw)
REAL qy
******************** BrNO2 photodissociation
j = j+1
jlabel(j) = 'BrNO2 -> Br + NO2'
* cross section from
* IUPAC (vol III) 2007
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/BrNO2.abs',STATUS='OLD')
DO i = 1, 6
READ(UNIT=ilu,FMT=*)
ENDDO
n = 54
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r129(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for bromine nitrite =*
*= BrONO -> Br + NO2 =*
*= BrONO -> BrO + NO =*
*= =*
*= Cross section: from IUPAC (vol.3) =*
*= Quantum yield: Assumed to be 0.5 for each channel =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
C INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER iw
INTEGER i, n
REAL x1(kdata)
REAL y1(kdata)
INTEGER ierr
* local
REAL yg(kw)
REAL qy1, qy2
******************** BrONO photodissociation
j = j+1
jlabel(j) = 'BrONO -> Br + NO2'
j = j+1
jlabel(j) = 'BrONO -> BrO + NO'
* cross section from
* IUPAC (vol III) 2007
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/BrONO.abs',STATUS='OLD')
DO i = 1, 8
READ(UNIT=ilu,FMT=*)
ENDDO
n = 32
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy1 = 0.5
qy2 = 0.5
DO iw = 1, nw-1
DO i = 1, nz
sq(j-1,i,iw) = qy1 * yg(iw)
sq(j,i,iw) = qy2 * yg(iw)
ENDDO
ENDDO
tpflag(j-1) = 0
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r130(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for
*= HOCl -> HO + Cl =*
*= Cross section: from IUPAC (vol.3) =*
*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER iw
INTEGER i, n
REAL x1(kdata)
REAL y1(kdata)
INTEGER ierr
* local
REAL yg(kw)
REAL qy
******************** HOCl photodissociation
j = j + 1
jlabel(j) = 'HOCl -> HO + Cl'
* cross section from
* IUPAC (vol III) 2007
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HOCl.abs',STATUS='OLD')
DO i = 1, 7
READ(UNIT=ilu,FMT=*)
ENDDO
n = 111
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r131(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for
*= NOCl -> NO + Cl =*
*= Cross section: from IUPAC (vol.3) =*
*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=150)
INTEGER iw
INTEGER i, n, ii
REAL x1(kdata), y1(kdata)
integer nn
REAL x223(kdata),x243(kdata),x263(kdata),x298(kdata),
$ x323(kdata), x343(kdata)
REAL y223(kdata),y243(kdata),y263(kdata),y298(kdata),
$ y323(kdata), y343(kdata)
INTEGER ierr
* local
REAL yg223(kw),yg243(kw),yg263(kw),yg298(kw),
$ yg323(kw), yg343(kw)
REAL qy, sig
******************** NOCl photodissociation
j = j + 1
jlabel(j) = 'NOCl -> NO + Cl'
* cross section from
* IUPAC (vol III) 2007
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/NOCl.abs',STATUS='OLD')
DO i = 1, 7
READ(UNIT=ilu,FMT=*)
ENDDO
n = 80
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y223(i) = y1(i)
y243(i) = y1(i)
y263(i) = y1(i)
y298(i) = y1(i)
y323(i) = y1(i)
y343(i) = y1(i)
x223(i) = x1(i)
x243(i) = x1(i)
x263(i) = x1(i)
x298(i) = x1(i)
x323(i) = x1(i)
x343(i) = x1(i)
ENDDO
READ(UNIT=ilu,FMT=*)
n = 61
do i = 1, n
ii = i + 80
read(UNIT=ilu,FMT=*) x1(ii), y223(ii), y243(ii), y263(ii),
$ y298(ii), y323(ii), y343(ii)
x223(ii) = x1(ii)
x243(ii) = x1(ii)
x263(ii) = x1(ii)
x298(ii) = x1(ii)
x323(ii) = x1(ii)
x343(ii) = x1(ii)
enddo
n = ii
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x223,y223,kdata,nn,x223(1)*(1.-deltax),0.)
CALL addpnt(x223,y223,kdata,nn, 0.,0.)
CALL addpnt(x223,y223,kdata,nn,x223(nn)*(1.+deltax),0.)
CALL addpnt(x223,y223,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg223,nn,x223,y223,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
nn = n
CALL addpnt(x243,y243,kdata,nn,x243(1)*(1.-deltax),0.)
CALL addpnt(x243,y243,kdata,nn, 0.,0.)
CALL addpnt(x243,y243,kdata,nn,x243(nn)*(1.+deltax),0.)
CALL addpnt(x243,y243,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg243,nn,x243,y243,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
nn = n
CALL addpnt(x263,y263,kdata,nn,x263(1)*(1.-deltax),0.)
CALL addpnt(x263,y263,kdata,nn, 0.,0.)
CALL addpnt(x263,y263,kdata,nn,x263(nn)*(1.+deltax),0.)
CALL addpnt(x263,y263,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg263,nn,x263,y263,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
nn = n
CALL addpnt(x298,y298,kdata,nn,x298(1)*(1.-deltax),0.)
CALL addpnt(x298,y298,kdata,nn, 0.,0.)
CALL addpnt(x298,y298,kdata,nn,x298(nn)*(1.+deltax),0.)
CALL addpnt(x298,y298,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg298,nn,x298,y298,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
nn = n
CALL addpnt(x323,y323,kdata,nn,x323(1)*(1.-deltax),0.)
CALL addpnt(x323,y323,kdata,nn, 0.,0.)
CALL addpnt(x323,y323,kdata,nn,x323(nn)*(1.+deltax),0.)
CALL addpnt(x323,y323,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg323,nn,x323,y323,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
nn = n
CALL addpnt(x343,y343,kdata,nn,x343(1)*(1.-deltax),0.)
CALL addpnt(x343,y343,kdata,nn, 0.,0.)
CALL addpnt(x343,y343,kdata,nn,x343(nn)*(1.+deltax),0.)
CALL addpnt(x343,y343,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg343,nn,x343,y343,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1
sig = 0.
DO iw = 1, nw-1
DO i = 1, nz
if(tlev(i) .le. 223.) then
sig = yg223(iw)
elseif (tlev(i) .gt. 223. .and. tlev(i) .le. 243.) then
sig = yg223(iw) +
$ (yg243(iw) - yg223(iw))*(tlev(i) - 223.)/20.
elseif (tlev(i) .gt. 243. .and. tlev(i) .le. 263.) then
sig = yg243(iw) +
$ (yg263(iw) - yg243(iw))*(tlev(i) - 243.)/20.
elseif (tlev(i) .gt. 263. .and. tlev(i) .le. 298.) then
sig = yg263(iw) +
$ (yg298(iw) - yg263(iw))*(tlev(i) - 263.)/35.
elseif (tlev(i) .gt. 298. .and. tlev(i) .le. 323.) then
sig = yg298(iw) +
$ (yg323(iw) - yg298(iw))*(tlev(i) - 298.)/25.
elseif (tlev(i) .gt. 323. .and. tlev(i) .le. 343.) then
sig = yg323(iw) +
$ (yg343(iw) - yg323(iw))*(tlev(i) - 323.)/20.
endif
sq(j,i,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r132(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for
*= OClO -> Products =*
*= Cross section: from Wahner et al., J. Phys. Chem. 91, 2734, 1987 =*
*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=2000)
INTEGER iw
INTEGER i, n
REAL x1(kdata), y1(kdata)
integer nn, n204, n296, n378
REAL x204(kdata),x296(kdata),x378(kdata)
REAL y204(kdata),y296(kdata),y378(kdata)
INTEGER ierr
* local
REAL yg204(kw),yg296(kw),yg378(kw)
REAL qy, sig
******************** NOCl photodissociation
j = j + 1
jlabel(j) = 'OClO -> Products'
* cross section from
*A. Wahner, G.S. tyndall, A.R. Ravishankara, J. Phys. Chem., 91, 2734, (1987).
*Supplementary Data, as quoted at:
*http://www.atmosphere.mpg.de/enid/26b4b5172008b02407b2e47f08de2fa1,0/Spectra/Introduction_1rr.html
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/OClO.abs',STATUS='OLD')
DO i = 1, 6
READ(UNIT=ilu,FMT=*)
ENDDO
n204 = 1074-6
DO i = 1, n204
READ(UNIT=ilu,FMT=*) x204(i), y204(i)
ENDDO
READ(UNIT=ilu,FMT=*)
n296 = 1067
do i = 1, n296
read(UNIT=ilu,FMT=*) x296(i), y296(i)
enddo
read(UNIT=ilu,FMT=*)
n378 = 1068
do i = 1, n378
read(UNIT=ilu,FMT=*) x378(i), y378(i)
enddo
CLOSE(UNIT=ilu)
nn = n204
CALL addpnt(x204,y204,kdata,nn,x204(1)*(1.-deltax),0.)
CALL addpnt(x204,y204,kdata,nn, 0.,0.)
CALL addpnt(x204,y204,kdata,nn,x204(nn)*(1.+deltax),0.)
CALL addpnt(x204,y204,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg204,nn,x204,y204,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
nn = n296
CALL addpnt(x296,y296,kdata,nn,x296(1)*(1.-deltax),0.)
CALL addpnt(x296,y296,kdata,nn, 0.,0.)
CALL addpnt(x296,y296,kdata,nn,x296(nn)*(1.+deltax),0.)
CALL addpnt(x296,y296,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg296,nn,x296,y296,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
nn = n378
CALL addpnt(x378,y378,kdata,nn,x378(1)*(1.-deltax),0.)
CALL addpnt(x378,y378,kdata,nn, 0.,0.)
CALL addpnt(x378,y378,kdata,nn,x378(nn)*(1.+deltax),0.)
CALL addpnt(x378,y378,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg378,nn,x378,y378,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1
DO iw = 1, nw-1
DO i = 1, nz
if(tlev(i) .le. 204.) then
sig = yg204(iw)
elseif (tlev(i) .gt. 204. .and. tlev(i) .le. 296.) then
sig = yg204(iw) +
$ (yg296(iw) - yg204(iw))*(tlev(i) - 204.)/92.
elseif (tlev(i) .gt. 296. .and. tlev(i) .le. 378.) then
sig = yg296(iw) +
$ (yg378(iw) - yg296(iw))*(tlev(i) - 296.)/82.
elseif (tlev(i) .gt. 378.) then
sig = yg378(iw)
endif
sq(j,i,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r133(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for =*
*= BrCl -> Br + Cl =*
*= Cross section: from Maric et al., J. Phtoochem Photobiol. A: Chem =*
*= 83, 179-192, 1994. =*
*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
INTEGER iw
INTEGER i, n
REAL x(kdata), y(kdata)
integer nn
INTEGER ierr
* local
REAL yg(kw)
REAL qy
******************** BrCl photodissociation
j = j + 1
jlabel(j) = 'BrCl -> Br + Cl'
* cross section from
* D. Maric, J.P. Burrows, and G.K. Moortgat, "A study of the UV-visible
* absorption spectra of Br2 and BrCl," J. Photochem. Photobiol. A: Chem.
* 83, 179-192 (1994).
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/BrCl.abs',STATUS='OLD')
DO i = 1, 9
READ(UNIT=ilu,FMT=*)
ENDDO
n = 81
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,nn, 0.,0.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r134(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for =*
*= CH3(OONO2) -> CH3(OO) + NO2 =*
*= Cross section: from
*= I. Bridier, R. Lesclaux, and B. Veyret, "Flash photolysis kinetic study
*= of the equilibrium CH3O2 + NO2 « CH3O2NO2," Chemical Physics Letters
*= 191, 259-263 (1992).
*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
INTEGER iw
INTEGER i, n
REAL x(kdata), y(kdata)
integer nn
INTEGER ierr
* local
REAL yg(kw)
REAL qy
******************** CH3(OONO2) photodissociation
j = j + 1
jlabel(j) = 'CH3(OONO2) -> CH3(OO) + NO2'
* cross section from
*= I. Bridier, R. Lesclaux, and B. Veyret, "Flash photolysis kinetic study
*= of the equilibrium CH3O2 + NO2 « CH3O2NO2," Chemical Physics Letters
*= 191, 259-263 (1992).
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CH3OONO2.abs',STATUS='OLD')
DO i = 1, 9
READ(UNIT=ilu,FMT=*)
ENDDO
n = 26
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,nn, 0.,0.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r135(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for t-butyl nitrite =*
*= C(CH3)3(ONO) -> C(CH3)3(O) + NO =*
*= Cross section: from
*= V. McMillan, 1966, private communication to J.G. Calvert, J.N.Pitts, Jr.,
*= Photochemistry, London, 1966, p. 455.
*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
INTEGER iw
INTEGER i, n
REAL x(kdata), y(kdata)
integer nn
INTEGER ierr
* local
REAL yg(kw)
REAL qy
******************** CH3(OONO2) photodissociation
j = j + 1
jlabel(j) = 'C(CH3)3(ONO) -> C(CH3)3(O) + NO'
* cross section from
*= V. McMillan, 1966, private communication to J.G. Calvert, J.N.Pitts, Jr.,
*= Photochemistry, London, 1966, p. 455.
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/t-butyl-nitrite.abs',
& STATUS='OLD')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 96
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,nn, 0.,0.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r136(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for ClONO =*
*= ClONO -> Cl + NO2 =*
*= cross section from IPUAC, orig from Molina and Molina (1977) =*
*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
INTEGER iw
INTEGER i, n
REAL x(kdata), y(kdata)
integer nn
INTEGER ierr
* local
REAL yg(kw)
REAL qy
******************** ClONO photodissociation
j = j + 1
jlabel(j) = 'ClONO -> Cl + NO2'
* cross section from JPL-2011
* Also published (with some minor differences) as:
* R. Atkinson, D.L. Baulch, R.A. Cox, J.N. Crowley, R.F. Hampson, R.G. Hynes, M.E. Jenkin, M.J. Rossi,
* and J. Troe, "Evaluated kinetic and photochemical data for atmospheric chemistry: Volume III - gas
* phase reactions of inorganic halogens", Atmos. Chem. Phys. 7, 981-1191 (2007).Comments:
* IUPAC (2005, 2007) recommendation:
* The preferred values of the absorption cross-sections at 231 K are the values reported by
* L.T. Molina and M.J. Molina, "Ultraviolet absorption spectrum of chlorine nitrite, ClONO,"
* Geophys. Res. Lett. 4, 83-86 (1977).
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/ClONO_jpl11.abs',STATUS='OLD')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 34
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,nn, 0.,0.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r137(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for HCl =*
*= HCl -> H + Cl =*
*= cross section from JPL2011 =*
*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER iw
INTEGER i, n
REAL x(kdata), y(kdata)
integer nn
INTEGER ierr
* local
REAL yg(kw)
REAL qy, dum
******************** HCl photodissociation
j = j + 1
jlabel(j) = 'HCl -> H + Cl'
* cross section from JPL2011
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/HCl_jpl11.abs',STATUS='OLD')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 31
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i), dum
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,nn, 0.,0.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*-----------------------------------------------------------------------------*
SUBROUTINE pxCH2O(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= JPL 2011 recommendation. =*
*= Provide product of (cross section) x (quantum yield) for CH2O photolysis =*
*= (a) CH2O + hv -> H + HCO =*
*= (b) CH2O + hv -> H2 + CO =*
*= written by s. madronich march 2013
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER kdata
PARAMETER(kdata=200)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER i, j, iz, iw
* data arrays
INTEGER n, n1, n2
REAL x1(kdata), x2(kdata)
REAL y298(kdata), tcoef(kdata)
REAL qr(kdata), qm(kdata)
* local
REAL yg1(kw), yg2(kw), yg3(kw), yg4(kw)
REAL ak300, akt, sig
real qyr300, qym300, qymt
INTEGER ierr
*_______________________________________________________________________
DO 5, iw = 1, nw - 1
wc(iw) = (wl(iw) + wl(iw+1))/2.
5 CONTINUE
****************************************************************
**************** CH2O photodissociatation
j = j+1
jlabel(j) = 'CH2O -> H + HCO'
j = j+1
jlabel(j) = 'CH2O -> H2 + CO'
* read JPL2011 cross section data:
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O/CH2O_jpl11.abs'
$ ,STATUS='old')
do i = 1, 4
read(UNIT=ilu,FMT=*)
enddo
n = 150
n1 = n
n2 = n
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y298(i), tcoef(i)
x2(i) = x1(i)
y298(i) = y298(i) * 1.e-20
tcoef(i) = tcoef(i) * 1.e-24
ENDDO
CLOSE(UNIT=ilu)
* terminate endpoints and interpolate to working grid
CALL addpnt(x1,y298,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y298,kdata,n1, 0.,0.)
CALL addpnt(x1,y298,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y298,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y298,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j-1)
STOP
ENDIF
CALL addpnt(x2,tcoef,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,tcoef,kdata,n2, 0.,0.)
CALL addpnt(x2,tcoef,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,tcoef,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n2,x2,tcoef,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j-1)
STOP
ENDIF
* quantum yields: Read, terminate, interpolate:
OPEN(NEWUNIT=ilu,FILE='DATAJ1/CH2O/CH2O_jpl11.yld',STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 112
n1 = n
n2 = n
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), qr(i), qm(i)
x2(i) = x1(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,qr,kdata,n1,x1(1)*(1.-deltax),qr(1))
CALL addpnt(x1,qr,kdata,n1, 0.,qr(1))
CALL addpnt(x1,qr,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,qr,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg3,n1,x1,qr,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j-1)
STOP
ENDIF
CALL addpnt(x2,qm,kdata,n2,x2(1)*(1.-deltax),qm(1))
CALL addpnt(x2,qm,kdata,n2, 0.,qm(1))
CALL addpnt(x2,qm,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,qm,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg4,n2,x2,qm,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j-1)
STOP
ENDIF
* combine gridded quantities:
* yg1 = cross section at 298K
* yg2 = temperature correction coefficient for cross section
* yg3 = quantum yields for radical channel, H + HCO
* yg4 = quantum yields for molecular channel, H2 + CO.
DO iz = 1, nz
DO iw = 1, nw - 1
* correct cross section for temperature dependence:
sig = yg1(iw) + yg2(iw) * (tlev(iz) - 298.)
* assign room temperature quantum yields for radical and molecular channels
qyr300 = yg3(iw)
qym300 = yg4(iw)
qymt = qym300
* between 330 ande 360 nm, molecular channel is pressure and temperature dependent.
IF (wc(iw) .ge. 330. .and. wc(iw) .lt. 360. .and.
$ qym300 .gt. 0.) then
ak300 = 1./qym300 - 1./(1. - qyr300)
ak300 = ak300/2.45e19
akt = ak300 * (1. + 0.05 * (wc(iw) - 329.) *
$ (300. - tlev(iz))/80.)
qymt = 1./(1./(1.-qyr300) + akt*airden(iz))
ENDIF
sq(j-1,iz,iw) = sig * qyr300
sq(j ,iz,iw) = sig * qymt
ENDDO
ENDDO
tpflag(j-1) = 1
tpflag(j) = 3
RETURN
END
*=============================================================================*
SUBROUTINE r138(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for acetic acid =*
*= CH3COOH -> CH3 + COOH =*
*= cross section from JPL2011 =*
*= Quantum yield: Assumed to be 0.55 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER iw
INTEGER i, n
REAL x(kdata), y(kdata)
integer nn
INTEGER ierr
* local
REAL yg(kw)
REAL qy, dum
******************** acetic acid photodissociation
j = j + 1
jlabel(j) = 'CH3COOH -> CH3 + COOH'
* cross section from JPL2011
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CH3COOH_jpl11.abs',STATUS='OLD')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 18
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,nn, 0.,0.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 0.55
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r139(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x(quantum yield) for methyl hypochlorite =*
*= CH3OCl -> CH3O + Cl =*
*= cross section from JPL2011 =*
*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER iw
INTEGER i, n
REAL x(kdata), y(kdata)
integer nn
INTEGER ierr
* local
REAL yg(kw)
REAL qy, dum
******************** methyl hypochlorite photodissociation
j = j + 1
jlabel(j) = 'CH3OCl -> CH3O + Cl'
* cross section from JPL2011
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CH3OCl_jpl11.abs',STATUS='OLD')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 83
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,nn, 0.,0.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r140(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for CHCl3 photolysis: =*
*= CHCL3 + hv -> Products =*
*= Cross section: from JPL 2011 recommendation =*
*= Quantum yield: assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
REAL x1(kdata)
REAL y1(kdata)
* local
REAL yg(kw)
REAL qy
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
INTEGER mabs
REAL b0, b1, b2, b3, b4, tcoeff, sig
REAL w1, w2, w3, w4, temp
**************************************************************
************* CHCl3 photodissociation
j = j+1
jlabel(j) = 'CHCl3 -> Products'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/CHCl3_jpl11.abs',STATUS='OLD')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 39
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1E38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* compute temperature correction factors:
b0 = 3.7973
b1 = -7.0913e-2
b2 = 4.9397e-4
b3 = -1.5226e-6
b4 = 1.7555e-9
*** quantum yield assumed to be unity
qy = 1.
DO iw = 1, nw-1
* compute temperature correction coefficients:
tcoeff = 0.
IF(wc(iw) .GT. 190. .AND. wc(iw) .LT. 240.) THEN
w1 = wc(iw)
w2 = w1**2
w3 = w1**3
w4 = w1**4
tcoeff = b0 + b1*w1 + b2*w2 + b3*w3 + b4*w4
ENDIF
DO iz = 1, nz
temp = tlev(iz)
temp = min(max(temp,210.),300.)
sig = yg(iw) * 10.**(tcoeff*(temp-295.))
sq(j,iz,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r141(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for C2H5ONO2 =*
*= photolysis: =*
*= C2H5ONO2 + hv -> C2H5O + NO2 =*
*= =*
*= Cross section: IUPAC 2006 (Atkinson et al., ACP, 6, 3625-4055, 2006) =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER (kdata = 200)
INTEGER i, n
INTEGER iw
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw)
REAL qy
REAL sig
INTEGER ierr
INTEGER mabs, myld
**************** C2H5ONO2 photodissociation
j = j + 1
jlabel(j) = 'C2H5ONO2 -> C2H5O + NO2'
* mabs: absorption cross section options:
* 1: IUPAC 2006
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/C2H5ONO2_iup2006.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 32
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i), y2(i)
x2(i) = x1(i)
y1(i) = y1(i) * 1.e-20
y2(i) = y2(i) * 1.e-3
ENDDO
CLOSE (UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
n2 = n
CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 0.,0.)
CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield = 1
* sigma(T,lambda) = sigma(298,lambda) * exp(B * (T-298))
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sig = yg1(iw) * exp(yg2(iw) * (tlev(i)-298.))
sq(j,i,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r142(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for n-C3H7ONO2 =*
*= photolysis: =*
*= n-C3H7ONO2 + hv -> C3H7O + NO2 =*
*= =*
*= Cross section: IUPAC 2006 (Atkinson et al., ACP, 6, 3625-4055, 2006) =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER (kdata = 200)
INTEGER i, n
INTEGER iw
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw)
REAL qy
REAL sig
INTEGER ierr
INTEGER mabs, myld
**************** n-C3H7ONO2 photodissociation
j = j + 1
jlabel(j) = 'n-C3H7ONO2 -> C3H7O + NO2'
* 1: IUPAC 2006
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/nC3H7ONO2_iup2006.abs',
$ STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 32
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE (UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = qy * yg1(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r143(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for 1-C4H9ONO2 =*
*= photolysis: =*
*= 1-C4H9ONO2 + hv -> 1-C4H9O + NO2 =*
*= =*
*= Cross section: IUPAC 2006 (Atkinson et al., ACP, 6, 3625-4055, 2006) =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER (kdata = 200)
INTEGER i, n
INTEGER iw
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw)
REAL qy
REAL sig
INTEGER ierr
INTEGER mabs, myld
**************** 1-C4H9ONO2 photodissociation
j = j + 1
jlabel(j) = '1-C4H9ONO2 -> 1-C4H9O + NO2'
* 1: IUPAC 2006
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/1C4H9ONO2_iup2006.abs',
$ STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 32
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE (UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = qy * yg1(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r144(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for 2-C4H9ONO2 =*
*= photolysis: =*
*= 2-C4H9ONO2 + hv -> 2-C4H9O + NO2 =*
*= =*
*= Cross section: IUPAC 2006 (Atkinson et al., ACP, 6, 3625-4055, 2006) =*
*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER (kdata = 200)
INTEGER i, n
INTEGER iw
INTEGER n1, n2
REAL x1(kdata), x2(kdata)
REAL y1(kdata), y2(kdata)
* local
REAL yg(kw), yg1(kw), yg2(kw)
REAL qy
REAL sig
INTEGER ierr
INTEGER mabs, myld
**************** 2-C4H9ONO2 photodissociation
j = j + 1
jlabel(j) = '2-C4H9ONO2 -> 2-C4H9O + NO2'
* 1: IUPAC 2006
OPEN(NEWUNIT=ilu,FILE='DATAJ1/RONO2/2C4H9ONO2_iup2006.abs',
$ STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
n = 15
DO i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
y1(i) = y1(i) * 1.e-20
ENDDO
CLOSE (UNIT=ilu)
n1 = n
CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 0.,0.)
CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yield = 1
qy = 1.
DO iw = 1, nw - 1
DO i = 1, nz
sq(j,i,iw) = qy * yg1(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*============================================================================*
SUBROUTINE r145(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for =*
*= perfluoro n-iodo propane (H24) =*
*= cross section from JPL2011 =*
*= Quantum yield: Assumed to be 0.55 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER iw
INTEGER i, n
REAL x(kdata), y(kdata)
integer nn
INTEGER ierr
* local
REAL yg(kw)
REAL qy, dum
j = j + 1
jlabel(j) = 'perfluoro 1-iodopropane -> products'
* cross section from JPL2011
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/PF-n-iodopropane.abs',
& STATUS='old')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 16
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,nn, 0.,0.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed unity
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r146(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for =*
*= molecular Iodine, I2 =*
*= cross section from JPL2011 =*
*= Quantum yield: wave-dep, from Brewer and Tellinhuisen, 1972 =*
*= Quantum yield for Unimolecular Dissociation of I2 in Visible Absorption =*
*= J. Chem. Phys. 56, 3929-3937, 1972.
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
INTEGER iw
INTEGER i, n
REAL x(kdata), y(kdata)
integer nn
INTEGER ierr
* local
REAL yg1(kw), yg2(kw)
REAL qy, dum
j = j + 1
jlabel(j) = 'I2 -> I + I'
* cross section from JPL2011
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/I2_jpl11.abs',STATUS='OLD')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 104
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,nn, 0.,0.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg1,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields
OPEN(NEWUNIT=ilu,FILE='DATAJ1/YLD/I2.qy',STATUS='OLD')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 12
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),1.)
CALL addpnt(x,y,kdata,nn, 0.,1.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg2,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* combine
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = yg1(iw) * yg2(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*============================================================================*
SUBROUTINE r147(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for =*
*= Iodine monoxide, IO =*
*= cross section from JPL2011 =*
*= Quantum yield: assumed 1.0 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=200)
INTEGER iw
INTEGER i, n
REAL x(kdata), y(kdata)
integer nn
INTEGER ierr
* local
REAL yg(kw)
REAL qy, dum
j = j + 1
jlabel(j) = 'IO -> I + O'
* cross section from JPL2011
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/IO_jpl11.abs',STATUS='OLD')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 133
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,nn, 0.,0.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*============================================================================*
SUBROUTINE r148(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide product (cross section) x (quantum yield) for =*
*= Hypoiodous acid, IOH =*
*= cross section from JPL2011 =*
*= Quantum yield: assumed 1.0 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=300)
INTEGER iw
INTEGER i, n
REAL x(kdata), y(kdata)
integer nn
INTEGER ierr
* local
REAL yg(kw)
REAL qy, dum
j = j + 1
jlabel(j) = 'IOH -> I + OH'
* cross section from JPL2011
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/IOH_jpl11.abs',STATUS='OLD')
DO i = 1, 2
READ(UNIT=ilu,FMT=*)
ENDDO
n = 101
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
nn = n
CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,nn, 0.,0.)
CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields
qy = 1.
DO iw = 1, nw-1
DO i = 1, nz
sq(j,i,iw) = qy * yg(iw)
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r149(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for 2-pentanone =*
*= photolysis: =*
*= CH3COCH2CH2CH3 + hv -> CH3CO + CH2CH2CH3 =*
*= =*
*= Cross section from Martinez et al. (1992) =*
*= =*
*= Quantum yield assuumed 0.34 (Griffin et al., 2002) =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
*= Routine added by M. Leriche for specie KETH and KETL of CACM, ReLACS2 =*
*= and ReLACS3 mecanisms - March 2018 =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=20000)
INTEGER i, n
REAL x(kdata), y(kdata)
* local
REAL yg(kw), dum
REAL qy, sig
INTEGER ierr
INTEGER iw
************************* CH3COCH2CH2CH3 photolysis
j = j+1
jlabel(j) = 'CH3COCH2CH2CH3 -> CH3CO + CH2CH2CH3'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/Martinez.abs',
$ STATUS='old')
DO i = 1, 4
READ(UNIT=ilu,FMT=*)
ENDDO
n = 96
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), dum, dum, y(i), dum
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed to be 0.34
qy = 0.34
DO iw = 1, nw-1
DO i = 1, nz
sig = yg(iw)
sq(j,i,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r150(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for benzaldehyde =*
*= photolysis: =*
*= C6H5CHO + hv -> CHO + HO2 + CO =*
*= =*
*= Cross section from SAPRC-07 (Calvert et al., 2002) =*
*= =*
*= Products from Zhu and Cronin (Chem. Phys. Let., 317, 2000) =*
*= =*
*= Quantum yield asumed 0.06 (RACM2, Goliff et al., 2013) =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
*= Routine added by M. Leriche for BALD in RACM2 mecanism - March 2018 =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=20000)
INTEGER i, n
REAL x(kdata), y(kdata)
* local
REAL yg(kw)
REAL qy, sig
INTEGER ierr
INTEGER iw
************************* C6H5CHO photolysis
j = j+1
jlabel(j) = 'C6H5CHO -> HCO + HO2 + CO'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/BENZALD.abs',
$ STATUS='old')
DO i = 1, 5
READ(UNIT=ilu,FMT=*)
ENDDO
n = 100
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields assumed to be 0.06
qy = 0.06
DO iw = 1, nw-1
DO i = 1, nz
sig = yg(iw)
sq(j,i,iw) = qy * sig
ENDDO
ENDDO
tpflag(j) = 0
RETURN
END
*=============================================================================*
SUBROUTINE r151(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for nitrate ion =*
*= photolysis in diluted aqueous atmospheric solution (cloud, rain): =*
*= NO3- + hv + H2O -> NO2 + OH + OH- =*
*= =*
*= Cross section from Graedel and Weschler (1981) =*
*= =*
*= Quantum yield from Zellner, Exner and Herrmann (1990) =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
*= Routine added by M. Leriche for ReLACS-AQ and ReLACS3 mecanisms =*
*= Adapted from TUVLaMP original 05/98 - March 2018 =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER i, n
REAL x(kdata), y(kdata)
* local
REAL yg(kw)
REAL qy, sig
INTEGER ierr
INTEGER iw
************************* NO3-(aq) photolysis
j = j+1
jlabel(j) = 'NO3-(aq) -> NO2(aq) + OH(aq)'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABSAQ/NO3-aq.abs',
$ STATUS='old')
DO i = 1, 6
READ(UNIT=ilu,FMT=*)
ENDDO
n = 9
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields from:
* Zellner, Exner, Herrmann: Absolute OH quantum Yields
* in the laser photolysis of nitrate, nitrite and dissolved H2O2
* at 308 and 351 nm in the temperature range 278-353K, JAC, 1990.
* Temperature dependency determined at 308 nm and 4<pH<9
DO iw = 1, nw-1
DO i = 1, nz
qy = 0.017 * EXP (1800. *((1./298.)-(1./tlev(i))))
sig = yg(iw)
* actinic flux in droplet assumes to be 1.6 the interstitial
* actinic flux (see Ruggaber, 1997)
sq(j,i,iw) = qy * sig *1.6
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
*=============================================================================*
SUBROUTINE r152(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Provide the product (cross section) x (quantum yield) for H2O2 =*
*= photolysis in diluted aqueous atmospheric solution (cloud, rain): =*
*= H2O2 + hv -> OH + OH =*
*= =*
*= Cross section from Graedel and Weschler (1981) =*
*= =*
*= Quantum yield from Zellner, Exner and Herrmann (1990) =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= WC - REAL, vector of center points of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
*= Routine added by M. Leriche for ReLACS-AQ and ReLACS3 mecanisms =*
*= Adapted from TUVLaMP original 05/98 - March 2018 =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw), wc(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
INTEGER j
* data arrays
INTEGER kdata
PARAMETER(kdata=100)
INTEGER i, n
REAL x(kdata), y(kdata)
* local
REAL yg(kw)
REAL qy, sig
INTEGER ierr
INTEGER iw
************************* H2O2(aq) photolysis
j = j+1
jlabel(j) = 'H2O2(aq) -> OH(aq) + OH(aq)'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABSAQ/H2O2aq.abs',
$ STATUS='old')
DO i = 1, 7
READ(UNIT=ilu,FMT=*)
ENDDO
n = 11
DO i = 1, n
READ(UNIT=ilu,FMT=*) x(i), y(i)
y(i) = y(i) * 1.e-23
ENDDO
CLOSE(UNIT=ilu)
CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
CALL addpnt(x,y,kdata,n, 0.,0.)
CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
CALL addpnt(x,y,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x,y,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
* quantum yields from:
* Zellner, Exner, Herrmann: Absolute OH quantum Yields
* in the laser photolysis of nitrate, nitrite and dissolved H2O2
* at 308 and 351 nm in the temperature range 278-353K, JAC, 1990.
* Temperature dependency determined at 308 nm and pH=9
DO iw = 1, nw-1
DO i = 1, nz
qy = 0.98 * EXP (660. *((1./298.)-(1./tlev(i))))
sig = yg(iw)
* actinic flux in droplet assumes to be 1.6 the interstitial
* actinic flux (see Ruggaber, 1997)
sq(j,i,iw) = qy * sig *1.6
ENDDO
ENDDO
tpflag(j) = 1
RETURN
END
CCC FILE setaer.f
* vertical profiles of atmospheric variables
* setaer
*=============================================================================*
SUBROUTINE setaer(ipbl, zpbl, aod330,
$ tau550, ssaaer, alpha,
$ nz, z, nw, wl,
$ dtaer, omaer, gaer, kout )
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Set up an altitude profile of aerosols, and corresponding absorption =*
*= optical depths, single scattering albedo, and asymmetry factor. =*
*= Single scattering albedo and asymmetry factor can be selected for each =*
*= input aerosol layer (do not have to correspond to working altitude =*
*= grid). See loop 27. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= DTAER - REAL, optical depth due to absorption by aerosols at each (O)=*
*= altitude and wavelength =*
*= OMAER - REAL, single scattering albedo due to aerosols at each (O)=*
*= defined altitude and wavelength =*
*= GAER - REAL, aerosol asymmetry factor at each defined altitude and (O)=*
*= wavelength =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER kdata
PARAMETER(kdata=51)
* input:
REAL wl(kw)
REAL z(kz)
INTEGER nz
INTEGER nw
REAL tau550
REAL ssaaer, alpha
* output: (on converted grid)
REAL dtaer(kz,kw), omaer(kz,kw), gaer(kz,kw)
* local:
REAL zd(kdata), aer(kdata)
REAL cd(kdata), omd(kdata), gd(kdata)
REAL womd(kdata), wgd(kdata)
REAL cz(kz)
REAL omz(kz)
REAL gz(kz)
REAL colold
REAL wc, wscale
INTEGER i, iw, nd
REAL fsum
EXTERNAL fsum
REAL zpbl
INTEGER ipbl
REAL aod330
REAL aodw(kw), ssaw(kw)
REAL fract(kz)
*_______________________________________________________________________
* Aerosol data from Elterman (1968)
* These are vertical optical depths per km, in 1 km
* intervals from 0 km to 50 km, at 340 nm.
* This is one option. User can specify different data set.
DATA aer/
1 2.40E-01,1.06E-01,4.56E-02,1.91E-02,1.01E-02,7.63E-03,
2 5.38E-03,5.00E-03,5.15E-03,4.94E-03,4.82E-03,4.51E-03,
3 4.74E-03,4.37E-03,4.28E-03,4.03E-03,3.83E-03,3.78E-03,
4 3.88E-03,3.08E-03,2.26E-03,1.64E-03,1.23E-03,9.45E-04,
5 7.49E-04,6.30E-04,5.50E-04,4.21E-04,3.22E-04,2.48E-04,
6 1.90E-04,1.45E-04,1.11E-04,8.51E-05,6.52E-05,5.00E-05,
7 3.83E-05,2.93E-05,2.25E-05,1.72E-05,1.32E-05,1.01E-05,
8 7.72E-06,5.91E-06,4.53E-06,3.46E-06,2.66E-06,2.04E-06,
9 1.56E-06,1.19E-06,9.14E-07/
*_______________________________________________________________________
* Altitudes corresponding to Elterman profile, from bottom to top:
WRITE(kout,*)'aerosols: Elterman (1968) continental profile'
nd = 51
DO 22, i = 1, nd
zd(i) = FLOAT(i-1)
22 CONTINUE
* assume these are point values (at each level), so find column
* increments
DO 27, i = 1, nd - 1
cd(i) = (aer(i+1) + aer(i)) / 2.
omd(i) = ssaaer
gd(i) = .61
27 CONTINUE
*********** end data input.
* Compute integrals and averages over grid layers:
* for g and omega, use averages weighted by optical depth
DO 29, i = 1, nd-1
womd(i) = omd(i) * cd(i)
wgd(i) = gd(i) * cd(i)
29 CONTINUE
CALL inter3(nz,z,cz, nd,zd,cd, 1)
CALL inter3(nz,z,omz, nd, zd,womd, 1)
CALL inter3(nz,z,gz , nd, zd,wgd, 1)
DO 30, i = 1, nz-1
IF (cz(i) .GT. 0.) THEN
omz(i) = omz(i)/cz(i)
gz(i) = gz(i) /cz(i)
ELSE
omz(i) = 1.
gz(i) = 0.
ENDIF
30 CONTINUE
* old column at 340 nm
* (minimum value is pzero = 10./largest)
colold = MAX(fsum(nz-1,cz),pzero)
* scale with new column tau at 550 nm
IF(tau550 .GT. nzero) THEN
DO i = 1, nz-1
cz(i) = cz(i) * (tau550/colold) * (550./340.)**alpha
ENDDO
ENDIF
* assign at all wavelengths
* (can move wavelength loop outside if want to vary with wavelength)
DO 50, iw = 1, nw - 1
wc = (wl(iw)+wl(iw+1))/2.
* Elterman's data are for 340 nm, so assume optical depth scales
* inversely with first power of wavelength.
wscale = (340./wc)**alpha
* optical depths:
DO 40, i = 1, nz - 1
dtaer(i,iw) = cz(i) * wscale
omaer(i,iw) = omz(i)
gaer(i,iw) = gz(i)
40 CONTINUE
50 CONTINUE
*! overwrite for pbl:
IF(ipbl .GT. 0) THEN
write (*,*) 'pbl aerosols, aod330 = ', aod330
* create wavelength-dependent optical depth and single scattering albedo:
DO iw = 1, nw-1
wc = (wl(iw)+wl(iw+1))/2.
aodw(iw) = aod330*(wc/330.)**(-1.0)
IF(wc .LT. 400.) THEN
ssaw(iw) = 0.6
ELSE
ssaw(iw) = 0.9
ENDIF
ENDDO
* divide aod among pbl layers, overwrite Elterman profile in pbl
DO i = 1, ipbl
fract(i) = (z(i+1) - z(i))/zpbl
ENDDO
DO iw = 1, nw-1
DO i = 1, ipbl
dtaer(i, iw) = aodw(iw) * fract(i)
omaer(i,iw) = ssaw(iw)
ENDDO
ENDDO
ENDIF
*_______________________________________________________________________
RETURN
END
CCC FILE setalb.f
*=============================================================================*
SUBROUTINE setalb(albnew,nw,wl,albedo,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Set the albedo of the surface. The albedo is assumed to be Lambertian, =*
*= i.e., the reflected light is isotropic, and independent of direction =*
*= of incidence of light. Albedo can be chosen to be wavelength dependent. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= ALBEDO - REAL, surface albedo at each specified wavelength (O)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input: (wavelength working grid data)
INTEGER nw
REAL wl(kw)
REAL albnew
* output:
REAL albedo(kw)
* local:
INTEGER iw
*_______________________________________________________________________
DO 10, iw = 1, nw - 1
albedo(iw) = albnew
10 CONTINUE
* alternatively, can input wavelenght-dependent values if avaialble.
*_______________________________________________________________________
RETURN
END
CCC FILE setcld.f
*======================================================================*
SUBROUTINE setcld(nz,z,nw,wl,
$ lwc, nlevel,
$ dtcld,omcld,gcld,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Set cloud properties for each specified altitude layer. Properties =*
*= may be wavelength dependent. =*
*= Assumes horizontally infinite homogeneous cloud layers.
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= DTCLD - REAL, optical depth due to absorption by clouds at each (O)=*
*= altitude and wavelength =*
*= OMCLD - REAL, single scattering albedo due to clouds at each (O)=*
*= defined altitude and wavelength =*
*= GCLD - REAL, cloud asymmetry factor at each defined altitude and (O)=*
*= wavelength =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER kdata
C PARAMETER(kdata=51)
PARAMETER(kdata=151)
***** input
* (grids)
REAL wl(kw)
REAL z(kz)
INTEGER nz
INTEGER nw
* new total cloud optical depth:
REAL taucld
C REAL zbase, ztop
C LWC is the liquid water content (!! kg/m3 !!) on the calling model
C grid (which has NLEVEL points: Z(1:NLEVEL) = AZ(*)
REAL lwc(*)
INTEGER nlevel
***** Output:
REAL dtcld(kz,kw), omcld(kz,kw), gcld(kz,kw)
***** specified default data:
REAL zd(kdata), cd(kdata), omd(kdata), gd(kdata)
REAL womd(kdata), wgd(kdata)
REAL cldold
* other:
REAL cz(kz)
REAL omz(kz)
REAL gz(kz)
INTEGER i, iw, n
REAL scale
* External functions:
REAL fsum
EXTERNAL fsum
*_______________________________________________________________________
* Set up clouds:
* All clouds are assumed to be infinite homogeneous layers
* Can have different clouds at different altitudes.
* If multiple cloud layers are specified, non-cloudy layers
* between them (if any) must be assigned zero optical depth.
* Set cloud optical properties:
* cd(i) = optical depth of i_th cloudy layer
* omd(i) = singel scattering albedo of i_th cloudy layer
* gd(i) = asymmetry factorof i_th cloudy layer
* Cloud top and bottom can be set to any height zd(i), but if they don't
* match the z-grid (see subroutine gridz.f), they will be interpolated to
* the z-grid.
* Example: set two separate cloudy layers:
* cloud 1:
* base = 4 km
* top = 7 km
* optical depth = 20. (6.67 per km)
* single scattering albedo = 0.9999
* asymmetry factor = 0.85
* cloud 2:
* base = 9 km
* top = 11 km
* optical depth = 5. (2.50 per km)
* single scattering albedo = 0.99999
* asymmetry factor = 0.85
n = nlevel + 1
if (n .gt. kdata) stop "SETCLD: not enough memory: KDATA"
zd(1) = 0.
do 110, i = 2, n
zd(i) = 0.5*( z(i-1) + z(i) )
110 continue
C calculate cloud optical properties
do 120, i = 1, nlevel
C
C reference: Fouquart et al., Rev. Geophys., 1990
C TAU = 3/2 LWC*DZ / (RHOWATER * Reff)
C RHOWATER = 1E3 kg/m3
C Reff = (11 w + 4) 1E-6
C w = LWC * 1E+3 (in g/cm3, since LWC is given in kg/m3)
C
cd(i) = 1.5 * ( lwc(i) * 1E3*(zd(i+1) - zd(i)) )
+ / ( 1E3 * (11.*lwc(i)*1E+3+4.) * 1E-6)
omd(i) = .9999
gd(i) = .85
C print '(A,I5,99E12.5)', "I,TAU,LWC,REFF(um)"
C + , i, cd(i), lwc(i)
C + , ((11.*lwc(i)*1E+3+4.))
120 continue
******************
* compute integrals and averages over grid layers:
* for g and omega, use averages weighted by optical depth
DO 10, i = 1, n-1
womd(i) = omd(i) * cd(i)
wgd(i) = gd(i) * cd(i)
10 CONTINUE
CALL inter3(nz,z,cz, n, zd,cd, 0)
CALL inter3(nz,z,omz, n, zd,womd, 0)
CALL inter3(nz,z,gz , n, zd,wgd, 0)
DO 15, i = 1, nz-1
IF (cz(i) .GT. 0.) THEN
omz(i) = omz(i)/cz(i)
gz(i) = gz(i) /cz(i)
ELSE
omz(i) = 1.
gz(i) = 0.
ENDIF
15 CONTINUE
* assign at all wavelengths
* (can move wavelength loop outside if want to vary with wavelength)
DO 20, iw = 1, nw-1
DO 25, i = 1, nz-1
dtcld(i,iw) = cz(i)
omcld(i,iw) = omz(i)
gcld (i,iw) = gz(i)
25 CONTINUE
20 CONTINUE
*_______________________________________________________________________
RETURN
END
CCC FILE setno2.f
*=============================================================================*
SUBROUTINE setno2(ipbl, zpbl, xpbl,
$ no2new, nz, z, nw, wl, no2xs,
$ tlay, dcol,
$ dtno2,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Set up an altitude profile of NO2 molecules, and corresponding absorption=*
*= optical depths. Subroutine includes a shape-conserving scaling method =*
*= that allows scaling of the entire profile to a given overhead NO2 =*
*= column amount. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NO2NEW - REAL, overhead NO2 column amount (molec/cm^2) to which (I)=*
*= profile should be scaled. If NO2NEW < 0, no scaling is done =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NO2XS - REAL, molecular absoprtion cross section (cm^2) of O2 at (I)=*
*= each specified wavelength =*
*= TLAY - REAL, temperature (K) at each specified altitude layer (I)=*
*= DTNO2 - REAL, optical depth due to NO2 absorption at each (O)=*
*= specified altitude at each specified wavelength =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER kdata
PARAMETER(kdata=51)
********
* input:
********
* grids:
REAL wl(kw)
REAL z(kz)
INTEGER nw
INTEGER nz
REAL no2new
* mid-layer temperature, layer air column
REAL tlay(kz), dcol(kz)
********
* output:
********
REAL dtno2(kz,kw)
********
* local:
********
* absorption cross sections
REAL no2xs(kz,kw)
REAL cz(kz)
* nitrogen dioxide profile data:
REAL zd(kdata), no2(kdata)
REAL cd(kdata)
REAL hscale
REAL colold, scale
REAL sno2
REAL zpbl, xpbl
INTEGER ipbl
* other:
INTEGER i, l, nd
********
* External functions:
********
REAL fsum
EXTERNAL fsum
*_______________________________________________________________________
* Data input:
* Example: set to 1 ppb in lowest 1 km, set to zero above that.
* - do by specifying concentration at 3 altitudes.
nd = 3
zd(1) = 0.
no2(1) = 1. * 2.69e10
zd(2) = 1.
no2(2) = 1. * 2.69e10
zd(3) = zd(2)* 1.000001
no2(3) = 10./largest
* compute column increments (alternatively, can specify these directly)
DO 11, i = 1, nd - 1
cd(i) = (no2(i+1)+no2(i)) * 1.E5 * (zd(i+1)-zd(i)) / 2.
11 CONTINUE
* Include exponential tail integral from top level to infinity.
* fold tail integral into top layer
* specify scale height near top of data (use ozone value)
hscale = 4.50e5
cd(nd-1) = cd(nd-1) + hscale * no2(nd)
***********
*********** end data input.
* Compute column increments and total column on standard z-grid.
CALL inter3(nz,z,cz, nd,zd,cd, 1)
**** Scaling of vertical profile by ratio of new to old column:
* If old column is near zero (less than 1 molec cm-2),
* use constant mixing ratio profile (nominal 1 ppt before scaling)
* to avoid numerical problems when scaling.
IF(fsum(nz-1,cz) .LT. 1.) THEN
DO i = 1, nz-1
cz(i) = 1.E-12 * dcol(i)
ENDDO
ENDIF
colold = fsum(nz-1, cz)
scale = 2.687e16 * no2new / colold
DO i = 1, nz-1
cz(i) = cz(i) * scale
ENDDO
*! overwrite for specified pbl height
IF(ipbl .GT. 0) THEN
write(*,*) 'pbl NO2 = ', xpbl, ' ppb'
DO i = 1, nz-1
IF (i .LE. ipbl) THEN
cz(i) = xpbl*1.E-9 * dcol(i)
ELSE
cz(i) = 0.
ENDIF
ENDDO
ENDIF
************************************
* calculate optical depth for each layer. Output: dtno2(kz,kw)
98 continue
DO 20, l = 1, nw-1
DO 10, i = 1, nz-1
dtno2(i,l) = cz(i)*no2xs(i,l)
10 CONTINUE
20 CONTINUE
*_______________________________________________________________________
RETURN
END
CCC FILE seto2.f
*=============================================================================*
SUBROUTINE seto2(nz, z, nw, wl, cz, o2xs1, dto2, kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Set up an altitude profile of air molecules. Subroutine includes a =*
*= shape-conserving scaling method that allows scaling of the entire =*
*= profile to a given sea-level pressure. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= and each specified wavelength =*
*= CZ - REAL, number of air molecules per cm^2 at each specified (O)=*
*= altitude layer =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input: (grids)
REAL wl(kw)
REAL z(kz)
INTEGER iw, nw
INTEGER iz, nz
REAL cz(kz)
REAL o2xs1(kw)
* output:
* O2 absorption optical depth per layer at each wavelength
REAL dto2(kz,kw)
*_______________________________________________________________________
* Assumes that O2 = 20.95 % of air density. If desire different O2
* profile (e.g. for upper atmosphere) then can load it here.
DO iz = 1, nz-1
DO iw =1, nw - 1
dto2(iz,iw) = 0.2095 * cz(iz) * o2xs1(iw)
ENDDO
ENDDO
*_______________________________________________________________________
RETURN
END
CCC FILE setsnw.f
* This file contains the following subroutines related to spectral optical
* propersties of snowpack needed to compute actinic fluxes
* setsnw
* rdice_acff
*=============================================================================*
SUBROUTINE setsnw(nz,z,nw,wl,dtsnw,omsnw,gsnw,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Set optical and physical properties for snowpack. =*
*= Currently for wavelength-independent properties. =*
*= Subroutine outputs spectral quantities. =*
*= Lee-Taylor, J., and S. Madronich (2002), Calculation of actinic fluxes =*
*= with a coupled atmosphere-snow radiative transfer model, J. Geophys. =*
*= Res., 107(D24) 4796 (2002) doi:10.1029/2002JD002084 =*
*-----------------------------------------------------------------------------*
*= USER-DEFINED VARIABLES: =*
*= zs - height (km) of snow layer boundary above GROUND level =*
*= snwdens - density (g/cm3) =*
*= ksct - mass-specific scattering coefficient (m2/kg) =*
*= csoot - soot content (ng Carbon / g snow) =*
*= snow - (=T/F) switch for presence of snow
*= =*
*= PARAMETERS: =*
*= nz - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= z - REAL, specified altitude working grid (km) (I)=*
*= nw - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= wl - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= dtsnw - REAL, optical depth due to absorption by snow at each (O)=*
*= altitude and wavelength =*
*= omsnw - REAL, single scattering albedo due to snow at each (O)=*
*= defined altitude and wavelength =*
*= gsnw - REAL, snow asymmetry factor at each defined altitude and (O)=*
*= wavelength =*
*= rabs - absorption coefficient of snow, wavelength-dependent =*
*= rsct - scattering coefficient of snow, assume wavelength-independent =*
*-----------------------------------------------------------------------------*
*= EDIT HISTORY: =*
*= 10/00 adapted from setcld.f, Julia Lee-Taylor, ACD, NCAR =*
*-----------------------------------------------------------------------------*
*= This program is free software; you can redistribute it and/or modify =*
*= it under the terms of the GNU General Public License as published by the =*
*= Free Software Foundation; either version 2 of the license, or (at your =*
*= option) any later version. =*
*= The TUV package is distributed in the hope that it will be useful, but =*
*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
*= License for more details. =*
*= To obtain a copy of the GNU General Public License, write to: =*
*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
*-----------------------------------------------------------------------------*
*= To contact the authors, please mail to: =*
*= Jula Lee-Taylor, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
*= send email to: julial@ucar.edu =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER kdata
PARAMETER(kdata=51)
* input: (grids)
REAL wl(kw)
REAL z(kz)
INTEGER nz
INTEGER nw
* Output:
REAL dtsnw(kz,kw), omsnw(kz,kw), gsnw(kz,kw)
* local:
* specified data:
REAL zs(kdata),dzs
REAL cd(kdata), omd(kdata), gd
REAL snwdens(kdata) ! snwdens = snow density, g/cm3
REAL csoot(kdata) ! conc of elemental carbon, ng/g
REAL r_ice(kw),rsoot
REAL womd(kdata), wgd(kdata)
REAL rsct(kdata),ksct(kdata),rabs(kdata)
* other:
REAL cz(kz),omz(kz),gz(kz)
INTEGER i,is,iw,iz,nsl
* External functions:
REAL fsum
EXTERNAL fsum
*--------------------------------------------------------------------------
* SNOW PROPERTIES: USER-DEFINED
*--------------------------------------------------------------------------
** define "number of snow layers + 1" (0 = no snow, 2 = single snow layer)
nsl = 0
IF(nsl.GE.2)THEN
** define snow grid, zs(ns), in km above GROUND level
* NOTE: to get good vertical resolution, subroutine gridz (in grids.f) should
* be modified to include small (1cm - 1mm) layers near snowpack top.
zs(1) = 0.0
zs(2) = 0.001
** define snow scattering coefficient, ksct, m2/kg snow
* melting midlatitude maritime (mountain) snow, ksct = 1-5 m2/kg_snow
* warmer polar coastal/maritime snow, ksct = 6-13 m2/kg_snow
* cold dry polar/tundra snow, ksct = 20-30 m2/kg_snow
* Fisher, King and Lee-Taylor (2005), JGR 110(D21301) doi:10.1029/2005JD005963
ksct(1) = 25. ! m2.kg-1 snow
** define snow density, snwdens, g/cm3
snwdens(1) = 0.4 ! g/cm3
** define soot content, csoot, ng/g elemental carbon
csoot(1) = 0. ! ng/g elemental carbon
*----------------------------------------------------------------------------
* SNOW PROPERTIES: FROM LITERATURE
*--------------------------------------------------------------------------
* read absorption coefficients
CALL rdice_acff(nw,wl,r_ice,kout) ! cm^-1 ice
* absorption due to soot, assume wavelength-independent
* rsoot ~ 10 m2/gC @500nm : Warren & Wiscombe, Nature 313,467-470 (1985)
rsoot = 10. ! m2/gC
* asymmetry factor : Wiscombe & Warren, J. Atmos. Sci, 37, 2712-2733 (1980)
gd = 0.89
*----------------------------------------------------------------------------
* loop snow layers, assigning optical properties at each wavelength
DO 17, iw = 1, nw-1
DO 11 is = 1,nsl-1
rsct(is)=ksct(is)*snwdens(is)*1.e+3 ! m-1
rsct(is)=rsct(is)*(zs(is+1)-zs(is))*1.e+3 ! no units
rabs(is) = (r_ice(iw)/0.9177*1.e5 + rsoot*csoot(is))
$ * snwdens(is)*(zs(is+1)-zs(is)) ! no units
cd(is) = rsct(is) + rabs(is)
omd(is)= rsct(is) / cd(is)
if(iw.EQ.1)then
print*,"Snowpack: is =",is,"; zs =",zs(is)
PRINT*," ksct =", ksct(is)
PRINT*," density =",snwdens(is)
PRINT*," csoot =",csoot(is)
PRINT*, 'cd = ',cd(is),' omd = ',omd(is),' gd = ',gd
WRITE(kout,*)'snwdens = ',snwdens,' g/cm3'
WRITE(kout,*)'ksct_snow = ',ksct(is),' m2.kg-1'
WRITE(kout,*)'soot = ',csoot(is),' ng/g'
WRITE(kout,*)'cd = ',cd(is),'omd = ',omd(is),'gd = ',gd
endif
* compute integrals and averages over snow layers:
* for g and omega, use averages weighted by optical depth
womd(is) = omd(is) * cd(is)
wgd(is) = gd * cd(is)
11 CONTINUE
* interpolate snow layers onto TUV altitude grid (gridz)
CALL inter3(nz,z,cz, nsl,zs,cd, 0)
CALL inter3(nz,z,omz,nsl,zs,womd, 0)
CALL inter3(nz,z,gz ,nsl,zs,wgd, 0)
DO 15, iz = 1, nz-1
IF (cz(iz) .GT. 0.) THEN
omz(iz) = omz(iz)/cz(iz)
gz(iz) = gz(iz) /cz(iz)
ELSE
omz(iz) = 0.
gz(iz) = 0.
ENDIF
dtsnw(iz,iw) = cz(iz)
omsnw(iz,iw) = omz(iz)
gsnw(iz,iw) = gz(iz)
15 CONTINUE
17 CONTINUE
PRINT*,"Snowpack top: zs =",zs(nsl)
ELSE ! no snow
DO 16, iz = 1, nz-1
cz(iz) = 0.
omz(iz) = 1.
gz(iz) = 0.
DO 18, iw = 1, nw-1
dtsnw(iz,iw) = cz(iz)
omsnw(iz,iw) = omz(iz)
gsnw(iz,iw) = gz(iz)
18 CONTINUE
16 CONTINUE
ENDIF ! snow exists
RETURN
END
*******************************************************************************
SUBROUTINE rdice_acff(nw,wl,rabs,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Read ice absorption coefficient. Re-grid data to match =*
*= specified wavelength working grid. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= RABS_ice - REAL, absorption coefficient (cm^-1) of ice at (O)=*
*= each specified wavelength =*
*-----------------------------------------------------------------------------*
*= EDIT HISTORY: =*
*= 10/00 Created routine by editing rdh2oxs. =*
*-----------------------------------------------------------------------------*
*= This program is free software; you can redistribute it and/or modify =*
*= it under the terms of the GNU General Public License as published by the =*
*= Free Software Foundation; either version 2 of the license, or (at your =*
*= option) any later version. =*
*= The TUV package is distributed in the hope that it will be useful, but =*
*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
*= License for more details. =*
*= To obtain a copy of the GNU General Public License, write to: =*
*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
*-----------------------------------------------------------------------------*
*= To contact the authors, please mail to: =*
*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
*= send email to: sasha@ucar.edu =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER kdata
PARAMETER(kdata=1000)
* input: (altitude working grid)
INTEGER nw
REAL wl(kw)
* output:
REAL rabs(kw)
* local:
REAL x1(kdata)
REAL y1(kdata),y2(kdata),y3(kdata)
REAL yg(kw)
REAL a1, a2, dum
INTEGER ierr
INTEGER i,l,m, n, idum
CHARACTER*40 fil
*_______________________________________________________________________
************* absorption cross sections:
* ice absorption cross sections from
fil = 'DATA/ice'
OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/ICE_Perov.acff',STATUS='old')
m = 17 ! header lines
n = 79 ! data lines
!OPEN(NEWUNIT=ilu,FILE='DATAJ1/ABS/ICE_min.acff',STATUS='old')
!m = 13 ! header lines
!n = 52 ! data lines
DO 11, i = 1,m
read(UNIT=ilu,FMT=*)
11 CONTINUE
DO 12, i = 1, n
READ(UNIT=ilu,FMT=*) x1(i), y1(i)
12 CONTINUE
CLOSE (UNIT=ilu)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
WRITE(*,*) ierr, fil
STOP
ENDIF
DO 13, l = 1, nw-1
rabs(l) = yg(l)
13 CONTINUE
*_______________________________________________________________________
RETURN
END
CCC FILE setso2.f
*=============================================================================*
SUBROUTINE setso2(ipbl, zpbl, xpbl,
$ so2new, nz, z, nw, wl, so2xs,
$ tlay, dcol,
$ dtso2,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Set up an altitude profile of SO2 molecules, and corresponding absorption=*
*= optical depths. Subroutine includes a shape-conserving scaling method =*
*= that allows scaling of the entire profile to a given overhead SO2 =*
*= column amount. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= SO2NEW - REAL, overhead SO2 column amount (molec/cm^2) to which (I)=*
*= profile should be scaled. If SO2NEW < 0, no scaling is done =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= SO2XS - REAL, molecular absoprtion cross section (cm^2) of O2 at (I)=*
*= each specified wavelength =*
*= TLAY - REAL, temperature (K) at each specified altitude layer (I)=*
*= DTSO2 - REAL, optical depth due to SO2 absorption at each (O)=*
*= specified altitude at each specified wavelength =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER kdata
PARAMETER(kdata=51)
********
* input:
********
* grids:
REAL wl(kw)
REAL z(kz)
INTEGER nw
INTEGER nz
REAL so2new
* mid-layer temperature and layer air column
REAL tlay(kz), dcol(kz)
********
* output:
********
REAL dtso2(kz,kw)
********
* local:
********
* absorption cross sections
REAL so2xs(kw)
REAL cz(kz)
* sulfur dioxide profile data:
REAL zd(kdata), so2(kdata)
REAL cd(kdata)
REAL hscale
REAL colold, scale
REAL sso2
REAL zpbl, xpbl
INTEGER ipbl
* other:
INTEGER i, l, nd
********
* External functions:
********
REAL fsum
EXTERNAL fsum
*_______________________________________________________________________
* Data input:
* Example: set to 1 ppb in lowest 1 km, set to zero above that.
* - do by specifying concentration at 3 altitudes.
nd = 3
zd(1) = 0.
so2(1) = 1. * 2.69e10
zd(2) = 1.
so2(2) = 1. * 2.69e10
zd(3) = zd(2)* 1.000001
so2(3) = 10./largest
* compute column increments (alternatively, can specify these directly)
DO 11, i = 1, nd - 1
cd(i) = (so2(i+1)+so2(i)) * 1.E5 * (zd(i+1)-zd(i)) / 2.
11 CONTINUE
* Include exponential tail integral from top level to infinity.
* fold tail integral into top layer
* specify scale height near top of data (use ozone value)
hscale = 4.50e5
cd(nd-1) = cd(nd-1) + hscale * so2(nd)
***********
*********** end data input.
* Compute column increments on standard z-grid.
CALL inter3(nz,z,cz, nd,zd,cd, 1)
**** Scaling of vertical profile by ratio of new to old column:
* If old column is near zero (less than 1 molec cm-2),
* use constant mixing ratio profile (nominal 1 ppt before scaling)
* to avoid numerical problems when scaling.
IF(fsum(nz-1,cz) .LT. 1.) THEN
DO i = 1, nz-1
cz(i) = 1.E-12 * dcol(i)
ENDDO
ENDIF
colold = fsum(nz-1,cz)
scale = 2.687e16 * so2new / colold
DO i = 1, nz-1
cz(i) = cz(i) * scale
ENDDO
*! overwrite for specified pbl height, set concentration here
IF(ipbl .GT. 0) THEN
write(*,*) 'pbl SO2 = ', xpbl, ' ppb'
DO i = 1, nz-1
IF (i .LE. ipbl) THEN
cz(i) = xpbl*1.E-9 * dcol(i)
ELSE
cz(i) = 0.
ENDIF
ENDDO
ENDIF
************************************
* calculate sulfur optical depth for each layer, with optional temperature
* correction. Output, dtso2(kz,kw)
DO 20, l = 1, nw-1
sso2 = so2xs(l)
DO 10, i = 1, nz - 1
c Leaving this part in in case i want to interpolate between
c the 221K and 298K data.
c
c IF ( wl(l) .GT. 240.5 .AND. wl(l+1) .LT. 350. ) THEN
c IF (tlay(i) .LT. 263.) THEN
c sso2 = s221(l) + (s263(l)-s226(l)) / (263.-226.) *
c $ (tlay(i)-226.)
c ELSE
c sso2 = s263(l) + (s298(l)-s263(l)) / (298.-263.) *
c $ (tlay(i)-263.)
c ENDIF
c ENDIF
dtso2(i,l) = cz(i)*sso2
10 CONTINUE
20 CONTINUE
*_______________________________________________________________________
RETURN
END
CCC FILE sphers.f
* This file contains the following subroutines, related to the
* spherical geometry of the Earth's atmosphere
* sphers
* airmas
*=============================================================================*
SUBROUTINE sphers(nz, z, zen, dsdh, nid, kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Calculate slant path over vertical depth ds/dh in spherical geometry. =*
*= Calculation is based on: A.Dahlback, and K.Stamnes, A new spheric model =*
*= for computing the radiation field available for photolysis and heating =*
*= at twilight, Planet.Space Sci., v39, n5, pp. 671-683, 1991 (Appendix B) =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= Z - REAL, specified altitude working grid (km) (I)=*
*= ZEN - REAL, solar zenith angle (degrees) (I)=*
*= DSDH - REAL, slant path of direct beam through each layer crossed (O)=*
*= when travelling from the top of the atmosphere to layer i; =*
*= DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1 =*
*= NID - INTEGER, number of layers crossed by the direct beam when (O)=*
*= travelling from the top of the atmosphere to layer i; =*
*= NID(i), i = 0..NZ-1 =*
*-----------------------------------------------------------------------------*
*= EDIT HISTORY: =*
*= double precision fix for shallow layers - Julia Lee-Taylor Dec 2000 =*
*-----------------------------------------------------------------------------*
*= This program is free software; you can redistribute it and/or modify =*
*= it under the terms of the GNU General Public License as published by the =*
*= Free Software Foundation; either version 2 of the license, or (at your =*
*= option) any later version. =*
*= The TUV package is distributed in the hope that it will be useful, but =*
*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
*= License for more details. =*
*= To obtain a copy of the GNU General Public License, write to: =*
*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
*-----------------------------------------------------------------------------*
*= To contact the authors, please mail to: =*
*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
*= send email to: sasha@ucar.edu =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nz
REAL zen, z(kz)
* output
INTEGER nid(0:kz)
REAL dsdh(0:kz,kz)
* more program constants
REAL re, ze(kz)
REAL dr
PARAMETER ( dr = pi/180.)
* local
REAL(kind(0.0d0)) :: zenrad, rpsinz, rj, rjp1, dsj, dhj,
& ga, gb, sm
INTEGER i, j, k
INTEGER id
INTEGER nlayer
REAL zd(0:kz-1)
*-----------------------------------------------------------------------------
zenrad = zen*dr
* number of layers:
nlayer = nz - 1
* include the elevation above sea level to the radius of the earth:
re = radius + z(1)
* correspondingly z changed to the elevation above earth surface:
DO k = 1, nz
ze(k) = z(k) - z(1)
END DO
* inverse coordinate of z
zd(0) = ze(nz)
DO k = 1, nlayer
zd(k) = ze(nz - k)
END DO
* initialize dsdh(i,j), nid(i)
DO i = 0, kz
nid(i) = 0
DO j = 1, kz
dsdh(i,j) = 0.
END DO
END DO
* calculate ds/dh of every layer
DO 100 i = 0, nlayer
rpsinz = (re + zd(i)) * SIN(zenrad)
IF ( (zen .GT. 90.0) .AND. (rpsinz .LT. re) ) THEN
nid(i) = -1
ELSE
*
* Find index of layer in which the screening height lies
*
id = i
IF( zen .GT. 90.0 ) THEN
DO 10 j = 1, nlayer
IF( (rpsinz .LT. ( zd(j-1) + re ) ) .AND.
$ (rpsinz .GE. ( zd(j) + re )) ) id = j
10 CONTINUE
END IF
DO 20 j = 1, id
sm = 1.0
IF(j .EQ. id .AND. id .EQ. i .AND. zen .GT. 90.0)
$ sm = -1.0
rj = re + zd(j-1)
rjp1 = re + zd(j)
dhj = zd(j-1) - zd(j)
ga = rj*rj - rpsinz*rpsinz
gb = rjp1*rjp1 - rpsinz*rpsinz
IF (ga .LT. 0.0) ga = 0.0
IF (gb .LT. 0.0) gb = 0.0
IF(id.GT.i .AND. j.EQ.id) THEN
dsj = SQRT( ga )
ELSE
dsj = SQRT( ga ) - sm*SQRT( gb )
END IF
dsdh(i,j) = dsj / dhj
20 CONTINUE
nid(i) = id
END IF
100 CONTINUE
*-----------------------------------------------------------------------------
RETURN
END
*=============================================================================*
SUBROUTINE airmas(nz, dsdh, nid, cz,
$ vcol, scol,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Calculate vertical and slant air columns, in spherical geometry, as a =*
*= function of altitude. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= DSDH - REAL, slant path of direct beam through each layer crossed (O)=*
*= when travelling from the top of the atmosphere to layer i; =*
*= DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1 =*
*= NID - INTEGER, number of layers crossed by the direct beam when (O)=*
*= travelling from the top of the atmosphere to layer i; =*
*= NID(i), i = 0..NZ-1 =*
*= VCOL - REAL, output, vertical air column, molec cm-2, above level iz =*
*= SCOL - REAL, output, slant air column in direction of sun, above iz =*
*= also in molec cm-2 =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* Input:
INTEGER nz
INTEGER nid(0:kz)
REAL dsdh(0:kz,kz)
REAL cz(kz)
* output:
REAL vcol(kz), scol(kz)
* internal:
INTEGER id, j
REAL sum, vsum
* calculate vertical and slant column from each level:
* work downward
vsum = 0.
DO id = 0, nz - 1
vsum = vsum + cz(nz-id)
vcol(nz-id) = vsum
sum = 0.
IF(nid(id) .LT. 0) THEN
sum = largest
ELSE
* single pass layers:
DO j = 1, MIN(nid(id), id)
sum = sum + cz(nz-j)*dsdh(id,j)
ENDDO
* double pass layers:
DO j = MIN(nid(id),id)+1, nid(id)
sum = sum + 2.*cz(nz-j)*dsdh(id,j)
ENDDO
ENDIF
scol(nz - id) = sum
ENDDO
RETURN
END
CCC FILE swchem.f
*=============================================================================*
SUBROUTINE swchem(nw,wl,nz,tlev,airden,
$ j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
*= Load various "weighting functions" (products of cross section and =*
*= quantum yield at each altitude and each wavelength). The altitude =*
*= dependence is necessary to ensure the consideration of pressure and =*
*= temperature dependence of the cross sections or quantum yields. =*
*= The actual reading, evaluation and interpolation is done in separate =*
*= subroutines for ease of management and manipulation. Please refer to =*
*= the inline documentation of the specific subroutines for detail =*
*= information. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
*= SQ - REAL, cross section * quantum yield (cm^2) for each (O)=*
*= photolysis reaction defined, at each defined wavelength and =*
*= at each defined altitude level =*
*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* input
INTEGER nw
REAL wl(kw)
INTEGER nz
REAL tlev(kz)
REAL airden(kz)
* weighting functions
CHARACTER*50 jlabel(kj)
REAL sq(kj,kz,kw)
INTEGER tpflag(kj)
* input/output:
INTEGER j
* local:
REAL wc(kw)
INTEGER iw
*_______________________________________________________________________
* complete wavelength grid
DO 5, iw = 1, nw - 1
wc(iw) = (wl(iw) + wl(iw+1))/2.
5 CONTINUE
*____________________________________________________________________________
******** Ox Photochemistry
* A1. O2 + hv -> O + O
* reserve first position. Cross section parameterization in Schumman-Runge and
* Lyman-alpha regions are zenith-angle dependent, will be written in
* subroutine seto2.f.
* declare temperature dependence, tpflag = 1
j = 1
jlabel(j) = 'O2 -> O + O'
tpflag(j) = 1
*A2. O3 + hv -> (both channels)
CALL r01(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
******** HOx Photochemistry
*B1. HO2 + hv -> OH + O
C CALL r39(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*B3. H2O2 + hv -> 2 OH
CALL r08(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
******** NOx Photochemistry
*C1. NO2 + hv -> NO + O(3P)
CALL r02(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*C2. NO3 + hv -> (both channels)
CALL r03(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*C3. N2O + hv -> N2 + O(1D)
C CALL r44(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*C5. N2O5 + hv -> (both channels)
C CALL r04(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*C6. HNO2 + hv -> OH + NO
CALL r05(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*C7. HNO3 + hv -> OH + NO2
CALL r06(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*C8. HNO4 + hv -> HO2 + NO2
CALL r07(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* NO3-(aq) + hv -> NO2 + O- (for snow)
* NO3-(aq) + hv -> NO2- + O(3P) (for snow)
C CALL r118(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
******** Organic Photochemistry
*D1. CH2O + hv -> (both channels)
c CALL r10(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
CALL pxCH2O(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D2. CH3CHO + hv -> (all three channels)
CALL r11(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D3. C2H5CHO + hv -> C2H5 + HCO
CALL r12(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D9. CH3(OOH) + hv -> CH3O + OH
CALL r16(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D10. HOCH2OOH -> HOCH2O. + OH
C CALL r121(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D12. CH3(ONO2) + hv -> CH3O + NO2
CALL r17(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D13. CH3(OONO2) -> CH3(OO) + NO2
C call r134(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* CH3CH2(ONO2) -> CH3CH2O + NO2
CALL r106(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* C2H5(ONO2) -> C2H5O + NO2
C call r141(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* n-C3H7ONO2 -> n-C3H7O + NO2
call r142(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* 1-C4H9ONO2 -> 1-C4H9O + NO2
C call r143(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* 2-C4H9ONO2 -> 2-C4H9O + NO2
C call r144(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* CH3CH(ONO2)CH3 -> CH3CHOCH3 + NO2
CALL r107(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* CH2(OH)CH2(ONO2) -> CH2(OH)CH2(O.) + NO2
C CALL r108(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* CH3COCH2(ONO2) -> CH3COCH2(O.) + NO2
C CALL r109(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* C(CH3)3(ONO2) -> C(CH3)3(O.) + NO2
C CALL r110(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* C(CH3)3(ONO) -> C(CH3)3(O) + NO
C call r135(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D14. PAN + hv -> CH3CO(OO) + NO2
* PAN + hv -> CH3CO(O) + NO3
CALL r18(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D15. CH3CH2COO2NO2 -> CH3CH2CO(OO) + NO2
* CH3CH2COO2NO2 -> CH2CH2CO(O) + NO3
CALL r120(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D16. CH2=CHCHO + hv -> Products
CALL r122(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D17. CH2=C(CH3)CHO + hv -> Products
CALL r104(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D18. CH3COCH=CH2 + hv -> Products
CALL r103(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D19. CH2(OH)CHO + hv -> Products
CALL r101(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D20. CH3COCH3 + hv -> Products
CALL r15(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* CH3COCH2CH3 -> CH3CO + CH2CH3
CALL r119(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D21. CH2(OH)COCH3 -> CH3CO + CH2(OH)
* CH2(OH)COCH3 -> CH2(OH)CO + CH3
C CALL r112(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D22. CHOCHO + hv -> Products
CALL r13(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D23. CH3COCHO + hv -> Products
CALL r14(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* CH3COCOCH3 + hv -> Products
C CALL r102(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D25. CH3CO(OH) + hv -> Products
C CALL r138(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D26. CH3CO(OOH) + hv -> Products
CALL r123(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*D28. CH3COCO(OH) + hv -> Products
C CALL r105(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* (CH3)2NNO -> products
C call r124(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* CH3COCH2CH2CH3 + hv -> CH3CO + CH2CH2CH3
* M. Leriche added March 2018 for KETL (CACM, ReLACS2 and ReLACS3)
* Uses availble Martinez data for cross section
CALL r149(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
* BENZALD + hv -> phenoxy + HO2 + CO
* M. Leriche added March 2018 for BALD (RACM2)
* Uses data from SAPRC-07 for cross section
CALL r150(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
******** FOx Photochemistry
*E12. CF2O + hv -> Products
C CALL r22(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
******** ClOx Photochemistry
*F1. Cl2 + hv -> Cl + Cl
C CALL r47(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F2. ClO -> Cl + O
C call r125(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F3. ClOO + hv -> Products
C CALL r31(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F4. OCLO -> Products
C call r132(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F7. ClOOCl -> Cl + ClOO
C CALL r111(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F13. HCl -> H + Cl
C CALL r137(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F14. HOCl -> HO + Cl
C call r130(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F15. NOCl -> NO + Cl
C call r131(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F16. ClNO2 -> Cl + NO2
C call r126(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F17. ClONO -> Cl + NO2
C call r136(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F18. ClONO2 + hv -> Products
C CALL r45(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F19. CCl4 + hv -> Products
C CALL r20(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F20. CH3OCl + hv -> Cl + CH3O
C CALL r139(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F21. CHCl3 -> Products
C CALL r140(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F23. CH3Cl + hv -> Products
C CALL r30(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F24. CH3CCl3 + hv -> Products
C CALL r29(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F30. CCl2O + hv -> Products
C CALL r19(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F32. CClFO + hv -> Products
C CALL r21(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F33. CCl3F (CFC-11) + hv -> Products
C CALL r26(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F34. CCl2F2 (CFC-12) + hv -> Products
C CALL r27(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F36. CF2ClCFCl2 (CFC-113) + hv -> Products
C CALL r23(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F37. CF2ClCF2Cl (CFC-114) + hv -> Products
C CALL r24(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F38. CF3CF2Cl (CFC-115) + hv -> Products
C CALL r25(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F40. CHClF2 (HCFC-22) + hv -> Products
C CALL r38(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F42. CF3CHCl2 (HCFC-123) + hv -> Products
C CALL r32(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F43. CF3CHFCl (HCFC-124) + hv -> Products
C CALL r33(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F45. CH3CFCl2 (HCFC-141b) + hv -> Products
C CALL r34(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F46. CH3CF2Cl (HCFC-142b) + hv -> Products
C CALL r35(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F56. CF3CF2CHCl2 (HCFC-225ca) + hv -> Products
C CALL r36(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*F57. CF2ClCF2CHFCl (HCFC-225cb) + hv -> Products
C CALL r37(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
**** BrOx Photochemistry
*G1. Br2 -> Br + Br
C CALL r115(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G3. BrO -> Br + O
C CALL r114(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G6. HOBr -> OH + Br
C CALL r113(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G7. BrNO -> Br + NO
C call r127(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G8. BrONO -> Br + NO2
* BrONO -> BrO + NO
C call r129(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G9. BrNO2 -> Br + NO2
C call r128(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G10. BrONO2 + hv -> Products
C CALL r46(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G11. BrCl -> Br + Cl
C call r133(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G13. CH3Br + hv -> Products
C CALL r28(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G15. CHBr3 + hv -> Products
C CALL r09(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G25. CF2Br2 (Halon-1202) + hv -> Products
C CALL r40(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G26. CF2BrCl (Halon-1211) + hv -> Products
C CALL r41(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G27. CF3Br (Halon-1301) + hv -> Products
C CALL r42(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*G35. CF2BrCF2Br (Halon-2402) + hv -> Products
C CALL r43(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
**** IOx Photochemistry
*H01. I2 -> I + I
c CALL r146(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*H02. IO -> I + O
C CALL r147(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*H05. IOH -> I + OH
C CALL r148(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*H24. perfluoro n-iodo propane -> products
C CALL r145(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
******** aqueous phase (diluted solution) Photochemistry
*** M. Leriche March 2018
*** Add from LaMP code (Deguillaume et al., 2004)
*AQ01. H2O2(aq) -> 2OH
CALL r152(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*AQ02. NO3-(aq) -> NO2 + OH
CALL r151(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
****************************************************************
IF (j .GT. kj) STOP '1002'
RETURN
END
CCC FILE vpair.f
*=============================================================================*
SUBROUTINE vpair(psurf, nz, z,
$ con, col,kout)
*-----------------------------------------------------------------------------*
*= NAME: Vertial Profile of AIR
*= PURPOSE: =*
*= Set up an altitude profile of air molecules. Subroutine includes a =*
*= shape-conserving scaling method that allows scaling of the entire =*
*= profile to a given sea-level pressure. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= PSURF - REAL, surface pressure (mb) to which profile should be (I)=*
*= scaled. If PSURF < 0, no scaling is done =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= outputs are on z-grid:
*= Z - REAL, specified altitude working grid (km) (I)=*
*= CON - REAL, air density (molec/cc) at each specified altitude (O)=*
*= COL - REAL, number of air molecules per cm^2 in each specified (O)=*
*= altitude layer (column vertical increment =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER kdata
PARAMETER(kdata=150)
********* input:
REAL z(kz)
INTEGER nz
REAL psurf
* specified air profile data:
INTEGER nd
REAL zd(kdata), air(kdata)
REAL hscale
REAL cd(kdata)
********* output:
* con(iz) = air density (molec cm-3) at level iz
* col(iz) = column amount (molec cm-2) for layer iz
REAL con(kz)
REAL col(kz)
* local:
REAL scale
REAL pold
REAL pconv
PARAMETER(pconv = 980.665 * 1.E-3 * 28.9644 / 6.022169E23)
* other:
INTEGER i
REAL airlog(kz), conlog(kz)
* External functions:
REAL fsum
EXTERNAL fsum
*_______________________________________________________________________
* The objective of this subroutine is to take the input air profile and interpolate
* it to the working grid, z(i = 1, nz). The desired outputs are con(i) and col(i).
* Input vertical profiles can be specified in various ways. For example:
* altitude vs. concentration (molecules cm-3)
* altitude vs. pressure (mbar) and temperature (K)
* altitude vs. column increments (molec cm-2)
* The interpolation scheme will depend on the specific type of input data.
* Here, the US Standard Atmosphere is given as altitude vs. concentration (also called
* number density)
* _________SECTION 1: Read in vertical profile of concentration
WRITE(kout,*) 'air concentrations: USSA, 1976'
OPEN(NEWUNIT=ilu,FILE='DATAE1/ATM/ussa.dens',STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
nd = 1
4 CONTINUE
READ(UNIT=ilu,FMT=*,END=5) zd(nd), air(nd)
nd = nd+1
GOTO 4
5 CONTINUE
CLOSE(UNIT=ilu)
nd = nd-1
* add 1 meter to top, to avoid interpolation end-problem if z-grid is up to 120 km
zd(nd) = zd(nd) + 0.001
* scale height, km, at top of atmosphere:
hscale = 8.01
********************** end data input.
* ________SECTION 2: Compute column increments on standard z-grid.
* For air, this is best done using logarithms of concentration.
* take logs
* if z-grid extends beyond available data, stop (no extrapolation allowed)
* interpolate log of air(nd) onto z grid
* re-exponentiate to get gridded concentrations
DO i = 1, nd
airlog(i) = ALOG(air(i))
ENDDO
IF(z(nz) .GT. zd(nd)) STOP 'in vpair: ztop < zdata'
CALL inter1(nz,z,conlog, nd,zd,airlog)
DO i = 1, nz
con(i) = EXP(conlog(i))
ENDDO
* Find gridded column increments in z-grid:
* use log intergration
DO i = 1, nz-1
col(i) = 1.E5*(z(i+1)-z(i)) * (con(i+1)-con(i)) /
$ ALOG(con(i+1)/con(i))
ENDDO
* Add exponential tail integral at top of atmosphere:
* this is folded into layer nz-1, making this layer "heavy'.
* The layer nz is not used. The radiative transfer
* calculation is based on nz-1 layers (not nz).
col(nz-1) = col(nz-1) + 1.E5 * hscale * con(nz)
col(nz) = 0.
* Scale by input surface pressure:
* min value = 1 molec cm-2
pold = pconv * MAX(fsum(nz-1,col),1.)
IF(psurf .GT. 0.) THEN
scale = psurf/pold
ELSE
scale = 1.
ENDIF
DO i = 1, nz - 1
col(i) = col(i) * scale
con(i) = con(i) * scale
ENDDO
con(nz) = con(nz) * scale
*_______________________________________________________________________
RETURN
END
CCC FILE vpo3.f
*=============================================================================*
SUBROUTINE vpo3(ipbl, zpbl, mr_pbl,
$ to3new, nz, z, aircol, col, kout)
*-----------------------------------------------------------------------------*
*= NAME: Vertical Profiles of Ozone = vpo3 =*
*= PURPOSE: =*
*= Computes O3 column increments, col(i), molec cm-2 for each layer i of =*
*= the working grid z(i = 1, nz). =*
*= Normally, col(i) values are computed from input vertical profiles of =*
*= concentrations (molec cm-3), that are then interpolated and integrated =*
*= over each layer. The default example here uses the US Standard =*
*= Atmosphere (1976) mid-latitude concentration profile. =*
*= Users can substitute their own concentration profile, as long as =*
*= appropriate adjustments are made in Section 1 to input the data, and in =*
*= section 2 to interpolate to the working grid. =*
*= A scale factor is provided to allow changing the total column amount, =*
*= but conserving the shape of the profile. =*
*= An option to insert PBL pollutants is provided =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= TO3NEW - REAL, Dobson Units, new total column amount from surface =*
*= to space, to be scaled. If TO3NEW < 0, no scaling is done. =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= Z - REAL, specified altitude working grid (km) (I)=*
*= AIRCOL(KZ) = REAL, air column increment (molec cm-2), provided here in =*
*= case it is necessary to convert from mixing ratio units (e.g. ppb). =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
********
* inputs:
********
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
*** from calling program:
INTEGER nz
REAL z(kz)
REAL to3new
REAL aircol(kz)
REAL zpbl, mr_pbl
INTEGER ipbl
* from data file: concentration data as a function of altitude
INTEGER kdata
PARAMETER(kdata=150)
REAL zd(kdata), xd(kdata)
********
* internal
********
INTEGER i, nd
REAL hscale
REAL to3old, scale
REAL con(kz)
REAL rfact
********
* output:
********
REAL col(kz)
********
* External functions:
********
REAL fsum
EXTERNAL fsum
* The objective of this subroutine is to calculate the vertical increments
* in the O3 column, for each layer of the working grid z(i = 1, nz).
* The input O3 profiles can be specified in different ways, and each case
* will require careful consideration of the interpolation scheme. Some
* examples of possible input data are:
* altitude vs. O3 concentration (number density), molec cm-3
* altitude vs. O3 mixing ratio (e.g. parts per billion) relative to air
* altitude vs. O3 column increments, molec cm-2, between specific altitudes.
* Special caution is required with mixed inputs, e.g. ppb in boundary layer and
* molec cm-3 above the boundary layer.
* _________SECTION 1: Read in vertical profile of concentration
* Default is US Standard Atmosphere (1976)
* If a different vertical concentration profile is specified, the code
* in this section (Section 1) should be replaced accordingly
WRITE(kout,*) 'ozone profile: USSA, 1976'
OPEN(NEWUNIT=ilu,FILE='DATAE1/ATM/ussa.ozone',STATUS='old')
DO i = 1, 7
READ(UNIT=ilu,FMT=*)
ENDDO
nd = 39
DO i = 1, nd
READ(UNIT=ilu,FMT=*) zd(i), xd(i)
ENDDO
CLOSE(UNIT=ilu)
* Ussa data stop at 74 km. Add values up to 121 km,
* assuming exponential decay from 74 km up, with scale height of
* 4.5 km.
hscale = 4.5
rfact = EXP(-1./hscale)
10 CONTINUE
nd = nd + 1
zd(nd) = zd(nd-1) + 1.
xd(nd) = xd(nd-1) * rfact
IF(zd(nd) .GE. 121.) GO TO 19
GO TO 10
19 CONTINUE
*********** end data input.
* ________SECTION 2: Compute column increments on standard z-grid.
* linear interpolation
CALL inter1(nz,z,con, nd,zd,xd)
* compute column increments
DO i = 1, nz-1
col(i) = 0.5 * (con(i) + con(i+1)) * (z(i+1) - z(i)) * 1.E5
ENDDO
* Add exponential tail integral at top of atmosphere:
* this is folded into layer nz-1, making this layer "heavy'.
* The layer nz is not used. The radiative transfer
* calculation is based on nz-1 layers (not nz).
col(nz-1) = col(nz-1) + 1.E5 * hscale * con(nz)
***** Scaling to new total ozone
* to3old = total o3 column, in Dobson Units, old value
* to3new = total o3 column, in Dobson Units, new value
* (1 DU = 2.687e16)
* If to3new is not negative, scale to new total column value, to3new :
* (to3new = 0. is a possible input, to see effect of zero ozone)
IF (to3new .GT. nzero) THEN
to3old = fsum(nz-1, col)/2.687e16
IF(to3old .LT. pzero) STOP 'in vpo3: to3old is too small'
scale = to3new/to3old
DO i = 1, nz-1
col(i) = col(i) * scale
con(i) = con(i) * scale
ENDDO
con(nz) = con(nz) * scale
ENDIF
*! overwrite column increments for specified pbl height
* use mixing ratio in pbl
IF(ipbl .GT. 0) THEN
write(*,*) 'pbl O3 = ', mr_pbl, ' ppb'
DO i = 1, nz-1
IF (i .LE. ipbl) THEN
col(i) = mr_pbl*1.E-9 * aircol(i)
ENDIF
ENDDO
ENDIF
*_______________________________________________________________________
RETURN
END
CCC FILE vptmp.f
*=============================================================================*
SUBROUTINE vptmp(nz,z,tlev,tlay,kout)
*-----------------------------------------------------------------------------*
* NAME: Vertical Profile of TeMPerature
*= PURPOSE: =*
*= Set up an altitude profile of temperatures. Temperature values are =*
*= needed to compute some cross sections and quantum yields. Distinguish =*
*= between temperature at levels and layers. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
*= grid =*
*= Z - REAL, specified altitude working grid (km) (I)=*
*= TLEV - REAL, temperature (K) at each specified altitude level (O)=*
*= TLAY - REAL, temperature (K) at each specified altitude layer (O)=*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
INTEGER kdata
PARAMETER(kdata=150)
* input: (altitude working grid)
REAL z(kz)
INTEGER nz
* output:
REAL tlev(kz), tlay(kz)
* local:
REAL zd(kdata), td(kdata)
INTEGER i, nd
*_______________________________________________________________________
* read in temperature profile
WRITE(kout,*) 'air temperature: USSA, 1976'
OPEN(NEWUNIT=ilu,FILE='DATAE1/ATM/ussa.temp',STATUS='old')
DO i = 1, 3
READ(UNIT=ilu,FMT=*)
ENDDO
nd = 1
4 CONTINUE
READ(UNIT=ilu,FMT=*,END=5) zd(nd), td(nd)
nd = nd+1
GOTO 4
5 CONTINUE
CLOSE(UNIT=ilu)
nd = nd-1
* use constant temperature to infinity:
zd(nd) = 1.E10
* alternative input temperature data could include, e.g., a read file here:
***********
*********** end data input.
* interpolate onto z-grid
CALL inter1(nz,z,tlev,nd,zd,td)
* compute layer-averages
DO 20, i = 1, nz - 1
tlay(i) = (tlev(i+1) + tlev(i))/2.
20 CONTINUE
tlay(nz) = tlay(nz-1)
*_______________________________________________________________________
RETURN
END
CCC FILE wshift.f This file contains the subroutine:
* wshift
* the function:
* refrac
*_______________________________________________________________________
SUBROUTINE wshift(mrefr, n, w, airden, kout)
* Shift wavelength scale between air and vacuum.
* if mrefr = 1, shift input waveelengths in air to vacuum.
* if mrefr = -1, shift input wavelengths from vacuum to air
* if any other number, don't shift
IMPLICIT none
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER :: ilu
INTEGER kout
* output
* PARAMETER(kout=6)
*_________________________________________________
* altitude, wavelength, time (or solar zenith angle) grids
INTEGER kz, kw
* altitude
PARAMETER(kz=151)
* wavelength
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
* some constants...
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
* radius of the earth, km:
REAL radius
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
* largest number of the machine:
REAL largest
PARAMETER(largest=1.E+36)
* small numbers (positive and negative)
REAL pzero, nzero
PARAMETER(pzero = +10./largest)
PARAMETER(nzero = -10./largest)
* machine precision
REAL precis
PARAMETER(precis = 1.e-7)
* inputs
INTEGER mrefr, n
REAL w(n), airden
* output = modified w(n)
* internal
INTEGER i
REAL refrac
EXTERNAL refrac
*_______________________________________________________________________
IF(mrefr .EQ. 1) THEN
DO i = 1, n
w(i) = w(i) * refrac(w(i),airden)
ENDDO
ELSEIF(mrefr .EQ. -1) THEN
DO i = 1, n
w(i) = w(i) / refrac(w(i),airden)
ENDDO
ENDIF
END
*_______________________________________________________________________
*_______________________________________________________________________
FUNCTION refrac(w,airden)
IMPLICIT NONE
* input vacuum wavelength, nm and air density, molec cm-3
REAL w, airden
* output refractive index for standard air
* (dry air at 15 deg. C, 101.325 kPa, 0.03% CO2)
REAL refrac
* internal
REAL sig, dum
* from CRC Handbook, originally from Edlen, B., Metrologia, 2, 71, 1966.
* valid from 200 nm to 2000 nm
* beyond this range, use constant value
sig = 1.E3/w
IF (w .LT. 200.) sig = 1.E3/200.
IF (w .GT. 2000.) sig = 1.E3/2000.
dum = 8342.13 + 2406030./(130. - sig*sig) +
$ 15997./(38.9 - sig*sig)
* adjust to local air density
dum = dum * airden/(2.69e19 * 273.15/288.15)
* index of refraction:
refrac = 1. + 1.E-8 * dum
RETURN
END
*======= END of TUV 5.3.1 =======*