* 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, skipped r116,r117, added pxCH2O *=============================================================================* module module_rxn use module_params IMPLICIT NONE private :: fo3qy2 logical, private :: initialize = .true. integer, parameter :: max_files = 5 integer :: npht, npht_tab type file_specs integer :: nfiles integer :: nskip(max_files) integer :: nread(max_files) real :: xfac(max_files) character(len=132) :: filename(max_files) end type file_specs type xs_qy_tab integer :: tpflag integer :: channel integer :: jndx real :: qyld real, allocatable :: sq(:,:) character(len=50) :: label character(len=50) :: wrf_label type(xs_qy_tab), pointer :: next type(xs_qy_tab), pointer :: last type(file_specs) :: filespec end type xs_qy_tab type(xs_qy_tab), allocatable, target :: xsqy_tab(:) type(xs_qy_tab), pointer :: xsqy_tab_head type(xs_qy_tab), pointer :: xsqy_tab_tail *===================================================================== * the following is fortran2003 compliant code *===================================================================== type xsqy_subs procedure(xsqy), nopass, pointer :: xsqy_sub end type xsqy_subs abstract interface SUBROUTINE xsqy(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) REAL, intent(inout) :: sq(kj,kz,kw) end SUBROUTINE xsqy end interface type(xsqy_subs), allocatable :: the_subs(:) type :: no_zdep contains procedure, nopass :: no_z_dep end type CONTAINS SUBROUTINE no_z_dep(nw,wl,wc,nz,tlev, $ airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= generic routine *-----------------------------------------------------------------------------* * input INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz INTEGER, intent(inout) :: j INTEGER, intent(inout) :: TPFLAG(:) REAL, intent(in) :: wl(:), wc(:) REAL, intent(in) :: airden(:) REAL, intent(in) :: tlev(:) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) CHARACTER(len=50), intent(inout) :: jlabel(:) integer, PARAMETER :: kdata=500 * local REAL :: x1(kdata) REAL :: y1(kdata) INTEGER :: wn REAL :: yg(kw) if( initialize ) then j = j+1 jlabel(j) = xsqy_tab(j)%label CALL readit tpflag(j) = xsqy_tab(j)%tpflag * allocate( xsqy_tab(j)%sq(nz,nw-1) ) allocate( xsqy_tab(j)%sq(nw-1,1) ) if( xsqy_tab(j)%qyld == 1. ) then **** quantum yield assumed to be unity xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) else xsqy_tab(j)%sq(1:nw-1,1) = xsqy_tab(j)%qyld * yg(1:nw-1) endif endif CONTAINS SUBROUTINE readit INTEGER :: ierr integer :: n, fileno character(len=132) :: filename do fileno = 1,xsqy_tab(j)%filespec%nfiles filename = trim( xsqy_tab(j)%filespec%filename(fileno) ) n = xsqy_tab(j)%filespec%nread(fileno) if( xsqy_tab(j)%filespec%nskip(fileno) >= 0 ) then CALL base_read( filespec=trim(filename), $ skip_cnt=xsqy_tab(j)%filespec%nskip(fileno), $ rd_cnt =n,x=x1,y=y1 ) else CALL base_read( filespec=trim(filename), $ rd_cnt=n,x=x1,y=y1 ) endif y1(1:n) = y1(1:n) * xsqy_tab(j)%filespec%xfac(fileno) CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) enddo END SUBROUTINE readit END SUBROUTINE no_z_dep SUBROUTINE set_initialization( status ) LOGICAL, intent(in) :: status initialize = status END SUBROUTINE set_initialization SUBROUTINE rxn_init( nw ) *--------------------------------------------- * initialize wrf-tuv *--------------------------------------------- use module_o3xs, only : rdxs_init use module_io, only : lj, jtag integer, intent(in) :: nw integer :: astat, m, n call set_initialization( status=.true. ) if( .not. allocated( xsqy_tab ) ) then allocate( xsqy_tab(kj),stat=astat ) if( astat /= 0 ) then write(*,*) 'rxn_init: failed to allocate xsqy_tab' stop 'Alloc-error' endif endif if( .not. allocated( the_subs ) ) then allocate( the_subs(kj),stat=astat ) if( astat /= 0 ) then write(*,*) 'rxn_init: failed to allocate xsqy_tab' stop 'Alloc-error' endif endif nullify( xsqy_tab_head ) nullify( xsqy_tab_tail ) xsqy_tab(1:kj)%tpflag = 0 xsqy_tab(1:kj)%channel = 1 xsqy_tab(1:kj)%label = ' ' xsqy_tab(1:kj)%qyld = 1. xsqy_tab(1:kj)%filespec%nfiles = 1 do m = 1,max_files xsqy_tab(1:kj)%filespec%nskip(m) = 0 xsqy_tab(1:kj)%filespec%nread(m) = 0 xsqy_tab(1:kj)%filespec%xfac(m) = 1.e-20 xsqy_tab(1:kj)%filespec%filename(m) = ' ' end do do m = 1,kj nullify( xsqy_tab(m)%next ) nullify( xsqy_tab(m)%last ) the_subs(m)%xsqy_sub => null() end do npht_tab = 2 call setup_sub_calls( the_subs,npht_tab ) do m = 2,npht_tab if( lj(m) ) then do n = 2,npht_tab if( trim(jtag(m)) == trim(xsqy_tab(n)%label) ) then write(*,'(i3,2x,i3,2x,a)') m,n,trim(jtag(m)) exit endif enddo endif enddo call diagnostics call rdxs_init( nw ) call set_initialization( status=.false. ) END SUBROUTINE rxn_init subroutine setup_sub_calls( subr, m ) integer, intent(inout) :: m type(xsqy_subs), intent(inout) :: subr(:) xsqy_tab(m)%label = 'O3 -> O2 + O(1D)' xsqy_tab(m+1)%label = 'O3 -> O2 + O(3P)' xsqy_tab(m)%wrf_label = 'j_o3_a' xsqy_tab(m+1)%wrf_label = 'j_o3_b' xsqy_tab(m:m+1)%jndx = (/ m,m+1 /) xsqy_tab(m+1)%channel = 2 xsqy_tab(m:m+1)%tpflag = 1 subr(m)%xsqy_sub => r01 subr(m+1)%xsqy_sub => r01 m = m + 2 xsqy_tab(m)%label = 'NO2 -> NO + O(3P)' xsqy_tab(m)%wrf_label = 'j_no2' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/YLD/NO2_jpl11.yld' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 25 subr(m)%xsqy_sub => r02 m = m + 1 xsqy_tab(m)%label = 'NO3 -> NO + O2' xsqy_tab(m+1)%label = 'NO3 -> NO2 + O(3P)' xsqy_tab(m)%wrf_label = 'j_no3_a' xsqy_tab(m+1)%wrf_label = 'j_no3_b' xsqy_tab(m)%jndx = m xsqy_tab(m+1)%channel = 2 xsqy_tab(m:m+1)%tpflag = 1 xsqy_tab(m)%filespec%nfiles = 2 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/NO3_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 6 xsqy_tab(m)%filespec%nread(1) = 289 xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/YLD/NO3_jpl2011.qy' xsqy_tab(m)%filespec%nskip(2) = 5 xsqy_tab(m)%filespec%nread(2) = 56 xsqy_tab(m)%filespec%xfac(2) = 1.e-3 subr(m)%xsqy_sub => r03 subr(m+1)%xsqy_sub => r03 m = m + 2 xsqy_tab(m)%label = 'N2O5 -> NO3 + NO + O(3P)' xsqy_tab(m+1)%label = 'N2O5 -> NO3 + NO2' xsqy_tab(m)%wrf_label = 'j_n2o5_a' xsqy_tab(m+1)%wrf_label = 'j_n2o5_b' xsqy_tab(m)%jndx = m xsqy_tab(m+1)%channel = 2 xsqy_tab(m:m+1)%tpflag = 1 xsqy_tab(m)%filespec%nfiles = 2 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/N2O5_jpl11.abs' xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/ABS/N2O5_jpl11.abs' xsqy_tab(m)%filespec%nskip(1:2) = (/ 4,111 /) xsqy_tab(m)%filespec%nread(1:2) = (/ 103,8 /) subr(m)%xsqy_sub => r04 subr(m+1)%xsqy_sub => r04 m = m + 2 xsqy_tab(m)%label = 'HNO2 -> OH + NO' xsqy_tab(m)%wrf_label = 'j_hno2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HONO_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 3 xsqy_tab(m)%filespec%nread(1) = 192 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'HNO3 -> OH + NO2' xsqy_tab(m)%wrf_label = 'j_hno3' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HNO3_burk.abs' xsqy_tab(m)%filespec%nskip(1) = 6 xsqy_tab(m)%filespec%nread(1) = 83 subr(m)%xsqy_sub => r06 m = m + 1 xsqy_tab(m)%label = 'HNO4 -> HO2 + NO2' xsqy_tab(m)%wrf_label = 'j_hno4' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HNO4_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 54 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'H2O2 -> 2 OH' xsqy_tab(m)%wrf_label = 'j_h2o2' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%nfiles = 2 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/H2O2_jpl94.abs' xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/ABS/H2O2_Kahan.abs' xsqy_tab(m)%filespec%nskip(1:2) = (/ -1,0 /) xsqy_tab(m)%filespec%nread(2) = 494 subr(m)%xsqy_sub => r08 m = m + 1 xsqy_tab(m)%label = 'CHBr3 -> Products' xsqy_tab(m)%wrf_label = 'j_chbr3' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CHBr3.jpl97' xsqy_tab(m)%filespec%nskip(1) = 6 xsqy_tab(m)%filespec%nread(1) = 87 subr(m)%xsqy_sub => r09 m = m + 1 xsqy_tab(m)%label = 'CH3CHO -> CH3 + HCO' xsqy_tab(m+1)%label = 'CH3CHO -> CH4 + CO' xsqy_tab(m+2)%label = 'CH3CHO -> CH3CO + H' xsqy_tab(m)%wrf_label = 'j_ch3cho_a' xsqy_tab(m+1)%wrf_label = 'j_ch3cho_b' xsqy_tab(m+2)%wrf_label = 'j_ch3cho_c' xsqy_tab(m)%jndx = m xsqy_tab(m+1:m+2)%channel = (/ 2,3 /) xsqy_tab(m:m+2)%tpflag = (/ 2,0,0 /) xsqy_tab(m)%filespec%nfiles = 2 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/CH3CHO/CH3CHO_jpl11.abs' xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/CH3CHO/CH3CHO_uip.yld' xsqy_tab(m)%filespec%nskip(1:2) = (/ 2,4 /) xsqy_tab(m)%filespec%nread(1:2) = (/ 101,12 /) subr(m)%xsqy_sub => r11 subr(m+1)%xsqy_sub => r11 subr(m+2)%xsqy_sub => r11 m = m + 3 xsqy_tab(m)%label = 'C2H5CHO -> C2H5 + HCO' xsqy_tab(m)%wrf_label = 'j_c2h5cho' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 2 xsqy_tab(m)%filespec%nfiles = 2 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/C2H5CHO/C2H5CHO_iup.abs' xsqy_tab(m)%filespec%filename(2) = $ 'DATAJ1/C2H5CHO/C2H5CHO_iup.yld' xsqy_tab(m)%filespec%nskip(1:2) = 4 xsqy_tab(m)%filespec%nread(1:2) = (/ 106,5 /) subr(m)%xsqy_sub => r12 m = m + 1 xsqy_tab(m)%label = 'CHOCHO -> HCO + HCO' xsqy_tab(m+1)%label = 'CHOCHO -> H2 + 2CO' xsqy_tab(m+2)%label = 'CHOCHO -> CH2O + CO' xsqy_tab(m)%wrf_label = 'j_gly_a' xsqy_tab(m+1)%wrf_label = 'j_gly_b' xsqy_tab(m+2)%wrf_label = 'j_gly_c' xsqy_tab(m)%jndx = m xsqy_tab(m+1:m+2)%channel = (/ 2,3 /) xsqy_tab(m)%filespec%nfiles = 2 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/CHOCHO/glyoxal_jpl11.abs' xsqy_tab(m)%filespec%filename(2) = $ 'DATAJ1/CHOCHO/glyoxal_jpl11.qy' xsqy_tab(m)%filespec%nskip(1:2) = (/ 2,3 /) xsqy_tab(m)%filespec%nread(1:2) = (/ 277,40 /) subr(m)%xsqy_sub => r13 subr(m+1)%xsqy_sub => r13 subr(m+2)%xsqy_sub => r13 m = m + 3 xsqy_tab(m)%label = 'CH3COCHO -> CH3CO + HCO' xsqy_tab(m)%wrf_label = 'j_mgly' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 2 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/CH3COCHO/CH3COCHO_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 294 subr(m)%xsqy_sub => r14 m = m + 1 xsqy_tab(m)%label = 'CH3COCH3 -> CH3CO + CH3' xsqy_tab(m)%wrf_label = 'j_ch3coch3' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 3 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/CH3COCH3/CH3COCH3_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 5 xsqy_tab(m)%filespec%nread(1) = 135 subr(m)%xsqy_sub => r15 m = m + 1 xsqy_tab(m)%label = 'CH3OOH -> CH3O + OH' xsqy_tab(m)%wrf_label = 'j_ch3ooh' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/CH3OOH/CH3OOH_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 40 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CH3ONO2 -> CH3O + NO2' xsqy_tab(m)%wrf_label = 'j_ch3ono2' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/RONO2/CH3ONO2_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 65 subr(m)%xsqy_sub => r17 m = m + 1 xsqy_tab(m)%label = 'CH3CO(OONO2) -> CH3CO(OO) + NO2' xsqy_tab(m+1)%label = 'CH3CO(OONO2) -> CH3CO(O) + NO3' xsqy_tab(m)%wrf_label = 'j_pan_a' xsqy_tab(m+1)%wrf_label = 'j_pan_b' xsqy_tab(m)%jndx = m xsqy_tab(m+1)%channel = 2 xsqy_tab(m:m+1)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/PAN_talukdar.abs' xsqy_tab(m)%filespec%nskip(1) = 14 xsqy_tab(m)%filespec%nread(1) = 78 subr(m)%xsqy_sub => r18 subr(m+1)%xsqy_sub => r18 m = m + 2 xsqy_tab(m)%label = 'CCl2O -> Products' xsqy_tab(m)%wrf_label = 'j_ccl2o' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CCl2O_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CCl4 -> Products' xsqy_tab(m)%wrf_label = 'j_ccl4' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CCl4_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 5 xsqy_tab(m)%filespec%nread(1) = 44 subr(m)%xsqy_sub => r20 m = m + 1 xsqy_tab(m)%label = 'CClFO -> Products' xsqy_tab(m)%wrf_label = 'j_cclfo' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CClFO_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CF2O -> Products' xsqy_tab(m)%wrf_label = 'j_cf2o' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CF2O_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 5 xsqy_tab(m)%filespec%nread(1) = 21 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CF2ClCFCl2 (CFC-113) -> Products' xsqy_tab(m)%wrf_label = 'j_cf2clcfcl2' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CFC-113_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => r23 m = m + 1 xsqy_tab(m)%label = 'CF2ClCF2Cl (CFC-114) -> Products' xsqy_tab(m)%wrf_label = 'j_cf2clcf2cl' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CFC-114_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => r24 m = m + 1 xsqy_tab(m)%label = 'CF3CF2Cl (CFC-115) -> Products' xsqy_tab(m)%wrf_label = 'j_cf3cf2cl' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CFC-115_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CCl3F (CFC-11) -> Products' xsqy_tab(m)%wrf_label = 'j_ccl3f' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CFC-11_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => r26 m = m + 1 xsqy_tab(m)%label = 'CCl2F2 (CFC-12) -> Products' xsqy_tab(m)%wrf_label = 'j_ccl2f2' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CFC-12_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => r27 m = m + 1 xsqy_tab(m)%label = 'CH3Br -> Products' xsqy_tab(m)%wrf_label = 'j_ch3br' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CH3Br_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CH3CCl3 -> Products' xsqy_tab(m)%wrf_label = 'j_ch3ccl3' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CH3CCl3_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => r29 m = m + 1 xsqy_tab(m)%label = 'CH3Cl -> Products' xsqy_tab(m)%wrf_label = 'j_ch3cl' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/CH3Cl_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => r30 m = m + 1 xsqy_tab(m)%label = 'ClOO -> Products' xsqy_tab(m)%wrf_label = 'j_cloo' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/ClOO_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CF3CHCl2 (HCFC-123) -> Products' xsqy_tab(m)%wrf_label = 'j_cf3chcl2' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 subr(m)%xsqy_sub => r32 m = m + 1 xsqy_tab(m)%label = 'CF3CHFCl (HCFC-124) -> Products' xsqy_tab(m)%wrf_label = 'j_cf3chfcl' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 subr(m)%xsqy_sub => r33 m = m + 1 xsqy_tab(m)%label = 'CH3CFCl2 (HCFC-141b) -> Products' xsqy_tab(m)%wrf_label = 'j_ch3cfcl2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/HCFC-141b_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CH3CF2Cl (HCFC-142b) -> Products' xsqy_tab(m)%wrf_label = 'j_ch3cf2cl' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 subr(m)%xsqy_sub => r35 m = m + 1 xsqy_tab(m)%label = 'CF3CF2CHCl2 (HCFC-225ca) -> Products' xsqy_tab(m)%wrf_label = 'j_cf3cf2chcl2' xsqy_tab(m)%jndx = m subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CF2ClCF2CHFCl (HCFC-225cb) -> Products' xsqy_tab(m)%wrf_label = 'j_cf2clcf2chfcl' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/HCFC-225cb_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CHClF2 (HCFC-22) -> Products' xsqy_tab(m)%wrf_label = 'j_chclf2' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/HCFC-22_jpl94.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => r38 m = m + 1 xsqy_tab(m)%label = 'HO2 -> OH + O' xsqy_tab(m)%wrf_label = 'j_ho2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/HO2_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 10 xsqy_tab(m)%filespec%nread(1) = 15 subr(m)%xsqy_sub => r39 m = m + 1 xsqy_tab(m)%label = 'CF2Br2 (Halon-1202) -> Products' xsqy_tab(m)%wrf_label = 'j_cf2bf2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/Halon-1202_jpl97.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CF2BrCl (Halon-1211) -> Products' xsqy_tab(m)%wrf_label = 'j_cf2brcl' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/Halon-1211_jpl97.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CF3Br (Halon-1301) -> Products' xsqy_tab(m)%wrf_label = 'j_cf3br' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/Halon-1301_jpl97.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CF2BrCF2Br (Halon-2402) -> Products' xsqy_tab(m)%wrf_label = 'j_cf2brcf2br' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/Halon-2402_jpl97.abs' xsqy_tab(m)%filespec%nskip(1) = -1 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'N2O -> N2 + O(1D)' xsqy_tab(m)%wrf_label = 'j_n2o' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 subr(m)%xsqy_sub => r44 m = m + 1 xsqy_tab(m)%label = 'ClONO2 -> Cl + NO3' xsqy_tab(m+1)%label = 'ClONO2 -> ClO + NO2' xsqy_tab(m)%wrf_label = 'j_clono2_a' xsqy_tab(m+1)%wrf_label = 'j_clono2_b' xsqy_tab(m)%jndx = m xsqy_tab(m+1)%channel = 2 xsqy_tab(m:m+1)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClONO2_jpl97.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 119 subr(m)%xsqy_sub => r45 subr(m+1)%xsqy_sub => r45 m = m + 2 xsqy_tab(m)%label = 'BrONO2 -> BrO + NO2' xsqy_tab(m+1)%label = 'BrONO2 -> Br + NO3' xsqy_tab(m)%wrf_label = 'j_brono2_a' xsqy_tab(m+1)%wrf_label = 'j_brono2_b' xsqy_tab(m)%jndx = m xsqy_tab(m+1)%channel = 2 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrONO2_jpl03.abs' xsqy_tab(m)%filespec%nskip(1) = 13 xsqy_tab(m)%filespec%nread(1) = 61 subr(m)%xsqy_sub => r46 subr(m+1)%xsqy_sub => r46 m = m + 2 xsqy_tab(m)%label = 'Cl2 -> Cl + Cl' xsqy_tab(m)%wrf_label = 'j_cl2' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 subr(m)%xsqy_sub => r47 m = m + 1 xsqy_tab(m)%label = 'HOCH2CHO -> CH2OH + HCO' xsqy_tab(m+1)%label = 'HOCH2CHO -> CH3OH + CO' xsqy_tab(m+2)%label = 'HOCH2CHO -> CH2CHO + OH' xsqy_tab(m)%wrf_label = 'j_glyald_a' xsqy_tab(m+1)%wrf_label = 'j_glyald_b' xsqy_tab(m+2)%wrf_label = 'j_glyald_c' xsqy_tab(m)%jndx = m xsqy_tab(m+1:m+2)%channel = (/ 2,3 /) xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/CH2OHCHO/glycolaldehyde_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 63 subr(m)%xsqy_sub => r101 subr(m+1)%xsqy_sub => r101 subr(m+2)%xsqy_sub => r101 m = m + 3 xsqy_tab(m)%label = 'CH3COCOCH3 -> Products' xsqy_tab(m)%wrf_label = 'j_biacetyl' xsqy_tab(m)%qyld = .158 xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/CH3COCOCH3/biacetyl_horowitz.abs' xsqy_tab(m)%filespec%nskip(1) = 8 xsqy_tab(m)%filespec%nread(1) = 287 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CH3COCH=CH2 -> Products' xsqy_tab(m)%wrf_label = 'j_mvk' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 2 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/MVK_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 146 subr(m)%xsqy_sub => r103 m = m + 1 xsqy_tab(m)%label = 'CH2=C(CH3)CHO -> Products' xsqy_tab(m)%wrf_label = 'j_macr' xsqy_tab(m)%qyld = .01 xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/Methacrolein_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 7 xsqy_tab(m)%filespec%nread(1) = 146 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CH3COCO(OH) -> Products' xsqy_tab(m)%wrf_label = 'j_ch3cocooh' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/CH3COCOOH/pyruvic_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 139 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CH3CH2ONO2 -> CH3CH2O + NO2' xsqy_tab(m)%wrf_label = 'j_ch3ch2ono2' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/RONO2/RONO2_talukdar.abs' xsqy_tab(m)%filespec%nskip(1) = 10 xsqy_tab(m)%filespec%nread(1) = 63 subr(m)%xsqy_sub => r106 m = m + 1 xsqy_tab(m)%label = 'CH3CHONO2CH3 -> CH3CHOCH3 + NO2' xsqy_tab(m)%wrf_label = 'j_ch3chono2ch3' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/RONO2/RONO2_talukdar.abs' xsqy_tab(m)%filespec%nskip(1) = 10 xsqy_tab(m)%filespec%nread(1) = 63 subr(m)%xsqy_sub => r107 m = m + 1 xsqy_tab(m)%label = 'CH2(OH)CH2(ONO2) -> CH2(OH)CH2(O.) + NO2' xsqy_tab(m)%wrf_label = 'j_ch2ohch2ono2' xsqy_tab(m)%jndx = m subr(m)%xsqy_sub => r108 m = m + 1 xsqy_tab(m)%label = 'CH3COCH2(ONO2) -> CH3COCH2(O.) + NO2' xsqy_tab(m)%wrf_label = 'j_ch3coch2ono2' xsqy_tab(m)%jndx = m subr(m)%xsqy_sub => r109 m = m + 1 xsqy_tab(m)%label = 'C(CH3)3(ONO2) -> C(CH3)3(O.) + NO2' xsqy_tab(m)%wrf_label = 'j_bnit1' xsqy_tab(m)%jndx = m subr(m)%xsqy_sub => r110 m = m + 1 xsqy_tab(m)%label = 'ClOOCl -> Cl + ClOO' xsqy_tab(m)%wrf_label = 'j_cloocl' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/ClOOCl_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 3 xsqy_tab(m)%filespec%nread(1) = 111 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CH2(OH)COCH3 -> CH3CO + CH2(OH)' xsqy_tab(m+1)%label = 'CH2(OH)COCH3 -> CH2(OH)CO + CH3' xsqy_tab(m)%wrf_label = 'j_hyac_a' xsqy_tab(m+1)%wrf_label = 'j_hyac_b' xsqy_tab(m)%jndx = m xsqy_tab(m+1)%channel = 2 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/Hydroxyacetone_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 96 subr(m)%xsqy_sub => r112 subr(m+1)%xsqy_sub => r112 m = m + 2 xsqy_tab(m)%label = 'HOBr -> OH + Br' xsqy_tab(m)%wrf_label = 'j_hobr' xsqy_tab(m)%jndx = m subr(m)%xsqy_sub => r113 m = m + 1 xsqy_tab(m)%label = 'BrO -> Br + O' xsqy_tab(m)%wrf_label = 'j_bro' xsqy_tab(m)%jndx = m subr(m)%xsqy_sub => r114 m = m + 1 xsqy_tab(m)%label = 'Br2 -> Br + Br' xsqy_tab(m)%wrf_label = 'j_br2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Br2.abs' xsqy_tab(m)%filespec%nskip(1) = 6 xsqy_tab(m)%filespec%nread(1) = 29 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'NO3-(aq) -> NO2(aq) + O-' xsqy_tab(m+1)%label = 'NO3-(aq) -> NO2-(aq) + O(3P)' xsqy_tab(m+2)%label = 'NO3-(aq) with qy=1' xsqy_tab(m)%wrf_label = 'j_no3_aq_a' xsqy_tab(m+1)%wrf_label = 'j_no3_aq_b' xsqy_tab(m+2)%wrf_label = 'j_no3_aq_c' xsqy_tab(m)%jndx = m xsqy_tab(m+1:m+2)%channel = (/ 2,3 /) xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/NO3-_CA03.abs' xsqy_tab(m)%filespec%nskip(1) = 7 xsqy_tab(m)%filespec%nread(1) = 43 subr(m)%xsqy_sub => r118 subr(m+1)%xsqy_sub => r118 subr(m+2)%xsqy_sub => r118 m = m + 3 xsqy_tab(m)%label = 'CH3COCH2CH3 -> CH3CO + CH2CH3' xsqy_tab(m)%wrf_label = 'j_mek' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 2 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Martinez.abs' xsqy_tab(m)%filespec%nskip(1) = 4 xsqy_tab(m)%filespec%nread(1) = 96 subr(m)%xsqy_sub => r119 m = m + 1 xsqy_tab(m)%label = 'CH3CH2CO(OONO2) -> CH3CH2CO(OO) + NO2' xsqy_tab(m+1)%label = 'CH3CH2CO(OONO2) -> CH3CH2CO(O) + NO3' xsqy_tab(m)%wrf_label = 'j_ppn_a' xsqy_tab(m+1)%wrf_label = 'j_ppn_b' xsqy_tab(m:m+1)%tpflag = 1 xsqy_tab(m)%jndx = m xsqy_tab(m+1)%channel = 2 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/PPN_Harwood.txt' xsqy_tab(m)%filespec%nskip(1) = 10 xsqy_tab(m)%filespec%nread(1) = 66 subr(m)%xsqy_sub => r120 subr(m+1)%xsqy_sub => r120 m = m + 2 xsqy_tab(m)%label = 'HOCH2OOH -> HOCH2O. + OH' xsqy_tab(m)%wrf_label = 'j_hoch2ooh' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HOCH2OOH_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 3 xsqy_tab(m)%filespec%nread(1) = 32 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CH2=CHCHO -> Products' xsqy_tab(m)%wrf_label = 'j_acrol' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 2 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Acrolein.txt' xsqy_tab(m)%filespec%nskip(1) = 6 xsqy_tab(m)%filespec%nread(1) = 55 subr(m)%xsqy_sub => r122 m = m + 1 xsqy_tab(m)%label = 'CH3CO(OOH) -> Products' xsqy_tab(m)%wrf_label = 'j_ch3coooh' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Peracetic_acid.txt' xsqy_tab(m)%filespec%nskip(1) = 6 xsqy_tab(m)%filespec%nread(1) = 66 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = '(CH3)2NNO -> Products' xsqy_tab(m)%wrf_label = 'j_amine' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/dmna.abs' xsqy_tab(m)%filespec%nskip(1) = 5 xsqy_tab(m)%filespec%nread(1) = 132 xsqy_tab(m)%filespec%xfac(1) = 1.e-19 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'ClO -> Cl + O(1D)' xsqy_tab(m+1)%label = 'ClO -> Cl + O(3P)' xsqy_tab(m)%wrf_label = 'j_clo_a' xsqy_tab(m+1)%wrf_label = 'j_clo_b' xsqy_tab(m)%jndx = m xsqy_tab(m+1)%channel = 2 xsqy_tab(m:m+1)%tpflag = 1 subr(m)%xsqy_sub => r125 subr(m+1)%xsqy_sub => r125 m = m + 2 xsqy_tab(m)%label = 'ClNO2 -> Cl + NO2' xsqy_tab(m)%wrf_label = 'j_clno2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClNO2.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 26 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'BrNO -> Br + NO' xsqy_tab(m)%wrf_label = 'j_brno' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrNO.abs' xsqy_tab(m)%filespec%nskip(1) = 3 xsqy_tab(m)%filespec%nread(1) = 27 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'BrNO2 -> Br + NO2' xsqy_tab(m)%wrf_label = 'j_brno2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrNO2.abs' xsqy_tab(m)%filespec%nskip(1) = 6 xsqy_tab(m)%filespec%nread(1) = 54 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'BrONO -> Br + NO2' xsqy_tab(m+1)%label = 'BrONO -> BrO + NO' xsqy_tab(m)%wrf_label = 'j_brono_a' xsqy_tab(m+1)%wrf_label = 'j_brono_b' xsqy_tab(m)%jndx = m xsqy_tab(m+1)%channel = 2 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrONO.abs' xsqy_tab(m)%filespec%nskip(1) = 8 xsqy_tab(m)%filespec%nread(1) = 32 subr(m)%xsqy_sub => r129 subr(m+1)%xsqy_sub => r129 m = m + 2 xsqy_tab(m)%label = 'HOCl -> HO + Cl' xsqy_tab(m)%wrf_label = 'j_hocl' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HOCl.abs' xsqy_tab(m)%filespec%nskip(1) = 7 xsqy_tab(m)%filespec%nread(1) = 111 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'NOCl -> NO + Cl' xsqy_tab(m)%wrf_label = 'j_nocl' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%nfiles = 2 xsqy_tab(m)%filespec%filename(1:2) = 'DATAJ1/ABS/NOCl.abs' xsqy_tab(m)%filespec%nskip(1:2) = (/ 7,88 /) xsqy_tab(m)%filespec%nread(1:2) = (/ 80,61 /) subr(m)%xsqy_sub => r131 m = m + 1 xsqy_tab(m)%label = 'OClO -> Products' xsqy_tab(m)%wrf_label = 'j_oclo' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%nfiles = 3 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/OClO.abs' xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/ABS/OClO.abs' xsqy_tab(m)%filespec%filename(3) = 'DATAJ1/ABS/OClO.abs' xsqy_tab(m)%filespec%nskip(1:3) = (/ 6,1075,2142 /) xsqy_tab(m)%filespec%nread(1:3) = (/ 1068,1067,1068 /) subr(m)%xsqy_sub => r132 m = m + 1 xsqy_tab(m)%label = 'BrCl -> Br + Cl' xsqy_tab(m)%wrf_label = 'j_brcl' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrCl.abs' xsqy_tab(m)%filespec%nskip(1) = 9 xsqy_tab(m)%filespec%nread(1) = 81 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CH3(OONO2) -> CH3(OO) + NO2' xsqy_tab(m)%wrf_label = 'j_ch3oono2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3OONO2.abs' xsqy_tab(m)%filespec%nskip(1) = 9 xsqy_tab(m)%filespec%nread(1) = 26 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'C(CH3)3(ONO) -> C(CH3)3(O) + NO' xsqy_tab(m)%wrf_label = 'j_bnit2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/t-butyl-nitrite.abs' xsqy_tab(m)%filespec%nskip(1) = 4 xsqy_tab(m)%filespec%nread(1) = 96 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'ClONO -> Cl + NO2' xsqy_tab(m)%wrf_label = 'j_clono' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClONO_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 3 xsqy_tab(m)%filespec%nread(1) = 34 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'HCl -> H + Cl' xsqy_tab(m)%wrf_label = 'j_hcl' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HCl_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 3 xsqy_tab(m)%filespec%nread(1) = 31 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CH2O -> H + HCO' xsqy_tab(m+1)%label = 'CH2O -> H2 + CO' xsqy_tab(m)%wrf_label = 'j_ch2o_r' xsqy_tab(m+1)%wrf_label = 'j_ch2o_m' xsqy_tab(m)%jndx = m xsqy_tab(m+1)%channel = 2 xsqy_tab(m:m+1)%tpflag = (/ 1,3 /) xsqy_tab(m)%filespec%nfiles = 2 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH2O/CH2O_jpl11.abs' xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/CH2O/CH2O_jpl11.yld' xsqy_tab(m)%filespec%nskip(1:2) = 4 xsqy_tab(m)%filespec%nread(1:2) = (/ 150,112 /) subr(m)%xsqy_sub => pxCH2O subr(m+1)%xsqy_sub => pxCH2O m = m + 2 xsqy_tab(m)%label = 'CH3COOH -> CH3 + COOH' xsqy_tab(m)%wrf_label = 'j_ch3cooh' xsqy_tab(m)%qyld = .55 xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3COOH_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 18 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CH3OCl -> CH3O + Cl' xsqy_tab(m)%wrf_label = 'j_ch3ocl' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3OCl_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 3 xsqy_tab(m)%filespec%nread(1) = 83 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'CHCl3 -> Products' xsqy_tab(m)%wrf_label = 'j_chcl3' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CHCl3_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 3 xsqy_tab(m)%filespec%nread(1) = 39 subr(m)%xsqy_sub => r140 m = m + 1 xsqy_tab(m)%label = 'C2H5ONO2 -> C2H5O + NO2' xsqy_tab(m)%wrf_label = 'j_c2h5ono2' xsqy_tab(m)%jndx = m xsqy_tab(m)%tpflag = 1 xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/RONO2/C2H5ONO2_iup2006.abs' xsqy_tab(m)%filespec%nskip(1) = 4 xsqy_tab(m)%filespec%nread(1) = 32 subr(m)%xsqy_sub => r141 m = m + 1 xsqy_tab(m)%label = 'n-C3H7ONO2 -> C3H7O + NO2' xsqy_tab(m)%wrf_label = 'j_nc3h7ono2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/RONO2/nC3H7ONO2_iup2006.abs' xsqy_tab(m)%filespec%nskip(1) = 3 xsqy_tab(m)%filespec%nread(1) = 32 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = '1-C4H9ONO2 -> 1-C4H9O + NO2' xsqy_tab(m)%wrf_label = 'j_1c4h9ono2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/RONO2/1C4H9ONO2_iup2006.abs' xsqy_tab(m)%filespec%nskip(1) = 3 xsqy_tab(m)%filespec%nread(1) = 32 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = '2-C4H9ONO2 -> 2-C4H9O + NO2' xsqy_tab(m)%wrf_label = 'j_2c4h9ono2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/RONO2/2C4H9ONO2_iup2006.abs' xsqy_tab(m)%filespec%nskip(1) = 3 xsqy_tab(m)%filespec%nread(1) = 15 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'perfluoro 1-iodopropane -> products' xsqy_tab(m)%wrf_label = 'j_perfluoro' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = $ 'DATAJ1/ABS/PF-n-iodopropane.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 16 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'I2 -> I + I' xsqy_tab(m)%wrf_label = 'j_i2' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/YLD/I2.qy' xsqy_tab(m)%filespec%nskip(1) = 4 xsqy_tab(m)%filespec%nread(1) = 12 subr(m)%xsqy_sub => r146 m = m + 1 xsqy_tab(m)%label = 'IO -> I + O' xsqy_tab(m)%wrf_label = 'j_io' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/IO_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 133 subr(m)%xsqy_sub => no_z_dep m = m + 1 xsqy_tab(m)%label = 'IOH -> I + OH' xsqy_tab(m)%wrf_label = 'j_ioh' xsqy_tab(m)%jndx = m xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/IOH_jpl11.abs' xsqy_tab(m)%filespec%nskip(1) = 2 xsqy_tab(m)%filespec%nread(1) = 101 subr(m)%xsqy_sub => no_z_dep end subroutine setup_sub_calls *-----------------------------------------------------------------------------* *= *** ALL the following subroutines have the following arguments *= *** except for the routines: *= rxn_init, base_read, readit, add_pnts_inter2 *= =* *= 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(len=50) ::, string identifier for each photolysis (O)=* *= reaction defined =* *-----------------------------------------------------------------------------* SUBROUTINE r01(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* use module_o3xs, only : rdo3xs * input INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata = 500 INTEGER n1, n2, n3, n4, n5 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 :: xs(nz,nw-1) REAL yg(kw), yg1(kw), yg2(kw), yg3(kw), yg4(kw) REAL :: qy1d(nz) 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 LOGICAL :: is_initial **************************************************************** ************* jlabel(j) = 'O3 -> O2 + O(1D)' ************* jlabel(j) = 'O3 -> O2 + O(3P)' if( initialize ) then j = j + 1 * declare temperature dependence tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) if( xsqy_tab(j)%channel == 1 ) then jlabel(j) = 'O3 -> O2 + O(1D)' elseif( xsqy_tab(j)%channel == 2 ) then jlabel(j) = 'O3 -> O2 + O(3P)' endif endif * 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 is_initial = xsqy_tab(j)%channel == 1 CALL rdo3xs(mabs, nz,tlev,nw,wl, xs, is_initial) ******* quantum yield: * 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 * compute cross sections and yields at different wavelengths, altitudes: DO iw = 1, nw-1 * quantum yields * Matsumi et al. CALL fo3qy2(nz,wc(iw),tlev,qy1d) * compute product if( xsqy_tab(j)%channel == 2 ) then qy1d(1:nz) = (1. - qy1d(1:nz)) endif xsqy_tab(j)%sq(1:nz,iw) = qy1d(1:nz)*xs(1:nz,iw) END DO END SUBROUTINE r01 *=============================================================================* SUBROUTINE r02(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* use module_o3xs, only : no2xs_jpl06a INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays INTEGER, parameter :: kdata = 200 REAL x1(kdata) REAL y1(kdata), y2(kdata) * local REAL, save :: yg1(kw), ydel(kw) REAL :: yg2(kw) REAL :: qy(nz) REAL :: t(nz) REAL :: no2xs(nz,nw-1) INTEGER :: i, iw, n, idum, ierr **************** NO2 photodissociation if( initialize ) then j = j + 1 jlabel(j) = 'NO2 -> NO + O(3P)' CALL readit * declare temperature dependence tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) ydel(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1) endif * 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 CALL no2xs_jpl06a(nz,tlev,nw,wl, no2xs) * quantum yields * myld = 1 NO2_calvert.yld (same as JPL2002) * myld = 2 NO2_jpl11.yld (same as jpl2006) * myld = 2 * from jpl 2011 t(1:nz) = .02*(tlev(1:nz) - 298.) DO iw = 1, nw - 1 qy(1:nz) = yg1(iw) + ydel(iw)*t(1:nz) xsqy_tab(j)%sq(1:nz,iw) = no2xs(1:nz,iw)*max( qy(1:nz),0. ) ENDDO CONTAINS SUBROUTINE readit n = 25 CALL base_read( filespec='DATAJ1/YLD/NO2_jpl11.yld', $ skip_cnt=2,rd_cnt=n,x=x1,y=y1,y1=y2 ) CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r02 *=============================================================================* SUBROUTINE r03(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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) =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays INTEGER, 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) real :: sq_wrk(nz) * local real, parameter :: tfac1 = 1./(230. - 190.) real, parameter :: tfac2 = 1./(298. - 230.) REAL :: qy, qy1, qy2, xsect REAL, save :: yg1(kw) * real, save :: yg1_298(kw), yg1_230(kw), yg1_190(kw) * real, save :: yg2_298(kw), yg2_230(kw), yg2_190(kw) real, save :: yg_298(kw,2), yg_230(kw,2), yg_190(kw,2) real, save :: delabs(kw,2,2) real :: t(nz) INTEGER i, iw, iz, n, idum, chnl INTEGER ierr LOGICAL :: is_init **************** jlabel(j) = 'NO3 -> NO2 + O(3P)' **************** jlabel(j) = 'NO3 -> NO + O2' if( initialize ) then j = j + 1 tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,1:nw-1) ) if( xsqy_tab(j)%channel == 1 ) then jlabel(j) = 'NO3 -> NO + O2' * yields from JPL2011: CALL readit * declare temperature dependence for both channels: delabs(1:nw-1,1,1) = yg_230(1:nw-1,1) - yg_190(1:nw-1,1) delabs(1:nw-1,2,1) = yg_298(1:nw-1,1) - yg_230(1:nw-1,1) delabs(1:nw-1,1,2) = yg_230(1:nw-1,2) - yg_190(1:nw-1,2) delabs(1:nw-1,2,2) = yg_298(1:nw-1,2) - yg_230(1:nw-1,2) elseif( xsqy_tab(j)%channel == 2 ) then jlabel(j) = 'NO3 -> NO2 + O(3P)' endif endif * mabs = 3: JPL11 * mabs = 3 * myld = 2 from JPL-2011 * myld = 2 * compute T-dependent quantum yields chnl = xsqy_tab(j)%channel DO iw = 1, nw-1 xsect = yg1(iw) where(tlev(1:nz) <= 190. ) sq_wrk(1:nz) = yg_190(iw,chnl)*xsect elsewhere(tlev(1:nz) > 190. .and. tlev(1:nz) <= 230. ) t(1:nz) = tfac1*(tlev(1:nz) - 190.)*xsect sq_wrk(1:nz) = yg_190(iw,chnl) + delabs(iw,1,chnl)*t(1:nz) elsewhere(tlev(1:nz) > 230. .and. tlev(1:nz) <= 298. ) t(1:nz) = tfac2*(tlev(1:nz) - 230.)*xsect sq_wrk(1:nz) = yg_230(iw,chnl) + delabs(iw,2,chnl)*t(1:nz) elsewhere(tlev(1:nz) > 298. ) sq_wrk(1:nz) = yg_298(iw,chnl) endwhere xsqy_tab(j)%sq(1:nz,iw) = sq_wrk(1:nz) ENDDO CONTAINS SUBROUTINE readit n = 289 CALL base_read( filespec='DATAJ1/ABS/NO3_jpl11.abs', $ skip_cnt=6,rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n)*1.E-20 CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) n = 56 CALL base_read( filespec='DATAJ1/YLD/NO3_jpl2011.qy', $ skip_cnt=5,rd_cnt=n,x=x,y=q1_298, $ y1=q1_230,y2=q1_190,y3=q2_298, $ y4=q2_230,y5=q2_190 ) q1_298(1:n) = q1_298(1:n)*.001 q1_230(1:n) = q1_230(1:n)*.001 q1_190(1:n) = q1_190(1:n)*.001 q2_298(1:n) = q2_298(1:n)*.001 q2_230(1:n) = q2_230(1:n)*.001 q2_190(1:n) = q2_190(1:n)*.001 CALL add_pnts_inter2(x,q1_298,yg_298,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x,q1_230,yg_230,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x,q1_190,yg_190,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x,q2_298,yg_298(1,2),kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x,q2_230,yg_230(1,2),kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x,q2_190,yg_190(1,2),kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r03 *=============================================================================* SUBROUTINE r04(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 JPL2011: use tabulated values for 300K, correct for =* *= temperature. *= Quantum yield: Analysis of data in JPL94 (->DATAJ1/YLD/N2O5.qy) =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays INTEGER, PARAMETER :: kdata = 200 REAL x1(kdata), x2(kdata) REAL y1(kdata), A(kdata), B(kdata) INTEGER :: n, n1, n2 * local INTEGER i, iz, iw INTEGER ierr REAL xs REAL :: xsqy_wrk(nz,nw-1) REAL, save :: yg1(kw), yg2(kw) REAL :: dum(nz) REAL :: t(nz) **************** N2O5 photodissociation if( initialize ) then j = j + 1 * declare temperature dependence tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) if( xsqy_tab(j)%channel == 1 ) then jlabel(j) = 'N2O5 -> NO3 + NO + O(3P)' CALL readit DO iw = 1,nw-1 xsqy_tab(j)%sq(1:nz,iw) = 0. ENDDO elseif( xsqy_tab(j)%channel == 2 ) then jlabel(j) = 'N2O5 -> NO3 + NO2' endif endif if( xsqy_tab(j)%channel == 2 ) then * temperature dependence only valid for 233 - 295 K. Extend to 300. t(1:nz) = MAX(233.,MIN(tlev(1:nz),300.)) DO iw = 1, nw - 1 * Apply temperature correction to 300K values. Do not use A-coefficients * because they are inconsistent with the values at 300K. * quantum yield = 1 for NO2 + NO3, zero for other channels dum(1:nz) = $ 1000.*yg2(iw)*(300. - t(1:nz))/(300.*t(1:nz)) xsqy_wrk(1:nz,iw) = yg1(iw) * 10.**(dum(1:nz)) xsqy_tab(j)%sq(1:nz,iw) = xsqy_wrk(1:nz,iw) ENDDO endif CONTAINS SUBROUTINE readit * cross section from jpl2011, at 300 K n1 = 103 CALL base_read( filespec='DATAJ1/ABS/N2O5_jpl11.abs', $ skip_cnt=4,rd_cnt=n1,x=x1,y=y1 ) y1(1:n1) = y1(1:n1) * 1.E-20 * read temperature dependence coefficients: n2 = 8 CALL base_read( filespec='DATAJ1/ABS/N2O5_jpl11.abs', $ skip_cnt=111,rd_cnt=n2,x=x2,y=A,y1=B ) CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x2,B,yg2,kdata,n2, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r04 *=============================================================================* SUBROUTINE r06(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER n1 REAL x1(kdata), x2(kdata) REAL y1(kdata), y2(kdata) * local real :: t(nz) REAL, save :: yg1(kw), yg2(kw) INTEGER i, iw INTEGER ierr **************** HNO3 photodissociation if( initialize ) then j = j + 1 jlabel(j) = 'HNO3 -> OH + NO2' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1 ) ) endif * quantum yield = 1 * correct for temperature dependence t(1:nz) = tlev(1:nz) - 298. DO iw = 1, nw - 1 xsqy_tab(j)%sq(1:nz,iw) = yg1(iw) * exp( yg2(iw)*t(1:nz) ) ENDDO CONTAINS SUBROUTINE readit * HNO3 cross section parameters from Burkholder et al. 1993 n1 = 83 CALL base_read( filespec='DATAJ1/ABS/HNO3_burk.abs', $ skip_cnt=6,rd_cnt=n1,x=y1,y=y2 ) x1(1:n1) = (/ (184. + real(i)*2.,i=1,n1) /) y1(1:n1) = y1(1:n1) * 1.e-20 CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, $ nw,wl,jlabel(j),deltax) y2(1:n1) = y2(1:n1) * 1.e-3 CALL add_pnts_inter2(x1,y2,yg2,kdata,n1, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r06 *=============================================================================* SUBROUTINE r08(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=600 REAL x1(kdata) REAL y1(kdata) * local real, parameter :: A0 = 6.4761E+04 real, parameter :: A1 = -9.2170972E+02 real, parameter :: A2 = 4.535649 real, parameter :: A3 = -4.4589016E-03 real, parameter :: A4 = -4.035101E-05 real, parameter :: A5 = 1.6878206E-07 real, parameter :: A6 = -2.652014E-10 real, parameter :: A7 = 1.5534675E-13 real, parameter :: B0 = 6.8123E+03 real, parameter :: B1 = -5.1351E+01 real, parameter :: B2 = 1.1522E-01 real, parameter :: B3 = -3.0493E-05 real, parameter :: B4 = -1.0924E-07 INTEGER i, iw, n, idum INTEGER ierr REAL lambda REAL sumA, sumB REAL :: t(nz) REAL :: chi(nz) REAL, save :: yg(kw) **************** H2O2 photodissociation * cross section from Lin et al. 1978 if( initialize ) then j = j + 1 jlabel(j) = 'H2O2 -> 2 OH' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * quantum yield = 1 t(1:nz) = MIN(MAX(tlev(1:nz),200.),400.) chi(1:nz) = 1./(1. + EXP(-1265./t(1:nz))) 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 xsqy_tab(j)%sq(1:nz,iw) = $ (chi(1:nz) * sumA + (1. - chi(1:nz))*sumB)*1.E-21 ELSE xsqy_tab(j)%sq(1:nz,iw) = yg(iw) ENDIF ENDDO CONTAINS SUBROUTINE readit * cross section from JPL94 (identical to JPL97) * tabulated data up to 260 nm integer :: n1 CALL base_read( filespec='DATAJ1/ABS/H2O2_jpl94.abs', $ rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.E-20 n1 = 494 CALL base_read( filespec='DATAJ1/ABS/H2O2_Kahan.abs', $ skip_cnt=0,rd_cnt=n1,x=x1(n+1:),y=y1(n+1:) ) n = n + n1 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r08 *=============================================================================* SUBROUTINE r09(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=200 INTEGER n1 REAL x1(kdata) REAL y1(kdata) * local REAL, save :: yg(kw) real :: t(nz) INTEGER i, iw, n INTEGER ierr INTEGER iz **************** CHBr3 photodissociation if( initialize ) then j = j + 1 jlabel(j) = 'CHBr3 -> Products' xsqy_tab(j)%jndx = j CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * option: * kopt = 1: cross section from Elliot Atlas, 1997 * kopt = 2: cross section from JPL 1997 * kopt = 2 * quantum yield = 1 t(1:nz) = 273. - tlev(1:nz) DO iw = 1, nw - 1 IF (wc(iw) .GT. 290. .AND. wc(iw) .LT. 340. ) then where( tlev(1:nz) > 210. .AND. tlev(1:nz) < 300. ) xsqy_tab(j)%sq(1:nz,iw) = $ EXP( (.06183 - .000241*wc(iw))*t(1:nz) $ - (2.376 + 0.14757*wc(iw)) ) elsewhere xsqy_tab(j)%sq(1:nz,iw) = yg(iw) endwhere ELSE xsqy_tab(j)%sq(1:nz,iw) = yg(iw) ENDIF ENDDO CONTAINS SUBROUTINE readit * 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)) n1 = 87 CALL base_read( filespec='DATAJ1/ABS/CHBr3.jpl97', $ skip_cnt=6,rd_cnt=n1,x=x1,y=y1 ) y1(1:n1) = y1(1:n1) * 1.e-20 CALL add_pnts_inter2(x1,y1,yg,kdata,n1, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r09 *=============================================================================* SUBROUTINE r11(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=150 INTEGER i, n INTEGER n1, n2 REAL x1(kdata), x2(kdata) REAL y1(kdata), y2(kdata) * local INTEGER m, ierr INTEGER iz, iw INTEGER mabs, myld REAL qy2, qy3 REAL sig REAL dum REAL qy1_n0, qy1_0, x REAL, save :: yg(kw), yg1(kw), yg2(kw), yg3(kw) REAL :: qy1(nz) **************************************************************** ************************* CH3CHO photolysis * 1: CH3 + HCO * 2: CH4 + CO * 3: CH3CO + H if( initialize ) then j = j + 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) if( xsqy_tab(j)%channel == 1 ) then jlabel(j) = 'CH3CHO -> CH3 + HCO' CALL readit tpflag(j) = 2 elseif( xsqy_tab(j)%channel == 2 ) then jlabel(j) = 'CH3CHO -> CH4 + CO' DO iw = 1, nw - 1 xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * yg2(iw) ENDDO elseif( xsqy_tab(j)%channel == 3 ) then jlabel(j) = 'CH3CHO -> CH3CO + H' DO iw = 1, nw - 1 xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * yg3(iw) ENDDO endif endif * 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 * combine: if( xsqy_tab(j)%channel == 1 ) then DO iw = 1, nw - 1 sig = yg(iw) * quantum yields: * input yields at n0 = 1 atm qy1_n0 = yg1(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. - (yg2(iw) + yg3(iw)) * 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 > 0.) then x = qy1_0/qy1_n0 - 1. else x = 0. endif qy1(1:nz) = qy1_n0 $ * (1. + x) / (1. + x * airden(1:nz)/2.465E19) qy1(1:nz) = MIN( 1.,MAX(0.,qy1(1:nz)) ) xsqy_tab(j)%sq(1:nz,iw) = sig * qy1(1:nz) ENDDO endif CONTAINS SUBROUTINE readit real :: dum(kdata) n = 101 CALL base_read( filespec='DATAJ1/CH3CHO/CH3CHO_jpl11.abs', $ skip_cnt=2,rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.e-20 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) * quantum yields n = 12 CALL base_read( filespec='DATAJ1/CH3CHO/CH3CHO_uip.yld', $ skip_cnt=4,rd_cnt=n,x=x1,y=y2,y1=y1 ) CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) yg3(1:nw-1) = 0. END SUBROUTINE readit END SUBROUTINE r11 *=============================================================================* SUBROUTINE r12(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) integer, PARAMETER :: kdata=150 INTEGER i, n INTEGER n1 REAL x1(kdata) REAL y1(kdata) * local REAL, save :: yg(kw), yg1(kw) REAL :: qy1(nz) REAL sig INTEGER ierr INTEGER iw ************************* C2H5CHO photolysis * 1: C2H5 + HCO if( initialize ) then j = j+1 jlabel(j) = 'C2H5CHO -> C2H5 + HCO' CALL readit tpflag(j) = 2 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * 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 * combine: DO iw = 1, nw - 1 * quantum yields: * use Stern-Volmer pressure dependence: IF (yg1(iw) .LT. pzero) THEN xsqy_tab(j)%sq(1:nz,iw) = 0. ELSE qy1(1:nz) = $ 1./(1. + (1./yg1(iw) - 1.)*airden(1:nz)/2.45e19) qy1(1:nz) = MIN(qy1(1:nz),1.) xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * qy1(1:nz) ENDIF ENDDO CONTAINS SUBROUTINE readit n = 106 CALL base_read( filespec='DATAJ1/C2H5CHO/C2H5CHO_iup.abs', $ skip_cnt=4,rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.e-20 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) * quantum yields n = 5 CALL base_read( filespec='DATAJ1/C2H5CHO/C2H5CHO_iup.yld', $ skip_cnt=4,rd_cnt=n,x=x1,y=y1 ) CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r12 *=============================================================================* SUBROUTINE r13(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=500 INTEGER i, n REAL x(kdata), x1(kdata) REAL y1(kdata), y2(kdata), y3(kdata) * local REAL yg(kw), yg1(kw), yg2(kw), yg3(kw) REAL qyI, qyII, qyIII REAL sig INTEGER ierr INTEGER iw ************************* 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 * 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( initialize ) then j = j + 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) if( xsqy_tab(j)%channel == 1 ) then jlabel(j) = 'CHOCHO -> HCO + HCO' CALL readit DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * yg1(iw) ENDDO elseif( xsqy_tab(j)%channel == 2 ) then jlabel(j) = 'CHOCHO -> H2 + 2CO' CALL readit DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * yg2(iw) ENDDO elseif( xsqy_tab(j)%channel == 3 ) then jlabel(j) = 'CHOCHO -> CH2O + CO' CALL readit DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * yg3(iw) ENDDO endif endif CONTAINS SUBROUTINE readit real :: dum(kdata) n = 277 CALL base_read( filespec='DATAJ1/CHOCHO/glyoxal_jpl11.abs', $ skip_cnt=2,rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.e-20 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) * quantum yields n = 40 CALL base_read( filespec='DATAJ1/CHOCHO/glyoxal_jpl11.qy', $ skip_cnt=3,rd_cnt=n,x=x,y=dum,y1=y1,y2=y2,y3=y3 ) CALL add_pnts_inter2(x,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x,y3,yg3,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r13 *=============================================================================* SUBROUTINE r14(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=500 INTEGER i, n INTEGER n1, n2 REAL x1(kdata) REAL y1(kdata) * local REAL, save :: yg(kw) REAL qy REAL sig INTEGER ierr INTEGER iw REAL phi0, kq if( initialize ) then j = j+1 jlabel(j) = 'CH3COCHO -> CH3CO + HCO' CALL readit tpflag(j) = 2 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * 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 * combine: DO iw = 1, nw - 1 sig = yg(iw) * quantum yields: * 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(MAX(0.,phi0),1.) * Pressure correction: quenching coefficient, torr-1 * in air, Koch and Moortgat: kq = 1.36e8 * EXP(-8793./wc(iw)) * in N2, Chen et al: IF(phi0 .GT. 0.) THEN IF (wc(iw) .GE. 380. .AND. wc(iw) .LE. 440.) THEN xsqy_tab(j)%sq(1:nz,iw) = sig * phi0 $ / (phi0 + kq * airden(1:nz) * 760./2.456E19) ELSE xsqy_tab(j)%sq(1:nz,iw) = sig * phi0 ENDIF ELSE xsqy_tab(j)%sq(1:nz,iw) = 0. ENDIF ENDDO CONTAINS SUBROUTINE readit n = 294 CALL base_read( filespec='DATAJ1/CH3COCHO/CH3COCHO_jpl11.abs', $ skip_cnt=2,rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.e-20 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r14 *=============================================================================* SUBROUTINE r15(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) integer, PARAMETER :: kdata=150 INTEGER :: i, n REAL x1(kdata) REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata) * local REAL, save :: yg(kw), yg2(kw), yg3(kw) REAL :: qy(nz) REAL :: sig(nz) REAL :: T(nz) real :: fac(nz) INTEGER ierr INTEGER iw **************** CH3COCH3 photodissociation if( initialize ) then j = j + 1 jlabel(j) = 'CH3COCH3 -> CH3CO + CH3' CALL readit * both T and P tpflag(j) = 3 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * 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 T(1:nz) = MIN(MAX(tlev(1:nz), 235.),298.) DO iw = 1, nw - 1 sig(1:nz) = $ yg(iw) $ *(1. + t(1:nz)*(yg2(iw) + t(1:nz)*yg3(iw))) CALL qyacet(nz, wc(iw), T, airden, fac) xsqy_tab(j)%sq(1:nz,iw) = sig(1:nz)*min(max(0.,fac(1:nz)),1.) ENDDO CONTAINS SUBROUTINE readit n = 135 CALL base_read( filespec='DATAJ1/CH3COCH3/CH3COCH3_jpl11.abs', $ skip_cnt=5,rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3,y3=y4 ) y1(1:n) = y1(1:n) * 1.e-20 y2(1:n) = y2(1:n) * 1.e-3 y3(1:n) = y3(1:n) * 1.e-5 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y3,yg3,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r15 *=============================================================================* SUBROUTINE r17(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) integer, PARAMETER :: kdata = 100 INTEGER i, n INTEGER iw INTEGER n1, n2 REAL x1(kdata), x2(kdata) REAL y1(kdata), y2(kdata) * local REAL, save :: yg(kw), yg1(kw) REAL qy REAL sig INTEGER ierr **************** CH3ONO2 photodissociation if( initialize ) then j = j + 1 jlabel(j) = 'CH3ONO2 -> CH3O + NO2' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * 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 * quantum yield = 1 x2(1:nz) = tlev(1:nz) - 298. DO iw = 1, nw - 1 xsqy_tab(j)%sq(1:nz,iw) = $ yg(iw) * exp( yg1(iw) * x2(1:nz) ) ENDDO CONTAINS SUBROUTINE readit n = 65 CALL base_read( filespec='DATAJ1/RONO2/CH3ONO2_jpl11.abs', $ skip_cnt=2,rd_cnt=n,x=x1,y=y1,y1=y2 ) y1(1:n) = y1(1:n) * 1.e-20 y2(1:n) = y2(1:n) * 1.e-3 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y2,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r17 *=============================================================================* SUBROUTINE r18(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER iw INTEGER n REAL x1(kdata), x2(kdata) REAL y1(kdata), y2(kdata) * local * quantum yield: * from JPL 2011 values for >300 nm. * real, parameter :: qyNO2 = .7 * real, parameter :: qyNO3 = .3 real, parameter :: qyld(2) = (/ .7,.3 /) INTEGER :: ierr, chnl REAL, save :: yg(kw), yg2(kw) REAL :: sig(nz) **************** PAN photodissociation if( initialize ) then j = j + 1 tpflag(j) = 1 if( xsqy_tab(j)%channel == 1 ) then jlabel(j) = 'CH3CO(OONO2) -> CH3CO(OO) + NO2' CALL readit elseif( xsqy_tab(j)%channel == 2 ) then jlabel(j) = 'CH3CO(OONO2) -> CH3CO(O) + NO3' endif allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif chnl = xsqy_tab(j)%channel x2(1:nz) = tlev(1:nz) - 298. DO iw = 1, nw-1 sig(1:nz) = yg(iw) * EXP( yg2(iw)*x2(1:nz) ) xsqy_tab(j)%sq(1:nz,iw) = qyld(chnl) * sig(1:nz) ENDDO CONTAINS SUBROUTINE readit * cross section from * Talukdar et al., 1995, J.Geophys.Res. 100/D7, 14163-14174 n = 78 CALL base_read( filespec='DATAJ1/RONO2/PAN_talukdar.abs', $ skip_cnt=14,rd_cnt=n,x=x1,y=y1,y1=y2 ) y1(1:n) = y1(1:n) * 1.E-20 y2(1:n) = y2(1:n) * 1.E-3 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r18 *=============================================================================* SUBROUTINE r20(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 REAL x1(kdata) REAL y1(kdata) * local real, parameter :: b0 = 1.0739 real, parameter :: b1 = -1.6275e-2 real, parameter :: b2 = 8.8141e-5 real, parameter :: b3 = -1.9811e-7 real, parameter :: b4 = 1.5022e-10 REAL yg(kw) REAL, save :: qy INTEGER i, iw, n, idum INTEGER ierr INTEGER iz INTEGER mabs REAL tcoeff, sig REAL w1 REAL :: temp(nz) ************************************************************** ************* CCl4 photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CCl4 -> Products' tpflag(j) = 1 CALL readit allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * mabs = 1: jpl 1997 recommendation * mabs = 2: jpl 2011 recommendation, with T dependence * mabs = 2 * compute temperature correction factors: *** quantum yield assumed to be unity temp(1:nz) = min(max(tlev(1:nz),210.),300.) temp(1:nz) = temp(1:nz) - 295. 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) tcoeff = b0 + w1*(b1 + w1*(b2 + w1*(b3 + w1*b4))) ENDIF xsqy_tab(j)%sq(1:nz,iw) = yg(iw) $ * 10.**(tcoeff*temp(1:nz)) ENDDO CONTAINS SUBROUTINE readit *** cross sections from JPL97 recommendation (identical to 94 data) n = 44 CALL base_read( filespec='DATAJ1/ABS/CCl4_jpl11.abs', $ skip_cnt=5,rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.E-20 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r20 *=============================================================================* SUBROUTINE r23(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER n1, n2 REAL x1(kdata), x2(kdata) REAL y1(kdata), y2(kdata) * local real, parameter :: tfac1 = 1./(295. - 210.) REAL, save :: yg2(kw), ydel(kw) REAL :: yg1(kw) REAL qy REAL :: t(nz) REAL :: slope(nz) INTEGER i, iw, n, idum INTEGER iz INTEGER ierr ************************************************************** ************* CF2ClCFCl2 (CFC-113) photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CF2ClCFCl2 (CFC-113) -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) ydel(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1) endif *** quantum yield assumed to be unity t(1:nz) = MAX(210.,MIN(tlev(1:nz),295.)) slope(1:nz) = (t(1:nz) - 210.)*tfac1 DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel(iw) ENDDO CONTAINS SUBROUTINE readit *** cross sections from JPL97 recommendation (identical to 94 recommendation) CALL base_read( filespec='DATAJ1/ABS/CFC-113_jpl94.abs', $ rd_cnt=n,x=x1,y=y1,y1=y2 ) y1(1:n) = y1(1:n) * 1.E-20 y2(1:n) = y2(1:n) * 1.E-20 ** sigma @ 295 K CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) * sigma @ 210 K CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r23 *=============================================================================* SUBROUTINE r24(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER n1, n2 REAL x1(kdata), x2(kdata) REAL y1(kdata), y2(kdata) * local real, parameter :: tfac1 = 1./(295. - 210.) REAL, save :: yg2(kw), ydel(kw) REAL :: yg1(kw) REAL qy REAL :: t(nz) REAL :: slope(nz) INTEGER i, iw, n, idum INTEGER ierr INTEGER iz ************************************************************** ************* CF2ClCF2Cl (CFC-114) photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CF2ClCF2Cl (CFC-114) -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) ydel(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1) endif *** quantum yield assumed to be unity t(1:nz) = MAX(210.,MIN(tlev(1:nz),295.)) slope(1:nz) = (t(1:nz) - 210.)*tfac1 DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel(iw) ENDDO CONTAINS SUBROUTINE readit **** cross sections from JPL97 recommendation (identical to 94 recommendation) CALL base_read( filespec='DATAJ1/ABS/CFC-114_jpl94.abs', $ rd_cnt=n,x=x1,y=y1,y1=y2 ) y1(1:n) = y1(1:n) * 1.E-20 y2(1:n) = y2(1:n) * 1.E-20 ** sigma @ 295 K CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) * sigma @ 210 K CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r24 *=============================================================================* SUBROUTINE r26(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= PURPOSE: =* *= Provide product (cross section) x (quantum yield) for CFC-11 photolysis =* *= CCl3F + hv -> Products =* *= Cross section: from JPL 97 recommendation =* *= Quantum yield: assumed to be unity =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) integer, PARAMETER :: kdata=100 REAL x1(kdata) REAL y1(kdata) * local REAL, save :: yg(kw) REAL qy REAL :: t(nz) INTEGER i, iw, n, idum INTEGER ierr INTEGER iz ************************************************************** ************* CCl3F (CFC-11) photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CCl3F (CFC-11) -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif **** quantum yield assumed to be unity t(1:nz) = 1.E-04 * (tlev(1:nz) - 298.) DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * EXP((wc(iw)-184.9) * t(1:nz)) ENDDO CONTAINS SUBROUTINE readit **** cross sections from JPL97 recommendation (identical to 94 recommendation) CALL base_read( filespec='DATAJ1/ABS/CFC-11_jpl94.abs', $ rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.E-20 ** sigma @ 298 K CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r26 *=============================================================================* SUBROUTINE r27(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= PURPOSE: =* *= Provide product (cross section) x (quantum yield) for CFC-12 photolysis:=* *= CCl2F2 + hv -> Products =* *= Cross section: from JPL 97 recommendation =* *= Quantum yield: assumed to be unity =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 REAL x1(kdata) REAL y1(kdata) * local REAL, save :: yg(kw) REAL qy REAL :: t(nz) INTEGER i, iw, n, idum INTEGER ierr INTEGER iz ************************************************************** ************* CCl2F2 (CFC-12) photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CCl2F2 (CFC-12) -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif **** quantum yield assumed to be unity t(1:nz) = 1.E-04 * (tlev(1:nz) - 298.) DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * EXP((wc(iw)-184.9) * t(1:nz)) ENDDO CONTAINS SUBROUTINE readit **** cross sections from JPL97 recommendation (identical to 94 recommendation) CALL base_read( filespec='DATAJ1/ABS/CFC-12_jpl94.abs', $ rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.E-20 ** sigma @ 298 K CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r27 *=============================================================================* SUBROUTINE r29(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER n1, n2, n3 REAL x1(kdata), x2(kdata), x3(kdata) REAL y1(kdata), y2(kdata), y3(kdata) * local real, parameter :: tfac1 = 1./(250. - 210.) real, parameter :: tfac2 = 1./(295. - 250.) REAL, save :: yg2(kw), yg3(kw), ydel1(kw), ydel2(kw) REAL :: yg1(kw) REAL qy REAL :: t(nz) REAL :: slope(nz) INTEGER i, iw, n, idum INTEGER ierr INTEGER iz ************************************************************** ************* CH3CCl3 photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CH3CCl3 -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) ydel2(1:nw-1) = yg2(1:nw-1) - yg3(1:nw-1) ydel1(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1) endif **** quantum yield assumed to be unity t(1:nz) = MIN(295.,MAX(tlev(1:nz),210.)) DO iw = 1, nw-1 where( t(1:nz) <= 250. ) slope(1:nz) = (t(1:nz) - 210.)*tfac1 xsqy_tab(j)%sq(1:nz,iw) = yg3(iw) + slope(1:nz)*ydel2(iw) elsewhere slope(1:nz) = (t(1:nz) - 250.)*tfac2 xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel1(iw) endwhere ENDDO CONTAINS SUBROUTINE readit **** cross sections from JPL97 recommendation (identical to 94 recommendation) CALL base_read( filespec='DATAJ1/ABS/CH3CCl3_jpl94.abs', $ rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3 ) y1(1:n) = y1(1:n) * 1.E-20 y2(1:n) = y2(1:n) * 1.E-20 y3(1:n) = y3(1:n) * 1.E-20 ** sigma @ 295 K CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) ** sigma @ 250 K CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) ** sigma @ 210 K CALL add_pnts_inter2(x1,y3,yg3,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r29 *=============================================================================* SUBROUTINE r30(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER n1, n2, n3 REAL x1(kdata), x2(kdata), x3(kdata) REAL y1(kdata), y2(kdata), y3(kdata) * local real, parameter :: tfac1 = 1./(279. - 255.) real, parameter :: tfac2 = 1./(296. - 279.) REAL, save :: yg2(kw), yg3(kw) REAL, save :: ydel1(kw), ydel2(kw) REAL :: yg1(kw) REAL qy REAL :: t(nz) REAL :: slope(nz) INTEGER i, iw, n, idum INTEGER ierr INTEGER iz ************************************************************** ************* CH3Cl photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CH3Cl -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) ydel2(1:nw-1) = yg2(1:nw-1) - yg3(1:nw-1) ydel1(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1) endif **** quantum yield assumed to be unity t(1:nz) = MAX(255.,MIN(tlev(1:nz),296.)) DO iw = 1, nw-1 where( t(1:nz) <= 279. ) slope(1:nz) = (t(1:nz) - 255.)*tfac1 xsqy_tab(j)%sq(1:nz,iw) = yg3(iw) + slope(1:nz)*ydel2(iw) elsewhere slope(1:nz) = (t(1:nz) - 279.)*tfac2 xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel1(iw) endwhere ENDDO CONTAINS SUBROUTINE readit **** cross sections from JPL97 recommendation (identical to 94 recommendation) CALL base_read( filespec='DATAJ1/ABS/CH3Cl_jpl94.abs', $ rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3 ) y1(1:n) = y1(1:n) * 1.E-20 y2(1:n) = y2(1:n) * 1.E-20 y3(1:n) = y3(1:n) * 1.E-20 ** sigma @ 296 K CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) ** sigma @ 279 K CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) ** sigma @ 255 K CALL add_pnts_inter2(x1,y3,yg3,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r30 *=============================================================================* SUBROUTINE r32(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * local real, parameter :: LBar = 206.214 INTEGER i, iw, idum INTEGER iz, k REAL qy REAL lambda REAL, save :: TBar REAL :: t(nz) REAL :: sum(nz) REAL, save :: coeff(4,3) CHARACTER*120 inline ************************************************************** ************* CF3CHCl2 (HCFC-123) photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CF3CHCl2 (HCFC-123) -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif **** quantum yield assumed to be unity DO iw = 1, nw-1 lambda = wc(iw) * use parameterization only up to 220 nm, as the error bars associated with * the measurements beyond 220 nm are very large (Orlando, priv.comm.) IF (lambda .GE. 190. .AND. lambda .LE. 220.) THEN t(1:nz) = MIN(295.,MAX(tlev(1:nz),203.)) - TBar sum(1:nz) = 0. DO i = 1, 4 sum(1:nz) = $ (coeff(i,1) + t(1:nz)*(coeff(i,2) + t(1:nz)*coeff(i,3))) * $ (lambda-LBar)**(i-1) + sum(1:nz) ENDDO xsqy_tab(j)%sq(1:nz,iw) = EXP(sum(1:nz)) ELSE xsqy_tab(j)%sq(1:nz,iw) = 0. ENDIF ENDDO CONTAINS SUBROUTINE readit **** cross section from Orlando et al., 1991 OPEN(kin,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD') READ(kin,*) idum DO i = 1, idum-2 READ(kin,*) ENDDO READ(kin,100) inline 100 FORMAT(A120) READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3) READ(kin,*) i,(coeff(i,k),k=1,3) READ(kin,*) i,(coeff(i,k),k=1,3) READ(kin,*) i,(coeff(i,k),k=1,3) CLOSE(kin) END SUBROUTINE readit END SUBROUTINE r32 *=============================================================================* SUBROUTINE r33(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * local real, parameter :: LBar = 206.214 INTEGER i, iw, n, idum INTEGER iz, k REAL qy REAL lambda REAL, save :: TBar REAL :: t(nz) REAL :: sum(nz) REAL, save :: coeff(4,3) CHARACTER*120 inline ************************************************************** ************* CF3CHFCl (HCFC-124) photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CF3CHFCl (HCFC-124) -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif **** quantum yield assumed to be unity DO iw = 1, nw-1 lambda = wc(iw) IF (lambda .GE. 190. .AND. lambda .LE. 230.) THEN t(1:nz) = MIN(295.,MAX(tlev(1:nz),203.)) - TBar sum(1:nz) = 0. DO i = 1, 4 sum(1:nz) = $ (coeff(i,1) + t(1:nz)*(coeff(i,2) + t(1:nz)*coeff(i,3))) * $ (lambda-LBar)**(i-1) + sum(1:nz) ENDDO xsqy_tab(j)%sq(1:nz,iw) = EXP(sum(1:nz)) ELSE xsqy_tab(j)%sq(1:nz,iw) = 0. ENDIF ENDDO CONTAINS SUBROUTINE readit **** cross section from Orlando et al., 1991 OPEN(kin,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD') READ(kin,*) idum idum = idum+5 DO i = 1, idum-2 READ(kin,*) ENDDO READ(kin,100) inline 100 FORMAT(A120) READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3) READ(kin,*) i,(coeff(i,k),k=1,3) READ(kin,*) i,(coeff(i,k),k=1,3) READ(kin,*) i,(coeff(i,k),k=1,3) CLOSE(kin) END SUBROUTINE readit END SUBROUTINE r33 *=============================================================================* SUBROUTINE r35(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * local real, parameter :: LBar = 206.214 INTEGER i, iw, n, idum INTEGER ierr INTEGER iz, k REAL qy REAL lambda REAL, save :: Tbar REAL :: t(nz) REAL :: sum(nz) REAL, save :: coeff(4,3) CHARACTER*80 inline ************************************************************** ************* CH3CF2Cl (HCFC-142b) photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CH3CF2Cl (HCFC-142b) -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif **** quantum yield assumed to be unity DO iw = 1, nw-1 lambda = wc(iw) IF (lambda .GE. 190. .AND. lambda .LE. 230.) THEN t(1:nz) = MIN(295.,MAX(tlev(1:nz),203.)) - TBar sum(1:nz) = 0. DO i = 1, 4 sum(1:nz) = $ (coeff(i,1) + t(1:nz)*(coeff(i,2) + t(1:nz)*coeff(i,3))) * $ (lambda-LBar)**(i-1) + sum(1:nz) ENDDO * offeset exponent by 40 (exp(-40.) = 4.248e-18) to prevent exp. underflow errors * on some machines. xsqy_tab(j)%sq(1:nz,iw) = 4.248e-18 * EXP(sum(1:nz) + 40.) ELSE xsqy_tab(j)%sq(1:nz,iw) = 0. ENDIF ENDDO CONTAINS SUBROUTINE readit **** cross section from Orlando et al., 1991 OPEN(kin,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD') READ(kin,*) idum idum = idum+10 DO i = 1, idum-2 READ(kin,*) ENDDO READ(kin,100) inline 100 FORMAT(A80) READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3) READ(kin,*) i,(coeff(i,k),k=1,3) READ(kin,*) i,(coeff(i,k),k=1,3) READ(kin,*) i,(coeff(i,k),k=1,3) CLOSE(kin) END SUBROUTINE readit END SUBROUTINE r35 *=============================================================================* SUBROUTINE r38(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, 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, parameter :: tfac1 = 1./(230. - 210.) real, parameter :: tfac2 = 1./(250. - 230.) real, parameter :: tfac3 = 1./(270. - 250.) real, parameter :: tfac4 = 1./(295. - 270.) REAL qy REAL, save :: yg2(kw), yg3(kw), yg4(kw), yg5(kw) REAL :: yg1(kw) REAL, save :: ydel1(kw), ydel2(kw), ydel3(kw), ydel4(kw) REAL :: t(nz), t1(nz), t2(nz), t3(nz), t4(nz) REAL :: slope(nz) INTEGER i, iw, n, idum INTEGER ierr INTEGER iz ************************************************************** ************* CHClF2 (HCFC-22) photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CHClF2 (HCFC-22) -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) ydel4(1:nw-1) = $ yg4(1:nw-1) - yg5(1:nw-1) ydel3(1:nw-1) = $ yg3(1:nw-1) - yg4(1:nw-1) ydel2(1:nw-1) = $ yg2(1:nw-1) - yg3(1:nw-1) ydel1(1:nw-1) = $ yg1(1:nw-1) - yg1(1:nw-1) endif **** quantum yield assumed to be unity t(1:nz) = MIN(295.,MAX(tlev(1:nz),210.)) t1(1:nz) = (t(1:nz) - 210.)*tfac1 t2(1:nz) = (t(1:nz) - 230.)*tfac1 t3(1:nz) = (t(1:nz) - 250.)*tfac1 t4(1:nz) = (t(1:nz) - 270.)*tfac1 DO iw = 1, nw-1 where( t(1:nz) <= 230. ) xsqy_tab(j)%sq(1:nz,iw) = yg5(iw) + t1(1:nz)*ydel4(iw) elsewhere( t(1:nz) > 230. .and. t(1:nz) <= 250. ) xsqy_tab(j)%sq(1:nz,iw) = yg4(iw) + t2(1:nz)*ydel3(iw) elsewhere( t(1:nz) > 250. .and. t(1:nz) <= 270. ) xsqy_tab(j)%sq(1:nz,iw) = yg3(iw) + t3(1:nz)*ydel2(iw) elsewhere xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + t4(1:nz)*ydel1(iw) endwhere ENDDO CONTAINS SUBROUTINE readit **** cross sections from JPL97 recommendation (identical to 94 recommendation) CALL base_read( filespec='DATAJ1/ABS/HCFC-22_jpl94.abs', $ rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3,y3=y4,y4=y5 ) y1(1:n) = y1(1:n) * 1.E-20 y2(1:n) = y2(1:n) * 1.E-20 y3(1:n) = y3(1:n) * 1.E-20 y4(1:n) = y4(1:n) * 1.E-20 y5(1:n) = y5(1:n) * 1.E-20 ** sigma @ 295 K CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) ** sigma @ 270 K CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) ** sigma @ 250 K CALL add_pnts_inter2(x1,y3,yg3,kdata,n, $ nw,wl,jlabel(j),deltax) ** sigma @ 230 K CALL add_pnts_inter2(x1,y4,yg4,kdata,n, $ nw,wl,jlabel(j),deltax) ** sigma @ 210 K CALL add_pnts_inter2(x1,y5,yg5,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r38 *=============================================================================* SUBROUTINE r39(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 REAL x1(kdata) REAL y1(kdata) * local real, parameter :: tfac1 = 1./(248. - 193.) real, parameter :: xfac1 = 1./15. REAL :: yg(kw) REAL qy INTEGER i, iw, n, idum INTEGER ierr INTEGER iz ************************************************************** ************* HO2 photodissociation if( initialize ) then j = j+1 jlabel(j) = 'HO2 -> OH + O' CALL readit allocate( xsqy_tab(j)%sq(nz,nw-1) ) **** 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.)*tfac1 qy = (1. + (wc(iw) - 193.)*14.*tfac1)*xfac1 qy = MAX(qy,0.) ENDIF xsqy_tab(j)%sq(1:nz,iw) = qy * yg(iw) ENDDO endif CONTAINS SUBROUTINE readit **** cross sections from JPL11 recommendation n = 15 CALL base_read( filespec='DATAJ1/ABS/HO2_jpl11.abs', $ skip_cnt=10,rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.E-20 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r39 *=============================================================================* SUBROUTINE r44(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * local real, parameter :: A0 = 68.21023 real, parameter :: A1 = -4.071805 real, parameter :: A2 = 4.301146E-02 real, parameter :: A3 = -1.777846E-04 real, parameter :: A4 = 2.520672E-07 real, parameter :: B0 = 123.4014 real, parameter :: B1 = -2.116255 real, parameter :: B2 = 1.111572E-02 real, parameter :: B3 = -1.881058E-05 INTEGER iw, iz REAL qy REAL a, b, c REAL lambda REAL :: t(nz) REAL :: bt(nz) ************************************************************** ************* N2O photodissociation if( initialize ) then j = j+1 jlabel(j) = 'N2O -> N2 + O(1D)' tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif **** cross sections according to JPL97 recommendation (identical to 94 rec.) **** see file DATAJ1/ABS/N2O_jpl94.abs for detail **** 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 t(1:nz) = MAX(194.,MIN(tlev(1:nz),320.)) DO iw = 1, nw-1 lambda = wc(iw) IF (lambda .GE. 173. .AND. lambda .LE. 240.) THEN A = (((A4*lambda+A3)*lambda+A2)*lambda+A1)*lambda+A0 B = (((B3*lambda+B2)*lambda+B1)*lambda+B0) BT(1:nz) = (t(1:nz) - 300.)*EXP(B) xsqy_tab(j)%sq(1:nz,iw) = EXP(A+BT(1:nz)) ELSE xsqy_tab(j)%sq(1:nz,iw) = 0. ENDIF ENDDO END SUBROUTINE r44 *=============================================================================* SUBROUTINE r45(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= PURPOSE: =* *= Provide product (cross section) x (quantum yield) for ClONO2 photolysis: =* *= ClONO2 + hv -> Products =* *= =* *= Cross section: JPL 97 recommendation =* *= Quantum yield: JPL 97 recommendation =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=150 REAL x1(kdata) REAL y1(kdata),y2(kdata),y3(kdata) * local REAL qy1, qy2 REAL :: xs(nz) real :: t(nz) REAL, save :: yg1(kw), yg2(kw), yg3(kw) INTEGER i, iw, n, idum, chnl INTEGER ierr INTEGER iz ************* ClONO2 photodissociation if( initialize ) then j = j + 1 if( xsqy_tab(j)%channel == 1 ) then jlabel(j) = 'ClONO2 -> Cl + NO3' CALL readit elseif( xsqy_tab(j)%channel == 2 ) then jlabel(j) = 'ClONO2 -> ClO + NO2' endif tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif t(1:nz) = tlev(1:nz) - 296. chnl = xsqy_tab(j)%channel 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 IF( chnl == 2 ) then qy1 = 1.0 - qy1 ENDIF * compute T-dependent cross section xs(1:nz) = yg1(iw) $ *(1. + t(1:nz) $ *(yg2(iw) + t(1:nz)*yg3(iw))) xsqy_tab(j)%sq(1:nz,iw) = qy1 * xs(1:nz) ENDDO CONTAINS SUBROUTINE readit *** cross sections from JPL97 recommendation. Same in JPL-2011. n = 119 CALL base_read( filespec='DATAJ1/ABS/ClONO2_jpl97.abs', $ skip_cnt=2,rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3 ) y1(1:n) = y1(1:n) * 1.E-20 CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y3,yg3,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r45 *=============================================================================* SUBROUTINE r46(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= PURPOSE: =* *= Provide product (cross section) x (quantum yield) for BrONO2 photolysis: =* *= BrONO2 + hv -> Products =* *= =* *= Cross section: JPL 03 recommendation =* *= Quantum yield: JPL 03 recommendation =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 REAL x1(kdata) REAL y1(kdata) INTEGER n1, n2, n3 * local REAL, parameter :: qyld(2) = (/ .15,.85 /) REAL :: yg1(kw) INTEGER i, iw, n, idum INTEGER ierr INTEGER iz, chnl ************* BrONO2 photodissociation if( initialize ) then j = j + 1 chnl = xsqy_tab(j)%channel allocate( xsqy_tab(j)%sq(nz,nw-1) ) if( chnl == 1 ) then jlabel(j) = 'BrONO2 -> BrO + NO2' CALL readit elseif( chnl == 2 ) then jlabel(j) = 'BrONO2 -> Br + NO3' CALL readit endif DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = qyld(chnl) * yg1(iw) ENDDO endif CONTAINS SUBROUTINE readit *** cross sections from JPL03 recommendation n = 61 CALL base_read( filespec='DATAJ1/ABS/BrONO2_jpl03.abs', $ skip_cnt=13,rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.E-20 CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r46 *=============================================================================* SUBROUTINE r47(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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) =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * local real :: ex1(nz), ex2(nz) real :: alpha(kz) INTEGER iz, iw real :: aa, bb, bb2, sig ************* CL2 photodissociation if( initialize ) then j = j+1 jlabel(j) = 'Cl2 -> Cl + Cl' tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * mabs = 1: Finlayson-Pitts and Pitts * mabs = 2: JPL2011 formula DO iz = 1, nz aa = 402.7/tlev(iz) bb = exp(aa) bb2 = bb*bb * alpha(iz) = (bb - 1./bb) / (bb + 1./bb) alpha(iz) = (bb2 - 1.)/(bb2 + 1.) ENDDO *** quantum yield = 1 (Calvert and Pitts, 1966) DO iw = 1, nw-1 ex1(1:nz) = $ 27.3 * exp(-99.0 * alpha(1:nz) * (log(329.5/wc(iw)))**2) ex2(1:nz) = $ 0.932 * exp(-91.5 * alpha(1:nz) * (log(406.5/wc(iw)))**2) * sig = 1.e-20 * alpha(iz)**0.5 * (ex1 + ex2) xsqy_tab(j)%sq(1:nz,iw) = $ 1.e-20 * sqrt(alpha(1:nz)) * (ex1(1:nz) + ex2(1:nz)) ENDDO END SUBROUTINE r47 *=============================================================================* SUBROUTINE r101(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= PURPOSE: =* *= Provide the product (cross section) x (quantum yield) for CH2(OH)CHO =* *= (glycolaldehye, hydroxy acetaldehyde) photolysis: =* *= CH2(OH)CHO + hv -> Products =* *= =* *= Quantum yield about 50% =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER i, n REAL x(kdata), y(kdata) * local real, parameter :: qyld(3) = (/ .83, .10, .07 /) REAL :: yg(kw) REAL qy INTEGER ierr INTEGER iw INTEGER chnl ************************* CH2(OH)CHO photolysis * 1: CH2(OH)CHO * mabs = 2 if( initialize ) then j = j + 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) chnl = xsqy_tab(j)%channel if( chnl == 1 ) then jlabel(j) = 'HOCH2CHO -> CH2OH + HCO' CALL readit elseif( chnl == 2 ) then jlabel(j) = 'HOCH2CHO -> CH3OH + CO' CALL readit elseif( chnl == 3 ) then jlabel(j) = 'HOCH2CHO -> CH2CHO + OH' CALL readit endif DO iw = 1, nw - 1 xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * qyld(chnl) ENDDO endif CONTAINS SUBROUTINE readit n = 63 CALL base_read( $ filespec='DATAJ1/CH2OHCHO/glycolaldehyde_jpl11.abs', $ skip_cnt=2,rd_cnt=n,x=x,y=y ) y(1:n) = y(1:n) * 1.e-20 CALL add_pnts_inter2(x,y,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r101 *=============================================================================* SUBROUTINE r103(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= PURPOSE: =* *= Provide the product (cross section) x (quantum yield) for CH3COCHCH2 =* *= Methyl vinyl ketone photolysis: =* *= CH3COCH=CH2 + 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=150 INTEGER i, n REAL x(kdata), y(kdata) * local REAL, save :: yg(kw) REAL :: qy(nz) INTEGER ierr INTEGER iw INTEGER mabs ************************* CH3COCHCH2 photolysis if( initialize ) then j = j+1 jlabel(j) = 'CH3COCH=CH2 -> Products' CALL readit tpflag(j) = 2 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * mabs = 1: Schneider and moortgat * mabs = 2: jpl 2011 * mabs = 2 * 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 qy(1:nz) = exp(-0.055*(wc(iw) - 308.)) $ / (5.5 + 9.2e-19*airden(1:nz)) qy(1:nz) = min(qy(1:nz), 1.) xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * qy(1:nz) ENDDO CONTAINS SUBROUTINE readit n = 146 CALL base_read( filespec='DATAJ1/ABS/MVK_jpl11.abs', $ skip_cnt=2,rd_cnt=n,x=x,y=y ) y(1:n) = y(1:n) * 1.e-20 CALL add_pnts_inter2(x,y,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r103 *=============================================================================* SUBROUTINE r106(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER i, n1, n2 REAL x1(kdata), y1(kdata) REAL x2(kdata), y2(kdata) * local INTEGER ierr INTEGER iw REAL dum REAL qy, sig REAL, save :: yg1(kw), yg2(kw) real :: t(nz) ************************* CH3CH2ONO2 photolysis if( initialize ) then j = j+1 jlabel(j) = 'CH3CH2ONO2 -> CH3CH2O + NO2' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * quantum yield = 1 t(1:nz) = tlev(1:nz) - 298. DO iw = 1, nw - 1 xsqy_tab(j)%sq(1:nz,iw) = $ yg1(iw)*exp(yg2(iw)*t(1:nz)) ENDDO CONTAINS SUBROUTINE readit integer :: n real :: wrk(kdata) n = 63 CALL base_read( filespec='DATAJ1/RONO2/RONO2_talukdar.abs', $ skip_cnt=10,rd_cnt=n,x=x1,y=wrk,y1=wrk, $ y2=y1,y3=y2,y4=wrk,y5=wrk ) x2(1:n) = x1(1:n) n1 = count( y1(1:n) > 0. ) if( n1 > 0 ) then wrk(1:n1) = pack( y1(1:n),mask=y1(1:n) > 0. ) y1(1:n1) = wrk(1:n1) * 1.e-20 wrk(1:n1) = pack( x1(1:n),mask=y1(1:n) > 0. ) x1(1:n1) = wrk(1:n1) CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, $ nw,wl,jlabel(j),deltax) else yg1(:nw) = 0. endif n2 = count( y2(1:n) > 0. ) if( n2 > 0 ) then wrk(1:n2) = pack( y2(1:n),mask=y2(1:n) > 0. ) y2(1:n2) = wrk(1:n2) * 1.e-3 wrk(1:n2) = pack( x2(1:n),mask=y2(1:n) > 0. ) x2(1:n2) = wrk(1:n2) 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 else yg2(:nw) = 0. endif END SUBROUTINE readit END SUBROUTINE r106 *=============================================================================* SUBROUTINE r107(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER i, n1, n2 REAL x1(kdata), y1(kdata) REAL x2(kdata), y2(kdata) * local INTEGER ierr INTEGER iw REAL dum REAL qy, sig REAL, save :: yg1(kw), yg2(kw) real :: t(nz) ************************* CH3CHONO2CH3 photolysis if( initialize ) then j = j+1 jlabel(j) = 'CH3CHONO2CH3 -> CH3CHOCH3 + NO2' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * quantum yield = 1 t(1:nz) = tlev(1:nz) - 298. DO iw = 1, nw - 1 xsqy_tab(j)%sq(1:nz,iw) = $ yg1(iw)*exp(yg2(iw)*t(1:nz)) ENDDO CONTAINS SUBROUTINE readit integer :: n real :: wrk(kdata) n = 63 CALL base_read( filespec='DATAJ1/RONO2/RONO2_talukdar.abs', $ skip_cnt=10,rd_cnt=n,x=x1,y=wrk, $ y1=wrk,y2=wrk,y3=wrk,y4=y1,y5=y2 ) x2(1:n) = x1(1:n) n1 = count( y1(1:n) > 0. ) if( n1 > 0 ) then wrk(1:n1) = pack( y1(1:n),mask=y1(1:n) > 0. ) y1(1:n1) = wrk(1:n1) * 1.e-20 wrk(1:n1) = pack( x1(1:n),mask=y1(1:n) > 0. ) x1(1:n1) = wrk(1:n1) CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, $ nw,wl,jlabel(j),deltax) else yg1(:nw) = 0. endif n2 = count( y2(1:n) > 0. ) if( n2 > 0 ) then wrk(1:n2) = pack( y2(1:n),mask=y2(1:n) > 0. ) y2(1:n2) = wrk(1:n2) * 1.e-3 wrk(1:n2) = pack( x2(1:n),mask=y2(1:n) > 0. ) x2(1:n2) = wrk(1:n2) 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 else yg2(:nw) = 0. endif END SUBROUTINE readit END SUBROUTINE r107 *=============================================================================* SUBROUTINE r108(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * local * coefficients from Roberts and Fajer 1989, over 270-306 nm real, parameter ::a = -2.359E-3 real, parameter ::b = 1.2478 real, parameter ::c = -210.4 REAL qy, sig INTEGER iw, i ************************* CH2(OH)CH2(ONO2) photolysis if( initialize ) then j = j+1 jlabel(j) = 'CH2(OH)CH2(ONO2) -> CH2(OH)CH2(O.) + NO2' allocate( xsqy_tab(j)%sq(nz,nw-1) ) * quantum yield = 1 DO iw = 1, nw - 1 IF (wc(iw) .GE. 270. .AND. wc(iw) .LE. 306.) THEN xsqy_tab(j)%sq(1:nz,iw) = EXP(c + wc(iw)*(b + wc(iw)*a)) ELSE xsqy_tab(j)%sq(1:nz,iw) = 0. ENDIF ENDDO endif END SUBROUTINE r108 *=============================================================================* SUBROUTINE r109(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * local * coefficients from Roberts and Fajer 1989, over 284-335 nm real, parameter :: a = -1.365E-3 real, parameter :: b = 0.7834 real, parameter :: c = -156.8 REAL qy, sig INTEGER iw, i ************************* CH3COCH2(ONO2) photolysis if( initialize ) then j = j+1 jlabel(j) = 'CH3COCH2(ONO2) -> CH3COCH2(O.) + NO2' allocate( xsqy_tab(j)%sq(nz,nw-1) ) * quantum yield = 1 DO iw = 1, nw - 1 IF (wc(iw) .GE. 284. .AND. wc(iw) .LE. 335.) THEN xsqy_tab(j)%sq(1:nz,iw) = EXP(c + wc(iw)*(b + wc(iw)*a)) ELSE xsqy_tab(j)%sq(1:nz,iw) = 0. ENDIF ENDDO endif END SUBROUTINE r109 *=============================================================================* SUBROUTINE r110(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * local * coefficients from Roberts and Fajer 1989, over 270-330 nm real, parameter ::a = -0.993E-3 real, parameter ::b = 0.5307 real, parameter ::c = -115.5 REAL qy, sig INTEGER iw, i ************************* C(CH3)3(ONO2) photolysis if( initialize ) then j = j+1 jlabel(j) = 'C(CH3)3(ONO2) -> C(CH3)3(O.) + NO2' allocate( xsqy_tab(j)%sq(nz,nw-1) ) * quantum yield = 1 DO iw = 1, nw - 1 IF (wc(iw) .GE. 270. .AND. wc(iw) .LE. 330.) THEN xsqy_tab(j)%sq(1:nz,iw) = EXP(c + wc(iw)*(b + wc(iw)*a)) ELSE xsqy_tab(j)%sq(1:nz,iw) = 0. ENDIF ENDDO endif END SUBROUTINE r110 *=============================================================================* SUBROUTINE r112(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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)=* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER i, n REAL x(kdata), y(kdata) * local REAL, parameter :: qy = .325 REAL :: yg(kw) INTEGER ierr INTEGER iw ************************* CH2(OH)COCH3 photolysis * from Orlando et al. 1999 if( initialize ) then j = j + 1 if( xsqy_tab(j)%channel == 1 ) then jlabel(j) = 'CH2(OH)COCH3 -> CH3CO + CH2(OH)' CALL readit elseif( xsqy_tab(j)%channel == 2 ) then jlabel(j) = 'CH2(OH)COCH3 -> CH2(OH)CO + CH3' CALL readit endif allocate( xsqy_tab(j)%sq(nz,nw-1) ) * mabs = 1: from Orlando et al. 1999 * mabs = 2: from jpl 2011 * mabs = 2 * Total quantum yield = 0.65, fromm Orlando et al. Assume equal for each of * the two channels DO iw = 1, nw - 1 xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * qy ENDDO endif CONTAINS SUBROUTINE readit n = 96 CALL base_read( filespec='DATAJ1/ABS/Hydroxyacetone_jpl11.abs', $ skip_cnt=2,rd_cnt=n,x=x,y=y ) y(1:n) = y(1:n) * 1.e-20 CALL add_pnts_inter2(x,y,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r112 *=============================================================================* SUBROUTINE r113(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays * local REAL qy, sig REAL :: xfac1 INTEGER iw ************************* HOBr photolysis * from JPL2003 if( initialize ) then j = j+1 jlabel(j) = 'HOBr -> OH + Br' tpflag(j) = 0 allocate( xsqy_tab(j)%sq(nz,nw-1) ) DO iw = 1, nw - 1 IF(wc(iw) .LT. 250. .OR. wc(iw) .GT. 550.) then xsqy_tab(j)%sq(1:nz,iw) = 0. ELSE xfac1 = 1./wc(iw) sig = $ 24.77 * EXP( -109.80*(LOG(284.01*xfac1))**2 ) + $ 12.22 * exp( -93.63*(LOG(350.57*xfac1))**2 ) + $ 2.283 * exp(- 242.40*(LOG(457.38*xfac1))**2 ) xsqy_tab(j)%sq(1:nz,iw) = sig * 1.e-20 ENDIF ENDDO endif END SUBROUTINE r113 *=============================================================================* SUBROUTINE r114(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) INTEGER n, i REAL x(20), y(20) * local INTEGER iw REAL qy, yg(kw), dum ************************* HOBr photolysis * from JPL2003 if( initialize ) then j = j+1 jlabel(j) = 'BrO -> Br + O' tpflag(j) = 0 allocate( xsqy_tab(j)%sq(nz,nw-1) ) OPEN(UNIT=kin,FILE='DATAJ1/ABS/BrO.jpl03', $ STATUS='old') DO i = 1, 14 READ(kin,*) ENDDO n = 15 DO i = 1, n READ(kin,*) x(i), dum, y(i) ENDDO CLOSE(kin) y(1:n) = y(1:n) * 1.e-20 n = n + 1 x(n) = dum * use bin-to-bin interpolation CALL inter4(nw,wl,yg,n,x,y,1) DO iw = 1, nw - 1 xsqy_tab(j)%sq(1:nz,iw) = yg(iw) ENDDO endif END SUBROUTINE r114 *=============================================================================* SUBROUTINE r118(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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) =* *= Chu & Anastasio, J. Phys. Chem. A, 107, 9594-9602 (2003) =* *= 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) =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=50 REAL x1(kdata),x2(kdata) REAL y1(kdata),y2(kdata) ! y1 = 20'C, y2 = -20'C * local REAL, parameter :: qy2 = 1.1e-3 REAL, parameter :: qy3 = 1. REAL, save :: yg2(kw) REAL :: qy1(nz) INTEGER i, iw, n, n1, n2, idum, ierr, iz integer mabs *** NO3-(aq) quantum yields * O- (OH and NO2) production * chu and anastasio qy is T dependent: * mabs = 2 if( initialize ) then j = j + 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) if( xsqy_tab(j)%channel == 1 ) then jlabel(j) = 'NO3-(aq) -> NO2(aq) + O-' CALL readit tpflag(j) = 1 elseif( xsqy_tab(j)%channel == 2 ) then jlabel(j) = 'NO3-(aq) -> NO2-(aq) + O(3P)' DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = qy2*yg2(iw) ENDDO elseif( xsqy_tab(j)%channel == 3 ) then jlabel(j) = 'NO3-(aq) with qy=1' DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = qy3*yg2(iw) ENDDO endif endif if( xsqy_tab(j)%channel == 1 ) then qy1(1:nz) = exp(-2400./tlev(1:nz) + 3.6) ! Chu & Anastasio, 2003 DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = qy1(1:nz)*yg2(iw) ENDDO endif CONTAINS SUBROUTINE readit *** NO3-(aq) cross sections from Chu and Anastasio 2003: * convert from molar abs log10 to cm2 per molec real :: wrk(kdata) n = 43 CALL base_read( filespec='DATAJ1/ABS/NO3-_CA03.abs', $ skip_cnt=7,rd_cnt=n,x=x1,y=y1,y1=wrk, $ y2=wrk,y3=wrk,y4=wrk ) y1(1:n) = y1(1:n) * 3.82e-21 CALL add_pnts_inter2(x1,y1,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r118 *=============================================================================* *=============================================================================* SUBROUTINE r119(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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)=* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER i, n REAL x(kdata), y(kdata) * local REAL, save :: yg(kw) REAL :: ptorr(nz) REAL :: qy(nz) INTEGER ierr INTEGER iw ************************* CH3COCH2CH3 photolysis if( initialize ) then j = j+1 jlabel(j) = 'CH3COCH2CH3 -> CH3CO + CH2CH3' CALL readit tpflag(j) = 2 allocate( xsqy_tab(j)%sq(nz,nw-1) ) 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 ptorr(1:nz) = 760.*airden(1:nz)/2.69e19 qy(1:nz) = min( 1./(0.96 + 2.22E-3*ptorr(1:nz)),1. ) DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * qy(1:nz) ENDDO CONTAINS SUBROUTINE readit real :: wrk(kdata) n = 96 CALL base_read( filespec='DATAJ1/ABS/Martinez.abs', $ skip_cnt=4,rd_cnt=n,x=x,y=wrk,y1=y, $ y2=wrk,y3=wrk ) y(1:n) = y(1:n) * 1.e-20 CALL add_pnts_inter2(x,y,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r119 *=============================================================================* SUBROUTINE r120(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER iw INTEGER i, n INTEGER n2 REAL x1(kdata), x2(kdata) REAL y1(kdata), y2(kdata) * local real, parameter :: qyld(2) = (/ 0.61,0.39 /) INTEGER ierr, chnl REAL, save :: yg(kw), yg2(kw) real :: t(nz) REAL :: sig(nz) **************** PPN photodissociation * quantum yields from Harwood et al., at 308 nm if( initialize ) then j = j + 1 chnl = xsqy_tab(j)%channel if( chnl == 1 ) then jlabel(j) = 'CH3CH2CO(OONO2) -> CH3CH2CO(OO) + NO2' CALL readit elseif( chnl == 2 ) then jlabel(j) = 'CH3CH2CO(OONO2) -> CH3CH2CO(O) + NO3' endif tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif chnl = xsqy_tab(j)%channel t(1:nz) = tlev(1:nz) - 298. DO iw = 1, nw-1 sig(1:nz) = yg(iw) * EXP(yg2(iw)*t(1:nz)) xsqy_tab(j)%sq(1:nz,iw) = qyld(chnl) * sig(1:nz) ENDDO CONTAINS SUBROUTINE readit * cross section from * JPL 2011 (originally from Harwood et al. 2003) n = 66 CALL base_read( filespec='DATAJ1/ABS/PPN_Harwood.txt', $ skip_cnt=10,rd_cnt=n,x=x1,y=y1,y1=y2 ) y1(1:n) = y1(1:n) * 1.E-20 y2(1:n) = y2(1:n) * 1E-3 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r120 *=============================================================================* SUBROUTINE r122(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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. =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=100 INTEGER iw INTEGER i, n INTEGER n2 REAL x1(kdata), x2(kdata) REAL y1(kdata), y2(kdata) * local REAL, save :: yg(kw) real :: qy(nz), qym1(nz) REAL sig INTEGER ierr **************** acrolein photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CH2=CHCHO -> Products' CALL readit tpflag(j) = 2 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * quantum yields are pressure dependent between air number densities * of 8e17 and 2.6e19, Gardner et al.: DO iw = 1, nw-1 where( airden(1:nz) > 2.6e19 ) qy(1:nz) = 0.004 elsewhere( airden(1:nz) > 8.e17 .and. airden(1:nz) <= 2.6e19 ) qym1(1:nz) = 0.086 + 1.613e-17 * airden(1:nz) qy(1:nz) = 0.004 + 1./qym1(1:nz) elsewhere( airden(1:nz) <= 8.e17 ) qym1(1:nz) = 0.086 + 1.613e-17 * 8.e17 qy(1:nz) = 0.004 + 1./qym1(1:nz) endwhere xsqy_tab(j)%sq(1:nz,iw) = qy(1:nz) * yg(iw) ENDDO CONTAINS SUBROUTINE readit * cross section from * JPL 2006 (originally from Magneron et al.) n = 55 CALL base_read( filespec='DATAJ1/ABS/Acrolein.txt', $ skip_cnt=6,rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.E-20 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r122 *=============================================================================* SUBROUTINE r125(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=500 INTEGER iw INTEGER i, n REAL x1(kdata) REAL y1(kdata) INTEGER ierr * local REAL :: yg(kw) REAL qy1, qy2 real, save :: tmp(12) real, save :: ygt(kw,12) real x(kdata), y(kdata,12) real tx, xdum integer m, nn, ii real yy INTEGER m1, m2 **************** ClO photodissociation if( initialize ) then j = j + 1 if( xsqy_tab(j)%channel == 1 ) then jlabel(j) = 'ClO -> Cl + O(1D)' CALL readit tmp(1) = 180. tmp(2:12) = (/ (190. + 10.*real(m-1),m=2,12) /) elseif( xsqy_tab(j)%channel == 2 ) then jlabel(j) = 'ClO -> Cl + O(3P)' endif tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif DO i = 1, nz tx = tlev(i) * locate temperature indices for interpolation: m1 = 1 + INT(.1*(tx - 190.)) m1 = MIN(MAX(1 ,m1),11) 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 if( xsqy_tab(j)%channel == 1 ) then xsqy_tab(j)%sq(i,iw) = qy1 * yy elseif( xsqy_tab(j)%channel == 2 ) then xsqy_tab(j)%sq(i,iw) = qy2 * yy endif ENDDO ENDDO CONTAINS SUBROUTINE readit * 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 September 2009. OPEN(UNIT=kin,FILE='DATAJ1/ABS/ClO_spectrum.prn',STATUS='OLD') DO i = 1, 2 READ(kin,*) ENDDO nn = 453 DO ii = 1, nn i = nn - ii + 1 READ(kin,*) xdum, x(i), xdum, (y(i,m), m = 1, 12) ENDDO CLOSE(kin) x1(1:nn) = x(1:nn) DO m = 1, 12 y1(1:nn) = y(1:nn,m) CALL add_pnts_inter2(x1,y1,yg,kdata,nn, $ nw,wl,jlabel(j),deltax) ygt(1:nw-1,m) = yg(1:nw-1) ENDDO END SUBROUTINE readit END SUBROUTINE r125 *=============================================================================* SUBROUTINE r129(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=50 INTEGER iw INTEGER i, n REAL x1(kdata) REAL y1(kdata) INTEGER ierr, chnl * local real, parameter :: qyld(2) = 0.5 * real, parameter :: qy1 = 0.5 * real, parameter :: qy2 = 0.5 REAL yg(kw) ******************** BrONO photodissociation if( initialize ) then j = j + 1 chnl = xsqy_tab(j)%channel if( chnl == 1 ) then jlabel(j) = 'BrONO -> Br + NO2' CALL readit elseif( chnl == 2 ) then jlabel(j) = 'BrONO -> BrO + NO' CALL readit endif allocate( xsqy_tab(j)%sq(nz,nw-1) ) DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = qyld(chnl) * yg(iw) ENDDO endif CONTAINS SUBROUTINE readit * cross section from * IUPAC (vol III) 2007 n = 32 CALL base_read( filespec='DATAJ1/ABS/BrONO.abs', $ skip_cnt=8,rd_cnt=n,x=x1,y=y1 ) CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r129 ******************************************************************* SUBROUTINE r131(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= PURPOSE: =* *= Provide product (cross section) x (quantum yield) for *= NOCl -> NO + Cl =* *= Cross section: from IUPAC (vol.3) =* *= Quantum yield: Assumed to be 1 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, 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, save :: yg223(kw),yg243(kw),yg263(kw), $ yg298(kw),yg323(kw), yg343(kw) REAL qy, sig ******************** NOCl photodissociation if( initialize ) then j = j + 1 jlabel(j) = 'NOCl -> NO + Cl' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * quantum yields assumed unity DO iw = 1, nw-1 where( tlev(1:nz) .le. 223. ) xsqy_tab(j)%sq(1:nz,iw) = yg223(iw) elsewhere (tlev(1:nz) .gt. 223. .and. tlev(1:nz) .le. 243. ) xsqy_tab(j)%sq(1:nz,iw) = yg223(iw) + $ (yg243(iw) - yg223(iw))*(tlev(1:nz) - 223.)*.05 elsewhere (tlev(1:nz) .gt. 243. .and. tlev(1:nz) .le. 263. ) xsqy_tab(j)%sq(1:nz,iw) = yg243(iw) + $ (yg263(iw) - yg243(iw))*(tlev(1:nz) - 243.)*.05 elsewhere (tlev(1:nz) .gt. 263. .and. tlev(1:nz) .le. 298. ) xsqy_tab(j)%sq(1:nz,iw) = yg263(iw) + $ (yg298(iw) - yg263(iw))*(tlev(1:nz) - 263.)/35. elsewhere (tlev(1:nz) .gt. 298. .and. tlev(1:nz) .le. 323. ) xsqy_tab(j)%sq(1:nz,iw) = yg298(iw) + $ (yg323(iw) - yg298(iw))*(tlev(1:nz) - 298.)*.04 elsewhere (tlev(1:nz) .gt. 323. .and. tlev(1:nz) .le. 343. ) xsqy_tab(j)%sq(1:nz,iw) = yg323(iw) + $ (yg343(iw) - yg323(iw))*(tlev(1:nz) - 323.)*.05 elsewhere (tlev(1:nz) .gt. 343. ) xsqy_tab(j)%sq(1:nz,iw) = 0. endwhere ENDDO CONTAINS SUBROUTINE readit * cross section from * IUPAC (vol III) 2007 n = 80 CALL base_read( filespec='DATAJ1/ABS/NOCl.abs', $ skip_cnt=7,rd_cnt=n,x=x1,y=y1 ) y223(1:n) = y1(1:n) y243(1:n) = y1(1:n) y263(1:n) = y1(1:n) y298(1:n) = y1(1:n) y323(1:n) = y1(1:n) y343(1:n) = y1(1:n) ii = 61 CALL base_read( filespec='DATAJ1/ABS/NOCl.abs', $ skip_cnt=88,rd_cnt=ii,x=x1(n+1:),y=y223(n+1:), $ y1=y243(n+1:),y2=y263(n+1:),y3=y298(n+1:), $ y4=y323(n+1:),y5=y343(n+1:) ) n = n + ii CALL add_pnts_inter2(x1,y223,yg223,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y243,yg243,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y263,yg263,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y298,yg298,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y323,yg323,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y343,yg343,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r131 ******************************************************************* SUBROUTINE r132(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * 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, save :: yg204(kw),yg296(kw),yg378(kw) REAL qy, sig ******************** NOCl photodissociation if( initialize ) then j = j + 1 jlabel(j) = 'OClO -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * quantum yields assumed unity DO iw = 1, nw-1 where(tlev(1:nz) .le. 204. ) xsqy_tab(j)%sq(1:nz,iw) = yg204(iw) elsewhere (tlev(1:nz) .gt. 204. .and. tlev(1:nz) .le. 296. ) xsqy_tab(j)%sq(1:nz,iw) = yg204(iw) + $ (yg296(iw) - yg204(iw))*(tlev(1:nz) - 204.)/92. elsewhere (tlev(1:nz) .gt. 296. .and. tlev(1:nz) .le. 378. ) xsqy_tab(j)%sq(1:nz,iw) = yg296(iw) + $ (yg378(iw) - yg296(iw))*(tlev(1:nz) - 296.)/82. elsewhere (tlev(1:nz) .gt. 378. ) xsqy_tab(j)%sq(1:nz,iw) = yg378(iw) endwhere ENDDO CONTAINS SUBROUTINE readit * 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(UNIT=kin,FILE='DATAJ1/ABS/OClO.abs',STATUS='OLD') DO i = 1, 6 READ(kin,*) ENDDO n204 = 1074-6 DO i = 1, n204 READ(kin,*) x204(i), y204(i) ENDDO READ(kin,*) n296 = 1067 do i = 1, n296 read(kin,*) x296(i), y296(i) enddo read(kin,*) n378 = 1068 do i = 1, n378 read(kin,*) x378(i), y378(i) enddo CLOSE(kin) CALL add_pnts_inter2(x204,y204,yg204,kdata,n204, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x296,y296,yg296,kdata,n296, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x378,y378,yg378,kdata,n378, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r132 ******************************************************************* SUBROUTINE pxCH2O(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) integer, PARAMETER :: kdata=200 * data arrays INTEGER iw INTEGER n, n1, n2 REAL x1(kdata), x2(kdata) REAL y298(kdata), tcoef(kdata) REAL qr(kdata), qm(kdata) * local REAL ak300 real qyr300, qym300 REAL, save :: yg1(kw), yg2(kw), yg3(kw), yg4(kw) REAL :: t(nz), t1(nz) REAL :: sig(nz) REAL :: qymt(nz) REAL :: akt(nz) INTEGER ierr **************************************************************** **************** CH2O photodissociatation if( initialize ) then j = j + 1 if( xsqy_tab(j)%channel == 1 ) then jlabel(j) = 'CH2O -> H + HCO' CALL readit tpflag(j) = 1 elseif( xsqy_tab(j)%channel == 2 ) then jlabel(j) = 'CH2O -> H2 + CO' tpflag(j) = 3 endif allocate( xsqy_tab(j)%sq(nz,nw-1) ) 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. t(1:nz) = tlev(1:nz) - 298. t1(1:nz) = (300. - tlev(1:nz))/80. DO iw = 1, nw - 1 * correct cross section for temperature dependence: sig(1:nz) = yg1(iw) + yg2(iw) * t(1:nz) * assign room temperature quantum yields for radical and molecular channels qyr300 = yg3(iw) qym300 = yg4(iw) * 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. - 2.*qym300)/(qym300*(1. - qym300)) ak300 = ak300/2.45e19 akt(1:nz) = ak300 $ * (1. + 0.05 * (wc(iw) - 329.) * t1(1:nz)) qymt(1:nz) = 1./(1./(1.-qyr300) + akt(1:nz)*airden(1:nz)) ELSE qymt(1:nz) = qym300 ENDIF if( xsqy_tab(j)%channel == 1 ) then xsqy_tab(j)%sq(1:nz,iw) = sig(1:nz) * qyr300 elseif( xsqy_tab(j)%channel == 2 ) then xsqy_tab(j)%sq(1:nz,iw) = sig(1:nz) * qymt(1:nz) endif ENDDO CONTAINS SUBROUTINE readit * read JPL2011 cross section data: n = 150 CALL base_read( filespec='DATAJ1/CH2O/CH2O_jpl11.abs', $ skip_cnt=4,rd_cnt=n,x=x1,y=y298, $ y1=tcoef ) y298(1:n) = y298(1:n) * 1.e-20 tcoef(1:n) = tcoef(1:n) * 1.e-24 * terminate endpoints and interpolate to working grid CALL add_pnts_inter2(x1,y298,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,tcoef,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) * quantum yields: Read, terminate, interpolate: n = 112 CALL base_read( filespec='DATAJ1/CH2O/CH2O_jpl11.yld', $ skip_cnt=4,rd_cnt=n,x=x1,y=qr,y1=qm ) CALL add_pnts_inter2(x1,qr,yg3,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,qm,yg4,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE pxCH2O *=============================================================================* SUBROUTINE r140(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=50 REAL x1(kdata) REAL y1(kdata) * local * compute temperature correction factors: real, parameter :: b0 = 3.7973 real, parameter :: b1 = -7.0913e-2 real, parameter :: b2 = 4.9397e-4 real, parameter :: b3 = -1.5226e-6 real, parameter :: b4 = 1.7555e-9 REAL, save :: yg(kw) REAL qy INTEGER i, iw, n, idum INTEGER ierr INTEGER iz INTEGER mabs REAL tcoeff REAL w1 REAL :: sig(nz) REAL :: temp(nz) ************************************************************** ************* CHCl3 photodissociation if( initialize ) then j = j+1 jlabel(j) = 'CHCl3 -> Products' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif *** quantum yield assumed to be unity temp(1:nz) = min(max(tlev(1:nz),210.),300.) - 295. DO iw = 1, nw-1 * compute temperature correction coefficients: tcoeff = 0. w1 = wc(iw) IF(w1 .GT. 190. .AND. w1 .LT. 240.) THEN tcoeff = b0 + w1*(b1 + w1*(b2 + w1*(b3 + w1*b4))) ENDIF xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * 10.**(tcoeff*temp(1:nz)) ENDDO CONTAINS SUBROUTINE readit n = 39 CALL base_read( filespec='DATAJ1/ABS/CHCl3_jpl11.abs', $ skip_cnt=3,rd_cnt=n,x=x1,y=y1 ) y1(1:n) = y1(1:n) * 1.E-20 CALL add_pnts_inter2(x1,y1,yg,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r140 *=============================================================================* SUBROUTINE r141(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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 =* *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata = 50 INTEGER i, n INTEGER iw INTEGER n1, n2 REAL x1(kdata), x2(kdata) REAL y1(kdata), y2(kdata) * local REAL, save :: yg1(kw), yg2(kw) REAL qy REAL sig real :: t(nz) INTEGER ierr INTEGER mabs, myld **************** C2H5ONO2 photodissociation if( initialize ) then j = j + 1 jlabel(j) = 'C2H5ONO2 -> C2H5O + NO2' CALL readit tpflag(j) = 1 allocate( xsqy_tab(j)%sq(nz,nw-1) ) endif * quantum yield = 1 * sigma(T,lambda) = sigma(298,lambda) * exp(B * (T-298)) t(1:nz) = tlev(1:nz) - 298. DO iw = 1, nw - 1 xsqy_tab(j)%sq(1:nz,iw) = yg1(iw) * exp(yg2(iw) * t(1:nz)) ENDDO CONTAINS SUBROUTINE readit * mabs: absorption cross section options: * 1: IUPAC 2006 n = 32 CALL base_read( filespec='DATAJ1/RONO2/C2H5ONO2_iup2006.abs', $ skip_cnt=4,rd_cnt=n,x=x1,y=y1,y1=y2 ) y1(1:n) = y1(1:n) * 1.e-20 y2(1:n) = y2(1:n) * 1.e-3 CALL add_pnts_inter2(x1,y1,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) CALL add_pnts_inter2(x1,y2,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r141 SUBROUTINE r146(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag) *-----------------------------------------------------------------------------* *= 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. *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nw INTEGER, intent(in) :: nz REAL, intent(in) :: wl(kw), wc(kw) REAL, intent(in) :: tlev(kz) REAL, intent(in) :: airden(kz) INTEGER, intent(inout) :: j CHARACTER(len=50), intent(inout) :: jlabel(kj) INTEGER, optional, intent(inout) :: TPFLAG(kj) * weighting functions REAL, intent(inout) :: sq(kj,kz,kw) * data arrays integer, PARAMETER :: kdata=200 INTEGER iw INTEGER i, n REAL x(kdata), y(kdata) integer nn INTEGER ierr * local REAL yg1(nw), yg2(nw) REAL qy, dum if( initialize ) then j = j + 1 jlabel(j) = 'I2 -> I + I' CALL readit allocate( xsqy_tab(j)%sq(nz,nw-1) ) DO iw = 1, nw-1 xsqy_tab(j)%sq(1:nz,iw) = yg1(iw) * yg2(iw) ENDDO endif CONTAINS SUBROUTINE readit * cross section from JPL2011 n = 104 CALL base_read( filespec='DATAJ1/ABS/I2_jpl11.abs', $ skip_cnt=2,rd_cnt=n,x=x,y=y ) y(1:n) = y(1:n) * 1.e-20 CALL add_pnts_inter2(x,y,yg1,kdata,n, $ nw,wl,jlabel(j),deltax) * quantum yields n = 12 CALL base_read( filespec='DATAJ1/YLD/I2.qy', $ skip_cnt=4,rd_cnt=n,x=x,y=y ) CALL add_pnts_inter2(x,y,yg2,kdata,n, $ nw,wl,jlabel(j),deltax) END SUBROUTINE readit END SUBROUTINE r146 ****************************************************** SUBROUTINE add_pnts_inter2(xin,yin,yout,kdata,n, $ nw,wl,jlabel,deltax) integer, intent(in) :: kdata integer, intent(in) :: n integer, intent(in) :: nw real, intent(in) :: deltax real, intent(in) :: wl(nw) real, intent(in) :: xin(kdata) real, intent(in) :: yin(kdata) real, intent(inout) :: yout(kdata) character(len=*), intent(in) :: jlabel integer :: ierr, m real :: xwrk(kdata), ywrk(kdata) m = n xwrk(1:n) = xin(1:n) ywrk(1:n) = yin(1:n) CALL addpnt(xwrk,ywrk,kdata,m,xin(1)*(1.-deltax),0.) CALL addpnt(xwrk,ywrk,kdata,m, 0.,0.) CALL addpnt(xwrk,ywrk,kdata,m,xin(n)*(1.+deltax),0.) CALL addpnt(xwrk,ywrk,kdata,m, 1.e+38,0.) CALL inter2(nw,wl,yout,m,xwrk,ywrk,ierr) IF (ierr /= 0) THEN WRITE(*,*) ierr, trim(jlabel) STOP 'add_pnts_inter2' ENDIF END SUBROUTINE add_pnts_inter2 SUBROUTINE base_read( filespec, skip_cnt, rd_cnt, $ x, y, y1, y2, y3, y4, y5 ) integer, optional, intent(in) :: skip_cnt integer, intent(inout) :: rd_cnt real, intent(inout) :: x(:), y(:) real, optional, intent(inout) :: y1(:), y2(:), y3(:) real, optional, intent(inout) :: y4(:), y5(:) character(len=*), intent(in) :: filespec integer :: i, idum integer :: y_to_rd integer :: ios, err_cnt y_to_rd = 1 if( present(y5) ) y_to_rd = y_to_rd + 1 if( present(y4) ) y_to_rd = y_to_rd + 1 if( present(y3) ) y_to_rd = y_to_rd + 1 if( present(y2) ) y_to_rd = y_to_rd + 1 if( present(y1) ) y_to_rd = y_to_rd + 1 OPEN(UNIT=kin,FILE=trim(filespec), $ STATUS='old',IOSTAT=ios) IF( ios /= 0 ) then write(*,*) 'base_read: failed to open ', $ trim(filespec) STOP 'Open-error' ENDIF if( present(skip_cnt) ) then DO i = 1, skip_cnt READ(kin,*,IOSTAT=ios) IF( ios /= 0 ) exit END DO else READ(kin,*,IOSTAT=ios) idum,rd_cnt IF( ios == 0 ) then DO i = 1, idum-2 READ(kin,*,IOSTAT=ios) IF( ios /= 0 ) exit ENDDO ENDIF endif IF( ios /= 0 ) then write(*,*) 'base_read: failed to read ', $ trim(filespec) STOP 'Read-error' ENDIF select case( y_to_rd ) case( 1 ) DO i = 1, rd_cnt READ(kin,*,IOSTAT=ios) x(i), y(i) IF( ios /= 0 ) exit END DO case( 2 ) DO i = 1, rd_cnt READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i) IF( ios /= 0 ) exit END DO case( 3 ) DO i = 1, rd_cnt READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i), y2(i) IF( ios /= 0 ) exit END DO case( 4 ) DO i = 1, rd_cnt READ(kin,*,IOSTAT=ios) $ x(i), y(i), y1(i), y2(i), y3(i) IF( ios /= 0 ) exit END DO case( 5 ) DO i = 1, rd_cnt READ(kin,*,IOSTAT=ios) $ x(i), y(i), y1(i), y2(i), y3(i),y4(i) IF( ios /= 0 ) exit END DO case( 6 ) DO i = 1, rd_cnt READ(kin,*,IOSTAT=ios) $ x(i), y(i), y1(i), y2(i), y3(i),y4(i),y5(i) IF( ios /= 0 ) exit END DO end select CLOSE (kin) IF( ios /= 0 ) then write(*,*) 'base_read: failed to read ', $ trim(filespec) STOP 'Read-error' ENDIF END SUBROUTINE base_read SUBROUTINE fo3qy2(nz, w, t, qyld) *-----------------------------------------------------------------------------* *= 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. *-----------------------------------------------------------------------------* INTEGER, intent(in) :: nz REAL, intent(in) :: w REAL, intent(in) :: t(:) REAL, intent(inout) :: qyld(:) REAL, parameter :: A(3) = (/ 0.8036, 8.9061, 0.1192/) REAL, parameter :: X(3) = (/ 304.225, 314.957, 310.737/) REAL, parameter :: om(3) = (/ 5.576, 6.601, 2.187/) REAL :: kt(1:nz) REAL :: q2(1:nz) REAL :: q1 q1 = 1. kt(1:nz) = 0.695 * t(1:nz) q2(1:nz) = exp(-825.518/kt(1:nz)) kt(1:nz) = t(1:nz)/300. IF(w .LE. 305.) THEN qyld(1:nz) = 0.90 ELSEIF(w .GT. 305. .AND. w .LE. 328.) THEN qyld(1:nz) = 0.0765 + $ a(1)* (q1/(q1+q2))*EXP(-((x(1)-w)/om(1))**4)+ $ a(2)*(kT(1:nz))**2 *(q2/(q1+q2))*EXP(-((x(2)-w)/om(2))**2)+ $ a(3)*(kT(1:nz))**1.5 *EXP(-((x(3)-w)/om(3))**2) ELSEIF(w .GT. 328. .AND. w .LE. 340.) THEN qyld(1:nz) = 0.08 ELSEIF(w .GT. 340.) THEN qyld(1:nz) = 0. ENDIF END SUBROUTINE fo3qy2 SUBROUTINE qyacet(nz, w, T, M, fac) * This file contains subroutines used for calculation of quantum yields for * various photoreactions: * qyacet - q.y. for acetone, based on Blitz et al. (2004) * 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 INTEGER, intent(in) :: nz REAL, intent(in) :: w REAL, intent(in) :: T(:), M(:) REAL, intent(inout) :: fac(:) * internal: REAL :: a0(nz), a1(nz), a2(nz), a3(nz), a4(nz) REAL :: b0(nz), b1(nz), b2(nz), b3(nz), b4(nz) REAL :: c3(nz) REAL :: cA0(nz), cA1(nz), cA2(nz), cA3(nz), cA4(nz) real :: dumexp(nz) * output * fco = quantum yield for product CO * fac = quantum yield for product CH3CO (acetyl radical) REAL :: fco(nz) REAL :: tfac(nz) *** set out-of-range values: * use low pressure limits for shorter wavelengths * set to zero beyound 327.5 IF(w .LT. 279.) THEN fac(1:nz) = 0.95 ELSEIF(w .GT. 327.) THEN fac(1:nz) = 0. ELSE *** CO (carbon monoxide) quantum yields: tfac(1:nz) = t(1:nz)/295. a0 = 0.350 * tfac(1:nz)**(-1.28) b0 = 0.068 * tfac(1:nz)**(-2.65) **SM: prevent exponent overflow in rare cases: dumexp(1:nz) = b0(1:nz)*(w - 248.) where( dumexp(1:nz) > 80. ) cA0(1:nz) = 5.e34 elsewhere cA0(1:nz) = exp(dumexp(1:nz)) * a0(1:nz) / (1. - a0(1:nz)) endwhere fco(1:nz) = 1. / (1. + cA0(1:nz)) *** CH3CO (acetyl radical) quantum yields: IF(w >= 279. .AND. w < 302.) THEN a1(1:nz) = 1.600E-19 * tfac(1:nz)**(-2.38) b1(1:nz) = 0.55E-3 * tfac(1:nz)**(-3.19) cA1(1:nz) = a1(1:nz) * EXP(-b1(1:nz)*((1.e7/w) - 33113.)) fac(1:nz) = (1. - fco(1:nz)) / (1 + cA1(1:nz) * M(1:nz)) ELSEIF(w >= 302. .AND. w <= 327.) THEN a2(1:nz) = 1.62E-17 * tfac(1:nz)**(-10.03) b2(1:nz) = 1.79E-3 * tfac(1:nz)**(-1.364) cA2(1:nz) = a2(1:nz) * EXP(-b2(1:nz)*((1.e7/w) - 30488.)) a3(1:nz) = 26.29 * tfac(1:nz)**(-6.59) b3(1:nz) = 5.72E-7 * tfac(1:nz)**(-2.93) c3(1:nz) = 30006 * tfac(1:nz)**(-0.064) ca3(1:nz) = a3(1:nz) $ * EXP(-b3(1:nz)*((1.e7/w) - c3(1:nz))**2) a4(1:nz) = 1.67E-15 * tfac(1:nz)**(-7.25) b4(1:nz) = 2.08E-3 * tfac(1:nz)**(-1.16) cA4(1:nz) = a4(1:nz) * EXP(-b4(1:nz)*((1.e7/w) - 30488.)) fac(1:nz) = $ (1. - fco(1:nz)) * (1. + cA3(1:nz) + cA4(1:nz) * M(1:nz)) $ / ((1. + cA3(1:nz) + cA2(1:nz) * M(1:nz)) $ * (1. + cA4(1:nz) * M(1:nz))) ENDIF ENDIF END SUBROUTINE qyacet SUBROUTINE diagnostics integer :: m, n, n1 open( unit=44,file='TUV.diags') write(44,*) 'Photolysis diags' write(44,*) ' ' write(44,'(i3,'' Total photorates'')') npht write(44,*) ' ' do m = 2,npht write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) enddo write(44,*) ' ' write(44,'(''Wrf labels'')') write(44,*) ' ' do m = 2,npht write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%wrf_label) enddo write(44,*) ' ' write(44,'(i3,'' Photorate(s) with no p,temp dependence'')') $ count(xsqy_tab(2:npht)%tpflag == 0) write(44,*) ' ' do m = 2,npht if( xsqy_tab(m)%tpflag == 0 ) then write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) endif enddo write(44,*) ' ' write(44,'(i3,'' Photorate(s) with temp dependence'')') $ count(xsqy_tab(2:npht)%tpflag == 1) write(44,*) ' ' do m = 2,npht if( xsqy_tab(m)%tpflag == 1 ) then write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) endif enddo write(44,*) ' ' write(44,'(i3,'' Photorate(s) with press dependence'')') $ count(xsqy_tab(2:npht)%tpflag == 2) write(44,*) ' ' do m = 2,npht if( xsqy_tab(m)%tpflag == 2 ) then write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) endif enddo write(44,*) ' ' write(44,'(i3,'' Photorate(s) with temp,press dependence'')') $ count(xsqy_tab(2:npht)%tpflag == 3) write(44,*) ' ' do m = 2,npht if( xsqy_tab(m)%tpflag == 3 ) then write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) endif enddo write(44,*) ' ' write(44,'(i3,'' Photorate(s) with second channel'')') $ count(xsqy_tab(2:npht)%channel == 2) write(44,*) ' ' do m = 2,npht if( xsqy_tab(m)%channel == 2 ) then write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) endif enddo write(44,*) ' ' write(44,'(i3,'' Photorate(s) with third channel'')') $ count(xsqy_tab(2:npht)%channel == 3) write(44,*) ' ' do m = 2,npht if( xsqy_tab(m)%channel == 3 ) then write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) endif enddo write(44,*) ' ' write(44,'(i3,'' Photorate(s) with multiple input files'')') $ count(xsqy_tab(2:npht)%filespec%nfiles > 1) write(44,*) ' ' do m = 2,npht if( xsqy_tab(m)%filespec%nfiles > 1 ) then write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) endif enddo write(44,*) ' ' write(44,'('' Photorate(s) with skip == -1'')') write(44,*) ' ' do m = 2,npht n = xsqy_tab(m)%filespec%nfiles do n1 = 1,n if( xsqy_tab(m)%filespec%nskip(n1) == -1 ) then write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) endif enddo enddo write(44,*) ' ' write(44,'('' Photorate(s) with skip >= 0'')') write(44,*) ' ' do m = 2,npht n = xsqy_tab(m)%filespec%nfiles do n1 = 1,n if( xsqy_tab(m)%filespec%nskip(n1) >= 0 .and. $ xsqy_tab(m)%filespec%filename(n1) /= ' ' ) then write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) endif enddo enddo write(44,*) ' ' write(44,'('' Filenames'')') write(44,*) ' ' do m = 2,npht n = xsqy_tab(m)%filespec%nfiles do n1 = 1,n if( xsqy_tab(m)%filespec%filename(n1) /= ' ' ) then write(44,'(i3,2x,a,3x,i4,3x,i4)') $ m,trim(xsqy_tab(m)%filespec%filename(n1)), $ xsqy_tab(m)%filespec%nskip(n1), $ xsqy_tab(m)%filespec%nread(n1) endif enddo enddo close( 44 ) * stop 'Diags' END SUBROUTINE diagnostics end module module_rxn