From 5780a42a3df980f73b11bfccbe760a8a5239ec37 Mon Sep 17 00:00:00 2001
From: Gaelle DELAUTIER <gaelle.delautier@meteo.fr>
Date: Thu, 26 Apr 2018 14:56:18 +0200
Subject: [PATCH] Maud et Gaelle 26/04/2018 : TUV 531
---
.../009_ICARTT/001_pgd1/get_chimie_files | 2 +-
.../009_ICARTT/003_mesonh/run_mesonh_xyz | 5 +-
.../011_KW78CHEM/002_mesonh/run_mesonh_xyz | 5 +-
src/MNH/BASIC.f90 | 89 +-
src/MNH/ch_f77.fx90 | 12407 +++++++++++-----
src/MNH/ch_init_jvalues.f90 | 6 +-
src/MNH/modd_ch_init_jvalues.f90 | 2 +-
7 files changed, 8645 insertions(+), 3871 deletions(-)
diff --git a/MY_RUN/KTEST/009_ICARTT/001_pgd1/get_chimie_files b/MY_RUN/KTEST/009_ICARTT/001_pgd1/get_chimie_files
index e8947cd23..6718c71c1 100755
--- a/MY_RUN/KTEST/009_ICARTT/001_pgd1/get_chimie_files
+++ b/MY_RUN/KTEST/009_ICARTT/001_pgd1/get_chimie_files
@@ -20,7 +20,7 @@ cd ${CHIMIE_FILES}
CHIMIE_URL="http://mesonh.aero.obs-mip.fr/mesonh/dir_open/dir_CHIMIE"
WGET="wget"
export CHIMIE_URL
-for dir in EMISSIONS tuv50
+for dir in EMISSIONS tuv531
do
[ -d $dir ] || ( ${WGET} -c -nd $CHIMIE_URL/$dir.tar.gz ; tar xvfz $dir.tar.gz ; rm -f $dir.tar.gz )
done
diff --git a/MY_RUN/KTEST/009_ICARTT/003_mesonh/run_mesonh_xyz b/MY_RUN/KTEST/009_ICARTT/003_mesonh/run_mesonh_xyz
index 1d748be8e..afab5d0c2 100755
--- a/MY_RUN/KTEST/009_ICARTT/003_mesonh/run_mesonh_xyz
+++ b/MY_RUN/KTEST/009_ICARTT/003_mesonh/run_mesonh_xyz
@@ -9,9 +9,8 @@ rm -f ICART* OUT* EXSEG?.nam
export CHIMIE_FILES=${CHIMIE_FILES:-"$HOME/CHIMIE_FILES"}
-ln -sf ${CHIMIE_FILES}/tuv50/DATAE1 .
-ln -sf ${CHIMIE_FILES}/tuv50/DATAJ1 .
-ln -sf ${CHIMIE_FILES}/tuv50/DATAS1 .
+ln -sf ${CHIMIE_FILES}/tuv531/DATAE1 .
+ln -sf ${CHIMIE_FILES}/tuv531/DATAJ1 .
cp EXSEG1.nam.src EXSEG1.nam
ln -sf ../002_arp2lfi/CPLCH20040810.18.{des,lfi,nc} .
ln -sf ../001_pgd1/ICARTT1008_PGD_15km.{des,lfi,nc} .
diff --git a/MY_RUN/KTEST/011_KW78CHEM/002_mesonh/run_mesonh_xyz b/MY_RUN/KTEST/011_KW78CHEM/002_mesonh/run_mesonh_xyz
index d9adc3576..02331f2de 100755
--- a/MY_RUN/KTEST/011_KW78CHEM/002_mesonh/run_mesonh_xyz
+++ b/MY_RUN/KTEST/011_KW78CHEM/002_mesonh/run_mesonh_xyz
@@ -5,9 +5,8 @@
set -x
set -e
export CHIMIE_FILES=${CHIMIE_FILES:-"$HOME/CHIMIE_FILES"}
-ln -sf ${CHIMIE_FILES}/tuv50/DATAE1 .
-ln -sf ${CHIMIE_FILES}/tuv50/DATAJ1 .
-ln -sf ${CHIMIE_FILES}/tuv50/DATAS1 .
+ln -sf ${CHIMIE_FILES}/tuv531/DATAE1 .
+ln -sf ${CHIMIE_FILES}/tuv531/DATAJ1 .
ln -fs ../001_prep_ideal_case/KWRAIN.{des,lfi,nc} .
rm -f KWRAI.1.SEGCH OUT*
time ${MPIRUN} MESONH${XYZ}
diff --git a/src/MNH/BASIC.f90 b/src/MNH/BASIC.f90
index 699563349..cd557a6ee 100644
--- a/src/MNH/BASIC.f90
+++ b/src/MNH/BASIC.f90
@@ -1,7 +1,3 @@
-!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
-!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
-!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
-!MNH_LIC for details. version 1.
!
!========================================================================
!
@@ -250,7 +246,7 @@
! KTR38=@KT(0.03,60.,TPK%T,TPK%RADR,KVECNPT)/(@HEFFA(4.1e3,-6200.,1.74e-5,0.,0.,0.,TPK%PHR,TPK%T,KVECNPT)*TPK%RCH*TPK%T)::WR_ORA2-->ORA2
! KTR39=@KT(0.05,47.,TPK%T,TPK%RADR,KVECNPT)/(@HENRY(2.7e0,-2030.,TPK%T,KVECNPT)*TPK%RCH*TPK%T)::WR_MO2-->MO2
! KTR40=@KT(0.007,48.,TPK%T,TPK%RADR,KVECNPT)/(@HENRY(3.e2,-5280.,TPK%T,KVECNPT)*TPK%RCH*TPK%T)::WR_OP1-->OP1
-! KC1=7.e-6::WC_H2O2-->WC_OH+WC_OH
+! KC1=!ZRATES(:,018)::WC_H2O2-->WC_OH+WC_OH
! KC2=(3.6E+9*exp(-930.*(1./TPK%T-1./298.15)))/TPK%MOL2MOLECCLOUD::WC_OH+WC_OH-->WC_H2O2
! KC3=((2.8E+10*10.**(-TPK%PHC)+3.5E+10*exp(-720.*(1./TPK%T-1./298.15))*1.6e-5)/(1.6e-5+10.**(-TPK%PHC)))/TPK%MOL2MOLECCLOUD::WC_OH+WC_HO2-->
! KC4=(3.2E+7*exp(-1700.*(1./TPK%T-1./298.15)))/TPK%MOL2MOLECCLOUD::WC_H2O2+WC_OH-->WC_HO2
@@ -262,7 +258,7 @@
! KC10=2.6E-2*10.**(-TPK%PHC)/(1.26e-6+10.**(-TPK%PHC))::WC_HNO4-->WC_HO2+WC_NO2
! KC11=1.1E0*1.26e-6/(1.26e-6+10.**(-TPK%PHC))::WC_HNO4-->WC_HONO
! KC12=(3.3E+5*1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*(10.**(-TPK%PHC))**2./((1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*6.4e-8*exp(1430.*(1./TPK%T-1./298.15))+1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHC)+(10.**(-TPK%PHC))**2.)*(1.26e-6+10.**(-TPK%PHC))))/TPK%MOL2MOLECCLOUD::WC_HNO4+WC_SO2-->WC_SULF+WC_HNO3
-! KC13=4.e-7*2.2e+1/(2.2e+1+10.**(-TPK%PHC))::WC_HNO3-->WC_NO2+WC_OH
+! KC13=!ZRATES(:,019)*2.2e+1/(2.2e+1+10.**(-TPK%PHC))::WC_HNO3-->WC_NO2+WC_OH
! KC14=1.0E+10::WC_N2O5-->WC_HNO3+WC_HNO3
! KC15=(1.0E+5*1.0e+3*1.0e-2/(1.0e+3*1.0e-2+1.0e+3*10.**(-TPK%PHC)+(10.**(-TPK%PHC))**2.))/TPK%MOL2MOLECCLOUD::WC_NO3+WC_SULF-->WC_HNO3+WC_ASO4
! KC16=(1.3E+9*exp(-2200.*(1./TPK%T-1./298.15))*1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHC)/(1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*6.4e-8*exp(1430.*(1./TPK%T-1./298.15))+1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHC)+(10.**(-TPK%PHC))**2.))/TPK%MOL2MOLECCLOUD::WC_NO3+WC_SO2-->WC_HNO3+WC_ASO3
@@ -280,7 +276,7 @@
! KC28=4.6E+2*exp(-1100.*(1./TPK%T-1./298.15))::WC_ASO4-->WC_SULF+WC_OH
! KC29=((3.7E+5*exp(-5500.*(1./TPK%T-1./298.15))*1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHC)+1.5E+9*exp(-5300.*(1./TPK%T-1./298.15))*1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*6.4e-8*exp(1430.*(1./TPK%T-1./298.15)))/(1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*6.4e-8*exp(1430.*(1./TPK%T-1./298.15))+1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHC)+(10.**(-TPK%PHC))**2.))/TPK%MOL2MOLECCLOUD::WC_SO2+WC_O3-->WC_SULF
! KC30=(9.1E+7*exp(-3600.*(1./TPK%T-1./298.15))*1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHC)*10.**(-TPK%PHC)/(1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*6.4e-8*exp(1430.*(1./TPK%T-1./298.15))+1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHC)+(10.**(-TPK%PHC))**2.))/TPK%MOL2MOLECCLOUD::WC_SO2+WC_H2O2-->WC_SULF
-! KR1=7.e-6::WR_H2O2-->WR_OH+WR_OH
+! KR1=!ZRATES(:,018)::WR_H2O2-->WR_OH+WR_OH
! KR2=(3.6E+9*exp(-930.*(1./TPK%T-1./298.15)))/TPK%MOL2MOLECRAIN::WR_OH+WR_OH-->WR_H2O2
! KR3=((2.8E+10*10.**(-TPK%PHR)+3.5E+10*exp(-720.*(1./TPK%T-1./298.15))*1.6e-5)/(1.6e-5+10.**(-TPK%PHR)))/TPK%MOL2MOLECRAIN::WR_OH+WR_HO2-->
! KR4=(3.2E+7*exp(-1700.*(1./TPK%T-1./298.15)))/TPK%MOL2MOLECRAIN::WR_H2O2+WR_OH-->WR_HO2
@@ -292,7 +288,7 @@
! KR10=2.6E-2*10.**(-TPK%PHR)/(1.26e-6+10.**(-TPK%PHR))::WR_HNO4-->WR_HO2+WR_NO2
! KR11=1.1E0*1.26e-6/(1.26e-6+10.**(-TPK%PHR))::WR_HNO4-->WR_HONO
! KR12=(3.3E+5*1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*(10.**(-TPK%PHR))**2./((1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*6.4e-8*exp(1430.*(1./TPK%T-1./298.15))+1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHR)+(10.**(-TPK%PHR))**2.)*(1.26e-6+10.**(-TPK%PHR))))/TPK%MOL2MOLECRAIN::WR_HNO4+WR_SO2-->WR_SULF+WR_HNO3
-! KR13=4.e-7*2.2e+1/(2.2e+1+10.**(-TPK%PHR))::WR_HNO3-->WR_NO2+WR_OH
+! KR13=!ZRATES(:,019)*2.2e+1/(2.2e+1+10.**(-TPK%PHR))::WR_HNO3-->WR_NO2+WR_OH
! KR14=1.0E+10::WR_N2O5-->WR_HNO3+WR_HNO3
! KR15=(1.0E+5*1.0e+3*1.0e-2/(1.0e+3*1.0e-2+1.0e+3*10.**(-TPK%PHR)+(10.**(-TPK%PHR))**2.))/TPK%MOL2MOLECRAIN::WR_NO3+WR_SULF-->WR_HNO3+WR_ASO4
! KR16=(1.3E+9*exp(-2200.*(1./TPK%T-1./298.15))*1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHR)/(1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*6.4e-8*exp(1430.*(1./TPK%T-1./298.15))+1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHR)+(10.**(-TPK%PHR))**2.))/TPK%MOL2MOLECRAIN::WR_NO3+WR_SO2-->WR_HNO3+WR_ASO3
@@ -3572,7 +3568,7 @@ IF (GFIRSTCALL) THEN
&030.,TPK%T,KVECNPT)*TPK%RCH*TPK%T)::WR_MO2-->MO2'
CFULLREACS(212) = 'KTR40=@KT(0.007,48.,TPK%T,TPK%RADR,KVECNPT)/(@HENRY(3.e2,-5&
&280.,TPK%T,KVECNPT)*TPK%RCH*TPK%T)::WR_OP1-->OP1'
- CFULLREACS(213) = 'KC1=7.e-6::WC_H2O2-->WC_OH+WC_OH'
+ CFULLREACS(213) = 'KC1=!ZRATES(:,018)::WC_H2O2-->WC_OH+WC_OH'
CFULLREACS(214) = 'KC2=(3.6E+9*exp(-930.*(1./TPK%T-1./298.15)))/TPK%MOL2MOLECC&
&LOUD::WC_OH+WC_OH-->WC_H2O2'
CFULLREACS(215) = 'KC3=((2.8E+10*10.**(-TPK%PHC)+3.5E+10*exp(-720.*(1./TPK%T-1&
@@ -3602,8 +3598,8 @@ IF (GFIRSTCALL) THEN
&PK%T-1./298.15))+1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHC)+(10.**&
&(-TPK%PHC))**2.)*(1.26e-6+10.**(-TPK%PHC))))/TPK%MOL2MOLECCLOUD::WC_HNO4+WC_SO&
&2-->WC_SULF+WC_HNO3'
- CFULLREACS(225) = 'KC13=4.e-7*2.2e+1/(2.2e+1+10.**(-TPK%PHC))::WC_HNO3-->WC_NO&
-&2+WC_OH'
+ CFULLREACS(225) = 'KC13=!ZRATES(:,019)*2.2e+1/(2.2e+1+10.**(-TPK%PHC))::WC_HNO&
+&3-->WC_NO2+WC_OH'
CFULLREACS(226) = 'KC14=1.0E+10::WC_N2O5-->WC_HNO3+WC_HNO3'
CFULLREACS(227) = 'KC15=(1.0E+5*1.0e+3*1.0e-2/(1.0e+3*1.0e-2+1.0e+3*10.**(-TPK&
&%PHC)+(10.**(-TPK%PHC))**2.))/TPK%MOL2MOLECCLOUD::WC_NO3+WC_SULF-->WC_HNO3+WC_&
@@ -3659,7 +3655,7 @@ IF (GFIRSTCALL) THEN
&./TPK%T-1./298.15))*6.4e-8*exp(1430.*(1./TPK%T-1./298.15))+1.3e-2*exp(1965.*(1&
&./TPK%T-1./298.15))*10.**(-TPK%PHC)+(10.**(-TPK%PHC))**2.))/TPK%MOL2MOLECCLOUD&
&::WC_SO2+WC_H2O2-->WC_SULF'
- CFULLREACS(243) = 'KR1=7.e-6::WR_H2O2-->WR_OH+WR_OH'
+ CFULLREACS(243) = 'KR1=!ZRATES(:,018)::WR_H2O2-->WR_OH+WR_OH'
CFULLREACS(244) = 'KR2=(3.6E+9*exp(-930.*(1./TPK%T-1./298.15)))/TPK%MOL2MOLECR&
&AIN::WR_OH+WR_OH-->WR_H2O2'
CFULLREACS(245) = 'KR3=((2.8E+10*10.**(-TPK%PHR)+3.5E+10*exp(-720.*(1./TPK%T-1&
@@ -3689,8 +3685,8 @@ IF (GFIRSTCALL) THEN
&PK%T-1./298.15))+1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHR)+(10.**&
&(-TPK%PHR))**2.)*(1.26e-6+10.**(-TPK%PHR))))/TPK%MOL2MOLECRAIN::WR_HNO4+WR_SO2&
&-->WR_SULF+WR_HNO3'
- CFULLREACS(255) = 'KR13=4.e-7*2.2e+1/(2.2e+1+10.**(-TPK%PHR))::WR_HNO3-->WR_NO&
-&2+WR_OH'
+ CFULLREACS(255) = 'KR13=!ZRATES(:,019)*2.2e+1/(2.2e+1+10.**(-TPK%PHR))::WR_HNO&
+&3-->WR_NO2+WR_OH'
CFULLREACS(256) = 'KR14=1.0E+10::WR_N2O5-->WR_HNO3+WR_HNO3'
CFULLREACS(257) = 'KR15=(1.0E+5*1.0e+3*1.0e-2/(1.0e+3*1.0e-2+1.0e+3*10.**(-TPK&
&%PHR)+(10.**(-TPK%PHR))**2.))/TPK%MOL2MOLECRAIN::WR_NO3+WR_SULF-->WR_HNO3+WR_A&
@@ -28919,7 +28915,6 @@ SUBROUTINE SUBSRW8
!
!Indices 213 a 222
!
- TPK%KC1=7.e-6
TPK%KC2=(3.6E+9*exp(-930.*(1./TPK%T-1./298.15)))/TPK%MOL2MOLECCLOUD
TPK%KC3=((2.8E+10*10.**(-TPK%PHC)+3.5E+10*exp(-720.*(1./TPK%T-1./298.15))*1.6e&
&-5)/(1.6e-5+10.**(-TPK%PHC)))/TPK%MOL2MOLECCLOUD
@@ -28951,7 +28946,6 @@ SUBROUTINE SUBSRW9
&((1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*6.4e-8*exp(1430.*(1./TPK%T-1./298.15)&
&)+1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHC)+(10.**(-TPK%PHC))**2.&
&)*(1.26e-6+10.**(-TPK%PHC))))/TPK%MOL2MOLECCLOUD
- TPK%KC13=4.e-7*2.2e+1/(2.2e+1+10.**(-TPK%PHC))
TPK%KC14=1.0E+10
TPK%KC15=(1.0E+5*1.0e+3*1.0e-2/(1.0e+3*1.0e-2+1.0e+3*10.**(-TPK%PHC)+(10.**(-T&
&PK%PHC))**2.))/TPK%MOL2MOLECCLOUD
@@ -29012,7 +29006,6 @@ SUBROUTINE SUBSRW11
!
!Indices 243 a 252
!
- TPK%KR1=7.e-6
TPK%KR2=(3.6E+9*exp(-930.*(1./TPK%T-1./298.15)))/TPK%MOL2MOLECRAIN
TPK%KR3=((2.8E+10*10.**(-TPK%PHR)+3.5E+10*exp(-720.*(1./TPK%T-1./298.15))*1.6e&
&-5)/(1.6e-5+10.**(-TPK%PHR)))/TPK%MOL2MOLECRAIN
@@ -29044,7 +29037,6 @@ SUBROUTINE SUBSRW12
&((1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*6.4e-8*exp(1430.*(1./TPK%T-1./298.15)&
&)+1.3e-2*exp(1965.*(1./TPK%T-1./298.15))*10.**(-TPK%PHR)+(10.**(-TPK%PHR))**2.&
&)*(1.26e-6+10.**(-TPK%PHR))))/TPK%MOL2MOLECRAIN
- TPK%KR13=4.e-7*2.2e+1/(2.2e+1+10.**(-TPK%PHR))
TPK%KR14=1.0E+10
TPK%KR15=(1.0E+5*1.0e+3*1.0e-2/(1.0e+3*1.0e-2+1.0e+3*10.**(-TPK%PHR)+(10.**(-T&
&PK%PHR))**2.))/TPK%MOL2MOLECRAIN
@@ -29193,8 +29185,8 @@ REAL,DIMENSION(:,:,:,:), INTENT(IN) :: PJVALUES ! Tuv coefficient
! /BEGIN_SET_PHOTO_RATES/
! parameter for use by subroutine JVALUES,
! contains the actual photolysis rates
-REAL, DIMENSION(KVECNPT,21) :: ZRATESIO ! TUV photolysis rates at one level
-REAL, DIMENSION(KVECNPT,17) :: ZRATES ! photolysis rates of RACM (vector)
+REAL, DIMENSION(KVECNPT,41) :: ZRATESIO ! TUV photolysis rates at one level
+REAL, DIMENSION(KVECNPT,19) :: ZRATES ! photolysis rates of RACM (vector)
INTEGER :: JITPK ! loop counter for J-Value transfer
INTEGER :: IDTI,IDTJ
INTEGER :: JITPKPLUS
@@ -29229,29 +29221,34 @@ DO JITPK = 0, KVECNPT-1
!
! associate TUV J-Values to ReLACS J-Values
!
- ZRATES(JITPK+1, 1) = ZRATESIO(JITPK+1,2)
- ZRATES(JITPK+1, 2) = ZRATESIO(JITPK+1,3)
- ZRATES(JITPK+1, 3) = ZRATESIO(JITPK+1,4)
- ZRATES(JITPK+1, 4) = ZRATESIO(JITPK+1,9)
- ZRATES(JITPK+1, 5) = ZRATESIO(JITPK+1,10)
- ZRATES(JITPK+1, 6) = ZRATESIO(JITPK+1,11)
- ZRATES(JITPK+1, 7) = ZRATESIO(JITPK+1,5)
- ZRATES(JITPK+1, 8) = ZRATESIO(JITPK+1,6)
- ZRATES(JITPK+1, 9) = ZRATESIO(JITPK+1,12)
- ZRATES(JITPK+1, 10) = ZRATESIO(JITPK+1,14)
- ZRATES(JITPK+1, 11) = ZRATESIO(JITPK+1,13)
- ZRATES(JITPK+1, 12) = ZRATESIO(JITPK+1,17)
- ZRATES(JITPK+1, 13) = ZRATESIO(JITPK+1,15)
- ZRATES(JITPK+1, 14) = 0.962055 *ZRATESIO(JITPK+1,15)+&
- & 1.06247E-02 *ZRATESIO(JITPK+1,12)
- ZRATES(JITPK+1, 15) = ZRATESIO(JITPK+1,20)
- ZRATES(JITPK+1, 16) = 3.16657 *ZRATESIO(JITPK+1,15)&
- &+ 0.372446 *ZRATESIO(JITPK+1,15)&
- &+ 8.42257 *ZRATESIO(JITPK+1,15)&
- &+ 207.5913 *ZRATESIO(JITPK+1,20)&
- &+ 0.0 *ZRATESIO(JITPK+1,20)&
- &+ 8.44837E-04 *ZRATESIO(JITPK+1,20)
- ZRATES(JITPK+1, 17) = ZRATESIO(JITPK+1,16)
+! change according to original coefficients and modified RACM
+!
+ ZRATES(JITPK+1, 1) = ZRATESIO(JITPK+1,5)
+ ZRATES(JITPK+1, 2) = ZRATESIO(JITPK+1,2)
+ ZRATES(JITPK+1, 3) = ZRATESIO(JITPK+1,3)
+ ZRATES(JITPK+1, 4) = ZRATESIO(JITPK+1,8)
+ ZRATES(JITPK+1, 5) = ZRATESIO(JITPK+1,9)
+ ZRATES(JITPK+1, 6) = ZRATESIO(JITPK+1,10)
+ ZRATES(JITPK+1, 7) = ZRATESIO(JITPK+1,6)
+ ZRATES(JITPK+1, 8) = ZRATESIO(JITPK+1,7)
+ ZRATES(JITPK+1, 9) = ZRATESIO(JITPK+1,4)
+ ZRATES(JITPK+1, 10) = ZRATESIO(JITPK+1,12)
+ ZRATES(JITPK+1, 11) = ZRATESIO(JITPK+1,11)
+ ZRATES(JITPK+1, 12) = ZRATESIO(JITPK+1,13)
+ ZRATES(JITPK+1, 13) = ZRATESIO(JITPK+1,17)
+ ZRATES(JITPK+1, 14) = 0.962055 *ZRATESIO(JITPK+1,17)+&
+ & 3.79454E-02 *ZRATESIO(JITPK+1,38)
+ ZRATES(JITPK+1, 15) = ZRATESIO(JITPK+1,33)
+ ZRATES(JITPK+1, 16) = 0.20842 *ZRATESIO(JITPK+1,35)&
+ &+ 6.43207E-02 *ZRATESIO(JITPK+1,36)&
+ &+ 3.10372E-02 *ZRATESIO(JITPK+1,34)&
+ &+ 0.376 *ZRATESIO(JITPK+1,37)&
+ &+ 0.31937 *ZRATESIO(JITPK+1,26)
+ ZRATES(JITPK+1, 17) = 0.20*ZRATESIO(JITPK+1,20)&
+ &+ 0.80*ZRATESIO(JITPK+1,21)
+! aqueous phase photolysis
+ ZRATES(JITPK+1, 18) = ZRATESIO(JITPK+1,40)
+ ZRATES(JITPK+1, 19) = ZRATESIO(JITPK+1,41)
!
END DO
!
@@ -29273,6 +29270,12 @@ END DO
TPK%K015=ZRATES(:,015)
TPK%K016=ZRATES(:,016)
TPK%K017=ZRATES(:,017)
+IF (TPK%LUSECHAQ) THEN
+ TPK%KC1=ZRATES(:,018)
+ TPK%KC13=ZRATES(:,019)*2.2e+1/(2.2e+1+10.**(-TPK%PHC))
+ TPK%KR1=ZRATES(:,018)
+ TPK%KR13=ZRATES(:,019)*2.2e+1/(2.2e+1+10.**(-TPK%PHR))
+END IF
TPK%NOUT = KOUT
TPK%NVERB = KVERB
RETURN
diff --git a/src/MNH/ch_f77.fx90 b/src/MNH/ch_f77.fx90
index 54036a24c..f7a653034 100644
--- a/src/MNH/ch_f77.fx90
+++ b/src/MNH/ch_f77.fx90
@@ -1,8 +1,12 @@
-!MNH_LIC Copyright 1994-2018 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
!MNH_LIC for details. version 1.
!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source: /home/cvsroot/MNH-VX-Y-Z/src/MNH/ch_f77.fx90,v $ $Revision: 1.2.2.1.2.2.2.1.8.2.2.3 $ $Date: 2014/06/19 15:18:13 $
+!-----------------------------------------------------------------
C**FILE: svode.f
C**AUTHOR: Karsten Suhre
C**DATE: Fri Nov 10 09:17:45 GMT 1995
@@ -16,7 +20,6 @@ C** in exponential calculation --> problem with "ifort -O2" compiler
C**MODIFIED: 22/02/2011 (J.Escobar) remove erroneous 'CALL ABORT'
C**MODIFIED: 19/06/2014 (J.Escobar & M.Leriche) write(kout,...) to OUTPUT_LISTING file
C & correct IN_LUN = 11 => IN_LUN = 78 to avoid fort.11 creation
-C**MODIFIED: 13/02/2018 (P.Wautelet) use ifdef MNH_REAL to prevent problems with intrinsics on Blue Gene/Q
C!
C!
C!
@@ -4456,6 +4459,11 @@ c
30 continue
return
end
+
+*======= BEGIN of TUV 5.3.1 =======*
+* M.LERICHE Update Feb. 2018
+
+CCC FILE TUV.f
*----------------------------------------------------------------------------
subroutine tuvmain (asza, idate,
+ albnew, dobnew,
@@ -4464,8 +4472,8 @@ c
+ kout )
*-----------------------------------------------------------------------------*
*= Tropospheric Ultraviolet-Visible (TUV) radiation model =*
-*= Version 5.0 =*
-*= November 2010 =*
+*= Version 5.3 =*
+*= June 2016 =*
*-----------------------------------------------------------------------------*
*= Developed by Sasha Madronich with important contributions from: =*
*= Chris Fischer, Siri Flocke, Julia Lee-Taylor, Bernhard Meyer, =*
@@ -4490,10 +4498,11 @@ c
*= To obtain a copy of the GNU General Public License, write to: =*
*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
*-----------------------------------------------------------------------------*
-*= Copyright (C) 1994-2010 by the University Corporation for Atmospheric =*
+*= Copyright (C) 1994-2016 by the University Corporation for Atmospheric =*
*= Research, extending to all called subroutines, functions, and data unless =*
*= another source is specified. =*
*-----------------------------------------------------------------------------*
+*= Adapted to MesoNH : ONLY JVALUES are computed
IMPLICIT NONE
SAVE
@@ -4519,18 +4528,15 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
-
* delta for adding points at beginning or end of data grids
REAL deltax
PARAMETER (deltax = 1.E-5)
+*_________________________________________________
* some constants...
-
* pi:
REAL pi
PARAMETER(pi=3.1415926535898)
@@ -4540,7 +4546,6 @@ c INCLUDE 'params'
PARAMETER(radius=6.371E+3)
* Planck constant x speed of light, J m
-
REAL hc
PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
@@ -4554,7 +4559,6 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
REAL precis
PARAMETER(precis = 1.e-7)
@@ -4636,19 +4640,13 @@ c INCLUDE 'params'
REAL fdir(kz), fdn(kz), fup(kz)
REAL saflux(kz,kw)
-* Spectral weighting functions and weighted radiation
-
- INTEGER ns, is
- REAL sw(ks,kw), rate(ks,kz), dose(ks)
- REAL drdw
- CHARACTER*50 slabel(ks)
-
* Photolysis coefficients (j-values)
INTEGER nj, ij
REAL sj(kj,kz,kw), valj(kj,kz)
REAL djdw
CHARACTER*50 jlabel(kj)
+ INTEGER tpflag(kj)
**** Re-scaling factors (can be read from input file)
* New surface albedo and surface pressure (milli bar)
@@ -4672,7 +4670,7 @@ c INCLUDE 'params'
INTEGER iyear, imonth, iday
INTEGER it, nt
REAL t, tstart, tstop
- REAL tmzone, ut
+ REAL tmzone
LOGICAL lzenit
* number of radiation streams
@@ -4692,20 +4690,9 @@ c INCLUDE 'params'
* Save arrays for output:
- LOGICAL lirrad, laflux, lrates, ljvals, lmmech
+ LOGICAL laflux, ljvals, lmmech
INTEGER isfix, ijfix, itfix, izfix, iwfix, i
- INTEGER nms, ims(ks), nmj, imj(kj)
-
-c REAL svj_zj(kz,kj), svj_tj(kt,kj), svj_zt(kz,kt)
-c REAL svr_zs(kz,ks), svr_ts(kt,ks), svr_zt(kz,kt)
-c REAL svf_zw(kz,kw), svf_tw(kt,kw), svf_zt(kz,kt)
-c REAL svi_zw(kz,kw), svi_tw(kt,kw), svi_zt(kz,kt)
-
-* Parameters for shifting wavelengths air <--> vacuum
-
- INTEGER mrefr
- LOGICAL lrefr
- REAL airout
+ INTEGER nmj, imj(kj)
* Planetary boundary layer height and pollutant concentrations
@@ -4717,7 +4704,7 @@ c REAL svi_zw(kz,kw), svi_tw(kt,kw), svi_zt(kz,kt)
C method:
C
C on first call, all necessary data will be read from the files
-C in directories DATA0, DATA4, and DATAX;
+C in directories DATAE1, DATAJ1;
C all variables are saved for future calls to TUV
C
REAL, INTENT(IN) :: asza
@@ -4827,17 +4814,11 @@ C
* ztemp = air temperature (K) at zout. Set to negative value for
* default USSA76 value interpolated to zout.
* Output options, logical switches:
-* lirrad = output spectral irradiance
* laflux = output spectral actinic flux
* lmmech = output for NCAR Master Mechanism use
-* lrates = output dose rates (UVB, UVA, CIE/erythema, etc.)
- lirrad =.FALSE.
laflux =.FALSE.
lmmech =.FALSE.
- lrates =.FALSE.
* Output options, integer selections:
-* isfix: if > 0, output dose rate for action spectrum is=isfix, tabulated
-* for different times and altitudes.
* ijfix: if > 0, output j-values for reaction ij=ijfix, tabulated
* for different times and altitudes.
* iwfix: if > 0, output spectral irradiance and/or spectral actinic
@@ -4849,16 +4830,13 @@ C
* izfix: if > 0, output spectral irradiance and/or spectral actinic
* flux at altitude iz=izfix, tabulated for different times
* and wavelengths.
-* nms: number of dose rates that will be reported. Selections must be
-* made interactively, or by editing input file.
* nmj: number of j-values that will be reported. Selections must be
* made interactively, or by editing input file.
-* The following default settings are also found in the input file 'defin1':
- izfix = 1
+ izfix = 1
IF (LFIRSTCALL) THEN
- WRITE(kout,*) 'running TUVMAIN, version 5.0'
+ WRITE(kout,*) 'running TUVMAIN, version 5.3.1'
IF(nstr .LT. 2) THEN
WRITE(kout,*) 'Delta-Eddington 2-stream radiative transfer'
@@ -4869,17 +4847,9 @@ C
* ___ SECTION 2: SET GRIDS _________________________________________________
-* wavelengths (creates wavelength grid: lower, center, upper of each bin)
-* NOTE: Wavelengths are in vacuum. To use wavelengths in air, see
-* Section 3 below, where you must set lrefr= .TRUE.
-
- CALL gridw(wstart, wstop, nwint,
- $ nw, wl, wc, wu)
-c
-
* altitudes (creates altitude grid, locates index for selected output, izout)
- CALL gridz(zin,nlevel, zstart, zstop, nz, z, zout, izout)
+ CALL gridz(zin,nlevel, zstart, zstop, nz, z, zout, izout,kout)
if(izfix .gt. 0) izout = izfix
* time/zenith (creates time/zenith angle grid, starting at tstart)
@@ -4890,6 +4860,13 @@ c $ lzenit, tstart, tstop,
c $ nt, t, sza, esfact)
sza = asza
+* wavelength grid, user-set range and spacing.
+* NOTE: Wavelengths are in vacuum, and therefore independent of altitude.
+* To use wavelengths in air, see options in subroutine gridw
+
+ CALL gridw(wstart, wstop, nwint,
+ $ nw, wl, wc, wu, kout)
+
* ___ SECTION 3: SET UP VERTICAL PROFILES OF TEMPERATURE, AIR DENSITY, and OZONE______
***** Temperature vertical profile, Kelvin
@@ -4905,40 +4882,6 @@ c IF(ztemp .GT. nzero) tlev(izout) = ztemp
$ aircon, aircol, kout)
c IF(zaird .GT. nzero) aircon(izout) = zaird
-***** Correction for air-vacuum wavelength shift:
-* The TUV code assumes that all working wavelengths are strictly IN-VACUUM. This is for ALL
-* spectral data including extraterrestrial fluxes, ozone (and other) absorption cross sections,
-* and various weighting functons (action spectra, photolysis cross sections, instrument spectral
-* response functions). If the original data are specified in-air, conversion to in-vacuum must be
-* made when reading those data.
-
-* Occasionally, users may want their results to be given for wavelengths measured IN-AIR.
-* The shift between IN-VACUUM and IN-AIR wavelengths depends on the index of refraction
-* of air, which in turn depends on the local density of air, which in turn depends on
-* altitude, temperature, etc.
-* Here, we provide users with the option to use a wavelength grid IN-AIR, at the air density
-* corresponding to the output altitude, airout = aircon(izout), by setting the logical variable
-* lrefr = .TRUE. (default is lrefr = .FALSE.). The wavelengths specified in gridw.f will be assumed
-* to be IN-AIR, and will be shifted here to IN-VACUUM values to carry out the calculatons.
-* The actual radiative transfer calculations will be done strictly with IN-VACUUM values.
-* If this shift is applied (i.e., if lrefr = .TRUE.), the wavelength grid will be shifted back to air
-* values just before the output is written.
-* Note: if this option is used (lref = .TRUE.), the wavelength values will be correct ONLY at the
-* selected altitude, iz = iout. The wavelength shift will be INCORRECT at all other altitudes.
-* Note: This option cannot be changed interactively in the input table. It must be changed here.
-
-C lrefr = .TRUE.
- lrefr = .FALSE.
- IF(lrefr) THEN
- airout = aircon(izout)
- write(*,*) 'applying air to vacuum wavelength shift',
- $ izout, airout
- mrefr = 1
- CALL wshift(mrefr, nw, wl, airout)
- CALL wshift(mrefr, nwint, wc, airout)
- CALL wshift(mrefr, nwint, wu, airout)
- ENDIF
-
*****
*! PBL pollutants will be added if zpbl > 0.
* CAUTIONS:
@@ -4999,64 +4942,25 @@ C lrefr = .TRUE.
* NO2
nzm1 = nz - 1
- CALL rdo2xs(nw,wl, o2xs1)
+ CALL rdo2xs(nw,wl, o2xs1,kout)
mabs = 1
- CALL rdo3xs(mabs,nzm1,tlay,nw,wl, o3xs)
- CALL rdso2xs(nw,wl, so2xs)
- CALL rdno2xs(nz,tlay,nw,wl, no2xs)
+ CALL rdo3xs(mabs,nzm1,tlay,nw,wl, o3xs,kout)
+ CALL rdso2xs(nw,wl, so2xs,kout)
+ CALL rdno2xs(nz,tlay,nw,wl, no2xs,kout)
****** Spectral weighting functions
* (Some of these depend on temperature T and pressure P, and therefore
* on altitude z. Therefore they are computed only after the T and P profiles
* are set above with subroutines settmp and setair.)
-* Photo-physical set in swphys.f (transmission functions)
-* Photo-biological set in swbiol.f (action spectra)
* Photo-chemical set in swchem.f (cross sections x quantum yields)
-* Physical and biological weigthing functions are assumed to depend
-* only on wavelength.
* Chemical weighting functions (product of cross-section x quantum yield)
* for many photolysis reactions are known to depend on temperature
* and/or pressure, and therefore are functions of wavelength and altitude.
* Output:
-* from pphys & pbiol: s(ks,kw) - for each weighting function slabel(ks)
-* from pchem: sj(kj,kz,kw) - for each reaction jlabel(kj)
-* For pchem, need to know temperature and pressure profiles.
-
- CALL swphys(nw,wl,wc, ns,sw,slabel)
- CALL swbiol(nw,wl,wc, ns,sw,slabel)
- CALL swchem(nw,wl,nz,tlev,aircon, nj,sj,jlabel)
-
-c CALL swbiol2(nw,wl,wc, ns,sw,slabel)
-c CALL swbiol3(nw,wl,wc, ns,sw,slabel)
-
-**** The following lines are normally commented out.
-* The only serve to print a list of the spectral weighting
-* functions. If new functions (e.g. action spectra, photo-reactions)
-* are added, this list should be used to replace the list in the
-* default input files (defin1, defin2, etc.). The true/false toggle
-* will be set to F, and should be changed manually to select weighting
-* functions for output. Note that if many more functions are added, it
-* may be necessary to increase the parameters ks and kj in the include
-* file 'params'
-* The program will stop after writing this list.
-* Comment out these lines when not generating a new list.
-
-c OPEN(UNIT=50,FILE='spectra.list',STATUS='NEW')
-c WRITE(50,500)
-c 500 FORMAT(5('='),1X,'Available spectral weighting functions:')
-c DO is = 1, ns
-c WRITE(50,505) is, slabel(is)
-c ENDDO
-c WRITE(50,510)
-c 510 FORMAT(5('='),1X,'Available photolysis reactions')
-c DO ij = 1, nj
-c WRITE(50,505) ij, jlabel(ij)
-c ENDDO
-c 505 FORMAT('F',I3,1X,A50)
-c WRITE(50,520)
-c 520 FORMAT(66('='))
-c CLOSE (50)
-c STOP
+* from swchem: sj(kj,kz,kw) - for each reaction jlabel(kj)
+* For swchem, need to know temperature and pressure profiles.
+
+ CALL swchem(nw,wl,nz,tlev,aircon, nj,sj,jlabel,tpflag,kout)
******
@@ -5064,7 +4968,7 @@ c STOP
* Rayleigh optical depth increments:
- CALL odrl(nz, z, nw, wl, aircol, dtrl)
+ CALL odrl(nz, z, nw, wl, aircol, dtrl,kout)
* O2 vertical profile and O2 absorption optical depths
* For now, O2 densitiy assumed as 20.95% of air density, can be changed
@@ -5072,11 +4976,11 @@ c STOP
* Optical depths in Lyman-alpha and SRB will be over-written
* in subroutine la_srb.f
- CALL seto2(nz,z,nw,wl,aircol,o2xs1, dto2)
+ CALL seto2(nz,z,nw,wl,aircol,o2xs1, dto2, kout)
* Ozone optical depths
- CALL odo3(nz,z,nw,wl,o3xs,co3, dto3)
+ CALL odo3(nz,z,nw,wl,o3xs,co3, dto3,kout)
* SO2 vertical profile and optical depths
@@ -5084,7 +4988,7 @@ c STOP
CALL setso2(ipbl, zpbl, so2pbl,
$ so2_tc, nz, z, nw, wl, so2xs,
$ tlay, aircol,
- $ dtso2)
+ $ dtso2,kout)
* NO2 vertical profile and optical depths
@@ -5092,7 +4996,7 @@ c STOP
CALL setno2(ipbl, zpbl, no2pbl,
$ no2_tc, nz, z, nw, wl, no2xs,
$ tlay, aircol,
- $ dtno2)
+ $ dtno2,kout)
* Aerosol vertical profile, optical depths, single scattering albedo, asymmetry factor
@@ -5127,7 +5031,7 @@ C WRITE(kout,*)'wavelength-independent albedo = ', albnew
enddo
else
CALL setalb(alsurf,nw,wl,
- $ albedo)
+ $ albedo,kout)
endif
C cloud optical depth (may be modified at each call, so it has ben moved
@@ -5137,15 +5041,13 @@ C outside the if(firstcall) section:
CALL setcld(nz,z,nw,wl,
$ lwc,nlevel,
- $ dtcld,omcld,gcld)
+ $ dtcld,omcld,gcld,kout)
* ___ SECTION 6: TIME/SZA LOOP _____________________________________
* Initialize any time-integrated quantities here
- CALL zero1(dose,ks)
-
zen = asza
* Loop over time or solar zenith angle (zen):
@@ -5169,22 +5071,21 @@ c
* slant path lengths for spherical geometry
- CALL sphers(nz,z,zen, dsdh,nid)
- CALL airmas(nz, dsdh,nid, aircol,vcol,scol)
+ CALL sphers(nz,z,zen, dsdh,nid, kout)
+ CALL airmas(nz, dsdh,nid, aircol,vcol,scol, kout)
* Recalculate effective O2 optical depth and cross sections for Lyman-alpha
* and Schumann-Runge bands, must know zenith angle
* Then assign O2 cross section to sj(1,*,*)
CALL la_srb(nz,z,tlev,nw,wl,vcol,scol,o2xs1,
- $ dto2,o2xs)
- CALL sjo2(nz,nw,o2xs,1, sj)
+ $ dto2,o2xs,kout)
+ CALL sjo2(nz,nw,o2xs,1, sj,kout)
* ____ SECTION 8: WAVELENGTH LOOP ______________________________________
* initialize for wavelength integration
- CALL zero2(rate,ks,kz)
CALL zero2(valj,kj,kz)
***** Main wavelength loop:
@@ -5208,14 +5109,8 @@ c
$ dtcld, omcld, gcld,
$ dtaer,omaer,gaer,
$ dtsnw,omsnw,gsnw,
- $ edir, edn, eup, fdir, fdn, fup)
-
-* Spectral irradiance, W m-2 nm-1, down-welling:
-
- DO iz = 1, nz
- sirrad(iz,iw) = etf(iw) *
- $ (dirsun*edir(iz) + difdn*edn(iz) + difup*eup(iz))
- ENDDO
+ $ edir, edn, eup, fdir, fdn, fup,
+ $ kout)
* Spectral actinic flux, quanta s-1 nm-1 cm-2, all directions:
* units conversion: 1.e-4 * (wc*1e-9) / hc
@@ -5227,14 +5122,7 @@ c
*** Accumulate weighted integrals over wavelength, at all altitudes:
- DO 18 iz = 1, nz
-
-* Weighted irradiances (dose rates) W m-2
-
- DO is = 1, ns
- drdw = sirrad(iz,iw) * sw(is,iw)
- rate(is,iz) = rate(is,iz) + drdw * (wu(iw) - wl(iw))
- ENDDO
+ DO iz = 1, nz
* Photolysis rate coefficients (J-values) s-1
@@ -5243,57 +5131,18 @@ c
valj(ij,iz) = valj(ij,iz) + djdw * (wu(iw) - wl(iw))
ENDDO
- 18 CONTINUE
-
-* Save irradiances and actinic fluxes for output
-
-c CALL saver1(it, itfix, iw, iwfix, nz, izout,
-c $ sirrad, saflux,
-c $ svi_zw, svf_zw, svi_zt, svf_zt, svi_tw, svf_tw)
+ ENDDO
10 CONTINUE
*^^^^^^^^^^^^^^^^ end wavelength loop
-* Save dose rates and j-values for output
-
-c CALL saver2(it,itfix, nz,izout, ns,isfix,ims, nj,ijfix,imj,
-c $ rate, valj,
-c $ svr_zs, svj_zj, svr_zt, svj_zt, svr_ts, svj_tj)
+* ____ SECTION 9: OUTPUT ______________________________________________
-c 20 CONTINUE
-
-*^^^^^^^^^^^^^^^^ end time/zenith loop
-
-** reset wavelength scale if needed:
-
- IF(lrefr) THEN
- write(*,*) 'applying vacuum to air wavelength shift'
- $ , izout, airout
- mrefr = -mrefr
- CALL wshift(mrefr, nw, wl, airout)
- CALL wshift(mrefr, nwint, wc, airout)
- CALL wshift(mrefr, nwint, wu, airout)
- ENDIF
-
-* ____ SECTION 8: OUTPUT ______________________________________________
-
-c call outpt1( outfil, iout,
-c $ lirrad, laflux, lrates, ljvals, lmmech, lzenit,
-c $ nms, ims, nmj, imj,
-c $ nz, z, tlev, aircon, izout,
-c $ nw, wl, etf, iwfix,
-c $ nt, t, sza, itfix,
-c $ ns, slabel, isfix, nj, jlabel, ijfix,
-c $ svj_zj, svj_tj, svj_zt,
-c $ svr_zs, svr_ts, svr_zt,
-c $ svf_zw, svf_tw, svf_zt,
-c $ svi_zw, svi_tw, svi_zt )
-c
C copy labels into output array
- if (njout .ne. 21) then
- WRITE(kout,*) 'There should be 21 J-Values to be updated!'
+ if (njout .ne. 41) then
+ WRITE(kout,*) 'There should be 41 J-Values to be updated!'
WRITE(kout,*) 'We better stop here ... in tuvmain.f'
C callabortstop
CALL ABORT
@@ -5329,61 +5178,14 @@ c CLOSE(iout)
C CLOSE(kout)
END
-
+CCC FILE functs.f
* This file contains the following user-defined fortran functions:
-* fery
* fo3qy
* fo3qy2
* fsum
-* futr
-*=============================================================================*
-
-C ##############################
- FUNCTION fery(w)
-C ##############################
-
-*-----------------------------------------------------------------------------*
-*= PURPOSE: =*
-*= Calculate the action spectrum value for erythema at a given wavelength =*
-*= according to: McKinlay, A.F and B.L.Diffey, A reference action spectrum =*
-*= for ultraviolet induced erythema in human skin, CIE Journal, vol 6, =*
-*= pp 17-22, 1987. =*
-*= Value at 300 nm = 0.6486 =*
-*-----------------------------------------------------------------------------*
-*= PARAMETERS: =*
-*= W - REAL, wavelength (nm) (I)=*
-*-----------------------------------------------------------------------------*
-
- IMPLICIT NONE
-
-* input:
- REAL w
-
-* function value:
- REAL fery
-
- IF (w .LT. 250.) THEN
- fery = 1.
-C outside the ery spectrum range
- ELSEIF ((w .GE. 250.) .AND. (w .LT. 298)) THEN
- fery = 1.
- ELSEIF ((w .GE. 298.) .AND. (w .LT. 328.)) THEN
- fery = 10.**( 0.094*(298.-w) )
- ELSEIF ((w .GE. 328.) .AND. (w .LT. 400.)) THEN
- fery = 10.**( 0.015*(139.-w) )
- ELSE
- fery = 1.E-36
-C outside the ery spectrum range
- ENDIF
-
- RETURN
- END
-
*=============================================================================*
-C ##############################
FUNCTION fo3qy(w,t)
-C ##############################
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -5418,9 +5220,7 @@ C ##############################
END
-C ##############################
FUNCTION fo3qy2(w,t)
-C ##############################
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -5465,9 +5265,7 @@ C ##############################
*=============================================================================*
-C ##############################
FUNCTION fsum(n,x)
-C ##############################
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -5498,72 +5296,7 @@ C ##############################
RETURN
END
-*=============================================================================*
-
-C ##############################
- FUNCTION futr(w)
-C ##############################
-
-*-----------------------------------------------------------------------------*
-*= PURPOSE: =*
-*= Calculate the action spectrum value for skin cancer of albino hairless =*
-*= mice at a given wavelength according to: deGRuijl, F.R., H.J.C.M.Steren-=*
-*= borg, P.D.Forbes, R.E.Davies, C.Colse, G.Kelfkens, H.vanWeelden, =*
-*= and J.C.van der Leun, Wavelength dependence of skin cancer induction by =*
-*= ultraviolet irradiation of albino hairless mice, Cancer Research, vol 53,=*
-*= pp. 53-60, 1993 =*
-*= (Action spectrum for carcinomas) =*
-*-----------------------------------------------------------------------------*
-*= PARAMETERS: =*
-*= W - REAL, wavelength (nm) (I)=*
-*-----------------------------------------------------------------------------*
-
- IMPLICIT NONE
-
-* input:
- REAL w
-
-* function value:
- REAL futr
-
-* local:
- REAL a1, a2, a3, a4, a5,
- > x1, x2, x3, x4, x5,
- > t1, t2, t3, t4, t5,
- > b1, b2, b3, b4, b5,
- > p
-
- a1 = -10.91
- a2 = - 0.86
- a3 = - 8.60
- a4 = - 9.36
- a5 = -13.15
-
- x1 = 270.
- x2 = 302.
- x3 = 334.
- x4 = 367.
- x5 = 400.
-
- t1 = (w-x2)*(w-x3)*(w-x4)*(w-x5)
- t2 = (w-x1)*(w-x3)*(w-x4)*(w-x5)
- t3 = (w-x1)*(w-x2)*(w-x4)*(w-x5)
- t4 = (w-x1)*(w-x2)*(w-x3)*(w-x5)
- t5 = (w-x1)*(w-x2)*(w-x3)*(w-x4)
-
- b1 = (x1-x2)*(x1-x3)*(x1-x4)*(x1-x5)
- b2 = (x2-x1)*(x2-x3)*(x2-x4)*(x2-x5)
- b3 = (x3-x1)*(x3-x2)*(x3-x4)*(x3-x5)
- b4 = (x4-x1)*(x4-x2)*(x4-x3)*(x4-x5)
- b5 = (x5-x1)*(x5-x2)*(x5-x3)*(x5-x4)
-
- p = a1*t1/b1 + a2*t2/b2 + a3*t3/b3 + a4*t4/b4 + a5*t5/b5
-
- futr = EXP(p)
-
- RETURN
- END
-
+CCC FILE grids.f
* This file contains the following subroutine, related to setting up
* grids for numerical calculations:
* gridw
@@ -5574,7 +5307,7 @@ C ##############################
*=============================================================================*
SUBROUTINE gridw(wstart, wstop, nwint,
- $ nw,wl,wc,wu)
+ $ nw,wl,wc,wu,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -5601,7 +5334,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -5613,9 +5346,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -5673,6 +5404,9 @@ c INCLUDE 'params'
CHARACTER*40 fi
CHARACTER*20 wlabel
+ REAL airout
+ INTEGER mrefr
+
REAL dum
LOGICAL ok
@@ -5686,17 +5420,34 @@ c INCLUDE 'params'
* mopt = 3 user-defined
* mopt = 4 fast-TUV, troposheric wavelengths only
* mopt = 5 high resolution grid for O3 isotopologue study
+* mopt = 6 create uniform grid in air-wavelength scale
+
+* mopt = 10 Landgraf and Crutzen, 1998
+* mopt = 11 fastJ, Wild et al. 2000
+* mopt = 12 fastJ2, Bian and Prather, 2002
+* mopt = 13 UV-b, UV-a, Visible
mopt = 2
IF(nwint .EQ. -156) mopt = 2
IF(nwint .EQ. -7) mopt = 4
+ IF(nwint .eq. -10) mopt = 10
+ IF(nwint .eq. -11) mopt = 11
+ IF(nwint .eq. -12) mopt = 12
+ IF(nwint .eq. -13) mopt = 13
+
IF (mopt .EQ. 1) GO TO 1
IF (mopt .EQ. 2) GO TO 2
IF (mopt .EQ. 3) GO TO 3
IF (mopt .EQ. 4) GO TO 4
IF (mopt .EQ. 5) GO TO 5
+ IF (mopt .EQ. 6) GO TO 6
+
+ IF (mopt .EQ. 10) GO TO 10
+ IF (mopt .EQ. 11) GO TO 11
+ IF (mopt .EQ. 12) GO TO 12
+ IF (mopt .EQ. 13) GO TO 13
*_______________________________________________________________________
@@ -5705,11 +5456,11 @@ c INCLUDE 'params'
wlabel = 'equal spacing'
nw = nwint + 1
wincr = (wstop - wstart) / FLOAT (nwint)
- DO 10, iw = 1, nw-1
+ DO iw = 1, nw-1
wl(iw) = wstart + wincr*FLOAT(iw-1)
wu(iw) = wl(iw) + wincr
wc(iw) = ( wl(iw) + wu(iw) )/2.
- 10 CONTINUE
+ ENDDO
wl(nw) = wu(nw-1)
GO TO 9
@@ -5776,7 +5527,7 @@ c wlabel = 'isaksen.grid'
DO iw = 1, 10
READ(kin,*)
ENDDO
- nw = ABS(nwint) + 1
+ nw = 8
DO iw = 1, nw-1
READ(kin,*) dum, wl(iw), dum, dum
ENDDO
@@ -5806,8 +5557,8 @@ c wlabel = 'isaksen.grid'
DO i = 1, 3859
iw = 3859 - i + 39
- wn(iw) = 10000 + 10*FLOAT(i-1)
- wl(iw) = 1.E7/wn(iw)
+ wn(iw) = 10000 + 10*(i-1)
+ wl(iw) = 1.E7/float(wn(iw))
ENDDO
nw = 3859 + 38
@@ -5820,6 +5571,114 @@ c wlabel = 'isaksen.grid'
GO TO 9
+*_______________________________________________________________________
+
+ 6 CONTINUE
+
+***** Correction for air-vacuum wavelength shift:
+* The TUV code assumes that all working wavelengths are strictly IN-VACUUM. This is for ALL
+* spectral data including extraterrestrial fluxes, ozone (and other) absorption cross sections,
+* and various weighting functons (action spectra, photolysis cross sections, instrument spectral
+* response functions). If the original data are specified in-air, conversion to in-vacuum must be
+* made when reading those data.
+
+* Occasionally, users may want their results to be given for wavelengths measured IN-AIR.
+* The shift between IN-VACUUM and IN-AIR wavelengths depends on the index of refraction
+* of air, which in turn depends on the local density of air, which in turn depends on
+* altitude, temperature, etc.
+* Here, we provide users with the option to use a wavelength grid IN-AIR, at the air density
+* corresponding to the selected altitude, airout.
+* The actual radiative transfer calculations will be done strictly with IN-VACUUM values.
+
+* create grid that will be nicely spaced in air wavelengths.
+
+ wlabel = 'grid in air wavelengths'
+ nw = nwint + 1
+ wincr = (wstop - wstart) / FLOAT (nwint)
+ DO iw = 1, nw-1
+ wl(iw) = wstart + wincr*FLOAT(iw-1)
+ wu(iw) = wl(iw) + wincr
+ wc(iw) = ( wl(iw) + wu(iw) )/2.
+ ENDDO
+ wl(nw) = wu(nw-1)
+
+* shift by refractive index to vacuum wavelengths, for use in tuv
+
+ airout = 2.45e19
+ mrefr = 1
+ CALL wshift(mrefr, nw, wl, airout, kout)
+ CALL wshift(mrefr, nwint, wc, airout, kout)
+ CALL wshift(mrefr, nwint, wu, airout, kout)
+
+ GO TO 9
+*_______________________________________________________________________
+* Landgraf and Crutzen 1998
+ 10 CONTINUE
+ nw = 6
+ wl(1) = 289.0
+ wl(2) = 305.5
+ wl(3) = 313.5
+ wl(4) = 337.5
+ wl(5) = 422.5
+ wl(6) = 752.5
+ DO iw = 1, nw-1
+ wu(iw) = wl(iw+1)
+ wc(iw) = 0.5*(wl(iw) + wu(iw))
+ ENDDO
+ GO TO 9
+*_______________________________________________________________________
+* Wild 2000
+ 11 CONTINUE
+ nw = 8
+ wl(1) = 289.00
+ wl(2) = 298.25
+ wl(3) = 307.45
+ wl(4) = 312.45
+ wl(5) = 320.30
+ wl(6) = 345.0
+ wl(7) = 412.5
+ wl(8) = 850.0
+
+ DO iw = 1, nw-1
+ wu(iw) = wl(iw+1)
+ wc(iw) = 0.5*(wl(iw) + wu(iw))
+ ENDDO
+ GO TO 9
+*_______________________________________________________________________
+* Bian and Prather 2002
+ 12 CONTINUE
+ nw = 8
+ wl(1) = 291.0
+ wl(2) = 298.3
+ wl(3) = 307.5
+ wl(4) = 312.5
+ wl(5) = 320.3
+ wl(6) = 345.0
+ wl(7) = 412.5
+ wl(8) = 850.0
+
+ DO iw = 1, nw-1
+ wu(iw) = wl(iw+1)
+ wc(iw) = 0.5*(wl(iw) + wu(iw))
+ ENDDO
+ GO TO 9
+*_______________________________________________________________________
+
+*_______________________________________________________________________
+* UV-b, UV-A, Vis
+
+ 13 CONTINUE
+ nw = 4
+ wl(1) = 280.0
+ wl(2) = 315.0
+ wl(3) = 400.0
+ wl(4) = 700.0
+
+ DO iw = 1, nw-1
+ wu(iw) = wl(iw+1)
+ wc(iw) = 0.5*(wl(iw) + wu(iw))
+ ENDDO
+ GO TO 9
*_______________________________________________________________________
9 CONTINUE
@@ -5840,7 +5699,8 @@ c wlabel = 'isaksen.grid'
*=============================================================================*
- SUBROUTINE gridz(zin,nlevel,zstart, zstop, nz, z, zout, izout)
+ SUBROUTINE gridz(zin,nlevel,zstart, zstop, nz, z,
+ & zout, izout, kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -5860,7 +5720,7 @@ c wlabel = 'isaksen.grid'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -5872,9 +5732,7 @@ c wlabel = 'isaksen.grid'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -5924,7 +5782,7 @@ c wlabel = 'isaksen.grid'
* local:
- REAL zincr, tol
+ REAL zincr
INTEGER i, n, nlev
LOGICAL ok
*_______________________________________________________________________
@@ -6080,9 +5938,8 @@ c wlabel = 'isaksen.grid'
* insert your grid values here:
* specify:
-* nz = total number of altutudes
+* nz = total number of altitudes
* Table: z(iz), where iz goes from 1 to nz
-* trivial example of 2-layer (3-altitudes) shown below, user should modify
C use model levels for vertical grid where available
do 12, i = 1, nlevel
z(i) = zin(i) *1E-3
@@ -6101,6 +5958,19 @@ C
C
GOTO 10
+*-----end of user options.
+*-----grid option 6: high resolution window
+
+6 CONTINUE
+
+* insert your grid values here:
+* specify:
+* nz = total number of altutudes
+* Table: z(iz), where iz goes from 1 to nz
+
+ WRITE(*,*) 'user-defined grid, named...'
+ goto 10
+
*-----end of user options.
*------------------------------------------------
@@ -6161,249 +6031,6 @@ c 99 CONTINUE
IMPLICIT NONE
c INCLUDE 'params'
-* BROADLY USED PARAMETERS:
-*_________________________________________________
-* i/o file unit numbers
- INTEGER kout, kin
-* output
- PARAMETER(kout=6)
-* input
- PARAMETER(kin=78)
-*_________________________________________________
-* altitude, wavelength, time (or solar zenith angle) grids
- INTEGER kz, kw
-* altitude
- PARAMETER(kz=151)
-* wavelength
- PARAMETER(kw=157)
-*_________________________________________________
-* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
-* wavelength and altitude dependent
- PARAMETER(kj=90)
-
-* delta for adding points at beginning or end of data grids
- REAL deltax
- PARAMETER (deltax = 1.E-5)
-
-* some constants...
-
-* pi:
- REAL pi
- PARAMETER(pi=3.1415926535898)
-
-* radius of the earth, km:
- REAL radius
- PARAMETER(radius=6.371E+3)
-
-* Planck constant x speed of light, J m
-
- REAL hc
- PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
-
-* largest number of the machine:
- REAL largest
- PARAMETER(largest=1.E+36)
-
-* small numbers (positive and negative)
- REAL pzero, nzero
- PARAMETER(pzero = +10./largest)
- PARAMETER(nzero = -10./largest)
-
-* machine precision
-
- REAL precis
- PARAMETER(precis = 1.e-7)
-
- REAL zincr ! i
- INTEGER nlev ! i
- INTEGER n ! i/o
- REAL z(kz) ! i/o
- INTEGER i, j ! internal
-
- j = 0
- DO i = n + 1, n + nlev
- j = j + 1
- z(i) = z(n) + FLOAT(j)*zincr
- ENDDO
- n = n + nlev
-
- RETURN
- END
-
-*=============================================================================*
-
-c SUBROUTINE gridt(lat, lon, tmzone,
-c $ iyear, imonth, iday,
-c $ lzenit, tstart, tstop,
-c $ nt, t, sza, esrm2)
-c
-c *-----------------------------------------------------------------------------*
-c *= Subroutine to create time (or solar zenith angle) grid =*
-c *= Also computes earth-sun distance (1/R**2) correction. =*
-c *-----------------------------------------------------------------------------*
-c
-c IMPLICIT NONE
-c
-c c INCLUDE 'params'
-c
-c * BROADLY USED PARAMETERS:
-c *_________________________________________________
-c * i/o file unit numbers
-c INTEGER kout, kin
-c * output
-c PARAMETER(kout=6)
-c * input
-c PARAMETER(kin=78)
-c *_________________________________________________
-c * altitude, wavelength, time (or solar zenith angle) grids
-c INTEGER kz, kw
-c * altitude
-c PARAMETER(kz=151)
-c * wavelength
-c PARAMETER(kw=157)
-c *_________________________________________________
-c * number of weighting functions
-c INTEGER ks, kj
-c * wavelength dependent
-c PARAMETER(ks=60)
-c * wavelength and altitude dependent
-c PARAMETER(kj=90)
-c
-c * delta for adding points at beginning or end of data grids
-c REAL deltax
-c PARAMETER (deltax = 1.E-5)
-c
-c * some constants...
-c
-c * pi:
-c REAL pi
-c PARAMETER(pi=3.1415926535898)
-c
-c * radius of the earth, km:
-c REAL radius
-c PARAMETER(radius=6.371E+3)
-c
-c * Planck constant x speed of light, J m
-c
-c REAL hc
-c PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
-c
-c * largest number of the machine:
-c REAL largest
-c PARAMETER(largest=1.E+36)
-c
-c * small numbers (positive and negative)
-c REAL pzero, nzero
-c PARAMETER(pzero = +10./largest)
-c PARAMETER(nzero = -10./largest)
-c
-c * machine precision
-c
-c REAL precis
-c PARAMETER(precis = 1.e-7)
-c
-c * INPUTS
-c
-c REAL lat, lon, tmzone
-c INTEGER iyear, imonth, iday
-c LOGICAL lzenit
-c INTEGER nt
-c REAL tstart, tstop
-c
-c
-c * OUTPUTS
-c
-c REAL t, sza, esrm2
-c
-c * INTERNAL
-c
-c INTEGER it
-c REAL ut, dt
-c
-c INTEGER jday, nday
-c LOGICAL oky, okm, okd
-c
-c REAL az, el, soldia, soldst
-c
-c * switch for refraction correction to solar zenith angle. Because
-c * this is only for the observed sza at the surface, do not use.
-c
-c LOGICAL lrefr
-c DATA lrefr /.FALSE./
-c
-c ***************
-c
-c IF(nt .EQ. 1) THEN
-c dt = 0.
-c ELSE
-c dt = (tstop - tstart) / FLOAT(nt - 1)
-c ENDIF
-c
-c DO 10 it = 1, nt
-c t(it) = tstart + dt * FLOAT(it - 1)
-c
-c * solar zenith angle calculation:
-c * If lzenit = .TRUE., use selected solar zenith angles, also
-c * set Earth-Sun distance to 1 AU.
-c
-c IF (lzenit) THEN
-c sza(it) = t(it)
-c esrm2(it) = 1.
-c
-c * If lzenit = .FALSE., compute solar zenith angle for specified
-c * location, date, time of day. Assume no refraction (lrefr = .FALSE.)
-c * Also calculate corresponding
-c * Earth-Sun correcton factor.
-c
-c ELSE
-c CALL calend(iyear, imonth, iday,
-c $ jday, nday, oky, okm, okd)
-c IF( oky .AND. okm .AND. okd) THEN
-c
-c ut = t(it) - tmzone
-c CALL sunae(iyear, jday, ut, lat, lon, lrefr,
-c & az, el, soldia, soldst )
-c sza(it) = 90. - el
-c esrm2(it) = 1./(soldst*soldst)
-c ELSE
-c WRITE(*,*) '**** incorrect date specification'
-c STOP ' in gridt '
-c ENDIF
-c ENDIF
-c
-c 10 CONTINUE
-c RETURN
-c END
-
-*=============================================================================*
-
- SUBROUTINE gridck(k,n,x,ok, kout)
-
-*-----------------------------------------------------------------------------*
-*= PURPOSE: =*
-*= Check a grid X for various improperties. The values in X have to comply =*
-*= with the following rules: =*
-*= 1) Number of actual points cannot exceed declared length of X =*
-*= 2) Number of actual points has to be greater than or equal to 2 =*
-*= 3) X-values must be non-negative =*
-*= 4) X-values must be unique =*
-*= 5) X-values must be in ascending order =*
-*-----------------------------------------------------------------------------*
-*= PARAMETERS: =*
-*= K - INTEGER, length of X as declared in the calling program (I)=*
-*= N - INTEGER, number of actual points in X (I)=*
-*= X - REAL, vector (grid) to be checked (I)=*
-*= OK - LOGICAL, .TRUE. -> X agrees with rules 1)-5) (O)=*
-*= .FALSE.-> X violates at least one of 1)-5) =*
-*-----------------------------------------------------------------------------*
-
- IMPLICIT NONE
-
-c INCLUDE 'params'
-
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
@@ -6421,9 +6048,246 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+ REAL zincr ! i
+ INTEGER nlev ! i
+ INTEGER n ! i/o
+ REAL z(kz) ! i/o
+ INTEGER i, j ! internal
+
+ j = 0
+ DO i = n + 1, n + nlev
+ j = j + 1
+ z(i) = z(n) + FLOAT(j)*zincr
+ ENDDO
+ n = n + nlev
+
+ RETURN
+ END
+
+*=============================================================================*
+
+c SUBROUTINE gridt(lat, lon, tmzone,
+c $ iyear, imonth, iday,
+c $ lzenit, tstart, tstop,
+c $ nt, t, sza, esrm2)
+c
+c *-----------------------------------------------------------------------------*
+c *= Subroutine to create time (or solar zenith angle) grid =*
+c *= Also computes earth-sun distance (1/R**2) correction. =*
+c *-----------------------------------------------------------------------------*
+c
+c IMPLICIT NONE
+c
+c c INCLUDE 'params'
+c
+c * BROADLY USED PARAMETERS:
+c *_________________________________________________
+c * i/o file unit numbers
+c INTEGER kout, kin
+c * output
+c PARAMETER(kout=6)
+c * input
+c PARAMETER(kin=78)
+c *_________________________________________________
+c * altitude, wavelength, time (or solar zenith angle) grids
+c INTEGER kz, kw
+c * altitude
+c PARAMETER(kz=151)
+c * wavelength
+c PARAMETER(kw=157)
+c *_________________________________________________
+c * number of weighting functions
+c INTEGER kj
+c * wavelength and altitude dependent
+c PARAMETER(kj=90)
+c
+c * delta for adding points at beginning or end of data grids
+c REAL deltax
+c PARAMETER (deltax = 1.E-5)
+c
+c * some constants...
+c
+c * pi:
+c REAL pi
+c PARAMETER(pi=3.1415926535898)
+c
+c * radius of the earth, km:
+c REAL radius
+c PARAMETER(radius=6.371E+3)
+c
+c * Planck constant x speed of light, J m
+c
+c REAL hc
+c PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+c
+c * largest number of the machine:
+c REAL largest
+c PARAMETER(largest=1.E+36)
+c
+c * small numbers (positive and negative)
+c REAL pzero, nzero
+c PARAMETER(pzero = +10./largest)
+c PARAMETER(nzero = -10./largest)
+c
+c * machine precision
+c
+c REAL precis
+c PARAMETER(precis = 1.e-7)
+c
+c * INPUTS
+c
+c REAL lat, lon, tmzone
+c INTEGER iyear, imonth, iday
+c LOGICAL lzenit
+c INTEGER nt
+c REAL tstart, tstop
+c
+c
+c * OUTPUTS
+c
+c REAL t, sza, esrm2
+c
+c * INTERNAL
+c
+c INTEGER it
+c REAL ut, dt
+c
+c INTEGER jday, nday
+c LOGICAL oky, okm, okd
+c
+c REAL az, el, soldia, soldst
+c
+c * switch for refraction correction to solar zenith angle. Because
+c * this is only for the observed sza at the surface, do not use.
+c
+c LOGICAL lrefr
+c DATA lrefr /.FALSE./
+c
+c ***************
+c
+c IF(nt .EQ. 1) THEN
+c dt = 0.
+c ELSE
+c dt = (tstop - tstart) / FLOAT(nt - 1)
+c ENDIF
+c
+c DO 10 it = 1, nt
+c t(it) = tstart + dt * FLOAT(it - 1)
+c
+c * solar zenith angle calculation:
+c * If lzenit = .TRUE., use selected solar zenith angles, also
+c * set Earth-Sun distance to 1 AU.
+c
+c IF (lzenit) THEN
+c sza(it) = t(it)
+c esrm2(it) = 1.
+c
+c * If lzenit = .FALSE., compute solar zenith angle for specified
+c * location, date, time of day. Assume no refraction (lrefr = .FALSE.)
+c * Also calculate corresponding
+c * Earth-Sun correcton factor.
+c
+c ELSE
+c CALL calend(iyear, imonth, iday,
+c $ jday, nday, oky, okm, okd)
+c IF( oky .AND. okm .AND. okd) THEN
+c
+c ut = t(it) - tmzone
+c CALL sunae(iyear, jday, ut, lat, lon, lrefr,
+c & az, el, soldia, soldst )
+c sza(it) = 90. - el
+c esrm2(it) = 1./(soldst*soldst)
+c ELSE
+c WRITE(*,*) '**** incorrect date specification'
+c STOP ' in gridt '
+c ENDIF
+c ENDIF
+c
+c 10 CONTINUE
+c RETURN
+c END
+
+*=============================================================================*
+
+ SUBROUTINE gridck(k,n,x,ok, kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Check a grid X for various improperties. The values in X have to comply =*
+*= with the following rules: =*
+*= 1) Number of actual points cannot exceed declared length of X =*
+*= 2) Number of actual points has to be greater than or equal to 2 =*
+*= 3) X-values must be non-negative =*
+*= 4) X-values must be unique =*
+*= 5) X-values must be in ascending order =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= K - INTEGER, length of X as declared in the calling program (I)=*
+*= N - INTEGER, number of actual points in X (I)=*
+*= X - REAL, vector (grid) to be checked (I)=*
+*= OK - LOGICAL, .TRUE. -> X agrees with rules 1)-5) (O)=*
+*= .FALSE.-> X violates at least one of 1)-5) =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -6512,6 +6376,8 @@ c INCLUDE 'params'
RETURN
END
+
+CCC FILE la_srb.f
* This file contains the following subroutines, related to the calculation
* of radiation at Lyman-alpha and Schumann-Runge wavelengths:
* la_srb
@@ -6525,7 +6391,7 @@ c INCLUDE 'params'
* chebev
*=============================================================================*
- SUBROUTINE la_srb(nz,z,tlev,nw,wl,vcol,scol,o2xs1,dto2,o2xs)
+ SUBROUTINE la_srb(nz,z,tlev,nw,wl,vcol,scol,o2xs1,dto2,o2xs,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -6561,7 +6427,7 @@ c c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -6573,9 +6439,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -6758,7 +6622,7 @@ c c INCLUDE 'params'
* and O2 effective (equivalent) cross section
*----------------------------------------------------------------------
- CALL lymana(nz,o2col,secchi,dto2la,o2xsla)
+ CALL lymana(nz,o2col,secchi,dto2la,o2xsla,kout)
DO iw = ila, ila + nla - 1
DO iz = 1, nz
dto2(iz,iw) = dto2la(iz, iw - ila + 1)
@@ -6771,7 +6635,7 @@ c c INCLUDE 'params'
* optical depth and O2 equivalent cross section
*------------------------------------------------------------------------------
- CALL schum(nz,o2col,tlev,secchi,dto2k,o2xsk)
+ CALL schum(nz,o2col,tlev,secchi,dto2k,o2xsk,kout)
DO iw = isrb, isrb + nsrb - 1
DO iz = 1, nz
dto2(iz,iw) = dto2k(iz, iw - isrb + 1)
@@ -6784,7 +6648,7 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE lymana(nz,o2col,secchi,dto2la,o2xsla)
+ SUBROUTINE lymana(nz,o2col,secchi,dto2la,o2xsla,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -6815,7 +6679,7 @@ c c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -6827,9 +6691,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -6865,6 +6727,9 @@ c c INCLUDE 'params'
REAL precis
PARAMETER(precis = 1.e-7)
+
+* input:
+
INTEGER nz
REAL o2col(kz)
REAL secchi(kz)
@@ -6875,8 +6740,8 @@ c c INCLUDE 'params'
* local variables
- REAL rm(kz), ro2(kz)
- REAL b(3), c(3), d(3), e(3)
+ DOUBLE PRECISION rm(kz), ro2(kz)
+ DOUBLE PRECISION b(3), c(3), d(3), e(3)
DATA b/ 6.8431D-01, 2.29841D-01, 8.65412D-02/,
> c/8.22114D-21, 1.77556D-20, 8.22112D-21/,
> d/ 6.0073D-21, 4.28569D-21, 1.28059D-20/,
@@ -6896,8 +6761,8 @@ c c INCLUDE 'params'
rm(iz) = 0.D+00
ro2(iz) = 0.D+00
DO i = 1, 3
- rm(iz) = rm(iz) + b(i) * EXP(-c(i) * DBLE(o2col(iz)))
- ro2(iz) = ro2(iz) + d(i) * EXP(-e(i) * DBLE(o2col(iz)))
+ rm(iz) = rm(iz) + b(i) * DEXP(-c(i) * DBLE(o2col(iz)))
+ ro2(iz) = ro2(iz) + d(i) * DEXP(-e(i) * DBLE(o2col(iz)))
ENDDO
ENDDO
@@ -6942,7 +6807,7 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE schum(nz, o2col, tlev, secchi, dto2, o2xsk)
+ SUBROUTINE schum(nz, o2col, tlev, secchi, dto2, o2xsk,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -6965,14 +6830,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -6984,9 +6849,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -7023,6 +6886,7 @@ c c INCLUDE 'params'
REAL precis
PARAMETER(precis = 1.e-7)
+*----------
INTEGER nz
REAL o2col(kz), o2col1(kz)
REAL tlev(kz), secchi(kz)
@@ -7177,9 +7041,9 @@ C-------------------------------------------------------------
IMPLICIT NONE
- REAL NO2, T, X
+ REAL NO2, T, X
REAL XS(17)
- REAL A(17), B(17)
+ REAL A(17), B(17)
INTEGER I
CALL CALC_PARAMS( X, A, B )
@@ -7212,8 +7076,8 @@ C-------------------------------------------------------------
REAL CHEBEV
- REAL AC(20,17)
- REAL BC(20,17) ! Chebyshev polynomial coeffs
+ DOUBLE PRECISION AC(20,17)
+ DOUBLE PRECISION BC(20,17) ! Chebyshev polynomial coeffs
REAL WAVE_NUM(17)
COMMON /XS_COEFFS/ AC, BC, WAVE_NUM
@@ -7241,8 +7105,8 @@ C polynomial coeffs necessary to calculate O2 effective
C cross-sections
C
C-------------------------------------------------------------
- REAL AC(20,17)
- REAL BC(20,17) ! Chebyshev polynomial coeffs
+ DOUBLE PRECISION AC(20,17)
+ DOUBLE PRECISION BC(20,17) ! Chebyshev polynomial coeffs
REAL WAVE_NUM(17)
COMMON /XS_COEFFS/ AC, BC, WAVE_NUM
@@ -7280,9 +7144,7 @@ C locals
*=============================================================================*
-C ##############################
FUNCTION chebev(a,b,c,m,x)
-C ##############################
C-------------------------------------------------------------
C
@@ -7293,7 +7155,7 @@ C-------------------------------------------------------------
INTEGER M
REAL CHEBEV,A,B,X
- REAL C(M)
+ DOUBLE PRECISION C(M)
INTEGER J
REAL D,DD,SV,Y,Y2
@@ -7319,7 +7181,7 @@ c WRITE(6,*) 'X NOT IN RANGE IN CHEBEV', X
*=============================================================================*
- SUBROUTINE sjo2(nz,nw,xso2,nj,sq)
+ SUBROUTINE sjo2(nz,nw,xso2,nj,sq,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -7343,14 +7205,14 @@ c WRITE(6,*) 'X NOT IN RANGE IN CHEBEV', X
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -7362,9 +7224,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -7427,6 +7287,8 @@ c c INCLUDE 'params'
RETURN
END
+
+CCC FILE numer.f
* This file contains the following subroutines, related to interpolations
* of input data, addition of points to arrays, and zeroing of arrays:
* inter1
@@ -8064,9 +7926,11 @@ c c INCLUDE 'params'
1 CONTINUE
RETURN
END
+
+CCC FILE odo3.f
*=============================================================================*
- SUBROUTINE odo3(nz,z,nw,wl,o3xs,c, dto3)
+ SUBROUTINE odo3(nz,z,nw,wl,o3xs,c, dto3,kout)
*-----------------------------------------------------------------------------*
*= NAME: Optical Depths of O3
@@ -8097,7 +7961,7 @@ c c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -8109,9 +7973,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -8194,10 +8056,12 @@ c c INCLUDE 'params'
RETURN
END
+
+CCC FILE odrl.f
*=============================================================================*
SUBROUTINE odrl(nz,z,nw,wl, c,
- $ dtrl)
+ $ dtrl,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -8218,14 +8082,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -8237,9 +8101,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -8326,110 +8188,109 @@ C srayl(iw) = 3.90e-28/(wmicrn)**xx
RETURN
END
+
+CCC FILE orbit.f
* This file contains the following subroutines, related to the orbit and
* rotation of the Earth:
* calend
* sunae
*=============================================================================*
- SUBROUTINE calend(iyear, imonth, iday,
- $ jday, nday, oky, okm, okd)
-
-*-----------------------------------------------------------------------------*
-*= calculates julian day corresponding to specified year, month, day =*
-*= also checks validity of date =*
-*-----------------------------------------------------------------------------*
-
- IMPLICIT NONE
-
-* input:
-
- INTEGER iyear, imonth, iday
-
-* output:
-
- INTEGER jday, nday
- LOGICAL oky, okm, okd
-
-* internal
-
- INTEGER mday, month, imn(12)
- DATA imn/31,28,31,30,31,30,31,31,30,31,30,31/
-
- oky = .TRUE.
- okm = .TRUE.
- okd = .TRUE.
-
- IF(iyear .LT. 1950 .OR. iyear .GT. 2050) THEN
- WRITE(*,*) 'Year must be between 1950 and 2050)'
- oky = .FALSE.
- ENDIF
-
- IF(imonth .LT. 1 .OR. imonth .GT. 12) THEN
- WRITE(*,*) 'Month must be between 1 and 12'
- okm = .FALSE.
- ENDIF
-
- IF ( MOD(iyear,4) .EQ. 0) THEN
- imn(2) = 29
- ELSE
- imn(2) = 28
- ENDIF
-
- IF (iday. GT. imn(imonth)) THEN
- WRITE(*,*) 'Day in date exceeds days in month'
- WRITE(*,*) 'month = ', imonth
- WRITE(*,*) 'day = ', iday
- okd = .FALSE.
- ENDIF
-
- mday = 0
- DO 12, month = 1, imonth-1
- mday = mday + imn(month)
- 12 CONTINUE
- jday = mday + iday
-
- nday = 365
- IF(imn(2) .EQ. 29) nday = 366
-
- RETURN
- END
-
-c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-c RCS version control information:
-c $Header: /home/cvsroot/MNH-VX-Y-Z/src/MNH/ch_f77.fx90,v 1.2.2.1.2.2.2.1.8.2.2.3 2014/06/19 15:18:13 escj Exp $
+c SUBROUTINE calend(iyear, imonth, iday,
+c $ jday, nday, oky, okm, okd)
+c
+c*-----------------------------------------------------------------------------*
+c*= calculates julian day corresponding to specified year, month, day =*
+c*= also checks validity of date =*
+c*-----------------------------------------------------------------------------*
+c
+c IMPLICIT NONE
+c
+c* input:
+c
+c INTEGER iyear, imonth, iday
+c
+c* output:
+c
+c INTEGER jday, nday
+c LOGICAL oky, okm, okd
+c
+c* internal
+c
+c INTEGER mday, month, imn(12)
+c DATA imn/31,28,31,30,31,30,31,31,30,31,30,31/
+c
+c oky = .TRUE.
+c okm = .TRUE.
+c okd = .TRUE.
+c
+c IF(iyear .LT. 1950 .OR. iyear .GT. 2050) THEN
+c WRITE(*,*) 'Year must be between 1950 and 2050)'
+c oky = .FALSE.
+c ENDIF
+c
+c IF(imonth .LT. 1 .OR. imonth .GT. 12) THEN
+c WRITE(*,*) 'Month must be between 1 and 12'
+c okm = .FALSE.
+c ENDIF
+c
+c IF ( MOD(iyear,4) .EQ. 0) THEN
+c imn(2) = 29
+c ELSE
+c imn(2) = 28
+c ENDIF
+c
+c IF (iday. GT. imn(imonth)) THEN
+c WRITE(*,*) 'Day in date exceeds days in month'
+c WRITE(*,*) 'month = ', imonth
+c WRITE(*,*) 'day = ', iday
+c okd = .FALSE.
+c ENDIF
+c
+c mday = 0
+c DO 12, month = 1, imonth-1
+c mday = mday + imn(month)
+c 12 CONTINUE
+c jday = mday + iday
+c
+c nday = 365
+c IF(imn(2) .EQ. 29) nday = 366
+c
+c RETURN
+c END
+c
c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
- SUBROUTINE SUNAE( YEAR, DAY, HOUR, LAT, LONG, lrefr,
- & AZ, EL, SOLDIA, SOLDST )
-
+c
+c SUBROUTINE SUNAE( YEAR, DAY, HOUR, LAT, LONG, lrefr,
+c & AZ, EL, SOLDIA, SOLDST )
+c
c Calculates the local solar azimuth and elevation angles, and
c the distance to and angle subtended by the Sun, at a specific
c location and time using approximate formulas in The Astronomical
c Almanac. Accuracy of angles is 0.01 deg or better (the angular
c width of the Sun is about 0.5 deg, so 0.01 deg is more than
c sufficient for most applications).
-
+c
c Unlike many GCM (and other) sun angle routines, this
c one gives slightly different sun angles depending on
c the year. The difference is usually down in the 4th
c significant digit but can slowly creep up to the 3rd
c significant digit after several decades to a century.
-
+c
c A refraction correction appropriate for the "US Standard
c Atmosphere" is added, so that the returned sun position is
c the APPARENT one. The correction is below 0.1 deg for solar
c elevations above 9 deg. To remove it, comment out the code
c block where variable REFRAC is set, and replace it with
c REFRAC = 0.0.
-
+c
c References:
-
+c
c Michalsky, J., 1988: The Astronomical Almanac's algorithm for
c approximate solar position (1950-2050), Solar Energy 40,
c 227-235 (but the version of this program in the Appendix
c contains errors and should not be used)
-
+c
c The Astronomical Almanac, U.S. Gov't Printing Office, Washington,
c D.C. (published every year): the formulas used from the 1995
c version are as follows:
@@ -8440,31 +8301,31 @@ c p. C24: mean longitude, mean anomaly, ecliptic longitude,
c obliquity of ecliptic, right ascension, declination,
c Earth-Sun distance, angular diameter of Sun
c p. L2: Greenwich mean sidereal time (ignoring T^2, T^3 terms)
-
-
+c
+c
c Authors: Dr. Joe Michalsky (joe@asrc.albany.edu)
c Dr. Lee Harrison (lee@asrc.albany.edu)
c Atmospheric Sciences Research Center
c State University of New York
c Albany, New York
-
+c
c Modified by: Dr. Warren Wiscombe (wiscombe@climate.gsfc.nasa.gov)
c NASA Goddard Space Flight Center
c Code 913
c Greenbelt, MD 20771
-
-
+c
+c
c WARNING: Do not use this routine outside the year range
c 1950-2050. The approximations become increasingly
c worse, and the calculation of Julian date becomes
c more involved.
-
+c
c Input:
-
+c
c YEAR year (INTEGER; range 1950 to 2050)
-
+c
c DAY day of year at LAT-LONG location (INTEGER; range 1-366)
-
+c
c HOUR hour of DAY [GMT or UT] (REAL; range -13.0 to 36.0)
c = (local hour) + (time zone number)
c + (Daylight Savings Time correction; -1 or 0)
@@ -8475,56 +8336,56 @@ c (summer half of year), 0 otherwise;
c Example: 8:30 am Eastern Daylight Time would be
c
c HOUR = 8.5 + 5 - 1 = 12.5
-
+c
c LAT latitude [degrees]
c (REAL; range -90.0 to 90.0; north is positive)
-
+c
c LONG longitude [degrees]
c (REAL; range -180.0 to 180.0; east is positive)
-
-
+c
+c
c Output:
-
+c
c AZ solar azimuth angle (measured east from north,
c 0 to 360 degs)
-
+c
c EL solar elevation angle [-90 to 90 degs];
c solar zenith angle = 90 - EL
-
+c
c SOLDIA solar diameter [degs]
-
+c
c SOLDST distance to sun [Astronomical Units, AU]
c (1 AU = mean Earth-sun distance = 1.49597871E+11 m
c in IAU 1976 System of Astronomical Constants)
-
-
+c
+c
c Local Variables:
-
+c
c DEC Declination (radians)
-
+c
c ECLONG Ecliptic longitude (radians)
-
+c
c GMST Greenwich mean sidereal time (hours)
-
+c
c HA Hour angle (radians, -pi to pi)
-
+c
c JD Modified Julian date (number of days, including
c fractions thereof, from Julian year J2000.0);
c actual Julian date is JD + 2451545.0
-
+c
c LMST Local mean sidereal time (radians)
-
+c
c MNANOM Mean anomaly (radians, normalized to 0 to 2*pi)
-
+c
c MNLONG Mean longitude of Sun, corrected for aberration
c (deg; normalized to 0-360)
-
+c
c OBLQEC Obliquity of the ecliptic (radians)
-
+c
c RA Right ascension (radians)
-
+c
c REFRAC Refraction correction for US Standard Atmosphere (degs)
-
+c
c --------------------------------------------------------------------
c Uses double precision for safety and because Julian dates can
c have a large number of digits in their full form (but in practice
@@ -8532,7 +8393,7 @@ c this version seems to work fine in single precision if you only
c need about 3 significant digits and aren't doing precise climate
c change or solar tracking work).
c --------------------------------------------------------------------
-
+c
c Why does this routine require time input as Greenwich Mean Time
c (GMT; also called Universal Time, UT) rather than "local time"?
c Because "local time" (e.g. Eastern Standard Time) can be off by
@@ -8546,9 +8407,9 @@ c Thus it is far simpler to calculate local mean solar time from GMT,
c by adding 4 min for each degree of longitude the location is
c east of the Greenwich meridian or subtracting 4 min for each degree
c west of it.
-
+c
c --------------------------------------------------------------------
-
+c
c TIME
c
c The measurement of time has become a complicated topic. A few
@@ -8559,7 +8420,7 @@ c Julian calendar; in it, every year divisible by four is a leap
c year just as in the Julian calendar except for centurial years
c which must be exactly divisible by 400 to be leap years. Thus
c 2000 is a leap year, but not 1900 or 2100.
-
+c
c (2) The Julian day begins at Greenwich noon whereas the calendar
c day begins at the preceding midnight; and Julian years begin on
c "Jan 0" which is really Greenwich noon on Dec 31. True Julian
@@ -8567,236 +8428,217 @@ c dates are a continous count of day numbers beginning with JD 0 on
c 1 Jan 4713 B.C. The term "Julian date" is widely misused and few
c people understand it; it is best avoided unless you want to study
c the Astronomical Almanac and learn to use it correctly.
-
+c
c (3) Universal Time (UT), the basis of civil timekeeping, is
c defined by a formula relating UT to GMST (Greenwich mean sidereal
c time). UTC (Coordinated Universal Time) is the time scale
c distributed by most broadcast time services. UT, UTC, and other
c related time measures are within a few sec of each other and are
c frequently used interchangeably.
-
+c
c (4) Beginning in 1984, the "standard epoch" of the astronomical
c coordinate system is Jan 1, 2000, 12 hr TDB (Julian date
c 2,451,545.0, denoted J2000.0). The fact that this routine uses
c 1949 as a point of reference is merely for numerical convenience.
c --------------------------------------------------------------------
-
+c
c .. Scalar Arguments ..
-
- LOGICAL lrefr
-
-
- INTEGER YEAR, DAY
- REAL AZ, EL, HOUR, LAT, LONG, SOLDIA, SOLDST
+c
+c LOGICAL lrefr
+c
+c
+c INTEGER YEAR, DAY
+c REAL AZ, EL, HOUR, LAT, LONG, SOLDIA, SOLDST
c ..
c .. Local Scalars ..
-
- LOGICAL PASS1
- INTEGER DELTA, LEAP
- REAL DEC, DEN, ECLONG, GMST, HA, JD, LMST,
- & MNANOM, MNLONG, NUM, OBLQEC, PI, RA,
- & RPD, REFRAC, TIME, TWOPI
+c
+c LOGICAL PASS1
+c INTEGER DELTA, LEAP
+c REAL DEC, DEN, ECLONG, GMST, HA, JD, LMST,
+c & MNANOM, MNLONG, NUM, OBLQEC, PI, RA,
+c & RPD, REFRAC, TIME, TWOPI
c ..
c .. Intrinsic Functions ..
-
- INTRINSIC AINT, ASIN, ATAN, COS, MOD, SIN, TAN
+c
+c INTRINSIC AINT, ASIN, ATAN, COS, MOD, SIN, TAN
c ..
c .. Data statements ..
-
- SAVE PASS1, PI, TWOPI, RPD
- DATA PASS1 /.True./
+c
+c SAVE PASS1, PI, TWOPI, RPD
+c DATA PASS1 /.True./
c ..
-
- IF( YEAR.LT.1950 .OR. YEAR.GT.2050 )
- & STOP 'SUNAE--bad input variable YEAR'
- IF( DAY.LT.1 .OR. DAY.GT.366 )
- & STOP 'SUNAE--bad input variable DAY'
- IF( HOUR.LT.-13.0 .OR. HOUR.GT.36.0 )
- & STOP 'SUNAE--bad input variable HOUR'
- IF( LAT.LT.-90.0 .OR. LAT.GT.90.0 )
- & STOP 'SUNAE--bad input variable LAT'
- IF( LONG.LT.-180.0 .OR. LONG.GT.180.0 )
- & STOP 'SUNAE--bad input variable LONG'
-
- IF(PASS1) THEN
- PI = 2.*ASIN( 1.0 )
- TWOPI = 2.*PI
- RPD = PI / 180.
- PASS1 = .False.
- ENDIF
-
+c
+c IF( YEAR.LT.1950 .OR. YEAR.GT.2050 )
+c & STOP 'SUNAE--bad input variable YEAR'
+c IF( DAY.LT.1 .OR. DAY.GT.366 )
+c & STOP 'SUNAE--bad input variable DAY'
+c IF( HOUR.LT.-13.0 .OR. HOUR.GT.36.0 )
+c & STOP 'SUNAE--bad input variable HOUR'
+c IF( LAT.LT.-90.0 .OR. LAT.GT.90.0 )
+c & STOP 'SUNAE--bad input variable LAT'
+c IF( LONG.LT.-180.0 .OR. LONG.GT.180.0 )
+c & STOP 'SUNAE--bad input variable LONG'
+c
+c IF(PASS1) THEN
+c PI = 2.*ASIN( 1.0 )
+c TWOPI = 2.*PI
+c RPD = PI / 180.
+c PASS1 = .False.
+c ENDIF
+c
c ** current Julian date (actually add 2,400,000
c ** for true JD); LEAP = leap days since 1949;
c ** 32916.5 is midnite 0 jan 1949 minus 2.4e6
-
- DELTA = YEAR - 1949
- LEAP = DELTA / 4
- JD = 32916.5 + (DELTA*365 + LEAP + DAY) + HOUR / 24.
-
+c
+c DELTA = YEAR - 1949
+c LEAP = DELTA / 4
+c JD = 32916.5 + (DELTA*365 + LEAP + DAY) + HOUR / 24.
+c
c ** last yr of century not leap yr unless divisible
c ** by 400 (not executed for the allowed YEAR range,
c ** but left in so our successors can adapt this for
c ** the following 100 years)
-
- IF( MOD( YEAR, 100 ).EQ.0 .AND.
- & MOD( YEAR, 400 ).NE.0 ) JD = JD - 1.
-
+c
+c IF( MOD( YEAR, 100 ).EQ.0 .AND.
+c & MOD( YEAR, 400 ).NE.0 ) JD = JD - 1.
+c
c ** ecliptic coordinates
c ** 51545.0 + 2.4e6 = noon 1 jan 2000
-
- TIME = JD - 51545.0
-
+c
+c TIME = JD - 51545.0
+c
c ** force mean longitude between 0 and 360 degs
-
- MNLONG = 280.460 + 0.9856474*TIME
-#if (MNH_REAL == 8)
- MNLONG = MOD( MNLONG, 360.E0 )
-#else
- MNLONG = MOD( MNLONG, 360.D0 )
-#endif
- IF( MNLONG.LT.0. ) MNLONG = MNLONG + 360.
-
+c
+c MNLONG = 280.460 + 0.9856474*TIME
+c MNLONG = MOD( MNLONG, 360.D0 )
+c IF( MNLONG.LT.0. ) MNLONG = MNLONG + 360.
+c
c ** mean anomaly in radians between 0 and 2*pi
-
- MNANOM = 357.528 + 0.9856003*TIME
-#if (MNH_REAL == 8)
- MNANOM = MOD( MNANOM, 360.E0 )
-#else
- MNANOM = MOD( MNANOM, 360.D0 )
-#endif
- IF( MNANOM.LT.0.) MNANOM = MNANOM + 360.
-
- MNANOM = MNANOM*RPD
-
+c
+c MNANOM = 357.528 + 0.9856003*TIME
+c MNANOM = MOD( MNANOM, 360.D0 )
+c IF( MNANOM.LT.0.) MNANOM = MNANOM + 360.
+c
+c MNANOM = MNANOM*RPD
+c
c ** ecliptic longitude and obliquity
c ** of ecliptic in radians
-
- ECLONG = MNLONG + 1.915*SIN( MNANOM ) + 0.020*SIN( 2.*MNANOM )
-#if (MNH_REAL == 8)
- ECLONG = MOD( ECLONG, 360.E0 )
-#else
- ECLONG = MOD( ECLONG, 360.D0 )
-#endif
- IF( ECLONG.LT.0. ) ECLONG = ECLONG + 360.
-
- OBLQEC = 23.439 - 0.0000004*TIME
- ECLONG = ECLONG*RPD
- OBLQEC = OBLQEC*RPD
-
+c
+c ECLONG = MNLONG + 1.915*SIN( MNANOM ) + 0.020*SIN( 2.*MNANOM )
+c ECLONG = MOD( ECLONG, 360.D0 )
+c IF( ECLONG.LT.0. ) ECLONG = ECLONG + 360.
+c
+c OBLQEC = 23.439 - 0.0000004*TIME
+c ECLONG = ECLONG*RPD
+c OBLQEC = OBLQEC*RPD
+c
c ** right ascension
-
- NUM = COS( OBLQEC )*SIN( ECLONG )
- DEN = COS( ECLONG )
- RA = ATAN( NUM / DEN )
-
+c
+c NUM = COS( OBLQEC )*SIN( ECLONG )
+c DEN = COS( ECLONG )
+c RA = ATAN( NUM / DEN )
+c
c ** Force right ascension between 0 and 2*pi
-
- IF( DEN.LT.0.0 ) THEN
- RA = RA + PI
- ELSE IF( NUM.LT.0.0 ) THEN
- RA = RA + TWOPI
- END IF
-
+c
+c IF( DEN.LT.0.0 ) THEN
+c RA = RA + PI
+c ELSE IF( NUM.LT.0.0 ) THEN
+c RA = RA + TWOPI
+c END IF
+c
c ** declination
-
- DEC = ASIN( SIN( OBLQEC )*SIN( ECLONG ) )
-
+c
+c DEC = ASIN( SIN( OBLQEC )*SIN( ECLONG ) )
+c
c ** Greenwich mean sidereal time in hours
-
- GMST = 6.697375 + 0.0657098242*TIME + HOUR
-
+c
+c GMST = 6.697375 + 0.0657098242*TIME + HOUR
+c
c ** Hour not changed to sidereal time since
c ** 'time' includes the fractional day
-
-#if (MNH_REAL == 8)
- GMST = MOD( GMST, 24.E0)
-#else
- GMST = MOD( GMST, 24.D0)
-#endif
- IF( GMST.LT.0. ) GMST = GMST + 24.
-
+c
+c GMST = MOD( GMST, 24.D0)
+c IF( GMST.LT.0. ) GMST = GMST + 24.
+c
c ** local mean sidereal time in radians
-
- LMST = GMST + LONG / 15.
-#if (MNH_REAL == 8)
- LMST = MOD( LMST, 24.E0 )
-#else
- LMST = MOD( LMST, 24.D0 )
-#endif
- IF( LMST.LT.0. ) LMST = LMST + 24.
-
- LMST = LMST*15.*RPD
-
+c
+c LMST = GMST + LONG / 15.
+c LMST = MOD( LMST, 24.D0 )
+c IF( LMST.LT.0. ) LMST = LMST + 24.
+c
+c LMST = LMST*15.*RPD
+c
c ** hour angle in radians between -pi and pi
-
- HA = LMST - RA
-
- IF( HA.LT.- PI ) HA = HA + TWOPI
- IF( HA.GT.PI ) HA = HA - TWOPI
-
+c
+c HA = LMST - RA
+c
+c IF( HA.LT.- PI ) HA = HA + TWOPI
+c IF( HA.GT.PI ) HA = HA - TWOPI
+c
c ** solar azimuth and elevation
-
- EL = ASIN( SIN( DEC )*SIN( LAT*RPD ) +
- & COS( DEC )*COS( LAT*RPD )*COS( HA ) )
-
- AZ = ASIN( - COS( DEC )*SIN( HA ) / COS( EL ) )
-
+c
+c EL = ASIN( SIN( DEC )*SIN( LAT*RPD ) +
+c & COS( DEC )*COS( LAT*RPD )*COS( HA ) )
+c
+c AZ = ASIN( - COS( DEC )*SIN( HA ) / COS( EL ) )
+c
c ** Put azimuth between 0 and 2*pi radians
-
- IF( SIN( DEC ) - SIN( EL )*SIN( LAT*RPD ).GE.0. ) THEN
-
- IF( SIN(AZ).LT.0.) AZ = AZ + TWOPI
-
- ELSE
-
- AZ = PI - AZ
-
- END IF
-
+c
+c IF( SIN( DEC ) - SIN( EL )*SIN( LAT*RPD ).GE.0. ) THEN
+c
+c IF( SIN(AZ).LT.0.) AZ = AZ + TWOPI
+c
+c ELSE
+c
+c AZ = PI - AZ
+c
+c END IF
+c
c ** Convert elevation and azimuth to degrees
- EL = EL / RPD
- AZ = AZ / RPD
-
+c EL = EL / RPD
+c AZ = AZ / RPD
+c
c ======== Refraction correction for U.S. Standard Atmos. ==========
c (assumes elevation in degs) (3.51823=1013.25 mb/288 K)
-
- IF( EL.GE.19.225 ) THEN
-
- REFRAC = 0.00452*3.51823 / TAN( EL*RPD )
-
- ELSE IF( EL.GT.-0.766 .AND. EL.LT.19.225 ) THEN
-
- REFRAC = 3.51823 * ( 0.1594 + EL*(0.0196 + 0.00002*EL) ) /
- & ( 1. + EL*(0.505 + 0.0845*EL) )
-
- ELSE IF( EL.LE.-0.766 ) THEN
-
- REFRAC = 0.0
-
- END IF
-
-* sm: switch off refraction:
-
- IF(lrefr) THEN
- EL = EL + REFRAC
- ENDIF
-
-c ===================================================================
-
+c
+c IF( EL.GE.19.225 ) THEN
+c
+c REFRAC = 0.00452*3.51823 / TAN( EL*RPD )
+c
+c ELSE IF( EL.GT.-0.766 .AND. EL.LT.19.225 ) THEN
+c
+c REFRAC = 3.51823 * ( 0.1594 + EL*(0.0196 + 0.00002*EL) ) /
+c & ( 1. + EL*(0.505 + 0.0845*EL) )
+c
+c ELSE IF( EL.LE.-0.766 ) THEN
+c
+c REFRAC = 0.0
+c
+c END IF
+c
+c* sm: switch off refraction:
+c
+c IF(lrefr) THEN
+c EL = EL + REFRAC
+c ENDIF
+c
+cc ===================================================================
+c
c ** distance to sun in A.U. & diameter in degs
-
- SOLDST = 1.00014 - 0.01671*COS(MNANOM) - 0.00014*COS( 2.*MNANOM )
- SOLDIA = 0.5332 / SOLDST
-
- IF( EL.LT.-90.0 .OR. EL.GT.90.0 )
- & STOP 'SUNAE--output argument EL out of range'
- IF( AZ.LT.0.0 .OR. AZ.GT.360.0 )
- & STOP 'SUNAE--output argument AZ out of range'
-
- RETURN
-
- END
-
+c
+c SOLDST = 1.00014 - 0.01671*COS(MNANOM) - 0.00014*COS( 2.*MNANOM )
+c SOLDIA = 0.5332 / SOLDST
+c
+c IF( EL.LT.-90.0 .OR. EL.GT.90.0 )
+c & STOP 'SUNAE--output argument EL out of range'
+c IF( AZ.LT.0.0 .OR. AZ.GT.360.0 )
+c & STOP 'SUNAE--output argument AZ out of range'
+c
+c RETURN
+c
+c END
+c
+CCC FILE qys.f
* This file contains subroutines used for calculation of quantum yields for
* various photoreactions:
* qyacet - q.y. for acetone, based on Blitz et al. (2004)
@@ -8827,6 +8669,8 @@ c ** distance to sun in A.U. & diameter in degs
REAL c3
REAL cA0, cA1, cA2, cA3, cA4
+ real dumexp
+
* output
* fco = quantum yield for product CO
* fac = quantum yield for product CH3CO (acetyl radical)
@@ -8853,9 +8697,16 @@ c ** distance to sun in A.U. & diameter in degs
a0 = 0.350 * (T/295.)**(-1.28)
b0 = 0.068 * (T/295.)**(-2.65)
- cA0 = exp(b0*(w - 248.)) * a0 / (1. - a0)
+**SM: prevent exponent overflow in rare cases:
- fco = 1. / (1 + cA0)
+ dumexp = b0*(w - 248.)
+ if (dumexp .gt. 80.) then
+ cA0 = 5.e34
+ else
+ cA0 = exp(dumexp) * a0 / (1. - a0)
+ endif
+
+ fco = 1. / (1. + cA0)
*** CH3CO (acetyl radical) quantum yields:
@@ -8953,9 +8804,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -9331,7 +9180,7 @@ c c INCLUDE 'params'
ELSEIF (msun .EQ. 10) THEN
WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
- CALL read1(nw,wl,yg1)
+ CALL read1(nw,wl,yg1,kout)
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
@@ -9339,14 +9188,14 @@ c c INCLUDE 'params'
ELSEIF (msun .EQ. 11) THEN
WRITE(kout,*) 'DATAE1/SUN/wmo85.flx'
- CALL read2(nw,wl,yg1)
+ CALL read2(nw,wl,yg1,kout)
DO iw = 1, nw-1
f(iw) = yg1(iw)
ENDDO
ELSEIF (msun .EQ. 12) THEN
WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
- CALL read1(nw,wl,yg1)
+ CALL read1(nw,wl,yg1,kout)
fil = 'DATAE1/SUN/neckel.flx'
write(kout,*) fil
OPEN(UNIT=kin,FILE=fil,STATUS='old')
@@ -9383,7 +9232,7 @@ c c INCLUDE 'params'
ELSEIF (msun .EQ. 13) THEN
WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
- CALL read1(nw,wl,yg1)
+ CALL read1(nw,wl,yg1,kout)
nhead = 5
fil = 'DATAE1/SUN/atlas3_1994_317_a.dat'
@@ -9443,7 +9292,7 @@ c c INCLUDE 'params'
ELSEIF (msun .EQ. 14) THEN
WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
- CALL read1(nw,wl,yg1)
+ CALL read1(nw,wl,yg1,kout)
fil = 'DATAE1/SUN/neckel.flx'
write(kout,*) fil
@@ -9478,7 +9327,7 @@ c c INCLUDE 'params'
ELSEIF (msun .EQ. 15) THEN
WRITE(kout,*) 'DATAE1/SUN/susim_hi.flx'
- CALL read1(nw,wl,yg1)
+ CALL read1(nw,wl,yg1,kout)
nhead = 5
fil = 'DATAE1/SUN/atlas3_1994_317_a.dat'
@@ -9573,7 +9422,7 @@ c y1(i) = y1(i) * 1.E4 * hc / (x1(i) * 1.E-9)
*=============================================================================*
- SUBROUTINE read1(nw,wl,f)
+ SUBROUTINE read1(nw,wl,f,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -9597,7 +9446,7 @@ c c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -9609,9 +9458,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -9719,7 +9566,7 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE read2(nw,wl,f)
+ SUBROUTINE read2(nw,wl,f,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -9743,7 +9590,7 @@ c c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -9755,9 +9602,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -9859,6 +9704,8 @@ C inter3 is used for interpolation
RETURN
END
+
+CCC FILE rdxs.f
* This file contains subroutines related to reading the
* absorption cross sections of gases that contribute to atmospheric transmission:
* Some of these subroutines are also called from rxn.f when loading photolysis cross sections
@@ -9884,7 +9731,7 @@ C inter3 is used for interpolation
* rdso2xs
*=============================================================================*
- SUBROUTINE rdo3xs(mabs, nz,t,nw,wl, xs)
+ SUBROUTINE rdo3xs(mabs, nz,t,nw,wl, xs, kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -9905,14 +9752,14 @@ C inter3 is used for interpolation
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -9924,9 +9771,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -10010,15 +9855,17 @@ c c INCLUDE 'params'
* mol = Molina and Molina
* bas = Bass et al.
- CALL o3_rei(nw,wl, rei218,rei228,rei243,rei295, v195,v345,v830)
+ CALL o3_rei(nw,wl, rei218,rei228,rei243,rei295,
+ $ v195,v345,v830,kout)
- CALL o3_jpl(nw,wl, jpl218,jpl295, v186,v825)
+ CALL o3_jpl(nw,wl, jpl218,jpl295, v186,v825,kout)
- CALL o3_wmo(nw,wl, wmo203,wmo273, v176,v850)
+ CALL o3_wmo(nw,wl, wmo203,wmo273, v176,v850,kout)
- CALL o3_mol(nw,wl, mol226,mol263,mol298, v185,v240,v350)
+ CALL o3_mol(nw,wl, mol226,mol263,mol298, v185,v240,
+ $ v350,kout)
- CALL o3_bas(nw,wl, c0,c1,c2, vb245,vb342)
+ CALL o3_bas(nw,wl, c0,c1,c2, vb245,vb342,kout)
****** option 1:
@@ -10134,7 +9981,7 @@ c c INCLUDE 'params'
*=============================================================================*
SUBROUTINE o3_rei(nw,wl,
- $ rei218,rei228,rei243,rei295, v195,v345,v830)
+ $ rei218,rei228,rei243,rei295, v195,v345,v830,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -10156,14 +10003,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -10175,9 +10022,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -10342,7 +10187,7 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE o3_wmo(nw,wl, wmo203,wmo273, v176,v850)
+ SUBROUTINE o3_wmo(nw,wl, wmo203,wmo273, v176,v850,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -10369,7 +10214,7 @@ c c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -10381,9 +10226,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -10508,7 +10351,7 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE o3_jpl(nw,wl, jpl218,jpl295, v186,v825)
+ SUBROUTINE o3_jpl(nw,wl, jpl218,jpl295, v186,v825,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -10527,14 +10370,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -10546,9 +10389,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -10670,7 +10511,8 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE o3_mol(nw,wl, mol226,mol263,mol298, v185,v240,v350)
+ SUBROUTINE o3_mol(nw,wl, mol226,mol263,mol298,
+ & v185,v240,v350,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -10691,14 +10533,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -10710,9 +10552,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -10866,7 +10706,7 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE o3_bas(nw,wl, c0,c1,c2, vb245,vb342)
+ SUBROUTINE o3_bas(nw,wl, c0,c1,c2, vb245,vb342,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -10886,14 +10726,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -10905,9 +10745,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -11041,7 +10879,7 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE rdo2xs(nw,wl,o2xs1)
+ SUBROUTINE rdo2xs(nw,wl,o2xs1,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -11059,14 +10897,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -11078,9 +10916,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -11194,7 +11030,7 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE rdno2xs(nz,tlay,nw,wl,no2xs)
+ SUBROUTINE rdno2xs(nz,tlay,nw,wl,no2xs,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -11211,14 +11047,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -11230,9 +11066,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -11294,11 +11128,11 @@ c c INCLUDE 'params'
mabs = 4
- IF (mabs. EQ. 1) CALL no2xs_d(nz,tlay,nw,wl, no2xs)
- IF (mabs .EQ. 2) CALL no2xs_jpl94(nz,tlay,nw,wl, no2xs)
- IF (mabs .EQ. 3) CALL no2xs_har(nz,tlay,nw,wl, no2xs)
- IF (mabs .EQ. 4) CALL no2xs_jpl06a(nz,tlay,nw,wl, no2xs)
- IF (mabs .EQ. 5) CALL no2xs_jpl06b(nz,tlay,nw,wl, no2xs)
+ IF (mabs. EQ. 1) CALL no2xs_d(nz,tlay,nw,wl, no2xs,kout)
+ IF (mabs .EQ. 2) CALL no2xs_jpl94(nz,tlay,nw,wl, no2xs,kout)
+ IF (mabs .EQ. 3) CALL no2xs_har(nz,tlay,nw,wl, no2xs,kout)
+ IF (mabs .EQ. 4) CALL no2xs_jpl06a(nz,tlay,nw,wl, no2xs,kout)
+ IF (mabs .EQ. 5) CALL no2xs_jpl06b(nz,tlay,nw,wl, no2xs,kout)
*_______________________________________________________________________
@@ -11307,17 +11141,17 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE no2xs_d(nz,t,nw,wl, no2xs)
+ SUBROUTINE no2xs_d(nz,t,nw,wl, no2xs,kout)
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -11329,9 +11163,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -11437,17 +11269,17 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE no2xs_jpl94(nz,t,nw,wl, no2xs)
+ SUBROUTINE no2xs_jpl94(nz,t,nw,wl, no2xs,kout)
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -11459,9 +11291,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -11570,17 +11400,17 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE no2xs_har(nz,t,nw,wl, no2xs)
+ SUBROUTINE no2xs_har(nz,t,nw,wl, no2xs,kout)
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -11592,9 +11422,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -11682,19 +11510,19 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE no2xs_jpl06a(nz,t,nw,wl, no2xs)
+ SUBROUTINE no2xs_jpl06a(nz,t,nw,wl, no2xs,kout)
* read and interpolate NO2 xs from JPL2006
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -11706,9 +11534,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -11808,19 +11634,19 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE no2xs_jpl06b(nz,t,nw,wl, no2xs)
+ SUBROUTINE no2xs_jpl06b(nz,t,nw,wl, no2xs,kout)
* read and interpolate NO2 xs from Harder et al.
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -11832,9 +11658,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -11886,7 +11710,7 @@ c c INCLUDE 'params'
* local
INTEGER kdata
- PARAMETER (kdata=80)
+ PARAMETER (kdata=100)
INTEGER i, n, n1, n2, ierr
REAL x1(kdata), x2(kdata), y1(kdata), y2(kdata)
REAL x3(kdata), y3(kdata)
@@ -11897,7 +11721,7 @@ c c INCLUDE 'params'
DO i = 1, 3
READ(kin,*)
ENDDO
- n = 73
+ n = 81
do i = 1, n
read(kin,*) x1(i), x3(i), y1(i), y2(i)
y1(i) = (x3(i)-x1(i)) * y1(i)*1.E-20
@@ -11934,7 +11758,7 @@ c c INCLUDE 'params'
*=============================================================================*
- SUBROUTINE rdso2xs(nw,wl,so2xs)
+ SUBROUTINE rdso2xs(nw,wl,so2xs,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -11970,14 +11794,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -11989,9 +11813,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -12088,6 +11910,7 @@ c n = 681
*=============================================================================*
+CCC FILE rtrans.f
* This file contains the following subroutines, related to the solution of
* the equation of radiative transfer in multiple homogeneous layers.
* rtlink
@@ -12147,18 +11970,19 @@ c n = 681
$ dtcld, omcld, gcld,
$ dtaer, omaer, gaer,
$ dtsnw, omsnw, gsnw,
- $ edir, edn, eup, fdir, fdn, fup)
+ $ edir, edn, eup, fdir, fdn, fup,
+ $ kout)
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -12170,9 +11994,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -12360,7 +12182,8 @@ c c INCLUDE 'params'
CALL ps2str(nz,zen,ag,dt,om,g,
$ dsdh, nid, delta,
- $ fdiri, fupi, fdni, ediri, eupi, edni)
+ $ fdiri, fupi, fdni, ediri, eupi, edni,
+ $ kout)
ELSE
@@ -12371,7 +12194,8 @@ c c INCLUDE 'params'
$ MAXCLY, MAXULV, MAXUMU, MAXCMU, MAXPHI,
$ RFLDIR,RFLDN, FLUP, U0U,
$ uavgso, uavgup, uavgdn,
- $ sindir, sinup, sindn)
+ $ sindir, sinup, sindn,
+ $ kout)
ENDIF
@@ -12433,7 +12257,8 @@ c WRITE (*,*) edn(1),' = ',irrad,' ?'
SUBROUTINE ps2str(nlevel,zen,rsfc,tauu,omu,gu,
$ dsdh, nid, delta,
- $ fdr, fup, fdn, edr, eup, edn)
+ $ fdr, fup, fdn, edr, eup, edn,
+ $ kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -12474,14 +12299,14 @@ c WRITE (*,*) edn(1),' = ',irrad,' ?'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -12493,9 +12318,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -12568,7 +12391,7 @@ c c INCLUDE 'params'
*******
* other:
*******
- REAL pifs, fdn0
+ REAL pifs, fdn0, surfem
REAL gi(kz), omi(kz), tempg
REAL f, g, om
REAL gam1, gam2, gam3, gam4
@@ -12609,9 +12432,12 @@ C > BETA1, BETAn, amu1, subd
pifs = 1.
fdn0 = 0.
- nlayer = nlevel - 1
+* emission at surface (for night light pollution, set pifs = 0, surfem = 1.)
+
+ surfem = 0.
- mu = COS(zen*pi/180.)
+ nlayer = nlevel - 1
+ mu = COS(zen*pi/180.)
************** compute coefficients for each layer:
* GAM1 - GAM4 = 2-stream coefficients, different for different approximations
@@ -12862,7 +12688,7 @@ c mu1(i) = 0.5
***************** set up matrix ******
* ssfc = pg 16,292 equation 37 where pi Fs is one (unity).
- ssfc = rsfc*mu*EXP(-tausla(nlayer))*pifs
+ ssfc = rsfc*mu*EXP(-tausla(nlayer))*pifs + surfem
* MROWS = the number of rows in the matrix
@@ -12915,7 +12741,7 @@ c mu1(i) = 0.5
* solve tri-diagonal matrix:
- CALL tridag(a, b, d, e, y, mrows)
+ CALL tridag(a, b, d, e, y, mrows,kout)
**** unfold solution of matrix, compute output fluxes:
@@ -12925,7 +12751,7 @@ c mu1(i) = 0.5
* the following equations are from pg 16,291 equations 31 & 32
- fdr(lev) = EXP( -tausla(0) )
+ fdr(lev) = pifs * EXP( -tausla(0) )
edr(lev) = mu * fdr(lev)
edn(lev) = fdn0
eup(lev) = y(row)*e3(j) - y(row + 1)*e4(j) + cup(j)
@@ -12933,7 +12759,7 @@ c mu1(i) = 0.5
fup(lev) = eup(lev)/mu1(lev)
DO 60, lev = 2, nlayer + 1
- fdr(lev) = EXP(-tausla(lev-1))
+ fdr(lev) = pifs * EXP(-tausla(lev-1))
edr(lev) = mu *fdr(lev)
edn(lev) = y(row)*e3(j) + y(row + 1)*e4(j) + cdntn(j)
eup(lev) = y(row)*e1(j) + y(row + 1)*e2(j) + cuptn(j)
@@ -12950,7 +12776,7 @@ c mu1(i) = 0.5
*=============================================================================*
- SUBROUTINE tridag(a,b,c,r,u,n)
+ SUBROUTINE tridag(a,b,c,r,u,n,kout)
*_______________________________________________________________________
* solves tridiagonal system. From Numerical Recipies, p. 40
@@ -12970,14 +12796,14 @@ c mu1(i) = 0.5
* local:
INTEGER j
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -12989,9 +12815,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -13063,7 +12887,8 @@ C SUBROUTINE DISORT( dsdh, nid,
& MAXCLY, MAXULV, MAXUMU, MAXCMU, MAXPHI,
$ RFLDIR, RFLDN, FLUP, U0U,
& uavgso, uavgup, uavgdn,
- & sindir, sinup, sindn )
+ & sindir, sinup, sindn,
+ & kout )
c Improved handling of numerical instabilities. Bernhard Mayer on 5/3/99.
c disort seems to produce unstable results for certain combinations
@@ -13369,14 +13194,14 @@ c MXPHI = Max no. of output azimuthal angles
c +-------------------------------------------------------------------+
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -13388,9 +13213,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -13608,7 +13431,7 @@ c ** Perform various setup operations
& GL, HL, HLPR, IBCND, LAMBER, LAYRU, LYRCUT, MAXUMU,
& MAXCMU, MXCMU, NCUT, NLYR, NTAU, NN, NSTR, PLANK,
& NUMU, ONLYFL, OPRIM, PMOM, SSALB, TAUC, TAUCPR, UTAU,
- & UTAUPR, UMU, UMU0, USRTAU, USRANG )
+ & UTAUPR, UMU, UMU0, USRTAU, USRANG, kout )
c ** Print input information
IF ( PRNT(1) )
@@ -15670,12 +15493,12 @@ c .. Local Scalars ..
INTEGER ITER, K, LIM, MAXIT, NN, NP1
REAL CONA, PI, T
- REAL EN, NNP1, ONE, P, P2PRI, PM1, PM2, PPR, PROD,
+ DOUBLE PRECISION EN, NNP1, ONE, P, P2PRI, PM1, PM2, PPR, PROD,
& TMP, TOL, TWO, X, XI
c ..
c .. External Functions ..
- REAL D1MACH
+ DOUBLE PRECISION D1MACH
EXTERNAL D1MACH
c ..
c .. External Subroutines ..
@@ -15789,7 +15612,7 @@ c ** Convert from (-1,1) to (0,1)
& LYRCUT, MAXUMU, MAXCMU, MXCMU, NCUT, NLYR,
& NTAU, NN, NSTR, PLANK, NUMU, ONLYFL, OPRIM,
& PMOM, SSALB, TAUC, TAUCPR, UTAU, UTAUPR, UMU,
- & UMU0, USRTAU, USRANG )
+ & UMU0, USRTAU, USRANG, kout )
c Perform miscellaneous setting-up operations
@@ -15819,14 +15642,14 @@ c Called by- DISORT
c Calls- QGAUSN, ERRMSG
c ----------------------------------------------------------------------
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -15838,9 +15661,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -16436,7 +16257,7 @@ c .. Array Arguments ..
& CC( MXCMU, MXCMU ), CMU( MXCMU ), CWT( MXCMU ),
& EVAL( MI ), EVECC( MXCMU, MXCMU ), GC( MXCMU, MXCMU ),
& GL( 0:MXCMU ), KK( MXCMU ), YLMC( 0:MXCMU, MXCMU )
- REAL AAD( MI, MI ), EVALD( MI ), EVECCD( MI, MI ),
+ DOUBLE PRECISION AAD( MI, MI ), EVALD( MI ), EVECCD( MI, MI ),
& WKD( MXCMU )
c ..
c .. Local Scalars ..
@@ -17177,7 +16998,7 @@ c .. Array Arguments ..
& YLM0( 0:MXCMU ), YLMC( 0:MXCMU, MXCMU ),
& WK( MXCMU ), ZJ( MXCMU ), ZZ( MXCMU )
- REAL AAD( MI, MI ), EVALD( MI ), EVECCD( MI, MI ),
+ DOUBLE PRECISION AAD( MI, MI ), EVALD( MI ), EVECCD( MI, MI ),
& WKD( MXCMU )
*bm Variables for instability fix
@@ -18169,7 +17990,7 @@ C ROUTINES CALLED: FROM LINPACK: SGBFA
C FROM BLAS: SAXPY, SDOT, SSCAL, SASUM
C FROM FORTRAN: ABS, AMAX1, MAX0, MIN0, SIGN
- EXTERNAL SAXPY, SDOT, SASUM, SSCAL
+ EXTERNAL SGBFA, SAXPY, SDOT, SASUM, SSCAL
INTEGER LDA, N, ML, MU, IPVT(*)
REAL ABD(LDA,*), Z(*)
@@ -18480,6 +18301,7 @@ C 10 CONTINUE
C ROUTINES CALLED: FROM BLAS: SAXPY, SDOT
C FROM FORTRAN: MIN0
+
EXTERNAL SAXPY, SDOT
INTEGER LDA, N, ML, MU, IPVT(*), JOB
@@ -18600,7 +18422,8 @@ C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C ROUTINES CALLED: FROM LINPACK: SGEFA
C FROM BLAS: SAXPY, SDOT, SSCAL, SASUM
C FROM FORTRAN: ABS, AMAX1, SIGN
- EXTERNAL SAXPY, SDOT, SSCAL, SASUM
+
+ EXTERNAL SGEFA, SAXPY, SDOT, SSCAL, SASUM
INTEGER LDA, N, IPVT(*)
REAL A(LDA,*), Z(*)
@@ -18752,6 +18575,7 @@ C IF CALLED. USE RCOND IN SGECO FOR A RELIABLE
C INDICATION OF SINGULARITY.
C ROUTINES CALLED: FROM BLAS: SAXPY, SSCAL, ISAMAX
+
EXTERNAL SAXPY, SSCAL, ISAMAX
INTEGER LDA, N, IPVT(*), INFO
@@ -18857,6 +18681,7 @@ C 10 CONTINUE
C ROUTINES CALLED: FROM BLAS: SAXPY, SDOT
+
EXTERNAL SAXPY, SDOT
INTEGER LDA, N, IPVT(*), JOB
@@ -19286,14 +19111,15 @@ C ##############################
*= (see routine T665D for more information on different constants) =*
*-----------------------------------------------------------------------------*
- REAL d1mach
+ EXTERNAL t665d
+ DOUBLE PRECISION d1mach
INTEGER i
LOGICAL doinit
DATA doinit/.TRUE./
SAVE doinit
- REAL dmach(4)
+ DOUBLE PRECISION dmach(4)
SAVE dmach
IF (( i .GE. 1 ) .AND. ( i .LE. 4 )) THEN
@@ -19325,12 +19151,12 @@ C-----------------------------------------------------------------------
C This subroutine is a double precision version of subroutine T665R.
C See code of T665R for detailed comments and explanation
C-----------------------------------------------------------------------
- REAL DMACH(4)
+ DOUBLE PRECISION DMACH(4)
INTEGER I,IBETA,IEXP,IRND,IT,ITEMP,IZ,J,K,MACHEP,MAXEXP,
1 MINEXP,MX,NEGEP,NGRD,NXRES
CS REAL A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,T,TEMP,TEMPA,
CS 1 TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO
- REAL A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,
+ DOUBLE PRECISION A,B,BETA,BETAIN,BETAH,CONV,EPS,EPSNEG,ONE,
1 T,TEMP,TEMPA,TEMP1,TWO,XMAX,XMIN,Y,Z,ZERO
C-----------------------------------------------------------------------
CS CONV(I) = REAL(I)
@@ -19517,9 +19343,7 @@ C---------- LAST CARD OF T665D ----------
END
-C ##############################
FUNCTION R1MACH(i)
-C ##############################
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -19578,9 +19402,7 @@ C ##############################
C ALGORITHM 665, COLLECTED ALGORITHMS FROM ACM.
C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C VOL. 14, NO. 4, PP. 303-311.
-C ##############################
SUBROUTINE T665R(RMACH)
-C ##############################
C-----------------------------------------------------------------------
C This Fortran 77 subroutine is intended to determine the parameters
C of the floating-point arithmetic system specified below. The
@@ -19851,7 +19673,14 @@ C-----------------------------------------------------------------
C---------- LAST CARD OF T665R ----------
END
- SUBROUTINE r01(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+CCC FILE rxn.f
+* This file contains the following subroutines, related to reading/loading
+* the product (cross section) x (quantum yield) for photo-reactions:
+* r01 through r47
+* r101 through r148
+* r149, r150 and r151 added from original TUV code
+*=============================================================================*
+ SUBROUTINE r01(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -19889,14 +19718,14 @@ C---------- LAST CARD OF T665R ----------
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -19908,9 +19737,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -19960,6 +19787,7 @@ c c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -20016,7 +19844,7 @@ c c INCLUDE 'params'
* mabs = 2 = JPL 2006
mabs = 1
- CALL rdo3xs(mabs, nz,tlev,nw,wl, xs)
+ CALL rdo3xs(mabs, nz,tlev,nw,wl, xs, kout)
******* quantum yield:
@@ -20309,18 +20137,17 @@ c myld = kjpl00
20 CONTINUE
10 CONTINUE
+* declare temperature dependence
+
+ tpflag(j-1) = 1
+ tpflag(j) = 1
+
RETURN
END
-* This file contains the following subroutines, related to reading/loading
-* the product (cross section) x (quantum yield) for photo-reactions:
-* r01 through r47
-* r101 through r110
-*=============================================================================*
-
*=============================================================================*
- SUBROUTINE r02(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r02(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -20350,14 +20177,14 @@ c myld = kjpl00
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -20369,9 +20196,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -20421,6 +20246,7 @@ c c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -20502,9 +20328,9 @@ c c INCLUDE 'params'
else if(myld. eq. 2) then
-* from jpl 2006
+* from jpl 2011
- OPEN(UNIT=kin,FILE='DATAJ1/YLD/NO2_jpl2006.yld',STATUS='old')
+ OPEN(UNIT=kin,FILE='DATAJ1/YLD/NO2_jpl11.yld',STATUS='old')
DO i = 1, 2
READ(kin,*)
ENDDO
@@ -20537,15 +20363,15 @@ c c INCLUDE 'params'
STOP
ENDIF
- do iw = 1, nw - 1
- do iz = 1, nz
- qy(iz,iw) = yg1(iw) +
- $ (yg1(iw)-yg2(iw)) * (tlev(iz)-298)/50.
- qy(iz,iw) = amax1(qy(iz,iw),0.)
- enddo
- enddo
+ DO iw = 1, nw - 1
+ DO iz = 1, nz
+ qy(iz,iw) = yg1(iw) +
+ $ (yg1(iw)-yg2(iw)) * (tlev(iz)-298)/50.
+ qy(iz,iw) = amax1(qy(iz,iw),0.)
+ ENDDO
+ ENDDO
- endif
+ ENDIF
* combine
@@ -20555,13 +20381,15 @@ c c INCLUDE 'params'
ENDDO
ENDDO
+* declare temperature dependence
+ tpflag(j) = 1
-
+ RETURN
END
*=============================================================================*
- SUBROUTINE r03(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r03(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -20591,13 +20419,13 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -20609,9 +20437,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -20661,6 +20487,7 @@ c c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -20671,121 +20498,305 @@ c c INCLUDE 'params'
INTEGER kdata
PARAMETER(kdata=350)
- REAL x1(kdata)
+ REAL x(kdata), x1(kdata)
REAL y1(kdata)
+ real q1_298(kdata), q1_230(kdata), q1_190(kdata)
+ real q2_298(kdata), q2_230(kdata), q2_190(kdata)
* local
REAL yg(kw), yg1(kw)
- REAL qy
+ REAL qy,qy1, qy2
+ real yg1_298(kw), yg1_230(kw), yg1_190(kw)
+ real yg2_298(kw), yg2_230(kw), yg2_190(kw)
+
INTEGER irow, icol
- INTEGER i, iw, n, idum
+ INTEGER i, iw, iz, n, idum
INTEGER ierr
+ integer mabs, myld
+
**************** jlabel(j) = 'NO3 -> NO2 + O(3P)'
**************** jlabel(j) = 'NO3 -> NO + O2'
+ j = j + 1
+ jlabel(j) = 'NO3 -> NO + O2'
+ j = j + 1
+ jlabel(j) = 'NO3 -> NO2 + O(3P)'
+
+
+* mabs = 1: Graham and Johnston 1978
+* mabs = 2: JPL94
+* mabs = 3: JPL11
+
+ mabs = 3
+
+* myld = 1 from Madronich (1988) see CEC NO3 book.
+* myld = 2 from JPL-2011
+
+ myld = 2
+
+* cross section
+
+ IF(mabs. eq. 1) then
+
* cross section
* measurements of Graham and Johnston 1978
- OPEN(UNIT=kin,FILE='DATAJ1/ABS/NO3_gj78.abs',STATUS='old')
- DO i = 1, 9
- READ(kin,*)
- ENDDO
- n = 305
- DO irow = 1, 30
- READ(kin,*) ( y1(10*(irow-1) + icol), icol = 1, 10 )
- ENDDO
- READ(kin,*) ( y1(300 + icol), icol = 1, 5 )
- CLOSE (kin)
- DO i = 1, n
- y1(i) = y1(i) * 1.E-19
- x1(i) = 400. + 1.*FLOAT(i-1)
- ENDDO
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/NO3_gj78.abs',STATUS='old')
+ DO i = 1, 9
+ READ(kin,*)
+ ENDDO
+ n = 305
+ DO irow = 1, 30
+ READ(kin,*) ( y1(10*(irow-1) + icol), icol = 1, 10 )
+ ENDDO
+ READ(kin,*) ( y1(300 + icol), icol = 1, 5 )
+ CLOSE (kin)
+ DO i = 1, n
+ y1(i) = y1(i) * 1.E-19
+ x1(i) = 400. + 1.*FLOAT(i-1)
+ ENDDO
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 0.,0.)
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
- ENDIF
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ ELSEIF(mabs .EQ. 2) THEN
* cross section from JPL94:
- OPEN(UNIT=kin,FILE='DATAJ1/ABS/NO3_jpl94.abs',STATUS='old')
- READ(kin,*) idum, n
- DO i = 1, idum-2
- READ(kin,*)
- ENDDO
- DO i = 1, n
- READ(kin,*) x1(i), y1(i)
- y1(i) = y1(i)*1E-20
- ENDDO
- CLOSE (kin)
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 0.,0.)
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
- CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
- ENDIF
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/NO3_jpl94.abs',STATUS='old')
+ READ(kin,*) idum, n
+ DO i = 1, idum-2
+ READ(kin,*)
+ ENDDO
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i)*1E-20
+ ENDDO
+ CLOSE (kin)
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
* use JPL94 for wavelengths longer than 600 nm
- DO iw = 1, nw-1
- IF(wl(iw) .GT. 600.) yg(iw) = yg1(iw)
- ENDDO
+ DO iw = 1, nw-1
+ IF(wl(iw) .GT. 600.) yg(iw) = yg1(iw)
+ ENDDO
+
+* cross sections from JPL2011
+
+ ELSEIF(MABS .EQ. 3) THEN
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/NO3_jpl11.abs',STATUS='old')
+ DO i = 1, 6
+ READ(kin,*)
+ ENDDO
+ DO i = 1, 289
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i)*1E-20
+ ENDDO
+ CLOSE (kin)
+
+ n = 289
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ ENDIF
* quantum yield:
-* from Madronich (1988) see CEC NO3 book.
+
+ if (myld .eq. 1) then
* for NO3 ->NO+O2
- j = j + 1
- jlabel(j) = 'NO3 -> NO + O2'
- DO iw = 1, nw - 1
- IF (wc(iw).LT.584.) THEN
+ DO iw = 1, nw - 1
+ IF (wc(iw).LT.584.) THEN
qy = 0.
- ELSEIF (wc(iw).GE.640.) THEN
+ ELSEIF (wc(iw).GE.640.) THEN
qy = 0.
- ELSEIF (wc(iw).GE.595.) THEN
+ ELSEIF (wc(iw).GE.595.) THEN
qy = 0.35*(1.-(wc(iw)-595.)/45.)
- ELSE
+ ELSE
qy = 0.35*(wc(iw)-584.)/11.
- ENDIF
- DO i = 1, nz
+ ENDIF
+ DO i = 1, nz
sq(j,i,iw) = yg(iw)*qy
- ENDDO
- ENDDO
+ ENDDO
+ ENDDO
* for NO3 ->NO2+O
- j = j + 1
- jlabel(j) = 'NO3 -> NO2 + O(3P)'
- DO iw = 1, nw - 1
- IF (wc(iw).LT.584.) THEN
+
+ DO iw = 1, nw - 1
+ IF (wc(iw).LT.584.) THEN
qy = 1.
- ELSEIF (wc(iw).GT.640.) THEN
+ ELSEIF (wc(iw).GT.640.) THEN
qy = 0.
- ELSEIF (wc(iw).GT.595.) THEN
+ ELSEIF (wc(iw).GT.595.) THEN
qy = 0.65*(1-(wc(iw)-595.)/45.)
- ELSE
+ ELSE
qy = 1.-0.35*(wc(iw)-584.)/11.
- ENDIF
- DO i = 1, nz
+ ENDIF
+ DO i = 1, nz
sq(j,i,iw) = yg(iw)*qy
+ ENDDO
+ ENDDO
+
+* yields from JPL2011:
+
+ ELSEIF(myld .EQ. 2) THEN
+
+ open(unit=kin,file='DATAJ1/YLD/NO3_jpl2011.qy',status='old')
+ do i = 1, 5
+ read(kin,*)
+ enddo
+ do i = 1, 56
+ read(kin,*) x(i), q1_298(i), q1_230(i), q1_190(i),
+ $ q2_298(i), q2_230(i), q2_190(i)
+
+ q1_298(i) = q1_298(i)/1000.
+ q1_230(i) = q1_230(i)/1000.
+ q1_190(i) = q1_190(i)/1000.
+ q2_298(i) = q2_298(i)/1000.
+ q2_230(i) = q2_230(i)/1000.
+ q2_190(i) = q2_190(i)/1000.
+
+ enddo
+ close(kin)
+
+ n = 56
+ do i = 1, n
+ x1(i) = x(i)
+ enddo
+ CALL addpnt(x1,q1_298,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,q1_298,kdata,n, 0.,0.)
+ CALL addpnt(x1,q1_298,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,q1_298,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1_298,n,x1,q1_298,ierr)
+
+ n = 56
+ do i = 1, n
+ x1(i) = x(i)
+ enddo
+ CALL addpnt(x1,q1_230,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,q1_230,kdata,n, 0.,0.)
+ CALL addpnt(x1,q1_230,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,q1_230,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1_230,n,x1,q1_230,ierr)
+
+ n = 56
+ do i = 1, n
+ x1(i) = x(i)
+ enddo
+ CALL addpnt(x1,q1_190,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,q1_190,kdata,n, 0.,0.)
+ CALL addpnt(x1,q1_190,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,q1_190,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1_190,n,x1,q1_190,ierr)
+
+ n = 56
+ do i = 1, n
+ x1(i) = x(i)
+ enddo
+ CALL addpnt(x1,q2_298,kdata,n,x1(1)*(1.-deltax),1.)
+ CALL addpnt(x1,q2_298,kdata,n, 0.,1.)
+ CALL addpnt(x1,q2_298,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,q2_298,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg2_298,n,x1,q2_298,ierr)
+
+ n = 56
+ do i = 1, n
+ x1(i) = x(i)
+ enddo
+ CALL addpnt(x1,q2_230,kdata,n,x1(1)*(1.-deltax),1.)
+ CALL addpnt(x1,q2_230,kdata,n, 0.,1.)
+ CALL addpnt(x1,q2_230,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,q2_230,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg2_230,n,x1,q2_230,ierr)
+
+ n = 56
+ do i = 1, n
+ x1(i) = x(i)
+ enddo
+ CALL addpnt(x1,q2_190,kdata,n,x1(1)*(1.-deltax),1.)
+ CALL addpnt(x1,q2_190,kdata,n, 0.,1.)
+ CALL addpnt(x1,q2_190,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,q2_190,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg2_190,n,x1,q2_190,ierr)
+
+* compute T-dependent quantum yields
+
+ DO iw = 1, nw-1
+ DO iz = 1, nz
+
+ if(tlev(iz) .le. 190.) then
+
+ qy1 = yg1_190(iw)
+ qy2 = yg2_190(iw)
+
+ elseif(tlev(iz) .gt. 190. .and. tlev(iz) .le. 230.) then
+
+ qy1 = yg1_190(iw) + (yg1_230(iw) - yg1_190(iw))*
+ $ (tlev(iz) - 190.)/(230.-190.)
+ qy2 = yg2_190(iw) + (yg2_230(iw) - yg2_190(iw))*
+ $ (tlev(iz) - 190.)/(230.-190.)
+
+ elseif(tlev(iz) .gt. 230. .and. tlev(iz) .le. 298.) then
+
+ qy1 = yg1_230(iw) + (yg1_298(iw) - yg1_230(iw))*
+ $ (tlev(iz) - 230.)/(298.-230.)
+
+ qy2 = yg2_230(iw) + (yg2_298(iw) - yg2_230(iw))*
+ $ (tlev(iz) - 230.)/(298.-230.)
+
+ elseif(tlev(iz) .gt. 298.) then
+
+ qy1 = yg1_298(iw)
+ qy2 = yg2_298(iw)
+
+ endif
+
+ sq(j-1, iz, iw) = qy1 * yg1(iw)
+ sq(j, iz, iw) = qy2 * yg1(iw)
+
+ ENDDO
ENDDO
- ENDDO
+
+ ENDIF
+
+* declare temperature dependence for both channels:
+
+ tpflag(j-1) = 1
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r04(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r04(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -20817,14 +20828,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -20836,9 +20847,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -20888,6 +20897,7 @@ c c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -20896,20 +20906,18 @@ c c INCLUDE 'params'
* data arrays
INTEGER kdata
- PARAMETER(kdata=100)
+ PARAMETER(kdata=200)
- REAL x1(kdata)
- REAL y1(kdata)
+ REAL x1(kdata), x2(kdata)
+ REAL y1(kdata), A(kdata), B(kdata)
+ INTEGER n1, n2
* local
- REAL yg(kw)
- REAL qy
- REAL xs, xs270, xs280, xst290, xst300
- REAL dum1, dum2
- REAL t
- INTEGER i, iw, n, idum
+ REAL yg1(kw), yg2(kw)
+ INTEGER i, iz, iw
INTEGER ierr
+ REAL t, xs, dum
**************** N2O5 photodissociation
@@ -20919,92 +20927,84 @@ c c INCLUDE 'params'
j = j + 1
jlabel(j) = 'N2O5 -> NO3 + NO2'
-* cross section from jpl97, table up to 280 nm
+* cross section from jpl2011, at 300 K
- OPEN(UNIT=kin,FILE='DATAJ1/ABS/N2O5_jpl97.abs',STATUS='old')
- READ(kin,*) idum, n
- DO i = 1, idum-2
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/N2O5_jpl11.abs',STATUS='old')
+ DO i = 1, 4
READ(kin,*)
ENDDO
- DO i = 1, n
+ n1 = 103
+ DO i = 1, n1
READ(kin,*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
ENDDO
- xs270 = y1(n-2)
- xs280 = y1(n)
+* read temperature dependence coefficients:
+
+ DO i = 1, 4
+ READ(kin,*)
+ ENDDO
+ n2 = 8
+ DO i = 1, n2
+ READ(kin,*) x2(i), A(i), B(i)
+ ENDDO
CLOSE(kin)
- CALL addpnt(x1,y1,kdata, n,x1(1)*(1.-deltax),0.)
- CALL addpnt(x1,y1,kdata, n, 0.,0.)
- CALL addpnt(x1,y1,kdata, n,x1(n)*(1.+deltax),y1(n))
- CALL addpnt(x1,y1,kdata, n, 1.E36,y1(n))
+ CALL addpnt(x1,y1,kdata, n1,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata, n1, 0.,0.)
+ CALL addpnt(x1,y1,kdata, n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata, n1, 1.E36 ,0.)
- CALL inter2(nw,wl,yg, n,x1,y1, ierr)
+ CALL inter2(nw,wl,yg1, n1,x1,y1, ierr)
IF (ierr .NE. 0) THEN
- WRITE(0,*) ierr,jlabel(j)
+ WRITE(*,*) ierr,jlabel(j)
STOP
- ENDIF
-
-* quantum yield : see DATAJ1/YLD/N2O5.qy for explanation
-* correct for T-dependence of cross section
-
- DO iw = 1, nw - 1
-
- qy = MIN( 1., 3.832441 - 0.012809638 * wc(iw) )
- qy = MAX( 0., qy )
-
- DO i = 1, nz
-
-* temperature dependence only valid for 225 - 300 K.
-
- t = MAX(225.,MIN(tlev(i),300.))
-
-* evaluation of exponential
+ ENDIF
- IF (wc(iw) .GE. 285. .AND. wc(iw) .LE. 380.) THEN
+ CALL addpnt(x2,B,kdata, n2,x2(1)*(1.-deltax),0.)
+ CALL addpnt(x2,B,kdata, n2, 0.,0.)
+ CALL addpnt(x2,B,kdata, n2,x2(n2)*(1.+deltax),0.)
+ CALL addpnt(x2,B,kdata, n2, 1.E36 ,0.)
- sq(j-1,i,iw) = qy *
- $ 1.E-20*EXP( 2.735 + (4728.5-17.127*wc(iw)) / t )
- sq(j,i,iw) = (1.-qy) *
- $ 1.E-20*EXP( 2.735 + (4728.5-17.127*wc(iw)) / t )
+ CALL inter2(nw,wl,yg2, n2,x2,B, ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr,jlabel(j)
+ STOP
+ ENDIF
-* between 280 and 285 nm: Extrapolate from both sides, then average.
- ELSEIF (wc(iw) .GE. 280. .AND. wc(iw) .LT. 285.) THEN
+ DO iw = 1, nw - 1
+ DO iz = 1, nz
- xst290 = 1.E-20*
- > EXP( 2.735 + (4728.5-17.127*290.) / t )
- xst300 = 1.E-20*
- > EXP( 2.735 + (4728.5-17.127*300.) / t )
-
- dum1 = xs270 + (wc(iw) - 270.)*(xs280 - xs270)/10.
- dum2 = xst290 + (wc(iw) - 290.)*(xst300 - xst290)/10.
- xs = 0.5*(dum1 + dum2)
+* temperature dependence only valid for 233 - 295 K. Extend to 300.
- sq(j-1,i,iw) = qy * xs
- sq(j,i,iw) = (1.-qy) * xs
+ t = MAX(233.,MIN(tlev(iz),300.))
-* for less than 280 nm, use tabulated values
+* Apply temperature correction to 300K values. Do not use A-coefficients
+* because they are inconsistent with the values at 300K.
- ELSEIF (wc(iw) .LT. 280.) THEN
+ dum = 1000.*yg2(iw)*((1./t) - (1./300.))
+ xs = yg1(iw) * 10.**(dum)
- sq(j-1,i,iw) = qy * yg(iw)
- sq(j,i,iw) = (1.-qy) * yg(iw)
+* quantum yield = 1 for NO2 + NO3, zero for other channels
-* beyond 380 nm, set to zero
+ sq(j-1, iz, iw) = 0. * xs
+ sq(j , iz, iw) = 1. * xs
- ELSE
- sq(j-1,i,iw) = 0.
- sq(j,i,iw) = 0.
- ENDIF
ENDDO
ENDDO
+
+* declare temperature dependence
+
+ tpflag(j-1) = 1
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r05(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r05(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -21035,14 +21035,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -21054,9 +21054,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -21106,6 +21104,7 @@ c c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -21114,7 +21113,7 @@ c c INCLUDE 'params'
* data arrays
INTEGER kdata
- PARAMETER(kdata=100)
+ PARAMETER(kdata=200)
REAL x1(kdata)
REAL y1(kdata)
@@ -21126,31 +21125,66 @@ c c INCLUDE 'params'
INTEGER i, iw, n
INTEGER ierr
+ INTEGER mabs
+
**************** HNO2 photodissociation
+* mabs = 2: JPL 2011 recommendation
+* mabs = 1: earlier JPL recommendations
+
+ mabs = 2
+
* cross section from JPL92
* (from Bongartz et al., identical to JPL94, JPL97 recommendation)
j = j + 1
jlabel(j) = 'HNO2 -> OH + NO'
- OPEN(UNIT=kin,FILE='DATAJ1/ABS/HNO2_jpl92.abs',STATUS='old')
- DO i = 1, 13
- READ(kin,*)
- ENDDO
- n = 91
- DO i = 1, n
- READ(kin,*) x1(i), y1(i)
- y1(i) = y1(i) * 1.E-20
- ENDDO
- CLOSE (kin)
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 0.,0.)
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
+ IF(mabs .eq. 1) then
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/HNO2_jpl92.abs',STATUS='old')
+ DO i = 1, 13
+ READ(kin,*)
+ ENDDO
+ n = 91
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1.E-20
+ ENDDO
+ CLOSE (kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ ELSEIF(mabs .eq. 2) then
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/HONO_jpl11.abs',STATUS='old')
+ DO i = 1, 3
+ READ(kin,*)
+ ENDDO
+ n = 192
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1.E-20
+ ENDDO
+ CLOSE (kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
ENDIF
* quantum yield = 1
@@ -21162,11 +21196,16 @@ c c INCLUDE 'params'
ENDDO
ENDDO
+* no t or p dependence
+
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r06(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r06(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -21194,14 +21233,14 @@ c c INCLUDE 'params'
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -21213,9 +21252,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -21265,6 +21302,7 @@ c c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -21369,11 +21407,14 @@ C ENDDO
ENDDO
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r07(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r07(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -21401,14 +21442,14 @@ C ENDDO
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c c INCLUDE 'params'
+c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -21420,9 +21461,7 @@ c c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -21472,6 +21511,7 @@ c c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -21493,17 +21533,15 @@ C* local
INTEGER ierr
**************** HNO4 photodissociation
-
-* cross section from JPL85 (identical to JPL92 and JPL94 and JPL97)
+* cross section from JPL2011
j = j + 1
jlabel(j) = 'HNO4 -> HO2 + NO2'
-C OPEN(UNIT=kin,FILE='DATAJ1/ABS/HNO4.abs',STATUS='old')
- OPEN(UNIT=kin,FILE='DATAJ1/ABS/HNO4_jpl92.abs',STATUS='old')
- DO i = 1, 4
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/HNO4_jpl11.abs',STATUS='old')
+ DO i = 1, 2
READ(kin,*)
ENDDO
- n = 31
+ n = 54
DO i = 1, n
READ(kin,*) x1(i), y1(i)
y1(i) = y1(i) * 1.E-20
@@ -21529,11 +21567,16 @@ C OPEN(UNIT=kin,FILE='DATAJ1/ABS/HNO4.abs',STATUS='old')
ENDDO
ENDDO
+* no T or P dependence
+
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r08(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r08(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -21569,7 +21612,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -21581,9 +21624,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -21633,6 +21674,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -21641,7 +21683,7 @@ c INCLUDE 'params'
* data arrays
INTEGER kdata
- PARAMETER(kdata=100)
+ PARAMETER(kdata=600)
C INTEGER n1, n2, n3, n4, n5
REAL x1(kdata)
@@ -21701,6 +21743,12 @@ C ENDIF
ENDDO
CLOSE (kin)
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/H2O2_Kahan.abs',STATUS='old')
+ DO i = 1, 494
+ n = n + 1
+ READ(kin,*) x1(n), y1(n)
+ ENDDO
+ CLOSE (kin)
CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
CALL addpnt(x1,y1,kdata,n, 0.,0.)
@@ -21759,11 +21807,14 @@ C ENDIF
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r09(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r09(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -21798,7 +21849,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -21810,9 +21861,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -21862,6 +21911,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -22092,11 +22142,14 @@ c INCLUDE 'params'
ENDIF
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r10(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r10(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -22145,7 +22198,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -22157,9 +22210,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -22212,6 +22263,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -22706,11 +22758,16 @@ c ENDDO
ENDDO
ENDDO
+* declare T and P dependence
+
+ tpflag(j) = 3
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r11(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r11(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -22754,7 +22811,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -22766,9 +22823,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -22818,6 +22873,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -22842,6 +22898,7 @@ c INCLUDE 'params'
REAL dum
INTEGER ierr
INTEGER iz, iw
+ REAL qy1_n0, qy1_0, x
INTEGER mabs, myld
@@ -22868,6 +22925,7 @@ c INCLUDE 'params'
* 2: Calvert and Pitts
* 3: Martinez et al., Table 1 scanned from paper
* 4: KFA tabulations, 6 choices, see file OPEN statements
+* 5: JPL2011
* Quantum yield
* 1: DATAJ1/CH3CHO/CH3CHO_iup.yld
@@ -22879,8 +22937,8 @@ c INCLUDE 'params'
* DATAJ1/CH3CHO/d021_i.yld
* DATAJ1/CH3CHO/d021_i.yld
- mabs = 3
- myld = 2
+ mabs = 5
+ myld = 1
IF (mabs .EQ. 1) THEN
@@ -22991,6 +23049,30 @@ c n = 1705
STOP
ENDIF
+ ELSEIF (mabs .EQ. 5) THEN
+
+ OPEN(UNIT=kin,
+ $ FILE='DATAJ1/CH3CHO/CH3CHO_jpl11.abs',STATUS='old')
+ do i = 1, 2
+ read(kin,*)
+ enddo
+ n = 101
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
ENDIF
* quantum yields
@@ -23124,20 +23206,39 @@ c n = 1705
* combine:
DO iw = 1, nw - 1
- DO i = 1, nz
- sig = yg(iw)
+ sig = yg(iw)
* quantum yields:
+* input yields at n0 = 1 atm
+
+ qy1_n0 = yg1(iw)
+ qy2 = yg2(iw)
+ qy3 = yg3(iw)
+
+* Pressure correction for CH3 + CHO channel:
+* Assume pressure-dependence only for qy1, not qy2 or qy2.
+* Assume total yield 1 at zero pressure
+
+ qy1_0 = 1. - qy2 - qy3
- qy1 = yg1(iw)
- qy2 = yg2(iw)
- qy3 = yg3(iw)
+* compute coefficient:
+* Stern-Volmer: 1/q = 1/q0 + k N and N0 = 1 atm,
+* then x = K N0 q0 = qy_0/qy_N0 - 1
-* pressure correction for channel 1, CH3 + CHO
-* based on Horowitz and Calvert 1982.
+ if (qy1_n0 .gt. 0.) then
+ x = qy1_0/qy1_n0 - 1.
+ else
+ x = 0.
+ endif
+
+* use instead slope/intercept ratio from Horowitz and Calvert 1982,
+c x = yg4(iw)
+
+ DO i = 1, nz
+
+ qy1 = qy1_n0 * (1. + x) / (1. + x * airden(i)/2.465E19 )
- qy1 = qy1 * (1. + yg4(iw))/(1. + yg4(iw)*airden(i)/2.465E19)
qy1 = MIN(1., qy1)
qy1 = MAX(0., qy1)
@@ -23148,11 +23249,19 @@ c n = 1705
ENDDO
ENDDO
+* declare P dependence for channel 1
+
+ tpflag(j-2) = 2
+ tpflag(j) = 0
+ tpflag(j) = 0
+
+ RETURN
+
END
*=============================================================================*
- SUBROUTINE r12(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r12(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -23191,7 +23300,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -23203,9 +23312,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -23255,6 +23362,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -23402,11 +23510,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 2
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r13(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r13(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -23447,7 +23558,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -23459,9 +23570,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -23511,6 +23620,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -23522,15 +23632,15 @@ c INCLUDE 'params'
INTEGER kdata
PARAMETER(kdata=500)
- INTEGER i, n
- REAL x1(kdata)
- REAL y1(kdata)
+ INTEGER i, n, n1, n2, n3
+ REAL x(kdata), x1(kdata), x2(kdata), x3(kdata)
+ REAL y1(kdata), y2(kdata), y3(kdata)
* local
- REAL yg(kw)
- REAL qyII, qyIII
- REAL sig
+ REAL yg(kw), yg1(kw), yg2(kw), yg3(kw)
+ REAL qyI, qyII, qyIII
+ REAL sig, dum
INTEGER ierr
INTEGER iw
@@ -23567,6 +23677,9 @@ c INCLUDE 'params'
j = j + 1
jlabel(j) = 'CHOCHO -> CH2O + CO'
+ j = j + 1
+ jlabel(j) = 'CHOCHO -> CH2O + CO'
+
* options
* mabs for cross sections
* myld for quantum yields
@@ -23580,12 +23693,14 @@ c INCLUDE 'params'
* The UV-VIS absorption cross sectiono of the a-dicarbonyl compounds:
* pyruvic acid, biacetyl, and glyoxal.
* J. Photochem. Photobiol. A:Chemistry, v.146, pp.19-27, 2001.
+* 5: From JPL 2011, derived mostly from Volkamer et al.
* Quantum yield
* 1: IUPAC-97 data
+* 2: JPL 2011
- mabs = 4
- myld = 1
+ mabs = 5
+ myld = 2
IF (mabs .EQ. 1) THEN
@@ -23688,10 +23803,95 @@ c INCLUDE 'params'
WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
+
+ ELSEIF(mabs .eq. 5) then
+
+ open(unit=kin,
+ $ FILE='DATAJ1/CHOCHO/glyoxal_jpl11.abs',STATUS='old')
+
+ DO i = 1, 2
+ read(kin,*)
+ ENDDO
+ n = 277
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1.e-20
+ ENDDO
+ CLOSE (kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
ENDIF
* quantum yields
+ IF(myld .eq. 2) then
+
+ open(unit=kin,
+ $ FILE='DATAJ1/CHOCHO/glyoxal_jpl11.qy',STATUS='old')
+
+ DO i = 1, 3
+ read(kin,*)
+ ENDDO
+ n = 40
+ DO i = 1, n
+ READ(kin,*) x(i), dum, y1(i), y2(i), y3(i)
+ ENDDO
+ CLOSE (kin)
+
+ n1 = n
+ do i = 1, n
+ x1(i) = x(i)
+ enddo
+
+ CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),y1(1))
+ CALL addpnt(x1,y1,kdata,n1, 0.,y1(1))
+ CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+ n2 = n
+
+ do i = 1, n
+ x1(i) = x(i)
+ enddo
+ CALL addpnt(x1,y2,kdata,n2,x1(1)*(1.-deltax),y2(1))
+ CALL addpnt(x1,y2,kdata,n2, 0.,y2(1))
+ CALL addpnt(x1,y2,kdata,n2,x1(n2)*(1.+deltax),0.)
+ CALL addpnt(x1,y2,kdata,n2, 1.e+38,0.)
+ CALL inter2(nw,wl,yg2,n2,x1,y2,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ n3 = n
+ do i = 1, n
+ x1(i) = x(i)
+ enddo
+ CALL addpnt(x1,y3,kdata,n3,x1(1)*(1.-deltax),y3(1))
+ CALL addpnt(x1,y3,kdata,n3, 0.,y3(1))
+ CALL addpnt(x1,y3,kdata,n3,x1(n3)*(1.+deltax),0.)
+ CALL addpnt(x1,y3,kdata,n3, 1.e+38,0.)
+ CALL inter2(nw,wl,yg3,n3,x1,y3,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ ENDIF
+
* combine:
DO iw = 1, nw - 1
@@ -23699,29 +23899,48 @@ c INCLUDE 'params'
sig = yg(iw)
* quantum yields:
+ IF(myld .EQ. 1) THEN
+
* Use values from Bauerle, but corrected to cutoff at 417 rather than 380.
* this correction is a reduction by 7.1.
-* so that qyII = 0.63/7.1 and qyIII = 0.2/7.1
+* so that qyI = 0.63/7.1 and qyII = 0.2/7.1
+ qyII = 0.
if(wc(iw) .lt. 417. ) then
- qyII = 0.089
+ qyI = 0.089
qyIII = 0.028
else
- qyII = 0.
+ qyI = 0.
qyIII = 0.
endif
-
- DO i = 1, nz
- sq(j-1,i,iw) = sig * qyII
- sq(j,i, iw) = sig * qyIII
- ENDDO
+
+ DO i = 1, nz
+ sq(j-2,i,iw) = sig * qyI
+ sq(j-1,i,iw) = sig * qyII
+ sq(j, i,iw) = sig * qyIII
+ ENDDO
+
+ ELSEIF(myld .EQ. 2) THEN
+
+ DO i = 1, nz
+ sq(j-2,i,iw) = sig * yg1(iw)
+ sq(j-1,i,iw) = sig * yg2(iw)
+ sq(j, i,iw) = sig * yg3(iw)
+ ENDDO
+
+ ENDIF
ENDDO
+ tpflag(j-2) = 0
+ tpflag(j-1) = 0
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r14(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r14(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -23772,7 +23991,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -23784,9 +24003,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -23836,6 +24053,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -23887,6 +24105,7 @@ c INCLUDE 'params'
* 5: ch3cocho.003 - Meller et al. 1991, 1.0 nm resolution
* 6: ch3cocho.004 - Staffelbach et al. 1995
* 7: use synthetic spectrum, average of CHOCHO and CH3COCOCH3:
+* 8: cross section from JPL2011
@@ -23899,7 +24118,7 @@ c INCLUDE 'params'
* 5: Chen, Y., W. Wang, and L. Zhu, Wavelength-dependent photolysis of methylglyoxal
* in the 290-440 nm region, J Phys Chem A, 104, 11126-11131, 2000.
- mabs = 2
+ mabs = 8
myld = 5
IF (mabs .EQ. 1) THEN
@@ -24063,6 +24282,30 @@ c INCLUDE 'params'
yg(iw) = 0.5*(yg1(iw) + yg2(iw))
enddo
+ ELSEIF(mabs .eq. 8) then
+
+ OPEN(UNIT=kin,
+ $ FILE='DATAJ1/CH3COCHO/CH3COCHO_jpl11.abs',STATUS='old')
+ do i = 1, 2
+ read(kin,*)
+ enddo
+ n = 294
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1.e-20
+ ENDDO
+ CLOSE (kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
ENDIF
* quantum yields
@@ -24178,11 +24421,14 @@ c kq = 1.93e4 * EXP(-5639/wc(iw))
ENDDO
ENDDO
+ tpflag(j) = 2
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r15(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r15(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -24224,7 +24470,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -24236,9 +24482,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -24288,6 +24532,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -24300,13 +24545,13 @@ c INCLUDE 'params'
PARAMETER(kdata=150)
INTEGER i, n
- INTEGER n1, n2, n3
- REAL x1(kdata), x2(kdata), x3(kdata)
- REAL y1(kdata), y2(kdata), y3(kdata)
+ INTEGER n1, n2, n3, n4
+ REAL x1(kdata), x2(kdata), x3(kdata), x4(kdata)
+ REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata)
* local
- REAL yg(kw), yg1(kw), yg2(kw), yg3(kw)
+ REAL yg(kw), yg1(kw), yg2(kw), yg3(kw), yg4(kw)
REAL qy
REAL sig
INTEGER ierr
@@ -24329,6 +24574,7 @@ c INCLUDE 'params'
* 1: cross section from Calvert and Pitts
* 2: Martinez et al. 1991, also in IUPAC'97
* 3: NOAA 1998, unpublished as of Jan 98.
+* 4: JPL-2011
* Quantum yield
* 1: Gardiner et al. 1984
@@ -24342,7 +24588,7 @@ c INCLUDE 'params'
* photodissociation of acetone between 279 and 327.5 nm, Geophys.
* Res. Lett., 31, L06111, doi:10.1029/2003GL018793.
- mabs = 2
+ mabs = 4
myld = 4
IF (mabs .EQ. 1) THEN
@@ -24442,6 +24688,69 @@ c INCLUDE 'params'
STOP
ENDIF
+ ELSEIF(mabs.eq.4) then
+ OPEN(UNIT=kin,FILE='DATAJ1/CH3COCH3/CH3COCH3_jpl11.abs',
+ $ STATUS='old')
+ DO i = 1, 5
+ READ(kin,*)
+ ENDDO
+ n = 135
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i), y2(i), y3(i), y4(i)
+ x2(i) = x1(i)
+ x3(i) = x1(i)
+ x4(i) = x1(i)
+ y1(i) = y1(i) * 1.e-20
+ y2(i) = y2(i) / 1.e3
+ y3(i) = y3(i) / 1.e5
+ y4(i) = y4(i) / 1.e8
+ ENDDO
+ CLOSE (kin)
+ n1 = n
+ n2 = n
+ n3 = n
+ n4 = n
+
+ CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
+ CALL addpnt(x2,y2,kdata,n2, 0.,0.)
+ CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
+ CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
+ CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.)
+ CALL addpnt(x3,y3,kdata,n3, 0.,0.)
+ CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.)
+ CALL addpnt(x3,y3,kdata,n3, 1.e+38,0.)
+ CALL inter2(nw,wl,yg3,n3,x3,y3,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ CALL addpnt(x4,y4,kdata,n4,x4(1)*(1.-deltax),0.)
+ CALL addpnt(x4,y4,kdata,n4, 0.,0.)
+ CALL addpnt(x4,y4,kdata,n4,x4(n4)*(1.+deltax),0.)
+ CALL addpnt(x4,y4,kdata,n4, 1.e+38,0.)
+ CALL inter2(nw,wl,yg4,n4,x4,y4,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
ENDIF
IF (myld .EQ. 2) THEN
@@ -24476,11 +24785,20 @@ c INCLUDE 'params'
sig = yg(iw)
IF(mabs .EQ. 3) THEN
+*!!! this definition of t is not consistent with JPL2011
+
t = 298. - tlev(i)
t = MIN(t, 298.-235.)
t = MAX(t, 0.)
- sig = yg(iw)*(1. + yg2(iw)*t + yg3(iw)*t*t)
+ sig = yg(iw)*(1. + yg2(iw)*t + yg3(iw)*t*t
+ $ + yg4(iw)*t*t*t)
+
+ ELSEIF (mabs .eq. 4)THEN
+
+ t = MIN(MAX(tlev(i), 235.),298.)
+ sig = yg(iw)*(1. + yg2(iw)*t + yg3(iw)*t*t
+ $ + yg4(iw)*t*t*t)
ENDIF
@@ -24522,12 +24840,17 @@ c INCLUDE 'params'
ENDDO
ENDDO
+* both T and P
+
+ tpflag(j) = 3
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r16(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r16(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -24569,7 +24892,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -24581,9 +24904,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -24633,6 +24954,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -24670,8 +24992,9 @@ c INCLUDE 'params'
* 3: Cox and Tyndall (1978), only for wavelengths < 280 nm
* 4: Molina and Arguello (1979). According to Vaghjiani and Ravishankara (1989),
* Molina and Arguello had a problem measuring CH3OOH, cross sections 40% too high.
+* 5: JPL2011
- mabs = 2
+ mabs = 5
IF (mabs .EQ. 1) THEN
@@ -24773,6 +25096,30 @@ c $ STATUS='old')
STOP
ENDIF
+ ELSEIF (mabs .EQ. 5) THEN
+
+ OPEN(UNIT=kin,FILE='DATAJ1/CH3OOH/CH3OOH_jpl11.abs',
+ $ STATUS='old')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 40
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1.e-20
+ ENDDO
+ CLOSE (kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
ENDIF
* quantum yield = 1
@@ -24785,11 +25132,16 @@ c $ STATUS='old')
ENDDO
ENDDO
+* no T or P dep
+
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r17(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r17(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -24835,7 +25187,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -24847,9 +25199,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -24899,6 +25249,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -24939,8 +25290,9 @@ c INCLUDE 'params'
* 6: fit from Roberts and Fajer, 1989
* 7: Rattigan et al. 1992
* 8: Libuda and Zabel 1995
+* 9: JPL2011 including T-dependence
- mabs = 2
+ mabs = 9
IF (mabs .EQ. 1) THEN
@@ -25151,6 +25503,44 @@ c INCLUDE 'params'
STOP
ENDIF
+ ELSEIF (mabs. eq. 9) THEN
+
+ OPEN(UNIT=kin,FILE='DATAJ1/RONO2/CH3ONO2_jpl11.abs',
+ $ STATUS='old')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 65
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i), y2(i)
+ y1(i) = y1(i) * 1.e-20
+ x2(i) = x1(i)
+ y2(i) = y2(i) * 1.e-3
+ ENDDO
+ CLOSE (kin)
+
+ n1 = n
+ CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n1,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ n2 = n
+ CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
+ CALL addpnt(x2,y2,kdata,n2, 0.,0.)
+ CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
+ CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1,n2,x2,y2,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
ENDIF
* quantum yield = 1
@@ -25162,12 +25552,10 @@ c INCLUDE 'params'
DO i = 1, nz
- IF(mabs .EQ. 2) THEN
+ IF(mabs .EQ. 2 .OR. mabs .EQ. 9) THEN
sig = yg(iw) * exp (yg1(iw) * (tlev(i)-298.))
-
ELSEIF (mabs .EQ. 4) THEN
sig = yg(iw)*10.**(yg1(iw)*tlev(i))
-
ENDIF
sq(j,i,iw) = qy * sig
@@ -25175,11 +25563,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r18(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r18(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -25215,7 +25606,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -25227,9 +25618,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -25279,6 +25668,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -25371,10 +25761,10 @@ C ENDIF
ENDIF
* quantum yield:
-* from JPL 2006, values at 308 nm.
+* from JPL 2011 values for >300 nm.
- qyNO2 = 0.6
- qyNO3 = 0.4
+ qyNO2 = 0.7
+ qyNO3 = 0.3
DO iw = 1, nw-1
DO i = 1, nz
@@ -25383,15 +25773,19 @@ C ENDIF
sq(j-1,i,iw) = qyNO2 * sig
sq(j,i,iw) = qyNO3 * sig
-
+
ENDDO
- ENDDO
+ ENDDO
+
+ tpflag(j-1) = 1
+ tpflag(j) = 1
+ RETURN
END
*=============================================================================*
- SUBROUTINE r19(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r19(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -25427,7 +25821,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -25439,9 +25833,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -25491,6 +25883,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -25549,11 +25942,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r20(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r20(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -25588,7 +25984,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -25600,9 +25996,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -25652,6 +26046,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -25672,6 +26067,9 @@ c INCLUDE 'params'
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
+ INTEGER mabs
+ REAL b0, b1, b2, b3, b4, tcoeff, sig
+ REAL w1, w2, w3, w4, temp
**************************************************************
************* CCl4 photodissociation
@@ -25679,43 +26077,112 @@ c INCLUDE 'params'
j = j+1
jlabel(j) = 'CCl4 -> Products'
+* mabs = 1: jpl 1997 recommendation
+* mabs = 2: jpl 2011 recommendation, with T dependence
+
+ mabs = 2
+
*** cross sections from JPL97 recommendation (identical to 94 data)
- OPEN(kin,FILE='DATAJ1/ABS/CCl4_jpl94.abs',STATUS='OLD')
- READ(kin,*) idum, n
- DO i = 1, idum-2
- READ(kin,*)
- ENDDO
- DO i = 1, n
- READ(kin,*) x1(i), y1(i)
- y1(i) = y1(i) * 1E-20
- ENDDO
- CLOSE(kin)
+ IF(mabs .EQ. 1) THEN
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 0.,0.)
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 1E38,0.)
+ OPEN(kin,FILE='DATAJ1/ABS/CCl4_jpl94.abs',STATUS='OLD')
+ READ(kin,*) idum, n
+ DO i = 1, idum-2
+ READ(kin,*)
+ ENDDO
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1E-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1E38,0.)
+
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ ELSEIF(mabs .EQ. 2) THEN
+
+ OPEN(kin,FILE='DATAJ1/ABS/CCl4_jpl11.abs',STATUS='OLD')
+ DO i = 1, 5
+ READ(kin,*)
+ ENDDO
+ n = 44
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1E-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1E38,0.)
+
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
ENDIF
+* compute temperature correction factors:
+
+ b0 = 1.0739
+ b1 = -1.6275e-2
+ b2 = 8.8141e-5
+ b3 = -1.9811e-7
+ b4 = 1.5022e-10
+
*** quantum yield assumed to be unity
+
qy = 1.
DO iw = 1, nw-1
- DO iz = 1, nz
- sq(j,iz,iw) = qy * yg(iw)
- ENDDO
+
+* compute temperature correction coefficients:
+
+ tcoeff = 0.
+ IF(wc(iw) .GT. 194. .AND. wc(iw) .LT. 250.) THEN
+ w1 = wc(iw)
+ w2 = w1**2
+ w3 = w1**3
+ w4 = w1**4
+ tcoeff = b0 + b1*w1 + b2*w2 + b3*w3 + b4*w4
+ ENDIF
+
+ DO iz = 1, nz
+
+ IF(mabs .EQ. 1) THEN
+ sig = yg(iw)
+ ELSEIF (mabs .EQ. 2) THEN
+
+ temp = tlev(iz)
+ temp = min(max(temp,210.),300.)
+
+ sig = yg(iw) * 10.**(tcoeff*(temp-295.))
+ ENDIF
+
+ sq(j,iz,iw) = qy * sig
+
+ ENDDO
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r21(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r21(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -25750,7 +26217,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -25762,9 +26229,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -25814,6 +26279,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -25873,11 +26339,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r22(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r22(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -25912,7 +26381,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -25924,9 +26393,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -25976,6 +26443,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -26035,11 +26503,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r23(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r23(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -26075,7 +26546,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -26087,9 +26558,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -26139,6 +26608,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -26226,11 +26696,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r24(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r24(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -26266,7 +26739,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -26278,9 +26751,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -26330,6 +26801,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -26417,11 +26889,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r25(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r25(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -26456,7 +26931,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -26468,9 +26943,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -26520,6 +26993,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -26581,11 +27055,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r26(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r26(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -26620,7 +27097,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -26632,9 +27109,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -26684,6 +27159,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -26749,11 +27225,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r27(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r27(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -26788,7 +27267,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -26800,9 +27279,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -26852,6 +27329,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -26917,11 +27395,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r28(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r28(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -26956,7 +27437,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -26968,9 +27449,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -27020,6 +27499,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -27080,11 +27560,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r29(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r29(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -27120,7 +27603,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -27132,9 +27615,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -27184,6 +27665,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -27295,11 +27777,14 @@ c INCLUDE 'params'
ENDIF
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r30(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r30(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -27335,7 +27820,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -27347,9 +27832,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -27399,6 +27882,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -27510,11 +27994,14 @@ c INCLUDE 'params'
ENDIF
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r31(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r31(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -27549,7 +28036,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -27561,9 +28048,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -27613,6 +28098,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -27675,11 +28161,14 @@ C INTEGER n1, n2, n3, n4, n5
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r32(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r32(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -27714,7 +28203,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -27726,9 +28215,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -27778,6 +28265,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -27880,11 +28368,14 @@ C the measurements beyond 220 nm are very large (Orlando, priv.comm.)
ENDIF
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r33(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r33(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -27919,7 +28410,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -27931,9 +28422,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -27982,6 +28471,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -28082,11 +28572,14 @@ C ENDDO
ENDIF
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r34(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r34(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -28122,7 +28615,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -28134,9 +28627,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -28186,6 +28677,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -28247,11 +28739,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r35(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r35(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -28288,7 +28783,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -28300,9 +28795,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -28352,6 +28845,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -28460,12 +28954,14 @@ c sq(j,iz,iw) = qy * EXP(sum)
ENDDO
+ tpflag(j) = 1
+ RETURN
END
*=============================================================================*
- SUBROUTINE r36(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r36(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -28501,7 +28997,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -28513,9 +29009,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -28565,6 +29059,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -28626,11 +29121,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r37(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r37(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -28666,7 +29164,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -28678,9 +29176,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -28730,6 +29226,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -28791,11 +29288,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r38(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r38(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -28831,7 +29331,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -28843,9 +29343,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -28895,6 +29393,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -29050,11 +29549,14 @@ c INCLUDE 'params'
ENDIF
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r39(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r39(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -29090,7 +29592,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -29102,9 +29604,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -29154,6 +29654,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -29181,13 +29682,13 @@ c INCLUDE 'params'
j = j+1
jlabel(j) = 'HO2 -> OH + O'
-**** cross sections from JPL97 recommendation (identical to 94 recommendation)
+**** cross sections from JPL11 recommendation
- OPEN(kin,FILE='DATAJ1/ABS/HO2_jpl94.abs',STATUS='OLD')
- READ(kin,*) idum, n
- DO i = 1, idum-2
+ OPEN(kin,FILE='DATAJ1/ABS/HO2_jpl11.abs',STATUS='OLD')
+ DO i = 1, 10
READ(kin,*)
ENDDO
+ n = 15
DO i = 1, n
READ(kin,*) x1(i), y1(i)
y1(i) = y1(i) * 1E-20
@@ -29224,11 +29725,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r40(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r40(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -29263,7 +29767,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -29275,9 +29779,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -29327,6 +29829,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -29388,11 +29891,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r41(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r41(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -29428,7 +29934,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -29440,9 +29946,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -29492,6 +29996,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -29553,11 +30058,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r42(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r42(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -29593,7 +30101,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -29605,9 +30113,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -29657,6 +30163,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -29718,11 +30225,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r43(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r43(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -29758,7 +30268,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -29770,9 +30280,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -29822,6 +30330,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -29885,11 +30394,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r44(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r44(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -29924,7 +30436,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -29936,9 +30448,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -29988,6 +30498,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -30044,11 +30555,14 @@ c INCLUDE 'params'
ENDIF
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r45(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r45(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -30084,7 +30598,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -30096,9 +30610,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -30148,6 +30660,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -30179,7 +30692,7 @@ c INCLUDE 'params'
j = j+1
jlabel(j) = 'ClONO2 -> ClO + NO2'
-*** cross sections from JPL97 recommendation
+*** cross sections from JPL97 recommendation. Same in JPL-2011.
OPEN(kin,FILE='DATAJ1/ABS/ClONO2_jpl97.abs',STATUS='OLD')
n = 119
@@ -30226,7 +30739,7 @@ c INCLUDE 'params'
DO iw = 1, nw-1
-*** quantum yields (from jpl97)
+*** quantum yields (from jpl97, same in jpl2011)
IF( wc(iw) .LT. 308.) THEN
qy1 = 0.6
@@ -30249,11 +30762,15 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j-1) = 1
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r46(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r46(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -30289,7 +30806,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -30301,9 +30818,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -30353,6 +30868,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -30370,7 +30886,7 @@ c INCLUDE 'params'
* local
REAL yg1(kw)
- REAL qy1, qy2
+ REAL qyNO2, qyNO3
INTEGER i, iw, n, idum
INTEGER ierr
INTEGER iz
@@ -30409,20 +30925,24 @@ c INCLUDE 'params'
*** quantum yields (from jpl97)
- qy1 = 0.71
- qy2 = 0.29
+ qyNO2 = 0.15
+ qyNO3 = 0.85
DO iw = 1, nw-1
DO iz = 1, nz
- sq(j-1,iz,iw) = qy1 * yg1(iw)
- sq(j,iz,iw) = qy2 * yg1(iw)
+ sq(j-1,iz,iw) = qyNO2 * yg1(iw)
+ sq(j,iz,iw) = qyNO3 * yg1(iw)
ENDDO
ENDDO
+ tpflag(j-1) = 0
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r47(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r47(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -30458,7 +30978,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -30470,9 +30990,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -30522,6 +31040,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -30543,50 +31062,85 @@ c INCLUDE 'params'
INTEGER iz, iw
INTEGER ierr
+ integer mabs
+ real aa, bb, ex1, ex2, sig, alpha(kz)
************* CL2 photodissociation
j = j+1
jlabel(j) = 'Cl2 -> Cl + Cl'
+* mabs = 1: Finlayson-Pitts and Pitts
+* mabs = 2: JPL2011 formula
+
+ mabs = 2
+
+ IF (mabs .EQ. 1) THEN
+
*** cross sections from JPL97 recommendation (as tab by Finlayson-Pitts
* and Pitts, 1999.
- OPEN(kin,FILE='DATAJ1/ABS/CL2_fpp.abs',STATUS='OLD')
- do i = 1, 5
- read(kin,*)
- enddo
- n = 22
- DO i = 1, n
- READ(kin,*) x1(i), y1(i)
- y1(i) = y1(i) * 1E-20
- ENDDO
- CLOSE(kin)
+ OPEN(kin,FILE='DATAJ1/ABS/CL2_fpp.abs',STATUS='OLD')
+ do i = 1, 5
+ read(kin,*)
+ enddo
+ n = 22
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1E-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1E38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ ELSEIF(mabs .EQ. 2) THEN
+
+ DO iz = 1, nz
+ aa = 402.7/tlev(iz)
+ bb = exp(aa)
+ alpha(iz) = (bb - 1./bb) / (bb + 1./bb)
+ ENDDO
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 0.,0.)
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 1E38,0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
ENDIF
*** quantum yield = 1 (Calvert and Pitts, 1966)
qy = 1.
DO iw = 1, nw-1
+
+ if(mabs .eq. 1) sig = yg(iw)
+
DO iz = 1, nz
- sq(j,iz,iw) = qy * yg(iw)
+
+ if (mabs .eq. 2) then
+
+ ex1 = 27.3 * exp(-99.0 * alpha(iz) * (log(329.5/wc(iw)))**2)
+ ex2 = 0.932 * exp(-91.5 * alpha(iz) * (log(406.5/wc(iw)))**2)
+ sig = 1e-20 * alpha(iz)**0.5 * (ex1 + ex2)
+
+ ENDIF
+
+ sq(j,iz,iw) = qy * sig
+
ENDDO
ENDDO
+ tpflag(j) = 1
+
RETURN
END
*=============================================================================*
- SUBROUTINE r101(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+
+ SUBROUTINE r101(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -30626,7 +31180,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -30638,9 +31192,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -30690,6 +31242,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -30710,49 +31263,98 @@ c INCLUDE 'params'
REAL qy
INTEGER ierr
INTEGER iw
+ INTEGER mabs
+ real qy1, qy2, qy3
************************* CH2(OH)CHO photolysis
* 1: CH2(OH)CHO
j = j+1
- jlabel(j) = 'CH2(OH)CHO -> Products'
+ jlabel(j) = 'HOCH2CHO -> CH2OH + HCO'
+ j = j+1
+ jlabel(j) = 'HOCH2CHO -> CH3OH + CO'
+ j = j+1
+ jlabel(j) = 'HOCH2CHO -> CH2CHO + OH'
- OPEN(UNIT=kin,FILE='DATAJ1/CH2OHCHO/glycolaldehyde.abs',
- $ STATUS='old')
- DO i = 1, 15
- READ(kin,*)
- ENDDO
- n = 131
- DO i = 1, n
- READ(kin,*) x(i), y(i)
- ENDDO
- CLOSE(kin)
+ mabs = 2
+
+ IF(mabs .EQ. 1) THEN
+
+*= Cross section from =*
+*= The Atmospheric Chemistry of Glycolaldehyde, C. Bacher, G. S. Tyndall =*
+*= and J. J. Orlando, J. Atmos. Chem., 39 (2001) 171-189. =*
+
+ OPEN(UNIT=kin,FILE='DATAJ1/CH2OHCHO/glycolaldehyde.abs',
+ $ STATUS='old')
+ DO i = 1, 15
+ READ(kin,*)
+ ENDDO
+ n = 131
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,n, 0.,0.)
+ CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ ELSEIF(mabs .EQ. 2) THEN
+
+ OPEN(UNIT=kin,FILE='DATAJ1/CH2OHCHO/glycolaldehyde_jpl11.abs',
+ $ STATUS='old')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 63
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,n, 0.,0.)
+ CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
- CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
- CALL addpnt(x,y,kdata,n, 0.,0.)
- CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
- CALL addpnt(x,y,kdata,n, 1.e+38,0.)
- CALL inter2(nw,wl,yg,n,x,y,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
ENDIF
* combine:
- qy = 0.5
+ qy1 = 0.83
+ qy2 = 0.10
+ qy3 = 0.07
DO iw = 1, nw - 1
DO i = 1, nz
- sq(j,i,iw) = yg(iw) * qy
+ sq(j-2,i,iw) = yg(iw) * qy1
+ sq(j-1,i,iw) = yg(iw) * qy2
+ sq(j ,i,iw) = yg(iw) * qy3
ENDDO
ENDDO
+ tpflag(j-2) = 0
+ tpflag(j-1) = 0
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r102(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r102(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -30792,7 +31394,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -30804,9 +31406,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -30856,6 +31456,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -30948,11 +31549,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r103(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r103(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -30995,7 +31599,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -31007,9 +31611,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -31059,6 +31661,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -31079,31 +31682,66 @@ c INCLUDE 'params'
REAL qy
INTEGER ierr
INTEGER iw
+ INTEGER mabs
************************* CH3COCHCH2 photolysis
j = j+1
jlabel(j) = 'CH3COCHCH2 -> Products'
- OPEN(UNIT=kin,FILE='DATAJ1/ABS/methylvinylketone.abs',
- $ STATUS='old')
- DO i = 1, 9
- READ(kin,*)
- ENDDO
- n = 19682
- DO i = 1, n
- READ(kin,*) x(i), y(i)
- ENDDO
- CLOSE(kin)
+* mabs = 1: Schneider and moortgat
+* mabs = 2: jpl 2011
+
+ mabs = 2
+
+
+ IF(mabs .EQ. 1) THEN
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/MVK_schneider.abs',
+ $ STATUS='old')
+ DO i = 1, 9
+ READ(kin,*)
+ ENDDO
+ n = 19682
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,n, 0.,0.)
+ CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ ELSEIF(mabs .EQ. 2) THEN
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/MVK_jpl11.abs',
+ $ STATUS='old')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 146
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,n, 0.,0.)
+ CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
- CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
- CALL addpnt(x,y,kdata,n, 0.,0.)
- CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
- CALL addpnt(x,y,kdata,n, 1.e+38,0.)
- CALL inter2(nw,wl,yg,n,x,y,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
ENDIF
* quantum yield from
@@ -31121,12 +31759,15 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 2
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r104(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r104(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -31162,7 +31803,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -31174,9 +31815,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -31226,6 +31865,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -31258,7 +31898,7 @@ c INCLUDE 'params'
* cross section from
* JPL 2006 (originally from Gierczak et al.)
- OPEN(UNIT=kin,FILE='DATAJ1/ABS/Methacrolein_jpl2007.txt',
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/Methacrolein_jpl11.abs',
$ STATUS='OLD')
DO i = 1, 7
READ(kin,*)
@@ -31291,11 +31931,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r105(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r105(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -31336,7 +31979,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -31348,9 +31991,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -31400,6 +32041,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -31419,36 +32061,69 @@ c INCLUDE 'params'
REAL yg(kw)
REAL qy
INTEGER ierr
- INTEGER iw
+ INTEGER iw, mabs
************************* CH3COCO(OH) photolysis
j = j+1
jlabel(j) = 'CH3COCO(OH) -> Products'
- OPEN(UNIT=kin,FILE='DATAJ1/CH3COCOOH/pyruvic_horowitz.abs',
- $ STATUS='old')
- DO i = 1, 8
- READ(kin,*)
- ENDDO
- n = 148
- DO i = 1, n
- READ(kin,*) x(i), y(i)
- y(i) = y(i) * 1.e-20
- ENDDO
- CLOSE(kin)
+ mabs = 2
+
+* mabs = 1: Horowitz et al.
+* mabs = 2: JPL2011
+
+ IF (mabs .EQ. 1) THEN
+
+ OPEN(UNIT=kin,FILE='DATAJ1/CH3COCOOH/pyruvic_horowitz.abs',
+ $ STATUS='old')
+ DO i = 1, 8
+ READ(kin,*)
+ ENDDO
+ n = 148
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,n, 0.,0.)
+ CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ ELSEIF (mabs .eq. 2) then
+
+ OPEN(UNIT=kin,FILE='DATAJ1/CH3COCOOH/pyruvic_jpl11.abs',
+ $ STATUS='old')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 139
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,n, 0.,0.)
+ CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
- CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
- CALL addpnt(x,y,kdata,n, 0.,0.)
- CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
- CALL addpnt(x,y,kdata,n, 1.e+38,0.)
- CALL inter2(nw,wl,yg,n,x,y,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
ENDIF
-* quantum yield = 1
+* quantum yield = 1 (sum of all channels)
qy = 1.
@@ -31458,11 +32133,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r106(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r106(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -31503,7 +32181,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -31515,9 +32193,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -31567,6 +32243,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -31641,11 +32318,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r107(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r107(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -31686,7 +32366,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -31698,9 +32378,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -31750,6 +32428,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -31824,11 +32503,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 1
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r108(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r108(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -31868,7 +32550,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -31880,9 +32562,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -31932,6 +32612,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -31971,11 +32652,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r109(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r109(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -32015,7 +32699,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -32027,9 +32711,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -32079,6 +32761,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -32118,11 +32801,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r110(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r110(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -32162,7 +32848,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -32174,9 +32860,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -32226,6 +32910,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -32265,11 +32950,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r111(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r111(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -32307,7 +32995,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -32319,9 +33007,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -32371,6 +33057,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -32393,17 +33080,17 @@ c INCLUDE 'params'
INTEGER iw
************************* ClOOCl photolysis
-* from JPL-2002
+* from JPL-2011
j = j+1
jlabel(j) = 'ClOOCl -> Cl + ClOO'
- OPEN(UNIT=kin,FILE='DATAJ1/ABS/CLOOCL_jpl02.abs',
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/CLOOCL_jpl11.abs',
$ STATUS='old')
- DO i = 1, 25
+ DO i = 1, 3
READ(kin,*)
ENDDO
- n = 131
+ n = 111
DO i = 1, n
READ(kin,*) x(i), y(i)
y(i) = y(i) * 1.e-20
@@ -32430,11 +33117,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r112(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r112(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -32473,7 +33163,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -32485,9 +33175,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -32537,6 +33225,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -32556,7 +33245,7 @@ c INCLUDE 'params'
REAL yg(kw)
REAL qy
INTEGER ierr
- INTEGER iw
+ INTEGER iw, mabs
************************* CH2(OH)COCH3 photolysis
* from Orlando et al. 1999
@@ -32566,28 +33255,60 @@ c INCLUDE 'params'
j = j+1
jlabel(j) = 'CH2(OH)COCH3 -> CH2(OH)CO + CH3'
- OPEN(UNIT=kin,FILE='DATAJ1/ABS/Hydroxyacetone.abs',
- $ STATUS='old')
- DO i = 1, 8
- READ(kin,*)
- ENDDO
- n = 101
- DO i = 1, n
- READ(kin,*) x(i), y(i)
- ENDDO
- CLOSE(kin)
+* mabs = 1: from Orlando et al. 1999
+* mabs = 2: from jpl 2011
+
+ mabs = 2
+
+ if (mabs.eq.1) then
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/Hydroxyacetone.abs',
+ $ STATUS='old')
+ DO i = 1, 8
+ READ(kin,*)
+ ENDDO
+ n = 101
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,n, 0.,0.)
+ CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ ELSEIF(mabs .eq. 2) then
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/Hydroxyacetone_jpl11.abs',
+ $ STATUS='old')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 96
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,n, 0.,0.)
+ CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
- CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
- CALL addpnt(x,y,kdata,n, 0.,0.)
- CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
- CALL addpnt(x,y,kdata,n, 1.e+38,0.)
- CALL inter2(nw,wl,yg,n,x,y,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
ENDIF
-* Total quantum yield = 0.65, equal for each of the two channels
+* Total quantum yield = 0.65, from Orlando et al. Assume equal for each of
+* the two channels
qy = 0.325
@@ -32598,11 +33319,15 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j-1) = 0
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r113(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r113(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -32637,7 +33362,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -32649,9 +33374,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -32701,6 +33424,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -32733,11 +33457,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r114(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r114(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -32772,7 +33499,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -32784,9 +33511,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -32837,6 +33562,7 @@ c INCLUDE 'params'
INTEGER j
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* data arrays
@@ -32880,11 +33606,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r115(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r115(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -32917,7 +33646,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -32929,9 +33658,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -32982,6 +33709,7 @@ c INCLUDE 'params'
INTEGER j
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* data arrays
@@ -33035,10 +33763,15 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r118(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+
+ SUBROUTINE r118(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
*-----------------------------------------------------------------------------*
*= NO3-(aq) photolysis for snow simulations =*
*= a) NO3-(aq) + hv -> NO2 + O- =*
@@ -33063,7 +33796,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -33075,9 +33808,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -33120,6 +33851,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -33127,21 +33859,24 @@ c INCLUDE 'params'
* data arrays
INTEGER kdata
- PARAMETER(kdata=30)
+ PARAMETER(kdata=50)
REAL x1(kdata),x2(kdata)
REAL y1(kdata),y2(kdata) ! y1 = 20'C, y2 = -20'C
* local
- REAL yg(kw),yg1(kw),yg2(kw)
- REAL qy1(kz), qy2
+ REAL yg(kw),yg1(kw),yg2(kw), dum
+ REAL qy1(kz), qy2, qy3
INTEGER i, iw, n, n1, n2, idum, ierr, iz
+ integer mabs
*** NO3-(aq) quantum yields
* O- (OH and NO2) production
j = j + 1
jlabel(j) = 'NO3-(aq) -> NO2(aq) + O-'
DO iz = 1, nz
+
* qy1(iz) = 9.3e-3 ! Warneck & Wurzinger 1988
+
qy1(iz) = exp(-2400./tlev(iz) + 3.6) ! Chu & Anastasio, 2003
ENDDO
@@ -33150,60 +33885,107 @@ c INCLUDE 'params'
jlabel(j) = 'NO3-(aq) -> NO2-(aq) + O(3P)'
qy2 = 1.1e-3 ! Warneck & Wurzinger '88
+* NO2- with qy=1
-*** NO3-(aq) cross sections from Burley & Johnston (header lines = 24, data lines = 19)
- OPEN(kin,FILE='DATAJ1/ABS/NO3-_BJ92.abs',STATUS='OLD')
+ j = j + 1
+ jlabel(j) = 'NO3-(aq) with qy=1'
+ qy3 = 1.
- n = 24
- DO i = 1, n
- READ(kin,*)
- ENDDO
- n = 19
- DO i = 1, n
- READ(kin,*) x1(i), y1(i), y2(i)
- x2(i) = x1(i)
- y1(i)=y1(i)*1e-20
- y2(i)=y2(i)*1e-20
- ENDDO
- CLOSE(kin)
- n1 = n
- CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
- CALL addpnt(x1,y1,kdata,n1, 0.,0.)
- CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
- CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
- CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
- ENDIF
+* options for cross section
- n2 = n
- CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
- CALL addpnt(x2,y2,kdata,n2, 0.,0.)
- CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
- CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
- CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
- ENDIF
+ mabs = 2
+
+ if (mabs .eq. 1) then
+*** NO3-(aq) cross sections from Burley & Johnston (header lines = 24,
+* data lines = 19)
+ OPEN(kin,FILE='DATAJ1/ABS/NO3-_BJ92.abs',STATUS='OLD')
+
+ n = 24
+ DO i = 1, n
+ READ(kin,*)
+ ENDDO
+ n = 19
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i), y2(i)
+ x2(i) = x1(i)
+ y1(i)=y1(i)*1e-20
+ y2(i)=y2(i)*1e-20
+ ENDDO
+ CLOSE(kin)
+ n1 = n
+ CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
+ CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ n2 = n
+ CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
+ CALL addpnt(x2,y2,kdata,n2, 0.,0.)
+ CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
+ CALL addpnt(x2,y2,kdata,n2, 1E38,0.)
+ CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ elseif (mabs .eq. 2) then
+
+*** NO3-(aq) cross sections from Chu and Anastasio 2003:
+* convert from molar abs log10 to cm2 per molec
+
+ OPEN(kin,FILE='DATAJ1/ABS/NO3-_CA03.abs',STATUS='OLD')
+ n = 7
+ do i = 1, n
+ read(kin,*)
+ enddo
+ n = 43
+ DO i = 1, n
+ read(kin,*) x1(i), y1(i), dum, dum, dum, dum
+ y1(i) = y1(i) * 3.82e-21
+ enddo
+ n1 = n
+ CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 1E38,0.)
+ CALL inter2(nw,wl,yg2,n1,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ endif
DO iw = 1, nw-1
! yg(iw)=yg1(iw) ! for 20'C
yg(iw)=yg2(iw) ! for -20'C
DO iz = 1, nz
- sq(j-1,iz,iw) = qy1(iz)*yg(iw)
- sq(j,iz,iw) = qy2*yg(iw)
+
+ sq(j-2,iz,iw) = qy1(iz)*yg(iw)
+ sq(j-1,iz,iw) = qy2*yg(iw)
+ sq(j, iz,iw) = qy3*yg(iw)
+
ENDDO
ENDDO
- END
+* chu and anastasio qy is T dependent:
-*=============================================================================*
+ tpflag(j-2) = 1
+ tpflag(j-1) = 1
+ tpflag(j) = 1
+
+ RETURN
+ END
*=============================================================================*
- SUBROUTINE r119(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r119(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -33242,7 +34024,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -33254,9 +34036,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -33306,6 +34086,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -33340,7 +34121,7 @@ c INCLUDE 'params'
ENDDO
n = 96
DO i = 1, n
- READ(kin,*) x(i), dum, dum, y(i), dum
+ READ(kin,*) x(i), dum, y(i), dum, dum
y(i) = y(i) * 1.e-20
ENDDO
CLOSE(kin)
@@ -33372,10 +34153,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 2
+
+ RETURN
END
+
*=============================================================================*
- SUBROUTINE r120(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r120(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -33411,7 +34196,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -33423,9 +34208,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -33475,6 +34258,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -33508,7 +34292,7 @@ c INCLUDE 'params'
* cross section from
-* JPL 2006 (originally from Harwood et al. 2003)
+* JPL 2011 (originally from Harwood et al. 2003)
OPEN(UNIT=kin,FILE='DATAJ1/ABS/PPN_Harwood.txt',STATUS='OLD')
DO i = 1, 10
@@ -33560,10 +34344,15 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j-1) = 0
+ tpflag(j) = 0
+
+ RETURN
END
+
*=============================================================================*
- SUBROUTINE r121(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r121(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -33600,7 +34389,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -33612,9 +34401,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -33664,6 +34451,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -33730,10 +34518,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
+
*=============================================================================*
- SUBROUTINE r122(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r122(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -33770,7 +34562,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -33782,9 +34574,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -33834,6 +34624,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -33906,11 +34697,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 2
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r123(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r123(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -33947,7 +34741,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -33959,9 +34753,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -34011,6 +34803,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -34075,11 +34868,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r124(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r124(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -34116,7 +34912,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -34128,9 +34924,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -34180,6 +34974,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -34241,11 +35036,14 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
*=============================================================================*
- SUBROUTINE r125(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r125(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -34281,7 +35079,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -34293,9 +35091,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -34345,6 +35141,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -34453,16 +35250,15 @@ c INCLUDE 'params'
ENDDO
ENDDO
-c do iw = 1, nw-1
-c write(33,*) iw, wl(iw), sq(j,1,iw)
-c write(33,*) iw, wl(iw+1), sq(j,1,iw)
-c enddo
+ tpflag(j-1) = 1
+ tpflag(j) = 1
+ RETURN
END
*=============================================================================*
- SUBROUTINE r126(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE r126(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
@@ -34498,7 +35294,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -34510,9 +35306,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -34562,6 +35356,7 @@ c INCLUDE 'params'
* weighting functions
CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
REAL sq(kj,kz,kw)
* input/output:
@@ -34583,6 +35378,7 @@ c INCLUDE 'params'
REAL yg(kw)
REAL qy
+ integer mabs
**************** ClNO2 photodissociation
@@ -34590,28 +35386,56 @@ c INCLUDE 'params'
jlabel(j) = 'ClNO2 -> Cl + NO2'
* cross section from
-* JPL 2006
+* mabs = 1: JPL 2006, same as JPL-2011
+* mabs = 2: IUPAC 2007
- OPEN(UNIT=kin,FILE='DATAJ1/ABS/ClNO2.abs',STATUS='OLD')
- DO i = 1, 2
- READ(kin,*)
- ENDDO
- n = 26
- DO i = 1, n
- READ(kin,*) x1(i), y1(i)
- y1(i) = y1(i) * 1.E-20
- ENDDO
- CLOSE(kin)
-
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 0.,0.)
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, jlabel(j)
- STOP
- ENDIF
+ mabs = 1
+ if(mabs.eq.1) then
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/ClNO2.abs',STATUS='OLD')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 26
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1.E-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ elseif (mabs .eq. 2) then
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/ClNO2_iupac.abs',STATUS='OLD')
+ DO i = 1, 6
+ READ(kin,*)
+ ENDDO
+ n = 17
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ endif
* quantum yields assumed unity
@@ -34623,41 +35447,39 @@ c INCLUDE 'params'
ENDDO
ENDDO
+ tpflag(j) = 0
+
+ RETURN
END
-* This file contains the following subroutine, related to setting up the
-* vertical profiles of atmospheric variables
-* setaer
-
*=============================================================================*
- SUBROUTINE setaer(ipbl, zpbl, aod330,
- $ tau550, ssaaer, alpha,
- $ nz, z, nw, wl,
- $ dtaer, omaer, gaer, kout )
+ SUBROUTINE r127(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Set up an altitude profile of aerosols, and corresponding absorption =*
-*= optical depths, single scattering albedo, and asymmetry factor. =*
-*= Single scattering albedo and asymmetry factor can be selected for each =*
-*= input aerosol layer (do not have to correspond to working altitude =*
-*= grid). See loop 27. =*
+*= Provide product (cross section) x (quantum yield) for nitrosyl bromide =*
+*= BrNO -> Br + NO =*
+*= =*
+*= Cross section: from JPL 2006 =*
+*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
-*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
-*= grid =*
-*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
-*= DTAER - REAL, optical depth due to absorption by aerosols at each (O)=*
-*= altitude and wavelength =*
-*= OMAER - REAL, single scattering albedo due to aerosols at each (O)=*
-*= defined altitude and wavelength =*
-*= GAER - REAL, aerosol asymmetry factor at each defined altitude and (O)=*
-*= wavelength =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
@@ -34666,7 +35488,7 @@ c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
- INTEGER kout, kin
+ INTEGER kout, kin
* output
* PARAMETER(kout=6)
* input
@@ -34680,9 +35502,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -34715,206 +35535,129 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
+
REAL precis
PARAMETER(precis = 1.e-7)
- INTEGER kdata
- PARAMETER(kdata=51)
-
-* input:
+* input
- REAL wl(kw)
- REAL z(kz)
- INTEGER nz
INTEGER nw
+ REAL wl(kw), wc(kw)
- REAL tau550
- REAL ssaaer, alpha
-
-* output: (on converted grid)
- REAL dtaer(kz,kw), omaer(kz,kw), gaer(kz,kw)
-
-* local:
- REAL zd(kdata), aer(kdata)
- REAL cd(kdata), omd(kdata), gd(kdata)
- REAL womd(kdata), wgd(kdata)
-
- REAL cz(kz)
- REAL omz(kz)
- REAL gz(kz)
-
- REAL colold
-
- REAL wc, wscale
- INTEGER i, iw, nd
-
- REAL fsum
- EXTERNAL fsum
-
- REAL zpbl
- INTEGER ipbl
-
- REAL aod330
-
- REAL aodw(kw), ssaw(kw)
- REAL fract(kz)
+ INTEGER nz
-*_______________________________________________________________________
+ REAL tlev(kz)
+ REAL airden(kz)
-* Aerosol data from Elterman (1968)
-* These are vertical optical depths per km, in 1 km
-* intervals from 0 km to 50 km, at 340 nm.
-* This is one option. User can specify different data set.
+* weighting functions
- DATA aer/
- 1 2.40E-01,1.06E-01,4.56E-02,1.91E-02,1.01E-02,7.63E-03,
- 2 5.38E-03,5.00E-03,5.15E-03,4.94E-03,4.82E-03,4.51E-03,
- 3 4.74E-03,4.37E-03,4.28E-03,4.03E-03,3.83E-03,3.78E-03,
- 4 3.88E-03,3.08E-03,2.26E-03,1.64E-03,1.23E-03,9.45E-04,
- 5 7.49E-04,6.30E-04,5.50E-04,4.21E-04,3.22E-04,2.48E-04,
- 6 1.90E-04,1.45E-04,1.11E-04,8.51E-05,6.52E-05,5.00E-05,
- 7 3.83E-05,2.93E-05,2.25E-05,1.72E-05,1.32E-05,1.01E-05,
- 8 7.72E-06,5.91E-06,4.53E-06,3.46E-06,2.66E-06,2.04E-06,
- 9 1.56E-06,1.19E-06,9.14E-07/
-*_______________________________________________________________________
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+* input/output:
-* Altitudes corresponding to Elterman profile, from bottom to top:
+ INTEGER j
- WRITE(kout,*)'aerosols: Elterman (1968) continental profile'
- nd = 51
- DO 22, i = 1, nd
- zd(i) = FLOAT(i-1)
- 22 CONTINUE
+* data arrays
-* assume these are point values (at each level), so find column
-* increments
+ INTEGER kdata
+ PARAMETER(kdata=150)
- DO 27, i = 1, nd - 1
- cd(i) = (aer(i+1) + aer(i)) / 2.
- omd(i) = ssaaer
- gd(i) = .61
- 27 CONTINUE
+ INTEGER iw
+ INTEGER i, n
+ REAL x1(kdata)
+ REAL y1(kdata)
+ INTEGER ierr
-*********** end data input.
+* local
-* Compute integrals and averages over grid layers:
-* for g and omega, use averages weighted by optical depth
+ REAL yg(kw)
+ REAL qy
- DO 29, i = 1, nd-1
- womd(i) = omd(i) * cd(i)
- wgd(i) = gd(i) * cd(i)
- 29 CONTINUE
- CALL inter3(nz,z,cz, nd,zd,cd, 1)
- CALL inter3(nz,z,omz, nd, zd,womd, 1)
- CALL inter3(nz,z,gz , nd, zd,wgd, 1)
- DO 30, i = 1, nz-1
- IF (cz(i) .GT. 0.) THEN
- omz(i) = omz(i)/cz(i)
- gz(i) = gz(i) /cz(i)
- ELSE
- omz(i) = 1.
- gz(i) = 0.
- ENDIF
- 30 CONTINUE
+******************** BrNO photodissociation
-* old column at 340 nm
-* (minimum value is pzero = 10./largest)
+ j = j+1
+ jlabel(j) = 'BrNO -> Br + NO'
- colold = MAX(fsum(nz-1,cz),pzero)
+* cross section from
+* JPL 2006
-* scale with new column tau at 550 nm
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/BrNO.abs',STATUS='OLD')
+ DO i = 1, 3
+ READ(kin,*)
+ ENDDO
+ n = 27
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ ENDDO
+ CLOSE(kin)
- IF(tau550 .GT. nzero) THEN
- DO i = 1, nz-1
- cz(i) = cz(i) * (tau550/colold) * (550./340.)**alpha
- ENDDO
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
ENDIF
-* assign at all wavelengths
-* (can move wavelength loop outside if want to vary with wavelength)
-
- DO 50, iw = 1, nw - 1
- wc = (wl(iw)+wl(iw+1))/2.
-
-* Elterman's data are for 340 nm, so assume optical depth scales
-* inversely with first power of wavelength.
-
- wscale = (340./wc)**alpha
-
-* optical depths:
-
- DO 40, i = 1, nz - 1
- dtaer(i,iw) = cz(i) * wscale
- omaer(i,iw) = omz(i)
- gaer(i,iw) = gz(i)
- 40 CONTINUE
- 50 CONTINUE
-
-*! overwrite for pbl:
-
- IF(ipbl .GT. 0) THEN
- write (*,*) 'pbl aerosols, aod330 = ', aod330
-
-* create wavelength-dependent optical depth and single scattering albedo:
-
- DO iw = 1, nw-1
- wc = (wl(iw)+wl(iw+1))/2.
- aodw(iw) = aod330*(wc/330.)**(-1.0)
- IF(wc .LT. 400.) THEN
- ssaw(iw) = 0.6
- ELSE
- ssaw(iw) = 0.9
- ENDIF
- ENDDO
+* quantum yields assumed unity
-* divide aod among pbl layers, overwrite Elterman profile in pbl
+ qy = 1.
- DO i = 1, ipbl
- fract(i) = (z(i+1) - z(i))/zpbl
- ENDDO
-
- DO iw = 1, nw-1
- DO i = 1, ipbl
- dtaer(i, iw) = aodw(iw) * fract(i)
- omaer(i,iw) = ssaw(iw)
- ENDDO
- ENDDO
+ DO iw = 1, nw-1
+ DO i = 1, nz
+ sq(j,i,iw) = qy * yg(iw)
+ ENDDO
+ ENDDO
- ENDIF
-*_______________________________________________________________________
+ tpflag(j) = 0
RETURN
END
*=============================================================================*
- SUBROUTINE setalb(albnew,nw,wl,albedo)
+ SUBROUTINE r128(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Set the albedo of the surface. The albedo is assumed to be Lambertian, =*
-*= i.e., the reflected light is isotropic, and independent of direction =*
-*= of incidence of light. Albedo can be chosen to be wavelength dependent. =*
+*= Provide product (cross section) x (quantum yield) for bromine nitritee =*
+*= BrNO2 -> Br + NO2 =*
+*= =*
+*= Cross section: from JPL 2006 =*
+*= Quantum yield: Assumed to be unity =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
-*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
-*= wavelength grid =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
-*= ALBEDO - REAL, surface albedo at each specified wavelength (O)=*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
+
c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
- INTEGER kout, kin
+ INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -34926,9 +35669,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -34961,72 +35702,129 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
+
REAL precis
PARAMETER(precis = 1.e-7)
-* input: (wavelength working grid data)
+* input
INTEGER nw
- REAL wl(kw)
+ REAL wl(kw), wc(kw)
- REAL albnew
+ INTEGER nz
-* output:
- REAL albedo(kw)
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=150)
-* local:
INTEGER iw
-*_______________________________________________________________________
+ INTEGER i, n
+ REAL x1(kdata)
+ REAL y1(kdata)
+ INTEGER ierr
- DO 10, iw = 1, nw - 1
- albedo(iw) = albnew
- 10 CONTINUE
+* local
-* alternatively, can input wavelenght-dependent values if avaialble.
-*_______________________________________________________________________
+ REAL yg(kw)
+ REAL qy
+
+******************** BrNO2 photodissociation
+
+ j = j+1
+ jlabel(j) = 'BrNO2 -> Br + NO2'
+
+* cross section from
+* IUPAC (vol III) 2007
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/BrNO2.abs',STATUS='OLD')
+ DO i = 1, 6
+ READ(kin,*)
+ ENDDO
+ n = 54
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields assumed unity
+
+ qy = 1.
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+ sq(j,i,iw) = qy * yg(iw)
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
RETURN
END
-*======================================================================*
-
- SUBROUTINE setcld(nz,z,nw,wl,
- $ lwc, nlevel,
- $ dtcld,omcld,gcld)
+*=============================================================================*
+ SUBROUTINE r129(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Set cloud properties for each specified altitude layer. Properties =*
-*= may be wavelength dependent. =*
-*= Assumes horizontally infinite homogeneous cloud layers.
+*= Provide product (cross section) x (quantum yield) for bromine nitrite =*
+*= BrONO -> Br + NO2 =*
+*= BrONO -> BrO + NO =*
+*= =*
+*= Cross section: from IUPAC (vol.3) =*
+*= Quantum yield: Assumed to be 0.5 for each channel =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
-*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
-*= grid =*
-*= Z - REAL, specified altitude working grid (km) (I)=*
-*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
-*= wavelength grid =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
-*= DTCLD - REAL, optical depth due to absorption by clouds at each (O)=*
-*= altitude and wavelength =*
-*= OMCLD - REAL, single scattering albedo due to clouds at each (O)=*
-*= defined altitude and wavelength =*
-*= GCLD - REAL, cloud asymmetry factor at each defined altitude and (O)=*
-*= wavelength =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
-c INCLUDE 'params'
+C INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
- INTEGER kout, kin
+ INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -35038,9 +35836,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -35073,172 +35869,121 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
+
REAL precis
PARAMETER(precis = 1.e-7)
- INTEGER kdata
- PARAMETER(kdata=151)
+* input
-***** input
+ INTEGER nw
+ REAL wl(kw), wc(kw)
-* (grids)
- REAL wl(kw)
- REAL z(kz)
INTEGER nz
- INTEGER nw
-* new total cloud optical depth:
+ REAL tlev(kz)
+ REAL airden(kz)
- REAL taucld
-C REAL zbase, ztop
-C LWC is the liquid water content (!! kg/m3 !!) on the calling model
-C grid (which has NLEVEL points: Z(1:NLEVEL) = AZ(*)
- REAL lwc(*)
- INTEGER nlevel
+* weighting functions
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
-***** Output:
+* input/output:
- REAL dtcld(kz,kw), omcld(kz,kw), gcld(kz,kw)
+ INTEGER j
-***** specified default data:
+* data arrays
- REAL zd(kdata), cd(kdata), omd(kdata), gd(kdata)
- REAL womd(kdata), wgd(kdata)
- REAL cldold
+ INTEGER kdata
+ PARAMETER(kdata=150)
-* other:
+ INTEGER iw
+ INTEGER i, n
+ REAL x1(kdata)
+ REAL y1(kdata)
+ INTEGER ierr
- REAL cz(kz)
- REAL omz(kz)
- REAL gz(kz)
- INTEGER i, iw, n
- REAL scale
+* local
-* External functions:
- REAL fsum
- EXTERNAL fsum
-*_______________________________________________________________________
+ REAL yg(kw)
+ REAL qy1, qy2
-* Set up clouds:
-* All clouds are assumed to be infinite homogeneous layers
-* Can have different clouds at different altitudes.
-* If multiple cloud layers are specified, non-cloudy layers
-* between them (if any) must be assigned zero optical depth.
-* Set cloud optical properties:
-* cd(i) = optical depth of i_th cloudy layer
-* omd(i) = singel scattering albedo of i_th cloudy layer
-* gd(i) = asymmetry factorof i_th cloudy layer
-* Cloud top and bottom can be set to any height zd(i), but if they don't
-* match the z-grid (see subroutine gridz.f), they will be interpolated to
-* the z-grid.
+******************** BrONO photodissociation
-* Example: set two separate cloudy layers:
-* cloud 1:
-* base = 4 km
-* top = 7 km
-* optical depth = 20. (6.67 per km)
-* single scattering albedo = 0.9999
-* asymmetry factor = 0.85
-* cloud 2:
-* base = 9 km
-* top = 11 km
-* optical depth = 5. (2.50 per km)
-* single scattering albedo = 0.99999
-* asymmetry factor = 0.85
+ j = j+1
+ jlabel(j) = 'BrONO -> Br + NO2'
+ j = j+1
+ jlabel(j) = 'BrONO -> BrO + NO'
- n = nlevel + 1
- if (n .gt. kdata) stop "SETCLD: not enough memory: KDATA"
- zd(1) = 0.
- do 110, i = 2, n
- zd(i) = 0.5*( z(i-1) + z(i) )
-110 continue
+* cross section from
+* IUPAC (vol III) 2007
-C calculate cloud optical properties
- do 120, i = 1, nlevel
-C
-C reference: Fouquart et al., Rev. Geophys., 1990
-C TAU = 3/2 LWC*DZ / (RHOWATER * Reff)
-C RHOWATER = 1E3 kg/m3
-C Reff = (11 w + 4) 1E-6
-C w = LWC * 1E+3 (in g/cm3, since LWC is given in kg/m3)
-C
- cd(i) = 1.5 * ( lwc(i) * 1E3*(zd(i+1) - zd(i)) )
- + / ( 1E3 * (11.*lwc(i)*1E+3+4.) * 1E-6)
- omd(i) = .9999
- gd(i) = .85
-C print '(A,I5,99E12.5)', "I,TAU,LWC,REFF(um)"
-C + , i, cd(i), lwc(i)
-C + , ((11.*lwc(i)*1E+3+4.))
-120 continue
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/BrONO.abs',STATUS='OLD')
+ DO i = 1, 8
+ READ(kin,*)
+ ENDDO
+ n = 32
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ ENDDO
+ CLOSE(kin)
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
-******************
-* compute integrals and averages over grid layers:
-* for g and omega, use averages weighted by optical depth
+* quantum yields assumed unity
- DO 10, i = 1, n-1
- womd(i) = omd(i) * cd(i)
- wgd(i) = gd(i) * cd(i)
- 10 CONTINUE
- CALL inter3(nz,z,cz, n, zd,cd, 0)
- CALL inter3(nz,z,omz, n, zd,womd, 0)
- CALL inter3(nz,z,gz , n, zd,wgd, 0)
+ qy1 = 0.5
+ qy2 = 0.5
- DO 15, i = 1, nz-1
- IF (cz(i) .GT. 0.) THEN
- omz(i) = omz(i)/cz(i)
- gz(i) = gz(i) /cz(i)
- ELSE
- omz(i) = 1.
- gz(i) = 0.
- ENDIF
- 15 CONTINUE
-
-* assign at all wavelengths
-* (can move wavelength loop outside if want to vary with wavelength)
+ DO iw = 1, nw-1
+ DO i = 1, nz
+ sq(j-1,i,iw) = qy1 * yg(iw)
+ sq(j,i,iw) = qy2 * yg(iw)
+ ENDDO
+ ENDDO
- DO 20, iw = 1, nw-1
- DO 25, i = 1, nz-1
- dtcld(i,iw) = cz(i)
- omcld(i,iw) = omz(i)
- gcld (i,iw) = gz(i)
- 25 CONTINUE
- 20 CONTINUE
-*_______________________________________________________________________
+ tpflag(j-1) = 0
+ tpflag(j) = 0
RETURN
END
+
*=============================================================================*
- SUBROUTINE setno2(ipbl, zpbl, xpbl,
- $ no2new, nz, z, nw, wl, no2xs,
- $ tlay, dcol,
- $ dtno2)
+ SUBROUTINE r130(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Set up an altitude profile of NO2 molecules, and corresponding absorption=*
-*= optical depths. Subroutine includes a shape-conserving scaling method =*
-*= that allows scaling of the entire profile to a given overhead NO2 =*
-*= column amount. =*
+*= Provide product (cross section) x (quantum yield) for
+*= HOCl -> HO + Cl =*
+*= Cross section: from IUPAC (vol.3) =*
+*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
-*= NO2NEW - REAL, overhead NO2 column amount (molec/cm^2) to which (I)=*
-*= profile should be scaled. If NO2NEW < 0, no scaling is done =*
-*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
-*= grid =*
-*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
-*= NO2XS - REAL, molecular absoprtion cross section (cm^2) of O2 at (I)=*
-*= each specified wavelength =*
-*= TLAY - REAL, temperature (K) at each specified altitude layer (I)=*
-*= DTNO2 - REAL, optical depth due to NO2 absorption at each (O)=*
-*= specified altitude at each specified wavelength =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
@@ -35247,9 +35992,9 @@ c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
- INTEGER kout, kin
+ INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -35261,9 +36006,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -35296,167 +36039,116 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
+
REAL precis
PARAMETER(precis = 1.e-7)
- INTEGER kdata
- PARAMETER(kdata=51)
-
-********
-* input:
-********
-
-* grids:
+* input
- REAL wl(kw)
- REAL z(kz)
INTEGER nw
- INTEGER nz
- REAL no2new
-
-* mid-layer temperature, layer air column
-
- REAL tlay(kz), dcol(kz)
-
-********
-* output:
-********
-
- REAL dtno2(kz,kw)
-
-********
-* local:
-********
-
-* absorption cross sections
-
- REAL no2xs(kz,kw)
- REAL cz(kz)
-
-* nitrogen dioxide profile data:
-
- REAL zd(kdata), no2(kdata)
- REAL cd(kdata)
- REAL hscale
- REAL colold, scale
- REAL sno2
- REAL zpbl, xpbl
- INTEGER ipbl
-
-* other:
-
- INTEGER i, l, nd
-
-
-********
-* External functions:
-********
-
- REAL fsum
- EXTERNAL fsum
+ REAL wl(kw), wc(kw)
-*_______________________________________________________________________
-* Data input:
+ INTEGER nz
-* Example: set to 1 ppb in lowest 1 km, set to zero above that.
-* - do by specifying concentration at 3 altitudes.
+ REAL tlev(kz)
+ REAL airden(kz)
- nd = 3
- zd(1) = 0.
- no2(1) = 1. * 2.69e10
+* weighting functions
- zd(2) = 1.
- no2(2) = 1. * 2.69e10
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
- zd(3) = zd(2)* 1.000001
- no2(3) = 10./largest
+* input/output:
-* compute column increments (alternatively, can specify these directly)
+ INTEGER j
- DO 11, i = 1, nd - 1
- cd(i) = (no2(i+1)+no2(i)) * 1.E5 * (zd(i+1)-zd(i)) / 2.
- 11 CONTINUE
+* data arrays
-* Include exponential tail integral from top level to infinity.
-* fold tail integral into top layer
-* specify scale height near top of data (use ozone value)
+ INTEGER kdata
+ PARAMETER(kdata=150)
- hscale = 4.50e5
- cd(nd-1) = cd(nd-1) + hscale * no2(nd)
+ INTEGER iw
+ INTEGER i, n
+ REAL x1(kdata)
+ REAL y1(kdata)
+ INTEGER ierr
-***********
-*********** end data input.
+* local
-* Compute column increments and total column on standard z-grid.
+ REAL yg(kw)
+ REAL qy
- CALL inter3(nz,z,cz, nd,zd,cd, 1)
+******************** HOCl photodissociation
-**** Scaling of vertical profile by ratio of new to old column:
-* If old column is near zero (less than 1 molec cm-2),
-* use constant mixing ratio profile (nominal 1 ppt before scaling)
-* to avoid numerical problems when scaling.
+ j = j + 1
+ jlabel(j) = 'HOCl -> HO + Cl'
- IF(fsum(nz-1,cz) .LT. 1.) THEN
- DO i = 1, nz-1
- cz(i) = 1.E-12 * dcol(i)
- ENDDO
- ENDIF
- colold = fsum(nz-1, cz)
- scale = 2.687e16 * no2new / colold
+* cross section from
+* IUPAC (vol III) 2007
- DO i = 1, nz-1
- cz(i) = cz(i) * scale
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/HOCl.abs',STATUS='OLD')
+ DO i = 1, 7
+ READ(kin,*)
+ ENDDO
+ n = 111
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
ENDDO
+ CLOSE(kin)
-*! overwrite for specified pbl height
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
- IF(ipbl .GT. 0) THEN
- write(*,*) 'pbl NO2 = ', xpbl, ' ppb'
+* quantum yields assumed unity
- DO i = 1, nz-1
- IF (i .LE. ipbl) THEN
- cz(i) = xpbl*1.E-9 * dcol(i)
- ELSE
- cz(i) = 0.
- ENDIF
- ENDDO
- ENDIF
+ qy = 1
-************************************
-* calculate optical depth for each layer. Output: dtno2(kz,kw)
+ DO iw = 1, nw-1
+ DO i = 1, nz
+ sq(j,i,iw) = qy * yg(iw)
+ ENDDO
+ ENDDO
-98 continue
- DO 20, l = 1, nw-1
- DO 10, i = 1, nz-1
- dtno2(i,l) = cz(i)*no2xs(i,l)
- 10 CONTINUE
- 20 CONTINUE
-*_______________________________________________________________________
+ tpflag(j) = 0
RETURN
END
+
*=============================================================================*
- SUBROUTINE seto2(nz, z, nw, wl, cz, o2xs1, dto2)
+ SUBROUTINE r131(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Set up an altitude profile of air molecules. Subroutine includes a =*
-*= shape-conserving scaling method that allows scaling of the entire =*
-*= profile to a given sea-level pressure. =*
+*= Provide product (cross section) x (quantum yield) for
+*= NOCl -> NO + Cl =*
+*= Cross section: from IUPAC (vol.3) =*
+*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
-*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
-*= grid =*
-*= Z - REAL, specified altitude working grid (km) (I)=*
-*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
-*= wavelength grid =*
-*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
-*= working wavelength grid =*
-*= and each specified wavelength =*
-*= CZ - REAL, number of air molecules per cm^2 at each specified (O)=*
-*= altitude layer =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
@@ -35465,9 +36157,9 @@ c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
- INTEGER kout, kin
+ INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -35479,9 +36171,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -35514,90 +36204,235 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
+
REAL precis
PARAMETER(precis = 1.e-7)
-* input: (grids)
+* input
- REAL wl(kw)
- REAL z(kz)
- INTEGER iw, nw
- INTEGER iz, nz
- REAL cz(kz)
- REAL o2xs1(kw)
+ INTEGER nw
+ REAL wl(kw), wc(kw)
-* output:
-* O2 absorption optical depth per layer at each wavelength
+ INTEGER nz
- REAL dto2(kz,kw)
+ REAL tlev(kz)
+ REAL airden(kz)
-*_______________________________________________________________________
-* Assumes that O2 = 20.95 % of air density. If desire different O2
-* profile (e.g. for upper atmosphere) then can load it here.
+* weighting functions
- DO iz = 1, nz
- DO iw =1, nw - 1
- dto2(iz,iw) = 0.2095 * cz(iz) * o2xs1(iw)
- ENDDO
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=150)
+
+ INTEGER iw
+ INTEGER i, n, ii
+ REAL x1(kdata), y1(kdata)
+ integer nn
+ REAL x223(kdata),x243(kdata),x263(kdata),x298(kdata),
+ $ x323(kdata), x343(kdata)
+ REAL y223(kdata),y243(kdata),y263(kdata),y298(kdata),
+ $ y323(kdata), y343(kdata)
+ INTEGER ierr
+
+* local
+
+ REAL yg223(kw),yg243(kw),yg263(kw),yg298(kw),
+ $ yg323(kw), yg343(kw)
+ REAL qy, sig
+
+******************** NOCl photodissociation
+
+ j = j + 1
+ jlabel(j) = 'NOCl -> NO + Cl'
+
+* cross section from
+* IUPAC (vol III) 2007
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/NOCl.abs',STATUS='OLD')
+ DO i = 1, 7
+ READ(kin,*)
ENDDO
+ n = 80
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y223(i) = y1(i)
+ y243(i) = y1(i)
+ y263(i) = y1(i)
+ y298(i) = y1(i)
+ y323(i) = y1(i)
+ y343(i) = y1(i)
+
+ x223(i) = x1(i)
+ x243(i) = x1(i)
+ x263(i) = x1(i)
+ x298(i) = x1(i)
+ x323(i) = x1(i)
+ x343(i) = x1(i)
+
+ ENDDO
+ READ(kin,*)
+ n = 61
+ do i = 1, n
+ ii = i + 80
+ read(kin,*) x1(ii), y223(ii), y243(ii), y263(ii),
+ $ y298(ii), y323(ii), y343(ii)
-*_______________________________________________________________________
+ x223(ii) = x1(ii)
+ x243(ii) = x1(ii)
+ x263(ii) = x1(ii)
+ x298(ii) = x1(ii)
+ x323(ii) = x1(ii)
+ x343(ii) = x1(ii)
+
+ enddo
+ n = ii
+ CLOSE(kin)
+
+ nn = n
+ CALL addpnt(x223,y223,kdata,nn,x223(1)*(1.-deltax),0.)
+ CALL addpnt(x223,y223,kdata,nn, 0.,0.)
+ CALL addpnt(x223,y223,kdata,nn,x223(nn)*(1.+deltax),0.)
+ CALL addpnt(x223,y223,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg223,nn,x223,y223,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ nn = n
+ CALL addpnt(x243,y243,kdata,nn,x243(1)*(1.-deltax),0.)
+ CALL addpnt(x243,y243,kdata,nn, 0.,0.)
+ CALL addpnt(x243,y243,kdata,nn,x243(nn)*(1.+deltax),0.)
+ CALL addpnt(x243,y243,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg243,nn,x243,y243,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ nn = n
+ CALL addpnt(x263,y263,kdata,nn,x263(1)*(1.-deltax),0.)
+ CALL addpnt(x263,y263,kdata,nn, 0.,0.)
+ CALL addpnt(x263,y263,kdata,nn,x263(nn)*(1.+deltax),0.)
+ CALL addpnt(x263,y263,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg263,nn,x263,y263,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ nn = n
+ CALL addpnt(x298,y298,kdata,nn,x298(1)*(1.-deltax),0.)
+ CALL addpnt(x298,y298,kdata,nn, 0.,0.)
+ CALL addpnt(x298,y298,kdata,nn,x298(nn)*(1.+deltax),0.)
+ CALL addpnt(x298,y298,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg298,nn,x298,y298,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ nn = n
+ CALL addpnt(x323,y323,kdata,nn,x323(1)*(1.-deltax),0.)
+ CALL addpnt(x323,y323,kdata,nn, 0.,0.)
+ CALL addpnt(x323,y323,kdata,nn,x323(nn)*(1.+deltax),0.)
+ CALL addpnt(x323,y323,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg323,nn,x323,y323,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ nn = n
+ CALL addpnt(x343,y343,kdata,nn,x343(1)*(1.-deltax),0.)
+ CALL addpnt(x343,y343,kdata,nn, 0.,0.)
+ CALL addpnt(x343,y343,kdata,nn,x343(nn)*(1.+deltax),0.)
+ CALL addpnt(x343,y343,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg343,nn,x343,y343,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields assumed unity
+
+ qy = 1
+ sig = 0.
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ if(tlev(i) .le. 223.) then
+ sig = yg223(iw)
+
+ elseif (tlev(i) .gt. 223. .and. tlev(i) .le. 243.) then
+ sig = yg223(iw) +
+ $ (yg243(iw) - yg223(iw))*(tlev(i) - 223.)/20.
+
+ elseif (tlev(i) .gt. 243. .and. tlev(i) .le. 263.) then
+ sig = yg243(iw) +
+ $ (yg263(iw) - yg243(iw))*(tlev(i) - 243.)/20.
+
+ elseif (tlev(i) .gt. 263. .and. tlev(i) .le. 298.) then
+ sig = yg263(iw) +
+ $ (yg298(iw) - yg263(iw))*(tlev(i) - 263.)/35.
+
+ elseif (tlev(i) .gt. 298. .and. tlev(i) .le. 323.) then
+ sig = yg298(iw) +
+ $ (yg323(iw) - yg298(iw))*(tlev(i) - 298.)/25.
+
+ elseif (tlev(i) .gt. 323. .and. tlev(i) .le. 343.) then
+ sig = yg323(iw) +
+ $ (yg343(iw) - yg323(iw))*(tlev(i) - 323.)/20.
+
+ endif
+
+ sq(j,i,iw) = qy * sig
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 1
RETURN
END
- SUBROUTINE setsnw(nz,z,nw,wl,dtsnw,omsnw,gsnw,kout)
+
+*=============================================================================*
+
+ SUBROUTINE r132(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Set optical and physical properties for snowpack. =*
-*= Currently for wavelength-independent properties. =*
-*= Subroutine outputs spectral quantities. =*
-*= Lee-Taylor, J., and S. Madronich (2002), Calculation of actinic fluxes =*
-*= with a coupled atmosphere-snow radiative transfer model, J. Geophys. =*
-*= Res., 107(D24) 4796 (2002) doi:10.1029/2002JD002084 =*
+*= Provide product (cross section) x (quantum yield) for
+*= OClO -> Products =*
+*= Cross section: from Wahner et al., J. Phys. Chem. 91, 2734, 1987 =*
+*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
-*= USER-DEFINED VARIABLES: =*
-*= zs - height (km) of snow layer boundary above GROUND level =*
-*= snwdens - density (g/cm3) =*
-*= ksct - mass-specific scattering coefficient (m2/kg) =*
-*= csoot - soot content (ng Carbon / g snow) =*
-*= snow - (=T/F) switch for presence of snow
-*= =*
*= PARAMETERS: =*
-*= nz - INTEGER, number of specified altitude levels in the working (I)=*
-*= grid =*
-*= z - REAL, specified altitude working grid (km) (I)=*
-*= nw - INTEGER, number of specified intervals + 1 in working (I)=*
-*= wavelength grid =*
-*= wl - REAL, vector of lower limits of wavelength intervals in (I)=*
-*= working wavelength grid =*
-*= dtsnw - REAL, optical depth due to absorption by snow at each (O)=*
-*= altitude and wavelength =*
-*= omsnw - REAL, single scattering albedo due to snow at each (O)=*
-*= defined altitude and wavelength =*
-*= gsnw - REAL, snow asymmetry factor at each defined altitude and (O)=*
-*= wavelength =*
-*= rabs - absorption coefficient of snow, wavelength-dependent =*
-*= rsct - scattering coefficient of snow, assume wavelength-independent =*
-*-----------------------------------------------------------------------------*
-*= EDIT HISTORY: =*
-*= 10/00 adapted from setcld.f, Julia Lee-Taylor, ACD, NCAR =*
-*-----------------------------------------------------------------------------*
-*= This program is free software; you can redistribute it and/or modify =*
-*= it under the terms of the GNU General Public License as published by the =*
-*= Free Software Foundation; either version 2 of the license, or (at your =*
-*= option) any later version. =*
-*= The TUV package is distributed in the hope that it will be useful, but =*
-*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
-*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
-*= License for more details. =*
-*= To obtain a copy of the GNU General Public License, write to: =*
-*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
-*-----------------------------------------------------------------------------*
-*= To contact the authors, please mail to: =*
-*= Jula Lee-Taylor, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
-*= send email to: julial@ucar.edu =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
@@ -35606,7 +36441,7 @@ c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
- INTEGER kout, kin
+ INTEGER kout, kin
* output
* PARAMETER(kout=6)
* input
@@ -35620,9 +36455,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -35655,182 +36488,175 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
+
REAL precis
PARAMETER(precis = 1.e-7)
- INTEGER kdata
- PARAMETER(kdata=51)
+* input
-* input: (grids)
- REAL wl(kw)
- REAL z(kz)
- INTEGER nz
INTEGER nw
+ REAL wl(kw), wc(kw)
-* Output:
- REAL dtsnw(kz,kw), omsnw(kz,kw), gsnw(kz,kw)
+ INTEGER nz
-* local:
+ REAL tlev(kz)
+ REAL airden(kz)
-* specified data:
- REAL zs(kdata),dzs
- REAL cd(kdata), omd(kdata), gd
- REAL snwdens(kdata) ! snwdens = snow density, g/cm3
- REAL csoot(kdata) ! conc of elemental carbon, ng/g
- REAL r_ice(kw),rsoot
- REAL womd(kdata), wgd(kdata)
- REAL rsct(kdata),ksct(kdata),rabs(kdata)
+* weighting functions
-* other:
- REAL cz(kz),omz(kz),gz(kz)
- INTEGER i,is,iw,iz,nsl
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
-* External functions:
- REAL fsum
- EXTERNAL fsum
-*--------------------------------------------------------------------------
-* SNOW PROPERTIES: USER-DEFINED
-*--------------------------------------------------------------------------
-** define "number of snow layers + 1" (0 = no snow, 2 = single snow layer)
- nsl = 0
+* input/output:
- IF(nsl.GE.2)THEN
-** define snow grid, zs(ns), in km above GROUND level
-* NOTE: to get good vertical resolution, subroutine gridz (in grids.f) should
-* be modified to include small (1cm - 1mm) layers near snowpack top.
+ INTEGER j
- zs(1) = 0.0
- zs(2) = 0.001
+* data arrays
-** define snow scattering coefficient, ksct, m2/kg snow
-* melting midlatitude maritime (mountain) snow, ksct = 1-5 m2/kg_snow
-* warmer polar coastal/maritime snow, ksct = 6-13 m2/kg_snow
-* cold dry polar/tundra snow, ksct = 20-30 m2/kg_snow
-* Fisher, King and Lee-Taylor (2005), JGR 110(D21301) doi:10.1029/2005JD005963
+ INTEGER kdata
+ PARAMETER(kdata=2000)
- ksct(1) = 25. ! m2.kg-1 snow
+ INTEGER iw
+ INTEGER i, n
+ REAL x1(kdata), y1(kdata)
+ integer nn, n204, n296, n378
+ REAL x204(kdata),x296(kdata),x378(kdata)
+ REAL y204(kdata),y296(kdata),y378(kdata)
-** define snow density, snwdens, g/cm3
+ INTEGER ierr
- snwdens(1) = 0.4 ! g/cm3
+* local
-** define soot content, csoot, ng/g elemental carbon
+ REAL yg204(kw),yg296(kw),yg378(kw)
+ REAL qy, sig
- csoot(1) = 0. ! ng/g elemental carbon
+******************** NOCl photodissociation
-*----------------------------------------------------------------------------
-* SNOW PROPERTIES: FROM LITERATURE
-*--------------------------------------------------------------------------
-* read absorption coefficients
- CALL rdice_acff(nw,wl,r_ice) ! cm^-1 ice
+ j = j + 1
+ jlabel(j) = 'OClO -> Products'
-* absorption due to soot, assume wavelength-independent
-* rsoot ~ 10 m2/gC @500nm : Warren & Wiscombe, Nature 313,467-470 (1985)
- rsoot = 10. ! m2/gC
+* cross section from
+*A. Wahner, G.S. tyndall, A.R. Ravishankara, J. Phys. Chem., 91, 2734, (1987).
+*Supplementary Data, as quoted at:
+*http://www.atmosphere.mpg.de/enid/26b4b5172008b02407b2e47f08de2fa1,0/Spectra/Introduction_1rr.html
-* asymmetry factor : Wiscombe & Warren, J. Atmos. Sci, 37, 2712-2733 (1980)
- gd = 0.89
-*----------------------------------------------------------------------------
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/OClO.abs',STATUS='OLD')
+ DO i = 1, 6
+ READ(kin,*)
+ ENDDO
+ n204 = 1074-6
+ DO i = 1, n204
+ READ(kin,*) x204(i), y204(i)
+ ENDDO
-* loop snow layers, assigning optical properties at each wavelength
- DO 17, iw = 1, nw-1
- DO 11 is = 1,nsl-1
- rsct(is)=ksct(is)*snwdens(is)*1.e+3 ! m-1
- rsct(is)=rsct(is)*(zs(is+1)-zs(is))*1.e+3 ! no units
+ READ(kin,*)
+ n296 = 1067
+ do i = 1, n296
+ read(kin,*) x296(i), y296(i)
+ enddo
- rabs(is) = (r_ice(iw)/0.9177*1.e5 + rsoot*csoot(is))
- $ * snwdens(is)*(zs(is+1)-zs(is)) ! no units
-
- cd(is) = rsct(is) + rabs(is)
- omd(is)= rsct(is) / cd(is)
-
- if(iw.EQ.1)then
- print*,"Snowpack: is =",is,"; zs =",zs(is)
- PRINT*," ksct =", ksct(is)
- PRINT*," density =",snwdens(is)
- PRINT*," csoot =",csoot(is)
- PRINT*, 'cd = ',cd(is),' omd = ',omd(is),' gd = ',gd
- WRITE(kout,*)'snwdens = ',snwdens,' g/cm3'
- WRITE(kout,*)'ksct_snow = ',ksct(is),' m2.kg-1'
- WRITE(kout,*)'soot = ',csoot(is),' ng/g'
- WRITE(kout,*)'cd = ',cd(is),'omd = ',omd(is),'gd = ',gd
- endif
+ read(kin,*)
+ n378 = 1068
+ do i = 1, n378
+ read(kin,*) x378(i), y378(i)
+ enddo
-* compute integrals and averages over snow layers:
-* for g and omega, use averages weighted by optical depth
- womd(is) = omd(is) * cd(is)
- wgd(is) = gd * cd(is)
- 11 CONTINUE
+ CLOSE(kin)
-* interpolate snow layers onto TUV altitude grid (gridz)
- CALL inter3(nz,z,cz, nsl,zs,cd, 0)
- CALL inter3(nz,z,omz,nsl,zs,womd, 0)
- CALL inter3(nz,z,gz ,nsl,zs,wgd, 0)
+ nn = n204
+ CALL addpnt(x204,y204,kdata,nn,x204(1)*(1.-deltax),0.)
+ CALL addpnt(x204,y204,kdata,nn, 0.,0.)
+ CALL addpnt(x204,y204,kdata,nn,x204(nn)*(1.+deltax),0.)
+ CALL addpnt(x204,y204,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg204,nn,x204,y204,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
- DO 15, iz = 1, nz-1
- IF (cz(iz) .GT. 0.) THEN
- omz(iz) = omz(iz)/cz(iz)
- gz(iz) = gz(iz) /cz(iz)
- ELSE
- omz(iz) = 0.
- gz(iz) = 0.
- ENDIF
- dtsnw(iz,iw) = cz(iz)
- omsnw(iz,iw) = omz(iz)
- gsnw(iz,iw) = gz(iz)
- 15 CONTINUE
- 17 CONTINUE
+ nn = n296
+ CALL addpnt(x296,y296,kdata,nn,x296(1)*(1.-deltax),0.)
+ CALL addpnt(x296,y296,kdata,nn, 0.,0.)
+ CALL addpnt(x296,y296,kdata,nn,x296(nn)*(1.+deltax),0.)
+ CALL addpnt(x296,y296,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg296,nn,x296,y296,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
- PRINT*,"Snowpack top: zs =",zs(nsl)
+ nn = n378
+ CALL addpnt(x378,y378,kdata,nn,x378(1)*(1.-deltax),0.)
+ CALL addpnt(x378,y378,kdata,nn, 0.,0.)
+ CALL addpnt(x378,y378,kdata,nn,x378(nn)*(1.+deltax),0.)
+ CALL addpnt(x378,y378,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg378,nn,x378,y378,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
- ELSE ! no snow
- DO 16, iz = 1, nz-1
- cz(iz) = 0.
- omz(iz) = 1.
- gz(iz) = 0.
- DO 18, iw = 1, nw-1
- dtsnw(iz,iw) = cz(iz)
- omsnw(iz,iw) = omz(iz)
- gsnw(iz,iw) = gz(iz)
- 18 CONTINUE
- 16 CONTINUE
- ENDIF ! snow exists
+* quantum yields assumed unity
+
+ qy = 1
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ if(tlev(i) .le. 204.) then
+ sig = yg204(iw)
+
+ elseif (tlev(i) .gt. 204. .and. tlev(i) .le. 296.) then
+ sig = yg204(iw) +
+ $ (yg296(iw) - yg204(iw))*(tlev(i) - 204.)/92.
+
+ elseif (tlev(i) .gt. 296. .and. tlev(i) .le. 378.) then
+ sig = yg296(iw) +
+ $ (yg378(iw) - yg296(iw))*(tlev(i) - 296.)/82.
+
+ elseif (tlev(i) .gt. 378.) then
+ sig = yg378(iw)
+ endif
+
+ sq(j,i,iw) = qy * sig
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 1
RETURN
END
-*******************************************************************************
- SUBROUTINE rdice_acff(nw,wl,rabs)
+
+*=============================================================================*
+
+ SUBROUTINE r133(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Read ice absorption coefficient. Re-grid data to match =*
-*= specified wavelength working grid. =*
+*= Provide product (cross section) x (quantum yield) for =*
+*= BrCl -> Br + Cl =*
+*= Cross section: from Maric et al., J. Phtoochem Photobiol. A: Chem =*
+*= 83, 179-192, 1994. =*
+*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
-*= RABS_ice - REAL, absorption coefficient (cm^-1) of ice at (O)=*
-*= each specified wavelength =*
-*-----------------------------------------------------------------------------*
-*= EDIT HISTORY: =*
-*= 10/00 Created routine by editing rdh2oxs. =*
-*-----------------------------------------------------------------------------*
-*= This program is free software; you can redistribute it and/or modify =*
-*= it under the terms of the GNU General Public License as published by the =*
-*= Free Software Foundation; either version 2 of the license, or (at your =*
-*= option) any later version. =*
-*= The TUV package is distributed in the hope that it will be useful, but =*
-*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
-*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
-*= License for more details. =*
-*= To obtain a copy of the GNU General Public License, write to: =*
-*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
-*-----------------------------------------------------------------------------*
-*= To contact the authors, please mail to: =*
-*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
-*= send email to: sasha@ucar.edu =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
@@ -35839,9 +36665,9 @@ c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
- INTEGER kout, kin
+ INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -35853,9 +36679,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -35888,97 +36712,124 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
+
REAL precis
PARAMETER(precis = 1.e-7)
- INTEGER kdata
- PARAMETER(kdata=1000)
+* input
-* input: (altitude working grid)
INTEGER nw
- REAL wl(kw)
+ REAL wl(kw), wc(kw)
-* output:
+ INTEGER nz
- REAL rabs(kw)
+ REAL tlev(kz)
+ REAL airden(kz)
-* local:
- REAL x1(kdata)
- REAL y1(kdata),y2(kdata),y3(kdata)
- REAL yg(kw)
- REAL a1, a2, dum
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=200)
+
+ INTEGER iw
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+ integer nn
INTEGER ierr
- INTEGER i,l,m, n, idum
- CHARACTER*40 fil
-*_______________________________________________________________________
-************* absorption cross sections:
-* ice absorption cross sections from
+* local
- fil = 'DATA/ice'
- OPEN(UNIT=kin,FILE='DATAJ1/ABS/ICE_Perov.acff',STATUS='old')
- m = 17 ! header lines
- n = 79 ! data lines
- !OPEN(UNIT=kin,FILE='DATAJ1/ABS/ICE_min.acff',STATUS='old')
- !m = 13 ! header lines
- !n = 52 ! data lines
+ REAL yg(kw)
+ REAL qy
- DO 11, i = 1,m
- read(kin,*)
- 11 CONTINUE
- DO 12, i = 1, n
- READ(kin,*) x1(i), y1(i)
- 12 CONTINUE
- CLOSE (kin)
+******************** BrCl photodissociation
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 0.,0.)
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ j = j + 1
+ jlabel(j) = 'BrCl -> Br + Cl'
+
+* cross section from
+* D. Maric, J.P. Burrows, and G.K. Moortgat, "A study of the UV-visible
+* absorption spectra of Br2 and BrCl," J. Photochem. Photobiol. A: Chem.
+* 83, 179-192 (1994).
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/BrCl.abs',STATUS='OLD')
+ DO i = 1, 9
+ READ(kin,*)
+ ENDDO
+ n = 81
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ ENDDO
+ CLOSE(kin)
+
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 0.,0.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, fil
+ WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
-
- DO 13, l = 1, nw-1
- rabs(l) = yg(l)
- 13 CONTINUE
-*_______________________________________________________________________
+* quantum yields assumed unity
+
+ qy = 1.
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ sq(j,i,iw) = qy * yg(iw)
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
RETURN
END
+
*=============================================================================*
- SUBROUTINE setso2(ipbl, zpbl, xpbl,
- $ so2new, nz, z, nw, wl, so2xs,
- $ tlay, dcol,
- $ dtso2)
+ SUBROUTINE r134(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Set up an altitude profile of SO2 molecules, and corresponding absorption=*
-*= optical depths. Subroutine includes a shape-conserving scaling method =*
-*= that allows scaling of the entire profile to a given overhead SO2 =*
-*= column amount. =*
+*= Provide product (cross section) x (quantum yield) for =*
+*= CH3(OONO2) -> CH3(OO) + NO2 =*
+*= Cross section: from
+*= I. Bridier, R. Lesclaux, and B. Veyret, "Flash photolysis kinetic study
+*= of the equilibrium CH3O2 + NO2 « CH3O2NO2," Chemical Physics Letters
+*= 191, 259-263 (1992).
+*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
-*= SO2NEW - REAL, overhead SO2 column amount (molec/cm^2) to which (I)=*
-*= profile should be scaled. If SO2NEW < 0, no scaling is done =*
-*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
-*= grid =*
-*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
-*= SO2XS - REAL, molecular absoprtion cross section (cm^2) of O2 at (I)=*
-*= each specified wavelength =*
-*= TLAY - REAL, temperature (K) at each specified altitude layer (I)=*
-*= DTSO2 - REAL, optical depth due to SO2 absorption at each (O)=*
-*= specified altitude at each specified wavelength =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
@@ -35987,9 +36838,9 @@ c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
- INTEGER kout, kin
+ INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -36001,9 +36852,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -36036,204 +36885,123 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
+
REAL precis
PARAMETER(precis = 1.e-7)
- INTEGER kdata
- PARAMETER(kdata=51)
-
-********
-* input:
-********
-
-* grids:
+* input
- REAL wl(kw)
- REAL z(kz)
INTEGER nw
- INTEGER nz
- REAL so2new
-
-* mid-layer temperature and layer air column
-
- REAL tlay(kz), dcol(kz)
-
-********
-* output:
-********
-
- REAL dtso2(kz,kw)
-
-********
-* local:
-********
-
-* absorption cross sections
-
- REAL so2xs(kw)
- REAL cz(kz)
-
-* sulfur dioxide profile data:
-
- REAL zd(kdata), so2(kdata)
- REAL cd(kdata)
- REAL hscale
- REAL colold, scale
- REAL sso2
- REAL zpbl, xpbl
- INTEGER ipbl
-
-* other:
-
- INTEGER i, l, nd
-
-********
-* External functions:
-********
+ REAL wl(kw), wc(kw)
- REAL fsum
- EXTERNAL fsum
+ INTEGER nz
-*_______________________________________________________________________
-* Data input:
+ REAL tlev(kz)
+ REAL airden(kz)
-* Example: set to 1 ppb in lowest 1 km, set to zero above that.
-* - do by specifying concentration at 3 altitudes.
+* weighting functions
- nd = 3
- zd(1) = 0.
- so2(1) = 1. * 2.69e10
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
- zd(2) = 1.
- so2(2) = 1. * 2.69e10
+* input/output:
- zd(3) = zd(2)* 1.000001
- so2(3) = 10./largest
+ INTEGER j
-* compute column increments (alternatively, can specify these directly)
+* data arrays
- DO 11, i = 1, nd - 1
- cd(i) = (so2(i+1)+so2(i)) * 1.E5 * (zd(i+1)-zd(i)) / 2.
- 11 CONTINUE
+ INTEGER kdata
+ PARAMETER(kdata=200)
-* Include exponential tail integral from top level to infinity.
-* fold tail integral into top layer
-* specify scale height near top of data (use ozone value)
+ INTEGER iw
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+ integer nn
+ INTEGER ierr
- hscale = 4.50e5
- cd(nd-1) = cd(nd-1) + hscale * so2(nd)
+* local
-***********
-*********** end data input.
+ REAL yg(kw)
+ REAL qy
-* Compute column increments on standard z-grid.
+******************** CH3(OONO2) photodissociation
- CALL inter3(nz,z,cz, nd,zd,cd, 1)
+ j = j + 1
+ jlabel(j) = 'CH3(OONO2) -> CH3(OO) + NO2'
-**** Scaling of vertical profile by ratio of new to old column:
-* If old column is near zero (less than 1 molec cm-2),
-* use constant mixing ratio profile (nominal 1 ppt before scaling)
-* to avoid numerical problems when scaling.
+* cross section from
+*= I. Bridier, R. Lesclaux, and B. Veyret, "Flash photolysis kinetic study
+*= of the equilibrium CH3O2 + NO2 « CH3O2NO2," Chemical Physics Letters
+*= 191, 259-263 (1992).
- IF(fsum(nz-1,cz) .LT. 1.) THEN
- DO i = 1, nz-1
- cz(i) = 1.E-12 * dcol(i)
- ENDDO
- ENDIF
- colold = fsum(nz-1,cz)
- scale = 2.687e16 * so2new / colold
- DO i = 1, nz-1
- cz(i) = cz(i) * scale
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/CH3OONO2.abs',STATUS='OLD')
+ DO i = 1, 9
+ READ(kin,*)
ENDDO
+ n = 26
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ ENDDO
+ CLOSE(kin)
-*! overwrite for specified pbl height, set concentration here
-
- IF(ipbl .GT. 0) THEN
- write(*,*) 'pbl SO2 = ', xpbl, ' ppb'
-
- DO i = 1, nz-1
- IF (i .LE. ipbl) THEN
- cz(i) = xpbl*1.E-9 * dcol(i)
- ELSE
- cz(i) = 0.
- ENDIF
- ENDDO
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 0.,0.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,nn,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
ENDIF
-************************************
-* calculate sulfur optical depth for each layer, with optional temperature
-* correction. Output, dtso2(kz,kw)
+* quantum yields assumed unity
- DO 20, l = 1, nw-1
- sso2 = so2xs(l)
- DO 10, i = 1, nz - 1
+ qy = 1.
-c Leaving this part in in case i want to interpolate between
-c the 221K and 298K data.
-c
-c IF ( wl(l) .GT. 240.5 .AND. wl(l+1) .LT. 350. ) THEN
-c IF (tlay(i) .LT. 263.) THEN
-c sso2 = s221(l) + (s263(l)-s226(l)) / (263.-226.) *
-c $ (tlay(i)-226.)
-c ELSE
-c sso2 = s263(l) + (s298(l)-s263(l)) / (298.-263.) *
-c $ (tlay(i)-263.)
-c ENDIF
-c ENDIF
+ DO iw = 1, nw-1
+ DO i = 1, nz
- dtso2(i,l) = cz(i)*sso2
+ sq(j,i,iw) = qy * yg(iw)
- 10 CONTINUE
- 20 CONTINUE
-*_______________________________________________________________________
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
RETURN
END
-* This file contains the following subroutines, related to the
-* spherical geometry of the Earth's atmosphere
-* sphers
-* airmas
+
*=============================================================================*
- SUBROUTINE sphers(nz, z, zen, dsdh, nid)
+ SUBROUTINE r135(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Calculate slant path over vertical depth ds/dh in spherical geometry. =*
-*= Calculation is based on: A.Dahlback, and K.Stamnes, A new spheric model =*
-*= for computing the radiation field available for photolysis and heating =*
-*= at twilight, Planet.Space Sci., v39, n5, pp. 671-683, 1991 (Appendix B) =*
+*= Provide product (cross section) x (quantum yield) for t-butyl nitrite =*
+*= C(CH3)3(ONO) -> C(CH3)3(O) + NO =*
+*= Cross section: from
+*= V. McMillan, 1966, private communication to J.G. Calvert, J.N.Pitts, Jr.,
+*= Photochemistry, London, 1966, p. 455.
+*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
-*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
-*= grid =*
-*= Z - REAL, specified altitude working grid (km) (I)=*
-*= ZEN - REAL, solar zenith angle (degrees) (I)=*
-*= DSDH - REAL, slant path of direct beam through each layer crossed (O)=*
-*= when travelling from the top of the atmosphere to layer i; =*
-*= DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1 =*
-*= NID - INTEGER, number of layers crossed by the direct beam when (O)=*
-*= travelling from the top of the atmosphere to layer i; =*
-*= NID(i), i = 0..NZ-1 =*
-*-----------------------------------------------------------------------------*
-*= EDIT HISTORY: =*
-*= double precision fix for shallow layers - Julia Lee-Taylor Dec 2000 =*
-*-----------------------------------------------------------------------------*
-*= This program is free software; you can redistribute it and/or modify =*
-*= it under the terms of the GNU General Public License as published by the =*
-*= Free Software Foundation; either version 2 of the license, or (at your =*
-*= option) any later version. =*
-*= The TUV package is distributed in the hope that it will be useful, but =*
-*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
-*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
-*= License for more details. =*
-*= To obtain a copy of the GNU General Public License, write to: =*
-*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
-*-----------------------------------------------------------------------------*
-*= To contact the authors, please mail to: =*
-*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
-*= send email to: sasha@ucar.edu =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
@@ -36242,9 +37010,9 @@ c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
- INTEGER kout, kin
+ INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -36256,9 +37024,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -36291,137 +37057,120 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
+
REAL precis
PARAMETER(precis = 1.e-7)
* input
- INTEGER nz
- REAL zen, z(kz)
-
-* output
- INTEGER nid(0:kz)
- REAL dsdh(0:kz,kz)
-* more program constants
- REAL re, ze(kz)
- REAL dr
- PARAMETER ( dr = pi/180.)
+ INTEGER nw
+ REAL wl(kw), wc(kw)
-* local
+ INTEGER nz
- REAL zenrad, rpsinz, rj, rjp1, dsj, dhj, ga, gb, sm
- INTEGER i, j, k
- INTEGER id
+ REAL tlev(kz)
+ REAL airden(kz)
- INTEGER nlayer
- REAL zd(0:kz-1)
+* weighting functions
-*-----------------------------------------------------------------------------
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
- zenrad = zen*dr
+* input/output:
-* number of layers:
- nlayer = nz - 1
+ INTEGER j
-* include the elevation above sea level to the radius of the earth:
- re = radius + z(1)
-* correspondingly z changed to the elevation above earth surface:
- DO k = 1, nz
- ze(k) = z(k) - z(1)
- END DO
+* data arrays
-* inverse coordinate of z
- zd(0) = ze(nz)
- DO k = 1, nlayer
- zd(k) = ze(nz - k)
- END DO
+ INTEGER kdata
+ PARAMETER(kdata=200)
-* initialize dsdh(i,j), nid(i)
- DO i = 0, kz
- nid(i) = 0
- DO j = 1, kz
- dsdh(i,j) = 0.
- END DO
- END DO
+ INTEGER iw
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+ integer nn
+ INTEGER ierr
-* calculate ds/dh of every layer
- DO 100 i = 0, nlayer
+* local
- rpsinz = (re + zd(i)) * SIN(zenrad)
-
- IF ( (zen .GT. 90.0) .AND. (rpsinz .LT. re) ) THEN
- nid(i) = -1
- ELSE
+ REAL yg(kw)
+ REAL qy
-*
-* Find index of layer in which the screening height lies
-*
- id = i
- IF( zen .GT. 90.0 ) THEN
- DO 10 j = 1, nlayer
- IF( (rpsinz .LT. ( zd(j-1) + re ) ) .AND.
- $ (rpsinz .GE. ( zd(j) + re )) ) id = j
- 10 CONTINUE
- END IF
-
- DO 20 j = 1, id
+******************** CH3(OONO2) photodissociation
- sm = 1.0
- IF(j .EQ. id .AND. id .EQ. i .AND. zen .GT. 90.0)
- $ sm = -1.0
-
- rj = re + zd(j-1)
- rjp1 = re + zd(j)
-
- dhj = zd(j-1) - zd(j)
-
- ga = rj*rj - rpsinz*rpsinz
- gb = rjp1*rjp1 - rpsinz*rpsinz
- IF (ga .LT. 0.0) ga = 0.0
- IF (gb .LT. 0.0) gb = 0.0
-
- IF(id.GT.i .AND. j.EQ.id) THEN
- dsj = SQRT( ga )
- ELSE
- dsj = SQRT( ga ) - sm*SQRT( gb )
- END IF
- dsdh(i,j) = dsj / dhj
- 20 CONTINUE
-
- nid(i) = id
-
- END IF
+ j = j + 1
+ jlabel(j) = 'C(CH3)3(ONO) -> C(CH3)3(O) + NO'
- 100 CONTINUE
+* cross section from
+*= V. McMillan, 1966, private communication to J.G. Calvert, J.N.Pitts, Jr.,
+*= Photochemistry, London, 1966, p. 455.
-*-----------------------------------------------------------------------------
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/t-butyl-nitrite.abs',STATUS='OLD')
+ DO i = 1, 4
+ READ(kin,*)
+ ENDDO
+ n = 96
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ ENDDO
+ CLOSE(kin)
- RETURN
- END
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 0.,0.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,nn,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields assumed unity
+
+ qy = 1.
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ sq(j,i,iw) = qy * yg(iw)
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
+
+ RETURN
+ END
*=============================================================================*
- SUBROUTINE airmas(nz, dsdh, nid, cz,
- $ vcol, scol)
+ SUBROUTINE r136(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Calculate vertical and slant air columns, in spherical geometry, as a =*
-*= function of altitude. =*
+*= Provide product (cross section) x (quantum yield) for ClONO =*
+*= ClONO -> Cl + NO2 =*
+*= cross section from IPUAC, orig from Molina and Molina (1977) =*
+*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
-*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
-*= grid =*
-*= DSDH - REAL, slant path of direct beam through each layer crossed (O)=*
-*= when travelling from the top of the atmosphere to layer i; =*
-*= DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1 =*
-*= NID - INTEGER, number of layers crossed by the direct beam when (O)=*
-*= travelling from the top of the atmosphere to layer i; =*
-*= NID(i), i = 0..NZ-1 =*
-*= VCOL - REAL, output, vertical air column, molec cm-2, above level iz =*
-*= SCOL - REAL, output, slant air column in direction of sun, above iz =*
-*= also in molec cm-2 =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
@@ -36430,9 +37179,9 @@ c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
- INTEGER kout, kin
+ INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -36444,9 +37193,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -36479,85 +37226,125 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
+
REAL precis
PARAMETER(precis = 1.e-7)
-* Input:
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
INTEGER nz
- INTEGER nid(0:kz)
- REAL dsdh(0:kz,kz)
- REAL cz(kz)
-* output:
+ REAL tlev(kz)
+ REAL airden(kz)
- REAL vcol(kz), scol(kz)
+* weighting functions
-* internal:
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
- INTEGER id, j
- REAL sum, vsum
+* input/output:
-* calculate vertical and slant column from each level:
-* work downward
+ INTEGER j
- vsum = 0.
- DO id = 0, nz - 1
- vsum = vsum + cz(nz-id)
- vcol(nz-id) = vsum
- sum = 0.
- IF(nid(id) .LT. 0) THEN
- sum = largest
- ELSE
+* data arrays
-* single pass layers:
+ INTEGER kdata
+ PARAMETER(kdata=200)
- DO j = 1, MIN(nid(id), id)
- sum = sum + cz(nz-j)*dsdh(id,j)
- ENDDO
+ INTEGER iw
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+ integer nn
+ INTEGER ierr
-* double pass layers:
+* local
- DO j = MIN(nid(id),id)+1, nid(id)
- sum = sum + 2.*cz(nz-j)*dsdh(id,j)
- ENDDO
+ REAL yg(kw)
+ REAL qy
- ENDIF
- scol(nz - id) = sum
+******************** ClONO photodissociation
+ j = j + 1
+ jlabel(j) = 'ClONO -> Cl + NO2'
+
+* cross section from JPL-2011
+* Also published (with some minor differences) as:
+* R. Atkinson, D.L. Baulch, R.A. Cox, J.N. Crowley, R.F. Hampson, R.G. Hynes, M.E. Jenkin, M.J. Rossi,
+* and J. Troe, "Evaluated kinetic and photochemical data for atmospheric chemistry: Volume III - gas
+* phase reactions of inorganic halogens", Atmos. Chem. Phys. 7, 981-1191 (2007).Comments:
+* IUPAC (2005, 2007) recommendation:
+* The preferred values of the absorption cross-sections at 231 K are the values reported by
+* L.T. Molina and M.J. Molina, "Ultraviolet absorption spectrum of chlorine nitrite, ClONO,"
+* Geophys. Res. Lett. 4, 83-86 (1977).
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/ClONO_jpl11.abs',STATUS='OLD')
+ DO i = 1, 3
+ READ(kin,*)
+ ENDDO
+ n = 34
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
ENDDO
+ CLOSE(kin)
- RETURN
- END
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 0.,0.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,nn,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields assumed unity
+
+ qy = 1.
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+ sq(j,i,iw) = qy * yg(iw)
+ ENDDO
+ ENDDO
+ tpflag(j) = 0
-* This file contains the following subroutines, related to specifying
-* biological spectral weighting functions:
-* swbiol
+ RETURN
+ END
*=============================================================================*
- SUBROUTINE swbiol(nw,wl,wc,j,s,label)
+ SUBROUTINE r137(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Create or read various weighting functions, e.g. biological action =*
-*= spectra, UV index, etc. =*
+*= Provide product (cross section) x (quantum yield) for HCl =*
+*= HCl -> H + Cl =*
+*= cross section from JPL2011 =*
+*= Quantum yield: Assumed to be 1 =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
-*= WC - REAL, vector of central wavelength of wavelength intervals I)=*
-*= in working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
*= J - INTEGER, counter for number of weighting functions defined (IO)=*
-*= S - REAL, value of each defined weighting function at each (O)=*
-*= defined wavelength =*
-*= LABEL - CHARACTER*50, string identifier for each weighting function (O)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
*= defined =*
*-----------------------------------------------------------------------------*
@@ -36567,9 +37354,9 @@ c INCLUDE 'params'
* BROADLY USED PARAMETERS:
*_________________________________________________
* i/o file unit numbers
- INTEGER kout, kin
+ INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -36581,9 +37368,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -36616,525 +37401,4166 @@ c INCLUDE 'params'
PARAMETER(nzero = -10./largest)
* machine precision
-
+
REAL precis
PARAMETER(precis = 1.e-7)
- INTEGER kdata
- PARAMETER(kdata=1000)
+* input
-* input:
- REAL wl(kw), wc(kw)
INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
* input/output:
- INTEGER j
-* output: (weighting functions and labels)
- REAL s(ks,kw)
- CHARACTER*50 label(ks)
+ INTEGER j
-* internal:
- REAL x1(kdata)
- REAL y1(kdata)
- REAL yg(kw)
+* data arrays
- REAL fery, futr
- EXTERNAL fery, futr
- INTEGER i, iw, n
+ INTEGER kdata
+ PARAMETER(kdata=100)
+ INTEGER iw
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+ integer nn
INTEGER ierr
- INTEGER idum
- REAL dum1, dum2
- REAL em, a, b, c
- REAL sum
+* local
- REAL a0, a1, a2, a3
+ REAL yg(kw)
+ REAL qy, dum
-*_______________________________________________________________________
+******************** HCl photodissociation
-********* Photosynthetic Active Radiation (400 < PAR < 700 nm)
-* conversion to micro moles m-2 s-1:
-* s = s * (1e6/6.022142E23)(w/1e9)/(6.626068E-34*2.99792458E8)
-
j = j + 1
- label(j) = 'PAR, 400-700 nm, umol m-2 s-1'
- DO iw = 1, nw-1
- IF (wc(iw) .GT. 400. .AND. wc(iw) .LT. 700.) THEN
- s(j,iw) = 8.36e-3 * wc(iw)
- ELSE
- s(j,iw) = 0.
- ENDIF
- ENDDO
+ jlabel(j) = 'HCl -> H + Cl'
-********** unity raf constant slope:
+* cross section from JPL2011
- j = j + 1
- label(j) = 'Exponential decay, 14 nm/10'
- DO iw = 1, nw-1
- s(j,iw) = 10.**(-(wc(iw) -300.)/14.)
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/HCl_jpl11.abs',STATUS='OLD')
+ DO i = 1, 3
+ READ(kin,*)
ENDDO
-
-************ DNA damage action spectrum
-* from: Setlow, R. B., The wavelengths in sunlight effective in
-* producing skin cancer: a theoretical analysis, Proceedings
-* of the National Academy of Science, 71, 3363 -3366, 1974.
-* normalize to unity at 300 nm
-* Data read from original hand-drawn plot by Setlow
-* received from R. Setlow in May 1995
-* data is per quantum (confirmed with R. Setlow in May 1995).
-* Therefore must put on energy basis if irradiance is is energy
-* (rather than quanta) units.
-
- j = j + 1
- label(j) = 'DNA damage, in vitro (Setlow, 1974)'
- OPEN(UNIT=kin,FILE='DATAS1/dna.setlow.new',STATUS='old')
- do i = 1, 11
- read(kin,*)
- enddo
- n = 55
+ n = 31
DO i = 1, n
- READ(kin,*) x1(i), y1(i)
- y1(i) = y1(i) / 2.4E-02 * x1(i)/300.
+ READ(kin,*) x(i), y(i), dum
+ y(i) = y(i) * 1.e-20
ENDDO
- CLOSE (kin)
+ CLOSE(kin)
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
- CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 0.,0.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,nn,x,y,ierr)
IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, label(j)
+ WRITE(*,*) ierr, jlabel(j)
STOP
ENDIF
- DO iw = 1, nw-1
- s(j,iw) = yg(iw)
- ENDDO
+* quantum yields assumed unity
-********* skin cancer in mice, Utrecht/Phildelphia study
-*from de Gruijl, F. R., H. J. C. M. Sterenborg, P. D. Forbes,
-* R. E. Davies, C. Cole, G. Kelfkens, H. van Weelden, H. Slaper,
-* and J. C. van der Leun, Wavelength dependence of skin cancer
-* induction by ultraviolet irradiation of albino hairless mice,
-* Cancer Res., 53, 53-60, 1993.
-* Calculate with function futr(w), normalize at 300 nm.
+ qy = 1.
- j = j + 1
- label(j) = 'SCUP-mice (de Gruijl et al., 1993)'
DO iw = 1, nw-1
- s(j,iw) = futr(wc(iw)) / futr(300.)
- ENDDO
-
-*********** Utrecht/Philadelphia mice spectrum corrected for humans skin.
-* From de Gruijl, F.R. and J. C. van der Leun, Estimate of the wavelength
-* dependency of ultraviolet carcinogenesis and its relevance to the
-* risk assessment of a stratospheric ozone depletion, Health Phys., 4,
-* 317-323, 1994.
+ DO i = 1, nz
- j = j + 1
- label(j) = 'SCUP-human (de Gruijl and van der Leun, 1994)'
- OPEN(UNIT=kin,FILE='DATAS1/SCUP-h',STATUS='old')
- n = 28
- DO i = 1, n
- READ(kin,*) x1(i), y1(i)
- ENDDO
+ sq(j,i,iw) = qy * yg(iw)
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
- CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, label(j)
- STOP
- ENDIF
-
- DO iw = 1, nw-1
- s(j,iw) = yg(iw)
+ ENDDO
ENDDO
- CLOSE (kin)
-
-***************** CIE standard human erythema action spectrum
-*from:
-* McKinlay, A. F., and B. L. Diffey, A reference action spectrum for
-* ultraviolet induced erythema in human skin, in Human Exposure to
-* Ultraviolet Radiation: Risks and Regulations, W. R. Passchler
-* and B. F. M. Bosnajokovic, (eds.), Elsevier, Amsterdam, 1987.
- j = j + 1
- label(j) = 'CIE human erythema (McKinlay and Diffey, 1987)'
- DO iw = 1, nw-1
- s(j,iw) = fery(wc(iw))
- ENDDO
+ tpflag(j) = 0
+
+ RETURN
+ END
-***************** UV index (Canadian - WMO/WHO)
-* from:
-* Report of the WMO Meeting of experts on UV-B measurements, data quality
-* and standardization of UV indices, World Meteorological Organization
-* (WMO), report No. 95, Geneva, 1994.
-* based on the CIE erythema weighting, multiplied by 40.
+*-----------------------------------------------------------------------------*
- j = j + 1
- label(j) = 'UV index (WMO, 1994)'
- DO iw = 1, nw-1
- s(j,iw) = 40. * fery(wc(iw))
- ENDDO
+ SUBROUTINE pxCH2O(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
-************* Human erythema - Anders et al.
-* from:
-* Anders, A., H.-J. Altheide, M. Knalmann, and H. Tronnier,
-* Action spectrum for erythema in humands investigated with dye lasers,
-* Photochem. and Photobiol., 61, 200-203, 1995.
-* for skin types II and III, Units are J m-2.
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= JPL 2011 recommendation. =*
+*= Provide product of (cross section) x (quantum yield) for CH2O photolysis =*
+*= (a) CH2O + hv -> H + HCO =*
+*= (b) CH2O + hv -> H2 + CO =*
+*= written by s. madronich march 2013
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
- j = j + 1
- label(j) = 'Erythema, humans (Anders et al., 1995)'
- OPEN(UNIT=kin,FILE='DATAS1/ery.anders',STATUS='old')
- do i = 1, 5
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+ INTEGER kdata
+ PARAMETER(kdata=200)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER i, j, iz, iw
+
+* data arrays
+
+ INTEGER n, n1, n2
+ REAL x1(kdata), x2(kdata)
+ REAL y298(kdata), tcoef(kdata)
+ REAL qr(kdata), qm(kdata)
+
+* local
+
+ REAL yg1(kw), yg2(kw), yg3(kw), yg4(kw)
+ REAL ak300, akt, sig
+ real qyr300, qym300, qymt
+
+
+ INTEGER ierr
+
+*_______________________________________________________________________
+
+ DO 5, iw = 1, nw - 1
+ wc(iw) = (wl(iw) + wl(iw+1))/2.
+ 5 CONTINUE
+
+****************************************************************
+**************** CH2O photodissociatation
+
+ j = j+1
+ jlabel(j) = 'CH2O -> H + HCO'
+
+ j = j+1
+ jlabel(j) = 'CH2O -> H2 + CO'
+
+* read JPL2011 cross section data:
+
+ OPEN(UNIT=kin,FILE='DATAJ1/CH2O/CH2O_jpl11.abs'
+ $ ,STATUS='old')
+ do i = 1, 4
read(kin,*)
enddo
- n = 28
+ n = 150
+ n1 = n
+ n2 = n
DO i = 1, n
- READ(kin,*) x1(i), y1(i)
- y1(i) = 1./y1(i)
+ READ(kin,*) x1(i), y298(i), tcoef(i)
+ x2(i) = x1(i)
+ y298(i) = y298(i) * 1.e-20
+ tcoef(i) = tcoef(i) * 1.e-24
ENDDO
+ CLOSE(kin)
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
- CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+* terminate endpoints and interpolate to working grid
+
+ CALL addpnt(x1,y298,kdata,n1,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y298,kdata,n1, 0.,0.)
+ CALL addpnt(x1,y298,kdata,n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,y298,kdata,n1, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1,n1,x1,y298,ierr)
IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, label(j)
+ WRITE(*,*) ierr, jlabel(j-1)
STOP
ENDIF
-
- DO iw = 1, nw-1
- s(j,iw) = yg(iw)
- ENDDO
- CLOSE (kin)
-
-********* 1991-92 ACGIH threshold limit values
-* from
-* ACGIH, 1991-1992 Threshold Limit Values, American Conference
-* of Governmental and Industrial Hygienists, 1992.
- j = j + 1
- label(j) = 'Occupational TLV (ACGIH, 1992)'
- OPEN(UNIT=kin,FILE='DATAS1/acgih.1992',STATUS='old')
- n = 56
- DO i = 1, n
- READ(kin,*) x1(i), y1(i)
- y1(i) = y1(i)
- ENDDO
-
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
- CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ CALL addpnt(x2,tcoef,kdata,n2,x2(1)*(1.-deltax),0.)
+ CALL addpnt(x2,tcoef,kdata,n2, 0.,0.)
+ CALL addpnt(x2,tcoef,kdata,n2,x2(n2)*(1.+deltax),0.)
+ CALL addpnt(x2,tcoef,kdata,n2, 1.e+38,0.)
+ CALL inter2(nw,wl,yg2,n2,x2,tcoef,ierr)
IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, label(j)
+ WRITE(*,*) ierr, jlabel(j-1)
STOP
ENDIF
-
- DO iw = 1, nw-1
- s(j,iw) = yg(iw)
- ENDDO
- CLOSE (kin)
-********* phytoplankton, Boucher et al. (1994)
-* from Boucher, N., Prezelin, B.B., Evens, T., Jovine, R., Kroon, B., Moline, M.A.,
-* and Schofield, O., Icecolors '93: Biological weighting function for the ultraviolet
-* inhibition of carbon fixation in a natural antarctic phytoplankton community,
-* Antarctic Journal, Review 1994, pp. 272-275, 1994.
-* In original paper, value of b and m (em below are given as positive. Correct values
-* are negative. Also, limit to positive values.
+* quantum yields: Read, terminate, interpolate:
- j = j + 1
- label(j) = 'Phytoplankton (Boucher et al., 1994)'
- a = 112.5
- b = -6.223E-01
- c = 7.670E-04
- em = -3.17E-06
- DO iw = 1, nw-1
- IF (wc(iw) .GT. 290. .AND. wc(iw) .LT. 400.) THEN
- s(j,iw) = em + EXP(a+b*wc(iw)+c*wc(iw)*wc(iw))
- ELSE
- s(j,iw) = 0.
+ OPEN(UNIT=kin,FILE='DATAJ1/CH2O/CH2O_jpl11.yld',STATUS='old')
+ DO i = 1, 4
+ READ(kin,*)
+ ENDDO
+ n = 112
+ n1 = n
+ n2 = n
+ DO i = 1, n
+ READ(kin,*) x1(i), qr(i), qm(i)
+ x2(i) = x1(i)
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x1,qr,kdata,n1,x1(1)*(1.-deltax),qr(1))
+ CALL addpnt(x1,qr,kdata,n1, 0.,qr(1))
+ CALL addpnt(x1,qr,kdata,n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,qr,kdata,n1, 1.e+38,0.)
+ CALL inter2(nw,wl,yg3,n1,x1,qr,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j-1)
+ STOP
ENDIF
- s(j,iw) = max(s(j,iw),0.)
- ENDDO
-********* phytoplankton, Cullen et al.
-* Cullen, J.J., Neale, P.J., and Lesser, M.P., Biological weighting function for the
-* inhibition of phytoplankton photosynthesis by ultraviolet radiation, Science, 25,
-* 646-649, 1992.
-* phaeo
+ CALL addpnt(x2,qm,kdata,n2,x2(1)*(1.-deltax),qm(1))
+ CALL addpnt(x2,qm,kdata,n2, 0.,qm(1))
+ CALL addpnt(x2,qm,kdata,n2,x2(n2)*(1.+deltax),0.)
+ CALL addpnt(x2,qm,kdata,n2, 1.e+38,0.)
+ CALL inter2(nw,wl,yg4,n2,x2,qm,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j-1)
+ STOP
+ ENDIF
- j = j + 1
- label(j) = 'Phytoplankton, phaeo (Cullen et al., 1992)'
- OPEN(UNIT=kin,FILE='DATAS1/phaeo.bio',STATUS='old')
- n = 106
- DO i = 1, n
- READ(kin,*) idum, dum1, dum2, y1(i)
- x1(i) = (dum1+dum2)/2.
- ENDDO
+* combine gridded quantities:
+* yg1 = cross section at 298K
+* yg2 = temperature correction coefficient for cross section
+* yg3 = quantum yields for radical channel, H + HCO
+* yg4 = quantum yields for molecular channel, H2 + CO.
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
- CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, label(j)
- STOP
- ENDIF
+ DO iz = 1, nz
- DO iw = 1, nw-1
- s(j,iw) = yg(iw)
- ENDDO
- CLOSE(kin)
+ DO iw = 1, nw - 1
-* proro
+* correct cross section for temperature dependence:
- j = j + 1
- label(j) = 'Phytoplankton, proro (Cullen et al., 1992)'
- OPEN(UNIT=kin,FILE='DATAS1/proro.bio',STATUS='old')
- n = 100
- DO i = 1, n
- READ(kin,*) idum, dum1, dum2, y1(i)
- x1(i) = (dum1+dum2)/2.
- ENDDO
+ sig = yg1(iw) + yg2(iw) * (tlev(iz) - 298.)
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
- CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, label(j)
- STOP
- ENDIF
+* assign room temperature quantum yields for radical and molecular channels
- DO iw = 1, nw-1
- s(j,iw) = yg(iw)
- ENDDO
- CLOSE (kin)
+ qyr300 = yg3(iw)
+ qym300 = yg4(iw)
+ qymt = qym300
-**** Damage to lens of pig eyes, from
-* Oriowo, M. et al. (2001). Action spectrum for in vitro
-* UV-induced cataract using whole lenses. Invest. Ophthalmol. & Vis. Sci. 42,
-* 2596-2602. For pig eyes. Last two columns computed by L.O.Bjorn.
+* between 330 ande 360 nm, molecular channel is pressure and temperature dependent.
- j = j + 1
- label(j) = 'Cataract, pig (Oriowo et al., 2001)'
- OPEN(UNIT=kin,FILE='DATAS1/cataract_oriowo',STATUS='old')
- DO i = 1, 7
- READ(kin,*)
- ENDDO
- n = 18
- DO i = 1, n
- READ(kin,*) x1(i), dum1, dum1, y1(i)
- ENDDO
+ IF (wc(iw) .ge. 330. .and. wc(iw) .lt. 360. .and.
+ $ qym300 .gt. 0.) then
-* extrapolation to 400 nm (has very little effect on raf):
-c do i = 1, 30
-c n = n + 1
-c x1(n) = x1(n-1) + 1.
-c y1(n) = 10**(5.7666 - 0.0254*x1(n))
-c enddo
+ ak300 = 1./qym300 - 1./(1. - qyr300)
+ ak300 = ak300/2.45e19
+ akt = ak300 * (1. + 0.05 * (wc(iw) - 329.) *
+ $ (300. - tlev(iz))/80.)
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
- CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, label(j)
- STOP
- ENDIF
+ qymt = 1./(1./(1.-qyr300) + akt*airden(iz))
- DO iw = 1, nw-1
- s(j,iw) = yg(iw)
+ ENDIF
+
+ sq(j-1,iz,iw) = sig * qyr300
+ sq(j ,iz,iw) = sig * qymt
+
+ ENDDO
ENDDO
- CLOSE(kin)
-****** Plant damage - Caldwell 1971
-* Caldwell, M. M., Solar ultraviolet radiation and the growth and
-* development of higher plants, Photophysiology 6:131-177, 1971.
+ tpflag(j-1) = 1
+ tpflag(j) = 3
+
+ RETURN
+ END
+
+*=============================================================================*
+
+ SUBROUTINE r138(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide product (cross section) x (quantum yield) for acetic acid =*
+*= CH3COOH -> CH3 + COOH =*
+*= cross section from JPL2011 =*
+*= Quantum yield: Assumed to be 0.55 =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=100)
+
+ INTEGER iw
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+ integer nn
+ INTEGER ierr
+
+* local
+
+ REAL yg(kw)
+ REAL qy, dum
+
+******************** acetic acid photodissociation
+
+ j = j + 1
+ jlabel(j) = 'CH3COOH -> CH3 + COOH'
+
+* cross section from JPL2011
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/CH3COOH_jpl11.abs',STATUS='OLD')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 18
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 0.,0.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,nn,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields assumed unity
+
+ qy = 0.55
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ sq(j,i,iw) = qy * yg(iw)
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
+
+ RETURN
+ END
+
+*=============================================================================*
+
+ SUBROUTINE r139(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide product (cross section) x(quantum yield) for methyl hypochlorite =*
+*= CH3OCl -> CH3O + Cl =*
+*= cross section from JPL2011 =*
+*= Quantum yield: Assumed to be 1 =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=100)
+
+ INTEGER iw
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+ integer nn
+ INTEGER ierr
+
+* local
+
+ REAL yg(kw)
+ REAL qy, dum
+
+******************** methyl hypochlorite photodissociation
+
+ j = j + 1
+ jlabel(j) = 'CH3OCl -> CH3O + Cl'
+
+* cross section from JPL2011
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/CH3OCl_jpl11.abs',STATUS='OLD')
+ DO i = 1, 3
+ READ(kin,*)
+ ENDDO
+ n = 83
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 0.,0.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,nn,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields assumed unity
+
+ qy = 1.
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ sq(j,i,iw) = qy * yg(iw)
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
+
+ RETURN
+ END
+
+*=============================================================================*
+
+ SUBROUTINE r140(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide product (cross section) x (quantum yield) for CHCl3 photolysis: =*
+*= CHCL3 + hv -> Products =*
+*= Cross section: from JPL 2011 recommendation =*
+*= Quantum yield: assumed to be unity =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=100)
+
+ REAL x1(kdata)
+ REAL y1(kdata)
+
+* local
+
+ REAL yg(kw)
+ REAL qy
+ INTEGER i, iw, n, idum
+ INTEGER ierr
+ INTEGER iz
+ INTEGER mabs
+ REAL b0, b1, b2, b3, b4, tcoeff, sig
+ REAL w1, w2, w3, w4, temp
+
+**************************************************************
+************* CHCl3 photodissociation
+
+ j = j+1
+ jlabel(j) = 'CHCl3 -> Products'
+
+ OPEN(kin,FILE='DATAJ1/ABS/CHCl3_jpl11.abs',STATUS='OLD')
+ DO i = 1, 3
+ READ(kin,*)
+ ENDDO
+ n = 39
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1E-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1E38,0.)
+
+ CALL inter2(nw,wl,yg,n,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* compute temperature correction factors:
+
+ b0 = 3.7973
+ b1 = -7.0913e-2
+ b2 = 4.9397e-4
+ b3 = -1.5226e-6
+ b4 = 1.7555e-9
+
+*** quantum yield assumed to be unity
+
+ qy = 1.
+ DO iw = 1, nw-1
+
+* compute temperature correction coefficients:
+
+ tcoeff = 0.
+ IF(wc(iw) .GT. 190. .AND. wc(iw) .LT. 240.) THEN
+ w1 = wc(iw)
+ w2 = w1**2
+ w3 = w1**3
+ w4 = w1**4
+ tcoeff = b0 + b1*w1 + b2*w2 + b3*w3 + b4*w4
+ ENDIF
+
+ DO iz = 1, nz
+ temp = tlev(iz)
+ temp = min(max(temp,210.),300.)
+ sig = yg(iw) * 10.**(tcoeff*(temp-295.))
+ sq(j,iz,iw) = qy * sig
+ ENDDO
+
+ ENDDO
+
+ tpflag(j) = 1
+
+ RETURN
+ END
+
+*=============================================================================*
+
+ SUBROUTINE r141(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide product (cross section) x (quantum yield) for C2H5ONO2 =*
+*= photolysis: =*
+*= C2H5ONO2 + hv -> C2H5O + NO2 =*
+*= =*
+*= Cross section: IUPAC 2006 (Atkinson et al., ACP, 6, 3625-4055, 2006) =*
+*= Quantum yield: Assumed to be unity =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER (kdata = 200)
+
+ INTEGER i, n
+ INTEGER iw
+ INTEGER n1, n2
+ REAL x1(kdata), x2(kdata)
+ REAL y1(kdata), y2(kdata)
+
+* local
+
+ REAL yg(kw), yg1(kw), yg2(kw)
+ REAL qy
+ REAL sig
+ INTEGER ierr
+
+ INTEGER mabs, myld
+
+**************** C2H5ONO2 photodissociation
+
+ j = j + 1
+ jlabel(j) = 'C2H5ONO2 -> C2H5O + NO2'
+
+* mabs: absorption cross section options:
+* 1: IUPAC 2006
+
+ OPEN(UNIT=kin,FILE='DATAJ1/RONO2/C2H5ONO2_iup2006.abs',
+ $ STATUS='old')
+ DO i = 1, 4
+ READ(kin,*)
+ ENDDO
+ n = 32
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i), y2(i)
+ x2(i) = x1(i)
+ y1(i) = y1(i) * 1.e-20
+ y2(i) = y2(i) * 1.e-3
+ ENDDO
+ CLOSE (kin)
+
+ n1 = n
+ CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+ n2 = n
+ CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.)
+ CALL addpnt(x2,y2,kdata,n2, 0.,0.)
+ CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.)
+ CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.)
+ CALL inter2(nw,wl,yg2,n2,x2,y2,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yield = 1
+* sigma(T,lambda) = sigma(298,lambda) * exp(B * (T-298))
+
+ qy = 1.
+
+ DO iw = 1, nw - 1
+ DO i = 1, nz
+
+ sig = yg1(iw) * exp(yg2(iw) * (tlev(i)-298.))
+
+ sq(j,i,iw) = qy * sig
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 1
+
+ RETURN
+ END
+
+*=============================================================================*
+
+ SUBROUTINE r142(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide product (cross section) x (quantum yield) for n-C3H7ONO2 =*
+*= photolysis: =*
+*= n-C3H7ONO2 + hv -> C3H7O + NO2 =*
+*= =*
+*= Cross section: IUPAC 2006 (Atkinson et al., ACP, 6, 3625-4055, 2006) =*
+*= Quantum yield: Assumed to be unity =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER (kdata = 200)
+
+ INTEGER i, n
+ INTEGER iw
+ INTEGER n1, n2
+ REAL x1(kdata), x2(kdata)
+ REAL y1(kdata), y2(kdata)
+
+* local
+
+ REAL yg(kw), yg1(kw), yg2(kw)
+ REAL qy
+ REAL sig
+ INTEGER ierr
+
+ INTEGER mabs, myld
+
+**************** n-C3H7ONO2 photodissociation
+
+ j = j + 1
+ jlabel(j) = 'n-C3H7ONO2 -> C3H7O + NO2'
+
+* 1: IUPAC 2006
+
+ OPEN(UNIT=kin,FILE='DATAJ1/RONO2/nC3H7ONO2_iup2006.abs',
+ $ STATUS='old')
+ DO i = 1, 3
+ READ(kin,*)
+ ENDDO
+ n = 32
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1.e-20
+ ENDDO
+ CLOSE (kin)
+
+ n1 = n
+ CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yield = 1
+
+ qy = 1.
+
+ DO iw = 1, nw - 1
+ DO i = 1, nz
+ sq(j,i,iw) = qy * yg1(iw)
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
+
+ RETURN
+ END
+
+*=============================================================================*
+
+ SUBROUTINE r143(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide product (cross section) x (quantum yield) for 1-C4H9ONO2 =*
+*= photolysis: =*
+*= 1-C4H9ONO2 + hv -> 1-C4H9O + NO2 =*
+*= =*
+*= Cross section: IUPAC 2006 (Atkinson et al., ACP, 6, 3625-4055, 2006) =*
+*= Quantum yield: Assumed to be unity =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER (kdata = 200)
+
+ INTEGER i, n
+ INTEGER iw
+ INTEGER n1, n2
+ REAL x1(kdata), x2(kdata)
+ REAL y1(kdata), y2(kdata)
+
+* local
+
+ REAL yg(kw), yg1(kw), yg2(kw)
+ REAL qy
+ REAL sig
+ INTEGER ierr
+
+ INTEGER mabs, myld
+
+**************** 1-C4H9ONO2 photodissociation
+
+ j = j + 1
+ jlabel(j) = '1-C4H9ONO2 -> 1-C4H9O + NO2'
+
+* 1: IUPAC 2006
+
+ OPEN(UNIT=kin,FILE='DATAJ1/RONO2/1C4H9ONO2_iup2006.abs',
+ $ STATUS='old')
+ DO i = 1, 3
+ READ(kin,*)
+ ENDDO
+ n = 32
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1.e-20
+ ENDDO
+ CLOSE (kin)
+
+ n1 = n
+ CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yield = 1
+
+ qy = 1.
+
+ DO iw = 1, nw - 1
+ DO i = 1, nz
+ sq(j,i,iw) = qy * yg1(iw)
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
+
+ RETURN
+ END
+
+*=============================================================================*
+
+ SUBROUTINE r144(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide product (cross section) x (quantum yield) for 2-C4H9ONO2 =*
+*= photolysis: =*
+*= 2-C4H9ONO2 + hv -> 2-C4H9O + NO2 =*
+*= =*
+*= Cross section: IUPAC 2006 (Atkinson et al., ACP, 6, 3625-4055, 2006) =*
+*= Quantum yield: Assumed to be unity =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER (kdata = 200)
+
+ INTEGER i, n
+ INTEGER iw
+ INTEGER n1, n2
+ REAL x1(kdata), x2(kdata)
+ REAL y1(kdata), y2(kdata)
+
+* local
+
+ REAL yg(kw), yg1(kw), yg2(kw)
+ REAL qy
+ REAL sig
+ INTEGER ierr
+
+ INTEGER mabs, myld
+
+**************** 2-C4H9ONO2 photodissociation
+
+ j = j + 1
+ jlabel(j) = '2-C4H9ONO2 -> 2-C4H9O + NO2'
+
+* 1: IUPAC 2006
+
+ OPEN(UNIT=kin,FILE='DATAJ1/RONO2/2C4H9ONO2_iup2006.abs',
+ $ STATUS='old')
+ DO i = 1, 3
+ READ(kin,*)
+ ENDDO
+ n = 15
+ DO i = 1, n
+ READ(kin,*) x1(i), y1(i)
+ y1(i) = y1(i) * 1.e-20
+ ENDDO
+ CLOSE (kin)
+
+ n1 = n
+ CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1,n1,x1,y1,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yield = 1
+
+ qy = 1.
+
+ DO iw = 1, nw - 1
+ DO i = 1, nz
+ sq(j,i,iw) = qy * yg1(iw)
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
+
+ RETURN
+ END
+
+*============================================================================*
+
+ SUBROUTINE r145(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide product (cross section) x (quantum yield) for =*
+*= perfluoro n-iodo propane (H24) =*
+*= cross section from JPL2011 =*
+*= Quantum yield: Assumed to be 0.55 =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=100)
+
+ INTEGER iw
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+ integer nn
+ INTEGER ierr
+
+* local
+
+ REAL yg(kw)
+ REAL qy, dum
+
+ j = j + 1
+ jlabel(j) = 'perfluoro 1-iodopropane -> products'
+
+* cross section from JPL2011
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/PF-n-iodopropane.abs',STATUS='OLD')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 16
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 0.,0.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,nn,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields assumed unity
+
+ qy = 1.
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ sq(j,i,iw) = qy * yg(iw)
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
+
+ RETURN
+ END
+
+*=============================================================================*
+
+ SUBROUTINE r146(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide product (cross section) x (quantum yield) for =*
+*= molecular Iodine, I2 =*
+*= cross section from JPL2011 =*
+*= Quantum yield: wave-dep, from Brewer and Tellinhuisen, 1972 =*
+*= Quantum yield for Unimolecular Dissociation of I2 in Visible Absorption =*
+*= J. Chem. Phys. 56, 3929-3937, 1972.
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=200)
+
+ INTEGER iw
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+ integer nn
+ INTEGER ierr
+
+* local
+
+ REAL yg1(kw), yg2(kw)
+ REAL qy, dum
+
+ j = j + 1
+ jlabel(j) = 'I2 -> I + I'
+
+* cross section from JPL2011
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/I2_jpl11.abs',STATUS='OLD')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 104
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 0.,0.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg1,nn,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields
+
+ OPEN(UNIT=kin,FILE='DATAJ1/YLD/I2.qy',STATUS='OLD')
+ DO i = 1, 4
+ READ(kin,*)
+ ENDDO
+ n = 12
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ ENDDO
+ CLOSE(kin)
+
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),1.)
+ CALL addpnt(x,y,kdata,nn, 0.,1.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg2,nn,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* combine
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ sq(j,i,iw) = yg1(iw) * yg2(iw)
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
+
+ RETURN
+ END
+
+*============================================================================*
+
+ SUBROUTINE r147(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide product (cross section) x (quantum yield) for =*
+*= Iodine monoxide, IO =*
+*= cross section from JPL2011 =*
+*= Quantum yield: assumed 1.0 =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=200)
+
+ INTEGER iw
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+ integer nn
+ INTEGER ierr
+
+* local
+
+ REAL yg(kw)
+ REAL qy, dum
+
+ j = j + 1
+ jlabel(j) = 'IO -> I + O'
+
+* cross section from JPL2011
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/IO_jpl11.abs',STATUS='OLD')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 133
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 0.,0.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,nn,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields
+
+ qy = 1.
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ sq(j,i,iw) = qy * yg(iw)
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
+
+ RETURN
+ END
+
+*============================================================================*
+
+ SUBROUTINE r148(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide product (cross section) x (quantum yield) for =*
+*= Hypoiodous acid, IOH =*
+*= cross section from JPL2011 =*
+*= Quantum yield: assumed 1.0 =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=300)
+
+ INTEGER iw
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+ integer nn
+ INTEGER ierr
+
+* local
+
+ REAL yg(kw)
+ REAL qy, dum
+
+ j = j + 1
+ jlabel(j) = 'IOH -> I + OH'
+
+* cross section from JPL2011
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/IOH_jpl11.abs',STATUS='OLD')
+ DO i = 1, 2
+ READ(kin,*)
+ ENDDO
+ n = 101
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ nn = n
+ CALL addpnt(x,y,kdata,nn,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 0.,0.)
+ CALL addpnt(x,y,kdata,nn,x(nn)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,nn, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,nn,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields
+
+ qy = 1.
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ sq(j,i,iw) = qy * yg(iw)
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
+
+ RETURN
+ END
+*=============================================================================*
+
+ SUBROUTINE r149(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide the product (cross section) x (quantum yield) for 2-pentanone =*
+*= photolysis: =*
+*= CH3COCH2CH2CH3 + hv -> CH3CO + CH2CH2CH3 =*
+*= =*
+*= Cross section from Martinez et al. (1992) =*
+*= =*
+*= Quantum yield assuumed 0.34 (Griffin et al., 2002) =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+*= Routine added by M. Leriche for specie KETH and KETL of CACM, ReLACS2 =*
+*= and ReLACS3 mecanisms - March 2018 =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=20000)
+
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+
+* local
+
+ REAL yg(kw), dum
+ REAL qy, sig
+ INTEGER ierr
+ INTEGER iw
+
+************************* CH3COCH2CH2CH3 photolysis
+
+ j = j+1
+ jlabel(j) = 'CH3COCH2CH2CH3 -> CH3CO + CH2CH2CH3'
+
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/Martinez.abs',
+ $ STATUS='old')
+ DO i = 1, 4
+ READ(kin,*)
+ ENDDO
+ n = 96
+ DO i = 1, n
+ READ(kin,*) x(i), dum, dum, y(i), dum
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,n, 0.,0.)
+ CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields assumed to be 0.34
+
+ qy = 0.34
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ sig = yg(iw)
+ sq(j,i,iw) = qy * sig
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 0
+
+ RETURN
+ END
+
+*=============================================================================*
+
+ SUBROUTINE r150(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide the product (cross section) x (quantum yield) for nitrate ion =*
+*= photolysis in diluted aqueous atmospheric solution (cloud, rain): =*
+*= NO3- + hv + H2O -> NO2 + OH + OH- =*
+*= =*
+*= Cross section from Graedel and Weschler (1981) =*
+*= =*
+*= Quantum yield from Zellner, Exner and Herrmann (1990) =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+*= Routine added by M. Leriche for ReLACS-AQ and ReLACS3 mecanisms =*
+*= Adapted from TUVLaMP original 05/98 - March 2018 =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=100)
+
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+
+* local
+
+ REAL yg(kw)
+ REAL qy, sig
+ INTEGER ierr
+ INTEGER iw
+
+************************* NO3-(aq) photolysis
+
+ j = j+1
+ jlabel(j) = 'NO3-(aq) -> NO2(aq) + OH(aq)'
+
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABSAQ/NO3-aq.abs',
+ $ STATUS='old')
+ DO i = 1, 6
+ READ(kin,*)
+ ENDDO
+ n = 9
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-20
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,n, 0.,0.)
+ CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields from:
+* Zellner, Exner, Herrmann: Absolute OH quantum Yields
+* in the laser photolysis of nitrate, nitrite and dissolved H2O2
+* at 308 and 351 nm in the temperature range 278-353K, JAC, 1990.
+* Temperature dependency determined at 308 nm and 4<pH<9
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ qy = 0.017 * EXP (1800. *((1./298.)-(1./tlev(i))))
+
+ sig = yg(iw)
+* actinic flux in droplet assumes to be 1.6 the interstitial
+* actinic flux (see Ruggaber, 1997)
+ sq(j,i,iw) = qy * sig *1.6
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 1
+
+ RETURN
+ END
+
+*=============================================================================*
+
+ SUBROUTINE r151(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Provide the product (cross section) x (quantum yield) for H2O2 =*
+*= photolysis in diluted aqueous atmospheric solution (cloud, rain): =*
+*= H2O2 + hv -> OH + OH =*
+*= =*
+*= Cross section from Graedel and Weschler (1981) =*
+*= =*
+*= Quantum yield from Zellner, Exner and Herrmann (1990) =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= WC - REAL, vector of center points of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
+*= Routine added by M. Leriche for ReLACS-AQ and ReLACS3 mecanisms =*
+*= Adapted from TUVLaMP original 05/98 - March 2018 =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
+
+ INTEGER nw
+ REAL wl(kw), wc(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ INTEGER TPFLAG(kj)
+ REAL sq(kj,kz,kw)
+
+* input/output:
+
+ INTEGER j
+
+* data arrays
+
+ INTEGER kdata
+ PARAMETER(kdata=100)
+
+ INTEGER i, n
+ REAL x(kdata), y(kdata)
+
+* local
+
+ REAL yg(kw)
+ REAL qy, sig
+ INTEGER ierr
+ INTEGER iw
+
+************************* H2O2(aq) photolysis
+
+ j = j+1
+ jlabel(j) = 'H2O2(aq) -> OH(aq) + OH(aq)'
+
+
+ OPEN(UNIT=kin,FILE='DATAJ1/ABSAQ/H2O2aq.abs',
+ $ STATUS='old')
+ DO i = 1, 7
+ READ(kin,*)
+ ENDDO
+ n = 11
+ DO i = 1, n
+ READ(kin,*) x(i), y(i)
+ y(i) = y(i) * 1.e-23
+ ENDDO
+ CLOSE(kin)
+
+ CALL addpnt(x,y,kdata,n,x(1)*(1.-deltax),0.)
+ CALL addpnt(x,y,kdata,n, 0.,0.)
+ CALL addpnt(x,y,kdata,n,x(n)*(1.+deltax),0.)
+ CALL addpnt(x,y,kdata,n, 1.e+38,0.)
+ CALL inter2(nw,wl,yg,n,x,y,ierr)
+ IF (ierr .NE. 0) THEN
+ WRITE(*,*) ierr, jlabel(j)
+ STOP
+ ENDIF
+
+* quantum yields from:
+* Zellner, Exner, Herrmann: Absolute OH quantum Yields
+* in the laser photolysis of nitrate, nitrite and dissolved H2O2
+* at 308 and 351 nm in the temperature range 278-353K, JAC, 1990.
+* Temperature dependency determined at 308 nm and pH=9
+
+ DO iw = 1, nw-1
+ DO i = 1, nz
+
+ qy = 0.98 * EXP (660. *((1./298.)-(1./tlev(i))))
+
+ sig = yg(iw)
+* actinic flux in droplet assumes to be 1.6 the interstitial
+* actinic flux (see Ruggaber, 1997)
+ sq(j,i,iw) = qy * sig *1.6
+
+ ENDDO
+ ENDDO
+
+ tpflag(j) = 1
+
+ RETURN
+ END
+
+CCC FILE setaer.f
+* vertical profiles of atmospheric variables
+* setaer
+
+*=============================================================================*
+
+ SUBROUTINE setaer(ipbl, zpbl, aod330,
+ $ tau550, ssaaer, alpha,
+ $ nz, z, nw, wl,
+ $ dtaer, omaer, gaer, kout )
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Set up an altitude profile of aerosols, and corresponding absorption =*
+*= optical depths, single scattering albedo, and asymmetry factor. =*
+*= Single scattering albedo and asymmetry factor can be selected for each =*
+*= input aerosol layer (do not have to correspond to working altitude =*
+*= grid). See loop 27. =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
+*= grid =*
+*= Z - REAL, specified altitude working grid (km) (I)=*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= DTAER - REAL, optical depth due to absorption by aerosols at each (O)=*
+*= altitude and wavelength =*
+*= OMAER - REAL, single scattering albedo due to aerosols at each (O)=*
+*= defined altitude and wavelength =*
+*= GAER - REAL, aerosol asymmetry factor at each defined altitude and (O)=*
+*= wavelength =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+ INTEGER kdata
+ PARAMETER(kdata=51)
+
+* input:
+
+ REAL wl(kw)
+ REAL z(kz)
+ INTEGER nz
+ INTEGER nw
+
+ REAL tau550
+ REAL ssaaer, alpha
+
+* output: (on converted grid)
+ REAL dtaer(kz,kw), omaer(kz,kw), gaer(kz,kw)
+
+* local:
+ REAL zd(kdata), aer(kdata)
+ REAL cd(kdata), omd(kdata), gd(kdata)
+ REAL womd(kdata), wgd(kdata)
+
+ REAL cz(kz)
+ REAL omz(kz)
+ REAL gz(kz)
+
+ REAL colold
+
+ REAL wc, wscale
+ INTEGER i, iw, nd
+
+ REAL fsum
+ EXTERNAL fsum
+
+ REAL zpbl
+ INTEGER ipbl
+
+ REAL aod330
+
+ REAL aodw(kw), ssaw(kw)
+ REAL fract(kz)
+
+*_______________________________________________________________________
+
+* Aerosol data from Elterman (1968)
+* These are vertical optical depths per km, in 1 km
+* intervals from 0 km to 50 km, at 340 nm.
+* This is one option. User can specify different data set.
+
+ DATA aer/
+ 1 2.40E-01,1.06E-01,4.56E-02,1.91E-02,1.01E-02,7.63E-03,
+ 2 5.38E-03,5.00E-03,5.15E-03,4.94E-03,4.82E-03,4.51E-03,
+ 3 4.74E-03,4.37E-03,4.28E-03,4.03E-03,3.83E-03,3.78E-03,
+ 4 3.88E-03,3.08E-03,2.26E-03,1.64E-03,1.23E-03,9.45E-04,
+ 5 7.49E-04,6.30E-04,5.50E-04,4.21E-04,3.22E-04,2.48E-04,
+ 6 1.90E-04,1.45E-04,1.11E-04,8.51E-05,6.52E-05,5.00E-05,
+ 7 3.83E-05,2.93E-05,2.25E-05,1.72E-05,1.32E-05,1.01E-05,
+ 8 7.72E-06,5.91E-06,4.53E-06,3.46E-06,2.66E-06,2.04E-06,
+ 9 1.56E-06,1.19E-06,9.14E-07/
+*_______________________________________________________________________
+
+
+* Altitudes corresponding to Elterman profile, from bottom to top:
+
+ WRITE(kout,*)'aerosols: Elterman (1968) continental profile'
+ nd = 51
+ DO 22, i = 1, nd
+ zd(i) = FLOAT(i-1)
+ 22 CONTINUE
+
+* assume these are point values (at each level), so find column
+* increments
+
+ DO 27, i = 1, nd - 1
+ cd(i) = (aer(i+1) + aer(i)) / 2.
+ omd(i) = ssaaer
+ gd(i) = .61
+ 27 CONTINUE
+
+*********** end data input.
+
+* Compute integrals and averages over grid layers:
+* for g and omega, use averages weighted by optical depth
+
+ DO 29, i = 1, nd-1
+ womd(i) = omd(i) * cd(i)
+ wgd(i) = gd(i) * cd(i)
+ 29 CONTINUE
+ CALL inter3(nz,z,cz, nd,zd,cd, 1)
+ CALL inter3(nz,z,omz, nd, zd,womd, 1)
+ CALL inter3(nz,z,gz , nd, zd,wgd, 1)
+ DO 30, i = 1, nz-1
+ IF (cz(i) .GT. 0.) THEN
+ omz(i) = omz(i)/cz(i)
+ gz(i) = gz(i) /cz(i)
+ ELSE
+ omz(i) = 1.
+ gz(i) = 0.
+ ENDIF
+ 30 CONTINUE
+
+* old column at 340 nm
+* (minimum value is pzero = 10./largest)
+
+ colold = MAX(fsum(nz-1,cz),pzero)
+
+* scale with new column tau at 550 nm
+
+ IF(tau550 .GT. nzero) THEN
+ DO i = 1, nz-1
+ cz(i) = cz(i) * (tau550/colold) * (550./340.)**alpha
+ ENDDO
+ ENDIF
+
+* assign at all wavelengths
+* (can move wavelength loop outside if want to vary with wavelength)
+
+ DO 50, iw = 1, nw - 1
+ wc = (wl(iw)+wl(iw+1))/2.
+
+* Elterman's data are for 340 nm, so assume optical depth scales
+* inversely with first power of wavelength.
+
+ wscale = (340./wc)**alpha
+
+* optical depths:
+
+ DO 40, i = 1, nz - 1
+ dtaer(i,iw) = cz(i) * wscale
+ omaer(i,iw) = omz(i)
+ gaer(i,iw) = gz(i)
+ 40 CONTINUE
+ 50 CONTINUE
+
+*! overwrite for pbl:
+
+ IF(ipbl .GT. 0) THEN
+ write (*,*) 'pbl aerosols, aod330 = ', aod330
+
+* create wavelength-dependent optical depth and single scattering albedo:
+
+ DO iw = 1, nw-1
+ wc = (wl(iw)+wl(iw+1))/2.
+ aodw(iw) = aod330*(wc/330.)**(-1.0)
+ IF(wc .LT. 400.) THEN
+ ssaw(iw) = 0.6
+ ELSE
+ ssaw(iw) = 0.9
+ ENDIF
+ ENDDO
+
+* divide aod among pbl layers, overwrite Elterman profile in pbl
+
+ DO i = 1, ipbl
+ fract(i) = (z(i+1) - z(i))/zpbl
+ ENDDO
+
+ DO iw = 1, nw-1
+ DO i = 1, ipbl
+ dtaer(i, iw) = aodw(iw) * fract(i)
+ omaer(i,iw) = ssaw(iw)
+ ENDDO
+ ENDDO
+
+ ENDIF
+*_______________________________________________________________________
+
+ RETURN
+ END
+
+CCC FILE setalb.f
+*=============================================================================*
+
+ SUBROUTINE setalb(albnew,nw,wl,albedo,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Set the albedo of the surface. The albedo is assumed to be Lambertian, =*
+*= i.e., the reflected light is isotropic, and independent of direction =*
+*= of incidence of light. Albedo can be chosen to be wavelength dependent. =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= ALBEDO - REAL, surface albedo at each specified wavelength (O)=*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input: (wavelength working grid data)
+
+ INTEGER nw
+ REAL wl(kw)
+
+ REAL albnew
+
+* output:
+ REAL albedo(kw)
+
+* local:
+ INTEGER iw
+*_______________________________________________________________________
+
+ DO 10, iw = 1, nw - 1
+ albedo(iw) = albnew
+ 10 CONTINUE
+
+* alternatively, can input wavelenght-dependent values if avaialble.
+*_______________________________________________________________________
+
+ RETURN
+ END
+
+CCC FILE setcld.f
+*======================================================================*
+
+ SUBROUTINE setcld(nz,z,nw,wl,
+ $ lwc, nlevel,
+ $ dtcld,omcld,gcld,kout)
+
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Set cloud properties for each specified altitude layer. Properties =*
+*= may be wavelength dependent. =*
+*= Assumes horizontally infinite homogeneous cloud layers.
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
+*= grid =*
+*= Z - REAL, specified altitude working grid (km) (I)=*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= DTCLD - REAL, optical depth due to absorption by clouds at each (O)=*
+*= altitude and wavelength =*
+*= OMCLD - REAL, single scattering albedo due to clouds at each (O)=*
+*= defined altitude and wavelength =*
+*= GCLD - REAL, cloud asymmetry factor at each defined altitude and (O)=*
+*= wavelength =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+ INTEGER kdata
+C PARAMETER(kdata=51)
+ PARAMETER(kdata=151)
+
+***** input
+
+* (grids)
+ REAL wl(kw)
+ REAL z(kz)
+ INTEGER nz
+ INTEGER nw
+
+* new total cloud optical depth:
+
+ REAL taucld
+C REAL zbase, ztop
+C LWC is the liquid water content (!! kg/m3 !!) on the calling model
+C grid (which has NLEVEL points: Z(1:NLEVEL) = AZ(*)
+ REAL lwc(*)
+ INTEGER nlevel
+
+
+***** Output:
+
+ REAL dtcld(kz,kw), omcld(kz,kw), gcld(kz,kw)
+
+***** specified default data:
+
+ REAL zd(kdata), cd(kdata), omd(kdata), gd(kdata)
+ REAL womd(kdata), wgd(kdata)
+ REAL cldold
+
+* other:
+
+ REAL cz(kz)
+ REAL omz(kz)
+ REAL gz(kz)
+ INTEGER i, iw, n
+ REAL scale
+
+* External functions:
+ REAL fsum
+ EXTERNAL fsum
+*_______________________________________________________________________
+
+* Set up clouds:
+* All clouds are assumed to be infinite homogeneous layers
+* Can have different clouds at different altitudes.
+* If multiple cloud layers are specified, non-cloudy layers
+* between them (if any) must be assigned zero optical depth.
+* Set cloud optical properties:
+* cd(i) = optical depth of i_th cloudy layer
+* omd(i) = singel scattering albedo of i_th cloudy layer
+* gd(i) = asymmetry factorof i_th cloudy layer
+* Cloud top and bottom can be set to any height zd(i), but if they don't
+* match the z-grid (see subroutine gridz.f), they will be interpolated to
+* the z-grid.
+
+* Example: set two separate cloudy layers:
+* cloud 1:
+* base = 4 km
+* top = 7 km
+* optical depth = 20. (6.67 per km)
+* single scattering albedo = 0.9999
+* asymmetry factor = 0.85
+* cloud 2:
+* base = 9 km
+* top = 11 km
+* optical depth = 5. (2.50 per km)
+* single scattering albedo = 0.99999
+* asymmetry factor = 0.85
+
+ n = nlevel + 1
+ if (n .gt. kdata) stop "SETCLD: not enough memory: KDATA"
+ zd(1) = 0.
+ do 110, i = 2, n
+ zd(i) = 0.5*( z(i-1) + z(i) )
+110 continue
+
+C calculate cloud optical properties
+ do 120, i = 1, nlevel
+C
+C reference: Fouquart et al., Rev. Geophys., 1990
+C TAU = 3/2 LWC*DZ / (RHOWATER * Reff)
+C RHOWATER = 1E3 kg/m3
+C Reff = (11 w + 4) 1E-6
+C w = LWC * 1E+3 (in g/cm3, since LWC is given in kg/m3)
+C
+ cd(i) = 1.5 * ( lwc(i) * 1E3*(zd(i+1) - zd(i)) )
+ + / ( 1E3 * (11.*lwc(i)*1E+3+4.) * 1E-6)
+ omd(i) = .9999
+ gd(i) = .85
+C print '(A,I5,99E12.5)', "I,TAU,LWC,REFF(um)"
+C + , i, cd(i), lwc(i)
+C + , ((11.*lwc(i)*1E+3+4.))
+120 continue
+
+
+******************
+* compute integrals and averages over grid layers:
+* for g and omega, use averages weighted by optical depth
+
+ DO 10, i = 1, n-1
+ womd(i) = omd(i) * cd(i)
+ wgd(i) = gd(i) * cd(i)
+ 10 CONTINUE
+ CALL inter3(nz,z,cz, n, zd,cd, 0)
+ CALL inter3(nz,z,omz, n, zd,womd, 0)
+ CALL inter3(nz,z,gz , n, zd,wgd, 0)
+
+ DO 15, i = 1, nz-1
+ IF (cz(i) .GT. 0.) THEN
+ omz(i) = omz(i)/cz(i)
+ gz(i) = gz(i) /cz(i)
+ ELSE
+ omz(i) = 1.
+ gz(i) = 0.
+ ENDIF
+ 15 CONTINUE
+
+* assign at all wavelengths
+* (can move wavelength loop outside if want to vary with wavelength)
+
+ DO 20, iw = 1, nw-1
+ DO 25, i = 1, nz-1
+ dtcld(i,iw) = cz(i)
+ omcld(i,iw) = omz(i)
+ gcld (i,iw) = gz(i)
+ 25 CONTINUE
+ 20 CONTINUE
+*_______________________________________________________________________
+
+ RETURN
+ END
+
+CCC FILE setno2.f
+*=============================================================================*
+
+ SUBROUTINE setno2(ipbl, zpbl, xpbl,
+ $ no2new, nz, z, nw, wl, no2xs,
+ $ tlay, dcol,
+ $ dtno2,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Set up an altitude profile of NO2 molecules, and corresponding absorption=*
+*= optical depths. Subroutine includes a shape-conserving scaling method =*
+*= that allows scaling of the entire profile to a given overhead NO2 =*
+*= column amount. =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NO2NEW - REAL, overhead NO2 column amount (molec/cm^2) to which (I)=*
+*= profile should be scaled. If NO2NEW < 0, no scaling is done =*
+*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
+*= grid =*
+*= Z - REAL, specified altitude working grid (km) (I)=*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NO2XS - REAL, molecular absoprtion cross section (cm^2) of O2 at (I)=*
+*= each specified wavelength =*
+*= TLAY - REAL, temperature (K) at each specified altitude layer (I)=*
+*= DTNO2 - REAL, optical depth due to NO2 absorption at each (O)=*
+*= specified altitude at each specified wavelength =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+ INTEGER kdata
+ PARAMETER(kdata=51)
+
+********
+* input:
+********
+
+* grids:
+
+ REAL wl(kw)
+ REAL z(kz)
+ INTEGER nw
+ INTEGER nz
+ REAL no2new
+
+* mid-layer temperature, layer air column
+
+ REAL tlay(kz), dcol(kz)
+
+********
+* output:
+********
+
+ REAL dtno2(kz,kw)
+
+********
+* local:
+********
+
+* absorption cross sections
+
+ REAL no2xs(kz,kw)
+ REAL cz(kz)
+
+* nitrogen dioxide profile data:
+
+ REAL zd(kdata), no2(kdata)
+ REAL cd(kdata)
+ REAL hscale
+ REAL colold, scale
+ REAL sno2
+ REAL zpbl, xpbl
+ INTEGER ipbl
+
+* other:
+
+ INTEGER i, l, nd
+
+
+********
+* External functions:
+********
+
+ REAL fsum
+ EXTERNAL fsum
+
+*_______________________________________________________________________
+* Data input:
+
+* Example: set to 1 ppb in lowest 1 km, set to zero above that.
+* - do by specifying concentration at 3 altitudes.
+
+ nd = 3
+ zd(1) = 0.
+ no2(1) = 1. * 2.69e10
+
+ zd(2) = 1.
+ no2(2) = 1. * 2.69e10
+
+ zd(3) = zd(2)* 1.000001
+ no2(3) = 10./largest
+
+* compute column increments (alternatively, can specify these directly)
+
+ DO 11, i = 1, nd - 1
+ cd(i) = (no2(i+1)+no2(i)) * 1.E5 * (zd(i+1)-zd(i)) / 2.
+ 11 CONTINUE
+
+* Include exponential tail integral from top level to infinity.
+* fold tail integral into top layer
+* specify scale height near top of data (use ozone value)
+
+ hscale = 4.50e5
+ cd(nd-1) = cd(nd-1) + hscale * no2(nd)
+
+***********
+*********** end data input.
+
+* Compute column increments and total column on standard z-grid.
+
+ CALL inter3(nz,z,cz, nd,zd,cd, 1)
+
+**** Scaling of vertical profile by ratio of new to old column:
+* If old column is near zero (less than 1 molec cm-2),
+* use constant mixing ratio profile (nominal 1 ppt before scaling)
+* to avoid numerical problems when scaling.
+
+ IF(fsum(nz-1,cz) .LT. 1.) THEN
+ DO i = 1, nz-1
+ cz(i) = 1.E-12 * dcol(i)
+ ENDDO
+ ENDIF
+ colold = fsum(nz-1, cz)
+ scale = 2.687e16 * no2new / colold
+
+ DO i = 1, nz-1
+ cz(i) = cz(i) * scale
+ ENDDO
+
+*! overwrite for specified pbl height
+
+ IF(ipbl .GT. 0) THEN
+ write(*,*) 'pbl NO2 = ', xpbl, ' ppb'
+
+ DO i = 1, nz-1
+ IF (i .LE. ipbl) THEN
+ cz(i) = xpbl*1.E-9 * dcol(i)
+ ELSE
+ cz(i) = 0.
+ ENDIF
+ ENDDO
+ ENDIF
+
+************************************
+* calculate optical depth for each layer. Output: dtno2(kz,kw)
+
+98 continue
+ DO 20, l = 1, nw-1
+ DO 10, i = 1, nz-1
+ dtno2(i,l) = cz(i)*no2xs(i,l)
+ 10 CONTINUE
+ 20 CONTINUE
+*_______________________________________________________________________
+
+ RETURN
+ END
+
+CCC FILE seto2.f
+*=============================================================================*
+
+ SUBROUTINE seto2(nz, z, nw, wl, cz, o2xs1, dto2, kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Set up an altitude profile of air molecules. Subroutine includes a =*
+*= shape-conserving scaling method that allows scaling of the entire =*
+*= profile to a given sea-level pressure. =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
+*= grid =*
+*= Z - REAL, specified altitude working grid (km) (I)=*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= and each specified wavelength =*
+*= CZ - REAL, number of air molecules per cm^2 at each specified (O)=*
+*= altitude layer =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input: (grids)
+
+ REAL wl(kw)
+ REAL z(kz)
+ INTEGER iw, nw
+ INTEGER iz, nz
+ REAL cz(kz)
+ REAL o2xs1(kw)
+
+* output:
+* O2 absorption optical depth per layer at each wavelength
+
+ REAL dto2(kz,kw)
+
+*_______________________________________________________________________
+* Assumes that O2 = 20.95 % of air density. If desire different O2
+* profile (e.g. for upper atmosphere) then can load it here.
+
+ DO iz = 1, nz
+ DO iw =1, nw - 1
+ dto2(iz,iw) = 0.2095 * cz(iz) * o2xs1(iw)
+ ENDDO
+ ENDDO
+
+*_______________________________________________________________________
+
+ RETURN
+ END
+
+
+CCC FILE setsnw.f
+* This file contains the following subroutines related to spectral optical
+* propersties of snowpack needed to compute actinic fluxes
+* setsnw
+* rdice_acff
+*=============================================================================*
+
+ SUBROUTINE setsnw(nz,z,nw,wl,dtsnw,omsnw,gsnw,kout)
+
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Set optical and physical properties for snowpack. =*
+*= Currently for wavelength-independent properties. =*
+*= Subroutine outputs spectral quantities. =*
+*= Lee-Taylor, J., and S. Madronich (2002), Calculation of actinic fluxes =*
+*= with a coupled atmosphere-snow radiative transfer model, J. Geophys. =*
+*= Res., 107(D24) 4796 (2002) doi:10.1029/2002JD002084 =*
+*-----------------------------------------------------------------------------*
+*= USER-DEFINED VARIABLES: =*
+*= zs - height (km) of snow layer boundary above GROUND level =*
+*= snwdens - density (g/cm3) =*
+*= ksct - mass-specific scattering coefficient (m2/kg) =*
+*= csoot - soot content (ng Carbon / g snow) =*
+*= snow - (=T/F) switch for presence of snow
+*= =*
+*= PARAMETERS: =*
+*= nz - INTEGER, number of specified altitude levels in the working (I)=*
+*= grid =*
+*= z - REAL, specified altitude working grid (km) (I)=*
+*= nw - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= wl - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= dtsnw - REAL, optical depth due to absorption by snow at each (O)=*
+*= altitude and wavelength =*
+*= omsnw - REAL, single scattering albedo due to snow at each (O)=*
+*= defined altitude and wavelength =*
+*= gsnw - REAL, snow asymmetry factor at each defined altitude and (O)=*
+*= wavelength =*
+*= rabs - absorption coefficient of snow, wavelength-dependent =*
+*= rsct - scattering coefficient of snow, assume wavelength-independent =*
+*-----------------------------------------------------------------------------*
+*= EDIT HISTORY: =*
+*= 10/00 adapted from setcld.f, Julia Lee-Taylor, ACD, NCAR =*
+*-----------------------------------------------------------------------------*
+*= This program is free software; you can redistribute it and/or modify =*
+*= it under the terms of the GNU General Public License as published by the =*
+*= Free Software Foundation; either version 2 of the license, or (at your =*
+*= option) any later version. =*
+*= The TUV package is distributed in the hope that it will be useful, but =*
+*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
+*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
+*= License for more details. =*
+*= To obtain a copy of the GNU General Public License, write to: =*
+*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
+*-----------------------------------------------------------------------------*
+*= To contact the authors, please mail to: =*
+*= Jula Lee-Taylor, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
+*= send email to: julial@ucar.edu =*
+*-----------------------------------------------------------------------------*
+
+ IMPLICIT NONE
+c INCLUDE 'params'
+
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
+
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
+
+* some constants...
+
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
+
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
+
+* Planck constant x speed of light, J m
+
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
+
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
+
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+ INTEGER kdata
+ PARAMETER(kdata=51)
+
+* input: (grids)
+ REAL wl(kw)
+ REAL z(kz)
+ INTEGER nz
+ INTEGER nw
+
+* Output:
+ REAL dtsnw(kz,kw), omsnw(kz,kw), gsnw(kz,kw)
+
+* local:
+
+* specified data:
+ REAL zs(kdata),dzs
+ REAL cd(kdata), omd(kdata), gd
+ REAL snwdens(kdata) ! snwdens = snow density, g/cm3
+ REAL csoot(kdata) ! conc of elemental carbon, ng/g
+ REAL r_ice(kw),rsoot
+ REAL womd(kdata), wgd(kdata)
+ REAL rsct(kdata),ksct(kdata),rabs(kdata)
+
+* other:
+ REAL cz(kz),omz(kz),gz(kz)
+ INTEGER i,is,iw,iz,nsl
+
+* External functions:
+ REAL fsum
+ EXTERNAL fsum
+*--------------------------------------------------------------------------
+* SNOW PROPERTIES: USER-DEFINED
+*--------------------------------------------------------------------------
+** define "number of snow layers + 1" (0 = no snow, 2 = single snow layer)
+ nsl = 0
+
+ IF(nsl.GE.2)THEN
+** define snow grid, zs(ns), in km above GROUND level
+* NOTE: to get good vertical resolution, subroutine gridz (in grids.f) should
+* be modified to include small (1cm - 1mm) layers near snowpack top.
+
+ zs(1) = 0.0
+ zs(2) = 0.001
+
+** define snow scattering coefficient, ksct, m2/kg snow
+* melting midlatitude maritime (mountain) snow, ksct = 1-5 m2/kg_snow
+* warmer polar coastal/maritime snow, ksct = 6-13 m2/kg_snow
+* cold dry polar/tundra snow, ksct = 20-30 m2/kg_snow
+* Fisher, King and Lee-Taylor (2005), JGR 110(D21301) doi:10.1029/2005JD005963
+
+ ksct(1) = 25. ! m2.kg-1 snow
+
+** define snow density, snwdens, g/cm3
+
+ snwdens(1) = 0.4 ! g/cm3
+
+** define soot content, csoot, ng/g elemental carbon
+
+ csoot(1) = 0. ! ng/g elemental carbon
+
+*----------------------------------------------------------------------------
+* SNOW PROPERTIES: FROM LITERATURE
+*--------------------------------------------------------------------------
+* read absorption coefficients
+ CALL rdice_acff(nw,wl,r_ice,kout) ! cm^-1 ice
+
+* absorption due to soot, assume wavelength-independent
+* rsoot ~ 10 m2/gC @500nm : Warren & Wiscombe, Nature 313,467-470 (1985)
+ rsoot = 10. ! m2/gC
+
+* asymmetry factor : Wiscombe & Warren, J. Atmos. Sci, 37, 2712-2733 (1980)
+ gd = 0.89
+*----------------------------------------------------------------------------
+
+* loop snow layers, assigning optical properties at each wavelength
+ DO 17, iw = 1, nw-1
+ DO 11 is = 1,nsl-1
+ rsct(is)=ksct(is)*snwdens(is)*1.e+3 ! m-1
+ rsct(is)=rsct(is)*(zs(is+1)-zs(is))*1.e+3 ! no units
+
+ rabs(is) = (r_ice(iw)/0.9177*1.e5 + rsoot*csoot(is))
+ $ * snwdens(is)*(zs(is+1)-zs(is)) ! no units
+
+ cd(is) = rsct(is) + rabs(is)
+ omd(is)= rsct(is) / cd(is)
+
+ if(iw.EQ.1)then
+ print*,"Snowpack: is =",is,"; zs =",zs(is)
+ PRINT*," ksct =", ksct(is)
+ PRINT*," density =",snwdens(is)
+ PRINT*," csoot =",csoot(is)
+ PRINT*, 'cd = ',cd(is),' omd = ',omd(is),' gd = ',gd
+ WRITE(kout,*)'snwdens = ',snwdens,' g/cm3'
+ WRITE(kout,*)'ksct_snow = ',ksct(is),' m2.kg-1'
+ WRITE(kout,*)'soot = ',csoot(is),' ng/g'
+ WRITE(kout,*)'cd = ',cd(is),'omd = ',omd(is),'gd = ',gd
+ endif
+
+* compute integrals and averages over snow layers:
+* for g and omega, use averages weighted by optical depth
+ womd(is) = omd(is) * cd(is)
+ wgd(is) = gd * cd(is)
+ 11 CONTINUE
+
+* interpolate snow layers onto TUV altitude grid (gridz)
+ CALL inter3(nz,z,cz, nsl,zs,cd, 0)
+ CALL inter3(nz,z,omz,nsl,zs,womd, 0)
+ CALL inter3(nz,z,gz ,nsl,zs,wgd, 0)
+
+ DO 15, iz = 1, nz-1
+ IF (cz(iz) .GT. 0.) THEN
+ omz(iz) = omz(iz)/cz(iz)
+ gz(iz) = gz(iz) /cz(iz)
+ ELSE
+ omz(iz) = 0.
+ gz(iz) = 0.
+ ENDIF
+ dtsnw(iz,iw) = cz(iz)
+ omsnw(iz,iw) = omz(iz)
+ gsnw(iz,iw) = gz(iz)
+ 15 CONTINUE
+ 17 CONTINUE
+
+ PRINT*,"Snowpack top: zs =",zs(nsl)
+
+ ELSE ! no snow
+ DO 16, iz = 1, nz-1
+ cz(iz) = 0.
+ omz(iz) = 1.
+ gz(iz) = 0.
+ DO 18, iw = 1, nw-1
+ dtsnw(iz,iw) = cz(iz)
+ omsnw(iz,iw) = omz(iz)
+ gsnw(iz,iw) = gz(iz)
+ 18 CONTINUE
+ 16 CONTINUE
+ ENDIF ! snow exists
+
+ RETURN
+ END
+
+*******************************************************************************
+ SUBROUTINE rdice_acff(nw,wl,rabs,kout)
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Read ice absorption coefficient. Re-grid data to match =*
+*= specified wavelength working grid. =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= RABS_ice - REAL, absorption coefficient (cm^-1) of ice at (O)=*
+*= each specified wavelength =*
+*-----------------------------------------------------------------------------*
+*= EDIT HISTORY: =*
+*= 10/00 Created routine by editing rdh2oxs. =*
+*-----------------------------------------------------------------------------*
+*= This program is free software; you can redistribute it and/or modify =*
+*= it under the terms of the GNU General Public License as published by the =*
+*= Free Software Foundation; either version 2 of the license, or (at your =*
+*= option) any later version. =*
+*= The TUV package is distributed in the hope that it will be useful, but =*
+*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
+*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
+*= License for more details. =*
+*= To obtain a copy of the GNU General Public License, write to: =*
+*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
+*-----------------------------------------------------------------------------*
+*= To contact the authors, please mail to: =*
+*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
+*= send email to: sasha@ucar.edu =*
+*-----------------------------------------------------------------------------*
- j = j + 1
- label(j) = 'Plant damage (Caldwell, 1971)'
+ IMPLICIT NONE
+c INCLUDE 'params'
-* Fit to Caldwell (1971) data by
-* Green, A. E. S., T. Sawada, and E. P. Shettle, The middle
-* ultraviolet reaching the ground, Photochem. Photobiol., 19,
-* 251-259, 1974.
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
- DO iw = 1, nw-1
- s(j,iw) = 2.628*(1. - (wc(iw)/313.3)**2)*
- $ exp(-(wc(iw)-300.)/31.08)
- IF( s(j,iw) .LT. 0. .OR. wc(iw) .GT. 313.) THEN
- s(j,iw) = 0.
- ENDIF
- ENDDO
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
-* Alternative fit to Caldwell (1971) by
-* Micheletti, M. I. and R. D. Piacentini, Photochem. Photobiol.,
-* 76, pp.?, 2002.
+* some constants...
- a0 = 570.25
- a1 = -4.70144
- a2 = 0.01274
- a3 = -1.13118E-5
- DO iw = 1, nw-1
- s(j,iw) = a0 + a1*wc(iw) + a2*wc(iw)**2 + a3*wc(iw)**3
- IF( s(j,iw) .LT. 0. .OR. wc(iw) .GT. 313.) THEN
- s(j,iw) = 0.
- ENDIF
- ENDDO
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
-****** Plant damage - Flint & Caldwell 2003
-* Flint, S. D. and M. M. Caldwell, A biological spectral weigthing
-* function for ozone depletion research with higher plants, Physiologia
-* Plantorum, in press, 2003.
-* Data available to 366 nm
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
- j = j + 1
- label(j) = 'Plant damage (Flint & Caldwell, 2003)'
+* Planck constant x speed of light, J m
- DO iw = 1, nw-1
- s(j,iw) = EXP( 4.688272*EXP(
- $ -EXP(0.1703411*(wc(iw)-307.867)/1.15))+
- $ ((390-wc(iw))/121.7557-4.183832) )
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
-* put on per joule (rather than per quantum) basis:
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
- s(j,iw) = s(j,iw) * wc(iw)/300.
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
- IF( s(j,iw) .LT. 0. .OR. wc(iw) .GT. 366.) THEN
- s(j,iw) = 0.
- ENDIF
-
- ENDDO
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
-****** Vitamin D - CIE 2006
-* Action spectrum for the production fo previtamin-D3 in human skin,
-* CIE Techincal Report TC 6-54, Commission Internatinale del'Eclairage, 2006.
-* Wavelength range of data is 252-330 nm, but Values below 260 nm and beyond
-* 315 nm were interpolated by CIE using a spline fit.
-* TUV also assigns the 252nm value to shorter wavelengths, and zero
-* beyond 330nm.
+ INTEGER kdata
+ PARAMETER(kdata=1000)
- j = j + 1
- label(j) = 'Previtamin-D3 (CIE 2006)'
+* input: (altitude working grid)
+ INTEGER nw
+ REAL wl(kw)
- OPEN(UNIT=kin,FILE='DATAS1/vitamin_D.txt',STATUS='old')
- DO i = 1, 7
- READ(kin,*)
- ENDDO
- n = 79
- DO i = 1, n
- READ(kin,*) x1(i), y1(i)
- ENDDO
+* output:
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
- CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, label(j)
- STOP
- ENDIF
+ REAL rabs(kw)
- DO iw = 1, nw-1
- s(j,iw) = yg(iw)
- ENDDO
- CLOSE(kin)
+* local:
+ REAL x1(kdata)
+ REAL y1(kdata),y2(kdata),y3(kdata)
+ REAL yg(kw)
+ REAL a1, a2, dum
+ INTEGER ierr
+ INTEGER i,l,m, n, idum
+ CHARACTER*40 fil
+*_______________________________________________________________________
-****** Non-melanoma skin cancer, CIE 2006.
-* Action spectrum for the induction of non-melanoma skin cancer. From:
-* Photocarcinogenesis Action Spectrum (Non-Melanoma Skin Cancers),
-* CIE S 019/E:2006, Commission Internationale de l'Eclairage, 2006.
-* 1 nm spacing from 250 to 400 nm. Normalized at maximum, 299 nm.
-* Set constanta at 3.94E-04 between 340 and 400 nm.
-* Assume zero beyond 400 nm.
-* Assume constant below 250 nm.
+************* absorption cross sections:
+* ice absorption cross sections from
- j = j + 1
- label(j) = 'NMSC (CIE 2006)'
+ fil = 'DATA/ice'
+ OPEN(UNIT=kin,FILE='DATAJ1/ABS/ICE_Perov.acff',STATUS='old')
+ m = 17 ! header lines
+ n = 79 ! data lines
+ !OPEN(UNIT=kin,FILE='DATAJ1/ABS/ICE_min.acff',STATUS='old')
+ !m = 13 ! header lines
+ !n = 52 ! data lines
- OPEN(UNIT=kin,FILE='DATAS1/nmsc_cie.txt',STATUS='old')
- DO i = 1, 7
- READ(kin,*)
- ENDDO
- n = 151
- DO i = 1, n
+ DO 11, i = 1,m
+ read(kin,*)
+ 11 CONTINUE
+ DO 12, i = 1, n
READ(kin,*) x1(i), y1(i)
- ENDDO
+ 12 CONTINUE
+ CLOSE (kin)
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
- CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
+ CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 0.,0.)
+ CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.)
+ CALL addpnt(x1,y1,kdata,n, 1.e+38,0.)
CALL inter2(nw,wl,yg,n,x1,y1,ierr)
IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, label(j)
+ WRITE(*,*) ierr, fil
STOP
ENDIF
+
+ DO 13, l = 1, nw-1
+ rabs(l) = yg(l)
+ 13 CONTINUE
- DO iw = 1, nw-1
- s(j,iw) = yg(iw)
- ENDDO
- CLOSE(kin)
-****************************************************************
-****************************************************************
-*_______________________________________________________________________
-
- IF (j .GT. ks) STOP '1001'
*_______________________________________________________________________
RETURN
END
-* This file contains the following subroutines, related to specifying
-* chemical spectral weighting functions (cross sections x quantum yields)
-* swphys
+CCC FILE setso2.f
*=============================================================================*
- SUBROUTINE swchem(nw,wl,nz,tlev,airden,
- $ j,sq,jlabel)
+ SUBROUTINE setso2(ipbl, zpbl, xpbl,
+ $ so2new, nz, z, nw, wl, so2xs,
+ $ tlay, dcol,
+ $ dtso2,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Load various "weighting functions" (products of cross section and =*
-*= quantum yield at each altitude and each wavelength). The altitude =*
-*= dependence is necessary to ensure the consideration of pressure and =*
-*= temperature dependence of the cross sections or quantum yields. =*
-*= The actual reading, evaluation and interpolation is done in separate =*
-*= subroutines for ease of management and manipulation. Please refer to =*
-*= the inline documentation of the specific subroutines for detail =*
-*= information. =*
+*= Set up an altitude profile of SO2 molecules, and corresponding absorption=*
+*= optical depths. Subroutine includes a shape-conserving scaling method =*
+*= that allows scaling of the entire profile to a given overhead SO2 =*
+*= column amount. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
+*= SO2NEW - REAL, overhead SO2 column amount (molec/cm^2) to which (I)=*
+*= profile should be scaled. If SO2NEW < 0, no scaling is done =*
+*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
+*= grid =*
+*= Z - REAL, specified altitude working grid (km) (I)=*
*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
*= wavelength grid =*
*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
*= working wavelength grid =*
-*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
-*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
-*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
-*= J - INTEGER, counter for number of weighting functions defined (IO)=*
-*= SQ - REAL, cross section * quantum yield (cm^2) for each (O)=*
-*= photolysis reaction defined, at each defined wavelength and =*
-*= at each defined altitude level =*
-*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
-*= defined =*
+*= SO2XS - REAL, molecular absoprtion cross section (cm^2) of O2 at (I)=*
+*= each specified wavelength =*
+*= TLAY - REAL, temperature (K) at each specified altitude layer (I)=*
+*= DTSO2 - REAL, optical depth due to SO2 absorption at each (O)=*
+*= specified altitude at each specified wavelength =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
@@ -37145,7 +41571,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -37157,9 +41583,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -37196,296 +41620,388 @@ c INCLUDE 'params'
REAL precis
PARAMETER(precis = 1.e-7)
-* input
+ INTEGER kdata
+ PARAMETER(kdata=51)
+
+********
+* input:
+********
+
+* grids:
- INTEGER nw
REAL wl(kw)
-
+ REAL z(kz)
+ INTEGER nw
INTEGER nz
+ REAL so2new
- REAL tlev(kz)
- REAL airden(kz)
+* mid-layer temperature and layer air column
-* weighting functions
+ REAL tlay(kz), dcol(kz)
- CHARACTER*50 jlabel(kj)
- REAL sq(kj,kz,kw)
+********
+* output:
+********
-* input/output:
- INTEGER j
+ REAL dtso2(kz,kw)
+********
* local:
- REAL wc(kw)
- INTEGER iw
-*_______________________________________________________________________
-
-* complete wavelength grid
-
- DO 5, iw = 1, nw - 1
- wc(iw) = (wl(iw) + wl(iw+1))/2.
- 5 CONTINUE
-
-*____________________________________________________________________________
-
-* O2 + hv -> O + O
-* reserve first position. Cross section parameterization in Schumman-Runge and
-* Lyman-alpha regions are zenith-angle dependent, will be written in
-* subroutine seto2.f.
-*
-* Warning call positions have been changer to match the same order than
-* previous versions
-* Only 21 jvalues out of 90 are calculated which correspond to ReLACS scheme
-
- j = 1
- jlabel(j) = 'O2 -> O + O'
-
-* NO2 + hv -> NO + O(3P)
- CALL r02(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
-
-* O3 + hv -> (both channels)
- CALL r01(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
-
-* NO3 + hv -> (both channels)
- CALL r03(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
-
-* N2O5 + hv -> (both channels)
- CALL r04(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
-
-* HNO2 + hv -> OH + NO
- CALL r05(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
-
-* HNO3 + hv -> OH + NO2
- CALL r06(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
-
-* HNO4 + hv -> HO2 + NO2
- CALL r07(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
-
-* H2O2 + hv -> 2 OH
- CALL r08(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+********
-* CH2O + hv -> (both channels)
- CALL r10(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* absorption cross sections
-* CH3(OOH) + hv -> CH3O + OH
- CALL r16(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ REAL so2xs(kw)
+ REAL cz(kz)
-* CH3(ONO2) + hv -> CH3O + NO2
- CALL r17(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* sulfur dioxide profile data:
-* CH3CHO + hv -> (all three channels)
- CALL r11(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ REAL zd(kdata), so2(kdata)
+ REAL cd(kdata)
+ REAL hscale
+ REAL colold, scale
+ REAL sso2
+ REAL zpbl, xpbl
+ INTEGER ipbl
-* CH3COCH3 + hv -> Products
- CALL r15(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* other:
-* PAN + hv -> CH3CO(OO) + NO2
-* PAN + hv -> CH3CO(O) + NO3
-c CALL r18(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
-
-* HO2 + hv -> OH + O
- CALL r39(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ INTEGER i, l, nd
-* N2O + hv -> N2 + O(1D)
-c CALL r44(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+********
+* External functions:
+********
-* NO3-(aq) + hv -> NO2 + O- (for snow)
-* NO3-(aq) + hv -> NO2- + O(3P) (for snow)
-c CALL r118(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ REAL fsum
+ EXTERNAL fsum
-* C2H5CHO + hv -> C2H5 + HCO
-c CALL r12(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+*_______________________________________________________________________
+* Data input:
-* CH2(OH)CHO + hv -> Products
-c CALL r101(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* Example: set to 1 ppb in lowest 1 km, set to zero above that.
+* - do by specifying concentration at 3 altitudes.
-* CH2=CHCHO + hv -> Products
-c CALL r122(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ nd = 3
+ zd(1) = 0.
+ so2(1) = 1. * 2.69e10
-* CH2=C(CH3)CHO + hv -> Products
-c CALL r104(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ zd(2) = 1.
+ so2(2) = 1. * 2.69e10
-* CH3COCHCH2 + hv -> Products
-c CALL r103(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ zd(3) = zd(2)* 1.000001
+ so2(3) = 10./largest
-* CH3COCH2CH3 -> CH3CO + CH2CH3
-c CALL r119(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* compute column increments (alternatively, can specify these directly)
-* CH2(OH)COCH3 -> CH3CO + CH2(OH)
-* CH2(OH)COCH3 -> CH2(OH)CO + CH3
-c CALL r112(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ DO 11, i = 1, nd - 1
+ cd(i) = (so2(i+1)+so2(i)) * 1.E5 * (zd(i+1)-zd(i)) / 2.
+ 11 CONTINUE
-* HOCH2OOH -> HOCH2O. + OH
-c CALL r121(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* Include exponential tail integral from top level to infinity.
+* fold tail integral into top layer
+* specify scale height near top of data (use ozone value)
-* CH3CO(OOH) + hv -> Products
-c CALL r123(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ hscale = 4.50e5
+ cd(nd-1) = cd(nd-1) + hscale * so2(nd)
-* CH3CH2(ONO2) -> CH3CH2O + NO2
-c CALL r106(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+***********
+*********** end data input.
-* CH3CH(ONO2)CH3 -> CH3CHOCH3 + NO2
-c CALL r107(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* Compute column increments on standard z-grid.
-* CH2(OH)CH2(ONO2) -> CH2(OH)CH2(O.) + NO2
-c CALL r108(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ CALL inter3(nz,z,cz, nd,zd,cd, 1)
-* CH3COCH2(ONO2) -> CH3COCH2(O.) + NO2
-c CALL r109(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+**** Scaling of vertical profile by ratio of new to old column:
+* If old column is near zero (less than 1 molec cm-2),
+* use constant mixing ratio profile (nominal 1 ppt before scaling)
+* to avoid numerical problems when scaling.
-* C(CH3)3(ONO2) -> C(CH3)3(O.) + NO2
-c CALL r110(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ IF(fsum(nz-1,cz) .LT. 1.) THEN
+ DO i = 1, nz-1
+ cz(i) = 1.E-12 * dcol(i)
+ ENDDO
+ ENDIF
+ colold = fsum(nz-1,cz)
+ scale = 2.687e16 * so2new / colold
+ DO i = 1, nz-1
+ cz(i) = cz(i) * scale
+ ENDDO
-* CH3CH2COO2NO2 -> CH3CH2CO(OO) + NO2
-* CH3CH2COO2NO2 -> CH2CH2CO(O) + NO3
-c CALL r120(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+*! overwrite for specified pbl height, set concentration here
-* CHOCHO + hv -> Products
-c CALL r13(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ IF(ipbl .GT. 0) THEN
+ write(*,*) 'pbl SO2 = ', xpbl, ' ppb'
-* CH3COCHO + hv -> Products
-c CALL r14(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ DO i = 1, nz-1
+ IF (i .LE. ipbl) THEN
+ cz(i) = xpbl*1.E-9 * dcol(i)
+ ELSE
+ cz(i) = 0.
+ ENDIF
+ ENDDO
+ ENDIF
-* CH3COCOCH3 + hv -> Products
-c CALL r102(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+************************************
+* calculate sulfur optical depth for each layer, with optional temperature
+* correction. Output, dtso2(kz,kw)
-* CH3COCO(OH) + hv -> Products
-c CALL r105(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ DO 20, l = 1, nw-1
+ sso2 = so2xs(l)
+ DO 10, i = 1, nz - 1
-* Cl2 + hv -> Cl + Cl
-c CALL r47(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+c Leaving this part in in case i want to interpolate between
+c the 221K and 298K data.
+c
+c IF ( wl(l) .GT. 240.5 .AND. wl(l+1) .LT. 350. ) THEN
+c IF (tlay(i) .LT. 263.) THEN
+c sso2 = s221(l) + (s263(l)-s226(l)) / (263.-226.) *
+c $ (tlay(i)-226.)
+c ELSE
+c sso2 = s263(l) + (s298(l)-s263(l)) / (298.-263.) *
+c $ (tlay(i)-263.)
+c ENDIF
+c ENDIF
-* ClOOCl -> Cl + ClOO
-c CALL r111(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ dtso2(i,l) = cz(i)*sso2
-* ClOO + hv -> Products
-c CALL r31(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ 10 CONTINUE
+ 20 CONTINUE
+*_______________________________________________________________________
-* ClONO2 + hv -> Products
-c CALL r45(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ RETURN
+ END
-* Br2 -> Br + Br
-c CALL r115(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+CCC FILE sphers.f
+* This file contains the following subroutines, related to the
+* spherical geometry of the Earth's atmosphere
+* sphers
+* airmas
+*=============================================================================*
-* BrO -> Br + O
-c CALL r114(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ SUBROUTINE sphers(nz, z, zen, dsdh, nid, kout)
-* HOBr -> OH + Br
-c CALL r113(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Calculate slant path over vertical depth ds/dh in spherical geometry. =*
+*= Calculation is based on: A.Dahlback, and K.Stamnes, A new spheric model =*
+*= for computing the radiation field available for photolysis and heating =*
+*= at twilight, Planet.Space Sci., v39, n5, pp. 671-683, 1991 (Appendix B) =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
+*= grid =*
+*= Z - REAL, specified altitude working grid (km) (I)=*
+*= ZEN - REAL, solar zenith angle (degrees) (I)=*
+*= DSDH - REAL, slant path of direct beam through each layer crossed (O)=*
+*= when travelling from the top of the atmosphere to layer i; =*
+*= DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1 =*
+*= NID - INTEGER, number of layers crossed by the direct beam when (O)=*
+*= travelling from the top of the atmosphere to layer i; =*
+*= NID(i), i = 0..NZ-1 =*
+*-----------------------------------------------------------------------------*
+*= EDIT HISTORY: =*
+*= double precision fix for shallow layers - Julia Lee-Taylor Dec 2000 =*
+*-----------------------------------------------------------------------------*
+*= This program is free software; you can redistribute it and/or modify =*
+*= it under the terms of the GNU General Public License as published by the =*
+*= Free Software Foundation; either version 2 of the license, or (at your =*
+*= option) any later version. =*
+*= The TUV package is distributed in the hope that it will be useful, but =*
+*= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- =*
+*= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public =*
+*= License for more details. =*
+*= To obtain a copy of the GNU General Public License, write to: =*
+*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. =*
+*-----------------------------------------------------------------------------*
+*= To contact the authors, please mail to: =*
+*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA or =*
+*= send email to: sasha@ucar.edu =*
+*-----------------------------------------------------------------------------*
-* BrONO2 + hv -> Products
-c CALL r46(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ IMPLICIT NONE
+c INCLUDE 'params'
-* CH3Cl + hv -> Products
-c CALL r30(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
-* CCl2O + hv -> Products
-c CALL r19(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
-* CCl4 + hv -> Products
-c CALL r20(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* some constants...
-* CClFO + hv -> Products
-c CALL r21(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
-* CCF2O + hv -> Products
-c CALL r22(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
-* CF2ClCFCl2 (CFC-113) + hv -> Products
-c CALL r23(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* Planck constant x speed of light, J m
-* CF2ClCF2Cl (CFC-114) + hv -> Products
-c CALL r24(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
-* CF3CF2Cl (CFC-115) + hv -> Products
-c CALL r25(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
-* CCl3F (CFC-111) + hv -> Products
-c CALL r26(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
-* CCl2F2 (CFC-112) + hv -> Products
-c CALL r27(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
-* CH3CCl3 + hv -> Products
-c CALL r29(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* input
+ INTEGER nz
+ REAL zen, z(kz)
-* CF3CHCl2 (HCFC-123) + hv -> Products
-c CALL r32(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* output
+ INTEGER nid(0:kz)
+ REAL dsdh(0:kz,kz)
-* CF3CHFCl (HCFC-124) + hv -> Products
-c CALL r33(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* more program constants
+ REAL re, ze(kz)
+ REAL dr
+ PARAMETER ( dr = pi/180.)
-* CH3CFCl2 (HCFC-141b) + hv -> Products
-c CALL r34(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* local
-* CH3CF2Cl (HCFC-142b) + hv -> Products
-c CALL r35(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ DOUBLE PRECISION zenrad, rpsinz, rj, rjp1, dsj, dhj, ga, gb, sm
+ INTEGER i, j, k
+ INTEGER id
-* CF3CF2CHCl2 (HCFC-225ca) + hv -> Products
-c CALL r36(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ INTEGER nlayer
+ REAL zd(0:kz-1)
-* CF2ClCF2CHFCl (HCFC-225cb) + hv -> Products
-c CALL r37(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+*-----------------------------------------------------------------------------
-* CHClF2 (HCFC-22) + hv -> Products
-c CALL r38(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ zenrad = zen*dr
-* CH3Br + hv -> Products
-c CALL r28(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* number of layers:
+ nlayer = nz - 1
-* CHBr3 + hv -> Products
-c CALL r09(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* include the elevation above sea level to the radius of the earth:
+ re = radius + z(1)
+* correspondingly z changed to the elevation above earth surface:
+ DO k = 1, nz
+ ze(k) = z(k) - z(1)
+ END DO
-* CF3Br (Halon-1301) + hv -> Products
-c CALL r42(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* inverse coordinate of z
+ zd(0) = ze(nz)
+ DO k = 1, nlayer
+ zd(k) = ze(nz - k)
+ END DO
-* CF2BrCF2Br (Halon-2402) + hv -> Products
-c CALL r43(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* initialize dsdh(i,j), nid(i)
+ DO i = 0, kz
+ nid(i) = 0
+ DO j = 1, kz
+ dsdh(i,j) = 0.
+ END DO
+ END DO
-* CF2Br2 (Halon-1202) + hv -> Products
-c CALL r40(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+* calculate ds/dh of every layer
+ DO 100 i = 0, nlayer
-* CF2BrCl (Halon-1211) + hv -> Products
-c CALL r41(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ rpsinz = (re + zd(i)) * SIN(zenrad)
+
+ IF ( (zen .GT. 90.0) .AND. (rpsinz .LT. re) ) THEN
+ nid(i) = -1
+ ELSE
-* (CH3)2NNO -> products
-c call r124(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+*
+* Find index of layer in which the screening height lies
+*
+ id = i
+ IF( zen .GT. 90.0 ) THEN
+ DO 10 j = 1, nlayer
+ IF( (rpsinz .LT. ( zd(j-1) + re ) ) .AND.
+ $ (rpsinz .GE. ( zd(j) + re )) ) id = j
+ 10 CONTINUE
+ END IF
+
+ DO 20 j = 1, id
-* ClO -> Cl + O
-c call r125(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ sm = 1.0
+ IF(j .EQ. id .AND. id .EQ. i .AND. zen .GT. 90.0)
+ $ sm = -1.0
+
+ rj = re + zd(j-1)
+ rjp1 = re + zd(j)
+
+ dhj = zd(j-1) - zd(j)
+
+ ga = rj*rj - rpsinz*rpsinz
+ gb = rjp1*rjp1 - rpsinz*rpsinz
+ IF (ga .LT. 0.0) ga = 0.0
+ IF (gb .LT. 0.0) gb = 0.0
+
+ IF(id.GT.i .AND. j.EQ.id) THEN
+ dsj = SQRT( ga )
+ ELSE
+ dsj = SQRT( ga ) - sm*SQRT( gb )
+ END IF
+ dsdh(i,j) = dsj / dhj
+ 20 CONTINUE
+
+ nid(i) = id
+
+ END IF
-* ClNO2 -> Cl + NO2
-c call r126(nw,wl,wc,nz,tlev,airden,j,sq,jlabel)
+ 100 CONTINUE
-****************************************************************
+*-----------------------------------------------------------------------------
- IF (j .GT. kj) STOP '1002'
RETURN
END
-* This file contains the following subroutines, related to specifying
-* physical spectral weighting functions:
-* swphys
*=============================================================================*
- SUBROUTINE swphys(nw,wl,wc,j,s,label)
+ SUBROUTINE airmas(nz, dsdh, nid, cz,
+ $ vcol, scol,kout)
*-----------------------------------------------------------------------------*
*= PURPOSE: =*
-*= Create or read various spectral weighting functions, physically-based =*
-*= e.g. UV-B, UV-A, visible ranges, instrument responses, etc. =*
+*= Calculate vertical and slant air columns, in spherical geometry, as a =*
+*= function of altitude. =*
*-----------------------------------------------------------------------------*
*= PARAMETERS: =*
-*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
-*= wavelength grid =*
-*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
-*= working wavelength grid =*
-*= WC - REAL, vector of central wavelength of wavelength intervals I)=*
-*= in working wavelength grid =*
-*= J - INTEGER, counter for number of weighting functions defined (IO)=*
-*= S - REAL, value of each defined weighting function at each (O)=*
-*= defined wavelength =*
-*= LABEL - CHARACTER*40, string identifier for each weighting function (O)=*
-*= defined =*
+*= NZ - INTEGER, number of specified altitude levels in the working (I)=*
+*= grid =*
+*= DSDH - REAL, slant path of direct beam through each layer crossed (O)=*
+*= when travelling from the top of the atmosphere to layer i; =*
+*= DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1 =*
+*= NID - INTEGER, number of layers crossed by the direct beam when (O)=*
+*= travelling from the top of the atmosphere to layer i; =*
+*= NID(i), i = 0..NZ-1 =*
+*= VCOL - REAL, output, vertical air column, molec cm-2, above level iz =*
+*= SCOL - REAL, output, slant air column in direction of sun, above iz =*
+*= also in molec cm-2 =*
*-----------------------------------------------------------------------------*
IMPLICIT NONE
@@ -37496,7 +42012,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -37508,9 +42024,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -37547,227 +42061,510 @@ c INCLUDE 'params'
REAL precis
PARAMETER(precis = 1.e-7)
- INTEGER kdata
- PARAMETER(kdata=1000)
+* Input:
-* input:
- REAL wl(kw), wc(kw)
- INTEGER nw
+ INTEGER nz
+ INTEGER nid(0:kz)
+ REAL dsdh(0:kz,kz)
+ REAL cz(kz)
-* input/output:
- INTEGER j
+* output:
-* output: (weighting functions and labels)
- REAL s(ks,kw)
- CHARACTER*50 label(ks)
+ REAL vcol(kz), scol(kz)
* internal:
- REAL x1(kdata)
- REAL y1(kdata)
- REAL yg(kw)
- INTEGER i, iw, n
+ INTEGER id, j
+ REAL sum, vsum
- INTEGER ierr
+* calculate vertical and slant column from each level:
+* work downward
- INTEGER idum
- REAL dum1, dum2
- REAL em, a, b, c
- REAL sum
+ vsum = 0.
+ DO id = 0, nz - 1
+ vsum = vsum + cz(nz-id)
+ vcol(nz-id) = vsum
+ sum = 0.
+ IF(nid(id) .LT. 0) THEN
+ sum = largest
+ ELSE
-*_______________________________________________________________________
+* single pass layers:
- j = 0
+ DO j = 1, MIN(nid(id), id)
+ sum = sum + cz(nz-j)*dsdh(id,j)
+ ENDDO
-********* UV-B (280-315 nm)
-
- j = j + 1
- label(j) = 'UV-B, 280-315 nm'
- DO iw = 1, nw-1
- IF (wc(iw) .GT. 280. .AND. wc(iw) .LT. 315.) THEN
- s(j,iw) = 1.
- ELSE
- s(j,iw) = 0.
- ENDIF
- ENDDO
+* double pass layers:
-********* UV-B* (280-320 nm)
-
- j = j + 1
- label(j) = 'UV-B*, 280-320 nm'
- DO iw = 1, nw-1
- IF (wc(iw) .GT. 280. .AND. wc(iw) .LT. 320.) THEN
- s(j,iw) = 1.
- ELSE
- s(j,iw) = 0.
- ENDIF
- ENDDO
+ DO j = MIN(nid(id),id)+1, nid(id)
+ sum = sum + 2.*cz(nz-j)*dsdh(id,j)
+ ENDDO
-********* UV-A (315-400 nm)
-
- j = j + 1
- label(j) = 'UV-A, 315-400 nm'
- DO iw = 1, nw-1
- IF (wc(iw) .GT. 315. .AND. wc(iw) .LT. 400.) THEN
- s(j,iw) = 1.
- ELSE
- s(j,iw) = 0.
ENDIF
- ENDDO
+ scol(nz - id) = sum
-********* visible+ (> 400 nm)
-
- j = j + 1
- label(j) = 'vis+, > 400 nm'
- DO iw = 1, nw-1
- IF (wc(iw) .GT. 400.) THEN
- s(j,iw) = 1.
- ELSE
- s(j,iw) = 0.
- ENDIF
ENDDO
-********** Gaussian transmission functions
+ RETURN
+ END
- j = j + 1
- label(j) = 'Gaussian, 305 nm, 10 nm FWHM'
- sum = 0.
- DO iw = 1, nw-1
- s(j,iw) = exp(- ( log(2.) * ((wc(iw)-305.)/(5.))**2) )
- sum = sum + s(j,iw)
- ENDDO
- DO iw = 1, nw-1
- s(j,iw) = s(j,iw)/sum
- ENDDO
+CCC FILE swchem.f
+*=============================================================================*
- j = j + 1
- label(j) = 'Gaussian, 320 nm, 10 nm FWHM'
- sum = 0.
- DO iw = 1, nw-1
- s(j,iw) = exp(- ( log(2.) * ((wc(iw)-320.)/(5.))**2) )
- sum = sum + s(j,iw)
- ENDDO
- DO iw = 1, nw-1
- s(j,iw) = s(j,iw)/sum
- ENDDO
+ SUBROUTINE swchem(nw,wl,nz,tlev,airden,
+ $ j,sq,jlabel,tpflag,kout)
- j = j + 1
- label(j) = 'Gaussian, 340 nm, 10 nm FWHM'
- sum = 0.
- DO iw = 1, nw-1
- s(j,iw) = exp(- ( log(2.) * ((wc(iw)-340.)/(5.))**2) )
- sum = sum + s(j,iw)
- ENDDO
- DO iw = 1, nw-1
- s(j,iw) = s(j,iw)/sum
- ENDDO
+*-----------------------------------------------------------------------------*
+*= PURPOSE: =*
+*= Load various "weighting functions" (products of cross section and =*
+*= quantum yield at each altitude and each wavelength). The altitude =*
+*= dependence is necessary to ensure the consideration of pressure and =*
+*= temperature dependence of the cross sections or quantum yields. =*
+*= The actual reading, evaluation and interpolation is done in separate =*
+*= subroutines for ease of management and manipulation. Please refer to =*
+*= the inline documentation of the specific subroutines for detail =*
+*= information. =*
+*-----------------------------------------------------------------------------*
+*= PARAMETERS: =*
+*= NW - INTEGER, number of specified intervals + 1 in working (I)=*
+*= wavelength grid =*
+*= WL - REAL, vector of lower limits of wavelength intervals in (I)=*
+*= working wavelength grid =*
+*= NZ - INTEGER, number of altitude levels in working altitude grid (I)=*
+*= TLEV - REAL, temperature (K) at each specified altitude level (I)=*
+*= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=*
+*= J - INTEGER, counter for number of weighting functions defined (IO)=*
+*= SQ - REAL, cross section * quantum yield (cm^2) for each (O)=*
+*= photolysis reaction defined, at each defined wavelength and =*
+*= at each defined altitude level =*
+*= JLABEL - CHARACTER*50, string identifier for each photolysis reaction (O)=*
+*= defined =*
+*-----------------------------------------------------------------------------*
- j = j + 1
- label(j) = 'Gaussian, 380 nm, 10 nm FWHM'
- sum = 0.
- DO iw = 1, nw-1
- s(j,iw) = exp(- ( log(2.) * ((wc(iw)-380.)/(5.))**2) )
- sum = sum + s(j,iw)
- ENDDO
- DO iw = 1, nw-1
- s(j,iw) = s(j,iw)/sum
- ENDDO
+ IMPLICIT NONE
+c INCLUDE 'params'
-********** RB Meter, model 501
-* private communication, M. Morys (Solar Light Co.), 1994.
-* From: morys@omni.voicenet.com (Marian Morys)
-* Received: from acd.ucar.edu by sasha.acd.ucar.edu (AIX 3.2/UCB 5.64/4.03)
-* id AA17274; Wed, 21 Sep 1994 11:35:44 -0600
+* BROADLY USED PARAMETERS:
+*_________________________________________________
+* i/o file unit numbers
+ INTEGER kout, kin
+* output
+* PARAMETER(kout=6)
+* input
+ PARAMETER(kin=78)
+*_________________________________________________
+* altitude, wavelength, time (or solar zenith angle) grids
+ INTEGER kz, kw
+* altitude
+ PARAMETER(kz=151)
+* wavelength
+ PARAMETER(kw=157)
+*_________________________________________________
+* number of weighting functions
+ INTEGER kj
+* wavelength and altitude dependent
+ PARAMETER(kj=90)
- j = j + 1
- label(j) = 'RB Meter, model 501'
- OPEN(UNIT=kin,FILE='DATAS1/rbm.501',STATUS='old')
- n = 57
- DO i = 1, n
- READ(kin,*) x1(i), y1(i)
- ENDDO
- CLOSE (kin)
-
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1))
- CALL addpnt(x1,y1,kdata,n, 0.,y1(1))
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, label(j)
- STOP
- ENDIF
-
- DO iw = 1, nw-1
- s(j,iw) = yg(iw)
- ENDDO
-
-********** Eppley UV Photometer
-* CAUTION:
-* Contrary to the manufacturer's claims, the Eppley Total UV photometer does
-* not measure integrated uv radiation in any wavelength band. It actually
-* measures the *average* spectral irradiance over 295-385 nm, with the
-* averaging kernel given by the instrument's spectral response function
-* (which is the product of the photodiode response and the filter transmission
-* function).
-* The calibration factor provided by Eppley Laboratories Inc. is only valid
-* when the photometer is exposed to a spectrum that has the same shape as their
-* calibration lamp. The calibration factor is not accurate for exposure to the
-* solar spectrum. The values of Eppley total UV irradiance for outdoor
-* observations, although reported as W m-2, should be used with caution and
-* cannot be associated to any specific physical quantity, such as UVA,
-* UVA + UVB, the 295-385 nm band, or the 295-400 nm band.
-* The value calculated here is the average spectral irradiance using the
-* Eppley repsonse kernel, then multiplied by the nominal bandwith of 90 nm
-* (295-385 nm). This value is about 10% higher than the un-weighted integral
-* over 295-385 nm, and about 10% lower than the UVA (315-400 nm).
-* - Sasha Madronich, March 2009
+* delta for adding points at beginning or end of data grids
+ REAL deltax
+ PARAMETER (deltax = 1.E-5)
- j = j + 1
- label(j) = 'Eppley UV Photometer'
- OPEN(UNIT=kin,FILE='DATAS1/eppley_uv',STATUS='old')
- DO i = 1, 6
- READ(kin,*)
- ENDDO
- n = 19
- DO i = 1, n
- READ(kin,*) x1(i), dum1, dum2
- y1(i) = dum1*dum2
- ENDDO
- CLOSE(kin)
+* some constants...
- CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.)
- CALL addpnt(x1,y1,kdata,n, 0.,0.)
- CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax), 0.)
- CALL addpnt(x1,y1,kdata,n, 1.e+38, 0.)
- CALL inter2(nw,wl,yg,n,x1,y1,ierr)
- IF (ierr .NE. 0) THEN
- WRITE(*,*) ierr, label(j)
- STOP
- ENDIF
+* pi:
+ REAL pi
+ PARAMETER(pi=3.1415926535898)
-* compute normalization
+* radius of the earth, km:
+ REAL radius
+ PARAMETER(radius=6.371E+3)
- sum = 0.
- DO iw = 1, nw-1
- sum = sum + yg(iw)*(wl(iw+1) - wl(iw))
- ENDDO
+* Planck constant x speed of light, J m
- DO iw = 1, nw-1
- s(j,iw) = 90.*yg(iw)/sum
- ENDDO
+ REAL hc
+ PARAMETER(hc = 6.626068E-34 * 2.99792458E8)
-****************************************************************
-****************************************************************
+* largest number of the machine:
+ REAL largest
+ PARAMETER(largest=1.E+36)
-*_______________________________________________________________________
+* small numbers (positive and negative)
+ REAL pzero, nzero
+ PARAMETER(pzero = +10./largest)
+ PARAMETER(nzero = -10./largest)
+
+* machine precision
+
+ REAL precis
+ PARAMETER(precis = 1.e-7)
+
+* input
- IF (j .GT. ks) STOP '1001'
+ INTEGER nw
+ REAL wl(kw)
+
+ INTEGER nz
+
+ REAL tlev(kz)
+ REAL airden(kz)
+
+* weighting functions
+
+ CHARACTER*50 jlabel(kj)
+ REAL sq(kj,kz,kw)
+ INTEGER tpflag(kj)
+
+* input/output:
+ INTEGER j
+
+* local:
+ REAL wc(kw)
+ INTEGER iw
*_______________________________________________________________________
+* complete wavelength grid
+
+ DO 5, iw = 1, nw - 1
+ wc(iw) = (wl(iw) + wl(iw+1))/2.
+ 5 CONTINUE
+
+*____________________________________________________________________________
+
+
+******** Ox Photochemistry
+
+* A1. O2 + hv -> O + O
+* reserve first position. Cross section parameterization in Schumman-Runge and
+* Lyman-alpha regions are zenith-angle dependent, will be written in
+* subroutine seto2.f.
+* declare temperature dependence, tpflag = 1
+
+ j = 1
+ jlabel(j) = 'O2 -> O + O'
+ tpflag(j) = 1
+
+*A2. O3 + hv -> (both channels)
+ CALL r01(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+******** HOx Photochemistry
+
+*B1. HO2 + hv -> OH + O
+C CALL r39(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*B3. H2O2 + hv -> 2 OH
+ CALL r08(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+******** NOx Photochemistry
+
+*C1. NO2 + hv -> NO + O(3P)
+ CALL r02(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*C2. NO3 + hv -> (both channels)
+ CALL r03(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*C3. N2O + hv -> N2 + O(1D)
+C CALL r44(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*C5. N2O5 + hv -> (both channels)
+C CALL r04(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*C6. HNO2 + hv -> OH + NO
+ CALL r05(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*C7. HNO3 + hv -> OH + NO2
+ CALL r06(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*C8. HNO4 + hv -> HO2 + NO2
+ CALL r07(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* NO3-(aq) + hv -> NO2 + O- (for snow)
+* NO3-(aq) + hv -> NO2- + O(3P) (for snow)
+C CALL r118(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+******** Organic Photochemistry
+
+*D1. CH2O + hv -> (both channels)
+c CALL r10(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+ CALL pxCH2O(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D2. CH3CHO + hv -> (all three channels)
+ CALL r11(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D3. C2H5CHO + hv -> C2H5 + HCO
+ CALL r12(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D9. CH3(OOH) + hv -> CH3O + OH
+ CALL r16(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D10. HOCH2OOH -> HOCH2O. + OH
+C CALL r121(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D12. CH3(ONO2) + hv -> CH3O + NO2
+ CALL r17(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D13. CH3(OONO2) -> CH3(OO) + NO2
+C call r134(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* CH3CH2(ONO2) -> CH3CH2O + NO2
+ CALL r106(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* C2H5(ONO2) -> C2H5O + NO2
+C call r141(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* n-C3H7ONO2 -> n-C3H7O + NO2
+ call r142(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* 1-C4H9ONO2 -> 1-C4H9O + NO2
+C call r143(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* 2-C4H9ONO2 -> 2-C4H9O + NO2
+C call r144(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* CH3CH(ONO2)CH3 -> CH3CHOCH3 + NO2
+ CALL r107(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* CH2(OH)CH2(ONO2) -> CH2(OH)CH2(O.) + NO2
+C CALL r108(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* CH3COCH2(ONO2) -> CH3COCH2(O.) + NO2
+C CALL r109(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* C(CH3)3(ONO2) -> C(CH3)3(O.) + NO2
+C CALL r110(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* C(CH3)3(ONO) -> C(CH3)3(O) + NO
+C call r135(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D14. PAN + hv -> CH3CO(OO) + NO2
+* PAN + hv -> CH3CO(O) + NO3
+ CALL r18(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D15. CH3CH2COO2NO2 -> CH3CH2CO(OO) + NO2
+* CH3CH2COO2NO2 -> CH2CH2CO(O) + NO3
+ CALL r120(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D16. CH2=CHCHO + hv -> Products
+ CALL r122(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D17. CH2=C(CH3)CHO + hv -> Products
+ CALL r104(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D18. CH3COCH=CH2 + hv -> Products
+ CALL r103(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D19. CH2(OH)CHO + hv -> Products
+ CALL r101(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D20. CH3COCH3 + hv -> Products
+ CALL r15(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* CH3COCH2CH3 -> CH3CO + CH2CH3
+ CALL r119(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D21. CH2(OH)COCH3 -> CH3CO + CH2(OH)
+* CH2(OH)COCH3 -> CH2(OH)CO + CH3
+C CALL r112(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D22. CHOCHO + hv -> Products
+ CALL r13(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D23. CH3COCHO + hv -> Products
+ CALL r14(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* CH3COCOCH3 + hv -> Products
+C CALL r102(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D25. CH3CO(OH) + hv -> Products
+C CALL r138(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D26. CH3CO(OOH) + hv -> Products
+ CALL r123(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*D28. CH3COCO(OH) + hv -> Products
+C CALL r105(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* (CH3)2NNO -> products
+C call r124(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+* CH3COCH2CH2CH3 + hv -> CH3CO + CH2CH2CH3
+* M. Leriche added March 2018 for KETL (CACM, ReLACS2 and ReLACS3)
+* Uses availble Martinez data for cross section
+ CALL r149(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+******** FOx Photochemistry
+
+*E12. CF2O + hv -> Products
+C CALL r22(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+******** ClOx Photochemistry
+
+*F1. Cl2 + hv -> Cl + Cl
+C CALL r47(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F2. ClO -> Cl + O
+C call r125(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F3. ClOO + hv -> Products
+C CALL r31(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F4. OCLO -> Products
+C call r132(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F7. ClOOCl -> Cl + ClOO
+C CALL r111(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F13. HCl -> H + Cl
+C CALL r137(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F14. HOCl -> HO + Cl
+C call r130(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F15. NOCl -> NO + Cl
+C call r131(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F16. ClNO2 -> Cl + NO2
+C call r126(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F17. ClONO -> Cl + NO2
+C call r136(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F18. ClONO2 + hv -> Products
+C CALL r45(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F19. CCl4 + hv -> Products
+C CALL r20(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F20. CH3OCl + hv -> Cl + CH3O
+C CALL r139(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F21. CHCl3 -> Products
+C CALL r140(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F23. CH3Cl + hv -> Products
+C CALL r30(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F24. CH3CCl3 + hv -> Products
+C CALL r29(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F30. CCl2O + hv -> Products
+C CALL r19(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F32. CClFO + hv -> Products
+C CALL r21(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F33. CCl3F (CFC-11) + hv -> Products
+C CALL r26(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F34. CCl2F2 (CFC-12) + hv -> Products
+C CALL r27(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F36. CF2ClCFCl2 (CFC-113) + hv -> Products
+C CALL r23(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F37. CF2ClCF2Cl (CFC-114) + hv -> Products
+C CALL r24(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F38. CF3CF2Cl (CFC-115) + hv -> Products
+C CALL r25(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F40. CHClF2 (HCFC-22) + hv -> Products
+C CALL r38(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F42. CF3CHCl2 (HCFC-123) + hv -> Products
+C CALL r32(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F43. CF3CHFCl (HCFC-124) + hv -> Products
+C CALL r33(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F45. CH3CFCl2 (HCFC-141b) + hv -> Products
+C CALL r34(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F46. CH3CF2Cl (HCFC-142b) + hv -> Products
+C CALL r35(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F56. CF3CF2CHCl2 (HCFC-225ca) + hv -> Products
+C CALL r36(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*F57. CF2ClCF2CHFCl (HCFC-225cb) + hv -> Products
+C CALL r37(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+**** BrOx Photochemistry
+
+*G1. Br2 -> Br + Br
+C CALL r115(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G3. BrO -> Br + O
+C CALL r114(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G6. HOBr -> OH + Br
+C CALL r113(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G7. BrNO -> Br + NO
+C call r127(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G8. BrONO -> Br + NO2
+* BrONO -> BrO + NO
+C call r129(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G9. BrNO2 -> Br + NO2
+C call r128(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G10. BrONO2 + hv -> Products
+C CALL r46(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G11. BrCl -> Br + Cl
+C call r133(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G13. CH3Br + hv -> Products
+C CALL r28(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G15. CHBr3 + hv -> Products
+C CALL r09(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G25. CF2Br2 (Halon-1202) + hv -> Products
+C CALL r40(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G26. CF2BrCl (Halon-1211) + hv -> Products
+C CALL r41(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G27. CF3Br (Halon-1301) + hv -> Products
+C CALL r42(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*G35. CF2BrCF2Br (Halon-2402) + hv -> Products
+C CALL r43(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+**** IOx Photochemistry
+
+*H01. I2 -> I + I
+c CALL r146(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*H02. IO -> I + O
+C CALL r147(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*H05. IOH -> I + OH
+C CALL r148(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*H24. perfluoro n-iodo propane -> products
+C CALL r145(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+******** aqueous phase (diluted solution) Photochemistry
+*** M. Leriche March 2018
+*** Add from LaMP code (Deguillaume et al., 2004)
+
+*AQ01. H2O2(aq) -> 2OH
+ CALL r151(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+*AQ02. NO3-(aq) -> NO2 + OH
+ CALL r150(nw,wl,wc,nz,tlev,airden,j,sq,jlabel,tpflag,kout)
+
+****************************************************************
+
+ IF (j .GT. kj) STOP '1002'
RETURN
END
+CCC FILE vpair.f
*=============================================================================*
SUBROUTINE vpair(psurf, nz, z,
@@ -37812,9 +42609,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -37978,6 +42773,8 @@ c INCLUDE 'params'
RETURN
END
+
+CCC FILE vpo3.f
*=============================================================================*
SUBROUTINE vpo3(ipbl, zpbl, mr_pbl,
@@ -38034,9 +42831,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -38213,6 +43008,8 @@ c INCLUDE 'params'
RETURN
END
+
+CCC FILE vptmp.f
*=============================================================================*
SUBROUTINE vptmp(nz,z,tlev,tlay,kout)
@@ -38252,9 +43049,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -38347,9 +43142,14 @@ c INCLUDE 'params'
RETURN
END
+
+CCC FILE wshift.f This file contains the subroutine:
+* wshift
+* the function:
+* refrac
*_______________________________________________________________________
- SUBROUTINE wshift(mrefr, n, w, airden)
+ SUBROUTINE wshift(mrefr, n, w, airden, kout)
* Shift wavelength scale between air and vacuum.
* if mrefr = 1, shift input waveelengths in air to vacuum.
@@ -38364,7 +43164,7 @@ c INCLUDE 'params'
* i/o file unit numbers
INTEGER kout, kin
* output
- PARAMETER(kout=6)
+* PARAMETER(kout=6)
* input
PARAMETER(kin=78)
*_________________________________________________
@@ -38376,9 +43176,7 @@ c INCLUDE 'params'
PARAMETER(kw=157)
*_________________________________________________
* number of weighting functions
- INTEGER ks, kj
-* wavelength dependent
- PARAMETER(ks=60)
+ INTEGER kj
* wavelength and altitude dependent
PARAMETER(kj=90)
@@ -38445,9 +43243,7 @@ c INCLUDE 'params'
*_______________________________________________________________________
*_______________________________________________________________________
-C ##############################
FUNCTION refrac(w,airden)
-C ##############################
IMPLICIT NONE
@@ -38487,27 +43283,4 @@ C ##############################
RETURN
END
-! ######spl
- SUBROUTINE ZEROIT( A, LENGTH )
-
-c Zeros a real array A having LENGTH elements
-c --------------------------------------------------------------------
-
-c .. Scalar Arguments ..
-
- INTEGER LENGTH
-c ..
-c .. Array Arguments ..
-
- REAL A( LENGTH )
-c ..
-c .. Local Scalars ..
-
- INTEGER L
-c ..
-
- DO 10 L = 1, LENGTH
- A( L ) = 0.0
- 10 CONTINUE
-
- END
+*======= END of TUV 5.3.1 =======*
diff --git a/src/MNH/ch_init_jvalues.f90 b/src/MNH/ch_init_jvalues.f90
index 1b7e280b4..72cb3783f 100644
--- a/src/MNH/ch_init_jvalues.f90
+++ b/src/MNH/ch_init_jvalues.f90
@@ -72,7 +72,7 @@ END MODULE MODI_CH_INIT_JVALUES
!!
!! EXTERNAL
!! --------
-!! TUV39.f (Fortran 77 code from S. Madronich)
+!! TUV version 5.3.1 (Fortran 77 code from S. Madronich)
!!
!! IMPLICIT ARGUMENTS
!! ------------------
@@ -148,8 +148,8 @@ IF (.NOT.ALLOCATED(XJDATA)) ALLOCATE(XJDATA(NSZA_INCR,NZZ_JVAL,JPJVMAX,NBALB))
ZLWC(JKLEV)= 0.0
ENDDO
!
- !* CALL TUV 5.0
- ! ------------
+ !* CALL TUV 5.3.1
+ ! --------------
!
DO JALB=1,NBALB
ZALBLOOP=0.02+0.20*FLOAT(JALB-1)/FLOAT(NBALB-1)
diff --git a/src/MNH/modd_ch_init_jvalues.f90 b/src/MNH/modd_ch_init_jvalues.f90
index 67aea522c..54cd33967 100644
--- a/src/MNH/modd_ch_init_jvalues.f90
+++ b/src/MNH/modd_ch_init_jvalues.f90
@@ -33,7 +33,7 @@ INTEGER :: NSZA_INCR = 99 + 1
REAL, ALLOCATABLE, DIMENSION(:) :: XSZA_JVAL
INTEGER, PARAMETER :: NZZ_JVAL = 30 + 1
REAL, ALLOCATABLE, DIMENSION(:) :: XZZ_JVAL
-INTEGER, PARAMETER :: JPJVMAX = 21
+INTEGER, PARAMETER :: JPJVMAX = 41
INTEGER :: NBALB = 10
!
END MODULE MODD_CH_INIT_JVALUES
--
GitLab