Sola/GEOS-Chem-adjoint-v35-note
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add files via upload

Browse Source
This commit is contained in:
Xuesong (Steve)
2018-08-28 00:46:26 -04:00
committed by GitHub
parent e17feeaad3
commit fa691eb0aa
98 changed files with 54210 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

152
code/GEN.f Normal file
View File

@ -0,0 +1,152 @@
C $Id: GEN.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE GEN(ID)
C-----------------------------------------------------------------------
C Generates coefficient matrices for the block tri-diagonal system:
C A(I)*X(I-1) + B(I)*X(I) + C(I)*X(I+1) = H(I)
C-----------------------------------------------------------------------
IMPLICIT NONE
# include "jv_mie.h"
integer id, id0, id1, im, i, j, k, mstart
real*8 sum0, sum1, sum2, sum3
real*8 deltau, d1, d2, surfac
C---------------------------------------------
IF(ID.EQ.1 .OR. ID.EQ.ND) THEN
C---------calculate generic 2nd-order terms for boundaries
ID0 = ID
ID1 = ID+1
IF(ID.GE.ND) ID1 = ID-1
DO 10 I=1,N
SUM0 = 0.0d0
SUM1 = 0.0d0
SUM2 = 0.0d0
SUM3 = 0.0d0
DO IM=M,MFIT,2
SUM0 = SUM0 + POMEGA(IM,ID0)*PM(I,IM)*PM0(IM)
SUM2 = SUM2 + POMEGA(IM,ID1)*PM(I,IM)*PM0(IM)
ENDDO
DO IM=M+1,MFIT,2
SUM1 = SUM1 + POMEGA(IM,ID0)*PM(I,IM)*PM0(IM)
SUM3 = SUM3 + POMEGA(IM,ID1)*PM(I,IM)*PM0(IM)
ENDDO
H(I) = 0.5d0*(SUM0*FZ(ID0) + SUM2*FZ(ID1))
A(I) = 0.5d0*(SUM1*FZ(ID0) + SUM3*FZ(ID1))
DO J=1,I
SUM0 = 0.0d0
SUM1 = 0.0d0
SUM2 = 0.0d0
SUM3 = 0.0d0
DO IM=M,MFIT,2
SUM0 = SUM0 + POMEGA(IM,ID0)*PM(I,IM)*PM(J,IM)
SUM2 = SUM2 + POMEGA(IM,ID1)*PM(I,IM)*PM(J,IM)
ENDDO
DO IM=M+1,MFIT,2
SUM1 = SUM1 + POMEGA(IM,ID0)*PM(I,IM)*PM(J,IM)
SUM3 = SUM3 + POMEGA(IM,ID1)*PM(I,IM)*PM(J,IM)
ENDDO
S(I,J) = - SUM2*WT(J)
S(J,I) = - SUM2*WT(I)
W(I,J) = - SUM1*WT(J)
W(J,I) = - SUM1*WT(I)
U1(I,J) = - SUM3*WT(J)
U1(J,I) = - SUM3*WT(I)
SUM0 = 0.5d0*(SUM0 + SUM2)
B(I,J) = - SUM0*WT(J)
B(J,I) = - SUM0*WT(I)
ENDDO
S(I,I) = S(I,I) + 1.0d0
W(I,I) = W(I,I) + 1.0d0
U1(I,I) = U1(I,I) + 1.0d0
B(I,I) = B(I,I) + 1.0d0
10 CONTINUE
DO I=1,N
SUM0 = 0.0d0
DO J=1,N
SUM0 = SUM0 + S(I,J)*A(J)/EMU(J)
ENDDO
C1(I) = SUM0
ENDDO
DO I=1,N
DO J=1,N
SUM0 = 0.0d0
SUM2 = 0.0d0
DO K=1,N
SUM0 = SUM0 + S(J,K)*W(K,I)/EMU(K)
SUM2 = SUM2 + S(J,K)*U1(K,I)/EMU(K)
ENDDO
A(J) = SUM0
V1(J) = SUM2
ENDDO
DO J=1,N
W(J,I) = A(J)
U1(J,I) = V1(J)
ENDDO
ENDDO
IF (ID.EQ.1) THEN
C-------------upper boundary, 2nd-order, C-matrix is full (CC)
DELTAU = ZTAU(2) - ZTAU(1)
D2 = 0.25d0*DELTAU
DO I=1,N
D1 = EMU(I)/DELTAU
DO J=1,N
B(I,J) = B(I,J) + D2*W(I,J)
CC(I,J) = D2*U1(I,J)
ENDDO
B(I,I) = B(I,I) + D1
CC(I,I) = CC(I,I) - D1
C H(I) = H(I) + 2.0d0*D2*C1(I) + D1*SISOTP
H(I) = H(I) + 2.0d0*D2*C1(I)
A(I) = 0.0d0
ENDDO
ELSE
C-------------lower boundary, 2nd-order, A-matrix is full (AA)
DELTAU = ZTAU(ND) - ZTAU(ND-1)
D2 = 0.25d0*DELTAU
SURFAC = 4.0d0*ZREFL/(1.0d0 + ZREFL)
DO I=1,N
D1 = EMU(I)/DELTAU
H(I) = H(I) - 2.0d0*D2*C1(I)
SUM0 = 0.0d0
DO J=1,N
SUM0 = SUM0 + W(I,J)
ENDDO
SUM0 = D1 + D2*SUM0
SUM1 = SURFAC*SUM0
DO J=1,N
B(I,J) = B(I,J) + D2*W(I,J) - SUM1*EMU(J)*WT(J)
ENDDO
B(I,I) = B(I,I) + D1
H(I) = H(I) + SUM0*ZFLUX
DO J=1,N
AA(I,J) = - D2*U1(I,J)
ENDDO
AA(I,I) = AA(I,I) + D1
C1(I) = 0.0d0
ENDDO
ENDIF
C------------intermediate points: can be even or odd, A & C diagonal
ELSE
DELTAU = ZTAU(ID+1) - ZTAU(ID-1)
MSTART = M + MOD(ID+1,2)
DO I=1,N
A(I) = EMU(I)/DELTAU
C1(I) = -A(I)
SUM0 = 0.0d0
DO IM=MSTART,MFIT,2
SUM0 = SUM0 + POMEGA(IM,ID)*PM(I,IM)*PM0(IM)
ENDDO
H(I) = SUM0*FZ(ID)
DO J=1,I
SUM0 = 0.0d0
DO IM=MSTART,MFIT,2
SUM0 = SUM0 + POMEGA(IM,ID)*PM(I,IM)*PM(J,IM)
ENDDO
B(I,J) = - SUM0*WT(J)
B(J,I) = - SUM0*WT(I)
ENDDO
B(I,I) = B(I,I) + 1.0d0
ENDDO
ENDIF
RETURN
END

232
code/JRATET.f Normal file
View File

@ -0,0 +1,232 @@
!------------------------------------------------------------------------------
! GEOS-Chem Global Chemical Transport Model !
!------------------------------------------------------------------------------
!BOP
!
! !ROUTINE: jratet
!
! !DESCRIPTION: Subroutine JRATET calculates and prints J-values. Note that
! the loop in this routine only covers the jpnl levels actually needed by
! the CTM.
!\\
!\\
! !INTERFACE:
!
SUBROUTINE JRATET( T, IDAY )
!
! !USES:
!
USE FJX_ACET_MOD
IMPLICIT NONE
# include "cmn_fj.h"
# include "jv_cmn.h"
!
! !INPUT PARAMETERS:
!
REAL*8, INTENT(IN) :: T(LLPAR) ! Temperature [K]
INTEGER, INTENT(IN) :: IDAY ! Day of year (0-365 or 0-366)
!
! !REMARKS:
! FFF Actinic flux at each level for each wavelength bin
! QQQ Cross sections for species (read in in RD_TJPL)
! SOLF Solar distance factor, for scaling; normally given by:
! 1.0-(0.034*cos(real(iday-172)*2.0*pi/365.))
! TQQ Temperatures at which QQQ cross sections supplied
!
! !REVISION HISTORY:
! 1997 - O. Wild - Initial version
! (1 ) Added a pressure-dependancy function selector 'pdepf'
! in 'jv_spec.dat'. (tmf, 1/7/09)
! (2 ) Added pressure dependency for MGLY. (tmf, 1/7/09)
! (3 ) Updated pressure dependency algorithm for ACET. (tmf, 1/7/09)
! (4 ) Added pressure dependancy for MeCOVi, EtCOMe, MeCOCHO. Rewritten
! pressure dependancy for Acetone according to FAST-JX v6.4.
! See more detailed documentation for Acetone in fjx_acet_mod.f.
! (ccc, 4/20/09)
! 25 Aug 2011 - R. Yantosca - Rewrite IF statement to prevent PF from
! never being initialized.
! 31 Jul 2012 - R. Yantosca - Added ProTeX headers
! 10 Aug 2012 - R. Yantosca - Replace LPAR with LLPAR
! 19 May 2014 - M. Sulprizio- Update acetone photolysis to Fast-JX v7.0b
! (S.D. Eastham)
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
! Add Pressure dependancy function selector PF. (tmf, 1/7/09)
integer i, j, k, l, PF
real*8 qptemp
! For new pressure-dependency algorithm: (tmf, 1/7/09)
real*8 xp, xa, xb, xc
! For new pressure dependency algo. for acetone
! All variables "*_F" are results from external functions from
! fjx_acet_mod.f (ccc, 4/20/09)
real*8 TFACA
real*8 TFAC0
real*8 TFAC1, TFAC2
real*8 QQQA , QQ1A , QQ1B
real*8 QQ2
real*8 qo2tot, qo3tot, qo31d, qo33p, qqqt
real*8 xseco2, xseco3, xsec1d, solf, tfact
! Parameters for Solar distance compensation
real*8 PI, TWOPI
PARAMETER (PI=3.14159265358979324D0,TWOPI=2.*PI)
! Physical constants
REAL*8 Na, R
PARAMETER (Na=6.02217d23, R=8.3143d0)
! Scale actinic flux (FFF) by Solar distance factor (SOLF)
solf=1.d0-(0.034d0*cos(dble(iday-172)*2.d0*pi/365.d0))
!----------------------------------------------------------------------
! If you want to set SOLF = 1.0 for testing, uncomment the next line
! SOLF = 1d0
!----------------------------------------------------------------------
!
do I=1,jpnl
VALJ(1) = 0.d0
VALJ(2) = 0.d0
VALJ(3) = 0.d0
do K=NW1,NW2 ! Using model 'T's here
QO2TOT= XSECO2(K,dble(T(I)))
VALJ(1) = VALJ(1) + QO2TOT*FFF(K,I)
QO3TOT= XSECO3(K,dble(T(I)))
QO31D = XSEC1D(K,dble(T(I)))*QO3TOT
QO33P = QO3TOT - QO31D
VALJ(2) = VALJ(2) + QO33P*FFF(K,I)
VALJ(3) = VALJ(3) + QO31D*FFF(K,I)
enddo
!------Calculate remaining J-values with T-dep X-sections
do J=4,NJVAL
VALJ(J) = 0.d0
TFACT = 0.d0
L = jpdep(J)
! To choose different forms of pres. dependancy. (ccc, 4/20/09)
if ( L.ne.0 ) then
PF = pdepf(L)
else
PF = -1
endif
if(TQQ(2,J).gt.TQQ(1,J)) TFACT = max(0.d0,min(1.d0,
$ (T(I)-TQQ(1,J))/(TQQ(2,J)-TQQ(1,J)) ))
!------------------------------------------------------------------------------
! Prior to 5/19/14:
! Update acetone photolysis to Fast-JX v7.0b (sde, mps, 5/19/14)
!! FAST_JX introduces a new pres. dependancy for acetone (ccc, 4/20/09)
!! Special calculations for the temperature interpolation factors
! if ( PF.eq.2 ) then
! TFACA=TFACA_F(dble(T(I)), J )
! TFAC0=TFAC0_F(dble(T(I)), J+1 )
! TFAC1=TFAC_F (dble(T(I)), NJVAL+1)
! TFAC2=TFAC_F (dble(T(I)), NJVAL+2)
! else if ( PF.eq.3 ) then
! TFACA=TFACA_F(dble(T(I)), J-1 )
! TFAC0=TFAC0_F(dble(T(I)), J )
! endif
!------------------------------------------------------------------------------
do K=NW1,NW2
QQQT = QQQ(K,1,J-3) + (QQQ(K,2,J-3) - QQQ(K,1,J-3))*TFACT
if(L.eq.0) then
VALJ(J) = VALJ(J) + QQQT*FFF(K,I)
else
! Select pressure dependancy function (tmf, 1/31/06)
if (PF .eq. 1) then
!----------------------------------------------------------------------
! Prior to 9/17/99
! Original form for acetaldehyde P-dep -- believed to be incorrect (pjc)
! VALJ(J) = VALJ(J) + QQQT*FFF(K,I)*
! $ (1.d0+zpdep(K,L)*(pj(i)+pj(i+1))*0.5d0)
!----------------------------------------------------------------------
! Essentially the change is the replacement of the factor
!
! (1 + a P) with 1
! ---------------------
! (1 + b density)
!
! where a and b are constants, P is pressure, and density is the
! density of air in molec-cm(-3) (pjc, 9/17/99)
!----------------------------------------------------------------------
VALJ(J)=VALJ(J)+QQQT*FFF(K,I)/(1 +
$ (zpdep(K,L)*Na*1d-6 /(R*T(I))) *
$ (pj(i)+pj(i+1))*0.5d0*1d2)
else if ( PF .eq. 4 ) then
!-----------------------------------------------------------------------
! For MGLY
! y = a + ( b * exp(-p/c) )
! where y is the ratio between Omega(p) / Omega(p=0);
! x is the atmospheric pressure [Pa]
! a,b,c are MGLYPDEP(:,1), MGLYPDEP(:,2), MGLYPDEP(:,3)
!-----------------------------------------------------------------------
xp = (pj(i)+pj(i+1))*0.5d0*1.d2 ! pressure [Pa]
xa = mglypdep( K, 1 )
xb = mglypdep( K, 2 )
xc = mglypdep( K, 3 )
qptemp = 1.0d0
if ( abs( xc ) .ge. 1.d-10 ) then
qptemp = xa + ( xb * exp(-xp/xc) )
endif
VALJ(J) = VALJ(J) + QQQT*FFF(K,I)*qptemp
else if ( PF.eq.2 ) then
!------------------------------------------------------------------------------
! Prior to 5/19/14:
! Update acetone photolysis to Fast-JX v7.0b (sde, mps, 5/19/14)
!! Acetone pressure dependency from FAST-JX (ccc, 4/20/09)
!! J1(acetone-a) ==> CH3CO + CH3
!! Special values for Xsect
! QQQA = QQ1_F (TFACA, J , K )
! QQ2 = QQ2_F (TFAC0, J+1 , K, dble(T(I)))
! QQ1A = QQ1_F (TFAC1, NJVAL+1, K )
! QQ1B = QQ1_F (TFAC2, NJVAL+2, K ) * 4.d-20
!
! VALJ(J) = VALJ(J) + FFF(K,L)*QQQA *
! & (1.d0-QQ2)/(QQ1A + (QQ1B*Na*1d-6 /(R*T(I))) *
! $ (pj(i)+pj(i+1))*0.5d0*1d2)
!------------------------------------------------------------------------------
call QQA(pj(i),QQQA,K)
VALJ(J) = VALJ(J) + FFF(K,I)*QQQA
else if ( PF.eq.3 ) then
!------------------------------------------------------------------------------
! Prior to 5/19/14:
! Update acetone photolysis to Fast-JX v7.0b (sde, mps, 5/19/14)
!! Second acetone pressure dependency from FAST-JX (ccc, 4/20/09)
!! J2(acetone-b) ==> CH3 + CO + CH3
!! Special values for Xsect
! QQQA = QQ1_F (TFACA, J-1 , K )
! QQ2 = QQ2_F (TFAC0, J , K, dble(T(I)))
!
! VALJ(J) = VALJ(J) + FFF(K,L)*QQQA*QQ2
!------------------------------------------------------------------------------
call QQB(T(i),QQQA,K)
VALJ(J) = VALJ(J) + FFF(K,I)*QQQA
endif
endif
enddo
enddo
do j=1,jppj
zj(i,j)=VALJ(jind(j))*jfacta(j)*SOLF
enddo
cc write(6,'(I5,1P,7E10.3/(5X,7E10.3))') I, (VALJ(J), J=1,NJVAL)
enddo
return
END SUBROUTINE JRATET
!EOC

68
code/JVALUE.f Normal file
View File

@ -0,0 +1,68 @@
C $Id: JVALUE.f,v 1.1 2009/06/09 21:51:51 daven Exp $
SUBROUTINE JVALUE( SA )
C-----------------------------------------------------------------------
c Calculate the actinic flux at each level for the current SZA value.
C quit when SZA > 98.0 deg ==> tangent height = 63 km
C or 99. 80 km
C-----------------------------------------------------------------------
C Add the following input variables for CTM interface (bmy, 9/13/99)
C
C Variable Type Dimensn Units Description
C -------- ---- ------- ----- -----------
C SA dble - - Surface Albedo
C-----------------------------------------------------------------------
c
c AVGF Attenuation of beam at each level for each wavelength
c FFF Actinic flux at each desired level
c WAVE Effective wavelength of each wavelength bin
c XQO2 Absorption cross-section of O2
c XQO3 Absorption cross-section of O3
c
C-----------------------------------------------------------------------
IMPLICIT NONE
# include "cmn_fj.h"
# include "jv_cmn.h"
C=============== INPUT PARAMETERS ======================================
REAL*8, INTENT(IN) :: SA
C=============== LOCAL VARIABLES =======================================
integer j, k
real*8 wave, xseco3, xseco2
real*8 AVGF(lpar),XQO3(NB),XQO2(NB)
C
do J=1,jpnl
do K=NW1,NW2
FFF(K,J) = 0.d0
enddo
enddo
c
c---SZA check
c write(6,1000) SZA, RFLECT, (OD(nslon,nslat,j),j=1,lpar)
if(SZA.gt.szamax) GOTO 99
c
C---Calculate spherical weighting functions
CALL SPHERE
c
C---Loop over all wavelength bins
do K=NW1,NW2
WAVE = WL(K)
do J=1,NB
XQO3(J) = XSECO3(K,dble(TJ(J)))
enddo
do J=1,NB
XQO2(J) = XSECO2(K,dble(TJ(J)))
enddo
C-----------------------------------------
CALL OPMIE(K,WAVE,XQO2,XQO3,AVGF)
C-----------------------------------------
do J=1,jpnl
FFF(K,J) = FFF(K,J) + FL(K)*AVGF(J)
enddo
enddo
c
99 continue
1000 format(' SZA=',f6.1,' Reflectvty=',f6.3,' OD=',10(1pe10.3))
return
end

417
code/Kr85_mod.f Normal file
View File

@ -0,0 +1,417 @@
! $Id: Kr85_mod.f,v 1.1 2009/06/09 21:51:52 daven Exp $
MODULE Kr85_MOD
!
!******************************************************************************
! Module Kr85_MOD contains routines and variables for the Kr85 radionuclide
! simulation. (jsw, bmy, 8/21/03, 11/6/08)
!
! Module Variables:
! ============================================================================
! (1 ) N_SOURCES (INTEGER) : Maximum number of Kr85 point sources
! (2 ) N_YEARS (INTEGER) : Maximum number of years for Kr85 emissions
! (3 ) SMALLNUM (REAL*8 ) : A small number, used to prevent underflow
!
! Module Routines:
! ============================================================================
! (1 ) GET_SOURCE_IJ : Returns (I,J) location of each Kr85 point source
! (2 ) GET_EMITTED_Kr85 : Returns Kr85 emission from a point src in [kg]
! (3 ) EMISSKr85 : Adds Kr85 emissions into the tracer array
! (4 ) CHEMKr85 : Performs radioactive (1st-order) loss for Kr85
!
! GEOS-CHEM modules referenced by biomass_mod.f
! ============================================================================
! (1 ) diag_mod.f : Module containing GEOS-CHEM diagnostic arrays
! (2 ) error_mod.f : Module containing I/O error and NaN check routines
! (3 ) time_mod.f : Module containing routines for computing time & date
! (4 ) tracer_mod.f : Module containing GEOS-CHEM tracer array STT etc.
!
! References:
! ============================================================================
! (1 ) Jacob, D.J., M.J. Prather, S.C. Wofsy, M.B. McElroy, "Atmospheric
! distribution of 85Kr simulated with a general circulation model",
! JGR, 92(D6), pp. 6614-6626, June 20, 1987.
!
! NOTES:
! (1 ) Now references "tracer_mod.f" (bmy, 7/20/04)
! (2 ) Modifications for GEOS-5 nested grids (yxw, dan, bmy, 11/6/08)
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE PRIVATE DECLARATIONS -- keep certain internal variables
! and routines from being seen outside "Kr85_mod.f"
!=================================================================
! PRIVATE module routines
PRIVATE :: GET_SOURCE_IJ
PRIVATE :: GET_EMITTED_KR85
! PRIVATE module variables
PRIVATE :: N_SOURCES, N_YEARS, SMALLNUM
!=================================================================
! MODULE VARIABLES
!=================================================================
INTEGER, PARAMETER :: N_SOURCES = 8
INTEGER, PARAMETER :: N_YEARS = 6
REAL*8, PARAMETER :: SMALLNUM = 1d-20
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
SUBROUTINE GET_SOURCE_IJ( N_SOURCE, I, J )
!
!******************************************************************************
! Subroutine GET_SOURCE_IJ returns the (I,J) grid box indices for each
! Kr85 point source. For now we have hardwired this, since there are only
! a few stations. Worry about making this more general at some future time.
! (bmy, 8/21/03, 11/6/08)
!
! Arguments as Input:
! ============================================================================
! (1 ) N_SOURCE (INTEGER) : Number of Kr85 point source (1-8)
!
! Arguments as Output
! ============================================================================
! (1-2) I, J (INTEGER) : Lon & lat indices for the N_SOURCEth Kr85 source
!
! NOTES:
! (1 ) Updated for 0.5 x 0.666 nested grids (yxw, dan, bmy, 11/6/08)
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : ERROR_STOP
# include "define.h" ! Switches
! Arguments
INTEGER, INTENT(IN) :: N_SOURCE
INTEGER, INTENT(OUT) :: I, J
! Local variables
INTEGER :: GRID
! Station (I,J) arrays 4x5 2x25 1x1
INTEGER :: I1(3) = (/ 21, 41, 101 /)
INTEGER :: J1(3) = (/ 32, 63, 105 /)
!---
INTEGER :: I2(3) = (/ 14, 27, 66 /)
INTEGER :: J2(3) = (/ 35, 69, 137 /)
!---
INTEGER :: I3(3) = (/ 36, 71, 176 /)
INTEGER :: J3(3) = (/ 37, 73, 145 /)
!---
INTEGER :: I4(3) = (/ 38, 75, 186 /)
INTEGER :: J4(3) = (/ 35, 69, 137 /)
!---
INTEGER :: I5(3) = (/ 37, 73, 181 /)
INTEGER :: J5(3) = (/ 36, 71, 141 /)
!---
INTEGER :: I6(3) = (/ 39, 77, 191 /)
INTEGER :: J6(3) = (/ 36, 71, 141 /)
!---
INTEGER :: I7(3) = (/ 65, 129, 321 /)
INTEGER :: J7(3) = (/ 32, 63, 125 /)
!---
INTEGER :: I8(3) = (/ 49, 97, 241 /)
INTEGER :: J8(3) = (/ 37, 73, 145 /)
!=================================================================
! GET_SOURCE_IJ begins here!
!=================================================================
! Select flag for grid type
#if defined( GRID4x5 )
GRID = 1
#elif defined( GRID2x25 )
GRID = 2
#elif defined( GRID1x1 )
GRID = 3
#elif defined( GRID05x0666 )
GRID = 3 !(dan )
#endif
! Select proper (I,J) for each station
SELECT CASE( N_SOURCE )
CASE( 1 )
I = I1(GRID)
J = J1(GRID)
CASE( 2 )
I = I2(GRID)
J = J2(GRID)
CASE( 3 )
I = I3(GRID)
J = J3(GRID)
CASE( 4 )
I = I4(GRID)
J = J4(GRID)
CASE( 5 )
I = I5(GRID)
J = J5(GRID)
CASE( 6 )
I = I6(GRID)
J = J6(GRID)
CASE( 7 )
I = I7(GRID)
J = J7(GRID)
CASE( 8 )
I = I8(GRID)
J = J8(GRID)
CASE DEFAULT
CALL ERROR_STOP( 'N_SOURCE must be between 1-8!',
& 'GET_SOURCE_IJ (Kr85_mod.f)' )
END SELECT
! Return to calling program
END SUBROUTINE GET_SOURCE_IJ
!------------------------------------------------------------------------------
FUNCTION GET_EMITTED_Kr85( N_SOURCE, YEARCOUNT ) RESULT( Kr85 )
!
!******************************************************************************
! Subroutine GET_EMITTED_Kr85 returns the amount of Kr85 emitted from a
! given point source
!
! Arguments as Input:
! ============================================================================
! (1 ) N_SOURCE (INTEGER) : Kr85 point source index (1-N_SOURCES)
! (2 ) YEARCOUNT (INTEGER) : Year of Kr85 emissions to use (1-N_YEARS)
!
! NOTES:
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : ERROR_STOP
USE TIME_MOD, ONLY : GET_TS_EMIS
! Arguments
INTEGER, INTENT(IN) :: N_SOURCE, YEARCOUNT
! Local variables
REAL*8 :: Kr85, DTSRCE
REAL*8, PARAMETER :: SEC_PER_YR = 86400d0 * 365.25d0
! Kr85 point src emissions
! Units: MCi/year Year1 Year2 Year3 Year4 Year5 Year6
REAL*8 :: S1(6) = (/ 0.48d0,0.46d0,0.47d0,0.54d0,0.56d0,0.69d0 /)
REAL*8 :: S2(6) = (/ 0.10d0,0.00d0,0.09d0,0.06d0,0.01d0,0.00d0 /)
REAL*8 :: S3(6) = (/ 0.70d0,0.94d0,0.84d0,1.40d0,1.19d0,1.13d0 /)
REAL*8 :: S4(6) = (/ 0.31d0,0.28d0,0.54d0,0.31d0,0.31d0,0.31d0 /)
REAL*8 :: S5(6) = (/ 0.79d0,0.64d0,0.83d0,0.91d0,1.27d0,1.95d0 /)
REAL*8 :: S6(6) = (/ 0.00d0,0.05d0,0.03d0,0.00d0,0.00d0,0.08d0 /)
REAL*8 :: S7(6) = (/ 0.06d0,0.00d0,0.28d0,0.11d0,0.19d0,0.09d0 /)
REAL*8 :: S8(6) = (/ 3.56d0,3.77d0,3.19d0,3.07d0,3.00d0,2.40d0 /)
!=================================================================
! GET_EMITTED_Kr85 begins here!
!=================================================================
! Error check year
IF ( YEARCOUNT < 1 .or. YEARCOUNT > 6 ) THEN
CALL ERROR_STOP( 'YEARCOUNT must be between 1-6!',
& 'GET_EMITTED_KR85 (Kr85_mod.f)' )
ENDIF
! Return Kr85 for the given point source & year
SELECT CASE( N_SOURCE )
CASE( 1 )
Kr85 = S1(YEARCOUNT)
CASE( 2 )
Kr85 = S2(YEARCOUNT)
CASE( 3 )
Kr85 = S3(YEARCOUNT)
CASE( 4 )
Kr85 = S4(YEARCOUNT)
CASE( 5 )
Kr85 = S5(YEARCOUNT)
CASE( 6 )
Kr85 = S6(YEARCOUNT)
CASE( 7 )
Kr85 = S7(YEARCOUNT)
CASE( 8 )
Kr85 = S8(YEARCOUNT)
CASE DEFAULT
CALL ERROR_STOP( 'N_SOURCE must be between 1-8!',
& 'GET_SOURCE_IJ (Kr85_mod.f)' )
END SELECT
! Emission timestep [s]
DTSRCE = GET_TS_EMIS() * 60d0
! Convert from [MCi/yr] to [kg/emission timestep]
! 1 kg of Kr85 is equivalent to 2.55 MCi (cf Jacob et al 1987)
Kr85 = Kr85 * 2.55d0 * ( DTSRCE / SEC_PER_YR )
! Return to calling program
END FUNCTION GET_EMITTED_Kr85
!------------------------------------------------------------------------------
SUBROUTINE EMISSKr85
!
!******************************************************************************
! Subroutine EMISSKr85 places Kr85 emissions from point sources (e.g. nuclear
! reprocessing plants) into the tracer array. (jsw, bmy, 8/21/03, 7/20/04)
!
! NOTES:
! (1 ) Now references STT from "tracer_mod.f" (bmy, 7/20/04)
!******************************************************************************
!
! References to F90 modules
!--------------------------------------------------------------
! Prior to 12/7/04:
! Need to reassign the diagnostic number
!USE DIAG_MOD, ONLY : AD03
!--------------------------------------------------------------
USE TIME_MOD, ONLY : GET_TS_EMIS, GET_YEAR
USE TRACER_MOD, ONLY : STT
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! Diagnostics
# include "CMN_O3" ! FSCALYR
! Local Variables
LOGICAL, SAVE :: FIRSTEMISS = .TRUE.
INTEGER, SAVE :: YEARCOUNT, LASTYEAR
INTEGER :: I, J, N
REAL*8 :: Kr85_KG, DTSRCE
!=================================================================
! EMISSKr85 begins here!
!=================================================================
! Emission timestep [s]
DTSRCE = GET_TS_EMIS() * 60d0
! First-time initialization
IF ( FIRSTEMISS ) THEN
YEARCOUNT = FSCALYR
LASTYEAR = GET_YEAR()
FIRSTEMISS = .FALSE.
WRITE( 6, 100 ) YEARCOUNT
100 FORMAT( ' - EMISSKr85: Using Kr85 emissions from year ',i3)
ENDIF
! If it's a new year, increment YEARCOUNT
IF ( GET_YEAR() /= LASTYEAR ) THEN
YEARCOUNT = YEARCOUNT + 1
LASTYEAR = GET_YEAR()
WRITE( 6, 100 ) YEARCOUNT
ENDIF
!=================================================================
! Add Kr85 emissions [kg] to the STT tracer array
! NOTE: Assumes a global (not a window!) simulation
!=================================================================
DO N = 1, N_SOURCES
! Get (I,J) for each Kr85 point source
CALL GET_SOURCE_IJ( N, I, J )
! Get emitted Kr85 from each point source [kg]
Kr85_KG = GET_EMITTED_Kr85( N, YEARCOUNT )
! Add Kr85 into STT array
STT(I,J,1,1) = STT(I,J,1,1) + Kr85_KG
!--------------------------------------------------------------
! Prior to 12/7/04:
! Need to reassign the diagnostic number (bmy, 12/7/04)
!! Archive emitted Kr85 for ND04 diagnostic [kg]
!IF ( ND03 > 0 ) THEN
! AD03(I,J,1,1) = AD03(I,J,1,1) + Kr85_KG
!ENDIF
!--------------------------------------------------------------
ENDDO
! Return to calling program
END SUBROUTINE EMISSKr85
!------------------------------------------------------------------------------
SUBROUTINE CHEMKr85
!
!******************************************************************************
! Subroutine CHEMKr85 applies first-order loss to the Kr85 tracer.
! (jsw, bmy, 8/21/03, 7/20/04)
!
! NOTES:
! (1 ) Now references STT from "tracer_mod.f" (bmy, 7/20/04)
!******************************************************************************
!
! References to F90 modules
!------------------------------------------
! Prior to 12/7/04:
! Need to reassign diagnostic number
!USE DIAG_MOD, ONLY : AD03
!------------------------------------------
USE TIME_MOD, ONLY : GET_TS_CHEM
USE TRACER_MOD, ONLY : STT
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! ND03
! Local variables
INTEGER :: I, J, L
REAL*8 :: DTCHEM, KRATE, LOSS_FACTOR, Kr_LOST
!=================================================================
! CHEMKr85 begins here!
!=================================================================
! Chemistry timestep [s]
DTCHEM = GET_TS_CHEM() * 60d0
! The decay for 85Kr is calculated by: dC/dt = -kC
! where k = 1/15.52yr = 2.042E-9 s^-1
KRATE = 2.042d-9
! Multiplication factor to compute tracer lost
LOSS_FACTOR = 1d0 - EXP( -2.042d-9 * DTCHEM )
!=================================================================
! Apply radioactive decay to Kr85 tracer
!=================================================================
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, Kr_LOST )
DO L = 1, LLPAR
DO J = 1, JJPAR
DO I = 1, IIPAR
! Amount of Kr85 lost to radioactive decay [kg]
Kr_LOST = STT(I,J,L,1) * LOSS_FACTOR
! Prevent underflow
IF ( Kr_LOST < SMALLNUM ) Kr_LOST = 0d0
! Subtract Kr85 lost from the tracer array
STT(I,J,L,1) = STT(I,J,L,1) - Kr_LOST
!-------------------------------------------------------------
! Prior to 12/7/04:
! Need to reassign the diagnostic number
!! Archive Kr85 lost by decay [kg] in ND04 diagnostic
!IF ( ND03 > 0 ) THEN
! AD03(I,J,L,2) = AD03(I,J,L,2) + Kr_LOST
!ENDIF
!-------------------------------------------------------------
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE CHEMKr85
!------------------------------------------------------------------------------
END MODULE Kr85_MOD

16
code/LEGND0.f Normal file
View File

@ -0,0 +1,16 @@
C $Id: LEGND0.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE LEGND0 (X,PL,N)
C---Calculates ORDINARY LEGENDRE fns of X (real)
C--- from P[0] = PL(1) = 1, P[1] = X, .... P[N-1] = PL(N)
IMPLICIT NONE
INTEGER N,I
REAL*8 X,PL(N),DEN
C---Always does PL(2) = P[1]
PL(1) = 1.D0
PL(2) = X
DO I=3,N
DEN = (I-1)
PL(I) = PL(I-1)*X*(2.d0-1.D0/DEN) - PL(I-2)*(1.d0-1.D0/DEN)
ENDDO
RETURN
END

53
code/MATIN4.f Normal file
View File

@ -0,0 +1,53 @@
C $Id: MATIN4.f,v 1.1 2009/06/09 21:51:51 daven Exp $
SUBROUTINE MATIN4 (A)
C-----------------------------------------------------------------------
C invert 4x4 matrix A(4,4) in place with L-U decomposition (mjp, old...)
C-----------------------------------------------------------------------
IMPLICIT NONE
REAL*8 A(4,4)
C---SETUP L AND U
A(2,1) = A(2,1)/A(1,1)
A(2,2) = A(2,2)-A(2,1)*A(1,2)
A(2,3) = A(2,3)-A(2,1)*A(1,3)
A(2,4) = A(2,4)-A(2,1)*A(1,4)
A(3,1) = A(3,1)/A(1,1)
A(3,2) = (A(3,2)-A(3,1)*A(1,2))/A(2,2)
A(3,3) = A(3,3)-A(3,1)*A(1,3)-A(3,2)*A(2,3)
A(3,4) = A(3,4)-A(3,1)*A(1,4)-A(3,2)*A(2,4)
A(4,1) = A(4,1)/A(1,1)
A(4,2) = (A(4,2)-A(4,1)*A(1,2))/A(2,2)
A(4,3) = (A(4,3)-A(4,1)*A(1,3)-A(4,2)*A(2,3))/A(3,3)
A(4,4) = A(4,4)-A(4,1)*A(1,4)-A(4,2)*A(2,4)-A(4,3)*A(3,4)
C---INVERT L
A(4,3) = -A(4,3)
A(4,2) = -A(4,2)-A(4,3)*A(3,2)
A(4,1) = -A(4,1)-A(4,2)*A(2,1)-A(4,3)*A(3,1)
A(3,2) = -A(3,2)
A(3,1) = -A(3,1)-A(3,2)*A(2,1)
A(2,1) = -A(2,1)
C---INVERT U
A(4,4) = 1.D0/A(4,4)
A(3,4) = -A(3,4)*A(4,4)/A(3,3)
A(3,3) = 1.D0/A(3,3)
A(2,4) = -(A(2,3)*A(3,4)+A(2,4)*A(4,4))/A(2,2)
A(2,3) = -A(2,3)*A(3,3)/A(2,2)
A(2,2) = 1.D0/A(2,2)
A(1,4) = -(A(1,2)*A(2,4)+A(1,3)*A(3,4)+A(1,4)*A(4,4))/A(1,1)
A(1,3) = -(A(1,2)*A(2,3)+A(1,3)*A(3,3))/A(1,1)
A(1,2) = -A(1,2)*A(2,2)/A(1,1)
A(1,1) = 1.D0/A(1,1)
C---MULTIPLY (U-INVERSE)*(L-INVERSE)
A(1,1) = A(1,1)+A(1,2)*A(2,1)+A(1,3)*A(3,1)+A(1,4)*A(4,1)
A(1,2) = A(1,2)+A(1,3)*A(3,2)+A(1,4)*A(4,2)
A(1,3) = A(1,3)+A(1,4)*A(4,3)
A(2,1) = A(2,2)*A(2,1)+A(2,3)*A(3,1)+A(2,4)*A(4,1)
A(2,2) = A(2,2)+A(2,3)*A(3,2)+A(2,4)*A(4,2)
A(2,3) = A(2,3)+A(2,4)*A(4,3)
A(3,1) = A(3,3)*A(3,1)+A(3,4)*A(4,1)
A(3,2) = A(3,3)*A(3,2)+A(3,4)*A(4,2)
A(3,3) = A(3,3)+A(3,4)*A(4,3)
A(4,1) = A(4,4)*A(4,1)
A(4,2) = A(4,4)*A(4,2)
A(4,3) = A(4,4)*A(4,3)
RETURN
END

64
code/MIESCT.f Normal file
View File

@ -0,0 +1,64 @@
C $Id: MIESCT.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE MIESCT
C-----------------------------------------------------------------------
C This is an adaption of the Prather radiative transfer code, (mjp, 10/95)
C Prather, 1974, Astrophys. J. 192, 787-792.
C Sol'n of inhomogeneous Rayleigh scattering atmosphere.
C (original Rayleigh w/ polarization)
C Cochran and Trafton, 1978, Ap.J., 219, 756-762.
C Raman scattering in the atmospheres of the major planets.
C (first use of anisotropic code)
C Jacob, Gottlieb and Prather, 1989, J.Geophys.Res., 94, 12975-13002.
C Chemistry of a polluted cloudy boundary layer,
C (documentation of extension to anisotropic scattering)
C
C takes atmospheric structure and source terms from std J-code
C ALSO limited to 4 Gauss points, only calculates mean field!
C
C mean rad. field ONLY (M=1)
C initialize variables FIXED/UNUSED in this special version:
C FTOP = 1.0 = astrophysical flux (unit of pi) at SZA, -ZU0, use for scaling
C FBOT = 0.0 = external isotropic flux on lower boundary
C SISOTP = 0.0 = Specific Intensity of isotropic radiation incident from top
C
C SUBROUTINES: MIESCT needs 'jv_mie.cmn'
C BLKSLV needs 'jv_mie.cmn'
C GEN (ID) needs 'jv_mie.cmn'
C LEGND0 (X,PL,N)
C MATIN4 (A)
C GAUSSP (N,XPT,XWT)
C-----------------------------------------------------------------------
IMPLICIT NONE
# include "jv_mie.h"
integer i, id, im
real*8 cmeq1
C-----------------------------------------------------------------------
C---fix scattering to 4 Gauss pts = 8-stream
CALL GAUSSP (N,EMU,WT)
C---solve eqn of R.T. only for first-order M=1
C ZFLUX = (ZU0*FZ(ND)*ZREFL+FBOT)/(1.0d0+ZREFL)
ZFLUX = (ZU0*FZ(ND)*ZREFL)/(1.0d0+ZREFL)
M=1
DO I=1,N
CALL LEGND0 (EMU(I),PM0,MFIT)
DO IM=M,MFIT
PM(I,IM) = PM0(IM)
ENDDO
ENDDO
C
CMEQ1 = 0.25D0
CALL LEGND0 (-ZU0,PM0,MFIT)
DO IM=M,MFIT
PM0(IM) = CMEQ1*PM0(IM)
ENDDO
C
CALL BLKSLV
C
DO ID=1,ND,2
FJ(ID) = 4.0d0*FJ(ID) + FZ(ID)
ENDDO
RETURN
END

556
code/Makefile Normal file
View File

@ -0,0 +1,556 @@
#==============================================================================
#
# GEOS-Chem Makefile for LINUX/IFORT compiler
#
#==============================================================================
SHELL = /bin/sh
#==============================================================================
# Default settings
#==============================================================================
# OpenMP is turned on by default
ifndef OMP
OMP = yes
endif
# Turn on -traceback option by default
ifndef TRACEBACK
TRACEBACK=yes
endif
#==============================================================================
# Declare Options
#==============================================================================
# Pick compiler options for debug run or regular run
ifeq ($(DEBUG),yes)
FFLAGS = -cpp -w -auto -noalign -convert big_endian -g -O0 -check arg_temp_created -debug all -fp-model source -mcmodel=medium -shared-intel
else
FFLAGS = -cpp -w -auto -noalign -convert big_endian -O3 -fp-model source -vec-report0 -mcmodel=medium -shared-intel
endif
# Also add traceback option
ifeq ($(TRACEBACK),yes)
FFLAGS += -traceback
endif
# Turn on OpenMP parallelization
ifeq ($(OMP),yes)
FFLAGS += -openmp -Dmultitask
endif
# Add special IFORT optimization commands
ifeq ($(IPO),yes)
FFLAGS += -ipo
endif
F90 = ifort $(FFLAGS) $(INCLUDE)
# Library include path
INCLUDE := -I$(GC_INCLUDE)
# Library link path: first try to get the list of proper linking flags
# for this build of netCDF with nf-config and nc-config.
NCL := $(shell $(GC_BIN)/nf-config --flibs)
NCL += $(shell $(GC_BIN)/nc-config --libs)
NCL := $(filter -l%,$(NCL))
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%% NOTE TO GEOS-CHEM USERS: If you do not have netCDF-4.2 installed
#%%%% Then you can add/modify the linking sequence here. (This sequence
#%%%% is a guess, but is probably good enough for other netCDF builds.)
ifeq ($(NCL),)
NCL :=-lnetcdf -lnetcdff -lhdf5_hl -lhdf5 -lz
endif
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Prepend the library directory path to the linking sequence
NCL := -L$(GC_LIB) $(NCL)
LINK := $(NCL)
ifeq ($(USE_MKL),yes)
LINK += -L$(MKLROOT)/lib/em64t $(MKLROOT)/lib/em64t/libmkl_blas95_lp64.a $(MKLROOT)/lib/em64t/libmkl_lapack95_lp64.a -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core -openmp -lpthread
LAPACK_BLAS_FFLAGS += -I$(MKLROOT)/include/em64t/lp64/ -I$(MKLROOT)/include
endif
# Link to the HDF and HDF-EOS libraries
ifeq ($(HDF),yes)
HDFHOME=$(ROOT_LIBRARY_DIR)
HDFINC=$(GC_INCLUDE)
HDFLIB=$(GC_LIB)
HDFEOS_HOME=$(ROOT_LIBRARY_DIR)
HDFEOS_INC=$(GC_INCLUDE)
HDFEOS_LIB=$(GC_LIB)
HDF5HOME=$(ROOT_LIBRARY_DIR)
HDF5INC=$(GC_INCLUDE)
HDF5LIB=$(GC_LIB)
FFLAGS += -I$(HDFEOS_INC) -I$(HDF5INC) -I$(HDFINC)
LINK += -L$(HDFEOS_LIB) -L$(HDF5LIB) -L$(HDFLIB) -lhdfeos -lGctp -lmfhdf -ldf -lz -lm -ljpeg -lsz -lhdf5 -lhdf5_hl -lhdf5hl_fortran -lhdf5_fortran -lhe5_hdfeos
endif
ifeq ($(SAT_NETCDF),yes)
LINK += -L$(MKLPATH) $(MKLPATH)/libmkl_solver_lp64.a -Wl,--start-group \
-lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core -Wl,--end-group \
-openmp -lpthread
endif
#==============================================================================
# Include Objects
#==============================================================================
VPATH = ./modified ./adjoint ./new ./obs_operators ./NcdfUtil
ifeq ($(LIDORT),yes)
VPATH += ./lidort ./lidort/thread_sourcecode_MkII_F90
endif
include ./Objects.mk
# Add LIDORT Specific Code
ifeq ($(LIDORT),yes)
#====================
# LIDORT CODE
#====================
# dkh
#LIDORT_COMPILE = ifort -c -warn all -check bounds -O3 -zero
LIDORT_COMPILE_FIXED = ifort -cpp -check bounds -O3 -zero -noalign -fixed -openmp -Dmultitask
LIDORT_COMPILE = ifort -c -check bounds -O3 -zero -noalign -free -openmp -Dmultitask -traceback -CB -vec-report0
LAPACK_COMPILE = ifort -c -warn all -check bounds -O3 -zero
LAPACK_NOPT_COMPILE = ifort -c -O3 -zero
FLINK = ifort
# Link definition
#################
#LINK.f90 = $(FLINK) -g -pg
LINK.f90 = $(FLINK)
# dkh
#LIDORT_PATH = ..
LIDORT_PATH = ./lidort
# other paths are relative
SPATH_S = $(LIDORT_PATH)/thread_sourcecode_MkII_F90/
OBJ = $(LIDORT_PATH)/OBJECTS_F90
# OBJECT MODULES
# LIDORT modules in directory sourcecode
MIE = \
RTS_mie_modules.o \
RTS_mie_sourcecode.o \
RTS_mie_sourcecode_plus.o \
GC_forward_Mie.o \
GC_adjoint_Mie.o
# Masters set
OBJECTS_LIDORT_MASTERS = $(OBJ)/lidort_masters_basic.o
OBJECTS_LIDORT_MASTERS_LCS = $(OBJ)/lidort_masters_lcs.o
OBJECTS_LIDORT_MASTERS_LPS = $(OBJ)/lidort_masters_lps.o
# Basic set for Radiances
OBJECTS_LIDORT_BASIC = $(OBJ)/lidort_solutions.o \
$(OBJ)/lidort_bvproblem.o \
$(OBJ)/lidort_intensity.o \
$(OBJ)/lidort_corrections.o \
$(OBJ)/lidort_miscsetups.o \
$(OBJ)/lidort_inputs.o \
$(OBJ)/lidort_geometry.o
OBJECTS_LIDORT_AUX = $(OBJ)/lidort_aux.o
OBJECTS_LIDORT_LA = $(OBJ)/lidort_la_solutions.o \
$(OBJ)/lidort_la_miscsetups.o
OBJECTS_LIDORT_LC = $(OBJ)/lidort_lc_bvproblem.o \
$(OBJ)/lidort_lc_wfatmos.o \
$(OBJ)/lidort_lc_corrections.o \
$(OBJ)/lidort_lc_miscsetups.o
OBJECTS_LIDORT_LP = $(OBJ)/lidort_lp_bvproblem.o \
$(OBJ)/lidort_lp_wfatmos.o \
$(OBJ)/lidort_lp_corrections.o \
$(OBJ)/lidort_lp_miscsetups.o
OBJECTS_LIDORT_LS = $(OBJ)/lidort_ls_wfsurface.o \
$(OBJ)/lidort_ls_corrections.o
# LIDORT environment & interface modules
#OBJECTS_LIDORT_3P5T_LPS_MT = $(OBJ)/lidort_mod.o
endif
#=============================================================================
# Executables and Documentation
#=============================================================================
ifeq ($(LIDORT),yes)
geos: $(MODS) $(OBJS) $(OBJSe) $(FJ) \
$(OBJECTS_LIDORT_MASTERS_LPS) \
$(OBJECTS_LIDORT_AUX) \
$(OBJECTS_LIDORT_BASIC) \
$(OBJECTS_LIDORT_LA) \
$(OBJECTS_LIDORT_LP) \
$(OBJECTS_LIDORT_LS) \
$(MIE)
# $(F90) $(MODS) $(OBJS) $(OBJSe) $(FJ) $(LIBS) -o geos
# $(F90) *.o -o geos
# $(F90) $(MODS) $(OBJS) $(OBJSe) $(FJ) -o geos
$(F90) $(MODS) $(OBJS) $(OBJSe) $(FJ) \
$(OBJECTS_LIDORT_MASTERS_LPS) \
$(OBJECTS_LIDORT_AUX) \
$(OBJECTS_LIDORT_BASIC) \
$(OBJECTS_LIDORT_LA) \
$(OBJECTS_LIDORT_LP) \
$(OBJECTS_LIDORT_LS) \
$(MIE) $(LINK) -o geos
else
geos: $(MODS) $(OBJS) $(OBJSe) $(FJ)
$(F90) $(MODS) $(OBJS) $(OBJSe) $(FJ) \
$(LINK) -o geos
endif
# Build GEOS-Chem documenation w/ ProTeX
doc:
@$(MAKE) -C doc all
# Remove all *.tex, *.ps, and *.pdf files from the doc subdirectory
docclean:
@$(MAKE) -C doc clean
help:
@echo '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%'
@echo '%%% GEOS-Chem Adjoint Help Screen %%%'
@echo '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%'
@echo ''
@echo 'Usage: make TARGET [ OPTIONAL-FLAGS ]'
@echo ''
@echo 'TARGET may be one of the following:'
@echo 'geos Builds GEOS-Chem Adjoint source code'
@echo 'clean Removes *.o, *.mod files and geos executable'
@echo 'OPTIONAL-FLAGS may be:'
@echo 'DEBUG=yes Builds GEOS-Chem for a debugger (with -g -O0)'
@echo 'HDF=yes Enables writing diagnostic timeseries output to HDF files'
@echo 'IPO=yes Turns on optmization options -ipo -static (default is no)'
@echo 'LIDORT=yes Enables LIDORT Modules'
@echo 'OMP=[yes|no] Turns OpenMP parallelization on/off (default is yes)'
@echo 'SAT_NETCDF=yes Enables Satellite NetCDF'
@echo 'TRACEBACK=yes Turns on -traceback option (default is yes)'
@echo ''
@echo 'NOTE: This installation is set up to work with Intel Fortran Compilers only'
#==============================================================================
# Include Dependencies
#==============================================================================
include ./Dependencies.mk
ifeq ($(HDF),yes)
#====================
# MOPITT CODE
#====================
gvchsq.o : gvchsq.f
$(F90) -c -r8 obs_operators/gvchsq.f
HdfIncludeModule.o : HdfIncludeModule.f90
$(F90) -c -r8 obs_operators/HdfIncludeModule.f90
HdfSdModule.o : HdfSdModule.f90
$(F90) -c -r8 obs_operators/HdfSdModule.f90
HdfVdModule.o : HdfVdModule.f90
$(F90) -c -r8 obs_operators/HdfVdModule.f90
interp.o : interp.f
$(F90) -c -r8 obs_operators/interp.f
gaussj.o : gaussj.f
$(F90) -c -r8 obs_operators/gaussj.f
mopitt_obs_mod.o : mopitt_obs_mod.f CMN CMN_SIZE define.h define_adj.h
$(F90) -c -r8 obs_operators/mopitt_obs_mod.f
#====================
# IASI CO CODE
#====================
iasi_co_obs_mod.o : iasi_co_obs_mod.f90 CMN CMN_SIZE define.h define_adj.h
$(F90) -c -r8 obs_operators/iasi_co_obs_mod.f90
#====================
# MLS O3 CODE
#====================
mls_o3_obs_mod.o : mls_o3_obs_mod.f90 CMN CMN_SIZE define.h define_adj.h
$(F90) -c -r8 obs_operators/mls_o3_obs_mod.f90
#====================
# MLS HNO3 CODE
#====================
mls_hno3_obs_mod.o : mls_hno3_obs_mod.f90 CMN CMN_SIZE define.h define_adj.h
$(F90) -c -r8 obs_operators/mls_hno3_obs_mod.f90
#====================
# OMI NO2 CODE
#====================
omi_no2_obs_mod.o : omi_no2_obs_mod.f90 CMN CMN_SIZE define.h define_adj.h
$(F90) -c -r8 obs_operators/omi_no2_obs_mod.f90
#====================
# OMI L3 SO2
#====================
omi_so2_obs_mod.o : omi_so2_obs_mod.f
$(F90) -c -r8 obs_operators/omi_so2_obs_mod.f
#====================
# OMI CH2O CODE
#====================
omi_ch2o_obs_mod.o : omi_ch2o_obs_mod.f90 CMN CMN_SIZE define.h define_adj.h
$(F90) -c -r8 obs_operators/omi_ch2o_obs_mod.f90
#====================
# OSIRIS NO2 CODE
#====================
osiris_no2_obs_mod.o : osiris_no2_obs_mod.f90 CMN CMN_SIZE define.h define_adj.h
$(F90) -c -r8 obs_operators/osiris_no2_obs_mod.f90
#====================
# AIRS CODE
#====================
He4IncludeModule.o : He4IncludeModule.f90
$(F90) -c -r8 obs_operators/He4IncludeModule.f90
He4ErrorModule.o : He4ErrorModule.f90
$(F90) -c -r8 obs_operators/He4ErrorModule.f90
He4GridModule.o : He4GridModule.f90
$(F90) -c -r8 obs_operators/He4GridModule.f90
He4SwathModule.o : He4SwathModule.f90
$(F90) -c -r8 obs_operators/He4SwathModule.f90
airsv5_mod.o : airsv5_mod.f90
$(F90) -c -r8 obs_operators/airsv5_mod.f90
airs_co_obs_mod.o : airs_co_obs_mod.f CMN_SIZE define.h
$(F90) -c -r8 obs_operators/airs_co_obs_mod.f
findinv.o : findinv.f
$(F90) -c -r8 obs_operators/findinv.f
endif
ifeq ($(SAT_NETCDF),yes)
#====================
# TES CODE
#====================
gosat_co2_mod.o : gosat_co2_mod.f
$(F90) -c -r8 obs_operators/gosat_co2_mod.f
tes_nh3_mod.o : tes_nh3_mod.f
$(F90) -c -r8 obs_operators/tes_nh3_mod.f
tes_o3_mod.o : tes_o3_mod.f
$(F90) -c -r8 obs_operators/tes_o3_mod.f
tes_o3_irk_mod.o : tes_o3_irk_mod.f
$(F90) -c -r8 obs_operators/tes_o3_irk_mod.f
#====================
# IASI O3 CODE
#====================
iasi_o3_obs_mod.o : iasi_o3_obs_mod.f90
$(F90) -c -r8 obs_operators/iasi_o3_obs_mod.f90
#====================
# MODIS AOD CODE (xxu, dkh, 01/09/12, adj32_011)
#====================
modis_aod_obs_mod.o : modis_aod_obs_mod.f
$(F90) -c -r8 obs_operators/modis_aod_obs_mod.f
#====================
# SCIA CODE
#====================
scia_ch4_mod.o : scia_ch4_mod.f CMN_SIZE
$(F90) -c -r8 $<
endif
ifeq ($(LIDORT),yes)
#====================
# LIDORT CODE
#====================
#--------------------------------------------------
#--------------------------Environment modules-----
#--------------------------------------------------
#lidort_mod.o: lidort_mod.f \
# $(SPATH_S)LIDORT.PARS_F90
# $(F90) $(LIDORT_PATH)/lidort_mod.f
# $(LIDORT_COMPILE_FIXED) $(LIDORT_PATH)/lidort_mod.f90
#$(LIDORT_COMPILE_FIXED) $(LIDORT_PATH)/lidort_mod.f90 -o lidort_mod.o
lidort_mod.o : lidort_mod.f LIDORT.PARS_F90
$(F90) -c -r8 lidort/lidort_mod.f
mie_mod.o : mie_mod.f
$(F90) -c -r8 lidort/mie_mod.f
RTS_mie_modules.o : RTS_mie_modules.f90
$(F90) -c -r8 lidort/RTS_mie_modules.f90
RTS_mie_sourcecode.o : RTS_mie_sourcecode.f90
$(F90) -c -r8 lidort/RTS_mie_sourcecode.f90
RTS_mie_sourcecode_plus.o : RTS_mie_sourcecode_plus.f90
$(F90) -c -r8 lidort/RTS_mie_sourcecode_plus.f90
GC_forward_Mie.o : GC_forward_Mie.f90
$(F90) -c -r8 lidort/GC_forward_Mie.f90
GC_adjoint_Mie.o : GC_adjoint_Mie.f90
$(F90) -c -r8 lidort/GC_adjoint_Mie.f90
#----------------------------------------------------
#----------------------LIDORT master modules --------
#----------------------------------------------------
$(OBJ)/lidort_masters_lps.o: $(SPATH_S)lidort_masters_lps.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_masters_lps.f90 -o $(OBJ)/lidort_masters_lps.o
#----------------------------------------------------
#----------------------LIDORT Radiance modules ------
#----------------------------------------------------
$(OBJ)/lidort_solutions.o: $(SPATH_S)lidort_solutions.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_solutions.f90 -o $(OBJ)/lidort_solutions.o
$(OBJ)/lidort_bvproblem.o: $(SPATH_S)lidort_bvproblem.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_bvproblem.f90 -o $(OBJ)/lidort_bvproblem.o
$(OBJ)/lidort_geometry.o: $(SPATH_S)lidort_geometry.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_geometry.f90 -o $(OBJ)/lidort_geometry.o
$(OBJ)/lidort_intensity.o: $(SPATH_S)lidort_intensity.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_intensity.f90 -o $(OBJ)/lidort_intensity.o
$(OBJ)/lidort_miscsetups.o: $(SPATH_S)lidort_miscsetups.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_miscsetups.f90 -o $(OBJ)/lidort_miscsetups.o
$(OBJ)/lidort_corrections.o: $(SPATH_S)lidort_corrections.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_corrections.f90 -o $(OBJ)/lidort_corrections.o
$(OBJ)/lidort_inputs.o: $(SPATH_S)lidort_inputs.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_inputs.f90 -o $(OBJ)/lidort_inputs.o
# ---------------------------------------------------
#----------------------LIDORT Auxiliary module ------
# ---------------------------------------------------
$(OBJ)/lidort_aux.o: $(SPATH_S)lidort_aux.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LAPACK_COMPILE) $(SPATH_S)lidort_aux.f90 -o $(OBJ)/lidort_aux.o
# ---------------------------------------------------
#----------------------LIDORT Jacobian modules ------
# ---------------------------------------------------
# General
$(OBJ)/lidort_la_solutions.o: $(SPATH_S)lidort_la_solutions.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_la_solutions.f90 -o $(OBJ)/lidort_la_solutions.o
$(OBJ)/lidort_la_miscsetups.o: $(SPATH_S)lidort_la_miscsetups.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_la_miscsetups.f90 -o $(OBJ)/lidort_la_miscsetups.o
# Column specific
$(OBJ)/lidort_lc_bvproblem.o: $(SPATH_S)lidort_lc_bvproblem.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lc_bvproblem.f90 -o $(OBJ)/lidort_lc_bvproblem.o
$(OBJ)/lidort_lc_wfatmos.o: $(SPATH_S)lidort_lc_wfatmos.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lc_wfatmos.f90 -o $(OBJ)/lidort_lc_wfatmos.o
$(OBJ)/lidort_lc_corrections.o: $(SPATH_S)lidort_lc_corrections.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lc_corrections.f90 -o $(OBJ)/lidort_lc_corrections.o
$(OBJ)/lidort_lc_miscsetups.o: $(SPATH_S)lidort_lc_miscsetups.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lc_miscsetups.f90 -o $(OBJ)/lidort_lc_miscsetups.o
# Profile specific
$(OBJ)/lidort_lp_bvproblem.o: $(SPATH_S)lidort_lp_bvproblem.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lp_bvproblem.f90 -o $(OBJ)/lidort_lp_bvproblem.o
$(OBJ)/lidort_lp_wfatmos.o: $(SPATH_S)lidort_lp_wfatmos.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lp_wfatmos.f90 -o $(OBJ)/lidort_lp_wfatmos.o
$(OBJ)/lidort_lp_corrections.o: $(SPATH_S)lidort_lp_corrections.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lp_corrections.f90 -o $(OBJ)/lidort_lp_corrections.o
$(OBJ)/lidort_lp_miscsetups.o: $(SPATH_S)lidort_lp_miscsetups.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lp_miscsetups.f90 -o $(OBJ)/lidort_lp_miscsetups.o
# Surface
$(OBJ)/lidort_ls_wfsurface.o: $(SPATH_S)lidort_ls_wfsurface.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_ls_wfsurface.f90 -o $(OBJ)/lidort_ls_wfsurface.o
$(OBJ)/lidort_ls_corrections.o: $(SPATH_S)lidort_ls_corrections.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_ls_corrections.f90 -o $(OBJ)/lidort_ls_corrections.o
#----------------------------------------------------
#----------- BRDF supplement modules ----------------
#----------------------------------------------------
$(OBJ)/lidort_brdf_supplement.o: $(SPATH_S)lidort_brdf_supplement.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_brdf_supplement.f90 -o $(OBJ)/lidort_brdf_supplement.o
$(OBJ)/lidort_brdf_kernels.o: $(SPATH_S)lidort_brdf_kernels.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_brdf_kernels.f90 -o $(OBJ)/lidort_brdf_kernels.o
$(OBJ)/lidort_brdf_ls_supplement.o: $(SPATH_S)lidort_brdf_ls_supplement.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_brdf_ls_supplement.f90 -o $(OBJ)/lidort_brdf_ls_supplement.o
$(OBJ)/lidort_brdf_ls_kernels.o: $(SPATH_S)lidort_brdf_ls_kernels.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_brdf_ls_kernels.f90 -o $(OBJ)/lidort_brdf_ls_kernels.o
endif
#==============================================================================
# Other compilation commands
#==============================================================================
ifort_errmsg.o : ifort_errmsg.f
linux_err.o : linux_err.c
$(CC) -c linux_err.c
#=============================================================================
# Other Makefile Commands
#=============================================================================
clean:
rm -rf *.o *.mod ifc* geos rii_files
.PHONY: clean doc docclean
.SUFFIXES: .f .F .f90 .F90
.f.o: ; $(F90) -c $*.f
.F.o: ; $(F90) -c $*.F
.f90.o: ; $(F90) -c -free $*.f90
.F90.o: ; $(F90) -c -free $*.F90
%.o : %.mod

522
code/Makefile~ Normal file
View File

@ -0,0 +1,522 @@
#==============================================================================
#
# GEOS-Chem Makefile for LINUX/IFORT compiler
#
#==============================================================================
SHELL = /bin/sh
#==============================================================================
# Default settings
#==============================================================================
# OpenMP is turned on by default
ifndef OMP
OMP = yes
endif
# Turn on -traceback option by default
ifndef TRACEBACK
TRACEBACK=yes
endif
#==============================================================================
# Declare Options
#==============================================================================
# Pick compiler options for debug run or regular run
ifeq ($(DEBUG),yes)
FFLAGS = -cpp -w -auto -noalign -convert big_endian -g -O0 -check arg_temp_created -debug all -fp-model source -mcmodel=medium -shared-intel
else
FFLAGS = -cpp -w -auto -noalign -convert big_endian -O3 -fp-model source -vec-report0 -mcmodel=medium -shared-intel
endif
# Also add traceback option
ifeq ($(TRACEBACK),yes)
FFLAGS += -traceback
endif
# Turn on OpenMP parallelization
ifeq ($(OMP),yes)
FFLAGS += -openmp -Dmultitask
endif
# Add special IFORT optimization commands
ifeq ($(IPO),yes)
FFLAGS += -ipo
endif
F90 = ifort $(FFLAGS) $(INCLUDE)
# Library include path
INCLUDE := -I$(GC_INCLUDE)
# Library link path: first try to get the list of proper linking flags
# for this build of netCDF with nf-config and nc-config.
NCL := $(shell $(GC_BIN)/nf-config --flibs)
NCL += $(shell $(GC_BIN)/nc-config --libs)
NCL := $(filter -l%,$(NCL))
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%% NOTE TO GEOS-CHEM USERS: If you do not have netCDF-4.2 installed
#%%%% Then you can add/modify the linking sequence here. (This sequence
#%%%% is a guess, but is probably good enough for other netCDF builds.)
ifeq ($(NCL),)
NCL :=-lnetcdf -lnetcdff -lhdf5_hl -lhdf5 -lz
endif
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Prepend the library directory path to the linking sequence
NCL := -L$(GC_LIB) $(NCL)
LINK := $(NCL)
ifeq ($(USE_MKL),yes)
LINK += -L$(MKLROOT)/lib/em64t $(MKLROOT)/lib/em64t/libmkl_blas95_lp64.a $(MKLROOT)/lib/em64t/libmkl_lapack95_lp64.a -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core -openmp -lpthread
LAPACK_BLAS_FFLAGS += -I$(MKLROOT)/include/em64t/lp64/ -I$(MKLROOT)/include
endif
# Link to the HDF and HDF-EOS libraries
ifeq ($(HDF),yes)
HDFHOME=$(ROOT_LIBRARY_DIR)
HDFINC=$(GC_INCLUDE)
HDFLIB=$(GC_LIB)
HDFEOS_HOME=$(ROOT_LIBRARY_DIR)
HDFEOS_INC=$(GC_INCLUDE)
HDFEOS_LIB=$(GC_LIB)
HDF5HOME=$(ROOT_LIBRARY_DIR)
HDF5INC=$(GC_INCLUDE)
HDF5LIB=$(GC_LIB)
FFLAGS += -I$(HDFEOS_INC) -I$(HDF5INC) -I$(HDFINC)
LINK += -L$(HDFEOS_LIB) -L$(HDF5LIB) -L$(HDFLIB) -lhdfeos -lGctp -lmfhdf -ldf -lz -lm -ljpeg -lsz -lhdf5 -lhdf5_hl -lhdf5hl_fortran -lhdf5_fortran -lhe5_hdfeos
endif
ifeq ($(SAT_NETCDF),yes)
LINK += -L$(MKLPATH) $(MKLPATH)/libmkl_solver_lp64.a -Wl,--start-group \
-lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core -Wl,--end-group \
-openmp -lpthread
endif
#==============================================================================
# Include Objects
#==============================================================================
VPATH = ./modified ./adjoint ./new ./obs_operators ./NcdfUtil
ifeq ($(LIDORT),yes)
VPATH += ./lidort ./lidort/thread_sourcecode_MkII_F90
endif
include ./Objects.mk
# Add LIDORT Specific Code
ifeq ($(LIDORT),yes)
#====================
# LIDORT CODE
#====================
# dkh
#LIDORT_COMPILE = ifort -c -warn all -check bounds -O3 -zero
LIDORT_COMPILE_FIXED = ifort -cpp -check bounds -O3 -zero -noalign -fixed -openmp -Dmultitask
LIDORT_COMPILE = ifort -c -check bounds -O3 -zero -noalign -free -openmp -Dmultitask -traceback -CB -vec-report0
LAPACK_COMPILE = ifort -c -warn all -check bounds -O3 -zero
LAPACK_NOPT_COMPILE = ifort -c -O3 -zero
FLINK = ifort
# Link definition
#################
#LINK.f90 = $(FLINK) -g -pg
LINK.f90 = $(FLINK)
# dkh
#LIDORT_PATH = ..
LIDORT_PATH = ./lidort
# other paths are relative
SPATH_S = $(LIDORT_PATH)/thread_sourcecode_MkII_F90/
OBJ = $(LIDORT_PATH)/OBJECTS_F90
# OBJECT MODULES
# LIDORT modules in directory sourcecode
MIE = \
RTS_mie_modules.o \
RTS_mie_sourcecode.o \
RTS_mie_sourcecode_plus.o \
GC_forward_Mie.o \
GC_adjoint_Mie.o
# Masters set
OBJECTS_LIDORT_MASTERS = $(OBJ)/lidort_masters_basic.o
OBJECTS_LIDORT_MASTERS_LCS = $(OBJ)/lidort_masters_lcs.o
OBJECTS_LIDORT_MASTERS_LPS = $(OBJ)/lidort_masters_lps.o
# Basic set for Radiances
OBJECTS_LIDORT_BASIC = $(OBJ)/lidort_solutions.o \
$(OBJ)/lidort_bvproblem.o \
$(OBJ)/lidort_intensity.o \
$(OBJ)/lidort_corrections.o \
$(OBJ)/lidort_miscsetups.o \
$(OBJ)/lidort_inputs.o \
$(OBJ)/lidort_geometry.o
OBJECTS_LIDORT_AUX = $(OBJ)/lidort_aux.o
OBJECTS_LIDORT_LA = $(OBJ)/lidort_la_solutions.o \
$(OBJ)/lidort_la_miscsetups.o
OBJECTS_LIDORT_LC = $(OBJ)/lidort_lc_bvproblem.o \
$(OBJ)/lidort_lc_wfatmos.o \
$(OBJ)/lidort_lc_corrections.o \
$(OBJ)/lidort_lc_miscsetups.o
OBJECTS_LIDORT_LP = $(OBJ)/lidort_lp_bvproblem.o \
$(OBJ)/lidort_lp_wfatmos.o \
$(OBJ)/lidort_lp_corrections.o \
$(OBJ)/lidort_lp_miscsetups.o
OBJECTS_LIDORT_LS = $(OBJ)/lidort_ls_wfsurface.o \
$(OBJ)/lidort_ls_corrections.o
# LIDORT environment & interface modules
#OBJECTS_LIDORT_3P5T_LPS_MT = $(OBJ)/lidort_mod.o
endif
#=============================================================================
# Executables and Documentation
#=============================================================================
ifeq ($(LIDORT),yes)
geos: $(MODS) $(OBJS) $(OBJSe) $(FJ) \
$(OBJECTS_LIDORT_MASTERS_LPS) \
$(OBJECTS_LIDORT_AUX) \
$(OBJECTS_LIDORT_BASIC) \
$(OBJECTS_LIDORT_LA) \
$(OBJECTS_LIDORT_LP) \
$(OBJECTS_LIDORT_LS) \
$(MIE)
# $(F90) $(MODS) $(OBJS) $(OBJSe) $(FJ) $(LIBS) -o geos
# $(F90) *.o -o geos
# $(F90) $(MODS) $(OBJS) $(OBJSe) $(FJ) -o geos
$(F90) $(MODS) $(OBJS) $(OBJSe) $(FJ) \
$(OBJECTS_LIDORT_MASTERS_LPS) \
$(OBJECTS_LIDORT_AUX) \
$(OBJECTS_LIDORT_BASIC) \
$(OBJECTS_LIDORT_LA) \
$(OBJECTS_LIDORT_LP) \
$(OBJECTS_LIDORT_LS) \
$(MIE) $(LINK) -o geos
else
geos: $(MODS) $(OBJS) $(OBJSe) $(FJ)
$(F90) $(MODS) $(OBJS) $(OBJSe) $(FJ) \
$(LINK) -o geos
endif
# Build GEOS-Chem documenation w/ ProTeX
doc:
@$(MAKE) -C doc all
# Remove all *.tex, *.ps, and *.pdf files from the doc subdirectory
docclean:
@$(MAKE) -C doc clean
help:
@echo '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%'
@echo '%%% GEOS-Chem Adjoint Help Screen %%%'
@echo '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%'
@echo ''
@echo 'Usage: make TARGET [ OPTIONAL-FLAGS ]'
@echo ''
@echo 'TARGET may be one of the following:'
@echo 'geos Builds GEOS-Chem Adjoint source code'
@echo 'clean Removes *.o, *.mod files and geos executable'
@echo 'OPTIONAL-FLAGS may be:'
@echo 'DEBUG=yes Builds GEOS-Chem for a debugger (with -g -O0)'
@echo 'HDF=yes Enables writing diagnostic timeseries output to HDF files'
@echo 'IPO=yes Turns on optmization options -ipo -static (default is no)'
@echo 'LIDORT=yes Enables LIDORT Modules'
@echo 'OMP=[yes|no] Turns OpenMP parallelization on/off (default is yes)'
@echo 'SAT_NETCDF=yes Enables Satellite NetCDF'
@echo 'TRACEBACK=yes Turns on -traceback option (default is yes)'
@echo ''
@echo 'NOTE: This installation is set up to work with Intel Fortran Compilers only'
#==============================================================================
# Include Dependencies
#==============================================================================
include ./Dependencies.mk
ifeq ($(HDF),yes)
#====================
# MOPITT CODE
#====================
gvchsq.o : gvchsq.f
$(F90) -c -r8 obs_operators/gvchsq.f
HdfIncludeModule.o : HdfIncludeModule.f90
$(F90) -c -r8 obs_operators/HdfIncludeModule.f90
HdfSdModule.o : HdfSdModule.f90
$(F90) -c -r8 obs_operators/HdfSdModule.f90
HdfVdModule.o : HdfVdModule.f90
$(F90) -c -r8 obs_operators/HdfVdModule.f90
interp.o : interp.f
$(F90) -c -r8 obs_operators/interp.f
gaussj.o : gaussj.f
$(F90) -c -r8 obs_operators/gaussj.f
mopitt_obs_mod.o : mopitt_obs_mod.f CMN CMN_SIZE define.h define_adj.h
$(F90) -c -r8 obs_operators/mopitt_obs_mod.f
#====================
# OMI NO2 CODE
#====================
omi_no2_obs_mod.o : omi_no2_obs_mod.f90 CMN CMN_SIZE define.h define_adj.h
$(F90) -c -r8 obs_operators/omi_no2_obs_mod.f90
#====================
# OMI L3 SO2
#====================
omi_so2_obs_mod.o : omi_so2_obs_mod.f
$(F90) -c -r8 obs_operators/omi_so2_obs_mod.f
#====================
# AIRS CODE
#====================
He4IncludeModule.o : He4IncludeModule.f90
$(F90) -c -r8 obs_operators/He4IncludeModule.f90
He4ErrorModule.o : He4ErrorModule.f90
$(F90) -c -r8 obs_operators/He4ErrorModule.f90
He4GridModule.o : He4GridModule.f90
$(F90) -c -r8 obs_operators/He4GridModule.f90
He4SwathModule.o : He4SwathModule.f90
$(F90) -c -r8 obs_operators/He4SwathModule.f90
airsv5_mod.o : airsv5_mod.f90
$(F90) -c -r8 obs_operators/airsv5_mod.f90
airs_co_obs_mod.o : airs_co_obs_mod.f CMN_SIZE define.h
$(F90) -c -r8 obs_operators/airs_co_obs_mod.f
findinv.o : findinv.f
$(F90) -c -r8 obs_operators/findinv.f
endif
ifeq ($(SAT_NETCDF),yes)
#====================
# TES CODE
#====================
gosat_co2_mod.o : gosat_co2_mod.f
$(F90) -c -r8 obs_operators/gosat_co2_mod.f
tes_nh3_mod.o : tes_nh3_mod.f
$(F90) -c -r8 obs_operators/tes_nh3_mod.f
tes_o3_mod.o : tes_o3_mod.f
$(F90) -c -r8 obs_operators/tes_o3_mod.f
tes_o3_irk_mod.o : tes_o3_irk_mod.f
$(F90) -c -r8 obs_operators/tes_o3_irk_mod.f
#====================
# MODIS AOD CODE (xxu, dkh, 01/09/12, adj32_011)
#====================
modis_aod_obs_mod.o : modis_aod_obs_mod.f
$(F90) -c -r8 obs_operators/modis_aod_obs_mod.f
#====================
# SCIA CODE
#====================
scia_ch4_mod.o : scia_ch4_mod.f CMN_SIZE
$(F90) -c -r8 $<
endif
ifeq ($(LIDORT),yes)
#====================
# LIDORT CODE
#====================
#--------------------------------------------------
#--------------------------Environment modules-----
#--------------------------------------------------
#lidort_mod.o: lidort_mod.f \
# $(SPATH_S)LIDORT.PARS_F90
# $(F90) $(LIDORT_PATH)/lidort_mod.f
# $(LIDORT_COMPILE_FIXED) $(LIDORT_PATH)/lidort_mod.f90
#$(LIDORT_COMPILE_FIXED) $(LIDORT_PATH)/lidort_mod.f90 -o lidort_mod.o
lidort_mod.o : lidort_mod.f LIDORT.PARS_F90
$(F90) -c -r8 lidort/lidort_mod.f
mie_mod.o : mie_mod.f
$(F90) -c -r8 lidort/mie_mod.f
RTS_mie_modules.o : RTS_mie_modules.f90
$(F90) -c -r8 lidort/RTS_mie_modules.f90
RTS_mie_sourcecode.o : RTS_mie_sourcecode.f90
$(F90) -c -r8 lidort/RTS_mie_sourcecode.f90
RTS_mie_sourcecode_plus.o : RTS_mie_sourcecode_plus.f90
$(F90) -c -r8 lidort/RTS_mie_sourcecode_plus.f90
GC_forward_Mie.o : GC_forward_Mie.f90
$(F90) -c -r8 lidort/GC_forward_Mie.f90
GC_adjoint_Mie.o : GC_adjoint_Mie.f90
$(F90) -c -r8 lidort/GC_adjoint_Mie.f90
#----------------------------------------------------
#----------------------LIDORT master modules --------
#----------------------------------------------------
$(OBJ)/lidort_masters_lps.o: $(SPATH_S)lidort_masters_lps.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_masters_lps.f90 -o $(OBJ)/lidort_masters_lps.o
#----------------------------------------------------
#----------------------LIDORT Radiance modules ------
#----------------------------------------------------
$(OBJ)/lidort_solutions.o: $(SPATH_S)lidort_solutions.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_solutions.f90 -o $(OBJ)/lidort_solutions.o
$(OBJ)/lidort_bvproblem.o: $(SPATH_S)lidort_bvproblem.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_bvproblem.f90 -o $(OBJ)/lidort_bvproblem.o
$(OBJ)/lidort_geometry.o: $(SPATH_S)lidort_geometry.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_geometry.f90 -o $(OBJ)/lidort_geometry.o
$(OBJ)/lidort_intensity.o: $(SPATH_S)lidort_intensity.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_intensity.f90 -o $(OBJ)/lidort_intensity.o
$(OBJ)/lidort_miscsetups.o: $(SPATH_S)lidort_miscsetups.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_miscsetups.f90 -o $(OBJ)/lidort_miscsetups.o
$(OBJ)/lidort_corrections.o: $(SPATH_S)lidort_corrections.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_corrections.f90 -o $(OBJ)/lidort_corrections.o
$(OBJ)/lidort_inputs.o: $(SPATH_S)lidort_inputs.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_inputs.f90 -o $(OBJ)/lidort_inputs.o
# ---------------------------------------------------
#----------------------LIDORT Auxiliary module ------
# ---------------------------------------------------
$(OBJ)/lidort_aux.o: $(SPATH_S)lidort_aux.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LAPACK_COMPILE) $(SPATH_S)lidort_aux.f90 -o $(OBJ)/lidort_aux.o
# ---------------------------------------------------
#----------------------LIDORT Jacobian modules ------
# ---------------------------------------------------
# General
$(OBJ)/lidort_la_solutions.o: $(SPATH_S)lidort_la_solutions.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_la_solutions.f90 -o $(OBJ)/lidort_la_solutions.o
$(OBJ)/lidort_la_miscsetups.o: $(SPATH_S)lidort_la_miscsetups.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_la_miscsetups.f90 -o $(OBJ)/lidort_la_miscsetups.o
# Column specific
$(OBJ)/lidort_lc_bvproblem.o: $(SPATH_S)lidort_lc_bvproblem.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lc_bvproblem.f90 -o $(OBJ)/lidort_lc_bvproblem.o
$(OBJ)/lidort_lc_wfatmos.o: $(SPATH_S)lidort_lc_wfatmos.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lc_wfatmos.f90 -o $(OBJ)/lidort_lc_wfatmos.o
$(OBJ)/lidort_lc_corrections.o: $(SPATH_S)lidort_lc_corrections.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lc_corrections.f90 -o $(OBJ)/lidort_lc_corrections.o
$(OBJ)/lidort_lc_miscsetups.o: $(SPATH_S)lidort_lc_miscsetups.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lc_miscsetups.f90 -o $(OBJ)/lidort_lc_miscsetups.o
# Profile specific
$(OBJ)/lidort_lp_bvproblem.o: $(SPATH_S)lidort_lp_bvproblem.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lp_bvproblem.f90 -o $(OBJ)/lidort_lp_bvproblem.o
$(OBJ)/lidort_lp_wfatmos.o: $(SPATH_S)lidort_lp_wfatmos.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lp_wfatmos.f90 -o $(OBJ)/lidort_lp_wfatmos.o
$(OBJ)/lidort_lp_corrections.o: $(SPATH_S)lidort_lp_corrections.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lp_corrections.f90 -o $(OBJ)/lidort_lp_corrections.o
$(OBJ)/lidort_lp_miscsetups.o: $(SPATH_S)lidort_lp_miscsetups.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_lp_miscsetups.f90 -o $(OBJ)/lidort_lp_miscsetups.o
# Surface
$(OBJ)/lidort_ls_wfsurface.o: $(SPATH_S)lidort_ls_wfsurface.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_ls_wfsurface.f90 -o $(OBJ)/lidort_ls_wfsurface.o
$(OBJ)/lidort_ls_corrections.o: $(SPATH_S)lidort_ls_corrections.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_ls_corrections.f90 -o $(OBJ)/lidort_ls_corrections.o
#----------------------------------------------------
#----------- BRDF supplement modules ----------------
#----------------------------------------------------
$(OBJ)/lidort_brdf_supplement.o: $(SPATH_S)lidort_brdf_supplement.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_brdf_supplement.f90 -o $(OBJ)/lidort_brdf_supplement.o
$(OBJ)/lidort_brdf_kernels.o: $(SPATH_S)lidort_brdf_kernels.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_brdf_kernels.f90 -o $(OBJ)/lidort_brdf_kernels.o
$(OBJ)/lidort_brdf_ls_supplement.o: $(SPATH_S)lidort_brdf_ls_supplement.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_brdf_ls_supplement.f90 -o $(OBJ)/lidort_brdf_ls_supplement.o
$(OBJ)/lidort_brdf_ls_kernels.o: $(SPATH_S)lidort_brdf_ls_kernels.f90 \
$(SPATH_S)LIDORT.PARS_F90
$(LIDORT_COMPILE) $(SPATH_S)lidort_brdf_ls_kernels.f90 -o $(OBJ)/lidort_brdf_ls_kernels.o
endif
#==============================================================================
# Other compilation commands
#==============================================================================
ifort_errmsg.o : ifort_errmsg.f
linux_err.o : linux_err.c
$(CC) -c linux_err.c
#=============================================================================
# Other Makefile Commands
#=============================================================================
clean:
rm -rf *.o *.mod ifc* geos rii_files
.PHONY: clean doc docclean
.SUFFIXES: .f .F .f90 .F90
.f.o: ; $(F90) -c $*.f
.F.o: ; $(F90) -c $*.F
.f90.o: ; $(F90) -c -free $*.f90
.F90.o: ; $(F90) -c -free $*.F90
%.o : %.mod

16
code/NOABS.f Normal file
View File

@ -0,0 +1,16 @@
C $Id: NOABS.f,v 1.1 2009/06/09 21:51:51 daven Exp $
SUBROUTINE NOABS(XLO3,XLO2,XLRAY,BCAER,RFLECT)
C-----------------------------------------------------------------------
C Zero out absorption terms to check scattering code. Leave a little
C Rayleigh to provide a minimal optical depth, and set surface albedo
C to unity.
C-----------------------------------------------------------------------
IMPLICIT NONE
real*8 XLO3,XLO2,XLRAY,BCAER,RFLECT
XLO3=0.d0
XLO2=0.d0
XLRAY=XLRAY*1.d-10
BCAER=0.d0
RFLECT=1.d0
RETURN
END

436
code/OPMIE.f Normal file
View File

@ -0,0 +1,436 @@
C $Id: OPMIE.f,v 1.1 2009/06/09 21:51:54 daven Exp $
SUBROUTINE OPMIE(KW,WAVEL,XQO2,XQO3,FMEAN)
C-----------------------------------------------------------------------
C NEW Mie code for J's, only uses 8-term expansion, 4-Gauss pts
C Currently allow up to NP aerosol phase functions (at all altitudes) to
C be associated with optical depth AER(1:NC) = aerosol opt.depth @ 1000 nm
C
C Pick Mie-wavelength with phase function and Qext:
C
C 01 RAYLE = Rayleigh phase
C 02 ISOTR = isotropic
C 03 ABSRB = fully absorbing 'soot', wavelength indep.
C 04 S_Bkg = backgrnd stratospheric sulfate (n=1.46,log-norm:r=.09um/sigma=.6)
C 05 S_Vol = volcanic stratospheric sulfate (n=1.46,log-norm:r=.08um/sigma=.8)
C 06 W_H01 = water haze (H1/Deirm.) (n=1.335, gamma: r-mode=0.1um /alpha=2)
C 07 W_H04 = water haze (H1/Deirm.) (n=1.335, gamma: r-mode=0.4um /alpha=2)
C 08 W_C02 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=2.0um /alpha=6)
C 09 W_C04 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=4.0um /alpha=6)
C 10 W_C08 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=8.0um /alpha=6)
C 11 W_C13 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=13.3um /alpha=6)
C 12 W_L06 = water cloud (Lacis) (n=1.335, r-mode=5.5um / alpha=11/3)
C 13 Ice-H = hexagonal ice cloud (Mishchenko)
C 14 Ice-I = irregular ice cloud (Mishchenko)
C
C Choice of aerosol index MIEDX is made in SET_AER; optical depths are
C apportioned to the AER array in SET_PROF
C
C-----------------------------------------------------------------------
C FUNCTION RAYLAY(WAVE)---RAYLEIGH CROSS-SECTION for wave > 170 nm
C WSQI = 1.E6/(WAVE*WAVE)
C REFRM1 = 1.0E-6*(64.328+29498.1/(146.-WSQI)+255.4/(41.-WSQI))
C RAYLAY = 5.40E-21*(REFRM1*WSQI)**2
C-----------------------------------------------------------------------
c
c DTAUX Local optical depth of each CTM level
c PIRAY Contribution of Rayleigh scattering to extinction
c PIAER Contribution of Aerosol scattering to extinction
c TTAU Optical depth of air vertically above each point (to top of atm)
c FTAU Attenuation of solar beam
c POMEGA Scattering phase function
c FMEAN Mean actinic flux at desired levels
c
C-----------------------------------------------------------------------
IMPLICIT NONE
# include "cmn_fj.h"
# include "jv_cmn.h"
# include "jv_mie.h"
integer jndlev(lpar),jaddlv(nc),jaddto(nc+1)
integer KW,km,i,j,k,l,ix,j1
real*8 QXMIE(MX),XLAER(MX),SSALB(MX)
real*8 xlo2,xlo3,xlray,xltau,zk,taudn,tauup,zk2
real*8 WAVEL,XQO2(NB),XQO3(NB),FMEAN(lpar),POMEGAJ(2*M__,NC+1)
real*8 DTAUX(NB),PIRAY(NB),PIAER(MX,NB),TTAU(NC+1),FTAU(NC+1)
real*8 ftaulog,dttau,dpomega(2*M__)
real*8 ftaulog2,dttau2,dpomega2(2*M__)
! For KLUDGE to fix the # of added levels (phs, 7/1/08)
INTEGER :: loc(1)
c
C---Pick nearest Mie wavelength, no interpolation--------------
KM=1
if( WAVEL .gt. 355.d0 ) KM=2
if( WAVEL .gt. 500.d0 ) KM=3
C if( WAVEL .gt. 800.d0 ) KM=4 !drop the 1000 nm wavelength
c
C---For Mie code scale extinction at 1000 nm to wavelength WAVEL (QXMIE)
do I=1,MX
QXMIE(I) = QAA(KM,MIEDX(I))/QAA(4,MIEDX(I))
SSALB(I) = SSA(KM,MIEDX(I))
enddo
c
C---Reinitialize arrays
do j=1,nc+1
ttau(j)=0.d0
ftau(j)=0.d0
enddo
c
C---Set up total optical depth over each CTM level, DTAUX
J1 = NLBATM
do J=J1,NB
XLO3=DO3(J)*XQO3(J)
XLO2=DM(J)*XQO2(J)*0.20948d0
XLRAY=DM(J)*QRAYL(KW)
c Zero absorption for testing purposes
c call NOABS(XLO3,XLO2,XLRAY,AER(1,j),RFLECT)
do I=1,MX
XLAER(I)=AER(I,J)*QXMIE(I)
enddo
c Total optical depth from all elements
DTAUX(J)=XLO3+XLO2+XLRAY
do I=1,MX
DTAUX(J)=DTAUX(J)+XLAER(I)
enddo
c Fractional extinction for Rayleigh scattering and each aerosol type
PIRAY(J)=XLRAY/DTAUX(J)
do I=1,MX
PIAER(I,J)=SSALB(I)*XLAER(I)/DTAUX(J)
enddo
enddo
c
C---Define the scattering phase fn. with mix of Rayleigh(1) & Mie(MIEDX)
C No. of quadrature pts fixed at 4 (M__), expansion of phase fn @ 8
N = M__
MFIT = 2*M__
do j=j1,NB
do i=1,MFIT
pomegaj(i,j) = PIRAY(J)*PAA(I,KM,1)
do k=1,MX
pomegaj(i,j) = pomegaj(i,j) + PIAER(K,J)*PAA(I,KM,MIEDX(K))
enddo
enddo
enddo
c
C---Calculate attenuated incident beam EXP(-TTAU/U0) and flux on surface
do J=J1,NB
if(AMF(J,J).gt.0.0D0) then
XLTAU=0.0D0
do I=1,NB
XLTAU=XLTAU + DTAUX(I)*AMF(I,J)
enddo
if(XLTAU.gt.450.d0) then ! for compilers with no underflow trapping
FTAU(j)=0.d0
else
FTAU(J)=DEXP(-XLTAU)
endif
else
FTAU(J)=0.0D0
endif
enddo
if(U0.gt.0.D0) then
ZFLUX = U0*FTAU(J1)*RFLECT/(1.d0+RFLECT)
else
ZFLUX = 0.d0
endif
c
C------------------------------------------------------------------------
c Take optical properties on CTM layers and convert to a photolysis
c level grid corresponding to layer centres and boundaries. This is
c required so that J-values can be calculated for the centre of CTM
c layers; the index of these layers is kept in the jndlev array.
C------------------------------------------------------------------------
c
c Set lower boundary and levels to calculate J-values at
J1=2*J1-1
do j=1,lpar
jndlev(j)=2*j
enddo
c
c Calculate column optical depths above each level, TTAU
TTAU(NC+1)=0.0D0
do J=NC,J1,-1
I=(J+1)/2
TTAU(J)=TTAU(J+1) + 0.5d0*DTAUX(I)
jaddlv(j)=int(0.5d0*DTAUX(I)/dtaumax)
c Subdivide cloud-top levels if required
! NOTE: Don't add more than DTAUSUB-1 (=9) sublevels (phs)
if(jadsub(j).gt.0) then
jadsub(j)=min(jaddlv(j)+1,nint(dtausub))*(nint(dsubdiv)-1)
jaddlv(j)=jaddlv(j)+jadsub(j)
endif
enddo
c
c Calculate attenuated beam, FTAU, level boundaries then level centres
FTAU(NC+1)=1.0D0
do J=NC-1,J1,-2
I=(J+1)/2
FTAU(J)=FTAU(I)
enddo
do J=NC,J1,-2
FTAU(J)=sqrt(FTAU(J+1)*FTAU(J-1))
enddo
c
c Calculate scattering properties, level centres then level boundaries
c using an inverse interpolation to give correctly-weighted values
do j=NC,J1,-2
do i=1,MFIT
pomegaj(i,j) = pomegaj(i,j/2)
enddo
enddo
do j=J1+2,nc,2
taudn = ttau(j-1)-ttau(j)
tauup = ttau(j)-ttau(j+1)
do i=1,MFIT
pomegaj(i,j) = (pomegaj(i,j-1)*taudn +
$ pomegaj(i,j+1)*tauup) / (taudn+tauup)
enddo
enddo
c Define lower and upper boundaries
do i=1,MFIT
pomegaj(i,J1) = pomegaj(i,J1+1)
pomegaj(i,nc+1) = pomegaj(i,nc)
enddo
c
C------------------------------------------------------------------------
c Calculate cumulative total and define levels we want J-values at.
c Sum upwards for levels, and then downwards for Mie code readjustments.
c
c jaddlv(i) Number of new levels to add between (i) and (i+1)
c jaddto(i) Total number of new levels to add to and above level (i)
c jndlev(j) Level needed for J-value for CTM layer (j)
c
C------------------------------------------------------------------------
c
c Reinitialize level arrays
do j=1,nc+1
jaddto(j)=0
enddo
c
jaddto(J1)=jaddlv(J1)
do j=J1+1,nc
jaddto(j)=jaddto(j-1)+jaddlv(j)
enddo
!==============================================================================
! KLUDGE TO LIMIT THE NUMBER OF ADDED LEVELS (phs, 7/1/08)
!
! PART 1: We need to replace the .gt. with .ge in this IF test
!
if((jaddto(nc)+nc).GE.nl) then
write(6,1500) jaddto(nc)+nc, 'NL',NL
!
! PART 2: We just trim the largest JADDLV until the condition is satisfied
! instead of simply stopping. Remove the STOP statement.
!
!-------------------
! Prior to 7/1/08:
!stop
!-------------------
! trim
do while( (SUM( jaddlv(J1:nc) ) + NC) >= NL )
loc=maxloc(jaddlv)
jaddlv(loc(1))=jaddlv(loc(1))-1
enddo
! then refill JADDTO
jaddto(J1)=jaddlv(J1)
do j=J1+1,nc
jaddto(j)=jaddto(j-1)+jaddlv(j)
enddo
! ! Debug: double check
! write(6,*) jaddto(nc)+nc
! if((jaddto(nc)+nc).gt.nl)
! & write(6,*)'OPMIE kludge: trap not working'
!==============================================================================
endif
c write(6,1300) jndlev
c write(6,1300) jaddto
do i=1,lpar
jndlev(i)=jndlev(i)+jaddto(jndlev(i)-1)
enddo
! this is just a transposition of the jaddto vector (phs)
jaddto(nc)=jaddlv(nc)
do j=nc-1,J1,-1
jaddto(j)=jaddto(j+1)+jaddlv(j)
enddo
c write(6,1300) jndlev
c write(6,1300) jaddto
c
C---------------------SET UP FOR MIE CODE-------------------------------
c
c Transpose the ascending TTAU grid to a descending ZTAU grid.
c Double the resolution - TTAU points become the odd points on the
c ZTAU grid, even points needed for asymm phase fn soln, contain 'h'.
c Odd point added at top of grid for unattenuated beam (Z='inf')
c
c Surface: TTAU(1) now use ZTAU(2*NC+1)
c Top: TTAU(NC) now use ZTAU(3)
c Infinity: now use ZTAU(1)
c
c Mie scattering code only used from surface to level NC
C------------------------------------------------------------------------
C
c Initialise all Fast-J optical property arrays
do k=1,N__
do i=1,MFIT
pomega(i,k) = 0.d0
enddo
ztau(k) = 0.d0
fz(k) = 0.d0
enddo
c
c Ascend through atmosphere transposing grid and adding extra points
do j=J1,nc+1
k = 2*(nc+1-j)+2*jaddto(j)+1
ztau(k)= ttau(j)
fz(k) = ftau(j)
do i=1,MFIT
pomega(i,k) = pomegaj(i,j)
enddo
enddo
c
c Check profiles if desired
c ND = 2*(NC+jaddto(J1)-J1) + 3
c if(kw.eq.1) call CH_PROF
c
C------------------------------------------------------------------------
c Insert new levels, working downwards from the top of the atmosphere
c to the surface (down in 'j', up in 'k'). This allows ztau and pomega
c to be incremented linearly (in a +ve sense), and the flux fz to be
c attenuated top-down (avoiding problems where lower level fluxes are
c zero).
c
c zk fractional increment in level
c dttau change in ttau per increment (linear, positive)
c dpomega change in pomega per increment (linear)
c ftaulog change in ftau per increment (exponential, normally < 1)
c
C------------------------------------------------------------------------
c
do j=nc,J1,-1
zk = 0.5d0/(1.d0+dble(jaddlv(j)-jadsub(j)))
dttau = (ttau(j)-ttau(j+1))*zk
do i=1,MFIT
dpomega(i) = (pomegaj(i,j)-pomegaj(i,j+1))*zk
enddo
c Filter attenuation factor - set minimum at 1.0d-05
if(ftau(j+1).eq.0.d0) then
ftaulog=0.d0
else
ftaulog = ftau(j)/ftau(j+1)
if(ftaulog.lt.1.d-150) then
ftaulog=1.0d-05
else
ftaulog=exp(log(ftaulog)*zk)
endif
endif
k = 2*(nc-j+jaddto(j)-jaddlv(j))+1 ! k at level j+1
l = 0
c Additional subdivision of first level if required
if(jadsub(j).ne.0) then
l=jadsub(j)/nint(dsubdiv-1)
zk2=1.d0/dsubdiv
dttau2=dttau*zk2
ftaulog2=ftaulog**zk2
do i=1,MFIT
dpomega2(i)=dpomega(i)*zk2
enddo
do ix=1,2*(jadsub(j)+l)
ztau(k+1) = ztau(k) + dttau2
fz(k+1) = fz(k)*ftaulog2
do i=1,MFIT
pomega(i,k+1) = pomega(i,k) + dpomega2(i)
enddo
k = k+1
enddo
endif
l = 2*(jaddlv(j)-jadsub(j)-l)+1
c
c Add values at all intermediate levels
do ix=1,l
ztau(k+1) = ztau(k) + dttau
fz(k+1) = fz(k)*ftaulog
do i=1,MFIT
pomega(i,k+1) = pomega(i,k) + dpomega(i)
enddo
k = k+1
enddo
c
c Alternate method to attenuate fluxes, fz, using 2nd-order finite
c difference scheme - just need to comment in section below
c ix = 2*(jaddlv(j)-jadsub(j))+1
c if(l.le.0) then
c l=k-ix-1
c else
c l=k-ix
c endif
c call efold(ftau(j+1),ftau(j),ix+1,fz(l))
c if(jadsub(j).ne.0) then
c k = 2*(nc-j+jaddto(j)-jaddlv(j))+1 ! k at level j+1
c ix=2*(jadsub(j)+(jadsub(j)/nint(dsubdiv-1)))
c call efold(ftau(j+1),fz(k+ix),ix,fz(k))
c endif
c
enddo
c
C---Update total number of levels and check doesn't exceed N__
ND = 2*(NC+jaddto(J1)-J1) + 3
!==============================================================================
! KLUDGE TO LIMIT THE NUMBER OF ADDED LEVELS (phs, 7/1/08)
!
! PART 3: Test to make sure that we haven't added more levels than the
! dimension of the common block (i.e. ND <= N__).
!
! NOTE: this test should always be passed now that .ge. is
! used instead of .gt. in PART 1.
!
if(nd.gt.N__) then
write(6,1500) ND, 'N__',N__
stop
endif
!==============================================================================
c
C---Add boundary/ground layer to ensure no negative J's caused by
C---too large a TTAU-step in the 2nd-order lower b.c.
ZTAU(ND+1) = ZTAU(ND)*1.000005d0
ZTAU(ND+2) = ZTAU(ND)*1.000010d0
zk=max(abs(U0),0.01d0)
zk=dexp(-ZTAU(ND)*5.d-6/zk)
FZ(ND+1) = FZ(ND)*zk
FZ(ND+2) = FZ(ND+1)*zk
do I=1,MFIT
POMEGA(I,ND+1) = POMEGA(I,ND)
POMEGA(I,ND+2) = POMEGA(I,ND)
enddo
ND = ND+2
c
ZU0 = U0
ZREFL = RFLECT
c
C-----------------------------------------
CALL MIESCT
C-----------------------------------------
c Accumulate attenuation for selected levels
l=2*(NC+jaddto(J1))+3
do j=1,lpar
k=l-(2*jndlev(j))
if(k.gt.ND-2) then
FMEAN(j) = 0.d0
else
FMEAN(j) = FJ(k)
endif
enddo
c
return
1000 format(1x,i3,3(2x,1pe10.4),1x,i3)
1300 format(1x,50(i3))
1500 format(' Too many levels in photolysis code: need ',i5,' but ',a,
$ ' dimensioned as ',i5)
END

320
code/Objects.default Normal file
View File

@ -0,0 +1,320 @@
OBJSe = \
ifort_errmsg.o
OBJS = \
CO_strat_pl.o \
CO_strat_pl_adj.o \
airmas.o \
anthroems.o \
arsl1k.o \
adBuffer.o \
adStack.o \
backsub.o \
biofit.o \
blas.o \
boxvl.o \
calcrate.o \
calcrate_adj.o \
chemdr.o \
chemdr_adj.o \
cleanup.o \
cleanup_adj.o \
decomp.o \
diag1.o \
diag3.o \
diag_2pm.o \
diagoh.o \
emf_scale.o \
emfossil.o \
emisop.o \
emisop_grass.o \
emisop_mb.o \
emissdr.o \
emmonot.o \
fertadd.o \
findmon.o \
fcro2ho2.o \
fyrno3.o \
fyhoro.o \
gasconc.o \
get_global_ch4.o \
getifsun.o \
initialize.o \
jsparse.o \
ksparse.o \
linpack.o \
lump.o \
lump_adj.o \
ndxx_setup.o \
ohsave.o \
partition.o \
partition_adj.o \
pderiv.o \
physproc.o \
precipfrac.o \
pulsing.o \
rdisopt.o \
rdlai.o \
rdland.o \
rdlight.o \
rdmonot.o \
rdsoil.o \
readchem.o \
reader.o \
readlai.o \
routines.o \
ruralbox.o \
schem.o \
schem_adj.o \
setbase.o \
setemdep.o \
setemis.o \
setemis_adj.o \
setmodel.o \
sfcwindsqr.o \
smvgear.o \
soilbase.o \
soilcrf.o \
soilnoxems.o \
soiltemp.o \
soiltype.o \
subfun.o \
sunparam.o \
timer.o \
tcorr.o \
tropopause.o \
update.o \
xltmmp.o
FJ = \
BLKSLV.o \
CLDSRF.o \
EFOLD.o \
FLINT.o \
GAUSSP.o \
GEN.o \
JRATET.o \
JVALUE.o \
LEGND0.o \
MATIN4.o \
MIESCT.o \
NOABS.o \
OPMIE.o \
RD_TJPL.o \
SPHERE.o \
XSEC1D.o \
XSECO2.o \
XSECO3.o \
fast_j.o \
fjfunc.o \
rd_aod.o \
inphot.o \
jv_index.o \
mmran_16.o \
photoj.o \
rd_js.o \
rd_prof.o \
set_aer.o \
set_prof.o
MODS = \
fjx_acet_mod.o \
charpak_mod.o \
error_mod.o \
netcdf_util_mod.o \
m_do_err_out.o \
m_netcdf_io_checks.o \
m_netcdf_io_close.o \
m_netcdf_io_create.o \
m_netcdf_io_define.o \
m_netcdf_io_get_dimlen.o \
m_netcdf_io_handle_err.o \
m_netcdf_io_open.o \
m_netcdf_io_read.o \
m_netcdf_io_readattr.o \
m_netcdf_io_write.o \
logical_mod.o \
directory_mod.o \
unix_cmds_mod.o \
tracer_mod.o \
julday_mod.o \
file_mod.o \
grid_mod.o \
time_mod.o \
logical_adj_mod.o \
directory_adj_mod.o \
bpch2_mod.o \
inquireMod.o \
regrid_1x1_mod.o \
regrid_a2a_mod.o \
pressure_mod.o \
transfer_mod.o \
future_emissions_mod.o \
lai_mod.o \
tracerid_mod.o \
benchmark_mod.o \
comode_mod.o \
diag_mod.o \
dao_mod.o \
gc_type_mod.o \
tropopause_mod.o \
gckpp_adj_Precision.o \
gckpp_adj_Parameters.o \
gckpp_adj_Global.o \
critical_load_mod.o \
htap_mod.o \
adj_arrays_mod.o \
gckpp_adj_Function.o \
gckpp_adj_Monitor.o \
gckpp_adj_Util.o \
gckpp_adj_HessianSP.o \
gckpp_adj_Hessian.o \
gckpp_adj_Initialize.o \
gckpp_adj_JacobianSP.o \
gckpp_adj_Jacobian.o \
gckpp_adj_LinearAlgebra.o \
gckpp_adj_Rates.o \
gckpp_adj_StoichiomSP.o \
gckpp_adj_Stoichiom.o \
gckpp_adj_Integrator.o \
gckpp_adj_Model.o \
checkpoint_mod.o \
pbl_mix_mod.o \
pbl_mix_adj_mod.o \
diag03_mod.o \
diag04_mod.o \
diag41_mod.o \
diag42_mod.o \
diag48_mod.o \
diag49_mod.o \
diag50_mod.o \
diag51_mod.o \
diag51b_mod.o \
diag51c_mod.o \
diag51d_mod.o \
diag56_mod.o \
diag59_mod.o \
diag_oh_mod.o \
diag_pl_mod.o \
ocean_mercury_mod.o \
drydep_mod.o \
scale_anthro_mod.o \
edgar_mod.o \
bravo_mod.o \
emep_mod.o \
nei2005_anthro_mod.o \
nei2008_anthro_mod.o \
epa_nei_mod.o \
streets_anthro_mod.o \
icoads_ship_mod.o \
arctas_ship_emiss_mod.o \
cac_anthro_mod.o \
vistas_anthro_mod.o \
geia_mod.o \
geosfp_read_mod.o \
global_oh_mod.o \
global_hno3_mod.o \
global_no3_mod.o \
global_nox_mod.o \
global_o1d_mod.o \
global_o3_mod.o \
hippo_mod.o \
atom_obs_mod.o \
uvalbedo_mod.o \
RnPbBe_mod.o \
Kr85_mod.o \
acetone_mod.o \
aerosol_mod.o \
aircraft_nox_mod.o \
retro_mod.o \
biofuel_mod.o \
gc_biomass_mod.o \
gfed2_biomass_mod.o \
gfed3_biomass_mod.o \
biomass_mod.o \
global_ch4_mod.o \
global_ch4_adj_mod.o \
c2h6_mod.o \
ch3i_mod.o \
a3_read_mod.o \
a6_read_mod.o \
i6_read_mod.o \
gcap_read_mod.o \
gwet_read_mod.o \
xtra_read_mod.o \
megan_mod.o \
rcp_mod.o \
carbon_mod.o \
carbon_adj_mod.o \
optdepth_mod.o \
planeflight_mod.o \
restart_mod.o \
checkpt_mod.o \
population_mod.o \
lightning_nox_mod.o \
rpmares_mod.o \
rpmares_adj_mod.o \
isoropiaIIcode_adj.o \
isoropiaII_adj_mod.o \
wetscav_mod.o \
wetscav_adj_mod.o \
seasalt_mod.o \
sulfate_mod.o \
sulfate_adj_mod.o \
hcn_ch3cn_mod.o \
tagged_co_mod.o \
tagged_co_adj_mod.o \
tagged_ox_mod.o \
tagged_ox_adj_mod.o \
h2_hd_mod.o \
gcap_convect_mod.o \
fvdas_convect_mod.o \
convection_mod.o \
fvdas_convect_adj_mod.o \
convection_adj_mod.o \
pjc_pfix_mod.o \
pjc_pfix_geos5_window_mod.o \
pjc_pfix_geosfp_window_mod.o \
dust_dead_mod.o \
dust_mod.o \
dust_adj_mod.o \
co2_mod.o \
co2_adj_mod.o \
mercury_mod.o \
toms_mod.o \
tpcore_bc_mod.o \
tpcore_fvdas_mod.o \
tpcore_mod.o \
tpcore_window_mod.o \
tpcore_geos5_window_mod.o \
tpcore_geosfp_window_mod.o \
transport_mod.o \
linoz_mod.o \
linoz_adj_mod.o \
upbdflx_adj_mod.o \
upbdflx_mod.o \
strat_chem_mod.o \
strat_chem_adj_mod.o \
chemistry_mod.o \
chemistry_adj_mod.o \
paranox_mod.o \
paranox_adj_mod.o \
emissions_mod.o \
weak_constraint_mod.o \
emissions_adj_mod.o \
gamap_mod.o \
input_mod.o \
improve_bc_mod.o \
geos_chem_mod.o \
ErrorModule.o \
sciabr_co_obs_mod.o \
tes_ch4_mod.o \
mem_ch4_mod.o \
leo_ch4_mod.o \
geocape_ch4_mod.o \
osiris_obs_mod.o \
geos_chem_adj_mod.o \
inv_hessian_mod.o \
input_adj_mod.o \
inverse_mod.o \
inverse_driver.o

319
code/Objects.default~ Normal file
View File

@ -0,0 +1,319 @@
OBJSe = \
ifort_errmsg.o
OBJS = \
CO_strat_pl.o \
CO_strat_pl_adj.o \
airmas.o \
anthroems.o \
arsl1k.o \
adBuffer.o \
adStack.o \
backsub.o \
biofit.o \
blas.o \
boxvl.o \
calcrate.o \
calcrate_adj.o \
chemdr.o \
chemdr_adj.o \
cleanup.o \
cleanup_adj.o \
decomp.o \
diag1.o \
diag3.o \
diag_2pm.o \
diagoh.o \
emf_scale.o \
emfossil.o \
emisop.o \
emisop_grass.o \
emisop_mb.o \
emissdr.o \
emmonot.o \
fertadd.o \
findmon.o \
fcro2ho2.o \
fyrno3.o \
fyhoro.o \
gasconc.o \
get_global_ch4.o \
getifsun.o \
initialize.o \
jsparse.o \
ksparse.o \
linpack.o \
lump.o \
lump_adj.o \
ndxx_setup.o \
ohsave.o \
partition.o \
partition_adj.o \
pderiv.o \
physproc.o \
precipfrac.o \
pulsing.o \
rdisopt.o \
rdlai.o \
rdland.o \
rdlight.o \
rdmonot.o \
rdsoil.o \
readchem.o \
reader.o \
readlai.o \
routines.o \
ruralbox.o \
schem.o \
schem_adj.o \
setbase.o \
setemdep.o \
setemis.o \
setemis_adj.o \
setmodel.o \
sfcwindsqr.o \
smvgear.o \
soilbase.o \
soilcrf.o \
soilnoxems.o \
soiltemp.o \
soiltype.o \
subfun.o \
sunparam.o \
timer.o \
tcorr.o \
tropopause.o \
update.o \
xltmmp.o
FJ = \
BLKSLV.o \
CLDSRF.o \
EFOLD.o \
FLINT.o \
GAUSSP.o \
GEN.o \
JRATET.o \
JVALUE.o \
LEGND0.o \
MATIN4.o \
MIESCT.o \
NOABS.o \
OPMIE.o \
RD_TJPL.o \
SPHERE.o \
XSEC1D.o \
XSECO2.o \
XSECO3.o \
fast_j.o \
fjfunc.o \
rd_aod.o \
inphot.o \
jv_index.o \
mmran_16.o \
photoj.o \
rd_js.o \
rd_prof.o \
set_aer.o \
set_prof.o
MODS = \
fjx_acet_mod.o \
charpak_mod.o \
error_mod.o \
netcdf_util_mod.o \
m_do_err_out.o \
m_netcdf_io_checks.o \
m_netcdf_io_close.o \
m_netcdf_io_create.o \
m_netcdf_io_define.o \
m_netcdf_io_get_dimlen.o \
m_netcdf_io_handle_err.o \
m_netcdf_io_open.o \
m_netcdf_io_read.o \
m_netcdf_io_readattr.o \
m_netcdf_io_write.o \
logical_mod.o \
directory_mod.o \
unix_cmds_mod.o \
tracer_mod.o \
julday_mod.o \
file_mod.o \
grid_mod.o \
time_mod.o \
logical_adj_mod.o \
directory_adj_mod.o \
bpch2_mod.o \
inquireMod.o \
regrid_1x1_mod.o \
regrid_a2a_mod.o \
pressure_mod.o \
transfer_mod.o \
future_emissions_mod.o \
lai_mod.o \
tracerid_mod.o \
benchmark_mod.o \
comode_mod.o \
diag_mod.o \
dao_mod.o \
gc_type_mod.o \
tropopause_mod.o \
gckpp_adj_Precision.o \
gckpp_adj_Parameters.o \
gckpp_adj_Global.o \
critical_load_mod.o \
htap_mod.o \
adj_arrays_mod.o \
gckpp_adj_Function.o \
gckpp_adj_Monitor.o \
gckpp_adj_Util.o \
gckpp_adj_HessianSP.o \
gckpp_adj_Hessian.o \
gckpp_adj_Initialize.o \
gckpp_adj_JacobianSP.o \
gckpp_adj_Jacobian.o \
gckpp_adj_LinearAlgebra.o \
gckpp_adj_Rates.o \
gckpp_adj_StoichiomSP.o \
gckpp_adj_Stoichiom.o \
gckpp_adj_Integrator.o \
gckpp_adj_Model.o \
checkpoint_mod.o \
pbl_mix_mod.o \
pbl_mix_adj_mod.o \
diag03_mod.o \
diag04_mod.o \
diag41_mod.o \
diag42_mod.o \
diag48_mod.o \
diag49_mod.o \
diag50_mod.o \
diag51_mod.o \
diag51b_mod.o \
diag51c_mod.o \
diag51d_mod.o \
diag56_mod.o \
diag59_mod.o \
diag_oh_mod.o \
diag_pl_mod.o \
ocean_mercury_mod.o \
drydep_mod.o \
scale_anthro_mod.o \
edgar_mod.o \
bravo_mod.o \
emep_mod.o \
nei2005_anthro_mod.o \
nei2008_anthro_mod.o \
epa_nei_mod.o \
streets_anthro_mod.o \
icoads_ship_mod.o \
arctas_ship_emiss_mod.o \
cac_anthro_mod.o \
vistas_anthro_mod.o \
geia_mod.o \
geosfp_read_mod.o \
global_oh_mod.o \
global_hno3_mod.o \
global_no3_mod.o \
global_nox_mod.o \
global_o1d_mod.o \
global_o3_mod.o \
hippo_mod.o \
uvalbedo_mod.o \
RnPbBe_mod.o \
Kr85_mod.o \
acetone_mod.o \
aerosol_mod.o \
aircraft_nox_mod.o \
retro_mod.o \
biofuel_mod.o \
gc_biomass_mod.o \
gfed2_biomass_mod.o \
gfed3_biomass_mod.o \
biomass_mod.o \
global_ch4_mod.o \
global_ch4_adj_mod.o \
c2h6_mod.o \
ch3i_mod.o \
a3_read_mod.o \
a6_read_mod.o \
i6_read_mod.o \
gcap_read_mod.o \
gwet_read_mod.o \
xtra_read_mod.o \
megan_mod.o \
rcp_mod.o \
carbon_mod.o \
carbon_adj_mod.o \
optdepth_mod.o \
planeflight_mod.o \
restart_mod.o \
checkpt_mod.o \
population_mod.o \
lightning_nox_mod.o \
rpmares_mod.o \
rpmares_adj_mod.o \
isoropiaIIcode_adj.o \
isoropiaII_adj_mod.o \
wetscav_mod.o \
wetscav_adj_mod.o \
seasalt_mod.o \
sulfate_mod.o \
sulfate_adj_mod.o \
hcn_ch3cn_mod.o \
tagged_co_mod.o \
tagged_co_adj_mod.o \
tagged_ox_mod.o \
tagged_ox_adj_mod.o \
h2_hd_mod.o \
gcap_convect_mod.o \
fvdas_convect_mod.o \
convection_mod.o \
fvdas_convect_adj_mod.o \
convection_adj_mod.o \
pjc_pfix_mod.o \
pjc_pfix_geos5_window_mod.o \
pjc_pfix_geosfp_window_mod.o \
dust_dead_mod.o \
dust_mod.o \
dust_adj_mod.o \
co2_mod.o \
co2_adj_mod.o \
mercury_mod.o \
toms_mod.o \
tpcore_bc_mod.o \
tpcore_fvdas_mod.o \
tpcore_mod.o \
tpcore_window_mod.o \
tpcore_geos5_window_mod.o \
tpcore_geosfp_window_mod.o \
transport_mod.o \
linoz_mod.o \
linoz_adj_mod.o \
upbdflx_adj_mod.o \
upbdflx_mod.o \
strat_chem_mod.o \
strat_chem_adj_mod.o \
chemistry_mod.o \
chemistry_adj_mod.o \
paranox_mod.o \
paranox_adj_mod.o \
emissions_mod.o \
weak_constraint_mod.o \
emissions_adj_mod.o \
gamap_mod.o \
input_mod.o \
improve_bc_mod.o \
geos_chem_mod.o \
ErrorModule.o \
sciabr_co_obs_mod.o \
tes_ch4_mod.o \
mem_ch4_mod.o \
leo_ch4_mod.o \
geocape_ch4_mod.o \
osiris_obs_mod.o \
geos_chem_adj_mod.o \
inv_hessian_mod.o \
input_adj_mod.o \
inverse_mod.o \
inverse_driver.o

320
code/Objects.mk Normal file
View File

@ -0,0 +1,320 @@
OBJSe = \
ifort_errmsg.o
OBJS = \
CO_strat_pl.o \
CO_strat_pl_adj.o \
airmas.o \
anthroems.o \
arsl1k.o \
adBuffer.o \
adStack.o \
backsub.o \
biofit.o \
blas.o \
boxvl.o \
calcrate.o \
calcrate_adj.o \
chemdr.o \
chemdr_adj.o \
cleanup.o \
cleanup_adj.o \
decomp.o \
diag1.o \
diag3.o \
diag_2pm.o \
diagoh.o \
emf_scale.o \
emfossil.o \
emisop.o \
emisop_grass.o \
emisop_mb.o \
emissdr.o \
emmonot.o \
fertadd.o \
findmon.o \
fcro2ho2.o \
fyrno3.o \
fyhoro.o \
gasconc.o \
get_global_ch4.o \
getifsun.o gvchsq.o \
initialize.o \
jsparse.o \
ksparse.o \
linpack.o \
lump.o \
lump_adj.o \
ndxx_setup.o \
ohsave.o \
partition.o \
partition_adj.o \
pderiv.o \
physproc.o \
precipfrac.o \
pulsing.o \
rdisopt.o \
rdlai.o \
rdland.o \
rdlight.o \
rdmonot.o \
rdsoil.o \
readchem.o \
reader.o \
readlai.o \
routines.o \
ruralbox.o \
schem.o \
schem_adj.o \
setbase.o \
setemdep.o \
setemis.o \
setemis_adj.o \
setmodel.o \
sfcwindsqr.o \
smvgear.o \
soilbase.o \
soilcrf.o \
soilnoxems.o \
soiltemp.o \
soiltype.o \
subfun.o \
sunparam.o \
timer.o \
tcorr.o \
tropopause.o \
update.o \
xltmmp.o
FJ = \
BLKSLV.o \
CLDSRF.o \
EFOLD.o \
FLINT.o \
GAUSSP.o \
GEN.o \
JRATET.o \
JVALUE.o \
LEGND0.o \
MATIN4.o \
MIESCT.o \
NOABS.o \
OPMIE.o \
RD_TJPL.o \
SPHERE.o \
XSEC1D.o \
XSECO2.o \
XSECO3.o \
fast_j.o \
fjfunc.o \
rd_aod.o \
inphot.o \
jv_index.o \
mmran_16.o \
photoj.o \
rd_js.o \
rd_prof.o \
set_aer.o \
set_prof.o
MODS = \
fjx_acet_mod.o \
charpak_mod.o \
error_mod.o \
netcdf_util_mod.o \
m_do_err_out.o \
m_netcdf_io_checks.o \
m_netcdf_io_close.o \
m_netcdf_io_create.o \
m_netcdf_io_define.o \
m_netcdf_io_get_dimlen.o \
m_netcdf_io_handle_err.o \
m_netcdf_io_open.o \
m_netcdf_io_read.o \
m_netcdf_io_readattr.o \
m_netcdf_io_write.o \
logical_mod.o \
directory_mod.o \
unix_cmds_mod.o \
tracer_mod.o \
julday_mod.o \
file_mod.o \
grid_mod.o \
time_mod.o \
logical_adj_mod.o \
directory_adj_mod.o \
bpch2_mod.o \
inquireMod.o \
regrid_1x1_mod.o \
regrid_a2a_mod.o \
pressure_mod.o \
transfer_mod.o \
future_emissions_mod.o \
lai_mod.o \
tracerid_mod.o \
benchmark_mod.o \
comode_mod.o \
diag_mod.o \
dao_mod.o \
gc_type_mod.o \
tropopause_mod.o \
gckpp_adj_Precision.o \
gckpp_adj_Parameters.o \
gckpp_adj_Global.o \
critical_load_mod.o \
htap_mod.o \
adj_arrays_mod.o \
gckpp_adj_Function.o \
gckpp_adj_Monitor.o \
gckpp_adj_Util.o \
gckpp_adj_HessianSP.o \
gckpp_adj_Hessian.o \
gckpp_adj_Initialize.o \
gckpp_adj_JacobianSP.o \
gckpp_adj_Jacobian.o \
gckpp_adj_LinearAlgebra.o \
gckpp_adj_Rates.o \
gckpp_adj_StoichiomSP.o \
gckpp_adj_Stoichiom.o \
gckpp_adj_Integrator.o \
gckpp_adj_Model.o \
checkpoint_mod.o \
pbl_mix_mod.o \
pbl_mix_adj_mod.o \
diag03_mod.o \
diag04_mod.o \
diag41_mod.o \
diag42_mod.o \
diag48_mod.o \
diag49_mod.o \
diag50_mod.o \
diag51_mod.o \
diag51b_mod.o \
diag51c_mod.o \
diag51d_mod.o \
diag56_mod.o \
diag59_mod.o \
diag_oh_mod.o \
diag_pl_mod.o \
ocean_mercury_mod.o \
drydep_mod.o \
scale_anthro_mod.o \
edgar_mod.o \
bravo_mod.o \
emep_mod.o \
nei2005_anthro_mod.o \
nei2008_anthro_mod.o \
epa_nei_mod.o \
streets_anthro_mod.o \
icoads_ship_mod.o \
arctas_ship_emiss_mod.o \
cac_anthro_mod.o \
vistas_anthro_mod.o \
geia_mod.o \
geosfp_read_mod.o \
global_oh_mod.o \
global_hno3_mod.o \
global_no3_mod.o \
global_nox_mod.o \
global_o1d_mod.o \
global_o3_mod.o \
hippo_mod.o \
atom_obs_mod.o \
uvalbedo_mod.o \
RnPbBe_mod.o \
Kr85_mod.o \
acetone_mod.o \
aerosol_mod.o \
aircraft_nox_mod.o \
retro_mod.o \
biofuel_mod.o \
gc_biomass_mod.o \
gfed2_biomass_mod.o \
gfed3_biomass_mod.o \
biomass_mod.o \
global_ch4_mod.o \
global_ch4_adj_mod.o \
c2h6_mod.o \
ch3i_mod.o \
a3_read_mod.o \
a6_read_mod.o \
i6_read_mod.o \
gcap_read_mod.o \
gwet_read_mod.o \
xtra_read_mod.o \
megan_mod.o \
rcp_mod.o \
carbon_mod.o \
carbon_adj_mod.o \
optdepth_mod.o \
planeflight_mod.o \
restart_mod.o \
checkpt_mod.o \
population_mod.o \
lightning_nox_mod.o \
rpmares_mod.o gosat_co2_mod.o tes_nh3_mod.o tes_o3_mod.o iasi_o3_obs_mod.o tes_o3_irk_mod.o \
rpmares_adj_mod.o \
isoropiaIIcode_adj.o \
isoropiaII_adj_mod.o \
wetscav_mod.o \
wetscav_adj_mod.o \
seasalt_mod.o \
sulfate_mod.o \
sulfate_adj_mod.o \
hcn_ch3cn_mod.o \
tagged_co_mod.o \
tagged_co_adj_mod.o \
tagged_ox_mod.o \
tagged_ox_adj_mod.o \
h2_hd_mod.o \
gcap_convect_mod.o \
fvdas_convect_mod.o \
convection_mod.o \
fvdas_convect_adj_mod.o \
convection_adj_mod.o \
pjc_pfix_mod.o \
pjc_pfix_geos5_window_mod.o \
pjc_pfix_geosfp_window_mod.o \
dust_dead_mod.o \
dust_mod.o \
dust_adj_mod.o \
co2_mod.o \
co2_adj_mod.o \
mercury_mod.o \
toms_mod.o \
tpcore_bc_mod.o \
tpcore_fvdas_mod.o \
tpcore_mod.o \
tpcore_window_mod.o \
tpcore_geos5_window_mod.o \
tpcore_geosfp_window_mod.o \
transport_mod.o \
linoz_mod.o \
linoz_adj_mod.o \
upbdflx_adj_mod.o \
upbdflx_mod.o \
strat_chem_mod.o \
strat_chem_adj_mod.o \
chemistry_mod.o \
chemistry_adj_mod.o \
paranox_mod.o \
paranox_adj_mod.o \
emissions_mod.o \
weak_constraint_mod.o \
emissions_adj_mod.o \
gamap_mod.o \
input_mod.o He4IncludeModule.o He4ErrorModule.o He4GridModule.o He4SwathModule.o findinv.o airsv5_mod.o airs_co_obs_mod.o HdfIncludeModule.o HdfSdModule.o HdfVdModule.o mls_o3_obs_mod.o mls_hno3_obs_mod.o omi_no2_obs_mod.o omi_so2_obs_mod.o omi_ch2o_obs_mod.o osiris_no2_obs_mod.o interp.o gaussj.o iasi_co_obs_mod.o mopitt_obs_mod.o \
improve_bc_mod.o \
geos_chem_mod.o \
ErrorModule.o \
sciabr_co_obs_mod.o \
tes_ch4_mod.o scia_ch4_mod.o \
mem_ch4_mod.o \
leo_ch4_mod.o \
geocape_ch4_mod.o \
osiris_obs_mod.o \
geos_chem_adj_mod.o \
inv_hessian_mod.o \
input_adj_mod.o \
inverse_mod.o \
inverse_driver.o

320
code/Objects.mkl Normal file
View File

@ -0,0 +1,320 @@
OBJSe = \
ifort_errmsg.o
OBJS = \
CO_strat_pl.o \
CO_strat_pl_adj.o \
airmas.o \
anthroems.o \
arsl1k.o \
adBuffer.o \
adStack.o \
backsub.o \
biofit.o \
blas.o \
boxvl.o \
calcrate.o \
calcrate_adj.o \
chemdr.o \
chemdr_adj.o \
cleanup.o \
cleanup_adj.o \
decomp.o \
diag1.o \
diag3.o \
diag_2pm.o \
diagoh.o \
emf_scale.o \
emfossil.o \
emisop.o \
emisop_grass.o \
emisop_mb.o \
emissdr.o \
emmonot.o \
fertadd.o \
findmon.o \
fcro2ho2.o \
fyrno3.o \
fyhoro.o \
gasconc.o \
get_global_ch4.o \
getifsun.o \
initialize.o \
jsparse.o \
ksparse.o \
linpack.o \
lump.o \
lump_adj.o \
ndxx_setup.o \
ohsave.o \
partition.o \
partition_adj.o \
pderiv.o \
physproc.o \
precipfrac.o \
pulsing.o \
rdisopt.o \
rdlai.o \
rdland.o \
rdlight.o \
rdmonot.o \
rdsoil.o \
readchem.o \
reader.o \
readlai.o \
routines.o \
ruralbox.o \
schem.o \
schem_adj.o \
setbase.o \
setemdep.o \
setemis.o \
setemis_adj.o \
setmodel.o \
sfcwindsqr.o \
smvgear.o \
soilbase.o \
soilcrf.o \
soilnoxems.o \
soiltemp.o \
soiltype.o \
subfun.o \
sunparam.o \
timer.o \
tcorr.o \
tropopause.o \
update.o \
xltmmp.o
FJ = \
BLKSLV.o \
CLDSRF.o \
EFOLD.o \
FLINT.o \
GAUSSP.o \
GEN.o \
JRATET.o \
JVALUE.o \
LEGND0.o \
MATIN4.o \
MIESCT.o \
NOABS.o \
OPMIE.o \
RD_TJPL.o \
SPHERE.o \
XSEC1D.o \
XSECO2.o \
XSECO3.o \
fast_j.o \
fjfunc.o \
rd_aod.o \
inphot.o \
jv_index.o \
mmran_16.o \
photoj.o \
rd_js.o \
rd_prof.o \
set_aer.o \
set_prof.o
MODS = \
fjx_acet_mod.o \
charpak_mod.o \
error_mod.o \
netcdf_util_mod.o \
m_do_err_out.o \
m_netcdf_io_checks.o \
m_netcdf_io_close.o \
m_netcdf_io_create.o \
m_netcdf_io_define.o \
m_netcdf_io_get_dimlen.o \
m_netcdf_io_handle_err.o \
m_netcdf_io_open.o \
m_netcdf_io_read.o \
m_netcdf_io_readattr.o \
m_netcdf_io_write.o \
logical_mod.o \
directory_mod.o \
unix_cmds_mod.o \
tracer_mod.o \
julday_mod.o \
file_mod.o \
grid_mod.o \
time_mod.o \
logical_adj_mod.o \
directory_adj_mod.o \
bpch2_mod.o \
inquireMod.o \
regrid_1x1_mod.o \
regrid_a2a_mod.o \
pressure_mod.o \
transfer_mod.o \
future_emissions_mod.o \
lai_mod.o \
tracerid_mod.o \
benchmark_mod.o \
comode_mod.o \
diag_mod.o \
dao_mod.o \
gc_type_mod.o \
tropopause_mod.o \
gckpp_adj_Precision.o \
gckpp_adj_Parameters.o \
gckpp_adj_Global.o \
critical_load_mod.o \
htap_mod.o \
adj_arrays_mod.o \
gckpp_adj_Function.o \
gckpp_adj_Monitor.o \
gckpp_adj_Util.o \
gckpp_adj_HessianSP.o \
gckpp_adj_Hessian.o \
gckpp_adj_Initialize.o \
gckpp_adj_JacobianSP.o \
gckpp_adj_Jacobian.o \
gckpp_adj_LinearAlgebra.o \
gckpp_adj_Rates.o \
gckpp_adj_StoichiomSP.o \
gckpp_adj_Stoichiom.o \
gckpp_adj_Integrator.o \
gckpp_adj_Model.o \
checkpoint_mod.o \
pbl_mix_mod.o \
pbl_mix_adj_mod.o \
diag03_mod.o \
diag04_mod.o \
diag41_mod.o \
diag42_mod.o \
diag48_mod.o \
diag49_mod.o \
diag50_mod.o \
diag51_mod.o \
diag51b_mod.o \
diag51c_mod.o \
diag51d_mod.o \
diag56_mod.o \
diag59_mod.o \
diag_oh_mod.o \
diag_pl_mod.o \
ocean_mercury_mod.o \
drydep_mod.o \
scale_anthro_mod.o \
edgar_mod.o \
bravo_mod.o \
emep_mod.o \
nei2005_anthro_mod.o \
nei2008_anthro_mod.o \
epa_nei_mod.o \
streets_anthro_mod.o \
icoads_ship_mod.o \
arctas_ship_emiss_mod.o \
cac_anthro_mod.o \
vistas_anthro_mod.o \
geia_mod.o \
geosfp_read_mod.o \
global_oh_mod.o \
global_hno3_mod.o \
global_no3_mod.o \
global_nox_mod.o \
global_o1d_mod.o \
global_o3_mod.o \
hippo_mod.o \
atom_obs_mod.o \
uvalbedo_mod.o \
RnPbBe_mod.o \
Kr85_mod.o \
acetone_mod.o \
aerosol_mod.o \
aircraft_nox_mod.o \
retro_mod.o \
biofuel_mod.o \
gc_biomass_mod.o \
gfed2_biomass_mod.o \
gfed3_biomass_mod.o \
biomass_mod.o \
global_ch4_mod.o \
global_ch4_adj_mod.o \
c2h6_mod.o \
ch3i_mod.o \
a3_read_mod.o \
a6_read_mod.o \
i6_read_mod.o \
gcap_read_mod.o \
gwet_read_mod.o \
xtra_read_mod.o \
megan_mod.o \
rcp_mod.o \
carbon_mod.o \
carbon_adj_mod.o \
optdepth_mod.o \
planeflight_mod.o \
restart_mod.o \
checkpt_mod.o \
population_mod.o \
lightning_nox_mod.o \
rpmares_mod.o \
rpmares_adj_mod.o \
isoropiaIIcode_adj.o \
isoropiaII_adj_mod.o \
wetscav_mod.o \
wetscav_adj_mod.o \
seasalt_mod.o \
sulfate_mod.o \
sulfate_adj_mod.o \
hcn_ch3cn_mod.o \
tagged_co_mod.o \
tagged_co_adj_mod.o \
tagged_ox_mod.o \
tagged_ox_adj_mod.o \
h2_hd_mod.o \
gcap_convect_mod.o \
fvdas_convect_mod.o \
convection_mod.o \
fvdas_convect_adj_mod.o \
convection_adj_mod.o \
pjc_pfix_mod.o \
pjc_pfix_geos5_window_mod.o \
pjc_pfix_geosfp_window_mod.o \
dust_dead_mod.o \
dust_mod.o \
dust_adj_mod.o \
co2_mod.o \
co2_adj_mod.o \
mercury_mod.o \
toms_mod.o \
tpcore_bc_mod.o \
tpcore_fvdas_mod.o \
tpcore_mod.o \
tpcore_window_mod.o \
tpcore_geos5_window_mod.o \
tpcore_geosfp_window_mod.o \
transport_mod.o \
linoz_mod.o \
linoz_adj_mod.o \
upbdflx_adj_mod.o \
upbdflx_mod.o \
strat_chem_mod.o \
strat_chem_adj_mod.o \
chemistry_mod.o \
chemistry_adj_mod.o \
paranox_mod.o \
paranox_adj_mod.o \
emissions_mod.o \
weak_constraint_mod.o \
emissions_adj_mod.o \
gamap_mod.o \
input_mod.o \
improve_bc_mod.o \
geos_chem_mod.o \
ErrorModule.o \
sciabr_co_obs_mod.o \
tes_ch4_mod.o \
mem_ch4_mod.o \
leo_ch4_mod.o \
geocape_ch4_mod.o \
osiris_obs_mod.o \
geos_chem_adj_mod.o \
inv_hessian_mod.o \
input_adj_mod.o \
inverse_mod.o \
inverse_driver.o

319
code/Objects.mkl~ Normal file
View File

@ -0,0 +1,319 @@
OBJSe = \
ifort_errmsg.o
OBJS = \
CO_strat_pl.o \
CO_strat_pl_adj.o \
airmas.o \
anthroems.o \
arsl1k.o \
adBuffer.o \
adStack.o \
backsub.o \
biofit.o \
blas.o \
boxvl.o \
calcrate.o \
calcrate_adj.o \
chemdr.o \
chemdr_adj.o \
cleanup.o \
cleanup_adj.o \
decomp.o \
diag1.o \
diag3.o \
diag_2pm.o \
diagoh.o \
emf_scale.o \
emfossil.o \
emisop.o \
emisop_grass.o \
emisop_mb.o \
emissdr.o \
emmonot.o \
fertadd.o \
findmon.o \
fcro2ho2.o \
fyrno3.o \
fyhoro.o \
gasconc.o \
get_global_ch4.o \
getifsun.o \
initialize.o \
jsparse.o \
ksparse.o \
linpack.o \
lump.o \
lump_adj.o \
ndxx_setup.o \
ohsave.o \
partition.o \
partition_adj.o \
pderiv.o \
physproc.o \
precipfrac.o \
pulsing.o \
rdisopt.o \
rdlai.o \
rdland.o \
rdlight.o \
rdmonot.o \
rdsoil.o \
readchem.o \
reader.o \
readlai.o \
routines.o \
ruralbox.o \
schem.o \
schem_adj.o \
setbase.o \
setemdep.o \
setemis.o \
setemis_adj.o \
setmodel.o \
sfcwindsqr.o \
smvgear.o \
soilbase.o \
soilcrf.o \
soilnoxems.o \
soiltemp.o \
soiltype.o \
subfun.o \
sunparam.o \
timer.o \
tcorr.o \
tropopause.o \
update.o \
xltmmp.o
FJ = \
BLKSLV.o \
CLDSRF.o \
EFOLD.o \
FLINT.o \
GAUSSP.o \
GEN.o \
JRATET.o \
JVALUE.o \
LEGND0.o \
MATIN4.o \
MIESCT.o \
NOABS.o \
OPMIE.o \
RD_TJPL.o \
SPHERE.o \
XSEC1D.o \
XSECO2.o \
XSECO3.o \
fast_j.o \
fjfunc.o \
rd_aod.o \
inphot.o \
jv_index.o \
mmran_16.o \
photoj.o \
rd_js.o \
rd_prof.o \
set_aer.o \
set_prof.o
MODS = \
fjx_acet_mod.o \
charpak_mod.o \
error_mod.o \
netcdf_util_mod.o \
m_do_err_out.o \
m_netcdf_io_checks.o \
m_netcdf_io_close.o \
m_netcdf_io_create.o \
m_netcdf_io_define.o \
m_netcdf_io_get_dimlen.o \
m_netcdf_io_handle_err.o \
m_netcdf_io_open.o \
m_netcdf_io_read.o \
m_netcdf_io_readattr.o \
m_netcdf_io_write.o \
logical_mod.o \
directory_mod.o \
unix_cmds_mod.o \
tracer_mod.o \
julday_mod.o \
file_mod.o \
grid_mod.o \
time_mod.o \
logical_adj_mod.o \
directory_adj_mod.o \
bpch2_mod.o \
inquireMod.o \
regrid_1x1_mod.o \
regrid_a2a_mod.o \
pressure_mod.o \
transfer_mod.o \
future_emissions_mod.o \
lai_mod.o \
tracerid_mod.o \
benchmark_mod.o \
comode_mod.o \
diag_mod.o \
dao_mod.o \
gc_type_mod.o \
tropopause_mod.o \
gckpp_adj_Precision.o \
gckpp_adj_Parameters.o \
gckpp_adj_Global.o \
critical_load_mod.o \
htap_mod.o \
adj_arrays_mod.o \
gckpp_adj_Function.o \
gckpp_adj_Monitor.o \
gckpp_adj_Util.o \
gckpp_adj_HessianSP.o \
gckpp_adj_Hessian.o \
gckpp_adj_Initialize.o \
gckpp_adj_JacobianSP.o \
gckpp_adj_Jacobian.o \
gckpp_adj_LinearAlgebra.o \
gckpp_adj_Rates.o \
gckpp_adj_StoichiomSP.o \
gckpp_adj_Stoichiom.o \
gckpp_adj_Integrator.o \
gckpp_adj_Model.o \
checkpoint_mod.o \
pbl_mix_mod.o \
pbl_mix_adj_mod.o \
diag03_mod.o \
diag04_mod.o \
diag41_mod.o \
diag42_mod.o \
diag48_mod.o \
diag49_mod.o \
diag50_mod.o \
diag51_mod.o \
diag51b_mod.o \
diag51c_mod.o \
diag51d_mod.o \
diag56_mod.o \
diag59_mod.o \
diag_oh_mod.o \
diag_pl_mod.o \
ocean_mercury_mod.o \
drydep_mod.o \
scale_anthro_mod.o \
edgar_mod.o \
bravo_mod.o \
emep_mod.o \
nei2005_anthro_mod.o \
nei2008_anthro_mod.o \
epa_nei_mod.o \
streets_anthro_mod.o \
icoads_ship_mod.o \
arctas_ship_emiss_mod.o \
cac_anthro_mod.o \
vistas_anthro_mod.o \
geia_mod.o \
geosfp_read_mod.o \
global_oh_mod.o \
global_hno3_mod.o \
global_no3_mod.o \
global_nox_mod.o \
global_o1d_mod.o \
global_o3_mod.o \
hippo_mod.o \
uvalbedo_mod.o \
RnPbBe_mod.o \
Kr85_mod.o \
acetone_mod.o \
aerosol_mod.o \
aircraft_nox_mod.o \
retro_mod.o \
biofuel_mod.o \
gc_biomass_mod.o \
gfed2_biomass_mod.o \
gfed3_biomass_mod.o \
biomass_mod.o \
global_ch4_mod.o \
global_ch4_adj_mod.o \
c2h6_mod.o \
ch3i_mod.o \
a3_read_mod.o \
a6_read_mod.o \
i6_read_mod.o \
gcap_read_mod.o \
gwet_read_mod.o \
xtra_read_mod.o \
megan_mod.o \
rcp_mod.o \
carbon_mod.o \
carbon_adj_mod.o \
optdepth_mod.o \
planeflight_mod.o \
restart_mod.o \
checkpt_mod.o \
population_mod.o \
lightning_nox_mod.o \
rpmares_mod.o \
rpmares_adj_mod.o \
isoropiaIIcode_adj.o \
isoropiaII_adj_mod.o \
wetscav_mod.o \
wetscav_adj_mod.o \
seasalt_mod.o \
sulfate_mod.o \
sulfate_adj_mod.o \
hcn_ch3cn_mod.o \
tagged_co_mod.o \
tagged_co_adj_mod.o \
tagged_ox_mod.o \
tagged_ox_adj_mod.o \
h2_hd_mod.o \
gcap_convect_mod.o \
fvdas_convect_mod.o \
convection_mod.o \
fvdas_convect_adj_mod.o \
convection_adj_mod.o \
pjc_pfix_mod.o \
pjc_pfix_geos5_window_mod.o \
pjc_pfix_geosfp_window_mod.o \
dust_dead_mod.o \
dust_mod.o \
dust_adj_mod.o \
co2_mod.o \
co2_adj_mod.o \
mercury_mod.o \
toms_mod.o \
tpcore_bc_mod.o \
tpcore_fvdas_mod.o \
tpcore_mod.o \
tpcore_window_mod.o \
tpcore_geos5_window_mod.o \
tpcore_geosfp_window_mod.o \
transport_mod.o \
linoz_mod.o \
linoz_adj_mod.o \
upbdflx_adj_mod.o \
upbdflx_mod.o \
strat_chem_mod.o \
strat_chem_adj_mod.o \
chemistry_mod.o \
chemistry_adj_mod.o \
paranox_mod.o \
paranox_adj_mod.o \
emissions_mod.o \
weak_constraint_mod.o \
emissions_adj_mod.o \
gamap_mod.o \
input_mod.o \
improve_bc_mod.o \
geos_chem_mod.o \
ErrorModule.o \
sciabr_co_obs_mod.o \
tes_ch4_mod.o \
mem_ch4_mod.o \
leo_ch4_mod.o \
geocape_ch4_mod.o \
osiris_obs_mod.o \
geos_chem_adj_mod.o \
inv_hessian_mod.o \
input_adj_mod.o \
inverse_mod.o \
inverse_driver.o

319
code/Objects.mk~ Normal file
View File

@ -0,0 +1,319 @@
OBJSe = \
ifort_errmsg.o
OBJS = \
CO_strat_pl.o \
CO_strat_pl_adj.o \
airmas.o \
anthroems.o \
arsl1k.o \
adBuffer.o \
adStack.o \
backsub.o \
biofit.o \
blas.o \
boxvl.o \
calcrate.o \
calcrate_adj.o \
chemdr.o \
chemdr_adj.o \
cleanup.o \
cleanup_adj.o \
decomp.o \
diag1.o \
diag3.o \
diag_2pm.o \
diagoh.o \
emf_scale.o \
emfossil.o \
emisop.o \
emisop_grass.o \
emisop_mb.o \
emissdr.o \
emmonot.o \
fertadd.o \
findmon.o \
fcro2ho2.o \
fyrno3.o \
fyhoro.o \
gasconc.o \
get_global_ch4.o \
getifsun.o gvchsq.o \
initialize.o \
jsparse.o \
ksparse.o \
linpack.o \
lump.o \
lump_adj.o \
ndxx_setup.o \
ohsave.o \
partition.o \
partition_adj.o \
pderiv.o \
physproc.o \
precipfrac.o \
pulsing.o \
rdisopt.o \
rdlai.o \
rdland.o \
rdlight.o \
rdmonot.o \
rdsoil.o \
readchem.o \
reader.o \
readlai.o \
routines.o \
ruralbox.o \
schem.o \
schem_adj.o \
setbase.o \
setemdep.o \
setemis.o \
setemis_adj.o \
setmodel.o \
sfcwindsqr.o \
smvgear.o \
soilbase.o \
soilcrf.o \
soilnoxems.o \
soiltemp.o \
soiltype.o \
subfun.o \
sunparam.o \
timer.o \
tcorr.o \
tropopause.o \
update.o \
xltmmp.o
FJ = \
BLKSLV.o \
CLDSRF.o \
EFOLD.o \
FLINT.o \
GAUSSP.o \
GEN.o \
JRATET.o \
JVALUE.o \
LEGND0.o \
MATIN4.o \
MIESCT.o \
NOABS.o \
OPMIE.o \
RD_TJPL.o \
SPHERE.o \
XSEC1D.o \
XSECO2.o \
XSECO3.o \
fast_j.o \
fjfunc.o \
rd_aod.o \
inphot.o \
jv_index.o \
mmran_16.o \
photoj.o \
rd_js.o \
rd_prof.o \
set_aer.o \
set_prof.o
MODS = \
fjx_acet_mod.o \
charpak_mod.o \
error_mod.o \
netcdf_util_mod.o \
m_do_err_out.o \
m_netcdf_io_checks.o \
m_netcdf_io_close.o \
m_netcdf_io_create.o \
m_netcdf_io_define.o \
m_netcdf_io_get_dimlen.o \
m_netcdf_io_handle_err.o \
m_netcdf_io_open.o \
m_netcdf_io_read.o \
m_netcdf_io_readattr.o \
m_netcdf_io_write.o \
logical_mod.o \
directory_mod.o \
unix_cmds_mod.o \
tracer_mod.o \
julday_mod.o \
file_mod.o \
grid_mod.o \
time_mod.o \
logical_adj_mod.o \
directory_adj_mod.o \
bpch2_mod.o \
inquireMod.o \
regrid_1x1_mod.o \
regrid_a2a_mod.o \
pressure_mod.o \
transfer_mod.o \
future_emissions_mod.o \
lai_mod.o \
tracerid_mod.o \
benchmark_mod.o \
comode_mod.o \
diag_mod.o \
dao_mod.o \
gc_type_mod.o \
tropopause_mod.o \
gckpp_adj_Precision.o \
gckpp_adj_Parameters.o \
gckpp_adj_Global.o \
critical_load_mod.o \
htap_mod.o \
adj_arrays_mod.o \
gckpp_adj_Function.o \
gckpp_adj_Monitor.o \
gckpp_adj_Util.o \
gckpp_adj_HessianSP.o \
gckpp_adj_Hessian.o \
gckpp_adj_Initialize.o \
gckpp_adj_JacobianSP.o \
gckpp_adj_Jacobian.o \
gckpp_adj_LinearAlgebra.o \
gckpp_adj_Rates.o \
gckpp_adj_StoichiomSP.o \
gckpp_adj_Stoichiom.o \
gckpp_adj_Integrator.o \
gckpp_adj_Model.o \
checkpoint_mod.o \
pbl_mix_mod.o \
pbl_mix_adj_mod.o \
diag03_mod.o \
diag04_mod.o \
diag41_mod.o \
diag42_mod.o \
diag48_mod.o \
diag49_mod.o \
diag50_mod.o \
diag51_mod.o \
diag51b_mod.o \
diag51c_mod.o \
diag51d_mod.o \
diag56_mod.o \
diag59_mod.o \
diag_oh_mod.o \
diag_pl_mod.o \
ocean_mercury_mod.o \
drydep_mod.o \
scale_anthro_mod.o \
edgar_mod.o \
bravo_mod.o \
emep_mod.o \
nei2005_anthro_mod.o \
nei2008_anthro_mod.o \
epa_nei_mod.o \
streets_anthro_mod.o \
icoads_ship_mod.o \
arctas_ship_emiss_mod.o \
cac_anthro_mod.o \
vistas_anthro_mod.o \
geia_mod.o \
geosfp_read_mod.o \
global_oh_mod.o \
global_hno3_mod.o \
global_no3_mod.o \
global_nox_mod.o \
global_o1d_mod.o \
global_o3_mod.o \
hippo_mod.o \
uvalbedo_mod.o \
RnPbBe_mod.o \
Kr85_mod.o \
acetone_mod.o \
aerosol_mod.o \
aircraft_nox_mod.o \
retro_mod.o \
biofuel_mod.o \
gc_biomass_mod.o \
gfed2_biomass_mod.o \
gfed3_biomass_mod.o \
biomass_mod.o \
global_ch4_mod.o \
global_ch4_adj_mod.o \
c2h6_mod.o \
ch3i_mod.o \
a3_read_mod.o \
a6_read_mod.o \
i6_read_mod.o \
gcap_read_mod.o \
gwet_read_mod.o \
xtra_read_mod.o \
megan_mod.o \
rcp_mod.o \
carbon_mod.o \
carbon_adj_mod.o \
optdepth_mod.o \
planeflight_mod.o \
restart_mod.o \
checkpt_mod.o \
population_mod.o \
lightning_nox_mod.o \
rpmares_mod.o gosat_co2_mod.o tes_nh3_mod.o tes_o3_mod.o iasi_o3_obs_mod.o tes_o3_irk_mod.o \
rpmares_adj_mod.o \
isoropiaIIcode_adj.o \
isoropiaII_adj_mod.o \
wetscav_mod.o \
wetscav_adj_mod.o \
seasalt_mod.o \
sulfate_mod.o \
sulfate_adj_mod.o \
hcn_ch3cn_mod.o \
tagged_co_mod.o \
tagged_co_adj_mod.o \
tagged_ox_mod.o \
tagged_ox_adj_mod.o \
h2_hd_mod.o \
gcap_convect_mod.o \
fvdas_convect_mod.o \
convection_mod.o \
fvdas_convect_adj_mod.o \
convection_adj_mod.o \
pjc_pfix_mod.o \
pjc_pfix_geos5_window_mod.o \
pjc_pfix_geosfp_window_mod.o \
dust_dead_mod.o \
dust_mod.o \
dust_adj_mod.o \
co2_mod.o \
co2_adj_mod.o \
mercury_mod.o \
toms_mod.o \
tpcore_bc_mod.o \
tpcore_fvdas_mod.o \
tpcore_mod.o \
tpcore_window_mod.o \
tpcore_geos5_window_mod.o \
tpcore_geosfp_window_mod.o \
transport_mod.o \
linoz_mod.o \
linoz_adj_mod.o \
upbdflx_adj_mod.o \
upbdflx_mod.o \
strat_chem_mod.o \
strat_chem_adj_mod.o \
chemistry_mod.o \
chemistry_adj_mod.o \
paranox_mod.o \
paranox_adj_mod.o \
emissions_mod.o \
weak_constraint_mod.o \
emissions_adj_mod.o \
gamap_mod.o \
input_mod.o He4IncludeModule.o He4ErrorModule.o He4GridModule.o He4SwathModule.o findinv.o airsv5_mod.o airs_co_obs_mod.o HdfIncludeModule.o HdfSdModule.o HdfVdModule.o mls_o3_obs_mod.o mls_hno3_obs_mod.o omi_no2_obs_mod.o omi_so2_obs_mod.o omi_ch2o_obs_mod.o osiris_no2_obs_mod.o interp.o gaussj.o iasi_co_obs_mod.o mopitt_obs_mod.o \
improve_bc_mod.o \
geos_chem_mod.o \
ErrorModule.o \
sciabr_co_obs_mod.o \
tes_ch4_mod.o scia_ch4_mod.o \
mem_ch4_mod.o \
leo_ch4_mod.o \
geocape_ch4_mod.o \
osiris_obs_mod.o \
geos_chem_adj_mod.o \
inv_hessian_mod.o \
input_adj_mod.o \
inverse_mod.o \
inverse_driver.o

184
code/RD_TJPL.f Normal file
View File

@ -0,0 +1,184 @@
C $Id: RD_TJPL.f,v 1.1 2009/06/09 21:51:51 daven Exp $
SUBROUTINE RD_TJPL(NJ1,NAMFIL)
C-----------------------------------------------------------------------
c Read in wavelength bins, solar fluxes, Rayleigh parameters, temperature-
c dependent cross sections and Rayleigh/aerosol scattering phase functions
c with temperature dependences. Current data originates from JPL'97
C-----------------------------------------------------------------------
c
c NAMFIL Name of spectral data file (jv_spec.dat)
c NJ1 Channel number for reading data file
c NJVAL Number of species to calculate J-values for
c NWWW Number of wavelength bins, from NW1:NW2
c WBIN Boundaries of wavelength bins
c WL Centres of wavelength bins - 'effective wavelength'
c FL Solar flux incident on top of atmosphere (cm-2.s-1)
c QRAYL Rayleigh parameters (effective cross-section) (cm2)
c QBC Black Carbon absorption extinct. (specific cross-sect.) (m2/g)
c QO2 O2 cross-sections
c QO3 O3 cross-sections
c Q1D O3 => O(1D) quantum yield
c TQQ Temperature for supplied cross sections
c QQQ Supplied cross sections in each wavelength bin (cm2)
c NAA Number of categories for scattering phase functions
c QAA Aerosol scattering phase functions
c NK Number of wavelengths at which functions supplied (set as 4)
c WAA Wavelengths for the NK supplied phase functions
c PAA Phase function: first 8 terms of expansion
c RAA Effective radius associated with aerosol type
c SSA Single scattering albedo
c
c npdep Number of pressure dependencies
c zpdep Pressure dependencies by wavelength bin
c jpdep Index of cross sections requiring pressure dependence
c lpdep Label for pressure dependence
c
c NOTES:
c (1 ) Updated to include new pressure-dependancy function for GLYX and MGLY.
c (tmf, 1/7/09)
c (2 ) Added a pressure-dependancy function selector 'pdepf'.
c (tmf, ccc, 1/7/09)
C-----------------------------------------------------------------------
IMPLICIT NONE
# include "cmn_fj.h"
# include "jv_cmn.h"
integer i, j, k, iw, nk, nqqq, nwww, nj1
character*7 lpdep(7)
character*11 NAMFIL
do J=1,NS
do K=1,3
TQQ(K,J) = 0.d0
enddo
enddo
C-------------spectral data---------------------------------------------
open(NJ1, FILE=NAMFIL)
read(NJ1,'(A)') TITLE0
write(6,'(1X,A)') TITLE0
read(NJ1,'(10X,14I5)') NJVAL,NWWW,NW1,NW2
if(NJVAL.gt.NS) then
write(6,300) NJVAL,NS
stop
endif
C------------NQQQ = no. additional J-values from X-sects (O2,O3P,O3D+NQQQ)
C- NQQQ is changed to NJVAL-1 because there are 2 dummy species at the end
C used for acetone pressure dependency only. (ccc, 4/20/09)
C- prior to 4/20/09
C NQQQ = NJVAL-3
NQQQ = NJVAL-1
read(NJ1,102) (WBIN(IW),IW=1,NWWW)
read(NJ1,102) (WBIN(IW+1),IW=1,NWWW)
read(NJ1,102) (WL(IW),IW=1,NWWW)
read(NJ1,102) (FL(IW),IW=1,NWWW)
read(NJ1,102) (QRAYL(IW),IW=1,NWWW)
read(NJ1,102) (QBC(IW),IW=1,NWWW) ! From Loiusse et al. [JGR, 1996]
c
C---Read O2 X-sects, O3 X-sects, O3=>O(1D) quant yields (each at 3 temps)
do K=1,3
read(NJ1,103) TITLEJ(K,1),TQQ(K,1), (QO2(IW,K),IW=1,NWWW)
enddo
do K=1,3
read(NJ1,103) TITLEJ(K,2),TQQ(K,2), (QO3(IW,K),IW=1,NWWW)
enddo
do K=1,3
read(NJ1,103) TITLEJ(K,3),TQQ(K,3), (Q1D(IW,K),IW=1,NWWW)
enddo
do K=1,3
write(6,200) titlej(1,k),(tqq(i,k),i=1,3)
enddo
c
C---Read remaining species: X-sections at 2 T's
do J=1,NQQQ
read(NJ1,103) TITLEJ(1,J+3),TQQ(1,J+3),(QQQ(IW,1,J),IW=1,NWWW)
read(NJ1,103) TITLEJ(2,J+3),TQQ(2,J+3),(QQQ(IW,2,J),IW=1,NWWW)
write(6,200) titlej(1,j+3),(tqq(i,j+3),i=1,2)
enddo
read(NJ1,'(A)') TITLE0
c
c---Pressure dependencies
read(NJ1,104) npdep
do k=1,npdep
read(NJ1,105) lpdep(k), pdepf(k), (zpdep(iw,k),iw=1,nwww)
write(6,201) lpdep(k), pdepf(k), (zpdep(iw,k),iw=1,nwww)
!--------------------------------------
! Special treatment for MGLY pressure dependency
! (tmf, 11/16/06)
!--------------------------------------
if ( pdepf(k) .eq. 4 ) then
! pass zpdep to mglypdep
mglypdep(:,1) = zpdep(:,k)
read(NJ1,105) lpdep(k), pdepf(k), (mglypdep(iw,2),iw=1,nwww)
read(NJ1,105) lpdep(k), pdepf(k), (mglypdep(iw,3),iw=1,nwww)
endif
enddo
read(NJ1,'(A)') TITLE0
c
c---Zero index arrays
do j=1,jppj
jind(j)=0
enddo
do j=1,NJVAL
jpdep(j)=0
enddo
c
C---Set mapping index
do j=1,NJVAL
do k=1,jppj
if (jlabel(k).eq.titlej(1,j)) jind(k)=j
enddo
do k=1,npdep
if (lpdep(k).eq.titlej(1,j)) jpdep(j)=k
enddo
enddo
do k=1,jppj
if(jfacta(k).eq.0.d0)
& write(6,*) 'Not using photolysis reaction ',k
if(jind(k).eq.0) then
if(jfacta(k).eq.0.d0) then
jind(k)=1
else
write(6,*) 'Which J-rate for photolysis reaction ',k,' ?'
stop
endif
endif
enddo
c
C---Read aerosol phase functions:
read(NJ1,'(A10,I5,/)') TITLE0,NAA
NK=4 ! Fix number of wavelengths at 4
do j=1,NAA
read(NJ1,110) TITLEA(j)
do k=1,NK
read(NJ1,*) WAA(k,j),QAA(k,j),RAA(k,j),SSA(k,j),
& (PAA(i,k,j),i=1,8)
enddo
enddo
c
write(6,*) 'Aerosol phase functions & wavelengths'
do J=1,NAA
write(6,'(1x,A8,I2,A,9F8.1)')
$ TITLEA(J),J,' wavel=',(WAA(K,J),K=1,NK)
write(6,'(9x,I2,A,9F8.4)') J,' Qext =',(QAA(K,J),K=1,NK)
enddo
C--------
C Modify reading and writing formats 105 & 201 for pressure dependancy
c (ccc, 1/7/09)
101 FORMAT(8E10.3)
102 FORMAT(10X,7E10.3)
103 FORMAT(A7,F3.0,7E10.3)
c 103 FORMAT(A7,F3.0,7E10.3/(10X,7E10.3))
104 FORMAT(13x,i2)
105 FORMAT(A7,2x,I1,7E10.3)
110 format(3x,a20)
200 format(1x,' x-sect:',a10,3(3x,f6.2))
201 format(1x,' pr.dep:',a10,1x,I1,7(1pE10.3))
300 format(' Number of x-sections supplied to Fast-J: ',i3,/,
& ' Maximum number allowed (NS) only set to: ',i3,
& ' - increase in jv_cmn.h')
close(NJ1)
return
end

390
code/REVISIONS Normal file
View File

@ -0,0 +1,390 @@
REVISIONS (v8-02-01)
6 May 2009
Bob Yantosca, Philippe Le Sager, and Claire Carouge
geos-chem-support@as.harvard.edu
New in v8-02-01:
=====================================================================
Revisions Logs for bug fixes put into v8-02-01
Claire
=====================================================================
REMOVED:
-------
NEW MODULES:
------------
NEW FUNCTION :
-------------
MODIFIED:
---------
emission_mod.f -- add choice for 0.5x0.667 grid for Streets emissions
emiss_streets_anthro_05x0666 -- Bug fix : Here we need to call
("streets_anthro_mod.f") READ_STREETS_05X0666 instead of
READ_STREETS
carbon_mod.f -- add LANTHRO switch to effectively turn off
anthropo. emissions when asked in input.geos
fertadd.f -- add LANTHRO switch to effectively turn off
anthropo. emissions when asked in input.geos
sulfate_mod.f -- add LANTHRO switch to effectively turn off
anthropo. emissions when asked in input.geos
geia_mod.f -- GET_IHOUR should use NINT and not INT (only used
in offline h2/hd and hcn/ch3cn simulations)
Makefile.sparc -- delete double declaration of some modules
introduced in v8-01-04.
Makefile.ifort -- added a lign for using the profiler
define.h -- force compile error if GCAP or GEOS3-4 used
along IN_CLOUD_OD
edgar_mod.f -- commented code to emit ship NOx as NOx.
We need to keep that so users can revert to
the old mechanism.
emep_mod.f -- commented code to emit ship NOx as NOx.
We need to keep that so users can revert to
the old mechanism.
emissions_mod.f -- fix to read Streets every month for CH4, CO, CO2,
and H2/HD simulations.
error_mod.f -- updated SAFE_DIV
gamap_mod.f -- minor fix for un-initialized variable (?)
input_mod.f -- couple of typo & default anthro emissions for
nested china at 0.5x0.666
ndxx_setup.f -- always allocate mass flux diagnostic arrays
streets_anthro_mod.f -- update NH3 and verbose
convection_mod.f -- add a check for negative values at the end of
the convection
========================================================================
Revisions Logs for updated chemistry with Fast-JX put into v8-02-01
(JMao)
========================================================================
REMOVED:
-------
NEW MODULES:
------------
fjx_acet_mod.f -- contains functions for the new temp-pressure
dependency for acetone photolysis
NEW FUNCTION :
-------------
MODIFIED:
---------
calcrate.f -- add calculation for 2 reactions
JRATET.f -- add new pres-temp dependency for each
acetone reaction (2 reactions now)
=====================================================================
Revisions Logs for HO2 reaction on aerosols put into v8-01-05
(Lyatt)
=====================================================================
REMOVED:
-------
NEW MODULES:
------------
NEW FUNCTION :
-------------
HO2 -- calculates GAMMA for HO2 self-reaction on aerosols
(in "calcrate.f")
MODIFIED:
---------
CMN_DIAG -- add PD52 and LD52
calcrate.f -- calculate GAMMA for HO2 self-reaction on aerosols
comode.h -- add NKHO2 to /CHEM4/
diag1.f -- change comment for ND52
diag3.f -- add output for ND52
diag_mod.f -- add definition for AD52
gamap_mod.f -- add ND52 definition
initialize.f -- add initialization ND52
input_mod.f -- change comment for ND52
ndxx_setup.f -- add ND52
readchem.f -- add HO2 as specie in 'K' rxn
=====================================================================
Revisions Logs for scaling CO put into v8-01-05
(Jenny)
=====================================================================
REMOVED:
-------
NEW MODULES:
------------
NEW FUNCTION :
-------------
MODIFIED:
---------
biomass_mod.f -- add biomass CO scaling
emfossil.f -- move lines for scaling CO for tagged_CO
add the 39% scaling if over the USA and
using ICARTT results
gc_biomass_mod.f -- remove biomass CO scaling
=====================================================================
Revisions Logs for saving CSPEC_FULL in a restart file into v8-01-05
(Daven & Havala)
=====================================================================
REMOVED:
-------
NEW MODULES:
------------
NEW FUNCTION :
-------------
make_cpsec_file -- creates GEOS-CHEM checkpt files of
(in "restart_mod.f") species concentrations.
READ_CSPEC_FILE -- initializes GEOS-CHEM species concentrations
(in "restart_mod.f") from a checkpoint file
MODIFIED:
---------
chemdr.f -- change call to GASCONC.
copy CSPEC to CSPEC_FULL if we want to create
a CSPEC_FULL restart file.
read CSPEC_FULL restart file.
gasconc.f -- add input argument READ_CSPEC.
change call to COPY_FULL_TROP.
input_mod.f -- read new switch in input.geos
logical_mod.f -- define new switch LSVCSPEC
main.f -- call make_cspec_file to create cspec_full restart
restart_mod.f -- add routines read_cspec_file and make_cspec_file
=====================================================================
Revisions Logs for GLYX chemistry put into v8-01-05
(May)
=====================================================================
REMOVED:
-------
NEW MODULES:
------------
NEW FUNCTION :
-------------
fyhoro.f -- returns the branching ratio between
HOC2H4O oxidation and dissociation:
read_aromatics -- read EDGARv2 aromatics emissions.
(in edgar_mod.f) Modified to read GEOS 1x1 emission files
read_c2h4 -- read EDGARv2 C2H4 emissions.
(in edgar_mod.f) Modified to read GEOS 1x1 emission files
read_c2h2 -- read EDGARv2 C2H2 emissions.
(in edgar_mod.f) Modified to read GEOS 1x1 emission files
read_aromatics_05x0666 -- read EDGARv2 aromatics emissions on
(in edgar_mod.f) 0.5x0.666 grid, cut too China region.
read_c2h4_05x0666 -- read EDGARv2 C2H4 emissions on
(in edgar_mod.f) 0.5x0.666 grid, cut too China region.
read_c2h2_05x0666 -- read EDGARv2 C2H2 emissions on
(in edgar_mod.f) 0.5x0.666 grid, cut too China region.
MODIFIED:
---------
CMN_DIAG -- increase size of some diagnostics
to save more tracers.
CMN_O3 -- Add emissions for BENZ, TOLU, XYLE, C2H2, C2H4.
CMN_SIZE -- change NNPAR, NEMPARA, NEMPARB.
Makefiles -- add fyhoro.f compilation.
RD_TJPL.f -- add pressure dependency selector.
add pressure dependency for MGLYX.
anthroems.f -- add emissions for aromatics, C2H2 and C2H4.
Add regridding emissions when not on 0.5x0.666
biofuel_mod.f -- add 9 species
biomass_mod.f -- add 9 species
bpch2_mod.f -- add file name in error messages
calcrate.f -- add new branching ratios
carbon_mod.f -- change LMEGAN to LMEGANMONO.
added SOA production from dicarbonyls.
cleanup ORVC_TERP and ORVC_SESQ.
cmn_fj.h -- Increase photolysis rxns JPMAX = 79.
comode.h -- Increase parameter values.
Add new variables.
comode_mod.f -- Add WTAREA and WERADIUS.
diag3.f -- Add AD07_SAOGM, J-values for GLYX and MGLY
in AD22.
diag42_mod.f -- Add diag for SOAG and SOAM.
diag48_mod.f -- archive O3, NO, NOy as tracers 89, 90, 91
diag49_mod.f -- archive O3, NO, NOy as tracers 89, 90, 91
diag50_mod.f -- archive O3, NO, NOy as tracers 89, 90, 91
diag51_mod.f -- archive O3, NO, NOy as tracers 89, 90, 91
diag_mod.f -- save out GLYX, MGLY in ND33, ND43, ND45, ND47.
save out GLYX production of SOAG in ND07
drydep_mod.f -- Added 15 more dry deposition species
dust_mod.f -- archive only hydrophilic aerosol/aqueous
dust surface area.
emf_scale.f -- change scaling weekend/weekdays
emissdr.f -- add LMEGANMONO switch
gamap_mod.f -- add gamap info for dicarbonyl simulation
(ND07 and ND28).
add C2H4 in ND46.
gc_biomass_mod.f -- add 9 biomass burning species
gfed2_biomass_mod.f -- add 9 biomass burning species.
!!!! Change the gfed emission factor file.
initialize.f -- add changes for AD07
input_mod.f -- add LMEGANMONO line reading
jv_cmn.h -- add pressure dependency variables
logical_mod.f -- add LMEGANMONO switch
ndxx_setup.f -- Add AD07_SOAGM
planeflight_mod.f -- Set very small values to zero.
Add new RO2 species according
to 'globchem.dat'.
readchem.f -- Add flags for some relations
smvgear.f -- Change error message
tracerid_mod.f -- Add all the new tracers.
!!! Warning to check because Philippe
added 2 new tracers in the mean time...
wetscav_mod.f -- Add wet scavenging of GLYX, MGLY, GLYC,
SOAG, SOAM.
=====================================================================
Revisions Logs for Acetone scale factors put into v8-01-05
(May)
=====================================================================
REMOVED:
-------
NEW MODULES:
------------
NEW FUNCTION :
-------------
MODIFIED:
---------
acetone_mod.f -- Add scale factors for new grids.

799
code/RnPbBe_mod.f Normal file
View File

@ -0,0 +1,799 @@
! $Id: RnPbBe_mod.f,v 1.1 2009/06/09 21:51:53 daven Exp $
MODULE RnPbBe_MOD
!
!******************************************************************************
! Module RnPbBe_MOD contains variables and routines used for the
! 222Rn-210Pb-7Be simulation. (hyl, swu, bmy, 6/14/01, 8/4/06)
!
! Module Variables:
! ============================================================================
! (1 ) LATSOU : Array holding 10 latitudes for 7Be emissions
! (2 ) PRESOU : Array holding 33 pressure levels for 7Be emissions
! (3 ) BESOU : Array holding 7Be emissions for 10 lat x 33 prs levs
! (4 ) XNUMOL_Rn : Atoms 222Rn per kg 222Rn
! (5 ) XNUMOL_Pb : Atoms 210Pb per kg 210Pb
! (6 ) XNUMOL_Be : Atoms 7Be per kg 7Be
!
! Module Procedures:
! ============================================================================
! (1 ) READ_7BE : Reads Lal & Peters 7Be emissions from a file
! (2 ) CORRECT_STE : Corrects S-T exchange for 210Pb and 7Be
! (3 ) EMISSRnPbBe : Adds emissions of Rn, 210Pb, 7Be, to tracer array
! (4 ) CHEMRnPbBe : Performs radioactive decay for Rn, 210Pb, 7Be
! (5 ) SLQ : Interpolation subroutine (cf. Numerical Recpies)
!
! GEOS-CHEM modules referenced by RnPbBe_mod.f
! ============================================================================
! (1 ) dao_mod.f : Module w/ arrays for DAO met fields
! (2 ) diag_mod.f : Module w/ GEOS-CHEM diagnostic arrays
! (3 ) directory_mod.f : Module w/ GEOS-CHEM data & met field dires
! (4 ) file_mod.f : Module w/ file unit numbers and error checks
! (5 ) logical_mod.f : Module w/ GEOS-CHEM logical switches
! (6 ) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc.
! (7 ) tropopause_mod.f : Module w/ routines to read in ann mean tropopause
!
! References:
! ============================================================================
! (1 ) Liu,H., D.Jacob, I.Bey, and R.M.Yantosca, Constraints from 210Pb
! and 7Be on wet deposition and transport in a global three-dimensional
! chemical tracer model driven by assimilated meteorological fields,
! JGR, 106, D11, 12,109-12,128, 2001.
! (2 ) Jacob et al.,Evaluation and intercomparison of global atmospheric
! transport models using Rn-222 and other short-lived tracers,
! JGR, 1997 (102):5953-5970
! (3 ) Dorothy Koch, JGR 101, D13, 18651, 1996.
! (4 ) Lal, D., and B. Peters, Cosmic ray produced radioactivity on the
! Earth. Handbuch der Physik, 46/2, 551-612, edited by K. Sitte,
! Springer-Verlag, New York, 1967.
!
! NOTES:
! (1 ) Added existing routines to this module (bmy, 6/14/01)
! (2 ) Updated comments (bmy, 9/4/01)
! (3 ) Eliminate AVGF; redimensioned XTRA2 (bmy, 9/25/01)
! (4 ) Replace references to PW(I,J) with P(I,J) (bmy, 10/3/01)
! (5 ) Remove obsolete code from 9/01 and 10/01 (bmy, 10/23/01)
! (6 ) Removed duplicate variable declarations (bmy, 11/15/01)
! (7 ) Now read files from DATA_DIR/RnPbBe_200203/ directory.
! Also updated comments. (bmy, 3/29/02)
! (8 ) Incorporated latest changes from Hongyu Liu. Also split off the
! code to read in the 7Be emissions into a separate routine.
! Add parallel DO-loops in several places. Cleaned up DRYFLXRnPbBe,
! and now make sure ND44 accurately represents the drydep fluxes
! of 210Pb and 7Be. (hyl, bmy, 8/7/02)
! (9 ) Now reference AD from "dao_mod.f". Now references "error_mod.f".
! Moved routine DRYFLXRnPbBe into "drydep_mod.f". (bmy, 1/27/03)
! (10) Now references the new "time_mod.f" (bmy, 2/11/03)
! (11) Bug fix in EMISSRnPbBe -- take abs( lat) for 7Be emiss. (bmy, 6/10/03)
! (12) Bug fix in EMISSRnPbBe -- shut off 222Rn emissions in polar regions
! (swu, bmy, 10/28/03)
! (13) Now references "directory_mod.f", "logical_mod.f", and "tracer_mod.f"
! (bmy, 7/20/04)
! (14) Now modified for GCAP and GEOS-5 met fields (swu, bmy, 5/24/05)
! (15) Now references "tropopause_mod.f"
! (16) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06)
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE PRIVATE DECLARATIONS -- keep certain internal variables
! and routines from being seen outside "RnPbBe_mod.f"
!=================================================================
! Make everything PRIVATE ...
PRIVATE
! ... except these routines
PUBLIC :: EMISSRnPbBe
PUBLIC :: CHEMRnPbBe
!=================================================================
! MODULE VARIABLES
!=================================================================
REAL*8 :: LATSOU(10), PRESOU(33), BESOU(10,33)
REAL*8, PARAMETER :: XNUMOL_Rn = ( 6.0225d23 / 222.0d-3 )
REAL*8, PARAMETER :: XNUMOL_Pb = ( 6.0225d23 / 210.0d-3 )
REAL*8, PARAMETER :: XNUMOL_Be = ( 6.0225d23 / 7.0d-3 )
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
SUBROUTINE READ_7BE
!
!******************************************************************************
! Subroutine READ_7BE reads the 7Be emissions from Lal & Peters on 33
! pressure levels. This only needs to be done on the very first timestep.
! (hyl, bmy, 8/7/02, 7/19/04)
!
! NOTES:
! (1 ) This code was split off from routine EMISSRnPbBe below. (bmy, 8/7/02)
! (2 ) Now reference DATA_DIR from "directory_mod.f" (bmy, 7/19/04)
!******************************************************************************
!
! References to F90 modules
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE FILE_MOD, ONLY : IU_FILE, IOERROR
# include "CMN_SIZE" ! Size parameters
! Local variables
INTEGER :: IOS, J, L
CHARACTER(LEN=255) :: FILENAME
!==============================================================
! READ_7BE begins here!
!
! Units of 7Be emissions are [stars/g air/s].
! Here, "stars" = # of nuclear disintegrations of cosmic rays
!==============================================================
! Define the file name
FILENAME = TRIM( DATA_DIR ) // 'RnPbBe_200203/7Be.Lal'
! Open the 7Be file
OPEN( IU_FILE, FILE=TRIM( FILENAME ),
& STATUS='OLD', IOSTAT=IOS )
! Error check
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'emissRnPbBe:1' )
! Read latitudes in southern hemisphere
READ ( IU_FILE, '(13X,F5.0,7F8.0)', IOSTAT=IOS )
& ( LATSOU(J), J=1,8 )
! Error check
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'emissRnPbBe:2' )
! Add latitudes for 80S and 90S
LATSOU(9) = 80d0
LATSOU(10) = 90d0
! For 33 levels read the pressure and the Be concentration
! at each of the above-defined southern latitudes
DO L = 1, 33
READ( IU_FILE, '(F5.0,8X,8F8.2)', IOSTAT=IOS )
& PRESOU(L), ( BESOU(J,L), J=1,8 )
! Error check
IF ( IOS /= 0 ) THEN
CALL IOERROR( IOS, IU_FILE, 'emissRnPbBe:3' )
ENDIF
ENDDO
! Overwrite 70S at the top (as recommended by Koch 1996)
BESOU(8,1) = 1900d0
! Copy value from 70S into 80S and 90S at all levels
DO L = 1, 33
BESOU(9,L) = BESOU(8,L)
BESOU(10,L) = BESOU(8,L)
ENDDO
! All the numbers in the file need to be multiplied by 1e-5
! in order to put them into the correct data range.
BESOU = BESOU * 1d-5
! Close the file
CLOSE( IU_FILE )
! Return to calling program
END SUBROUTINE READ_7BE
!------------------------------------------------------------------------------
SUBROUTINE CORRECT_STE( EMISSION )
!
!******************************************************************************
! Subroutine CORRECT_STE reduces the emission of 210Pb and/or 7Be in the
! stratosphere, to correct for too fast STE in the GEOS-CHEM model.
! (hyl, bmy, 8/7/02, 8/4/06)
!
! Arguments as Input/Output:
! ============================================================================
! (1 ) EMISSION (REAL*8) : Emissions to be corrected [kg]
!
! NOTES:
! (1 ) Now updated for GCAP met fields (swu, bmy, 5/24/05)
! (2 ) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06)
!******************************************************************************
!
# include "define.h" ! Switches
! Arguments
REAL*8, INTENT(INOUT) :: EMISSION
!=================================================================
! CORRECT_STE begins here!
!
! Correction factors were computed by Hongyu Liu (hyl, 8/6/02)
!=================================================================
#if defined( GEOS_3 )
EMISSION = EMISSION / 3.5d0
#elif defined( GEOS_4 )
!EMISSION = 0d0 ! to be determined later
#elif defined( GEOS_5 )
!EMISSION = 0d0 ! to be determined later
#elif defined( GCAP )
EMISSION = EMISSION / 3.5d0
#endif
! Return to calling program
END SUBROUTINE CORRECT_STE
!------------------------------------------------------------------------------
SUBROUTINE EMISSRnPbBe
!
!******************************************************************************
! Subroutine EMISSRnPbBe emits 222Rn and 7Be into the tracer array STT.
! (hyl, bey, bmy, 5/28/99, 10/28/03)
!
! NOTES:
! (1 ) Also added Hongyu's code for emission of Be7 (bmy, 3/22/99)
! (2 ) Now trap I/O errors with subroutine IOERROR (bmy, 5/28/99)
! (3 ) Eliminate obsolete code and ND63 diagnostic (bmy, 4/12/00)
! (4 ) Now reference TS from "dao_mod.f" instead of from common block
! header file "CMN_TS". (bmy, 6/23/00)
! (5 ) Cosmetic changes (bmy, 7/12/00)
! (6 ) Now use IOS /= 0 criterion to trap both I/O errors and EOF
! condition. (bmy, 9/13/00)
! (7 ) Added to module "RnPbBe_mod.f". Also updated comments and made
! cosmetic changes. (bmy, 6/14/01)
! (8 ) Replace PW(I,J) with P(I,J) (bmy, 10/3/01)
! (9 ) Now reference DATA_DIR from "CMN_SETUP". Added FILENAME variable.
! Now read "7Be.Lal" file from DATA_DIR/RnPbBe_200203/ directory.
! (bmy, 3/29/02)
! (10) Add diagnostics for Rn/Be emissions. Also cleaned up some old code
! and added parallel DO-loops. Correct for S-T exchange for 7Be
! emissions. Updated comments, cosmetic changes. (hyl, 8/6/02)
! (11) Now reference routine GET_PCENTER from "pressure_mod.f", which
! returns the correct "floating" pressure. (dsa, bdf, bmy, 8/20/02)
! (12) Now reference AD from "dao_mod.f". Now make FIRSTEMISS a local SAVEd
! variable instead of an argument. (bmy, 1/27/03)
! (13) Now use routine GET_YMID from "grid_mod.f" instead of common block
! variable YLMID. Now replace DXYP(JREF)*1d4 with routine GET_AREA_CM2
! of "grid_mod.f". Now use routine GET_TS_EMIS from time_mod.
! (bmy, 2/11/03)
! (14) Bug fix: take the absolute value of latitude -- this was a bug when
! implementing the GET_YMID function from v5-04. (bmy, 6/10/03)
! (15) Now reference GET_YEDGE from "grid_mod.f".
! (16) Bug fix: the Rn emission in antarctic area in the original code would
! lead to enormously hight Rn concentrations there, esp. after boundary
! layer mixing. Now apply different emissions over land and water,
! and also shut off emissions poleward of 70 deg. (swu, bmy, 10/28/03)
! (17) Now reference LEMIS from "logical_mod.f". Now reference STT and
! N_TRACERS from "tracer_mod.f" (bmy, 7/20/04)
! (18) Remove reference to CMN; it's obsolete. Now use inquiry functions
! from "tropopause_mod.f" to diagnose strat boxes. (bmy, 8/15/05)
!******************************************************************************
!
! References to F90 modules
USE DAO_MOD, ONLY : AD, TS
USE DIAG_MOD, ONLY : AD01
USE GRID_MOD, ONLY : GET_AREA_CM2, GET_YMID, GET_YEDGE
USE LOGICAL_MOD, ONLY : LEMIS
USE TIME_MOD, ONLY : GET_TS_EMIS
USE TRACER_MOD, ONLY : STT, N_TRACERS
USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT
USE PRESSURE_MOD, ONLY : GET_PCENTER
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! ND02
# include "CMN_DEP" ! FRCLND
! Local variables
LOGICAL, SAVE :: FIRSTEMISS = .TRUE.
INTEGER :: I, J, L, N
REAL*8 :: A_CM2, ADD_Be, ADD_Rn, Rn_LAND
REAL*8 :: Rn_WATER, DTSRCE, LAT_TMP, P_TMP
REAL*8 :: Be_TMP, Rn_TMP, LAT_S, LAT_N
REAL*8 :: LAT_H, LAT_L, F_LAND, F_WATER
REAL*8 :: F_BELOW_70, F_BELOW_60, F_ABOVE_60
!=================================================================
! EMISSRnPbBe begins here!
!=================================================================
! Return if we are not doing emissions!
IF ( .not. LEMIS ) RETURN
! Emission timestep [s]
DTSRCE = GET_TS_EMIS() * 60d0
!=================================================================
! Add 222Rn emissions into tracer #1 according to the following:
!
! (1) 222Rn emission poleward of 70 degrees = 0.0 [atoms/cm2/s]
!
! (2) For latitudes 70S-60S and 60N-70N (both land & ocean),
! 222Rn emission is 0.005 [atoms/cm2/s]
!
! (3) For latitudes between 60S and 60N,
! 222Rn emission is 1 [atoms/cm2/s] over land or
! 0.005 [atoms/cm2/s] over oceans
!
! (4) For grid boxes where the surface temperature is below
! 0 deg Celsius, reduce 222Rn emissions by a factor of 3.
!
! Reference: Jacob et al.,Evaluation and intercomparison of
! global atmospheric transport models using Rn-222 and other
! short-lived tracers, JGR, 1997 (102):5953-5970
!=================================================================
! Loop over latitudes
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, LAT_S, LAT_N, LAT_H, LAT_L, F_BELOW_70 )
!$OMP+PRIVATE( F_BELOW_60, F_ABOVE_60, A_CM2, Rn_LAND, Rn_WATER )
!$OMP+PRIVATE( F_LAND, F_WATER, ADD_Rn )
DO J = 1, JJPAR
! Get ABS( latitude ) at S and N edges of grid box
LAT_S = ABS( GET_YEDGE(J) )
LAT_N = ABS( GET_YEDGE(J+1) )
LAT_H = MAX( LAT_S, LAT_N )
LAT_L = MIN( LAT_S, LAT_N )
! Fraction of grid box w/ ABS( latitude ) less than 70 degrees
F_BELOW_70 = ( 70.0d0 - LAT_L ) / ( LAT_H - LAT_L )
! Fraction of grid box w/ ABS( latitude ) less than 60 degrees
F_BELOW_60 = ( 60.0d0 - LAT_L ) / ( LAT_H - LAT_L )
! Fraction of grid box w/ ABS( latitude ) greater than 60 degrees
F_ABOVE_60 = 1d0 - F_BELOW_60
! Grid box surface area [cm2]
A_CM2 = GET_AREA_CM2( J )
! Baseline 222Rn emissions over land [kg]
! Rn_LAND [kg] = [1 atom 222Rn/cm2/s] / [atoms/kg] * [s] * [cm2]
Rn_LAND = 1d0 / XNUMOL_Rn * DTSRCE * A_CM2
! Baseline 222Rn emissions over water or ice [kg]
Rn_WATER = Rn_LAND * 0.005d0
! Loop over longitudes
DO I = 1, IIPAR
! Fraction of grid box that is land
F_LAND = FRCLND(I,J)
! Fraction of grid box that is water
F_WATER = 1d0 - F_LAND
!--------------------
! 90S-70S or 70N-90N
!--------------------
IF ( LAT_L >= 70d0 ) THEN
! 222Rn emissions are shut off poleward of 70 degrees
ADD_Rn = 0.0d0
!--------------------
! 70S-60S or 60N-70N
!--------------------
ELSE IF ( LAT_L >= 60d0 ) THEN
IF ( LAT_H <= 70d0 ) THEN
! If the entire grid box lies equatorward of 70 deg,
! then 222Rn emissions here are 0.005 [atoms/cm2/s]
ADD_Rn = Rn_WATER
ELSE
! If the grid box straddles the 70S or 70N latitude line,
! then only count 222Rn emissions equatorward of 70 degrees.
! 222Rn emissions here are 0.005 [atoms/cm2/s].
ADD_Rn = F_BELOW_70 * Rn_WATER
ENDIF
ELSE
!--------------------
! 70S-60S or 60N-70N
!--------------------
IF ( LAT_H > 60d0 ) THEN
ADD_Rn =
! Consider 222Rn emissions equatorward of
! 60 degrees for both land (1.0 [atoms/cm2/s])
! and water (0.005 [atoms/cm2/s])
& F_BELOW_60 *
& ( Rn_LAND * F_LAND ) +
& ( Rn_WATER * F_WATER ) +
! If the grid box straddles the 60 degree boundary
! then also consider the emissions poleward of 60
! degrees. 222Rn emissions here are 0.005 [at/cm2/s].
& F_ABOVE_60 * Rn_WATER
!--------------------
! 60S-60N
!--------------------
ELSE
! Consider 222Rn emissions equatorward of 60 deg for
! land (1.0 [atoms/cm2/s]) and water (0.005 [atoms/cm2/s])
ADD_Rn = ( Rn_LAND * F_LAND ) + ( Rn_WATER * F_WATER )
ENDIF
ENDIF
! For boxes below freezing, reduce 222Rn emissions by 3x
IF ( TS(I,J) < 273.15 ) ADD_Rn = ADD_Rn / 3d0
! Save 222Rn into STT array [kg]
STT(I,J,1,1) = STT(I,J,1,1) + ADD_Rn
! ND01 diag: 222Rn emission [kg/s]
IF ( ND01 > 0 ) THEN
AD01(I,J,1,1) = AD01(I,J,1,1) + ( ADD_Rn / DTSRCE )
ENDIF
ENDDO
ENDDO
!$OMP END PARALLEL DO
!=================================================================
! Add 7Be emissions into tracer #3 (if necessary)
!
! Original units of 7Be emissions are [stars/g air/sec],
! where "stars" = # of nuclear disintegrations of cosmic rays
!=================================================================
IF ( N_TRACERS >= 3 ) THEN
! Read 7Be emissions on the first timestep only
IF ( FIRSTEMISS ) CALL READ_7BE
!==============================================================
! Now interpolate from 33 std levels onto GEOS-CHEM levels
!==============================================================
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, LAT_TMP, P_TMP, Be_TMP, ADD_Be )
!$OMP+SCHEDULE( DYNAMIC )
DO L = 1, LLPAR
DO J = 1, JJPAR
DO I = 1, IIPAR
! Get absolute value of latitude, since we will assume that
! the 7Be distribution is symmetric about the equator
LAT_TMP = ABS( GET_YMID( J ) )
! Pressure at (I,J,L) -- need to change for fvDAS!
P_TMP = GET_PCENTER( I, J, L )
! Interpolate 7Be [stars/g air/sec] to GEOS-CHEM levels
CALL SLQ( LATSOU,PRESOU,BESOU,10,33,LAT_TMP,P_TMP,Be_TMP)
! Be_TMP = [stars/g air/s] * [0.045 atom/star] *
! [kg air] * [1e3 g/kg] = 7Be emissions [atoms/s]
Be_TMP = Be_TMP * 0.045d0 * AD(I,J,L) * 1.d3
! ADD_Be = [atoms/s] * [s] / [atom/kg] = 7Be emissions [kg]
ADD_Be = Be_TMP * DTSRCE / XNUMOL_Be
! Correct the strat-trop exchange of 7Be
IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN
CALL CORRECT_STE( ADD_Be )
ENDIF
! Add 7Be into STT tracer array [kg]
STT(I,J,L,3) = STT(I,J,L,3) + ADD_Be
! ND01 diag: 7Be emission [kg/s]
IF ( ND01 > 0 ) THEN
AD01(I,J,L,3) = AD01(I,J,L,3) + ( ADD_Be / DTSRCE )
ENDIF
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
ENDIF
! Reset FIRSTEMISS
FIRSTEMISS = .FALSE.
! Return to calling program
END SUBROUTINE EMISSRnPbBe
!------------------------------------------------------------------------------
SUBROUTINE CHEMRnPbBe
!
!******************************************************************************
! Subroutine CHEMRnPbBe performs loss chemistry on 222Rn, 210Pb, and 7Be.
! (hyl, amf, bey, bmy, 10/13/99, 8/15/05)
!
! NOTES:
! (1 ) Now use F90 syntax (bmy, hyl, 3/22/99)
! (2 ) Add FIRSTCHEM as an argument. Only compute the exponential terms
! when FIRSTCHEM = .TRUE., and save the values for later use
! (bmy, 3/24/99)
! (3 ) Cosmetic changes (bmy, 10/13/99)
! (4 ) Eliminate obsolete code and ND63 diagnostic (bmy, 4/12/00)
! (5 ) Cosmetic changes (bmy, 7/12/00)
! (6 ) Added to module "RnPbBe_mod.f". Also updated comments
! and made cosmetic changes. (bmy, 6/14/01)
! (7 ) Add diagnostics for Rn/Be emissions. Also cleaned up some old code
! and added parallel DO-loops. Updated comments. (hyl, 8/6/02)
! (8 ) Now make FIRSTCHEM a local SAVEd variable. (bmy, 1/27/03)
! (9 ) Now use function GET_TS_CHEM from "time_mod.f" (bmy, 2/11/03)
! (10) Now references STT and N_TRACERS from "tracer_mod.f" (bmy, 7/20/04)
! (11) Remove reference to CMN; it's obsolete. Now use inquiry functions
! from "tropopause_mod.f" to diagnose strat boxes. (bmy, 8/15/05)
!******************************************************************************
!
! References to F90 modules
USE DIAG_MOD, ONLY : AD01, AD02
USE TIME_MOD, ONLY : GET_TS_CHEM
USE TRACER_MOD, ONLY : STT, N_TRACERS
USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! ND01, ND02
! Local variables
LOGICAL, SAVE :: FIRSTCHEM = .TRUE.
INTEGER :: I, J, L, N
REAL*8 :: ADD_Pb, Be_LOST ,DTCHEM, Pb_LOST
REAL*8 :: Rn_LOST(IIPAR,JJPAR,LLPAR)
! Static variables
REAL*8, SAVE :: EXP_Rn, EXP_Pb, EXP_Be
! Ratio of molecular weights of 210Pb/222Rn
REAL*8, PARAMETER :: Pb_Rn_RATIO = 210d0 / 222d0
!=================================================================
! CHEMRnPbBe begins here!
!=================================================================
! Chemistry timestep [s]
DTCHEM = GET_TS_CHEM() * 60d0
! Pre-compute exponential terms only on first timestep
IF ( FIRSTCHEM ) THEN
! Fraction of (222Rn, 210Pb, 7Be) left after radioactive decay
EXP_Rn = EXP( -DTCHEM * 2.097d-6 )
EXP_Pb = EXP( -DTCHEM * 9.725d-10 )
EXP_Be = EXP( -DTCHEM * 1.506d-7 )
! Reset FIRSTCHEM flag
FIRSTCHEM = .FALSE.
ENDIF
!=================================================================
! Radioactive decay of 222Rn (tracer #1)
!=================================================================
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L )
DO L = 1, LLPAR
DO J = 1, JJPAR
DO I = 1, IIPAR
! Rn_LOST = amount of 222Rn lost to decay [kg]
Rn_LOST(I,J,L) = STT(I,J,L,1) * ( 1d0 - EXP_Rn )
! ND02 diag: 222Rn lost to decay [kg/s]
IF ( ND02 > 0 ) THEN
AD02(I,J,L,1) = AD02(I,J,L,1) + ( Rn_LOST(I,J,L) / DTCHEM )
ENDIF
! Subtract Rn_LOST from STT [kg]
STT(I,J,L,1) = STT(I,J,L,1) - Rn_LOST(I,J,L)
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
!=================================================================
! Radioactive decay of 210Pb (tracer #2)
!=================================================================
IF ( N_TRACERS >= 2 ) THEN
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, ADD_Pb, Pb_LOST )
DO L = 1, LLPAR
DO J = 1, JJPAR
DO I = 1, IIPAR
! ADD_Pb = Amount of 210Pb gained by decay from 222Rn [kg]
ADD_Pb = Rn_LOST(I,J,L) * Pb_Rn_RATIO
! Correct strat-trop exchange of 210Pb in stratosphere
IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN
CALL CORRECT_STE( ADD_Pb )
ENDIF
! ND01 diag: 210Pb emission from 222Rn decay [kg/s]
IF ( ND01 > 0 ) THEN
AD01(I,J,L,2) = AD01(I,J,L,2) + ( ADD_Pb / DTCHEM )
ENDIF
! Add 210Pb gained by decay from 222Rn into STT [kg]
STT(I,J,L,2) = STT(I,J,L,2) + ADD_Pb
! Amount of 210Pb lost to radioactive decay [kg]
! NOTE: we've already added in the 210Pb gained from 222Rn
Pb_LOST = STT(I,J,L,2) * ( 1d0 - EXP_Pb )
! ND02 diag: 210Pb lost to decay [kg/s]
IF ( ND02 > 0 ) THEN
AD02(I,J,L,2) = AD02(I,J,L,2) + ( Pb_LOST / DTCHEM )
ENDIF
! Subtract 210Pb lost to decay from STT [kg]
STT(I,J,L,2) = STT(I,J,L,2) - Pb_LOST
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
ENDIF
!=================================================================
! Radioactive decay of 7Be (tracer #3)
!=================================================================
IF ( N_TRACERS >= 3 ) THEN
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, Be_LOST )
DO L = 1, LLPAR
DO J = 1, JJPAR
DO I = 1, IIPAR
! Amount of 7Be lost to decay [kg]
Be_LOST = STT(I,J,L,3) * ( 1d0 - EXP_Be )
! ND02 diag: 7Be lost to decay [kg/s]
IF ( ND02 > 0 ) THEN
AD02(I,J,L,3) = AD02(I,J,L,3) + ( Be_LOST / DTCHEM )
ENDIF
! Subtract amount of 7Be lost to decay from STT [kg]
STT(I,J,L,3) = STT(I,J,L,3) - Be_LOST
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
ENDIF
! Return to calling program
END SUBROUTINE CHEMRnPbBe
!------------------------------------------------------------------------------
SUBROUTINE SLQ( X, Y, Z, N, M, U, V, W )
!
!******************************************************************************
! Subroutine SLQ is an interpolation subroutine from a Chinese
! reference book (says Hongyu). (hyl, bmy, 3/17/98, 11/15/01)
!
! Arguments as Input:
! ============================================================================
! (1 ) X (REAL*8) : X-axis coordinate on original grid
! (2 ) Y (REAL*8) : Y-axis coordinate on original grid
! (3 ) Z (REAL*8) : Array of data on original grid
! (4 ) N (REAL*8) : First dimension of Z
! (5 ) M (REAL*8) : Second dimension of Z
! (6 ) U (REAL*8) : X-axis coordinate for desired interpolated value
! (7 ) V (REAL*8) : Y-axis coordinate for desired interpolated value
!
! Arguments as Output:
! ============================================================================
! (8 ) W (REAL*8) : Interpolated value of Z array, at coordinates (U,V)
!
! NOTES:
! (1 ) Added to "RnPbBe_mod.f" (bmy, 7/16/01)
! (2 ) Removed duplicate definition of IQ. Added comments. (bmy, 11/15/01)
!******************************************************************************
!
! Arguments
INTEGER :: N, M
REAL*8 :: X, Y, Z, U, V, W, B, HH
DIMENSION :: X(N), Y(M), Z(N,M), B(3)
! Local variables
INTEGER NN, IP, I, J, L, IQ, K, MM
!=================================================================
! SLQ begins here!
!=================================================================
NN=3
IF(N.LE.3) THEN
IP=1
NN=N
ELSE IF (U.LE.X(2)) THEN
IP=1
ELSE IF (U.GE.X(N-1)) THEN
IP=N-2
ELSE
I=1
J=N
10 IF (IABS(I-J).NE.1) THEN
L=(I+J)/2
IF (U.LT.X(L)) THEN
J=L
ELSE
I=L
END IF
GOTO 10
END IF
IF (ABS(U-X(I)).LT.ABS(U-X(J))) THEN
IP=I-1
ELSE
IP=I
END IF
END IF
MM=3
IF (M.LE.3) THEN
IQ=1
MM=N
ELSE IF (V.LE.Y(2)) THEN
IQ=1
ELSE IF (V.GE.Y(M-1)) THEN
IQ=M-2
ELSE
I=1
J=M
20 IF (IABS(J-I).NE.1) THEN
L=(I+J)/2
IF (V.LT.Y(L)) THEN
J=L
ELSE
I=L
END IF
GOTO 20
END IF
IF (ABS(V-Y(I)).LT.ABS(V-Y(J))) THEN
IQ=I-1
ELSE
IQ=I
END IF
END IF
DO 50 I=1,NN
B(I)=0.0
DO 40 J=1,MM
HH=Z(IP+I-1,IQ+J-1)
DO 30 K=1,MM
IF (K.NE.J) THEN
HH=HH*(V-Y(IQ+K-1))/(Y(IQ+J-1)-Y(IQ+K-1))
END IF
30 CONTINUE
B(I)=B(I)+HH
40 CONTINUE
50 CONTINUE
W=0.0
DO 70 I=1,NN
HH=B(I)
DO 60 J=1,NN
IF (J.NE.I) THEN
HH=HH*(U-X(IP+J-1))/(X(IP+I-1)-X(IP+J-1))
END IF
60 CONTINUE
W=W+HH
70 CONTINUE
! Return to calling program
END SUBROUTINE SLQ
!------------------------------------------------------------------------------
END MODULE RnPbBe_MOD

90
code/SPHERE.f Normal file
View File

@ -0,0 +1,90 @@
C $Id: SPHERE.f,v 1.1 2009/06/09 21:51:50 daven Exp $
SUBROUTINE SPHERE
C-----------------------------------------------------------------------
c Calculation of spherical geometry; derive tangent heights, slant path
c lengths and air mass factor for each layer. Not called when
c SZA > 98 degrees. Beyond 90 degrees, include treatment of emergent
c beam (where tangent height is below altitude J-value desired at).
C-----------------------------------------------------------------------
c
c GMU MU, cos(solar zenith angle)
c RZ Distance from centre of Earth to each point (cm)
c RQ Square of radius ratios
c TANHT Tangent height for the current SZA
c XL Slant path between points
c AMF Air mass factor for slab between level and level above
c
C-----------------------------------------------------------------------
IMPLICIT NONE
# include "cmn_fj.h"
# include "jv_cmn.h"
integer i, j, k, ii
real*8 airmas, gmu, xmu1, xmu2, xl, diff
REAL*8 Ux,H,RZ(NB),RQ(NB),ZBYR
c
c Inlined air mass factor function for top of atmosphere
AIRMAS(Ux,H) = (1.0d0+H)/SQRT(Ux*Ux+2.0d0*H*(1.0d0-
$ 0.6817d0*EXP(-57.3d0*ABS(Ux)/SQRT(1.0d0+5500.d0*H))/
$ (1.0d0+0.625d0*H)))
c
GMU = U0
RZ(1)=RAD+Z(1)
ZBYR = ZZHT/RAD
DO 2 II=2,NB
RZ(II) = RAD + Z(II)
RQ(II-1) = (RZ(II-1)/RZ(II))**2
2 CONTINUE
IF (GMU.LT.0.0D0) THEN
TANHT = RZ(nlbatm)/DSQRT(1.0D0-GMU**2)
ELSE
TANHT = RZ(nlbatm)
ENDIF
c
c Go up from the surface calculating the slant paths between each level
c and the level above, and deriving the appropriate Air Mass Factor
DO 16 J=1,NB
DO K=1,NB
AMF(K,J)=0.D0
ENDDO
c
c Air Mass Factors all zero if below the tangent height
IF (RZ(J).LT.TANHT) GOTO 16
c Ascend from layer J calculating AMFs
XMU1=ABS(GMU)
DO 12 I=J,lpar
XMU2=DSQRT(1.0D0-RQ(I)*(1.0D0-XMU1**2))
XL=RZ(I+1)*XMU2-RZ(I)*XMU1
AMF(I,J)=XL/(RZ(I+1)-RZ(I))
XMU1=XMU2
12 CONTINUE
c Use function and scale height to provide AMF above top of model
AMF(NB,J)=AIRMAS(XMU1,ZBYR)
c
c Twilight case - Emergent Beam
IF (GMU.GE.0.0D0) GOTO 16
XMU1=ABS(GMU)
c Descend from layer J
DO 14 II=J-1,1,-1
DIFF=RZ(II+1)*DSQRT(1.0D0-XMU1**2)-RZ(II)
if(II.eq.1) DIFF=max(DIFF,0.d0) ! filter
c Tangent height below current level - beam passes through twice
IF (DIFF.LT.0.0D0) THEN
XMU2=DSQRT(1.0D0-(1.0D0-XMU1**2)/RQ(II))
XL=ABS(RZ(II+1)*XMU1-RZ(II)*XMU2)
AMF(II,J)=2.d0*XL/(RZ(II+1)-RZ(II))
XMU1=XMU2
c Lowest level intersected by emergent beam
ELSE
XL=RZ(II+1)*XMU1*2.0D0
c WTING=DIFF/(RZ(II+1)-RZ(II))
c AMF(II,J)=(1.0D0-WTING)*2.D0**XL/(RZ(II+1)-RZ(II))
AMF(II,J)=XL/(RZ(II+1)-RZ(II))
GOTO 16
ENDIF
14 CONTINUE
c
16 CONTINUE
RETURN
END

BIN
code/geos Normal file
View File

Binary file not shown.

326
code/get_global_ch4.f Normal file
View File

@ -0,0 +1,326 @@
! $Id: get_global_ch4.f,v 1.1 2009/06/09 21:51:51 daven Exp $
SUBROUTINE GET_GLOBAL_CH4( THISYEAR, VARIABLE_CH4,
& A3090S, A0030S, A0030N, A3090N )
!
!******************************************************************************
! Subroutine GET_GLOBAL_CH4 computes the latitudinal gradient in CH4
! corresponding to year (jsw, bnd, bmy, 1/3/01, 1/25/08)
!
! Arguments as Input:
! ===========================================================================
! (1 ) THISYEAR (INTEGER) : Current month number (1-12)
! (2 ) VARIABLE_CH4 (LOGICAL) : Flag for selecting variable or constant CH4
!
! Arguments as Output:
! ===========================================================================
! (3 ) A3090S (REAL*8 ) : CH4 concentration [ppbv], 90S - 30S lat
! (4 ) A0030S (REAL*8 ) : CH4 concentration [ppbv], 30S - 00 lat
! (5 ) A0030N (REAL*8 ) : CH4 concentration [ppbv], 00 - 30N lat
! (6 ) A3090N (REAL*8 ) : CH4 concentration [ppbv], 30N - 90N lat
!
! NOTES:
! (1 ) GET_GLOBAL_CH4 only has to be called at the start of the new year,
! as long as A3090S, A0030S, A0030N, A3090N are saved in the
! calling program (bmy, 1/3/01)
! (2 ) Also need to compute yearly gradients for CH4 beyond 1997 --
! will do this later (bmy, 1/3/01)
! (3 ) Bug fix: add missing comma to FORMAT statement (bmy, 3/23/03)
! (4 ) Place WRITE statments w/in an !$OMP CRITICAL block, so as to make
! sure that only one processor at a time writes them. Also now use
! F90 REPEAT intrinsic function. Also replaced old CH4 gradient values
! with updated values for 1983-2001. Use data for 2001 as a proxy for
! years past 2001, since data for those years has not been reported
! yet. (mje, bmy, 7/7/03)
! (5 ) Split off from module "global_ch4_mod.f". Updated for IPCC future
! emissions scenarios. (swu, bmy, 5/30/06)
! (6 ) Add the preindustrial CH4 scenarios. Also set 2001 as the default
! in case we are running 2030 or 2050 met but present-day emissions.
! (swu, havala, bmy, 1/25/08)
!******************************************************************************
!
! References to F90 modules
USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCENARIO
USE LOGICAL_MOD, ONLY : LFUTURE, LHTAP
IMPLICIT NONE
! Arguments
INTEGER, INTENT(IN) :: THISYEAR
LOGICAL, INTENT(IN) :: VARIABLE_CH4
REAL*8, INTENT(OUT) :: A3090S, A0030S, A0030N, A3090N
! Local variables
CHARACTER(LEN=2) :: FUTURE_SCENARIO
!=================================================================
! GET_GLOBAL_CH4 begins here!
!
! New methane data from 1983-2001 (mje, bmy, 7/7/03)
!
! Methane measurements are from CMDL website:
! ftp://140.172.192.211/ccg/ch4/flask/month
!
! Measurements includes all sites other than:
! BAL BSC HUN MHD OXK TAP SEY IZO KUM MID ASK
!
! Sites are separated into 4 latitude bands:
! (1) 90S - 30S; (2) 30S - 00S;
! (3) 00N - 30N; (4) 30N - 90N
!
! Bob Yantosca (bmy@io.harvard.edu) maintains the archive
! of the IDL code needed to process the methane data.
!
! Also add future emission scenarios for GCAP, as well as
! the preindustrial CH4 levels (swu, havala, bmy, 1/25/08)
!=================================================================
IF ( VARIABLE_CH4 ) THEN
! Get IPCC future scenario (e.g. A1, A2, B1, B2)
IF ( LFUTURE ) THEN
FUTURE_SCENARIO = GET_FUTURE_SCENARIO()
ENDIF
! Select latitudinal CH4 gradient by year...
SELECT CASE ( THISYEAR )
! Preindustrial years
CASE ( :1750 )
A3090S = 700.0d0
A0030S = 700.0d0
A0030N = 700.0d0
A3090N = 700.0d0
! Modern-day years ...
CASE( 1983 )
A3090S = 1559.89d0
A0030S = 1575.68d0
A0030N = 1627.04d0
A3090N = 1682.40d0
CASE( 1984 )
A3090S = 1578.59d0
A0030S = 1587.03d0
A0030N = 1635.20d0
A3090N = 1702.69d0
CASE( 1985 )
A3090S = 1588.78d0
A0030S = 1600.98d0
A0030N = 1648.02d0
A3090N = 1716.23d0
CASE( 1986 )
A3090S = 1598.28d0
A0030S = 1612.76d0
A0030N = 1664.98d0
A3090N = 1731.23d0
CASE( 1987 )
A3090S = 1611.65d0
A0030S = 1622.34d0
A0030N = 1681.88d0
A3090N = 1741.44d0
CASE( 1988 )
A3090S = 1620.31d0
A0030S = 1634.43d0
A0030N = 1691.88d0
A3090N = 1753.92d0
CASE( 1989 )
A3090S = 1634.89d0
A0030S = 1647.15d0
A0030N = 1699.20d0
A3090N = 1759.64d0
CASE( 1990 )
A3090S = 1643.58d0
A0030S = 1653.97d0
A0030N = 1712.33d0
A3090N = 1769.97d0
CASE( 1991 )
A3090S = 1654.38d0
A0030S = 1665.13d0
A0030N = 1722.64d0
A3090N = 1779.76d0
CASE( 1992 )
A3090S = 1668.22d0
A0030S = 1673.40d0
A0030N = 1732.30d0
A3090N = 1786.76d0
CASE( 1993 )
A3090S = 1667.04d0
A0030S = 1677.26d0
A0030N = 1733.96d0
A3090N = 1790.82d0
CASE( 1994 )
A3090S = 1670.85d0
A0030S = 1681.07d0
A0030N = 1740.88d0
A3090N = 1797.05d0
CASE( 1995 )
A3090S = 1681.00d0
A0030S = 1689.19d0
A0030N = 1751.25d0
A3090N = 1802.51d0
CASE( 1996 )
A3090S = 1682.23d0
A0030S = 1690.72d0
A0030N = 1751.64d0
A3090N = 1805.18d0
CASE( 1997 )
A3090S = 1687.94d0
A0030S = 1693.35d0
A0030N = 1755.41d0
A3090N = 1805.92d0
CASE( 1998 )
A3090S = 1696.98d0
A0030S = 1703.54d0
A0030N = 1764.94d0
A3090N = 1820.58d0
CASE( 1999 )
A3090S = 1705.64d0
A0030S = 1714.18d0
A0030N = 1769.83d0
A3090N = 1823.48d0
CASE( 2000 )
A3090S = 1707.14d0
A0030S = 1715.63d0
A0030N = 1769.11d0
A3090N = 1822.85d0
CASE( 2001 )
A3090S = 1705.68d0
A0030S = 1709.52d0
A0030N = 1767.51d0
A3090N = 1822.53d0
! Future year 2030
CASE( 2025:2035 )
! Pick the IPCC scenario. If LFUTURE=F and FUTURE_SCENARIO
! are undefined, then we are running 2030 meteorology with
! present-day emissions. In this case, default to 2001 CH4
! concentrations. (havala, 1/25/08)
SELECT CASE( FUTURE_SCENARIO )
CASE( 'A1' )
A3090S = 2202.0d0
A0030S = 2202.0d0
A0030N = 2202.0d0
A3090N = 2202.0d0
CASE( 'B1' )
A3090S = 1927.0d0
A0030S = 1927.0d0
A0030N = 1927.0d0
A3090N = 1927.0d0
CASE( 'A2' )
! Not defined yet
CASE( 'B2' )
! Not defined yet
CASE DEFAULT
! 2001 is the default
A3090S = 1705.68d0
A0030S = 1709.52d0
A0030N = 1767.51d0
A3090N = 1822.53d0
END SELECT
! Future year 2050
CASE( 2045:2055 )
! Pick the IPCC scenario. If LFUTURE=F and FUTURE_SCENARIO
! is undefined, then we are running 2050 meteorology with
! present-day emissions. In this case, default to 2001 CH4
! concentrations. (havala, 1/25/08)
SELECT CASE ( FUTURE_SCENARIO )
CASE ( 'A1' )
A3090S = 2400.0d0
A0030S = 2400.0d0
A0030N = 2400.0d0
A3090N = 2400.0d0
CASE ( 'B1' )
A3090S = 1881.0d0
A0030S = 1881.0d0
A0030N = 1881.0d0
A3090N = 1881.0d0
CASE ( 'A2' )
A3090S = 2562.0d0
A0030S = 2562.0d0
A0030N = 2562.0d0
A3090N = 2562.0d0
CASE ( 'B2' )
A3090S = 2363.0d0
A0030S = 2363.0d0
A0030N = 2363.0d0
A3090N = 2363.0d0
CASE DEFAULT
! 2001 is the default
A3090S = 1705.68d0
A0030S = 1709.52d0
A0030N = 1767.51d0
A3090N = 1822.53d0
END SELECT
! Default is to use 2001 data for other years
! for which we do not yet have data (bmy, 5/30/06)
CASE DEFAULT
IF ( LHTAP ) THEN
A3090S = 1798d0
A0030S = 1798d0
A0030N = 1798d0
A3090N = 1798d0
ELSE
A3090S = 1705.68d0
A0030S = 1709.52d0
A0030N = 1767.51d0
A3090N = 1822.53d0
ENDIF
END SELECT
ELSE
! ...otherwise assume constant global CH4
A3090S = 1700.0d0
A0030S = 1700.0d0
A0030N = 1700.0d0
A3090N = 1700.0d0
ENDIF
!=================================================================
! Print the latitudinal CH4 gradient for this year to stdout
!=================================================================
!$OMP CRITICAL
WRITE( 6, '(a)' ) REPEAT( '=', 79 )
WRITE( 6, 105 ) THISYEAR
105 FORMAT( 'GET_GLOBAL_CH4: YEAR = ', i4 )
WRITE( 6, 110 ) A3090N, A0030N, A0030S, A3090S
110 FORMAT( 'CH4 (90N - 30N) : ', f7.1, ' [ppbv]', /,
& 'CH4 (30N - 00 ) : ', f7.1, ' [ppbv]', /,
& 'CH4 (00 - 30S) : ', f7.1, ' [ppbv]', /,
& 'CH4 (30S - 90S) : ', f7.1, ' [ppbv]' )
! Indicate to the log file if we are using CH4 gradient data
! from 2001 as a proxy for years past 2001 (mje, bmy, 7/7/03)
IF ( THISYEAR > 2001 ) THEN
WRITE( 6, 115 )
115 FORMAT( /, 'Using CH4 gradient data from 2001 as a proxy',
& /, 'since 2001 is the last year with reported data!' )
ENDIF
WRITE( 6, '(a)' ) REPEAT( '=', 79 )
!$OMP END CRITICAL
! Return to calling program
END SUBROUTINE GET_GLOBAL_CH4

34
code/getifsun.f Normal file
View File

@ -0,0 +1,34 @@
! $Id: getifsun.f,v 1.1 2009/06/09 21:51:53 daven Exp $
INTEGER FUNCTION GETIFSUN(SUNCOS)
! References to F90 modules (bmy, 10/19/00)
USE COMODE_MOD, ONLY : IXSAVE, IYSAVE, JLOP
IMPLICIT NONE
# include "CMN_SIZE"
# include "comode.h"
INTEGER I,J,K,JLOOP,IJWINDOW,IX,IY
REAL*8 SUNCOS(MAXIJ)
C
*** see if photolysis should be considered.
c Get the right index for SUNCOS, which is calculated
c outside of chemistry module.
C (This works for LEMBED= .TRUE. or .FALSE.)
K = 0
DO 240 J = 1, NLAT
DO 230 I = 1, NLONG
JLOOP = JLOP(I,J,1)
IF (JLOOP.EQ.0) GOTO 230
IX=IXSAVE(JLOOP)
IY=IYSAVE(JLOOP)
IJWINDOW = (IY-1)*IIPAR + IX
IF(SUNCOS(IJWINDOW).GT.0.D0) K = 1
230 CONTINUE
240 CONTINUE
GETIFSUN = 2 - K
RETURN
END

1139
code/gfed2_biomass_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

2033
code/gfed3_biomass_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

273
code/global_hno3_mod.f Normal file
View File

@ -0,0 +1,273 @@
! $Id: global_hno3_mod.f,v 1.1 2009/06/09 21:51:50 daven Exp $
MODULE GLOBAL_HNO3_MOD
!
!******************************************************************************
! Module GLOBAL_HNO3_MOD contains variables and routines for reading the
! global monthly mean HNO3 fields from disk. (bmy, 10/15/02, 2/7/07)
!
! Module Variables:
! ===========================================================================
! (1 ) HNO3 (REAL*8) : stores global monthly mean HNO3 field
!
! Module Routines:
! ===========================================================================
! (1 ) GET_HNO3_UGM3 : Converts HNO3 from [v/v] to [ug/m3]
! (2 ) GET_GLOBAL_HNO3 : Reads global monthly mean HNO3 from disk
! (3 ) INIT_GLOBAL_HNO3 : allocates & initializes the HNO3 array
! (4 ) CLEANUP_GLOBAL_HNO3 : deallocates the HNO3 array
!
! GEOS-CHEM modules referenced by global_nox_mod.f
! ============================================================================
! (1 ) bpch2_mod.f : Module containing routines for binary punch file I/O
! (2 ) dao_mod.f : Module containing arrays for DAO met fields
! (3 ) directory_mod.f : Module containing GEOS-CHEM data & met field dirs
! (4 ) error_mod.f : Module containing NaN and other error check routines
! (5 ) tracer_mod.f : Module containing GEOS-CHEM tracer array STT etc.
! (6 ) transfer_mod.f : Module containing routines to cast & resize arrays!
!
! NOTES:
! (1 ) Minor bug fix in FORMAT statement (bmy, 3/23/03)
! (2 ) Cosmetic changes (bmy, 3/27/03)
! (3 ) Now references "directory_mod.f" & "tracer_mod.f" (bmy, 7/20/04)
! (4 ) Now suppress output from READ_BPCH2 with QUIET=T (bmy, 1/14/05)
! (5 ) Now read total gas + aerosol HNO3 data (bec, bmy, 4/13/05)
! (6 ) Now read files from "sulfate_sim_200508/offline" dir (bmy, 8/1/05)
! (7 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (8 )
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE PRIVATE DECLARATIONS -- keep certain internal variables
! and routines from being seen outside "global_hno3_mod.f"
!=================================================================
! PRIVATE module variables
PRIVATE :: HNO3
! PRIVATE module routines
PRIVATE :: INIT_GLOBAL_HNO3
!=================================================================
! MODULE VARIABLES
!=================================================================
! Array to store global monthly mean OH field
REAL*8, ALLOCATABLE :: HNO3(:,:,:)
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
FUNCTION GET_HNO3_UGM3( I, J, L ) RESULT( HNO3_UGM3 )
!
!******************************************************************************
! Subroutine GET_HNO3_UGM3 converts monthly mean HNO3 mixing ratio from [v/v]
! to [ug/m3]. This is necessary for the RPMARES code. We allow HNO3
! concentrations to evolve but relax back to the monthly mean value
! every 3 hours. (bmy, 10/15/02, 7/20/04)
!
! Arguments as Input:
! ===========================================================================
! (1-3) I, J, L (INTEGER) : Grid box indices for lon, lat, vertical level
!
! NOTES:
! (1 ) Now references TCVV from "tracer_mod.f" (bmy, 7/20/04)
!******************************************************************************
!
! References to F90 modules
USE DAO_MOD, ONLY : AD, AIRVOL
USE TRACER_MOD, ONLY : TCVV
# include "CMN_SIZE" ! Size parameters
! Arguments
INTEGER, INTENT(IN) :: I, J, L
! Local variables
REAL*8 :: HNO3_UGM3
!=================================================================
! GET_HNO3_UGM3 begins here!
!=================================================================
! First convert HNO3 from [v/v] to [kg]
HNO3_UGM3 = HNO3(I,J,L) * AD(I,J,L) / ( 28.97d0 / 63d0 )
! Then convert HNO3 from [kg] to [ug/m3]
HNO3_UGM3 = HNO3_UGM3 * 1.d9 / AIRVOL(I,J,L)
! Return to calling program
END FUNCTION GET_HNO3_UGM3
!------------------------------------------------------------------------------
SUBROUTINE GET_GLOBAL_HNO3( THISMONTH )
!
!******************************************************************************
! Subroutine GET_GLOBAL_HNO3 reads global OH from binary punch files stored
! in the data directory. This is needed for the offline sulfate simulation.
! (bmy, 10/3/02, 2/7/07)
!
! Arguments as Input:
! ===========================================================================
! (1 ) THISMONTH (INTEGER) : Current month number (1-12)
!
! NOTES:
! (1 ) Bug fix in FORMAT statement: Replace missing commas (bmy, 3/23/03)
! (2 ) Cosmetic changes (bmy, 3/27/03)
! (3 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04)
! (4 ) Now suppress output from READ_BPCH2 with QUIET=T (bmy, 1/14/05)
! (5 ) Now read total gas + aerosol HNO3 data (bec, bmy, 4/13/05)
! (6 ) GEOS-3 and GEOS-4 data comes from model runs w/ 30 layers. Also now
! read from "sulfate_sim_200508/offline" directory (bmy, 8/1/05)
! (7 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (8 ) Renamed GRID30LEV to GRIDREDUCED (bmy, 2/7/07)
!******************************************************************************
!
! References to F90 modules
USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2
USE ERROR_MOD, ONLY : ERROR_STOP
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE TRANSFER_MOD, ONLY : TRANSFER_2D, TRANSFER_3D
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
! Arguments
INTEGER, INTENT(IN) :: THISMONTH
! Local variables
INTEGER :: I, J, L
REAL*4 :: ARRAY(IGLOB,JGLOB,LGLOB)
REAL*8 :: XTAU
CHARACTER(LEN=255) :: FILENAME
! First time flag
LOGICAL, SAVE :: FIRST = .TRUE.
!=================================================================
! GET_GLOBAL_HNO3 begins here!
!=================================================================
! Allocate OH array, if this is the first call
IF ( FIRST ) THEN
CALL INIT_GLOBAL_HNO3
FIRST = .FALSE.
ENDIF
! File name for modified HNO3 (total gas + aerosol nitrate)
! after sea-salt chemistry (bec, bmy, 4/13/05, 8/1/05)
FILENAME = TRIM( DATA_DIR ) //
& 'sulfate_sim_200508/offline/THNO3.' //
& GET_NAME_EXT() // '.' // GET_RES_EXT()!
! Echo some information to the standard output
WRITE( 6, 110 ) TRIM( FILENAME )
110 FORMAT( ' - GET_GLOBAL_HNO3: Reading ', a )
! Get the TAU0 value for the start of the given month
! Assume "generic" year 1985 (TAU0 = [0, 744, ... 8016])
XTAU = GET_TAU0( THISMONTH, 1, 1985 )
#if defined( GEOS_3 ) || defined( GEOS_4 ) || defined( GEOS_5 ) || defined( GEOS_FP )
!-------------------------------------------------------
! GEOS-3 / GEOS-4 data come from the 30 level model run
!-------------------------------------------------------
#if defined( GRIDREDUCED )
! Read HNO3 data from the binary punch file
CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 7,
& XTAU, IGLOB, JGLOB,
& LLPAR, ARRAY(:,:,1:LLPAR), QUIET=.TRUE. )
! Assign data from ARRAY to the module variable HNO3
DO L = 1, LLPAR
CALL TRANSFER_2D( ARRAY(:,:,L), HNO3(:,:,L) )
ENDDO
#else
! If LLPAR is not 30 levels then stop with error
CALL ERROR_STOP( 'Must use 30 levels for offline aerosol sim!',
& 'GET_GLOBAL_HNO3 ("global_hno3_mod.f!")' )
#endif
#else
!-------------------------------------------------------
! Data for other GEOS grids have LGLOB levels
!-------------------------------------------------------
! Read HNO3 data from the binary punch file
CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 7,
& XTAU, IGLOB, JGLOB,
& LGLOB, ARRAY, QUIET=.TRUE. )
! Assign data from ARRAY to the module variable HNO3
CALL TRANSFER_3D( ARRAY, HNO3 )
#endif
! Return to calling program
END SUBROUTINE GET_GLOBAL_HNO3
!------------------------------------------------------------------------------
SUBROUTINE INIT_GLOBAL_HNO3
!
!******************************************************************************
! Subroutine INIT_GLOBAL_HNO3 allocates and zeroes the HNO3 array
! (bmy, 10/15/02)
!
! NOTES:
! (1 ) Now references ALLOC_ERR from "error_mod.f" (bmy, 10/15/02)
! (2 ) Now dimension HNO3 as (IIPAR,JJPAR,LLPAR) (bmy, 8/1/05)
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : ALLOC_ERR
# include "CMN_SIZE" ! Size parameters
! Local variables
INTEGER :: AS
!=================================================================
! INIT_GLOBAL_HNO3 begins here!
!=================================================================
ALLOCATE( HNO3( IIPAR, JJPAR, LLPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'HNO3' )
HNO3 = 0d0
! Return to calling program
END SUBROUTINE INIT_GLOBAL_HNO3
!------------------------------------------------------------------------------
SUBROUTINE CLEANUP_GLOBAL_HNO3
!
!******************************************************************************
! Subroutine CLEANUP_GLOBAL_HNO3 deallocates the HNO3 array. (bmy, 10/15/02)
!******************************************************************************
!
!=================================================================
! CLEANUP_GLOBAL_HNO3 begins here!
!=================================================================
IF ( ALLOCATED( HNO3 ) ) DEALLOCATE( HNO3 )
! Return to calling program
END SUBROUTINE CLEANUP_GLOBAL_HNO3
!------------------------------------------------------------------------------
END MODULE GLOBAL_HNO3_MOD

197
code/global_no3_mod.f Normal file
View File

@ -0,0 +1,197 @@
! $Id: global_no3_mod.f,v 1.1 2009/06/09 21:51:54 daven Exp $
MODULE GLOBAL_NO3_MOD
!
!******************************************************************************
! Module GLOBAL_NO3_MOD contains variables and routines for reading the
! global monthly mean NO3 concentration from disk. These are needed for the
! offline sulfate/aerosol simulation. (bmy, 10/15/02, 1/22/07)
!
! Module Variables:
! ===========================================================================
! (1 ) NO3 (REAL*8) : Stores global monthly mean NO3 field
!
! Module Routines:
! ===========================================================================
! (1 ) GET_GLOBAL_NO3 : Reads global monthly mean HNO3 from disk
! (2 ) INIT_GLOBAL_NO3 : Allocates & initializes the HNO3 array
! (3 ) CLEANUP_GLOBAL_NO3 : Deallocates the HNO3 array
!
! GEOS-CHEM modules referenced by global_no3_mod.f
! ============================================================================
! (1 ) bpch2_mod.f : Module containing routines for binary punch file I/O
! (2 ) directory_mod.f : Module containing GEOS-CHEM data and met field dirs
! (3 ) error_mod.f : Module containing NaN and other error check routines
! (4 ) transfer_mod.f : Module containing routines to cast & resize arrays
!
! NOTES:
! (1 ) Adapted from "global_oh_mod.f" (bmy, 10/3/02)
! (2 ) Minor bug fix in FORMAT statements (bmy, 3/23/03)
! (3 ) Cosmetic changes (bmy, 3/27/03)
! (4 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04)
! (5 ) Now suppress output from READ_BPCH2 with QUIET=T (bmy, 1/14/05)
! (6 ) Now read from "sulfate_sim_200508/offline" directory (bmy, 8/1/05)
! (7 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (8 ) Bug fix: now zero ARRAY (phs, 1/22/07)
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE PRIVATE DECLARATIONS -- keep certain internal variables
! and routines from being seen outside "global_hno3_mod.f"
!=================================================================
! PRIVATE module variables
PRIVATE :: INIT_GLOBAL_NO3
!=================================================================
! MODULE VARIABLES
!=================================================================
! Array to store global monthly mean OH field
REAL*8, ALLOCATABLE :: NO3(:,:,:)
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
SUBROUTINE GET_GLOBAL_NO3( THISMONTH )
!
!******************************************************************************
! Subroutine GET_GLOBAL_NO3 reads monthly mean NO3 data fields. These
! are needed for simulations such as offline sulfate/aerosol.
! (bmy, 10/15/02, 1/22/07)
!
! Arguments as Input:
! ===========================================================================
! (1 ) THISMONTH (INTEGER) : Current month number (1-12)
!
! NOTES:
! (1 ) Minor bug fix in FORMAT statements (bmy, 3/23/03)
! (2 ) Cosmetic changes (bmy, 3/27/03)
! (3 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04)
! (4 ) Now suppress output from READ_BPCH2 with QUIET=T (bmy, 1/14/05)
! (5 ) GEOS-3 & GEOS-4 data comes from model runs w/ 30 levels. Also now
! read from "sulfate_sim_200508/offline" directory. Also now read
! up to LLTROP levels. Now reference TRANSFER_3D_TROP from
! "transfer_mod.f". (bmy, 8/1/05)
! (5 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (6 ) Now zero local variable ARRAY (phs, 1/22/07)
!******************************************************************************
!
! References to F90 modules
USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE TRANSFER_MOD, ONLY : TRANSFER_3D_TROP
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
! Arguments
INTEGER, INTENT(IN) :: THISMONTH
! Local variables
REAL*4 :: ARRAY(IGLOB,JGLOB,LLTROP)
REAL*8 :: XTAU
CHARACTER(LEN=255) :: FILENAME
! First time flag
LOGICAL, SAVE :: FIRST = .TRUE.
!=================================================================
! GET_GLOBAL_NO3 begins here!
!=================================================================
! Allocate NO3 array, if this is the first call
IF ( FIRST ) THEN
CALL INIT_GLOBAL_NO3
FIRST = .FALSE.
ENDIF
! File name
FILENAME = TRIM( DATA_DIR ) //
& 'sulfate_sim_200508/offline/NO3.' //
& GET_NAME_EXT() // '.' // GET_RES_EXT()
! Echo some information to the standard output
WRITE( 6, 110 ) TRIM( FILENAME )
110 FORMAT( ' - GET_GLOBAL_NO3: Reading ', a )
! Get the TAU0 value for the start of the given month
! Assume "generic" year 1985 (TAU0 = [0, 744, ... 8016])
XTAU = GET_TAU0( THISMONTH, 1, 1985 )
! Zero ARRAY so that we avoid random data between
! levels LLTROP_FIX and LLTROP (phs, 1/22/07)
ARRAY = 0e0
! Read NO3 data from the binary punch file (tracer #5)
! NOTE: NO3 data is only defined w/in the tropopause, so set the 3rd
! dim of ARRAY to LLTROP_FIX (i.e, case of annual mean tropopause).
! This is backward compatibility with offline data set. (phs, 1/22/07)
CALL READ_BPCH2(
& FILENAME, 'CHEM-L=$', 5,
& XTAU, IGLOB, JGLOB,
& LLTROP_FIX, ARRAY(:,:,1:LLTROP_FIX), QUIET=.TRUE. )
! Assign data from ARRAY to the module variable H2O2
! Levels between LLTROP_FIX and LLROP are 0
CALL TRANSFER_3D_TROP( ARRAY, NO3 )
! Return to calling program
END SUBROUTINE GET_GLOBAL_NO3
!------------------------------------------------------------------------------
SUBROUTINE INIT_GLOBAL_NO3
!
!******************************************************************************
! Subroutine INIT_GLOBAL_NO3 allocates the NO3 module array (bmy, 10/15/02)
!
! NOTES:
! (1 ) Now references ALLOC_ERR from "error_mod.f" (bmy, 10/15/02)
! (2 ) Now allocate NO3 array up to LLTROP levels (bmy, 8/1/05)
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : ALLOC_ERR
# include "CMN_SIZE" ! Size parameters
! Local variables
INTEGER :: AS
!=================================================================
! INIT_GLOBAL_H2O2 begins here!
!=================================================================
ALLOCATE( NO3( IIPAR, JJPAR, LLTROP ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'NO3' )
NO3 = 0d0
! Return to calling program
END SUBROUTINE INIT_GLOBAL_NO3
!------------------------------------------------------------------------------
SUBROUTINE CLEANUP_GLOBAL_NO3
!
!******************************************************************************
! Subroutine CLEANUP_GLOBAL_H2O2 deallocates the H2O2 array. (bmy, 10/15/02)
!******************************************************************************
!
!=================================================================
! CLEANUP_GLOBAL_H2O2 begins here!
!=================================================================
IF ( ALLOCATED( NO3 ) ) DEALLOCATE( NO3 )
! Return to calling program
END SUBROUTINE CLEANUP_GLOBAL_NO3
!------------------------------------------------------------------------------
END MODULE GLOBAL_NO3_MOD

217
code/global_nox_mod.f Normal file
View File

@ -0,0 +1,217 @@
! $Id: global_nox_mod.f,v 1.1 2009/06/09 21:51:52 daven Exp $
MODULE GLOBAL_NOX_MOD
!
!******************************************************************************
! Module GLOBAL_NOX_MOD contains variables and routines for reading the
! global monthly mean NOX concentration from disk. (bmy, 7/28/00, 10/3/05)
!
! Module Variables:
! ===========================================================================
! (1 ) BNOX (REAL*8) : stores global monthly mean NOx field [ppbv]
!
! Module Routines:
! ===========================================================================
! (1 ) GET_GLOBAL_NOX : reads global monthly mean NOx from disk
! (2 ) INIT_GLOBAL_NOX : allocates & initializes the NOx array
! (3 ) CLEANUP_GLOBAL_NOX : deallocates the NOx array
!
! GEOS-CHEM modules referenced by global_nox_mod.f
! ============================================================================
! (1 ) bpch2_mod.f : Module containing routines for binary punch file I/O
! (2 ) directory_mod.f : Module containing GEOS-CHEM data & met field dirs
! (3 ) error_mod.f : Module containing NaN and other error check routines
! (4 ) unix_cmds_mod.f : Module containing Unix commands for unzipping etc.
!
! NOTES:
! (1 ) Updated comments, made cosmetic changes (bmy, 6/13/01)
! (2 ) Updated comments (bmy, 9/4/01)
! (3 ) Now regrid BNOX array from 48L to 30L for GEOS-3 if necessary.
! (bmy, 1/14/02)
! (4 ) Eliminated obsolete code from 1/02 (bmy, 2/27/02)
! (5 ) Now divide module header into MODULE PRIVATE, MODULE VARIABLES, and
! MODULE ROUTINES sections. Updated comments (bmy, 5/28/02)
! (6 ) Now references "error_mod.f" (bmy, 10/15/02)
! (7 ) Minor bug fix in FORMAT statements (bmy, 3/23/03)
! (8 ) Cosmetic changes to improve output (bmy, 3/27/03)
! (9 ) Now references "directory_mod.f" and "unix_cmds_mod.f" (bmy, 7/20/04)
! (10) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE VARIABLES
!=================================================================
! Array to store global monthly mean BNOX field
REAL*8, ALLOCATABLE :: BNOX(:,:,:)
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
SUBROUTINE GET_GLOBAL_NOX( THISMONTH )
!
!******************************************************************************
! Subroutine GET_GLOBAL_NOX reads global NOX from binary punch files from a
! a full chemistry run. This NOx data is needed to calculate the CO yield
! from isoprene oxidation. (bmy, 7/28/00, 10/3/05)
!
! Arguments as Input:
! ===========================================================================
! (1 ) THISMONTH (INTEGER) : Current month number (1-12)
!
! NOTES:
! (1 ) Now use version of GET_TAU0 with 3 arguments. Now call READ_BPCH2
! with IGLOB,JGLOB,LGLOB. Call TRANSFER_3D to cast from REAL*4 to
! REAL*8 and to regrid to 30 levels for GEOS-3 (if necessary). ARRAY
! should now be of size (IGLOB,JGLOB,LGLOB). (bmy, 1/14/02)
! (2 ) Eliminated obsolete code from 1/02 (bmy, 2/27/02)
! (3 ) Bug fix in FORMAT statement: replace missing commas. Also make sure
! to define FILENAME before printing it (bmy, 4/28/03)
! (4 ) Now references TEMP_DIR, DATA_DIR from "directory_mod.f". Also
! references Unix unzipping commands from "unix_cmds_mod.f".
! (bmy, 7/20/04)
! (5 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
!******************************************************************************
!
! References to F90 modules
USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2
USE DIRECTORY_MOD, ONLY : DATA_DIR, TEMP_DIR
USE TRANSFER_MOD, ONLY : TRANSFER_3D
USE UNIX_CMDS_MOD, ONLY : REDIRECT, UNZIP_CMD, ZIP_SUFFIX
# include "CMN_SIZE" ! Size parameters
! Arguments
INTEGER, INTENT(IN) :: THISMONTH
! Local variables
INTEGER :: I, J, L
REAL*4 :: ARRAY(IGLOB,JGLOB,LGLOB)
REAL*8 :: XTAU
CHARACTER(LEN=255) :: FILENAME
CHARACTER(LEN=255) :: FIELD_DIR, RGNAME, TEMPO, CHAROP
CHARACTER(LEN=3) :: BMONTH(12) = (/ 'jan', 'feb', 'mar',
& 'apr', 'may', 'jun',
& 'jul', 'aug', 'sep',
& 'oct', 'nov', 'dec' /)
! First time flag
LOGICAL, SAVE :: FIRST = .TRUE.
!=================================================================
! GET_GLOBAL_NOX begins here!
!=================================================================
! Allocate NOx array, if this is the first call
IF ( FIRST ) THEN
CALL INIT_GLOBAL_NOx
FIRST = .FALSE.
ENDIF
!=================================================================
! Construct file names and uncompress commands
!=================================================================
! Name of unzipped file in TEMP_DIR
TEMPO = 'tempo'
! Directory where the NOx files reside
FIELD_DIR = '/data/ctm/GEOS_MEAN/OHparam/'
! Name of the zipped punch file w/ NOx in FIELD_DIR
RGNAME = TRIM( FIELD_DIR ) // 'ctm.bpch.' //
& BMONTH( THISMONTH ) // '.' //
& GET_NAME_EXT() // TRIM( ZIP_SUFFIX )
! Construct the command to unzip the file & copy to TEMP_DIR
CHAROP = TRIM( UNZIP_CMD ) // ' ' //
& TRIM( RGNAME ) // TRIM( REDIRECT ) //
& ' ' // TRIM( TEMP_DIR ) //
& TRIM( TEMPO )
! Uncompress the file and store in TEMP_DIR
CALL SYSTEM( TRIM( CHAROP ) )
!=================================================================
! Read NOx data from the punch file
!=================================================================
! Read 1997 NOx data for Jan-Aug; Read 1996 NOx data for Sep-Dec
! This avoids the 1997 El Nino signal in the NOx data
IF ( THISMONTH >= 9 ) THEN
XTAU = GET_TAU0( THISMONTH, 1, 1996 )
ELSE
XTAU = GET_TAU0( THISMONTH, 1, 1997 )
ENDIF
! Name of unzipped file in TEMP_DIR
FILENAME = TRIM( TEMP_DIR ) // TRIM( TEMPO )
! Echo info
WRITE( 6, 110 ) TRIM( FILENAME )
110 FORMAT( ' - GET_GLOBAL_NOX: Reading NOX from: ', a )
! Read NOX data from the binary punch file
CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 1, XTAU,
& IGLOB, JGLOB, LGLOB, ARRAY )
! Cast from REAL*4 to REAL*8
CALL TRANSFER_3D( ARRAY, BNOX )
! Return to calling program
END SUBROUTINE GET_GLOBAL_NOX
!------------------------------------------------------------------------------
SUBROUTINE INIT_GLOBAL_NOX
!
!******************************************************************************
! Subroutine INIT_GLOBAL_NOX allocates and zeroes the NOX array, which
! holds global monthly mean NOX concentrations. (bmy, 7/28/00, 10/15/02)
!
! NOTES:
! (1 ) BNOX now needs to be sized (IIPAR,JJPAR,LLPAR) (bmy, 1/14/02)
! (2 ) Eliminated obsolete code from 1/02 (bmy, 2/27/02)
! (3 ) Now references ALLOC_ERR from "error_mod.f" (bmy, 10/15/02)
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : ALLOC_ERR
# include "CMN_SIZE"
! Local variables
INTEGER :: AS
! Allocate NOX array
ALLOCATE( BNOX( IIPAR, JJPAR, LLPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'BNOX' )
! Zero BNOX array
BNOX = 0d0
! Return to calling program
END SUBROUTINE INIT_GLOBAL_NOX
!------------------------------------------------------------------------------
SUBROUTINE CLEANUP_GLOBAL_NOX
!
!******************************************************************************
! Subroutine CLEANUP_GLOBAL_NOX deallocates the NOX array.
!******************************************************************************
!
IF ( ALLOCATED( BNOX ) ) DEALLOCATE( BNOX )
! Return to calling program
END SUBROUTINE CLEANUP_GLOBAL_NOX
!------------------------------------------------------------------------------
END MODULE GLOBAL_NOX_MOD

167
code/global_o1d_mod.f Normal file
View File

@ -0,0 +1,167 @@
! $Id: global_o1d_mod.f,v 1.1 2009/06/09 21:51:53 daven Exp $
MODULE GLOBAL_O1D_MOD
!
!******************************************************************************
! Module GLOBAL_O1D_MOD contains variables and routines for reading the
! global monthly mean O1D stratospheric concentration from disk. This is
! used in the H2/HD simulation. The O1D fields were obtained from Gabriele
! Curci GEOS-Chem simulation in the stratosphere (v5.03).
! (hup, phs, 9/18/07)
!
! Module Variables:
! ===========================================================================
! (1 ) O1D (REAL*8) : stores global monthly mean O1D field
!
! Module Routines:
! ===========================================================================
! (1 ) GET_O1D : Wrapper for GET_GLOBAL_O1D
! (2 ) GET_GLOBAL_O1D : Reads global monthly mean O1D from disk
! (3 ) INIT_GLOBAL_O1D : Allocates & initializes the O1D array
! (4 ) CLEANUP_GLOBAL_O1D : Deallocates the OH array
!
! GEOS-Chem modules referenced by global_o1d_mod.f
! ============================================================================
! (1 ) bpch2_mod.f : Module containing routines for binary punch file I/O
! (2 ) error_mod.f : Module containing NaN and other error-check routines
!
! NOTES:
! (1 ) Adapted from GLOBAL_OH_MOD module (hup, phs, 9/18/07)
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE VARIABLES
!=================================================================
! Array to store global monthly mean O1D field
REAL*8, ALLOCATABLE :: O1D(:,:,:)
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
SUBROUTINE GET_GLOBAL_O1D( THISMONTH )
!
!******************************************************************************
! Subroutine GET_GLOBAL_O1D reads global O1D from binary punch files stored
! in the /data/ctm/GEOS_MEAN directory. This O1D data is needed for the H2/HD
! mechanisms in Tagged H2. (hup, phs, 9/18/07)
!
! Arguments as Input:
! ===========================================================================
! (1 ) THISMONTH (INTEGER) : Current month number (1-12)
!
! NOTES:
! (1 ) GET_GLOBAL_O1D assumes that we are reading global O1D data that
! occupies all CTM levels. Contact Bob Yantosca (bmy@io.harvard.edu)
! for IDL regridding code which will produce the appropriate O1D files.
! (2 ) ARRAY should now be of size (IGLOB,JGLOB,LGLOB). (bmy, 1/11/02)
! (3 ) Now point to new O1D files in the ??? subdirectory.
!******************************************************************************
!
! References to F90 modules
USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE TRANSFER_MOD, ONLY : TRANSFER_3D
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
! Arguments
INTEGER, INTENT(IN) :: THISMONTH
! Local variables
INTEGER :: I, J, L
REAL*4 :: ARRAY(IGLOB,JGLOB,LGLOB)
REAL*8 :: XTAU
CHARACTER(LEN=255) :: FILENAME
! First time flag
LOGICAL, SAVE :: FIRST = .TRUE.
!=================================================================
! GET_GLOBAL_O1D begins here!
!=================================================================
! Allocate O1D array, if this is the first call
IF ( FIRST ) THEN
CALL INIT_GLOBAL_O1D
FIRST = .FALSE.
ENDIF
!=================================================================
! Read Gabriele Curci's O1D (v5.03)
!=================================================================
FILENAME = TRIM( DATA_DIR ) // 'hydrogen_200704/stratO1D.' //
& GET_NAME_EXT() // '.' // GET_RES_EXT()
! Echo some information to the standard output
WRITE( 6, 110 ) TRIM( FILENAME )
110 FORMAT( ' - GET_GLOBAL_O1D: Reading O1D from: ', a )
! Get the TAU0 value for the start of the given month
! Assume "generic" year 1998
XTAU = GET_TAU0( THISMONTH, 1, 1998 )
! Read O1D data from the binary punch file
CALL READ_BPCH2( FILENAME, 'SL-AVG-$', 2,
& XTAU, IGLOB, JGLOB,
& LGLOB, ARRAY, QUIET=.TRUE. )
! Assign data from ARRAY to the module variable O1D
CALL TRANSFER_3D( ARRAY, O1D )
! Return to calling program
END SUBROUTINE GET_GLOBAL_O1D
!------------------------------------------------------------------------------
SUBROUTINE INIT_GLOBAL_O1D
!
!******************************************************************************
! Subroutine INIT_GLOBAL_O1D allocates and zeroes the O1D array, which holds
! global monthly mean O1D concentrations.
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : ALLOC_ERR
# include "CMN_SIZE"
! Local variables
INTEGER :: AS
! Allocate O1D array
ALLOCATE( O1D( IGLOB, JGLOB, LGLOB ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'O1D' )
! Zero O1D array
O1D = 0d0
! Return to calling program
END SUBROUTINE INIT_GLOBAL_O1D
!------------------------------------------------------------------------------
SUBROUTINE CLEANUP_GLOBAL_O1D
!
!******************************************************************************
! Subroutine CLEANUP_GLOBAL_O1D deallocates the O1D array.
!******************************************************************************
!
IF ( ALLOCATED( O1D ) ) DEALLOCATE( O1D )
! Return to calling program
END SUBROUTINE CLEANUP_GLOBAL_O1D
!------------------------------------------------------------------------------
! End of module
END MODULE GLOBAL_O1D_MOD

220
code/global_o3_mod.f Normal file
View File

@ -0,0 +1,220 @@
! $Id: global_o3_mod.f,v 1.1 2009/06/09 21:51:53 daven Exp $
MODULE GLOBAL_O3_MOD
!
!******************************************************************************
! Module GLOBAL_O3_MOD contains variables and routines for reading the
! global monthly mean O3 concentration from disk. These are needed for the
! offline sulfate/aerosol simulation. (rjp, bmy, 3/27/03, 1/14/09)
!
! Module Variables:
! ===========================================================================
! (1 ) O3 (REAL*8) : Stores global monthly mean O3 field
!
! Module Routines:
! ===========================================================================
! (1 ) GET_GLOBAL_O3 : Reads global monthly mean HO3 from disk
! (2 ) INIT_GLOBAL_O3 : Allocates & initializes the HO3 array
! (3 ) CLEANUP_GLOBAL_O3 : Deallocates the HO3 array
!
! GEOS-CHEM modules referenced by global_O3_mod.f
! ============================================================================
! (1 ) bpch2_mod.f : Module containing routines for binary punch file I/O
! (2 ) directory_mod.f : Module containing GEOS-CHEM data & met field dirs
! (2 ) error_mod.f : Module containing NaN and other error check routines
! (3 ) transfer_mod.f : Module containing routines to cast & resize arrays
!
! NOTES:
! (1 ) Now references "directory_mod.f" (bmy, 7/20/04)
! (2 ) Now reads O3 data from "sulfate_sim_200508/offline" dir (bmy, 8/30/05)
! (3 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (4 ) Bug fixes in GET_GLOBAL_O3 (bmy, 12/1/05)
! (5 ) Now reads O3 from MERGE files, which include stratospheric O3 from
! COMBO, for GEOS-3 and GEOS-4 met fields (phs, 1/19/07)
! (6 ) Bug fix in GET_GLOBAL_O3 (bmy, 1/14/09)
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE PRIVATE DECLARATIONS -- keep certain internal variables
! and routines from being seen outside "global_o3_mod.f"
!=================================================================
! PRIVATE module variables
PRIVATE :: INIT_GLOBAL_O3
!=================================================================
! MODULE VARIABLES
!=================================================================
! Array to store global monthly mean OH field
REAL*8, ALLOCATABLE :: O3(:,:,:)
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
SUBROUTINE GET_GLOBAL_O3( THISMONTH )
!
!******************************************************************************
! Subroutine GET_GLOBAL_O3 reads monthly mean O3 data fields.
! These are needed for simulations such as offline sulfate/aerosol.
! (bmy, 3/23/03, 1/14/09)
!
! Arguments as Input:
! ===========================================================================
! (1 ) THISMONTH (INTEGER) : Current month number (1-12)
!
! NOTES:
! (1 ) Minor bug fix in FORMAT statements (bmy, 3/23/03)
! (2 ) Cosmetic changes (bmy, 3/27/03)
! (3 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04)
! (4 ) Now reads O3 data from "sulfate_sim_200508/offline" dir (bmy, 8/30/05)
! (5 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (6 ) Tracer number for O3 is now 51. Also need to call TRANSFER_3D_TROP
! since the new O3 data file only goes up to LLTROP. (bmy, 11/18/05)
! (7 ) Modified to include stratospheric O3 -- Requires access to new
! MERGE.O3* files. (phs, 1/19/07)
! (8 ) Renamed GRID30LEV to GRIDREDUCED (bmy, 2/7/07)
! (9 ) Bug fix: don't call TRANSFER_3D if you use GRIDREDUCED (bmy, 1/14/09)
!******************************************************************************
!
! References to F90 modules
USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE TRANSFER_MOD, ONLY : TRANSFER_3D
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
! Arguments
INTEGER, INTENT(IN) :: THISMONTH
! Local variables
REAL*4 :: ARRAY(IGLOB,JGLOB,LGLOB)
REAL*4 :: ARRAY2(IGLOB,JGLOB,LLPAR)
REAL*8 :: XTAU
CHARACTER(LEN=255) :: FILENAME
! First time flag
LOGICAL, SAVE :: FIRST = .TRUE.
!=================================================================
! GET_GLOBAL_O3 begins here!
!=================================================================
! Allocate O3 array, if this is the first call
IF ( FIRST ) THEN
CALL INIT_GLOBAL_O3
FIRST = .FALSE.
ENDIF
#if defined( GRIDREDUCED )
! Filename for 30-level model
FILENAME = TRIM( DATA_DIR ) //
& 'sulfate_sim_200508/offline/MERGE.O3.30L.' //
& GET_NAME_EXT() // '.' // GET_RES_EXT()
! Echo some information to the standard output
WRITE( 6, 110 ) TRIM( FILENAME )
110 FORMAT( ' - GET_GLOBAL_O3: Reading ', a )
! Get the TAU0 value for the start of the given month
! Assume "generic" year 1985 (TAU0 = [0, 744, ... 8016])
XTAU = GET_TAU0( THISMONTH, 1, 1985 )
! Read O3 data (v/v) from the binary punch file (tracer #51)
CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 51,
& XTAU, IGLOB, JGLOB,
& LLPAR, ARRAY2, QUIET=.TRUE. )
! Assign data from ARRAY to the module variable O3
! (don't have to fold layers in the stratosphere)
O3 = ARRAY2
#else
! Filename for full vertical grid
FILENAME = TRIM( DATA_DIR ) //
& 'sulfate_sim_200508/offline/MERGE.O3.' //
& GET_NAME_EXT() // '.' // GET_RES_EXT()
! Echo some information to the standard output
WRITE( 6, 110 ) TRIM( FILENAME )
110 FORMAT( ' - GET_GLOBAL_O3: Reading ', a )
! Get the TAU0 value for the start of the given month
! Assume "generic" year 1985 (TAU0 = [0, 744, ... 8016])
XTAU = GET_TAU0( THISMONTH, 1, 1985 )
! Read O3 data (v/v) from the binary punch file (tracer #51)
CALL READ_BPCH2( FILENAME, 'IJ-AVG-$', 51,
& XTAU, IGLOB, JGLOB,
& LGLOB, ARRAY, QUIET=.TRUE. )
! Assign data from ARRAY to the module variable O3
! (folding layers in the stratosphere)
CALL TRANSFER_3D( ARRAY, O3 )
#endif
! Return to calling program
END SUBROUTINE GET_GLOBAL_O3
!------------------------------------------------------------------------------
SUBROUTINE INIT_GLOBAL_O3
!
!******************************************************************************
! Subroutine INIT_GLOBAL_O3 allocates the O3 module array.
! (bmy, 7/13/04, 1/19/07)
!
! NOTES:
! (1 ) Now references ALLOC_ERR from "error_mod.f" (bmy, 7/13/04)
! (2 ) Now dimension O3 with LLTROP (bmy, 12/1/05)
! (3 ) Now dimension O3 with LLPAR (phs, 1/19/07)
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : ALLOC_ERR
# include "CMN_SIZE" ! Size parameters
! Local variables
INTEGER :: AS
!=================================================================
! INIT_GLOBAL_O3 begins here!
!=================================================================
ALLOCATE( O3( IIPAR, JJPAR, LLPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'O3' )
O3 = 0d0
! Return to calling program
END SUBROUTINE INIT_GLOBAL_O3
!------------------------------------------------------------------------------
SUBROUTINE CLEANUP_GLOBAL_O3
!
!******************************************************************************
! Subroutine CLEANUP_GLOBAL_O3 deallocates the O3 array. (bmy, 7/13/04)
!******************************************************************************
!
!=================================================================
! CLEANUP_GLOBAL_O3 begins here!
!=================================================================
IF ( ALLOCATED( O3 ) ) DEALLOCATE( O3 )
! Return to calling program
END SUBROUTINE CLEANUP_GLOBAL_O3
!------------------------------------------------------------------------------
END MODULE GLOBAL_O3_MOD

1520
code/h2_hd_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

920
code/hcn_ch3cn_mod.f Normal file
View File

@ -0,0 +1,920 @@
! $Id: hcn_ch3cn_mod.f,v 1.1 2009/06/09 21:51:53 daven Exp $
MODULE HCN_CH3CN_MOD
!
!******************************************************************************
! Module HCN_CH3CN_MOD contains variables and routines that are used for the
! geographically tagged HCN/CH3CN simulation. (qli, xyp, bmy, 8/16/05,9/27/06)
!
! Module Variables:
! ============================================================================
! (1 ) HCN_BB_REGION : Array to denote tagged HCN biomass tracers
! (2 ) HCN_DF_REGION : Array to denote tagged HCN fossil fuel tracers
! (3 ) CH3CN_BB_REGION : Array to denote tagged CH3CN biomass tracers
! (4 ) CH3CN_DF_REGION : Array to denote tagged CH3CN fossil fuel tracers
! (5 ) EMIS_CO_df : Array for CO from domestic fossil fuel
! (6 ) HCN_INDEX : Index array for HCN tracers
! (7 ) CH3CN_INDEX : Index array for CH3CN tracers
! (8 ) SCNR89 : Weekday/weekend scenarios for fossil fuel scaling
! (9 ) TODH : Time of day scale factor for hydrocarbon emissions
! (10) TODN : Time of day scale factor for NOx emissions
! (11) TODB : Time of day scale factor for biogenic emissions
!
! Module Routines:
! ============================================================================
! (1 ) DEFINE_BB_REGIONS : Defines geographic regions for biomass burn
! (2 ) DEFINE_DF_REGIONS : Defines geographic regions for fossil fuel
! (3 ) EMISS_HCN_CH3CN : Emits into geographically "tagged" tracers
! (4 ) CHEM_HCN_CH3CN : Does chemistry for "tagged" tracers
! (5 ) INIT_HCN_CH3CN : Allocates and initializes module arrays
! (6 ) CLEANUP_HCN_CH3CN : Deallocates module arrays
!
! GEOS-Chem modules referenced by hcn_ch3cn_mod.f
! ============================================================================
! (1 ) biomass_mod.f : Module w/ routines to read biomass emissions
! (2 ) bpch2_mod.f : Module w/ routines for binary punch file I/O
! (3 ) dao_mod.f : Module w/ arrays for DAO met fields!
! (4 ) diag_mod.f : Module w/ GEOS-Chem diagnostic arrays
! (5 ) directory_mod.f : Module w/ GEOS-Chem data & met field dirs
! (6 ) geia_mod.f : Module w/ routines to read anthro emissions
! (7 ) global_oh_mod.f : Module w/ routines to read 3-D OH field
! (8 ) grid_mod.f : Module w/ horizontal grid information
! (9 ) global_oh_mod.f : Module w/ routines to read 3-D OH field
! (10) logical_mod.f : Module w/ GEOS-Chem logical switches
! (11) pbl_mix_mod.f : Module w/ routines for PBL height & mixing
! (12) time_mod.f : Module w/ routines for computing time & date
! (13) tracerid_mod.f : Module w/ pointers to tracers & emissions
! (14) transfer_mod.f : Module w/ routines to cast & resize arrays
!
!
! Tagged HCN/CH3CN tracers:
! ============================================================================
! (1 ) Total HCN
! (2 ) Total CH3CN
! (3 ) HCN from Asian biomass burning
! (4 ) HCN from elsewhere biomass burning
! (5 ) HCN from Asian domestic fossil fuel
! (6 ) HCN from elsewhere domestic fossil fuel
! (7 ) CH3CN from Asian biomass burning
! (8 ) CH3CN from elsewhere biomass burning
! (9 ) CH3CN from Asian domestic fossil fuel
! (10) CH3CN from elsewhere domestic fossil fuel
!
! References:
! ============================================================================
! (1 ) Li, Q.B., D.J. Jacob, R.M. Yantosca, C.L. Heald, H.B. Singh, M. Koike,
! Y.Zhao, G.W. Sachse, and D.G. Streets, "A Global 3-D Model Evaluation
! of the Atmospheric Budgets of HCN and CH3CN: Constraints From
! Aircraft Measurements Over the Western Pacific", J. Geophys. Res.,
! 108(D21), 2003
! (2 ) Nightingale et al [2000a], J. Geophys. Res, 14, 373-387
! (3 ) Nightingale et al [2000b], Geophys. Res. Lett, 27, 2117-2120
!
! NOTES:
! (1 ) Now use Nightingale et al [2000b] formulation for KL (bmy, 8/16/05)
! (2 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (3 ) Remove duplicate variable declarations for Linux IFORT v9 compiler
! (bmy, 11/2/05)
! (4 ) Now modified for new "biomass_mod.f" (bmy, 4/5/06)
! (5 ) BIOMASS(:,:,IDBCO) from "biomass_mod.f" is now in units of
! [molec CO/cm2/s]. Adjust unit conversion accordingly. (bmy, 9/27/06)
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE PRIVATE DECLARATIONS -- keep certain internal variables
! and routines from being seen outside "tagged_hcn_ch3cn_mod.f"
!=================================================================
! Make everything PRIVATE ...
PRIVATE
! ... except these routines
PUBLIC :: CHEM_HCN_CH3CN
PUBLIC :: CLEANUP_HCN_CH3CN
PUBLIC :: EMISS_HCN_CH3CN
!=================================================================
! MODULE VARIABLES
!=================================================================
! Scalars
REAL*8, PARAMETER :: MAIR = 28.96d-3 ! kg/mol
REAL*8, PARAMETER :: MHCN = 27d-3 ! kg/mol
REAL*8, PARAMETER :: MCH3CN = 41d-3 ! kg/mol
REAL*8, PARAMETER :: XNUMOL_AIR = 6.022d23 / MAIR ! molec/kg
REAL*8, PARAMETER :: XNUMOL_HCN = 6.022d23 / MHCN ! molec/kg
REAL*8, PARAMETER :: XNUMOL_CH3CN = 6.022d23 / MCH3CN ! molec/kg
! Allocatable arrays
INTEGER, ALLOCATABLE :: HCN_REG_bb(:,:)
INTEGER, ALLOCATABLE :: HCN_REG_df(:,:)
INTEGER, ALLOCATABLE :: CH3CN_REG_bb(:,:)
INTEGER, ALLOCATABLE :: CH3CN_REG_df(:,:)
REAL*8, ALLOCATABLE :: EMIS_CO_df(:,:)
! Fixed-size arrays
INTEGER :: HCN_INDEX(5)
INTEGER :: CH3CN_INDEX(5)
REAL*8 :: SCNR89(3,3)
REAL*8 :: TODH(6)
REAL*8 :: TODN(6)
REAL*8 :: TODB(6)
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
SUBROUTINE DEFINE_BB_REGIONS
!
!******************************************************************************
! Subroutine DEFINE_BB_REGIONS defines the geographic regions for biomass
! burning emissions for the tagged HCN/CH3CN simulation. (xyp, bmy, 6/30/05)
!
! Arguments as Input:
! ============================================================================
! (1 ) REGION (INTEGER) : Array of Fossil Fuel CO regions
!
! NOTES:
!******************************************************************************
!
! References to F90 modules
USE GRID_MOD, ONLY : GET_XMID, GET_YMID
# include "CMN_SIZE" ! Size parameters
! Local variables
INTEGER :: I, J
REAL*8 :: X, Y
!=================================================================
! DEFINE_BB_REGIONS begins here!
!=================================================================
! Loop over latitudes
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, X, Y )
DO J = 1, JJPAR
! Latitude [degrees]
Y = GET_YMID( J )
! Loop over longitudes
DO I = 1, IIPAR
! Longitude [degrees]
X = GET_XMID( I )
! Region #3: SE Asian BB HCN (1st sub-box)
IF ( ( X >= 72.5 .AND. X < 127.5 ) .AND.
& ( Y >= 8.0 .AND. Y < 28.0 ) ) THEN
HCN_REG_bb(I,J) = 3
! Region #3: SE Asian HCN BB (2nd sub-box)
ELSE IF ( ( X >= 72.5 .AND. X < 152.5 ) .AND.
& ( Y >= 28.0 .AND. Y < 48.0 ) ) THEN
HCN_REG_bb(I,J) = 3
! Region #4: HCN BB from elsewhere
ELSE
HCN_REG_bb(I,J) = 4
ENDIF
! CH3CN tracer #'s are HCN tagged tracers + 4
CH3CN_REG_bb(I,J) = HCN_REG_bb(I,J) + 4
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE DEFINE_BB_REGIONS
!------------------------------------------------------------------------------
SUBROUTINE DEFINE_DF_REGIONS
!
!******************************************************************************
! Subroutine DEFINE_DF_REGIONS defines the geographic regions for domestic
! fossil fuel emissions for the HCN/CH3CN simulation. (xyp, bmy, 6/30/05)
!
! Arguments as Output:
! ============================================================================
! (1 ) REGION (INTEGER) : Array of Fossil Fuel regions
!
! NOTES:
!******************************************************************************
!
! References to F90 modules
USE GRID_MOD, ONLY : GET_XMID, GET_YMID
# include "CMN_SIZE" ! Size parameters
! Local variables
INTEGER :: I, J
REAL*8 :: X, Y
!=================================================================
! DEFINE_DF_REGIONS begins here!
!=================================================================
! Loop over latitudes
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, X, Y )
DO J = 1, JJPAR
! Latitude [degrees]
Y = GET_YMID( J )
! Loop over longitudes
DO I = 1, IIPAR
! Longitude [degrees]
X = GET_XMID( I )
! Region #5: HCN Asian DF (1st sub-box)
IF ( ( X >= 72.5 .AND. X < 127.5 ) .AND.
& ( Y >= 8.0 .AND. Y < 28.0 ) ) THEN
HCN_REG_df(I,J) = 5
! Region #5: HCN Asian DF (2nd sub-box)
ELSE IF ( ( X >= 72.5 .AND. X < 152.5 ) .AND.
& ( Y >= 28.0 .AND. Y < 48.0 ) ) THEN
HCN_REG_df(I,J) = 5
! Region #6: HCN DF from elsewhere
ELSE
HCN_REG_df(I,J) = 6
ENDIF
! CH3CN tracer #'s are HCN tagged tracers + 4
CH3CN_REG_df(I,J) = HCN_REG_df(I,J) + 4
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE DEFINE_DF_REGIONS
!------------------------------------------------------------------------------
SUBROUTINE EMISS_HCN_CH3CN( N_TRACERS, STT )
!
!******************************************************************************
! Subroutine EMISS_HCN_CH3CN reads in CO emissions and scale them to get
! HCN/CH3CN emissions for the tagged HCN/CH3CN run. (bmy, 8/16/05, 9/27/06)
!
! Arguments as Input:
! ============================================================================
! (1 ) N_TRACERS (INTEGER) : Number of tracers
! (2 ) STT (REAL*8 ) : Tracer array [kg]
!
! NOTES:
! (1 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (2 ) Now modified for new "biomass_mod.f" (bmy, 4/5/06)
! (3 ) BIOMASS(:,:,IDBCO) from "biomass_mod.f" is now in units of
! [molec CO/cm2/s]. Adjust unit conversion accordingly. (bmy, 9/27/06)
!******************************************************************************
!
! References to F90 modules
USE BIOMASS_MOD, ONLY : BIOMASS, IDBCO
USE GEIA_MOD, ONLY : GET_DAY_INDEX, GET_IHOUR
USE GRID_MOD, ONLY : GET_AREA_CM2
USE DIAG_MOD, ONLY : AD09_em
USE LOGICAL_MOD, ONLY : LSPLIT
USE PBL_MIX_MOD, ONLY : GET_FRAC_OF_PBL, GET_PBL_MAX_L
USE TIME_MOD, ONLY : GET_MONTH, GET_TS_CHEM, GET_TAU
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! ND09
! Arguments
INTEGER, INTENT(IN) :: N_TRACERS
REAL*8, INTENT(INOUT) :: STT(IIPAR,JJPAR,LLPAR,N_TRACERS)
! Local variables
LOGICAL, SAVE :: FIRST = .TRUE.
INTEGER :: I, J, L, N, NTAU
INTEGER :: IHOUR, INDEX, MONTH, PBL_MAX
REAL*8 :: ACM2, E_CObb, E_COdf, SFAC89
REAL*8 :: HCN_bb, HCN_df, CH3CN_bb, CH3CN_df
REAL*8 :: DTSRCE, FRAC
! Emission ratios for HCN/CH3CN from biomass burning
! and domestic fossil fuel
REAL*8, PARAMETER :: EHCN_bb = 0.27d-2
REAL*8, PARAMETER :: EHCN_df = 1.60d-2
REAL*8, PARAMETER :: ECH3CN_bb = 0.20d-2
REAL*8, PARAMETER :: ECH3CN_df = 0.25d-2
! External functions
REAL*8, EXTERNAL :: BOXVL
!=================================================================
! EMISS_TAGGED_HCN_CH3CN begins here!
!=================================================================
! DTSRCE is the number of seconds per emission timestep
DTSRCE = GET_TS_CHEM() * 60d0
! Get the highest extent of the PBL [levels]
PBL_MAX = GET_PBL_MAX_L()
! Get the current month
MONTH = GET_MONTH()
! Current TAU value (integer)
NTAU = GET_TAU()
! First-time initialization
IF ( FIRST ) THEN
CALL INIT_HCN_CH3CN
FIRST = .FALSE.
ENDIF
!=================================================================
! Process biomass burning/domestic fossil fuel HCN/CH3CN emissions
!=================================================================
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, ACM2, E_CObb, INDEX, SFAC89, E_COdf )
!$OMP+PRIVATE( IHOUR, N, L, HCN_bb, HCN_df, CH3CN_bb, CH3CN_df )
DO J = 1, JJPAR
DO I = 1, IIPAR
! Grid area in [cm2]
ACM2 = GET_AREA_CM2( J )
!-----------------------------------------------------------------
! (1) Process biomass burning HCN/CH3CN emissions
!-----------------------------------------------------------------
! Get CO biomass burning [molec CO/cm2/s]
E_CObb = BIOMASS(I,J,IDBCO)
! ND09: biomass burning HCN/CH3CN emissions [molec/cm2/s]
IF ( ND09 > 0 ) THEN
AD09_em(I,J,1) = AD09_em(I,J,1) + ( EHCN_bb * E_CObb )
AD09_em(I,J,2) = AD09_em(I,J,2) + ( ECH3CN_bb * E_CObb )
ENDIF
! Convert [molec CO/cm2/s] to [mole/grid box]: 1/6.022d23 = 1.66d-24
E_CObb = E_CObb * 1.66d-24 * ACM2 * DTSRCE
!-----------------------------------------------------------------
! (2) Process domestic fossil fuel HCN/CH3CN emissions
!-----------------------------------------------------------------
! SFAC89 is the Weekday/Saturday/Sunday scale factor
INDEX = GET_DAY_INDEX( NTAU )
SFAC89 = SCNR89( 2, INDEX )
! E_COdf is DF CO emissions in [molec CO/cm2/s]
! Scale E_COdf by the day-of-week scale factor SFAC89
E_COdf = EMIS_CO_df(I,J) * SFAC89
! Scale E_COdf by the time-of-day scale factor TODH
! IHOUR is the index for the time-of-day scale factor TODH
IHOUR = GET_IHOUR( I )
E_COdf = E_COdf * TODH(IHOUR)
! Enhance E_COdf by 18.5% to account for oxidation
! from anthropogenic VOC's (bnd, bmy, 6/8/01)
E_COdf = E_COdf * 1.185d0
! Get HCN domestic fossil fuel region # (either =5 or =6)
N = HCN_REG_df(I,J)
! To achieve the best fit to the observed HCN-CH3CN-CO correlations
! in the boundary layer, we have to double the residential coal
! burning source from Asia. This leads us to reduce the residential
! coal burning source from the rest of the world by a factor of eight
! to achieve a best fit to the observed vertical distributions of HCN
! and CH3CN. [According to Li et al 2003.] (xyp, 6/22/05)
IF ( N == 5 ) THEN
E_COdf = E_COdf * 2.1d0 ! Asian domestic fossil fuel
ELSE
E_COdf = E_COdf / 8.0d0 ! Elsewhere domestic fossil fuel
ENDIF
! ND09: domestic fossil fuel HCN/CH3CN emissions [molec/cm2/s]
IF ( ND09 > 0 ) THEN
AD09_em(I,J,3) = AD09_em(I,J,3) + ( EHCN_df * E_COdf )
AD09_em(I,J,4) = AD09_em(I,J,4) + ( ECH3CN_df * E_COdf )
ENDIF
! Convert [molec CO/cm2/s] to [mole/grid box]: 1/6.022d23 = 1.66d-24
E_COdf = E_COdf * 1.66d-24 * ACM2 * DTSRCE
!-----------------------------------------------------------------
! (3) Partition emissions throughout the boundary layer
!-----------------------------------------------------------------
! Loop up to the highest PBL level
DO L = 1, PBL_MAX
! Fraction of the PBL occupied by this layer
FRAC = GET_FRAC_OF_PBL( I, J, L )
! HCN biomass and domestic fossil fuel emissions
HCN_bb = FRAC * MHCN * EHCN_bb * E_CObb
HCN_df = FRAC * MHCN * EHCN_df * E_COdf
! CH3CN biomass and domestic fossil fuel emissions
CH3CN_bb = FRAC * MCH3CN * ECH3CN_bb * E_CObb
CH3CN_df = FRAC * MCH3CN * ECH3CN_df * E_COdf
! Add total HCN emissions (BB+DF) into STT
STT(I,J,L,1) = STT(I,J,L,1) + ( HCN_bb + HCN_df )
! Add total CH3CN emissions (BB+DF) into STT
STT(I,J,L,2) = STT(I,J,L,2) + ( CH3CN_bb + CH3CN_df )
! If we are using tagged tracers ...
IF ( LSPLIT ) THEN
! Add emissions into tagged HCN biomass tracers
N = HCN_REG_bb(I,J)
STT(I,J,L,N) = STT(I,J,L,N) + HCN_bb
! Add emissions into tagged HCN dom. fossil tracers
N = HCN_REG_df(I,J)
STT(I,J,L,N) = STT(I,J,L,N) + HCN_df
! Add emissions into tagged CH3CN biomass tracers
N = CH3CN_REG_bb(I,J)
STT(I,J,L,N) = STT(I,J,L,N) + CH3CN_bb
! Add emissions into tagged CH3CN dom. fossil tracers
N = CH3CN_REG_df(I,J)
STT(I,J,L,N) = STT(I,J,L,N) + CH3CN_df
ENDIF
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE EMISS_HCN_CH3CN
!------------------------------------------------------------------------------
SUBROUTINE CHEM_HCN_CH3CN( N_TRACERS, STT )
!
!******************************************************************************
! Subroutine CHEM_HCN_CH3CN computes the loss of HCN and CH3CN due to
! reaction with OH and ocean uptake. (xyp, bmy, 8/16/05, 11/2/05)
!
! Arguments as Input:
! ============================================================================
! (1 ) FIRSTCHEM (LOGICAL) : = T if this is the first call to this routine
!
! NOTES:
! (1 ) Now use Nightingale et al [2000b] formulation for KL (bmy, 8/16/05)
! (2 ) Bug fix: remove duplicate declaration of KTMP (bmy, 11/2/05)
!******************************************************************************
!
! References to F90 modules
USE DAO_MOD, ONLY : AD, ALBD, T, TS, U10M, V10M
USE DIAG_MOD, ONLY : AD09, AD09_em
USE GLOBAL_OH_MOD, ONLY : OH, GET_GLOBAL_OH
USE GRID_MOD, ONLY : GET_AREA_CM2
USE LOGICAL_MOD, ONLY : LSPLIT
USE TIME_MOD, ONLY : GET_TS_CHEM, GET_MONTH, ITS_A_NEW_MONTH
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! ND09
# include "CMN_DEP" ! FRCLND
! Arguments
INTEGER, INTENT(IN) :: N_TRACERS
REAL*8, INTENT(INOUT) :: STT(IIPAR,JJPAR,LLPAR,N_TRACERS)
! Local variables
LOGICAL, SAVE :: FIRST = .TRUE.
INTEGER :: I, J, L, N, NN, N_MAX
REAL*8 :: K0, K1, KTMP, KRATE, TMP, DTCHEM
REAL*8 :: H, U, TC, SC, KL, KG
REAL*8 :: KKG, CL, SR, CG, FLUX
REAL*8 :: ACM2, AMT_LOST, OCEAN_HCN
REAL*8 :: FOCEAN, OCEAN_CH3CN
! Undersaturation ratios for HCN/CH3CN in seawater
REAL*8, PARAMETER :: ALPHA_HCN = 0.21d0
REAL*8, PARAMETER :: ALPHA_CH3CN = 0.12d0
! Coefficients for fitting the Schmdit number for HCN in seawater
REAL*8, PARAMETER :: A0 = 2008.917d0
REAL*8, PARAMETER :: A1 = -83.235d0
REAL*8, PARAMETER :: A2 = 1.348d0
REAL*8, PARAMETER :: A3 = -0.009d0
! Coefficients for fitting the Schmdit number for CH3CN in seawater
REAL*8, PARAMETER :: B0 = 2745.722d0
REAL*8, PARAMETER :: B1 = -113.763d0
REAL*8, PARAMETER :: B2 = 1.843d0
REAL*8, PARAMETER :: B3 = -0.012d0
! External functions
REAL*8, EXTERNAL :: BOXVL
!=================================================================
! CHEM_HCN_CH3CN begins here!
!=================================================================
! First-time initialization (if not already done)
IF ( FIRST ) THEN
CALL INIT_HCN_CH3CN
FIRST = .FALSE.
ENDIF
! Read offline OH fields once per month
IF ( ITS_A_NEW_MONTH() ) THEN
CALL GET_GLOBAL_OH( GET_MONTH() )
ENDIF
! Compute number of tracers to process
IF ( LSPLIT ) THEN
N_MAX = 5
ELSE
N_MAX = 1
ENDIF
!=================================================================
! Do HCN and CH3CN chemistry
!=================================================================
! Chemistry timestep in seconds
DTCHEM = GET_TS_CHEM() * 60d0
! Loop over grid boxes
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, K0, K1, TMP, KTMP, KRATE, NN, N, AMT_LOST )
DO L = 1, LLPAR
DO J = 1, JJPAR
DO I = 1, IIPAR
!------------------------------------------------------------------
! (1) HCN loss via reaction with OH
!------------------------------------------------------------------
K0 = 7.4d-33
K1 = 9.0d-15 * ( T(I,J,L) / 300d0 ) ** 3.2d0
TMP = K0 / K1 * AD(I,J,L) * XNUMOL_AIR / BOXVL(I,J,L)
! K: [cm3/molec/s]
KTMP = K1 * TMP / ( 1d0 + TMP )
& * EXP ( -0.511d0 / ( 1d0 + LOG10( TMP ) ** 2d0 ) )
! Rate constant for rxn w/ OH [units??]
KRATE = KTMP * OH(I,J,L) * DTCHEM
! Subtract lost HCN from STT array
DO NN = 1, N_MAX
! Get the pr
N = HCN_INDEX(NN)
! Compute the amount of tracer that is lost to OH
AMT_LOST = KRATE * STT(I,J,L,N)
! Remove lost tracer from STT array (avoid negatives!)
STT(I,J,L,N) = MAX( STT(I,J,L,N) - AMT_LOST, 0d0 )
! ND09 diagnostic: HCN/CH3CN loss via OH [kg]
IF ( ND09 > 0 ) THEN
AD09(I,J,L,N) = AD09(I,J,L,N) + AMT_LOST
ENDIF
ENDDO
!------------------------------------------------------------------
! (2) CH3CN loss via reaction with OH
!------------------------------------------------------------------
! K: [cm3/molec/s]
KTMP = 7.8d-13 * EXP( -1050d0 / T(I,J,L) )
KRATE = KTMP * OH(I,J,L) * DTCHEM
! Subtract lost CH3CN tracer from STT
DO NN = 1, N_MAX
! Get the proper tracer number
N = CH3CN_INDEX(NN)
! Compute the amount of tracer that is lost to OH
AMT_LOST = KRATE * STT(I,J,L,N)
! Remove lost CH3CN tracer from STT array (avoid negatives!)
STT(I,J,L,N) = MAX( STT(I,J,L,N) - AMT_LOST, 0d0 )
! ND09 diagnostic: CH3CN loss via OH [kg]
IF ( ND09 > 0 ) THEN
AD09(I,J,L,N) = AD09(I,J,L,N) + AMT_LOST
ENDIF
ENDDO
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
!=================================================================
! HCN and CH3CN ocean uptake
!=================================================================
! Loop over grid boxes
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, FOCEAN, OCEAN_HCN, OCEAN_CH3CN, ACM2 )
!$OMP+PRIVATE( U, TC, H, SC, KL, KG )
!$OMP+PRIVATE( KKG, NN, N, CG, FLUX, AMT_LOST )
!$OMP+SCHEDULE( DYNAMIC )
DO J = 1, JJPAR
DO I = 1, IIPAR
! Fraction of a grid box that is ocean
FOCEAN = 1d0 - FRCLND(I,J)
! Initialize HCN and CH3CN [kg] lost into the ocean
OCEAN_HCN = 0d0
OCEAN_CH3CN = 0d0
! Make sure there is > 50% ocean (not ice) in the grid box
IF ( FOCEAN > 0.5d0 .AND. ALBD(I,J) <= 0.4d0 ) THEN
! Grid box area in [cm2]
ACM2 = GET_AREA_CM2( J )
! Wind speed [m/s] at 10m above the surface
U = SQRT( U10M(I,J)**2 + V10M(I,J)**2 )
! Surface temperature [C]
TC = TS(I,J) - 273.15d0
!-----------------------------------------------------------
! (1) HCN ocean uptake
!-----------------------------------------------------------
! Henry's law constant for HCN [unitless]
H = 7.93d4 * EXP( -5000d0 / TS(I,J) )
! SC is Schmidt # for HCN in seawater [unitless]
SC = A0 + TC * ( A1 + TC * ( A2 + TC * ( A3 )))
! KL: conductance for mass transfer in liquid phase
! (Nightingale 2000b), which has unit of [cm/h]
KL = ( 0.24d0*U*U + 0.061d0*U ) * SQRT( 600d0/SC )
! KG: conductance for mass transfer in gas phase (Asher 1997)
! Convert from m/s to cm/h by multiplying 360000
KG = ( 15.3d0 + 940.6d0 * U )
! KKG: transfer velocity on a gas phase basis (Liss & Slater 1974)
! Convert from [cm/h] to [cm/s] by dividing 3600
KKG = 2.78d-4 * KL * KG / ( KL + H * KG )
! Loop over HCN tagged tracers
DO NN = 1, N_MAX
! Get HCN tagged tracer number
N = HCN_INDEX(NN)
! Bulk concentration of HCN in gas phase [kg/cm3]
CG = STT(I,J,1,N) / BOXVL(I,J,1)
! Air-to-sea flux of HCN [kg/cm2/s]
FLUX = ALPHA_HCN * KKG * CG
! Amount of tagged tracer lost to ocean [kg]
AMT_LOST = FLUX * FOCEAN * ACM2 * DTCHEM
! Save total HCN lost to ocean for ND09 diag [molec/cm2/s]
IF ( N == 1 ) THEN
OCEAN_HCN = AMT_LOST * XNUMOL_HCN / ( ACM2 * DTCHEM )
ENDIF
! Subtract ocean loss from STT array [kg/box/step]
STT(I,J,1,N) = MAX( STT(I,J,1,N) - AMT_LOST, 0d0 )
ENDDO
!-----------------------------------------------------------
! (2) CH3CN ocean uptake
!-----------------------------------------------------------
! Henry's law constant for CH3CN [unitless]
H = 861.7d0 * EXP( -4100d0 / TS(I,J) )
! SC is Schmidt # for HCN in seawater [unitless]
SC = B0 + TC * ( B1 + TC * ( B2 + TC * ( B3 )))
! KL: conductance for mass transfer in liquid phase
! (Wanninkhof 1992), which has units of [cm/h]
KL = ( 0.222d0 * U * U + 0.333d0 * U )
& * ( SC / 600d0 )**( -0.5d0 )
! KG: conductance for mass transfer in gas phase (Asher 1997)
! Convert from m/s to cm/h by mutiplying by 360000
KG = ( 12.4d0 + 763.3d0 * U )
! KKG: transfer velocity on a gas phase basis (Liss & Slater 1974)
! Convert from [cm/h] to [cm/s] by dividing by 3600
KKG = 2.78d-4 * KL * KG / ( KL + H * KG )
! Loop over CH3HCN tagged tracers
DO NN = 1, N_MAX
! Get CH3CN tagged tracer number
N = CH3CN_INDEX(NN)
! Bulk concentration of CH3CN in gas phase [kg/cm3]
CG = STT(I,J,1,N) / BOXVL(I,J,1)
! Air-to-sea flux of HCN [kg/cm2/s]
FLUX = ALPHA_HCN * KKG * CG
! Amount of tagged tracer lost to ocean [kg]
AMT_LOST = FLUX * FOCEAN * ACM2 * DTCHEM
! Save total HCN lost to ocean for ND09 diag [molec/cm2/s]
IF ( N == 2 ) THEN
OCEAN_CH3CN = AMT_LOST * XNUMOL_CH3CN / (ACM2*DTCHEM)
ENDIF
! Subtract ocean loss from STT array [kg/box/step]
STT(I,J,1,N) = MAX( STT(I,J,1,N) - AMT_LOST, 0d0 )
ENDDO
ENDIF
!--------------------------------------------------------------
! ND10 diag: Save HCN and CH3CN ocean uptake in [molec/cm2/s]
!--------------------------------------------------------------
IF ( ND09 > 0 ) THEN
AD09_em(I,J,5) = AD09_em(I,J,5) + OCEAN_HCN
AD09_em(I,J,6) = AD09_em(I,J,6) + OCEAN_CH3CN
ENDIF
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE CHEM_HCN_CH3CN
!------------------------------------------------------------------------------
SUBROUTINE READ_EMISSIONS
!
!******************************************************************************
! Subroutine READ_EMISSIONS reads the domestic fossil fuel emissions from
! disk. (bmy, 6/29/05, 10/3/05)
!
! Arguments as Output:
! ============================================================================
! (1 ) E_CO (REAL*4) : GEIA anthro CO (no seasonality, 1 level )
!
! NOTES:
! (1 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
!******************************************************************************
!
! References to F90 modules
USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE GEIA_MOD, ONLY : READ_TODX
USE TRANSFER_MOD, ONLY : TRANSFER_2D
# include "CMN_SIZE" ! Size parameters
! Local variables
REAL*4 :: ARRAY(IGLOB,JGLOB,1)
CHARACTER(LEN=255) :: FILENAME
!=================================================================
! READ_EMISSIONS begins here!
!=================================================================
! Define the binary punch file name
FILENAME = TRIM( DATA_DIR ) //
& 'HCN_200507/domfos_CO_for_TRACEP.' //
& GET_NAME_EXT_2D() // '.' // GET_RES_EXT()
! Write file name to stdout
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( 'READ_EMISSIONS: Reading ', a )
! Read time-of-day and day-of-week scale factors for GEIA emissions
CALL READ_TODX( TODN, TODH, TODB, SCNR89 )
! Read CO (tracer #4): aseasonal
CALL READ_BPCH2( FILENAME, 'ANTHSRCE', 4,
& 0d0, IGLOB, JGLOB,
& 1, ARRAY(:,:,1), QUIET=.TRUE. )
! Cast to REAL*8 and resize if necessary
CALL TRANSFER_2D( ARRAY(:,:,1), EMIS_CO_df )
! Return to calling program
END SUBROUTINE READ_EMISSIONS
!------------------------------------------------------------------------------
SUBROUTINE INIT_HCN_CH3CN
!
!******************************************************************************
! Subroutine INIT_TAGGED_HCN_CH3CN allocates memory to module arrays.
! (bmy, 6/29/05)
!
! NOTES:
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : ALLOC_ERR
# include "CMN_SIZE" ! Size parameters
! Local variables
LOGICAL, SAVE :: IS_INIT = .FALSE.
INTEGER :: AS
!=================================================================
! INIT_TAGGED_CO begins here!
!=================================================================
! Return if we have already allocated arrays
IF ( IS_INIT ) RETURN
! Allocate arrays
ALLOCATE( HCN_REG_bb( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'HCN_REG_bb' )
ALLOCATE( HCN_REG_df( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'HCN_REG_df' )
ALLOCATE( CH3CN_REG_bb( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'CH3CN_REG_bb' )
ALLOCATE( CH3CN_REG_df( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'CH3CN_REG_df' )
ALLOCATE( EMIS_CO_df( IIPAR, JJPAR ), STAT=as )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMIS_CO_df' )
! Define geographic regions for biomass burning
CALL DEFINE_BB_REGIONS
! Define geographic regions for domestic fossil fuel burning
CALL DEFINE_DF_REGIONS
! Read domestic fossil fuel emissions
CALL READ_EMISSIONS
! Index of HCN tracers
HCN_INDEX(:) = (/ 1, 3, 4, 5, 6 /)
! Index of CH3CN tracers
CH3CN_INDEX(:) = (/ 2, 7, 8, 9, 10 /)
! Set flag
IS_INIT = .TRUE.
! Return to calling program
END SUBROUTINE INIT_HCN_CH3CN
!------------------------------------------------------------------------------
SUBROUTINE CLEANUP_HCN_CH3CN
!
!******************************************************************************
! Subroutine CLEANUP_HCN_CH3CN deallocates memory from previously
! allocated module arrays (bmy, 6/23/05)
!
! NOTES:
!******************************************************************************
!
!=================================================================
! CLEANUP_HCN_CH3CN begins here!
!=================================================================
IF ( ALLOCATED( HCN_REG_bb ) ) DEALLOCATE( HCN_REG_bb )
IF ( ALLOCATED( HCN_REG_df ) ) DEALLOCATE( HCN_REG_df )
IF ( ALLOCATED( CH3CN_REG_bb ) ) DEALLOCATE( CH3CN_REG_bb )
IF ( ALLOCATED( CH3CN_REG_df ) ) DEALLOCATE( CH3CN_REG_df )
IF ( ALLOCATED( EMIS_CO_df ) ) DEALLOCATE( EMIS_CO_df )
! Return to calling program
END SUBROUTINE CLEANUP_HCN_CH3CN
!------------------------------------------------------------------------------
! End of module
END MODULE HCN_CH3CN_MOD

1377
code/htap_mod.f90 Normal file
View File

File diff suppressed because it is too large Load Diff

581
code/icoads_ship_mod.f Normal file
View File

@ -0,0 +1,581 @@
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !MODULE: icoads_ship_mod
!
! !DESCRIPTION: Module ICOADS\_SHIP\_MOD contains variables and routines to
! read the International Comprehensive Ocean-Atmosphere Data Set (ICOADS)
! ship emissions. Base year is 2002.
!\\
!\\
! !INTERFACE:
!
MODULE ICOADS_SHIP_MOD
!
! !USES:
!
IMPLICIT NONE
# include "define.h"
PRIVATE
!
! !PUBLIC MEMBER FUNCTIONS:
!
PUBLIC :: CLEANUP_ICOADS_SHIP
PUBLIC :: EMISS_ICOADS_SHIP
PUBLIC :: GET_ICOADS_SHIP
!
! !PRIVATE MEMBER FUNCTIONS:
!
PRIVATE :: ICOADS_SCALE_FUTURE
PRIVATE :: INIT_ICOADS_SHIP
PRIVATE :: TOTAL_ICOADS_SHIP_TG
!
! !REMARKS:
! Source: ICOADS Emissions data for NOx, SOx, and CO were downloaded from
! http://coast.cms.udel.edu/GlobalShipEmissions/Inventories/
!
! Reference: Wang, C., J. J. Corbett, and J. Firestone, \emph{Improving
! Spatial representation of Global Ship Emissions Inventories},
! Environ. Sci. Technol., 42, (1), 193-199, 2008.
!
! !REVISION HISTORY:
! 21 Jul 2009 - Chulkyu Lee & P. Le Sager - Initial Version
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !PRIVATE DATA MEMBERS:
!
! Array for surface area
REAL*8, ALLOCATABLE :: A_CM2(:)
! Arrays for emissions
REAL*8, ALLOCATABLE :: NOx(:,:)
REAL*8, ALLOCATABLE :: CO(:,:)
REAL*8, ALLOCATABLE :: SO2(:,:)
CONTAINS
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: get_icoads_ship
!
! !DESCRIPTION: Function GET\_ICOADS\_SHIP returns the ICOADS ship emissions
! for GEOS-Chem grid box (I,J) and tracer N. Emissions can be returned in
! units of [kg/s] or [molec/cm2/s].
!\\
!\\
! !INTERFACE:
!
FUNCTION GET_ICOADS_SHIP( I, J, N,
& MOLEC_CM2_S, KG_S ) RESULT( VALUE )
!
! !USES:
!
USE TRACER_MOD, ONLY : XNUMOL
USE TRACERID_MOD, ONLY : IDTNOx, IDTCO, IDTSO2, IDTNH3
USE TIME_MOD, ONLY : GET_YEAR, GET_MONTH
!
! !INPUT PARAMETERS:
!
! Longitude, latitude, and tracer indices
INTEGER, INTENT(IN) :: I, J, N
! OPTIONAL -- return emissions in [molec/cm2/s]
LOGICAL, INTENT(IN), OPTIONAL :: MOLEC_CM2_S
! OPTIONAL -- return emissions in [kg/s]
LOGICAL, INTENT(IN), OPTIONAL :: KG_S
!
! !RETURN VALUE:
!
! Emissions output
REAL*8 :: VALUE
!
! !REVISION HISTORY:
! 21 Jul 2009 - Chulkyu Lee & P. Le Sager - Initial Version
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
LOGICAL :: DO_KGS, DO_MCS
INTEGER :: YEAR, MONTH
REAL*8 :: SEC_IN_MONTH
!=================================================================
! GET_ICOADS_SHIP begins here!
!=================================================================
! Initialize
DO_KGS = .FALSE.
DO_MCS = .FALSE.
! Return data in [kg/s] or [molec/cm2/s]?
IF ( PRESENT( KG_S ) ) DO_KGS = KG_S
IF ( PRESENT( MOLEC_CM2_S ) ) DO_MCS = MOLEC_CM2_S
IF ( N == IDTNOx ) THEN
! NOx [kg/month]
VALUE = NOx(I,J)
ELSE IF ( N == IDTCO ) THEN
! CO [kg/month]
VALUE = CO(I,J)
ELSE IF ( N == IDTSO2 ) THEN
! SO2 [kg/month]
VALUE = SO2(I,J)
ELSE
! Otherwise return a negative value to indicate
! that there are no CAC emissions for tracer N
VALUE = -1d0
RETURN
ENDIF
!------------------------------
! Convert units (if necessary)
!------------------------------
! Get emissions year
YEAR = GET_YEAR()
! Get emissions month
MONTH = GET_MONTH()
IF ( (MONTH == 4) .OR. (MONTH == 6) .OR.
& (MONTH == 9) .OR. (MONTH == 11) ) THEN
SEC_IN_MONTH = 86400D0*30.0D0
ELSE IF (MONTH == 2) THEN
! ICOADS ship emissions for 2002
IF (MOD(YEAR,4) == 0) THEN
SEC_IN_MONTH = 86400D0*29.0D0
ELSE
SEC_IN_MONTH = 86400D0*28.0D0
ENDIF
ELSE
SEC_IN_MONTH = 86400D0*31.0D0
ENDIF
IF ( DO_KGS ) THEN
! Convert from [kg/box/month] to [kg/box/s]
VALUE = VALUE / SEC_IN_MONTH
ELSE IF ( DO_MCS ) THEN
! Convert NOx from [kg/month] to [molec/cm2/s]
VALUE = VALUE * XNUMOL(N) / ( A_CM2(J) * SEC_IN_MONTH )
ENDIF
END FUNCTION GET_ICOADS_SHIP
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: emiss_icoads_ship
!
! !DESCRIPTION: Subroutine EMISS\_ICOADS\_SHIP reads the ICOADS emission fields
! at 1x1 resolution and regrids them to the current model resolution.
!\\
!\\
! !INTERFACE:
!
SUBROUTINE EMISS_ICOADS_SHIP
!
! !USES:
!
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2
USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1
USE LOGICAL_MOD, ONLY : LFUTURE
USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1
USE TIME_MOD, ONLY : GET_YEAR, GET_MONTH
USE SCALE_ANTHRO_MOD, ONLY : GET_ANNUAL_SCALAR_1x1
# include "CMN_SIZE" ! Size parameters
# include "CMN_O3" ! FSCALYR
!USE CMN_SIZE_MOD ! Size parameters
!USE CMN_O3_MOD ! FSCALYR
!
! !REVISION HISTORY:
! 21 Jul 2009 - Chulkyu Lee & P. Le Sager - Initial Version
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
LOGICAL, SAVE :: FIRST = .TRUE.
INTEGER :: I, J, THISYEAR, SPECIES, SNo, ScNo
INTEGER :: THISMONTH
REAL*4 :: ARRAY(I1x1,J1x1,1)
REAL*8 :: GEOS_1x1(I1x1,J1x1,1)
REAL*8 :: SC_1x1(I1x1,J1x1)
REAL*8 :: TAU
CHARACTER(LEN=255) :: FILENAME
CHARACTER(LEN=4) :: SYEAR, SNAME
CHARACTER (LEN=2) :: SMONTH
!=================================================================
! EMISS_ICOADS_SHIP begins here!
!=================================================================
! First-time initialization
IF ( FIRST ) THEN
CALL INIT_ICOADS_SHIP
FIRST = .FALSE.
ENDIF
! Get emissions year
IF ( FSCALYR < 0 ) THEN
THISYEAR = GET_YEAR()
ELSE
THISYEAR = FSCALYR
ENDIF
! Get emissions month
THISMONTH = GET_MONTH()
WRITE( SMONTH, '(i2.2)' ) THISMONTH
DO SPECIES = 1,3
IF ( SPECIES .eq. 1 ) THEN
SNAME = 'NOx'
SNo = 1
ScNo = 71
ELSEIF ( SPECIES .eq. 2 ) THEN
SNAME = 'CO'
SNo = 4
ScNo = 72
ELSEIF ( SPECIES .eq. 3 ) THEN
SNAME = 'SOx'
SNo = 26
ScNo = 73
ENDIF
! TAU values for 2002
TAU = GET_TAU0( 1, 1, 2002 )
! File name
FILENAME = TRIM( DATA_DIR_1x1 ) //'ICOADS_200907/' //
& TRIM( SNAME ) // '_' // SMONTH // '.geos.1x1'
! Echo info
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( ' - EMISS_ICOADS_SHIP: Reading ', a )
! Read data
CALL READ_BPCH2( FILENAME, 'ICOADS-$', SNo,
& TAU, I1x1, J1x1,
& 1, ARRAY, QUIET=.TRUE. )
! Cast to REAL*8 before regridding
GEOS_1x1(:,:,1) = ARRAY(:,:,1)
! Convert [kg S/month] to [kg SO2/month]
IF ( SPECIES .eq. 3 ) THEN
GEOS_1X1 = GEOS_1x1*64.0D0/32.0D0
ENDIF
! Apply annual scalar factor
CALL GET_ANNUAL_SCALAR_1x1( ScNo, 2002, THISYEAR, SC_1x1 )
GEOS_1x1(:,:,1) = GEOS_1x1(:,:,1) * SC_1x1(:,:)
! Regrid from GEOS 1x1 --> current model resolution
IF ( SPECIES .eq. 1 ) THEN
GEOS_1x1 = GEOS_1x1 * 46d0 / 14d0
CALL DO_REGRID_1x1( 'kg/month', GEOS_1x1, NOx )
ELSEIF ( SPECIES .eq. 2 ) THEN
CALL DO_REGRID_1x1( 'kg/month', GEOS_1x1, CO )
ELSEIF ( SPECIES .eq. 3 ) THEN
! Convert SOx to SO2, where SOx is assumed to be 1.4% SO4 and
! 98.6% SO2 over NA, based upon Chin et al, 2000, and as
! utilized in sulfate_mod.f
GEOS_1x1(:,:,1) = GEOS_1x1(:,:,1) * 0.986
CALL DO_REGRID_1x1( 'kg/month', GEOS_1x1, SO2 )
ENDIF
ENDDO
!--------------------------
! Compute future emissions
!--------------------------
IF ( LFUTURE ) THEN
CALL ICOADS_SCALE_FUTURE
ENDIF
!--------------------------
! Print emission totals
!--------------------------
CALL TOTAL_ICOADS_SHIP_TG( THISYEAR )
END SUBROUTINE EMISS_ICOADS_SHIP
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: icoads_scale_future
!
! !DESCRIPTION: applies the IPCC future scale factors
!\\
!\\
! !INTERFACE:
SUBROUTINE ICOADS_SCALE_FUTURE
!
! !USES:
!
USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_COff
USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NOxff
USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_SO2ff
# include "CMN_SIZE" ! Size parameters
!USE CMN_SIZE_MOD ! Size parameters
!
! !REVISION HISTORY:
! 21 Jul 2009 - Chulkyu Lee & P. Le Sager - Initial Version
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: I, J
!=================================================================
! ICOADS_SCALE_FUTURE begins here!
!=================================================================
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J )
DO J = 1, JJPAR
DO I = 1, IIPAR
! Future NOx [kg NO2/month]
NOx(I,J) = NOx(I,J) * GET_FUTURE_SCALE_NOxff( I, J )
! Future CO [kg CO /month]
CO(I,J) = CO(I,J) * GET_FUTURE_SCALE_COff( I, J )
! Future SO2 [kg SO2/month]
SO2(I,J) = SO2(I,J) * GET_FUTURE_SCALE_SO2ff( I, J )
ENDDO
ENDDO
!$OMP END PARALLEL DO
END SUBROUTINE ICOADS_SCALE_FUTURE
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: total_icoads_ship_Tg
!
! !DESCRIPTION: Subroutine TOTAL\_ICOADS\_SHIP\_TG prints the totals for
! ship emissions of NOx, CO, and SO2.
!\\
!\\
! !INTERFACE:
!
SUBROUTINE TOTAL_ICOADS_SHIP_TG( MONTH )
!
! !USES:
!
# include "CMN_SIZE" ! Size parameters
!USE CMN_SIZE_MOD ! Size parameters
!
! !INPUT PARAMETERS:
!
INTEGER, INTENT(IN) :: MONTH ! Month of data to compute totals
!
! !REVISION HISTORY:
! 21 Jul 2009 - Chulkyu Lee & P. Le Sager - Initial Version
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: I, J
REAL*8 :: T_NOX, T_CO, T_SO2
CHARACTER(LEN=3) :: UNIT
!=================================================================
! TOTAL_ICOADS_SHIP_TG begins here!
!=================================================================
! Fancy output
WRITE( 6, '(a)' ) REPEAT( '=', 79 )
WRITE( 6, 100 )
100 FORMAT( 'I. C. O. A. D. S. S H I P E M I S S I O N S', / )
! Total NOx [Tg N]
T_NOX = SUM( NOx ) * 1d-9 * ( 14d0 / 46d0 )
! Total CO [Tg CO]
T_CO = SUM( CO ) * 1d-9
! Total SO2 [Tg S]
T_SO2 = SUM( SO2 ) * 1d-9 * ( 32d0 / 64d0 )
! Print totals in [kg]
WRITE( 6, 110 ) 'NOx ', MONTH, T_NOx, '[Tg N ]'
WRITE( 6, 110 ) 'CO ', MONTH, T_CO, '[Tg CO ]'
WRITE( 6, 110 ) 'SO2 ', MONTH, T_SO2, '[Tg S ]'
! Format statement
110 FORMAT( 'ICOADS ship ', a5,
& 'for month ', i4, ': ', f11.4, 1x, a8 )
! Fancy output
WRITE( 6, '(a)' ) REPEAT( '=', 79 )
END SUBROUTINE TOTAL_ICOADS_SHIP_TG
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_icoads_ship
!
! !DESCRIPTION: Subroutine INIT\_ICOADS\_SHIP allocates and zeroes all
! module arrays.
!\\
!\\
! !INTERFACE:
!
SUBROUTINE INIT_ICOADS_SHIP
!
! !USES:
!
USE ERROR_MOD, ONLY : ALLOC_ERR
USE GRID_MOD, ONLY : GET_AREA_CM2
USE LOGICAL_MOD, ONLY : LICOADSSHIP
# include "CMN_SIZE" ! Size parameters
!USE CMN_SIZE_MOD ! Size parameters
!
! !REVISION HISTORY:
! 21 Jul 2009 - Chulkyu Lee & P. Le Sager - Initial Version
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: AS, J
!=================================================================
! INIT_ICOADS_SHIP begins here!
!=================================================================
! Return if LICOADSSHIP is false
IF ( .not. LICOADSSHIP ) RETURN
!--------------------------------------------------
! Allocate and zero arrays for emissions
!--------------------------------------------------
ALLOCATE( NOx( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'NOx' )
NOx = 0d0
ALLOCATE( CO( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'CO' )
CO = 0d0
ALLOCATE( SO2( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO2' )
SO2 = 0d0
!---------------------------------------------------
! Pre-store array for grid box surface area in cm2
!---------------------------------------------------
! Allocate array
ALLOCATE( A_CM2( JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'A_CM2' )
! Fill array
DO J = 1, JJPAR
A_CM2(J) = GET_AREA_CM2( J )
ENDDO
END SUBROUTINE INIT_ICOADS_SHIP
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: cleanup_icoads_ship
!
! !DESCRIPTION: Subroutine CLEANUP\_ICOADS\_SHIP deallocates all module
! arrays.
!\\
!\\
! !INTERFACE:
!
SUBROUTINE CLEANUP_ICOADS_SHIP
!
! !REVISION HISTORY:
! 21 Jul 2009 - Chulkyu Lee & P. Le Sager - Initial Version
!EOP
!------------------------------------------------------------------------------
!BOC
!
IF ( ALLOCATED( A_CM2 ) ) DEALLOCATE( A_CM2 )
IF ( ALLOCATED( NOx ) ) DEALLOCATE( NOx )
IF ( ALLOCATED( CO ) ) DEALLOCATE( CO )
IF ( ALLOCATED( SO2 ) ) DEALLOCATE( SO2 )
END SUBROUTINE CLEANUP_ICOADS_SHIP
!EOC
END MODULE ICOADS_SHIP_MOD

240
code/ifort_errmsg.f Normal file
View File

@ -0,0 +1,240 @@
! $Id: ifort_errmsg.f,v 1.1 2009/06/09 21:51:51 daven Exp $
FUNCTION IFORT_ERRMSG( ERROR_NUM ) RESULT( MSG )
!
!******************************************************************************
! Function IFORT_ERRMSG returns an error message string that corresponds
! to an I/O error number obtained via the IOSTAT or STAT specifiers
! (bmy, 11/30/05)
!
! Arguments as Input:
! ============================================================================
! (1 ) ERROR_NUM (INTEGER) : Error condition from IOSTAT
!
! Reference:
! ============================================================================
! (1 ) Intel Fortran Language Reference, v9.0
!
! NOTES:
!******************************************************************************
!
! Arguments
INTEGER, INTENT(IN) :: ERROR_NUM
! Local variables
CHARACTER(LEN=255) :: MSG
!=================================================================
! IFORT_ERRMSG begins here!
!=================================================================
! Select a error message based on the error codes
! for Intel Fortran Compiler v9.0.
SELECT CASE( ERROR_NUM )
CASE( 0 )
MSG = ''
CASE( 1 )
MSG = 'Not a Fortran-specific error'
CASE( 8 )
MSG = 'Internal consistency check failure'
CASE( 9 )
MSG = 'Permission to access file denied'
CASE( 10 )
MSG = 'Cannot overwrite existing file'
CASE( 11 )
MSG = 'Unit not connected'
CASE( 17 )
MSG = 'Syntax error in NAMELIST input'
CASE( 18 )
MSG = 'Too many values for NAMELIST variable'
CASE( 19 )
MSG = 'Invalid reference to variable in NAMELIST input'
CASE( 20 )
MSG = 'REWIND error'
CASE( 21 )
MSG = 'Duplicate file specifications'
CASE( 22 )
MSG = 'Input record too long'
CASE( 23 )
MSG = 'Backspace error'
CASE( 24 )
MSG = 'END-OF-FILE during read'
CASE( 25 )
MSG = 'Record number outside range'
CASE( 26 )
MSG = 'OPEN or DEFINE FILE required'
CASE( 27 )
MSG = 'Too many records in I/O statement'
CASE( 28 )
MSG = 'CLOSE error'
CASE( 29 )
MSG = 'File not found'
CASE( 30 )
MSG = 'OPEN failure'
CASE( 31 )
MSG = 'Mixed file access modes'
CASE( 32 )
MSG = 'Invalid logical unit number'
CASE( 33 )
MSG = 'ENDFILE error'
CASE( 34 )
MSG = 'Unit already open'
CASE( 35 )
MSG = 'Segmented record format error'
CASE( 36 )
MSG = 'Attempt to access non-existent record'
CASE( 37 )
MSG = 'Inconsistent record length'
CASE( 38 )
MSG = 'Error during write'
CASE( 39 )
MSG = 'Error during read'
CASE( 40 )
MSG = 'Recursive I/O operation'
CASE( 41 )
MSG = 'Insufficient virtual memory'
CASE( 42 )
MSG = 'No such device'
CASE( 43 )
MSG = 'File name specification error'
CASE( 44 )
MSG = 'Inconsistent record type'
CASE( 45 )
MSG = 'Keyword value error in OPEN statement'
CASE( 46 )
MSG = 'Inconsistent OPEN/CLOSE parameters'
CASE( 47 )
MSG = 'Write to READONLY file'
CASE( 48 )
MSG = 'Invalid argument to Fortran Run-Time Library'
CASE( 51 )
MSG = 'Inconsistent file organization'
CASE( 53 )
MSG = 'No current record'
CASE( 55 )
MSG = 'DELETE error'
CASE( 57 )
MSG = 'FIND error'
CASE( 58 )
MSG = 'Format syntax error'
CASE( 59 )
MSG = 'List-directed I/O syntax error'
CASE( 60 )
MSG = 'Infinite format loop'
CASE( 61 )
MSG = 'Format/variable type mismatch'
CASE( 62 )
MSG = 'Syntax error in format'
CASE( 63 )
MSG = 'Output conversion error'
CASE( 64 )
MSG = 'Input conversion error'
CASE( 65 )
MSG = 'Floating invalid'
CASE( 66 )
MSG = 'Output statement overflows record'
CASE( 67 )
MSG = 'Input statement requires too much data'
CASE( 68 )
MSG = 'Variable format expression value error'
CASE( 69 )
MSG = 'Process interrupted (SIGINT)'
CASE( 70 )
MSG = 'Integer overflow'
CASE( 71 )
MSG = 'Integer divide by zero'
CASE( 72 )
MSG = 'Floating overflow'
CASE( 73 )
MSG = 'Floating divide by zero'
CASE( 74 )
MSG = 'Floating underflow'
CASE( 75 )
MSG = 'Floating point exception'
CASE( 76 )
MSG = 'IOT trap signal'
CASE( 77 )
MSG = 'Subscript out of range'
CASE( 78 )
MSG = 'Process killed (SIGTERM)'
CASE( 79 )
MSG = 'Process quit (SIGQUIT)'
CASE( 95 )
MSG = 'Floating-point conversion failed'
CASE( 96 )
MSG = 'F_UFMTENDIAN env variable was ignored: bad syntax'
CASE( 108 )
MSG = 'Cannot stat file'
CASE( 120 )
MSG = 'Operation requires seek ability'
CASE( 138 )
MSG = 'Array index out of bounds (SIGILL)'
CASE( 139 )
MSG = 'Array index out of bounds'
CASE( 140 )
MSG = 'Floating inexact'
CASE( 144 )
MSG = 'Reserved operand'
CASE( 145 )
MSG = 'Assertion error'
CASE( 146 )
MSG = 'Null pointer error'
CASE( 147 )
MSG = 'Stack overflow'
CASE( 148 )
MSG = 'String length error'
CASE( 149 )
MSG = 'Substring error'
CASE( 150 )
MSG = 'Range error'
CASE( 151 )
MSG = 'Allocatable array is already allocated'
CASE( 152 )
MSG = 'Unresolved contention for RTL global resource'
CASE( 153 )
MSG = 'Allocatable array or pointer is not allocated'
CASE( 173 )
MSG = 'A pointer passed to DEALLOCATE points to an array'
MSG = TRIM( MSG ) // ' that cannot be deallocated'
CASE( 174 )
MSG = 'SIGSEGV: seg fault or program stack overflow'
CASE( 175 )
MSG = 'DATE argument to DATE_AND_TIME is too short,'
MSG = TRIM( MSG ) // ' required LEN=8'
CASE( 176 )
MSG = 'TIME argument to DATE_AND_TIME is too short,'
MSG = TRIM( MSG ) // ' required LEN=10'
CASE( 177 )
MSG = 'ZONE argument to DATE_AND_TIME is too short,'
MSG = TRIM( MSG ) // ' required LEN=5'
CASE( 178 )
MSG = 'Divide by zero'
CASE( 179 )
MSG = 'Cannot allocate array:'
MSG = TRIM( MSG ) // ' overflow in array size calculation'
CASE( 256 )
MSG = 'Unformatted I/O to unit open for formatted transfers'
CASE( 257 )
MSG = 'Formatted I/O to unit open for unformatted transfers'
CASE( 264 )
MSG = 'Operation requires file to be on disk or tape'
CASE( 265 )
MSG = 'Operation requires sequential file organization'
MSG = TRIM( MSG ) // ' and access'
CASE( 266 )
MSG = 'Fortran abort routine called'
CASE( 268 )
MSG = 'End of record during read'
CASE( 269 )
MSG = 'Floating invalid traps'
CASE( 298 )
MSG = 'Floating overflow traps'
CASE( 299 )
MSG = 'Divide-by-zero traps'
CASE( 300 )
MSG = 'Floating underflow traps'
CASE DEFAULT
MSG = 'Unknown error'
END SELECT
! Return to calling program
END FUNCTION IFORT_ERRMSG

441
code/initialize.f Normal file
View File

@ -0,0 +1,441 @@
! $Id: initialize.f,v 1.3 2012/03/01 22:00:26 daven Exp $
SUBROUTINE INITIALIZE( IFLAG )
!
!******************************************************************************
! Subroutine INITIALIZE (bmy, 6/15/98, 11/18/08) does the following:
! (1) Zeroes globally defined GEOS-CHEM variables.
! (2) Zeroes accumulating diagnostic arrays.
! (3) Resets certain year/month/day and counter variables used
! in GEOS-CHEM diagnostic subroutines.
!
! NOTE: Eventually we will fold this into "diag_mod.f" in a cleaner,
! more consistent fashion. Think about this later (bmy, 11/14/02)
!
! Arguments as Input/Output
! ============================================================================
! (1 ) IFLAG : IFLAG=1, zero global CTM arrays
! : IFLAG=2, zero accumulating diagnostic arrays
! : IFLAG=3, zero accumulating diagnostic counters
!
! CTM arrays passed via COMMON blocks:
! ============================================================================
! (2 ) XTRA2 : Contains global boundary layer height in # of layers
!
! Allocatable arrays passed via F90 module "diag_mod.f"
! ============================================================================
! (-1) AD11 : ND11 array -- acetone source diagnostic
! (0 ) AD12 : ND12 array -- boundary layer emissions in "setemis.f"
! (1 ) AD13_DMS : ND13 array -- DMS emissions
! (2 ) AD13_SO2_ac : ND13 array -- SO2 aircraft emissions
! (3 ) AD13_SO2_an : ND13 array -- SO2 anthro emissions
! (4 ) AD13_SO2_bb : ND13 array -- SO2 biomass emissions
! (4a) AD13_SO2_bf : ND13 array -- SO2 biofuel emissions
! (5 ) AD13_SO2_nv : ND13 array -- SO2 non-eruptive volcano emissions
! (6 ) AD13_SO2_ev : ND13 array -- SO2 eruptive volcano emissions
! (6a) AD13_SO2_sh : ND13 array -- SO2 ship emissions
! (7 ) AD13_SO4_an : ND13 array -- SO4 anthro emissions
! (8 ) AD13_NH3_an : ND13 array -- NH3 anthro emissions
! (8a) AD13_NH3_na : ND13 array -- NH3 natural source emissions
! (9 ) AD13_NH3_bb : ND13 array -- NH3 biomass emissions
! (10) AD13_NH3_bf : ND13 array -- NH3 biofuel emissions
! (11) CONVFLUP : ND14 array -- cloud convection fluxes
! (12) TURBFLUP : ND15 array -- mass change in BL mixing
! (13) AD16 : ND16 array -- precip fractions for wetdep
! (14) AD17 : ND17 array -- rainout fractions
! (15) AD18 : ND18 array -- washout fractions
! (16) AD21 : ND21 array -- optical depths, cloud fractions
! (17) AD22 : ND22 array -- J-values
! (18) DIAGCHLORO : ND23 array -- CH3CCl3 lifetime
! (19) MASSFLEW : ND24 array -- E-W transport fluxes
! (20) MASSFLNS : ND25 array -- N-S transport fluxes
! (21) MASSFLUP : ND26 array -- vertical transport fluxes
! (22) AD31 : ND31 array -- Psurface - PTOP
! (23) AD33 : ND33 array -- tropopsheric sum of tracer
! (24) AD32_ac : ND32 array -- NOx source from aircraft
! (25) AD32_an : ND32 array -- NOx source from anthro emissions
! (26) AD32_bb : ND32 array -- NOx source from biomass burning
! (27) AD32_bf : ND32 array -- NOx source from biofuel burning
! (28) AD32_fe : ND32 array -- NOx source from fertilizers
! (29) AD32_li : ND32 array -- NOx source from lightning
! (30) AD32_so : ND32 array -- NOx source from soils
! (31) AD32_ub : ND32 array -- NOx source from upper boundary
! (32) AD34 : ND34 array -- biofuel burning emissions
! (33) AD35 : ND35 array -- tracer at 500 mb
! (34) AD37 : ND37 array -- wet scavenging fraction
! (35) AD38 : ND38 array -- rainout in wet conv
! (36) AD39 : ND39 array -- washout in aerosol deposition
! (37) AD40 : ND40 array -- prod/loss H2/HD
! (38) AD40em : ND40 array -- H2/HD emissions
! (38) AD41 : ND41 array -- afternoon PBL depths
! (39) AD43 : ND43 array -- OH, NO concentrations
! (40) AD45 : ND45 array -- tracer concentrations
! (41) AD47 : ND47 array -- 24-h avg'd tracer conc.
! (42) TCOBOX : ND48 array -- station time series
! (43) AD54 : ND54 array -- time in the troposphere (fraction)
! (44) AD55 : ND55 array -- tropopause quantities
! (45) AD65 : ND65 array -- chemical prod & loss
! (46) FAMPL : ND65 array -- accumulator for chemical prod & loss
! (47) AD66 : ND66 array -- DAO 3-D fields
! (48) AD67 : ND67 array -- DAO surface fields
! (49) AD68 : ND68 array -- boxheights, air mass, water vapor,
! Air number density
! (50) AD69 : ND69 array -- surface areas
! (51) AD19 : ND19 array -- CH4 Loss by reaction w/ OH
! (52) AD58 : ND58 array -- CH4 emissions
! (53) AD60 ; ND60 array -- Wetland Fraction
!
! Scalars & Counter variables passed via COMMON blocks
! ============================================================================
! (1 ) TAU0 : beginning of diagnostic interval
! (2 ) NTAU0 : integer representation of TAU0
! (3 ) IDAY0 : day at beginning of diagnostic interval
! (4 ) TOFDY0 : GMT at beginning of diagnostic interval
! (5 ) JDATE0 : day of month at beginning of diagnostic interval
! (6 ) JMNTH0 : month of year at beginning of diagnostic interval
! (7 ) JYEAR0 : year at beginning of diagnostic interval
! (8 ) KDA48 : Counter for timeseries accumulation (ND48 diagnostic)
! (9 ) KDACC : Counter for DIAG1
! (10) KDADYN : Counter of dynamic timesteps
! (11) KDACONV : Counter of convective timesteps
! (12) KDASRCE : Counter of emission timesteps
! (13) KDACHEM : Counter of chemistry timesteps
! (14) KDA3FLDS : Counter for # of times A-3 fields are read
! (15) KDA6FLDS : Counter for # of times A-6 fields are read
! (16) KDI6FLDS : Counter for # of times I-6 fields are read
! (17) KDKZZFLDS : Counter for # of times KZZ fields are read
!
! Dynamically allocatable counter variables passed via F90 Modules
! ============================================================================
! (1 ) CT16 : ND16 counter array
! (2 ) CT17 : ND17 counter array
! (3 ) CT18 : ND18 counter array
! (4 ) CTJV : ND22 counter array
! (5 ) AFTTOT : ND41 counter array
! (6 ) CTNO : ND43 counter array -- NO
! (7 ) CTOH : ND43 counter array -- OH
! (8 ) CTOTH : ND45 counter array
!
! NOTES:
! (1 ) INITIALIZE is written in Fixed-Form Fortran 90.
! (2 ) To ensure double precision accuracy, use 0d0 instead of 0.0.
! (3 ) Also zero the mass flux arrays from TPCORE (bmy, 4/26/99)
! (4 ) Only zero allocatable arrays that are turned on. (bmy, 11/29/99)
! (5 ) Added arrays for ND13 diagnostic -- sulfur emissions.
! Also updated comments (bmy, 6/21/00)
! (6 ) Remove SAVEJ and SAVEL -- we don't call DIAG0 anymore (bmy, 9/8/00)
! (7 ) Add array AD32_bf for ND32 NOx biofuel diagnostic (bmy, 9/12/00)
! (8 ) Also zero the FAMPL array for ND65 (bmy, 12/5/00)
! (9 ) Now initialize AD34 array for biofuel emissions (bmy, 3/15/01)
! (10) Now initialize AD12 array for boundary layer emissions in "setemis.f".
! Also made cosmetic changes & updated comments. (bdf, bmy, 6/15/01)
! (11) Now initialize AD11 array for acetone diagnostic (bmy, 8/1/01)
! (12) Remove reference to AVGF -- it is obsolete. Also, AVGW is now
! included in "dao_mod.f", and is initialized there. (bmy, 9/25/01)
! (13) Removed obsolete code from 9/01 (bmy, 10/24/01)
! (14) Make sure FAMPL is allocated before we reference it (bmy, 1/15/02)
! (15) Eliminated obsolete code from 1/02. Now also zero CTNO2, CTHO2
! counter arrays. (bmy, 2/27/02)
! (16) Bug fix: CTHO2 and CTNO2 should be zeroed if ND43 > 0, not if
! ND45 > 0. Fix this typo. (bmy, 4/19/02)
! (17) Now also zero AD01, AD02 arrays (bmy, 8/7/02)
! (18) Remove reference to arrays P, SIG, SIGE from "CMN", since we now
! use floating pressure + the hybrid grid. (dsa, bdf, bmy, 8/21/02)
! (19) Now zero the AD05 array for sulfate P-L (rjp, bdf, bmy, 9/20/02)
! (20) Now we no longer have to zero the T array. Also reference ERROR_STOP
! from "error_mod.f". Now also initialize AD13_NH3_an, AD13_NH3_bb,
! AD13_NH3_bf. (bmy, 12/13/02)
! (21) Now also zero AD13_NH3_na array for ND13 (rjp, bmy, 3/23/03)
! (22) Now references "time_mod.f" (bmy, 3/27/03)
! (23) Now zeroes AD03 array for Kr85 prod/loss diag. (jsw, bmy, 8/20/03)
! (24) Now also zeroes AD06 and AD07* arrays (rjp, tdf, bmy, 4/5/04)
! (25) Now also zeroes AD08 array (rjp, bec, bmy, 4/20/04)
! (26) Now also initialize AD13_SO2_sh array (bec, bmy, 5/20/04)
! (27) Now also initialize AD07_HC array (rjp, bmy, 7/13/04)
! (28) Now references AD65 & FAM_PL from "diag_pl_mod.f". Now remove
! reference to DIAGCHLORO, it's obsolete. (bmy, 7/20/04)
! (29) Now initialize extra arrays for ND03 mercury diag. Also remove
! reference to obsolete TOFDY0 variable. (eck, bmy, 12/7/04)
! (30) Now initialize AD21_cr array for ND21 diag. Also references
! LCRYST from "logical_mod.f" Now call ZERO_DIAG03 from "diag03_mod.f"
! to zero ND03 arrays (bmy, 1/21/05)
! (31) Now call ZERO_DIAG41 from "diag41_mod.f". Also removed references
! to AD41 and AFTTOT. (bmy, 2/17/05)
! (32) Now zero AD09 and AD09_em for HCN simulation (xyp, bmy, 6/27/05)
! (33) Now references ND04, ZERO_DIAG04 from "diag04_mod.f". Also remove
! reference to "CMN" and XTRA2. Now zeroes AD30 array (bmy, 8/18/05)
! (34) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (35) Now resets SET_CT_XTRA at the beginning of the run. (tmf, 10/20/05)
! (36) Now references ND56, ZERO_DIAG56 from "diag56_mod.f" (ltm, bmy, 5/5/06)
! (37) Now references ND42, ZERO_DIAG42 from "diag42_mod.f" (dkh, bmy,5/22/06)
! (38) take care of AD54 (time in the troposphere diagnostic) (phs, 10/17/06)
! (39) Now also zero CTO3 array. Bug fix: ZERO_DIAG42 is now called when
! ND42 is turned on. (phs, bmy, 1/30/07)
! (40) Now zero AD10 and AD10em for H2HD simulation (phs, 9/18/07)
! (41) Now zero CTO3_24h (phs, 11/17/08)
! (42) Now zero AD52 for Gamma HO2 diag. (ccc, jaegle, 2/26/09)
! (43) Updated to diagnose GLYX production of SOAG in ND07. (tmf, 1/7/09)
! (44) Add AD19, AD58, AD60 (kjw, dkh, 02/12/12, adj32_023)
!******************************************************************************
!
! References to F90 modules
USE DIAG_MOD, ONLY : AD01, AD02, AD05
USE DIAG_MOD, ONLY : AD06, AD07, AD07_BC
USE DIAG_MOD, ONLY : AD07_OC, AD07_HC, AD08
USE DIAG_MOD, ONLY : AD07_SOAGM
USE DIAG_MOD, ONLY : AD09, AD09_em, AD11
USE DIAG_MOD, ONLY : AD12, AD13_DMS, AD13_SO2_ac
USE DIAG_MOD, ONLY : AD13_SO2_an, AD13_SO2_bb, AD13_SO2_bf
USE DIAG_MOD, ONLY : AD13_SO2_ev, AD13_SO2_nv, AD13_SO4_an
USE DIAG_MOD, ONLY : AD13_SO4_bf, AD13_SO2_sh, AD13_NH3_an
USE DIAG_MOD, ONLY : AD13_NH3_na, AD13_NH3_bb, AD13_NH3_bf
USE DIAG_MOD, ONLY : CONVFLUP, TURBFLUP, AD16
USE DIAG_MOD, ONLY : CT16, AD17, CT17
USE DIAG_MOD, ONLY : AD18, CT18, AD21
USE DIAG_MOD, ONLY : AD21_cr, AD22, LTJV
USE DIAG_MOD, ONLY : CTJV, MASSFLEW, MASSFLNS
USE DIAG_MOD, ONLY : MASSFLUP, AD28, AD29
USE DIAG_MOD, ONLY : AD30, AD31
USE DIAG_MOD, ONLY : AD32_ac, AD32_an, AD32_bb
USE DIAG_MOD, ONLY : AD32_bf, AD32_fe, AD32_li
USE DIAG_MOD, ONLY : AD32_so, AD32_ub, AD33
USE DIAG_MOD, ONLY : AD32_ship, AD32_ship_count
USE DIAG_MOD, ONLY : AD34, AD35, AD36
USE DIAG_MOD, ONLY : AD36_SHIP, AD36_SHIP_COUNT
USE DIAG_MOD, ONLY : AD37, AD38, AD39
USE DIAG_MOD, ONLY : AD43, LTNO
USE DIAG_MOD, ONLY : CTNO, LTOH, CTOH
USE DIAG_MOD, ONLY : LTHO2, CTHO2, LTNO2
USE DIAG_MOD, ONLY : CTNO2, LTNO3, CTNO3
USE DIAG_MOD, ONLY : AD44, AD45, LTOTH
USE DIAG_MOD, ONLY : CTOTH, AD46, AD47
USE DIAG_MOD, ONLY : AD52
USE DIAG_MOD, ONLY : AD54, CTO3, CTO3_24h
USE DIAG_MOD, ONLY : AD55, AD66, AD67
USE DIAG_MOD, ONLY : AD19, AD58, AD60
USE DIAG_MOD, ONLY : AD68, AD69
USE DIAG_MOD, ONLY : AD10, AD10em
USE DIAG03_MOD, ONLY : ND03, ZERO_DIAG03
USE DIAG04_MOD, ONLY : ND04, ZERO_DIAG04
USE DIAG41_MOD, ONLY : ND41, ZERO_DIAG41
USE DIAG42_MOD, ONLY : ND42, ZERO_DIAG42
USE DIAG56_MOD, ONLY : ND56, ZERO_DIAG56
! diag59 added, (lz, 10/11/10)
USE DIAG59_MOD, ONLY : ND59, ZERO_DIAG59
USE DIAG_PL_MOD, ONLY : AD65, FAM_PL
USE ERROR_MOD, ONLY : ERROR_STOP
USE LOGICAL_MOD, ONLY : LCRYST
USE TIME_MOD
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! NDxx flags
! Arguments
INTEGER, INTENT(IN) :: IFLAG
!=================================================================
! INITIALIZE begins here!
!
! Error condition if IFLAG does not equal 2, or 3!
!=================================================================
IF ( IFLAG < 2 .or. IFLAG > 3 ) THEN
CALL ERROR_STOP( 'Invalid IFLAG!', 'initialize.f' )
ENDIF
!=================================================================
! If IFLAG=2 then zero the accumulating arrays
!=================================================================
IF ( IFLAG == 2 ) THEN
! Allocatable arrays are zeroed only if their
! respective diagnostics are turned on (bmy, 2/17/00)
IF ( ND01 > 0 ) AD01 = 0e0
IF ( ND02 > 0 ) AD02 = 0e0
IF ( ND05 > 0 ) AD05 = 0e0
IF ( ND06 > 0 ) AD06 = 0e0
IF ( ND08 > 0 ) AD08 = 0e0
IF ( ND11 > 0 ) AD11 = 0e0
IF ( ND12 > 0 ) AD12 = 0e0
IF ( ND14 > 0 ) CONVFLUP = 0d0
IF ( ND15 > 0 ) TURBFLUP = 0d0
IF ( ND16 > 0 ) AD16 = 0e0
IF ( ND17 > 0 ) AD17 = 0e0
IF ( ND18 > 0 ) AD18 = 0e0
IF ( ND22 > 0 ) AD22 = 0e0
IF ( ND24 > 0 ) MASSFLEW = 0d0
IF ( ND25 > 0 ) MASSFLNS = 0d0
IF ( ND26 > 0 ) MASSFLUP = 0d0
IF ( ND28 > 0 ) AD28 = 0e0
IF ( ND29 > 0 ) AD29 = 0e0
IF ( ND30 > 0 ) AD30 = 0e0
IF ( ND31 > 0 ) AD31 = 0e0
IF ( ND33 > 0 ) AD33 = 0e0
IF ( ND34 > 0 ) AD34 = 0e0
IF ( ND35 > 0 ) AD35 = 0e0
IF ( ND36 > 0 ) AD36 = 0e0
IF ( ND37 > 0 ) AD37 = 0e0
IF ( ND38 > 0 ) AD38 = 0e0
IF ( ND39 > 0 ) AD39 = 0e0
IF ( ND43 > 0 ) AD43 = 0e0
IF ( ND44 > 0 ) AD44 = 0e0
IF ( ND45 > 0 ) AD45 = 0e0
IF ( ND46 > 0 ) AD46 = 0e0
IF ( ND47 > 0 ) AD47 = 0e0
IF ( ND52 > 0 ) AD52 = 0e0
IF ( ND54 > 0 ) AD54 = 0e0
IF ( ND55 > 0 ) AD55 = 0e0
IF ( ND19 > 0 ) AD19 = 0e0
IF ( ND58 > 0 ) AD58 = 0e0
IF ( ND60 > 0 ) AD60 = 0e0
IF ( ND66 > 0 ) AD66 = 0e0
IF ( ND67 > 0 ) AD67 = 0e0
IF ( ND68 > 0 ) AD68 = 0e0
IF ( ND69 > 0 ) AD69 = 0e0
! For ND03 - mercury simulations (eck, sas, bmy, 1/20/05)
IF ( ND03 > 0 ) THEN
CALL ZERO_DIAG03
ENDIF
! For ND04 - CO2 simulation (pns, bmy, 7/26/05)
IF ( ND04 > 0 ) THEN
CALL ZERO_DIAG04
ENDIF
! ND07 -- carbon aerosol emissions (rjp, tdf, bmy, 4/5/04)
IF ( ND07 > 0 ) THEN
AD07 = 0e0
AD07_BC = 0e0
AD07_OC = 0e0
AD07_HC = 0e0
AD07_SOAGM = 0e0
ENDIF
! ND09 -- HCN & CH3CN simulation (xyp, bmy, 6/27/05)
IF ( ND09 > 0 ) THEN
AD09 = 0e0
AD09_em = 0e0
ENDIF
! For ND10 -- H2 & HD simulation (phs, 9/18/07)
IF ( ND10 > 0 ) THEN
AD10 = 0e0
AD10em = 0e0
ENDIF
! For ND13 - sulfur emissions (bmy, 6/6/00, 5/20/04)
IF ( ND13 > 0 ) THEN
AD13_DMS = 0e0
AD13_SO2_ac = 0e0
AD13_SO2_an = 0e0
AD13_SO2_bb = 0e0
AD13_SO2_bf = 0e0
AD13_SO2_nv = 0e0
AD13_SO2_ev = 0e0
AD13_SO2_sh = 0e0
AD13_SO4_an = 0e0
AD13_SO4_bf = 0e0
AD13_NH3_an = 0e0
AD13_NH3_na = 0e0
AD13_NH3_bb = 0e0
AD13_NH3_bf = 0e0
ENDIF
! ND21 -- optical depths
IF ( ND21 > 0 ) THEN
AD21 = 0e0
IF ( LCRYST ) AD21_cr = 0e0
ENDIF
! For ND32 -- NOx source diagnostics (bmy, 3/28/00)
IF ( ND32 > 0 ) THEN
AD32_ac = 0e0
AD32_an = 0e0
AD32_bb = 0e0
AD32_bf = 0e0
AD32_fe = 0e0
AD32_li = 0e0
AD32_so = 0e0
AD32_ub = 0e0
AD32_ship = 0e0
AD32_ship_count = 0e0
ENDIF
IF ( ND36 > 0 ) THEN
AD36 = 0e0
AD36_SHIP = 0e0
AD36_SHIP_COUNT = 0
ENDIF
! For ND41 - afternoon PBL heights (bmy, 2/17/05)
IF ( ND41 > 0 ) THEN
CALL ZERO_DIAG41
ENDIF
! For ND42 - SOA concentrations (dkh, bmy, 5/22/06)
IF ( ND42 > 0 ) THEN
CALL ZERO_DIAG42
ENDIF
! For ND56 - lightning flash rates (bmy, 5/5/06)
IF ( ND56 > 0 ) THEN
CALL ZERO_DIAG56
ENDIF
! For ND59 - NH3 concentrations (diag59 added, lz,10/11/10)
IF ( ND59 > 0 ) THEN
CALL ZERO_DIAG59
ENDIF
! For ND65 -- Chemical production & loss (bmy, 12/5/00)
IF ( ND65 > 0 ) THEN
AD65 = 0e0
IF ( ALLOCATED( FAM_PL ) ) FAM_PL = 0d0
ENDIF
! Echo output
WRITE( 6, '(a)' ) ' - INITIALIZE: Diag arrays zeroed!'
ENDIF
!=================================================================
! If IFLAG=3 then zero the counter variables & arrays
!=================================================================
IF ( IFLAG == 3 ) THEN
! Now reset timesteps here for now
CALL SET_CT_A1( RESET=.TRUE. ) !! geos-fp (lzh,07/10/2014)
CALL SET_CT_A3( RESET=.TRUE. )
CALL SET_CT_A6( RESET=.TRUE. )
CALL SET_CT_CHEM( RESET=.TRUE. )
CALL SET_CT_CONV( RESET=.TRUE. )
CALL SET_CT_DYN( RESET=.TRUE. )
CALL SET_CT_EMIS( RESET=.TRUE. )
CALL SET_CT_I6( RESET=.TRUE. )
CALL SET_CT_I3( RESET=.TRUE. ) !! geos-fp (lzh,07/10/2014)
CALL SET_CT_XTRA( RESET=.TRUE. )
! Leave the ND48 counter for now
KDA48 = 0
! Allocatable counter arrays
IF ( ND16 > 0 ) CT16 = 0
IF ( ND17 > 0 ) CT17 = 0
IF ( ND18 > 0 ) CT18 = 0
IF ( ND22 > 0 ) CTJV = 0
IF ( ND43 > 0 ) CTNO = 0
IF ( ND43 > 0 ) CTOH = 0
IF ( ND45 > 0 ) CTOTH = 0
IF ( ND45 > 0 ) CTO3 = 0
IF ( ND47 > 0 .OR. ND65 > 0 ) CTO3_24h = 0
IF ( ND43 > 0 ) CTNO2 = 0
IF ( ND43 > 0 ) CTHO2 = 0
IF ( ND43 > 0 ) CTNO3 = 0
! Echo output
WRITE( 6, '(a)' ) ' - INITIALIZE: Diag counters zeroed!'
ENDIF
! Return to calling program
END SUBROUTINE INITIALIZE

83
code/inphot.f Normal file
View File

@ -0,0 +1,83 @@
! $Id: inphot.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE INPHOT( NLAYER, NREACS )
!
!******************************************************************************
! Subroutine INPHOT initializes quantities for FAST-J photolysis, including
! JPL spectral data (e.g. cross sections, quantum yields), standard O3 and T
! profiles, and the translation indices between GEOS-Chem and FAST-J species
! names. (Oliver Wild, 4/99, ppm, bmy, 9/7/99, 5/10/10)
!
! Arguments as Input:
! ============================================================================
! (1 ) NLAYER (INTEGER) : Number of layers for FAST-J photolysis
! (2 ) NREACS (INTEGER) : Total # of photolysis reactions for FAST-J
!
! NOTES:
! (1 ) Remove PTOP from the arg list, since it is now a
! parameter in "CMN_SIZE" (bmy, 2/10/00).
! (2 ) Remove SIGE from the argument list, since we are now using
! a hybrid pressure specification. Now define ETAA and ETAB
! for use in "set_prof.f". (bmy, 8/23/02)
! (3 ) Now reference ERROR_STOP from "error_mod.f". Updated comments and
! made cosmetic changes (bmy, 10/15/02)
! (4 ) Remove IPH -- now use IU_FASTJ directly (bmy, 4/8/03)
! (5 ) Removed ETAA and ETAB arrays. We now compute PJ directly from the
! GET_PEDGE routine. Also remove reference to "pressure_mod.f".
! Updated comments. (bmy, 10/30/07)
! (6 ) Read jv_spec_aod.dat file for AOD diagnostics. (clh, bmy, 5/10/10)
!******************************************************************************
!
! References to F90 modules (bmy, 6/27/02)
USE ERROR_MOD, ONLY : ERROR_STOP
USE FILE_MOD, ONLY : IU_FASTJ
IMPLICIT NONE
# include "cmn_fj.h"
# include "jv_cmn.h"
! Arguments
INTEGER, INTENT(IN) :: NLAYER, NREACS
!=================================================================
! INPHOT begins here!
!=================================================================
! # of layers to do chemistry
JPNL = NLAYER
! # of reactions in chemistry
JPPJ = NREACS + 4
! Error check # of layers
IF ( JPNL > LPAR ) THEN
CALL ERROR_STOP( 'JPNL > LPAR!', 'inphot.f' )
ENDIF
! Error check # of rxns
IF ( JPPJ > JPMAX ) THEN
CALL ERROR_STOP( 'JPPJ > JPMAX!', 'inphot.f' )
ENDIF
! Read in labels of photolysis rates required
CALL RD_JS( IU_FASTJ, 'ratj.d' )
! Call JV_INDEX to translate between GEOS-Chem species
! nomenclature and Fast-J species nomenclature (bmy, 9/13/99)
CALL JV_INDEX
! Read in JPL spectral data set (e.g. X-sections, quantum yields)
CALL RD_TJPL( IU_FASTJ, 'jv_spec.dat' )
WRITE(*,*) 'Trying to read jv_spec_aod.dat'
! Read in aerosol optics to be used to calculate AODs (clh)
CALL RD_AOD( IU_FASTJ, 'jv_spec_aod.dat' )
! Read in T & O3 climatology (cf. Nagatani/92 and McPeters/91)
CALL RD_PROF( IU_FASTJ, 'jv_atms.dat' )
! Select Aerosol/Cloud types to be used
CALL SET_AER
! Return to calling program
END SUBROUTINE INPHOT

197
code/inquireMod.F90 Normal file
View File

@ -0,0 +1,197 @@
#if defined( ESMF_ )
! We only need to refer to this include file if we are connecting
! to the GEOS-5 GCM via the ESMF/MAPL framework (bmy, 8/3/12)
#include "MAPL_Generic.h"
#endif
!------------------------------------------------------------------------
! NASA/GSFC, Global Modeling and Assimilation Office, Code 910.1 !
!------------------------------------------------------------------------
!BOP
!
! !MODULE: inquireMod
!
! !DESCRIPTION: Module inquireMod contains functions to find free and
! unopened logical file units (LUNs) for Fortran I/O.
!
! !INTERFACE:
!
MODULE inquireMod
!
! !USES:
!
#if defined( ESMF_ )
! We only need to refer to these modules if we are connecting
! to the GEOS-5 GCM via the ESMF/MAPL framework (bmy, 8/3/12)
USE ESMF_Mod
USE MAPL_Mod
#endif
IMPLICIT NONE
PRIVATE
!
! !PUBLIC MEMBER FUNCTIONS:
!
PUBLIC :: findFreeLUN
PUBLIC :: I_Am_UnOPENed
!
! !REVISION HISTORY:
! 14 Jun 2012 - E. Nielsen - Initial version
! 03 Aug 2012 - R. Yantosca - Block off ESMF-specific code with #ifdefs
! 03 Aug 2012 - R. Yantosca - Cosmetic changes
!EOP
!------------------------------------------------------------------------------
!BOC
CONTAINS
!EOC
!------------------------------------------------------------------------
! NASA/GSFC, Global Modeling and Assimilation Office, Code 910.1 !
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: findFreeLUN
!
! !DESCRIPTION: Inquire for an existing, but unopened, logical unit number
!\\
!\\
! !INTERFACE:
!
FUNCTION findFreeLUN( b ) RESULT( lun )
!
! !USES:
!
IMPLICIT NONE
!
! !INPUT PARAMETERS:
!
INTEGER, INTENT(IN), OPTIONAL :: b ! Not really used here
!
! !RETURN VALUE:
!
INTEGER :: lun
!
! !REVISION HISTORY:
! 14 Jun 2012 - E. Nielsen - Initial version
! 03 Aug 2012 - R. Yantosca - Block off ESMF-specific code with #ifdefs
! 03 Aug 2012 - R. Yantosca - Cosmetic changes
! 06 Aug 2012 - R. Yantosca - Now make LUN range 11..199
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: i, rc, status
LOGICAL :: exists ! File existence
LOGICAL :: found ! Detect unused logical unit
LOGICAL :: open ! Is open?
#if defined( ESMF_ )
CHARACTER(LEN=ESMF_MAXSTR) :: Iam
#else
CHARACTER(LEN=255) :: Iam
#endif
!
! !DEFINED PARAMETERS
!
INTEGER, PARAMETER :: iTop = 199 ! Maximum LUN limit
!======================================================================
! Initialization
!======================================================================
Iam = "GEOSCHEMCHEM::findFreeLUN"
status = 0
rc = 0
!======================================================================
! Find an available logical unit
!======================================================================
found = .FALSE.
i = 11
DO WHILE ( .NOT. found .AND. i <= iTop )
INQUIRE( UNIT=i, EXIST=exists, OPENED=open )
IF ( exists .AND. .NOT. open ) THEN
found = .TRUE.
lun = i
ENDIF
i = i + 1
ENDDO
IF ( .NOT. found ) THEN
status = 1
PRINT *,TRIM( Iam ) // ": No available logical units"
ENDIF
#if defined( ESMF_ )
VERIFY_(status)
#endif
END FUNCTION findFreeLUN
!EOC
!------------------------------------------------------------------------
! NASA/GSFC, Global Modeling and Assimilation Office, Code 910.1 !
!------------------------------------------------------------------------
!BOP
!
! !IROUTINE: I_Am_UnOPENed
!
! !DESCRIPTION: Inquire as to the availability of a given logical unit
!\\
!\\
! !INTERFACE:
!
FUNCTION I_Am_UnOPENed( n ) RESULT( TorF )
!
! !USES:
!
IMPLICIT NONE
!
! !INPUT PARAMETERS:
!
INTEGER :: n ! Logical unit # to test
!
! !RETURN VALUE:
!
LOGICAL :: TorF ! .TRUE. means the file is unopened
!
! !REVISION HISTORY:
! 14 Jun 2012 - E. Nielsen - Initial version
! 03 Aug 2012 - R. Yantosca - Block off ESMF-specific code with #ifdefs
! 03 Aug 2012 - R. Yantosca - Cosmetic changes
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: rc, status
LOGICAL :: exists ! File existence
LOGICAL :: open ! Is open?
#if defined( ESMF_ )
CHARACTER(LEN=ESMF_MAXSTR) :: Iam
#else
CHARACTER(LEN=255) :: Iam
#endif
!======================================================================
! Initialization
!======================================================================
Iam = "GEOSCHEMCHEM::I_Am_UnOPENed"
status = 0
rc = 0
!======================================================================
! Inquire if the LUN is available
!======================================================================
INQUIRE( UNIT=n, EXIST=exists, OPENED=open )
IF ( exists .AND. .NOT. open ) THEN
TorF = .TRUE.
ELSE
TorF = .FALSE.
ENDIF
END FUNCTION I_Am_UnOPENed
!EOC
END MODULE inquireMod

865
code/jsparse.f Normal file
View File

@ -0,0 +1,865 @@
! $Id: jsparse.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE JSPARSE
!
!******************************************************************************
! Subroutine JSPARSE sets up the sparse-matrix arrays for SMVGEAR II.
! (M. Jacobson 1993; bdf, bmy, 4/18/03)
!
! NOTES:
! (1 ) For GEOS-CHEM we had to remove T3 from "comode.h" and to declare it
! allocatable in "comode_mod.f". This allows us to only allocate it
! if we are doing a fullchem run. Write list of repeat reactants to
! and change in moles to "smv2.log". Now call GEOS_CHEM_STOP to
! deallocate all arrays and stop the run safely. Now force double
! precision with "D" exponents. (bmy, 4/18/03)
!******************************************************************************
!
! References to F90 modules
USE COMODE_MOD, ONLY : T3
USE ERROR_MOD, ONLY : GEOS_CHEM_STOP
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "comode.h" ! SMVGEAR II arrays
C
C *********************************************************************
C ************ WRITTEN BY MARK JACOBSON (1993) ************
C *** (C) COPYRIGHT, 1993 BY MARK Z. JACOBSON ***
C *** U.S. COPYRIGHT OFFICE REGISTRATION NO. TXu 670-279 ***
C *** (650) 723-6836 ***
C *********************************************************************
C
C JJ SSSSSSS PPPPPPP A RRRRRRR SSSSSSS EEEEEEE
C J S P P A A R R S E
C J SSSSSSS PPPPPPP A A RRRRRRR SSSSSSS EEEEEEE
C J J S P AAAAAAA R R S E
C JJJJJJJ SSSSSSS P A A R R SSSSSSS EEEEEEE
C
C *********************************************************************
C * THIS ROUTINE SETS UP SPARSE-MATRIX AND OTHER ARRAYS FOR SMVGEAR *
C * (SPARSE-MATRIX VECTORIZED GEAR-CODE. IT SETS ARRAYS FOR GAS- *
C * -PHASE, AQUEOUS-PHASE, AND ANY OTHER TYPE OF CHEMISTRY. IT ALSO *
C * SETS ARRAYS FOR BOTH DAY AND NIGHT CHEMISTRY OF EACH TYPE. *
C * *
C * HOW TO CALL SUBROUTINE: *
C * ---------------------- *
C * CALL JSPARSE.F FROM READCHEM.F WITH *
C * NCS = 1..NCSGAS FOR GAS CHEMISTRY *
C *********************************************************************
C
C *********************************************************************
C ******* SETS UP ARRAYS FOR GAS- AND AQUEOUS-PHASE CHEMISTRY ********
C * INCLUDES ARRAYS FOR CALCULATING FIRST DERIVATIVES, PARTIAL DERIV- *
C * ATIVES, MATRIX DECOMPOSTION, AND MATRIX BACK-SUBSTITUTION. FIRST, *
C * JSPARSE RE-ORDERS THE ORDINARY DIFFERENTIAL EQUATIONS TO MAXIMIZE *
C * THE NUMBER OF ZEROS IN THE MATRIX OF PARTIAL DERIVATIVES. IT *
C * LATER SETS ARRAYS TO ELIMINATE ALL CALCULATIONS INVOLVING A ZERO. *
C *********************************************************************
*
C NTSPEC = TOTAL NUMBER OF ACTIVE + INACTIVE SPECIES.
C NSPEC = TOTAL NUMBER OF ACTIVE SPECIES.
C NMREAC = 3 = MAXIMUM NUMBER OF ACTIVE REACTANTS IN A REACTION
C NALLREAC = 4 = TOTAL REACTANT POSITIONS IN A REACTION
C NMPROD = 5 = MAXIMUN NUMBER OF ACTIVE PRODUCTS IN A REACTION
C NPRODLO = NALLREAC + 1 = LOWEST PRODUCT POSITION NUMBER.
C NPRODHI = NALLREAC + NMPROD = HIGHEST PRODUCT POSITION NUMBER.
C
C *********************************************************************
C * DETERMINE HOW MANY PARTIAL DERIV TERMS ARE NEEDED FOR EACH SPECIES*
C *********************************************************************
C IFREPRO = 1 THEN SPECIES IS LOST AND REPRODUCED IN REACTION NK
C IRM = SPECIES # OF EACH REACT OR PRODUCT IN EACH NK REACTION
C ISAPORL = COUNTS PARTIAL DERIVATIVE TERMS FOR EACH SPECIES
C FKOEF = 1, 2, FRACTION, OR MORE = # OF A GIVEN REACTANT OR PRODUCTS
C E.G. REACTION A + B --> 2C + 0.34D + D
C VALUE OF FKOEF 1 1 2 0.34 1
C NCS = 1..NCSGAS FOR GAS CHEMISTRY
C NCSP = NCS FOR DAYTIME GAS CHEM
C = NCS +ICS FOR NIGHTTIME GAS CHEM
C NK = REACTION # OF EACH REACTION
C NRATES = NUMBER OF KINETIC (NON-PHOTO) RATE COEFFICIENTS
C NTRATES = NUMBER OF KINETIC PLUS PHOTO RATE COEFFICIENTS
C NALLRAT = NUMBER OF KINETIC PLUS PHOTO REACTION RATES
C
INTEGER NREPT,I,J,NAR,NK,K,IREACT,L,IPO,NOCHANG,JOLD,JNEW
INTEGER MINVALU,IMINOLD,IMINNEW,INEW,IOLD,NKLAST,IAL,IRE
INTEGER NMO,NOL,ISDIFF,IB,JSPCL,ISPC1,ISPC2,ISPC3,IAP,IPROD
INTEGER IPR,LFRAC,NGN,KPRODS,KDIF,NPL,IC,NK1,NTWO,ICB,ICD
INTEGER NKN,IGR,ISP,NSP,NGR,NGTSUM,NLTSUM,NGSUM,NLSUM,NGFSUM
INTEGER N,JGAS,NA,IHIREAC,JAL,JRE,JPR
INTEGER KNUMPORL,NCCOUNT,NREMAIN,NFIVE,NFOUR,NTHREE,NONE,MC
INTEGER IR,JR,IAR,JP,JSPC
REAL*8 RFRAC,ALFRAC,DIFF,TNUMGNA,TNUMGN
REAL*8 TNUMLS,SUMGN,TSUMGNA,TNUMLSA
INTEGER, SAVE :: NPLTOT,NPLFUN,NFRCOUN,NPDCOUN
NCSP = NCS + ICS
NREPT = 0
C
DO 30 I = 1, MXGSAER
ISAPORL( I) = 0
30 CONTINUE
C
DO 33 I = 1, MAXGL
NEWNK(I) = 0
33 CONTINUE
C
DO 42 I = 1, MXGSAER
DO 41 J = 1, MXGSAER
ISPARDER(I,J) = 0
41 CONTINUE
42 CONTINUE
C
DO 100 NAR = 1, NALLRAT(NCS)
NK = NCEQUAT(NAR,NCS)
IF (NK.LE.NRATES(NCS)) NALLRAT(NCSP) = NAR
DO 60 K = 1, NMREAC
IREACT = IRM(K,NK,NCS)
IF (IREACT.GT.0.AND.IREACT.LE.NSPEC(NCS)) THEN
DO 50 L = 1, NPRODHI
IPO = IRM(L,NK,NCS)
IF ((L.LE.NMREAC.OR.L.GE.NPRODLO).AND.IPO.GT.0.AND.
1 IPO.LE.NSPEC(NCS)) ISPARDER(IPO,IREACT) = 1
50 CONTINUE
ENDIF
60 CONTINUE
100 CONTINUE
C CONTINUE NAR = 1, NALLRAT
C
DO 72 IREACT = 1, NTSPEC(NCS)
DO 70 IPO = 1, NTSPEC(NCS)
IF (ISPARDER(IPO,IREACT).EQ.1) ISAPORL(IPO)=ISAPORL(IPO)+1
70 CONTINUE
72 CONTINUE
C
C *********************************************************************
C * RE-ARRAGE SPECIES ARRAY SO THAT ALL SPECIES WITH AT LEAST ONE *
C * PARTIAL DERIVATIVE TERM APPEAR FIRST, AND THOSE WITH ZERO *
C * APPEAR LAST. *
C *********************************************************************
C ISCHANG = NUMBER OF ORIGINAL NSPEC SPECIES WITH AT LEAST ONE PD TERM.
C INEWOLD = ORIGINAL SPECIES NUMBER OF EACH NEW JNEW SPECIES
C MAPPL = NEW SPECIES NUMBER FOR CHEMISTRY OF EACH ORIGINAL JOLD SPECIES
C
NOCHANG = NSPEC(NCS)
DO 110 JOLD = 1, NTSPEC(NCS)
IF (JOLD.GT.NSPEC(NCS)) THEN
MAPPL(JOLD,NCS) = JOLD
INEWOLD(JOLD,NCS) = JOLD
ELSEIF (ISAPORL(JOLD).GT.0) THEN
ISCHANG(NCS) = ISCHANG(NCS) + 1
JNEW = ISCHANG(NCS)
INEWOLD(JNEW,NCS) = JOLD
MAPPL(JOLD,NCS) = JNEW
ELSE
INEWOLD(NOCHANG,NCS) = JOLD
MAPPL(JOLD,NCS) = NOCHANG
NOCHANG = NOCHANG - 1
ENDIF
110 CONTINUE
C
C *********************************************************************
C * RE-ARRAGE SPECIES IN ISCHANG ARRAY SO THAT SPECIES WITH THE *
C * FEWEST PARTIAL DERIVATIVE TERMS COMBINED ARE PLACED FIRST, *
C * AND THOSE WITH THE MOST APPEAR LAST. HOWEVER, SPECIES WITH ZERO *
C * PARTIAL DERIVATIVE TERMS STILL APPEAR AFTER ALL ISCHANG SPECIES *
C *********************************************************************
C
DO 117 JNEW = 1, ISCHANG(NCS)
JOLD = INEWOLD(JNEW,NCS)
MINVALU = ISAPORL(JOLD)
IMINOLD = JOLD
IMINNEW = JNEW
DO 115 INEW = JNEW+1, ISCHANG(NCS)
IOLD = INEWOLD(INEW,NCS)
IF (ISAPORL(IOLD).LT.MINVALU) THEN
MINVALU = ISAPORL(IOLD)
IMINOLD = IOLD
IMINNEW = INEW
ENDIF
115 CONTINUE
INEWOLD(IMINNEW,NCS) = JOLD
INEWOLD(JNEW,NCS) = IMINOLD
MAPPL(JOLD,NCS) = IMINNEW
MAPPL(IMINOLD,NCS) = JNEW
117 CONTINUE
C
C *********************************************************************
C * COUNT GROSS AND NET LOSS *
C *********************************************************************
C IONER = NUMBER OF REACTIONS WITH ONE ACTIVE REACTANT
C ITWOR = NUMBER OF REACTIONS WITH TWO ACTIVE REACTANTS
C ITHRR = NUMBER OF REACTIONS WITH THREE ACTIVE REACTANTS
C NKONER = REACTION NUMBER OF EACH IONER REACTION
C NKTWOR = REACTION NUMBER OF EACH ITWOR REACTION
C NKTHRR = REACTION NUMBER OF EACH ITHRR REACTION
C NUMLOST = EVERY OCCURENCE OF A LOSS (ACTIVE & INACTIVE SPEC)
C NUMLOSS = EVERY NET OCCURENCE OF A LOSS WHERE THE SPECIES IS NOT
C REPRODUCED IN THE SAME REACTION. (ACTIVE & INACTIVE SPECIES)
C JLOSS = REACTION NUMBER OF EACH NET LOSS OCCURRENCE
C IRM2 = IDENTIFIES EACH NEW ACTIVE SPECIES NUMBER IN EACH REACTION
C NUMKIAL = NUMBER OF REACTIONS WITH EITHER 1, 2, OR 3 ACTIVE REACTANTS
C NKSDT = REACTION NUMBER OF EACH NUMKIAL REACTION
C NRUSE = 1,2,3 IF REACTION HAS 1, 2, OR 3 ACTIVE REACTANTS, RESPECTIVELY.
C NRREP = 0 FOR EACH OF TWO REACTIONS WHERE THE REACTANTS ARE IDENTICAL.
C IF MORE THAN TWO REACTIONS HAVE THE SAME REACTANTS, NRREP = 0
C FOR THE FIRST TWO REACTIONS ONLY.
C = 1,2,3 IF REACTION HAS 1, 2, OR 3 REACTANTS, RESPECTIVELY.
C NMOTH = # OF OCCURRENCES WHERE INACTIVE SPEC APPEARS IN RATE EQUATION
C EXCLUDES THIRD BODIES IN ARRAY NM3BOD (E.G., O2, N2, M, WHEN
C THESE SPECIES DO NOT LOSE CONCENTRATION IN THE REACTION)
C NREACOTH = REACTION NUMBER OF EACH NMOTH OCCURRENCE
C LGASBINO = OLD SPECIES NUMBER OF EACH INACTIVE SPECIES
C
NOLOSP(NCSP) = 0
NKLAST = 0
C
DO 230 NAR = 1, NALLRAT(NCS)
NK = NCEQUAT(NAR,NCS)
C
C *********************************************************************
C *** DETERMINE OCCURRENCES OF INACTIVE SPECIES IN RATE EQUATIONS ***
C * SET ARRAY TO IDENTIFY ACTIVE LOSS SPECIES *
C *********************************************************************
C
IAL = 0
C
DO 157 JSPC = 1, MXGSAER
APORL(JSPC) = 0.d0
157 CONTINUE
C
DO 158 J = 1, NMREAC
IREACT = IRM(J,NK,NCS)
IF (IREACT.GT.0) THEN
IRE = MAPPL(IREACT,NCS)
C
APORL(IRE) = APORL(IRE) - 1.d0
NUMLOST(IRE,NCS) = NUMLOST(IRE,NCS) + 1
C
IF (IRE.LE.NSPEC(NCS)) THEN
C
IAL = IAL + 1
IRM2(IAL,NK,NCS) = IRE
C
ELSEIF (IRE.GT.NSPEC(NCS)) THEN
C
IF (NK.LE.NRATES(NCS)) THEN
NMOTH(NCS) = NMOTH(NCS) + 1
NMO = NMOTH(NCS)
NREACOTH(NMO,NCS) = NK
LGASBINO(NMO,NCS) = IREACT
ELSE
NOLOSP(NCS) = NOLOSP(NCS) + 1
NOL = NOLOSP(NCS)
NKNLOSP(NOL,NCS) = NK
LOSINACP(NOL,NCS) = IREACT
ENDIF
C
ENDIF
ENDIF
C
158 CONTINUE
C
C *********************************************************************
C * SET ARRAYS TO IDENTIFY REACTIONS WITH AT LEAST ONE ACTIVE LOSS *
C *********************************************************************
C
IF (IAL.GT.0) THEN
NRUSE(NK,NCS) = IAL
NRREP(NK,NCS) = IAL
C
IF (IAL.EQ.1) THEN
IONER(NCS) = IONER(NCS) + 1
NKONER(IONER(NCS),NCS) = NK
ELSEIF (IAL.EQ.2) THEN
ITWOR(NCS) = ITWOR(NCS) + 1
NKTWOR(ITWOR(NCS),NCS) = NK
ELSEIF (IAL.EQ.3) THEN
ITHRR(NCS) = ITHRR(NCS) + 1
NKTHRR(ITHRR(NCS),NCS) = NK
ENDIF
C
C *********************************************************************
C * COMPARE TWO CONSECUTIVE REACTIONS. IF THE SPECIES (BUT NOT RATES) *
C * ARE THE SAME, THEN SAVE MULTIPLICATIONS IN SUBFUN.F *
C *********************************************************************
C
IF (NKLAST.GT.0) THEN
IF (NRUSE(NKLAST,NCS).EQ.IAL) THEN
ISDIFF = 0
DO 150 IB = 1, IAL
JSPCL = IRM2(IB,NKLAST,NCS)
JSPC = IRM2(IB,NK ,NCS)
IF (JSPCL.NE.JSPC) ISDIFF = 1
150 CONTINUE
IF (ISDIFF.EQ.0.AND.NRREP(NKLAST,NCS).NE.0) THEN
NRREP(NK,NCS) = 0
NRREP(NKLAST,NCS) = 0
NREPT = NREPT + 1
ISPC1 = IRM2(1,NK,NCS)
ISPC2 = IRM2(2,NK,NCS)
ISPC3 = IRM2(3,NK,NCS)
IF (ISPC1.GT.0) ISPC1 = INEWOLD(ISPC1,NCS)
IF (ISPC2.GT.0) ISPC2 = INEWOLD(ISPC2,NCS)
IF (ISPC3.GT.0) ISPC3 = INEWOLD(ISPC3,NCS)
WRITE(IO93,155) NREPT, NK,NAMENCS(ISPC1,NCS),
1 NAMENCS(ISPC2,NCS), NAMENCS(ISPC3,NCS)
155 FORMAT('REPEAT REACTANTS: ',I5,I5,3(1X,A14))
ENDIF
ENDIF
ENDIF
C
C *********************************************************************
C * DETERMINE THE NUMBER OF REACTIONS WITH ZERO ACTIVE LOSS TERMS *
C *********************************************************************
C NOLOSRAT = NUMBER OF ACTIVE REACTIONS WITH NO LOSS TERMS
C NOLOSRN = REACTION NUMBER OF EACH REACTION WITH NO LOSS TERMS
C
ELSEIF (IAL.EQ.0) THEN
NOLOSRAT(NCS) = NOLOSRAT(NCS) + 1
NOL = NOLOSRAT(NCS)
NOLOSRN(NOL,NCS) = NK
ENDIF
C ENDIF IAL.GT.0
C
C *********************************************************************
C * COUNT GROSS AND NET PRODUCTION AND SET A PARTIAL DERIVATIVE ARRAY *
C *********************************************************************
C NUMGAINT = EVERY OCCURENCE OF A PRODUCTION (ACTIVE & INACTIVE SPEC)
C NUMGAIN = EVERY NET OCCURENCE OF A PRODUCTION WHERE THE SPECIES IS
C NOT LOST IN THE SAME REACTION. (ACTIVE & INACTIVE SPEC)
C IAPROD = NUMBER OF ACTIVE PRODUCTS IN EACH NK REACTION. USED
C TO CALCULATE PARTIAL DERIVATIVES IN PDERIV.F.
C IRM2 = NEW SPECIES # OF EACH ACTIVE PRODUCT IN EACH NK REACTION
C
IAP = NPRODLO - 1
DO 210 K = NPRODLO, NPRODHI
IPROD = IRM(K,NK,NCS)
IF (IPROD.GT.0) THEN
IPR = MAPPL(IPROD,NCS)
RFRAC = FKOEF(K,NK,NCS)
LFRAC = INT(RFRAC + SMAL1)
ALFRAC = FLOAT(LFRAC)
DIFF = ABS(RFRAC-ALFRAC)
C
C ******************** PRODUCTION TERM IS A FRACTION ******************
C
IF (DIFF.GT.SMAL1) THEN
IF (IPR.LE.NSPEC(NCS)) THEN
NGNFRAC(NCS) = NGNFRAC(NCS) + 1
NGN = NGNFRAC(NCS)
IGNFRAC( NGN,NCS) = IPR
NKGNFRAC(NGN,NCS) = NK
FRACP( NGN,NCS) = RFRAC
ENDIF
KPRODS = 1
NUMGFRT( IPR,NCS) = NUMGFRT( IPR,NCS) + 1
FRACGAIN(IPR,NCS) = FRACGAIN(IPR,NCS) + RFRAC
C
C ******************* PRODUCTION TERM IS NON-FRACTION *****************
C
ELSE
APORL(IPR) = APORL(IPR) + RFRAC
KPRODS = LFRAC
NUMGAINT(IPR,NCS) = NUMGAINT(IPR,NCS) + LFRAC
FKOEF(K,NK,NCS) = 1.d0
ENDIF
C
C ******************* IDENTIFY ALL PRODUCTION TERMS *******************
C
IF (IPR.LE.NSPEC(NCS)) THEN
DO 170 L = 1, KPRODS
IAP = IAP + 1
IAPROD(NK,NCS) = IAP
IRM2(IAP,NK,NCS) = IPR
FK2( IAP,NK,NCS) = FKOEF(K,NK,NCS)
170 CONTINUE
ENDIF
C
ENDIF
C
210 CONTINUE
C
C *********************************************************************
C * FIND NET PROD AND LOSS TERMS FOR ALL BUT FRACTIONATED PRODUCTS *
C *********************************************************************
C
DO 220 JSPC = 1, NTSPEC(NCS)
IF (ABS(APORL(JSPC)).LT.SMAL1) THEN
KDIF = 0
C
ELSEIF (APORL(JSPC).GT.0.) THEN
KDIF = INT(APORL(JSPC) + 0.00001)
DO 190 L = 1, KDIF
NUMGAIN(JSPC,NCS) = NUMGAIN(JSPC,NCS) + 1
NUMPORL(JSPC,NCS) = NUMPORL(JSPC,NCS) + 1
NPL = NUMPORL(JSPC,NCS)
JPORL(JSPC,NPL,NCS) = NK + NTRATES(NCS)
190 CONTINUE
ELSE
KDIF = -INT(APORL(JSPC) - 0.00001)
DO 140 L = 1, KDIF
NUMLOSS(JSPC,NCS) = NUMLOSS(JSPC,NCS) + 1
NUMPORL(JSPC,NCS) = NUMPORL(JSPC,NCS) + 1
NPL = NUMPORL(JSPC,NCS)
JPORL(JSPC,NPL,NCS) = NK
140 CONTINUE
ENDIF
C
IF (NK.LE.NRATES(NCS)) THEN
NUMLOSS(JSPC,NCSP) = NUMLOSS(JSPC,NCS)
NUMGAIN(JSPC,NCSP) = NUMGAIN(JSPC,NCS)
NUMPORL(JSPC,NCSP) = NUMPORL(JSPC,NCS)
ENDIF
C
220 CONTINUE
C
IF (NK.LE.NRATES(NCS)) THEN
NOLOSRAT(NCSP) = NOLOSRAT(NCS)
NGNFRAC( NCSP) = NGNFRAC( NCS)
IONER( NCSP) = IONER( NCS)
ENDIF
C
NKLAST = NK
C
230 CONTINUE
C CONTINUE N = 1, NTRATES
C
C *********************************************************************
C * SET ARRAY FOR REORDERING RATES FROM 3..2..1..0 BODY REACTIONS *
C *********************************************************************
C INOREP = LAST REORDERED REACTION NUMBER PRIOR TO SETS OF TWO
C REACTIONS WITH TWO REACTANTS
C NOLDFNEW = OLD REACTION RATE # CORRESP. TO EACH REORDERED REACTION
C NEWFOLD = NEW REACTION RATE # CORRESP. TO EACH ORIGINAL RATE NUMBER
C
IC = 0
DO 235 I = 1, ITHRR(NCS)
IC = IC + 1
NK = NKTHRR(I,NCS)
NK1 = NK + NTRATES(NCS)
NOLDFNEW(IC, NCS) = NK
NEWFOLD( NK, NCS) = IC
NEWFOLD( NK1,NCS) = IC + NALLRAT(NCS)
235 CONTINUE
C
NTWO = ITHRR(NCS) + ITWOR(NCS)
ICB = NTWO + 1
DO 237 I = 1, ITWOR(NCS)
NK = NKTWOR(I,NCS)
NK1 = NK + NTRATES(NCS)
IF (NRREP(NK,NCS).GT.0) THEN
IC = IC + 1
ICD = IC
ELSE
ICB = ICB - 1
ICD = ICB
ENDIF
NOLDFNEW(ICD, NCS) = NK
NEWFOLD( NK, NCS) = ICD
NEWFOLD( NK1, NCS) = ICD + NALLRAT(NCS)
237 CONTINUE
C
INOREP(NCS) = IC
IC = NTWO
DO 239 I = 1, IONER(NCS)
IC = IC + 1
NK = NKONER(I,NCS)
NK1 = NK + NTRATES(NCS)
NOLDFNEW(IC, NCS) = NK
NEWFOLD( NK, NCS) = IC
NEWFOLD( NK1,NCS) = IC + NALLRAT(NCS)
239 CONTINUE
C
DO 241 I = 1, NOLOSRAT(NCS)
IC = IC + 1
NK = NOLOSRN(I,NCS)
NK1 = NK + NTRATES(NCS)
NOLDFNEW(IC, NCS) = NK
NEWFOLD( NK, NCS) = IC
NEWFOLD( NK1,NCS) = IC + NALLRAT(NCS)
241 CONTINUE
C
IF (IC.NE.NALLRAT(NCS)) THEN
WRITE(6,245) IC, NALLRAT(NCS)
CALL GEOS_CHEM_STOP
ENDIF
C
C *********************************************************************
C SET A SLIGHTLY MORE EFFICIENT PHOTO ARRAY
C *********************************************************************
C
DO 243 J = 1, JPHOTRAT(NCS)
NK = NKPHOTRAT(J,NCS)
NKN = NEWFOLD(NK,NCS)
NKNPHOTRT(J,NCS) = NKN
243 CONTINUE
C
245 FORMAT('JSPARSE: IC NE NALLRAT =',2(I5))
C
C *********************************************************************
C ****** DETERMINE NUMBER OF SPECIES WITH GROSS/NET LOSSES/GAINS ******
C *********************************************************************
C NSPCSOLV = # OF ACTIVE SPECIES WITH AT LEAST ONE GROSS LOSS
C ISOLVSPC = SPECIES NUMBER OF EACH NSPCSOLV SPECIES
C ISGAINR = # OF ACTIVE SPECIES WITH AT LEAST ONE NET CHEM GAIN
C IGAINR = SPECIES NUMBER OF EACH ISGAINR SPECIES
C ISGAINE = # OF ACTIVE SPECIES WITH AT LEAST 1 NET CHEM GAIN
C IGAINR = SPECIES NUMBER OF EACH ISGAINR SPECIES
C NOGAINE = # OF ACTIVE SPECIES WITH ZERO NET CHEM OR GAINS
C NGAINE = SPECIES NUMBER OF EACH NOGAINE SPECIES
C ISPORL = # OF ACTIVE SPECIES WITH AT LEAST ONE NET PRODUCTION
C OR LOSS TERM FOR SMVGEAR.
C IPORL = SPECIES NUMBER OF EACH ISPORL SPECIES
C
DO 300 JOLD = 1, NSPEC(NCS)
JNEW = MAPPL(JOLD,NCS)
C
IF (NUMGAIN(JNEW,NCS).GT.0) THEN
ISGAINR(NCS) = ISGAINR(NCS) + 1
IGR = ISGAINR(NCS)
IGAINR(IGR,NCS) = JNEW
ENDIF
C
IF (NUMPORL(JNEW,NCS).GT.0) THEN
ISPORL(NCS) = ISPORL(NCS) + 1
ISP = ISPORL(NCS)
IPORL(ISP,NCS) = JNEW
ENDIF
C
IF (NUMLOST(JNEW,NCS).GT.0) THEN
NSPCSOLV(NCS) = NSPCSOLV(NCS) + 1
NSP = NSPCSOLV(NCS)
ISOLVSPC(NSP,NCS) = JNEW
ENDIF
C
IF (NUMGAIN(JNEW,NCS).GT.0.OR.FRACGAIN(JNEW,NCS).GT.0) THEN
ISGAINE(NCS) = ISGAINE(NCS) + 1
IGR = ISGAINE(NCS)
IGAINE(IGR,NCS) = JNEW
ELSEIF (NUMLOSS(JNEW,NCS).GT.0) THEN
NOGAINE(NCS) = NOGAINE(NCS) + 1
NGR = NOGAINE(NCS)
NGAINE(NGR,NCS) = JNEW
ENDIF
C
300 CONTINUE
C
C *********************************************************************
C ******** CHECK DIMENSIONS RESULTING FROM GAINS AND LOSSES *********
C *********************************************************************
C
NGTSUM = 0
NLTSUM = 0
NGSUM = 0
NLSUM = 0
NGFSUM = 0
DO 260 K = 1, NTSPEC(NCS)
J = INEWOLD(K,NCS)
NGTSUM = NGTSUM + NUMGAINT(K,NCS)
NLTSUM = NLTSUM + NUMLOST( K,NCS)
NGSUM = NGSUM + NUMGAIN( K,NCS)
NLSUM = NLSUM + NUMLOSS( K,NCS)
NGFSUM = NGFSUM + NUMGFRT( K,NCS)
IF (NUMGAINT(K,NCS) .GT. MAXGL .OR.
1 NUMLOST( K,NCS) .GT. MAXGL) THEN
WRITE(6,280) NAMENCS(J,NCS), NUMGAINT(K,NCS), NUMLOST(K,NCS)
CALL GEOS_CHEM_STOP
ENDIF
260 CONTINUE
C
IF (IOREAC.EQ.1) THEN
WRITE(IO93,*)
WRITE(IO93,240)
DO 270 K = 1, NTSPEC(NCS)
J = INEWOLD(K,NCS)
WRITE(IO93,250)NAMENCS( J,NCS),NUMGAINT(K,NCS),NUMGAIN( K,NCS),
1 NUMLOST( K,NCS),NUMLOSS( K,NCS),NUMGAINT(K,NCS)
2 -NUMLOST( K,NCS)-NUMGAIN( K,NCS)+NUMLOSS( K,NCS),
3 FRACGAIN(K,NCS),NUMGFRT( K,NCS)
270 CONTINUE
WRITE(IO93,250) 'OVERALL ',NGTSUM, NGSUM, NLTSUM, NLSUM,
1 NGTSUM - NLTSUM - NGSUM + NLSUM, 0., NGFSUM
ENDIF
C
IF (NMOTH( NCS).GT.MAXGL2.OR.NOLOSP(NCS).GT.MAXGL3.OR.
1 NGNFRAC(NCS).GT.MAXGL) THEN
WRITE(6,275) MAXGL2, NMOTH( NCS), MAXGL3, NOLOSP(NCS),
1 MAXGL, NGNFRAC(NCS)
CALL GEOS_CHEM_STOP
ENDIF
C
C *********************************************************************
C * CHECK WHETHER CHEMICAL SYSTEM IS ATOM-CONSERVATIVE *
C *********************************************************************
C JMBCOMP = SPECIES NUMBER FOR EACH SPECIES IN A MASS BAL. GROUP
C MBCOMP = COUNTS THE NUMBER OF MASS BALANCE SPECIES IN EACH M.B GROUP
C NMASBAL = NUMBER OF MASS BALANCE GROUPS (E.G. S, N, C ARE GROUPS)
C WTMB(1) = NUMBER OF ATOMS OF A GIVEN MASS BALANCE SPECIES PER MOLECULE
C
WRITE(IO93,360) CHEMTYP(NCS)
C
IF (NCS.LE.NCSGAS) THEN
C
C ---------------------------- GAS-PHASE --------------------------
C
DO 385 N = 1, NMASBAL
IF (MBCOMP(N,MB1).GT.0) THEN
TNUMGN = 0
TNUMLS = 0
WRITE(IO93,325) NAMEMB(N)
DO 380 J = 1, MBCOMP(N,MB1)
JGAS = JMBCOMP(N,J,MB1)
JNEW = MAPPL(JGAS,NCS)
SUMGN = NUMGAIN(JNEW,NCS) + FRACGAIN(JNEW,NCS)
TNUMGNA = SUMGN * WTMB(N,JGAS,MB1)
TNUMLSA = NUMLOSS(JNEW,NCS) * WTMB(N,JGAS,MB1)
TNUMGN = TNUMGN + TNUMGNA
TNUMLS = TNUMLS + TNUMLSA
WRITE(IO93,320) NAMEGAS(JGAS), TNUMGNA, TNUMLSA, 0
380 CONTINUE
WRITE(IO93,370) TNUMGN, TNUMLS, TNUMGN - TNUMLS
ENDIF
385 CONTINUE
ENDIF
C
WRITE(IO93,375) NALLRAT(NCSP), NALLRAT(NCS) - NALLRAT(NCSP),
1 NALLRAT(NCS)
C
360 FORMAT(/'CHANGE IN MOLES DUE TO ',A14,' CHEMISTRY')
325 FORMAT('MASS BALANCE GROUP = ',A14)
320 FORMAT('GAINS/LOSSES FOR ',A14,' = ',2(F8.3),I5)
370 FORMAT('TOTAL GAINS - LOSSES = ',3(F8.3))
375 FORMAT(/'# KINETIC REACTIONS: ',I5,' PHOTORATES: ',I5,
1 ' TOTAL: ',I5)
240 FORMAT('SPEC NUMGT NUMG NUMLT NUML NGT-NLT-',
1 'NG+NL FRACGN NUMGFT')
250 FORMAT(A14,4(2X,I4),7X,I4,3X,F8.3,I5)
280 FORMAT('GEARSET: SPEC ',A6,' DIMENS EXCEEDED. EITHER NUMGAINT ',
1 'NUMLOSS,NUMGAIN, OR NUMLOST > MAXGL ',
2 4(I3,1X))
275 FORMAT('JSPARSE: ONE OF THE DIMENSIONS BELOW IS TOO SMALL:',/,
1 'DIMENSION: MAXGL2 = ',I4,' VARIABLE: NMOTH = ',I4/
2 'DIMENSION: MAXGL3 = ',I4,' VARIABLE: NOLOSP = ',I4/
3 'DIMENSION: MAXGL = ',I4,' VARIABLE: NGNFRAC = ',I4)
C
C *********************************************************************
C *********************************************************************
C ** SET ARRAYS TO TAKE ADVANTAGE OF SPARSE MATRICES **
C *********************************************************************
C *********************************************************************
C
C IFSUN = 1 THEN DAY-CHEMISTRY; = 2 THEN NIGHT CHEMISTRY
C NCSP = NCS FOR DAYTIME TROP-GAS, STRAT-GAS CHEM
C NCSP = NCS + ICP FOR NIGHTTIME TROP-GAS, STRAT-GAS CHEM
C
C LZERO = 1 IF AN ARRAY SPOT IS FILLED WITH A NON-ZERO VALUE. LZERO
C IS UPDATED AS WE SIMULATE THE ORDER OF CALCULATIONS DURING
C A PRACTICE L-U DECOMPOSITION
C MXGSAER = LARGER OF IGAS, IAERTY
C
C
IF (IFNONE.EQ.0) THEN
IFNONE = 1
NPLFUN = 0
NFRCOUN = 0
NPDCOUN = 0
NPLTOT = 0
ENDIF
C
DO 700 IFSUN = 1, 2
NCSP = (IFSUN - 1) * ICS + NCS
C
DO 517 I = 1, MXGSAER
DO 515 J = 1, MXGSAER
LZERO(J,I) = 0
515 CONTINUE
LZERO(I,I) = 1
517 CONTINUE
C
DO 504 NA = 1, NALLRAT(NCSP)
NK = NCEQUAT(NA,NCS)
IHIREAC = NRUSE( NK,NCS)
DO 502 IAL = 1, IHIREAC
IRE = IRM2(IAL,NK,NCS)
DO 490 JAL = 1, IHIREAC
JRE = IRM2(JAL,NK,NCS)
LZERO(JRE,IRE) = 1
490 CONTINUE
DO 500 IAP = NPRODLO, IAPROD(NK,NCS)
JPR = IRM2(IAP,NK,NCS)
LZERO(JPR,IRE) = 1
500 CONTINUE
502 CONTINUE
504 CONTINUE
C
C *********************************************************************
C * SET DECOMPOSITION AND BACK-SUBSTITUTION SPARSE-MATRIX ARRAYS *
C *********************************************************************
C
CALL KSPARSE
C
C *********************************************************************
C * SET ARRAYS TO IMPROVE EFFICIENCY OF FIRST-DERIVATIVE CALCS *
C *********************************************************************
C *********************************************************************
C ** SET ARRAYS FOR KINETIC AND PHOTO PRODUCTION AND LOSS RATES **
C *********************************************************************
C
NPLLO(NCSP) = NPLTOT + 1
DO 670 I = 1, ISPORL(NCS)
JSPC = IPORL(I,NCS)
KNUMPORL = NUMPORL(JSPC,NCSP)
NCCOUNT = 0
NPLTOT = NPLTOT + 1
NREMAIN = KNUMPORL
NFIVE = (NREMAIN + 0.0001) / 5
NREMAIN = NREMAIN - NFIVE * 5
NFOUR = (NREMAIN + 0.0001) / 4
NREMAIN = NREMAIN - NFOUR * 4
NTHREE = (NREMAIN + 0.0001) / 3
NREMAIN = NREMAIN - NTHREE * 3
NTWO = (NREMAIN + 0.0001) / 2
NREMAIN = NREMAIN - NTWO * 2
NONE = (NREMAIN + 0.0001)
NREMAIN = NREMAIN - NONE
C
JSPNPL(NPLTOT) = JSPC
NPL5( NPLTOT) = NPLFUN + 1
NPH5( NPLTOT) = NPLFUN + NFIVE
NPL4( NPLTOT) = NPH5(NPLTOT) + 1
NPH4( NPLTOT) = NPH5(NPLTOT) + NFOUR
NPL3( NPLTOT) = NPH4(NPLTOT) + 1
NPH3( NPLTOT) = NPH4(NPLTOT) + NTHREE
NPL2( NPLTOT) = NPH3(NPLTOT) + 1
NPH2( NPLTOT) = NPH3(NPLTOT) + NTWO
NPL1( NPLTOT) = NPH2(NPLTOT) + 1
NPH1( NPLTOT) = NPH2(NPLTOT) + NONE
NPLFUN = NPH1(NPLTOT)
C
DO 649 N = 1, KNUMPORL
NK = JPORL(JSPC,N,NCS)
NEWNK(N) = NEWFOLD(NK,NCS)
649 CONTINUE
C
DO 651 MC = NPL5(NPLTOT), NPH5(NPLTOT)
LOSSRA(MC) = NEWNK(NCCOUNT+1)
LOSSRB(MC) = NEWNK(NCCOUNT+2)
LOSSRC(MC) = NEWNK(NCCOUNT+3)
LOSSRD(MC) = NEWNK(NCCOUNT+4)
LOSSRE(MC) = NEWNK(NCCOUNT+5)
NCCOUNT = NCCOUNT + 5
651 CONTINUE
C
DO 652 MC = NPL4(NPLTOT), NPH4(NPLTOT)
LOSSRA(MC) = NEWNK(NCCOUNT+1)
LOSSRB(MC) = NEWNK(NCCOUNT+2)
LOSSRC(MC) = NEWNK(NCCOUNT+3)
LOSSRD(MC) = NEWNK(NCCOUNT+4)
NCCOUNT = NCCOUNT + 4
652 CONTINUE
C
DO 653 MC = NPL3(NPLTOT), NPH3(NPLTOT)
LOSSRA(MC) = NEWNK(NCCOUNT+1)
LOSSRB(MC) = NEWNK(NCCOUNT+2)
LOSSRC(MC) = NEWNK(NCCOUNT+3)
NCCOUNT = NCCOUNT + 3
653 CONTINUE
C
DO 654 MC = NPL2(NPLTOT), NPH2(NPLTOT)
LOSSRA(MC) = NEWNK(NCCOUNT+1)
LOSSRB(MC) = NEWNK(NCCOUNT+2)
NCCOUNT = NCCOUNT + 2
654 CONTINUE
C
DO 656 MC = NPL1(NPLTOT), NPH1(NPLTOT)
LOSSRA(MC) = NEWNK(NCCOUNT+1)
NCCOUNT = NCCOUNT + 1
656 CONTINUE
C
670 CONTINUE
NPLHI(NCSP) = NPLTOT
C
C *********************************************************************
C * SET ARRAY FOR FRACTIONATED PRODUCTS *
C *********************************************************************
C
NFRLO(NCSP) = NFRCOUN + 1
DO 695 I = 1, NGNFRAC(NCSP)
JSPC = IGNFRAC(I,NCS)
NFRCOUN = NFRCOUN + 1
JSPCNFR(NFRCOUN) = JSPC
NK = NKGNFRAC(I,NCS)
NKNFR( NFRCOUN) = NEWFOLD(NK,NCS)
FRACNFR(NFRCOUN) = FRACP(I,NCS)
695 CONTINUE
NFRHI(NCSP) = NFRCOUN
C
C *********************************************************************
C * SET ARRAYS TO IMPROVE EFFICIENCY OF PARTIAL DERIVATIVE CALCS *
C *********************************************************************
C
NPDLO(NCSP) = NPDCOUN + 1
C
DO 974 NA = 1, NALLRAT(NCSP)
NK = NCEQUAT(NA,NCS)
IHIREAC = NRUSE( NK,NCS)
C
DO 972 IAL = 1, IHIREAC
IR = IRM2(IAL,NK,NCS)
DO 960 JAL = 1, IHIREAC
JR = IRM2(JAL,NK,NCS)
IAR = JARRAYPT(JR,IR)
NPDCOUN = NPDCOUN + 1
NKPDTERM(NPDCOUN) = NEWFOLD(NK,NCS)
IPOSPD( NPDCOUN) = IAR
IIALPD( NPDCOUN) = IAL
FRACPL( NPDCOUN) = -1.
960 CONTINUE
C
DO 970 IAP = NPRODLO, IAPROD(NK,NCS)
JP = IRM2(IAP,NK,NCS)
IAR = JARRAYPT(JP,IR)
NPDCOUN = NPDCOUN + 1
NKPDTERM(NPDCOUN) = NEWFOLD(NK,NCS)
IPOSPD( NPDCOUN) = IAR
IIALPD( NPDCOUN) = IAL
FRACPL( NPDCOUN) = FK2(IAP,NK,NCS)
970 CONTINUE
972 CONTINUE
974 CONTINUE
C
NPDHI(NCSP) = NPDCOUN
C
C *********************************************************************
C ** CHECK DIMENSIONS AND PRINT OUT ARRAY SAVINGS **
C *********************************************************************
C
IF (NPLTOT .GT. MXCOUNT4 .OR. NPLFUN .GT. MXCOUNT4 .OR.
3 NFRCOUN .GT. MXCOUNT4 .OR. NPDCOUN .GT. MXCOUNT2) THEN
WRITE(6,645) MXCOUNT4, NPLTOT, MXCOUNT4, NPLFUN,
2 MXCOUNT4, NFRCOUN, MXCOUNT2, NPDCOUN
CALL GEOS_CHEM_STOP
ENDIF
C
700 CONTINUE
C CONTINUE IFSUN = 1, 2
C
645 FORMAT('ONE OF THE DIMENSIONS BELOW IS TOO SMALL:',/,
1 'DIMENSION: MXCOUNT4 = ',I5,' VARIABLE: NPLTOT = ',I5,/,
2 'DIMENSION: MXCOUNT4 = ',I5,' VARIABLE: NPLFUN = ',I5,/,
3 'DIMENSION: MXCOUNT4 = ',I5,' VARIABLE: NFRCOUN = ',I5,/,
4 'DIMENSION: MXCOUNT2 = ',I5,' VARIABLE: NPDCOUN = ',I5)
C
C *********************************************************************
C ********************** END OF SUBROUTINE JSPARSE ********************
C *********************************************************************
C
RETURN
END SUBROUTINE JSPARSE

123
code/jv_cmn.h Normal file
View File

@ -0,0 +1,123 @@
! $Id: jv_cmn.h,v 1.1 2009/06/09 21:51:52 daven Exp $
!
!----jv_cmn.h---COMMON BLOCKS for new FAST-J code (wild/prather 7/99)
!
! Parameters
! ----------
!
! NB Number of levels in CTM plus one for above model top
! NC Number of levels in the fundamental Fast-J grid
! NS Maximum number of species which require J-values calculating
! NW Maximum number of wavelength bins that can be used
! NP Maximum number of aerosol/cloud types that can be used
! MX Number of aerosol/cloud types supplied from CTM
! NDUST Number of mineral dust categories
!
! Note: THETA(NL) no longer used
!
! NOTES for CTM Interface (bmy, 10/27/99, 3/23/03)
! =====================================================================
! (1) Change JPNL and JPPJ from parameters to variables, which are
! set in "inphot.f". This allows the user to switch the number
! of levels at run-time via the CTM inputs.
!
! (2) Now make RAD, ZZHT, DTAUMAX, DTAUSUB, DSUBDIV, SZAMAX into
! parameters instead of holding them in common blocks.
!
! (3) Create new common blocks /WLLOC/ and /JVLOC/ to hold certain
! quantities -Xlocal for parallel code (ppm, 4/98, bmy, 9/21/99)
!
! (4) The common blocks that must be held -Xlocal are:
! /ATMOS/, /JVSUB/, /WLLOC/, /JVLOC/
!
! (4a) Declare the above commons THREADPRIVATE for the Compaq
! Alpha platform (bmy, 7/10/01)
!
! (5) Break MIEDX off from the WLLOC common block, since it must
! not be declared LOCAL for the parallelization. (bmy, 5/2/00)
!
! (6) For including aerosol optical depths: (rvm, bmy, 9/30/00)
! (a) Increase MX from 3 to 10 .
! (c) Add ODMDUST(IPAR,JPAR,LPAR,NDUST) to common block /CLIM/
!
! (7) Move NDUST to CMN_SIZE to avoid conflicts (bmy, 11/15/01)
!
! (8) For updating aerosol optical depths again (rvm, bmy, 2/27/02):
! (a) Change NP from 21 to 56
! (b) Change MX from 10 to 35
! (c) Add ODAER(IPAR,JPAR,LPAR,NAER*NRH) to common block /CLIM/
!
! (9) Changed RCS ID tag comment character from "C" to "!" to allow freeform
! compilation. Also added & continuation characters in column 73
! to allow header files to be included in F90 freeform files.
! Also changed comment character from "C" to "!" to allow this
! file to be inlined into freeform source code. (bmy, 6/25/02)
!
! (10) Renamed cpp switch from DEC_COMPAQ to COMPAQ. Also declare common
! blocks ATMOS, JVLOC, WLLOC, JVSUB as !$OMP THREADPRIVATE for
! all platforms. (bmy, 3/23/03)
! (11) Added new pressure denpendencies algorithm parameters
! for MGLY. (tmf, 1/7/09)
! (12) Added 'pdepf' as pressure dependancy function selector. (tmf, 1/31/06)
! (14) Add new optical variables for AOD calculation (clh, 05/06/10)
!-----------------------------------------------------------------------------
INTEGER NB, NC, NS, NW, NP, MX
PARAMETER (NB=LPAR+1, NC=2*NB, NS=51, NW=15, NP=56, MX=35)
CHARACTER*20 TITLEA(NP)
CHARACTER*78 TITLE0
CHARACTER*7 TITLEJ(3,NS), jlabel(JPMAX)
INTEGER jind(JPMAX),jadsub(nc)
INTEGER NJVAL,NW1,NW2,MIEDX,NAA,NLBATM,npdep,jpdep(NS)
REAL*8 TJ,PJ,DM,DO3,Z,AER,AMF,RAD,RFLECT,SZA,U0,TANHT,ZZHT
REAL*8 WBIN,WL,FL,QO2,QO3,Q1D,QQQ,QRAYL,TQQ,FFF,VALJ,WAA,QAA,PAA
REAL*8 RAA,SSA,TREF,OREF,BREF,QBC,DBC,zpdep(NW,7)
REAL*8 WAA_AOD,QAA_AOD,PAA_AOD,RAA_AOD,SSA_AOD
REAL*8 dtaumax,szamax,zj(LPAR,JPMAX),jfacta(JPMAX)
REAL*8 dtausub,dsubdiv
REAL*8 ODMDUST,ODAER
INTEGER PDEPF(7)
REAL*8 MGLYPDEP(NW, 3)
!-----------------------------------------------------------------------
! These common blocks MUST NOT be held local (bmy, 5/2/00)
COMMON /TITLS/TITLE0,TITLEJ,TITLEA
COMMON /CCWVL/WBIN(NW+1),WL(NW),FL(NW),QO2(NW,3),QO3(NW,3),
& Q1D(NW,3),QQQ(NW,2,NS-3),QRAYL(NW),TQQ(3,NS),
& WAA(4,NP),QAA(4,NP),
& PAA(8,4,NP),RAA(4,NP),SSA(4,NP),QBC(NW),
& NJVAL,NW1,NW2,NAA,NLBATM,
& WAA_AOD(NP),QAA_AOD(NP),PAA_AOD(8,NP),
& RAA_AOD(NP),SSA_AOD(NP)
COMMON /CLIM/ TREF(51,18,12),OREF(51,18,12),BREF(51),
& ODMDUST(IPAR,JPAR,LPAR,NDUST),
& ODAER(IPAR,JPAR,LPAR,NAER*NRH)
COMMON /JVALS/jfacta,zpdep,npdep,jpdep,jind,jlabel, &
& pdepf,mglypdep
COMMON /JVIDX/MIEDX(MX)
!-----------------------------------------------------------------------
! These common blocks MUST be held local for the parallelization (bmy, 5/2/00)
COMMON /ATMOS/TJ(NB),PJ(NB+1),DM(NB),DO3(NB),DBC(NB),Z(NB), &
& AER(MX,NB),AMF(NB,NB),RFLECT,SZA,U0,TANHT
COMMON /JVLOC/zj
COMMON /WLLOC/FFF(NW,lpar),VALJ(NS)
COMMON /JVSUB/jadsub
!=================================================================
! Declare the following common blocks as THREADPRIVATE for the
! OpenMP parallelization on all platforms (bmy, 3/23/03)
!=================================================================
!$OMP THREADPRIVATE( /ATMOS/ )
!$OMP THREADPRIVATE( /JVLOC/ )
!$OMP THREADPRIVATE( /WLLOC/ )
!$OMP THREADPRIVATE( /JVSUB/ )
!-----------------------------------------------------------------------
! Parameters for FAST-J
PARAMETER ( RAD = 6375.d5 )
PARAMETER ( ZZHT = 5.d5 )
PARAMETER ( dtaumax = 1.d0 )
PARAMETER ( dtausub = 1.d0 )
PARAMETER ( dsubdiv = 10.d0 )
PARAMETER ( szamax = 98.0d0 )
!-----------------------------------------------------------------------

80
code/jv_index.f Normal file
View File

@ -0,0 +1,80 @@
! $Id: jv_index.f,v 1.1 2009/06/09 21:51:52 daven Exp $
SUBROUTINE JV_INDEX
!
!******************************************************************************
! Subroutine JV_INDEX computes the mapping between the CTM indices
! (from "chem.dat") for J-values to the FAST-J indices (from "ratj.d")
! for J-values. (bmy, 10/5/98, 10/16/06)
!
! NOTES:
! (1 ) Assumes the ordering of a species with several branches in
! "ratj.d" is the same as in "chem.dat".
! (2 ) Updated comments, cosmetic changes (bmy, 11/15/01)
! (3 ) NAMESPEC is now NAMEGAS for SMVGEAR II. We don't need to reference
! CMN anymore. Now loop from NCS = 1..NCSGAS (bdf, bmy, 4/8/03)
! (4 ) Now reset NCS to NCSURBAN after loop (dbm, bmy, 10/16/06)
!******************************************************************************
!
IMPLICIT NONE
# include "cmn_fj.h" ! CMN_SIZE
# include "comode.h" ! SMVGEAR II arrays
! Local variables
INTEGER :: I, IFNC, IBRCH, N, NK
CHARACTER (LEN=4) :: SPECNAME
!=================================================================
! JV_INDEX begins here!
!=================================================================
! Zero the RINDEX array
RINDEX(:) = 0
! Loop over photolysis rxns (urban chemistry only)
DO NCS = 1, NCSGAS
DO I = 1, NPHOT
!==============================================================
! I = Index of photo rxns from "globchem.dat"
! NK = Absolute rxn number (adds offset to I)
! SPECNAME = Name of species I, from "globchem.dat"
! IBRCH = Branch # of species I, from "globchem.dat"
!==============================================================
NK = NRATES(NCS) + I
SPECNAME = NAMEGAS(IRM(1,NK,NCS))
IFNC = DEFPRAT(NK,NCS) + 0.01d0
IBRCH = 10d0*( DEFPRAT(NK,NCS) - IFNC ) + 0.5d0
!==============================================================
! N = Index of photolysis reactions as listed in "ratj.d"
! RNAMES = Name of species N, as listed in "ratj.d"
! BRANCH = Branch number of species N, as listed in "ratj.d"
!
! If the species names and branch numbers from both "chem.dat"
! and "ratj.d" match, then store N (the "ratj.d" index) in the
! Ith element of RINDEX.
!
! Thus, when looping over I (the chem.dat" indices), as is
! done in FJFUNC.F, RINDEX(I) will access the correct J-value
! according to the ordering in "ratj.d".
!==============================================================
DO N = 1, JPPJ
IF ( SPECNAME == RNAMES(N) .and. IBRCH == BRANCH(N) ) THEN
RINDEX(I) = N
WRITE ( 6, 100 ) I, SPECNAME, IBRCH,
& RINDEX(I), RNAMES(N), BRANCH(N)
100 FORMAT('Harvard #: ', i3, 1x, a4, ' Branch: ', i2,
& ' ---> Fast-J #: ', i3, 1x, a4, ' Branch: ',i2 )
EXIT
ENDIF
ENDDO
ENDDO
ENDDO
! Reset NCS to NCSURBAN for safety's sake (bmy, 10/16/06)
NCS = NCSURBAN
! Return to calling program
END SUBROUTINE JV_INDEX

60
code/jv_mie.h Normal file
View File

@ -0,0 +1,60 @@
! $Id: jv_mie.h,v 1.2 2009/11/18 07:09:33 daven Exp $
!
!----jv_mie.h-----COMMON BLOCKS for FAST-J code: 4x4x85 (prather 4/96)
!
! Parameters
! ----------
!
! NL Maximum number of levels after insertion of extra Mie levels
! N__ Number of levels in Mie grid: 2*(2*lpar+2+jaddto(1))+3
! M__ Number of Gauss points used
!
!
! NOTES:
! (1 ) Changed RCS ID tags to by adding a ! comment character to allow
! freeform compilation. Also added & continuation characters in
! column 73 to allow header files to be included in F90 freeform files.
! Also changed comment character from "C" to "!", to allow this
! file to be inlined into freeform source code. (bmy, 6/25/02)
! (2 ) Now declare common blocks /MIEBLK/ and /MINDEX/ as THREADPRIVATE for
! all platforms (bmy, 3/23/03)
!-----------------------------------------------------------------------
INTEGER NL, N__, M__
!-----------------------------------------------------------------------
! NL=250 was too small for the GEOS code, so I upped it to 400.
! Uncomment this line to restore the original definition (bmy, 9/29/99)
! PARAMETER (NL=250, N__=2*NL, M__=4)
!-----------------------------------------------------------------------
! NL=400 was too small again, so we upped it to 500.
! Uncomment this line to restore the previous definition (bmy, 9/29/99)
! PARAMETER (NL=400, N__=2*NL, M__=4)
!-----------------------------------------------------------------------
! NL=500 was too small again, so we upped it to 750.
! Uncomment this line to restore the previous definition (mje, 6/14/01)
! PARAMETER (NL=500, N__=2*NL, M__=4)
!-----------------------------------------------------------------------
! NL=750 was too small again, so we upped it to 1000.
! Uncomment this line to restore the previous definition (phs, 10/9/09)
! PARAMETER (NL=750, N__=2*NL, M__=4)
!-----------------------------------------------------------------------
! PARAMETER (NL=1000, N__=2*NL, M__=4)
! (lzh,02/01/2015) upped for 0.25 nested
PARAMETER (NL=2000, N__=2*NL, M__=4)
REAL*8 A,B,C1,H,AA,CC,S,W,U1,V1,WT,EMU,PM,PM0,POMEGA
REAL*8 ZTAU,FZ,FJ,DD,RR,ZREFL,ZFLUX,RADIUS,ZU0
INTEGER ND,N,M,MFIT
COMMON/MIEBLK/ A(M__),B(M__,M__),C1(M__),H(M__),AA(M__,M__), &
& CC(M__,M__),S(M__,M__),W(M__,M__),U1(M__,M__),V1(M__),WT(M__), &
& EMU(M__),PM(M__,2*M__),PM0(2*M__),POMEGA(2*M__,N__),ZTAU(N__), &
& FZ(N__),FJ(N__),DD(M__,M__,N__),RR(M__,N__), &
& ZREFL,ZFLUX,RADIUS,ZU0
COMMON/MINDEX/ ND,N,M,MFIT
!=================================================================
! Declare the following common blocks as THREADPRIVATE for the
! OpenMP parallelization on all platforms (bmy, 3/23/03)
!=================================================================
!$OMP THREADPRIVATE( /MIEBLK/ )
!$OMP THREADPRIVATE( /MINDEX/ )
C-----------------------------------------------------------------------

654
code/ksparse.f Normal file
View File

@ -0,0 +1,654 @@
! $Id: ksparse.f,v 1.1 2009/06/09 21:51:54 daven Exp $
SUBROUTINE KSPARSE
!
!******************************************************************************
! Subroutine KSPARSE sets up the sparse-matrix arrays, and also arrays for
! day & night chemistry for SMVGEAR II. (M. Jacobson 1997; bdf, bmy, 4/18/03)
!
! NOTES:
! (1 ) Now direct some output to "smv2.log" file. Now call GEOS_CHEM_STOP
! to deallocate all arrays and stop the run safely. Now also force
! double-precision with "D" exponents. (bmy, 4/18/03)
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : GEOS_CHEM_STOP
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "comode.h" ! SMVGEAR II arrays
C
C *********************************************************************
C ************ WRITTEN BY MARK JACOBSON (1993) ************
C *** (C) COPYRIGHT, 1993 BY MARK Z. JACOBSON ***
C *** U.S. COPYRIGHT OFFICE REGISTRATION NO. TXu 670-279 ***
C *** (650) 723-6836 ***
C *********************************************************************
C
C K K SSSSSSS PPPPPPP A RRRRRRR SSSSSSS EEEEEEE
C K K S P P A A R R S E
C KK SSSSSSS PPPPPPP A A RRRRRRR SSSSSSS EEEEEEE
C K K S P AAAAAAA R R S E
C K K SSSSSSS P A A R R SSSSSSS EEEEEEE
C
C *********************************************************************
C * THIS ROUTINE SETS UP SPARSE-MATRIX AND OTHER ARRAYS. IT ALSO *
C * SETS ARRAYS FOR GAS-PHASE, AQUEOUS-PHASE, OR ANY OTHER TYPE *
C * OF CHEMISTRY. FINALLY, IT SETS ARRAYS FOR BOTH DAY AND NIGHT *
C * CHEMISTRY OF EACH TYPE. *
C * *
C * HOW TO CALL SUBROUTINE: *
C * ---------------------- *
C * CALL KSPARSE.F FROM JSPARSE.F WITH *
C * NCS = 1..NCSGAS FOR GAS CHEMISTRY *
C *********************************************************************
C
C *********************************************************************
C * SETS UP ARRAYS FOR DECOMPOSITION / BACK-SUBSTITUTION OF SPARSE *
C * MATRICES BY REMOVING ALL CALCULATIONS INVOLVING A ZERO. *
C *********************************************************************
C
C *********************************************************************
C *********************************************************************
C ** SET ARRAYS TO TAKE ADVANTAGE OF SPARSE MATRICES **
C *********************************************************************
C *********************************************************************
C
C IFSUN = 1 THEN DAY-CHEMISTRY; = 2 THEN NIGHT CHEMISTRY
C NCSP = NCS FOR DAYTIME GAS CHEM
C NCSP = NCS +ICS FOR NIGHTTIME GAS CHEM
C
C KOUNT0A = # INITIAL MATRIX SPOTS FILLED W/O SPARSE-MATRIX REDUCTIONS
C KOUNT0 = # INITIAL MATRIX SPOTS FILLED WITH SPARSE-MATRIX REDUCTIONS
C KNTARRAY = # FINAL MATRIX SPOTS FILLED W/O SPARSE-MATRIX REDUCTIONS
C IARRAY2 = # FINAL MATRIX SPOTS FILLED WITH SPARSE-MATRIX REDUCTIONS
C ICNTA = # OPERATIONS IN DECOMP LOOP 1 W/O SPARSE-MATRIX REDUCTIONS
C ICNTB = # OPERATIONS IN DECOMP LOOP 1 WITH SPARSE-MATRIX REDUCTIONS
C JCNTA = # OPERATIONS IN DECOMP LOOP 2 W/O SPARSE-MATRIX REDUCTIONS
C JCNTB = # OPERATIONS IN DECOMP LOOP 2 WITH SPARSE-MATRIX REDUCTIONS
C KCNTA = # OPERATIONS IN BACK-SUP LOOP 1 W/O SPARSE-MATRIX REDUCTIONS
C KCNTB = # OPERATIONS IN BACK-SUB LOOP 1 WITH SPARSE-MATRIX REDUCTIONS
C MCNTA = # OPERATIONS IN BACK-SUP LOOP 2 W/O SPARSE-MATRIX REDUCTIONS
C MCNTB = # OPERATIONS IN BACK-SUB LOOP 2 WITH SPARSE-MATRIX REDUCTIONS
C
C LZERO = 1 IF AN ARRAY SPOT IS FILLED WITH A NON-ZERO VALUE. LZERO
C IS UPDATED AS WE SIMULATE THE ORDER OF CALCULATIONS DURING
C A PRACTICE L-U DECOMPOSITION
C
INTEGER KOUNT0A,KOUNT0,ICNTA,ICNTB
INTEGER KCNTA,KCNTB,MCNTA,MCNTV,IARRAY2,J,K,J1,I,I1,I2,KNTARRAY
INTEGER IZIL,NREMAIN,NFIVE,NFOUR,NTHREE,NTWO,NONE,IC,KA,KB,KC,KD
! Bug fix (gcc)
!INTEGER IA,KZIL,MC,JCNTA,JCNTB,MCNTA,MCNTB,KE,MZIL
INTEGER IA,KZIL,MC,JCNTA,JCNTB,MCNTB,KE,MZIL
INTEGER, SAVE :: MCNT,KCNT,ICNT,JCNT,MZTOT,IJTOT,KZTOT,IDECOMP
INTEGER, SAVE :: MCCOUNT,ICCOUNT,JCCOUNT,KCCOUNT,KBSUB,MBSUB
IF (IFNEVER.EQ.0) THEN
IFNEVER = 1
ICNT = 0
JCNT = 0
KCNT = 0
MCNT = 0
ICCOUNT = 0
JCCOUNT = 0
KCCOUNT = 0
MCCOUNT = 0
IDECOMP = 0
KBSUB = 0
MBSUB = 0
IJTOT = 0
KZTOT = 0
MZTOT = 0
ENDIF
C
KOUNT0A = 0
KOUNT0 = 0
ICNTA = 0
ICNTB = 0
JCNTA = 0
JCNTB = 0
KCNTA = 0
KCNTB = 0
MCNTA = 0
MCNTB = 0
IARRAY2 = 0
C
DO 522 J = 1, ISCHANG(NCS)
DO 520 K = 1, ISCHANG(NCS)
KOUNT0A = KOUNT0A + 1
IF (LZERO(K,J).EQ.1) KOUNT0 = KOUNT0 + 1
JARRAYPT(K,J) = 0
520 CONTINUE
522 CONTINUE
C
C *********************************************************************
C ** ARRAYS FOR DECOMPOSITION (LUDCMP) **
C *********************************************************************
C IZILCH = # OF CALCULATIONS WITH NON-ZERO VALUES DURING MATRIX DECOMP
C IZERO = EACH OCCURRENCE OF EACH IZILCH CALCULATION
C
DO 562 J = 1, ISCHANG(NCS)
JZILCH(J) = 0
J1 = J - 1
C
C ------------------- FIRST LOOP OF DECOMPOSTION ----------------------
C
DO 542 I = 2, ISCHANG(NCS)
IZILCH(J,I) = 0
I1 = J1
IF (I.LE.J1) I1 = I - 1
DO 540 K = 1, I1
ICNTA = ICNTA + 1
IF (LZERO(I,K).EQ.1.AND.LZERO(K,J).EQ.1) THEN
IZILCH(J,I) = IZILCH(J,I) + 1
ICNT = ICNT + 1
ICNTB = ICNTB + 1
IZEROK(ICNT) = K
LZERO(I,J) = 1
ENDIF
540 CONTINUE
542 CONTINUE
C
C ------------------- SECOND LOOP OF DECOMPOSTION ---------------------
C
C JZILCH = # OF CALCULATIONS WITH NON-ZERO VALUES TO FILL LOWER
C PART OF DECOMPOSED MATRIX
C
DO 560 I = J+1, ISCHANG(NCS)
JCNTA = JCNTA + 1
IF (LZERO(I,J).EQ.1) THEN
JZILCH(J) = JZILCH(J) + 1
JCNT = JCNT + 1
JCNTB = JCNTB + 1
JZERO(JCNT) = I
ENDIF
560 CONTINUE
562 CONTINUE
C
C *********************************************************************
C ** ARRAYS FOR BACK-SUBSTITUTION (LUBKSB) **
C *********************************************************************
C JZILCH AND KZILCH HAVE SAME NUMBER OF TOTAL ELEMENTS
C BOTH CONTAIN NON-ZEROS IN LOWER TRIANGLULAR MATRIX
C
C
C ------------------ FIRST LOOP OF BACK-SUBSTITUTION ------------------
C
DO 572 I = 2, ISCHANG(NCS)
KZILCH(I) = 0
I1 = I - 1
DO 570 J = 1, I1
KCNTA = KCNTA + 1
IF (LZERO(I,J).EQ.1) THEN
KZILCH(I) = KZILCH(I) + 1
KCNTB = KCNTB + 1
KCNT = KCNT + 1
IARRAY2 = IARRAY2 + 1
KZERO(KCNT) = J
JARRAYPT(I,J) = IARRAY2
ENDIF
570 CONTINUE
572 CONTINUE
C
C ----------------- SECOND LOOP OF BACK-SUBSTITUTION ------------------
C
C MZILCH CONTAINS NON-ZEROS FOR UPPER TRIANGULAR MATRIX, WHERE BACK-
C SUBSTITUTION OCCURS.
C
DO 577 I = ISCHANG(NCS), 1, -1
MZILCH(I) = 0
I2 = I + 1
DO 575 J = I+1, ISCHANG(NCS)
MCNTA = MCNTA + 1
IF (LZERO(I,J).EQ.1) THEN
MZILCH(I) = MZILCH(I) + 1
MCNTB = MCNTB + 1
MCNT = MCNT + 1
IARRAY2 = IARRAY2 + 1
MZERO(MCNT) = J
JARRAYPT(I,J) = IARRAY2
ENDIF
575 CONTINUE
577 CONTINUE
C
C *********************************************************************
C * FILL JARRAYPT WITH REMAINING ARRAY POINTS (ALONG DIAGONAL) *
C *********************************************************************
C
DO 580 I = 1, ISCHANG(NCS)
IARRAY2 = IARRAY2 + 1
JARRAYPT(I,I) = IARRAY2
580 CONTINUE
C
IARRAY(NCSP) = IARRAY2
KNTARRAY = KCNTA + MCNTA + ISCHANG(NCS)
C
C *********************************************************************
C *** CHANGE IZERO AND JZERO ARRAYS SO THEIR VALUES POINT TO NEW ***
C *** ARRAY POSITIONS DEFINED IN JARRAYPT ***
C *********************************************************************
C
C JARRAYPT = IDENTIFIES THE ONE-DIMENSIONAL ARRAY POINT FOR EACH TWO-
C DIMENSIONAL POINT I,J
C IARRAY = THE LENGTH OF THE ONE-DIMENSIONAL ARRAY HOLDING ALL
C SPARSE MATRIX POINTS = SPARSE-MATRIX DIMENSION
C IZER2 = USED TO IDENTIFY THE 1-D ARRAY POINT FOR EACH K,J VALUE
C FOUND IN THE FIRST MAJOR LOOP OF MATRIX DECOMPOSITION
C IZERO = USED TO FIND THE 1-D ARRAY POINT FOR EACH I,K VALUE
C FOUND IN THE SAME LOOP.
C
DO 595 J = 1, ISCHANG(NCS)
C
C ------------------- FIRST LOOP OF DECOMPOSTION ----------------------
C
IJTLO(J,NCSP) = IJTOT + 1
DO 605 I = 2, ISCHANG(NCS)
IZIL = IZILCH(J,I)
IF (IZIL.GT.0) THEN
IJTOT = IJTOT + 1
NREMAIN = IZIL
NFIVE = (NREMAIN + 0.0001d0) / 5
NREMAIN = NREMAIN - NFIVE * 5
NFOUR = (NREMAIN + 0.0001d0) / 4
NREMAIN = NREMAIN - NFOUR * 4
NTHREE = (NREMAIN + 0.0001d0) / 3
NREMAIN = NREMAIN - NTHREE * 3
NTWO = (NREMAIN + 0.0001d0) / 2
NREMAIN = NREMAIN - NTWO * 2
NONE = (NREMAIN + 0.0001d0)
NREMAIN = NREMAIN - NONE
C
IJVAL(IJTOT) = JARRAYPT(I,J)
IDL5( IJTOT) = IDECOMP + 1
IDH5( IJTOT) = IDECOMP + NFIVE
IDL4( IJTOT) = IDH5(IJTOT) + 1
IDH4( IJTOT) = IDH5(IJTOT) + NFOUR
IDL3( IJTOT) = IDH4(IJTOT) + 1
IDH3( IJTOT) = IDH4(IJTOT) + NTHREE
IDL2( IJTOT) = IDH3(IJTOT) + 1
IDH2( IJTOT) = IDH3(IJTOT) + NTWO
IDL1( IJTOT) = IDH2(IJTOT) + 1
IDH1( IJTOT) = IDH2(IJTOT) + NONE
IDECOMP = IDH1(IJTOT)
C
DO 601 IC = IDL5(IJTOT), IDH5(IJTOT)
KA = IZEROK(ICCOUNT+1)
KB = IZEROK(ICCOUNT+2)
KC = IZEROK(ICCOUNT+3)
KD = IZEROK(ICCOUNT+4)
KE = IZEROK(ICCOUNT+5)
ICCOUNT = ICCOUNT + 5
IKDECA(IC) = JARRAYPT(I,KA)
IKDECB(IC) = JARRAYPT(I,KB)
IKDECC(IC) = JARRAYPT(I,KC)
IKDECD(IC) = JARRAYPT(I,KD)
IKDECE(IC) = JARRAYPT(I,KE)
KJDECA(IC) = JARRAYPT(KA,J)
KJDECB(IC) = JARRAYPT(KB,J)
KJDECC(IC) = JARRAYPT(KC,J)
KJDECD(IC) = JARRAYPT(KD,J)
KJDECE(IC) = JARRAYPT(KE,J)
601 CONTINUE
C
DO 602 IC = IDH5(IJTOT) + 1, IDH4(IJTOT)
KA = IZEROK(ICCOUNT+1)
KB = IZEROK(ICCOUNT+2)
KC = IZEROK(ICCOUNT+3)
KD = IZEROK(ICCOUNT+4)
ICCOUNT = ICCOUNT + 4
IKDECA(IC) = JARRAYPT(I,KA)
IKDECB(IC) = JARRAYPT(I,KB)
IKDECC(IC) = JARRAYPT(I,KC)
IKDECD(IC) = JARRAYPT(I,KD)
KJDECA(IC) = JARRAYPT(KA,J)
KJDECB(IC) = JARRAYPT(KB,J)
KJDECC(IC) = JARRAYPT(KC,J)
KJDECD(IC) = JARRAYPT(KD,J)
602 CONTINUE
C
DO 603 IC = IDH4(IJTOT) + 1, IDH3(IJTOT)
KA = IZEROK(ICCOUNT+1)
KB = IZEROK(ICCOUNT+2)
KC = IZEROK(ICCOUNT+3)
ICCOUNT = ICCOUNT + 3
IKDECA(IC) = JARRAYPT(I,KA)
IKDECB(IC) = JARRAYPT(I,KB)
IKDECC(IC) = JARRAYPT(I,KC)
KJDECA(IC) = JARRAYPT(KA,J)
KJDECB(IC) = JARRAYPT(KB,J)
KJDECC(IC) = JARRAYPT(KC,J)
603 CONTINUE
C
DO 604 IC = IDH3(IJTOT) + 1, IDH2(IJTOT)
KA = IZEROK(ICCOUNT+1)
KB = IZEROK(ICCOUNT+2)
ICCOUNT = ICCOUNT + 2
IKDECA(IC) = JARRAYPT(I,KA)
IKDECB(IC) = JARRAYPT(I,KB)
KJDECA(IC) = JARRAYPT(KA,J)
KJDECB(IC) = JARRAYPT(KB,J)
604 CONTINUE
C
DO 606 IC = IDH2(IJTOT) + 1, IDH1(IJTOT)
KA = IZEROK(ICCOUNT+1)
ICCOUNT = ICCOUNT + 1
IKDECA(IC) = JARRAYPT(I,KA)
KJDECA(IC) = JARRAYPT(KA,J)
606 CONTINUE
ENDIF
605 CONTINUE
C
IJTHI(J,NCSP) = IJTOT
C
C ------------------ DIAGONAL TERM OF DECOMPOSTION --------------------
C
JARRDIAG(J,NCSP) = JARRAYPT(J,J)
C
C ------------------- SECOND LOOP OF DECOMPOSTION ---------------------
C
JLOZ1(J,NCSP) = JCCOUNT + 1
DO 635 I = 1, JZILCH(J)
JCCOUNT = JCCOUNT + 1
IA = JZERO(JCCOUNT)
JZEROA(JCCOUNT) = JARRAYPT(IA,J)
635 CONTINUE
JHIZ1(J,NCSP) = JCCOUNT
C
595 CONTINUE
C
C *********************************************************************
C ** CREATE MORE BACK-SUBSTITUTION ARRAYS TO INCREASE EFFICIENCY **
C *********************************************************************
C
C ------------------ FIRST LOOP OF BACK-SUBSTITUTION ------------------
C
KZTLO(NCSP) = KZTOT + 1
DO 620 I = 2, ISCHANG(NCS)
KZIL = KZILCH(I)
IF (KZIL.GT.0) THEN
KZTOT = KZTOT + 1
NREMAIN = KZIL
NFIVE = (NREMAIN + 0.0001d0) / 5
NREMAIN = NREMAIN - NFIVE * 5
NFOUR = (NREMAIN + 0.0001d0) / 4
NREMAIN = NREMAIN - NFOUR * 4
NTHREE = (NREMAIN + 0.0001d0) / 3
NREMAIN = NREMAIN - NTHREE * 3
NTWO = (NREMAIN + 0.0001d0) / 2
NREMAIN = NREMAIN - NTWO * 2
NONE = (NREMAIN + 0.0001d0)
NREMAIN = NREMAIN - NONE
C
IKZTOT(KZTOT) = I
KBL5( KZTOT) = KBSUB + 1
KBH5( KZTOT) = KBSUB + NFIVE
KBL4( KZTOT) = KBH5(KZTOT) + 1
KBH4( KZTOT) = KBH5(KZTOT) + NFOUR
KBL3( KZTOT) = KBH4(KZTOT) + 1
KBH3( KZTOT) = KBH4(KZTOT) + NTHREE
KBL2( KZTOT) = KBH3(KZTOT) + 1
KBH2( KZTOT) = KBH3(KZTOT) + NTWO
KBL1( KZTOT) = KBH2(KZTOT) + 1
KBH1( KZTOT) = KBH2(KZTOT) + NONE
KBSUB = KBH1(KZTOT)
C
DO 611 KC = KBL5(KZTOT), KBH5(KZTOT)
KZEROA(KC) = KZERO(KCCOUNT+1)
KZEROB(KC) = KZERO(KCCOUNT+2)
KZEROC(KC) = KZERO(KCCOUNT+3)
KZEROD(KC) = KZERO(KCCOUNT+4)
KZEROE(KC) = KZERO(KCCOUNT+5)
KCCOUNT = KCCOUNT + 5
611 CONTINUE
C
DO 612 KC = KBL4(KZTOT), KBH4(KZTOT)
KZEROA(KC) = KZERO(KCCOUNT+1)
KZEROB(KC) = KZERO(KCCOUNT+2)
KZEROC(KC) = KZERO(KCCOUNT+3)
KZEROD(KC) = KZERO(KCCOUNT+4)
KCCOUNT = KCCOUNT + 4
612 CONTINUE
C
DO 613 KC = KBL3(KZTOT), KBH3(KZTOT)
KZEROA(KC) = KZERO(KCCOUNT+1)
KZEROB(KC) = KZERO(KCCOUNT+2)
KZEROC(KC) = KZERO(KCCOUNT+3)
KCCOUNT = KCCOUNT + 3
613 CONTINUE
C
DO 614 KC = KBL2(KZTOT), KBH2(KZTOT)
KZEROA(KC) = KZERO(KCCOUNT+1)
KZEROB(KC) = KZERO(KCCOUNT+2)
KCCOUNT = KCCOUNT + 2
614 CONTINUE
C
DO 615 KC = KBL1(KZTOT), KBH1(KZTOT)
KZEROA(KC) = KZERO(KCCOUNT+1)
KCCOUNT = KCCOUNT + 1
615 CONTINUE
ENDIF
620 CONTINUE
KZTHI(NCSP) = KZTOT
C
C ----------------- SECOND LOOP OF BACK-SUBSTITUTION ------------------
C
DO 640 I = ISCHANG(NCS), 1, -1
MZIL = MZILCH(I)
IF (MZIL.GT.0) THEN
MZTOT = MZTOT + 1
NREMAIN = MZIL
NFIVE = (NREMAIN + 0.0001d0) / 5
NREMAIN = NREMAIN - NFIVE * 5
NFOUR = (NREMAIN + 0.0001d0) / 4
NREMAIN = NREMAIN - NFOUR * 4
NTHREE = (NREMAIN + 0.0001d0) / 3
NREMAIN = NREMAIN - NTHREE * 3
NTWO = (NREMAIN + 0.0001d0) / 2
NREMAIN = NREMAIN - NTWO * 2
NONE = (NREMAIN + 0.0001d0)
NREMAIN = NREMAIN - NONE
C
IMZTOT(I,NCSP) = MZTOT
MBL5( MZTOT) = MBSUB + 1
MBH5( MZTOT) = MBSUB + NFIVE
MBL4( MZTOT) = MBH5(MZTOT) + 1
MBH4( MZTOT) = MBH5(MZTOT) + NFOUR
MBL3( MZTOT) = MBH4(MZTOT) + 1
MBH3( MZTOT) = MBH4(MZTOT) + NTHREE
MBL2( MZTOT) = MBH3(MZTOT) + 1
MBH2( MZTOT) = MBH3(MZTOT) + NTWO
MBL1( MZTOT) = MBH2(MZTOT) + 1
MBH1( MZTOT) = MBH2(MZTOT) + NONE
MBSUB = MBH1(MZTOT)
C
DO 631 MC = MBL5(MZTOT), MBH5(MZTOT)
MZEROA(MC) = MZERO(MCCOUNT+1)
MZEROB(MC) = MZERO(MCCOUNT+2)
MZEROC(MC) = MZERO(MCCOUNT+3)
MZEROD(MC) = MZERO(MCCOUNT+4)
MZEROE(MC) = MZERO(MCCOUNT+5)
MCCOUNT = MCCOUNT + 5
631 CONTINUE
C
DO 632 MC = MBL4(MZTOT), MBH4(MZTOT)
MZEROA(MC) = MZERO(MCCOUNT+1)
MZEROB(MC) = MZERO(MCCOUNT+2)
MZEROC(MC) = MZERO(MCCOUNT+3)
MZEROD(MC) = MZERO(MCCOUNT+4)
MCCOUNT = MCCOUNT + 4
632 CONTINUE
C
DO 633 MC = MBL3(MZTOT), MBH3(MZTOT)
MZEROA(MC) = MZERO(MCCOUNT+1)
MZEROB(MC) = MZERO(MCCOUNT+2)
MZEROC(MC) = MZERO(MCCOUNT+3)
MCCOUNT = MCCOUNT + 3
633 CONTINUE
C
DO 634 MC = MBL2(MZTOT), MBH2(MZTOT)
MZEROA(MC) = MZERO(MCCOUNT+1)
MZEROB(MC) = MZERO(MCCOUNT+2)
MCCOUNT = MCCOUNT + 2
634 CONTINUE
C
DO 636 MC = MBL1(MZTOT), MBH1(MZTOT)
MZEROA(MC) = MZERO(MCCOUNT+1)
MCCOUNT = MCCOUNT + 1
636 CONTINUE
ENDIF
640 CONTINUE
C
C *********************************************************************
C ** CHECK DIMENSIONS AND PRINT OUT ARRAY SAVINGS **
C *********************************************************************
C
IF (ICNT .GT. MXCOUNT2 .OR. JCNT .GT. MXCOUNT3 .OR.
1 KCNT .GT. MXCOUNT3 .OR. MCNT .GT. MXCOUNT3 .OR.
2 ICCOUNT .GT. MXCOUNT2 .OR. JCCOUNT .GT. MXCOUNT3 .OR.
3 KCCOUNT .GT. MXCOUNT3 .OR. MCCOUNT .GT. MXCOUNT3 .OR.
4 IJTOT .GT. MXCOUNT3 .OR. IDECOMP .GT. MXCOUNT3 .OR.
5 KZTOT .GT. MXCOUNT4 .OR. KBSUB .GT. MXCOUNT4 .OR.
6 MZTOT .GT. MXCOUNT4 .OR. MBSUB .GT. MXCOUNT4 .OR.
7 IARRAY2 .GT. MXARRAY) THEN
C
WRITE(6,705)
1 MXCOUNT2, ICNT, MXCOUNT3, JCNT,
2 MXCOUNT3, KCNT, MXCOUNT3, MCNT,
3 MXCOUNT2, ICCOUNT, MXCOUNT3, JCCOUNT,
4 MXCOUNT3, KCCOUNT, MXCOUNT3, MCCOUNT,
5 MXCOUNT3, IJTOT, MXCOUNT3, IDECOMP,
6 MXCOUNT4, KZTOT, MXCOUNT4, KBSUB,
7 MXCOUNT4, MZTOT, MXCOUNT4, MBSUB,
8 MXARRAY, IARRAY2
CALL GEOS_CHEM_STOP
ENDIF
C
705 FORMAT('KSPARSE: ONE OF THE DIMENSIONS BELOW IS TOO SMALL:',/,
1 'DIMENSION: MXCOUNT2 = ',I5,' VARIABLE: ICNT = ',I5,/,
2 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: JCNT = ',I5,/,
3 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: KCNT = ',I5,/,
4 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: MCNT = ',I5,/,
5 'DIMENSION: MXCOUNT2 = ',I5,' VARIABLE: ICCOUNT = ',I5,/,
6 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: JCCOUNT = ',I5,/,
7 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: KCCOUNT = ',I5,/,
8 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: MCCOUNT = ',I5,/,
9 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: IJTOT = ',I5,/,
1 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: IDECOMP = ',I5,/,
2 'DIMENSION: MXCOUNT4 = ',I5,' VARIABLE: KZTOT = ',I5,/,
3 'DIMENSION: MXCOUNT4 = ',I5,' VARIABLE: KBSUB = ',I5,/,
4 'DIMENSION: MXCOUNT4 = ',I5,' VARIABLE: MZTOT = ',I5,/,
5 'DIMENSION: MXCOUNT4 = ',I5,' VARIABLE: MBSUB = ',I5,/,
6 'DIMENSION: MXARRAY = ',I5,' VARIABLE: IARRAY2 = ',I5)
C
WRITE(IO93,655)NCSP,KOUNT0A,KOUNT0,KNTARRAY,IARRAY2,ICNTA,ICNTB,
1 JCNTA,JCNTB,KCNTA,KCNTB,MCNTA,MCNTB
C
655 FORMAT(/'PARAM POSS MATRIX POINTS -- NONZEROS -- NCSP=',I4/
1 'INITMAT ',4X,I8,9X,I8/
2 'FINMAT ',4X,I8,9X,I8/
3 'DECOMP1 ',4X,I8,9X,I8/
4 'DECOMP2 ',4X,I8,9X,I8/
5 'BACKSB1 ',4X,I8,9X,I8/
6 'BACKSB2 ',4X,I8,9X,I8/)
C
C *********************************************************************
C * SET COEFFICIENTS OF THE INTEGRATION METHOD *
C *********************************************************************
C
C PARAMETERS USED IN SMVGEAR
C --------------------------
C PERTST = COEFFICIENTS USED TO SELECT THE STEP-SIZE AND ORDER. THUS,
C ONLY ABOUT ONE-PERCENT ACCURACY NEEDED. SEE GEAR(1971)
C OR HINDMARSH '73 UCID-30059.
C ASET = PARAMETERS FOR DETERMINING THE ORDER OF THE INTEGRATION METHOD
C AND FOR CALCULATION THE MATRIX P.
C MSTEP = MAXIMUM NUMBER OF CORRECTOR ITERATIONS ALLOWED
C HMIN = MINIMUM TIME-STEP ALLOWED (SEC)
C MAXORD = MAXIMUM ORDER OF THE METHOD USED
C MBETWEEN = MAXIMUM NUMBER OF STEPS BETWEEN CALLS TO PDERIV
C NQQ = ORDER OF THE INTEGRATION METHOD
C
IF (IFDID.EQ.0) THEN
IFDID = 1
C
! Now force double-precision with "D" exponents (bmy, 4/18/03)
DATA PERTST /
1 2.0d0, 4.5d0, 7.333d0, 10.42d0, 13.7d0, 17.15d0, 1.0d0,
3 3.0d0, 6.0d0, 9.167d0, 12.5d0, 15.98d0, 1.0d0, 1.0d0,
5 1.0d0, 1.0d0, 0.5d0, 0.1667d0, 0.04133d0, 0.008267d0, 1.0d0/
C
C ADAMS-MOULTON COEFFICIENTS
C
C 2 2.0, 12.0, 24.0, 37.89, 53.33, 70.08, 87.97,
C 4 12.0, 24.0, 37.89, 53.33, 70.08, 87.97, 1.0,
C 6 1.0, 1.0, 2.0, 1.0, 0.3157, 0.07407, 0.0139 /
C
MSTEP = 3
HMIN = 1.0d-15
MAXORD = 5
MBETWEEN = 50
C
DO 800 NQQ = 1, 7
ENQQ1(NQQ) = 0.5d0 / FLOAT(NQQ )
ENQQ2(NQQ) = 0.5d0 / FLOAT(NQQ + 1)
ENQQ3(NQQ) = 0.5d0 / FLOAT(NQQ + 2)
CONPST(NQQ) = 1.0d0 / (PERTST(NQQ,1) * ENQQ3(NQQ))
CONP15(NQQ) = 1.5d0 * CONPST(NQQ)
PERTS2(NQQ,1) = PERTST(NQQ,1) * PERTST(NQQ,1)
PERTS2(NQQ,2) = PERTST(NQQ,2) * PERTST(NQQ,2)
PERTS2(NQQ,3) = PERTST(NQQ,3) * PERTST(NQQ,3)
800 CONTINUE
C
DO 830 I2 = 1, 6
ASET(I2,2) = 1.0d0
ASET(I2,8) = 0.d0
830 CONTINUE
C
ASET(1,1) = 1.0d0
C
ASET(2,1) = 2.0d0 / 3.0d0
ASET(2,3) = 1.0d0 / 3.0d0
C
ASET(3,1) = 6.0d0 / 11.0d0
ASET(3,3) = 6.0d0 / 11.0d0
ASET(3,4) = 1.0d0 / 11.0d0
C
ASET(4,1) = 12.0d0 / 25.0d0
ASET(4,3) = .70d0
ASET(4,4) = .20d0
ASET(4,5) = .020d0
C
ASET(5,1) = 60.0d0 / 137.0d0
ASET(5,3) = 225.0d0 / 274.0d0
ASET(5,4) = 85.0d0 / 274.0d0
ASET(5,5) = 15.0d0 / 274.0d0
ASET(5,6) = 1.0d0 / 274.0d0
C
ASET(6,1) = 180.0d0 / 441.0d0
ASET(6,3) = 406.0d0 / 441.0d0
ASET(6,4) = 735.0d0 / 1764.0d0
ASET(6,5) = 175.0d0 / 1764.0d0
ASET(6,6) = 21.0d0 / 1764.0d0
ASET(6,7) = 1.0d0 / 1764.0d0
C
ENDIF
C ENDIF IFDID.EQ.0
C
C *********************************************************************
C ********************** END OF SUBROUTINE KSPARSE ********************
C *********************************************************************
C
RETURN
END SUBROUTINE KSPARSE

464
code/lai_mod.f Normal file
View File

@ -0,0 +1,464 @@
! $Id: lai_mod.f,v 1.1 2009/06/09 21:51:52 daven Exp $
MODULE LAI_MOD
!
!******************************************************************************
! Module LAI_MOD reads and stores AVHRR LAI for calculating MEGAN biogenic
! VOC emissions. (dsa, tmf, bmy, 10/20/05, 11/6/08)
!
! Module Variables:
! ============================================================================
! (1 ) ISOLAI (REAL*8 ) : AVHRR LAI data for the current day
! (2 ) MISOLAI (REAL*8 ) : AVHRR LAI data for the current month
! (3 ) NMISOLAI (REAL*8 ) : AVHRR LAI data for the next month
! (4 ) PMISOLAI (REAL*8 ) : AVHRR LAI data for the previous month
! (5 ) DAYS_BTW_M (INTEGER) : days btw the current & previous months for LAI
!
! Module Routines:
! ============================================================================
! (1 ) READISOLAI : Reads monthly AVHRR LAI data
! (2 ) RDISOLAI : Calls READISOLAI and interpolates to daily LAI
! (8 ) INIT_LAI : Allocate and initialize data array
! (9 ) CLEANUP_LAI : Deallocate data array
!
! GEOS-CHEM modules referenced by megan_mod.f
! ============================================================================
! (1 ) bpch2_mod.f : Module w/ routines for binary punch file I/O
! (2 ) error_mod.f : Module w/ I/O error and NaN check routines
! (3 ) transfer_mod.f : Module w/ routines to cast & resize arrays
!
! References:
! ============================================================================
!
! NOTES:
! (1 ) Original code (biogen_em_mod.f) by Dorian Abbot (7/8/03). Updated
! and modified for the standard code by May Fu (11/2004).
! (2 ) MEGAN is currently locked to use AVHRR LAI data.
! The LAVHRRLAI logical switch controls whether the AVHRR LAI data
! is used for the GEIA inventory and dry deposition.
! (3 ) Modifications for 0.5 x 0.667 nested grid. Added routine
! READISOLAI_05x0666 to read finer-resolution data for GEOS-5 nested
! grids. (yxw, dan, bmy, 11/6/08)
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE PRIVATE DECLARATIONS -- keep certain internal variables
! and routines from being seen outside "lai_mod.f"
!=================================================================
! PRIVATE module variables
!=================================================================
! MODULE VARIABLES
!=================================================================
REAL*8, ALLOCATABLE :: ISOLAI(:,:)
REAL*8, ALLOCATABLE :: MISOLAI(:,:)
REAL*8, ALLOCATABLE :: NMISOLAI(:,:)
REAL*8, ALLOCATABLE :: PMISOLAI(:,:)
INTEGER :: DAYS_BTW_M
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
SUBROUTINE READISOLAI( MM )
!
!******************************************************************************
! Subroutine READISOLAI reads AVHRR LAI data from bpch file for the current
! month, the previous month, and the next month. (dsa, tmf, bmy, 10/18/05)
!
! Arguments as Input:
! ============================================================================
! (1 ) MM (INTEGER) : Current month number (1-12)
!
! NOTES:
! (1 ) Original code (biogen_em_mod.f) by Dorian Abbot (7/8/03). Updated
! and modified for the standard code by May Fu (11/2004).
!******************************************************************************
!
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2, GET_RES_EXT
USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1
USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1
USE TRANSFER_MOD, ONLY : TRANSFER_2D
! (lzh,02/01/2015) update regridding
USE REGRID_A2A_MOD, ONLY : DO_REGRID_A2A
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
! Arguments
INTEGER, INTENT(IN) :: MM
! Local variables
INTEGER :: I, J, K, INDEX, MMM, PMM, IJLOOP
REAL*4 :: ARRAY(I1x1,J1x1,1)
REAL*8 :: TAU0
CHARACTER(LEN=255) :: FILENAME
! (lzh, 02/01/2015)
CHARACTER(LEN=255) :: LLFILENAME
REAL*8 :: INGRID(I1x1,J1x1)
REAL*8 :: OUTGRID(IIPAR,JJPAR)
!=================================================================
! READISOLAI begins here!
!=================================================================
! Zero arrays
MISOLAI = 0.d0
NMISOLAI = 0.d0
ARRAY = 0.d0
!------------------------------------
! Read current month's lai at (I,J)
!------------------------------------
! Filename
FILENAME = TRIM( DATA_DIR_1x1 ) //
& 'leaf_area_index_200412/avhrrlai.global.geos.1x1.2000'
! Echo info
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( ' - READISOLAI: Reading ', a )
! Get TAU0 value
TAU0 = GET_TAU0( MM, 1, 2000 )
! Read 1x1 LAI data [cm2/cm2]
CALL READ_BPCH2( FILENAME, 'AVHRR', 1,
& TAU0, I1x1, J1x1,
& 1, ARRAY, QUIET=.TRUE. )
! Regrid from 1x1 to current grid resolution
!CALL DO_REGRID_1x1( 'cm2/cm2', ARRAY, MISOLAI )
! (lzh, 02/01/2015)
! File with lat/lon edges for regridding
LLFILENAME = TRIM( DATA_DIR_1x1) //
& 'MAP_A2A_Regrid_201203/latlon_geos1x1_new.txt'
INGRID = ARRAY(:,:,1)
CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,
& INGRID, OUTGRID, IS_MASS=0 )
MISOLAI = OUTGRID
!------------------------------------
! Read next month's lai at (I,J)
!------------------------------------
! MMM is next month
MMM = MM + 1
IF ( MMM == 13 ) MMM = 1
! TAU0 for 1st day of next month
TAU0 = GET_TAU0( MMM, 1, 2000 )
! Read data
CALL READ_BPCH2( FILENAME, 'AVHRR', 1,
& TAU0, I1x1, J1x1,
& 1, ARRAY, QUIET=.TRUE. )
! Regrid from 1x1 to current grid resolution
!CALL DO_REGRID_1x1( 'cm2/cm2', ARRAY, NMISOLAI )
! (lzh, 02/01/2015)
INGRID = ARRAY(:,:,1)
CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,
& INGRID, OUTGRID, IS_MASS=0 )
NMISOLAI = OUTGRID
!------------------------------------
! Read previous month's lai at (I,J)
!------------------------------------
! PMM is previous month
PMM = MM - 1
IF ( PMM == 0 ) PMM = 12
! TAU0 for 1st day of previous month
TAU0 = GET_TAU0( PMM, 1, 2000 )
! Read data
CALL READ_BPCH2( FILENAME, 'AVHRR', 1,
& TAU0, I1x1, J1x1,
& 1, ARRAY, QUIET=.TRUE. )
! Regrid from 1x1 to current grid resolution
!CALL DO_REGRID_1x1( 'cm2/cm2', ARRAY, PMISOLAI )
! (lzh, 02/01/2015)
INGRID = ARRAY(:,:,1)
CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,
& INGRID, OUTGRID, IS_MASS=0 )
PMISOLAI = OUTGRID
! Return to calling program
END SUBROUTINE READISOLAI
!------------------------------------------------------------------------------
SUBROUTINE READISOLAI_05x0666( MM )
!
!******************************************************************************
! Subroutine READISOLAI reads AVHRR LAI data from bpch file for the current
! month, the previous month, and the next month. Specially constructed to
! read hi-res data for the GEOS-5 0.5 x 0.666 nested grid simulations.
! (yxw, bmy, dan, 11/6/08)
!
! Arguments as Input:
! ============================================================================
! (1 ) MM (INTEGER) : Current month number (1-12)
!
! NOTES:
!******************************************************************************
!
! Modules
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2, GET_RES_EXT
USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1
USE TRANSFER_MOD, ONLY : TRANSFER_2D
USE DIRECTORY_MOD, ONLY : DATA_DIR
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
! Arguments
INTEGER, INTENT(IN) :: MM
! Local variables
INTEGER :: I, J, K, INDEX, MMM, PMM, IJLOOP
REAL*4 :: ARRAY(IGLOB,JGLOB,1)
REAL*8 :: TAU0
CHARACTER(LEN=255) :: FILENAME
!=================================================================
! READISOLAI begins here!
!=================================================================
! Zero arrays
MISOLAI = 0.d0
NMISOLAI = 0.d0
ARRAY = 0.d0
!------------------------------------
! Read current month's lai at (I,J)
!------------------------------------
! Filename
FILENAME = TRIM( DATA_DIR ) //
& 'leaf_area_index_200412/avhrrlai.global.geos.05x0666.2000'
! Echo info
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( ' - READISOLAI: Reading ', a )
! Get TAU0 value
TAU0 = GET_TAU0( MM, 1, 2000 )
! Read 1x1 LAI data [cm2/cm2]
CALL READ_BPCH2( FILENAME, 'AVHRR', 1,
& TAU0, IGLOB, JGLOB,
& 1, ARRAY, QUIET=.TRUE. )
CALL TRANSFER_2D( ARRAY(:,:,1), MISOLAI )
!------------------------------------
! Read next month's lai at (I,J)
!------------------------------------
! MMM is next month
MMM = MM + 1
IF ( MMM == 13 ) MMM = 1
! TAU0 for 1st day of next month
TAU0 = GET_TAU0( MMM, 1, 2000 )
! Read data
CALL READ_BPCH2( FILENAME, 'AVHRR', 1,
& TAU0, IGLOB, JGLOB,
& 1, ARRAY, QUIET=.TRUE. )
CALL TRANSFER_2D( ARRAY(:,:,1), NMISOLAI )
!------------------------------------
! Read previous month's lai at (I,J)
!------------------------------------
! PMM is previous month
PMM = MM - 1
IF ( PMM == 0 ) PMM = 12
! TAU0 for 1st day of previous month
TAU0 = GET_TAU0( PMM, 1, 2000 )
! Read data
CALL READ_BPCH2( FILENAME, 'AVHRR', 1,
& TAU0, IGLOB, JGLOB,
& 1, ARRAY, QUIET=.TRUE. )
CALL TRANSFER_2D( ARRAY(:,:,1), PMISOLAI )
! Return to calling program
END SUBROUTINE READISOLAI_05x0666
!------------------------------------------------------------------------------
SUBROUTINE RDISOLAI( JDAY, MONTH )
!
!******************************************************************************
! Subroutine RDISOLAI sets ISOLAI daily. The stored monthly LAI are used for
! the middle day in the month and LAIs are interpolated for other days.
! (dsa, tmf, bmy, 10/20/05, 11/6/08)
!
! Arguments as Input:
! ============================================================================
! (1 ) JDAY (INTEGER) : Julian Day
! (2 ) MONTH (INTEGER) : Calendar month JDAY is in.
!
! NOTES:
! (1 ) Original code (biogen_em_mod.f) by Dorian Abbot (7/8/03). Updated
! and modified for the standard code by May Fu (11/2004).
! (2 ) Now call READISOLAI_05x0666 to read hi-res LAI data if we are doing a
! GEOS-5 0.5 x 0.666 nested grid simulation. (yxw, dan, bmy, 11/6/08)
!******************************************************************************
!
! References to F90 modules
USE TIME_MOD, ONLY : ITS_A_LEAPYEAR
# include "CMN_SIZE" ! Size parameters
! Arguments
INTEGER, INTENT(IN) :: JDAY, MONTH
! Local variables
INTEGER :: I, J, IMUL, ITD, IJLOOP, MM
INTEGER, SAVE :: LAST_MM = -1
REAL*8 :: FRACTION
! specify midmonth day for year 2000
INTEGER, PARAMETER :: STARTDAY(13) =
& (/ 15, 45, 74, 105, 135, 166,
& 196, 227, 258, 288, 319, 349, 380/)
!=================================================================
! RDISOLAI begins here!
!=================================================================
! Find the month if we index by midmonth
CALL FINDMON( JDAY, MONTH, MM, STARTDAY )
! Read new data if it's a new LAI month
IF ( MM /= LAST_MM ) THEN
#if defined( GRID05x0666 )
CALL READISOLAI_05x0666( MM ) ! GEOS-5 nested grid simulation
#else
CALL READISOLAI( MM ) ! Global simulations
#endif
! Save for next month
LAST_MM = MM
ENDIF
! IMUL is days since midmonth
! ITD is days between midmonths
IF ( JDAY < STARTDAY(1) ) THEN
IMUL = 365 + JDAY - STARTDAY(12)
ITD = 31
ELSE
IMUL = JDAY - STARTDAY(MM)
ITD = STARTDAY(MM+1) - STARTDAY(MM)
END IF
! Archive the days between midmonths in the LAI data
DAYS_BTW_M = ITD
! Fraction of the LAI month that we are in
FRACTION = DBLE( IMUL ) / DBLE( ITD )
! Interpolate to daily LAI value
DO J = 1, JJPAR
DO I = 1, IIPAR
ISOLAI(I,J) = MISOLAI(I,J) +
& ( FRACTION * ( NMISOLAI(I,J) - MISOLAI(I,J) ) )
ENDDO
ENDDO
! Return to calling program
END SUBROUTINE RDISOLAI
!------------------------------------------------------------------------------
SUBROUTINE INIT_LAI
!
!******************************************************************************
! Subroutine INIT_ISOLAI allocates and initializes arrays for AVHRR LAI.
! (dsa, tmf, 7/8/03, 11/20/04)
!
! NOTES:
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : ALLOC_ERR
# include "CMN_SIZE" ! Size parameters
! Local Variables
INTEGER :: AS
!=================================================================
! INIT_ISOLAI begins here!
!=================================================================
ALLOCATE( ISOLAI( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'ISOLAI' )
ISOLAI = 0d0
ALLOCATE( MISOLAI( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'MISOLAI' )
MISOLAI = 0d0
ALLOCATE( NMISOLAI( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'NMISOLAI' )
NMISOLAI = 0d0
ALLOCATE( PMISOLAI( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'PMISOLAI' )
PMISOLAI = 0d0
! Return to calling program
END SUBROUTINE INIT_LAI
!------------------------------------------------------------------------------
SUBROUTINE CLEANUP_LAI
!
!******************************************************************************
! Subroutine CLEANUP_ISOLAI deallocates all allocated arrays at the
! end of a GEOS-CHEM model run. (dsa 7/8/03)
!
! NOTES:
!******************************************************************************
!
!=================================================================
! CLEANUP_ISOLAI begins here!
!=================================================================
IF ( ALLOCATED( ISOLAI ) ) DEALLOCATE( ISOLAI )
IF ( ALLOCATED( MISOLAI ) ) DEALLOCATE( MISOLAI )
IF ( ALLOCATED( NMISOLAI ) ) DEALLOCATE( NMISOLAI )
IF ( ALLOCATED( PMISOLAI ) ) DEALLOCATE( PMISOLAI )
! Return to calling program
END SUBROUTINE CLEANUP_LAI
!------------------------------------------------------------------------------
! End of module
END MODULE LAI_MOD

81
code/linux_err.c Normal file
View File

@ -0,0 +1,81 @@
/* $Id: linux_err.c,v 1.1 2009/06/09 21:51:52 daven Exp $ */
#include <math.h>
int is_nan_( double *x ) {
/*====================================================================
* C function "is_nan_" is a wrapper for the Linux function isnan(x).
* (bmy, 3/22/02)
*
* isnan(x) returns
* non-zero : if x is Not-a-Number (NaN),
* zero : otherwise
*
* Note that we must declare x as a pointer (i.e. we write *x
* instead of x) since FORTRAN will pass by reference. In other
* words, FORTRAN will pass the memory location of the variable x
* to this routine.
*
* Also, the underscore in the last character of the routine name
* "is_nan_" is needed so that we can call this from FORTRAN.
*====================================================================
*/
/* isnan is a library call, return value to calling program */
return isnan( *x );
}
int is_inf_( double *x ) {
/*====================================================================
* C function "is_inf_" is a wrapper for the Linux function isinf(x).
* (bmy, 3/22/02)
*
* isinf(x) returns
* -1 : if x is negative infinity
* 1 : if x is positive infinity
* 0 : otherwise
*
* Note that we must declare x as a pointer (i.e. we write *x
* instead of x) since FORTRAN will pass by reference. In other
* words, FORTRAN will pass the memory location of the variable x
* to this routine.
*
* Also, the underscore in the last character of the routine name
* "is_inf_" is needed so that we can call this from FORTRAN.
*====================================================================
*/
/* isinf is a library call, return value to calling program */
return isinf( *x );
}
int is_finite_( double *x ) {
/*====================================================================
* C function "is_finite_" is a wrapper for the Linux function
* finite(x). (bmy, 3/22/02)
*
* finite(x) returns
* non-zero : if x is +/- infinity or NaNis negative infinity
* zero : otherwise
*
* Note that we must declare x as a pointer (i.e. we write *x
* instead of x) since FORTRAN will pass by reference. In other
* words, FORTRAN will pass the memory location of the variable x
* to this routine.
*
* Also, the underscore in the last character of the routine name
* "is_finite_" is needed so that we can call this from FORTRAN.
*====================================================================
*/
/* finite is a library call, return value to calling program */
return finite( *x );
}

313
code/logical_mod.f Normal file
View File

@ -0,0 +1,313 @@
! $Id: logical_mod.f,v 1.5 2012/03/01 22:00:26 daven Exp $
MODULE LOGICAL_MOD
!
!******************************************************************************
! Module LOGICAL_MOD contains all of the logical switches used by GEOS-CHEM.
! (bmy, 7/9/04, 9/24/07)
!
! Module Variables:
! ============================================================================
! (1 ) LAIRNOX (LOGICAL) : ON/OFF switch for aircraft NOx emissions
! (2 ) LATEQ (LOGICAL) : --
! (3 ) LAVHRRLAI (LOGICAL) : ON/OFF switch for reading AVHRR-derived LAI data
! (4 ) LBIONOX (LOGICAL) : ON/OFF switch for biomass burning emissions
! (5 ) LBBSEA (LOGICAL) : ON/OFF switch for seasonal biomass emissions
! (6 ) LCARB (LOGICAL) : ON/OFF switch for ONLINE CARBONACEOUS AEROSOLS
! (7 ) LCHEM (LOGICAL) : ON/OFF switch for CHEMISTRY
! (8 ) LCONV (LOGICAL) : ON/OFF switch for CLOUD CONVECTION
! (9 ) LDBUG (LOGICAL) : --
! (10) LDEAD (LOGICAL) : Toggles DEAD (=T) or GOCART (=F) dust emissions
! (11) LDIAG (LOGICAL) : --
! (12) LDRYD (LOGICAL) : ON/OFF switch for DRY DEPOSITION
! (13) LDUST (LOGICAL) : ON/OFF switch for online DUST MOBILIZATION
! (14) LEMBED (LOGICAL) : ON/OFF switch for EMBEDDED CHEMISTRY
! (15) LEMEP (LOGICAL) : ON/OFF switch for EMEP EUROPEAN EMISSIONS
! (16) LEMIS (LOGICAL) : ON/OFF switch for EMISSIONS
! (17) LFFNOX (LOGICAL) : ON/OFF switch for FOSSIL FUEL NOx
! (18) LFILL (LOGICAL) : Argument for TPCORE (transport)
! (19) LFOSSIL (LOGICAL) : ON/OFF switch for ANTHROPOGENIC EMISSIONS
! (20) LLIGHTNOX (LOGICAL) : ON/OFF switch for LIGHTNING NOx EMISSIONS
! (21) LCTH (LOGICAL) : ON/OFF switch for CTH LIGHTNING PARAMETERIZATION
! (22) LMFLUX (LOGICAL) : ON/OFF switch for MFLUX LIGHTNING PARAMETERIZ'N
! (23) LPRECON (LOGICAL) : ON/OFF switch for PRECON LIGHTNING PARAMETERIZ'N
! (24) LMEGAN (LOGICAL): ON/OFF switch for MEGAN BIOGENIC EMISSIONS for ISOP
! (24) LMEGANMONO (LOGICAL): ON/OFF switch for MEGAN BIOGENIC EMISSIONS
! for MONO and MBO.
! (25) LMFCT (LOGICAL) : Argument for TPCORE (transport)
! (26) LMONOT (LOGICAL) : Scales acetone to monoterpene emission
! (27) LNEI99 (LOGICAL) : Toggles on EPA/NEI 99 emissions over cont. USA
! (28) LPRT (LOGICAL) : Toggles ND70 debug output (via DEBUG_MSG)
! (29) LSHIPSO2 (LOGICAL) : ON/OFF switch for SO2 EMISSIONS FROM SHIP EXHAUST
! (30) LSOA (LOGICAL) : ON/OFF switch for SECONDARY ORGANIC AEROSOLS
! (31) LSOILNOX (LOGICAL) : ON/OFF switch for SOIL NOx EMISSIONS
! (32) LSPLIT (LOGICAL) : Splits
! (33) LSSALT (LOGICAL) : ON/OFF switch for online SEA SALT AEROSOLS
! (34) LSTDRUN (LOGICAL) : ON/OFF switch to save init/final masses std runs
! (35) LSULF (LOGICAL) : ON/OFF switch for online SULFATE AEROSOLS
! (36) LSVGLB (LOGICAL) : ON/OFF switch for SAVING A RESTART FILE
! (37) LTPFV (LOGICAL) : If =T, will use fvDAS TPCORE for GEOS-3 winds
! (38) LTRAN (LOGICAL) : ON/OFF switch for TRANSPORT
! (39) LTOMSAI (LOGICAL) : ON/OFF switch for scaling biomass w/ TOMS AI data
! (40) LTURB (LOGICAL) : ON/OFF switch for PBL MIXING
! (41) LUNZIP (LOGICAL) : ON/OFF switch for unzipping met field data
! (42) LUPBD (LOGICAL) : ON/OFF switch for STRATOSPHERIC O3, NOy BC's
! (43) LWAIT (LOGICAL) : ON/OFF switch for unzipping met fields in fg
! (44) LWETD (LOGICAL) : ON/OFF switch for WET DEPOSITION
! (45) LWINDO (LOGICAL) : ON/OFF switch for WINDOW TRANSPORT (usually 1x1)
! (46) LWOODCO (LOGICAL) : ON/OFF switch for BIOFUEL EMISSIONS
! (47) LDYNOCEAN (LOGICAL) : ON/OFF switch for OCEAN MERCURY MODULE
! (48) LGFED2BB (LOGICAL) : ON/OFF switch for GFED2 BIOMASS BURNING
! (49) LBRAVO (LOGICAL) : ON/OFF switch for BRAVO EMISSIONS
! (50) LEDGAR (LOGICAL) : ON/OFF switch for EDGAR emissions
! (51) LEDGARNOx (LOGICAL) : ON/OFF switch for EDGAR NOx emissions
! (52) LEDGARCO (LOGICAL) : ON/OFF switch for EDGAR CO emissions
! (53) LEDGARSHIP(LOGICAL) : ON/OFF switch for EDGAR ship exhaust emissions
! (54) LEDGARSOx (LOGICAL) : ON/OFF switch for EDGAR SOx emissions
! (55) LSTREETS (LOGICAL) : ON/OFF switch for David Streets' emissions
! (56) LVARTROP (LOGICAL) : ON/OFF switch for Variable Tropopause
! (57) LOTDREG (LOGICAL) : ON/OFF switch for OTD-LIS regional redistribution
! (57) LOTDLOC (LOGICAL) : ON/OFF switch for OTD-LIS local redistribution
! (58) LOTDSCALE (LOGICAL) : ON/OFF switch for scaling to OTD-LIS climatology
! (59) LCAC (LOGICAL) : ON/OFF switch for CAC Canadian anthro emissions
! (60) LARCSHIP (LOGICAL) : ON/OFF switch for ARCTAS ship SO2 emissions
! (61) LEMEPSHIP (LOGICAL) : ON/OFF switch for EMEP ship emissions
! (62) LVISTAS (LOGICAL) : ON/OFF switch for VISTAS NOX anthro emissions
! (63) L8DAYBB (LOGICAL) : ON/OFF switch for 8-day GFED BB emissions
! (64) L3HRBB (LOGICAL) : ON/OFF switch for 3-hr GFED BB emissions
! (65) LSYNOPBB (LOGICAL) : ON/OFF switch for synoptic GFED BB emissions
! (66) LICARTT (LOGICAL) : ON/OFF switch for modified NEI99-EPA
!
! (67) LSVCSPEC (LOGICAL) : ON/OFF switch for using CSPEC restart values
!
! (68) LDICARB (LOGICAL) : ON/OFF switch for SOG condensation
! onto OC aerosols
! (69) LCOOKE (LOGICAL) : ON/OFF switch for overwritting OC/BC emissions
! from BOND with COOKE data over North America
!
! (??) LGENFF (LOGICAL) : ON/OFF switch for generic fossil fuel emisions (1995)
! (??) LANNFF (LOGICAL) : ON/OFF switch for annual fossil fuel emissions
! (??) LMONFF (LOGICAL) : ON/OFF switch for monthly fossil fuel emissions
! (??) LBIONETORIG (LOGICAL) : ON/OFF switch for original Net Terrestrial Exchange
! (??) LBIONETCLIM (LOGICAL) : ON/OFF switch for Net Terrestrial Exchange Climatology
! (??) LBDIURNAL (LOGICAL) : ON/OFF switch for biospheric diurnal cycle
! (??) LOCEAN (LOGICAL) : ON/OFF switch for ocean exchange
! (??) LFFBKGRD (LOGICAL) : ON/OFF switch for saving fossil fuels in tagged CO2 background
! (??) LOCN1997 (LOGICAL) : ON/OFF switch for generic ocean exchange (Takahashi 1997)
! (??) LOCN2009ANN (LOGICAL) : ON/OFF switch for annual fossil fuel emissions
! (??) LOCN2009MON (LOGICAL) : ON/OFF switch for monthly fossil fuel emissions
! (??) LSHIPEDG (LOGICAL) : ON/OFF switch for EDGAR CO2 ship emissions
! (??) LSHIPICO (LOGICAL) : ON/OFF switch for CO2 ship emissions from ICOADS
! (??) LSHIPSCALE (LOGICAL) : ON/OFF switch for Temporal scaling of CO2 ship emissions
! (??) LPLANE (LOGICAL) : ON/OFF switch for CO2 aircraft emissions
! (??) LPLANESCALE (LOGICAL) : ON/OFF switch for Temporal scaling of CO2 aviation emissions
! (??) LBIOSPHTAG (LOGICAL) : ON/OFF switch for land biosphere tagged CO2 regions
! (??) LFOSSILTAG (LOGICAL) : ON/OFF switch for fossil fuel tagged CO2 regions
! (??) LSHIPTAG (LOGICAL) : ON/OFF switch for global ship emissions tagged tracer
! (??) LPLANETAG (LOGICAL) : ON/OFF switch for global aircraft emissions tagged tracer
! (??) LCHEMCO2 (LOGICAL) : ON/OFF switch for global 3-D CO2 from oxidation of CO, CH4 etc.
!
! NOTES:
! (1 ) Added LNEI99 switch to toggle EPA/NEI emissions (bmy, 11/5/04)
! (2 ) Added LAVHRRLAI switch to toggle AVHRR LAI fields (bmy, 12/20/04)
! (3 ) Added LMEGAN switch to toggle MEGAN biogenics (tmf, bmy, 10/20/05)
! (4 ) Added LEMEP switch to toggle EMEP anthro emissions (bdf, bmy, 11/1/05)
! (5 ) Added LDYNOCEAN switch for online ocean Hg model (bmy, 2/24/06)
! (6 ) Added LGFED2BB switch for GFED2 BIOMASS BURNING (bmy, 4/5/06)
! (7 ) Added LCTH, LMFLUX, LPRECON for lightning options (ltm, bmy, 5/5/06)
! (8 ) Added LFUTURE (swu, bmy, 5/30/06)
! (9 ) Added LBRAVO (rjp, kfb, bmy, 6/26/06)
! (10) Added LEDGAR, LEDGARNOx, LEDGARCO, LEDGARSHIP, LEDGARSOx switches
! for EDGAR emissions (avd, bmy, 7/6/06)
! (11) Added LSTREETS for David Streets' emissions (bmy, 8/17/06)
! (12) Added LVARTROP for variable tropopause (phs, 8/21/06)
! (13) Added LOTDREG, LOTDLOC for regional or local OTD-LIS redistribution
! of lightning flashes. (bmy, 1/31/07)
! (14) Added LOTDSCALE (ltm, bmy, 9/24/07)
! (15) Added LCAC, LARCSHIP, LEMEPSHIP (amv, phs, 3/8/08)
! (16) Added LVISTAS (amv, 11/24/08)
! (17) Added L8DAYBB, L3HRBB and LSYNOPBB for 8-day and 3-hr GFED BB
! emissions (yc, phs, 02/12/07)
! (18) Added LICARTT to account for Hudman corrections to EPA/NEI99
! (phs, 1/26/09)
! (19) Added LSVCSPEC (dkh, 02/12/09)
! (20) Added LMEGANMONO (ccc, tmf, 3/2/09)
! (21) Added LDICARB (ccc, tmf, 3/10/09)
! (23) Added LCOOKE (phs, 5/18/09)
! (24) Added support for LSCHEM from v9-01-02 (hml, dkh, 02/20/12, adj32_025)
! 07 Sep 2011 - P. Kasibhatla - Modified to include GFED3
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE VARIABLES
!=================================================================
! Aerosols
LOGICAL :: LATEQ
LOGICAL :: LCARB
LOGICAL :: LCRYST
LOGICAL :: LCOOKE
LOGICAL :: LDEAD
LOGICAL :: LDUST
LOGICAL :: LSULF
LOGICAL :: LSOA
LOGICAL :: LSSALT
LOGICAL :: LDICARB
! Chemistry
LOGICAL :: LCHEM
LOGICAL :: LEMBED
LOGICAL :: LSCHEM ! Use linearized strat chemistry? (hml,06/29/11)
! Cloud convection
LOGICAL :: LCONV
! Diagnostics
LOGICAL :: LDBUG
LOGICAL :: LDIAG
LOGICAL :: LPRT
LOGICAL :: LSTDRUN
! Dry deposition
LOGICAL :: LDRYD
! Emissions
LOGICAL :: LAIRNOX
LOGICAL :: LANTHRO
LOGICAL :: LBBSEA
LOGICAL :: LBIONOX ! <-- deprecated: replace w/ LBIOMASS soon
LOGICAL :: LBIOMASS
LOGICAL :: LBIOFUEL
LOGICAL :: LBIOGENIC
LOGICAL :: LCAC
LOGICAL :: LBRAVO
LOGICAL :: LEDGAR
LOGICAL :: LEDGARNOx
LOGICAL :: LEDGARCO
LOGICAL :: LEDGARSHIP
LOGICAL :: LEDGARSOx
LOGICAL :: LEMEP
LOGICAL :: LEMIS
LOGICAL :: LFFNOX
LOGICAL :: LFOSSIL ! <-- deprecated: replace w/ LANTHRO soon
LOGICAL :: LSTREETS
LOGICAL :: LICARTT
LOGICAL :: LICOADSSHIP ! Use ICOADS ship emissions inventory
LOGICAL :: LLIGHTNOX
LOGICAL :: LOTDREG
LOGICAL :: LOTDLOC
LOGICAL :: LOTDSCALE ! (ltm, 9/24/07)
LOGICAL :: LCTH
LOGICAL :: LMFLUX
LOGICAL :: LPRECON
LOGICAL :: LMEGAN
LOGICAL :: LMEGANMONO
LOGICAL :: LMONOT
LOGICAL :: LNEI99
LOGICAL :: LNEI05 ! Use EPA 2005 regional emissions?
LOGICAL :: LNEI08 ! Use EPA 2008 regional emissions?
LOGICAL :: LSHIPSO2
LOGICAL :: LSOILNOX
LOGICAL :: LTOMSAI
LOGICAL :: LWOODCO ! <-- deprecated: replace w/ LBIOFUEL soon
LOGICAL :: LAVHRRLAI
LOGICAL :: LGFED2BB ! Use GFED2 biomass burning?
LOGICAL :: LGFED3BB ! Use GFED3 biomass burning?
LOGICAL :: LFUTURE
LOGICAL :: LARCSHIP
LOGICAL :: LEMEPSHIP
LOGICAL :: LVISTAS
LOGICAL :: L8DAYBB ! Use GFED2 8-day biomass burning?
LOGICAL :: L3HRBB ! Use GFED2 3-hr biomass burning?
LOGICAL :: LSYNOPBB ! Use GFED2 synoptic biomass burning
LOGICAL :: LDAYBB3 ! Use GFED3 daily biomass burning?
LOGICAL :: L3HRBB3 ! Use GFED3 3-hr biomass burning?
LOGICAL :: LRETRO ! RETRO anthropogenic emissions (wfr, 3/8/11)
LOGICAL :: LRCP ! RCP anthropogenic emissions (cdh, 10/14/11)
LOGICAL :: LRCPSHIP ! RCP anthropogenic SHIP emissions (cdh, 10/14/11)
LOGICAL :: LRCPAIR ! RCP anthro AIRCRAFT emissions (cdh,10/14/11)
! Transport and strat BC's
LOGICAL :: LFILL
LOGICAL :: LMFCT
LOGICAL :: LTRAN
LOGICAL :: LTPFV
LOGICAL :: LUPBD
LOGICAL :: LWINDO
LOGICAL :: LLINOZ ! Use LINOZ chemistry in the stratosphere? (hml, 06/29/11)
LOGICAL :: LWINDO2x25 ! update nested runs (lzh,02/01/2015)
LOGICAL :: LWINDO_NA
LOGICAL :: LWINDO_EU
LOGICAL :: LWINDO_CH
LOGICAL :: LWINDO_CU
! Met fields
LOGICAL :: LUNZIP
LOGICAL :: LWAIT
! PBL mixing
LOGICAL :: LTURB
! Restart file
LOGICAL :: LSVGLB
LOGICAL :: LSVCSPEC
! Tagged simulations
LOGICAL :: LSPLIT
!Specifically for CO2 simulation (R Nassar, 2009-03-02 --> 2010-03-31)
LOGICAL :: LGENFF
LOGICAL :: LANNFF
LOGICAL :: LMONFF
LOGICAL :: LSEASBB
LOGICAL :: LBIONETORIG
LOGICAL :: LBIONETCLIM
LOGICAL :: LBIODAILY
LOGICAL :: LBIODIURNAL
LOGICAL :: LOCEAN
LOGICAL :: LFFBKGRD
LOGICAL :: LBIOSPHTAG
LOGICAL :: LFOSSILTAG
LOGICAL :: LOCN1997
LOGICAL :: LOCN2009ANN
LOGICAL :: LOCN2009MON
LOGICAL :: LSHIPEDG
LOGICAL :: LSHIPICO
LOGICAL :: LSHIPSCALE
LOGICAL :: LSHIPTAG
LOGICAL :: LPLANE
LOGICAL :: LPLANESCALE
LOGICAL :: LPLANETAG
LOGICAL :: LCHEMCO2
! Variable Tropopause
LOGICAL :: LVARTROP
! Wet convection
LOGICAL :: LWETD
! Dynamic ocean mercury model
LOGICAL :: LDYNOCEAN
!%%%% For the CH4 offline simulation only %%%% (kjw, dkh, 02/12/12, adj32_023)
LOGICAL :: LGAO ! Use gas & oil emissions?
LOGICAL :: LCOL ! Use coal emissions?
LOGICAL :: LLIV ! Use livestock emissions?
LOGICAL :: LWAST ! Use waste emissions?
LOGICAL :: LRICE ! Use rice emissions?
LOGICAL :: LOTANT ! Use other anthropogenic emissions?
LOGICAL :: LWETL ! Use wetland emissions?
LOGICAL :: LSOABS ! Use soil absorption?
LOGICAL :: LOTNAT ! Use other natural emissions?
LOGICAL :: LBFCH4 ! Use CH4 biofuel emissions?
LOGICAL :: LBMCH4 ! Use CH4 biomass emissions?
LOGICAL :: LCH4BUD ! Use computing CH4 budget
! For HTAP
LOGICAL :: LHTAP, LSRC_MASK, LRCPTR_MASK
! End of module
END MODULE LOGICAL_MOD

84
code/lump.f Normal file
View File

@ -0,0 +1,84 @@
! $Id: lump.f,v 1.1 2009/06/09 21:51:52 daven Exp $
SUBROUTINE LUMP( NTRACER, XNUMOL, STT )
!
!******************************************************************************
! Subroutine LUMP takes individual chemistry species and "lumps" them back
! into tracers after each SMVGEAR chemistry timestep. (bmy, 4/1/03, 7/20/04)
!
! Arguments as Input:
! ============================================================================
! (1 ) NTRACER (INTEGER) : Number of tracers
! (2 ) XNUMOL (REAL*8 ) : Array of molecules tracer / kg tracer
! (3 ) STT (REAL*8 ) : Tracer concentrations [molec/cm3/box]
!
! Arguments as Output:
! ============================================================================
! (3 ) STT (REAL*8 ) : Tracer concentrations [kg/box]
!
! NOTES:
! (1 ) Updated comments, cosmetic changes (bmy, 4/1/03)
! (2 ) Added OpenMP parallelization commands (bmy, 8/1/03)
! (3 ) Now dimension args XNUMOL, STT w/ NTRACER and not NNPAR (bmy, 7/20/04)
!******************************************************************************
!
! References to F90 modules
USE COMODE_MOD, ONLY : CSPEC, JLOP, VOLUME
USE TRACERID_MOD, ONLY : IDTRMB, NMEMBER, CTRMB
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "comode.h" ! SMVGEAR II arrays
! Arguments
INTEGER, INTENT(IN) :: NTRACER
REAL*8, INTENT(IN) :: XNUMOL(NTRACER)
REAL*8, INTENT(INOUT) :: STT(IIPAR,JJPAR,LLPAR,NTRACER)
! Local variables
INTEGER :: I, J, L, N, JLOOP, KK, JJ
REAL*8 :: CONCTMP
!=================================================================
! LUMP begins here!
!=================================================================
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, N, JLOOP, CONCTMP, KK, JJ )
!$OMP+SCHEDULE( DYNAMIC )
DO N = 1, NTRACER
! Skip if not a valid tracer
IF ( IDTRMB(N,1) == 0 ) CYCLE
! Loop over grid boxes
DO L = 1, NPVERT
DO J = 1, NLAT
DO I = 1, NLONG
! 1-D SMVGEAR grid box index
JLOOP = JLOP(I,J,L)
IF ( JLOOP == 0 ) CYCLE
! Compute tracer concentration [molec/cm3/box] by
! looping over all species belonging to this tracer
CONCTMP = 0.d0
DO KK = 1, NMEMBER(N)
JJ = IDTRMB(N, KK)
CONCTMP = CONCTMP + ( 1d0+CTRMB(N,KK) ) * CSPEC(JLOOP,JJ)
ENDDO
! Save tracer concentrations back to STT
STT(I,J,L,N) = CONCTMP
! Change STT from [molec/cm3/box] back to [kg/box]
STT(I,J,L,N) = STT(I,J,L,N) * VOLUME(JLOOP) / XNUMOL(N)
ENDDO
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE LUMP

1362
code/main.f Normal file
View File

File diff suppressed because it is too large Load Diff

2514
code/mercury_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

211
code/mmran_16.f Normal file
View File

@ -0,0 +1,211 @@
! $Id: mmran_16.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE MMRAN_16( NCB, NLON, NLAT, YLAT, DAY,
& MONTH, DAY_OF_YR, CSZA, TEMP, SFCA,
& OPTDUST, OPTAER, MAXBLK, FMAX, ODNEW,
& KBOT, KTOP )
!
!******************************************************************************
! Subroutine MMRAN_16 does the maximum random cloud overlap for 1 to 6 cloud
! blocks at a time, and calls PHOTOJ to compute J-Values for one column.
! (hyl, phs, bmy, 9/18/07, 11/29/07)
!
! Arguments as Input:
! ============================================================================
! Variable Type Dimension Units Description
! -------- ---- --------- ----- -----------
! Those for PHOTOJ:
!
! NLON INT - - Longitude index
! NLAT INT - - Latitude index
! YLAT DBLE - - Latitude
! MONTH INT - - Month of year (1-12)
! DAY INT - - Day of the month
! DAY_OF_YR INT - - Day of the year
! CSZA DBLE - - Cosine of solar zenith angle
! at nlon, nlat
! PRES DBLE - [mb] Column pressure at nlon, nlat
! TEMP DBLE [LMAX] [K] Layer temperatures at nlon, nlat
! SFCA DBLE - - Surface albedo at nlon, nlat
! OPTDUST DBLE [LMAX,NDUST] - Dust optical depths
! (for NDUST dust types)
! OPTAER DBLE [LMAX,NAER*NRH] - Aerosol optical depths
! (for NAER aerosol types)
!
! and those specifically for MMRAN:
!
! NCB INT - - Number of cloud blocks
! MAXBLK INT - - Dimension of FMAX,
! FMAX DBLE [MAXBLK] - Largest cloud fraction in block
! ODNEW DBLE [LPAR] - In-cloud optical depth
! KBOT INT [LPAR] - Index of bottom layer of each block
! KTOP INT [LPAR] - Index of top layer of each block
!
! LOCAL VARIABLE:
! OPTD DBLE [LPAR] - Layer optical depths at nlon, nlat
! JSUM DBLE [LPAR,JPMAX] - accumulate the J-values for the column
!
!
! NOTES:
! (1 ) Remove PRES as an argument, since we no longer need to pass that
! to PHOTOJ. (bmy, 11/29/07)
!******************************************************************************
!
IMPLICIT NONE
# include "cmn_fj.h" ! IPAR, JPAR, LPAR, CMN_SIZE
# include "jv_cmn.h" ! ZPJ
! Local variables
INTEGER, INTENT(IN) :: NCB ! Number of Cloud Blocks
INTEGER, INTENT(IN) :: NLON, NLAT
REAL*8, INTENT(IN) :: CSZA, SFCA, YLAT
INTEGER, INTENT(IN) :: DAY, MONTH, DAY_OF_YR
REAL*8, INTENT(IN) :: TEMP(LPAR)
REAL*8, INTENT(IN) :: OPTDUST(LPAR,NDUST)
REAL*8, INTENT(IN) :: OPTAER(LPAR,NAER*NRH)
INTEGER, INTENT(IN) :: MAXBLK
REAL*8, INTENT(IN) :: FMAX(MAXBLK)
REAL*8, INTENT(IN) :: ODNEW(LPAR)
INTEGER, INTENT(IN) :: KBOT(LPAR)
INTEGER, INTENT(IN) :: KTOP(LPAR)
! Local variables
INTEGER :: II, JJ, KK, LL, MM, NN
INTEGER :: II2, JJ2, LL2, MM2, NN2
REAL*8 :: P1, P2, P3, P4, P5, P6
REAL*8 :: JSUM(LPAR,JPMAX)
REAL*8 :: OPTD(LPAR)
!=================================================================
! MMRAN_16 begins here!
!=================================================================
! Initialize J-value array
JSUM = 0d0
! Initialize Pi
P1=1d0
P2=1d0
P3=1d0
P4=1d0
P5=1d0
P6=1d0
! Define the number of loops
II2 = 1
JJ2 = 1
LL2 = 1
MM2 = 1
NN2 = 1
IF ( NCB > 1 ) LL2 = 2 ! At least 2 block-clouds
IF ( NCB > 2 ) MM2 = 2 ! At least 3 block-clouds
IF ( NCB > 3 ) NN2 = 2 ! At least 4 block-clouds
IF ( NCB > 4 ) II2 = 2 ! At least 5 block-clouds
IF ( NCB > 5 ) JJ2 = 2 ! At least 6 block-clouds
! Loop over cloud blocks
DO KK = 1, 2
DO LL = 1, LL2
DO MM = 1, MM2
DO NN = 1, NN2
DO II = 1, II2
DO JJ = 1, JJ2
! Zero optical depth
OPTD(:) = 0d0
! 1st cloud block
IF ( KK == 1 ) THEN
OPTD(KBOT(1):KTOP(1)) = 0d0
P1 = 1d0 - FMAX(1)
ELSE
OPTD(KBOT(1):KTOP(1)) = ODNEW(KBOT(1):KTOP(1))
P1 = FMAX(1)
ENDIF
! 2nd cloud block
IF ( NCB > 1 ) THEN
IF ( LL == 1 ) THEN
OPTD(KBOT(2):KTOP(2)) = 0d0
P2 = 1d0 - FMAX(2)
ELSE
OPTD(KBOT(2):KTOP(2)) = ODNEW(KBOT(2):KTOP(2))
P2 = FMAX(2)
ENDIF
! 3rd cloud block
IF ( NCB > 2 ) THEN
IF ( MM == 1 ) THEN
OPTD(KBOT(3):KTOP(3)) = 0d0
P3 = 1d0 - FMAX(3)
ELSE
OPTD(KBOT(3):KTOP(3)) = ODNEW(KBOT(3):KTOP(3))
P3 = FMAX(3)
ENDIF
! 4th cloud block
IF ( NCB > 3 ) THEN
IF ( NN == 1 ) THEN
OPTD(KBOT(4):KTOP(4)) = 0d0
P4 = 1d0 - FMAX(4)
ELSE
OPTD(KBOT(4):KTOP(4)) = ODNEW(KBOT(4):KTOP(4))
P4 = FMAX(4)
ENDIF
! 5th cloud block
IF ( NCB > 4 ) THEN
IF ( II == 1 ) THEN
OPTD(KBOT(5):KTOP(5)) = 0d0
P5 = 1d0 - FMAX(5)
ELSE
OPTD(KBOT(5):KTOP(5)) = ODNEW(KBOT(5):KTOP(5))
P5 = FMAX(5)
ENDIF
! 6th cloud block
IF ( NCB > 5 ) THEN
IF ( JJ == 1 ) THEN
OPTD(KBOT(6):KTOP(6)) = 0d0
P6 = 1d0 - FMAX(6)
ELSE
OPTD(KBOT(6):KTOP(6)) = ODNEW(KBOT(6):KTOP(6))
P6 = FMAX(6)
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
! Call the photolysis routine with the OPTD as
! computed from the cloud overlaps
CALL PHOTOJ( NLON, NLAT, YLAT, DAY_OF_YR, MONTH, DAY,
& CSZA, TEMP, SFCA, OPTD, OPTDUST, OPTAER )
! Store the J values into JSUM array
JSUM(:,:) = JSUM(:,:) +
& ( P1 * P2 * P3 * P4 * P5 * P6 * ZPJ(:,:,NLON,NLAT) )
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
! Update J-Values
ZPJ(:,:,NLON,NLAT) = JSUM(:,:)
! Return to caller
END SUBROUTINE MMRAN_16

1095
code/ndxx_setup.f Normal file
View File

File diff suppressed because it is too large Load Diff

2250
code/nei2005_anthro_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

3178
code/nei2008_anthro_mod.F90 Normal file
View File

File diff suppressed because it is too large Load Diff

157
code/objects.sh Normal file
View File

@ -0,0 +1,157 @@
#!/bin/bash
INPUT_FOLDER=`cat INPUT_FOLDER`
cp Objects.default Objects.mkl
# Note this line gives an error but WORKS correctly
if [ -n $(grep ' => offdiagonal : F' $INPUT_FOLDER/input.gcadj) ]; then
find="geos_chem_adj_mod.o"
replace="covariance_mod.o \
geos_chem_adj_mod.o"
sed -e "s/$find/$replace/g" Objects.mkl > Objects.off-diag
mv Objects.off-diag Objects.mkl
fi
# Note this line gives an error but WORKS correctly
if [ -n $(grep 'Compute BFGS inverse Hessian : F' $INPUT_FOLDER/input.gcadj) ]; then
find="inv_hessian_mod.o"
replace="inv_hessian_mod.o \
inv_hessian_lbfgs_mod.o"
sed -e "s/$find/$replace/g" Objects.mkl > Objects.lbfgs
mv Objects.lbfgs Objects.mkl
fi
if [ $1 = "HDF" ]; then
find="getifsun.o"
replace="getifsun.o \
gvchsq.o "
sed -e "s/$find/$replace/g" Objects.mkl > output1
find="input_mod.o"
replace="input_mod.o \
He4IncludeModule.o \
He4ErrorModule.o \
He4GridModule.o \
He4SwathModule.o \
findinv.o \
airsv5_mod.o \
airs_co_obs_mod.o \
HdfIncludeModule.o \
HdfSdModule.o \
HdfVdModule.o \
mls_o3_obs_mod.o \
mls_hno3_obs_mod.o \
omi_no2_obs_mod.o \
omi_so2_obs_mod.o \
omi_ch2o_obs_mod.o \
osiris_no2_obs_mod.o \
interp.o \
gaussj.o \
iasi_co_obs_mod.o \
mopitt_obs_mod.o"
sed -e "s/$find/$replace/g" output1 > output
rm output1
mv output Objects.mk
fi
if [ $1 = "SAT_NETCDF" ]; then
find="rpmares_mod.o"
replace="rpmares_mod.o \
gosat_co2_mod.o \
tes_nh3_mod.o \
tes_o3_mod.o \
iasi_o3_obs_mod.o \
tes_o3_irk_mod.o"
sed -e "s/$find/$replace/g" Objects.mkl > output1
find="tes_ch4_mod.o"
replace="tes_ch4_mod.o \
scia_ch4_mod.o"
sed -e "s/$find/$replace/g" output1 > output
rm output1
mv output Objects.mk
fi
if [ $1 = "LIDORT" ]; then
find="population_mod.o"
replace="population_mod.o \
mie_mod.o \
lidort_mod.o"
sed -e "s/$find/$replace/g" Objects.mkl > output
mv output Objects.mk
fi
if [ $1 = "DEFAULT" ]; then
mv Objects.mkl Objects.mk
fi
if [ $1 = "HDF_NETCDF" ]; then
find="rpmares_mod.o"
replace="rpmares_mod.o \
gosat_co2_mod.o \
tes_nh3_mod.o \
tes_o3_mod.o \
iasi_o3_obs_mod.o \
tes_o3_irk_mod.o"
sed -e "s/$find/$replace/g" Objects.mkl > output1
find="tes_ch4_mod.o"
replace="tes_ch4_mod.o \
scia_ch4_mod.o"
sed -e "s/$find/$replace/g" output1 > output2
#rm output1
#mv output Objects.mk
find="getifsun.o"
replace="getifsun.o \
gvchsq.o "
sed -e "s/$find/$replace/g" output2 > output3
find="input_mod.o"
replace="input_mod.o \
He4IncludeModule.o \
He4ErrorModule.o \
He4GridModule.o \
He4SwathModule.o \
findinv.o \
airsv5_mod.o \
airs_co_obs_mod.o \
HdfIncludeModule.o \
HdfSdModule.o \
HdfVdModule.o \
mls_o3_obs_mod.o \
mls_hno3_obs_mod.o \
omi_no2_obs_mod.o \
omi_so2_obs_mod.o \
omi_ch2o_obs_mod.o \
osiris_no2_obs_mod.o \
interp.o \
gaussj.o \
iasi_co_obs_mod.o \
mopitt_obs_mod.o"
sed -e "s/$find/$replace/g" output3 > output
rm output1
rm output2
rm output3
mv output Objects.mk
fi

157
code/objects.sh~ Normal file
View File

@ -0,0 +1,157 @@
#!/bin/bash
INPUT_FOLDER=`cat INPUT_FOLDER`
cp Objects.default Objects.mkl
# Note this line gives an error but WORKS correctly
if [ -n $(grep ' => offdiagonal : F' $INPUT_FOLDER/input.gcadj) ]; then
find="geos_chem_adj_mod.o"
replace="covariance_mod.o \
geos_chem_adj_mod.o"
sed -e "s/$find/$replace/g" Objects.mkl > Objects.off-diag
mv Objects.off-diag Objects.mkl
fi
# Note this line gives an error but WORKS correctly
if [ -n $(grep 'Compute BFGS inverse Hessian : F' $INPUT_FOLDER/input.gcadj) ]; then
find="inv_hessian_mod.o"
replace="inv_hessian_mod.o \
inv_hessian_lbfgs_mod.o"
sed -e "s/$find/$replace/g" Objects.mkl > Objects.lbfgs
mv Objects.lbfgs Objects.mkl
fi
if [ $1 = "HDF" ]; then
find="getifsun.o"
replace="getifsun.o \
gvchsq.o "
sed -e "s/$find/$replace/g" Objects.mkl > output1
find="input_mod.o"
replace="input_mod.o \
He4IncludeModule.o \
He4ErrorModule.o \
He4GridModule.o \
He4SwathModule.o \
findinv.o \
airsv5_mod.o \
airs_co_obs_mod.o \
HdfIncludeModule.o \
HdfSdModule.o \
HdfVdModule.o \
mls_o3_obs_mod.o \
mls_hno3_obs_mod.o \
omi_no2_obs_mod.o \
omi_so2_obs_mod.o \
omi_ch2o_obs_mod.o \
osiris_no2_obs_mod.o \
interp.o \
gaussj.o \
iasi_co_obs_mod.o \
mopitt_obs_mod.o"
sed -e "s/$find/$replace/g" output1 > output
rm output1
mv output Objects.mk
fi
if [ $1 = "SAT_NETCDF" ]; then
find="rpmares_mod.o"
replace="rpmares_mod.o \
gosat_co2_mod.o \
tes_nh3_mod.o \
tes_o3_mod.o \
iasi_o3_obs_mod.o \
tes_o3_irk_mod.o"
sed -e "s/$find/$replace/g" Objects.mkl > output1
find="tes_ch4_mod.o"
replace="tes_ch4_mod.o \
scia_ch4_mod.o"
sed -e "s/$find/$replace/g" output1 > output
rm output1
mv output Objects.mk
fi
if [ $1 = "LIDORT" ]; then
find="population_mod.o"
replace="population_mod.o \
mie_mod.o \
lidort_mod.o"
sed -e "s/$find/$replace/g" Objects.mkl > output
mv output Objects.mk
fi
if [ $1 = "DEFAULT" ]; then
mv Objects.mkl Objects.mk
fi
if [ $1 = "HDF_NETCDF" ]; then
find="rpmares_mod.o"
replace="rpmares_mod.o \
gosat_co2_mod.o \
tes_nh3_mod.o \
tes_o3_mod.o \
iasi_o3_obs_mod.o \
tes_o3_irk_mod.o"
sed -e "s/$find/$replace/g" Objects.mkl > output1
find="tes_ch4_mod.o"
replace="tes_ch4_mod.o \
scia_ch4_mod.o"
sed -e "s/$find/$replace/g" output1 > output2
#rm output1
#mv output Objects.mk
find="getifsun.o"
replace="getifsun.o \
gvchsq.o "
sed -e "s/$find/$replace/g" output2 > output3
find="input_mod.o"
replace="input_mod.o \
He4IncludeModule.o \
He4ErrorModule.o \
He4GridModule.o \
He4SwathModule.o \
findinv.o \
airsv5_mod.o \
airs_co_obs_mod.o \
HdfIncludeModule.o \
HdfSdModule.o \
HdfVdModule.o \
mls_o3_obs_mod.o \
mls_hno3_obs_mod.o \
omi_no2_obs_mod.o \
oni_so2_obs_mod.o \
omi_ch2o_obs_mod.o \
osiris_no2_obs_mod.o \
interp.o \
gaussj.o \
iasi_co_obs_mod.o \
mopitt_obs_mod.o"
sed -e "s/$find/$replace/g" output3 > output
rm output1
rm output2
rm output3
mv output Objects.mk
fi

2223
code/ocean_mercury_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

149
code/ohsave.f Normal file
View File

@ -0,0 +1,149 @@
! $Id: ohsave.f,v 1.1 2009/06/09 21:51:52 daven Exp $
SUBROUTINE OHSAVE( N_TRACERS, XNUMOL, STT, FRACO3,
& FRACNO, FRACNO2, SAVEOH, SAVEHO2,
& SAVENO, SAVENO2, SAVENO3 )
!
!******************************************************************************
! Subroutine OHSAVE stores the concentrations of OH, HO2, NO, NO2, and NO3
! for the ND43 diagnostic. Also the O3/Ox, NO/NOx and NO2/NOx fractions
! are computed and returned to the calling program. (bmy, 2/27/02, 1/19/07)
!
! Arguments as Input:
! ============================================================================
! (1 ) N_TRACERS (INTEGER) : Number of tracers in XNUMOL and STT
! (2 ) XNUMOL (REAL*8 ) : Array of molec/kg for each tracer
! (3 ) STT (REAL*8 ) : Array containing CTM tracers
!
! Arguments as Output:
! ============================================================================
! (4 ) FRACO3 (REAL*8 ) : Array of O3/Ox fractions
! (5 ) FRACNO (REAL*8 ) : Array of NO/NOx fractions
! (6 ) FRACNO2 (REAL*8 ) : Array of NO2/NOx fractions
! (7 ) SAVEOH (REAL*8 ) : Array of OH concentrations [molec/cm3]
! (8 ) SAVEHO2 (REAL*8 ) : Array of HO2 concentrations [v/v]
! (9 ) SAVENO (REAL*8 ) : Array of NO concentrations [v/v]
! (10) SAVENO2 (REAL*8 ) : Array of NO2 concentrations [v/v]
! (11) SAVENO3 (REAL*8 ) : Array of NO3 concentrations [v/v]
!
! NOTES:
! (1 ) Original code from lwh, gmg, djj, jyl, etc, 1990's. Modified for
! GEOS-CHEM by Bob Yantosca et al.
! (2 ) Added comment header and F90 declaration syntax. Also now specify
! the units of each variable for clarity.
! (3 ) Deleted NTRACER, it is not used. Also added FRACNO2 and SAVEHO2
! variables. Updated comments, cosmetic changes (rvm, bmy, 2/27/02)
! (4 ) Bug fix: swap the order of the lines where TMPNOX is computed.
! Also deleted obsolete code from 2/02. (bmy, 7/31/02)
! (5 ) Now reference IDTOX, IDTNOX, etc from "tracerid_mod.f". (1/13/03)
! (6 ) Added OpenMP parallelization commands (bmy, 8/1/03)
! (7 ) Now compute quantities for mean OH in "diag_oh_mod.f". Now also
! references STT from "tracer_mod.f". Added N_TRACERS to the arg list.
! Now dimension args XNUMOL, STT w/ N_TRACERS and not NNPAR.
! (bmy, 7/20/04)
! (8 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (9 ) Reset FRAC* and SAVE* arrays, so that we don't carry dubious data
! over from boxes that used to be in the tropopause but aren't anymore.
! (phs, 1/19/07)
!******************************************************************************
!
! References to F90 modules
USE COMODE_MOD, ONLY : AIRDENS, CSPEC, JLOP, T3, VOLUME
USE DIAG_MOD, ONLY : DIAGCHLORO
USE TRACERID_MOD, ONLY : IDTOX, IDTNOX, IDO3, IDNO
USE TRACERID_MOD, ONLY : IDNO2, IDOH, IDHO2, IDNO3
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "comode.h" ! VOLUME, CSPEC, NPVERT, NLAT, NLONG
! Arguments
INTEGER, INTENT(IN) :: N_TRACERS
REAL*8, INTENT(IN) :: XNUMOL(N_TRACERS)
REAL*8, INTENT(IN) :: STT(IIPAR,JJPAR,LLPAR,N_TRACERS)
REAL*8, INTENT(OUT) :: FRACO3(IIPAR,JJPAR,LLPAR)
REAL*8, INTENT(OUT) :: FRACNO(IIPAR,JJPAR,LLPAR)
REAL*8, INTENT(OUT) :: FRACNO2(IIPAR,JJPAR,LLPAR)
REAL*8, INTENT(OUT) :: SAVEOH(IIPAR,JJPAR,LLPAR)
REAL*8, INTENT(OUT) :: SAVEHO2(IIPAR,JJPAR,LLPAR)
REAL*8, INTENT(OUT) :: SAVENO(IIPAR,JJPAR,LLPAR)
REAL*8, INTENT(OUT) :: SAVENO2(IIPAR,JJPAR,LLPAR)
REAL*8, INTENT(OUT) :: SAVENO3(IIPAR,JJPAR,LLPAR)
! Local variables
INTEGER :: I, J, L, JLOOP ! (bmy, 7/20/04)
REAL*8 :: TEMPOX, TEMPNOX !, KCLO, XLOSS, XOHMASS
!=================================================================
! OHSAVE begins here!
!
! Save info on ozone, OH, and NO concentrations
! for consistency with the old method of doing O3, we'll archive
! the fraction O3/Ox, and the fraction NO/NOx
!=================================================================
! Reset because of variable tropopause. Ensure that data for boxes
! that once were in the troposphere, and are not anymore, do not
! carry dubious data over. (phs, 1/19/07)
FRACO3 = 0d0
FRACNO = 0d0
FRACNO2 = 0d0
SAVEOH = 0d0
SAVEHO2 = 0d0
SAVENO = 0d0
SAVENO2 = 0d0
SAVENO3 = 0d0
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, JLOOP, TEMPOX, TEMPNOX )
!$OMP+SCHEDULE( DYNAMIC )
DO 370 L = 1, NPVERT
DO 360 J = 1, NLAT
DO 350 I = 1, NLONG
! 1-D grid box index
JLOOP = JLOP(I,J,L)
! Cycle if this isn't a valid SMVGEAR gridbox
IF ( JLOOP == 0 ) GOTO 350
! Total Ox concentration, convert from [kg] to [molec/cm3]
TEMPOX = STT(I,J,L,IDTOX)
TEMPOX = TEMPOX * XNUMOL(IDTOX) /VOLUME(JLOOP)
! Total NOx concentration, convert from [kg] to [molec/cm3]
TEMPNOX = STT(I,J,L,IDTNOX)
TEMPNOX = TEMPNOX * XNUMOL(IDTNOX)/VOLUME(JLOOP)
! Ox/O3 fraction [unitless]
FRACO3(I,J,L) = CSPEC(JLOOP,IDO3) / TEMPOX
! NO/NOx fraction [unitless]
FRACNO(I,J,L) = CSPEC(JLOOP,IDNO) / TEMPNOX
! NO2/NOx fraction [unitless]
FRACNO2(I,J,L) = CSPEC(JLOOP,IDNO2) / TEMPNOX
! OH concentration [molec/cm3]
SAVEOH(I,J,L) = CSPEC(JLOOP,IDOH)
! HO2 concentration [v/v]
SAVEHO2(I,J,L) = CSPEC(JLOOP,IDHO2) / AIRDENS(JLOOP)
! NO concentration [v/v]
SAVENO(I,J,L) = CSPEC(JLOOP,IDNO) / AIRDENS(JLOOP)
! NO2 concentration [v/v]
SAVENO2(I,J,L) = CSPEC(JLOOP,IDNO2) / AIRDENS(JLOOP)
! NO3 concentration [v/v]
SAVENO3(I,J,L) = CSPEC(JLOOP,IDNO3) / AIRDENS(JLOOP)
350 CONTINUE
360 CONTINUE
370 CONTINUE
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE OHSAVE

141
code/optdepth_mod.f Normal file
View File

@ -0,0 +1,141 @@
! $Id: optdepth_mod.f,v 1.1 2009/06/09 21:51:50 daven Exp $
MODULE OPTDEPTH_MOD
!
!******************************************************************************
! Module OPTDEPTH_MOD contains routines to compute optical depths for GEOS-3
! GEOS-4, and GCAP met data sets. (bmy, 8/15/01, 8/4/06)
!
! Module Routines:
! ============================================================================
! (1 ) OD_GEOS3_GEOS4 : Computes optical depths for GEOS-2 or GEOS-3
!
! Module Interfaces:
! ============================================================================
! (1 ) OPTDEPTH : Connects routines OD_GEOS1_GEOSS, OD_GEOS2_GEOS3
!
! GEOS-CHEM modules referenced by optdepth_mod.f
! ============================================================================
! (1 ) diag_mod.f : Module containing GEOS-CHEM diagnostic arrays
!
! NOTES:
! (1 ) Now add parallel DO-loops (bmy, 8/15/01)
! (2 ) Removed obsolete code from 9/01 (bmy, 10/24/01)
! (3 ) Now divide module header into MODULE PRIVATE, MODULE VARIABLES, and
! MODULE ROUTINES sections. Also add MODULE INTERFACES section,
! since we have an interface here. (bmy, 5/28/02)
! (4 ) Renamed OD_GEOS2_GEOS_3 to OD_GEOS3_GEOS4. (bmy, 4/20/05)
! (5 ) Remove support for GEOS-1 and GEOS-STRAT met fields (bmy, 8/4/06)
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE PRIVATE DECLARATIONS -- keep certain internal variables
! and routines from being seen outside "optdepth_mod.f"
!=================================================================
! PRIVATE module routines
PRIVATE OD_GEOS3_GEOS4
!=================================================================
! MODULE INTERFACES -- "bind" two or more routines with different
! argument types or # of arguments under one unique name
!=================================================================
INTERFACE OPTDEPTH
MODULE PROCEDURE OD_GEOS3_GEOS4
END INTERFACE
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
SUBROUTINE OD_GEOS3_GEOS4( NVERT, CLDF, OPTDEP, OPTD )
!
!******************************************************************************
! Subroutine OD_GEOS3_GEOS4 copies the DAO grid box optical depth from
! the OPTDEP met field array into the OPTD array. Diagnostics are also
! archived. (bmy, 8/15/01, 4/20/05)
!
! Arguments as input:
! ===========================================================================
! (1 ) NVERT (INTEGER) : Number of levels to compute Optical Depth fo
! (2 ) CLDF (REAL*8 ) : GEOS-3/GEOS-4 3/D cloud fraction [unitless]
! (3 ) OPTDEP (REAL*8 ) : GEOS-3/GEOS-4 grid box optical depths [unitless]
!
! Arguments as output:
! ===========================================================================
! (4 ) OPTD (REAL*8 ) : DAO optical depth at grid box (I,J,L) [unitless]
!
! NOTES:
! (1 ) Now parallelize I-J DO loops (bmy, 8/15/01)
! (2 ) Renamed to OD_GEOS3_GEOS4. Also now saves CLDF in AD21(I,J,L,2)
! for the ND21 diagnostic (bmy, 4/20/05)
!******************************************************************************
!
! References to F90 modules
USE DIAG_MOD, ONLY: AD21
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! ND21
! Arguments
INTEGER, INTENT(IN) :: NVERT
REAL*8, INTENT(IN) :: CLDF (LLPAR,IIPAR,JJPAR)
REAL*8, INTENT(IN) :: OPTDEP(LLPAR,IIPAR,JJPAR)
REAL*8, INTENT(OUT) :: OPTD (LLPAR,IIPAR,JJPAR)
! Local Variables
INTEGER :: I, J, L
!=================================================================
! OD_GEOS3_GEOS4 begins here!
!
! GEOS-3/GEOS-4 optical depth is stored in the OPTDEP array,
! which is read in routine "read_a6" of "dao_read_mod.f".
!
! OPTDEP is archived every 6 hours, nevertheless, each chemistry
! timestep we copy this into the OPTD array and archive for the
! ND21 diagnostic. This way the ND21 diagnostic is consistent
! with GEOS-1/GEOS-STRAT.
!
! OPTDEP and OPTD are dimensioned (LLPAR,IIPAR,JJPAR) to maximize
! loop efficiency for processing an (I,J) column layer by layer.
!
! Now also save CLDTOT to the ND21 diagnostic (bmy, 4/20/05)
!=================================================================
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L )
!$OMP+SCHEDULE( DYNAMIC )
DO J = 1, JJPAR
DO I = 1, IIPAR
DO L = 1, NVERT
! Copy optical depth over from OPTDEP array
OPTD(L,I,J) = OPTDEP(L,I,J)
! Save to AD21 array only if ND21 is turned on
IF ( ND21 > 0 .and. L <= LD21 ) THEN
AD21(I,J,L,1) = AD21(I,J,L,1) + OPTD(L,I,J)
AD21(I,J,L,2) = AD21(I,J,L,2) + CLDF(L,I,J)
ENDIF
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Return to calling program
END SUBROUTINE OD_GEOS3_GEOS4
!------------------------------------------------------------------------------
! End of module
END MODULE OPTDEPTH_MOD

1009
code/paranox_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

187
code/pderiv.f Normal file
View File

@ -0,0 +1,187 @@
! $Id: pderiv.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE PDERIV
!
!******************************************************************************
! Subroutine PDERIV places the partial differential equations into a matrix
! for SMVGEAR II. (M. Jacobson, 1997; bdf, bmy, 4/18/03)
!
! NOTES:
! (1 ) Now force double-precision w/ "D" exponents (bmy, 4/18/03)
!******************************************************************************
!
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "comode.h" ! SMVGEAR II arrays
C
C *********************************************************************
C ************ WRITTEN BY MARK JACOBSON (1993) ************
C *** (C) COPYRIGHT, 1993 BY MARK Z. JACOBSON ***
C *** U.S. COPYRIGHT OFFICE REGISTRATION NO. TXu 670-279 ***
C *** (650) 723-6836 ***
C *********************************************************************
C
C PPPPPPP DDDDDDD EEEEEEE RRRRRRR IIIIIII V V
C P P D D E R R I V V
C PPPPPPP D D EEEEEEE RRRRRRR I V V
C P D D E R R I V V
C P DDDDDDD EEEEEEE R R IIIIIII V
C
C *********************************************************************
C * THIS SUBROUTINE PUTS THE PARTIAL DERIVATIVES OF EACH ORDINARY *
C * DIFFERENTIAL EQUATION INTO A MATRIX. THE FORM OF THE MATRIX *
C * EQUATION IS *
C * P = I - H x Bo x J *
C * *
C * WHERE I = IDENTITY MATRIX, H = TIME-STEP, Bo = COEFFICIENT *
C * CORRESPONDING TO THE ORDER OF THE METHOD, AND J IS THE JACOBIAN *
C * MATRIX OF PARTIAL DERIVATIVES. *
C * *
C * HOW TO CALL SUBROUTINE: *
C * ---------------------- *
C * CALL PDERIV.F FROM SMVGEAR.F WITH *
C * NCS = 1..NCSGAS FOR GAS CHEMISTRY *
C * NCSP = NCS FOR DAYTIME GAS CHEM *
C * NCSP = NCS +ICS FOR NIGHTTIME GAS CHEM *
C *********************************************************************
C
C *********************************************************************
C * INITIALIZE MATRIX *
C *********************************************************************
C CC2 = ARRAY OF IARRAY UNITS HOLDING VALUES OF EACH MAXTRIX
C POSITION ACTUALLY USED.
C CC2 = P = I - DELT * ASET(NQQ,1) * PARTIAL DERIVATIVES.
C URATE = TERM OF JACOBIAN (J) = PARTIAL DERIVATIVE
C IARRAY = TOTAL NUMBER OF MATRIX POSITIONS FILLED AFTER MAT. PROCESSES
C IRMA,B,C = SPECIES # OF EACH REACTANT
C ISCHAN = ORIGINAL ORDER OF MATRIX
C KTLOOP = NUMBER OF GRID-CELLS IN A GRID-BLOCK
C NONDIAG1 = 1 + # OF FINAL MATRIX POSITIONS, EXCLUDING DIAGONAL TERMS,
C FILLED AFTER ALL MATRIX PROCESSES.
C NPDERIV = COUNTER OF NUMBER OF TIMES THIS ROUTINE IS CALLED
C R1DELT = -ASET(NQQ,1) * TIME STEP = -COEFFICIENT OF METHOD * DT
C RRATE = REACTION RATE COEFFICIENT
C
C EXAMPLE OF HOW PARTIAL DERIVATIVES ARE PLACED IN AN ARRAY:
C ---------------------------------------------------------
C
C SPECIES: A, B, C
C CONCENTRATIONS: [A], [B], [C]
C
C REACTIONS: 1) A --> B J
C 2) A + B --> C K1
C 3 A + B + C --> D K2
C
C FIRST d[A] / dt = -J[A] - K1[A][B] - K2[A][B][C]
C DERIVATIVES: d[B] / dt = +J[A] - K1[A][B] - K2[A][B][C]
C d[C] / dt = + K1[A][B] - K2[A][B][C]
C d[D] / dt = + K2[A][B][C]
C
C PREDICTOR MATRIX (P) = I - h * b * J:
C J = JACOBIAN MATRIX OF PARTIAL DERIVATES
C I = IDENTITY MATRIX
C h = TIME-STEP
C b = COEFFICIENT OF METHOD
C R = h * b = -R1DELT
C
C A B C D
C ___________________________________________________________________
C |
C A | 1-R(-J-K1[B]-K2[B][C]) -R(-K1[A]-K2[A][C]) -R(-K2[A][B]) 0
C |
C B | -R(+J-K1[B]-K2[B][C]) 1-R(-K1[A]-K2[A][C]) -R(-K2[A][B]) 0
C |
C C | -R( +K1[B]-K2[B][C]) -R(+K1[A]-K2[A][C]) 1-R(-K2[A][B]) 0
C |
C D | -R( +K2[B][C]) -R( +K2[A][C]) -R(+K2[A][B]) 1
C
C
C *********************************************************************
C ********* CALCULATE PARTIAL DERIVATIVES **********
C ********* AND SUM UP PARTIAL DERIVATIVE LOSS TERMS **********
C *********************************************************************
C
INTEGER IARRY,NONDIAG,NONDIAG1,NPDL,NPDH,NKN,JA,JB,JC,K,IAR,N
INTEGER IAL
REAL*8 FRACR1
NPDERIV = NPDERIV + 1
IARRY = IARRAY(NCSP)
NONDIAG = IARRY - ISCHAN
NONDIAG1 = NONDIAG + 1
NFDH1 = NFDH2 + IONER(NCSP)
NPDL = NPDLO(NCSP)
NPDH = NPDHI(NCSP)
C
C *********************************************************************
C * PARTIAL DERIVATIVES FOR RATES WITH THREE ACTIVE LOSS TERMS *
C *********************************************************************
C
DO 105 NKN = 1, NFDH3
JA = IRMA(NKN)
JB = IRMB(NKN)
JC = IRMC(NKN)
DO 100 K = 1, KTLOOP
URATE(K,NKN,1) = RRATE(K,NKN) * CNEW(K,JB) * CNEW(K,JC)
URATE(K,NKN,2) = RRATE(K,NKN) * CNEW(K,JA) * CNEW(K,JC)
URATE(K,NKN,3) = RRATE(K,NKN) * CNEW(K,JA) * CNEW(K,JB)
100 CONTINUE
105 CONTINUE
C
C *********************************************************************
C * PARTIAL DERIVATIVES FOR RATES WITH TWO ACTIVE LOSS TERMS *
C *********************************************************************
C
DO 155 NKN = NFDL2, NFDH2
JA = IRMA(NKN)
JB = IRMB(NKN)
DO 150 K = 1, KTLOOP
URATE(K,NKN,1) = RRATE(K,NKN) * CNEW(K,JB)
URATE(K,NKN,2) = RRATE(K,NKN) * CNEW(K,JA)
150 CONTINUE
155 CONTINUE
C
C *********************************************************************
C * PARTIAL DERIVATIVES FOR RATES WITH ONE ACTIVE LOSS TERM *
C *********************************************************************
C
DO 205 NKN = NFDL1, NFDH1
DO 200 K = 1, KTLOOP
URATE(K,NKN,1) = RRATE(K,NKN)
200 CONTINUE
205 CONTINUE
C
C *********************************************************************
C * PUT PARTIAL DERIVATIVES PRODUCTION AND LOSS TERMS IN MATRIX ARRAY *
C *********************************************************************
C FRACPL = -1. FOR ALL REACTANTS
C = +1. OR +FRACTION FOR ALL PRODUCTS
C
DO 255 IAR = 1, NONDIAG
DO 250 K = 1, KTLOOP
CC2(K,IAR) = 0.d0
250 CONTINUE
255 CONTINUE
C
DO 305 IAR = NONDIAG1, IARRY
DO 300 K = 1, KTLOOP
CC2(K,IAR) = 1.d0
300 CONTINUE
305 CONTINUE
C
DO 405 N = NPDL, NPDH
NKN = NKPDTERM(N)
IAR = IPOSPD( N)
IAL = IIALPD( N)
FRACR1 = FRACPL( N) * R1DELT
DO 400 K = 1, KTLOOP
CC2(K,IAR) = CC2(K,IAR) + FRACR1 * URATE(K,NKN,IAL)
400 CONTINUE
405 CONTINUE
C
C *********************************************************************
C ********************* END OF SUBROUTINE PDERIV **********************
C *********************************************************************
C
RETURN
END SUBROUTINE PDERIV

2157
code/pjc_pfix_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

1643
code/planeflight_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

122
code/precipfrac.f Normal file
View File

@ -0,0 +1,122 @@
! $Id: precipfrac.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE PRECIPFRAC( I, J, RATE, FRAC )
!
!*****************************************************************************
! Subroutine PRECIPFRAC computes the fraction of a grid box that is
! actually precipitating, along with the precipitation rate.
! (djj, hyl, bmy, 10/18/99, 2/11/03)
!
! Arguments as input:
! ===========================================================================
! (1 ) I (INTEGER) : Longitude index of grid box
! (2 ) J (INTEGER) : Latitude index of grid box
!
! Arguments as output:
! ===========================================================================
! (1) RATE (REAL*8) : Rate of precipitation for grid box (I,J) [mm/day ]
! (2) FRAC (REAL*8) : Fraction of grid box undergoing precip [unitless]
!
! Inputs passed via "CMN_PRECIP"
! ===========================================================================
! (3 ) PREACC (REAL*8) : DAO total precipitation at ground [mm/day]
! (4 ) PRECON (REAL*8) : DAO convective precipitation at ground [mm/day]
!
! References:
! ===========================================================================
! Liu, H. Y., D. J. Jacob, I. Bey, R. M. Yantosca, and D. M. Koch,
! Three-dimensional simulation of $210Pb$ and $7Be$ in the Harvard-DAO
! tropospheric chemistry model, Eos Trans. AGU, 80 (17), S32, 1999a.
!
! NOTES:
! (1 ) PRECIPFRAC is written in Fixed-Form Fortran 90.
! (2 ) This version of PRECIPFRAC replaces Yuhang Wang's original version,
! as used in the GEOS-CTM prior to 10/18/99.
! (3 ) Be sure to force double precision with the "D" exponent.
! (4 ) Now reference PREACC, PRECON from "dao_mod.f" instead of from
! common block header file "CMN_PRECIP". (bmy, 6/26/00)
! (5 ) Removed obsolete code from 6/26/00 (bmy, 8/31/00)
! (6 ) Replaced JMX with JGLOB. Updated comments, cosmetic changes.
! (bmy, 6/25/02)
! (7 ) Now use function GET_YOFFSET from "grid_mod.f" (bmy, 2/11/03)
!*****************************************************************************
!
! Reference to F90 modules
USE DAO_MOD, ONLY : PREACC, PRECON
USE GRID_MOD, ONLY : GET_YOFFSET
IMPLICIT NONE
# include "CMN_SIZE" ! JGLOB
! Arguments
INTEGER, INTENT(IN) :: I, J
REAL*8, INTENT(OUT) :: RATE, FRAC
! Local variables
INTEGER :: JREF
REAL*8 :: FRAC_LS, FRAC_CONV
!=================================================================
! PRECIPFRAC begins here!
!
! For the polar boxes there is no precipitation.
! Set RATE = 0, FRAC = 0 and return.
!=================================================================
JREF = J + GET_YOFFSET()
IF ( JREF == 1 .OR. JREF == JGLOB ) THEN
FRAC = 0.0d0
RATE = 0.0d0
RETURN
ENDIF
!=================================================================
! Large scale precipitation at (I,J) = PREACC(I,J) - PRECON(I,J).
!
! If there is large-scale precipitation at grid box (I,J), then
! assume that it covers 7% of the area of grid box(I,J). Store
! this value in the variable FRAC_LS.
!=================================================================
IF ( ( PREACC(I,J) - PRECON(I,J) ) > 0.0d0 ) THEN
FRAC_LS = 7.0d-2
ELSE
FRAC_LS = 0.0d0
ENDIF
!=================================================================
! Convective precipitation at (I,J) = PRECON(I,:J)
!
! If there is convective precipitation at (I,J), then
! assume that it covers 0.3% of the area of grid box (I,J).
! Store this value in the variable FRAC_CONV.
!=================================================================
IF ( PRECON(I,J) > 0.0d0 ) THEN
FRAC_CONV = 3.0d-3
ELSE
FRAC_CONV = 0.0d0
ENDIF
!=================================================================
! FRAC = total fraction of grid box (I,J) covered by precip
! = FRAC_LS + FRAC_CONV
!
! The possible values of FRAC are: 0.0%, 0.3%, 7.0%, or 7.3%.
!=================================================================
FRAC = FRAC_LS + FRAC_CONV
!=================================================================
! RATE = total precipitation rate in mm/day, adjusted for the
! fraction of the grid box that is precipitating.
!
! To get RATE, take total precip at (I,J) and divide it by FRAC.
!=================================================================
IF ( FRAC > 0.0d0 ) THEN
RATE = PREACC(I,J) / FRAC
ELSE
RATE = 0.0d0
ENDIF
! Return to calling program
END SUBROUTINE PRECIPFRAC

165
code/pulsing.f Normal file
View File

@ -0,0 +1,165 @@
! $Id: pulsing.f,v 1.1 2009/06/09 21:51:54 daven Exp $
FUNCTION PULSING( I, J, M ) RESULT( THE_PULSING )
!
!******************************************************************************
! Function PULSING calculates the increase (or "pulse") of soil NO emission
! due to precipitation falling over a dry grid square and activating dormant
! (yhw, gmg, lwh, djj, 1994; bmy, 2/11/03)
!
! Arguments as Input:
! ============================================================================
! (1 ) I (INTEGER) : Grid box longitude index
! (2 ) J (INTEGER) : Grid box latitude index
! (3 ) M (INTEGER) : Grid box surface index (M=1,NLAND)
!
! References:
! ============================================================================
! (1 ) Yienger, J.J, and H. Levy II, "Empirical model of global soil-biogenic
! NOx emissions", JGR, 100 (D6), pp. 11447-11464, June 20, 1995. See
! section 4.1 of this work.
!
! NOTES:
! (1 ) Original code by by Yuhang Wang, Gerry Gardner and Prof. Daniel Jacob
! written in the early 1990's. Updated and modified for GEOS-CHEM by
! Bob Yantosca. Updated comments, cosmetic changes. Now uses
! function GET_TS_EMIS from "time_mod.f". Removed NSRCE from the
! arg list; this is now obsolete. (bmy, 2/11/03)
!******************************************************************************
!
! References to F90 modules
USE TIME_MOD, ONLY : GET_TS_EMIS
IMPLICIT NONE
# include "CMN_SIZE"
# include "commsoil.h"
! Arguments
INTEGER, INTENT(IN) :: I, J, M
! Local variables
INTEGER :: K
REAL*8 :: AREA, RATE, FRAC, EXPFACTOR, DTSRCE
! Function value
REAL*8 :: THE_PULSING
!=================================================================
! PULSING begins here!
!=================================================================
! Emission timestep [days]
DTSRCE = GET_TS_EMIS() / 1440d0
!=================================================================
! SOILPULS(1,M) > 0 denotes dry soil. Only dry
! soil is subject to pulsing, so we proceed...
!=================================================================
IF ( SOILPULS(1,M) > 0.d0 ) THEN
! Loop over pulse types (1=sprinkle, 2=shower, 3=heavy rain)
DO K = 1, NPULSE
! SOILPULS(K+1,M) is the fraction of grid box M
! that is affected by fresh pulsing of type K
IF ( SOILPULS(K+1,M) < 1.d-3 ) THEN
! No pulse assume evaporation
SOILPULS(K+1,M) = 0.D0
ELSE
! Pulse from previous time step decays exponentially
EXPFACTOR = EXP( -PULSDECAY(K) * DTSRCE )
SOILPULS(K+1,M) = SOILPULS(K+1,M) * EXPFACTOR
ENDIF
ENDDO
!==============================================================
! Compute FRAC, the fraction of grid box (I,J) that is
! undergoing precipitation. Also compute RATE, the rate of
! total precipitation at the ground (in mm/day). RATE is
! adjusted so that it only applies to the fraction of the
! grid box where it is actually raining.
!==============================================================
CALL PRECIPFRAC( I, J, RATE, FRAC )
!==============================================================
! We now determine if a new pulse is to be applied to the grid
! box due to precipitation over the current time step.
!
! The pulse is applied to the grid square fraction FRAC
! experiencing precipitation. We assume a characteristic
! 1-day duration for precipitation in a given subgrid area of
! the grid box, so that the full extent of pulsing (PULSFACT)
! is realized over 24 hours.
!
! For a model time step of NSRCE hours we reduce the pulsing
! by a factor REAL(NSRCE)/24.
!==============================================================
IF ( ( RATE >= 1d0 ) .AND. ( RATE < 5d0 ) ) THEN
! Sprinkle
SOILPULS(2,M) = SOILPULS(2,M) + ( FRAC * DTSRCE )
ELSE IF ( ( RATE >= 5d0 ) .AND. ( RATE < 15d0 ) ) THEN
! K=3: Shower
SOILPULS(3,M) = SOILPULS(3,M) + ( FRAC * DTSRCE )
ELSE IF ( RATE >= 15d0 ) THEN
! K=4: Heavy rain
SOILPULS(4,M) = SOILPULS(4,M) + ( FRAC * DTSRCE )
ENDIF
! Initialize
THE_PULSING = 0d0
AREA = 0d0
!==============================================================
! Add up the contributions of the different pulses (K=1,3) to
! obtain the total pulsing multiplicative factor PULSING;
! PULSFACT is the multiplicative factor for fresh pulsing of
! each type.
!
! Also determine the fractional grid box area AREA affected
! by pulsing. We assume that the area occupied by the
! different pulses is additive, i.e., that successive pulses
! apply to different areas of the grid square and that the
! area coccupied by a pulse decreases as the pulsing decays.
!
! If the resulting AREA is in excess of unity then the pulsing
! must be scaled back to the grid box area. If the AREA is
! less than unity then we have to account for non-pulsing
! emissions from the (1-AREA) non-pulsing fraction of the grid
! box.
!==============================================================
DO K = 1, NPULSE
THE_PULSING = THE_PULSING + PULSFACT(K) * SOILPULS(1+K,M)
AREA = AREA + SOILPULS(1+K,M)
ENDDO
IF ( AREA < 1d0 ) THEN
THE_PULSING = THE_PULSING + 1d0 - AREA
ELSE
THE_PULSING = THE_PULSING / AREA
DO K = 1, NPULSE
SOILPULS(K+1,M) = SOILPULS(K+1,M) / AREA
ENDDO
ENDIF
!=================================================================
! ...otherwise, the soil is wet, so no pulsing occurs
!=================================================================
ELSE
THE_PULSING = 1.D0
ENDIF
! Return to calling program
END FUNCTION PULSING

973
code/rcp_mod.f Normal file
View File

@ -0,0 +1,973 @@
!------------------------------------------------------------------------------
! University of California, Irvine, Atmospheric Chemistry !
!------------------------------------------------------------------------------
!BOP
!
! !MODULE: rcp_mod
!
! !DESCRIPTION: Module RCP\_MOD provides access to the RCP emission inventories
! that were prepared for IPCC AR5. The inventory includes anthropogenic
! emissions from land, ships, and aircraft. Species include trace gases
! (NOx, CO, NH3, SO2, various VOCs) and aerosols (BC, OC). Land emissions
! include fossil fuel and biofuel use, energy production and distribution,
! residential and commercial combustion, industry, transportation, waste
! treatment and disposal, solvent production and use, agriculture, and
! agricultural waste burning. Data sources are documented in the data
! directories.
!\\
!\\
! !INTERFACE:
!
MODULE RCP_MOD
!
! !USES:
!
IMPLICIT NONE
PRIVATE
!
! !PUBLIC DATA MEMBERS:
!
!NONE
!
! !PUBLIC MEMBER FUNCTIONS:
!
PUBLIC :: CLEANUP_RCP
PUBLIC :: LOAD_RCP_EMISSIONS
PUBLIC :: GET_RCP_EMISSION
PUBLIC :: RCPNAME, RCPYEAR
PUBLIC :: RCP_AIREMISS
!
! !PRIVATE DATA MEMBERS:
!
REAL*4, ALLOCATABLE :: RCP_LAND(:,:,:)
REAL*4, ALLOCATABLE :: RCP_AIR(:,:,:,:)
REAL*4, ALLOCATABLE :: RCP_SHIP(:,:,:)
CHARACTER(LEN=20) :: RCPNAME
INTEGER :: RCPYEAR
INTEGER :: IDTRCP_LAND(20), IDTRCP_SHIP(20),
& IDTRCP_AIR(3)
!
! !REVISION HISTORY:
! 14 Jun 2012 - C. Holmes - Initial version
!EOP
!------------------------------------------------------------------------------
!BOC
CONTAINS
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: load_rcp_emissions
!
! !DESCRIPTION: Subroutine LOAD\_RCP\_EMISSIONS reads all RCP emissions at the
! beginning of each month. (cdh, 10/14/11)
!\\
!\\
! !INTERFACE:
!
SUBROUTINE LOAD_RCP_EMISSIONS
!
! !USES:
!
USE BPCH2_MOD, ONLY : GET_TAU0, GET_RES_EXT
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE ERROR_MOD, ONLY : GEOS_CHEM_STOP
USE LOGICAL_MOD, ONLY : LRCP, LRCPSHIP, LRCPAIR
USE TIME_MOD, ONLY : GET_MONTH
USE TRACERID_MOD
USE TRACER_MOD, ONLY : TRACER_NAME
# include "define.h"
!
! !REVISION HISTORY:
! 22 Jul 2013 - M. Sulprizio- Added ProTeX headers
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
LOGICAL, SAVE :: FIRST = .TRUE.
INTEGER :: THISMONTH, I
CHARACTER(LEN=20) :: RCPSPECIES, YEARSTR
CHARACTER(LEN=255) :: FILENAME
REAL*8 :: XTAU
!=================================================================
! LOAD_RCP_EMISSIONS begins here
!=================================================================
! First-time initialization
IF ( FIRST ) THEN
! Allocate arrays
CALL INIT_RCP
! Reset first-time flag
FIRST = .FALSE.
ENDIF
! Get month
THISMONTH = GET_MONTH()
! Convert to string
WRITE( YEARSTR, '(I4)' ) RCPYEAR
!=================================================================
! Land and ship emissions
!=================================================================
IF( LRCP .OR. LRCPSHIP) THEN
! Land file name
FILENAME = TRIM( DATA_DIR ) // 'RCP_201206/' //
& trim( RCPNAME ) // '/' //
& trim( RCPNAME ) // '_anthropogenic_' //
& trim( YEARSTR ) // '.' //
& GET_RES_EXT() // '.bpch'
! Date for emissions
! Land emissions dated Jan 1 because all months are the same
XTAU = GET_TAU0( 1, 1, RCPYEAR )
! Read data (LAND -> TYPE=1)
CALL READ_RCP_BPCH( FILENAME, TYPE=1, TAU0=XTAU )
! Ship file name
FILENAME = TRIM( DATA_DIR ) // 'RCP_201206/' //
& trim( RCPNAME ) // '/' //
& trim( RCPNAME ) // '_ships_' //
& trim( YEARSTR ) // '.' //
& GET_RES_EXT() // '.bpch'
! Date for emissions
XTAU = GET_TAU0( THISMONTH, 1, RCPYEAR )
! Read data (SHIP -> TYPE=2)
CALL READ_RCP_BPCH( FILENAME, TYPE=2, TAU0=XTAU )
ENDIF
!=================================================================
! Aircraft emissions
!=================================================================
IF (LRCPAIR) THEN
FILENAME = TRIM( DATA_DIR ) // 'RCP_201206/' //
& trim( RCPNAME ) // '/' //
& trim( RCPNAME ) // '_aircraft_' //
& trim( YEARSTR ) // '.' //
& GET_RES_EXT() // '.bpch'
! Date for emissions
XTAU = GET_TAU0( THISMONTH, 1, RCPYEAR )
! Read data (AIRCRAFT -> TYPE=3)
CALL READ_RCP_BPCH( FILENAME, TYPE=3, TAU0=XTAU )
ENDIF
!=================================================================
! Print totals to log
!=================================================================
CALL TOTAL_ANTHRO_RCP( THISMONTH )
! Fancy output
WRITE(6, '(a)' ) REPEAT( '=', 79)
END SUBROUTINE LOAD_RCP_EMISSIONS
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: read_rcp_bpch
!
! !DESCRIPTION: Subroutine READ\_RCP\_BPCH reads a BPCH file containing RCP
! data. (cdh, 10/14/11)
!\\
!\\
! !INTERFACE:
!
SUBROUTINE READ_RCP_BPCH( FILENAME, TYPE, TAU0 )
!
! !USES:
!
USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ
USE FILE_MOD, ONLY : IU_FILE, IOERROR
USE TRANSFER_MOD, ONLY : TRANSFER_2D
USE ERROR_MOD, ONLY : ERROR_STOP
USE TRACERID_MOD ! tracer ID numbers
# include "CMN_SIZE" ! Size parameters
!
! !INPUT PARAMETERS:
!
CHARACTER(LEN=*), INTENT(IN) :: FILENAME
INTEGER, INTENT(IN) :: TYPE ! 1=LAND, 2=SHIP, 3=AIRCRAFT
REAL*8,OPTIONAL, INTENT(IN) :: TAU0
!
! !REVISION HISTORY:
! 22 Jul 2013 - M. Sulprizio- Added ProTeX headers
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: I, J, L, N, IOS, K, IDT
INTEGER :: NI, NJ, NL
INTEGER :: IFIRST, JFIRST, LFIRST
INTEGER :: NTRACER, NSKIP
INTEGER :: HALFPOLAR, CENTER180
INTEGER :: SCALEYEAR, BASEYEAR
REAL*4 :: LONRES, LATRES
REAL*4 :: ARRAY(IIPAR,JJPAR,LLPAR)
REAL*4 :: TMP(IIPAR,JJPAR)
REAL*8 :: ZTAU0, ZTAU1
CHARACTER(LEN=20) :: MODELNAME
CHARACTER(LEN=40) :: CATEGORY
CHARACTER(LEN=40) :: UNIT
CHARACTER(LEN=40) :: RESERVED
CHARACTER(LEN=20) :: STR
!=================================================================
! READ_RCP_BPCH begins here
!=================================================================
! Echo info
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( 'READ_RCP_BPCH: Reading ', a )
! Open file
CALL OPEN_BPCH2_FOR_READ( IU_FILE, FILENAME)
! Initialize
K = 0
! Read the entire file in one pass
DO
! Read 1st data block header
READ( IU_FILE, IOSTAT=IOS )
& MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180
! Check for EOF or errors
IF ( IOS < 0 ) EXIT
IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'read_data:2' )
! Read 2nd data block header line
READ (IU_FILE, IOSTAT=IOS )
& CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED,
& NI, NJ, NL, IFIRST, JFIRST, LFIRST, NSKIP
IF ( CATEGORY /= 'ANTHSRCE' )
& CALL ERROR_STOP( 'ANTHSRCE not found', 'READ_RCP_BPCH' )
! Error check
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_data:3' )
! Read data
READ( IU_FILE, IOSTAT=IOS )
& ( ( ( ARRAY(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL )
! Error check
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_data:4' )
!==============================================================
! Save into tracer arrays
!==============================================================
! Select date, if this argument is present
IF ( PRESENT( TAU0 ) ) THEN
IF (ZTAU0 /= TAU0) CYCLE
ENDIF
IDT = 0
! Find GEOS-Chem tracer ID for each species in file
! These ID numbers will be the same as the ID numbers
! stored in the files, but we do this in case the GEOS-Chem tracer
! numbers change in the future
SELECT CASE ( NTRACER )
CASE ( 1 )
IDT = IDTNOX
CASE ( 4 )
IDT = IDTCO
CASE ( 5 )
IDT = IDTALK4
CASE ( 9 )
! We expect ACET to be lumped with MEK, as explained below
! and in RETRO implementation
CALL ERROR_STOP( 'RCP file unexpectely contains ACET: ' //
& FILENAME, 'READ_RCP_BPCH ' )
! IDT = IDTACET
CASE ( 10 )
IDT = IDTMEK
CASE ( 11 )
IDT = IDTALD2
CASE ( 18 )
IDT = IDTPRPE
CASE ( 19 )
IDT = IDTC3H8
CASE ( 20 )
IDT = IDTCH2O
CASE ( 21 )
IDT = IDTC2H6
CASE ( 26 )
IDT = IDTSO2
CASE ( 30 )
IDT = IDTNH3
CASE ( 36 )
IDT = IDTBCPO
CASE ( 37 )
IDT = IDTOCPO
CASE ( 59 )
IDT = IDTBENZ
CASE ( 60 )
IDT = IDTTOLU
CASE ( 61 )
IDT = IDTXYLE
CASE ( 65 )
IDT = IDTC2H4
CASE ( 66 )
IDT = IDTC2H2
CASE DEFAULT
! DO NOTHING
END SELECT
! Tracer number must be positive,
! otherwise it's not used for this simulation type
IF ( IDT > 0 ) THEN
! Increment tracer counter
K = K + 1
! Save emissions and tracer number
SELECT CASE ( TYPE )
CASE ( 1 )
! Error check
IF (K > SIZE( IDTRCP_LAND )) THEN
WRITE( STR, '(I4)' ) K
CALL ERROR_STOP( 'TOO MANY SPECIES FOR RCP_LAND '//
& TRIM(STR), 'READ_RCP_BPCH' )
ENDIF
CALL TRANSFER_2D( ARRAY(:,:,1), RCP_LAND(:,:,K) )
IDTRCP_LAND(K) = IDT
CASE ( 2 )
! Error check
IF (K > SIZE( IDTRCP_SHIP )) THEN
WRITE( STR, '(I4)' ) K
CALL ERROR_STOP( 'TOO MANY SPECIES FOR RCP_SHIP '//
& TRIM(STR), 'READ_RCP_BPCH' )
ENDIF
CALL TRANSFER_2D( ARRAY(:,:,1), RCP_SHIP(:,:,K) )
IDTRCP_SHIP(K) = IDT
CASE ( 3 )
! Error check
IF (K > SIZE( IDTRCP_AIR )) THEN
WRITE( STR, '(I4)' ) K
CALL ERROR_STOP( 'TOO MANY SPECIES FOR RCP_AIR '//
& TRIM(STR), 'READ_RCP_BPCH' )
ENDIF
! Transfer,
DO L=1, LLPAR
CALL TRANSFER_2D( ARRAY(:,:,L), RCP_AIR(:,:,L,K) )
ENDDO
IDTRCP_AIR(K) = IDT
CASE DEFAULT
END SELECT
!==============================================================
! Special case for MEK
! Partition ketones into 75% acetone and 25% MEK
! In the file, MEK contains all ketones.
! As done for RETRO (cdh, 10/18/11; dbm, 8/18/2011)
!==============================================================
IF (IDT == IDTMEK) THEN
! Reduce MEK emissions
SELECT CASE ( TYPE )
CASE ( 1 )
RCP_LAND(:,:,K) = RCP_LAND(:,:,K) * 0.25D0
CASE ( 2 )
RCP_SHIP(:,:,K) = RCP_SHIP(:,:,K) * 0.25D0
CASE DEFAULT
! No MEK emissions expected for aircraft
END SELECT
IF (IDTACET > 0d0) THEN
! Increment tracer counter
K = K + 1
! Save ACET emissions (75% of original MEK = 3*25%)
SELECT CASE ( TYPE )
CASE ( 1 )
RCP_LAND(:,:,K) = RCP_LAND(:,:,K-1) * 3d0
IDTRCP_LAND(K) = IDTACET
CASE ( 2 )
RCP_SHIP(:,:,K) = RCP_SHIP(:,:,K-1) * 3d0
IDTRCP_SHIP(K) = IDTACET
CASE DEFAULT
! No MEK emissions expected for aircraft
END SELECT
ENDIF
ENDIF
ENDIF
END DO
! Close file
CLOSE( IU_FILE )
END SUBROUTINE READ_RCP_BPCH
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: rcp_airemiss
!
! !DESCRIPTION: Subroutine RCP\_AIREMISS populates EMIS\_AC\_NOx with aircraft
! NOx emissions. Also does diagnostics. (cdh, 10/14/11)
!\\
!\\
! !INTERFACE:
!
SUBROUTINE RCP_AIREMISS
!
! !USES:
!
USE AIRCRAFT_NOX_MOD, ONLY : EMIS_AC_NOx, READAIR
USE DIAG_MOD, ONLY : AD32_AC
USE ERROR_MOD, ONLY : ERROR_STOP
USE DAO_MOD, ONLY : BXHEIGHT
USE TRACERID_MOD, ONLY : IDTNO
# include "CMN_SIZE" ! Size parameters
# include "CMN_DIAG" ! Diagnostic switches
!
! !REVISION HISTORY:
! 22 Jul 2013 - M. Sulprizio- Added ProTeX headers
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: I, J, L, K
LOGICAL, SAVE :: FIRST=.TRUE.
LOGICAL :: TRACERFOUND
!=================================================================
! RCP_AIREMISS begins here
!=================================================================
! Allocate and initialize arrays
IF ( FIRST ) THEN
CALL READAIR ! use this only because init_aircraft_nox is private
FIRST = .FALSE.
ENDIF
! Initialized
TRACERFOUND = .FALSE.
! Locate the NOx tracer in the emission array
DO K=1, SIZE(IDTRCP_AIR)
IF (IDTNO == IDTRCP_AIR(K)) THEN
TRACERFOUND=.TRUE.
EXIT
ENDIF
ENDDO
! Error if there are no NOx emissions
IF (.NOT. TRACERFOUND)
& CALL ERROR_STOP('RCP AVIATION NOX HAS NOT BEEN READ',
& 'RCP_AIREMISS' )
! Convert molec/cm2/s -> molec/cm3/s
EMIS_AC_NOx = RCP_AIR(:,:,:,K) / ( BXHEIGHT * 1D2 )
! ND32 -- save NOx in [molec/cm2], will convert to
! [molec/cm2/s] in subroutine "diag3.f" (bmy, 3/16/00)
IF ( ND32 > 0 ) THEN
!DO L=1, LLTROP
!DO J=1, JJPAR
!DO I=1, IIPAR
AD32_ac(:,:,:) = AD32_ac(:,:,:) + ( EMIS_AC_NOx(:,:,:) *
& BXHEIGHT(:,:,:) * 1d2 )
! AD32_ac(I,J,L) = AD32_ac(I,J,L) + ( EMIS_AC_NOx(I,J,L) *
! & BXHEIGHT(I,J,L) * 1d2 )
!ENDDO
!ENDDO
!ENDDO
ENDIF
END SUBROUTINE RCP_AIREMISS
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: total_anthro_rcp
!
! !DESCRIPTION: Subroutine TOTAL\_ANTHRO\_RCP prints total RCP anthropogenic
! emissions each month. (cdh, 10/14/11)
!\\
!\\
! !INTERFACE:
!
SUBROUTINE TOTAL_ANTHRO_RCP( THISMONTH )
!
! !USES:
!
USE GRID_MOD, ONLY : GET_AREA_CM2
USE TRACER_MOD, ONLY : TRACER_MW_KG
USE TRACER_MOD, ONLY : TRACER_NAME
USE ERROR_MOD, ONLY : GEOS_CHEM_STOP
# include "CMN_SIZE" ! Size parameters
!
! !INPUT PARAMETERS:
!
INTEGER, INTENT(IN) :: THISMONTH
!
! !REVISION HISTORY:
! 22 Jul 2013 - M. Sulprizio- Added ProTeX headers
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: I, J, K
REAL*8 :: A, TOTAL, TOTAL_SHIP
CHARACTER(LEN=6) :: UNIT
! Days per month
INTEGER :: D(12) = (/ 31, 28, 31, 30, 31, 30,
& 31, 31, 30, 31, 30, 31 /)
!=================================================================
! TOTAL_ANTHRO_RCP begins here
!=================================================================
! Echo info
WRITE(6, '(a)' ) REPEAT( '=', 79)
WRITE(6, 100 ) RCPNAME, RCPYEAR
100 FORMAT( 'R C P E M I S S I O N S',
& ' -- Scenario: ', A10, I6, / )
!==============================================================
! RCP Land emissions
!==============================================================
WRITE( 6, '(a)' )
DO K=1, SIZE(IDTRCP_LAND)
IF (IDTRCP_LAND(K) < 1) CYCLE
!==============================================================
! Global total emission
!==============================================================
TOTAL = 0d0
! Loop over latitudes
DO J = 1, JJPAR
! Surface area [cm2] * seconds in the month / Avogadro's number
! Also multiply by the factor 1d-9 to convert kg to Tg
A = GET_AREA_CM2( J ) * ( D(THISMONTH) * 86400d-9 )
& / 6.0225d23
! Anthro emissions
TOTAL = TOTAL + SUM(RCP_LAND(:,J,K)) * A *
& TRACER_MW_KG(IDTRCP_LAND(K))
ENDDO
!==============================================================
! Units
!==============================================================
SELECT CASE ( TRACER_NAME(IDTRCP_LAND(K)) )
CASE ( 'NOx' )
! Convert to Tg(N)
TOTAL = TOTAL * 0.014 / TRACER_MW_KG(IDTRCP_LAND(K))
UNIT='N'
CASE ( 'SO2' )
! Convert to Tg(S)
TOTAL = TOTAL * 0.032 / TRACER_MW_KG(IDTRCP_LAND(K))
UNIT='S'
CASE ( 'NH3' )
! Convert to Tg(N)
TOTAL = TOTAL * 0.014 / TRACER_MW_KG(IDTRCP_LAND(K))
UNIT='N'
CASE ( 'CO' )
UNIT='CO'
CASE DEFAULT
UNIT='C'
END SELECT
!==============================================================
! Print info
!==============================================================
WRITE( 6, 101 ) 'Land', TRACER_NAME(IDTRCP_LAND(K)), THISMONTH,
& TOTAL, UNIT
101 FORMAT( 'Anthro ',a5, ' ', a4, ' for month ',
& i2.2, ': ', f13.6, ' Tg ', a3 )
ENDDO
!==============================================================
! RCP Ship emissions
!==============================================================
WRITE( 6, '(a)' )
DO K=1, SIZE(IDTRCP_SHIP)
IF (IDTRCP_SHIP(K) < 1) CYCLE
!==============================================================
! Global total emission
!==============================================================
TOTAL = 0d0
! Loop over latitudes
DO J = 1, JJPAR
! Surface area [cm2] * seconds in the month / Avogadro's number
! Also multiply by the factor 1d-9 to convert kg to Tg
A = GET_AREA_CM2( J ) * ( D(THISMONTH) * 86400d-9 )
& / 6.0225d23
! Anthro emissions
TOTAL = TOTAL + SUM(RCP_SHIP(:,J,K)) * A *
& TRACER_MW_KG(IDTRCP_SHIP(K))
ENDDO
!==============================================================
! Units
!==============================================================
SELECT CASE ( TRACER_NAME(IDTRCP_SHIP(K)) )
CASE ( 'NOx' )
! Convert to Tg(N)
TOTAL = TOTAL * 0.014 / TRACER_MW_KG(IDTRCP_SHIP(K))
UNIT='N'
CASE ( 'SO2' )
! Convert to Tg(S)
TOTAL = TOTAL * 0.032 / TRACER_MW_KG(IDTRCP_SHIP(K))
UNIT='S'
CASE ( 'NH3' )
! Convert to Tg(N)
TOTAL = TOTAL * 0.014 / TRACER_MW_KG(IDTRCP_SHIP(K))
UNIT='N'
CASE ( 'CO' )
UNIT='CO'
CASE DEFAULT
UNIT='C'
END SELECT
!==============================================================
! Print info
!==============================================================
WRITE( 6, 101 ) 'Ship', TRACER_NAME(IDTRCP_SHIP(K)), THISMONTH,
& TOTAL, UNIT
ENDDO
!==============================================================
! RCP Aircraft emissions
!==============================================================
WRITE( 6, '(a)' )
DO K=1, SIZE(IDTRCP_AIR)
IF (IDTRCP_AIR(K) < 1) CYCLE
!==============================================================
! Global total emission
!==============================================================
TOTAL = 0d0
! Loop over latitudes
DO J = 1, JJPAR
! Surface area [cm2] * seconds in the month / Avogadro's number
! Also multiply by the factor 1d-9 to convert kg to Tg
A = GET_AREA_CM2( J ) * ( D(THISMONTH) * 86400d-9 )
& / 6.0225d23
! Anthro emissions
TOTAL = TOTAL + SUM(RCP_AIR(:,J,:,K)) * A *
& TRACER_MW_KG(IDTRCP_AIR(K))
ENDDO
!==============================================================
! Units
!==============================================================
SELECT CASE ( TRACER_NAME(IDTRCP_AIR(K)) )
CASE ( 'NOx' )
! Convert to Tg(N)
TOTAL = TOTAL * 0.014 / TRACER_MW_KG(IDTRCP_AIR(K))
UNIT='N'
CASE ( 'SO2' )
! Convert to Tg(S)
TOTAL = TOTAL * 0.032 / TRACER_MW_KG(IDTRCP_AIR(K))
UNIT='S'
CASE ( 'NH3' )
! Convert to Tg(N)
TOTAL = TOTAL * 0.014 / TRACER_MW_KG(IDTRCP_AIR(K))
UNIT='N'
CASE ( 'CO' )
UNIT='CO'
CASE DEFAULT
UNIT='C'
END SELECT
!==============================================================
! Print info
!==============================================================
WRITE( 6, 101 ) 'Air', TRACER_NAME(IDTRCP_AIR(K)), THISMONTH,
& TOTAL, UNIT
ENDDO
END SUBROUTINE TOTAL_ANTHRO_RCP
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: get_rcp_emission
!
! !DESCRIPTION: Function GET\_RCP\_EMISSION retrieves the emissions of tracer N
! at grid location (I,J). Use LAND=.TRUE. or SHIP=.TRUE. or both to retrieve
! either land anthropogenic emissions, ship emissions, or their sum.
! "N" is the advected tracer index, i.e. the tracer index for STT.
! The function will return -1 if no emissions are found for that species.
! (cdh, 10/14/11)
!\\
!\\
! !INTERFACE:
!
FUNCTION GET_RCP_EMISSION( I, J, N, LAND, SHIP )
& RESULT( EMISS )
!
! !USES:
!
USE TRACERID_MOD
USE ERROR_MOD, ONLY : ERROR_STOP
!
! !INPUT PARAMETERS:
!
INTEGER, INTENT(IN) :: I, J
INTEGER, INTENT(IN) :: N !GEOS-Chem advected tracer index
LOGICAL, INTENT(IN), OPTIONAL :: SHIP
LOGICAL, INTENT(IN), OPTIONAL :: LAND
!
! !REVISION HISTORY:
! 22 Jul 2013 - M. Sulprizio- Added ProTeX headers
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
REAL*8 :: EMISS
CHARACTER(LEN=20) :: STR
LOGICAL :: DOLAND, DOSHIP, TRACERFOUND
INTEGER :: K
!=================================================================
! GET_RCP_EMISSION begins here!
!=================================================================
! Are we getting land emissions?
IF ( PRESENT( LAND ) ) THEN
DOLAND = LAND
ELSE
DOLAND = .FALSE.
ENDIF
! Are we getting ship emissions?
IF ( PRESENT( SHIP ) ) THEN
DOSHIP = SHIP
ELSE
DOSHIP = .FALSE.
ENDIF
! Throw error if neither emission type is requested
IF ( .NOT. (DOLAND .OR. DOSHIP) ) THEN
WRITE( STR, '(I4)' ) N
CALL ERROR_STOP( 'No land/ship emissions, tracer '//trim(STR),
& 'GET_RCP_EMISSION' )
ENDIF
! Initialize
EMISS = 0d0
TRACERFOUND = .FALSE.
! Find tracer number for land emissions
IF ( DOLAND ) THEN
! Loop over all the species we have land emissions for
DO K=1, SIZE(IDTRCP_LAND)
IF (N == IDTRCP_LAND(K)) THEN
! We found the desired tracer, so add it up and exit loop
EMISS = EMISS + RCP_LAND(I,J,K)
TRACERFOUND=.TRUE.
EXIT
ENDIF
ENDDO
ENDIF
! Find tracer number for ship emissions
IF ( DOSHIP ) THEN
! Loop over all the species we have ship emissions for
DO K=1, SIZE(IDTRCP_SHIP)
IF (N == IDTRCP_SHIP(K)) THEN
! We found the desired tracer, so add it up and exit loop
EMISS = EMISS + RCP_SHIP(I,J,K)
TRACERFOUND=.TRUE.
EXIT
ENDIF
ENDDO
ENDIF
! Return -1 if there are no emissions for tracer N
IF (.NOT. TRACERFOUND) EMISS = -1d0
END FUNCTION GET_RCP_EMISSION
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_rcp
!
! !DESCRIPTION: Subroutine INIT\_RCP allocates and zeroes all module arrays
! (cdh, 10/14/11)
!\\
!\\
! !INTERFACE:
!
SUBROUTINE INIT_RCP
!
! !USES:
!
USE ERROR_MOD, ONLY : ALLOC_ERR
USE LOGICAL_MOD, ONLY : LRCP, LRCPSHIP, LRCPAIR
# include "CMN_SIZE" ! Size parameters
!
! !REVISION HISTORY:
! 22 Jul 2013 - M. Sulprizio- Added ProTeX headers
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: AS
!=================================================================
! INIT_RCP begins here
!=================================================================
! Return if we LRCP = .FALSE.
IF ( .not. (LRCP .OR. LRCPSHIP .OR. LRCPAIR) ) RETURN
IDTRCP_LAND = 0d0
IDTRCP_SHIP = 0d0
IDTRCP_AIR = 0d0
! Anthropogenic land surface emissions
ALLOCATE( RCP_LAND( IIPAR, JJPAR, SIZE(IDTRCP_LAND) ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RCP_LAND' )
RCP_LAND = 0e0
! Shipping
ALLOCATE( RCP_SHIP( IIPAR, JJPAR, SIZE(IDTRCP_SHIP) ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RCP_SHIP' )
RCP_SHIP = 0e0
! Aircraft
ALLOCATE( RCP_AIR( IIPAR, JJPAR, LLPAR, SIZE(IDTRCP_AIR) ),
& STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RCP_AIR' )
RCP_AIR = 0e0
END SUBROUTINE INIT_RCP
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: cleanup_rcp
!
! !DESCRIPTION: Subroutine CLEANUP\_RCP deallocates all module arrays
! (cdh, 10/14/11)
!\\
!\\
! !INTERFACE:
!
SUBROUTINE CLEANUP_RCP
!
! !REVISION HISTORY:
! 22 Jul 2013 - M. Sulprizio- Added ProTeX headers
!EOP
!------------------------------------------------------------------------------
!BOC
!=================================================================
! CLEANUP_RCP begins here
!=================================================================
IF ( ALLOCATED( RCP_LAND ) ) DEALLOCATE( RCP_LAND )
IF ( ALLOCATED( RCP_SHIP ) ) DEALLOCATE( RCP_SHIP )
IF ( ALLOCATED( RCP_AIR ) ) DEALLOCATE( RCP_AIR )
END SUBROUTINE CLEANUP_RCP
!EOC
END MODULE RCP_MOD

114
code/rd_aod.f Normal file
View File

@ -0,0 +1,114 @@
!------------------------------------------------------------------------------
! GEOS-Chem Global Chemical Transport Model !
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: rd_aod
!
! !DESCRIPTION: Subroutine RD\_AOD reads aerosol phase functions that are
! used to scale diagnostic output to an arbitrary wavelengh. This
! facilitates comparing with satellite observations.
!\\
!\\
! !INTERFACE:
!
SUBROUTINE RD_AOD( NJ1, NAMFIL )
!
! !USES:
!
USE ERROR_MOD, ONLY : ERROR_STOP
USE FILE_MOD, ONLY : IOERROR
IMPLICIT NONE
# include "cmn_fj.h"
# include "jv_cmn.h"
!
! !INPUT PARAMETERS:
!
INTEGER, INTENT(IN) :: NJ1 ! Unit # of file to open
CHARACTER(LEN=*), INTENT(IN) :: NAMFIL ! Name of file to open
!
! !REMARKS:
! The jv_spec_aod.dat file contains the optical properties for aerosols
! at a single wavelength to be used in the online calculation of the aerosol
! optical depth diagnostics. The default properties are provided at 550 nm.
! These properties have been calculated using the same size and optical
! properties as the jv_spec.dat file used for the FAST-J photolysis
! calculations. The user can exchange this set of properties with those at
! another wavelength. We recommend that the wavelength used be included
! in the first line of the header for traceability (this line is output to
! the GEOS-Chem log file during run time). A complete set of optical
! properties from 250-2000 nm for aerosols is available at:
! ftp://ftp.as.harvard.edu/geos-chem/data/aerosol_optics/hi_spectral_res
! .
! -- Colette L. Heald, 05/10/10)
!
! Important variables:
! .
! NAMFIL Name of spectral data file (jv_spec_aod.dat)
! NJ1 Channel number for reading data file
! NAA2 Number of categories for scattering phase functions
! QAA_AOD Aerosol scattering phase functions
! WAA_AOD Wavelengths for the NK supplied phase functions
! PAA_AOD Phase function: first 8 terms of expansion
! RAA_AOD Effective radius associated with aerosol type
! SSA_AOD Single scattering albedo
!
! !REVISION HISTORY:
! 10 May 2010 - C. Heald - Initial version
! 06 Aug 2010 - C. Carouge - Add an error check when opening the file
! 01 Aug 2012 - R. Yantosca - Now restore NJ1 to INTENT(IN) status
! 20 Aug 2013 - R. Yantosca - Removed "define.h", this is now obsolete
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES
!
INTEGER :: I, J, K, NAA2
INTEGER :: IOS
!================================================================
! RD_AOD begins here!
!================================================================
! open file
OPEN( NJ1, FILE=TRIM( NAMFIL ), STATUS='OLD', IOSTAT=IOS )
! Error check
IF ( IOS /= 0 ) THEN
WRITE(6,100) trim(NAMFIL)
100 FORMAT('Error opening filename=', a )
CALL FLUSH(6)
CALL IOERROR( IOS, NJ1, 'RD_AOD:1')
ENDIF
! Read header lines
READ( NJ1,'(A)' ) TITLE0
WRITE( 6, '(1X,A)' ) TITLE0
READ( NJ1,'(A)' ) TITLE0
! Read aerosol phase functions (one wavelength only):
READ( NJ1,'(A10,I5,/)' ) TITLE0,NAA2
DO j = 15, NAA
READ(NJ1,110) TITLEA(j)
110 FORMAT( 3x, a20 )
WRITE(6,*) TITLEA(j)
READ(NJ1,*) WAA_AOD(j),QAA_AOD(j),RAA_AOD(j),SSA_AOD(j),
& (PAA_AOD(i,j),i=1,8)
ENDDO
! Echo info to stdout
WRITE( 6, '(a)' ) 'Aerosol Qext for AOD calculations'
DO J=15,NAA
WRITE( 6, * ) TITLEA(J),J,' Qext =',(QAA_AOD(J))
ENDDO
! Close file
CLOSE( NJ1 )
END SUBROUTINE RD_AOD
!EOC

64
code/rd_js.f Normal file
View File

@ -0,0 +1,64 @@
C $Id: rd_js.f,v 1.1 2009/06/09 21:51:53 daven Exp $
subroutine rd_js(nj1,namfil)
C-----------------------------------------------------------------------
c Reread the ratj.d file to map photolysis rate to reaction
c Read in quantum yield 'jfacta' and fastj label 'jlabel'
C-----------------------------------------------------------------------
c
c jfacta Quantum yield (or multiplication factor) for photolysis
c jlabel Reference label identifying appropriate J-value to use
c ipr Photolysis reaction counter - should total 'jppj'
c
C-----------------------------------------------------------------------
IMPLICIT NONE
# include "cmn_fj.h"
# include "jv_cmn.h"
c
integer nj1, ipr, i
character*6 namfil
character*120 cline
c
c Reread the ratj.d file to map photolysis rate to reaction
c Read in quantum yield jfacta and fastj label jlabel
ipr=0
open(nj1,file=namfil,status='old',form='formatted')
10 read(nj1,'(a)',err=20) cline
if(cline(2:5).eq.'9999') then
go to 20
elseif(cline(1:1).eq.'#') then
go to 10
elseif(cline(5:5).eq.'$') then
go to 10
else
ipr=ipr+1
read(cline(79:83),'(f5.1)') jfacta(ipr)
read(cline(86:92),'(a7)') jlabel(ipr)
jfacta(ipr)=jfacta(ipr)/100.d0
C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
C Additional code to read reaction names and branch numbers
C (ppm, 6/98, bmy, 9/99)
read (cline(7:10),"(a4)") rnames(ipr)
rnames(ipr) = trim(rnames(ipr))
branch(ipr) = 1
do i=1,ipr-1
if (rnames(ipr) == rnames(i)) branch(ipr) = branch(i) + 1
enddo
C~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
go to 10
endif
20 close(nj1)
if(ipr.ne.jppj) then
write(6,1000) ipr,jppj
stop
endif
c
c Print details to standard output
write(6,1100) ipr
write(6,1200) (i, jlabel(i), jfacta(i),i=1,ipr)
c
return
1000 format(' Error: ',i3,' photolysis labels but ',i3,' reactions')
1100 format(' Fast-J Photolysis Scheme: considering ',i2,' reactions')
1200 format(3x,10(3(i2,': ',a7,' (Q.Y. ',f5.3,') '),/,3x))
end

50
code/rd_prof.f Normal file
View File

@ -0,0 +1,50 @@
C $Id: rd_prof.f,v 1.1 2009/06/09 21:51:53 daven Exp $
subroutine rd_prof(nj2,namfil)
C-----------------------------------------------------------------------
c Routine to input T and O3 reference profiles
C-----------------------------------------------------------------------
IMPLICIT NONE
# include "cmn_fj.h"
# include "jv_cmn.h"
integer ia, i, m, l, lat, mon, ntlats, ntmons, n216, nj2
real*8 ofac,ofak
character*11 namfil
c
open(NJ2,file=namfil)
read(NJ2,'(A)') TITLE0
write(6,'(1X,A)') TITLE0
read(NJ2,'(2I5)') NTLATS,NTMONS
write(6,1000) NTLATS,NTMONS
N216 = MIN0(216, NTLATS*NTMONS)
do IA=1,N216
read(NJ2,'(1X,I3,3X,I2)') LAT, MON
M = MIN(12, MAX(1, MON))
L = MIN(18, MAX(1, (LAT+95)/10))
read(NJ2,'(3X,11F7.1)') (TREF(I,L,M), I=1,41)
read(NJ2,'(3X,11F7.4)') (OREF(I,L,M), I=1,31)
enddo
close(NJ2)
c
c Extend climatology to 100 km
ofac=exp(-2.d5/ZZHT)
do i=32,51
ofak=ofac**(i-31)
do m=1,ntmons
do l=1,ntlats
oref(i,l,m)=oref(31,l,m)*ofak
enddo
enddo
enddo
do l=1,ntlats
do m=1,ntmons
do i=42,51
tref(i,l,m)=tref(41,l,m)
enddo
enddo
enddo
c
return
1000 format(1x,'Data: ',i3,' Lats x ',i2,' Months')
end

73
code/rdisopt.f Normal file
View File

@ -0,0 +1,73 @@
! $Id: rdisopt.f,v 1.1 2009/06/09 21:51:51 daven Exp $
SUBROUTINE RDISOPT( CONVERT )
!
!******************************************************************************
! Subroutine RDISOPT reads in the baseline emissions for Isoprene, as
! a function of Olson land type. (yhw, bmy, 7/6/01, 7/20/04)
!
! Arguments as Input:
! ============================================================================
! (1 ) CONVERT (REAL*8) : Base emissions for Isoprene by Olson land type
! [atoms C/cm2 leaf/s]
!
! NOTES:
! (1 ) Now use F90 syntax. Use IOERROR to trap I/O errors. Now read the
! "isopemis.table" file directly from DATA_DIR. Updated comments
! and made cosmetic changes. CMN_ISOP is not needed. (bmy, 7/6/01)
! (2 ) Deleted obsolete code from ages past (bmy, 9/4/01)
! (3 ) Now read the "isopemis.table" file from the DATA_DIR/biogenic_200203/
! directory (bmy, 3/29/02)
! (4 ) Deleted obsolete code from March 2002. Now reference IU_FILE and
! IOERROR from "file_mod.f". Now use IU_FILE instead of IUNIT as
! the file unit number. (bmy, 6/27/02)
! (5 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04)
!******************************************************************************
!
! References to F90 modules
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE FILE_MOD, ONLY : IU_FILE, IOERROR
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
! Arguments
REAL*8, INTENT(OUT) :: CONVERT(NVEGTYPE)
! Local variables
INTEGER :: I, J, IOS
!INTEGER, PARAMETER :: IUNIT=65
CHARACTER(LEN=80) :: DUM
CHARACTER(LEN=255) :: FILENAME
!=================================================================
! RDISOPT begins here!
!=================================================================
! Define the file name
FILENAME = TRIM( DATA_DIR ) // 'biogenic_200203/isopemis.table'
! Echo info to stdout
WRITE( 6, 10 ) TRIM( FILENAME )
10 FORMAT( ' - RDISOPT: Reading ', a )
! Open file
OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='OLD',
& FORM='FORMATTED', IOSTAT=IOS )
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'rdisopt:1' )
! Read header line
READ( IU_FILE, '(a80)', IOSTAT=IOS ) DUM
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'rdisopt:2' )
! Read base isoprene emissons by landtype [atoms C/cm2 leaf/s]
DO I = 1, NVEGTYPE
READ( IU_FILE, *, IOSTAT=IOS ) J, CONVERT(I)
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'rdisopt:3' )
ENDDO
! Close file
CLOSE( IU_FILE )
! Return to calling program
END SUBROUTINE RDISOPT

111
code/rdlai.f Normal file
View File

@ -0,0 +1,111 @@
! $Id: rdlai.f,v 1.1 2009/06/09 21:51:54 daven Exp $
SUBROUTINE RDLAI( JDAY, MONTH )
C**********************************************************************
C *
C HARVARD ATMOSPHERIC CHEMISTRY MODELING GROUP *
C MODULE FOR SOIL NOx EMISSIONS *
C by Yuhang Wang, Gerry Gardner and Prof. Daniel Jacob *
C (Release V2.1) *
C *
C Contact person: Bob Yantosca (bmy@io.harvard.edu) *
C *
C**********************************************************************
C Be sure to force double precision with the DBLE function *
C and the "D" exponent, wherever necessary. (bmy, 10/6/99) *
C**********************************************************************
C Replace IMX with IGLOB and JMX with JGLOB (bmy, 6/25/02) *
C**********************************************************************
! References to F90 modules (bmy, 2/11/03)
USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET
IMPLICIT NONE
C**********************************************************************
C update daily the LAIs (Leaf Area Index) *
C**********************************************************************
C IREG = Number of landtypes in grid square (I,J) *
C XLAI = Leaf Area Index of land type element K (I,J,K) *
C current month *
C XLAI2 = Leaf Area Index of land type element K (I,J,K) *
C following month *
C XYLAI = Leaf Area Index of land type element K (IJLOOP,K) *
C**********************************************************************
# include "CMN_SIZE"
# include "CMN_DEP"
# include "CMN_VEL"
INTEGER STARTDAY(13),ISAVE
DATA STARTDAY /15,45,74,105,135,166,196,227,258,288,319,349,380/
DATA ISAVE /0/
SAVE ISAVE
INTEGER IMUL
INTEGER I,J,K,IJLOOP,MM,ITD
INTEGER JDAY,MONTH,IREF,JREF
! Need to add I0, J0 as local variables (bmy, 2/11/03)
INTEGER I0, J0
! Get nested-grid offsets (bmy, 2/11/03)
I0 = GET_XOFFSET()
J0 = GET_YOFFSET()
IF (ISAVE.EQ.0) THEN
ISAVE=1
CALL FINDMON(JDAY,MONTH,MM,STARTDAY)
IF (JDAY.LT.STARTDAY(1)) THEN
IMUL=365-STARTDAY(12)+JDAY
ITD = 31
ELSE
IMUL=JDAY-STARTDAY(MM)
ITD = STARTDAY(MM+1) - STARTDAY(MM)
END IF
CALL READLAI(MM)
DO J=1,JGLOB
DO I=1,IGLOB
DO K=1,IREG(I,J)
XLAI2(I,J,K) = (XLAI2(I,J,K)-XLAI(I,J,K))/(DBLE(ITD))
XLAI(I,J,K)=XLAI(I,J,K)+ XLAI2(I,J,K) * DBLE(IMUL)
END DO
END DO
END DO
ELSE
CALL FINDMON(JDAY,MONTH,MM,STARTDAY)
IF (JDAY.EQ.STARTDAY(MM)) THEN
ITD = STARTDAY(MM+1) - STARTDAY(MM)
CALL READLAI(MM)
DO J=1,JGLOB
DO I=1,IGLOB
DO K=1,IREG(I,J)
XLAI2(I,J,K) = (XLAI2(I,J,K)-XLAI(I,J,K))/(DBLE(ITD))
END DO
END DO
END DO
ELSE
DO J=1,JGLOB
DO I=1,IGLOB
DO K=1,IREG(I,J)
XLAI(I,J,K)=XLAI(I,J,K)+ XLAI2(I,J,K)
END DO
END DO
END DO
END IF
END IF
IJLOOP = 0
DO J = 1, JJPAR
JREF = J + J0
DO I = 1, IIPAR
IJLOOP = IJLOOP + 1
DO K=1,IJREG(IJLOOP)
IREF = I + I0
XYLAI(IJLOOP,K)=XLAI(IREF,JREF,K)
END DO
END DO
END DO
! Return to calling program
END SUBROUTINE RDLAI

121
code/rdland.f Normal file
View File

@ -0,0 +1,121 @@
! $Id: rdland.f,v 1.1 2009/06/09 21:51:52 daven Exp $
SUBROUTINE RDLAND
!
!******************************************************************************
! Subroutine RDLAND reads the land types and fractions (times 1000)
! from the "vegtype.global" file. (yhw, gmg, djj, 1994; bmy, 12/20/04)
!
! Common-block variables from header file "CMN_DEP":
! ============================================================================
! (1 ) FRCLND(I,J) : Land fraction (0.0 - 1.0)
! (2 ) IREG(I,J) : Number of landtypes in each grid box
! (3 ) ILAND(I,J,LDT) : Land type ID for element LDT =1, IREG(I,J)
! (4 ) IUSE(I,J,LDT) : Fraction (per mil) of gridbox area occupied by
! land type element LDT
!
! Common-block variables from header file "CMN_VEL":
! ============================================================================
! (1 ) IJREG(IJLOOP) : 2-D (I*J, LDT) version of IJREG (for DEPVEL)
! (2 ) IJLAND(IJLOOP,LDT) : 2-D (I*J, LDT) version of IJLAND (for DEPVEL)
! (3 ) IJUSE(IJLOOP,LDT) : 2-D (I*J, LDT) version of IJUSE (for DEPVEL)
!
! NOTES:
! (1 ) Now read the "vegtype.global" file from the leaf_area_index_200412
! subdirectory of DATA_DIR. This is the same Olson land map as was
! used previously. Also updated comments and added standard GEOS-CHEM
! program documentation header. (tmf, bmy, 12/6/04)
! (2 ) Now read the "vegtype.global" file from the leaf_area_index_200412
! subdirectory if LAVHRRLAI=T. Also updated comments and added
! standard GEOS-CHEM program documentation header. (bmy, 12/20/04)
!******************************************************************************
!
! References to F90 modules
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE ERROR_MOD, ONLY : ERROR_STOP
USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET
USE LOGICAL_MOD, ONLY : LAVHRRLAI
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "CMN_DEP" ! FRCLND, IREG, ILAND, IUSE
# include "CMN_VEL" ! IJREG, IJLAND, IJUSE
! Local variables
INTEGER :: I, J, K, IJLOOP, IREF, JREF
INTEGER :: I0, J0
! For filename
CHARACTER(LEN=255) :: FILENAME
!=================================================================
! RDLAND begins here!
!=================================================================
! Get nested-grid offsets (bmy, 2/11/03)
I0 = GET_XOFFSET()
J0 = GET_YOFFSET()
! Read the "vegtype.global" from the proper directory
! depending on the setting of the LAVHRRLAI flag (bmy, 12/20/04)
IF ( LAVHRRLAI ) THEN
FILENAME = TRIM( DATA_DIR ) //
& 'leaf_area_index_200412/vegtype.global'
ELSE
FILENAME = TRIM( DATA_DIR ) //
& 'leaf_area_index_200202/vegtype.global'
ENDIF
WRITE( 6, 50 ) TRIM( FILENAME )
50 FORMAT( ' - RDLAND: Reading ', a )
! Open the file
OPEN( 65, FILE=TRIM( FILENAME ), STATUS='OLD',
& FORM='FORMATTED', ERR=700 )
! Read data
100 READ(65,101,end=110,ERR=800) I,J,IREG(I,J),
& (ILAND(I,J,K),K=1,IREG(I,J)),
& (IUSE(I,J,K),K=1,IREG(I,J))
#if defined( GRID2x25 )
101 FORMAT(25I4)
#else
101 FORMAT(20I4)
#endif
GO TO 100
! Process data into arrays
110 CONTINUE
CLOSE (65)
IJLOOP = 0
DO 500 J = 1, JJPAR
JREF = J + J0
DO 400 I = 1, IIPAR
FRCLND(I,J) = 1000.
IREF = I + I0
IJLOOP = IJLOOP + 1
IJREG(IJLOOP) = IREG(IREF,JREF)
DO 300 K=1,IJREG(IJLOOP)
IJLAND(IJLOOP,K) = ILAND(IREF,JREF,K)
IJUSE(IJLOOP,K) = IUSE(IREF,JREF,K)
IF (IJLAND(IJLOOP,K) .EQ. 0 )
& FRCLND(I,J) = FRCLND(I,J) - IJUSE(IJLOOP,K)
300 CONTINUE
FRCLND(I,J) = FRCLND(I,J) / 1000.
400 CONTINUE
500 CONTINUE
! Return
RETURN
! Trap File open error
700 CONTINUE
CALL ERROR_STOP( 'Error opening "vegtype.global"', 'rdland.f' )
! Trap file read error
800 CONTINUE
CALL ERROR_STOP( 'Error reading "vegtype.global"', 'rdland.f' )
! Return to calling program
END SUBROUTINE RDLAND

62
code/rdlight.f Normal file
View File

@ -0,0 +1,62 @@
! $Id: rdlight.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE RDLIGHT
!
!******************************************************************************
! Subroutine RDLIGHT reads the polynomial coefficients for isoprene
! emissions from disk. (yhw, bmy, 7/6/01, 7/20/04)
!
! NOTES:
! (1 ) Now use F90 syntax. Now reads the file "light.table" directly
! from DATA_DIR so that symbolic links are unnecessary. Also use
! IOERROR to trap I/O errors. Updated comments and made cosmetic
! changes (bmy, 7/6/01)
! (2 ) Deleted obsolete code from ages ago. Also print full pathname
! of the "light.table" file. (bmy, 9/4/01)
! (3 ) Now read file "light.table" from the DATA_DIR/biogenic_200203/
! directory. Added FILENAME variable. (bmy, 3/29/02)
! (4 ) Deleted obsolete code from March 2002. Now reference IU_FILE and
! IOERROR from "file_mod.f". Now use IU_FILE instead of IUNIT as
! the file unit number. (bmy, 6/27/02)
! (5 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04)
!******************************************************************************
!
! References to F90 modules
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE FILE_MOD, ONLY : IU_FILE, IOERROR
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "CMN_ISOP" ! SOPCOEFF
INTEGER :: I, IOS
CHARACTER(LEN=80) :: DUM
CHARACTER(LEN=255) :: FILENAME
!=================================================================
! RDLIGHT begins here!
!=================================================================
! File containing polynomial data
FILENAME = TRIM( DATA_DIR ) // 'biogenic_200203/light.table'
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( ' - RDLIGHT: Reading ', a )
! Open the "light.table" file in DATA_DIR/biogenic_200203/
OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS )
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'rdlight:1' )
! Read header line
READ( IU_FILE, '(a80)', IOSTAT=IOS ) DUM
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'rdlight:2' )
! Read data
READ( IU_FILE,'(8(1PE10.2))',IOSTAT=IOS ) (SOPCOEFF(I), I=1,NPOLY)
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'rdlight:3' )
! Close file
CLOSE( IU_FILE )
! Return to calling program
END SUBROUTINE RDLIGHT

72
code/rdmonot.f Normal file
View File

@ -0,0 +1,72 @@
! $Id: rdmonot.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE RDMONOT( GMONOT )
!
!******************************************************************************
! Subroutine RDMONOT reads baseline monoterpene emission values from
! Guenther et al. (1995), as a function of Olson landtype area.
! (bdf, bmy, 7/6/01, 7/20/04)
!
! Arguments as Output:
! ============================================================================
! (1 ) GMONOT: Monoterpene emissions for each landtype [atoms C/cm2 leaf/s]
!
! NOTES:
! (1 ) Now read updated file "monotemis.v4-13.table" (bdf, bmy, 6/6/01)
! (2 ) Now reference DATA_DIR from "CMN_SETUP. (bmy, 6/6/01)
! (3 ) Now use IOERROR to trap I/O errors (bmy, 6/6/01)
! (4 ) IUNIT=65 is now a parameter (bmy, 7/6/01)
! (5 ) Now read file "monotemis.v4-13.table" from the
! DATA_DIR/biogenic_200203 directory (bmy, 3/29/02)
! (6 ) Removed obsolete code from March 2002. Now reference IU_FILE and
! IOERROR from "file_mod.f". Now use IU_FILE as the file unit number
! instead of IUNIT. (bmy, 6/27/02)
! (7 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04)
!******************************************************************************
!
! References to F90 modules
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE FILE_MOD, ONLY : IU_FILE, IOERROR
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
! Arguments
REAL*8, INTENT(OUT) :: GMONOT(NVEGTYPE)
! Local variables
INTEGER :: N, T, IOS
CHARACTER(LEN=255) :: FILENAME
!=================================================================
! RDMONOT begins here!
!=================================================================
! Monoterpene file name
FILENAME = TRIM( DATA_DIR ) //
& 'biogenic_200203/monotemis.v4-13.table'
! Echo output
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( ' - RDMONOT: Reading ', a )
! Open file
OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='OLD',
& FORM='FORMATTED', IOSTAT=IOS )
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'rdmonot:1' )
! Read header line
READ( IU_FILE, * )
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'rdmonot:2' )
! Loop over vegetation types and read emissions [atoms C/cm2 leaf/s]
DO N = 1, NVEGTYPE
READ( IU_FILE, *, IOSTAT=IOS ) T, GMONOT(N)
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'rdmonot:3' )
ENDDO
! Close IU_FILE
CLOSE( IU_FILE )
! Return to calling program
END SUBROUTINE RDMONOT

197
code/rdsoil.f Normal file
View File

@ -0,0 +1,197 @@
! $Id: rdsoil.f,v 1.1 2009/06/09 21:51:54 daven Exp $
SUBROUTINE RDSOIL
!
!******************************************************************************
! Subroutine RDSOIL reads in soiltype data, fertilizer data, and monthly
! soil precipitation data. (yhw, gmg, djj, bmy, 1994, 7/20/04)
!
! RDSOIL is one of the original GEOS-CHEM subroutines, and has its origins
! from the GISS-II model that was used at Harvard in the early 90's. This
! was cleaned up and improved error checking was added. (bmy, 4/2/02)
!
! Variables from "commsoil.h" header file:
! ============================================================================
! (1 ) NCONSOIL (INTEGER) : Olson -> soil type mapping index
! (2 ) INDEXSOIL (INTEGER) : Array containing grid box indices (I,J)
! (3 ) SOILFERT (REAL*8 ) : Array containing fertilizer NOx [ng N/m2/s]
! (4 ) SOILPREP (REAL*8 ) : Array containing 2 months of observed
! soil precipitation [mm/day]
!
! Files read in by "rdsoil.f":
! ============================================================================
! (1 ) DATA_DIR/soil_NOx_200203/soiltype.dat : Olson and soil land types
! (2 ) DATA_DIR/soil_NOx_200203/fert_scale.dat : NOx from fertilizers
! (3 ) DATA_DIR/soil_NOx_200203/climatprep4x5.dat : 1x1 monthly soil precip
! climatprep2x25.dat : 2x2.5 monthly soil precip
! climatprep1x1.dat : 4x5 monthly soil precip
!
! NOTES:
! (1 ) Be sure to force double precision with the DBLE function and the "D"
! exponent, wherever necessary (bmy, 10/6/99) *
! (2 ) Now read soil data files directly from the from
! DATA_DIR/soil_NOx_200203/ subdirectory. Now use IOERROR to trap
! I/O errors across all platforms. Added comment header. Updated
! comments, cosmetic changes. (bmy, 4/2/02)
! (3 ) Removed obsolete code from April 2002. Now reference IU_FILE and
! IOERROR from "file_mod.f". Now use IU_FILE as the file unit number,
! assign it to IUNIT. (bmy, 6/27/02)
! (4 ) Now reference GEOS_CHEM_STOP from "error_mod.f". Bug fix: remove
! duplicate declaration of IOS. This causes compile errors for the
! ALPHA platform. (gcc, bmy, 11/6/02)
! (5 ) Now use function GET_MONTH from "time_mod.f". Now make MONTH a local
! variable. (bmy, 2/11/03)
! (6 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04)
!******************************************************************************
!
! References to F90 modules
USE BPCH2_MOD, ONLY : GET_RES_EXT
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE FILE_MOD, ONLY : IU_FILE, IOERROR
USE ERROR_MOD, ONLY : GEOS_CHEM_STOP
USE TIME_MOD, ONLY : GET_MONTH
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "commsoil.h" ! Soil variables
! Local variables
LOGICAL, SAVE :: FIRST = .TRUE.
INTEGER, SAVE :: MONSAVE = 0
INTEGER :: I, IUNIT, IOS, J, K, KK, M, M1, MONTH
REAL*8 :: TMP(12)
! Name of file to read in
CHARACTER(LEN=255) :: FILENAME
!=================================================================
! RDSOIL begins here!
!=================================================================
! Define the file unit
IUNIT = IU_FILE
! Get the current month
MONTH = GET_MONTH()
! First-time only initialization
IF ( FIRST ) THEN
! Reset First-time flag
FIRST = .FALSE.
!==============================================================
! Read in soil type data (first pass only)
!==============================================================
! Define soiltype file name
FILENAME = TRIM( DATA_DIR ) // 'soil_NOx_200203/soiltype.dat'
! Echo filename
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( ' - RDSOIL: Reading ', a )
! Open file
OPEN( IUNIT, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS )
IF ( IOS /= 0 ) CALL IOERROR( IOS, IUNIT, 'rdsoil:1' )
! Read header line
READ( IUNIT, '(a)', IOSTAT=IOS )
IF ( IOS /= 0 ) CALL IOERROR( IOS, IUNIT, 'rdsoil:2' )
! Read data
DO K = 1, NVEGTYPE
READ( IUNIT, *, IOSTAT=IOS ) KK, NCONSOIL(KK+1)
IF ( IOS /= 0 ) CALL IOERROR( IOS, IUNIT, 'rdsoil:3' )
ENDDO
! Close file
CLOSE( IUNIT )
!==============================================================
! Read in fertilizer data (first pass only)
! Units are [ng N/m2/s]
!==============================================================
! Define fertilizer file name
FILENAME = TRIM( DATA_DIR ) // 'soil_NOx_200203/fert_scale.dat'
! Echo filename
WRITE( 6, 100 ) TRIM( FILENAME )
! Open file
OPEN( IUNIT, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS )
IF ( IOS /= 0 ) CALL IOERROR( IOS, IUNIT, 'rdsoil:4' )
! Read data -- save (I,J) pairs into INDEXSOIL array
DO M = 1, NLAND
READ( IUNIT,*, IOSTAT=IOS )
& ( INDEXSOIL(I,M), I=1,2 ), SOILFERT(M)
IF ( IOS /= 0 ) CALL IOERROR( IOS, IUNIT, 'rdsoil:5' )
ENDDO
! Close file
CLOSE( IUNIT )
ENDIF
!=================================================================
! Read in monthly soil precipitation data
!=================================================================
! Only read data when we have entered a new month...
IF ( MONSAVE /= MONTH ) THEN
! Save the current month
MONSAVE = MONTH
! M1 is the previous month
IF ( MONTH == 1 ) THEN
M1 = 12
ELSE
M1 = MONTH - 1
END IF
! Define soil precip file name
FILENAME = TRIM( DATA_DIR ) // 'soil_NOx_200203/climatprep' //
& GET_RES_EXT() // '.dat'
! Echo filename
WRITE( 6, 100 ) TRIM( FILENAME )
! Open soil precip file
OPEN( IUNIT, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS )
IF ( IOS /= 0 ) CALL IOERROR( IOS, IUNIT, 'rdsoil:6' )
! Loop over Olson land types
DO M = 1, NLAND
! Read monthly soil precip data for each (I,J) box
READ( IUNIT, *, IOSTAT=IOS ) I, J, ( TMP(K), K=1,12 )
IF ( IOS /= 0 ) CALL IOERROR( IOS, IUNIT, 'rdsoil:7' )
! Error check -- make sure that each (I,J) pair has both
! soil precip data and fertilizer data defined
IF ( INDEXSOIL(1,M) /= I .OR. INDEXSOIL(2,M) /= J ) THEN
WRITE(6,*) 'CORRUPTED TEMPCORR OR CLMATPRECIP DATA'
WRITE(6,*) 'CHECK (I,J)',I,J
CALL GEOS_CHEM_STOP
ELSE
SOILPREP(1,M) = TMP(M1)
SOILPREP(2,M) = TMP(MONTH)
ENDIF
ENDDO
! Close file
CLOSE( IUNIT )
ENDIF
! Return to calling program
END SUBROUTINE RDSOIL

1182
code/readchem.f Normal file
View File

File diff suppressed because it is too large Load Diff

783
code/reader.f Normal file
View File

@ -0,0 +1,783 @@
! $Id: reader.f,v 1.2 2012/03/01 22:00:26 daven Exp $
SUBROUTINE READER( FIRSTCHEM )
!
!******************************************************************************
! Subroutine READER reads on/off switches and other settings for SMVGEAR II.
! (M. Jacobson 1997; bdf, bmy, 4/18/03, 10/16/06)
!
! NOTES:
! (1 ) Now force double-precision values with the "D" exponent. Also use
! consistent physical constant values w/ GEOS-CHEM. Now use GEOS-CHEM
! unit IU_FILE number to read the "mglob.dat" file. Now references
! GEOS_CHEM_STOP from "error_mod.f". Now force double-precision with
! the "D" exponent. Set KGLC = IU_CHEMDAT = 7 from "file_mod.f"
! (bmy, 4/18/03)
! (2 ) Remove obsolete variables AERSURF, MLOPJ, REARTHC, DENCONS, HALFDAY,
! GRAVC, FOURPI, TWOPI, REARTH, RPRIMB, AVOG1, HALF, THIRD, THRPI2,
! PID180, PID2, SCTWOPI, AMRGAS, TWPISC, REARTH. these aren't used w/in
! "reader.f" anymore. Use F90-style variable declarations. Also
! remove obsolete variables from documentation. (bmy, 7/16/03)
! (3 ) Redefine CHEMINTV [s] to the value in "input.geos" so that we don't
! have a discrepancy with the value in "mglob.dat". SLOW-J is now
! obsolete; remove LSLOWJ #ifdef blocks (bmy, 6/23/05)
! (4 ) Physical constants and some error tolerances are now defined as
! parameters in "comode.h". In this way, their values will be defined
! before the first call to READER for the offline aerosol simulation.
! (bec, bmy, 3/29/06)
! (5 ) Increase max # of products that a reaction can have from 12 to 14.
! This coincides w/ the new globchem.dat. (bmy, 8/9/06)
! (6 ) At the end of this subrouitne, now set NCS=NCSURBAN (=1) instead of
! hardwiring it. (dbm, bmy, 10/16/06)
!******************************************************************************
!
! References to F90 modules
USE ERROR_MOD, ONLY : GEOS_CHEM_STOP
USE FILE_MOD, ONLY : IU_FILE, IU_CHEMDAT, IU_SMV2LOG
USE TIME_MOD, ONLY : GET_TS_CHEM
! adj_group: add for adjoint (dkh, 01/13/12, adj32_013)
USE LOGICAL_ADJ_MOD, ONLY : LADJ
USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "comode.h" ! SMVGEAR II arrays
# include "CMN_GCTM" ! Re, PI
C
C *********************************************************************
C * THIS SUBROUTINE OPENS ALL DATA FILES AND READS DATA FROM m.dat ***
C * FOR DEFINITIONS OF THE PARAMETERS READ IN HERE, SEE define.dat ***
C *********************************************************************
C
C RRRRRRR EEEEEEE A DDDDDDD EEEEEEE RRRRRRR
C R R E A A D D E R R
C RRRRRRR EEEEEEE A A D D EEEEEEE RRRRRRR
C R R E AAAAAAA D D E R R
C R R EEEEEEE A A DDDDDDD EEEEEEE R R
C
C
C *********************************************************************
C * NAMELIST DATA FOR DATA FILE m.dat *
C *********************************************************************
C
C *********************************************************************
C MAIN SWITCHES
C *********************************************************************
C IFSOLVE = 1: SOLVE CHEMICAL EQUATIONS WITH SMVGEAR
C 0: DO NOT SOLVE ANY CHEMICAL EQUATIONS (mglob.dat)
C IFPRAT = 1: USE DEFAULT PHOTORATES FROM photrate.dat;
C = 0: USE DEFAULT PHOTORATES FROM globchem.dat
C INCVMIX = 1: INTERPOLATE MIXING RATIO PROFILES FROM DATA IN MIXRATIO.DAT
C ITESTGEAR = 1: CREATE EXACT SOLUTION TO COMPARE OTHER GEAR SOLUTIONS AGAINST
C = 2: COMPARE CURRENT SOLUTION TO EXACT SOLUTION
C
C IFURBAN IFTROP IFSTRAT TYPE OF CHEMISTRY SOLVED
C (U=URBAN, T=TROPOSPHERIC, S=STRATOSPHERIC)
C ----------------------------------------------------------------------
C 0 0 0 DO NOT SOLVE CHEMISTRY
C 1 0 0 SOLVE U EVERYWHERE
C 0 1 0 SOLVE T EVERYWHERE
C 0 0 1 SOLVE S EVERYWHERE
C 1 1 1 SOLVE U BELOW PLOURB, T BETWEEN PLOURB,
C PLOTROP, AND S ABOVE PLOTROP
C 0 2 2 SOLVE T/S CHEMISTRY EVERYWHERE
C 2 2 2 SOLVE U/T/S CHEMISTRY EVERYWHERE
C
LOGICAL, INTENT(IN) :: FIRSTCHEM
INTEGER :: K, M2, M1, MLOOP, KLOOP
INTEGER :: JLOOP, IAVBLOK, IAVGSIZE, IREMAIN, JADD
INTEGER :: IFCHEM, I, NALLREAC, NMPROD, I1
INTEGER :: J, NK
REAL*8 :: ERRMAXU, YLOWU, YHIU, HMAXDAYU
REAL*8 :: ERRMAXR, YLOWR, YHIR, HMAXDAYR
REAL*8 :: ERRMAXS, YLOWS, YHIS, HMAXDAYS
REAL*8 :: ABHI, ABLO
NAMELIST /CTLFLG/ IFSOLVE, ITESTGEAR,
1 IFURBAN, IFTROP, IFSTRAT
C
C *********************************************************************
C DIMENSIONS
C *********************************************************************
C NLAT = # SOUTH-NORTH GRID CELLS
C NLONG = # WEST-EAST GRID CELLS
C NVERT = # VERTICAL LAYERS
C KULOOP = MAXIMUM ACTUAL # OF GRID CELLS IN A GRID BLOCK
C LYOUT = SPECIFIC SOUTH-NORTH CELL FOR PRINTING
C LXOUT = SPECIFIC WEST-EAST CELL FOR PRINTING
C LZOUT = SPECIFIC VERTICAL LAYER FOR PRINTING
C
NAMELIST /CTLDIM/ KULOOP,
1 LYOUT, LXOUT, LZOUT
C
C *********************************************************************
C SWITCHES FOR TIME, TIME-STEPS, AND OUTPUT
C *********************************************************************
C CHEMINTV = TIME STEP FOR GAS AND RADIATIVE PROCESS CALCULATIONS
C
NAMELIST /CTLTIM/ CHEMINTV
C
C *********************************************************************
C SWITCHES FOR OUTPUT
C *********************************************************************
C IPRATES = 1: PRINT CHEMICAL RATE COEFFICIENT DATA IN UPDATE.F
C IPREADER = 1: PRINT INPUT DATA READ IN READER.F
C IOREAC = 1: PRINT LIST OF REACTIONS IN READCHEM.F
C APGASA..H = GASES FOR WHICH OUTPUT ARE PRINTED. OVERRIDES IPRMANY
C
NAMELIST /CTLPRT/ IPRATES, IPREADER,
1 IOSPEC, IOREAC,
3 APGASA, APGASB, APGASC,
4 APGASD, APGASE, APGASF,
5 APGASG, APGASH
C
C *********************************************************************
C SWITCHES FOR CHEMISTRY
C *********************************************************************
C IFREORD = 1: REORDER GRID CELLS BY STIFFNESS DURING CHEMISTRY
C FRACDEC = FRACTION THE TIME STEP IS DECREASED IF CONVERGENCE FAILS
C PLOTROP = PRESSURE (MB) ABOVE WHICH STRAT CHEM IS SOLVED
C PLOURB = PRESSURE (MB) BELOW WHICH URBAN CHEM IS SOLVED
C ERRMAXU = RELATIVE ERROR TOLERANCE (FRACTION) FOR URBAN CHEMISTRY
C ERRMAXR = RELATIVE ERROR TOLERANCE (FRACTION) FOR TROPOSPHERIC CHEMISTRY
C ERRMAXS = RELATIVE ERROR TOLERANCE (FRACTION) FOR STRATOSPHERIC CHEMISTRY
C YLOWU,YHIU = LOW /HIGH ABS. ERROR TOLERANCES (MOLEC. CM-3) FOR URBAN CHEM
C YLOWR,YHIR = LOW /HIGH ABS. ERROR TOLERANCES (MOLEC. CM-3) FOR TROP. CHEM
C YLOWS,YHIS = LOW /HIGH ABS. ERROR TOLERANCES (MOLEC. CM-3) FOR STRAT. CHEM
C HMAXDAYU = MAXIMUM TIME STEP FOR DAYTIME URBAN CHEMISTRY (S)
C HMAXDAYR = MAXIMUM TIME STEP FOR DAYTIME TROP. CHEMISTRY (S)
C HMAXDAYS = MAXIMUM TIME STEP FOR DAYTIME STRAT. CHEMISTRY (S)
C HMAXNIT = MAXIMUM TIME STEP FOR NIGHTTIME CHEMISTRY EVERYWHERE
C
NAMELIST /CLGEAR/ IFREORD, FRACDEC,
2 PLOURB, PLOTROP,
3 ERRMAXU, YLOWU, YHIU, HMAXDAYU,
4 ERRMAXR, YLOWR, YHIR, HMAXDAYR,
5 ERRMAXS, YLOWS, YHIS, HMAXDAYS,
8 HMAXNIT
C
C *********************************************************************
C *********************** OPEN CONTROL INPUT FILE *********************
C *********************************************************************
C
! Echo info to stdout
WRITE( 6, '(a)' ) ' - READER: Reading mglob.dat'
! Use GEOS-CHEM file unit to prevent conflicts (bmy, 4/7/03)
OPEN( IU_FILE, FILE = 'mglob.dat' )
READ( IU_FILE, 100 ) HEADING
READ( IU_FILE, 100 ) COMMENT
READ( IU_FILE, CTLFLG )
READ( IU_FILE, CTLDIM )
READ( IU_FILE, CTLTIM )
READ( IU_FILE, CTLPRT )
READ( IU_FILE, CLGEAR )
CLOSE( IU_FILE )
! NOTE: Redefine CHEMINTV [s] to the value in "input.geos" so
! that we don't have a discrepancy with the value in "mglob.dat"
! (bmy, 5/10/05)
CHEMINTV = GET_TS_CHEM() * 60d0
C
C *********************************************************************
C * DEFINE SOME GRID PARAMETERS *
C *********************************************************************
C NLOOP = NUMBER OF GRID-CELLS IN A VERTICAL LAYER
C NTLOOP = NUMBER OF GRID-CELLS IN THE ENTIRE GRID-DOMAIN
C NLAYER = NVERT + 1
C LX,Y,ZOUT = IDENTIFY GRID POINT WHERE OUTPUT IS PRINTED
C INCVMIX = 1: INITIALIZE MIXING RATIOS FROM mixratio.dat
C IFPRAT = 1: USE DEFAULT PHOTORATES FROM photrate.dat
C ICOORD = 1: RECTANGULAR; 2: SPHERICAL; 3: GLOBAL SPHERICAL
C IFBOX = 1: SETS UP BOX MODEL TO SOLVE URBAN/TROP/STRAT CHEM TOGETHER
C USING DEFAULT PHOTORATES
C ITESTGEAR = 1: SETS UP BOX MODEL TO COMPARE URBAN/TROP/STRAT
C CHEMISTRY TO EXACT SOLUTION
C = 2: SETS UP BOX MODEL TO CREATE URBAN/TROP/STRAT
C CHEMISTRY EXACT SOLUTION
C
IF (ITESTGEAR.GT.0) THEN
NLAT = 1
NLONG = 1
NVERT = 1
ICOORD = 1
LXOUT = 1
LYOUT = 1
LZOUT = 1
ENDIF
C
! nlat and nlong are defined in chemdr.f (bdf, 4/1/03)
!NLOOP = NLAT * NLONG
!NTLOOP = NLOOP * NVERT
! needed in reader.f for kuloop (bdf, 4/1/03)
NTLOOP = IIPAR*JJPAR*NVERT
C
NLAYER = LLTROP
LXOUT = MIN0(LXOUT,NLONG)
LYOUT = MIN0(LYOUT,NLAT)
LZOUT = MIN0(LZOUT,NVERT)
C
C *********************************************************************
C OPEN MORE FILES
C *********************************************************************
C
IOUT = 6
KGLC = IU_CHEMDAT
C
! Open chemistry mechanism file
OPEN( KGLC, FILE ='globchem.dat' )
! Open "smv2.log" for echoback output as unit #93
IO93 = IU_SMV2LOG
OPEN( IO93, FILE='smv2.log', STATUS='UNKNOWN' )
C
C *********************************************************************
C * PRINT INFORMATION FROM m.dat *
C *********************************************************************
C
IF (IPREADER.EQ. 1 .AND. FIRSTCHEM) THEN
WRITE( IO93, '(a)' ) REPEAT( '=', 79 )
WRITE( IO93, '(a,/)' ) 'SMV2.LOG -- SMVGEAR II information'
WRITE( IO93, '(a)' ) 'Switches in mglob.dat!'
WRITE( IO93, '(a)' ) REPEAT( '=', 79 )
WRITE( IO93, * ) 'IFSOLVE = ', IFSOLVE
WRITE( IO93, * ) 'ITESTGEAR = ', ITESTGEAR
WRITE( IO93, * ) 'IFURBAN = ', IFURBAN
WRITE( IO93, * ) 'IFTROP = ', IFTROP
WRITE( IO93, * ) 'IFSTRAT = ', IFSTRAT
WRITE( IO93, * ) 'KULOOP = ', KULOOP
WRITE( IO93, * ) 'LYOUT = ', LYOUT
WRITE( IO93, * ) 'LXOUT = ', LXOUT
WRITE( IO93, * ) 'LZOUT = ', LZOUT
WRITE( IO93, * ) 'CHEMINTV = ', CHEMINTV
WRITE( IO93, * ) 'IPRATES = ', IPRATES
WRITE( IO93, * ) 'IPREADER = ', IPREADER
WRITE( IO93, * ) 'IOSPEC = ', IOSPEC
WRITE( IO93, * ) 'IOREAC = ', IOREAC
WRITE( IO93, * ) 'APGASA = ', APGASA
WRITE( IO93, * ) 'APGASB = ', APGASB
WRITE( IO93, * ) 'APGASC = ', APGASC
WRITE( IO93, * ) 'APGASD = ', APGASD
WRITE( IO93, * ) 'APGASE = ', APGASE
WRITE( IO93, * ) 'APGASF = ', APGASF
WRITE( IO93, * ) 'APGASG = ', APGASG
WRITE( IO93, * ) 'IFREORD = ', IFREORD
WRITE( IO93, * ) 'FRACDEC = ', FRACDEC
WRITE( IO93, * ) 'PLOURB = ', PLOURB
WRITE( IO93, * ) 'PLOTROP = ', PLOTROP
WRITE( IO93, * ) 'ERRMAXU = ', ERRMAXU
WRITE( IO93, * ) 'YLOWU = ', YLOWU
WRITE( IO93, * ) 'YHIU = ', YHIU
WRITE( IO93, * ) 'HMAXDAYU = ', HMAXDAYU
WRITE( IO93, * ) 'ERRMAXR = ', ERRMAXR
WRITE( IO93, * ) 'YLOWR = ', YLOWR
WRITE( IO93, * ) 'YHIR = ', YHIR
WRITE( IO93, * ) 'HMAXDAYR = ', HMAXDAYR
WRITE( IO93, * ) 'ERRMAXS = ', ERRMAXS
WRITE( IO93, * ) 'YLOWS = ', YLOWS
WRITE( IO93, * ) 'YHIS = ', YHIS
WRITE( IO93, * ) 'HMAXDAYS = ', HMAXDAYS
WRITE( IO93, * ) 'HMAXNIT = ', HMAXNIT
WRITE( IO93, '(/,a)' ) 'Using U.C.I. Fast-J photolysis'
WRITE( 6, '(a)' ) 'Using U.C.I. Fast-J photolysis'
! Write spacer line to "smv2.log
WRITE( IO93, '(a)' )
END IF
C
C *********************************************************************
C ******* THE VALUES OF BASIC PARAMETERS *******
C *********************************************************************
C BOLTG = BOLTZMANN"S CONSTANT, 1.381E-16 ERG DEG K**-1 = RGAS / AVG
C = (1 J = 10**7 ERG = 1 N-M = 1 KG M2 S-2)
C RSTARG = UNIVERSAL GAS CONSTANT = 8.3145E+07 G CM2 S-2 MOLE-1 K-1
C AVG = AVOGADRO"S NUMBER,MOL**-1
C WTAIR = MOLECULAR WEIGHT OF AIR;
C RGAS = GAS CONSTANT (ERG DEG K-1 MOL-1)
C 1 ERG = 1 DYNE-CM = 10**-7 J
C 1 ATM = 1.013 BAR = 10**5 PA. 1PA = 1 N M-2 = 10 DYNES CM-2.
C SCDAY = SECONDS PER DAY
C
C
NMASBAL = 9
NAMEMB( 1) = 'SULFUR ATOMS'
NAMEMB( 2) = 'NITROGEN NO3'
NAMEMB( 3) = 'NITROGEN NH4'
NAMEMB( 4) = 'CARBON ATOMS'
NAMEMB( 5) = 'CHLORINE ATOMS'
NAMEMB( 6) = 'BROMINE ATOMS'
NAMEMB( 7) = 'FLOURINE ATOMS'
NAMEMB( 8) = 'HYDROGEN ATOMS'
NAMEMB( 9) = 'OXYGEN ATOMS'
C
C *********************************************************************
C
IF (NLAT.GT.ILAT.OR.NLONG.GT.ILONG.OR.NVERT.GT.IVERT) THEN
WRITE(6,*)'READER: NLAT, NLONG, OR NVERT TOO BIG'
CALL GEOS_CHEM_STOP
END IF
C
C *********************************************************************
C * SETUP LOOP-LOCATING ARRAYS *
C *********************************************************************
C
C VALUE OF JLOOP CORRESPONDING TO EACH GRID-CELL FOR GRID
C OF NLAT = 3, NLONG = 5, NVERT = 2.
C
C LAYER 1 (TOP) LAYER NVERT = 2 (BOTTOM)
C M1 M1
C 3 | 11 12 13 14 15 3 | 26 27 28 29 30
C 2 | 6 7 8 9 10 2 | 21 22 23 24 25
C 1 | 1 2 3 4 5 1 | 16 17 18 19 20
C ------------------- -------------------
C 1 2 3 4 5 M2 1 2 3 4 5 M2
C
DO 210 M2 = 1, NLONG
DO 210 M1 = 1, NLAT
MLOOP = (M1 - 1) * NLONG + M2
210 MLOP(M1,M2) = MLOOP
C
! adj_group: update to allow aerosol only simulation
! (yhmao, dkh, 01/13/12, adj32_013)
!IF ( LADJ .and. ITS_AN_AEROSOL_SIM() ) THEN
IF ( ITS_AN_AEROSOL_SIM() ) THEN
LLOOP = 0
ELSE
DO 220 K = 1, NLAYER
KLOOP = (K - 1) * NLOOP
DO 220 M2 = 1, NLONG
DO 220 M1 = 1, NLAT
MLOOP = MLOP(M1,M2)
JLOOP = MLOOP + KLOOP
! JLOP set differently in ruralbox (bdf, 4/1/03)
JLOP_SMV(M1,M2,K) = JLOOP
220 CONTINUE
C
LLOOP = JLOP_SMV(LYOUT,LXOUT,LZOUT)
ENDIF
C
C *********************************************************************
C DETERMINE HOW MANY PROCESSES SOLVED FOR IN SMVGEAR
C *********************************************************************
C
C IFURBAN IFTROP IFSTRAT TYPE OF CHEMISTRY SOLVED
C (U=URBAN, T=TROPOSPHERIC, S=STRATOSPHERIC)
C ----------------------------------------------------------------------
C 0 0 0 DO NOT SOLVE CHEMISTRY
C 1 0 0 SOLVE U EVERYWHERE
C 0 1 0 SOLVE T EVERYWHERE
C 0 0 1 SOLVE S EVERYWHERE
C 1 1 1 SOLVE U BELOW PLOURB, T BETWEEN PLOURB,
C PLOTROP, AND S ABOVE PLOTROP
C 0 2 2 SOLVE T/S CHEMISTRY EVERYWHERE
C 2 2 2 SOLVE U/T/S CHEMISTRY EVERYWHERE
C
C IGLOBCHEM = -2 --> SOLVE ALL GAS CHEMISTRY WITH COMBINATION OF U/R/S SETS
C = -1 --> SOLVE ALL GAS CHEMISTRY WITH COMBINATION OF R/S SETS
C = 0 --> SOLVE ALL GAS CHEMISTRY WITH EITHER U, R, OR S SETS
C = 1 --> SOLVE EACH REGION SEPARATELY WITH U, R, OR S SET
C
IF (IFURBAN.EQ.2.AND.IFTROP.EQ.2.AND.IFSTRAT.EQ.2) THEN
IGLOBCHEM = -2
NCSALL = 1
NCSTRST = 0
NCSURBAN = 0
NCSTROP = 0
NCSSTRAT = 0
NCSGAS = 1
NTLOOPNCS(NCSGAS) = NTLOOP
ELSEIF (IFURBAN.EQ.0.AND.IFTROP.EQ.2.AND.IFSTRAT.EQ.2) THEN
IGLOBCHEM = -1
NCSALL = 0
NCSTRST = 1
NCSURBAN = 0
NCSTROP = 0
NCSSTRAT = 0
NCSGAS = 1
NTLOOPNCS(NCSGAS) = NTLOOP
ELSEIF (IFURBAN.EQ.1.AND.IFTROP.EQ.1.AND.IFSTRAT.EQ.1) THEN
IGLOBCHEM = 1
NCSALL = 0
NCSTRST = 0
NCSURBAN = 1
NCSTROP = 2
NCSSTRAT = 3
NCSGAS = 3
ELSE
IGLOBCHEM = 0
NCSALL = 0
NCSTRST = 0
NCSURBAN = 0
NCSTROP = 0
NCSSTRAT = 0
NCSGAS = 1
IF (IFURBAN.EQ.1.AND.IFTROP.EQ.0.AND.IFSTRAT.EQ.0) THEN
NTLOOPNCS(NCSGAS) = NTLOOP
NCSURBAN = 1
ELSEIF (IFURBAN.EQ.0.AND.IFTROP.EQ.1.AND.IFSTRAT.EQ.0) THEN
NTLOOPNCS(NCSGAS) = NTLOOP
NCSTROP = 1
ELSEIF (IFURBAN.EQ.0.AND.IFTROP.EQ.0.AND.IFSTRAT.EQ.1) THEN
NTLOOPNCS(NCSGAS) = NTLOOP
NCSSTRAT = 1
ELSEIF (IFURBAN.EQ.0.AND.IFTROP.EQ.0.AND.IFSTRAT.EQ.0) THEN
IFCHEM = 0
IFSOLVE = 0
ELSE
WRITE(6,265)
CALL GEOS_CHEM_STOP
ENDIF
ENDIF
C
265 FORMAT('READER: NEED IFURBAN, IFSTRAT, IFTROP ALL = 1 OR JUST ',
1 'ONE = 1')
C
C ITESTGEAR = 1: TEST SMVGEAR TO ACCURATE SOLUTION FOUND IN compare.dat
C ITESTGEAR = 2: GENERATE SMVGEAR ACCURATE SOLUTION AND WRITE TO compare.dat
C
IF (ITESTGEAR.EQ.2) THEN
ERRMAXU = 1.00d-09
ERRMAXR = 1.00d-09
ERRMAXS = 1.00d-09
C
YLOWU = 1.00d-10
YLOWR = 1.00d-10
YLOWS = 1.00d-10
C
YHIU = 1.00d-10
YHIR = 1.00d-10
YHIS = 1.00d-10
ENDIF
C
DO 269 NCS = 1, ICS
ABTOL(1,NCS) = 0.d0
ABTOL(6,NCS) = 0.d0
269 CONTINUE
C
C URBAN / REGIONAL / STRATOSPHERIC CHEMISTRY TOGETHER
C
IF (NCSALL.GT.0) THEN
NCS = NCSALL
NCSP = NCS + ICS
CHEMTYP( NCS) = 'URB/REG/STR'
ERRMAX( NCS) = ERRMAXU
ABTOL(1, NCS) = YHIU
ABTOL(6, NCS) = YLOWU
TIMEINTV( NCS) = CHEMINTV
ABST2( NCS) = 1. / (CHEMINTV * CHEMINTV)
HMAXUSE( NCS) = HMAXDAYU
HMAXUSE( NCSP) = HMAXNIT
ENDIF
C
C REGIONAL / STRATOSPHERIC CHEMISTRY TOGETHER
C
IF (NCSTRST.GT.0) THEN
NCS = NCSTRST
NCSP = NCS + ICS
CHEMTYP( NCS) = 'REG/STR'
ERRMAX( NCS) = ERRMAXR
ABTOL(1, NCS) = YHIR
ABTOL(6, NCS) = YLOWR
TIMEINTV( NCS) = CHEMINTV
ABST2( NCS) = 1. / (CHEMINTV * CHEMINTV)
HMAXUSE( NCS) = HMAXDAYR
HMAXUSE( NCSP) = HMAXNIT
ENDIF
C
C URBAN CHEMISTRY
C
IF (NCSURBAN.GT.0) THEN
NCS = NCSURBAN
NCSP = NCS + ICS
CHEMTYP( NCS) = 'URBAN'
ERRMAX( NCS) = ERRMAXU
ABTOL(1, NCS) = YHIU
ABTOL(6, NCS) = YLOWU
TIMEINTV(NCS) = CHEMINTV
ABST2( NCS) = 1. / (CHEMINTV * CHEMINTV)
HMAXUSE( NCS) = HMAXDAYU
HMAXUSE(NCSP) = HMAXNIT
ENDIF
C
C TROPOSPHERIC CHEMISTRY
C
IF (NCSTROP.GT.0) THEN
NCS = NCSTROP
NCSP = NCS + ICS
CHEMTYP( NCS) = 'TROPOSPHERIC'
ERRMAX( NCS) = ERRMAXR
ABTOL(1, NCS) = YHIR
ABTOL(6, NCS) = YLOWR
TIMEINTV(NCS) = CHEMINTV
ABST2( NCS) = 1.d0 / (CHEMINTV * CHEMINTV)
HMAXUSE( NCS) = HMAXDAYR
HMAXUSE(NCSP) = HMAXNIT
ENDIF
C
C STRATOSPHERIC CHEMISTRY
C
IF (NCSSTRAT.GT.0) THEN
NCS = NCSSTRAT
NCSP = NCS + ICS
CHEMTYP( NCS) = 'STRATOSPHERIC'
ERRMAX( NCS) = ERRMAXS
ABTOL(1, NCS) = YHIS
ABTOL(6, NCS) = YLOWS
TIMEINTV(NCS) = CHEMINTV
ABST2( NCS) = 1.d0 / (CHEMINTV * CHEMINTV)
HMAXUSE( NCS) = HMAXDAYS
HMAXUSE(NCSP) = HMAXNIT
ENDIF
C
C CALCULATE ALL POSSIBLE REMAINING ABSOLUTE ERROR TOLERANCES
C
DO 272 NCS = 1, NCSGAS
ABHI = LOG10(ABTOL(1,NCS))
ABLO = LOG10(ABTOL(6,NCS))
C
IF (ABHI.LT.ABLO) THEN
WRITE(6,*)'READER: ABHI < ABLO - INCREASE UPPER BOUND OF',
1 'ABSOLUTE ERROR TOLERANCE FOR NCS = ',NCS,
2 ABTOL(1,NCS),ABTOL(6,NCS)
CALL GEOS_CHEM_STOP
ENDIF
C
DO 270 I = 2, 5
ABTOL(I,NCS) = 10.d0**(ABLO + (ABHI - ABLO) *FLOAT(6-I) / 5.d0)
270 CONTINUE
272 CONTINUE
C
C *********************************************************************
C
NMREAC = 3
NALLREAC = 4
NMPROD = 14
NPRODLO = NALLREAC + 1
NPRODHI = NALLREAC + NMPROD
IFDID = 0
IFNEVER = 0
IFNONE = 0
NSFTOT = 0
NPDTOT = 0
NSTTOT = 0
IFAILTOT = 0
LFAILTOT = 0
NFAILTOT = 0
NOCC = 0
SUMAVGE = 0.d0
SUMAVHI = 0.d0
SUMRMSE = 0.d0
SUMRMHI = 0.d0
TOTSTEP = 0.d0
TOTIT = 0.d0
TELAPS = 0.d0
RMSERR = 0.d0
C
MB1 = 1
MB2 = 2
DO 660 I = 1, IMASBAL
MBCOMP(I,MB1) = 0.d0
MBCOMP(I,MB2) = 0.d0
660 CONTINUE
C
DO 705 NCS = 1, ICS
NAMENCS(0,NCS) = ' '
NMOTH( NCS) = 0
NTSPEC( NCS) = 0
JPHOTRAT( NCS) = 0
ISGAINR( NCS) = 0
ISPORL( NCS) = 0
NOGAINE( NCS) = 0
NOUSE( NCS) = 0
NSPEC( NCS) = 0
NTRATES( NCS) = 0
ISGAINE( NCS) = 0
NSPCSOLV( NCS) = 0
ISCHANG( NCS) = 0
NRATES( NCS) = 0
NM3BOD( NCS) = 0
ITWOR( NCS) = 0
ITHRR( NCS) = 0
INOREP( NCS) = 0
NRATCUR( NCS) = 0
NSURFACE( NCS) = 0
NPRESM( NCS) = 0
NMAIR( NCS) = 0
NMO2( NCS) = 0
NMN2( NCS) = 0
NNEQ( NCS) = 0
NARR( NCS) = 0
NABR( NCS) = 0
NACR( NCS) = 0
NABC( NCS) = 0
NKSPECW( NCS) = 0
NKSPECX( NCS) = 0
NKSPECY( NCS) = 0
NKSPECZ( NCS) = 0
705 CONTINUE
! Zero out entire nkspecv array (bdf, 4/1/03)
NKSPECV = 0d0
C
DO 710 NCS = 1, ICP
NOLOSP( NCS) = 0
NGNFRAC( NCS) = 0
NOLOSRAT( NCS) = 0
IARRAY( NCS) = 0
NALLRAT( NCS) = 0
KZTLO( NCS) = 0
KZTHI( NCS) = 0
IONER( NCS) = 0
NPLLO( NCS) = 0
NPLHI( NCS) = 0
NFRLO( NCS) = 0
NFRHI( NCS) = 0
NPDLO( NCS) = 0
NPDHI( NCS) = 0
710 CONTINUE
C
DO 715 NCS = 1, ICS
DO 714 I = 1, MAXGL
FRACP( I,NCS) = 0
IGNFRAC( I,NCS) = 0
NKGNFRAC(I,NCS) = 0
714 CONTINUE
715 CONTINUE
C
DO 720 NCS = 1, ICS
DO 719 I = 1, MAXGL2
NREACOTH(I,NCS) = 0
LGASBINO(I,NCS) = 0
719 CONTINUE
720 CONTINUE
C
DO 725 NCS = 1, ICS
DO 724 I = 1, MAXGL3
NKNLOSP( I,NCS) = 0
LOSINACP(I,NCS) = 0
NREACAIR(I,NCS) = 0
NREAC3B( I,NCS) = 0
NREACEQ( I,NCS) = 0
NREQOTH( I,NCS) = 0
NREACN2( I,NCS) = 0
NREACO2( I,NCS) = 0
NREACPM( I,NCS) = 0
LGAS3BOD(I,NCS) = 0
724 CONTINUE
725 CONTINUE
C
DO 735 NCS = 1, ICS
DO 734 I = 1, MXGSAER
NAMENCS( I,NCS) = ' '
FRACGAIN(I,NCS) = 0.d0
QBKCHEM( I,NCS) = 0.d0
NUMLOST( I,NCS) = 0
NUMGFRT( I,NCS) = 0
NUMGAINT(I,NCS) = 0
NGAINE( I,NCS) = 0
IGAINR( I,NCS) = 0
IPORL( I,NCS) = 0
IGAINE( I,NCS) = 0
ISOLVSPC(I,NCS) = 0
INEWOLD( I,NCS) = 0
MAPPL( I,NCS) = 0
734 CONTINUE
735 CONTINUE
C
DO 740 NCS = 1, ICP
DO 739 I = 1, MXGSAER
NUMLOSS( I,NCS) = 0
NUMGAIN( I,NCS) = 0
NUMPORL( I,NCS) = 0
739 CONTINUE
740 CONTINUE
C
DO 745 NCS = 1, ICS
DO 744 I = 1, NMTRATE
I1 = NMTRATE + I
ARR( I,NCS) = 0.d0
BRR( I,NCS) = 0.d0
FCV( I,NCS) = 0.d0
FCTEMP1( I,NCS) = 0.d0
FCTEMP2( I,NCS) = 0.d0
NKARR( I,NCS) = 0
NKABR( I,NCS) = 0
NKACR( I,NCS) = 0
NKABC( I,NCS) = 0
IRORD( I,NCS) = 0
IAPROD( I,NCS) = 0
NOLOSRN( I,NCS) = 0
NRUSE( I,NCS) = 0
NRREP( I,NCS) = 0
NPRODUC( I,NCS) = 0
NCEQUAT( I,NCS) = 0
NOLDFNEW(I,NCS) = 0
NEWFOLD( I,NCS) = 0
NEWFOLD(I1,NCS) = 0
NKONER( I,NCS) = 0
NKTWOR( I,NCS) = 0
NKTHRR( I,NCS) = 0
KCRR( I,NCS) = 0
JPHOTNK( I,NCS) = 0
744 CONTINUE
745 CONTINUE
C
DO 755 NCS = 1, ICS
DO 754 J = 1, IPHOT
NKPHOTRAT(J,NCS) = 0
NPPHOTRAT(J,NCS) = 0
NKNPHOTRT(J,NCS) = 0
754 CONTINUE
755 CONTINUE
C
DO 765 NCS = 1, ICP
DO 764 I = 1, MXGSAER
JARRDIAG(I,NCS) = 0
JLOZ1( I,NCS) = 0
JHIZ1( I,NCS) = 0
IJTLO( I,NCS) = 0
IJTHI( I,NCS) = 0
IMZTOT( I,NCS) = 0
764 CONTINUE
765 CONTINUE
DO 770 NCS = 1, ICS
DO 769 NK = 1, NMTRATE
DO 768 I = 1, NMRPROD
IRM( I,NK,NCS) = 0
IRM2( I,NK,NCS) = 0
FKOEF(I,NK,NCS) = 0.d0
FK2( I,NK,NCS) = 0.d0
768 CONTINUE
769 CONTINUE
770 CONTINUE
C
DO 775 NCS = 1, ICS
DO 774 J = 1, MAXGL
DO 773 I = 1, MXGSAER
JPORL(I,J,NCS) = 0
773 CONTINUE
774 CONTINUE
775 CONTINUE
! Set NCS=NCSURBAN here since we have defined our tropospheric
! chemistry mechanism in the urban slot of SMVGEAR II
NCS = NCSURBAN
C
C *********************************************************************
C ********************** END OF SUBROUTINE READER *********************
C *********************************************************************
C
100 FORMAT(A72)
110 FORMAT(32X,'SMVGEAR II')
115 FORMAT(//,35X,'***** MAIN SWITCHES',
1 ' *****',/)
C
RETURN
END SUBROUTINE READER

143
code/readlai.f Normal file
View File

@ -0,0 +1,143 @@
! $Id: readlai.f,v 1.1 2009/06/09 21:51:52 daven Exp $
SUBROUTINE READLAI( MM )
!
!******************************************************************************
! Subroutine READLAI reads the leaf area indices from disk for two months.
! (yhw, gmg, djj, 1994; bmy, 12/20/04)
!
! Arguments as Input:
! ============================================================================
! (1 ) MM (INTEGER) : Current month number (1-12)
!
! NOTES:
! (1 ) Be sure to force double precision with the DBLE function and the "D"
! exponent, wherever necessary (bmy, 10/6/99)
! (2 ) Now reads the LAI files directly from the data directory, so you don't
! have to create symbolic links anymore (bmy, 7/5/01)
! (3 ) Deleted obsolete code (bmy, 9/4/01, 2/27/02)
! (4 ) Replaced IMX with IGLOB and JMX with JGLOB (bmy, 6/25/02)
! (5 ) Now reference IU_FILE from "file_mod.f" (bmy, 7/31/02)
! (6 ) Now define FILENAME and echo FILENAME to stdout. Now use F90 style
! declaration statements. Cleaned up old code. (bmy, 11/13/02)
! (7 ) Now references DATA_DIR from "directory_mod.f" (bmy, 7/20/04)
! (8 ) Now use AVHRR LAI derived leaf-area index data (stored in the
! leaf_area_index_200412 subdir of DATA_DIR) if the logical switch
! LAVHRRLAI=T. Otherwise use the old LAI data. (tmf, bmy, 12/20/04)
!******************************************************************************
!
! References to F90 modules
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE FILE_MOD, ONLY : IU_FILE
USE LOGICAL_MOD, ONLY : LAVHRRLAI
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "CMN_DEP" ! IREG, ILAND, IUSE
# include "CMN_VEL" ! XLAI, XLAI2
! Arguments
INTEGER, INTENT(IN) :: MM
! Local variables
INTEGER :: I, INDEX, J, K, MMM
CHARACTER(LEN=2) :: CMONTH(12) = (/ '01','02','03','04',
& '05','06','07','08',
& '09','10','11','12'/)
CHARACTER(LEN=255) :: FILENAME
!=================================================================
! READLAI begins here!
!=================================================================
! Zero XLAI, XLAI2
DO J = 1, JGLOB
DO I = 1, IGLOB
DO K = 1, IREG(I,J)
XLAI(I,J,K) = 0.D0
XLAI2(I,J,K) = 0.D0
ENDDO
ENDDO
ENDDO
!=================================================================
! Read current month's lai (XLAI) at (I,J) and for landtype K
!=================================================================
! Pick proper filename for the old Yuhang Wang LAI, or
! for AVHRR satellite-derived LAI (tmf, bmy, 12/20/04)
IF ( LAVHRRLAI ) THEN
FILENAME = TRIM( DATA_DIR ) // 'leaf_area_index_200412/lai' //
& CMONTH(MM) // '.global'
ELSE
FILENAME = TRIM( DATA_DIR ) // 'leaf_area_index_200202/lai' //
& CMONTH(MM) // '.global'
ENDIF
! Echo filename
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( ' - READLAI: Reading ', a )
! Open file
OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='OLD' )
! Read until EOF
! (lzh,02/01/2015) for 0.25 nested
#if defined( GRID025x03125 )
10 READ( IU_FILE, '(3i3,20f5.1)', END=20 )
& I, J, INDEX, ( XLAI(I,J,K), K=1,INDEX )
GOTO 10
#else
10 READ( IU_FILE, '(3i3,20f5.1)', END=20 )
& I, J, INDEX, ( XLAI(I,J,K), K=1,INDEX )
GOTO 10
#endif
! Close file
20 CLOSE( IU_FILE )
! Save for next month
MMM = MM
IF(MMM .EQ. 12) MMM = 0
!=================================================================
! Read following month's lai (XLAI2) at (I,J) and for landtype K
!=================================================================
! Pick proper filename for the old Yuhang Wang LAI, or
! for AVHRR satellite-derived LAI (tmf, bmy, 12/20/04)
IF ( LAVHRRLAI ) THEN
FILENAME = TRIM( DATA_DIR ) // 'leaf_area_index_200412/lai' //
& CMONTH(MMM+1) // '.global'
ELSE
FILENAME = TRIM( DATA_DIR ) // 'leaf_area_index_200202/lai' //
& CMONTH(MMM+1) // '.global'
ENDIF
! Echo filename
WRITE( 6, 100 ) TRIM( FILENAME )
! Open file
OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='OLD' )
! Read until EOF
! 30 READ( IU_FILE, '(3i3,20f5.1)', END=40 )
! & I, J, INDEX, ( XLAI2(I,J,K), K=1,INDEX )
! GOTO 30
! (lzh,02/01/2015) for 0.25 nested
#if defined( GRID025x03125 )
30 READ( IU_FILE, '(3i3,20f5.1)', END=40 )
& I, J, INDEX, ( XLAI2(I,J,K), K=1,INDEX )
GOTO 30
#else
30 READ( IU_FILE, '(3i3,20f5.1)', END=40 )
& I, J, INDEX, ( XLAI2(I,J,K), K=1,INDEX )
GOTO 30
#endif
! Close file
40 CLOSE( IU_FILE )
! Return to calling program
END SUBROUTINE READLAI

2435
code/regrid_1x1_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

1203
code/regrid_a2a_mod.F90 Normal file
View File

File diff suppressed because it is too large Load Diff

782
code/retro_mod.f Normal file
View File

@ -0,0 +1,782 @@
!------------------------------------------------------------------------------
! University of Minnesota Atmospheric Chemistry Group
!------------------------------------------------------------------------------
!BOP
!
! !MODULE: retro_mod
!
! !DESCRIPTION: Module RETRO\_MOD reads emissions from the RETRO emissions
! inventory
!\\
!\\
! !INTERFACE:
!
MODULE RETRO_MOD
IMPLICIT NONE
PRIVATE
!
! !PUBLIC DATA MEMBERS:
!
REAL*4, ALLOCATABLE :: RETRO_ALK4(:,:)
REAL*4, ALLOCATABLE :: RETRO_ACET(:,:)
REAL*4, ALLOCATABLE :: RETRO_MEK(:,:)
REAL*4, ALLOCATABLE :: RETRO_ALD2(:,:)
REAL*4, ALLOCATABLE :: RETRO_PRPE(:,:)
REAL*4, ALLOCATABLE :: RETRO_C3H8(:,:)
REAL*4, ALLOCATABLE :: RETRO_C2H6(:,:)
REAL*4, ALLOCATABLE :: RETRO_CH2O(:,:)
REAL*4, ALLOCATABLE :: RETRO_BENZ(:,:)
REAL*4, ALLOCATABLE :: RETRO_TOLU(:,:)
REAL*4, ALLOCATABLE :: RETRO_XYLE(:,:)
REAL*4, ALLOCATABLE :: RETRO_C2H4(:,:)
REAL*4, ALLOCATABLE :: RETRO_C2H2(:,:)
!
! !PUBLIC MEMBER FUNCTIONS:
!
PUBLIC :: CLEANUP_RETRO
PUBLIC :: EMISS_RETRO
PUBLIC :: GET_RETRO_ANTHRO
!
! !PRIVATE MEMBER FUNCTIONS:
!
PRIVATE :: INIT_RETRO
PRIVATE :: READ_RETRO
PRIVATE :: TOTAL_ANTHRO_Tg
!
! !REVISION HISTORY:
! 08 Mar 2011 - W. Reinhart - Initial version
! 18 Aug 2011 - D. Millet - Partition ketones into 25% MEK and 75% ACET
! 18 Aug 2011 - D. Millet - Remove call to GET_ANNUAL_SCALAR
! 22 Aug 2011 - R. Yantosca - Added ProTeX headers
! 01 Mar 2012 - R. Yantosca - Now reference new grid_mod.F90
! 22 Mar 2012 - M. Payer - RETRO C2H6 emissions are too low. Use
! Yaping Xiao's C2H6 emissions instead.
!EOP
!------------------------------------------------------------------------------
!BOC
CONTAINS
!-----------------------------------------------------------------------
#if defined( DEVEL )
SUBROUTINE EMISS_RETRO( EMISSIONS )
#else
SUBROUTINE EMISS_RETRO
#endif
!***********************************************************************
! Subroutine EMISS_RETRO reads all RETRO emissions at the beginning of
! each month. (wfr, 3/8/11)
!***********************************************************************
!
! !USES:
!
USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D
USE BPCH2_MOD, ONLY : GET_RES_EXT
USE FILE_MOD, ONLY : IOERROR
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_ALK4ff
USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_PRPEff
USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_C3H8ff
USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_C2H6ff
USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_VOCff
USE LOGICAL_MOD, ONLY : LFUTURE
USE TIME_MOD, ONLY : EXPAND_DATE
USE TIME_MOD, ONLY : GET_MONTH
# include "CMN_SIZE" ! Size parameters
#if defined( DEVEL )
USE TRACERID_MOD, ONLY : IDTALK4, IDTACET, IDTMEK,
& IDTALD2, IDTPRPE, IDTC3H8, IDTC2H6, IDTCH2O, IDTBENZ,
& IDTTOLU, IDTXYLE, IDTC2H4, IDTC2H2
USE TRACER_MOD, ONLY : N_TRACERS, TRACER_MW_KG
USE GRID_MOD, ONLY : GET_AREA_CM2
USE ERROR_MOD, ONLY : ALLOC_ERR
#endif
!
! !REVISION HISTORY:
! 08 Mar 2011 - W. Reinhart - Initial version
! 22 Aug 2011 - R. Yantosca - Added ProTeX headers
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
LOGICAL, SAVE :: FIRST = .TRUE.
INTEGER :: I, J, THISMONTH, YYYYMMDD
REAL*8 :: ALK4ff, PRPEff, C3H8ff
REAL*8 :: C2H6ff, VOCff
CHARACTER(LEN=255) :: FILENAME
#if defined( DEVEL )
REAL*8, INTENT(INOUT) :: EMISSIONS(IIPAR,JJPAR,N_TRACERS)
REAL*8, ALLOCATABLE :: A(:,:)
INTEGER AS
#endif
!=================================================================
! EMISS_RETRO begins here
!=================================================================
! First-time initialization
IF ( FIRST ) THEN
! Allocate arrays
#if defined( DEVEL )
ALLOCATE( A( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMISS_EPA_NEI:A' )
A = 0d0
#endif
CALL INIT_RETRO
! Reset first-time flag
FIRST = .FALSE.
ENDIF
! Get month
THISMONTH = GET_MONTH()
! Get date for 2000 emissions
YYYYMMDD = 20000000 + ( THISMONTH * 100 ) + 01
! Echo info
WRITE(6, '(a)' ) REPEAT( '=', 79)
WRITE(6, 100 )
100 FORMAT( 'R E T R O E M I S S I O N S',
& ' -- Baseline Year: 2000', / )
!=================================================================
! Read RETRO average annual anthropogenic emissions
!=================================================================
! Anthro file name
FILENAME = TRIM( DATA_DIR ) // 'RETRO_201103/' //
& 'YYYYMM.' // GET_RES_EXT()
! Replace date in filename
CALL EXPAND_DATE( FILENAME, YYYYMMDD, 000000 )
! Read data
CALL READ_RETRO( FILENAME, RETRO_ALK4, RETRO_ACET, RETRO_MEK,
& RETRO_ALD2, RETRO_PRPE, RETRO_C3H8, RETRO_C2H6,
& RETRO_CH2O, RETRO_BENZ, RETRO_TOLU, RETRO_XYLE,
& RETRO_C2H4, RETRO_C2H2 )
DO J = 1, JJPAR
DO I = 1, IIPAR
!-----------------------------------
! Calculate IPCC future emissions
!-----------------------------------
IF ( LFUTURE ) THEN
! Future anthro scale factors
ALK4ff = GET_FUTURE_SCALE_ALK4ff( I, J )
VOCff = GET_FUTURE_SCALE_VOCff( I, J )
PRPEff = GET_FUTURE_SCALE_PRPEff( I, J )
C3H8ff = GET_FUTURE_SCALE_C3H8ff( I, J )
C2H6ff = GET_FUTURE_SCALE_C2H6ff( I, J )
! Apply scale factors
RETRO_ALK4 (I,J) = RETRO_ALK4 (I,J) * ALK4ff
RETRO_ACET (I,J) = RETRO_ACET (I,J) * VOCff
RETRO_MEK (I,J) = RETRO_MEK (I,J) * VOCff
RETRO_ALD2 (I,J) = RETRO_ALD2 (I,J) * VOCff
RETRO_PRPE (I,J) = RETRO_PRPE (I,J) * PRPEff
RETRO_C3H8 (I,J) = RETRO_C3H8 (I,J) * C3H8ff
RETRO_C2H6 (I,J) = RETRO_C2H6 (I,J) * C2H6ff
RETRO_CH2O (I,J) = RETRO_CH2O (I,J) * VOCff
RETRO_BENZ (I,J) = RETRO_BENZ (I,J) * VOCff
RETRO_TOLU (I,J) = RETRO_TOLU (I,J) * VOCff
RETRO_XYLE (I,J) = RETRO_XYLE (I,J) * VOCff
RETRO_C2H4 (I,J) = RETRO_C2H4 (I,J) * VOCff
RETRO_C2H2 (I,J) = RETRO_C2H2 (I,J) * VOCff
ENDIF
ENDDO
ENDDO
! Print totals to log
CALL TOTAL_ANTHRO_TG( THISMONTH )
! Fancy output
WRITE(6, '(a)' ) REPEAT( '=', 79)
#if defined( DEVEL )
DO I=1,IIPAR
DO J=1,JJPAR
A(I,J) = GET_AREA_CM2( I, J, 1 )
ENDDO
ENDDO
IF ( IDTALK4 > 0 ) EMISSIONS(:,:,IDTALK4) = RETRO_ALK4(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTALK4)
IF ( IDTACET > 0 ) EMISSIONS(:,:,IDTACET) = RETRO_ACET(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTACET)
IF ( IDTMEK > 0 ) EMISSIONS(:,:,IDTMEK) = RETRO_MEK(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTMEK)
IF ( IDTALD2 > 0 ) EMISSIONS(:,:,IDTALD2) = RETRO_ALD2(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTALD2)
IF ( IDTPRPE > 0 ) EMISSIONS(:,:,IDTPRPE) = RETRO_PRPE(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTPRPE)
IF ( IDTC3H8 > 0 ) EMISSIONS(:,:,IDTC3H8) = RETRO_C3H8(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTC3H8)
IF ( IDTC2H6 > 0 ) EMISSIONS(:,:,IDTC2H6) = RETRO_C2H6(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTC2H6)
IF ( IDTCH2O > 0 ) EMISSIONS(:,:,IDTCH2O) = RETRO_CH2O(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTCH2O)
IF ( IDTBENZ > 0 ) EMISSIONS(:,:,IDTBENZ) = RETRO_BENZ(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTBENZ)
IF ( IDTTOLU > 0 ) EMISSIONS(:,:,IDTTOLU) = RETRO_TOLU(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTTOLU)
IF ( IDTXYLE > 0 ) EMISSIONS(:,:,IDTXYLE) = RETRO_XYLE(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTXYLE)
IF ( IDTC2H4 > 0 ) EMISSIONS(:,:,IDTC2H4) = RETRO_C2H4(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTC2H4)
IF ( IDTC2H2 > 0 ) EMISSIONS(:,:,IDTC2H2) = RETRO_C2H2(:,:) *
& A * 6.0225d-23 * TRACER_MW_KG(IDTC2H2)
#endif
! Return to calling program
END SUBROUTINE EMISS_RETRO
!EOC
!------------------------------------------------------------------------------
! University of Minnesota Atmospheric Chemistry Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: read_retro
!
! !DESCRIPTION: Subroutine READ\_RETRO reads a BPCH file created from
! RETRO data. The data has units of [atoms C/cm2/s].
!\\
!\\
! !INTERFACE:
!
SUBROUTINE READ_RETRO( FILENAME, ALK4, ACET, MEK, ALD2, PRPE,
& C3H8, C2H6, CH2O, BENZ, TOLU, XYLE,
& C2H4, C2H2 )
!
! !USES:
!
USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ
USE FILE_MOD, ONLY : IU_FILE, IOERROR
USE TRANSFER_MOD, ONLY : TRANSFER_2D
USE SCALE_ANTHRO_MOD, ONLY : GET_ANNUAL_SCALAR
USE TIME_MOD, ONLY : GET_YEAR
# include "CMN_SIZE" ! Size parameters
# include "CMN_O3" ! FSCLYR
!
! !INPUT PARAMETERS:
!
! Name of file to read
CHARACTER(LEN=*), INTENT(IN) :: FILENAME
!
! !INPUT/OUTPUT PARAMETERS:
!
! RETRO emissions for various VOC species [molec/cm2/s]
REAL*4, INTENT(INOUT) :: ALK4(IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: ACET(IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: MEK (IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: ALD2(IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: PRPE(IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: C3H8(IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: CH2O(IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: C2H6(IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: BENZ(IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: TOLU(IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: XYLE(IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: C2H4(IIPAR,JJPAR)
REAL*4, INTENT(INOUT) :: C2H2(IIPAR,JJPAR)
!
! !REVISION HISTORY:
! 08 Mar 2011 - W. Reinhart - Initial Version
! 18 Aug 2011 - D. Millet - Remove call to GET_ANNUAL_SCALAR
! 22 Aug 2011 - R. Yantosca - Added ProTeX headers
! 03 Aug 2012 - R. Yantosca - Move calls to findFreeLUN out of DEVEL block
! 07 Aug 2012 - R. Yantosca - Now print LUN used to open file
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: I, J, L, N, IOS
INTEGER :: NI, NJ, NL
INTEGER :: IFIRST, JFIRST, LFIRST
INTEGER :: NTRACER, NSKIP
INTEGER :: HALFPOLAR, CENTER180
INTEGER :: SCALEYEAR !, BASEYEAR (dbm, 8/18/11)
REAL*4 :: LONRES, LATRES
REAL*4 :: ARRAY(IIPAR,JJPAR,1)
REAL*4 :: SC(IIPAR,JJPAR)
REAL*8 :: ZTAU0, ZTAU1
CHARACTER(LEN=20) :: MODELNAME
CHARACTER(LEN=40) :: CATEGORY
CHARACTER(LEN=40) :: UNIT
CHARACTER(LEN=40) :: RESERVED
!=================================================================
! READ_RETRO begins here
!=================================================================
! Echo info
WRITE( 6, 100 ) TRIM( FILENAME ), IU_FILE
100 FORMAT( 'READ_RETRO: Reading ', a, ' on unit ', i4 )
! Open file
CALL OPEN_BPCH2_FOR_READ( IU_FILE, FILENAME )
! Read the entire file in one pass
DO
! Read 1st data block header
READ( IU_FILE, IOSTAT=IOS )
& MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180
! Check for EOF or errors
IF ( IOS < 0 ) EXIT
IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'read_data:2' )
! Read 2nd data block header line
READ (IU_FILE, IOSTAT=IOS )
& CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED,
& NI, NJ, NL, IFIRST, JFIRST, LFIRST, NSKIP
! Error check
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_data:3' )
! Read data
READ( IU_FILE, IOSTAT=IOS ) ARRAY(1:NI,1:NJ,1:NL)
! Error check
IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_data:4' )
!==============================================================
! Save into tracer arrays
!==============================================================
SELECT CASE ( NTRACER )
CASE( 5 )
CALL TRANSFER_2D( ARRAY(:,:,1), ALK4 )
CASE( 9 )
CALL TRANSFER_2D( ARRAY(:,:,1), ACET )
CASE( 10 )
CALL TRANSFER_2D( ARRAY(:,:,1), MEK )
CASE( 11 )
CALL TRANSFER_2D( ARRAY(:,:,1), ALD2 )
CASE( 18 )
CALL TRANSFER_2D( ARRAY(:,:,1), PRPE )
CASE( 19 )
CALL TRANSFER_2D( ARRAY(:,:,1), C3H8 )
CASE( 20 )
CALL TRANSFER_2D( ARRAY(:,:,1), CH2O )
CASE( 21 )
CALL TRANSFER_2D( ARRAY(:,:,1), C2H6 )
CASE( 59 )
CALL TRANSFER_2D( ARRAY(:,:,1), BENZ )
CASE( 60 )
CALL TRANSFER_2D( ARRAY(:,:,1), TOLU )
CASE( 61 )
CALL TRANSFER_2D( ARRAY(:,:,1), XYLE )
CASE( 65 )
CALL TRANSFER_2D( ARRAY(:,:,1), C2H4 )
CASE( 66 )
CALL TRANSFER_2D( ARRAY(:,:,1), C2H2 )
CASE DEFAULT
! Nothing
END SELECT
END DO
! Close file
CLOSE( IU_FILE )
! Apply annual scalar factor
IF ( FSCALYR < 0 ) THEN
SCALEYEAR = GET_YEAR()
ELSE
SCALEYEAR = FSCALYR
ENDIF
END SUBROUTINE READ_RETRO
!EOC
!------------------------------------------------------------------------------
! University of Minnesota Atmospheric Chemistry Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: TOTAL_ANTHRO_Tg
!
! !DESCRIPTION: Subroutine TOTAL\_ANTHRO\_Tg to print total RETRO
! anthropogenic VOC emissions each month in [Tg C].
!\\
!\\
! !INTERFACE:
!
SUBROUTINE TOTAL_ANTHRO_Tg( THISMONTH )
!
! !USES:
!
USE GRID_MOD, ONLY : GET_AREA_CM2
USE TRACER_MOD, ONLY : TRACER_MW_KG
USE TRACERID_MOD, ONLY : IDTALK4, IDTMEK, IDTPRPE, IDTC3H8
USE TRACERID_MOD, ONLY : IDTCH2O, IDTC2H6, IDTBENZ, IDTTOLU
USE TRACERID_MOD, ONLY : IDTXYLE, IDTC2H4, IDTC2H2
USE TRACERID_MOD, ONLY : IDTACET, IDTALD2
# include "CMN_SIZE" ! Size parameters
!
! !INPUT PARAMETERS:
!
INTEGER, INTENT(IN) :: THISMONTH ! Current month
!
! !REVISION HISTORY:
! 08 Mar 2011 - W. Reinhart - Initial Version
! 22 Aug 2011 - R. Yantosca - Added ProTeX headers
! 01 Mar 2012 - R. Yantosca - Now use GET_AREA_CM2(I,J,L) from grid_mod.F90
! 22 Mar 2012 - M. Payer - Remove print for C2H6 emissions
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: I, J
REAL*8 :: ALK4, MEK, ALD2, PRPE, C3H8, CH2O
REAL*8 :: BENZ, TOLU, XYLE, C2H4, C2H2, C2H6, ACET
REAL*8 :: F_ALK4, F_MEK, F_PRPE, F_C3H8, F_CH2O
REAL*8 :: F_BENZ, F_TOLU, F_XYLE, F_C2H4, F_C2H2
REAL*8 :: F_C2H6, F_ALD2, F_ACET
REAL*8 :: A
CHARACTER(LEN=6) :: UNIT
! Days per month
INTEGER :: D(12) = (/ 31, 28, 31, 30, 31, 30,
& 31, 31, 30, 31, 30, 31 /)
!=================================================================
! TOTAL_ANTHRO_Tg begins here
!=================================================================
! Summing variables for anthro
ALK4 = 0d0
ACET = 0d0
MEK = 0d0
ALD2 = 0d0
PRPE = 0d0
C3H8 = 0d0
CH2O = 0d0
C2H6 = 0d0
BENZ = 0d0
TOLU = 0d0
XYLE = 0d0
C2H4 = 0d0
C2H2 = 0d0
! Molecular weights
F_ALK4 = 0d0
F_ACET = 0d0
F_MEK = 0d0
F_ALD2 = 0d0
F_PRPE = 0d0
F_C3H8 = 0d0
F_CH2O = 0d0
F_C2H6 = 0d0
F_BENZ = 0d0
F_TOLU = 0d0
F_XYLE = 0d0
F_C2H4 = 0d0
F_C2H2 = 0d0
! Prevent array out of bounds error for undefined tracers
IF ( IDTALK4 > 0 ) F_ALK4 = TRACER_MW_KG(IDTALK4)
IF ( IDTACET > 0 ) F_ACET = TRACER_MW_KG(IDTACET)
IF ( IDTMEK > 0 ) F_MEK = TRACER_MW_KG(IDTMEK )
IF ( IDTALD2 > 0 ) F_ALD2 = TRACER_MW_KG(IDTALD2)
IF ( IDTPRPE > 0 ) F_PRPE = TRACER_MW_KG(IDTPRPE)
IF ( IDTC2H6 > 0 ) F_C2H6 = TRACER_MW_KG(IDTC2H6)
IF ( IDTC3H8 > 0 ) F_C3H8 = TRACER_MW_KG(IDTC3H8)
IF ( IDTCH2O > 0 ) F_CH2O = TRACER_MW_KG(IDTCH2O)
IF ( IDTBENZ > 0 ) F_BENZ = TRACER_MW_KG(IDTBENZ)
IF ( IDTTOLU > 0 ) F_TOLU = TRACER_MW_KG(IDTTOLU)
IF ( IDTXYLE > 0 ) F_XYLE = TRACER_MW_KG(IDTXYLE)
IF ( IDTC2H4 > 0 ) F_C2H4 = TRACER_MW_KG(IDTC2H4)
IF ( IDTC2H2 > 0 ) F_C2H2 = TRACER_MW_KG(IDTC2H2)
!=================================================================
! Sum anthropogenic emissions
!=================================================================
! Loop over surface boxes
DO J = 1, JJPAR
DO I = 1, IIPAR
! Surface area [cm2] * seconds in the month / Avogadro's number
! Also multiply by the factor 1d-9 to convert kg to Tg
!--------------------------------------------------------------
!A = GET_AREA_CM2 (I , J, 1) !Original imported statement (yd, 3/5/13)
!--------------------------------------------------------------
A = GET_AREA_CM2( J ) !Modified statemt to suit Function on adjoint code (yd, 3/5/13)
!--------------------------------------------------------------
& * ( D(THISMONTH) * 86400d-9 ) / 6.0225d23
! Anthro emissions
ALK4 = ALK4 + RETRO_ALK4(I,J) * A * F_ALK4
ACET = ACET + RETRO_ACET(I,J) * A * F_ACET
MEK = MEK + RETRO_MEK(I,J) * A * F_MEK
ALD2 = ALD2 + RETRO_ALD2(I,J) * A * F_ALD2
PRPE = PRPE + RETRO_PRPE(I,J) * A * F_PRPE
C3H8 = C3H8 + RETRO_C3H8(I,J) * A * F_C3H8
CH2O = CH2O + RETRO_CH2O(I,J) * A * F_CH2O
C2H6 = C2H6 + RETRO_C2H6(I,J) * A * F_C2H6
BENZ = BENZ + RETRO_BENZ(I,J) * A * F_BENZ
TOLU = TOLU + RETRO_TOLU(I,J) * A * F_TOLU
XYLE = XYLE + RETRO_XYLE(I,J) * A * F_XYLE
C2H4 = C2H4 + RETRO_C2H4(I,J) * A * F_C2H4
C2H2 = C2H2 + RETRO_C2H2(I,J) * A * F_C2H2
ENDDO
ENDDO
!==============================================================
! Print info
!==============================================================
WRITE( 6, '(a)' )
WRITE( 6, 100 ) 'ALK4', THISMONTH, ALK4, ' C'
WRITE( 6, 100 ) 'ACET', THISMONTH, ACET, ' C'
WRITE( 6, 100 ) 'MEK', THISMONTH, MEK, ' C'
WRITE( 6, 100 ) 'ALD2', THISMONTH, ALD2, ' C'
WRITE( 6, 100 ) 'PRPE', THISMONTH, PRPE, ' C'
WRITE( 6, 100 ) 'C3H8', THISMONTH, C3H8, ' C'
WRITE( 6, 100 ) 'CH2O', THISMONTH, CH2O, ' C'
WRITE( 6, 100 ) 'BENZ', THISMONTH, BENZ, ' C'
WRITE( 6, 100 ) 'TOLU', THISMONTH, TOLU, ' C'
WRITE( 6, 100 ) 'XYLE', THISMONTH, XYLE, ' C'
WRITE( 6, 100 ) 'C2H4', THISMONTH, C2H4, ' C'
WRITE( 6, 100 ) 'C2H2', THISMONTH, C2H2, ' C'
100 FORMAT( 'Total anthro ', a4, ' for 2000/',
& i2.2, ': ', f13.6, ' Tg', a2 )
WRITE( 6, '(/,a,/)' ) 'RETRO_MOD: RETRO C2H6 anthro ' //
& 'emissions are too low. Using offline C2H6 ' //
& 'emissions from Yaping Xiao.'
END SUBROUTINE TOTAL_ANTHRO_TG
!EOC
!------------------------------------------------------------------------------
! University of Minnesota Atmospheric Chemistry Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: get_retro_anthro
!
! !DESCRIPTION: Function GET\_RETRO\_ANTHRO returns the monthly average
! anthropogenic VOC emissions at GEOS-Chem grid box (I,J). Data will
! be returned in units of [atoms C/cm2/s].
!\\
!\\
! !INTERFACE:
!
FUNCTION GET_RETRO_ANTHRO( I, J, N ) RESULT( RETRO )
!
! !USES:
!
USE TRACERID_MOD, ONLY : IDTALK4, IDTMEK, IDTPRPE, IDTC3H8
USE TRACERID_MOD, ONLY : IDTCH2O, IDTC2H6, IDTBENZ, IDTTOLU
USE TRACERID_MOD, ONLY : IDTXYLE, IDTC2H4, IDTC2H2
USE TRACERID_MOD, ONLY : IDTACET, IDTALD2
# include "CMN_SIZE" ! Size parameters
!
! !INPUT PARAMETERS:
!
INTEGER, INTENT(IN) :: I ! GEOS-Chem longitude index
INTEGER, INTENT(IN) :: J ! GEOS-Chem latitude index
INTEGER, INTENT(IN) :: N ! GEOS-Chem tracer index
!
! !RETURN VALUE:
!
REAL*8 :: RETRO ! RETRO emissions [mole
!
! !REVISION HISTORY:
! 08 Mar 2011 - W. Reinhart - Initial Version
! 18 Aug 2011 - D. Millet - Partition RETRO ketones into 75% acetone
! and 25% MEK
! 22 Mar 2012 - M. Payer - RETRO C2H6 emissions are too low. Use
! Yaping Xiao's C2H6 emissions instead.
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES
!
!=================================================================
! GET_RETRO_ANTHRO begins here
!=================================================================
IF ( N == IDTALK4 ) THEN
RETRO = RETRO_ALK4(I,J)
ELSE IF ( N == IDTACET ) THEN
RETRO = 0.75d0*RETRO_MEK(I,J) ! RETRO ketones --> 75% ACET
ELSE IF ( N == IDTMEK ) THEN
RETRO = 0.25d0*RETRO_MEK(I,J) ! RETRO ketones --> 25% MEK
ELSE IF ( N == IDTALD2 ) THEN
RETRO = RETRO_ALD2(I,J)
ELSE IF ( N == IDTPRPE ) THEN
RETRO = RETRO_PRPE(I,J)
ELSE IF ( N == IDTC3H8 ) THEN
RETRO = RETRO_C3H8(I,J)
ELSE IF ( N == IDTCH2O ) THEN
RETRO = RETRO_CH2O(I,J)
ELSE IF ( N == IDTC2H6 ) THEN
RETRO = -1d0
ELSE IF ( N == IDTBENZ ) THEN
RETRO = RETRO_BENZ(I,J)
ELSE IF ( N == IDTTOLU ) THEN
RETRO = RETRO_TOLU(I,J)
ELSE IF ( N == IDTXYLE ) THEN
RETRO = RETRO_XYLE(I,J)
ELSE IF ( N == IDTC2H4 ) THEN
RETRO = RETRO_C2H4(I,J)
ELSE IF ( N == IDTC2H2 ) THEN
RETRO = RETRO_C2H2(I,J)
ELSE
RETRO = -1d0
ENDIF
END FUNCTION GET_RETRO_ANTHRO
!EOC
!------------------------------------------------------------------------------
! University of Minnesota Atmospheric Chemistry Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: init_retro
!
! !DESCRIPTION: Subroutine INIT\_RETRO allocates and zeroes all module arrays.
!\\
!\\
! !INTERFACE:
!
SUBROUTINE INIT_RETRO
!
! !USES:
!
USE ERROR_MOD, ONLY : ALLOC_ERR
USE LOGICAL_MOD, ONLY : LRETRO
# include "CMN_SIZE" ! Size parameters
!
! !REVISION HISTORY:
! 08 Mar 2011 - W. Reinhart - Initial Version
! 22 Aug 2011 - R. Yantosca - Added ProTeX headers
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
INTEGER :: AS
!=================================================================
! INIT_RETRO begins here
!=================================================================
! Return if we LRETRO = .FALSE.
IF (.not. LRETRO ) RETURN
ALLOCATE( RETRO_ALK4( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_ALK4' )
RETRO_ALK4 = 0e0
ALLOCATE( RETRO_ACET( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_ACET' )
RETRO_ACET = 0e0
ALLOCATE( RETRO_MEK( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_MEK' )
RETRO_MEK = 0e0
ALLOCATE( RETRO_ALD2( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_ALD2' )
RETRO_ALD2 = 0e0
ALLOCATE( RETRO_PRPE( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_PRPE' )
RETRO_PRPE = 0e0
ALLOCATE( RETRO_C3H8( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_C3H8' )
RETRO_C3H8 = 0e0
ALLOCATE( RETRO_CH2O( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_CH2O' )
RETRO_CH2O = 0e0
ALLOCATE( RETRO_C2H6( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_C2H6' )
RETRO_C2H6 = 0e0
ALLOCATE( RETRO_BENZ( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_BENZ' )
RETRO_BENZ = 0e0
ALLOCATE( RETRO_TOLU( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_TOLU' )
RETRO_TOLU = 0e0
ALLOCATE( RETRO_XYLE( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_XYLE' )
RETRO_XYLE = 0e0
ALLOCATE( RETRO_C2H4( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_C2H4' )
RETRO_C2H4 = 0e0
ALLOCATE( RETRO_C2H2( IIPAR, JJPAR ), STAT=AS )
IF ( AS /= 0 ) CALL ALLOC_ERR( 'RETRO_C2H2' )
RETRO_C2H2 = 0e0
END SUBROUTINE INIT_RETRO
!EOC
!------------------------------------------------------------------------------
! University of Minnesota Atmospheric Chemistry Group
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: cleanup_retro
!
! !DESCRIPTION: Subroutine CLEANUP\_RETRO deallocates all module arrays.
!\\
!\\
! !INTERFACE:
!
SUBROUTINE CLEANUP_RETRO
!
! !REVISION HISTORY:
! 08 Mar 2011 - W. Reinhart - Initial Version
! 22 Aug 2011 - R. Yantosca - Added ProTeX headers
!EOP
!------------------------------------------------------------------------------
!BOC
!=================================================================
! CLEANUP_RETRO begins here
!=================================================================
IF ( ALLOCATED( RETRO_ALK4 ) ) DEALLOCATE( RETRO_ALK4 )
IF ( ALLOCATED( RETRO_ACET ) ) DEALLOCATE( RETRO_ACET )
IF ( ALLOCATED( RETRO_MEK ) ) DEALLOCATE( RETRO_MEK )
IF ( ALLOCATED( RETRO_ALD2 ) ) DEALLOCATE( RETRO_ALD2 )
IF ( ALLOCATED( RETRO_PRPE ) ) DEALLOCATE( RETRO_PRPE )
IF ( ALLOCATED( RETRO_C3H8 ) ) DEALLOCATE( RETRO_C3H8 )
IF ( ALLOCATED( RETRO_CH2O ) ) DEALLOCATE( RETRO_CH2O )
IF ( ALLOCATED( RETRO_C2H6 ) ) DEALLOCATE( RETRO_C2H6 )
IF ( ALLOCATED( RETRO_BENZ ) ) DEALLOCATE( RETRO_BENZ )
IF ( ALLOCATED( RETRO_TOLU ) ) DEALLOCATE( RETRO_TOLU )
IF ( ALLOCATED( RETRO_XYLE ) ) DEALLOCATE( RETRO_XYLE )
IF ( ALLOCATED( RETRO_C2H4 ) ) DEALLOCATE( RETRO_C2H4 )
IF ( ALLOCATED( RETRO_C2H2 ) ) DEALLOCATE( RETRO_C2H2 )
END SUBROUTINE CLEANUP_RETRO
!EOC
END MODULE RETRO_MOD

230
code/ruralbox.f Normal file
View File

@ -0,0 +1,230 @@
! $Id: ruralbox.f,v 1.1 2009/06/09 21:51:52 daven Exp $
SUBROUTINE RURALBOX( AD, T, AVGW, ALBD, SUNCOS,
& LEMBED, IEBD1, IEBD2, JEBD1, JEBD2 )
!
!******************************************************************************
! Subroutine RURALBOX computes which boxes are tropospheric and which
! are stratospheric. SMVGEAR arrays are initialized with quantities from
! tropospheric boxes. (amf, bey, ljm, lwh, gmg, bdf, bmy, 7/16/01, 4/10/06)
!
! Arguments as Input:
! ============================================================================
! (1 ) AD (REAL*8 ) : Array for dry air mass [ kg ]
! (2 ) T (REAL*8 ) : Array for grid box temperatures [ K ]
! (3 ) AVGW (REAL*8 ) : Array for mixing ratio of water [ v/v ]
! (4 ) ALBD (REAL*8 ) : Array for visible albedo [unitless]
! (5 ) SUNCOS (REAL*8 ) : Array for COS( Solar Zenith Angle ) [unitless]
! (6 ) LEMBED (LOGICAL) : Switch for embedded chemistry region [ T or F ]
! (7 ) IEBD1 (INTEGER) : Lon: lower right corner } of the [unitless]
! (8 ) IEBD2 (INTEGER) : Lon: upper left corner } embedded [unitless]
! (9 ) JEBD1 (INTEGER) : Lat: lower right corner } chemistry [unitless]
! (10) JEBD2 (INTEGER) : Lat: upper left corner } region [unitless]
!
! NOTES:
! (1 ) Remove PTOP from the arg list. PTOP is now a parameter
! in "CMN_SIZE". (bmy, 2/10/00)
! (2 ) Add C-preprocessor switch LSLOWJ to bracket code for
! SLOW-J photolysis (bmy, 2/25/00)
! (3 ) Now reference ABHSUM, AIRDENS, IXSAVE, IYSAVE, IZSAVE, JLOP, PRESS3,
! T3, and VOLUME from F90 module "comode_mod.f" (bmy, 10/19/00)
! (4 ) PTOP is already a parameter in "CMN_SIZE", don't declare it here
! (bmy, 7/16/01)
! (5 ) Replace IGCMPAR,JGCMPAR,LGCMPAR with IIPAR,JJPAR,LLPAR. Also moved
! CLOUDREF to SLOW-J block. Also remove IREF, JREF, IOFF, JOFF, these
! are now obsolete. Updated comments. (bmy, 9/25/01)
! (6 ) Eliminate I00 and J00 as arguments, these are obsolete (bmy, 9/28/01)
! (7 ) Removed obsolete, commented out code from 9/01 (bmy, 10/24/01)
! (8 ) Updated comment header. Also updated comments, and made cosmetic
! changes. (bmy, 4/15/02)
! (9 ) Bug fix: declare variables for SLOW-J photolysis. Also eliminated
! obsolete code from 4/15/02. (bmy, 8/5/02)
! (10) Now reference GET_PCENTER and GET_PEDGE from "pressure_mod.f",
! which return the correct "floating" pressure. Also deleted obsolete,
! commented-out code. Also eliminate P, SIG, and NSKIPL from the arg
! list, since we don't need them anymore. (dsa, bdf, bmy, 8/20/02)
! (11) Added modifications for SMVGEAR II (gcc, bdf, bmy, 4/1/03)
! (12) SLOW-J is now obsolete; remove LSLOWJ #ifdef blocks (bmy, 6/23/05)
! (13) Now reference ITS_IN_THE_TROP and ITS_IN_THE_STRAT from
! "tropopause_mod.f" to diagnose trop & strat boxes. Also remove
! LPAUSE from the arg list (bmy, 8/22/05)
! (14) Remove ALT and CLOUDS from arg list -- they are obsolete (bmy, 4/10/06)
!******************************************************************************
!
! References to F90 modules
USE COMODE_MOD, ONLY : ABSHUM, AIRDENS, IXSAVE, IYSAVE,
& IZSAVE, JLOP, PRESS3, T3, VOLUME
USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE
USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT, ITS_IN_THE_TROP,
& GET_TPAUSE_LEVEL
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "comode.h" ! NPVERT
LOGICAL, INTENT(IN) :: LEMBED
INTEGER, INTENT(IN) :: IEBD1, IEBD2, JEBD1, JEBD2
REAL*8, INTENT(IN) :: AD(IIPAR,JJPAR,LLPAR)
REAL*8, INTENT(IN) :: T(IIPAR,JJPAR,LLPAR)
REAL*8, INTENT(IN) :: AVGW(IIPAR,JJPAR,LLPAR)
REAL*8, INTENT(IN) :: ALBD(IIPAR,JJPAR)
REAL*8, INTENT(IN) :: SUNCOS(MAXIJ)
! Local variables
LOGICAL :: LDEBUG
INTEGER :: I, J, L, JLOOP, IJLOOP, LL
! External functions
REAL*8, EXTERNAL :: BOXVL
!! testing variables for variable tropopause
!real*8 :: temp(iipar,jjpar,llpar)
!logical :: templ
!temp = 0
!=================================================================
! RURALBOX begins here!
!=================================================================
LDEBUG = .FALSE.
! Rural Boxes
JLOOP = 0
NTLOOPNCS = 0
! Loop over vertical levels (max = LLTROP)
DO L = 1, NVERT
! Loop over surface grid boxes
DO J = 1, NLAT
DO I = 1, NLONG
! JLOP is the 1-D grid box loop index
JLOP(I,J,L) = 0
! Filter to do chemistry in a window when
! rest of model is running global run.
! LEMBED - Logical for embedded window defined by
! IEBD1, IEBD2, JEBD1, JEBD2
IF ( LEMBED ) THEN
IF ( I < IEBD1 .OR. I > IEBD2 .OR.
& J < JEBD1 .OR. J > JEBD2 ) GOTO 40
ENDIF
IF ( IGLOBCHEM <= 0 ) THEN
! === testing === BDF
! if (i .eq. 30) then
! temp(i,j,1) = dble(get_tpause_level(i,j))
! write(6,*) i,j, 'val of last trop box: ', temp(i,j,1)
! templ = its_in_the_trop(i,j,l)
! write(6,*) ' ', l, 'trop: ', templ
! templ = its_in_the_strat(i,j,l)
! write(6,*) ' ', l, 'strat: ', templ
! endif
! === end testing === BDF
!=======================================================
! Skip over strat boxes
!=======================================================
IF ( ITS_IN_THE_STRAT( I, J, L ) ) GOTO 40
! Increment JLOOP for trop boxes
JLOOP = JLOOP + 1
JLOP(I,J,L) = JLOOP
! test jlop for variable chem
!temp(i,j,l) = dble(jloop)
ELSE
!=======================================================
! If we're doing a trop/strat run, IGLOBCHEM > 0.
! In that case we have to tell SMVGEAR which boxes are
! tropospheric and which are stratospheric. We do this
! using NTLOOPNCS and NCSLOOP. (gcc, bdf, bmy, 4/1/03)
!
! NTLOOPNCS counts the # of urban, trop, strat boxes
! NCSLOOP holds the 1-D grid box indices for
!
! NOTE: L < LPAUSE(I,J) are tropospheric boxes
! L >= LPAUSE(I,J) are stratospheric boxes
!========================================================
! Increment JLOOP for all boxes
JLOOP = JLOOP + 1
JLOP(I,J,L) = JLOOP
IF ( ITS_IN_THE_TROP( I, J, L ) ) THEN
! Tropospheric boxes go into the SMVGEAR II "URBAN" slot
NTLOOPNCS(NCSURBAN) = NTLOOPNCS(NCSURBAN) + 1
NCSLOOP(NTLOOPNCS(NCSURBAN),NCSURBAN) = JLOOP
!-----------------------------------------------------------
! Comment this out for now -- restore it later (bmy, 4/21/03)
!ELSE IF ( .FALSE. ) THEN
!
! ! The SMVGEAR II "FREE TROPOSPHERE" slot is unused
! NTLOOPNCS(NCSTROP) = NTLOOPNCS(NCSTROP) + 1
! NCSLOOP(NTLOOPNCS(NCSTROP),NCSTROP) = JLOOP
!-----------------------------------------------------------
ELSE
! Stratospheric boxes go into the SMVGEAR II "STRAT" slot
! (for now GEOS-CHEM skips these; later we will define
! a stratospheric chemistry mechanism a la G. Curci).
NTLOOPNCS(NCSSTRAT) = NTLOOPNCS(NCSSTRAT) + 1
NCSLOOP(NTLOOPNCS(NCSSTRAT),NCSSTRAT) = JLOOP
ENDIF
ENDIF
! These translate JLOOP back to an (I,J,L) triplet
IXSAVE(JLOOP) = I
IYSAVE(JLOOP) = J
IZSAVE(JLOOP) = L
! === testing === BDF
! if (i .eq. 18 .and. j .eq. 23 .and. l .eq. 19) then
! write(6,*) 'using offending box'
! endif
! === end testing === BDF
! get box volume [cm3]
VOLUME(JLOOP) = BOXVL(I, J, L)
! get air density in (molecs cm^-3)
AIRDENS(JLOOP) = AD(I,J,L)*1000.d0/VOLUME(JLOOP)*AVG/WTAIR
! get temperature
T3(JLOOP) = T(I,J,L)
! PRESS3 = pressure in bar, multiply mb * 1000
PRESS3(JLOOP) = GET_PCENTER(I,J,L) * 1000d0
! Get relative humidity (here is absolute #H2O/cc air)
! AVGW is the mixing ratio of water vapor [v/v]
ABSHUM(JLOOP) = AVGW(I,J,L) * AIRDENS(JLOOP)
! Go to next I
40 CONTINUE
ENDDO
ENDDO
! NIJLOOP is the number of surface boxes
IF ( L == 1 ) NIJLOOP = JLOOP
ENDDO
! === testing === BDF
! write(6,*) ' in ruralbox, number of tropospheric boxes: ', jloop
! call flush(6)
! call write_fields3(temp,'jloptest')
! === testing === BDF
! NTLOOP is the number of total tropospheric boxes
NTLOOP = JLOOP
! Return to calling program
END SUBROUTINE RURALBOX

551
code/scale_anthro_mod.f Normal file
View File

@ -0,0 +1,551 @@
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !MODULE: scale_anthro_mod
!
! !DESCRIPTION: Module SCALE\_ANTHRO\_MOD contains routines to scale
! anthropogenic emissions from a base year to a simulation year.
!\\
!\\
! !INTERFACE:
!
MODULE SCALE_ANTHRO_MOD
!
! !USES:
!
IMPLICIT NONE
PRIVATE
!
! !PUBLIC MEMBER FUNCTIONS:
!
PUBLIC :: GET_ANNUAL_SCALAR
PUBLIC :: GET_ANNUAL_SCALAR_1x1
PUBLIC :: GET_ANNUAL_SCALAR_05x0666_NESTED
! add GET_ANNUAL_SCALAR_05x0666_NESTED_CH for backward compatability (dkh, 02/19/11)
PUBLIC :: GET_ANNUAL_SCALAR_05x0666_NESTED_CH
!
! !REVISION HISTORY:
! 28 Jan 2009 - A. v. Donkelaar and P. Le Sager - Initial Version
!
! !REMARKS:
! (1 ) Add GET_ANNUAL_SCALAR_05x0666_NESTED_CH for nested grid simulations
! over China. (tmf, 12/3/09)
! (2 ) Renamed consistently variables: name depends on relation of variable
! to BASE or TARGET year. New data directory to account for updated
! scale factors for 1985-1989 (phs, 5/7/09)
! (3 ) Adjusted GET_ANNUAL_SCALAR_05x0666_CH for new scalar format and
! renamed to GET_ANNUAL_SCALAR_05x0666 (amv, 10/29/2009)
! 18 Dec 2009 - Aaron van D - Updated scale factors thru 2006
! 18 Dec 2009 - Aaron van D - Updated routine GET_ANNUAL_SCALAR_05x0666_NESTED
! 10 Aug 2011 - D. Millet - Now use updated scale factor file for CO, which
! corrects a problem over Botswana/S. Africa
! 20 Aug 2013 - R. Yantosca - Removed "define.h", this is now obsolete
!EOP
!------------------------------------------------------------------------------
!BOC
CONTAINS
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: get_annual_scalar
!
! !DESCRIPTION: Subroutine GET\_ANNUAL\_SCALAR returns annual scale
! factors to convert B\_YEAR (base year) to T\_YEAR (simulation year),
! on the current model resolution.
!\\
!\\
! !INTERFACE:
!
SUBROUTINE GET_ANNUAL_SCALAR( TRACER, B_YEAR, T_YEAR, AS )
!
! !USES:
!
USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1
USE REGRID_A2A_MOD, ONLY : DO_REGRID_A2A
USE FILE_MOD, ONLY : IOERROR, IU_FILE
USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1
# include "CMN_SIZE" ! Size parameters
!
! !INPUT PARAMETERS:
!
INTEGER, INTENT(IN) :: TRACER ! Tracer number
INTEGER, INTENT(IN) :: B_YEAR ! Base year of emissions
INTEGER, INTENT(IN) :: T_YEAR ! Target year of emissions
!
! !INPUT/OUTPUT PARAMETERS:
!
REAL*4, INTENT(INOUT) :: AS(IIPAR,JJPAR) ! Scale factor array
!
! !REVISION HISTORY:
! 28 Jan 2009 - A. v. Donkelaar and P. Le Sager - Initial Version
! 13 Mar 2012 - M. Cooper - Changed regrid algorithm to map_a2a
! 07 Jun 2012 - M. Payer - Fixed minor bugs in map_a2a calls (M. Cooper)
! 24 Aug 2012 - R. Yantosca - DO_REGRID_A2A now reads netCDF input file
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
REAL*8, TARGET :: AS_1x1(I1x1,J1x1)
REAL*8, TARGET :: AS_1x1x1(I1x1,J1x1,1)
CHARACTER(LEN=255) :: LLFILENAME
REAL*8 :: OUTGRID(IIPAR,JJPAR)
REAL*8, POINTER :: INGRID(:,:) => NULL()
! Read 1x1 scale factors
CALL GET_ANNUAL_SCALAR_1x1( TRACER, B_YEAR, T_YEAR, AS_1x1 )
! Cast to REAL*8
AS_1x1x1(:,:,1) = AS_1x1(:,:)
! File with lat/lon edges for regridding
LLFILENAME = TRIM( DATA_DIR_1x1) //
& 'MAP_A2A_Regrid_201203/MAP_A2A_latlon_geos1x1.nc'
! Regrid emissions factors to current model resolution [unitless]
INGRID => AS_1x1x1(:,:,1)
CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,
& INGRID, OUTGRID, IS_MASS=0,
& netCDF=.TRUE. )
! Cast to REAL*4
AS(:,:) = OUTGRID(:,:)
! Free pointer
NULLIFY( INGRID )
END SUBROUTINE GET_ANNUAL_SCALAR
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: get_annual_scalar_1x1
!
! !DESCRIPTION: Subroutine GET\_ANNUAL\_SCALAR\_1x1 returns annual scale
! factors to convert B\_YEAR (base year) to T\_YEAR (target year), on the 1x1
! GEOS-Chem grid.
!\\
!\\
! !INTERFACE:
!
SUBROUTINE GET_ANNUAL_SCALAR_1x1( TRACER, B_YEAR, T_YEAR, AS_1x1 )
!
! !USES:
!
USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2
# include "CMN_SIZE" ! Size parameters
!
! !INPUT PARAMETERS:
!
INTEGER, INTENT(IN) :: TRACER ! Tracer number
INTEGER, INTENT(IN) :: B_YEAR ! Base year of emissions
INTEGER, INTENT(IN) :: T_YEAR ! Target year of emissions
!
! !INPUT/OUTPUT PARAMETERS:
!
REAL*8, INTENT(OUT) :: AS_1x1(I1x1,J1x1) ! Scale factor array
!
! !REVISION HISTORY:
! 28 Jan 2009 - A. v. Donkelaar and P. Le Sager - Initial Version
!
! !REMARKS:
! (1) Scaling factors are for years between 1985 and 2005, on the GEOS-Chem
! 1x1 grid (phs, 3/10/08)
! 18 Dec 2009 - Aaron van D - Updated scale factors through 2006,
! changed to new, directory, reset year limits
! 18 Dec 2009 - Aaron van D - Reformated scale factors to a single file for
! all years, made necessary input changes
! 10 Aug 2011 - D. Millet - Now use updated scale factor file for CO, which
! corrects a problem over Botswana/S. Africa
! 25 Apr 2012 - M. Payer - Add kludge to set TARG_YEAR=1985 for 1986 thru
! 1989 (B. Yantosca)
! 02 Jul 2013 - M. Payer - Extend scale factors to 2010 for USA and Canada
! (A. van Donkelaar)
!EOP
!------------------------------------------------------------------------------
!BOC
!
! !LOCAL VARIABLES:
!
REAL*4 :: T_1x1(I1x1,J1x1)
REAL*4 :: B_1x1(I1x1,J1x1)
REAL*8 :: TAU
CHARACTER(LEN=255) :: FILENAME, SCALE_DIR
CHARACTER(LEN=4) :: BASE_YYYY_STR, TARG_YYYY_STR
INTEGER :: BASE_YEAR, TARG_YEAR
INTEGER :: I, J
!=================================================================
! GET_ANNUAL_SCALAR_1x1 begins here!
!=================================================================
SCALE_DIR = TRIM( DATA_DIR_1x1 ) // 'anth_scale_factors_201207/'
! limit scaling between available years
! Scale factors extended to 2010 for USA and Canada.
! Note that these factors remain fixed past 2006 for other regions unless
! overwritten by other emission inventory data (e.g. EMEP and Streets).
BASE_YEAR = MAX( MIN( B_YEAR, 2010 ), 1985 )
TARG_YEAR = MAX( MIN( T_YEAR, 2010 ), 1985 )
WRITE( BASE_YYYY_STR, '(i4.4)' ) BASE_YEAR
WRITE( TARG_YYYY_STR, '(i4.4)' ) TARG_YEAR
IF ( BASE_YEAR == 2000 ) THEN
B_1x1(:,:) = 1.d0
ELSE
! Filename
IF ( TRACER == 71 ) THEN
! NOx
FILENAME = TRIM( SCALE_DIR ) //
& 'NOx-AnnualScalar.geos.1x1'
ELSE IF ( TRACER == 72 ) THEN
! CO
FILENAME = TRIM( SCALE_DIR ) //
& 'CO-AnnualScalar.geos.1x1'
ELSE IF ( TRACER == 73 ) THEN
! SOx
FILENAME = TRIM( SCALE_DIR ) //
& 'SOx-AnnualScalar.geos.1x1'
ENDIF
! Get Tau
TAU = GET_TAU0(1,1,BASE_YEAR)
! Echo filename
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( ' - GET_ANNUAL_SCALAR_1x1: Reading ', a )
! Read data
CALL READ_BPCH2( FILENAME, 'RATIO-2D', TRACER,
& TAU, I1x1, J1x1,
& 1, B_1x1, QUIET=.TRUE. )
ENDIF
IF ( TARG_YEAR == 2000 ) THEN
T_1x1(:,:) = 1.d0
ELSE
! Filename
IF ( TRACER == 71 ) THEN
! NOx
FILENAME = TRIM( SCALE_DIR ) //
& 'NOx-AnnualScalar.geos.1x1'
ELSE IF ( TRACER == 72 ) THEN
! CO
FILENAME = TRIM( SCALE_DIR ) //
& 'CO-AnnualScalar.geos.1x1'
ELSE IF ( TRACER == 73 ) THEN
! SOx
FILENAME = TRIM( SCALE_DIR ) //
& 'SOx-AnnualScalar.geos.1x1'
ENDIF
! Calc Tau
TAU = GET_TAU0(1,1,TARG_YEAR)
! Echo filename
WRITE( 6, 100 ) TRIM( FILENAME )
! Read data
CALL READ_BPCH2( FILENAME, 'RATIO-2D', TRACER,
& TAU, I1x1, J1x1,
& 1, T_1x1, QUIET=.TRUE. )
ENDIF
! Get scaling and cast as real*8
AS_1x1(:,:) = T_1x1(:,:) / B_1x1(:,:)
END SUBROUTINE GET_ANNUAL_SCALAR_1x1
!EOC
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: get_annual_scalar_05x0666_nested
!
! !DESCRIPTION: Subroutine GET\_ANNUAL\_SCALAR\_05x0666\_NESTED
! returns annual scale factors to convert B\_YEAR (base year) to
! T\_YEAR (target year), on the 0.5x0.666 GEOS-Chem grid for nested China
! domain.
!\\
!\\
! !INTERFACE:
!
SUBROUTINE GET_ANNUAL_SCALAR_05x0666_NESTED
& ( TRACER, B_YEAR, T_YEAR, AS )
! !USES:
!
USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1
USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1
USE REGRID_A2A_MOD, ONLY : DO_REGRID_A2A
# include "CMN_SIZE" ! Size parameters
!
! !INPUT PARAMETERS:
!
INTEGER, INTENT(IN) :: TRACER
INTEGER, INTENT(IN) :: B_YEAR
INTEGER, INTENT(IN) :: T_YEAR
!
! !INPUT/OUTPUT PARAMETERS:
!
REAL*4, INTENT(INOUT) :: AS(IIPAR,JJPAR)
!
! !REVISION HISTORY:
! 28 Jan 2009 - A. v. Donkelaar and P. Le Sager - Initial Version
! 12 Mar 2009 - T-M. Fu - Initial Version
! 03 Nov 2009 - Aaron van D - rewritten to employ GET_ANNUAL_SCALAR_1x1
! and regrid.
! 18 Dec 2009 - Aaron van D - Renamed to GET_ANNUAL_SCALAR_05x0666_NESTED
! 18 Dec 2009 - Aaron van D - Rewrote GET_ANNUAL_SCALAR_05x0666_NESTED to
! retrieve and regrid scale factors by calling
! GET_ANNUAL_SCALAR_1x1 and regridding on fly
! 06 Apr 2012 - M. Payer - Changed regrid algorithm to map_a2a (M. Cooper)
! 07 Jun 2012 - M. Payer - Fixed minor bugs in map_a2a calls (M. Cooper)
!
! !REMARKS:
! (1) Scaling factors are for years between 1985 and 2005, on the GEOS-Chem
! 0.5x0.666 grid for China domain (tmf, 3/5/09)
! 24 Aug 2012 - R. Yantosca - DO_REGRID_A2A now reads netCDF input file
!EOP
!------------------------------------------------------------------------------
!BOC
!
! ! LOCAL VARIABLES:
!
REAL*8, TARGET :: AS_1x1(I1x1,J1x1,1)
REAL*8 :: AS_R8(IIPAR, JJPAR)
CHARACTER(LEN=255) :: LLFILENAME
REAL*8 :: OUTGRID(IIPAR,JJPAR)
REAL*8, POINTER :: INGRID(:,:) => NULL()
!=================================================================
! GET_ANNUAL_SCALAR_05x0666_NESTED begins here!
!=================================================================
CALL GET_ANNUAL_SCALAR_1x1( TRACER, B_YEAR, T_YEAR, AS_1x1 )
! File with lat/lon edges for regridding
LLFILENAME = TRIM( DATA_DIR_1x1) //
& 'MAP_A2A_Regrid_201203/MAP_A2A_latlon_geos1x1.nc'
! Regrid emissions factors to current model resolution [unitless]
INGRID => AS_1x1(:,:,1)
CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,
& INGRID, OUTGRID, IS_MASS=0,
& netCDF=.TRUE. )
! Cast to REAL*4
AS(:,:) = OUTGRID(:,:)
! Free pointer
NULLIFY( INGRID )
END SUBROUTINE GET_ANNUAL_SCALAR_05x0666_NESTED
!EOC
! Keep GET_ANNUAL_SCALAR_05x0666_NESTED_CH here for backwd compatability (dkh, 02/19/11)
!------------------------------------------------------------------------------
! Harvard University Atmospheric Chemistry Modeling Group !
!------------------------------------------------------------------------------
!BOP
!
! !IROUTINE: GET_ANNUAL_SCALAR_05x0666_NESTED_CH
!
! !DESCRIPTION: Subroutine GET\_ANNUAL\_SCALAR\_05x0666\_NESTED\_CH
! returns annual scale factors to convert B\_YEAR (base year) to
! T\_YEAR (target year), on the 0.5x0.666 GEOS-Chem grid for nested China
! domain. (avd, bmy, phs, 3/10/08)
!\\
!\\
! !INTERFACE:
!
SUBROUTINE GET_ANNUAL_SCALAR_05x0666_NESTED_CH
& ( TRACER, B_YEAR, T_YEAR, AS )
! !USES:
!
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2
USE REGRID_1x1_MOD, ONLY : DO_REGRID_05x0666
# include "CMN_SIZE" ! Size parameters
!
! !INPUT PARAMETERS:
!
INTEGER, INTENT(IN) :: TRACER
INTEGER, INTENT(IN) :: B_YEAR
INTEGER, INTENT(IN) :: T_YEAR
!
! !INPUT/OUTPUT PARAMETERS:
!
REAL*4, INTENT(INOUT) :: AS(IIPAR,JJPAR)
!
! !REVISION HISTORY:
! 12 Mar 2009 - T-M. Fu - Initial Version
!
! !REMARKS:
! (1) Scaling factors are for years between 1985 and 2005, on the GEOS-Chem
! 0.5x0.666 grid for China domain (tmf, 3/5/09)
!EOP
!------------------------------------------------------------------------------
!BOC
!
! ! LOCAL VARIABLES:
!
REAL*4 :: T_05x0666(I05x0666,J05x0666)
REAL*4 :: B_05x0666(I05x0666,J05x0666)
REAL*8 :: AS_05x0666(I05x0666,J05x0666)
REAL*8 :: AS_05x0666x1(I05x0666,J05x0666,1)
REAL*8 :: AS_R8(IIPAR, JJPAR)
REAL*8 :: TAU2000
CHARACTER(LEN=255) :: FILENAME, SCALE_DIR
CHARACTER(LEN=4) :: BASE_YYYY_STR, TARG_YYYY_STR
INTEGER :: BASE_YEAR, TARG_YEAR
INTEGER :: I, J
!=================================================================
! GET_ANNUAL_SCALAR_05x0666_NESTED_CH begins here!
!=================================================================
SCALE_DIR = TRIM( DATA_DIR ) // 'anth_scale_factors_200811/'
! limit scaling between available years
BASE_YEAR = MAX( MIN( B_YEAR, 2005 ), 1985 )
TARG_YEAR = MAX( MIN( T_YEAR, 2005 ), 1985 )
WRITE( BASE_YYYY_STR, '(i4.4)' ) BASE_YEAR
WRITE( TARG_YYYY_STR, '(i4.4)' ) TARG_YEAR
IF ( BASE_YEAR == 2000 ) THEN
B_05x0666(:,:) = 1.0
ELSE
! Filename
IF ( TRACER == 71 ) THEN
! NOx
FILENAME = TRIM( SCALE_DIR ) // 'NOxScalar-' //
& BASE_YYYY_STR // '-' // '2000.geos.05x0666'
ELSE IF ( TRACER == 72 ) THEN
! CO
FILENAME = TRIM( SCALE_DIR ) // 'COScalar-' //
& BASE_YYYY_STR // '-' // '2000.geos.05x0666'
ELSE IF ( TRACER == 73 ) THEN
! SOx
FILENAME = TRIM( SCALE_DIR ) // 'SOxScalar-' //
& BASE_YYYY_STR // '-' // '2000.geos.05x0666'
ENDIF
! Get Tau
TAU2000 = GET_TAU0(1,1,2000)
! Echo filename
WRITE( 6, 100 ) TRIM( FILENAME )
100 FORMAT( ' - GET_ANNUAL_SCALAR_05x0666_NESTED_CH: Reading ',
& a )
! Read data
CALL READ_BPCH2( FILENAME, 'RATIO-2D', TRACER,
& TAU2000, I05x0666, J05x0666,
& 1, B_05x0666, QUIET=.TRUE. )
ENDIF
IF ( TARG_YEAR == 2000 ) THEN
T_05x0666(:,:) = 1.0
ELSE
! Filename
IF ( TRACER == 71 ) THEN
! NOx
FILENAME = TRIM( SCALE_DIR ) // 'NOxScalar-' //
& TARG_YYYY_STR // '-' // '2000.geos.05x0666'
ELSE IF ( TRACER == 72 ) THEN
! CO
FILENAME = TRIM( SCALE_DIR ) // 'COScalar-' //
& TARG_YYYY_STR // '-' // '2000.geos.05x0666'
ELSE IF ( TRACER == 73 ) THEN
! SOx
FILENAME = TRIM( SCALE_DIR ) // 'SOxScalar-' //
& TARG_YYYY_STR // '-' // '2000.geos.05x0666'
ENDIF
! Calc Tau
TAU2000 = GET_TAU0(1,1,2000)
! Echo filename
WRITE( 6, 100 ) TRIM( FILENAME )
! Read data
CALL READ_BPCH2( FILENAME, 'RATIO-2D', TRACER,
& TAU2000, I05x0666, J05x0666,
& 1, T_05x0666, QUIET=.TRUE. )
ENDIF
! Get scaling and cast as real*8
AS_05x0666(:,:) = T_05x0666(:,:) / B_05x0666(:,:)
! Recast as 3D array
AS_05x0666x1(:,:,1) = AS_05x0666(:,:)
! Regrid emission factors to current model resolution
CALL DO_REGRID_05x0666( 1, 'unitless', AS_05x0666x1, AS_R8 )
AS(:,:) = AS_R8(:,:)
! Return to calling program
END SUBROUTINE GET_ANNUAL_SCALAR_05x0666_NESTED_CH
!EOC
!------------------------------------------------------------------------------
END MODULE SCALE_ANTHRO_MOD

401
code/schem.f Normal file
View File

@ -0,0 +1,401 @@
! $Id: schem.f,v 1.1 2009/06/09 21:51:52 daven Exp $
SUBROUTINE SCHEM
!
!******************************************************************************
! Subroutine SCHEM performs simplified stratospheric chemistry, which means
! only reactions with OH and photolysis are considered. The production and
! loss of CO and NOy in the stratosphere are taken from Dylan Jones' 2-D
! model. (qli, bmy, 11/20/1999, 10/25/05)
!
! NOTES:
! (1 ) Now read all inputs (stratospheric OH, monthly mean J-values,
! P(CO) rates, and L(CO) rates) from binary punch file format.
! (bmy, 12/10/99)
! (2 ) Uses READ_BPCH2 to read from binary file format (bmy, 12/10/99)
! (3 ) Make sure the DO-loops go in the order N-L-J-I to avoid disk
! swapping problems (bmy, 12/10/99)
! (4 ) Remove reactions for HNO3 photolysis and HNO3 + OH. The HNO3
! concentrations that we read in from disk are from Dylan's 2-D
! model, where chemistry is already taken into account.
! (qli, bmy, 12/23/99)
! (5 ) Remove obsolete code from 12/23/99. (bmy, 4/18/00)
! (6 ) Bug fixes: Cap RDLOSS so that it does not exceed 1.0.
! Now declare RDLOSS, T1L, RC, K0, K1, K2, K3, M as REAL*8
! Cosmetic changes & update comments (bmy, 5/4/00)
! (7 ) Reference F90 module "bpch2_mod" which contains routine "read_bpch2"
! for reading data from binary punch files (bmy, 6/28/00)
! (8 ) Now all monthly mean J-values are in the same file (bmy, 6/30/00)
! (9 ) Now use function GET_TAU0 (from "bpch2_mod.f") to return the TAU0
! value used to index the binary punch file. (bmy, 7/20/00)
! (10) Declared arrays for reading data from disk to be both ALLOCATABLE
! and SAVE. Also cosmetic changes & some cleanup. (bmy, 9/8/00)
! (11) Activated parallel DO-loops (bmy, 12/12/00)
! (12) Now use 3 arguments (M/D/Y) in call to GET_TAU0. ARRAY needs to be
! of size (IGLOB,JGLOB). Use JGLOB,LGLOB in calls to READ_BPCH2.
! Use TRANSFER_ZONAL (from "transfer_mod.f") to cast from REAL*4 to
! REAL*8 and resize arrays to (JJPAR,LLPAR). Updated comments,
! made cosmetic changes. (bmy, 9/27/01)
! (13) Removed obsolete commented out code from 9/01 (bmy, 10/24/01)
! (14) Now read COprod and COloss files directly from the
! DATA_DIR/pco_lco_200203/ subdirectory. Also read stratOH files
! directly from the DATA_DIR/stratOH_200203/ subdirectory. Also
! read stratjv files directly from the DATA_DIR/stratjv_200203/
! subdirectory. (bmy, 4/2/02)
! (15) Now reference AD and T from "dao_mod.f". Also reference routine
! ALLOC_ERR from "error_mod.f". Now reference IDTOX, IDTNOX, etc.
! from "tracerid_mod.f". (bmy, 11/6/02)
! (16) Now use functions GET_TS_CHEM, GET_MONTH and GET_TAU, and
! TIMESTAMP_STRING from the new "time_mod.f". Also call READ_BPCH2
! with QUIET=.TRUE., which prevents info from being printed to the
! log file. (bmy, 3/14/03)
! (17) LINUX has a problem putting a function call w/in a WRITE statement.
! Now save output from TIMESTAMP_STRING to STAMP and print that.
! (bmy, 9/29/03)
! (18) Now reference STT and TRACER_MW_KG from "tracer_mod.f". Now reference
! DATA_DIR from "directory_mod.f". Bug fix: now loop over N_TRACERS
! and not NNPAR. NNPAR is the max # of tracers but may not be the
! actual number of tracers. (bmy, 7/20/04)
! (19) Now references GET_MIN_TPAUSE_LEVEL and ITS_IN_THE_STRAT from
! "tropopause_mod.f". Now remove reference to CMN, it's obsolete.
! (bmy, 8/22/05)
! (20) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05)
! (21) Now references XNUMOLAIR from "tracer_mod.f" (bmy, 10/25/05)
!******************************************************************************
!
! References to F90 modules
USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT
USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2
USE DAO_MOD, ONLY : AD, T
USE DIRECTORY_MOD, ONLY : DATA_DIR
USE ERROR_MOD, ONLY : ALLOC_ERR
USE TIME_MOD, ONLY : GET_MONTH, GET_TAU
USE TIME_MOD, ONLY : GET_TS_CHEM, TIMESTAMP_STRING
USE TRACER_MOD, ONLY : N_TRACERS, STT
USE TRACER_MOD, ONLY : TRACER_MW_KG, XNUMOLAIR
USE TRACERID_MOD, ONLY : IDTACET, IDTALD2, IDTALK4, IDTC2H6
USE TRACERID_MOD, ONLY : IDTC3H8, IDTCH2O, IDTH2O2, IDTHNO4
USE TRACERID_MOD, ONLY : IDTISOP, IDTMACR, IDTMEK, IDTMP
USE TRACERID_MOD, ONLY : IDTMVK, IDTPMN, IDTPRPE, IDTR4N2
USE TRACERID_MOD, ONLY : IDTRCHO
USE TRANSFER_MOD, ONLY : TRANSFER_ZONAL
USE TROPOPAUSE_MOD, ONLY : GET_MIN_TPAUSE_LEVEL, ITS_IN_THE_STRAT
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
! Local variables
LOGICAL, SAVE :: FIRST = .TRUE.
INTEGER :: I, IOS, J, L, N, NN, LMIN
INTEGER, SAVE :: MONTHSAVE = 0
! Number of photolysis species (currently is 13)
INTEGER, PARAMETER :: NSPHOTO = 13
! Tracers that undergo photolysis loss in the stratosphere
INTEGER :: SPHOTOID(NSPHOTO) = (/
& 3, 8, 9, 10, 11, 12, 13,
& 14, 17, 20, 22, 23, 24 /)
! Character variables
CHARACTER(LEN=16 ) :: STAMP
CHARACTER(LEN=255) :: FILENAME
! REAL*4 arrays -- for reading from binary data files
REAL*4 :: ARRAY(1,JGLOB,LGLOB)
REAL*4, ALLOCATABLE, SAVE :: STRATOH(:,:)
REAL*4, ALLOCATABLE, SAVE :: SJVALUE(:,:,:)
REAL*4, ALLOCATABLE, SAVE :: COPROD(:,:)
REAL*4, ALLOCATABLE, SAVE :: COLOSS(:,:)
! REAL*8 variables
REAL*8 :: k0, k1, k2, k3, XTAU
REAL*8 :: DTCHEM, RDLOSS, T1L, M, TK, RC
! External functions
REAL*8, EXTERNAL :: BOXVL
!=================================================================
! SCHEM begins here!
!=================================================================
! Chemistry timestep [s]
DTCHEM = GET_TS_CHEM() * 60d0
! Echo info
STAMP = TIMESTAMP_STRING()
WRITE( 6, 100 ) STAMP
100 FORMAT( ' - SCHEM: Strat chemistry at ', a )
!=================================================================
! If it is the first call to SCHEM, allocate arrays for reading
! data. These arrays are declared SAVE so they will be preserved
! between calls.
!=================================================================
IF ( FIRST ) THEN
ALLOCATE( STRATOH( JJPAR, LLPAR ), STAT=IOS )
IF ( IOS /= 0 ) CALL ALLOC_ERR( 'STRATOH' )
STRATOH = 0e0
ALLOCATE( SJVALUE( JJPAR, LLPAR, NSPHOTO ), STAT=IOS )
IF ( IOS /= 0 ) CALL ALLOC_ERR( 'SJVALUE' )
SJVALUE = 0e0
ALLOCATE( COPROD( JJPAR, LLPAR ), STAT=IOS )
IF ( IOS /= 0 ) CALL ALLOC_ERR( 'COPROD' )
COPROD = 0e0
ALLOCATE( COLOSS( JJPAR, LLPAR ), STAT=IOS )
IF ( IOS /= 0 ) CALL ALLOC_ERR( 'COLOSS' )
COLOSS = 0e0
ENDIF
!=================================================================
! If it is a new month (or the first call to SCHEM),
! do the following:
!
! (1) Read archived J-values and store in SJVALUE
! (2) Read archived CO production rates and store in COPROD
! (3) Read archived CO loss rates and store in COLOSS
!
! NOTES
! (a) All of the above-mentioned data are stored in binary punch
! files, for ease of use.
!
! (b) STRATOH, SJVALUE, CO_PROD, and CO_LOSS are now declared
! as both ALLOCATABLE and SAVE. If SCHEM is called, then
! data will be declared for these arrays, and the values in
! these arrays will be preserved between calls.
!
! (c) If SCHEM is never called (i.e. if you are running another
! type of chemistry simulation), then memory never gets
! allocated to STRATOH, SJVALUE, CO_PROD, and CO_LOSS.
! This saves on computational resources.
!=================================================================
IF ( GET_MONTH() /= MONTHSAVE .or. FIRST ) THEN
MONTHSAVE = GET_MONTH()
! TAU value at the beginning of this month
XTAU = GET_TAU0( GET_MONTH(), 1, 1985 )
!==============================================================
! Read this month's OH
!==============================================================
FILENAME = TRIM( DATA_DIR ) // 'stratOH_200203/stratOH.' //
& GET_NAME_EXT() // '.' //
& GET_RES_EXT()
! Read data
CALL READ_BPCH2( FILENAME, 'CHEM-L=$', 1,
& XTAU, 1, JGLOB,
& LGLOB, ARRAY, QUIET=.TRUE. )
! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR)
CALL TRANSFER_ZONAL( ARRAY(1,:,:), STRATOH )
!==============================================================
! Read in monthly mean archived J-values
!==============================================================
FILENAME = TRIM( DATA_DIR ) // 'stratjv_200203/stratjv.' //
& GET_NAME_EXT() // '.' //
& GET_RES_EXT()
DO NN = 1, NSPHOTO
N = SPHOTOID(NN)
! Read data
CALL READ_BPCH2( FILENAME, 'JV-MAP-$', N,
& XTAU, 1, JGLOB,
& LGLOB, ARRAY, QUIET=.TRUE. )
! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR)
CALL TRANSFER_ZONAL( ARRAY(1,:,:), SJVALUE(:,:,NN) )
ENDDO
!==============================================================
! Read in CO production rates
!==============================================================
FILENAME = TRIM( DATA_DIR ) // 'pco_lco_200203/COprod.' //
& GET_NAME_EXT() // '.' //
& GET_RES_EXT()
! Read data
CALL READ_BPCH2( FILENAME, 'PORL-L=$', 9,
& XTAU, 1, JGLOB,
& LGLOB, ARRAY, QUIET=.TRUE. )
! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR)
CALL TRANSFER_ZONAL( ARRAY(1,:,:), COPROD )
!==============================================================
! Read in CO loss rates
!==============================================================
FILENAME = TRIM( DATA_DIR ) // 'pco_lco_200203/COloss.' //
& GET_NAME_EXT() // '.' //
& GET_RES_EXT()
! Read data
CALL READ_BPCH2( FILENAME, 'PORL-L=$', 10,
& XTAU, 1, JGLOB,
& LGLOB, ARRAY, QUIET=.TRUE. )
! Cast from REAL*4 to REAL*8 and resize to (JJPAR,LLPAR)
CALL TRANSFER_ZONAL( ARRAY(1,:,:), COLOSS )
ENDIF
!=================================================================
! Do photolysis for selected tracers with this
! month's archived J-values
!=================================================================
! Get the minimum level extent of the ann mean tropopause
LMIN = GET_MIN_TPAUSE_LEVEL()
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, N, NN )
!$OMP+SCHEDULE( DYNAMIC )
DO NN = 1, NSPHOTO
N = SPHOTOID(NN)
DO L = LMIN, LLPAR
DO J = 1, JJPAR
DO I = 1, IIPAR
! Only proceed for stratospheric boxes
IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN
! Compute photolysis loss
STT(I,J,L,N) = STT(I,J,L,N) *
& EXP( -SJVALUE(J,L,NN) * DTCHEM )
ENDIF
ENDDO
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
!print*, 'In schem, done with photolysis'
!=================================================================
! CO is special --
! use archived P, L rates for CO chemistry in stratosphere
!=================================================================
CALL CO_STRAT_PL( COPROD, COLOSS )
!=================================================================
! Reaction with OH -- compute rate constants for each tracer
!=================================================================
!print*, 'In schem, before reaction with OH'
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, N, M, TK, RC, k0, k1, RDLOSS, T1L )
!$OMP+SCHEDULE( DYNAMIC )
DO N = 1, N_TRACERS
DO L = LMIN, LLPAR
DO J = 1, JJPAR
DO I = 1, IIPAR
! Only proceed for stratospheric boxes
IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN
! Density of air at grid box (I,J,L) in molec/cm3
M = AD(I,J,L) / BOXVL(I,J,L) * XNUMOLAIR
! Temperature at grid box (I,J,L) in K
TK = T(I,J,L)
! Select proper reaction rate w/ OH for the given tracer
! Some rates are temperature or density dependent
IF ( N == IDTALK4 ) THEN
RC = 8.20D-12 * EXP( -300.D0 / TK )
ELSE IF ( N == IDTISOP ) THEN
RC = 2.55D-11 * EXP( 410.D0 / TK )
ELSE IF ( N == IDTH2O2 ) THEN
RC = 2.90D-12 * EXP( -160.D0 / TK )
ELSE IF ( N == IDTACET ) THEN
RC = 1.70D-12 * EXP( -600.D0 / TK )
ELSE IF ( N == IDTMEK ) THEN
RC = 2.92D-13 * EXP( 414.D0 / TK )
ELSE IF ( N == IDTALD2 ) THEN
RC = 1.40D-12 * EXP( -1860.D0 / TK )
ELSE IF ( N == IDTRCHO ) THEN
RC = 2.00D-11
ELSE IF ( N == IDTMVK ) THEN
RC = 4.13D-12 * EXP( 452.D0 / TK )
ELSE IF ( N == IDTMACR ) THEN
RC = 1.86D-11 * EXP( -175.D0 / TK )
ELSE IF ( N == IDTPMN ) THEN
RC = 3.60D-12
ELSE IF ( N == IDTR4N2 ) THEN
RC = 1.30D-12
ELSE IF ( N == IDTPRPE ) THEN
k0 = 8.0D-27 * ( 300.D0 / TK )**3.5
k1 = 3.0D-11
RC = k1 * k0 * M / ( k1 + k0*M )
RC = RC * 0.5 ** (1 / ( 1 + LOG10( k0*M/k1 )**2 ) )
ELSE IF ( N == IDTC3H8 ) THEN
RC = 8.00D-12 * EXP( -590.D0 / TK )
ELSE IF ( N == IDTCH2O ) THEN
RC = 1.00D-12
ELSE IF ( N == IDTC2H6 ) THEN
RC = 7.9D-12 * EXP( -1030.D0 / TK )
ELSE IF ( N == IDTHNO4 ) THEN
RC = 1.30D-12 * EXP( 380.D0 / TK )
ELSE IF ( N == IDTMP ) THEN
RC = 1.14D-12 * EXP( 200.D0 / TK )
ELSE
RC = 0d0
ENDIF
! Compute loss with OH based on the rate constants from above
! Cap RDLOSS so that it does not exceed 1.0 (bmy, 5/4/00)
RDLOSS = RC * STRATOH(J,L) * DTCHEM
RDLOSS = MIN( RDLOSS, 1d0 )
! T1L is the absolute amount of STT lost to rxn with OH
! Subtract T1L from STT
T1L = STT(I,J,L,N) * RDLOSS
STT(I,J,L,N) = STT(I,J,L,N) - T1L
! Oxidation of PRPE as source of ACET with 80% yield
IF ( N == IDTPRPE ) THEN
STT(I,J,L,IDTACET) = STT(I,J,L,IDTACET) +
& 0.8d0 * T1L *
& TRACER_MW_KG(IDTACET) / TRACER_MW_KG(IDTPRPE)
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Set FIRST = .FALSE. -- we have been thru SCHEM at least once now
FIRST = .FALSE.
! Return to calling program
END SUBROUTINE SCHEM

1454
code/seasalt_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

82
code/set_aer.f Normal file
View File

@ -0,0 +1,82 @@
C $Id: set_aer.f,v 1.1 2009/06/09 21:51:53 daven Exp $
subroutine set_aer
C-----------------------------------------------------------------------
c Set aerosol/cloud types and define black carbon profile
C-----------------------------------------------------------------------
c MX Number of different types of aerosol to be considered
c MIEDX Index of aerosol types in jv_spec.dat - hardwire in here
C-----------------------------------------------------------------------
IMPLICIT NONE
# include "cmn_fj.h"
# include "jv_cmn.h"
integer i
c
c Initialise aerosol index
do i=1,MX
MIEDX(i) = 0
enddo
c
c Select Aerosol/Cloud types to be used - define types here
c Each of these types must be listed in the order used by OPMIE.F
MIEDX(1) = 3 ! Black carbon absorber
MIEDX(2) = 10 ! Water Cloud (Deirmenjian 8 micron)
MIEDX(3) = 14 ! Irregular Ice Cloud (Mishchenko)
MIEDX(4) = 15 ! Mineral Dust .15 micron (rvm, 9/30/00)
MIEDX(5) = 16 ! Mineral Dust .25 micron (rvm, 9/30/00)
MIEDX(6) = 17 ! Mineral Dust .4 micron (rvm, 9/30/00)
MIEDX(7) = 18 ! Mineral Dust .8 micron (rvm, 9/30/00)
MIEDX(8) = 19 ! Mineral Dust 1.5 micron (rvm, 9/30/00)
MIEDX(9) = 20 ! Mineral Dust 2.5 micron (rvm, 9/30/00)
MIEDX(10) = 21 ! Mineral Dust 4.0 micron (rvm, 9/30/00)
MIEDX(11) = 22 ! Tropospheric Sulfate, RH=0 (rvm, bmy, 2/27/02)
MIEDX(12) = 23 ! Tropospheric Sulfate, RH=50 (rvm, bmy, 2/27/02)
MIEDX(13) = 24 ! Tropospheric Sulfate, RH=70 (rvm, bmy, 2/27/02)
MIEDX(14) = 25 ! Tropospheric Sulfate, RH=80 (rvm, bmy, 2/27/02)
MIEDX(15) = 26 ! Tropospheric Sulfate, RH=90 (rvm, bmy, 2/27/02)
MIEDX(16) = 29 ! Black Carbon, RH=0 (rvm, bmy, 2/27/02)
MIEDX(17) = 30 ! Black Carbon, RH=50 (rvm, bmy, 2/27/02)
MIEDX(18) = 31 ! Black Carbon, RH=70 (rvm, bmy, 2/27/02)
MIEDX(19) = 32 ! Black Carbon, RH=80 (rvm, bmy, 2/27/02)
MIEDX(20) = 33 ! Black Carbon, RH=90 (rvm, bmy, 2/27/02)
MIEDX(21) = 36 ! Organic Carbon, RH=0 (rvm, bmy, 2/27/02)
MIEDX(22) = 37 ! Organic Carbon, RH=50 (rvm, bmy, 2/27/02)
MIEDX(23) = 38 ! Organic Carbon, RH=70 (rvm, bmy, 2/27/02)
MIEDX(24) = 39 ! Organic Carbon, RH=80 (rvm, bmy, 2/27/02)
MIEDX(25) = 40 ! Organic Carbon, RH=90 (rvm, bmy, 2/27/02)
MIEDX(26) = 43 ! Sea Salt (accum), RH=0 (rvm, bmy, 2/27/02)
MIEDX(27) = 44 ! Sea Salt (accum), RH=50 (rvm, bmy, 2/27/02)
MIEDX(28) = 45 ! Sea Salt (accum), RH=70 (rvm, bmy, 2/27/02)
MIEDX(29) = 46 ! Sea Salt (accum), RH=80 (rvm, bmy, 2/27/02)
MIEDX(30) = 47 ! Sea Salt (accum), RH=90 (rvm, bmy, 2/27/02)
MIEDX(31) = 50 ! Sea Salt (coarse), RH=0 (rvm, bmy, 2/27/02)
MIEDX(32) = 51 ! Sea Salt (coarse), RH=50 (rvm, bmy, 2/27/02)
MIEDX(33) = 52 ! Sea Salt (coarse), RH=70 (rvm, bmy, 2/27/02)
MIEDX(34) = 53 ! Sea Salt (coarse), RH=80 (rvm, bmy, 2/27/02)
MIEDX(35) = 54 ! Sea Salt (coarse), RH=90 (rvm, bmy, 2/27/02)
c
c Ensure all 'MX' types are valid selections
do i=1,MX
write(6,1000) MIEDX(i),TITLEA(MIEDX(i))
if(MIEDX(i).gt.NAA.or.MIEDX(i).le.0) then
write(6,1200) MIEDX(i),NAA
stop
endif
enddo
c
c Approximate Black Carbon up to 10 km; surface 200 ng/m3 (Liousse et al)
c Scale: 1 ng/m3 = 1.0d-15 g/cm3 (1.0d-11 g/m2/cm as BREF is in cm))
c
c Simple place-holder profile
do i=1,51
BREF(i)=10.d0*1.0d-11
if(i.gt.6) BREF(i)=0.d0
enddo
c
return
1000 format('Using Aerosol type: ',i3,1x,a)
1200 format('Aerosol type ',i3,' unsuitable; supplied values must be ',
$ 'between 1 and ',i3)
end

99
code/setbase.f Normal file
View File

@ -0,0 +1,99 @@
! $Id: setbase.f,v 1.1 2009/06/09 21:51:52 daven Exp $
SUBROUTINE SETBASE( CONVERT, GMONOT )
!
!******************************************************************************
! Subroutine SETBASE computes the baseline emissions for
! ISOPRENE, MONOTERPENES, GRASSLAND ISOPRENE, and METHYL BUTENOL.
! (bdf, bmy, 8/1/01, 2/11/03)
!
! Baseline emissions are stored in arrays (from CMN_ISOP and CMN_MONOT)
! BASEISOP, BASEMONOT, BASEGRASS, BASEMB. Units are [kg C/box/step].
!
! Arguments as Input:
! ============================================================================
! (1 ) CONVERT (REAL*8) : ISOP emissions by landtype [atoms C/cm2 leaf/s]
! (2 ) GMONOT (REAL*8) : MONOT emissions by landtype [atoms C/cm2 leaf/s]
!
! NOTES:
! (1 ) Now use F90 syntax. Updated comments, cosmetic changes. Moved
! everything to within one I-J loop. Also removed reference to
! CMN_O3, which is no longer needed. (bdf, bmy, 8/1/01)
! (2 ) Replaced all instances of IM with IIPAR and JM with JJPAR, in order
! to prevent namespace confusion for the new TPCORE (bmy, 6/25/02)
! (3 ) Now replace DXYP(JREF)*1d4 with routine GET_AREA_CM2 from "grid_mod.f".
! Now use function GET_TS_EMIS from "grid_mod.f". (bmy, 2/11/03)
!******************************************************************************
!
! References to F90 modules
USE GRID_MOD, ONLY : GET_AREA_CM2
USE TIME_MOD, ONLY : GET_TS_EMIS
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "CMN" ! NSRCE
# include "CMN_VEL" ! IJREG, IJUSE, IJLAND
# include "CMN_ISOP" ! BASEISOP, BASEGRASS, BASEMB
# include "CMN_MONOT" ! BASEMONOT
! Arguments
REAL*8, INTENT(IN) :: CONVERT(NVEGTYPE), GMONOT(NVEGTYPE)
! Local variables
INTEGER :: I, J, IJLOOP, K
REAL*8 :: DTSRCE, FACTOR
! Avogadro's Number
REAL*8, PARAMETER :: AVO = 6.023D+23
!=================================================================
! SETBASE begins here!
!=================================================================
! Emission timestep [s]
DTSRCE = GET_TS_EMIS() * 60d0
!=================================================================
! Set up BASEISOP -- baseline ISOPRENE emissions
! Now hardwire molecular weight for Carbon = 0.012 kg/mol
! ISOPRENE is traced in terms of equivalent C atoms
!=================================================================
IJLOOP = 0
! Loop over latitudes
DO J = 1, JJPAR
! Conversion factor from [atoms C/cm2/s] to [kg C/box/step]
FACTOR = 12d-3 * DTSRCE * GET_AREA_CM2( J ) / AVO
! Loop over longitudes
DO I = 1, IIPAR
! 1-D grid box index corresponding to (I,J)
IJLOOP = IJLOOP + 1
! Loop over landtypes per (I,J) box
DO K = 1, IJREG(IJLOOP)
! Baseline emissions for ISOPRENE in [kg C/box/step]
! IJLAND+1 is the Olson land type index
BASEISOP(IJLOOP,K) = CONVERT(IJLAND(IJLOOP,K)+1) * FACTOR
! Baseline emissions for MONOTERPENES in [kg C/box/step]
! IJLAND+1 is the Olson land type index
BASEMONOT(IJLOOP,K) = GMONOT(IJLAND(IJLOOP,K)+1) * FACTOR
ENDDO
! Baseline emissions for GRASSLAND ISOPRENE in [kg C/box/step]
! needed for acetone chemistry. Based on Kirstine et al 1998.
BASEGRASS(IJLOOP) = 7.25d10 * FACTOR
! Baseline emissions for METHYL BUTENOL in [kg C/box/step]
! needed for acetone chemistry. Based on 3.2 TgC MB
! emissions in N.america from Guenther 2000
BASEMB(IJLOOP) = 4.37d11 * FACTOR
ENDDO
ENDDO
! Return to calling program
END SUBROUTINE SETBASE

148
code/setemdep.f Normal file
View File

@ -0,0 +1,148 @@
! $Id: setemdep.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE SETEMDEP( NTRACER )
!
!******************************************************************************
! Subroutine SETEMDEP stores SMVGEAR reaction numbers (listed in "chem.dat")
! corresponding to GEOS-CHEM tracers which emit and dry deposit into the
! NTEMIS and NTDEP index arrays. (lwh, jyl, gmg, djj, 1994; bmy, 7/20/04)
!
! Arguments as Input:
! ============================================================================
! (1 ) NTRACER (INTEGER) : Number of GEOS-CHEM tracers
!
! NOTES:
! (1 ) Now references "drydep_mod.f" and "tracerid_mod.f". Updated comments
! and made cosmetic changes. (bmy, 12/5/02)
! (2 ) Cosmetic changes (bmy, 3/14/03)
! (3 ) Updated for SMVGEAR II (gcc, bdf, bmy, 4/21/03)
! (4 ) Now flag to "smv2.log" the emitted & dry-deposited tracers instead
! of flagging the tracers which aren't. (bmy, 7/20/04)
!******************************************************************************
!
! References to F90 modules
USE DRYDEP_MOD, ONLY : DEPNAME, NUMDEP
USE TRACER_MOD, ONLY : TRACER_NAME
USE TRACERID_MOD, ONLY : IDEMIS, IDTRMB, NEMANTHRO, NEMBIOG
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "comode.h" ! SMVGEAR II arrays
! Arguments
INTEGER, INTENT(IN) :: NTRACER
! Local variables
INTEGER :: I, N, NK, NCS_TEMP
CHARACTER(LEN=14) :: NAME1
!=================================================================
! SETEMDEP begins here!
!=================================================================
! Write header to "smv2.log"
WRITE( IO93, '(/,a)' ) REPEAT( '=', 79 )
WRITE( IO93, '(a)' ) 'SETEMDEP: Emission & deposition species'
WRITE( IO93, '(a,/)' ) REPEAT( '=', 79 )
!=================================================================
! Flag EMISSION REACTIONS in "globchem.dat" for GEOS-CHEM tracers
!=================================================================
! Loop over different kinds of chemistry
DO NCS = 1, NCSGAS
! Loop over GEOS-CHEM tracers
DO I = 1, NTRACER
! Rxn # for Ith GEOS-CHEM tracer
NTEMIS(I,NCS) = 0
! Loop over emission species from "globchem.dat"
DO N = 1, NEMIS(NCS)
! Rxn # for Nth emission species in "globchem.dat"
NK = NKEMIS(N,NCS)
! Match "chem.dat" rxn number w/ GEOS-CHEM tracer number
! IRM is the species # for the first product of the NKth rxn
! IDTRMB is the species # of the GEOS-CHEM tracer which emits
IF ( IDEMIS(I) /= 0 ) THEN
IF ( IRM(NPRODLO,NK,NCS) == IDTRMB(I,IDEMIS(I)) ) THEN
NTEMIS(I,NCS) = NK
ENDIF
ENDIF
ENDDO
! Flag emitted tracer
IF ( NTEMIS(I,NCS) > 0 ) THEN
WRITE( IO93, 100 ) I, TRACER_NAME(I)
100 FORMAT( 'Tracer # ', i3, ' (', a4, ' ) has an ',
& 'emission rxn defined in "globchem.dat"' )
ENDIF
ENDDO
! The total # of emission species will be NEMANTHRO [anthro] +
! NEMBIOG [bio], so reset NEMIS accordingly
NEMIS(NCS) = NEMANTHRO + NEMBIOG
! Echo output to stdout
WRITE( 6, 110 ) NEMIS(NCS)
110 FORMAT( ' - SETEMDEP: Number of emitted '
& 'species in "globchem.dat":', i3 )
ENDDO
!=================================================================
! Flag DRYDEP REACTIONS from "chem.dat" for each GEOS-CHEM tracer
!=================================================================
! There is only drydep in the surface layer, which
! is accounted for in the "URBAN" chemistry slot
NCS = NCSURBAN
! Loop over GEOS_CHEM drydep tracers
DO I = 1, NUMDEP
! Rxn # of the Ith GEOS-CHEM drydep tracer
NTDEP(I) = 0
! Loop over drydep species from "globchem.dat"
DO N = 1, NDRYDEP(NCS)
! Rxn number and name of Nth drydep species in "globchem.dat"
NK = NKDRY(N,NCS)
NAME1 = NAMEGAS(IRM(1,NK,NCS))
! If we can match NAME1 against the GEOS-CHEM drydep tracer
! names in DEPNAME, then store the rxn number in NTDEP
IF ( DEPNAME(I) == NAME1 ) THEN
NTDEP(I) = NK
EXIT
ENDIF
ENDDO
! Flag drydep tracers
IF ( NTDEP(I) > 0 ) THEN
WRITE( IO93, 120 ) I, DEPNAME(I)
120 FORMAT( 'Drydep species # ', i3, ' (', a4,
& ') has a drydep rxn defined in "globchem.dat"' )
ENDIF
ENDDO
! Echo output to stdout
WRITE( 6, 130 ) NDRYDEP(1)
130 FORMAT( ' - SETEMDEP: Number of drydep species '
& 'in "globchem.dat":', i3 )
WRITE( 6, 140 ) NUMDEP
140 FORMAT( ' - SETEMDEP: Number of all GEOS-CHEM '
& 'drydep species :', i3 )
! Reset NCS = NCSURBAN, since we have defined our GEOS-CHEM
! mechanism in the urban slot of SMVGEAR II (bmy, 4/21/03)
NCS = NCSURBAN
! Return to calling program
END SUBROUTINE SETEMDEP

74
code/setmodel.f Normal file
View File

@ -0,0 +1,74 @@
! $Id: setmodel.f,v 1.1 2009/06/09 21:51:51 daven Exp $
SUBROUTINE SETMODEL
!
!******************************************************************************
! Subroutine SETMODEL computes the number of grid blocks that are needed.
! (M. Jacobson 1997; bdf, bmy, 4/18/03)
!
! NOTES:
! (1 ) Originally, this routine also computed other meteorological parameters
! such as horizontal & vertical coordinates, sun angles, etc. These
! are now computed elsewhere in GEOS-CHEM so this code has now been
! removed. The only code left is the code which determines the number
! of grid blocks used for the parallelization. Now force double-
! precision with the "D" exponent. (bdf, bmy, 4/18/03)
!******************************************************************************
!
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "comode.h" ! SMVGEAR II arrays
C
C *********************************************************************
C ************ WRITTEN BY MARK JACOBSON (1993-4) ************
C *** (C) COPYRIGHT, 1993-4 BY MARK Z. JACOBSON ***
C *** EXCEPT FOR DENOTED EXCERPTED PORTIONS ***
C *** (650) 650-6836 ***
C *********************************************************************
C
C SSSSSSS EEEEEEE TTTTTTT M M OOOOOOO DDDDDD EEEEEEE L
C S E T M M M M O O D D E L
C SSSSSSS EEEEEEE T M M M O O D D EEEEEEE L
C S E T M M O O D D E L
C SSSSSSS EEEEEEE T M M OOOOOOO DDDDDD EEEEEEE LLLLLLL
C
C *********************************************************************
C * THIS SUBROUTINE INITIALIZES METEOROLOGICAL PARAMETERS *
C *********************************************************************
C
! Local variables
INTEGER :: IAVBLOK, IAVGSIZE, IREMAIN, JADD
C
C *********************************************************************
C * DETERMINE HOW MANY BLOCKS OF GRID POINTS ARE NEEDED *
C *********************************************************************
C
KULOOP = MIN(KULOOP,KBLOOP,NTLOOP)
NBLOCKS = 1 + NTTLOOP / (KULOOP + 0.0001d0)
IAVBLOK = 1 + NTTLOOP / (NBLOCKS + 0.0001d0)
IAVGSIZE = MIN0(IAVBLOK,KULOOP)
JLOOPLO = 0
IREMAIN = NTTLOOP
C
DO 260 KBLK = 1, NBLOCKS
JADD = MIN0(IAVGSIZE,IREMAIN)
JLOFIXED(KBLK) = JLOOPLO
JHIFIXED(KBLK) = JADD
IREMAIN = IREMAIN - JADD
JLOOPLO = JLOOPLO + JADD
260 CONTINUE
C
C MAKE SURE MXBLOCK IS SUFFICIENTLY LARGE SINCE NBLOCKUSE CHANGES IN
C PHYSPROC.F
C
IF (NBLOCKS+15.GT.MXBLOCK) THEN
WRITE(6,*)'READER: NBLOCKS+15>MXBLOCKS ',NBLOCKS+15, MXBLOCK
STOP
ENDIF
C
C *********************************************************************
C ******************** END OF SUBROUTINE SETMODEL.F *******************
C *********************************************************************
C
RETURN
END SUBROUTINE SETMODEL

52
code/sfcwindsqr.f Normal file
View File

@ -0,0 +1,52 @@
! $Id: sfcwindsqr.f,v 1.1 2009/06/09 21:51:51 daven Exp $
REAL*8 FUNCTION SFCWINDSQR( I, J )
!
!******************************************************************************
! Function SFCWINDSQR computes the surface wind squared from the DAO
! U and V winds at 10 m above the surface. (bmy, 12/21/98, 8/4/06)
!
! NOTES:
! (1 ) The old SFCWINDSQR computed the surface wind squared (m/s)^2 from the
! the Harvard CTM winds (kg/s). But since the DAO winds are already
! in units of (m/s) then the previous unit conversion is unnecessary
! and costly in terms of computer resources.
! (2 ) Since GEOS-1 has U and V at 10 m, these are more representative
! of the surface than UWND(I,J,1) and VWND(I,J,1).
! (3 ) Pass GEOS-1 U10M and V10M fields via CMN_UV10M so that the argument
! list does not have to be modified in several existing Harvard CTM
! subroutines.
! (4 ) GEOS-STRAT does not store U10M and V10M, so compute 10 m wind speed
! from UWND(I,J,1) and VWND(I,J,1) in MAKE_WIND10M.
! (5 ) Now check for NaN's (bmy, 4/27/00)
! (6 ) Now reference U10M and V10M from "dao_mod.f" instead of from
! common block header files "CMN_UV10M". Also extend code
! to GEOS-2 and GEOS-3 met fields. (bmy, 7/11/00)
! (7 ) Now use interface IT_IS_NAN (from "error_mod.f") to trap NaN's.
! This will work on DEC/Compaq and SGI platforms. (bmy, 3/8/01)
! (8 ) Now call CHECK_VALUE from "error_mod.f". This will test SFCWINDSQR
! for NaN or Infinity conditions. Also updated comments and made
! cosmetic changes. (bmy, 7/16/01)
! (9 ) Removed obsolete, commented-out code from 7/01 (bmy, 11/26/01)
! (10) Remove support for GEOS-1 and GEOS-STRAT met fields. Also remove
! call to CHECK_VALUE. (bmy, 8/4/06)
!******************************************************************************
!
! References to F90 modules
USE DAO_MOD, ONLY : U10M, V10M
IMPLICIT NONE
# include "CMN_SIZE"
! Arguments
INTEGER, INTENT(IN) :: I, J
!=================================================================
! SFCWINDSQR begins here!!
!=================================================================
! Take the 10m wind speed squared as sfc wind speed squared
SFCWINDSQR = U10M(I,J)**2 + V10M(I,J)**2
! Return to calling program
END FUNCTION SFCWINDSQR

1752
code/smvgear.f Normal file
View File

File diff suppressed because it is too large Load Diff

72
code/soilbase.f Normal file
View File

@ -0,0 +1,72 @@
! $Id: soilbase.f,v 1.1 2009/06/09 21:51:53 daven Exp $
REAL*8 FUNCTION SOILBASE(I,J,M,NN,PULSE)
C**********************************************************************
C *
C HARVARD ATMOSPHERIC CHEMISTRY MODELING GROUP *
C MODULE FOR SOIL NOx EMISSIONS *
C by Yuhang Wang, Gerry Gardner and Prof. Daniel Jacob *
C (Release V2.1) *
C *
C Contact person: Bob Yantosca (bmy@io.harvard.edu) *
C *
C**********************************************************************
C Be sure to force double precision with the DBLE function *
C and the "D" exponent, wherever necessary (bmy, 10/6/99) *
C**********************************************************************
IMPLICIT NONE
C**********************************************************************
C SOILBASE = Emissions *
C SOILAW = Wet biome coefficient *
C SOILAD = Dry biome coefficient *
C SOILPREP = Two month observed precip (mm/day/box *
C (divide by # of days in month)) *
C NN = Soil type *
C M = Index to land box *
C SOILFERT = Ferterlizers *
C UNITCONV = Convert from NG_N/(M^2*S) to MOLECULES/CM^2/S *
C**********************************************************************
# include "CMN_SIZE"
# include "commsoil.h"
INTEGER I,J,M,NN
REAL*8 PULSE,UNITCONV
DATA UNITCONV /4.3D9/ !NG_N/(M^2*S)->MOLECULES/CM^2/S
IF (NN.EQ.1) THEN
C Desert
SOILBASE=0.D0
ELSE IF (NN.EQ.2) THEN
C Tropical rain forest
IF (SOILPREP(2,M).GT.1.D0) THEN
C WET season
SOILBASE=SOILAW(2)
ELSE
C DRY season
SOILBASE=SOILAD(2)
END IF
ELSE IF (NN.EQ.8.OR.NN.EQ.9) THEN
SOILBASE=SOILAW(NN)
IF (NN.EQ.9) SOILBASE=SOILBASE/30.D0
ELSE
C Other
IF (SOILPULS(1,M).GT.0.D0) THEN
C DRY
SOILBASE=SOILAD(NN)*PULSE
ELSE
C WET
SOILBASE=SOILAW(NN)
END IF
END IF
C Convert units
SOILBASE=SOILBASE*UNITCONV
RETURN
END

82
code/soilcrf.f Normal file
View File

@ -0,0 +1,82 @@
! $Id: soilcrf.f,v 1.1 2009/06/09 21:51:52 daven Exp $
REAL*8 FUNCTION SOILCRF(I,J,IREF,JREF,IJLOOP,M,NN,K,
& WINDSQR,SUNCOS)
C**********************************************************************
C *
C HARVARD ATMOSPHERIC CHEMISTRY MODELING GROUP *
C MODULE FOR SOIL NOx EMISSIONS *
C by Yuhang Wang, Gerry Gardner and Prof. Daniel Jacob *
C (Release V2.1) *
C *
C Contact person: Bob Yantosca (bmy@io.harvard.edu) *
C *
C**********************************************************************
C Be sure to force double precision with the DBLE function *
C and the "D" exponent, wherever necessary (bmy, 10/6/99) *
C Updated comments (bmy, 1/24/03) *
C**********************************************************************
IMPLICIT NONE
C**********************************************************************
C SOILEXC = Canopy wind extinction coeff. *
C WINDSQR = Wind speed squared *
C XLAI = LAI of land type element K *
C CANOPYNOX = Deposition rate constant for NOx *
C NN = Soil type *
C K = Number in vegationtype of the grid *
C VFNEW = Ventilation rate constant for NOx *
C SOILCRF = Canopy reduction factor *
C SUNCOS = Array of cosine( Solar zenith angle ) for grid boxes *
C**********************************************************************
C *
C Wang et al.: [1998] JGR vol. 103 p10713-10725 *
C *
C**********************************************************************
# include "CMN_SIZE" ! Size parameters
# include "CMN_DEP" ! CANOPYNOX
# include "commsoil.h" ! Soil pulsing & wetness variables
INTEGER I,J,IREF,JREF,M,NN,K,IJLOOP
REAL*8 WINDSQR,VFDAY,VFNIGHT,VFNEW,SUNCOS(MAXIJ)
C**********************************************************************
C coefficient ALPHA (2.8E-2, 5.6E-3) day, night canopy ventilation *
C time of 1 hour day, 5 hour night *
C VFDAY,VFNIGHT - alpha scaled *
C**********************************************************************
DATA VFDAY,VFNIGHT /1.0D-2,0.2D-2/ !VENTILATION VEL. IN DAY&NIGHT M/S
C For GEOS-CTM, RADIAT is a 3-hour average field. Replace the test for
C RADIAT > 0 with a test for SUNCOS > 0. SUNCOS is the cosine of the
C solar zenith angle, so SUNCOS > 0 is day and SUNCOS < 0 is night.
C In the GEOS model, SUNCOS is is computed every dynamic timestep
C (15 or 30 mins), and thus is a better indicator of where the
C day-night terminator falls. (bmy, 10/20/99)
C IF (RADIAT(IJLOOP).GT.0D0) THEN
IF ( SUNCOS(IJLOOP) .GT. 0D0 ) THEN
! Day
VFNEW=VFDAY
ELSE
! Night
VFNEW=VFNIGHT
END IF
IF ((XLAI(IREF,JREF,K).GT.0.D0).AND.
& (CANOPYNOX(IJLOOP,K).GT.0.D0))THEN
VFNEW=VFNEW*SQRT(WINDSQR/9.D0*7.D0/XLAI(IREF,JREF,K))*
* (SOILEXC(2)/SOILEXC(NN))
SOILCRF=CANOPYNOX(IJLOOP,K)/(CANOPYNOX(IJLOOP,K)
* +VFNEW)
ELSE
SOILCRF=0.D0
END IF
! Return to calling program
END FUNCTION SOILCRF

88
code/soiltemp.f Normal file
View File

@ -0,0 +1,88 @@
C $Id: soiltemp.f,v 1.1 2009/06/09 21:51:50 daven Exp $
REAL*8 FUNCTION SOILTEMP(I,J,M,NN,TMMP0)
C**********************************************************************
C *
C HARVARD ATMOSPHERIC CHEMISTRY MODELING GROUP *
C MODULE FOR SOIL NOx EMISSIONS *
C by Yuhang Wang, Gerry Gardner and Prof. Daniel Jacob *
C (Release V2.1) *
C *
C Contact person: Bob Yantosca (bmy@io.harvard.edu) *
C *
C**********************************************************************
C Be sure to force double precision with the DBLE function *
C and the "D" exponent, wherever necessary (bmy, 10/6/99) *
C**********************************************************************
IMPLICIT NONE
C**********************************************************************
C Yienger and Levy [1995] JGR 100, 11447-11464 *
C**********************************************************************
C NN = Soil type *
C SOILTEMP = Temperature factor *
C TMMP0 = Local air temperature (C), *
C include diurnal temp variation *
C SOILTA = Coefficient used to convert from surface temperture to *
C soil temperature *
C SOILTB = Coefficient used to convert from surface temperture to *
C soil temperature *
C**********************************************************************
# include "CMN_SIZE"
# include "commsoil.h"
INTEGER I,J,M,NN
REAL*8 TMMP0,TMMP
TMMP=TMMP0
C DRY
C SURFACE TEMPERATURE->SOIL TEMPERATURE
C Convert the lowest model level air temperature to soil temperature
C based on observations of Johansson et. al. [1988]
C add 5 degrees C to model temperature
C
IF (NN.LE.2) THEN
C Desert and rain forest
SOILTEMP=1.D0
C Agric. Rice paddies
ELSE IF (SOILPULS(1,M).GT.0..AND.NN.NE.8.AND.NN.NE.9) THEN
C DRY
TMMP=TMMP+5.D0
IF (TMMP.GT.30.D0) THEN
C Optimal
SOILTEMP=1.D0
ELSE IF (TMMP.GT.0.D0) THEN
C Cold-linear
SOILTEMP=TMMP/30.D0
ELSE
SOILTEMP=0.D0
END IF
ELSE
C WET
C SURFACE TEMPERATURE->SOIL TEMPERATURE
C**********************************************************************
C Convert the lowest model level air temperature to soil temperature *
C Use the empirical relationships derived by Williams et al. [1992b] *
C ECO SYSTEM DEPENDENT *
C**********************************************************************
TMMP=SOILTA(NN)*TMMP+SOILTB(NN)
IF (TMMP.GE.30.D0) THEN
C Optimal
SOILTEMP=21.97D0
ELSE IF (TMMP.GE.10.D0) THEN
C Exponential
SOILTEMP=EXP(0.103D0*TMMP)
ELSE IF (TMMP.GT.0.D0) THEN
C Cold-linear
SOILTEMP=0.28D0*TMMP
ELSE
SOILTEMP=0.D0
END IF
END IF
RETURN
END

92
code/soiltype.f Normal file
View File

@ -0,0 +1,92 @@
C $Id: soiltype.f,v 1.1 2009/06/09 21:51:52 daven Exp $
SUBROUTINE SOILTYPE
C**********************************************************************
C *
C HARVARD ATMOSPHERIC CHEMISTRY MODELING GROUP *
C MODULE FOR SOIL NOx EMISSIONS *
C by Yuhang Wang, Gerry Gardner and Prof. Daniel Jacob *
C (Release V2.1) *
C *
C Contact person: Bob Yantosca (bmy@io.harvard.edu) *
C *
C**********************************************************************
C Be sure to force double precision with the DBLE function *
C and the "D" exponent, wherever necessary (bmy, 10/6/99) *
C**********************************************************************
! References to F90 modules (bmy, 2/11/03)
USE TIME_MOD, ONLY : GET_MONTH, GET_DAY_OF_YEAR
IMPLICIT NONE
C**********************************************************************
C SOILTYPE DETERMINES WHETHER SOIL IS DRY OR WET *
C UPDATED DAILY. *
C**********************************************************************
C SOILPREP = Two month observed precip (mm/day/box *
C (divide by # of days in month)) *
C JENDDAY = Julian ending day of previous month *
C WETSOIL = Criteria for wet soil mm *
C LENGTHDAY = Number of days for pulse *
C MONTHDAY = Day of the month *
C NCURRENT = Number of days in current month *
C NPREV = Number of days in previous month *
C JDAY = Julian day *
C MONTH = Month number *
C RAIN = Total rain *
C NPULSE = Number of types of pulsing *
C NLAND = Total number of land boxes *
C SOILPULS = Tracking of wet/dry & three types of pulsing (Y&L, 94) *
C**********************************************************************
C
# include "CMN_SIZE"
# include "commsoil.h"
! Now make JDAY, MONTH local variables
INTEGER :: JDAY, MONTH
INTEGER LENGTHDAY,JDAYSAVE,M,K,MONTHDAY,NCURRENT,NPREV
REAL*8 WETSOIL,RAIN
REAL*8 JENDDAY(12)
DATA JENDDAY /0,31,59,90,120,151,181,212,243,273,304,334/
DATA WETSOIL /10.D0/ !ABOVE 10 MM FOR TWO WEEKS
DATA LENGTHDAY /14/
DATA JDAYSAVE /0/
!=================================================================
! SOILTYPE begins here
!=================================================================
! Get month and day of year
MONTH = GET_MONTH()
JDAY = GET_DAY_OF_YEAR()
! If it's a new day...
IF (JDAYSAVE.NE.JDAY) THEN
JDAYSAVE=JDAY
MONTHDAY=JDAY-JENDDAY(MONTH)
NCURRENT=MIN0(LENGTHDAY,MONTHDAY)
NPREV=MAX0(0,LENGTHDAY-NCURRENT)
DO M=1,NLAND
C For each land grid-box
RAIN=SOILPREP(1,M)*DBLE(NPREV)+SOILPREP(2,M)*
* DBLE(NCURRENT)
IF (RAIN.GT.WETSOIL) THEN
C WET
SOILPULS(1,M)=-1.D0
DO K=1,NPULSE
SOILPULS(1+K,M)=0.D0
END DO
ELSE
C DRY
SOILPULS(1,M)=1.D0
END IF
END DO
END IF
RETURN
END

3043
code/streets_anthro_mod.f Normal file
View File

File diff suppressed because it is too large Load Diff

272
code/subfun.f Normal file
View File

@ -0,0 +1,272 @@
! $Id: subfun.f,v 1.1 2009/06/09 21:51:54 daven Exp $
SUBROUTINE SUBFUN
!
!******************************************************************************
! Subroutine SUBFUN evaluates the first derivative of each ODE for SMVGEAR II.
! (M. Jacobson, 1997; bdf, bmy, 4/1/03)
!
! NOTES:
! (1 ) Now force double-precision with the "D" exponent (bmy, 4/18/03)
!******************************************************************************
!
IMPLICIT NONE
# include "CMN_SIZE" ! Size parameters
# include "comode.h" ! SMVGEAR II arrays
C
C *********************************************************************
C ************ WRITTEN BY MARK JACOBSON (1993) ************
C *** (C) COPYRIGHT, 1993 BY MARK Z. JACOBSON ***
C *** U.S. COPYRIGHT OFFICE REGISTRATION NO. TXu 670-279 ***
C *** (650) 723-6836 ***
C *********************************************************************
C
C SSSSSSS U U BBBBBBB FFFFFFF U U N N
C S U U B B F U U NN N
C SSSSSSS U U BBBBBBB FFF U U N N N
C S U U B B F U U N NN
C SSSSSSS UUUUUUU BBBBBBB F UUUUUUU N N
C
C *********************************************************************
C * THIS SUBROUTINE EVALUATES THE FIRST DERIVATIVE OF EACH ORDINARY *
C * DIFFERENTIAL EQUATION (ODE) *
C * *
C * HOW TO CALL SUBROUTINE: *
C * ---------------------- *
C * CALL SUBFUN.F FROM SMVGEAR.F WITH *
C * NCS = 1..NCSGAS FOR GAS CHEMISTRY *
C * NCSP = NCS FOR DAYTIME GAS CHEM *
C * NCSP = NCS +ICS FOR NIGHTTIME GAS CHEM *
C *********************************************************************
C
C EXAMPLE
C -------
C
C SPECIES: A, B, C
C CONCENTRATIONS: [A], [B], [C]
C
C REACTIONS: 1) A --> B J
C 2) A + B --> C K1
C 3 A + B + C --> D K2
C
C FIRST d[A] / dt = -J[A] - K1[A][B] - K2[A][B][C]
C DERIVATIVES: d[B] / dt = +J[A] - K1[A][B] - K2[A][B][C]
C d[C] / dt = + K1[A][B] - K2[A][B][C]
C d[D] / dt = + K2[A][B][C]
C
C *********************************************************************
C
C CONCMULT = PRODUCT OF CONCENTRATIONS IN A RATE. IF TWO
C CONSECUTIVE REACTIONS HAVE THE SAME SPECIES REACTING
C (EG A + B --> C AND A + B --> D + E) THEN USE THE
C SAME VALUE OF CONCMULT FOR BOTH REACTIONS.
C CNEW = INIT (AND FINAL) SPECIES CONC (# CM-3-AIR OR MOLES L-1-H2O)
C GLOSS = FIRST DERIVATIVE = SUM OF PROD. MINUS LOSS RATES FOR A SPECIES
C IRMA,B,C = LOCATES REORDERED ACTIVE SPECIES NUMBERS
C ISCHAN = NUMBER OF ODES.
C LOSSRA.. = REAORDERED REACTION RATE NUMBERS FOR EACH LOSS (AND PROD) TERM
C KTLOOP = NUMBER OF GRID-CELLS IN A GRID-BLOCK
C NSUBFUN = COUNTS THE NUMBER OF TIMES THIS ROUTINE IS CALLED
C RRATE = FORWARD RATE COEFFICIENT
C = S-1 FOR RATES WITH 1 REACTANT
C = L-H2O MOLE-1 S-1 OR CM**3 #-1 S-1 FOR RATES WITH 2 REACTANTS
C = L**2-H2O M-2 S-1 OR CM**6 #-2 S-1 FOR RATES WITH 3 REACTANTS
C TRATE = REACTION RATE MOLES L-1 -H2O S-1 OR # CM-3 S-1
C
C *********************************************************************
C * SET RATES OF REACTION *
C *********************************************************************
C
C
! Local variables
INTEGER NKN,JA,JB,JC,NH,K,NK2,NH2,JSPC,NPL,NL5,NH5,NL4,NH4,NL3,NH3
INTEGER NL2,NL1,NH1,NC,NK0,NK1,NK3,NK4,N
INTEGER NK,I,JNEW,KLOOP
REAL*8 CONCMULT,FRACN
NSUBFUN = NSUBFUN + 1
NFDH1 = NFDH2 + IONER(NCSP)
C
C *********************************************************************
C * FIRST DERIVATIVES FOR RATES WITH THREE ACTIVE LOSS TERMS *
C *********************************************************************
C
DO 102 NKN = 1, NFDH3
JA = IRMA(NKN)
JB = IRMB(NKN)
JC = IRMC(NKN)
NH = NKN + NALLR
DO 100 K = 1, KTLOOP
TRATE(K,NKN) = RRATE(K,NKN)*CNEW(K,JA)*CNEW(K,JB)*CNEW(K,JC)
TRATE(K,NH) = -TRATE(K,NKN)
100 CONTINUE
102 CONTINUE
C
C *********************************************************************
C * FIRST DERIVATIVES FOR RATES WITH TWO ACTIVE LOSS TERMS *
C *********************************************************************
C
DO 152 NKN = NFDL2, NFDREP
JA = IRMA(NKN)
JB = IRMB(NKN)
NH = NKN + NALLR
DO 150 K = 1, KTLOOP
TRATE(K,NKN) = RRATE(K,NKN) * CNEW(K,JA) * CNEW(K,JB)
TRATE(K,NH) = -TRATE(K,NKN)
150 CONTINUE
152 CONTINUE
C
C *********************************************************************
C * FIRST DERIVATIVES FOR RATES WITH TWO ACTIVE LOSS TERMS AND *
C * WHERE THE SUBSEQUENT REACTION HAS THE SAME REACTANTS BUT A *
C * DIFFERENT RATE. *
C *********************************************************************
C
DO 202 NKN = NFDREP1, NFDH2, 2
JA = IRMA(NKN)
JB = IRMB(NKN)
NK2 = NKN + 1
NH = NKN + NALLR
NH2 = NK2 + NALLR
DO 200 K = 1, KTLOOP
CONCMULT = CNEW(K,JA) * CNEW(K,JB)
TRATE(K,NKN) = RRATE(K,NKN) * CONCMULT
TRATE(K,NK2) = RRATE(K,NK2) * CONCMULT
TRATE(K,NH) = -TRATE(K,NKN)
TRATE(K,NH2) = -TRATE(K,NK2)
200 CONTINUE
202 CONTINUE
C
C *********************************************************************
C * FIRST DERIVATIVES FOR RATES WITH ONE ACTIVE LOSS TERM *
C *********************************************************************
C
DO 252 NKN = NFDL1, NFDH1
JA = IRMA(NKN)
NH = NKN + NALLR
DO 250 K = 1, KTLOOP
TRATE(K,NKN) = RRATE(K,NKN) * CNEW(K,JA)
TRATE(K,NH) = -TRATE(K,NKN)
250 CONTINUE
252 CONTINUE
C
C *********************************************************************
C * INITIALIZE FIRST DERIVATIVE = 0 *
C *********************************************************************
C
DO 302 JSPC = 1, ISCHAN
DO 300 K = 1, KTLOOP
GLOSS(K,JSPC) = 0.d0
300 CONTINUE
302 CONTINUE
C
C *********************************************************************
C * SUM NET (NOT REPRODUCED) KINETIC AND PHOTO GAINS AND LOSSES FOR *
C * EACH SPECIES. *
C *********************************************************************
C SUM 1,2,3,4, OR 5 TERMS AT A TIME TO IMPROVE VECTORIZATION.
C
DO 554 NPL = NPLLO(NCSP), NPLHI(NCSP)
JSPC = JSPNPL(NPL)
NL5 = NPL5( NPL)
NH5 = NPH5( NPL)
NL4 = NPL4( NPL)
NH4 = NPH4( NPL)
NL3 = NPL3( NPL)
NH3 = NPH3( NPL)
NL2 = NPL2( NPL)
NH2 = NPH2( NPL)
NL1 = NPL1( NPL)
NH1 = NPH1( NPL)
C
C *********************** SUM 5 TERMS AT A TIME *********************
C
DO 352 NC = NL5, NH5
NK0 = LOSSRA(NC)
NK1 = LOSSRB(NC)
NK2 = LOSSRC(NC)
NK3 = LOSSRD(NC)
NK4 = LOSSRE(NC)
DO 350 K = 1, KTLOOP
GLOSS(K,JSPC) = GLOSS(K,JSPC) - TRATE(K,NK0)
1 - TRATE(K,NK1) - TRATE(K,NK2)
2 - TRATE(K,NK3) - TRATE(K,NK4)
350 CONTINUE
352 CONTINUE
C
C *********************** SUM 4 TERMS AT A TIME *********************
C
DO 402 NC = NL4, NH4
NK0 = LOSSRA(NC)
NK1 = LOSSRB(NC)
NK2 = LOSSRC(NC)
NK3 = LOSSRD(NC)
DO 400 K = 1, KTLOOP
GLOSS(K,JSPC) = GLOSS(K,JSPC) - TRATE(K,NK0)
1 - TRATE(K,NK1) - TRATE(K,NK2)
2 - TRATE(K,NK3)
400 CONTINUE
402 CONTINUE
C
C *********************** SUM 3 TERMS AT A TIME *********************
C
DO 452 NC = NL3, NH3
NK0 = LOSSRA(NC)
NK1 = LOSSRB(NC)
NK2 = LOSSRC(NC)
DO 450 K = 1, KTLOOP
GLOSS(K,JSPC) = GLOSS(K,JSPC) - TRATE(K,NK0)
1 - TRATE(K,NK1) - TRATE(K,NK2)
450 CONTINUE
452 CONTINUE
C
C *********************** SUM 2 TERMS AT A TIME *********************
C
DO 502 NC = NL2, NH2
NK0 = LOSSRA(NC)
NK1 = LOSSRB(NC)
DO 500 K = 1, KTLOOP
GLOSS(K,JSPC) = GLOSS(K,JSPC) - TRATE(K,NK0)
1 - TRATE(K,NK1)
500 CONTINUE
502 CONTINUE
C
C *********************** SUM 1 TERM AT A TIME **********************
C
DO 552 NC = NL1, NH1
NK0 = LOSSRA(NC)
DO 550 K = 1, KTLOOP
GLOSS(K,JSPC) = GLOSS(K,JSPC) - TRATE(K,NK0)
550 CONTINUE
552 CONTINUE
554 CONTINUE
C
C *********************************************************************
C * SUM PRODUCTION TERM FOR REACTIONS WHERE PRODUCTS FRACTIONATED *
C *********************************************************************
C
DO 802 N = NFRLO(NCSP), NFRHI(NCSP)
JSPC = JSPCNFR(N)
NKN = NKNFR( N)
FRACN = FRACNFR(N)
DO 800 K = 1, KTLOOP
GLOSS(K,JSPC) = GLOSS(K,JSPC) + FRACN * TRATE(K,NKN)
800 CONTINUE
802 CONTINUE
C
C *********************************************************************
C ********************** END OF SUBROUTINE SUBFUN *******************
C *********************************************************************
C
RETURN
END SUBROUTINE SUBFUN

32
code/sunparam.f Normal file
View File

@ -0,0 +1,32 @@
C $Id: sunparam.f,v 1.1 2009/06/09 21:51:53 daven Exp $
SUBROUTINE SUNPARAM(X)
IMPLICIT NONE
C===============================================
C the sequence is lai,suncos,cloud fraction
C===============================================
C NN = number of variables (lai,suncos,cloud fraction)
INTEGER NN
PARAMETER(NN=3)
C ND = scaling factor for each variable
INTEGER ND(NN),I
DATA ND /55,20,11/
C X0 = maximum for each variable
REAL*8 X(NN),X0(NN),XLOW
DATA X0 /11.,1.,1./
DO I=1,NN
X(I)=MIN(X(I),X0(I))
C XLOW = minimum for each variable
IF (I.NE.3) THEN
XLOW=X0(I)/REAL(ND(I))
ELSE
XLOW= 0.
END IF
X(I)=MAX(X(I),XLOW)
X(I)=X(I)/X0(I)
END DO
RETURN
END