chem/rxn.F

   1 !=============================================================================*
   2 ! This file contains the following subroutines, related to reading/loading
   3 ! the product (cross section) x (quantum yield) for photo-reactions:
   4 !     r01 through r47
   5 !     r101 through r148, skipped r116,r117, added pxCH2O
   6 !=============================================================================*
   7
   8       module module_rxn
   9
  10       use module_params
  11
  12       IMPLICIT NONE
  13
  14       private :: fo3qy2, qyacet
  15
  16       logical, private :: initialize = .true.
  17       integer, parameter :: max_files = 5
  18
  19       integer :: npht, npht_tab
  20
  21       type file_specs
  22         integer            :: nfiles
  23         integer            :: nskip(max_files)
  24         integer            :: nread(max_files)
  25         real               :: xfac(max_files)
  26         character(len=132) :: filename(max_files)
  27       end type file_specs
  28
  29       type xs_qy_tab
  30         integer :: tpflag
  31         integer :: channel
  32         integer :: jndx
  33         real    :: qyld
  34         real, allocatable :: sq(:,:)
  35         character(len=50) :: label
  36         character(len=50) :: wrf_label
  37         type(xs_qy_tab), pointer :: next
  38         type(xs_qy_tab), pointer :: last
  39         type(file_specs)  :: filespec
  40       end type xs_qy_tab
  41
  42       type(xs_qy_tab), allocatable, target :: xsqy_tab(:)
  43       type(xs_qy_tab), pointer             :: xsqy_tab_head
  44       type(xs_qy_tab), pointer             :: xsqy_tab_tail
  45
  46 !=====================================================================
  47 !  the following is fortran2003 compliant code
  48 !=====================================================================
  49       type xsqy_subs
  50         procedure(xsqy), nopass, pointer :: xsqy_sub
  51       end type xsqy_subs
  52
  53       abstract interface
  54         SUBROUTINE xsqy(nw,wl,wc,nz,tlev,airden,j)
  55
  56           use module_params
  57
  58           INTEGER, intent(in) :: nw
  59           INTEGER, intent(in) :: nz
  60           REAL, intent(in)    :: wl(kw), wc(kw)
  61           REAL, intent(in)    :: tlev(kz)
  62           REAL, intent(in)    :: airden(kz)
  63
  64           INTEGER, intent(inout) :: j
  65         end SUBROUTINE xsqy
  66       end interface
  67
  68       type(xsqy_subs), allocatable :: the_subs(:)
  69
  70       CONTAINS
  71
  72       SUBROUTINE no_z_dep(nw,wl,wc,nz,tlev,airden,j)
  73 !-----------------------------------------------------------------------------*
  74 !  generic routine
  75 !-----------------------------------------------------------------------------*
  76
  77       use module_params
  78
  79 ! input
  80
  81       INTEGER, intent(in) :: nw
  82       INTEGER, intent(in) :: nz
  83       INTEGER, intent(inout) :: j
  84       REAL,    intent(in) :: wl(kw), wc(kw)
  85       REAL,    intent(in) :: airden(kz)
  86       REAL,    intent(in) :: tlev(kz)
  87
  88       integer, PARAMETER :: kdata=500
  89
  90 ! local
  91       REAL :: x1(kdata)
  92       REAL :: y1(kdata)
  93
  94       INTEGER :: wn
  95       REAL    :: yg(kw)
  96
  97       if( initialize ) then
  98         CALL readit
  99         call check_alloc( ndx=j, nz=nw-1, nw=1 )
 100         if( xsqy_tab(j)%qyld == 1. ) then
 101 !*** quantum yield assumed to be unity
 102           xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1)
 103         else
 104           xsqy_tab(j)%sq(1:nw-1,1) = xsqy_tab(j)%qyld * yg(1:nw-1)
 105         endif
 106       endif
 107
 108       CONTAINS
 109
 110       SUBROUTINE readit
 111
 112       INTEGER :: ierr
 113       integer :: n, fileno
 114       character(len=132) :: filename
 115
 116       do fileno = 1,xsqy_tab(j)%filespec%nfiles
 117         filename = trim( xsqy_tab(j)%filespec%filename(fileno) )
 118         n = xsqy_tab(j)%filespec%nread(fileno)
 119         if( xsqy_tab(j)%filespec%nskip(fileno) >= 0 ) then
 120           CALL base_read( filespec=trim(filename), &
 121                           skip_cnt=xsqy_tab(j)%filespec%nskip(fileno), &
 122                           rd_cnt  =n,x=x1,y=y1 )
 123         else
 124           CALL base_read( filespec=trim(filename),rd_cnt=n,x=x1,y=y1 )
 125         endif
 126         y1(1:n) = y1(1:n) * xsqy_tab(j)%filespec%xfac(fileno)
 127
 128         CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
 129                              nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
 130       enddo
 131
 132       END SUBROUTINE readit
 133
 134       END SUBROUTINE no_z_dep
 135
 136       LOGICAL FUNCTION get_initialization()
 137
 138       get_initialization = initialize
 139
 140       END FUNCTION get_initialization
 141
 142       SUBROUTINE set_initialization( status )
 143
 144       LOGICAL, intent(in) :: status
 145
 146       initialize = status
 147
 148       END SUBROUTINE set_initialization
 149
 150       SUBROUTINE rxn_init( nw, wl )
 151 !---------------------------------------------
 152 !  initialize wrf-tuv
 153 !---------------------------------------------
 154
 155       use module_xsections, only : rdxs_init
 156
 157       integer, intent(in) :: nw
 158       real, intent(in)    :: wl(nw)
 159
 160       integer :: astat, m, n, debug_level
 161       character(len=256) :: emsg
 162
 163       call set_initialization( status=.true. )
 164       call get_wrf_debug_level( debug_level )
 165
 166       if( .not. allocated( xsqy_tab ) ) then
 167          allocate( xsqy_tab(kj),stat=astat )
 168          if( astat /= 0 ) then
 169            write(emsg,'(''rxn_init: failed to allocate xsqy_tab; error = '',i4)') astat
 170            call wrf_error_fatal( trim(emsg) )
 171          endif
 172       endif
 173       if( .not. allocated( the_subs ) ) then
 174          allocate( the_subs(kj),stat=astat )
 175          if( astat /= 0 ) then
 176            write(emsg,'(''rxn_init: failed to allocate xsqy_tab subs; error = '',i4)') astat
 177            call wrf_error_fatal( trim(emsg) )
 178          endif
 179       endif
 180
 181       nullify( xsqy_tab_head )
 182       nullify( xsqy_tab_tail )
 183
 184       xsqy_tab(1:kj)%tpflag  = 0
 185       xsqy_tab(1:kj)%channel = 1
 186       xsqy_tab(1:kj)%label   =  ' '
 187       xsqy_tab(1:kj)%qyld    =  1.
 188       xsqy_tab(1:kj)%filespec%nfiles =  1
 189       do m = 1,max_files
 190         xsqy_tab(1:kj)%filespec%nskip(m) =  0
 191         xsqy_tab(1:kj)%filespec%nread(m) =  0
 192         xsqy_tab(1:kj)%filespec%xfac(m)  =  1.e-20
 193         xsqy_tab(1:kj)%filespec%filename(m) = ' '
 194       end do
 195       do m = 1,kj
 196         nullify( xsqy_tab(m)%next )
 197         nullify( xsqy_tab(m)%last )
 198         the_subs(m)%xsqy_sub => null()
 199       end do
 200
 201       npht_tab = 2
 202       call setup_sub_calls( the_subs,npht_tab )
 203
 204       IF ( 100 .LE. debug_level ) THEN
 205         call diagnostics
 206       ENDIF
 207
 208       call rdxs_init( nw, wl )
 209
 210       END SUBROUTINE rxn_init
 211
 212       subroutine setup_sub_calls( subr, m )
 213
 214       integer, intent(inout) :: m
 215       type(xsqy_subs), intent(inout) :: subr(:)
 216
 217       xsqy_tab(m)%label   = 'O3 -> O2 + O(1D)'
 218       xsqy_tab(m+1)%label = 'O3 -> O2 + O(3P)'
 219       xsqy_tab(m)%wrf_label   = 'j_o1d'
 220       xsqy_tab(m+1)%wrf_label = 'j_o3p'
 221       xsqy_tab(m:m+1)%jndx = (/ m,m+1 /)
 222       xsqy_tab(m+1)%channel = 2
 223       xsqy_tab(m:m+1)%tpflag = 1
 224       subr(m)%xsqy_sub   => r01
 225       subr(m+1)%xsqy_sub => r01
 226       m = m + 2
 227
 228       xsqy_tab(m)%label = 'NO2 -> NO + O(3P)'
 229       xsqy_tab(m)%wrf_label = 'j_no2'
 230       xsqy_tab(m)%jndx  = m
 231       xsqy_tab(m)%tpflag = 1
 232       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/YLD/NO2_jpl11.yld'
 233       xsqy_tab(m)%filespec%nskip(1) = 2
 234       xsqy_tab(m)%filespec%nread(1) = 25
 235       subr(m)%xsqy_sub   => r02
 236       m = m + 1
 237
 238       xsqy_tab(m)%label   = 'NO3 -> NO + O2'
 239       xsqy_tab(m+1)%label = 'NO3 -> NO2 + O(3P)'
 240       xsqy_tab(m)%wrf_label   = 'j_no3_a'
 241       xsqy_tab(m+1)%wrf_label = 'j_no3_b'
 242       xsqy_tab(m)%jndx = m
 243       xsqy_tab(m+1)%channel = 2
 244       xsqy_tab(m:m+1)%tpflag = 1
 245       xsqy_tab(m)%filespec%nfiles = 2
 246       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/NO3_jpl11.abs'
 247       xsqy_tab(m)%filespec%nskip(1) = 6
 248       xsqy_tab(m)%filespec%nread(1) = 289
 249       xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/YLD/NO3_jpl2011.qy'
 250       xsqy_tab(m)%filespec%nskip(2) = 5
 251       xsqy_tab(m)%filespec%nread(2) = 56
 252       xsqy_tab(m)%filespec%xfac(2)  = 1.e-3
 253       subr(m)%xsqy_sub   => r03
 254       subr(m+1)%xsqy_sub => r03
 255       m = m + 2
 256
 257       xsqy_tab(m)%label   = 'N2O5 -> NO3 + NO + O(3P)'
 258       xsqy_tab(m+1)%label = 'N2O5 -> NO3 + NO2'
 259       xsqy_tab(m)%wrf_label   = 'j_n2o5_a'
 260       xsqy_tab(m+1)%wrf_label = 'j_n2o5_b'
 261       xsqy_tab(m)%jndx = m
 262       xsqy_tab(m+1)%channel = 2
 263       xsqy_tab(m:m+1)%tpflag = 1
 264       xsqy_tab(m)%filespec%nfiles = 2
 265       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/N2O5_jpl11.abs'
 266       xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/ABS/N2O5_jpl11.abs'
 267       xsqy_tab(m)%filespec%nskip(1:2) = (/ 4,111 /)
 268       xsqy_tab(m)%filespec%nread(1:2) = (/ 103,8 /)
 269       subr(m)%xsqy_sub   => r04
 270       subr(m+1)%xsqy_sub => r04
 271       m = m + 2
 272
 273       xsqy_tab(m)%label = 'HNO2 -> OH + NO'
 274       xsqy_tab(m)%wrf_label = 'j_hno2'
 275       xsqy_tab(m)%jndx  = m
 276       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HONO_jpl11.abs'
 277       xsqy_tab(m)%filespec%nskip(1) = 3
 278       xsqy_tab(m)%filespec%nread(1) = 192
 279       subr(m)%xsqy_sub   => no_z_dep
 280       m = m + 1
 281
 282       xsqy_tab(m)%label = 'HNO3 -> OH + NO2'
 283       xsqy_tab(m)%wrf_label = 'j_hno3'
 284       xsqy_tab(m)%jndx  = m
 285       xsqy_tab(m)%tpflag = 1
 286       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HNO3_burk.abs'
 287       xsqy_tab(m)%filespec%nskip(1) = 6
 288       xsqy_tab(m)%filespec%nread(1) = 83
 289       subr(m)%xsqy_sub   => r06
 290       m = m + 1
 291
 292       xsqy_tab(m)%label = 'HNO4 -> HO2 + NO2'
 293       xsqy_tab(m)%wrf_label = 'j_hno4'
 294       xsqy_tab(m)%jndx  = m
 295       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HNO4_jpl11.abs'
 296       xsqy_tab(m)%filespec%nskip(1) = 2
 297       xsqy_tab(m)%filespec%nread(1) = 54
 298       subr(m)%xsqy_sub   => no_z_dep
 299       m = m + 1
 300
 301       xsqy_tab(m)%label = 'H2O2 -> 2 OH'
 302       xsqy_tab(m)%wrf_label = 'j_h2o2'
 303       xsqy_tab(m)%jndx  = m
 304       xsqy_tab(m)%tpflag = 1
 305       xsqy_tab(m)%filespec%nfiles      = 2
 306       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/H2O2_jpl94.abs'
 307       xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/ABS/H2O2_Kahan.abs'
 308       xsqy_tab(m)%filespec%nskip(1:2) = (/ -1,0 /)
 309       xsqy_tab(m)%filespec%nread(2)   = 494
 310       subr(m)%xsqy_sub   => r08
 311       m = m + 1
 312
 313       xsqy_tab(m)%label = 'CHBr3 -> Products'
 314       xsqy_tab(m)%wrf_label = 'j_chbr3'
 315       xsqy_tab(m)%jndx  = m
 316       xsqy_tab(m)%tpflag = 1
 317       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CHBr3.jpl97'
 318       xsqy_tab(m)%filespec%nskip(1) = 6
 319       xsqy_tab(m)%filespec%nread(1) = 87
 320       subr(m)%xsqy_sub   => r09
 321       m = m + 1
 322
 323       xsqy_tab(m)%label   = 'CH3CHO -> CH3 + HCO'
 324       xsqy_tab(m+1)%label = 'CH3CHO -> CH4 + CO'
 325       xsqy_tab(m+2)%label = 'CH3CHO -> CH3CO + H'
 326       xsqy_tab(m)%wrf_label = 'j_ch3cho_a'
 327       xsqy_tab(m+1)%wrf_label = 'j_ch3cho_b'
 328       xsqy_tab(m+2)%wrf_label = 'j_ch3cho_c'
 329       xsqy_tab(m)%jndx = m
 330       xsqy_tab(m+1:m+2)%channel = (/ 2,3 /)
 331       xsqy_tab(m:m+2)%tpflag = (/ 2,0,0 /)
 332       xsqy_tab(m)%filespec%nfiles = 2
 333       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3CHO/CH3CHO_jpl11.abs'
 334       xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/CH3CHO/CH3CHO_uip.yld'
 335       xsqy_tab(m)%filespec%nskip(1:2) = (/ 2,4 /)
 336       xsqy_tab(m)%filespec%nread(1:2) = (/ 101,12 /)
 337       subr(m)%xsqy_sub   => r11
 338       subr(m+1)%xsqy_sub => r11
 339       subr(m+2)%xsqy_sub => r11
 340       m = m + 3
 341
 342       xsqy_tab(m)%label = 'C2H5CHO -> C2H5 + HCO'
 343       xsqy_tab(m)%wrf_label = 'j_c2h5cho'
 344       xsqy_tab(m)%jndx  = m
 345       xsqy_tab(m)%tpflag = 2
 346       xsqy_tab(m)%filespec%nfiles = 2
 347       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/C2H5CHO/C2H5CHO_iup.abs'
 348       xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/C2H5CHO/C2H5CHO_iup.yld'
 349       xsqy_tab(m)%filespec%nskip(1:2) = 4
 350       xsqy_tab(m)%filespec%nread(1:2) = (/ 106,5 /)
 351       subr(m)%xsqy_sub   => r12
 352       m = m + 1
 353
 354       xsqy_tab(m)%label   = 'CHOCHO -> HCO + HCO'
 355       xsqy_tab(m+1)%label = 'CHOCHO -> H2 + 2CO'
 356       xsqy_tab(m+2)%label = 'CHOCHO -> CH2O + CO'
 357       xsqy_tab(m)%wrf_label = 'j_gly_a'
 358       xsqy_tab(m+1)%wrf_label = 'j_gly_b'
 359       xsqy_tab(m+2)%wrf_label = 'j_gly_c'
 360       xsqy_tab(m)%jndx = m
 361       xsqy_tab(m+1:m+2)%channel = (/ 2,3 /)
 362       xsqy_tab(m)%filespec%nfiles = 2
 363       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CHOCHO/glyoxal_jpl11.abs'
 364       xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/CHOCHO/glyoxal_jpl11.qy'
 365       xsqy_tab(m)%filespec%nskip(1:2) = (/ 2,3 /)
 366       xsqy_tab(m)%filespec%nread(1:2) = (/ 277,40 /)
 367       subr(m)%xsqy_sub   => r13
 368       subr(m+1)%xsqy_sub => r13
 369       subr(m+2)%xsqy_sub => r13
 370       m = m + 3
 371
 372       xsqy_tab(m)%label = 'CH3COCHO -> CH3CO + HCO'
 373       xsqy_tab(m)%wrf_label = 'j_mgly'
 374       xsqy_tab(m)%jndx  = m
 375       xsqy_tab(m)%tpflag = 2
 376       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3COCHO/CH3COCHO_jpl11.abs'
 377       xsqy_tab(m)%filespec%nskip(1) = 2
 378       xsqy_tab(m)%filespec%nread(1) = 294
 379       subr(m)%xsqy_sub   => r14
 380       m = m + 1
 381
 382       xsqy_tab(m)%label = 'CH3COCH3 -> CH3CO + CH3'
 383       xsqy_tab(m)%wrf_label = 'j_ch3coch3'
 384       xsqy_tab(m)%jndx  = m
 385       xsqy_tab(m)%tpflag = 3
 386       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3COCH3/CH3COCH3_jpl11.abs'
 387       xsqy_tab(m)%filespec%nskip(1) = 5
 388       xsqy_tab(m)%filespec%nread(1) = 135
 389       subr(m)%xsqy_sub   => r15
 390       m = m + 1
 391
 392       xsqy_tab(m)%label = 'CH3OOH -> CH3O + OH'
 393       xsqy_tab(m)%wrf_label = 'j_ch3ooh'
 394       xsqy_tab(m)%jndx  = m
 395       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3OOH/CH3OOH_jpl11.abs'
 396       xsqy_tab(m)%filespec%nskip(1) = 2
 397       xsqy_tab(m)%filespec%nread(1) = 40
 398       subr(m)%xsqy_sub   => no_z_dep
 399       m = m + 1
 400
 401       xsqy_tab(m)%label = 'CH3ONO2 -> CH3O + NO2'
 402       xsqy_tab(m)%wrf_label = 'j_ch3ono2'
 403       xsqy_tab(m)%jndx  = m
 404       xsqy_tab(m)%tpflag = 1
 405       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/CH3ONO2_jpl11.abs'
 406       xsqy_tab(m)%filespec%nskip(1) = 2
 407       xsqy_tab(m)%filespec%nread(1) = 65
 408       subr(m)%xsqy_sub   => r17
 409       m = m + 1
 410
 411       xsqy_tab(m)%label   = 'CH3CO(OONO2) -> CH3CO(OO) + NO2'
 412       xsqy_tab(m+1)%label = 'CH3CO(OONO2) -> CH3CO(O) + NO3'
 413       xsqy_tab(m)%wrf_label = 'j_pan_a'
 414       xsqy_tab(m+1)%wrf_label = 'j_pan_b'
 415       xsqy_tab(m)%jndx = m
 416       xsqy_tab(m+1)%channel = 2
 417       xsqy_tab(m:m+1)%tpflag = 1
 418       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/PAN_talukdar.abs'
 419       xsqy_tab(m)%filespec%nskip(1) = 14
 420       xsqy_tab(m)%filespec%nread(1) = 78
 421       subr(m)%xsqy_sub   => r18
 422       subr(m+1)%xsqy_sub => r18
 423       m = m + 2
 424
 425       xsqy_tab(m)%label = 'CCl2O -> Products'
 426       xsqy_tab(m)%wrf_label = 'j_ccl2o'
 427       xsqy_tab(m)%jndx  = m
 428       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CCl2O_jpl94.abs'
 429       xsqy_tab(m)%filespec%nskip(1) = -1
 430       subr(m)%xsqy_sub   => no_z_dep
 431       m = m + 1
 432
 433       xsqy_tab(m)%label = 'CCl4 -> Products'
 434       xsqy_tab(m)%wrf_label = 'j_ccl4'
 435       xsqy_tab(m)%jndx  = m
 436       xsqy_tab(m)%tpflag = 1
 437       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CCl4_jpl11.abs'
 438       xsqy_tab(m)%filespec%nskip(1) = 5
 439       xsqy_tab(m)%filespec%nread(1) = 44
 440       subr(m)%xsqy_sub   => r20
 441       m = m + 1
 442
 443       xsqy_tab(m)%label = 'CClFO -> Products'
 444       xsqy_tab(m)%wrf_label = 'j_cclfo'
 445       xsqy_tab(m)%jndx  = m
 446       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CClFO_jpl94.abs'
 447       xsqy_tab(m)%filespec%nskip(1) = -1
 448       subr(m)%xsqy_sub   => no_z_dep
 449       m = m + 1
 450
 451       xsqy_tab(m)%label = 'CF2O -> Products'
 452       xsqy_tab(m)%wrf_label = 'j_cf2o'
 453       xsqy_tab(m)%jndx  = m
 454       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CF2O_jpl11.abs'
 455       xsqy_tab(m)%filespec%nskip(1) = 5
 456       xsqy_tab(m)%filespec%nread(1) = 21
 457       subr(m)%xsqy_sub   => no_z_dep
 458       m = m + 1
 459
 460       xsqy_tab(m)%label = 'CF2ClCFCl2 (CFC-113) -> Products'
 461       xsqy_tab(m)%wrf_label = 'j_cf2clcfcl2'
 462       xsqy_tab(m)%jndx  = m
 463       xsqy_tab(m)%tpflag = 1
 464       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CFC-113_jpl94.abs'
 465       xsqy_tab(m)%filespec%nskip(1) = -1
 466       subr(m)%xsqy_sub   => r23
 467       m = m + 1
 468
 469       xsqy_tab(m)%label = 'CF2ClCF2Cl (CFC-114) -> Products'
 470       xsqy_tab(m)%wrf_label = 'j_cf2clcf2cl'
 471       xsqy_tab(m)%jndx  = m
 472       xsqy_tab(m)%tpflag = 1
 473       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CFC-114_jpl94.abs'
 474       xsqy_tab(m)%filespec%nskip(1) = -1
 475       subr(m)%xsqy_sub   => r24
 476       m = m + 1
 477
 478       xsqy_tab(m)%label = 'CF3CF2Cl (CFC-115) -> Products'
 479       xsqy_tab(m)%wrf_label = 'j_cf3cf2cl'
 480       xsqy_tab(m)%jndx  = m
 481       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CFC-115_jpl94.abs'
 482       xsqy_tab(m)%filespec%nskip(1) = -1
 483       subr(m)%xsqy_sub   => no_z_dep
 484       m = m + 1
 485
 486       xsqy_tab(m)%label = 'CCl3F (CFC-11) -> Products'
 487       xsqy_tab(m)%wrf_label = 'j_ccl3f'
 488       xsqy_tab(m)%jndx  = m
 489       xsqy_tab(m)%tpflag = 1
 490       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CFC-11_jpl94.abs'
 491       xsqy_tab(m)%filespec%nskip(1) = -1
 492       subr(m)%xsqy_sub   => r26
 493       m = m + 1
 494
 495       xsqy_tab(m)%label = 'CCl2F2 (CFC-12) -> Products'
 496       xsqy_tab(m)%wrf_label = 'j_ccl2f2'
 497       xsqy_tab(m)%jndx  = m
 498       xsqy_tab(m)%tpflag = 1
 499       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CFC-12_jpl94.abs'
 500       xsqy_tab(m)%filespec%nskip(1) = -1
 501       subr(m)%xsqy_sub   => r27
 502       m = m + 1
 503
 504       xsqy_tab(m)%label = 'CH3Br -> Products'
 505       xsqy_tab(m)%wrf_label = 'j_ch3br'
 506       xsqy_tab(m)%jndx  = m
 507       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3Br_jpl94.abs'
 508       xsqy_tab(m)%filespec%nskip(1) = -1
 509       subr(m)%xsqy_sub   => no_z_dep
 510       m = m + 1
 511
 512       xsqy_tab(m)%label = 'CH3CCl3 -> Products'
 513       xsqy_tab(m)%wrf_label = 'j_ch3ccl3'
 514       xsqy_tab(m)%jndx  = m
 515       xsqy_tab(m)%tpflag = 1
 516       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3CCl3_jpl94.abs'
 517       xsqy_tab(m)%filespec%nskip(1) = -1
 518       subr(m)%xsqy_sub   => r29
 519       m = m + 1
 520
 521       xsqy_tab(m)%label = 'CH3Cl -> Products'
 522       xsqy_tab(m)%wrf_label = 'j_ch3cl'
 523       xsqy_tab(m)%jndx  = m
 524       xsqy_tab(m)%tpflag = 1
 525       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3Cl_jpl94.abs'
 526       xsqy_tab(m)%filespec%nskip(1) = -1
 527       subr(m)%xsqy_sub   => r30
 528       m = m + 1
 529
 530       xsqy_tab(m)%label = 'ClOO -> Products'
 531       xsqy_tab(m)%wrf_label = 'j_cloo'
 532       xsqy_tab(m)%jndx  = m
 533       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClOO_jpl94.abs'
 534       xsqy_tab(m)%filespec%nskip(1) = -1
 535       subr(m)%xsqy_sub   => no_z_dep
 536       m = m + 1
 537
 538       xsqy_tab(m)%label = 'CF3CHCl2 (HCFC-123) -> Products'
 539       xsqy_tab(m)%wrf_label = 'j_cf3chcl2'
 540       xsqy_tab(m)%jndx  = m
 541       xsqy_tab(m)%tpflag = 1
 542       subr(m)%xsqy_sub   => r32
 543       m = m + 1
 544
 545       xsqy_tab(m)%label = 'CF3CHFCl (HCFC-124) -> Products'
 546       xsqy_tab(m)%wrf_label = 'j_cf3chfcl'
 547       xsqy_tab(m)%jndx  = m
 548       xsqy_tab(m)%tpflag = 1
 549       subr(m)%xsqy_sub   => r33
 550       m = m + 1
 551
 552       xsqy_tab(m)%label = 'CH3CFCl2 (HCFC-141b) -> Products'
 553       xsqy_tab(m)%wrf_label = 'j_ch3cfcl2'
 554       xsqy_tab(m)%jndx  = m
 555       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HCFC-141b_jpl94.abs'
 556       xsqy_tab(m)%filespec%nskip(1) = -1
 557       subr(m)%xsqy_sub   => no_z_dep
 558       m = m + 1
 559
 560       xsqy_tab(m)%label = 'CH3CF2Cl (HCFC-142b) -> Products'
 561       xsqy_tab(m)%wrf_label = 'j_ch3cf2cl'
 562       xsqy_tab(m)%jndx  = m
 563       xsqy_tab(m)%tpflag = 1
 564       subr(m)%xsqy_sub   => r35
 565       m = m + 1
 566
 567       xsqy_tab(m)%label = 'CF3CF2CHCl2 (HCFC-225ca) -> Products'
 568       xsqy_tab(m)%wrf_label = 'j_cf3cf2chcl2'
 569       xsqy_tab(m)%jndx  = m
 570       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HCFC-225ca_jpl94.abs'
 571       xsqy_tab(m)%filespec%nskip(1) = -1
 572       subr(m)%xsqy_sub   => no_z_dep
 573       m = m + 1
 574
 575       xsqy_tab(m)%label = 'CF2ClCF2CHFCl (HCFC-225cb) -> Products'
 576       xsqy_tab(m)%wrf_label = 'j_cf2clcf2chfcl'
 577       xsqy_tab(m)%jndx  = m
 578       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HCFC-225cb_jpl94.abs'
 579       xsqy_tab(m)%filespec%nskip(1) = -1
 580       subr(m)%xsqy_sub   => no_z_dep
 581       m = m + 1
 582
 583       xsqy_tab(m)%label = 'CHClF2 (HCFC-22) -> Products'
 584       xsqy_tab(m)%wrf_label = 'j_chclf2'
 585       xsqy_tab(m)%jndx  = m
 586       xsqy_tab(m)%tpflag = 1
 587       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HCFC-22_jpl94.abs'
 588       xsqy_tab(m)%filespec%nskip(1) = -1
 589       subr(m)%xsqy_sub   => r38
 590       m = m + 1
 591
 592       xsqy_tab(m)%label = 'HO2 -> OH + O'
 593       xsqy_tab(m)%wrf_label = 'j_ho2'
 594       xsqy_tab(m)%jndx  = m
 595       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HO2_jpl11.abs'
 596       xsqy_tab(m)%filespec%nskip(1) = 10
 597       xsqy_tab(m)%filespec%nread(1) = 15
 598       subr(m)%xsqy_sub   => r39
 599       m = m + 1
 600
 601       xsqy_tab(m)%label = 'CF2Br2 (Halon-1202) -> Products'
 602       xsqy_tab(m)%wrf_label = 'j_cf2bf2'
 603       xsqy_tab(m)%jndx  = m
 604       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Halon-1202_jpl97.abs'
 605       xsqy_tab(m)%filespec%nskip(1) = -1
 606       subr(m)%xsqy_sub   => no_z_dep
 607       m = m + 1
 608
 609       xsqy_tab(m)%label = 'CF2BrCl (Halon-1211) -> Products'
 610       xsqy_tab(m)%wrf_label = 'j_cf2brcl'
 611       xsqy_tab(m)%jndx  = m
 612       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Halon-1211_jpl97.abs'
 613       xsqy_tab(m)%filespec%nskip(1) = -1
 614       subr(m)%xsqy_sub   => no_z_dep
 615       m = m + 1
 616
 617       xsqy_tab(m)%label = 'CF3Br (Halon-1301) -> Products'
 618       xsqy_tab(m)%wrf_label = 'j_cf3br'
 619       xsqy_tab(m)%jndx  = m
 620       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Halon-1301_jpl97.abs'
 621       xsqy_tab(m)%filespec%nskip(1) = -1
 622       subr(m)%xsqy_sub   => no_z_dep
 623       m = m + 1
 624
 625       xsqy_tab(m)%label = 'CF2BrCF2Br (Halon-2402) -> Products'
 626       xsqy_tab(m)%wrf_label = 'j_cf2brcf2br'
 627       xsqy_tab(m)%jndx  = m
 628       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Halon-2402_jpl97.abs'
 629       xsqy_tab(m)%filespec%nskip(1) = -1
 630       subr(m)%xsqy_sub   => no_z_dep
 631       m = m + 1
 632
 633       xsqy_tab(m)%label = 'N2O -> N2 + O(1D)'
 634       xsqy_tab(m)%wrf_label = 'j_n2o'
 635       xsqy_tab(m)%jndx  = m
 636       xsqy_tab(m)%tpflag = 1
 637       subr(m)%xsqy_sub   => r44
 638       m = m + 1
 639
 640       xsqy_tab(m)%label   = 'ClONO2 -> Cl + NO3'
 641       xsqy_tab(m+1)%label = 'ClONO2 -> ClO + NO2'
 642       xsqy_tab(m)%wrf_label = 'j_clono2_a'
 643       xsqy_tab(m+1)%wrf_label = 'j_clono2_b'
 644       xsqy_tab(m)%jndx = m
 645       xsqy_tab(m+1)%channel = 2
 646       xsqy_tab(m:m+1)%tpflag = 1
 647       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClONO2_jpl97.abs'
 648       xsqy_tab(m)%filespec%nskip(1) = 2
 649       xsqy_tab(m)%filespec%nread(1) = 119
 650       subr(m)%xsqy_sub   => r45
 651       subr(m+1)%xsqy_sub => r45
 652       m = m + 2
 653
 654       xsqy_tab(m)%label   = 'BrONO2 -> BrO + NO2'
 655       xsqy_tab(m+1)%label = 'BrONO2 -> Br + NO3'
 656       xsqy_tab(m)%wrf_label = 'j_brono2_a'
 657       xsqy_tab(m+1)%wrf_label = 'j_brono2_b'
 658       xsqy_tab(m)%jndx = m
 659       xsqy_tab(m+1)%channel = 2
 660       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrONO2_jpl03.abs'
 661       xsqy_tab(m)%filespec%nskip(1) = 13
 662       xsqy_tab(m)%filespec%nread(1) = 61
 663       subr(m)%xsqy_sub   => r46
 664       subr(m+1)%xsqy_sub => r46
 665       m = m + 2
 666
 667       xsqy_tab(m)%label = 'Cl2 -> Cl + Cl'
 668       xsqy_tab(m)%wrf_label = 'j_cl2'
 669       xsqy_tab(m)%jndx  = m
 670       xsqy_tab(m)%tpflag = 1
 671       subr(m)%xsqy_sub   => r47
 672       m = m + 1
 673
 674       xsqy_tab(m)%label   = 'HOCH2CHO -> CH2OH + HCO'
 675       xsqy_tab(m+1)%label = 'HOCH2CHO -> CH3OH + CO'
 676       xsqy_tab(m+2)%label = 'HOCH2CHO -> CH2CHO + OH'
 677       xsqy_tab(m)%wrf_label = 'j_glyald_a'
 678       xsqy_tab(m+1)%wrf_label = 'j_glyald_b'
 679       xsqy_tab(m+2)%wrf_label = 'j_glyald_c'
 680       xsqy_tab(m)%jndx = m
 681       xsqy_tab(m+1:m+2)%channel = (/ 2,3 /)
 682       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH2OHCHO/glycolaldehyde_jpl11.abs'
 683       xsqy_tab(m)%filespec%nskip(1) = 2
 684       xsqy_tab(m)%filespec%nread(1) = 63
 685       subr(m)%xsqy_sub   => r101
 686       subr(m+1)%xsqy_sub => r101
 687       subr(m+2)%xsqy_sub => r101
 688       m = m + 3
 689
 690       xsqy_tab(m)%label = 'CH3COCOCH3 -> Products'
 691       xsqy_tab(m)%wrf_label = 'j_biacetyl'
 692       xsqy_tab(m)%qyld  = .158
 693       xsqy_tab(m)%jndx  = m
 694       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3COCOCH3/biacetyl_horowitz.abs'
 695       xsqy_tab(m)%filespec%nskip(1) = 8
 696       xsqy_tab(m)%filespec%nread(1) = 287
 697       subr(m)%xsqy_sub   => no_z_dep
 698       m = m + 1
 699
 700       xsqy_tab(m)%label = 'CH3COCH=CH2 -> Products'
 701       xsqy_tab(m)%wrf_label = 'j_mvk'
 702       xsqy_tab(m)%jndx  = m
 703       xsqy_tab(m)%tpflag = 2
 704       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/MVK_jpl11.abs'
 705       xsqy_tab(m)%filespec%nskip(1) = 2
 706       xsqy_tab(m)%filespec%nread(1) = 146
 707       subr(m)%xsqy_sub   => r103
 708       m = m + 1
 709
 710       xsqy_tab(m)%label = 'CH2=C(CH3)CHO -> Products'
 711       xsqy_tab(m)%wrf_label = 'j_macr'
 712       xsqy_tab(m)%qyld  = .01
 713       xsqy_tab(m)%jndx  = m
 714       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Methacrolein_jpl11.abs'
 715       xsqy_tab(m)%filespec%nskip(1) = 7
 716       xsqy_tab(m)%filespec%nread(1) = 146
 717       subr(m)%xsqy_sub   => no_z_dep
 718       m = m + 1
 719
 720       xsqy_tab(m)%label = 'CH3COCO(OH) -> Products'
 721       xsqy_tab(m)%wrf_label = 'j_ch3cocooh'
 722       xsqy_tab(m)%jndx  = m
 723       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3COCOOH/pyruvic_jpl11.abs'
 724       xsqy_tab(m)%filespec%nskip(1) = 2
 725       xsqy_tab(m)%filespec%nread(1) = 139
 726       subr(m)%xsqy_sub   => no_z_dep
 727       m = m + 1
 728
 729       xsqy_tab(m)%label = 'CH3CH2ONO2 -> CH3CH2O + NO2'
 730       xsqy_tab(m)%wrf_label = 'j_ch3ch2ono2'
 731       xsqy_tab(m)%jndx  = m
 732       xsqy_tab(m)%tpflag = 1
 733       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/RONO2_talukdar.abs'
 734       xsqy_tab(m)%filespec%nskip(1) = 10
 735       xsqy_tab(m)%filespec%nread(1) = 63
 736       subr(m)%xsqy_sub   => r106
 737       m = m + 1
 738
 739       xsqy_tab(m)%label = 'CH3CHONO2CH3 -> CH3CHOCH3 + NO2'
 740       xsqy_tab(m)%wrf_label = 'j_ch3chono2ch3'
 741       xsqy_tab(m)%jndx  = m
 742       xsqy_tab(m)%tpflag = 1
 743       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/RONO2_talukdar.abs'
 744       xsqy_tab(m)%filespec%nskip(1) = 10
 745       xsqy_tab(m)%filespec%nread(1) = 63
 746       subr(m)%xsqy_sub   => r107
 747       m = m + 1
 748
 749       xsqy_tab(m)%label = 'CH2(OH)CH2(ONO2) -> CH2(OH)CH2(O.) + NO2'
 750       xsqy_tab(m)%wrf_label = 'j_ch2ohch2ono2'
 751       xsqy_tab(m)%jndx  = m
 752       subr(m)%xsqy_sub   => r108
 753       m = m + 1
 754
 755       xsqy_tab(m)%label = 'CH3COCH2(ONO2) -> CH3COCH2(O.) + NO2'
 756       xsqy_tab(m)%wrf_label = 'j_ch3coch2ono2'
 757       xsqy_tab(m)%jndx  = m
 758       subr(m)%xsqy_sub   => r109
 759       m = m + 1
 760
 761       xsqy_tab(m)%label = 'C(CH3)3(ONO2) -> C(CH3)3(O.) + NO2'
 762       xsqy_tab(m)%wrf_label = 'j_bnit1'
 763       xsqy_tab(m)%jndx  = m
 764       subr(m)%xsqy_sub   => r110
 765       m = m + 1
 766
 767       xsqy_tab(m)%label = 'ClOOCl -> Cl + ClOO'
 768       xsqy_tab(m)%wrf_label = 'j_cloocl'
 769       xsqy_tab(m)%jndx  = m
 770       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClOOCl_jpl11.abs'
 771       xsqy_tab(m)%filespec%nskip(1) = 3
 772       xsqy_tab(m)%filespec%nread(1) = 111
 773       subr(m)%xsqy_sub   => no_z_dep
 774       m = m + 1
 775
 776       xsqy_tab(m)%label   = 'CH2(OH)COCH3 -> CH3CO + CH2(OH)'
 777       xsqy_tab(m+1)%label = 'CH2(OH)COCH3 -> CH2(OH)CO + CH3'
 778       xsqy_tab(m)%wrf_label = 'j_hyac_a'
 779       xsqy_tab(m+1)%wrf_label = 'j_hyac_b'
 780       xsqy_tab(m)%jndx = m
 781       xsqy_tab(m+1)%channel = 2
 782       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Hydroxyacetone_jpl11.abs'
 783       xsqy_tab(m)%filespec%nskip(1) = 2
 784       xsqy_tab(m)%filespec%nread(1) = 96
 785       subr(m)%xsqy_sub   => r112
 786       subr(m+1)%xsqy_sub => r112
 787       m = m + 2
 788
 789       xsqy_tab(m)%label = 'HOBr -> OH + Br'
 790       xsqy_tab(m)%wrf_label = 'j_hobr'
 791       xsqy_tab(m)%jndx  = m
 792       subr(m)%xsqy_sub   => r113
 793       m = m + 1
 794
 795       xsqy_tab(m)%label = 'BrO -> Br + O'
 796       xsqy_tab(m)%wrf_label = 'j_bro'
 797       xsqy_tab(m)%jndx  = m
 798       subr(m)%xsqy_sub   => r114
 799       m = m + 1
 800
 801       xsqy_tab(m)%label = 'Br2 -> Br + Br'
 802       xsqy_tab(m)%wrf_label = 'j_br2'
 803       xsqy_tab(m)%jndx  = m
 804       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Br2.abs'
 805       xsqy_tab(m)%filespec%nskip(1) = 6
 806       xsqy_tab(m)%filespec%nread(1) = 29
 807       xsqy_tab(m)%filespec%xfac(1)  = 1.
 808       subr(m)%xsqy_sub   => no_z_dep
 809       m = m + 1
 810
 811       xsqy_tab(m)%label   = 'NO3-(aq) -> NO2(aq) + O-'
 812       xsqy_tab(m+1)%label = 'NO3-(aq) -> NO2-(aq) + O(3P)'
 813       xsqy_tab(m+2)%label = 'NO3-(aq) with qy=1'
 814       xsqy_tab(m)%wrf_label = 'j_no3_aq_a'
 815       xsqy_tab(m+1)%wrf_label = 'j_no3_aq_b'
 816       xsqy_tab(m+2)%wrf_label = 'j_no3_aq_c'
 817       xsqy_tab(m)%jndx = m
 818       xsqy_tab(m+1:m+2)%channel = (/ 2,3 /)
 819       xsqy_tab(m)%tpflag = 1
 820       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/NO3-_CA03.abs'
 821       xsqy_tab(m)%filespec%nskip(1) = 7
 822       xsqy_tab(m)%filespec%nread(1) = 43
 823       subr(m)%xsqy_sub   => r118
 824       subr(m+1)%xsqy_sub => r118
 825       subr(m+2)%xsqy_sub => r118
 826       m = m + 3
 827
 828       xsqy_tab(m)%label = 'CH3COCH2CH3 -> CH3CO + CH2CH3'
 829       xsqy_tab(m)%wrf_label = 'j_mek'
 830       xsqy_tab(m)%jndx  = m
 831       xsqy_tab(m)%tpflag = 2
 832       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Martinez.abs'
 833       xsqy_tab(m)%filespec%nskip(1) = 4
 834       xsqy_tab(m)%filespec%nread(1) = 96
 835       subr(m)%xsqy_sub   => r119
 836       m = m + 1
 837
 838       xsqy_tab(m)%label   = 'CH3CH2CO(OONO2) -> CH3CH2CO(OO) + NO2'
 839       xsqy_tab(m+1)%label = 'CH3CH2CO(OONO2) -> CH3CH2CO(O) + NO3'
 840       xsqy_tab(m)%wrf_label = 'j_ppn_a'
 841       xsqy_tab(m+1)%wrf_label = 'j_ppn_b'
 842       xsqy_tab(m:m+1)%tpflag  = 1
 843       xsqy_tab(m)%jndx = m
 844       xsqy_tab(m+1)%channel = 2
 845       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/PPN_Harwood.txt'
 846       xsqy_tab(m)%filespec%nskip(1) = 10
 847       xsqy_tab(m)%filespec%nread(1) = 66
 848       subr(m)%xsqy_sub   => r120
 849       subr(m+1)%xsqy_sub => r120
 850       m = m + 2
 851
 852       xsqy_tab(m)%label = 'HOCH2OOH -> HOCH2O. + OH'
 853       xsqy_tab(m)%wrf_label = 'j_hoch2ooh'
 854       xsqy_tab(m)%jndx  = m
 855       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HOCH2OOH_jpl11.abs'
 856       xsqy_tab(m)%filespec%nskip(1) = 3
 857       xsqy_tab(m)%filespec%nread(1) = 32
 858       subr(m)%xsqy_sub   => no_z_dep
 859       m = m + 1
 860
 861       xsqy_tab(m)%label = 'CH2=CHCHO -> Products'
 862       xsqy_tab(m)%wrf_label = 'j_acrol'
 863       xsqy_tab(m)%jndx  = m
 864       xsqy_tab(m)%tpflag = 2
 865       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Acrolein.txt'
 866       xsqy_tab(m)%filespec%nskip(1) = 6
 867       xsqy_tab(m)%filespec%nread(1) = 55
 868       subr(m)%xsqy_sub   => r122
 869       m = m + 1
 870
 871       xsqy_tab(m)%label = 'CH3CO(OOH) -> Products'
 872       xsqy_tab(m)%wrf_label = 'j_ch3coooh'
 873       xsqy_tab(m)%jndx  = m
 874       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Peracetic_acid.txt'
 875       xsqy_tab(m)%filespec%nskip(1) = 6
 876       xsqy_tab(m)%filespec%nread(1) = 66
 877       subr(m)%xsqy_sub   => no_z_dep
 878       m = m + 1
 879
 880       xsqy_tab(m)%label = '(CH3)2NNO -> Products'
 881       xsqy_tab(m)%wrf_label = 'j_amine'
 882       xsqy_tab(m)%jndx  = m
 883       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/dmna.abs'
 884       xsqy_tab(m)%filespec%nskip(1) = 5
 885       xsqy_tab(m)%filespec%nread(1) = 132
 886       xsqy_tab(m)%filespec%xfac(1)  = 1.e-19
 887       subr(m)%xsqy_sub   => no_z_dep
 888       m = m + 1
 889
 890       xsqy_tab(m)%label   = 'ClO -> Cl + O(1D)'
 891       xsqy_tab(m+1)%label = 'ClO -> Cl + O(3P)'
 892       xsqy_tab(m)%wrf_label = 'j_clo_a'
 893       xsqy_tab(m+1)%wrf_label = 'j_clo_b'
 894       xsqy_tab(m)%jndx = m
 895       xsqy_tab(m+1)%channel = 2
 896       xsqy_tab(m:m+1)%tpflag = 1
 897       subr(m)%xsqy_sub   => r125
 898       subr(m+1)%xsqy_sub => r125
 899       m = m + 2
 900
 901       xsqy_tab(m)%label = 'ClNO2 -> Cl + NO2'
 902       xsqy_tab(m)%wrf_label = 'j_clno2'
 903       xsqy_tab(m)%jndx  = m
 904       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClNO2.abs'
 905       xsqy_tab(m)%filespec%nskip(1) = 2
 906       xsqy_tab(m)%filespec%nread(1) = 26
 907       subr(m)%xsqy_sub   => no_z_dep
 908       m = m + 1
 909
 910       xsqy_tab(m)%label = 'BrNO -> Br + NO'
 911       xsqy_tab(m)%wrf_label = 'j_brno'
 912       xsqy_tab(m)%jndx  = m
 913       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrNO.abs'
 914       xsqy_tab(m)%filespec%nskip(1) = 3
 915       xsqy_tab(m)%filespec%nread(1) = 27
 916       xsqy_tab(m)%filespec%xfac(1)  = 1.
 917       subr(m)%xsqy_sub   => no_z_dep
 918       m = m + 1
 919
 920       xsqy_tab(m)%label = 'BrNO2 -> Br + NO2'
 921       xsqy_tab(m)%wrf_label = 'j_brno2'
 922       xsqy_tab(m)%jndx  = m
 923       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrNO2.abs'
 924       xsqy_tab(m)%filespec%nskip(1) = 6
 925       xsqy_tab(m)%filespec%nread(1) = 54
 926       xsqy_tab(m)%filespec%xfac(1)  = 1.
 927       subr(m)%xsqy_sub   => no_z_dep
 928       m = m + 1
 929
 930       xsqy_tab(m)%label   = 'BrONO -> Br + NO2'
 931       xsqy_tab(m+1)%label = 'BrONO -> BrO + NO'
 932       xsqy_tab(m)%wrf_label = 'j_brono_a'
 933       xsqy_tab(m+1)%wrf_label = 'j_brono_b'
 934       xsqy_tab(m)%jndx = m
 935       xsqy_tab(m+1)%channel = 2
 936       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrONO.abs'
 937       xsqy_tab(m)%filespec%nskip(1) = 8
 938       xsqy_tab(m)%filespec%nread(1) = 32
 939       subr(m)%xsqy_sub   => r129
 940       subr(m+1)%xsqy_sub => r129
 941       m = m + 2
 942
 943       xsqy_tab(m)%label = 'HOCl -> HO + Cl'
 944       xsqy_tab(m)%wrf_label = 'j_hocl'
 945       xsqy_tab(m)%jndx  = m
 946       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HOCl.abs'
 947       xsqy_tab(m)%filespec%nskip(1) = 7
 948       xsqy_tab(m)%filespec%nread(1) = 111
 949       xsqy_tab(m)%filespec%xfac(1)  = 1.
 950       subr(m)%xsqy_sub   => no_z_dep
 951       m = m + 1
 952
 953       xsqy_tab(m)%label = 'NOCl -> NO + Cl'
 954       xsqy_tab(m)%wrf_label = 'j_nocl'
 955       xsqy_tab(m)%jndx  = m
 956       xsqy_tab(m)%tpflag = 1
 957       xsqy_tab(m)%filespec%nfiles = 2
 958       xsqy_tab(m)%filespec%filename(1:2) = 'DATAJ1/ABS/NOCl.abs'
 959       xsqy_tab(m)%filespec%nskip(1:2) = (/ 7,88 /)
 960       xsqy_tab(m)%filespec%nread(1:2) = (/ 80,61 /)
 961       subr(m)%xsqy_sub   => r131
 962       m = m + 1
 963
 964       xsqy_tab(m)%label = 'OClO -> Products'
 965       xsqy_tab(m)%wrf_label = 'j_oclo'
 966       xsqy_tab(m)%jndx  = m
 967       xsqy_tab(m)%tpflag = 1
 968       xsqy_tab(m)%filespec%nfiles      = 3
 969       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/OClO.abs'
 970       xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/ABS/OClO.abs'
 971       xsqy_tab(m)%filespec%filename(3) = 'DATAJ1/ABS/OClO.abs'
 972       xsqy_tab(m)%filespec%nskip(1:3) = (/ 6,1075,2142 /)
 973       xsqy_tab(m)%filespec%nread(1:3) = (/ 1068,1067,1068 /)
 974       subr(m)%xsqy_sub   => r132
 975       m = m + 1
 976
 977       xsqy_tab(m)%label = 'BrCl -> Br + Cl'
 978       xsqy_tab(m)%wrf_label = 'j_brcl'
 979       xsqy_tab(m)%jndx  = m
 980       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrCl.abs'
 981       xsqy_tab(m)%filespec%nskip(1) = 9
 982       xsqy_tab(m)%filespec%nread(1) = 81
 983       xsqy_tab(m)%filespec%xfac(1)  = 1.
 984       subr(m)%xsqy_sub   => no_z_dep
 985       m = m + 1
 986
 987       xsqy_tab(m)%label = 'CH3(OONO2) -> CH3(OO) + NO2'
 988       xsqy_tab(m)%wrf_label = 'j_ch3oono2'
 989       xsqy_tab(m)%jndx  = m
 990       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3OONO2.abs'
 991       xsqy_tab(m)%filespec%nskip(1) = 9
 992       xsqy_tab(m)%filespec%nread(1) = 26
 993       xsqy_tab(m)%filespec%xfac(1)  = 1.
 994       subr(m)%xsqy_sub   => no_z_dep
 995       m = m + 1
 996
 997       xsqy_tab(m)%label = 'C(CH3)3(ONO) -> C(CH3)3(O) + NO'
 998       xsqy_tab(m)%wrf_label = 'j_bnit2'
 999       xsqy_tab(m)%jndx  = m
1000       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/t-butyl-nitrite.abs'
1001       xsqy_tab(m)%filespec%nskip(1) = 4
1002       xsqy_tab(m)%filespec%nread(1) = 96
1003       xsqy_tab(m)%filespec%xfac(1)  = 1.
1004       subr(m)%xsqy_sub   => no_z_dep
1005       m = m + 1
1006
1007       xsqy_tab(m)%label = 'ClONO -> Cl + NO2'
1008       xsqy_tab(m)%wrf_label = 'j_clono'
1009       xsqy_tab(m)%jndx  = m
1010       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClONO_jpl11.abs'
1011       xsqy_tab(m)%filespec%nskip(1) = 3
1012       xsqy_tab(m)%filespec%nread(1) = 34
1013       subr(m)%xsqy_sub   => no_z_dep
1014       m = m + 1
1015
1016       xsqy_tab(m)%label = 'HCl -> H + Cl'
1017       xsqy_tab(m)%wrf_label = 'j_hcl'
1018       xsqy_tab(m)%jndx  = m
1019       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HCl_jpl11.abs'
1020       xsqy_tab(m)%filespec%nskip(1) = 3
1021       xsqy_tab(m)%filespec%nread(1) = 31
1022       subr(m)%xsqy_sub   => no_z_dep
1023       m = m + 1
1024
1025       xsqy_tab(m)%label   = 'CH2O -> H + HCO'
1026       xsqy_tab(m+1)%label = 'CH2O -> H2 + CO'
1027       xsqy_tab(m)%wrf_label = 'j_ch2o_r'
1028       xsqy_tab(m+1)%wrf_label = 'j_ch2o_m'
1029       xsqy_tab(m)%jndx = m
1030       xsqy_tab(m+1)%channel = 2
1031       xsqy_tab(m:m+1)%tpflag = (/ 1,3 /)
1032       xsqy_tab(m)%filespec%nfiles = 2
1033       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH2O/CH2O_jpl11.abs'
1034       xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/CH2O/CH2O_jpl11.yld'
1035       xsqy_tab(m)%filespec%nskip(1:2) = 4
1036       xsqy_tab(m)%filespec%nread(1:2) = (/ 150,112 /)
1037       subr(m)%xsqy_sub    => pxCH2O
1038       subr(m+1)%xsqy_sub  => pxCH2O
1039       m = m + 2
1040
1041       xsqy_tab(m)%label = 'CH3COOH -> CH3 + COOH'
1042       xsqy_tab(m)%wrf_label = 'j_ch3cooh'
1043       xsqy_tab(m)%qyld  = .55
1044       xsqy_tab(m)%jndx  = m
1045       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3COOH_jpl11.abs'
1046       xsqy_tab(m)%filespec%nskip(1) = 2
1047       xsqy_tab(m)%filespec%nread(1) = 18
1048       subr(m)%xsqy_sub   => no_z_dep
1049       m = m + 1
1050
1051       xsqy_tab(m)%label = 'CH3OCl -> CH3O + Cl'
1052       xsqy_tab(m)%wrf_label = 'j_ch3ocl'
1053       xsqy_tab(m)%jndx  = m
1054       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3OCl_jpl11.abs'
1055       xsqy_tab(m)%filespec%nskip(1) = 3
1056       xsqy_tab(m)%filespec%nread(1) = 83
1057       subr(m)%xsqy_sub   => no_z_dep
1058       m = m + 1
1059
1060       xsqy_tab(m)%label = 'CHCl3 -> Products'
1061       xsqy_tab(m)%wrf_label = 'j_chcl3'
1062       xsqy_tab(m)%jndx  = m
1063       xsqy_tab(m)%tpflag = 1
1064       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CHCl3_jpl11.abs'
1065       xsqy_tab(m)%filespec%nskip(1) = 3
1066       xsqy_tab(m)%filespec%nread(1) = 39
1067       subr(m)%xsqy_sub   => r140
1068       m = m + 1
1069
1070       xsqy_tab(m)%label = 'C2H5ONO2 -> C2H5O + NO2'
1071       xsqy_tab(m)%wrf_label = 'j_c2h5ono2'
1072       xsqy_tab(m)%jndx  = m
1073       xsqy_tab(m)%tpflag = 1
1074       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/C2H5ONO2_iup2006.abs'
1075       xsqy_tab(m)%filespec%nskip(1) = 4
1076       xsqy_tab(m)%filespec%nread(1) = 32
1077       subr(m)%xsqy_sub   => r141
1078       m = m + 1
1079
1080       xsqy_tab(m)%label = 'n-C3H7ONO2 -> C3H7O + NO2'
1081       xsqy_tab(m)%wrf_label = 'j_nc3h7ono2'
1082       xsqy_tab(m)%jndx  = m
1083       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/nC3H7ONO2_iup2006.abs'
1084       xsqy_tab(m)%filespec%nskip(1) = 3
1085       xsqy_tab(m)%filespec%nread(1) = 32
1086       subr(m)%xsqy_sub   => no_z_dep
1087       m = m + 1
1088
1089       xsqy_tab(m)%label = '1-C4H9ONO2 -> 1-C4H9O + NO2'
1090       xsqy_tab(m)%wrf_label = 'j_1c4h9ono2'
1091       xsqy_tab(m)%jndx  = m
1092       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/1C4H9ONO2_iup2006.abs'
1093       xsqy_tab(m)%filespec%nskip(1) = 3
1094       xsqy_tab(m)%filespec%nread(1) = 32
1095       subr(m)%xsqy_sub   => no_z_dep
1096       m = m + 1
1097
1098       xsqy_tab(m)%label = '2-C4H9ONO2 -> 2-C4H9O + NO2'
1099       xsqy_tab(m)%wrf_label = 'j_2c4h9ono2'
1100       xsqy_tab(m)%jndx  = m
1101       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/2C4H9ONO2_iup2006.abs'
1102       xsqy_tab(m)%filespec%nskip(1) = 3
1103       xsqy_tab(m)%filespec%nread(1) = 15
1104       subr(m)%xsqy_sub   => no_z_dep
1105       m = m + 1
1106
1107       xsqy_tab(m)%label = 'perfluoro 1-iodopropane -> products'
1108       xsqy_tab(m)%wrf_label = 'j_perfluoro'
1109       xsqy_tab(m)%jndx  = m
1110       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/PF-n-iodopropane.abs'
1111       xsqy_tab(m)%filespec%nskip(1) = 2
1112       xsqy_tab(m)%filespec%nread(1) = 16
1113       subr(m)%xsqy_sub   => no_z_dep
1114       m = m + 1
1115
1116       xsqy_tab(m)%label = 'I2 -> I + I'
1117       xsqy_tab(m)%wrf_label = 'j_i2'
1118       xsqy_tab(m)%jndx  = m
1119       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/YLD/I2.qy'
1120       xsqy_tab(m)%filespec%nskip(1) = 4
1121       xsqy_tab(m)%filespec%nread(1) = 12
1122       subr(m)%xsqy_sub   => r146
1123       m = m + 1
1124
1125       xsqy_tab(m)%label = 'IO -> I + O'
1126       xsqy_tab(m)%wrf_label = 'j_io'
1127       xsqy_tab(m)%jndx  = m
1128       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/IO_jpl11.abs'
1129       xsqy_tab(m)%filespec%nskip(1) = 2
1130       xsqy_tab(m)%filespec%nread(1) = 133
1131       subr(m)%xsqy_sub   => no_z_dep
1132       m = m + 1
1133
1134       xsqy_tab(m)%label = 'IOH -> I + OH'
1135       xsqy_tab(m)%wrf_label = 'j_ioh'
1136       xsqy_tab(m)%jndx  = m
1137       xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/IOH_jpl11.abs'
1138       xsqy_tab(m)%filespec%nskip(1) = 2
1139       xsqy_tab(m)%filespec%nread(1) = 101
1140       subr(m)%xsqy_sub   => no_z_dep
1141
1142       end subroutine setup_sub_calls
1143
1144 !-----------------------------------------------------------------------------*
1145 !=  *** ALL the following subroutines have the following arguments
1146 !=  *** except for the routines:
1147 !=      rxn_init, base_read, readit, add_pnts_inter2
1148 !=                                                                           =*
1149 !=  PARAMETERS:                                                              =*
1150 !=  NW     - INTEGER, number of specified intervals + 1 in working        (I)=*
1151 !=           wavelength grid                                                 =*
1152 !=  WL     - REAL, vector of lower limits of wavelength intervals in      (I)=*
1153 !=           working wavelength grid                                         =*
1154 !=  WC     - REAL, vector of center points of wavelength intervals in     (I)=*
1155 !=           working wavelength grid                                         =*
1156 !=  NZ     - INTEGER, number of altitude levels in working altitude grid  (I)=*
1157 !=  TLEV   - REAL, temperature (K) at each specified altitude level       (I)=*
1158 !=  AIRDEN - REAL, air density (molec/cc) at each altitude level          (I)=*
1159 !=  J      - INTEGER, counter for number of weighting functions defined  (IO)=*
1160 !=  SQ     - REAL, cross section x quantum yield (cm^2) for each          (O)=*
1161 !=           photolysis reaction defined, at each defined wavelength and     =*
1162 !=           at each defined altitude level                                  =*
1163 !=  JLABEL - CHARACTER(len=50) ::, string identifier for each photolysis  (O)=*
1164 !=           reaction defined                                                =*
1165 !-----------------------------------------------------------------------------*
1166
1167       SUBROUTINE r01(nw,wl,wc,nz,tlev,airden,j)
1168 !-----------------------------------------------------------------------------*
1169 !=  PURPOSE:                                                                 =*
1170 !=  Provide the product of (cross section) x (quantum yield) for the two     =*
1171 !=  O3 photolysis reactions:                                                 =*
1172 !=             (a) O3 + hv -> O2 + O(1D)                                     =*
1173 !=             (b) O3 + hv -> O2 + O(3P)                                     =*
1174 !=  Cross section:  Combined data from WMO 85 Ozone Assessment (use 273K     =*
1175 !=                  value from 175.439-847.5 nm) and data from Molina and    =*
1176 !=                  Molina (use in Hartley and Huggins bans (240.5-350 nm)   =*
1177 !=  Quantum yield:  Choice between                                           =*
1178 !=                   (1) data from Michelsen et al, 1994                     =*
1179 !=                   (2) JPL 87 recommendation                               =*
1180 !=                   (3) JPL 90/92 recommendation (no "tail")                =*
1181 !=                   (4) data from Shetter et al., 1996                      =*
1182 !=                   (5) JPL 97 recommendation                               =*
1183 !=                   (6) JPL 00 recommendation                               =*
1184 !-----------------------------------------------------------------------------*
1185
1186       use module_xsections, only : o3xs
1187
1188 ! input
1189
1190       INTEGER, intent(in) :: nw
1191       INTEGER, intent(in) :: nz
1192       REAL, intent(in)    :: wl(kw), wc(kw)
1193       REAL, intent(in)    :: tlev(kz)
1194       REAL, intent(in)    :: airden(kz)
1195
1196       INTEGER, intent(inout) :: j
1197
1198 ! local
1199
1200       INTEGER :: iw
1201       REAL    :: xs(nz,nw-1)
1202       REAL    :: qy1d(nz)
1203
1204       if( .not. initialize ) then
1205         call check_alloc( j, nz, nw-1 )
1206
1207 ! call cross section read/interpolate routine
1208 ! cross sections from WMO 1985 Ozone Assessment
1209 ! from 175.439 to 847.500 nm. Using value at 273 K.
1210 ! Values are over-written in Hartly and Huggins bands, using different
1211 ! options depending on value of mopt:
1212
1213 !     mabs = 1 = mostly Reims grp (Malicet, Brion)
1214 !     mabs = 2 = JPL 2006
1215
1216         CALL o3xs(nz,tlev,nw,wl, xs)
1217
1218 !****** quantum yield:
1219 ! choose quantum yield recommendation:
1220 !    kjpl87:  JPL recommendation 1987                - JPL 87, 90, 92 do not "tail"
1221 !    kjpl92:  JPL recommendations 1990/92 (identical) - still with no "tail"
1222 !    kjpl97:  JPL recommendation 1997, includes tail, similar to Shetter et al.
1223 !    kmich :  Michelsen et al., 1994
1224 !    kshet :  Shetter et al., 1996
1225 !    kjpl00:  JPL 2000
1226 !    kmats:  Matsumi et al., 2002
1227
1228 ! compute cross sections and yields at different wavelengths, altitudes:
1229         DO iw = 1, nw-1
1230 ! quantum yields, Matsumi et al.
1231           CALL fo3qy2(nz,wc(iw),tlev,qy1d)
1232           if( xsqy_tab(j)%channel == 2 ) then
1233             qy1d(1:nz) = (1. - qy1d(1:nz))
1234           endif
1235           xsqy_tab(j)%sq(1:nz,iw) = qy1d(1:nz)*xs(1:nz,iw)
1236         END DO
1237       endif
1238
1239       END SUBROUTINE r01
1240
1241 !=============================================================================*
1242
1243       SUBROUTINE r02(nw,wl,wc,nz,tlev,airden,j)
1244 !-----------------------------------------------------------------------------*
1245 !=  PURPOSE:                                                                 =*
1246 !=  Provide the product (cross section) x (quantum yield) for NO2            =*
1247 !=  photolysis:                                                              =*
1248 !=         NO2 + hv -> NO + O(3P)                                            =*
1249 !=  Cross section from JPL94 (can also have Davidson et al.)                 =*
1250 !=  Quantum yield from Gardiner, Sperry, and Calvert                         =*
1251 !-----------------------------------------------------------------------------*
1252
1253       use module_xsections, only : no2xs_jpl06a
1254
1255       INTEGER, intent(in) :: nw
1256       INTEGER, intent(in) :: nz
1257       INTEGER, intent(inout) :: j
1258       REAL, intent(in)    :: wl(kw), wc(kw)
1259       REAL, intent(in)    :: tlev(kz)
1260       REAL, intent(in)    :: airden(kz)
1261
1262
1263 ! data arrays
1264       INTEGER, parameter :: kdata = 200
1265
1266       REAL x1(kdata)
1267       REAL y1(kdata), y2(kdata)
1268
1269 ! local
1270       REAL, save :: yg1(kw), ydel(kw)
1271       REAL :: yg2(kw)
1272       REAL :: qy(nz)
1273       REAL :: t(nz)
1274       REAL :: no2xs(nz,nw-1)
1275       INTEGER :: i, iw, n, idum, ierr
1276       CHARACTER(len=256) :: msg
1277
1278 !*************** NO2 photodissociation
1279
1280       if( initialize ) then
1281         CALL readit
1282         ydel(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1)
1283       else
1284         call check_alloc( j, nz, nw-1 )
1285
1286 ! options for NO2 cross section:
1287 ! 1 = Davidson et al. (1988), indepedent of T
1288 ! 2 = JPL 1994 (same as JPL 1997, JPL 2002)
1289 ! 3 = Harder et al.
1290 ! 4 = JPL 2006, interpolating between midpoints of bins
1291 ! 5 = JPL 2006, bin-to-bin interpolation
1292
1293 !     mabs = 4
1294
1295         CALL no2xs_jpl06a(nz,tlev,nw,wl, no2xs)
1296
1297 ! quantum yields
1298 !     myld = 1   NO2_calvert.yld  (same as JPL2002)
1299 !     myld = 2   NO2_jpl11.yld (same as jpl2006)
1300
1301 !     myld = 2
1302
1303 ! from jpl 2011
1304
1305         t(1:nz) = .02*(tlev(1:nz) - 298.)
1306         DO iw = 1, nw - 1
1307           qy(1:nz) = yg1(iw) + ydel(iw)*t(1:nz)
1308           xsqy_tab(j)%sq(1:nz,iw) = no2xs(1:nz,iw)*max( qy(1:nz),0. )
1309         ENDDO
1310       endif
1311
1312       CONTAINS
1313
1314       SUBROUTINE readit
1315
1316       integer :: nsav
1317       real    :: xsav(kdata)
1318
1319       n = 25 ; nsav = 25
1320       CALL base_read( filespec='DATAJ1/YLD/NO2_jpl11.yld', &
1321                       skip_cnt=2,rd_cnt=n,x=x1,y=y1,y1=y2 )
1322       xsav(1:n) = x1(1:n)
1323       CALL add_pnts_inter2(x1,y1,yg1,kdata,n, &
1324                            nw,wl,xsqy_tab(j)%label,deltax,(/y1(1),0./))
1325       n = nsav
1326       x1(1:n) = xsav(1:n)
1327       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
1328                            nw,wl,xsqy_tab(j)%label,deltax,(/y2(1),0./))
1329
1330       END SUBROUTINE readit
1331
1332       END SUBROUTINE r02
1333
1334 !=============================================================================*
1335
1336       SUBROUTINE r03(nw,wl,wc,nz,tlev,airden,j)
1337
1338 !-----------------------------------------------------------------------------*
1339 !=  PURPOSE:                                                                 =*
1340 !=  Provide the product (absorptioon cross section) x (quantum yield) for    =*
1341 !=  both channels of NO3 photolysis:                                         =*
1342 !=          (a) NO3 + hv -> NO2 + O(3P)                                      =*
1343 !=          (b) NO3 + hv -> NO + O2                                          =*
1344 !=  Cross section combined from Graham and Johnston (<600 nm) and JPL 94     =*
1345 !=  Quantum yield from Madronich (1988)                                      =*
1346 !-----------------------------------------------------------------------------*
1347
1348       INTEGER, intent(in) :: nw
1349       INTEGER, intent(in) :: nz
1350       INTEGER, intent(inout) :: j
1351       REAL, intent(in)    :: wl(kw), wc(kw)
1352       REAL, intent(in)    :: tlev(kz)
1353       REAL, intent(in)    :: airden(kz)
1354
1355 ! data arrays
1356       INTEGER, PARAMETER :: kdata=350
1357
1358       REAL x(kdata), x1(kdata)
1359       REAL y1(kdata)
1360       real q1_298(kdata), q1_230(kdata), q1_190(kdata)
1361       real q2_298(kdata), q2_230(kdata), q2_190(kdata)
1362       real :: sq_wrk(nz)
1363
1364 ! local
1365       real, parameter :: tfac1 = 1./(230. - 190.)
1366       real, parameter :: tfac2 = 1./(298. - 230.)
1367
1368       REAL :: qy, qy1, qy2, xsect
1369       REAL, save :: yg1(kw)
1370       real, save :: yg_298(kw,2), yg_230(kw,2), yg_190(kw,2)
1371       real, save :: delabs(kw,2,2)
1372       real :: t(nz)
1373
1374       INTEGER i, iw, iz, n, idum, chnl
1375       INTEGER ierr
1376       LOGICAL, save :: is_initialized = .false.
1377
1378       if( initialize ) then
1379         if( .not. is_initialized ) then
1380 ! yields from JPL2011:
1381           CALL readit
1382           delabs(1:nw-1,1,1) = yg_230(1:nw-1,1) - yg_190(1:nw-1,1)
1383           delabs(1:nw-1,2,1) = yg_298(1:nw-1,1) - yg_230(1:nw-1,1)
1384           delabs(1:nw-1,1,2) = yg_230(1:nw-1,2) - yg_190(1:nw-1,2)
1385           delabs(1:nw-1,2,2) = yg_298(1:nw-1,2) - yg_230(1:nw-1,2)
1386           is_initialized = .true.
1387         endif
1388       else
1389         call check_alloc( j, nz, nw-1 )
1390
1391 ! mabs = 3:  JPL11
1392 !     mabs = 3
1393 ! myld = 2  from JPL-2011
1394 !     myld = 2
1395
1396 ! compute T-dependent quantum yields
1397         chnl = xsqy_tab(j)%channel
1398         DO iw = 1, nw-1
1399           xsect = yg1(iw)
1400           where(tlev(1:nz) <= 190. )
1401             sq_wrk(1:nz) = yg_190(iw,chnl)*xsect
1402           elsewhere(tlev(1:nz) > 190. .and. tlev(1:nz) <= 230. )
1403             t(1:nz) = tfac1*(tlev(1:nz) - 190.)
1404             sq_wrk(1:nz) = yg_190(iw,chnl) + delabs(iw,1,chnl)*t(1:nz)
1405           elsewhere(tlev(1:nz) > 230. .and. tlev(1:nz) <= 298. )
1406             t(1:nz) = tfac2*(tlev(1:nz) - 230.)
1407             sq_wrk(1:nz) = yg_230(iw,chnl) + delabs(iw,2,chnl)*t(1:nz)
1408           elsewhere(tlev(1:nz) > 298. )
1409             sq_wrk(1:nz) = yg_298(iw,chnl)
1410           endwhere
1411           xsqy_tab(j)%sq(1:nz,iw) = sq_wrk(1:nz)*xsect
1412         ENDDO
1413       endif
1414
1415       CONTAINS
1416
1417       SUBROUTINE readit
1418
1419       integer :: nsav
1420       real    :: xsav(kdata)
1421
1422       n = 289
1423       CALL base_read( filespec='DATAJ1/ABS/NO3_jpl11.abs', &
1424                       skip_cnt=6,rd_cnt=n,x=x1,y=y1 )
1425       y1(1:n) = y1(1:n)*1.E-20
1426       CALL add_pnts_inter2(x1,y1,yg1,kdata,n, &
1427                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
1428
1429       n = 56 ; nsav = 56
1430       CALL base_read( filespec='DATAJ1/YLD/NO3_jpl2011.qy', &
1431                       skip_cnt=5,rd_cnt=n,x=x,y=q1_298, &
1432                       y1=q1_230,y2=q1_190,y3=q2_298, &
1433                       y4=q2_230,y5=q2_190 )
1434       xsav(1:n) = x(1:n)
1435       q1_298(1:n) = q1_298(1:n)*.001
1436       q1_230(1:n) = q1_230(1:n)*.001
1437       q1_190(1:n) = q1_190(1:n)*.001
1438       q2_298(1:n) = q2_298(1:n)*.001
1439       q2_230(1:n) = q2_230(1:n)*.001
1440       q2_190(1:n) = q2_190(1:n)*.001
1441
1442       CALL add_pnts_inter2(x,q1_298,yg_298,kdata,n, &
1443                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
1444       n = nsav ; x(1:n) = xsav(1:n)
1445       CALL add_pnts_inter2(x,q1_230,yg_230,kdata,n, &
1446                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
1447       n = nsav ; x(1:n) = xsav(1:n)
1448       CALL add_pnts_inter2(x,q1_190,yg_190,kdata,n, &
1449                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
1450
1451       n = nsav ; x(1:n) = xsav(1:n)
1452       CALL add_pnts_inter2(x,q2_298,yg_298(1,2),kdata,n, &
1453                            nw,wl,xsqy_tab(j)%label,deltax,(/1.,0./))
1454       n = nsav ; x(1:n) = xsav(1:n)
1455       CALL add_pnts_inter2(x,q2_230,yg_230(1,2),kdata,n, &
1456                            nw,wl,xsqy_tab(j)%label,deltax,(/1.,0./))
1457       n = nsav ; x(1:n) = xsav(1:n)
1458       CALL add_pnts_inter2(x,q2_190,yg_190(1,2),kdata,n, &
1459                            nw,wl,xsqy_tab(j)%label,deltax,(/1.,0./))
1460
1461       END SUBROUTINE readit
1462
1463       END SUBROUTINE r03
1464
1465 !=============================================================================*
1466
1467       SUBROUTINE r04(nw,wl,wc,nz,tlev,airden,j)
1468 !-----------------------------------------------------------------------------*
1469 !=  PURPOSE:                                                                 =*
1470 !=  Provide product of (cross section) x (quantum yiels) for N2O5 photolysis =*
1471 !=  reactions:                                                               =*
1472 !=       (a) N2O5 + hv -> NO3 + NO + O(3P)                                   =*
1473 !=       (b) N2O5 + hv -> NO3 + NO2                                          =*
1474 !=  Cross section from JPL2011: use tabulated values for 300K, correct for   =*
1475 !=  temperature.
1476 !=  Quantum yield: Analysis of data in JPL94 (->DATAJ1/YLD/N2O5.qy)          =*
1477 !-----------------------------------------------------------------------------*
1478
1479       INTEGER, intent(in) :: nw
1480       INTEGER, intent(in) :: nz
1481       INTEGER, intent(inout) :: j
1482       REAL, intent(in)    :: wl(kw), wc(kw)
1483       REAL, intent(in)    :: tlev(kz)
1484       REAL, intent(in)    :: airden(kz)
1485
1486 ! data arrays
1487       INTEGER, PARAMETER :: kdata = 200
1488
1489       REAL x1(kdata), x2(kdata)
1490       REAL y1(kdata), A(kdata), B(kdata)
1491       INTEGER :: n, n1, n2
1492
1493 ! local
1494       INTEGER :: iw
1495       REAL    :: xs
1496       REAL, save :: yg1(kw), yg2(kw)
1497       REAL    :: dum(nz)
1498       REAL    :: t(nz)
1499       LOGICAL, save :: is_initialized = .false.
1500
1501       if( initialize ) then
1502         if( .not. is_initialized ) then
1503           CALL readit
1504           is_initialized = .true.
1505         endif
1506       else
1507         call check_alloc( j, nz, nw-1 )
1508         if( xsqy_tab(j)%channel == 1 ) then
1509           DO iw = 1,nw-1
1510             xsqy_tab(j)%sq(1:nz,iw) = 0.
1511           ENDDO
1512         elseif( xsqy_tab(j)%channel == 2 ) then
1513 ! temperature dependence only valid for 233 - 295 K.  Extend to 300.
1514           t(1:nz) = MAX(233.,MIN(tlev(1:nz),300.))
1515
1516           DO iw = 1, nw - 1
1517 ! Apply temperature correction to 300K values. Do not use A-coefficients
1518 ! because they are inconsistent with the values at 300K.
1519 ! quantum yield = 1 for NO2 + NO3, zero for other channels
1520             dum(1:nz) = 1000.*yg2(iw)*(300. - t(1:nz))/(300.*t(1:nz))
1521             xsqy_tab(j)%sq(1:nz,iw) = yg1(iw) * 10.**(dum(1:nz))
1522           ENDDO
1523         endif
1524       endif
1525
1526       CONTAINS
1527
1528       SUBROUTINE readit
1529 ! cross section from jpl2011, at 300 K
1530
1531       n1 = 103
1532       CALL base_read( filespec='DATAJ1/ABS/N2O5_jpl11.abs', &
1533                       skip_cnt=4,rd_cnt=n1,x=x1,y=y1 )
1534       y1(1:n1) = y1(1:n1) * 1.E-20
1535       CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, &
1536                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
1537
1538 ! read temperature dependence coefficients:
1539       n2 = 8
1540       CALL base_read( filespec='DATAJ1/ABS/N2O5_jpl11.abs', &
1541                       skip_cnt=111,rd_cnt=n2,x=x2,y=A,y1=B )
1542
1543       CALL add_pnts_inter2(x2,B,yg2,kdata,n2, &
1544                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
1545
1546       END SUBROUTINE readit
1547
1548       END SUBROUTINE r04
1549
1550 !=============================================================================*
1551
1552       SUBROUTINE r06(nw,wl,wc,nz,tlev,airden,j)
1553 !-----------------------------------------------------------------------------*
1554 !=  PURPOSE:                                                                 =*
1555 !=  Provide product of (cross section) x (quantum yield) for HNO3 photolysis =*
1556 !=        HNO3 + hv -> OH + NO2                                              =*
1557 !=  Cross section: Burkholder et al., 1993                                   =*
1558 !=  Quantum yield: Assumed to be unity                                       =*
1559 !-----------------------------------------------------------------------------*
1560
1561       INTEGER, intent(in) :: nw
1562       INTEGER, intent(in) :: nz
1563       INTEGER, intent(inout) :: j
1564       REAL, intent(in)    :: wl(kw), wc(kw)
1565       REAL, intent(in)    :: tlev(kz)
1566       REAL, intent(in)    :: airden(kz)
1567
1568 ! data arrays
1569       integer, PARAMETER :: kdata=100
1570
1571       INTEGER n1
1572       REAL x1(kdata), x2(kdata)
1573       REAL y1(kdata), y2(kdata)
1574
1575 ! local
1576       real :: t(nz)
1577       REAL, save :: yg1(kw), yg2(kw)
1578       INTEGER i, iw
1579       INTEGER ierr
1580
1581       if( initialize ) then
1582         CALL readit
1583       else
1584         call check_alloc( j, nz, nw-1 )
1585 ! quantum yield = 1
1586 ! correct for temperature dependence
1587         t(1:nz) = tlev(1:nz) - 298.
1588         DO iw = 1, nw - 1
1589           xsqy_tab(j)%sq(1:nz,iw) = yg1(iw) * exp( yg2(iw)*t(1:nz) )
1590         ENDDO
1591       endif
1592
1593       CONTAINS
1594
1595       SUBROUTINE readit
1596 ! HNO3 cross section parameters from Burkholder et al. 1993
1597
1598       integer :: nsav
1599       real    :: xsav(kdata)
1600       real    :: yends(2)
1601
1602       n1 =  83 ; nsav = 83
1603       CALL base_read( filespec='DATAJ1/ABS/HNO3_burk.abs', &
1604                       skip_cnt=6,rd_cnt=n1,x=y1,y=y2 )
1605
1606       x1(1:n1) = (/ (184. + real(i)*2.,i=1,n1) /)
1607       xsav(1:n1) = x1(1:n1)
1608
1609       y1(1:n1) = y1(1:n1) * 1.e-20
1610       CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, &
1611                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
1612
1613       y2(1:n1) = y2(1:n1) * 1.e-3
1614       yends(:) = (/ y2(1),y2(n1) /)
1615       n1 = nsav ; x1(1:n1) = xsav(1:n1)
1616       CALL add_pnts_inter2(x1,y2,yg2,kdata,n1, &
1617                            nw,wl,xsqy_tab(j)%label,deltax,yends)
1618
1619       END SUBROUTINE readit
1620
1621       END SUBROUTINE r06
1622
1623 !=============================================================================*
1624
1625       SUBROUTINE r08(nw,wl,wc,nz,tlev,airden,j)
1626 !-----------------------------------------------------------------------------*
1627 !=  PURPOSE:                                                                 =*
1628 !=  Provide product of (cross section) x (quantum yield) for H2O2 photolysis =*
1629 !=         H2O2 + hv -> 2 OH                                                 =*
1630 !=  Cross section:  From JPL97, tabulated values @ 298K for <260nm, T-depend.=*
1631 !=                  parameterization for 260-350nm                           =*
1632 !=  Quantum yield:  Assumed to be unity                                      =*
1633 !-----------------------------------------------------------------------------*
1634
1635       INTEGER, intent(in) :: nw
1636       INTEGER, intent(in) :: nz
1637       INTEGER, intent(inout) :: j
1638       REAL, intent(in)    :: wl(kw), wc(kw)
1639       REAL, intent(in)    :: tlev(kz)
1640       REAL, intent(in)    :: airden(kz)
1641
1642 ! data arrays
1643       integer, PARAMETER :: kdata=600
1644
1645       REAL x1(kdata)
1646       REAL y1(kdata)
1647
1648 ! local
1649       real, parameter :: A0 = 6.4761E+04
1650       real, parameter :: A1 = -9.2170972E+02
1651       real, parameter :: A2 = 4.535649
1652       real, parameter :: A3 = -4.4589016E-03
1653       real, parameter :: A4 = -4.035101E-05
1654       real, parameter :: A5 = 1.6878206E-07
1655       real, parameter :: A6 = -2.652014E-10
1656       real, parameter :: A7 = 1.5534675E-13
1657
1658       real, parameter :: B0 = 6.8123E+03
1659       real, parameter :: B1 = -5.1351E+01
1660       real, parameter :: B2 = 1.1522E-01
1661       real, parameter :: B3 = -3.0493E-05
1662       real, parameter :: B4 = -1.0924E-07
1663
1664       INTEGER i, iw, n, idum
1665       INTEGER ierr
1666       REAL lambda
1667       REAL sumA, sumB
1668       REAL :: t(nz)
1669       REAL :: chi(nz)
1670       REAL, save :: yg(kw)
1671
1672 ! cross section from Lin et al. 1978
1673
1674       if( initialize ) then
1675         CALL readit
1676       else
1677         call check_alloc( j, nz, nw-1 )
1678 ! quantum yield = 1
1679         t(1:nz) = MIN(MAX(tlev(1:nz),200.),400.)
1680         chi(1:nz) = 1./(1. + EXP(-1265./t(1:nz)))
1681         DO iw = 1, nw - 1
1682 ! Parameterization (JPL94)
1683 ! Range 260-350 nm; 200-400 K
1684            IF ((wl(iw) .GE. 260.) .AND. (wl(iw) .LT. 350.)) THEN
1685              lambda = wc(iw)
1686              sumA = ((((((A7*lambda + A6)*lambda + A5)*lambda +  &
1687                           A4)*lambda +A3)*lambda + A2)*lambda +  &
1688                           A1)*lambda + A0
1689              sumB = (((B4*lambda + B3)*lambda + B2)*lambda +  &
1690                        B1)*lambda + B0
1691
1692              xsqy_tab(j)%sq(1:nz,iw) = &
1693                  (chi(1:nz) * sumA + (1. - chi(1:nz))*sumB)*1.E-21
1694            ELSE
1695              xsqy_tab(j)%sq(1:nz,iw) = yg(iw)
1696            ENDIF
1697         ENDDO
1698       endif
1699
1700       CONTAINS
1701
1702       SUBROUTINE readit
1703 ! cross section from JPL94 (identical to JPL97)
1704 ! tabulated data up to 260 nm
1705
1706       integer :: n1
1707
1708       CALL base_read( filespec='DATAJ1/ABS/H2O2_jpl94.abs', &
1709                       rd_cnt=n,x=x1,y=y1 )
1710       y1(1:n) = y1(1:n) * 1.E-20
1711
1712       n1 = 494
1713       CALL base_read( filespec='DATAJ1/ABS/H2O2_Kahan.abs', &
1714                       skip_cnt=0,rd_cnt=n1,x=x1(n+1:),y=y1(n+1:) )
1715
1716       n = n + n1
1717       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
1718                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
1719
1720       END SUBROUTINE readit
1721
1722       END SUBROUTINE r08
1723
1724 !=============================================================================*
1725
1726       SUBROUTINE r09(nw,wl,wc,nz,tlev,airden,j)
1727 !-----------------------------------------------------------------------------*
1728 !=  PURPOSE:                                                                 =*
1729 !=  Provide product of (cross section) x (quantum yield) for CHBr3 photolysis=*
1730 !=          CHBr3 + hv -> Products                                           =*
1731 !=  Cross section: Choice of data from Atlas (?Talukdar???) or JPL97         =*
1732 !=  Quantum yield: Assumed to be unity                                       =*
1733 !-----------------------------------------------------------------------------*
1734
1735       INTEGER, intent(in) :: nw
1736       INTEGER, intent(in) :: nz
1737       INTEGER, intent(inout) :: j
1738       REAL, intent(in)    :: wl(kw), wc(kw)
1739       REAL, intent(in)    :: tlev(kz)
1740       REAL, intent(in)    :: airden(kz)
1741
1742 ! data arrays
1743       integer, PARAMETER :: kdata=200
1744
1745       INTEGER n1
1746       REAL x1(kdata)
1747       REAL y1(kdata)
1748
1749 ! local
1750       REAL, save :: yg(kw)
1751       real :: t(nz)
1752
1753       INTEGER i, iw, n
1754       INTEGER ierr
1755       INTEGER iz
1756
1757       if( initialize ) then
1758         CALL readit
1759       else
1760         call check_alloc( j, nz, nw-1 )
1761
1762 ! option:
1763
1764 ! kopt = 1:  cross section from Elliot Atlas, 1997
1765 ! kopt = 2:  cross section from JPL 1997
1766 !     kopt = 2
1767
1768 ! quantum yield = 1
1769
1770         t(1:nz) = 273. - tlev(1:nz)
1771         DO iw = 1, nw - 1
1772           IF (wc(iw) .GT. 290. .AND. wc(iw) .LT. 340. ) then
1773             where( tlev(1:nz) > 210. .AND. tlev(1:nz) < 300. )
1774               xsqy_tab(j)%sq(1:nz,iw) = &
1775                    EXP( (.06183 - .000241*wc(iw))*t(1:nz) &
1776                              - (2.376 + 0.14757*wc(iw)) )
1777             elsewhere
1778               xsqy_tab(j)%sq(1:nz,iw) = yg(iw)
1779             endwhere
1780           ELSE
1781             xsqy_tab(j)%sq(1:nz,iw) = yg(iw)
1782           ENDIF
1783         ENDDO
1784       endif
1785
1786       CONTAINS
1787
1788       SUBROUTINE readit
1789 ! jpl97, with temperature dependence formula,
1790 !w = 290 nm to 340 nm,
1791 !T = 210K to 300 K
1792 !sigma, cm2 = exp((0.06183-0.000241*w)*(273.-T)-(2.376+0.14757*w))
1793
1794       n1 = 87
1795       CALL base_read( filespec='DATAJ1/ABS/CHBr3.jpl97', &
1796                       skip_cnt=6,rd_cnt=n1,x=x1,y=y1 )
1797
1798       y1(1:n1) = y1(1:n1) * 1.e-20
1799       CALL add_pnts_inter2(x1,y1,yg,kdata,n1, &
1800                            nw,wl,xsqy_tab(j)%label,deltax,(/y1(1),0./))
1801
1802       END SUBROUTINE readit
1803
1804       END SUBROUTINE r09
1805
1806 !=============================================================================*
1807
1808       SUBROUTINE r11(nw,wl,wc,nz,tlev,airden,j)
1809 !-----------------------------------------------------------------------------*
1810 !=  PURPOSE:                                                                 =*
1811 !=  Provide product (cross section) x (quantum yield) for CH3CHO photolysis: =*
1812 !=      (a)  CH3CHO + hv -> CH3 + HCO                                        =*
1813 !=      (b)  CH3CHO + hv -> CH4 + CO                                         =*
1814 !=      (c)  CH3CHO + hv -> CH3CO + H                                        =*
1815 !=  Cross section:  Choice between                                           =*
1816 !=                   (1) IUPAC 97 data, from Martinez et al.                 =*
1817 !=                   (2) Calvert and Pitts                                   =*
1818 !=                   (3) Martinez et al., Table 1 scanned from paper         =*
1819 !=                   (4) KFA tabulations                                     =*
1820 !=  Quantum yields: Choice between                                           =*
1821 !=                   (1) IUPAC 97, pressure correction using Horowith and    =*
1822 !=                                 Calvert, 1982                             =*
1823 !=                   (2) NCAR data file, from Moortgat, 1986                 =*
1824 !-----------------------------------------------------------------------------*
1825
1826       INTEGER, intent(in) :: nw
1827       INTEGER, intent(in) :: nz
1828       INTEGER, intent(inout) :: j
1829       REAL, intent(in)    :: wl(kw), wc(kw)
1830       REAL, intent(in)    :: tlev(kz)
1831       REAL, intent(in)    :: airden(kz)
1832
1833 ! data arrays
1834       integer, PARAMETER :: kdata=150
1835
1836       INTEGER i, n
1837       INTEGER n1, n2
1838       REAL x1(kdata), x2(kdata)
1839       REAL y1(kdata), y2(kdata)
1840
1841 ! local
1842       INTEGER :: m, ierr
1843       INTEGER :: iw
1844       INTEGER :: chnl
1845       REAL    :: qy2, qy3
1846       REAL    :: sig
1847       REAL    :: dum
1848       REAL    :: qy1_n0, qy1_0, x
1849       REAL, save :: yg(kw), yg1(kw), yg2(kw), yg3(kw)
1850       REAL :: qy1(nz)
1851       LOGICAL, save :: is_initialized = .false.
1852
1853       chnl = xsqy_tab(j)%channel
1854       if( initialize ) then
1855         if( .not. is_initialized ) then
1856           CALL readit
1857           is_initialized = .true.
1858         endif
1859         if( chnl > 1 ) then
1860           call check_alloc( ndx=j, nz=nw-1, nw=1 )
1861           if( chnl == 2 ) then
1862             xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * yg2(1:nw-1)
1863           elseif( chnl == 3 ) then
1864             xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * yg3(1:nw-1)
1865           endif
1866         endif
1867       else
1868         if( xsqy_tab(j)%channel == 1 ) then
1869           call check_alloc( j, nz, nw-1 )
1870 !     mabs = 5
1871 !     myld = 1
1872           DO iw = 1, nw - 1
1873             sig = yg(iw)
1874 ! quantum yields:
1875 ! input yields at n0 = 1 atm
1876             qy1_n0 = yg1(iw)
1877 ! Pressure correction for CH3 + CHO channel:
1878 ! Assume pressure-dependence only for qy1, not qy2 or qy2.
1879 ! Assume total yield 1 at zero pressure
1880             qy1_0 = 1. - (yg2(iw) + yg3(iw))
1881
1882 !  compute coefficient:
1883 !  Stern-Volmer:  1/q = 1/q0 + k N  and N0 = 1 atm,
1884 !  then x = K N0 q0 = qy_0/qy_N0 - 1
1885             if (qy1_n0 > 0.) then
1886               x = qy1_0/qy1_n0 - 1.
1887             else
1888               x = 0.
1889             endif
1890
1891             qy1(1:nz) = qy1_n0 * (1. + x) / (1. + x * airden(1:nz)/2.465E19)
1892             qy1(1:nz) = MIN( 1.,MAX(0.,qy1(1:nz)) )
1893             xsqy_tab(j)%sq(1:nz,iw) = sig * qy1(1:nz)
1894           ENDDO
1895         endif
1896       endif
1897
1898       CONTAINS
1899
1900       SUBROUTINE readit
1901
1902       integer :: nsav
1903       real    :: xsav(kdata)
1904
1905       n = 101
1906       CALL base_read( filespec='DATAJ1/CH3CHO/CH3CHO_jpl11.abs', &
1907                       skip_cnt=2,rd_cnt=n,x=x1,y=y1 )
1908       y1(1:n) = y1(1:n) * 1.e-20
1909
1910       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
1911                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
1912
1913 ! quantum yields
1914
1915       n = 12 ; nsav = 12
1916       CALL base_read( filespec='DATAJ1/CH3CHO/CH3CHO_iup.yld', &
1917                       skip_cnt=4,rd_cnt=n,x=x1,y=y2,y1=y1 )
1918       xsav(1:n) = x1(1:n)
1919
1920       CALL add_pnts_inter2(x1,y1,yg1,kdata,n, &
1921                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
1922       n = nsav
1923       x1(1:n) = xsav(1:n)
1924       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
1925                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
1926
1927       yg3(1:nw-1) = 0.
1928
1929       END SUBROUTINE readit
1930
1931       END SUBROUTINE r11
1932
1933 !=============================================================================*
1934
1935       SUBROUTINE r12(nw,wl,wc,nz,tlev,airden,j)
1936 !-----------------------------------------------------------------------------*
1937 !=  PURPOSE:                                                                 =*
1938 !=  Provide the product (cross section) x (quantum yield) for C2H5CHO        =*
1939 !=  photolysis:                                                              =*
1940 !=         C2H5CHO + hv -> C2H5 + HCO                                        =*
1941 !=                                                                           =*
1942 !=  Cross section:  Choice between                                           =*
1943 !=                   (1) IUPAC 97 data, from Martinez et al.                 =*
1944 !=                   (2) Calvert and Pitts, as tabulated by KFA              =*
1945 !=  Quantum yield:  IUPAC 97 recommendation                                  =*
1946 !-----------------------------------------------------------------------------*
1947
1948       INTEGER, intent(in) :: nw
1949       INTEGER, intent(in) :: nz
1950       INTEGER, intent(inout) :: j
1951       REAL, intent(in)    :: wl(kw), wc(kw)
1952       REAL, intent(in)    :: tlev(kz)
1953       REAL, intent(in)    :: airden(kz)
1954
1955       integer, PARAMETER :: kdata=150
1956
1957       INTEGER i, n
1958       INTEGER n1
1959       REAL x1(kdata)
1960       REAL y1(kdata)
1961
1962 ! local
1963       REAL, save :: yg(kw), yg1(kw)
1964       REAL :: qy1(nz)
1965       REAL sig
1966       INTEGER ierr
1967       INTEGER iw
1968
1969       if( initialize ) then
1970         CALL readit
1971       else
1972         call check_alloc( j, nz, nw-1 )
1973
1974 ! Absorption:
1975 ! 1:  IUPAC-97 data, from Martinez et al.
1976 ! 2:  Calvert and Pitts, as tabulated by KFA.
1977
1978 ! Quantum yield
1979 ! 1:  IUPAC-97 data
1980
1981 !     mabs = 1
1982 !     myld = 1
1983
1984         DO iw = 1, nw - 1
1985 ! quantum yields:
1986 ! use Stern-Volmer pressure dependence:
1987           IF (yg1(iw) .LT. pzero) THEN
1988             xsqy_tab(j)%sq(1:nz,iw) = 0.
1989           ELSE
1990             qy1(1:nz) = 1./(1. + (1./yg1(iw) - 1.)*airden(1:nz)/2.45e19)
1991             qy1(1:nz) = MIN(qy1(1:nz),1.)
1992             xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * qy1(1:nz)
1993           ENDIF
1994         ENDDO
1995       endif
1996
1997       CONTAINS
1998
1999       SUBROUTINE readit
2000
2001       character(len=256) :: emsg
2002
2003       n = 106
2004       CALL base_read( filespec='DATAJ1/C2H5CHO/C2H5CHO_iup.abs', &
2005                       skip_cnt=4,rd_cnt=n,x=x1,y=y1 )
2006       y1(1:n) = y1(1:n) * 1.e-20
2007
2008       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
2009                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2010
2011 ! quantum yields
2012
2013       n = 5
2014       CALL base_read( filespec='DATAJ1/C2H5CHO/C2H5CHO_iup.yld', &
2015                       skip_cnt=4,rd_cnt=n,x=x1,y=y1 )
2016
2017       CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
2018       CALL addpnt(x1,y1,kdata,n,               0.,0.)
2019       CALL addpnt(x1,y1,kdata,n,340.,0.)
2020       CALL addpnt(x1,y1,kdata,n,           1.e+38,0.)
2021       CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
2022       IF (ierr .NE. 0) THEN
2023         write(emsg,'(''readit: Error '',i5,'' in inter2 for '',a)') ierr,trim(xsqy_tab(j)%label)
2024         call wrf_error_fatal( trim(emsg) )
2025       ENDIF
2026
2027       END SUBROUTINE readit
2028
2029       END SUBROUTINE r12
2030
2031 !=============================================================================*
2032
2033       SUBROUTINE r13(nw,wl,wc,nz,tlev,airden,j)
2034 !-----------------------------------------------------------------------------*
2035 !=  PURPOSE:                                                                 =*
2036 !=  Provide the product (cross section) x (quantum yield) for CHOCHO         =*
2037 !=  photolysis:                                                              =*
2038 !=              CHOCHO + hv -> Products                                      =*
2039 !=                                                                           =*
2040 !=  Cross section: Choice between                                            =*
2041 !=                  (1) Plum et al., as tabulated by IUPAC 97                =*
2042 !=                  (2) Plum et al., as tabulated by KFA.                    =*
2043 !=                  (3) Orlando et al.                                       =*
2044 !=                  (4) Horowitz et al., 2001                                =*
2045 !=  Quantum yield: IUPAC 97 recommendation                                   =*
2046 !-----------------------------------------------------------------------------*
2047
2048       INTEGER, intent(in) :: nw
2049       INTEGER, intent(in) :: nz
2050       INTEGER, intent(inout) :: j
2051       REAL, intent(in)    :: wl(kw), wc(kw)
2052       REAL, intent(in)    :: tlev(kz)
2053       REAL, intent(in)    :: airden(kz)
2054
2055 ! data arrays
2056       integer, PARAMETER :: kdata=500
2057
2058       INTEGER i, n
2059       REAL x(kdata), x1(kdata)
2060       REAL y1(kdata), y2(kdata), y3(kdata)
2061
2062 ! local
2063       REAL, save :: yg(kw), yg1(kw), yg2(kw), yg3(kw)
2064       INTEGER :: ierr
2065       LOGICAL, save :: is_initialized = .false.
2066
2067 !     mabs = 5
2068 !     myld = 2
2069
2070       if( initialize ) then
2071         if( .not. is_initialized ) then
2072           CALL readit
2073           is_initialized = .true.
2074         endif
2075         call check_alloc( ndx=j, nz=nw-1, nw=1 )
2076         if( xsqy_tab(j)%channel == 1 ) then
2077           xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * yg1(1:nw-1)
2078         elseif( xsqy_tab(j)%channel == 2 ) then
2079           xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * yg2(1:nw-1)
2080         elseif( xsqy_tab(j)%channel == 3 ) then
2081           xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * yg3(1:nw-1)
2082         endif
2083       endif
2084
2085       CONTAINS
2086
2087       SUBROUTINE readit
2088
2089       integer :: nsav
2090       real :: dum(kdata)
2091       real :: xsav(kdata)
2092       real :: yends(2)
2093
2094       n = 277
2095       CALL base_read( filespec='DATAJ1/CHOCHO/glyoxal_jpl11.abs', &
2096                       skip_cnt=2,rd_cnt=n,x=x1,y=y1 )
2097       y1(1:n) = y1(1:n) * 1.e-20
2098       yends(:) = 0.
2099       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
2100                            nw,wl,xsqy_tab(j)%label,deltax,yends)
2101
2102 ! quantum yields
2103
2104       n = 40 ; nsav = 40
2105       CALL base_read( filespec='DATAJ1/CHOCHO/glyoxal_jpl11.qy', &
2106                       skip_cnt=3,rd_cnt=n,x=x,y=dum,y1=y1,y2=y2,y3=y3 )
2107       xsav(1:n) = x(1:n)
2108       yends(1) = y1(1)
2109       CALL add_pnts_inter2(x,y1,yg1,kdata,n, &
2110                            nw,wl,xsqy_tab(j)%label,deltax,yends)
2111       n = nsav ; x(1:n) = xsav(1:n)
2112       yends(1) = y2(1)
2113       CALL add_pnts_inter2(x,y2,yg2,kdata,n, &
2114                            nw,wl,xsqy_tab(j)%label,deltax,yends)
2115       n = nsav ; x(1:n) = xsav(1:n)
2116       yends(1) = y3(1)
2117       CALL add_pnts_inter2(x,y3,yg3,kdata,n, &
2118                            nw,wl,xsqy_tab(j)%label,deltax,yends)
2119
2120       END SUBROUTINE readit
2121
2122       END SUBROUTINE r13
2123
2124 !=============================================================================*
2125
2126       SUBROUTINE r14(nw,wl,wc,nz,tlev,airden,j)
2127 !-----------------------------------------------------------------------------*
2128 !=  PURPOSE:                                                                 =*
2129 !=  Provide the product (cross section) x (quantum yield) for CH3COCHO       =*
2130 !=  photolysis:                                                              =*
2131 !=           CH3COCHO + hv -> CH3CO + HCO                                    =*
2132 !-----------------------------------------------------------------------------*
2133
2134       INTEGER, intent(in) :: nw
2135       INTEGER, intent(in) :: nz
2136       INTEGER, intent(inout) :: j
2137       REAL, intent(in)    :: wl(kw), wc(kw)
2138       REAL, intent(in)    :: tlev(kz)
2139       REAL, intent(in)    :: airden(kz)
2140
2141 ! data arrays
2142       integer, PARAMETER :: kdata=500
2143
2144       INTEGER i, n
2145       INTEGER n1, n2
2146       REAL x1(kdata)
2147       REAL y1(kdata)
2148
2149 ! local
2150       REAL, save :: yg(kw)
2151       REAL qy
2152       REAL sig
2153       INTEGER ierr
2154       INTEGER iw
2155       REAL phi0, kq
2156
2157       if( initialize ) then
2158         CALL readit
2159       else
2160         call check_alloc( j, nz, nw-1 )
2161
2162 !     mabs = 8
2163 !     myld = 5
2164
2165         DO iw = 1, nw - 1
2166           sig = yg(iw)
2167 ! quantum yields:
2168 ! zero pressure yield:
2169 ! 1.0 for wc < 380 nm
2170 ! 0.0 for wc > 440 nm
2171 ! linear in between:
2172           phi0 = 1. - (wc(iw) - 380.)/60.
2173           phi0 = MIN(MAX(0.,phi0),1.)
2174
2175 ! Pressure correction: quenching coefficient, torr-1
2176 ! in air, Koch and Moortgat:
2177           kq = 1.36e8 * EXP(-8793./wc(iw))
2178 ! in N2, Chen et al:
2179           IF(phi0 .GT. 0.) THEN
2180             IF (wc(iw) .GE. 380. .AND. wc(iw) .LE. 440.) THEN
2181               xsqy_tab(j)%sq(1:nz,iw) = sig * phi0 &
2182                   / (phi0 + kq * airden(1:nz) * 760./2.456E19)
2183             ELSE
2184               xsqy_tab(j)%sq(1:nz,iw) = sig * phi0
2185             ENDIF
2186           ELSE
2187             xsqy_tab(j)%sq(1:nz,iw) = 0.
2188           ENDIF
2189         ENDDO
2190       endif
2191
2192       CONTAINS
2193
2194       SUBROUTINE readit
2195
2196       n = 294
2197       CALL base_read( filespec='DATAJ1/CH3COCHO/CH3COCHO_jpl11.abs', &
2198                       skip_cnt=2,rd_cnt=n,x=x1,y=y1 )
2199       y1(1:n) = y1(1:n) * 1.e-20
2200       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
2201                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2202
2203       END SUBROUTINE readit
2204
2205       END SUBROUTINE r14
2206
2207 !=============================================================================*
2208
2209       SUBROUTINE r15(nw,wl,wc,nz,tlev,airden,j)
2210 !-----------------------------------------------------------------------------*
2211 !=  PURPOSE:                                                                 =*
2212 !=  Provide product (cross section) x (quantum yield) for CH3COCH3 photolysis=*
2213 !=          CH3COCH3 + hv -> Products                                        =*
2214 !-----------------------------------------------------------------------------*
2215
2216       INTEGER, intent(in) :: nw
2217       INTEGER, intent(in) :: nz
2218       INTEGER, intent(inout) :: j
2219       REAL, intent(in)    :: wl(kw), wc(kw)
2220       REAL, intent(in)    :: tlev(kz)
2221       REAL, intent(in)    :: airden(kz)
2222
2223       integer, PARAMETER :: kdata=150
2224
2225       INTEGER :: i, n
2226       REAL x1(kdata)
2227       REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata)
2228
2229 ! local
2230       REAL, save :: yg(kw), yg2(kw), yg3(kw)
2231       REAL :: qy(nz)
2232       REAL :: sig(nz)
2233       REAL :: T(nz)
2234       real :: fac(nz)
2235       INTEGER ierr
2236       INTEGER iw
2237
2238       if( initialize ) then
2239         CALL readit
2240       else
2241         call check_alloc( j, nz, nw-1 )
2242
2243 !     mabs = 4
2244 !     myld = 4
2245
2246         T(1:nz) = MIN(MAX(tlev(1:nz), 235.),298.)
2247         DO iw = 1, nw - 1
2248           sig(1:nz) = yg(iw) * (1. + t(1:nz)*(yg2(iw) + t(1:nz)*yg3(iw)))
2249           CALL qyacet(nz, wc(iw), tlev, airden, fac)
2250           xsqy_tab(j)%sq(1:nz,iw) = sig(1:nz)*min(max(0.,fac(1:nz)),1.)
2251         ENDDO
2252       endif
2253
2254       CONTAINS
2255
2256       SUBROUTINE readit
2257
2258       integer :: nsav
2259       real    :: xsav(kdata)
2260
2261       n = 135 ; nsav = 135
2262       CALL base_read( filespec='DATAJ1/CH3COCH3/CH3COCH3_jpl11.abs', &
2263                       skip_cnt=5,rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3,y3=y4 )
2264       y1(1:n) = y1(1:n) * 1.e-20
2265       y2(1:n) = y2(1:n) * 1.e-3
2266       y3(1:n) = y3(1:n) * 1.e-5
2267       xsav(1:n) = x1(1:n)
2268
2269       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
2270                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2271       n = nsav ; x1(1:n) = xsav(1:n)
2272       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
2273                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2274       n = nsav ; x1(1:n) = xsav(1:n)
2275       CALL add_pnts_inter2(x1,y3,yg3,kdata,n, &
2276                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2277
2278       END SUBROUTINE readit
2279
2280       END SUBROUTINE r15
2281
2282 !=============================================================================*
2283
2284       SUBROUTINE r17(nw,wl,wc,nz,tlev,airden,j)
2285 !-----------------------------------------------------------------------------*
2286 !=  PURPOSE:                                                                 =*
2287 !=  Provide product (cross section) x (quantum yield) for CH3ONO2            =*
2288 !=  photolysis:                                                              =*
2289 !=          CH3ONO2 + hv -> CH3O + NO2                                       =*
2290 !-----------------------------------------------------------------------------*
2291
2292       INTEGER, intent(in) :: nw
2293       INTEGER, intent(in) :: nz
2294       INTEGER, intent(inout) :: j
2295       REAL, intent(in)    :: wl(kw), wc(kw)
2296       REAL, intent(in)    :: tlev(kz)
2297       REAL, intent(in)    :: airden(kz)
2298
2299       integer, PARAMETER :: kdata = 100
2300
2301       INTEGER i, n
2302       INTEGER iw
2303       INTEGER n1, n2
2304       REAL :: x1(kdata)
2305       REAL :: y1(kdata), y2(kdata)
2306
2307 ! local
2308       REAL, save :: yg(kw), yg1(kw)
2309       REAL :: qy
2310       REAL :: sig
2311       REAL :: T(nz)
2312       INTEGER ierr
2313
2314       if( initialize ) then
2315         CALL readit
2316       else
2317         call check_alloc( j, nz, nw-1 )
2318
2319 !     mabs = 9
2320 ! quantum yield = 1
2321
2322         T(1:nz) = tlev(1:nz) - 298.
2323         DO iw = 1, nw - 1
2324           xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * exp( yg1(iw) * T(1:nz) )
2325         ENDDO
2326       endif
2327
2328       CONTAINS
2329
2330       SUBROUTINE readit
2331
2332       integer :: nsav
2333       real    :: xsav(kdata)
2334
2335       n = 65 ; nsav = 65
2336       CALL base_read( filespec='DATAJ1/RONO2/CH3ONO2_jpl11.abs', &
2337                       skip_cnt=2,rd_cnt=n,x=x1,y=y1,y1=y2 )
2338       y1(1:n) = y1(1:n) * 1.e-20
2339       y2(1:n) = y2(1:n) * 1.e-3
2340       xsav(1:n) = x1(1:n)
2341       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
2342                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2343       n = nsav ; x1(1:n) = xsav(1:n)
2344       CALL add_pnts_inter2(x1,y2,yg1,kdata,n, &
2345                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2346
2347       END SUBROUTINE readit
2348
2349       END SUBROUTINE r17
2350
2351 !=============================================================================*
2352
2353       SUBROUTINE r18(nw,wl,wc,nz,tlev,airden,j)
2354 !-----------------------------------------------------------------------------*
2355 !=  PURPOSE:                                                                 =*
2356 !=  Provide product (cross section) x (quantum yield) for PAN photolysis:    =*
2357 !=       PAN + hv -> Products                                                =*
2358 !=                                                                           =*
2359 !=  Cross section: from Talukdar et al., 1995                                =*
2360 !=  Quantum yield: Assumed to be unity                                       =*
2361 !-----------------------------------------------------------------------------*
2362
2363       INTEGER, intent(in) :: nw
2364       INTEGER, intent(in) :: nz
2365       INTEGER, intent(inout) :: j
2366       REAL, intent(in)    :: wl(kw), wc(kw)
2367       REAL, intent(in)    :: tlev(kz)
2368       REAL, intent(in)    :: airden(kz)
2369
2370 ! data arrays
2371       integer, PARAMETER :: kdata=100
2372
2373       INTEGER iw
2374       INTEGER n
2375       REAL :: x1(kdata)
2376       REAL :: y1(kdata), y2(kdata)
2377
2378 ! local
2379
2380 ! quantum yield:
2381 ! from JPL 2011 values for >300 nm.
2382 !     real, parameter :: qyNO2 = .7
2383 !     real, parameter :: qyNO3 = .3
2384       real, parameter :: qyld(2) = (/ .7,.3 /)
2385
2386       INTEGER :: ierr, chnl
2387       REAL, save :: yg(kw), yg2(kw)
2388       REAL :: sig(nz), T(nz)
2389       LOGICAL, save :: is_initialized = .false.
2390
2391       if( initialize ) then
2392         if( .not. is_initialized ) then
2393           CALL readit
2394           is_initialized = .true.
2395         endif
2396       else
2397         call check_alloc( j, nz, nw-1 )
2398
2399         chnl = xsqy_tab(j)%channel
2400         T(1:nz) = tlev(1:nz) - 298.
2401         DO iw = 1, nw-1
2402           sig(1:nz) = yg(iw) * EXP( yg2(iw)*T(1:nz) )
2403           xsqy_tab(j)%sq(1:nz,iw) = qyld(chnl) * sig(1:nz)
2404         ENDDO
2405       endif
2406
2407       CONTAINS
2408
2409       SUBROUTINE readit
2410 ! cross section from
2411 !      Talukdar et al., 1995, J.Geophys.Res. 100/D7, 14163-14174
2412
2413       integer :: nsav
2414       real    :: xsav(kdata)
2415
2416       n = 78 ; nsav = 78
2417       CALL base_read( filespec='DATAJ1/RONO2/PAN_talukdar.abs', &
2418                       skip_cnt=14,rd_cnt=n,x=x1,y=y1,y1=y2 )
2419       y1(1:n) = y1(1:n) * 1.E-20
2420       y2(1:n) = y2(1:n) * 1.E-3
2421       xsav(1:n) = x1(1:n)
2422
2423       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
2424                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2425       n = nsav ; x1(1:n) = xsav(1:n)
2426       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
2427                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2428
2429       END SUBROUTINE readit
2430
2431       END SUBROUTINE r18
2432
2433 !=============================================================================*
2434
2435       SUBROUTINE r20(nw,wl,wc,nz,tlev,airden,j)
2436 !-----------------------------------------------------------------------------*
2437 !=  PURPOSE:                                                                 =*
2438 !=  Provide product (cross section) x (quantum yield) for CCl4 photolysis:   =*
2439 !=      CCl4 + hv -> Products                                                =*
2440 !=  Cross section: from JPL 97 recommendation                                =*
2441 !=  Quantum yield: assumed to be unity                                       =*
2442 !-----------------------------------------------------------------------------*
2443
2444       INTEGER, intent(in) :: nw
2445       INTEGER, intent(in) :: nz
2446       INTEGER, intent(inout) :: j
2447       REAL, intent(in)    :: wl(kw), wc(kw)
2448       REAL, intent(in)    :: tlev(kz)
2449       REAL, intent(in)    :: airden(kz)
2450
2451 ! data arrays
2452       integer, PARAMETER :: kdata=100
2453
2454       REAL x1(kdata)
2455       REAL y1(kdata)
2456
2457 ! local
2458       real, parameter :: b0 = 1.0739
2459       real, parameter :: b1 = -1.6275e-2
2460       real, parameter :: b2 = 8.8141e-5
2461       real, parameter :: b3 = -1.9811e-7
2462       real, parameter :: b4 = 1.5022e-10
2463
2464       REAL, save :: yg(kw)
2465       INTEGER i, iw, n, idum
2466       INTEGER :: ierr
2467       REAL :: tcoeff, sig
2468       REAL :: w1
2469       REAL :: temp(nz)
2470
2471       if( initialize ) then
2472         CALL readit
2473       else
2474         call check_alloc( j, nz, nw-1 )
2475
2476 ! mabs = 1:  jpl 1997 recommendation
2477 ! mabs = 2:  jpl 2011 recommendation, with T dependence
2478
2479 !     mabs = 2
2480
2481 ! compute temperature correction factors:
2482
2483 !** quantum yield assumed to be unity
2484
2485         temp(1:nz) = min(max(tlev(1:nz),210.),300.)
2486         temp(1:nz) = temp(1:nz) - 295.
2487         DO iw = 1, nw-1
2488 ! compute temperature correction coefficients:
2489            tcoeff = 0.
2490            IF(wc(iw) .GT. 194. .AND. wc(iw) .LT. 250.) THEN
2491              w1 = wc(iw)
2492              tcoeff = b0 + w1*(b1 + w1*(b2 + w1*(b3 + w1*b4)))
2493            ENDIF
2494            xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * 10.**(tcoeff*temp(1:nz))
2495         ENDDO
2496       endif
2497
2498       CONTAINS
2499
2500       SUBROUTINE readit
2501 !** cross sections from JPL97 recommendation (identical to 94 data)
2502
2503       n = 44
2504       CALL base_read( filespec='DATAJ1/ABS/CCl4_jpl11.abs', &
2505                       skip_cnt=5,rd_cnt=n,x=x1,y=y1 )
2506       y1(1:n) = y1(1:n) * 1.E-20
2507
2508       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
2509                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2510
2511       END SUBROUTINE readit
2512
2513       END SUBROUTINE r20
2514
2515 !=============================================================================*
2516
2517       SUBROUTINE r23(nw,wl,wc,nz,tlev,airden,j)
2518 !-----------------------------------------------------------------------------*
2519 !=  PURPOSE:                                                                 =*
2520 !=  Provide product (cross section) x (quantum yield) for CFC-113 photolysis:=*
2521 !=          CF2ClCFCl2 + hv -> Products                                      =*
2522 !=  Cross section:  from JPL 97 recommendation, linear interp. between       =*
2523 !=                  values at 210 and 295K                                   =*
2524 !=  Quantum yield:  assumed to be unity                                      =*
2525 !-----------------------------------------------------------------------------*
2526
2527       INTEGER, intent(in) :: nw
2528       INTEGER, intent(in) :: nz
2529       INTEGER, intent(inout) :: j
2530       REAL, intent(in)    :: wl(kw), wc(kw)
2531       REAL, intent(in)    :: tlev(kz)
2532       REAL, intent(in)    :: airden(kz)
2533
2534 ! data arrays
2535       integer, PARAMETER :: kdata=100
2536
2537       INTEGER n1, n2
2538       REAL x1(kdata), x2(kdata)
2539       REAL y1(kdata), y2(kdata)
2540
2541 ! local
2542       real, parameter :: tfac1 = 1./(295. - 210.)
2543
2544       REAL, save :: yg2(kw), ydel(kw)
2545       REAL       :: yg1(kw)
2546       REAL qy
2547       REAL :: t(nz)
2548       REAL :: slope(nz)
2549       INTEGER i, iw, n, idum
2550       INTEGER iz
2551       INTEGER ierr
2552
2553       if( initialize ) then
2554         CALL readit
2555         ydel(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1)
2556       else
2557         call check_alloc( j, nz, nw-1 )
2558
2559 !** quantum yield assumed to be unity
2560
2561         t(1:nz) = MAX(210.,MIN(tlev(1:nz),295.))
2562         slope(1:nz) = (t(1:nz) - 210.)*tfac1
2563         DO iw = 1, nw-1
2564           xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel(iw)
2565         ENDDO
2566       endif
2567
2568       CONTAINS
2569
2570       SUBROUTINE readit
2571 !** cross sections from JPL97 recommendation (identical to 94 recommendation)
2572
2573       integer :: nsav
2574       real    :: xsav(kdata)
2575
2576       CALL base_read( filespec='DATAJ1/ABS/CFC-113_jpl94.abs', &
2577                       rd_cnt=n,x=x1,y=y1,y1=y2 )
2578       y1(1:n) = y1(1:n) * 1.E-20
2579       y2(1:n) = y2(1:n) * 1.E-20
2580       xsav(1:n) = x1(1:n)
2581       nsav = n
2582
2583 !* sigma @ 295 K
2584       CALL add_pnts_inter2(x1,y1,yg1,kdata,n, &
2585                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2586
2587 ! sigma @ 210 K
2588       n = nsav ; x1(1:n) = xsav(1:n)
2589       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
2590                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2591
2592       END SUBROUTINE readit
2593
2594       END SUBROUTINE r23
2595
2596 !=============================================================================*
2597
2598       SUBROUTINE r24(nw,wl,wc,nz,tlev,airden,j)
2599 !-----------------------------------------------------------------------------*
2600 !=  PURPOSE:                                                                 =*
2601 !=  Provide product (cross section) x (quantum yield) for CFC-144 photolysis:=*
2602 !=              CF2ClCF2Cl + hv -> Products                                  =*
2603 !=  Cross section: from JPL 97 recommendation, linear interp. between values =*
2604 !=                 at 210 and 295K                                           =*
2605 !=  Quantum yield: assumed to be unity                                       =*
2606 !-----------------------------------------------------------------------------*
2607
2608       INTEGER, intent(in) :: nw
2609       INTEGER, intent(in) :: nz
2610       INTEGER, intent(inout) :: j
2611       REAL, intent(in)    :: wl(kw), wc(kw)
2612       REAL, intent(in)    :: tlev(kz)
2613       REAL, intent(in)    :: airden(kz)
2614
2615 ! data arrays
2616       integer, PARAMETER :: kdata=100
2617
2618       INTEGER n1, n2
2619       REAL x1(kdata), x2(kdata)
2620       REAL y1(kdata), y2(kdata)
2621
2622 ! local
2623       real, parameter :: tfac1 = 1./(295. - 210.)
2624
2625       REAL, save :: yg2(kw), ydel(kw)
2626       REAL       :: yg1(kw)
2627       REAL qy
2628       REAL :: t(nz)
2629       REAL :: slope(nz)
2630       INTEGER i, iw, n, idum
2631       INTEGER ierr
2632       INTEGER iz
2633
2634       if( initialize ) then
2635         CALL readit
2636         ydel(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1)
2637       else
2638         call check_alloc( j, nz, nw-1 )
2639
2640 !** quantum yield assumed to be unity
2641
2642         t(1:nz) = MAX(210.,MIN(tlev(1:nz),295.))
2643         slope(1:nz) = (t(1:nz) - 210.)*tfac1
2644         DO iw = 1, nw-1
2645           xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel(iw)
2646         ENDDO
2647       endif
2648
2649       CONTAINS
2650
2651       SUBROUTINE readit
2652 !*** cross sections from JPL97 recommendation (identical to 94 recommendation)
2653
2654       integer :: nsav
2655       real    :: xsav(kdata)
2656
2657       CALL base_read( filespec='DATAJ1/ABS/CFC-114_jpl94.abs', &
2658                       rd_cnt=n,x=x1,y=y1,y1=y2 )
2659       y1(1:n) = y1(1:n) * 1.E-20
2660       y2(1:n) = y2(1:n) * 1.E-20
2661       xsav(1:n) = x1(1:n)
2662       nsav = n
2663
2664 !* sigma @ 295 K
2665       CALL add_pnts_inter2(x1,y1,yg1,kdata,n, &
2666                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2667
2668       n = nsav ; x1(1:n) = xsav(1:n)
2669 ! sigma @ 210 K
2670       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
2671                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2672
2673       END SUBROUTINE readit
2674
2675       END SUBROUTINE r24
2676
2677 !=============================================================================*
2678
2679       SUBROUTINE r26(nw,wl,wc,nz,tlev,airden,j)
2680 !-----------------------------------------------------------------------------*
2681 !=  PURPOSE:                                                                 =*
2682 !=  Provide product (cross section) x (quantum yield) for CFC-11  photolysis =*
2683 !=          CCl3F + hv -> Products                                           =*
2684 !=  Cross section: from JPL 97 recommendation                                =*
2685 !=  Quantum yield: assumed to be unity                                       =*
2686 !-----------------------------------------------------------------------------*
2687
2688       INTEGER, intent(in) :: nw
2689       INTEGER, intent(in) :: nz
2690       INTEGER, intent(inout) :: j
2691       REAL, intent(in)    :: wl(kw), wc(kw)
2692       REAL, intent(in)    :: tlev(kz)
2693       REAL, intent(in)    :: airden(kz)
2694
2695       integer, PARAMETER :: kdata=100
2696
2697       REAL x1(kdata)
2698       REAL y1(kdata)
2699
2700 ! local
2701       REAL, save :: yg(kw)
2702       REAL :: t(nz)
2703       INTEGER :: iw, n
2704
2705       if( initialize ) then
2706         CALL readit
2707       else
2708         call check_alloc( j, nz, nw-1 )
2709
2710 !*** quantum yield assumed to be unity
2711
2712         t(1:nz) = 1.E-04 * (tlev(1:nz) - 298.)
2713         DO iw = 1, nw-1
2714           xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * EXP((wc(iw)-184.9) * t(1:nz))
2715         ENDDO
2716       endif
2717
2718       CONTAINS
2719
2720       SUBROUTINE readit
2721 !*** cross sections from JPL97 recommendation (identical to 94 recommendation)
2722
2723       CALL base_read( filespec='DATAJ1/ABS/CFC-11_jpl94.abs',rd_cnt=n,x=x1,y=y1 )
2724       y1(1:n) = y1(1:n) * 1.E-20
2725
2726 !* sigma @ 298 K
2727
2728       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
2729                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2730
2731       END SUBROUTINE readit
2732
2733       END SUBROUTINE r26
2734
2735 !=============================================================================*
2736
2737       SUBROUTINE r27(nw,wl,wc,nz,tlev,airden,j)
2738 !-----------------------------------------------------------------------------*
2739 !=  PURPOSE:                                                                 =*
2740 !=  Provide product (cross section) x (quantum yield) for CFC-12  photolysis:=*
2741 !=         CCl2F2 + hv -> Products                                           =*
2742 !=  Cross section: from JPL 97 recommendation                                =*
2743 !=  Quantum yield: assumed to be unity                                       =*
2744 !-----------------------------------------------------------------------------*
2745
2746       INTEGER, intent(in) :: nw
2747       INTEGER, intent(in) :: nz
2748       INTEGER, intent(inout) :: j
2749       REAL, intent(in)    :: wl(kw), wc(kw)
2750       REAL, intent(in)    :: tlev(kz)
2751       REAL, intent(in)    :: airden(kz)
2752
2753 ! data arrays
2754       integer, PARAMETER :: kdata=100
2755
2756       REAL x1(kdata)
2757       REAL y1(kdata)
2758
2759 ! local
2760       REAL, save :: yg(kw)
2761       REAL    :: t(nz)
2762       INTEGER :: iw, n
2763
2764       if( initialize ) then
2765         CALL readit
2766       else
2767         call check_alloc( j, nz, nw-1 )
2768 !*** quantum yield assumed to be unity
2769         t(1:nz) = 1.E-04 * (tlev(1:nz) - 298.)
2770         DO iw = 1, nw-1
2771           xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * EXP((wc(iw)-184.9) * t(1:nz))
2772         ENDDO
2773       endif
2774
2775       CONTAINS
2776
2777       SUBROUTINE readit
2778 !*** cross sections from JPL97 recommendation (identical to 94 recommendation)
2779
2780       CALL base_read( filespec='DATAJ1/ABS/CFC-12_jpl94.abs',rd_cnt=n,x=x1,y=y1 )
2781       y1(1:n) = y1(1:n) * 1.E-20
2782
2783 !* sigma @ 298 K
2784       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
2785                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2786
2787       END SUBROUTINE readit
2788
2789       END SUBROUTINE r27
2790
2791 !=============================================================================*
2792
2793       SUBROUTINE r29(nw,wl,wc,nz,tlev,airden,j)
2794 !-----------------------------------------------------------------------------*
2795 !=  PURPOSE:                                                                 =*
2796 !=  Provide product (cross section) x (quantum yield) for CH3CCl3 photolysis =*
2797 !=           CH3CCl3 + hv -> Products                                        =*
2798 !=  Cross section: from JPL 97 recommendation, piecewise linear interp.      =*
2799 !=                 of data at 210, 250, and 295K                             =*
2800 !=  Quantum yield: assumed to be unity                                       =*
2801 !-----------------------------------------------------------------------------*
2802
2803       INTEGER, intent(in) :: nw
2804       INTEGER, intent(in) :: nz
2805       INTEGER, intent(inout) :: j
2806       REAL, intent(in)    :: wl(kw), wc(kw)
2807       REAL, intent(in)    :: tlev(kz)
2808       REAL, intent(in)    :: airden(kz)
2809
2810 ! data arrays
2811       integer, PARAMETER :: kdata=100
2812
2813       INTEGER n1, n2, n3
2814       REAL x1(kdata), x2(kdata), x3(kdata)
2815       REAL y1(kdata), y2(kdata), y3(kdata)
2816
2817 ! local
2818       real, parameter :: tfac1 = 1./(250. - 210.)
2819       real, parameter :: tfac2 = 1./(295. - 250.)
2820
2821       REAL, save :: yg2(kw), yg3(kw), ydel1(kw), ydel2(kw)
2822       REAL       :: yg1(kw)
2823       REAL qy
2824       REAL :: t(nz)
2825       REAL :: slope(nz)
2826       INTEGER i, iw, n, idum
2827       INTEGER ierr
2828       INTEGER iz
2829
2830       if( initialize ) then
2831         CALL readit
2832         ydel2(1:nw-1) = yg2(1:nw-1) - yg3(1:nw-1)
2833         ydel1(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1)
2834       else
2835         call check_alloc( j, nz, nw-1 )
2836
2837 !*** quantum yield assumed to be unity
2838
2839         t(1:nz) = MIN(295.,MAX(tlev(1:nz),210.))
2840         DO iw = 1, nw-1
2841           where( t(1:nz) <= 250. )
2842             slope(1:nz) = (t(1:nz) - 210.)*tfac1
2843             xsqy_tab(j)%sq(1:nz,iw) = yg3(iw) + slope(1:nz)*ydel2(iw)
2844           elsewhere
2845             slope(1:nz) = (t(1:nz) - 250.)*tfac2
2846             xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel1(iw)
2847           endwhere
2848         ENDDO
2849       endif
2850
2851       CONTAINS
2852
2853       SUBROUTINE readit
2854 !*** cross sections from JPL97 recommendation (identical to 94 recommendation)
2855
2856       integer :: nsav
2857       real    :: xsav(kdata)
2858
2859       CALL base_read( filespec='DATAJ1/ABS/CH3CCl3_jpl94.abs', &
2860                       rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3 )
2861       y1(1:n) = y1(1:n) * 1.E-20
2862       y2(1:n) = y2(1:n) * 1.E-20
2863       y3(1:n) = y3(1:n) * 1.E-20
2864       xsav(1:n) = x1(1:n)
2865       nsav = n
2866
2867 !* sigma @ 295 K
2868       CALL add_pnts_inter2(x1,y1,yg1,kdata,n, &
2869                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2870
2871       n = nsav ; x1(1:n) = xsav(1:n)
2872 !* sigma @ 250 K
2873       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
2874                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2875
2876       n = nsav ; x1(1:n) = xsav(1:n)
2877 !* sigma @ 210 K
2878       CALL add_pnts_inter2(x1,y3,yg3,kdata,n, &
2879                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2880
2881       END SUBROUTINE readit
2882
2883       END SUBROUTINE r29
2884
2885 !=============================================================================*
2886
2887       SUBROUTINE r30(nw,wl,wc,nz,tlev,airden,j)
2888 !-----------------------------------------------------------------------------*
2889 !=  PURPOSE:                                                                 =*
2890 !=  Provide product (cross section) x (quantum yield) for CH3Cl photolysis:  =*
2891 !=            CH3Cl + hv -> Products                                         =*
2892 !=  Cross section: from JPL 97 recommendation, piecewise linear interp.      =*
2893 !=                 from values at 255, 279, and 296K                         =*
2894 !=  Quantum yield: assumed to be unity                                       =*
2895 !-----------------------------------------------------------------------------*
2896
2897       INTEGER, intent(in) :: nw
2898       INTEGER, intent(in) :: nz
2899       INTEGER, intent(inout) :: j
2900       REAL, intent(in)    :: wl(kw), wc(kw)
2901       REAL, intent(in)    :: tlev(kz)
2902       REAL, intent(in)    :: airden(kz)
2903
2904 ! data arrays
2905       integer, PARAMETER :: kdata=100
2906
2907       INTEGER n1, n2, n3
2908       REAL x1(kdata), x2(kdata), x3(kdata)
2909       REAL y1(kdata), y2(kdata), y3(kdata)
2910
2911 ! local
2912       real, parameter :: tfac1 = 1./(279. - 255.)
2913       real, parameter :: tfac2 = 1./(296. - 279.)
2914
2915       REAL, save :: yg2(kw), yg3(kw)
2916       REAL, save :: ydel1(kw), ydel2(kw)
2917       REAL       :: yg1(kw)
2918       REAL qy
2919       REAL :: t(nz)
2920       REAL :: slope(nz)
2921       INTEGER i, iw, n, idum
2922       INTEGER ierr
2923       INTEGER iz
2924
2925       if( initialize ) then
2926         CALL readit
2927         ydel2(1:nw-1) = yg2(1:nw-1) - yg3(1:nw-1)
2928         ydel1(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1)
2929       else
2930         call check_alloc( j, nz, nw-1 )
2931
2932 !*** quantum yield assumed to be unity
2933
2934         t(1:nz) = MAX(255.,MIN(tlev(1:nz),296.))
2935         DO iw = 1, nw-1
2936           where( t(1:nz) <= 279. )
2937             slope(1:nz) = (t(1:nz) - 255.)*tfac1
2938             xsqy_tab(j)%sq(1:nz,iw) = yg3(iw) + slope(1:nz)*ydel2(iw)
2939           elsewhere
2940             slope(1:nz) = (t(1:nz) - 279.)*tfac2
2941             xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel1(iw)
2942           endwhere
2943         ENDDO
2944       endif
2945
2946       CONTAINS
2947
2948       SUBROUTINE readit
2949 !*** cross sections from JPL97 recommendation (identical to 94 recommendation)
2950
2951       integer :: nsav
2952       real    :: xsav(kdata)
2953
2954       CALL base_read( filespec='DATAJ1/ABS/CH3Cl_jpl94.abs', &
2955                       rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3 )
2956       y1(1:n) = y1(1:n) * 1.E-20
2957       y2(1:n) = y2(1:n) * 1.E-20
2958       y3(1:n) = y3(1:n) * 1.E-20
2959       xsav(1:n) = x1(1:n)
2960       nsav = n
2961
2962 !* sigma @ 296 K
2963       CALL add_pnts_inter2(x1,y1,yg1,kdata,n, &
2964                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2965
2966       n = nsav ; x1(1:n) = xsav(1:n)
2967 !* sigma @ 279 K
2968       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
2969                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2970
2971       n = nsav ; x1(1:n) = xsav(1:n)
2972 !* sigma @ 255 K
2973       CALL add_pnts_inter2(x1,y3,yg3,kdata,n, &
2974                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
2975
2976       END SUBROUTINE readit
2977
2978       END SUBROUTINE r30
2979
2980 !=============================================================================*
2981
2982       SUBROUTINE r32(nw,wl,wc,nz,tlev,airden,j)
2983 !-----------------------------------------------------------------------------*
2984 !=  PURPOSE:                                                                 =*
2985 !=  Provide product (cross section) x (quantum yield) for HCFC-123 photolysis=*
2986 !=       CF3CHCl2 + hv -> Products                                           =*
2987 !=  Cross section: from Orlando et al., 1991                                 =*
2988 !=  Quantum yield: assumed to be unity                                       =*
2989 !-----------------------------------------------------------------------------*
2990
2991       INTEGER, intent(in) :: nw
2992       INTEGER, intent(in) :: nz
2993       INTEGER, intent(inout) :: j
2994       REAL, intent(in)    :: wl(kw), wc(kw)
2995       REAL, intent(in)    :: tlev(kz)
2996       REAL, intent(in)    :: airden(kz)
2997
2998 ! local
2999       real, parameter :: LBar = 206.214
3000
3001       INTEGER i, iw, idum
3002       INTEGER iz, k
3003       REAL qy
3004       REAL lambda
3005       REAL, save :: TBar
3006       REAL :: t(nz)
3007       REAL :: sum(nz)
3008       REAL, save :: coeff(4,3)
3009       CHARACTER*120 inline
3010
3011       if( initialize ) then
3012         CALL readit
3013       else
3014         call check_alloc( j, nz, nw-1 )
3015
3016 !*** quantum yield assumed to be unity
3017
3018         DO iw = 1, nw-1
3019           lambda = wc(iw)
3020 ! use parameterization only up to 220 nm, as the error bars associated with
3021 ! the measurements beyond 220 nm are very large (Orlando, priv.comm.)
3022           IF (lambda .GE. 190. .AND. lambda .LE. 220.) THEN
3023             t(1:nz) = MIN(295.,MAX(tlev(1:nz),203.)) - TBar
3024             sum(1:nz) = 0.
3025             DO i = 1, 4
3026               sum(1:nz) = (coeff(i,1) + t(1:nz)*(coeff(i,2) + t(1:nz)*coeff(i,3))) &
3027                           * (lambda-LBar)**(i-1) + sum(1:nz)
3028             ENDDO
3029             xsqy_tab(j)%sq(1:nz,iw) = EXP(sum(1:nz))
3030           ELSE
3031             xsqy_tab(j)%sq(1:nz,iw) = 0.
3032           ENDIF
3033         ENDDO
3034       endif
3035
3036       CONTAINS
3037
3038       SUBROUTINE readit
3039 !*** cross section from Orlando et al., 1991
3040
3041       OPEN(kin,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD')
3042       READ(kin,*) idum
3043       DO i = 1, idum-2
3044         READ(kin,*)
3045       ENDDO
3046       READ(kin,'(a120)') inline
3047       READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3)
3048       READ(kin,*)           i,(coeff(i,k),k=1,3)
3049       READ(kin,*)           i,(coeff(i,k),k=1,3)
3050       READ(kin,*)           i,(coeff(i,k),k=1,3)
3051       CLOSE(kin)
3052
3053       END SUBROUTINE readit
3054
3055       END SUBROUTINE r32
3056
3057 !=============================================================================*
3058
3059       SUBROUTINE r33(nw,wl,wc,nz,tlev,airden,j)
3060 !-----------------------------------------------------------------------------*
3061 !=  PURPOSE:                                                                 =*
3062 !=  Provide product (cross section) x (quantum yield) for HCFC-124 photolysis=*
3063 !=        CF3CHFCl + hv -> Products                                          =*
3064 !=  Cross section: from Orlando et al., 1991                                 =*
3065 !=  Quantum yield: assumed to be unity                                       =*
3066 !-----------------------------------------------------------------------------*
3067
3068       INTEGER, intent(in) :: nw
3069       INTEGER, intent(in) :: nz
3070       INTEGER, intent(inout) :: j
3071       REAL, intent(in)    :: wl(kw), wc(kw)
3072       REAL, intent(in)    :: tlev(kz)
3073       REAL, intent(in)    :: airden(kz)
3074
3075 ! local
3076       real, parameter :: LBar = 206.214
3077
3078       INTEGER i, iw, n, idum
3079       INTEGER iz, k
3080       REAL qy
3081       REAL lambda
3082       REAL, save :: TBar
3083       REAL :: t(nz)
3084       REAL :: sum(nz)
3085       REAL, save :: coeff(4,3)
3086       CHARACTER*120 inline
3087
3088       if( initialize ) then
3089         CALL readit
3090       else
3091         call check_alloc( j, nz, nw-1 )
3092
3093 !*** quantum yield assumed to be unity
3094
3095         DO iw = 1, nw-1
3096           lambda = wc(iw)
3097           IF (lambda .GE. 190. .AND. lambda .LE. 230.) THEN
3098             t(1:nz) = MIN(295.,MAX(tlev(1:nz),203.)) - TBar
3099             sum(1:nz) = 0.
3100             DO i = 1, 4
3101               sum(1:nz) = (coeff(i,1) + t(1:nz)*(coeff(i,2) + t(1:nz)*coeff(i,3))) &
3102                           * (lambda-LBar)**(i-1) + sum(1:nz)
3103             ENDDO
3104             xsqy_tab(j)%sq(1:nz,iw) = EXP(sum(1:nz))
3105           ELSE
3106             xsqy_tab(j)%sq(1:nz,iw) = 0.
3107           ENDIF
3108         ENDDO
3109       endif
3110
3111       CONTAINS
3112
3113       SUBROUTINE readit
3114 !*** cross section from Orlando et al., 1991
3115
3116       OPEN(kin,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD')
3117       READ(kin,*) idum
3118       idum = idum+5
3119       DO i = 1, idum-2
3120         READ(kin,*)
3121       ENDDO
3122       READ(kin,'(a120)') inline
3123       READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3)
3124       READ(kin,*)           i,(coeff(i,k),k=1,3)
3125       READ(kin,*)           i,(coeff(i,k),k=1,3)
3126       READ(kin,*)           i,(coeff(i,k),k=1,3)
3127       CLOSE(kin)
3128
3129       END SUBROUTINE readit
3130
3131       END SUBROUTINE r33
3132
3133 !=============================================================================*
3134
3135       SUBROUTINE r35(nw,wl,wc,nz,tlev,airden,j)
3136 !-----------------------------------------------------------------------------*
3137 !=  PURPOSE:                                                                 =*
3138 !=  Provide product (cross section) x (quantum yield) for HCFC-142b          =*
3139 !=  photolysis:                                                              =*
3140 !=          CH3CF2Cl + hv -> Products                                        =*
3141 !=  Cross section: from Orlando et al., 1991                                 =*
3142 !=  Quantum yield: assumed to be unity                                       =*
3143 !-----------------------------------------------------------------------------*
3144
3145       INTEGER, intent(in) :: nw
3146       INTEGER, intent(in) :: nz
3147       INTEGER, intent(inout) :: j
3148       REAL, intent(in)    :: wl(kw), wc(kw)
3149       REAL, intent(in)    :: tlev(kz)
3150       REAL, intent(in)    :: airden(kz)
3151
3152 ! local
3153       real, parameter :: LBar = 206.214
3154
3155       INTEGER i, iw, n, idum
3156       INTEGER ierr
3157       INTEGER iz, k
3158       REAL qy
3159       REAL lambda
3160       REAL, save :: Tbar
3161       REAL :: t(nz)
3162       REAL :: sum(nz)
3163       REAL, save :: coeff(4,3)
3164       CHARACTER*80 inline
3165
3166       if( initialize ) then
3167         CALL readit
3168       else
3169         call check_alloc( j, nz, nw-1 )
3170
3171 !*** quantum yield assumed to be unity
3172
3173         DO iw = 1, nw-1
3174           lambda = wc(iw)
3175           IF (lambda .GE. 190. .AND. lambda .LE. 230.) THEN
3176             t(1:nz) = MIN(295.,MAX(tlev(1:nz),203.)) - TBar
3177             sum(1:nz) = 0.
3178             DO i = 1, 4
3179               sum(1:nz) = (coeff(i,1) + t(1:nz)*(coeff(i,2) + t(1:nz)*coeff(i,3))) &
3180                           * (lambda-LBar)**(i-1) + sum(1:nz)
3181             ENDDO
3182 ! offeset exponent by 40 (exp(-40.) = 4.248e-18) to prevent exp. underflow errors
3183 ! on some machines.
3184             xsqy_tab(j)%sq(1:nz,iw) = 4.248e-18 * EXP(sum(1:nz) + 40.)
3185           ELSE
3186             xsqy_tab(j)%sq(1:nz,iw) = 0.
3187           ENDIF
3188         ENDDO
3189       endif
3190
3191       CONTAINS
3192
3193       SUBROUTINE readit
3194 !*** cross section from Orlando et al., 1991
3195
3196       OPEN(kin,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD')
3197       READ(kin,*) idum
3198       idum = idum+10
3199       DO i = 1, idum-2
3200         READ(kin,*)
3201       ENDDO
3202       READ(kin,'(a80)') inline
3203       READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3)
3204       READ(kin,*)           i,(coeff(i,k),k=1,3)
3205       READ(kin,*)           i,(coeff(i,k),k=1,3)
3206       READ(kin,*)           i,(coeff(i,k),k=1,3)
3207       CLOSE(kin)
3208
3209       END SUBROUTINE readit
3210
3211       END SUBROUTINE r35
3212
3213 !=============================================================================*
3214
3215       SUBROUTINE r38(nw,wl,wc,nz,tlev,airden,j)
3216 !-----------------------------------------------------------------------------*
3217 !=  PURPOSE:                                                                 =*
3218 !=  Provide product (cross section) x (quantum yield) for HCFC-22 photolysis =*
3219 !=          CHClF2 + hv -> Products                                          =*
3220 !=  Cross section: from JPL 97 recommendation, piecewise linear interp.      =*
3221 !=                 from values at 210, 230, 250, 279, and 295 K              =*
3222 !=  Quantum yield: assumed to be unity                                       =*
3223 !-----------------------------------------------------------------------------*
3224
3225       INTEGER, intent(in) :: nw
3226       INTEGER, intent(in) :: nz
3227       INTEGER, intent(inout) :: j
3228       REAL, intent(in)    :: wl(kw), wc(kw)
3229       REAL, intent(in)    :: tlev(kz)
3230       REAL, intent(in)    :: airden(kz)
3231
3232 ! data arrays
3233       integer, PARAMETER :: kdata=100
3234
3235       INTEGER n1, n2, n3, n4, n5
3236       REAL x1(kdata), x2(kdata), x3(kdata), x4(kdata), x5(kdata)
3237       REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata), y5(kdata)
3238
3239 ! local
3240       real, parameter :: tfac1 = 1./(230. - 210.)
3241       real, parameter :: tfac2 = 1./(250. - 230.)
3242       real, parameter :: tfac3 = 1./(270. - 250.)
3243       real, parameter :: tfac4 = 1./(295. - 270.)
3244
3245       REAL qy
3246       REAL, save :: yg2(kw), yg3(kw), yg4(kw), yg5(kw)
3247       REAL       :: yg1(kw)
3248       REAL, save :: ydel1(kw), ydel2(kw), ydel3(kw), ydel4(kw)
3249       REAL :: t(nz), t1(nz), t2(nz), t3(nz), t4(nz)
3250       REAL :: slope(nz)
3251       INTEGER i, iw, n, idum
3252       INTEGER ierr
3253       INTEGER iz
3254
3255       if( initialize ) then
3256         CALL readit
3257         ydel4(1:nw-1) = yg4(1:nw-1) - yg5(1:nw-1)
3258         ydel3(1:nw-1) = yg3(1:nw-1) - yg4(1:nw-1)
3259         ydel2(1:nw-1) = yg2(1:nw-1) - yg3(1:nw-1)
3260         ydel1(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1)
3261       else
3262         call check_alloc( j, nz, nw-1 )
3263
3264 !*** quantum yield assumed to be unity
3265
3266         t(1:nz) = MIN(295.,MAX(tlev(1:nz),210.))
3267         t1(1:nz) = (t(1:nz) - 210.)*tfac1
3268         t2(1:nz) = (t(1:nz) - 230.)*tfac2
3269         t3(1:nz) = (t(1:nz) - 250.)*tfac3
3270         t4(1:nz) = (t(1:nz) - 270.)*tfac4
3271         DO iw = 1, nw-1
3272           where( t(1:nz) <= 230. )
3273             xsqy_tab(j)%sq(1:nz,iw) = yg5(iw) + t1(1:nz)*ydel4(iw)
3274           elsewhere( t(1:nz) > 230. .and. t(1:nz) <= 250. )
3275             xsqy_tab(j)%sq(1:nz,iw) = yg4(iw) + t2(1:nz)*ydel3(iw)
3276           elsewhere( t(1:nz) > 250. .and. t(1:nz) <= 270. )
3277             xsqy_tab(j)%sq(1:nz,iw) = yg3(iw) + t3(1:nz)*ydel2(iw)
3278           elsewhere
3279             xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + t4(1:nz)*ydel1(iw)
3280           endwhere
3281         ENDDO
3282       endif
3283
3284       CONTAINS
3285
3286       SUBROUTINE readit
3287 !*** cross sections from JPL97 recommendation (identical to 94 recommendation)
3288
3289       integer :: nsav
3290       real    :: xsav(kdata)
3291
3292       CALL base_read( filespec='DATAJ1/ABS/HCFC-22_jpl94.abs', &
3293                       rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3,y3=y4,y4=y5 )
3294       y1(1:n) = y1(1:n) * 1.E-20
3295       y2(1:n) = y2(1:n) * 1.E-20
3296       y3(1:n) = y3(1:n) * 1.E-20
3297       y4(1:n) = y4(1:n) * 1.E-20
3298       y5(1:n) = y5(1:n) * 1.E-20
3299       nsav = n ; xsav(1:n) = x1(1:n)
3300
3301 !* sigma @ 295 K
3302       CALL add_pnts_inter2(x1,y1,yg1,kdata,n, &
3303                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3304
3305       n = nsav ; x1(1:n) = xsav(1:n)
3306 !* sigma @ 270 K
3307       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
3308                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3309
3310       n = nsav ; x1(1:n) = xsav(1:n)
3311 !* sigma @ 250 K
3312       CALL add_pnts_inter2(x1,y3,yg3,kdata,n, &
3313                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3314
3315       n = nsav ; x1(1:n) = xsav(1:n)
3316 !* sigma @ 230 K
3317       CALL add_pnts_inter2(x1,y4,yg4,kdata,n, &
3318                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3319
3320       n = nsav ; x1(1:n) = xsav(1:n)
3321 !* sigma @ 210 K
3322       CALL add_pnts_inter2(x1,y5,yg5,kdata,n, &
3323                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3324
3325       END SUBROUTINE readit
3326
3327       END SUBROUTINE r38
3328
3329 !=============================================================================*
3330
3331       SUBROUTINE r39(nw,wl,wc,nz,tlev,airden,j)
3332 !-----------------------------------------------------------------------------*
3333 !=  PURPOSE:                                                                 =*
3334 !=  Provide product (cross section) x (quantum yield) for HO2 photolysis:    =*
3335 !=          HO2 + hv -> OH + O                                               =*
3336 !=  Cross section: from JPL 97 recommendation                                =*
3337 !=  Quantum yield: assumed shape based on work by Lee, 1982; normalized      =*
3338 !=                 to unity at 248 nm                                        =*
3339 !-----------------------------------------------------------------------------*
3340
3341       INTEGER, intent(in) :: nw
3342       INTEGER, intent(in) :: nz
3343       INTEGER, intent(inout) :: j
3344       REAL, intent(in)    :: wl(kw), wc(kw)
3345       REAL, intent(in)    :: tlev(kz)
3346       REAL, intent(in)    :: airden(kz)
3347
3348 ! data arrays
3349       integer, PARAMETER :: kdata=100
3350
3351       REAL x1(kdata)
3352       REAL y1(kdata)
3353
3354 ! local
3355       real, parameter :: tfac1 = 1./(248. - 193.)
3356       real, parameter :: xfac1 = 1./15.
3357
3358       REAL :: yg(kw)
3359       REAL :: qy(nw)
3360       INTEGER :: n, idum
3361
3362       if( initialize ) then
3363         CALL readit
3364         call check_alloc( ndx=j, nz=nw-1, nw=1 )
3365         WHERE( wc(1:nw-1) >= 248. )
3366           qy(1:nw-1) = 1.
3367         ELSEWHERE
3368           qy(1:nw-1) = max( (1. + (wc(1:nw-1) - 193.)*14.*tfac1)*xfac1,0. )
3369         ENDWHERE
3370         xsqy_tab(j)%sq(1:nw-1,1) = qy(1:nw-1) * yg(1:nw-1)
3371       endif
3372
3373       CONTAINS
3374
3375       SUBROUTINE readit
3376 !*** cross sections from JPL11 recommendation
3377
3378       n = 15
3379       CALL base_read( filespec='DATAJ1/ABS/HO2_jpl11.abs', &
3380                       skip_cnt=10,rd_cnt=n,x=x1,y=y1 )
3381       y1(1:n) = y1(1:n) * 1.E-20
3382
3383       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
3384                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3385
3386       END SUBROUTINE readit
3387
3388       END SUBROUTINE r39
3389
3390 !=============================================================================*
3391
3392       SUBROUTINE r44(nw,wl,wc,nz,tlev,airden,j)
3393 !-----------------------------------------------------------------------------*
3394 !=  PURPOSE:                                                                 =*
3395 !=  Provide product (cross section) x (quantum yield) for N2O photolysis:    =*
3396 !=              N2O + hv -> N2 + O(1D)                                       =*
3397 !=  Cross section: from JPL 97 recommendation                                =*
3398 !=  Quantum yield: assumed to be unity, based on Greenblatt and Ravishankara =*
3399 !-----------------------------------------------------------------------------*
3400
3401       INTEGER, intent(in) :: nw
3402       INTEGER, intent(in) :: nz
3403       INTEGER, intent(inout) :: j
3404       REAL, intent(in)    :: wl(kw), wc(kw)
3405       REAL, intent(in)    :: tlev(kz)
3406       REAL, intent(in)    :: airden(kz)
3407
3408 ! local
3409       real, parameter :: A0 = 68.21023
3410       real, parameter :: A1 = -4.071805
3411       real, parameter :: A2 = 4.301146E-02
3412       real, parameter :: A3 = -1.777846E-04
3413       real, parameter :: A4 = 2.520672E-07
3414
3415       real, parameter :: B0 = 123.4014
3416       real, parameter :: B1 = -2.116255
3417       real, parameter :: B2 = 1.111572E-02
3418       real, parameter :: B3 = -1.881058E-05
3419
3420       INTEGER :: iw
3421       REAL, save :: a(kw), b(kw)
3422       REAL :: lambda
3423       REAL :: t(nz)
3424       REAL :: bt(nz)
3425
3426       if( initialize ) then
3427         DO iw = 1, nw-1
3428           lambda = wc(iw)
3429           IF (lambda >= 173. .AND. lambda <= 240.) THEN
3430             A(iw) = (((A4*lambda+A3)*lambda+A2)*lambda+A1)*lambda+A0
3431             B(iw) = (((B3*lambda+B2)*lambda+B1)*lambda+B0)
3432           ENDIF
3433         ENDDO
3434       else
3435         call check_alloc( j, nz, nw-1 )
3436
3437 !*** cross sections according to JPL97 recommendation (identical to 94 rec.)
3438 !*** see file DATAJ1/ABS/N2O_jpl94.abs for detail
3439 !*** quantum yield of N(4s) and NO(2Pi) is less than 1% (Greenblatt and
3440 !*** Ravishankara), so quantum yield of O(1D) is assumed to be unity
3441
3442         t(1:nz) = MAX(194.,MIN(tlev(1:nz),320.))
3443         DO iw = 1, nw-1
3444           lambda = wc(iw)
3445           IF (lambda >= 173. .AND. lambda <= 240.) THEN
3446             BT(1:nz) = (t(1:nz) - 300.)*EXP(B(iw))
3447             xsqy_tab(j)%sq(1:nz,iw) = EXP(A(iw)+BT(1:nz))
3448           ELSE
3449             xsqy_tab(j)%sq(1:nz,iw) = 0.
3450           ENDIF
3451         ENDDO
3452       endif
3453
3454       END SUBROUTINE r44
3455
3456 !=============================================================================*
3457
3458       SUBROUTINE r45(nw,wl,wc,nz,tlev,airden,j)
3459 !-----------------------------------------------------------------------------*
3460 !=  PURPOSE:                                                                 =*
3461 !=  Provide product (cross section) x (quantum yield) for ClONO2 photolysis: =*
3462 !=        ClONO2 + hv -> Products                                            =*
3463 !=                                                                           =*
3464 !=  Cross section: JPL 97 recommendation                                     =*
3465 !=  Quantum yield: JPL 97 recommendation                                     =*
3466 !-----------------------------------------------------------------------------*
3467
3468       INTEGER, intent(in) :: nw
3469       INTEGER, intent(in) :: nz
3470       INTEGER, intent(inout) :: j
3471       REAL, intent(in)    :: wl(kw), wc(kw)
3472       REAL, intent(in)    :: tlev(kz)
3473       REAL, intent(in)    :: airden(kz)
3474
3475 ! data arrays
3476       integer, PARAMETER :: kdata=150
3477
3478       REAL x1(kdata)
3479       REAL y1(kdata),y2(kdata),y3(kdata)
3480
3481 ! local
3482       REAL qy1, qy2
3483       REAL :: xs(nz)
3484       real :: t(nz)
3485       REAL, save :: yg1(kw), yg2(kw), yg3(kw)
3486       INTEGER i, iw, n, idum, chnl
3487       INTEGER ierr
3488       INTEGER iz
3489       LOGICAL, save :: is_initialized = .false.
3490
3491       if( initialize ) then
3492         if( .not. is_initialized ) then
3493           CALL readit
3494           is_initialized = .true.
3495         endif
3496       else
3497         call check_alloc( j, nz, nw-1 )
3498
3499         t(1:nz) = tlev(1:nz) - 296.
3500         chnl = xsqy_tab(j)%channel
3501         DO iw = 1, nw-1
3502 !** quantum yields (from jpl97, same in jpl2011)
3503           IF( wc(iw) .LT. 308.) THEN
3504             qy1 = 0.6
3505           ELSEIF( (wc(iw) .GE. 308) .AND. (wc(iw) .LE. 364.) ) THEN
3506             qy1 = 7.143e-3 * wc(iw) - 1.6
3507           ELSEIF( wc(iw) .GT. 364. ) THEN
3508             qy1 = 1.0
3509           ENDIF
3510           IF( chnl == 2 ) then
3511             qy1 = 1.0 - qy1
3512           ENDIF
3513 ! compute T-dependent cross section
3514           xs(1:nz) = yg1(iw) * (1. + t(1:nz) &
3515                    * (yg2(iw) + t(1:nz)*yg3(iw)))
3516           xsqy_tab(j)%sq(1:nz,iw) = qy1 * xs(1:nz)
3517         ENDDO
3518       endif
3519
3520       CONTAINS
3521
3522       SUBROUTINE readit
3523 !** cross sections from JPL97 recommendation.  Same in JPL-2011.
3524
3525       integer :: nsav
3526       real    :: xsav(kz)
3527
3528       n = 119 ; nsav = 119
3529       CALL base_read( filespec='DATAJ1/ABS/ClONO2_jpl97.abs', &
3530                       skip_cnt=2,rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3 )
3531       xsav(1:n) = x1(1:n)
3532       y1(1:n)   = y1(1:n) * 1.E-20
3533
3534       CALL add_pnts_inter2(x1,y1,yg1,kdata,n, &
3535                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3536
3537       n = nsav ; x1(1:n) = xsav(1:n)
3538       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
3539                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3540
3541       n = nsav ; x1(1:n) = xsav(1:n)
3542       CALL add_pnts_inter2(x1,y3,yg3,kdata,n, &
3543                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3544
3545       END SUBROUTINE readit
3546
3547       END SUBROUTINE r45
3548
3549 !=============================================================================*
3550
3551       SUBROUTINE r46(nw,wl,wc,nz,tlev,airden,j)
3552 !-----------------------------------------------------------------------------*
3553 !=  PURPOSE:                                                                 =*
3554 !=  Provide product (cross section) x (quantum yield) for BrONO2 photolysis: =*
3555 !=        BrONO2 + hv -> Products                                            =*
3556 !=                                                                           =*
3557 !=  Cross section: JPL 03 recommendation                                     =*
3558 !=  Quantum yield: JPL 03 recommendation                                     =*
3559 !-----------------------------------------------------------------------------*
3560
3561       INTEGER, intent(in) :: nw
3562       INTEGER, intent(in) :: nz
3563       INTEGER, intent(inout) :: j
3564       REAL, intent(in)    :: wl(kw), wc(kw)
3565       REAL, intent(in)    :: tlev(kz)
3566       REAL, intent(in)    :: airden(kz)
3567
3568 ! data arrays
3569       integer, PARAMETER :: kdata=100
3570
3571       REAL x1(kdata)
3572       REAL y1(kdata)
3573
3574 ! local
3575       REAL, parameter :: qyld(2) = (/ .15,.85 /)
3576
3577       REAL    :: yg1(kw)
3578       INTEGER :: n
3579       INTEGER :: chnl
3580
3581       if( initialize ) then
3582         CALL readit
3583         call check_alloc( ndx=j, nz=nw-1, nw=1 )
3584         chnl = xsqy_tab(j)%channel
3585         xsqy_tab(j)%sq(1:nw-1,1) = qyld(chnl) * yg1(1:nw-1)
3586       endif
3587
3588       CONTAINS
3589
3590       SUBROUTINE readit
3591 !** cross sections from JPL03 recommendation
3592
3593       n = 61
3594       CALL base_read( filespec='DATAJ1/ABS/BrONO2_jpl03.abs', &
3595                       skip_cnt=13,rd_cnt=n,x=x1,y=y1 )
3596       y1(1:n) = y1(1:n) * 1.E-20
3597
3598       CALL add_pnts_inter2(x1,y1,yg1,kdata,n, &
3599                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3600
3601       END SUBROUTINE readit
3602
3603       END SUBROUTINE r46
3604
3605 !=============================================================================*
3606
3607       SUBROUTINE r47(nw,wl,wc,nz,tlev,airden,j)
3608 !-----------------------------------------------------------------------------*
3609 !=  PURPOSE:                                                                 =*
3610 !=  Provide product (cross section) x (quantum yield) for Cl2 photolysis:    =*
3611 !=        Cl2 + hv -> 2 Cl                                                   =*
3612 !=                                                                           =*
3613 !=  Cross section: JPL 97 recommendation                                     =*
3614 !=  Quantum yield: 1     (Calvert and Pitts, 1966)                           =*
3615 !-----------------------------------------------------------------------------*
3616
3617       INTEGER, intent(in) :: nw
3618       INTEGER, intent(in) :: nz
3619       INTEGER, intent(inout) :: j
3620       REAL, intent(in)    :: wl(kw), wc(kw)
3621       REAL, intent(in)    :: tlev(kz)
3622       REAL, intent(in)    :: airden(kz)
3623
3624 ! local
3625       real :: ex1(nz), ex2(nz)
3626       real :: alpha(kz)
3627       INTEGER iz, iw
3628
3629       real :: aa, bb, bb2, sig
3630
3631       if( .not. initialize ) then
3632         call check_alloc( j, nz, nw-1 )
3633
3634 ! mabs = 1: Finlayson-Pitts and Pitts
3635 ! mabs = 2: JPL2011 formula
3636
3637         DO iz = 1, nz
3638           aa = 402.7/tlev(iz)
3639           bb = exp(aa)
3640           bb2 = bb*bb
3641           alpha(iz) = (bb2 - 1.)/(bb2 + 1.)
3642         ENDDO
3643
3644 !** quantum yield = 1 (Calvert and Pitts, 1966)
3645
3646         DO iw = 1, nw-1
3647           ex1(1:nz) = 27.3  * exp(-99.0 * alpha(1:nz) * (log(329.5/wc(iw)))**2)
3648           ex2(1:nz) = .932 * exp(-91.5 * alpha(1:nz) * (log(406.5/wc(iw)))**2)
3649           xsqy_tab(j)%sq(1:nz,iw) = 1.e-20 * sqrt(alpha(1:nz)) * (ex1(1:nz) + ex2(1:nz))
3650         ENDDO
3651       endif
3652
3653       END SUBROUTINE r47
3654
3655 !=============================================================================*
3656
3657       SUBROUTINE r101(nw,wl,wc,nz,tlev,airden,j)
3658 !-----------------------------------------------------------------------------*
3659 !=  PURPOSE:                                                                 =*
3660 !=  Provide the product (cross section) x (quantum yield) for CH2(OH)CHO     =*
3661 !=  (glycolaldehye, hydroxy acetaldehyde) photolysis:                        =*
3662 !=           CH2(OH)CHO + hv -> Products                                     =*
3663 !=                                                                           =*
3664 !=  Quantum yield about 50%                                                  =*
3665 !-----------------------------------------------------------------------------*
3666
3667       INTEGER, intent(in) :: nw
3668       INTEGER, intent(in) :: nz
3669       INTEGER, intent(inout) :: j
3670       REAL, intent(in)    :: wl(kw), wc(kw)
3671       REAL, intent(in)    :: tlev(kz)
3672       REAL, intent(in)    :: airden(kz)
3673
3674 ! data arrays
3675       integer, PARAMETER :: kdata=100
3676
3677       INTEGER :: n
3678       REAL x(kdata), y(kdata)
3679
3680 ! local
3681       real, parameter :: qyld(3) = (/ .83, .10, .07 /)
3682
3683       REAL    :: yg(kw)
3684       INTEGER :: chnl
3685
3686       if( initialize ) then
3687         chnl = xsqy_tab(j)%channel
3688         CALL readit
3689         call check_alloc( ndx=j, nz=nw-1, nw=1 )
3690         xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * qyld(chnl)
3691       endif
3692
3693       CONTAINS
3694
3695       SUBROUTINE readit
3696
3697       n = 63
3698       CALL base_read( filespec='DATAJ1/CH2OHCHO/glycolaldehyde_jpl11.abs', &
3699                       skip_cnt=2,rd_cnt=n,x=x,y=y )
3700       y(1:n) = y(1:n) * 1.e-20
3701
3702       CALL add_pnts_inter2(x,y,yg,kdata,n, &
3703                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3704
3705       END SUBROUTINE readit
3706
3707       END SUBROUTINE r101
3708
3709 !=============================================================================*
3710
3711       SUBROUTINE r103(nw,wl,wc,nz,tlev,airden,j)
3712 !-----------------------------------------------------------------------------*
3713 !=  PURPOSE:                                                                 =*
3714 !=  Provide the product (cross section) x (quantum yield) for CH3COCHCH2     =*
3715 !=  Methyl vinyl ketone photolysis:                                          =*
3716 !=           CH3COCH=CH2 + hv -> Products                                     =*
3717 !-----------------------------------------------------------------------------*
3718
3719       INTEGER, intent(in) :: nw
3720       INTEGER, intent(in) :: nz
3721       INTEGER, intent(inout) :: j
3722       REAL, intent(in)    :: wl(kw), wc(kw)
3723       REAL, intent(in)    :: tlev(kz)
3724       REAL, intent(in)    :: airden(kz)
3725
3726 ! data arrays
3727       integer, PARAMETER :: kdata=150
3728
3729       INTEGER i, n
3730       REAL x(kdata), y(kdata)
3731
3732 ! local
3733       REAL, save :: yg(kw)
3734       REAL :: qy(nz)
3735       INTEGER ierr
3736       INTEGER iw
3737       INTEGER mabs
3738
3739       if( initialize ) then
3740         CALL readit
3741       else
3742         call check_alloc( j, nz, nw-1 )
3743
3744 ! mabs = 1: Schneider and moortgat
3745 ! mabs = 2: jpl 2011
3746 !     mabs = 2
3747
3748 ! quantum yield from
3749 ! Gierczak, T., J. B. Burkholder, R. K. Talukdar, A. Mellouki, S. B. Barone,
3750 ! and A. R. Ravishankara, Atmospheric fate of methyl vinyl ketone and methacrolein,
3751 ! J. Photochem. Photobiol A: Chemistry, 110 1-10, 1997.
3752 ! depends on pressure and wavelength, set upper limit to 1.0
3753
3754         DO iw = 1, nw - 1
3755           qy(1:nz) = exp(-0.055*(wc(iw) - 308.)) &
3756                    / (5.5 + 9.2e-19*airden(1:nz))
3757           qy(1:nz) = min(qy(1:nz), 1.)
3758           xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * qy(1:nz)
3759         ENDDO
3760       endif
3761
3762       CONTAINS
3763
3764       SUBROUTINE readit
3765
3766       n = 146
3767       CALL base_read( filespec='DATAJ1/ABS/MVK_jpl11.abs', &
3768                       skip_cnt=2,rd_cnt=n,x=x,y=y )
3769       y(1:n) = y(1:n) * 1.e-20
3770
3771       CALL add_pnts_inter2(x,y,yg,kdata,n, &
3772                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3773
3774       END SUBROUTINE readit
3775
3776       END SUBROUTINE r103
3777
3778 !=============================================================================*
3779
3780       SUBROUTINE r106(nw,wl,wc,nz,tlev,airden,j)
3781 !-----------------------------------------------------------------------------*
3782 !=  PURPOSE:                                                                 =*
3783 !=  Provide the product (cross section) x (quantum yield) for CH3CH2ONO2     =*
3784 !=  ethyl nitrate       photolysis:                                          =*
3785 !=           CH3CH2ONO2 + hv -> CH3CH2O + NO2                                =*
3786 !-----------------------------------------------------------------------------*
3787
3788       INTEGER, intent(in) :: nw
3789       INTEGER, intent(in) :: nz
3790       INTEGER, intent(inout) :: j
3791       REAL, intent(in)    :: wl(kw), wc(kw)
3792       REAL, intent(in)    :: tlev(kz)
3793       REAL, intent(in)    :: airden(kz)
3794
3795 ! data arrays
3796       integer, PARAMETER :: kdata=100
3797
3798       INTEGER i, n1, n2
3799       REAL x1(kdata), y1(kdata)
3800       REAL x2(kdata), y2(kdata)
3801
3802 ! local
3803       INTEGER ierr
3804       INTEGER iw
3805       REAL dum
3806       REAL qy, sig
3807       REAL, save :: yg1(kw), yg2(kw)
3808       real :: t(nz)
3809
3810       if( initialize ) then
3811         CALL readit
3812       else
3813         call check_alloc( j, nz, nw-1 )
3814
3815 ! quantum yield  = 1
3816
3817         t(1:nz) = tlev(1:nz) - 298.
3818         DO iw = 1, nw - 1
3819           xsqy_tab(j)%sq(1:nz,iw) = yg1(iw)*exp(yg2(iw)*t(1:nz))
3820         ENDDO
3821       endif
3822
3823       CONTAINS
3824
3825       SUBROUTINE readit
3826
3827       integer :: n
3828       real :: wrk(kdata)
3829       character(len=256) :: emsg
3830
3831       n = 63
3832       CALL base_read( filespec='DATAJ1/RONO2/RONO2_talukdar.abs', &
3833                       skip_cnt=10,rd_cnt=n,x=x1,y=wrk,y1=wrk, &
3834                       y2=y1,y3=y2,y4=wrk,y5=wrk )
3835
3836       x2(1:n) = x1(1:n)
3837
3838       n1 = count( y1(1:n) > 0. )
3839       if( n1 > 0 ) then
3840         wrk(1:n1) = pack( y1(1:n),mask=y1(1:n) > 0. )
3841         y1(1:n1)  = wrk(1:n1) * 1.e-20
3842         wrk(1:n1) = pack( x1(1:n),mask=y1(1:n) > 0. )
3843         x1(1:n1)  = wrk(1:n1)
3844         CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, &
3845                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3846       else
3847         yg1(:nw) = 0.
3848       endif
3849
3850
3851       n2 = count( y2(1:n) > 0. )
3852       if( n2 > 0 ) then
3853         wrk(1:n2) = pack( y2(1:n),mask=y2(1:n) > 0. )
3854         y2(1:n2)  = wrk(1:n2) * 1.e-3
3855         wrk(1:n2) = pack( x2(1:n),mask=y2(1:n) > 0. )
3856         x2(1:n2)  = wrk(1:n2)
3857         CALL addpnt(x2,y2,kdata,n2,               0.,y2(1))
3858         CALL addpnt(x2,y2,kdata,n2,           1.e+38,y2(n2))
3859         CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
3860         IF (ierr .NE. 0) THEN
3861           write(emsg,'(''readit: Error '',i5,'' in inter2 for '',a)') ierr,trim(xsqy_tab(j)%label)
3862           call wrf_error_fatal( trim(emsg) )
3863         ENDIF
3864       else
3865         yg2(:nw) = 0.
3866       endif
3867
3868       END SUBROUTINE readit
3869
3870       END SUBROUTINE r106
3871
3872 !=============================================================================*
3873
3874       SUBROUTINE r107(nw,wl,wc,nz,tlev,airden,j)
3875 !-----------------------------------------------------------------------------*
3876 !=  PURPOSE:                                                                 =*
3877 !=  Provide the product (cross section) x (quantum yield) for CH3CHONO2CH3   =*
3878 !=  isopropyl nitrate   photolysis:                                          =*
3879 !=           CH3CHONO2CH3 + hv -> CH3CHOCH3 + NO2                            =*
3880 !-----------------------------------------------------------------------------*
3881
3882       INTEGER, intent(in) :: nw
3883       INTEGER, intent(in) :: nz
3884       INTEGER, intent(inout) :: j
3885       REAL, intent(in)    :: wl(kw), wc(kw)
3886       REAL, intent(in)    :: tlev(kz)
3887       REAL, intent(in)    :: airden(kz)
3888
3889 ! data arrays
3890       integer, PARAMETER :: kdata=100
3891
3892       INTEGER i, n1, n2
3893       REAL x1(kdata), y1(kdata)
3894       REAL x2(kdata), y2(kdata)
3895
3896 ! local
3897       INTEGER ierr
3898       INTEGER iw
3899       REAL dum
3900       REAL qy, sig
3901       REAL, save :: yg1(kw), yg2(kw)
3902       real :: t(nz)
3903
3904       if( initialize ) then
3905         CALL readit
3906       else
3907         call check_alloc( j, nz, nw-1 )
3908
3909 ! quantum yield  = 1
3910
3911         t(1:nz) = tlev(1:nz) - 298.
3912         DO iw = 1, nw - 1
3913           xsqy_tab(j)%sq(1:nz,iw) = yg1(iw)*exp(yg2(iw)*t(1:nz))
3914         ENDDO
3915       endif
3916
3917       CONTAINS
3918
3919       SUBROUTINE readit
3920
3921       integer :: n
3922       real :: wrk(kdata)
3923       character(len=256) :: emsg
3924
3925       n = 63
3926       CALL base_read( filespec='DATAJ1/RONO2/RONO2_talukdar.abs', &
3927                       skip_cnt=10,rd_cnt=n,x=x1,y=wrk, &
3928                       y1=wrk,y2=wrk,y3=wrk,y4=y1,y5=y2 )
3929
3930       x2(1:n) = x1(1:n)
3931
3932       n1 = count( y1(1:n) > 0. )
3933       if( n1 > 0 ) then
3934         wrk(1:n1) = pack( y1(1:n),mask=y1(1:n) > 0. )
3935         y1(1:n1)  = wrk(1:n1) * 1.e-20
3936         wrk(1:n1) = pack( x1(1:n),mask=y1(1:n) > 0. )
3937         x1(1:n1)  = wrk(1:n1)
3938         CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, &
3939                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
3940       else
3941         yg1(:nw) = 0.
3942       endif
3943
3944       n2 = count( y2(1:n) > 0. )
3945       if( n2 > 0 ) then
3946         wrk(1:n2) = pack( y2(1:n),mask=y2(1:n) > 0. )
3947         y2(1:n2)  = wrk(1:n2) * 1.e-3
3948         wrk(1:n2) = pack( x2(1:n),mask=y2(1:n) > 0. )
3949         x2(1:n2)  = wrk(1:n2)
3950         CALL addpnt(x2,y2,kdata,n2,               0.,y2(1))
3951         CALL addpnt(x2,y2,kdata,n2,           1.e+38,y2(n2))
3952         CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
3953         IF (ierr .NE. 0) THEN
3954           write(emsg,'(''readit: Error '',i5,'' in inter2 for '',a)') ierr,trim(xsqy_tab(j)%label)
3955           call wrf_error_fatal( trim(emsg) )
3956         ENDIF
3957       else
3958         yg2(:nw) = 0.
3959       endif
3960
3961       END SUBROUTINE readit
3962
3963       END SUBROUTINE r107
3964
3965 !=============================================================================*
3966
3967       SUBROUTINE r108(nw,wl,wc,nz,tlev,airden,j)
3968 !-----------------------------------------------------------------------------*
3969 !=  PURPOSE:                                                                 =*
3970 !=  Provide the product (cross section) x (quantum yield) for                =*
3971 !=   nitroxy ethanol CH2(OH)CH2(ONO2) + hv -> CH2(OH)CH2(O.) + NO2           =*
3972 !-----------------------------------------------------------------------------*
3973
3974       INTEGER, intent(in) :: nw
3975       INTEGER, intent(in) :: nz
3976       INTEGER, intent(inout) :: j
3977       REAL, intent(in)    :: wl(kw), wc(kw)
3978       REAL, intent(in)    :: tlev(kz)
3979       REAL, intent(in)    :: airden(kz)
3980
3981 ! local
3982 ! coefficients from Roberts and Fajer 1989, over 270-306 nm
3983       real, parameter ::a = -2.359E-3
3984       real, parameter ::b = 1.2478
3985       real, parameter ::c = -210.4
3986
3987       if( initialize ) then
3988         call check_alloc( ndx=j, nz=nw-1, nw=1 )
3989 ! quantum yield  = 1
3990         WHERE( wc(1:nw-1) >= 270. .AND. wc(1:nw-1) <= 306. )
3991           xsqy_tab(j)%sq(1:nw-1,1) = EXP(c + wc(1:nw-1)*(b + wc(1:nw-1)*a))
3992         ELSEWHERE
3993           xsqy_tab(j)%sq(1:nw-1,1) = 0.
3994         ENDWHERE
3995       endif
3996
3997       END SUBROUTINE r108
3998
3999 !=============================================================================*
4000
4001       SUBROUTINE r109(nw,wl,wc,nz,tlev,airden,j)
4002 !-----------------------------------------------------------------------------*
4003 !=  PURPOSE:                                                                 =*
4004 !=  Provide the product (cross section) x (quantum yield) for                =*
4005 !=   nitroxy acetone CH3COCH2(ONO2) + hv -> CH3COCH2(O.) + NO2               =*
4006 !-----------------------------------------------------------------------------*
4007
4008       INTEGER, intent(in) :: nw
4009       INTEGER, intent(in) :: nz
4010       INTEGER, intent(inout) :: j
4011       REAL, intent(in)    :: wl(kw), wc(kw)
4012       REAL, intent(in)    :: tlev(kz)
4013       REAL, intent(in)    :: airden(kz)
4014
4015 ! local
4016 ! coefficients from Roberts and Fajer 1989, over 284-335 nm
4017       real, parameter :: a = -1.365E-3
4018       real, parameter :: b = 0.7834
4019       real, parameter :: c = -156.8
4020
4021       if( initialize ) then
4022         call check_alloc( ndx=j, nz=nw-1, nw=1 )
4023 ! quantum yield  = 1
4024         WHERE( wc(1:nw-1) >= 284. .AND. wc(1:nw-1) <= 335. )
4025           xsqy_tab(j)%sq(1:nw-1,1) = EXP(c + wc(1:nw-1)*(b + wc(1:nw-1)*a))
4026         ELSEWHERE
4027           xsqy_tab(j)%sq(1:nw-1,1) = 0.
4028         ENDWHERE
4029       endif
4030
4031       END SUBROUTINE r109
4032
4033 !=============================================================================*
4034
4035       SUBROUTINE r110(nw,wl,wc,nz,tlev,airden,j)
4036 !-----------------------------------------------------------------------------*
4037 !=  PURPOSE:                                                                 =*
4038 !=  Provide the product (cross section) x (quantum yield) for                =*
4039 !=  t-butyl nitrate C(CH3)3(ONO2) + hv -> C(CH3)(O.) + NO2                   =*
4040 !-----------------------------------------------------------------------------*
4041
4042       INTEGER, intent(in) :: nw
4043       INTEGER, intent(in) :: nz
4044       INTEGER, intent(inout) :: j
4045       REAL, intent(in)    :: wl(kw), wc(kw)
4046       REAL, intent(in)    :: tlev(kz)
4047       REAL, intent(in)    :: airden(kz)
4048
4049 ! local
4050 ! coefficients from Roberts and Fajer 1989, over 270-330 nm
4051       real, parameter ::a = -0.993E-3
4052       real, parameter ::b = 0.5307
4053       real, parameter ::c = -115.5
4054
4055       if( initialize ) then
4056         call check_alloc( ndx=j, nz=nw-1, nw=1 )
4057 ! quantum yield  = 1
4058         WHERE( wc(1:nw-1) >= 270. .AND. wc(1:nw-1) <= 330. )
4059           xsqy_tab(j)%sq(1:nw-1,1) = EXP(c + wc(1:nw-1)*(b + wc(1:nw-1)*a))
4060         ELSEWHERE
4061           xsqy_tab(j)%sq(1:nw-1,1) = 0.
4062         ENDWHERE
4063       endif
4064
4065       END SUBROUTINE r110
4066
4067 !=============================================================================*
4068
4069       SUBROUTINE r112(nw,wl,wc,nz,tlev,airden,j)
4070 !-----------------------------------------------------------------------------*
4071 !=  PURPOSE:                                                                 =*
4072 !=  Provide the product (cross section) x (quantum yield) for hydroxyacetone =*
4073 !=  CH2(OH)COCH3        photolysis:                                          =*
4074 !=           CH2(OH)COCH3  -> CH3CO + CH2OH
4075 !=                         -> CH2(OH)CO + CH3                                =*
4076 !=                                                                           =*
4077 !=  Cross section from Orlando et al. (1999)                                 =*
4078 !=                                                                           =*
4079 !=  Quantum yield assumed 0.325 for each channel (J. Orlando, priv.comm.2003)=*
4080 !-----------------------------------------------------------------------------*
4081
4082       INTEGER, intent(in) :: nw
4083       INTEGER, intent(in) :: nz
4084       INTEGER, intent(inout) :: j
4085       REAL, intent(in)    :: wl(kw), wc(kw)
4086       REAL, intent(in)    :: tlev(kz)
4087       REAL, intent(in)    :: airden(kz)
4088
4089 ! data arrays
4090       integer, PARAMETER :: kdata=100
4091
4092       INTEGER :: n
4093       REAL    :: x(kdata), y(kdata)
4094
4095 ! local
4096       REAL, parameter :: qy = .325
4097
4098       REAL :: yg(kw)
4099
4100       if( initialize ) then
4101         call check_alloc( ndx=j, nz=nw-1, nw=1 )
4102         CALL readit
4103         xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * qy
4104       endif
4105
4106       CONTAINS
4107
4108       SUBROUTINE readit
4109
4110       n = 96
4111       CALL base_read( filespec='DATAJ1/ABS/Hydroxyacetone_jpl11.abs', &
4112                       skip_cnt=2,rd_cnt=n,x=x,y=y )
4113       y(1:n) = y(1:n) * 1.e-20
4114
4115       CALL add_pnts_inter2(x,y,yg,kdata,n, &
4116                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4117
4118       END SUBROUTINE readit
4119
4120       END SUBROUTINE r112
4121
4122 !=============================================================================*
4123
4124       SUBROUTINE r113(nw,wl,wc,nz,tlev,airden,j)
4125 !-----------------------------------------------------------------------------*
4126 !=  PURPOSE:                                                                 =*
4127 !=  Provide the product (cross section) x (quantum yield) for HOBr           =*
4128 !=  HOBr -> OH + Br                                                          =*
4129 !=  Cross section from JPL 2003                                              =*
4130 !=  Quantum yield assumed unity as in JPL2003                                =*
4131 !-----------------------------------------------------------------------------*
4132
4133       INTEGER, intent(in) :: nw
4134       INTEGER, intent(in) :: nz
4135       INTEGER, intent(inout) :: j
4136       REAL, intent(in)    :: wl(kw), wc(kw)
4137       REAL, intent(in)    :: tlev(kz)
4138       REAL, intent(in)    :: airden(kz)
4139
4140 ! local
4141       REAL    :: sig(nw)
4142       REAL    :: xfac1(nw)
4143       INTEGER :: iw
4144
4145       if( initialize ) then
4146         call check_alloc( ndx=j, nz=nw-1, nw=1 )
4147         xsqy_tab(j)%sq(1:nw-1,1) = 0.
4148         WHERE( wc(1:nw-1) >= 250. .and. wc(1:nw-1) <= 550. )
4149           xfac1(1:nw-1) = 1./wc(1:nw-1)
4150           sig(1:nw-1) = 24.77 * exp( -109.80*(LOG(284.01*xfac1(1:nw-1)))**2 ) &
4151                 + 12.22 * exp(  -93.63*(LOG(350.57*xfac1(1:nw-1)))**2 ) &
4152                 + 2.283 * exp(- 242.40*(LOG(457.38*xfac1(1:nw-1)))**2 )
4153           xsqy_tab(j)%sq(1:nw-1,1) = sig(1:nw-1) * 1.e-20
4154         ENDWHERE
4155       endif
4156
4157       END SUBROUTINE r113
4158
4159 !=============================================================================*
4160
4161       SUBROUTINE r114(nw,wl,wc,nz,tlev,airden,j)
4162 !-----------------------------------------------------------------------------*
4163 !=  PURPOSE:                                                                 =*
4164 !=  Provide the product (cross section) x (quantum yield) for BrO            =*
4165 !=  BrO -> Br + O                                                            =*
4166 !=  Cross section from JPL 2003                                              =*
4167 !=  Quantum yield assumed unity as in JPL2003                                =*
4168 !-----------------------------------------------------------------------------*
4169
4170       INTEGER, intent(in) :: nw
4171       INTEGER, intent(in) :: nz
4172       INTEGER, intent(inout) :: j
4173       REAL, intent(in)    :: wl(kw), wc(kw)
4174       REAL, intent(in)    :: tlev(kz)
4175       REAL, intent(in)    :: airden(kz)
4176
4177 ! local
4178       INTEGER :: i, n
4179       REAL :: x(20), y(20)
4180       REAL :: dum
4181       REAL :: yg(kw)
4182
4183       if( initialize ) then
4184         call check_alloc( ndx=j, nz=nw-1, nw=1 )
4185         OPEN(UNIT=kin,FILE='DATAJ1/ABS/BrO.jpl03',STATUS='old')
4186         DO i = 1, 14
4187           READ(kin,*)
4188         ENDDO
4189         n = 15
4190         DO i = 1, n
4191           READ(kin,*) x(i), dum, y(i)
4192         ENDDO
4193         CLOSE(kin)
4194
4195         y(1:n) = y(1:n) * 1.e-20
4196         n = n + 1
4197         x(n) = dum
4198 ! use bin-to-bin interpolation
4199         CALL inter4(nw,wl,yg,n,x,y,1)
4200         xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1)
4201       endif
4202
4203       END SUBROUTINE r114
4204
4205 !=============================================================================*
4206
4207       SUBROUTINE r118(nw,wl,wc,nz,tlev,airden,j)
4208 !-----------------------------------------------------------------------------*
4209 != NO3-(aq) photolysis for snow simulations                                  =*
4210 !=        a) NO3-(aq) + hv -> NO2 + O-                                       =*
4211 !=        b) NO3-(aq) + hv -> NO2- + O(3P)                                   =*
4212 !=  Cross section:                                                           =*
4213 !=  Burley & Johnston, Geophys. Res. Lett., 19, 1359-1362 (1992)             =*
4214 !=  Chu & Anastasio, J. Phys. Chem. A, 107, 9594-9602 (2003)                 =*
4215 !=  Quantum yield:                                                           =*
4216 !=  Warneck & Wurzinger, J. Phys. Chem., 92, 6278-6283 (1988)                =*
4217 !=  Chu & Anastasio, J. Phys. Chem. A, 107, 9594-9602 (2003)                 =*
4218 !-----------------------------------------------------------------------------*
4219 != NOTE: user may have to manually add these reactions to the end of the     =*
4220 != reaction list in file usrinp to include these reactions for a snow run:   =*
4221 != T 74 NO3-(aq) -> NO2 + O-                                                 =*
4222 != T 75 NO3-(aq) -> NO2- + O(3P)                                             =*
4223 !-----------------------------------------------------------------------------*
4224
4225       INTEGER, intent(in) :: nw
4226       INTEGER, intent(in) :: nz
4227       INTEGER, intent(inout) :: j
4228       REAL, intent(in)    :: wl(kw), wc(kw)
4229       REAL, intent(in)    :: tlev(kz)
4230       REAL, intent(in)    :: airden(kz)
4231
4232 ! data arrays
4233       integer, PARAMETER :: kdata=50
4234
4235       REAL x1(kdata),x2(kdata)
4236       REAL y1(kdata),y2(kdata)     ! y1 = 20'C, y2 = -20'C
4237
4238 ! local
4239       REAL, parameter :: qyld(2:3) = (/ 1.1e-3,1. /)
4240 !     REAL, parameter :: qy2 = 1.1e-3
4241 !     REAL, parameter :: qy3 = 1.
4242
4243       REAL, save :: yg2(kw)
4244       REAL :: qy1(nz)
4245       INTEGER i, iw, n, idum
4246       integer :: chnl
4247       LOGICAL, save :: is_initialized = .false.
4248
4249       chnl = xsqy_tab(j)%channel
4250       if( initialize ) then
4251         if( .not. is_initialized ) then
4252           CALL readit
4253           is_initialized = .true.
4254         endif
4255         if( chnl > 1 ) then
4256           call check_alloc( ndx=j, nz=nw-1, nw=1 )
4257           xsqy_tab(j)%sq(1:nw-1,1) = qyld(chnl)*yg2(1:nw-1)
4258         endif
4259       else
4260         if( chnl == 1 ) then
4261           call check_alloc( j, nz, nw-1 )
4262
4263           qy1(1:nz) = exp(-2400./tlev(1:nz) + 3.6) ! Chu & Anastasio, 2003
4264           DO iw = 1, nw-1
4265             xsqy_tab(j)%sq(1:nz,iw) = qy1(1:nz)*yg2(iw)
4266           ENDDO
4267         endif
4268       endif
4269
4270       CONTAINS
4271
4272       SUBROUTINE readit
4273 !** NO3-(aq) cross sections from Chu and Anastasio 2003:
4274 ! convert from molar abs log10 to cm2 per molec
4275
4276       real :: wrk(kdata)
4277
4278       n = 43
4279       CALL base_read( filespec='DATAJ1/ABS/NO3-_CA03.abs', &
4280                       skip_cnt=7,rd_cnt=n,x=x1,y=y1,y1=wrk, &
4281                       y2=wrk,y3=wrk,y4=wrk )
4282       y1(1:n) = y1(1:n) * 3.82e-21
4283       CALL add_pnts_inter2(x1,y1,yg2,kdata,n, &
4284                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4285
4286       END SUBROUTINE readit
4287
4288       END SUBROUTINE r118
4289
4290 !=============================================================================*
4291
4292       SUBROUTINE r119(nw,wl,wc,nz,tlev,airden,j)
4293 !-----------------------------------------------------------------------------*
4294 !=  PURPOSE:                                                                 =*
4295 !=  Provide the product (cross section) x (quantum yield) for                =*
4296 !=    methylethylketone                                                      =*
4297 !=  CH3COCH2CH3 photolysis:                                                  =*
4298 !=           CH3COCH2CH3  -> CH3CO + CH2CH3                                  =*
4299 !=                                                                           =*
4300 !=  Cross section from Martinez et al. (1992)                                =*
4301 !=                                                                           =*
4302 !=  Quantum yield assumed 0.325 for each channel (J. Orlando, priv.comm.2003)=*
4303 !-----------------------------------------------------------------------------*
4304
4305       INTEGER, intent(in) :: nw
4306       INTEGER, intent(in) :: nz
4307       INTEGER, intent(inout) :: j
4308       REAL, intent(in)    :: wl(kw), wc(kw)
4309       REAL, intent(in)    :: tlev(kz)
4310       REAL, intent(in)    :: airden(kz)
4311
4312 ! data arrays
4313       integer, PARAMETER :: kdata=100
4314
4315       INTEGER i, n
4316       REAL x(kdata), y(kdata)
4317
4318 ! local
4319       REAL, save :: yg(kw)
4320       REAL :: ptorr(nz)
4321       REAL :: qy(nz)
4322       INTEGER ierr
4323       INTEGER iw
4324
4325       if( initialize ) then
4326         CALL readit
4327       else
4328         call check_alloc( j, nz, nw-1 )
4329
4330 ! Quantum Yields from
4331 ! Raber, W.H. (1992) PhD Thesis, Johannes Gutenberg-Universitaet, Mainz, Germany.
4332 ! other channels assumed negligible (less than 10%).
4333 ! Total quantum yield  = 0.38 at 760 Torr.
4334 ! Stern-Volmer form given:  1/phi = 0.96 + 2.22e-3*P(torr)
4335 !     compute local pressure in torr
4336
4337         ptorr(1:nz) = 760.*airden(1:nz)/2.69e19
4338         qy(1:nz)    = min( 1./(0.96 + 2.22E-3*ptorr(1:nz)),1. )
4339         DO iw = 1, nw-1
4340           xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * qy(1:nz)
4341         ENDDO
4342       endif
4343
4344       CONTAINS
4345
4346       SUBROUTINE readit
4347
4348       real :: wrk(kdata)
4349       n = 96
4350       CALL base_read( filespec='DATAJ1/ABS/Martinez.abs', &
4351                       skip_cnt=4,rd_cnt=n,x=x,y=wrk,y1=y, &
4352                       y2=wrk,y3=wrk )
4353       y(1:n) = y(1:n) * 1.e-20
4354
4355       CALL add_pnts_inter2(x,y,yg,kdata,n, &
4356                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4357
4358       END SUBROUTINE readit
4359
4360       END SUBROUTINE r119
4361
4362 !=============================================================================*
4363
4364       SUBROUTINE r120(nw,wl,wc,nz,tlev,airden,j)
4365 !-----------------------------------------------------------------------------*
4366 !=  PURPOSE:                                                                 =*
4367 !=  Provide product (cross section) x (quantum yield) for PPN photolysis:    =*
4368 !=       PPN + hv -> Products                                                =*
4369 !=                                                                           =*
4370 !=  Cross section: from JPL 2006 (originally from Harwood et al. 2003)       =*
4371 !=  Quantum yield: Assumed to be unity                                       =*
4372 !-----------------------------------------------------------------------------*
4373
4374       INTEGER, intent(in) :: nw
4375       INTEGER, intent(in) :: nz
4376       INTEGER, intent(inout) :: j
4377       REAL, intent(in)    :: wl(kw), wc(kw)
4378       REAL, intent(in)    :: tlev(kz)
4379       REAL, intent(in)    :: airden(kz)
4380
4381 ! data arrays
4382       integer, PARAMETER :: kdata=100
4383
4384       INTEGER :: iw
4385       INTEGER :: n
4386       REAL    :: x1(kdata), x2(kdata)
4387       REAL    :: y1(kdata), y2(kdata)
4388
4389 ! local
4390       real, parameter :: qyld(2) = (/ 0.61,0.39 /)
4391
4392       INTEGER :: chnl
4393       REAL, save :: yg(kw), yg2(kw)
4394       real :: t(nz)
4395       REAL :: sig(nz)
4396       LOGICAL, save :: is_initialized = .false.
4397
4398       if( initialize ) then
4399         if( .not. is_initialized ) then
4400           CALL readit
4401           is_initialized = .true.
4402         endif
4403       else
4404         call check_alloc( j, nz, nw-1 )
4405
4406         chnl = xsqy_tab(j)%channel
4407         t(1:nz) = tlev(1:nz) - 298.
4408         DO iw = 1, nw-1
4409           sig(1:nz) = yg(iw) * EXP(yg2(iw)*t(1:nz))
4410           xsqy_tab(j)%sq(1:nz,iw) = qyld(chnl) * sig(1:nz)
4411         ENDDO
4412       endif
4413
4414       CONTAINS
4415
4416       SUBROUTINE readit
4417 ! cross section from JPL 2011 (originally from Harwood et al. 2003)
4418
4419       integer :: nsav
4420       real    :: xsav(kdata)
4421
4422       n = 66 ; nsav = 66
4423       CALL base_read( filespec='DATAJ1/ABS/PPN_Harwood.txt', &
4424                       skip_cnt=10,rd_cnt=n,x=x1,y=y1,y1=y2 )
4425       y1(1:n) = y1(1:n) * 1.E-20
4426       y2(1:n) = y2(1:n) * 1E-3
4427       xsav(1:n) = x1(1:n)
4428
4429       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
4430                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4431
4432       n = nsav ; x1(1:n) = xsav(1:n)
4433       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
4434                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4435
4436       END SUBROUTINE readit
4437
4438       END SUBROUTINE r120
4439
4440 !=============================================================================*
4441
4442       SUBROUTINE r122(nw,wl,wc,nz,tlev,airden,j)
4443 !-----------------------------------------------------------------------------*
4444 !=  PURPOSE:                                                                 =*
4445 !=  Provide product (cross section) x (quantum yield) for CH2=CHCHO          =*
4446 !=  (acrolein) photolysis:                                                   =*
4447 !=       CH2=CHCHO + hv -> Products                                          =*
4448 !=                                                                           =*
4449 !=  Cross section: from JPL 2006 (originally from Magneron et al.            =*
4450 !=  Quantum yield: P-dependent, JPL 2006 orig. from Gardner et al.           =*
4451 !-----------------------------------------------------------------------------*
4452
4453       INTEGER, intent(in) :: nw
4454       INTEGER, intent(in) :: nz
4455       INTEGER, intent(inout) :: j
4456       REAL, intent(in)    :: wl(kw), wc(kw)
4457       REAL, intent(in)    :: tlev(kz)
4458       REAL, intent(in)    :: airden(kz)
4459
4460 ! data arrays
4461       integer, PARAMETER :: kdata=100
4462
4463       INTEGER iw
4464       INTEGER i, n
4465       INTEGER n2
4466       REAL x1(kdata), x2(kdata)
4467       REAL y1(kdata), y2(kdata)
4468
4469 ! local
4470       REAL, save :: yg(kw)
4471       real :: qy(nz), qym1(nz)
4472       REAL sig
4473       INTEGER ierr
4474
4475       if( initialize ) then
4476         CALL readit
4477       else
4478         call check_alloc( j, nz, nw-1 )
4479
4480 ! quantum yields are pressure dependent between air number densities
4481 ! of 8e17 and 2.6e19, Gardner et al.:
4482         DO iw = 1, nw-1
4483           where( airden(1:nz) > 2.6e19 )
4484             qy(1:nz) = 0.004
4485           elsewhere( airden(1:nz) > 8.e17 .and. airden(1:nz) <= 2.6e19 )
4486             qym1(1:nz) = 0.086 + 1.613e-17 * airden(1:nz)
4487             qy(1:nz)   = 0.004 + 1./qym1(1:nz)
4488           elsewhere( airden(1:nz) <= 8.e17 )
4489             qym1(1:nz) = 0.086 + 1.613e-17 * 8.e17
4490             qy(1:nz)   = 0.004 + 1./qym1(1:nz)
4491           endwhere
4492           xsqy_tab(j)%sq(1:nz,iw) = qy(1:nz) * yg(iw)
4493         ENDDO
4494       endif
4495
4496       CONTAINS
4497
4498       SUBROUTINE readit
4499 ! cross section from JPL 2006 (originally from Magneron et al.)
4500
4501       n = 55
4502       CALL base_read( filespec='DATAJ1/ABS/Acrolein.txt',skip_cnt=6,rd_cnt=n,x=x1,y=y1 )
4503       y1(1:n) = y1(1:n) * 1.E-20
4504
4505       CALL add_pnts_inter2(x1,y1,yg,kdata,n,nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4506
4507       END SUBROUTINE readit
4508
4509       END SUBROUTINE r122
4510
4511 !=============================================================================*
4512
4513       SUBROUTINE r125(nw,wl,wc,nz,tlev,airden,j)
4514 !-----------------------------------------------------------------------------*
4515 !=  PURPOSE:                                                                 =*
4516 !=  Provide product (cross section) x (quantum yield) for ClO photolysis     =*
4517 !=       ClO + hv -> Cl + O                                                  =*
4518 !=                                                                           =*
4519 !=  Cross section: from Maric and Burrows 1999                               =*
4520 !=  Quantum yield: Assumed to be unity                                       =*
4521 !-----------------------------------------------------------------------------*
4522
4523       INTEGER, intent(in) :: nw
4524       INTEGER, intent(in) :: nz
4525       REAL, intent(in)    :: wl(kw), wc(kw)
4526       REAL, intent(in)    :: tlev(kz)
4527       REAL, intent(in)    :: airden(kz)
4528
4529       INTEGER, intent(inout) :: j
4530 ! data arrays
4531       integer, PARAMETER :: kdata=500
4532
4533       INTEGER iw
4534       INTEGER i, n
4535       REAL x1(kdata)
4536       REAL y1(kdata)
4537       INTEGER ierr
4538
4539 ! local
4540       REAL :: yg(kw)
4541       REAL qy1, qy2
4542
4543       real, save :: tmp(12)
4544       real, save :: ygt(kw,12)
4545       real x(kdata), y(kdata,12)
4546       real tx, xdum
4547       integer m, nn, ii
4548       real yy
4549       INTEGER m1, m2
4550       LOGICAL, save :: is_initialized = .false.
4551
4552       if( initialize ) then
4553         if( .not. is_initialized ) then
4554           CALL readit
4555           tmp(1)    = 180.
4556           tmp(2:12) = (/ (190. + 10.*real(m-1),m=2,12) /)
4557           is_initialized = .true.
4558         endif
4559       else
4560         call check_alloc( j, nz, nw-1 )
4561
4562         DO i = 1, nz
4563           tx = tlev(i)
4564 ! locate temperature indices for interpolation:
4565           m1 = 1 + INT(.1*(tx - 190.))
4566           m1 = MIN(MAX(1 ,m1),11)
4567           m2 = m1 + 1
4568           DO iw = 1, nw-1
4569             yy = ygt(iw,m1) + (ygt(iw,m2) - ygt(iw,m1)) &
4570                  * (tx - tmp(m1))/(tmp(m2) - tmp(m1))
4571 ! threshold for O(1D) productionis 263.4 nm:
4572             if(wc(iw) .lt. 263.4) then
4573                qy1 = 1.
4574             else
4575                qy1 = 0.
4576             endif
4577             qy2 = 1. - qy1
4578             if( xsqy_tab(j)%channel == 1 ) then
4579               xsqy_tab(j)%sq(i,iw) = qy1 * yy
4580             elseif( xsqy_tab(j)%channel == 2 ) then
4581               xsqy_tab(j)%sq(i,iw) = qy2 * yy
4582             endif
4583           ENDDO
4584         ENDDO
4585       endif
4586
4587       CONTAINS
4588
4589       SUBROUTINE readit
4590 ! cross section from
4591 ! Maric D. and J.P. Burrows, J. Quantitative Spectroscopy and
4592 ! Radiative Transfer 62, 345-369, 1999.  Data was downloaded from
4593 ! their web site on 15 September 2009.
4594
4595       integer :: nsav
4596       real    :: xsav(kdata)
4597
4598       OPEN(UNIT=kin,FILE='DATAJ1/ABS/ClO_spectrum.prn',STATUS='OLD')
4599       DO i = 1, 2
4600          READ(kin,*)
4601       ENDDO
4602       nn = 453 ; nsav = 453
4603       DO ii = 1, nn
4604          i = nn - ii + 1
4605          READ(kin,*) xdum, x(i), xdum, (y(i,m), m = 1, 12)
4606       ENDDO
4607       CLOSE(kin)
4608
4609       xsav(1:nn) = x(1:nn)
4610       DO m = 1, 12
4611          nn = nsav
4612          x1(1:nn) = xsav(1:nn)
4613          y1(1:nn) = y(1:nn,m)
4614          CALL add_pnts_inter2(x1,y1,yg,kdata,nn, &
4615                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4616          ygt(1:nw-1,m) = yg(1:nw-1)
4617       ENDDO
4618
4619       END SUBROUTINE readit
4620
4621       END SUBROUTINE r125
4622
4623 !=============================================================================*
4624
4625       SUBROUTINE r129(nw,wl,wc,nz,tlev,airden,j)
4626 !-----------------------------------------------------------------------------*
4627 !=  PURPOSE:                                                                 =*
4628 !=  Provide product (cross section) x (quantum yield) for bromine nitrite    =*
4629 !=       BrONO -> Br + NO2                                                   =*
4630 !=       BrONO -> BrO + NO                                                   =*
4631 !=                                                                           =*
4632 !=  Cross section: from IUPAC (vol.3)                                        =*
4633 !=  Quantum yield: Assumed to be 0.5 for each channel                        =*
4634 !-----------------------------------------------------------------------------*
4635
4636       INTEGER, intent(in) :: nw
4637       INTEGER, intent(in) :: nz
4638       INTEGER, intent(inout) :: j
4639       REAL, intent(in)    :: wl(kw), wc(kw)
4640       REAL, intent(in)    :: tlev(kz)
4641       REAL, intent(in)    :: airden(kz)
4642
4643 ! data arrays
4644       integer, PARAMETER :: kdata=50
4645
4646       INTEGER :: n
4647       INTEGER :: chnl
4648       REAL    :: x1(kdata)
4649       REAL    :: y1(kdata)
4650
4651 ! local
4652       real, parameter :: qyld(2) = 0.5
4653
4654       REAL :: yg(kw)
4655
4656       if( initialize ) then
4657         call check_alloc( ndx=j, nz=nw-1, nw=1 )
4658         CALL readit
4659         chnl = xsqy_tab(j)%channel
4660         xsqy_tab(j)%sq(1:nw-1,1) = qyld(chnl) * yg(1:nw-1)
4661       endif
4662
4663       CONTAINS
4664
4665       SUBROUTINE readit
4666 ! cross section from IUPAC (vol III) 2007
4667
4668       n = 32
4669       CALL base_read( filespec='DATAJ1/ABS/BrONO.abs', &
4670                       skip_cnt=8,rd_cnt=n,x=x1,y=y1 )
4671
4672       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
4673                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4674
4675       END SUBROUTINE readit
4676
4677       END SUBROUTINE r129
4678
4679 !******************************************************************
4680
4681       SUBROUTINE r131(nw,wl,wc,nz,tlev,airden,j)
4682 !-----------------------------------------------------------------------------*
4683 !=  PURPOSE:                                                                 =*
4684 !=  Provide product (cross section) x (quantum yield) for
4685 !=       NOCl -> NO + Cl                                                     =*
4686 !=  Cross section: from IUPAC (vol.3)                                        =*
4687 !=  Quantum yield: Assumed to be 1                                           =*
4688 !-----------------------------------------------------------------------------*
4689
4690       INTEGER, intent(in) :: nw
4691       INTEGER, intent(in) :: nz
4692       INTEGER, intent(inout) :: j
4693       REAL, intent(in)    :: wl(kw), wc(kw)
4694       REAL, intent(in)    :: tlev(kz)
4695       REAL, intent(in)    :: airden(kz)
4696
4697 ! data arrays
4698       integer, PARAMETER :: kdata=150
4699
4700       INTEGER iw
4701       INTEGER i, n, ii
4702       REAL x1(kdata), y1(kdata)
4703       REAL y223(kdata),y243(kdata),y263(kdata),y298(kdata), &
4704            y323(kdata), y343(kdata)
4705       INTEGER ierr
4706
4707 ! local
4708       REAL, save :: yg223(kw),yg243(kw),yg263(kw), &
4709                     yg298(kw),yg323(kw), yg343(kw)
4710       REAL qy, sig
4711
4712       if( initialize ) then
4713         CALL readit
4714       else
4715         call check_alloc( j, nz, nw-1 )
4716 ! quantum yields assumed unity
4717         DO iw = 1, nw-1
4718           where( tlev(1:nz) .le. 223. )
4719             xsqy_tab(j)%sq(1:nz,iw) = yg223(iw)
4720           elsewhere (tlev(1:nz) .gt. 223. .and. tlev(1:nz) .le. 243. )
4721             xsqy_tab(j)%sq(1:nz,iw) = yg223(iw) &
4722                    + (yg243(iw) - yg223(iw))*(tlev(1:nz) - 223.)*.05
4723           elsewhere (tlev(1:nz) .gt. 243. .and. tlev(1:nz) .le. 263. )
4724             xsqy_tab(j)%sq(1:nz,iw) = yg243(iw) &
4725                    + (yg263(iw) - yg243(iw))*(tlev(1:nz) - 243.)*.05
4726           elsewhere (tlev(1:nz) .gt. 263. .and. tlev(1:nz) .le. 298. )
4727             xsqy_tab(j)%sq(1:nz,iw) = yg263(iw) &
4728                    + (yg298(iw) - yg263(iw))*(tlev(1:nz) - 263.)/35.
4729           elsewhere (tlev(1:nz) .gt. 298. .and. tlev(1:nz) .le. 323. )
4730             xsqy_tab(j)%sq(1:nz,iw) = yg298(iw) &
4731                    + (yg323(iw) - yg298(iw))*(tlev(1:nz) - 298.)*.04
4732           elsewhere (tlev(1:nz) .gt. 323. .and. tlev(1:nz) .le. 343. )
4733             xsqy_tab(j)%sq(1:nz,iw) = yg323(iw) &
4734                    + (yg343(iw) - yg323(iw))*(tlev(1:nz) - 323.)*.05
4735           elsewhere (tlev(1:nz) .gt. 343. )
4736             xsqy_tab(j)%sq(1:nz,iw) = 0.
4737           endwhere
4738         ENDDO
4739       endif
4740
4741       CONTAINS
4742
4743       SUBROUTINE readit
4744 ! cross section from IUPAC (vol III) 2007
4745
4746       integer :: nsav
4747       real    :: xsav(kdata)
4748
4749       n = 80
4750       CALL base_read( filespec='DATAJ1/ABS/NOCl.abs', &
4751                       skip_cnt=7,rd_cnt=n,x=x1,y=y1 )
4752       y223(1:n) = y1(1:n)
4753       y243(1:n) = y1(1:n)
4754       y263(1:n) = y1(1:n)
4755       y298(1:n) = y1(1:n)
4756       y323(1:n) = y1(1:n)
4757       y343(1:n) = y1(1:n)
4758       ii = 61
4759       CALL base_read( filespec='DATAJ1/ABS/NOCl.abs', &
4760                       skip_cnt=88,rd_cnt=ii,x=x1(n+1:),y=y223(n+1:), &
4761                       y1=y243(n+1:),y2=y263(n+1:),y3=y298(n+1:), &
4762                       y4=y323(n+1:),y5=y343(n+1:) )
4763
4764       n = n + ii
4765       nsav = n ; xsav(1:n) = x1(1:n)
4766
4767       CALL add_pnts_inter2(x1,y223,yg223,kdata,n, &
4768                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4769
4770       n = nsav ; x1(1:n) = xsav(1:n)
4771       CALL add_pnts_inter2(x1,y243,yg243,kdata,n, &
4772                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4773
4774       n = nsav ; x1(1:n) = xsav(1:n)
4775       CALL add_pnts_inter2(x1,y263,yg263,kdata,n, &
4776                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4777
4778       n = nsav ; x1(1:n) = xsav(1:n)
4779       CALL add_pnts_inter2(x1,y298,yg298,kdata,n, &
4780                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4781
4782       n = nsav ; x1(1:n) = xsav(1:n)
4783       CALL add_pnts_inter2(x1,y323,yg323,kdata,n, &
4784                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4785
4786       n = nsav ; x1(1:n) = xsav(1:n)
4787       CALL add_pnts_inter2(x1,y343,yg343,kdata,n, &
4788                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4789
4790       END SUBROUTINE readit
4791
4792       END SUBROUTINE r131
4793
4794 !******************************************************************
4795
4796       SUBROUTINE r132(nw,wl,wc,nz,tlev,airden,j)
4797 !-----------------------------------------------------------------------------*
4798 !=  PURPOSE:                                                                 =*
4799 !=  Provide product (cross section) x (quantum yield) for
4800 !=       OClO -> Products                                                    =*
4801 !=  Cross section: from Wahner et al., J. Phys. Chem. 91, 2734, 1987         =*
4802 !=  Quantum yield: Assumed to be 1                                           =*
4803 !-----------------------------------------------------------------------------*
4804
4805       INTEGER, intent(in) :: nw
4806       INTEGER, intent(in) :: nz
4807       INTEGER, intent(inout) :: j
4808       REAL, intent(in)    :: wl(kw), wc(kw)
4809       REAL, intent(in)    :: tlev(kz)
4810       REAL, intent(in)    :: airden(kz)
4811
4812 ! data arrays
4813       integer, PARAMETER :: kdata=2000
4814
4815       INTEGER iw
4816       INTEGER i, n
4817       REAL x1(kdata), y1(kdata)
4818       integer nn, n204, n296, n378
4819       REAL x204(kdata),x296(kdata),x378(kdata)
4820       REAL y204(kdata),y296(kdata),y378(kdata)
4821
4822       INTEGER ierr
4823
4824 ! local
4825       REAL, save :: yg204(kw),yg296(kw),yg378(kw)
4826       REAL qy, sig
4827
4828       if( initialize ) then
4829         CALL readit
4830       else
4831         call check_alloc( j, nz, nw-1 )
4832 ! quantum yields assumed unity
4833         DO iw = 1, nw-1
4834           where(tlev(1:nz) .le. 204. )
4835             xsqy_tab(j)%sq(1:nz,iw) = yg204(iw)
4836           elsewhere (tlev(1:nz) .gt. 204. .and. tlev(1:nz) .le. 296. )
4837             xsqy_tab(j)%sq(1:nz,iw) = yg204(iw) &
4838                 + (yg296(iw) - yg204(iw))*(tlev(1:nz) - 204.)/92.
4839           elsewhere (tlev(1:nz) .gt. 296. .and. tlev(1:nz) .le. 378. )
4840             xsqy_tab(j)%sq(1:nz,iw) = yg296(iw) &
4841                 + (yg378(iw) - yg296(iw))*(tlev(1:nz) - 296.)/82.
4842           elsewhere (tlev(1:nz) .gt. 378. )
4843             xsqy_tab(j)%sq(1:nz,iw) = yg378(iw)
4844           endwhere
4845         ENDDO
4846       endif
4847
4848       CONTAINS
4849
4850       SUBROUTINE readit
4851 ! cross section from
4852 !A. Wahner, G.S. tyndall, A.R. Ravishankara, J. Phys. Chem., 91, 2734, (1987).
4853 !Supplementary Data, as quoted at:
4854 !http://www.atmosphere.mpg.de/enid/26b4b5172008b02407b2e47f08de2fa1,0/Spectra/Introduction_1rr.html
4855
4856       OPEN(UNIT=kin,FILE='DATAJ1/ABS/OClO.abs',STATUS='OLD')
4857       DO i = 1, 6
4858          READ(kin,*)
4859       ENDDO
4860       n204 = 1074-6
4861       DO i = 1, n204
4862          READ(kin,*) x204(i), y204(i)
4863       ENDDO
4864
4865       READ(kin,*)
4866       n296 = 1067
4867       do i = 1, n296
4868          read(kin,*) x296(i), y296(i)
4869       enddo
4870
4871       read(kin,*)
4872       n378 = 1068
4873       do i = 1, n378
4874          read(kin,*) x378(i), y378(i)
4875       enddo
4876
4877       CLOSE(kin)
4878
4879       CALL add_pnts_inter2(x204,y204,yg204,kdata,n204, &
4880                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4881
4882       CALL add_pnts_inter2(x296,y296,yg296,kdata,n296, &
4883                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4884
4885       CALL add_pnts_inter2(x378,y378,yg378,kdata,n378, &
4886                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4887
4888       END SUBROUTINE readit
4889
4890       END SUBROUTINE r132
4891
4892 !******************************************************************
4893
4894       SUBROUTINE pxCH2O(nw,wl,wc,nz,tlev,airden,j)
4895 !-----------------------------------------------------------------------------*
4896 !=  PURPOSE:                                                                 =*
4897 !=  JPL 2011 recommendation.                                                 =*
4898 !=  Provide product of (cross section) x (quantum yield) for CH2O photolysis =*
4899 !=        (a) CH2O + hv -> H + HCO                                           =*
4900 !=        (b) CH2O + hv -> H2 + CO                                           =*
4901 !=  written by s. madronich march 2013
4902 !-----------------------------------------------------------------------------*
4903
4904       INTEGER, intent(in) :: nw
4905       INTEGER, intent(in) :: nz
4906       INTEGER, intent(inout) :: j
4907       REAL, intent(in)    :: wl(kw), wc(kw)
4908       REAL, intent(in)    :: tlev(kz)
4909       REAL, intent(in)    :: airden(kz)
4910
4911       integer, PARAMETER :: kdata=200
4912
4913 ! data arrays
4914       INTEGER iw
4915       INTEGER n, n1, n2
4916       REAL x1(kdata), x2(kdata)
4917       REAL y298(kdata), tcoef(kdata)
4918       REAL qr(kdata), qm(kdata)
4919
4920 ! local
4921       INTEGER ierr
4922       REAL ak300
4923       real qyr300, qym300
4924       REAL, save :: yg1(kw), yg2(kw), yg3(kw), yg4(kw)
4925       REAL :: t(nz), t1(nz)
4926       REAL :: sig(nz)
4927       REAL :: qymt(nz)
4928       REAL :: akt(nz)
4929       LOGICAL, save :: is_initialized = .false.
4930
4931       if( initialize ) then
4932         if( .not. is_initialized ) then
4933           CALL readit
4934           is_initialized = .true.
4935         endif
4936       else
4937         call check_alloc( j, nz, nw-1 )
4938
4939         t(1:nz)  = tlev(1:nz) - 298.
4940         t1(1:nz) = (300. - tlev(1:nz))/80.
4941         DO iw = 1, nw - 1
4942 ! correct cross section for temperature dependence:
4943           sig(1:nz) = yg1(iw) + yg2(iw) * t(1:nz)
4944 ! assign room temperature quantum yields for radical and molecular channels
4945           qyr300 = yg3(iw)
4946           qym300 = yg4(iw)
4947 ! between 330 ande 360 nm, molecular channel is pressure and temperature dependent.
4948           IF (wc(iw) .ge. 330. .and. wc(iw) .lt. 360. .and. qym300 .gt. 0.) then
4949             ak300 = (1. - (qym300+qyr300))/(qym300*(1. - qyr300))
4950             ak300 = ak300/2.45e19
4951             akt(1:nz) = ak300 * (1. + 0.05 * (wc(iw) - 329.) * t1(1:nz))
4952             qymt(1:nz) = 1./(1./(1.-qyr300) + akt(1:nz)*airden(1:nz))
4953           ELSE
4954             qymt(1:nz) = qym300
4955           ENDIF
4956           if( xsqy_tab(j)%channel == 1 ) then
4957             xsqy_tab(j)%sq(1:nz,iw) = sig(1:nz) * qyr300
4958           elseif( xsqy_tab(j)%channel == 2 ) then
4959             xsqy_tab(j)%sq(1:nz,iw) = sig(1:nz) * qymt(1:nz)
4960           endif
4961         ENDDO
4962       endif
4963
4964       CONTAINS
4965
4966       SUBROUTINE readit
4967 ! read JPL2011 cross section data:
4968
4969       integer :: nsav
4970       real    :: xsav(kdata)
4971
4972       n = 150 ; nsav = 150
4973       CALL base_read( filespec='DATAJ1/CH2O/CH2O_jpl11.abs', &
4974                       skip_cnt=4,rd_cnt=n,x=x1,y=y298, &
4975                       y1=tcoef )
4976       y298(1:n)  = y298(1:n) * 1.e-20
4977       tcoef(1:n) = tcoef(1:n) * 1.e-24
4978       xsav(1:n) = x1(1:n)
4979
4980 !     terminate endpoints and interpolate to working grid
4981       CALL add_pnts_inter2(x1,y298,yg1,kdata,n, &
4982                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4983
4984       n = nsav ; x1(1:n) = xsav(1:n)
4985       CALL add_pnts_inter2(x1,tcoef,yg2,kdata,n, &
4986                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
4987
4988 ! quantum yields: Read, terminate, interpolate:
4989
4990       n = 112 ; nsav = 112
4991       CALL base_read( filespec='DATAJ1/CH2O/CH2O_jpl11.yld', &
4992                       skip_cnt=4,rd_cnt=n,x=x1,y=qr,y1=qm )
4993       xsav(1:n) = x1(1:n)
4994
4995       CALL add_pnts_inter2(x1,qr,yg3,kdata,n, &
4996                            nw,wl,xsqy_tab(j)%label,deltax,(/qr(1),0./))
4997
4998       n = nsav ; x1(1:n) = xsav(1:n)
4999       CALL add_pnts_inter2(x1,qm,yg4,kdata,n, &
5000                            nw,wl,xsqy_tab(j)%label,deltax,(/qm(1),0./))
5001
5002       END SUBROUTINE readit
5003
5004       END SUBROUTINE pxCH2O
5005
5006 !=============================================================================*
5007
5008       SUBROUTINE r140(nw,wl,wc,nz,tlev,airden,j)
5009 !-----------------------------------------------------------------------------*
5010 !=  PURPOSE:                                                                 =*
5011 !=  Provide product (cross section) x (quantum yield) for CHCl3 photolysis:  =*
5012 !=      CHCL3 + hv -> Products                                               =*
5013 !=  Cross section: from JPL 2011 recommendation                              =*
5014 !=  Quantum yield: assumed to be unity                                       =*
5015 !-----------------------------------------------------------------------------*
5016
5017       INTEGER, intent(in) :: nw
5018       INTEGER, intent(in) :: nz
5019       INTEGER, intent(inout) :: j
5020       REAL, intent(in)    :: wl(kw), wc(kw)
5021       REAL, intent(in)    :: tlev(kz)
5022       REAL, intent(in)    :: airden(kz)
5023
5024 ! data arrays
5025       integer, PARAMETER :: kdata=50
5026
5027       REAL x1(kdata)
5028       REAL y1(kdata)
5029
5030 ! local
5031 ! temperature correction factors:
5032       real, parameter :: b0 = 3.7973
5033       real, parameter :: b1 = -7.0913e-2
5034       real, parameter :: b2 = 4.9397e-4
5035       real, parameter :: b3 = -1.5226e-6
5036       real, parameter :: b4 = 1.7555e-9
5037
5038       INTEGER :: iw, n
5039       REAL, save :: yg(kw)
5040       REAL    :: tcoeff
5041       REAL    :: w1
5042       REAL    :: sig(nz)
5043       REAL    :: temp(nz)
5044
5045       if( initialize ) then
5046         CALL readit
5047       else
5048         call check_alloc( j, nz, nw-1 )
5049
5050 !** quantum yield assumed to be unity
5051         temp(1:nz) = min(max(tlev(1:nz),210.),300.) - 295.
5052         DO iw = 1, nw-1
5053 ! compute temperature correction coefficients:
5054           tcoeff = 0.
5055           w1 = wc(iw)
5056           IF(w1 > 190. .AND. w1 < 240.) THEN
5057             tcoeff = b0 + w1*(b1 + w1*(b2 + w1*(b3 + w1*b4)))
5058           ENDIF
5059           xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * 10.**(tcoeff*temp(1:nz))
5060         ENDDO
5061       endif
5062
5063       CONTAINS
5064
5065       SUBROUTINE readit
5066
5067       n = 39
5068       CALL base_read( filespec='DATAJ1/ABS/CHCl3_jpl11.abs', &
5069                       skip_cnt=3,rd_cnt=n,x=x1,y=y1 )
5070       y1(1:n) = y1(1:n) * 1.E-20
5071
5072       CALL add_pnts_inter2(x1,y1,yg,kdata,n, &
5073                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
5074
5075       END SUBROUTINE readit
5076
5077       END SUBROUTINE r140
5078
5079 !=============================================================================*
5080
5081       SUBROUTINE r141(nw,wl,wc,nz,tlev,airden,j)
5082 !-----------------------------------------------------------------------------*
5083 !=  PURPOSE:                                                                 =*
5084 !=  Provide product (cross section) x (quantum yield) for C2H5ONO2           =*
5085 !=  photolysis:                                                              =*
5086 !=          C2H5ONO2 + hv -> C2H5O + NO2                                     =*
5087 !=                                                                           =*
5088 !=  Cross section:  IUPAC 2006 (Atkinson et al., ACP, 6, 3625-4055, 2006)    =*
5089 !=  Quantum yield: Assumed to be unity                                       =*
5090 !-----------------------------------------------------------------------------*
5091
5092       INTEGER, intent(in) :: nw
5093       INTEGER, intent(in) :: nz
5094       INTEGER, intent(inout) :: j
5095       REAL, intent(in)    :: wl(kw), wc(kw)
5096       REAL, intent(in)    :: tlev(kz)
5097       REAL, intent(in)    :: airden(kz)
5098
5099 ! data arrays
5100       integer, PARAMETER :: kdata = 50
5101
5102       INTEGER :: iw
5103       REAL    :: x1(kdata), x2(kdata)
5104       REAL    :: y1(kdata), y2(kdata)
5105
5106 ! local
5107       REAL, save :: yg1(kw), yg2(kw)
5108       real :: t(nz)
5109
5110       if( initialize ) then
5111         CALL readit
5112       else
5113         call check_alloc( j, nz, nw-1 )
5114 ! quantum yield = 1
5115         t(1:nz) = tlev(1:nz) - 298.
5116         DO iw = 1, nw - 1
5117           xsqy_tab(j)%sq(1:nz,iw) = yg1(iw) * exp(yg2(iw) * t(1:nz))
5118         ENDDO
5119       endif
5120
5121       CONTAINS
5122
5123       SUBROUTINE readit
5124 ! mabs: absorption cross section options: 1:  IUPAC 2006
5125
5126       integer :: n, nsav
5127       real    :: xsav(kdata)
5128
5129       n = 32 ; nsav = 32
5130       CALL base_read( filespec='DATAJ1/RONO2/C2H5ONO2_iup2006.abs', &
5131                       skip_cnt=4,rd_cnt=n,x=x1,y=y1,y1=y2 )
5132       y1(1:n) = y1(1:n) * 1.e-20
5133       y2(1:n) = y2(1:n) * 1.e-3
5134       xsav(1:n) = x1(1:n)
5135
5136       CALL add_pnts_inter2(x1,y1,yg1,kdata,n, &
5137                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
5138
5139       n = nsav ; x1(1:n) = xsav(1:n)
5140       CALL add_pnts_inter2(x1,y2,yg2,kdata,n, &
5141                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
5142
5143       END SUBROUTINE readit
5144
5145       END SUBROUTINE r141
5146
5147       SUBROUTINE r146(nw,wl,wc,nz,tlev,airden,j)
5148 !-----------------------------------------------------------------------------*
5149 !=  PURPOSE:                                                                 =*
5150 !=  Provide product (cross section) x (quantum yield) for                    =*
5151 !=     molecular Iodine, I2                                                  =*
5152 !=  cross section from JPL2011                                               =*
5153 !=  Quantum yield: wave-dep, from Brewer and Tellinhuisen, 1972              =*
5154 !=  Quantum yield for Unimolecular Dissociation of I2 in Visible Absorption  =*
5155 !=  J. Chem. Phys. 56, 3929-3937, 1972.
5156 !-----------------------------------------------------------------------------*
5157
5158       INTEGER, intent(in) :: nw
5159       INTEGER, intent(in) :: nz
5160       INTEGER, intent(inout) :: j
5161       REAL, intent(in)    :: wl(kw), wc(kw)
5162       REAL, intent(in)    :: tlev(kz)
5163       REAL, intent(in)    :: airden(kz)
5164
5165 ! data arrays
5166       integer, PARAMETER :: kdata=200
5167
5168       INTEGER :: n
5169       REAL    :: x(kdata), y(kdata)
5170
5171 ! local
5172       REAL    :: yg1(kw), yg2(kw)
5173
5174       if( initialize ) then
5175         call check_alloc( ndx=j, nz=nw-1, nw=1 )
5176         CALL readit
5177         xsqy_tab(j)%sq(1:nw-1,1) = yg1(1:nw-1) * yg2(1:nw-1)
5178       endif
5179
5180       CONTAINS
5181
5182       SUBROUTINE readit
5183 ! cross section from JPL2011
5184
5185       n = 104
5186       CALL base_read( filespec='DATAJ1/ABS/I2_jpl11.abs', &
5187                       skip_cnt=2,rd_cnt=n,x=x,y=y )
5188       y(1:n) = y(1:n) * 1.e-20
5189
5190       CALL add_pnts_inter2(x,y,yg1,kdata,n, &
5191                            nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./))
5192
5193 ! quantum yields
5194
5195       n = 12
5196       CALL base_read( filespec='DATAJ1/YLD/I2.qy',skip_cnt=4,rd_cnt=n,x=x,y=y )
5197
5198       CALL add_pnts_inter2(x,y,yg2,kdata,n,nw,wl,xsqy_tab(j)%label,deltax,(/1.,0./))
5199
5200       END SUBROUTINE readit
5201
5202       END SUBROUTINE r146
5203
5204       SUBROUTINE add_pnts_inter2(xin,yin,yout,kdata,n,nw,wl,jlabel,deltax,yends)
5205
5206       integer, intent(in) :: kdata
5207       integer, intent(in) :: n
5208       integer, intent(in) :: nw
5209       real, intent(in)    :: deltax
5210       real, intent(in)    :: wl(nw)
5211       real, intent(in)    :: xin(kdata)
5212       real, intent(in)    :: yin(kdata)
5213       real, intent(in)    :: yends(2)
5214       real, intent(inout) :: yout(kdata)
5215       character(len=*), intent(in) :: jlabel
5216
5217       integer :: ierr, m
5218       real    :: xwrk(kdata), ywrk(kdata)
5219       character(len=256) :: emsg
5220
5221       m = n
5222       xwrk(1:n) = xin(1:n)
5223       ywrk(1:n) = yin(1:n)
5224       CALL addpnt(xwrk,ywrk,kdata,m,xin(1)*(1.-deltax),yends(1))
5225       CALL addpnt(xwrk,ywrk,kdata,m,              0.,yends(1))
5226       CALL addpnt(xwrk,ywrk,kdata,m,xin(n)*(1.+deltax),yends(2))
5227       CALL addpnt(xwrk,ywrk,kdata,m,          1.e+38,yends(2))
5228
5229       CALL inter2(nw,wl,yout,m,xwrk,ywrk,ierr)
5230
5231       IF (ierr /= 0) THEN
5232          write(emsg,'(''add_pnts_inter2: Error '',i5,'' in inter2 for '',a)') ierr,trim(jlabel)
5233          call wrf_error_fatal( trim(emsg) )
5234       ENDIF
5235
5236       END SUBROUTINE add_pnts_inter2
5237
5238       SUBROUTINE base_read( filespec, skip_cnt, rd_cnt,x, y, y1, y2, y3, y4, y5 )
5239
5240       integer, optional, intent(in) :: skip_cnt
5241       integer, intent(inout)        :: rd_cnt
5242       real, intent(inout)           :: x(:), y(:)
5243       real, optional, intent(inout) :: y1(:), y2(:), y3(:)
5244       real, optional, intent(inout) :: y4(:), y5(:)
5245       character(len=*), intent(in)  :: filespec
5246
5247       integer :: i, idum
5248       integer :: y_to_rd
5249       integer :: ios, err_cnt
5250       character(len=256) :: emsg
5251
5252       y_to_rd = 1
5253       if( present(y5) ) y_to_rd = y_to_rd + 1
5254       if( present(y4) ) y_to_rd = y_to_rd + 1
5255       if( present(y3) ) y_to_rd = y_to_rd + 1
5256       if( present(y2) ) y_to_rd = y_to_rd + 1
5257       if( present(y1) ) y_to_rd = y_to_rd + 1
5258
5259       OPEN(UNIT=kin,FILE=trim(filespec),STATUS='old',IOSTAT=ios)
5260       IF( ios /= 0 ) then
5261         write(emsg,'(''base_read: failed to open '',a)') trim(filespec)
5262         call wrf_error_fatal( trim(emsg) )
5263       ENDIF
5264
5265       if( present(skip_cnt) ) then
5266         DO i = 1, skip_cnt
5267           READ(kin,*,IOSTAT=ios)
5268           IF( ios /= 0 ) exit
5269         END DO
5270       else
5271         READ(kin,*,IOSTAT=ios) idum,rd_cnt
5272         IF( ios == 0 ) then
5273           DO i = 1, idum-2
5274             READ(kin,*,IOSTAT=ios)
5275             IF( ios /= 0 ) exit
5276           ENDDO
5277         ENDIF
5278       endif
5279
5280       IF( ios /= 0 ) then
5281         write(emsg,'(''base_read: failed to read '',a)') trim(filespec)
5282         call wrf_error_fatal( trim(emsg) )
5283       ENDIF
5284
5285       select case( y_to_rd )
5286         case( 1 )
5287           DO i = 1, rd_cnt
5288             READ(kin,*,IOSTAT=ios) x(i), y(i)
5289             IF( ios /= 0 ) exit
5290           END DO
5291         case( 2 )
5292           DO i = 1, rd_cnt
5293             READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i)
5294             IF( ios /= 0 ) exit
5295           END DO
5296         case( 3 )
5297           DO i = 1, rd_cnt
5298             READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i), y2(i)
5299             IF( ios /= 0 ) exit
5300           END DO
5301         case( 4 )
5302           DO i = 1, rd_cnt
5303             READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i), y2(i), y3(i)
5304             IF( ios /= 0 ) exit
5305           END DO
5306         case( 5 )
5307           DO i = 1, rd_cnt
5308             READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i), y2(i), y3(i),y4(i)
5309             IF( ios /= 0 ) exit
5310           END DO
5311         case( 6 )
5312           DO i = 1, rd_cnt
5313             READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i), y2(i), y3(i),y4(i),y5(i)
5314             IF( ios /= 0 ) exit
5315           END DO
5316       end select
5317
5318       CLOSE (kin)
5319
5320       IF( ios /= 0 ) then
5321         write(emsg,'(''base_read: failed to read '',a)') trim(filespec)
5322         call wrf_error_fatal( trim(emsg) )
5323       ENDIF
5324
5325       END SUBROUTINE base_read
5326
5327       SUBROUTINE fo3qy2(nz, w, t, qyld)
5328 !-----------------------------------------------------------------------------*
5329 !=  PURPOSE:                                                                 =*
5330 ! function to calculate the quantum yield O3 + hv -> O(1D) + O2,             =*
5331 ! according to:
5332 ! Matsumi, Y., F. J. Comes, G. Hancock, A. Hofzumanhays, A. J. Hynes,
5333 ! M. Kawasaki, and A. R. Ravishankara, QUantum yields for production of O(1D)
5334 ! in the ultraviolet photolysis of ozone:  Recommendation based on evaluation
5335 ! of laboratory data, J. Geophys. Res., 107, 10.1029/2001JD000510, 2002.
5336 !-----------------------------------------------------------------------------*
5337
5338       INTEGER, intent(in) :: nz
5339       REAL, intent(in)    :: w
5340       REAL, intent(in)    :: t(:)
5341       REAL, intent(inout) :: qyld(:)
5342
5343       REAL, parameter :: A(3)  = (/ 0.8036, 8.9061, 0.1192/)
5344       REAL, parameter :: X(3)  = (/ 304.225, 314.957, 310.737/)
5345       REAL, parameter :: om(3) = (/ 5.576, 6.601, 2.187/)
5346
5347       REAL, parameter :: q1 = 1.
5348
5349       REAL :: kt(nz)
5350       REAL :: q2(nz), qdiv(nz)
5351
5352
5353       kT(1:nz) = 0.695 * t(1:nz)
5354       q2(1:nz) = exp(-825.518/kT(1:nz))
5355
5356       kT(1:nz) = t(1:nz)/300.
5357       qdiv(1:nz) = 1/(q1 + q2(1:nz))
5358
5359       IF(w .LE. 305.) THEN
5360         qyld(1:nz) = 0.90
5361       ELSEIF(w .GT. 305. .AND. w .LE. 328.) THEN
5362         qyld(1:nz) = 0.0765 + a(1)*q1*qdiv(1:nz)*EXP(-((x(1) - w)/om(1))**4) &
5363                    + kT(1:nz)*(a(2)*kT(1:nz)*q2*qdiv(1:nz)*EXP(-((x(2) - w)/om(2))**2) &
5364                                + a(3)*sqrt(kT(1:nz))*EXP(-((x(3) - w)/om(3))**2))
5365       ELSEIF(w .GT. 328. .AND. w .LE. 340.) THEN
5366          qyld(1:nz) = 0.08
5367       ELSEIF(w .GT. 340.) THEN
5368          qyld(1:nz) = 0.
5369       ENDIF
5370
5371       END SUBROUTINE fo3qy2
5372
5373       SUBROUTINE qyacet(nz, w, T, M, fac)
5374 ! This file contains subroutines used for calculation of quantum yields for
5375 ! various photoreactions:
5376 !     qyacet - q.y. for acetone, based on Blitz et al. (2004)
5377
5378 ! Compute acetone quantum yields according to the parameterization of:
5379 ! Blitz, M. A., D. E. Heard, M. J. Pilling, S. R. Arnold, and M. P. Chipperfield
5380 !       (2004), Pressure and temperature-dependent quantum yields for the
5381 !       photodissociation of acetone between 279 and 327.5 nm, Geophys.
5382 !       Res. Lett., 31, L06111, doi:10.1029/2003GL018793.
5383
5384       IMPLICIT NONE
5385
5386 ! input:
5387 ! w = wavelength, nm
5388 ! T = temperature, K
5389 ! m = air number density, molec. cm-3
5390
5391       INTEGER, intent(in) :: nz
5392       REAL, intent(in)    :: w
5393       REAL, intent(in)    :: T(:), M(:)
5394       REAL, intent(inout) :: fac(:)
5395
5396 ! internal:
5397
5398       REAL :: wfac
5399       REAL :: a0(nz), a1(nz), a2(nz), a3(nz), a4(nz)
5400       REAL :: b0(nz), b1(nz), b2(nz), b3(nz), b4(nz)
5401       REAL :: c3(nz)
5402       REAL :: cA0(nz), cA1(nz), cA2(nz), cA3(nz), cA4(nz)
5403       real :: dumexp(nz)
5404
5405 ! fac = quantum yield for product CH3CO (acetyl radical)
5406
5407       REAL :: fco(nz)
5408       REAL :: tfac(nz)
5409
5410 !** set out-of-range values:
5411 ! use low pressure limits for shorter wavelengths
5412 ! set to zero beyound 327.5
5413
5414       IF(w .LT. 279.) THEN
5415         fac(1:nz) = 0.95
5416       ELSEIF(w .GT. 327.) THEN
5417         fac(1:nz) = 0.
5418       ELSE
5419         wfac = 1.e7/w
5420 !** CO (carbon monoxide) quantum yields:
5421         tfac(1:nz) = t(1:nz)/295.
5422         a0(1:nz) = 0.350 * tfac(1:nz)**(-1.28)
5423         b0(1:nz) = 0.068 * tfac(1:nz)**(-2.65)
5424 !*SM: prevent exponent overflow in rare cases:
5425
5426         dumexp(1:nz) = b0(1:nz)*(w - 248.)
5427         where( dumexp(1:nz) > 80. )
5428           cA0(1:nz) = 5.e34
5429         elsewhere
5430           cA0(1:nz) = exp(dumexp(1:nz)) * a0(1:nz) / (1. - a0(1:nz))
5431         endwhere
5432
5433         fco(1:nz) = 1. / (1. + cA0(1:nz))
5434
5435 !** CH3CO (acetyl radical) quantum yields:
5436
5437         IF(w >= 279. .AND. w < 302.) THEN
5438           a1(1:nz) = 1.600E-19 * tfac(1:nz)**(-2.38)
5439           b1(1:nz) = 0.55E-3   * tfac(1:nz)**(-3.19)
5440           cA1(1:nz) = a1(1:nz) * EXP(-b1(1:nz)*(wfac - 33113.))
5441           fac(1:nz) = (1. - fco(1:nz)) / (1. + cA1(1:nz) * M(1:nz))
5442         ELSEIF(w >= 302. .AND. w <= 327.) THEN
5443          a2(1:nz) = 1.62E-17 * tfac(1:nz)**(-10.03)
5444          b2(1:nz) = 1.79E-3  * tfac(1:nz)**(-1.364)
5445          cA2(1:nz) = a2(1:nz) * EXP(-b2(1:nz)*(wfac - 30488.))
5446
5447          a3(1:nz) = 26.29   * tfac(1:nz)**(-6.59)
5448          b3(1:nz) = 5.72E-7 * tfac(1:nz)**(-2.93)
5449          c3(1:nz) = 30006.  * tfac(1:nz)**(-0.064)
5450          ca3(1:nz) = a3(1:nz) * EXP(-b3(1:nz)*((1.e7/w) - c3(1:nz))**2)
5451
5452          a4(1:nz) = 1.67E-15 * tfac(1:nz)**(-7.25)
5453          b4(1:nz) = 2.08E-3  * tfac(1:nz)**(-1.16)
5454          cA4(1:nz) = a4(1:nz) * EXP(-b4(1:nz)*(wfac - 30488.))
5455
5456          fac(1:nz) = (1. - fco(1:nz)) * (1. + cA3(1:nz) + cA4(1:nz) * M(1:nz)) &
5457                      / ((1. + cA3(1:nz) + cA2(1:nz) * M(1:nz)) * (1. + cA4(1:nz) * M(1:nz)))
5458         ENDIF
5459       ENDIF
5460
5461       END SUBROUTINE qyacet
5462
5463       SUBROUTINE diagnostics
5464
5465       integer :: m, n, n1
5466
5467       open( unit=44,file='TUV.diags')
5468
5469       write(44,*) 'Photolysis diags'
5470       write(44,*) ' '
5471       write(44,'(i3,'' Total photorates'')') npht_tab
5472       write(44,*) ' '
5473       do m = 2,npht_tab
5474         write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label)
5475       enddo
5476       write(44,*) ' '
5477       write(44,'(''Wrf labels'')')
5478       write(44,*) ' '
5479       do m = 2,npht_tab
5480         write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%wrf_label)
5481       enddo
5482
5483       write(44,*) ' '
5484       write(44,'(i3,'' Photorate(s) with no p,temp dependence'')') &
5485               count(xsqy_tab(2:npht_tab)%tpflag == 0)
5486       write(44,*) ' '
5487       do m = 2,npht_tab
5488         if( xsqy_tab(m)%tpflag == 0 ) then
5489           write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label)
5490         endif
5491       enddo
5492
5493       write(44,*) ' '
5494       write(44,'(i3,'' Photorate(s) with temp dependence'')') &
5495               count(xsqy_tab(2:npht_tab)%tpflag == 1)
5496       write(44,*) ' '
5497       do m = 2,npht_tab
5498         if( xsqy_tab(m)%tpflag == 1 ) then
5499           write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label)
5500         endif
5501       enddo
5502
5503       write(44,*) ' '
5504       write(44,'(i3,'' Photorate(s) with press dependence'')') &
5505               count(xsqy_tab(2:npht_tab)%tpflag == 2)
5506       write(44,*) ' '
5507       do m = 2,npht_tab
5508         if( xsqy_tab(m)%tpflag == 2 ) then
5509           write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label)
5510         endif
5511       enddo
5512
5513       write(44,*) ' '
5514       write(44,'(i3,'' Photorate(s) with temp,press dependence'')') &
5515               count(xsqy_tab(2:npht_tab)%tpflag == 3)
5516       write(44,*) ' '
5517       do m = 2,npht_tab
5518         if( xsqy_tab(m)%tpflag == 3 ) then
5519           write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label)
5520         endif
5521       enddo
5522
5523       write(44,*) ' '
5524       write(44,'(i3,'' Photorate(s) with second channel'')') &
5525               count(xsqy_tab(2:npht_tab)%channel == 2)
5526       write(44,*) ' '
5527       do m = 2,npht_tab
5528         if( xsqy_tab(m)%channel == 2 ) then
5529           write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label)
5530         endif
5531       enddo
5532
5533       write(44,*) ' '
5534       write(44,'(i3,'' Photorate(s) with third channel'')') &
5535               count(xsqy_tab(2:npht_tab)%channel == 3)
5536       write(44,*) ' '
5537       do m = 2,npht_tab
5538         if( xsqy_tab(m)%channel == 3 ) then
5539           write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label)
5540         endif
5541       enddo
5542
5543       write(44,*) ' '
5544       write(44,'(i3,'' Photorate(s) with multiple input files'')') &
5545               count(xsqy_tab(2:npht_tab)%filespec%nfiles > 1)
5546       write(44,*) ' '
5547       do m = 2,npht_tab
5548         if( xsqy_tab(m)%filespec%nfiles > 1 ) then
5549           write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label)
5550         endif
5551       enddo
5552
5553       write(44,*) ' '
5554       write(44,'('' Photorate(s) with skip == -1'')')
5555       write(44,*) ' '
5556       do m = 2,npht_tab
5557         n = xsqy_tab(m)%filespec%nfiles
5558         do n1 = 1,n
5559           if( xsqy_tab(m)%filespec%nskip(n1)  == -1 ) then
5560             write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label)
5561           endif
5562         enddo
5563       enddo
5564
5565       write(44,*) ' '
5566       write(44,'('' Photorate(s) with skip >= 0'')')
5567       write(44,*) ' '
5568       do m = 2,npht_tab
5569         n = xsqy_tab(m)%filespec%nfiles
5570         do n1 = 1,n
5571           if( xsqy_tab(m)%filespec%nskip(n1) >= 0 .and. &
5572               xsqy_tab(m)%filespec%filename(n1) /= ' ' ) then
5573             write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label)
5574           endif
5575         enddo
5576       enddo
5577
5578       write(44,*) ' '
5579       write(44,'('' Photorate(s) with xfac /= 1.e-20'')')
5580       write(44,*) ' '
5581       do m = 2,npht_tab
5582         n = xsqy_tab(m)%filespec%nfiles
5583         do n1 = 1,n
5584           if( xsqy_tab(m)%filespec%xfac(n1) /= 1.e-20 ) then
5585             write(44,'(i3,2x,a,1pg15.7)') &
5586               m,trim(xsqy_tab(m)%label),xsqy_tab(m)%filespec%xfac(n1)
5587           endif
5588         enddo
5589       enddo
5590
5591       write(44,*) ' '
5592       write(44,'('' Filenames'')')
5593       write(44,*) ' '
5594       do m = 2,npht_tab
5595         n = xsqy_tab(m)%filespec%nfiles
5596         do n1 = 1,n
5597           if( xsqy_tab(m)%filespec%filename(n1) /= ' ' ) then
5598             write(44,'(i3,2x,a,3x,i4,3x,i4)') &
5599                m,trim(xsqy_tab(m)%filespec%filename(n1)), &
5600                xsqy_tab(m)%filespec%nskip(n1), &
5601                xsqy_tab(m)%filespec%nread(n1)
5602           endif
5603         enddo
5604       enddo
5605
5606       close( 44 )
5607
5608       END SUBROUTINE diagnostics
5609
5610       INTEGER FUNCTION get_xsqy_tab_ndx( jlabel,wrf_label )
5611
5612       character(len=*), optional, intent(in) :: jlabel
5613       character(len=*), optional, intent(in) :: wrf_label
5614
5615       integer :: m
5616
5617       get_xsqy_tab_ndx = -1
5618
5619       if( present(jlabel) ) then
5620         do m = 2,npht_tab
5621           if( trim(jlabel) == trim(xsqy_tab(m)%label) ) then
5622             get_xsqy_tab_ndx = m
5623             exit
5624           endif
5625         enddo
5626       elseif( present(wrf_label) ) then
5627         do m = 2,npht_tab
5628           if( trim(wrf_label) == trim(xsqy_tab(m)%wrf_label) ) then
5629             get_xsqy_tab_ndx = m
5630             exit
5631           endif
5632         enddo
5633       endif
5634
5635
5636       END FUNCTION get_xsqy_tab_ndx
5637
5638       SUBROUTINE check_alloc( ndx, nz, nw )
5639
5640       integer, intent(in) :: ndx
5641       integer, intent(in) :: nz
5642       integer, intent(in) :: nw
5643
5644       integer :: astat
5645       character(len=256)  :: emsg
5646
5647       if( .not. allocated(xsqy_tab(ndx)%sq) ) then
5648         allocate( xsqy_tab(ndx)%sq(nz,nw),stat=astat )
5649       elseif( size(xsqy_tab(ndx)%sq,dim=1) /= nz ) then
5650         deallocate( xsqy_tab(ndx)%sq )
5651         allocate( xsqy_tab(ndx)%sq(nz,nw),stat=astat )
5652       else
5653         astat = 0
5654       endif
5655
5656       if( astat /= 0 ) then
5657          write(emsg,'(''check_alloc: failed to alloc sq; error = '',i4)') astat
5658          call wrf_error_fatal( trim(emsg) )
5659       endif
5660
5661       END SUBROUTINE check_alloc
5662
5663       end module module_rxn