diff --git a/code/GEN.f b/code/GEN.f new file mode 100644 index 0000000..2cc0e25 --- /dev/null +++ b/code/GEN.f @@ -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 diff --git a/code/JRATET.f b/code/JRATET.f new file mode 100644 index 0000000..3667290 --- /dev/null +++ b/code/JRATET.f @@ -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 diff --git a/code/JVALUE.f b/code/JVALUE.f new file mode 100644 index 0000000..c4f1d96 --- /dev/null +++ b/code/JVALUE.f @@ -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 diff --git a/code/Kr85_mod.f b/code/Kr85_mod.f new file mode 100644 index 0000000..aebf399 --- /dev/null +++ b/code/Kr85_mod.f @@ -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 diff --git a/code/LEGND0.f b/code/LEGND0.f new file mode 100644 index 0000000..b803f68 --- /dev/null +++ b/code/LEGND0.f @@ -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 diff --git a/code/MATIN4.f b/code/MATIN4.f new file mode 100644 index 0000000..1816abf --- /dev/null +++ b/code/MATIN4.f @@ -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 diff --git a/code/MIESCT.f b/code/MIESCT.f new file mode 100644 index 0000000..982f6fe --- /dev/null +++ b/code/MIESCT.f @@ -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 diff --git a/code/Makefile b/code/Makefile new file mode 100644 index 0000000..53a1b45 --- /dev/null +++ b/code/Makefile @@ -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 + diff --git a/code/Makefile~ b/code/Makefile~ new file mode 100644 index 0000000..ebd66a2 --- /dev/null +++ b/code/Makefile~ @@ -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 + diff --git a/code/NOABS.f b/code/NOABS.f new file mode 100644 index 0000000..43c7915 --- /dev/null +++ b/code/NOABS.f @@ -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 diff --git a/code/OPMIE.f b/code/OPMIE.f new file mode 100644 index 0000000..cc730c6 --- /dev/null +++ b/code/OPMIE.f @@ -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 diff --git a/code/Objects.default b/code/Objects.default new file mode 100644 index 0000000..3a3d4ef --- /dev/null +++ b/code/Objects.default @@ -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 diff --git a/code/Objects.default~ b/code/Objects.default~ new file mode 100644 index 0000000..aaf12f5 --- /dev/null +++ b/code/Objects.default~ @@ -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 diff --git a/code/Objects.mk b/code/Objects.mk new file mode 100644 index 0000000..4dd3eff --- /dev/null +++ b/code/Objects.mk @@ -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 diff --git a/code/Objects.mkl b/code/Objects.mkl new file mode 100644 index 0000000..3a3d4ef --- /dev/null +++ b/code/Objects.mkl @@ -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 diff --git a/code/Objects.mkl~ b/code/Objects.mkl~ new file mode 100644 index 0000000..aaf12f5 --- /dev/null +++ b/code/Objects.mkl~ @@ -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 diff --git a/code/Objects.mk~ b/code/Objects.mk~ new file mode 100644 index 0000000..e21554b --- /dev/null +++ b/code/Objects.mk~ @@ -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 diff --git a/code/RD_TJPL.f b/code/RD_TJPL.f new file mode 100644 index 0000000..7046d0c --- /dev/null +++ b/code/RD_TJPL.f @@ -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 diff --git a/code/REVISIONS b/code/REVISIONS new file mode 100644 index 0000000..e2e0a6f --- /dev/null +++ b/code/REVISIONS @@ -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. \ No newline at end of file diff --git a/code/RnPbBe_mod.f b/code/RnPbBe_mod.f new file mode 100644 index 0000000..ebba584 --- /dev/null +++ b/code/RnPbBe_mod.f @@ -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 + + diff --git a/code/SPHERE.f b/code/SPHERE.f new file mode 100644 index 0000000..f95be1e --- /dev/null +++ b/code/SPHERE.f @@ -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 diff --git a/code/geos b/code/geos new file mode 100644 index 0000000..5b3cf25 Binary files /dev/null and b/code/geos differ diff --git a/code/get_global_ch4.f b/code/get_global_ch4.f new file mode 100644 index 0000000..3d250eb --- /dev/null +++ b/code/get_global_ch4.f @@ -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 diff --git a/code/getifsun.f b/code/getifsun.f new file mode 100644 index 0000000..892aeab --- /dev/null +++ b/code/getifsun.f @@ -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 + diff --git a/code/gfed2_biomass_mod.f b/code/gfed2_biomass_mod.f new file mode 100644 index 0000000..002dede --- /dev/null +++ b/code/gfed2_biomass_mod.f @@ -0,0 +1,1139 @@ +! $Id: gfed2_biomass_mod.f,v 1.5 2010/05/07 20:39:47 daven Exp $ + MODULE GFED2_BIOMASS_MOD +! +!****************************************************************************** +! Module GFED2_BIOMASS_MOD contains variables and routines to compute the +! GFED2 biomass burning emissions. (psk, bmy, 4/20/06, 7/8/09) +! +! Monthly/8-day/3-hr emissions of C are read from disk and then +! multiplied by the appropriate emission factors to produce biomass +! burning emissions on a "generic" 1x1 grid. The emissions are then +! regridded to the current GEOS-Chem or GCAP grid (1x1, 2x25, or +! 4x5). +! If several GFED2 options are switched on, the smaller period +! product is used: 3-hr before 8-day before monthly. +! +! GFED2 biomass burning emissions are computed for the following gas-phase +! and aerosol-phase species: +! +! (1 ) NOx [ molec/cm2/s] (9 ) CH2O [ molec/cm2/s] +! (2 ) CO [ molec/cm2/s] (10) C2H6 [atoms C/cm2/s] +! (3 ) ALK4 [atoms C/cm2/s] (11) SO2 [ molec/cm2/s] +! (4 ) ACET [atoms C/cm2/s] (12) NH3 [ molec/cm2/s] +! (5 ) MEK [atoms C/cm2/s] (13) BC [atoms C/cm2/s] +! (6 ) ALD2 [atoms C/cm2/s] (14) OC [atoms C/cm2/s] +! (7 ) PRPE [atoms C/cm2/s] (15) CO2 [ molec/cm2/s] +! (8 ) C3H8 [atoms C/cm2/s] +! +! Module Variables: +! ============================================================================ +! (1 ) IDBNOx (INTEGER) : Local index for NOx in BIOM_OUT array +! (2 ) IDBCO (INTEGER) : Local index for CO in BIOM_OUT array +! (3 ) IDBALK4 (INTEGER) : Local index for ALK4 in BIOM_OUT array +! (4 ) IDBACET (INTEGER) : Local index for ACET in BIOM_OUT array +! (5 ) IDBMEK (INTEGER) : Local index for MEK in BIOM_OUT array +! (6 ) IDBALD2 (INTEGER) : Local index for ALD2 in BIOM_OUT array +! (7 ) IDBPRPE (INTEGER) : Local index for PRPE in BIOM_OUT array +! (8 ) IDBC3H8 (INTEGER) : Local index for C3H8 in BIOM_OUT array +! (9 ) IDBCH2O (INTEGER) : Local index for CH2O in BIOM_OUT array +! (10) IDBC2H6 (INTEGER) : Local index for C2H6 in BIOM_OUT array +! (11) IDBSO2 (INTEGER) : Local index for SO2 in BIOM_OUT array +! (12) IDBNH3 (INTEGER) : Local index for NH3 in BIOM_OUT array +! (13) IDBBC (INTEGER) : Local index for BC in BIOM_OUT array +! (14) IDBOC (INTEGER) : Local index for OC in BIOM_OUT array +! (15) IDBCO2 (INTEGER) : Local index for CO2 in BIOM_OUT array +! (11) SECONDS (REAL*8 ) : Number of seconds in the current month +! (12) N_EMFAC (INTEGER) : Number of emission factors per species +! (13) N_SPEC (INTEGER) : Number of species +! (14) VEG_GEN_1x1 (REAL*8 ) : Array for GFED2 1x1 vegetation ma +! (15) GFED2_SPEC_NAME (CHAR*4 ) : Array for GFED2 biomass species names +! (16) GFED2_EMFAC (REAL*8 ) : Array for user-defined emission factors +! (17) BIOM_OUT (REAL*8 ) : Array for biomass emissions on model grid +! (18) DOY8DAY (INTEGER) : Day Of the Year at start of the current +! 8-day period. +! (19) T3HR (INTEGER) : HH at start of the current 3-hr period. +! (20) UPDATED (LOGICAL) : flag to indicate if new data are read at +! the current emission time step. +! +! Module Routines: +! ============================================================================ +! (1 ) GFED2_COMPUTE_BIOMASS : Computes biomass emissions once per month +! (2 ) GFED2_SCALE_FUTURE : Applies IPCC future scale factors to GFED2 +! (3 ) GFED2_TOTAL_Tg : Totals GFED2 biomass emissions [Tg/month] +! (4 ) INIT_GFED2_BIOMASS : Initializes arrays and reads startup data +! (5 ) CLEANUP_GFED2_BIOMASS : Deallocates all module arrays +! +! GEOS-Chem modules referenced by "gfed2_biomass_mod.f": +! ============================================================================ +! (1 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (2 ) directory_mod.f : Module w/ GEOS-CHEM data & met field dirs +! (3 ) error_mod.f : Module w/ error and NaN check routines +! (4 ) file_mod.f : Module w/ file unit numbers and error checks +! (5 ) future_emissions_mod.f : Module w/ routines for IPCC future emissions +! (6 ) grid_mod.f : Module w/ horizontal grid information +! (7 ) time_mod.f : Module w/ routines for computing time & date +! (8 ) regrid_1x1_mod.f : Module w/ routines for regrid 1x1 data +! +! References: +! ============================================================================ +! (1 ) Original GFED2 database from Jim Randerson: +! http://ess1.ess.uci.edu/~jranders/data/GFED2/ +! (2 ) Giglio, L., G.R. van der Werf, J.T. Randerson, G.J. Collatz, and +! P. Kasibhatla, "Global estimation of burned area using MODIS active +! fire observations", Atm. Chem. Phys. Discuss, Vol 5, 11091, 2005. +! http://www.copernicus.org/EGU/acp/acpd/5/11091/acpd-5-11091.pdf +! (3 ) G.R. van der Werf, J.T. Randerson, L. Giglio, G.J. Collatz, +! P.S. Kasibhatla, and A.F. Arellano, Jr., "Interannual variability +! in global biomass burning emissions from 1997 to 2004", Atm. Chem. +! Phys. Discuss., submitted, 2005, +! http://sheba.geo.vu.nl/~gwerf/pubs/VanderWerfEA2005ACPD.pdf +! +! NOTES: +! (1 ) Added private routine GFED2_SCALE_FUTURE (swu, bmy, 5/30/06) +! (2 ) Now pass the unit string to DO_REGRID_G2G_1x1 (bmy, 8/9/06) +! (3 ) Added BC, OC, SO2, NH3, CO2 species. Also now can read 2005 GFED2 +! C emissions from disk. (rjp, yxw, bmy, 9/25/06) +! (4 ) 2006 is now the last year of GFED2 emissions (bmy, 1/2/08) +! (5 ) Add routines to check if GFED2 has been or must be updated. Added +! module variable UPDATED, DOY8DAY, and T3HR. Now choice between 3-hr, +! 8-day or monthly data (phs, psk, yc, 12/18/08) +! (6 ) Added 9 gaseous biomass burning emissions (tmf, 1/7/09) +! (7 ) The value of N_SPEC is now determined in INIT_GFED2_BIOMASS and depend +! on the tracers used in the simulation. (ccc, 4/23/09) +! (8 ) Adjust call to GFED2_AVAILABLE to reflect that monthly data for +! 2008 is now available on disk (bmy, 7/8/09) +! (9 ) Add modifications for CH4 (K. Wecht) (M. Payer 2/14/12) +!****************************************************************************** +! + IMPLICIT NONE +# include "define.h" + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "gfed2_biomass_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: GFED2_COMPUTE_BIOMASS + PUBLIC :: CLEANUP_GFED2_BIOMASS + PUBLIC :: GFED2_IS_NEW + + !================================================================== + ! MODULE VARIABLES + !================================================================== + + ! Scalars + INTEGER :: IDBNOx, IDBCO, IDBALK4 + INTEGER :: IDBACET, IDBMEK, IDBALD2 + INTEGER :: IDBPRPE, IDBC3H8, IDBCH2O + INTEGER :: IDBC2H6, IDBBC, IDBOC + INTEGER :: IDBSO2, IDBNH3, IDBCO2 + INTEGER :: IDBBENZ, IDBTOLU, IDBXYLE + INTEGER :: IDBC2H2, IDBC2H4, IDBGLYX + INTEGER :: IDBMGLY, IDBGLYC, IDBHAC + INTEGER :: IDBCH4 + INTEGER :: DOY8DAY, T3HR + LOGICAL :: UPDATED + REAL*8 :: SECONDS + + ! Parameters + INTEGER, PARAMETER :: N_EMFAC = 3 +!------------------------------------------------------------------------ + ! Why is this hardwired? (dkh, 09/20/09) + INTEGER, PARAMETER :: N_SPEC = 24 !no CH4 + !INTEGER, PARAMETER :: N_SPEC = 25 ! add CH4, kjw + + ! Arrays + INTEGER, ALLOCATABLE :: VEG_GEN_1x1(:,:) + REAL*8, ALLOCATABLE :: GFED2_EMFAC(:,:) + REAL*8, ALLOCATABLE :: GFED2_SPEC_MOLWT(:) + CHARACTER(LEN=4), ALLOCATABLE :: GFED2_SPEC_NAME(:) + CHARACTER(LEN=6), ALLOCATABLE :: GFED2_SPEC_UNIT(:) + REAL*8, ALLOCATABLE :: GFED2_BIOMASS(:,:,:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + FUNCTION GFED2_IS_NEW( ) RESULT( IS_UPDATED ) +! +!****************************************************************************** +! Function GFED2_IS_NEW returns TRUE if GFED2 emissions have been updated. +! (phs, 12/18/08) +! +! NOTES: +! (1 ) Used in carbon_mod.f and sulfate_mod.f +!****************************************************************************** +! + ! Function value + LOGICAL :: IS_UPDATED + + IS_UPDATED = UPDATED + + ! Return to calling program + END FUNCTION GFED2_IS_NEW + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_GFED2( DOY, HH ) +! +!****************************************************************************** +! Subroutine GFED2_UPDATE checks if we entered a new GFED period +! since last emission timestep (ie, last call). The result depends +! on the emissions time step, and the GFED time period used, as well +! as MMDDHH at beginning of the GEOS-Chem run (phs, 12/18/08) +! +! +! Arguments as Input: +! ============================================================================ +! (1 ) DOY (INTEGER) : Day of the Year (0-366) +! (2 ) HH (INTEGER) : Current hour of the day (0-23) +! +! NOTES: +! (1 ) the routine computes the DOY (resp. HOUR) at start of the 8-day (resp. +! 3-hour) period we are in, if the 8-day (resp. 3-hr or synoptic) GFED2 +! option is on. Result is compared to previous value to indicate if new +! data should be read. +!****************************************************************************** +! + USE LOGICAL_MOD, ONLY : LGFED2BB, L8DAYBB, L3HRBB, LSYNOPBB + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH,GET_DIRECTION !lzhang + USE TIME_MOD, ONLY : GET_DAY_OF_YEAR !lzhang + ! Arguments + INTEGER, INTENT(IN) :: DOY, HH !lzhang + + ! Local + INTEGER :: NEW_T3HR, NEW_DOY8DAY + INTEGER :: IDAY !lzhang + + ! Reset to default + UPDATED = .FALSE. + + ! Check if we enter a new 3hr GFED period (we assume that + ! emissions time step is less than a day) + IF ( L3HRBB .OR. LSYNOPBB ) THEN + + NEW_T3HR = INT( HH / 3 ) * 3 + + IF ( NEW_T3HR .NE. T3HR ) THEN + UPDATED = .TRUE. + T3HR = NEW_T3HR + ENDIF + + ! or a new 8-day GFED period + ELSE IF ( L8DAYBB ) THEN + + NEW_DOY8DAY = DOY - MOD( DOY - 1, 8 ) + IF ( GET_DIRECTION() > 0 ) THEN !lzhang + + IF ( NEW_DOY8DAY .NE. DOY8DAY ) THEN + UPDATED = .TRUE. + DOY8DAY = NEW_DOY8DAY + ENDIF + ELSE IF ( GET_DIRECTION() < 0 ) THEN !lzhang + + IF ( HH == 0 ) THEN + ! DATE_FWD = GET_TIME_AHEAD( 60 ) + ! CALL YMD_EXTRACT( DATE_FWD(1), YY_FWD, MM_FWD, DD_FWD ) + IDAY= GET_DAY_OF_YEAR() + PRINT *, IDAY + !NEW_DOY8DAY1 = DOY - MOD( DOY - 1, 8) +1 + ! then we must be in the last hour of a new 8-day GFED period + IF ( MOD(DOY-1,8)== 0 ) THEN + UPDATED = .TRUE. + DOY8DAY = NEW_DOY8DAY-8 + IF (IDAY==1) THEN !lzhang + DOY8DAY = NEW_DOY8DAY-5 ! lzhang + ENDIF ! lzhang + ENDIF + ENDIF + ENDIF + ! or a new month (we assume that we always do emissions on + ! 1st day 00 GMT of each month - except for the month the + ! run starts, for which it is not required) + ELSE IF ( LGFED2BB ) THEN + + IF ( ITS_A_NEW_MONTH() ) UPDATED = .TRUE. + + ENDIF + + + END SUBROUTINE CHECK_GFED2 + +!------------------------------------------------------------------------------ + + SUBROUTINE GFED2_AVAILABLE( YYYY, YMIN, YMAX, MM, MMIN, MMAX ) +! +!****************************************************************************** +! Function GFED2_AVAILABLE checks if data are available for input YYYY/MM +! date, and constrains the later if needed (phs, 1/5/08) +! +! NOTES: +! (1 ) +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(INOUT) :: YYYY + INTEGER, INTENT(IN) :: YMIN, YMAX + INTEGER, INTENT(INOUT), OPTIONAL :: MM + INTEGER, INTENT(IN), OPTIONAL :: MMIN, MMAX + + + ! Check year + IF ( YYYY > YMAX .OR. YYYY < YMIN ) THEN + + YYYY = MAX( YMIN, MIN( YYYY, YMAX) ) + + WRITE( 6, 100 ) YMAX, YMIN, YYYY + 100 FORMAT( 'YEAR > ', i4, ' or YEAR < ', i4, + $ '. Using GFED2 biomass for ', i4) + ENDIF + + + ! Check month + IF ( PRESENT( MM ) ) THEN + IF ( MM > MMAX .OR. MM < MMIN ) THEN + + MM = MAX( MMIN, MIN( MM, MMAX) ) + + WRITE( 6, 200 ) MMIN, MMAX, MM + 200 FORMAT( ' ** WARNING ** : MONTH is not within ', i2,'-', + $ i2, '. Using GFED2 biomass for month #', i2) + ENDIF + ENDIF + + ! Return to calling program + END subroutine GFED2_AVAILABLE + +!------------------------------------------------------------------------------ + + SUBROUTINE GFED2_COMPUTE_BIOMASS( THIS_YYYY, THIS_MM, BIOM_OUT ) +! +!****************************************************************************** +! Subroutine GFED2_COMPUTE_BIOMASS computes the monthly GFED2 biomass burning +! emissions for a given year and month. (psk, bmy, 4/20/06, 1/2/08) +! +! This routine has to be called on EVERY emissions-timestep if you use one +! of the GFED2 options. +! +! Arguments as Input: +! ============================================================================ +! (1 ) THIS_YYYY (INTEGER) : Current year +! (2 ) THIS_MM (INTEGER) : Current month (1-12) +! +! NOTES: +! (1 ) Now references LFUTURE from "logical_mod.f". Now call private routine +! GFED2_SCALE_FUTURE to compute future biomass emissions, if necessary. +! (swu, bmy, 5/30/06) +! (2 ) Now pass the unit string to DO_REGRID_G2G_1x1 (bmy, 8/9/06) +! (3 ) 2005 is now the last year of available data (bmy, 10/16/06) +! (4 ) 2006 is now the last year of available data (bmy, 1/2/08) +! (5 ) Biomass emissions array BIOM_OUT is now INOUT; automatically update +! BIOMASS array if needed, account for different GFED2 products: +! monthly, 8-day, 3hr, synoptic (phs, yc, psk, 12/18/08) +! (6 ) Adjust call to GFED2_AVAILABLE to reflect that monthly data for +! 2008 is now available on disk (bmy, 7/8/09) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : READ_BPCH2, GET_TAU0 + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE JULDAY_MOD, ONLY : JULDAY, CALDATE + USE LOGICAL_MOD, ONLY : LFUTURE + USE LOGICAL_MOD, ONLY : L8DAYBB, L3HRBB, LSYNOPBB, LGFED2BB + USE TIME_MOD, ONLY : EXPAND_DATE, TIMESTAMP_STRING + USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1, DO_REGRID_G2G_1x1 + USE TIME_MOD, ONLY : GET_DAY, GET_HOUR, GET_DAY_OF_YEAR + USE TIME_MOD, ONLY : ITS_A_LEAPYEAR + ! adj_group + USE ERROR_MOD, ONLY : ERROR_STOP + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: THIS_YYYY + INTEGER, INTENT(IN) :: THIS_MM + REAL*8, INTENT(INOUT) :: BIOM_OUT(IIPAR,JJPAR,N_SPEC) + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, N, N_VEG + INTEGER :: YYYY, MM, MM1, YYYY1 + INTEGER :: YYYYMMDD, HHMMSS + REAL*4 :: DM_GEN_1x1(I1x1,J1x1-1) + REAL*8 :: BIOM_GEN_1x1(I1x1,J1x1-1,N_SPEC) + REAL*8 :: BIOM_GEOS_1x1(I1x1,J1x1,N_SPEC) + REAL*8 :: TAU0, TAU1, JD8DAY + REAL*4 :: TMP + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=16 ) :: TIME_STR + INTEGER :: DD, HH, DOY + + + !================================================================= + ! GFED2_COMPUTE_BIOMASS begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + CALL INIT_GFED2_BIOMASS + FIRST = .FALSE. + + ! adj_group: kludgy check value of N_SPEC (dkh, 09/20/09). + ! Forward code should adjust N_SPEC automatically, see note (7), + ! but does not yet. N_SPEC is hardwired at the top of this + ! module. + ! Since applying TPCORE patch, maybe don't need this. +! IF ( ITS_A_TAGCO_SIM() .and. N_SPEC /= 1 ) THEN +! CALL ERROR_STOP('N_SPEC needs to be 1 for adj tag co', +! & 'GFED2_COMPUTE_BIOMASS') +! ENDIF +! IF ( ITS_A_FULLCHEM_SIM() .and. N_SPEC /= 24 ) THEN +! CALL ERROR_STOP('N_SPEC needs to be 24 for adj fullchem', +! & 'GFED2_COMPUTE_BIOMASS') +! ENDIF + + ENDIF + + ! Save in local variables + YYYY = THIS_YYYY + MM = THIS_MM + DD = GET_DAY() + HH = GET_HOUR() + DOY = GET_DAY_OF_YEAR() + + ! Check if we need to update GFED2 (phs, 18/12/08) + CALL CHECK_GFED2( DOY, HH ) + + IF ( UPDATED ) THEN + GFED2_BIOMASS = 0D0 + ELSE + BIOM_OUT = GFED2_BIOMASS + RETURN + ENDIF + + ! Echo info + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) + & 'G F E D 2 B I O M A S S B U R N I N G E M I S S I O N S' + + + !================================================================= + ! Check GFED2 availability & get YYYYMMDD of data to read. + !================================================================= + + ! Availability of 3-HR data + !------------------------------- + IF ( L3HRBB .OR. LSYNOPBB ) THEN + + CALL GFED2_AVAILABLE( YYYY, 2004, 2004, MM, 6, 9 ) + + ! Kludge until we have a full year of data: make sure that + ! DD .ne. 31 if data for MM are not available + IF ( MM /= THIS_MM ) DD = MIN( 30, DD ) + + YYYYMMDD = YYYY * 10000 + MM * 100 + DD + HHMMSS = T3HR * 10000 + + TIME_STR = TIMESTAMP_STRING( YYYYMMDD, HHMMSS ) + + WRITE( 6, 210 ) TIME_STR + 210 FORMAT( 'for 3-hr period starting: ', a16, / ) + + + ! Availability of 8-DAY data + !------------------------------- + ELSE IF ( L8DAYBB ) THEN + + CALL GFED2_AVAILABLE( YYYY, 2001, 2007 ) + + ! Get Julian day at start of 8-day period & its YYYYMMDD + JD8DAY = JULDAY( YYYY, 1, 0d0) + dble( DOY8DAY ) + CALL CALDATE( JD8DAY, YYYYMMDD, HHMMSS ) + + TIME_STR = TIMESTAMP_STRING( YYYYMMDD, 0 ) + + WRITE( 6, 310 ) TIME_STR + 310 FORMAT( 'for 8-day period starting: ', a16, / ) + + + ! Availability of MONTHLY data + !------------------------------- + ELSE IF ( LGFED2BB ) THEN + + !----------------------------------------------------------- + ! Prior to 7/8/09: + ! GFED2 2008 monthly data is now available (bmy, 7/8/09) + !CALL GFED2_AVAILABLE( YYYY, 1997, 2007 ) + !----------------------------------------------------------- + CALL GFED2_AVAILABLE( YYYY, 1997, 2008 ) + + WRITE( 6, 410 ) YYYY, MM + 410 FORMAT( 'for year and month: ', i4, '/', i2.2, / ) + + ! Create YYYYMMDD integer value + YYYYMMDD = YYYY*10000 + MM*100 + 01 + + ENDIF + + + !================================================================= + ! Filename, TAU0 and number of seconds + !================================================================= + + ! for 3-HR data + !------------------------------- + IF ( L3HRBB .OR. LSYNOPBB ) THEN + + TAU0 = GET_TAU0( MM, DD, YYYY, T3HR ) + + IF ( LSYNOPBB ) THEN + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'GFED2_3hr_200901/YYYY/' // + $ 'GFED2.synoptic.C_YYYYMM.generic.1x1' + ELSE + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'GFED2_3hr_200901/YYYY/' // + $ 'GFED2.3hr.C_YYYYMM.generic.1x1' + ENDIF + + SECONDS = 3 * 3600d0 + + + ! for 8-day data + !------------------------------- + ELSE IF (L8DAYBB) THEN + + ! get TAU0 from two JDs: start of 8-day period and 1985/1/1 + TMP = ( JD8DAY - 2446066.5d0 ) * 24e0 + TAU0 = DBLE( TMP ) + + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'GFED2_8day_200712/YYYY/' // + $ 'GFED2_8day_C_YYYYMMDD.generic.1x1' + + SECONDS = 8 * 24 * 3600d0 + + ! check for last period of the year + IF ( DOY > 360) THEN + IF ( ITS_A_LEAPYEAR( YYYY ) ) THEN + SECONDS = 6*24* 3600d0 + ELSE + SECONDS = 5*24* 3600d0 + ENDIF + ENDIF + + + ! for monthly data + !------------------------------- + ELSE IF ( LGFED2BB ) THEN + + ! TAU value at start of YYYY/MM + TAU0 = GET_TAU0( MM, 1, YYYY ) + + ! Get YYYY/MM value for next month + MM1 = MM + 1 + YYYY1 = YYYY + + ! Increment year if necessary + IF ( MM1 == 13 ) THEN + MM1 = 1 + YYYY1 = YYYY + 1 + ENDIF + + ! TAU value at start of next month + TAU1 = GET_TAU0( MM1, 1, YYYY1 ) + + ! Number of seconds in this month + ! (NOTE: its value will be saved until the next month) + SECONDS = ( TAU1 - TAU0 ) * 3600d0 + + ! File name with GFED2 C emissions + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'GFED2_200601/YYYY/GFED2_C_YYYYMM.generic.1x1' + + ENDIF + + !================================================================= + ! Read GFED2 C emissions [g/m2/month, g/m2/8-day, or g/m2/3-hr] + !================================================================= + + ! Replace YYYY/MM in the file name + CALL EXPAND_DATE( FILENAME, YYYYMMDD, 000000 ) + + ! Read GFED2 C emissions [g C/m2/month] + CALL READ_BPCH2( FILENAME, 'GFED2-BB', 99, + & TAU0, I1x1, J1x1-1, + & 1, DM_GEN_1x1, QUIET=.TRUE. ) + + !================================================================= + ! Convert C [g/m2/month] to dry matter burned [kg/cm2/month] + ! + ! Unit Conversions: + ! (1) C to DM --> Divide by 0.45 + ! (2) g to kg --> Divide by 1000 + ! (3) 1/m2 to 1/cm2 --> Divide by 10000 + !================================================================= + + ! Loop over GENERIC 1x1 GRID + DO J = 1, J1x1-1 + DO I = 1, I1x1 + + ! Set negatives to zero + DM_GEN_1x1(I,J) = MAX( DM_GEN_1x1(I,J), 0e0 ) + + ! Convert [g C/m2/month] to [kg DM/cm2/month] + DM_GEN_1x1(I,J) = DM_GEN_1x1(I,J) / ( 0.45d0 * 1d3 * 1d4 ) + + ENDDO + ENDDO + + !================================================================= + ! Calculate biomass species emissions on 1x1 emissions grid + ! + ! Emission factors convert from [kg/cm2/month] to either + ! [molec/cm2/month] or [atoms C/cm2/month] + ! + ! Units: + ! [ molec/cm2/month] : NOx, CO, CH2O, SO2, NH3, CO2 + ! [atoms C/cm2/month] : ALK4, ACET, MEK, ALD2, PRPE, C3H8, + ! C2H6, BC, OC + !================================================================= + + ! Loop over biomass species + DO N = 1, N_SPEC + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, N_VEG ) + DO J = 1, J1x1-1 + DO I = 1, I1x1 + + ! Vegetation type index + N_VEG = VEG_GEN_1x1(I,J) + + ! Multiply DM * EMISSION FACTOR to get biomass emissions + ! for each species on the GENERIC 1x1 GRID + SELECT CASE( N_VEG ) + + ! Ocean + CASE( 0 ) + BIOM_GEN_1x1(I,J,N) = 0d0 + + ! Land + CASE( 1:3 ) + BIOM_GEN_1x1(I,J,N) = DM_GEN_1x1(I,J) * + & GFED2_EMFAC(N,N_VEG) + + ! Otherwise + CASE DEFAULT + ! Nothing + + END SELECT + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Regrid each species from GENERIC 1x1 GRID to GEOS-Chem 1x1 GRID + CALL DO_REGRID_G2G_1x1( 'molec/cm2', + & BIOM_GEN_1x1(:,:,N), + & BIOM_GEOS_1x1(:,:,N) ) + ENDDO + + ! Regrid from GEOS 1x1 grid to current grid. (The unit 'molec/cm2' + ! is just used to denote that the quantity is per unit area.) + CALL DO_REGRID_1x1( N_SPEC, 'molec/cm2', + & BIOM_GEOS_1x1, GFED2_BIOMASS ) + + ! Compute future biomass emissions (if necessary) + IF ( LFUTURE ) THEN + CALL GFED2_SCALE_FUTURE( GFED2_BIOMASS ) + ENDIF + + ! Print totals in Tg/month + CALL GFED2_TOTAL_Tg( THIS_YYYY, THIS_MM ) + + ! Convert from [molec/cm2/month], [molec/cm2/8day] or + ! [molec/cm2/3hr] to [molec/cm2/s] + GFED2_BIOMASS = GFED2_BIOMASS / SECONDS + + ! set output + BIOM_OUT = GFED2_BIOMASS + + ! Echo info + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Return to calling program + END SUBROUTINE GFED2_COMPUTE_BIOMASS + +!------------------------------------------------------------------------------ + + SUBROUTINE GFED2_SCALE_FUTURE( BB ) +! +!****************************************************************************** +! Subroutine GFED2_SCALE_FUTURE applies the IPCC future emissions scale +! factors to the GFED2 biomass burning emisisons in order to compute the +! future emissions of biomass burning for NOx, CO, and VOC's. +! (swu, bmy, 5/30/06, 9/25/06) +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) BB (REAL*8) : Array w/ biomass burning emisisons [molec/cm2] +! +! NOTES: +! (1 ) Now scale to IPCC future scenario for BC, OC, SO2, NH3 (bmy, 9/25/03) +!****************************************************************************** +! + ! References to F90 modules + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_BCbb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_CObb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NH3bb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NOxbb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_OCbb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_SO2bb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_VOCbb + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM + USE TRACER_MOD, ONLY : ITS_A_CO2_SIM + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*8, INTENT(INOUT) :: BB(IIPAR,JJPAR,N_SPEC) + + ! Local variables + LOGICAL :: ITS_CO2 + LOGICAL :: ITS_CH4 + INTEGER :: I, J, N + + !================================================================= + ! GFED2_SCALE_FUTURE begins here! + !================================================================= + + ! Test if it's a CO2 simulation outside of the loop + ITS_CO2 = ITS_A_CO2_SIM() + ITS_CH4 = ITS_A_CH4_SIM() + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, N ) + + ! Loop over species and grid boxes + DO N = 1, N_SPEC + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Scale each species to IPCC future scenario + IF ( N == IDBNOx ) THEN + + ! Future biomass NOx [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_NOxbb( I, J ) + + ELSE IF ( N == IDBCO ) THEN + + ! Future biomass CO [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_CObb( I, J ) + + ELSE IF ( N == IDBSO2 ) THEN + + ! Future biomass SO2 [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_SO2bb( I, J ) + + ELSE IF ( N == IDBNH3 ) THEN + + ! Future biomass NH3 [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_NH3bb( I, J ) + + ELSE IF ( N == IDBBC ) THEN + + ! Future biomass BC [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_BCbb( I, J ) + + ELSE IF ( N == IDBOC ) THEN + + ! Future biomass OC [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_OCbb( I, J ) + + ELSE IF ( ITS_CO2 .OR. ITS_CH4 ) THEN + + ! Nothing + + ELSE + + ! Future biomass Hydrocarbons [atoms C/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_VOCbb( I, J ) + + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE GFED2_SCALE_FUTURE + +!------------------------------------------------------------------------------ + + SUBROUTINE GFED2_TOTAL_Tg( YYYY, MM ) +! +!****************************************************************************** +! Subroutine TOTAL_BIOMASS_TG prints the amount of biomass burning emissions +! that are emitted each month/8-day/3-hr in Tg or Tg C. (bmy, 3/20/01, +! 12/23/08) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYY (INTEGER) : Current year +! (2 ) MM (INTEGER) : Currrent month +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_AREA_CM2 + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYY, MM + + ! Local variables + INTEGER :: I, J, N + REAL*8 :: CONV, MOLWT, TOTAL + CHARACTER(LEN=4) :: NAME + CHARACTER(LEN=6) :: UNIT + + !================================================================= + ! GFED2_TOTAL_Tg begins here! + !================================================================= + + ! Loop over biomass species + DO N = 1, N_SPEC + + ! Initialize + NAME = GFED2_SPEC_NAME(N) + MOLWT = GFED2_SPEC_MOLWT(N) + UNIT = GFED2_SPEC_UNIT(N) + TOTAL = 0d0 + + ! Loop over latitudes + DO J = 1, JJPAR + + ! Convert to [Tg/gfed-period] (or [Tg C/gfed-period] for HC's) + CONV = GET_AREA_CM2( J ) * ( MOLWT / 6.023d23 ) * 1d-9 + + ! Loop over longitudes + DO I = 1, IIPAR + TOTAL = TOTAL + ( GFED2_BIOMASS(I,J,N) * CONV ) + ENDDO + ENDDO + + ! Write totals + WRITE( 6, 110 ) NAME, TOTAL, UNIT + 110 FORMAT( 'Sum Biomass ', a4, 1x, ': ', f9.4, 1x, a6 ) + ENDDO + + ! Return to calling program + END SUBROUTINE GFED2_TOTAL_Tg + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_GFED2_BIOMASS +! +!****************************************************************************** +! Subroutine INIT_GFED2_BIOMASS allocates all module arrays. It also reads +! the emission factors and vegetation map files at the start of a GEOS-Chem +! simulation. (psk, bmy, 4/20/06, 9/25/06) +! +! NOTES: +! (1 ) Now initialize for BC, OC, SO2, NH3, CO2 (bmy, 9/25/06) +! (2 ) Bug fix: IDBSO2, IDBNH3, IDBOC, and IDBCO2 are correctly +! set (phs, 3/18/08) +! (3 ) Add 9 gaseous biomass burning emissions (tmf, 1/7/09) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE ERROR_MOD, ONLY : ALLOC_ERR + USE FILE_MOD, ONLY : IOERROR, IU_FILE + USE LOGICAL_MOD, ONLY : LDICARB + + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: AS, IOS, M, N, NDUM + REAL*4 :: ARRAY(I1x1,J1x1-1,1) + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! INIT_GFED2_BIOMASS begins here! + !================================================================= + + ! Allocate array to hold emissions + ALLOCATE( GFED2_BIOMASS( IIPAR, JJPAR, N_SPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GFED2_BIOMASS' ) + GFED2_BIOMASS = 0d0 + + ! Allocate array for emission factors + ALLOCATE( GFED2_EMFAC( N_SPEC, N_EMFAC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GFED2_EMFAC' ) + GFED2_EMFAC = 0d0 + + ! Allocate array for species molecular weight + ALLOCATE( GFED2_SPEC_MOLWT( N_SPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GFED2_SPEC_MOLWT' ) + GFED2_SPEC_MOLWT = 0d0 + + ! Allocate array for species name + ALLOCATE( GFED2_SPEC_NAME( N_SPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GFED2_SPEC_NAME' ) + GFED2_SPEC_NAME = '' + + ! Allocate array for species molecular weight + ALLOCATE( GFED2_SPEC_UNIT( N_SPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GFED2_SPEC_UNIT' ) + GFED2_SPEC_UNIT = '' + + ! Allocate array for vegetation map + ALLOCATE( VEG_GEN_1x1( I1x1, J1x1-1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'VEG_GEN_1x1' ) + + ! Set default values for module variables + T3HR = -1 + DOY8DAY = -1 + + !================================================================= + ! Read emission factors (which convert from kg DM to + ! either [molec species] or [atoms C]) from bpch file + !================================================================= + + ! File name + FILENAME = TRIM( DATA_DIR_1x1) // + & 'GFED2_200601/GFED2_emission_factors_73t.txt' + + ! Open emission factor file (ASCII format) + OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'init_gfed2:1' ) + + ! Skip header lines + DO N = 1, 6 + READ( IU_FILE, *, IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'init_gfed2:2' ) + ENDDO + + ! Read emission factors for each species + DO N = 1, N_SPEC + READ( IU_FILE, 100, IOSTAT=IOS ) + & NDUM, GFED2_SPEC_NAME(N), ( GFED2_EMFAC(N,M), M=1,N_EMFAC ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'init_gfed2:3' ) + ENDDO + + ! FORMAT string + 100 FORMAT( 1x, i2, 1x, a4, 3(3x,es14.6) ) + + ! Close file + CLOSE( IU_FILE ) + + !================================================================= + ! Read GFED2 vegetation map from bpch file + ! + ! Values: 3 = boreal forest + ! 2 = tropical forest; + ! 1 = savanna / herb / other land + ! 0 = water + !================================================================= + + ! File name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'GFED2_200601/GFED2_vegmap.generic.1x1' + + ! Read GFED2 veg map + CALL READ_BPCH2( FILENAME, 'LANDMAP', 1, + & 0d0, I1x1, J1x1-1, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast from REAL*4 to INTEGER + VEG_GEN_1x1(:,:) = ARRAY(:,:,1) + + !================================================================= + ! Define local ID flags and arrays for the names, units, + ! and molecular weights of the GFED2 biomass species + !================================================================= + + ! Initialize + IDBNOx = 0 + IDBCO = 0 + IDBALK4 = 0 + IDBACET = 0 + IDBMEK = 0 + IDBALD2 = 0 + IDBPRPE = 0 + IDBC3H8 = 0 + IDBCH2O = 0 + IDBC2H6 = 0 + IDBBC = 0 + IDBOC = 0 + IDBSO2 = 0 + IDBNH3 = 0 + IDBCO2 = 0 + IDBGLYX = 0 + IDBMGLY = 0 + IDBBENZ = 0 + IDBTOLU = 0 + IDBXYLE = 0 + IDBC2H4 = 0 + IDBC2H2 = 0 + IDBGLYC = 0 + IDBHAC = 0 + IDBCH4 = 0 + + ! Save species # in IDBxxxx flags for future reference + ! and also initialize arrays for mol wts and units + DO N = 1, N_SPEC + SELECT CASE ( TRIM( GFED2_SPEC_NAME(N) ) ) + CASE( 'NOx' ) + IDBNOx = N + GFED2_SPEC_MOLWT(N) = 14d-3 + GFED2_SPEC_UNIT(N) = '[Tg N]' + CASE( 'CO' ) + IDBCO = N + GFED2_SPEC_MOLWT(N) = 28d-3 + GFED2_SPEC_UNIT(N) = '[Tg ]' + CASE( 'ALK4' ) + IDBALK4 = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'ACET' ) + IDBACET = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'MEK' ) + IDBMEK = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'ALD2' ) + IDBALD2 = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'PRPE' ) + IDBPRPE = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'C3H8' ) + IDBC3H8 = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'CH2O' ) + IDBCH2O = N + GFED2_SPEC_MOLWT(N) = 30d-3 + GFED2_SPEC_UNIT(N) = '[Tg ]' + CASE( 'C2H6' ) + IDBC2H6 = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'SO2' ) + IDBSO2 = N + GFED2_SPEC_MOLWT(N) = 64d-3 + GFED2_SPEC_UNIT(N) = '[Tg ]' + CASE( 'NH3' ) + IDBNH3 = N + GFED2_SPEC_MOLWT(N) = 17d-3 + GFED2_SPEC_UNIT(N) = '[Tg ]' + CASE( 'BC' ) + IDBBC = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'OC' ) + IDBOC = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'GLYX' ) + IDBGLYX = N + GFED2_SPEC_MOLWT(N) = 58d-3 + GFED2_SPEC_UNIT(N) = '[Tg ]' + CASE( 'MGLY' ) + IDBMGLY = N + GFED2_SPEC_MOLWT(N) = 72d-3 + GFED2_SPEC_UNIT(N) = '[Tg ]' + CASE( 'BENZ' ) + IDBBENZ = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'TOLU' ) + IDBTOLU = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'XYLE' ) + IDBXYLE = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'C2H4' ) + IDBC2H4 = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'C2H2' ) + IDBC2H2 = N + GFED2_SPEC_MOLWT(N) = 12d-3 + GFED2_SPEC_UNIT(N) = '[Tg C]' + CASE( 'GLYC' ) + IDBGLYC = N + GFED2_SPEC_MOLWT(N) = 60d-3 + GFED2_SPEC_UNIT(N) = '[Tg ]' + CASE( 'HAC' ) + IDBHAC = N + GFED2_SPEC_MOLWT(N) = 74d-3 + GFED2_SPEC_UNIT(N) = '[Tg ]' + CASE( 'CO2' ) + IDBCO2 = N + GFED2_SPEC_MOLWT(N) = 44d-3 + GFED2_SPEC_UNIT(N) = '[Tg ]' + CASE( 'CH4' ) + IDBCH4 = N + GFED2_SPEC_MOLWT(N) = 16d-3 + GFED2_SPEC_UNIT(N) = '[Tg ]' + CASE DEFAULT + WRITE(*,*) 'NAME',TRIM( GFED2_SPEC_NAME(N) ) + END SELECT + ENDDO + + ! Return to calling program + END SUBROUTINE INIT_GFED2_BIOMASS + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_GFED2_BIOMASS +! +!****************************************************************************** +! Subroutine CLEANUP_GFED2_BIOMASS deallocates all module arrays. +! (psk, bmy, 4/20/06) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_GFED2_BIOMASS begins here! + !================================================================= + IF ( ALLOCATED( GFED2_EMFAC ) ) DEALLOCATE( GFED2_EMFAC ) + IF ( ALLOCATED( GFED2_SPEC_MOLWT ) ) DEALLOCATE( GFED2_SPEC_MOLWT) + IF ( ALLOCATED( GFED2_SPEC_NAME ) ) DEALLOCATE( GFED2_SPEC_NAME ) + IF ( ALLOCATED( VEG_GEN_1x1 ) ) DEALLOCATE( VEG_GEN_1x1 ) + IF ( ALLOCATED( GFED2_BIOMASS ) ) DEALLOCATE( GFED2_BIOMASS ) + + ! Return to calling program + END SUBROUTINE CLEANUP_GFED2_BIOMASS + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE GFED2_BIOMASS_MOD diff --git a/code/gfed3_biomass_mod.f b/code/gfed3_biomass_mod.f new file mode 100644 index 0000000..eec6c77 --- /dev/null +++ b/code/gfed3_biomass_mod.f @@ -0,0 +1,2033 @@ +!------------------------------------------------------------------------------ +! Prasad Kasibhatla - Duke University ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: gfed3_biomass_mod +! +! !DESCRIPTION: Module GFED3\_BIOMASS\_MOD contains routines and variables +! used to incorporate GFED3 emissions into GEOS-Chem +!\\ +!\\ +! !INTERFACE: +! + MODULE GFED3_BIOMASS_MOD +! +! !USES: +! + IMPLICIT NONE +# include "define.h" + PRIVATE + +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: GFED3_COMPUTE_BIOMASS + PUBLIC :: CLEANUP_GFED3_BIOMASS + PUBLIC :: GFED3_IS_NEW +! +! PRIVATE MEMBER FUNCTIONS: +! + PRIVATE :: CHECK_GFED3 + PRIVATE :: GFED3_AVAILABLE + PRIVATE :: GFED3_SCALE_FUTURE + PRIVATE :: GFED3_TOTAL_Tg + PRIVATE :: INIT_GFED3_BIOMASS + PRIVATE :: REARRANGE_BIOM + PRIVATE :: GRID_GFED3 + PRIVATE :: YMAP_GFED3 + PRIVATE :: XMAP_GFED3 + PRIVATE :: READ_BPCH2_GFED3 +! +! !REMARKS: +! Monthly emissions of DM are read from disk, +! multiplied by daily and 3hourly fractions (if necessary), and then +! multiplied by the appropriate emission factors to produce biomass +! burning emissions on the GFED3 0.5x0.5 degree grid The emissions are +! then regridded to the current GEOS-Chem or GCAP grid (1x1, 2x25, or 4x5). +! . +! GFED3 biomass burning emissions are computed for the following gas-phase +! and aerosol-phase species: +! . +! (1 ) NOx [ molec/cm2/s] (13) BC [atoms C/cm2/s] +! (2 ) CO [ molec/cm2/s] (14) OC [atoms C/cm2/s] +! (3 ) ALK4 [atoms C/cm2/s] (15) GLYX [ molec/cm2/s] +! (4 ) ACET [atoms C/cm2/s] (16) MGLY [ molec/cm2/s] +! (5 ) MEK [atoms C/cm2/s] (17) BENZ [atoms C/cm2/s] +! (6 ) ALD2 [atoms C/cm2/s] (18) TOLU [atoms C/cm2/s] +! (7 ) PRPE [atoms C/cm2/s] (19) XYLE [atoms C/cm2/s] +! (8 ) C3H8 [atoms C/cm2/s] (20) C2H4 [atoms C/cm2/s] +! (9 ) CH2O [ molec/cm2/s] (21) C2H2 [atoms C/cm2/s] +! (10) C2H6 [atoms C/cm2/s] (22) GLYC [ molec/cm2/s] +! (11) SO2 [ molec/cm2/s] (23) HAC [ molec/cm2/s] +! (12) NH3 [ molec/cm2/s] (24) CO2 [ molec/cm2/s] +! (25) CH4 [ molec/cm2/s] +! . +! References: +! ============================================================================ +! (1 ) Original GFED3 database from Guido van der Werf +! http://www.falw.vu/~gwerf/GFED/GFED3/emissions/ +! (2 ) Giglio, L., Randerson, J. T., van der Werf, G. R., Kasibhatla, P. S., +! Collatz, G. J., Morton, D. C., and DeFries, R. S.: Assessing +! variability and long-term trends in burned area by merging multiple +! satellite fire products, Biogeosciences, 7, 1171-1186, +! doi:10.5194/bg-7-1171-2010, 2010. +! (3 ) van der Werf, G. R., Randerson, J. T., Giglio, L., Collatz, G. J., +! Mu, M., Kasibhatla, P. S., Morton, D. C., DeFries, R. S., Jin, Y., +! and van Leeuwen, T. T.: Global fire emissions and the contribution of +! deforestation, savanna, forest, agricultural, and peat fires +! (1997–2009), Atmos. Chem. Phys., 10, 11707-11735, +! doi:10.5194/acp-10-11707-2010, 2010. +! +! !REVISION HISTORY: +! 07 Sep 2011 - P. Kasibhatla - Initial version, based on GFED2 +! 07 Sep 2011 - R. Yantosca - Added ProTeX headers +! 14 Feb 2012 - M. Payer - Add modifications for CH4 (K. Wecht) +! 06 Mar 2012 - P. Kasibhatla - Final version +! 25 Jul 2012 - M. Payer - Modified for the GC adjoint +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !DEFINED PARAMETERS: +! + !================================================================= + ! MODULE PARAMETERS + ! + ! N_EMFAC : Number of emission factors per species + ! N_SPEC : Number of species + !================================================================= + INTEGER, PARAMETER :: N_EMFAC = 6 + INTEGER, PARAMETER :: N_SPEC = 25 ! add CH4, kjw +! +! PRIVATE TYPES: +! + !================================================================= + ! MODULE VARIABLES: + ! + ! Scalars + ! + ! T3HR : HH at start of the current 3-hr period. + ! UPDATED : flag to indicate if GFED3 emissions are updated + ! UPDATED_MON : flag to indicate if new month + ! UPDATED_DAY : flag to indicate if new day + ! - only set to true if daily emissions are used + ! UPDATED_3HR : flag to indicate if new 3-hour period + ! - only set to true if 3-hourly emissions are used + ! SECONDS : Number of seconds in the current month + ! + ! Arrays + ! + ! GFED3_SPEC_NAME : Array for GFED3 biomass species names + ! GFED3_SPEC_MOLWT: Array for GFED3 biomass species molecular wts + ! GFED3_SPEC_UNIT : Array for GFED3 biomass species emissions units + ! GFED3_EMFAC : Array for user-defined emission factors + ! DM_GFED3_MON : Array for monthly GFED3 DM burnt GFED3 grid + ! DM_GFED3_DAY : Array for daily GFED3 DM burnt on GFED3 grid + ! FR_GFED3_3HR : Array for 3hourly fractions on GFED3 grid + ! HUMTROP_GFED3 : Array for GFED3 0.5x0.5 humid trop forest map + ! BIOMASS_MODEL : Array for GFED3 species emissions on model grid + ! BIO_SAVE : Index array to store IDBxxx values + ! XEDGE_GFED3 : Array for lon edges of GFED3 grid + ! YEDGE_GFED3 : Array for sin of at edges of GFED3 grid + ! XEDGE_MODELG : Array for lat edges of global grid at model res + ! YEDGE_MODELG : Array for sin of lat edges of global grid at model res + !================================================================= + + ! Scalars + INTEGER :: IDBNOx, IDBCO, IDBALK4 + INTEGER :: IDBACET, IDBMEK, IDBALD2 + INTEGER :: IDBPRPE, IDBC3H8, IDBCH2O + INTEGER :: IDBC2H6, IDBBC, IDBOC + INTEGER :: IDBSO2, IDBNH3, IDBCO2 + INTEGER :: IDBBENZ, IDBTOLU, IDBXYLE + INTEGER :: IDBC2H2, IDBC2H4, IDBGLYX + INTEGER :: IDBMGLY, IDBGLYC, IDBHAC + INTEGER :: IDBCH4 + LOGICAL :: UPDATED + LOGICAL :: UPDATED_MON + LOGICAL :: UPDATED_DAY + LOGICAL :: UPDATED_3HR + INTEGER :: T3HR + REAL*8 :: SECONDS + INTEGER :: IIIPAR0 + INTEGER :: JJJPAR0 + + ! Arrays + CHARACTER(LEN=4), ALLOCATABLE :: GFED3_SPEC_NAME(:) + REAL*8, ALLOCATABLE :: GFED3_SPEC_MOLWT(:) + CHARACTER(LEN=6), ALLOCATABLE :: GFED3_SPEC_UNIT(:) + REAL*8, ALLOCATABLE :: GFED3_EMFAC(:,:) + REAL*8, ALLOCATABLE :: DM_GFED3_MON(:,:,:) + REAL*8, ALLOCATABLE :: DM_GFED3_DAY(:,:,:) + REAL*4, ALLOCATABLE :: FR_GFED3_3HR(:,:,:) + INTEGER, ALLOCATABLE :: HUMTROP_GFED3(:,:) + REAL*8, ALLOCATABLE :: BIOMASS_MODEL(:,:,:) + INTEGER, ALLOCATABLE :: BIO_SAVE(:) + REAL*8, ALLOCATABLE :: XEDGE_GFED3(:) + REAL*8, ALLOCATABLE :: YEDGE_GFED3(:) + REAL*8, ALLOCATABLE :: XEDGE_MODELG(:) + REAL*8, ALLOCATABLE :: YEDGE_MODELG(:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: gfed3_is_new +! +! !DESCRIPTION: Function GFED3\_IS\_NEW returns TRUE if GFED3 emissions +! have been updated. +!\\ +!\\ +! !INTERFACE: +! + FUNCTION GFED3_IS_NEW( ) RESULT( IS_UPDATED ) +! +! !RETURN VALUE: +! + LOGICAL :: IS_UPDATED ! =T if GFED3 is updated; =F otherwise +! +! !REMARKS: +! Called from carbon_mod.f and sulfate_mod.f +! +! !REVISION HISTORY: +! 07 Sep 2011 - P. Kasibhatla - Initial version, based on GFED2 +! 07 Sep 2011 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC + IS_UPDATED = UPDATED + + END FUNCTION GFED3_IS_NEW +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: check_gfed3 +! +! !DESCRIPTION: Subroutine CHECK\_GFED3 checks if we entered a new GFED period +! since last emission timestep (ie, last call). The result depends +! on the emissions time step, and the GFED time period used, as well +! as MMDDHH at beginning of the GEOS-Chem run +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE CHECK_GFED3( DOY, HH ) +! +! !USES: +! + USE LOGICAL_MOD, ONLY : LDAYBB3 + USE LOGICAL_MOD, ONLY : L3HRBB3 + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH + USE TIME_MOD, ONLY : ITS_A_NEW_DAY +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: DOY ! Day of year (0-365 or 0-366 leap years) + INTEGER, INTENT(IN) :: HH ! Hour of day (0-23) +! +! !REMARKS: +! The routine computes the DOY (resp. HOUR) at start of the 1-day (resp. +! 3-hour) period we are in, if the 1-day (resp. 3-hr ) GFED3 +! option is on. Result is compared to previous value to indicate if new +! data should be read. +! +! !REVISION HISTORY: +! 07 Sep 2011 - P. Kasibhatla - Initial version, based on GFED2 +! 07 Sep 2011 - R. Yantosca - Added ProTeX headers +! 06 Mar 2012 - P. Kasibhatla - final GFED3 version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: NEW_T3HR + + ! Reset to default + UPDATED = .FALSE. + UPDATED_MON = .FALSE. + UPDATED_DAY = .FALSE. + UPDATED_3HR = .FALSE. + + ! Check if it is a new month + IF ( ITS_A_NEW_MONTH() ) THEN + UPDATED = .TRUE. + UPDATED_MON = .TRUE. + ENDIF + + ! Check if it is a new day + IF ( LDAYBB3 ) THEN + IF ( ITS_A_NEW_DAY() ) THEN + UPDATED = .TRUE. + UPDATED_DAY = .TRUE. + ENDIF + ENDIF + + ! Check if it is a new 3-hr period + IF ( L3HRBB3 ) THEN + + NEW_T3HR = INT( HH / 3 ) * 3 + + IF ( NEW_T3HR .NE. T3HR ) THEN + UPDATED = .TRUE. + UPDATED_3HR = .TRUE. + T3HR = NEW_T3HR + ENDIF + ENDIF + + END SUBROUTINE CHECK_GFED3 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: gfed3_available +! +! !DESCRIPTION: Function GFED3\_AVAILABLE checks an input YYYY year and MM +! month against the available data dates. If the requested YYYY and MM +! lie outside of the valid range of dates, then GFED3\_AVAILABLE will return +! the last valid YYYY and MM. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GFED3_AVAILABLE( YYYY, YMIN, YMAX, MM, MMIN, MMAX ) +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: YMIN, YMAX ! Min & max years + INTEGER, INTENT(IN), OPTIONAL :: MMIN, MMAX ! Min & max months +! +! !INPUT/OUTPUT PARAMETERS: +! + INTEGER, INTENT(INOUT) :: YYYY ! Year of GFED3 data + INTEGER, INTENT(INOUT), OPTIONAL :: MM ! Month of GFED3 data +! +! !REVISION HISTORY: +! 07 Sep 2011 - P. Kasibhatla - Initial version, based on GFED2 +! 07 Sep 2011 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC + + ! Check year + IF ( YYYY > YMAX .OR. YYYY < YMIN ) THEN + + YYYY = MAX( YMIN, MIN( YYYY, YMAX) ) + + WRITE( 6, 100 ) YMAX, YMIN, YYYY + 100 FORMAT( 'YEAR > ', i4, ' or YEAR < ', i4, + $ '. Using GFED3 biomass for ', i4) + ENDIF + + + ! Check month + IF ( PRESENT( MM ) ) THEN + IF ( MM > MMAX .OR. MM < MMIN ) THEN + + MM = MAX( MMIN, MIN( MM, MMAX) ) + + WRITE( 6, 200 ) MMIN, MMAX, MM + 200 FORMAT( ' ** WARNING ** : MONTH is not within ', i2,'-', + $ i2, '. Using GFED3 biomass for month #', i2) + ENDIF + ENDIF + + END SUBROUTINE GFED3_AVAILABLE +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: gfed3_compute_biomass +! +! !DESCRIPTION: Subroutine GFED3\_COMPUTE\_BIOMASS computes the monthly +! GFED3 biomass burning emissions for a given year and month. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GFED3_COMPUTE_BIOMASS( THIS_YYYY, THIS_MM, BIOM_OUT ) +! +! !USES: +! + USE BPCH2_MOD, ONLY : GET_TAU0 + USE DIRECTORY_MOD, ONLY : DATA_DIR_NATIVE => DATA_DIR_1x1 + USE JULDAY_MOD, ONLY : JULDAY + USE JULDAY_MOD, ONLY : CALDATE + USE LOGICAL_MOD, ONLY : LFUTURE + USE LOGICAL_MOD, ONLY : LDAYBB3 + USE LOGICAL_MOD, ONLY : L3HRBB3 + USE LOGICAL_MOD, ONLY : LGFED3BB + USE TIME_MOD, ONLY : EXPAND_DATE + USE TIME_MOD, ONLY : TIMESTAMP_STRING + USE TIME_MOD, ONLY : GET_DIRECTION + USE TIME_MOD, ONLY : GET_DAY + USE TIME_MOD, ONLY : GET_HOUR + USE TIME_MOD, ONLY : GET_DAY_OF_YEAR + USE TIME_MOD, ONLY : ITS_A_LEAPYEAR + USE GRID_MOD, ONLY : GET_IIIPAR + USE GRID_MOD, ONLY : GET_JJJPAR + USE GRID_MOD, ONLY : GET_XEDGE_G + USE GRID_MOD, ONLY : GET_YEDGE_G + USE GRID_MOD, ONLY : GET_XOFFSET + USE GRID_MOD, ONLY : GET_YOFFSET + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" ! Size parameters +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: THIS_YYYY ! Current year + INTEGER, INTENT(IN) :: THIS_MM ! Current month +! +! !OUTPUT PARAMETERS: +! + REAL*8, INTENT(INOUT) :: BIOM_OUT(IIPAR,JJPAR,N_SPEC) ! BB emissions + ! [molec/cm2/s] +! +! !REMARKS: +! This routine has to be called on EVERY emissions-timestep if you use one +! of the GFED3 options. +! +! +! !REVISION HISTORY: +! 07 Sep 2011 - P. Kasibhatla - Initial version, based on GFED2 +! 07 Sep 2011 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, N, NF , IT3 + INTEGER :: AS + INTEGER :: II, JJ + INTEGER :: I0, J0 + INTEGER :: YYYY, MM, MM1, YYYY1 + INTEGER :: YYYYMMDD, HHMMSS + REAL*8 :: GFED3_EMFACX + REAL*4 :: ARRAY_GFED3(IGFED3, JGFED3, 1) + REAL*4 :: FR_GFED3_DAY(IGFED3, JGFED3) + REAL*8 :: DM_GFED3(IGFED3, JGFED3, N_EMFAC) + REAL*8 :: BIOMASS_GFED3(IGFED3, JGFED3, N_SPEC) + REAL*8 :: TAU0, TAU1 + REAL*4 :: TMP + CHARACTER(LEN=255) :: FILENAME1 + CHARACTER(LEN=255) :: FILENAME2 + CHARACTER(LEN=255) :: FILENAME3 + CHARACTER(LEN=255) :: FILENAME4 + CHARACTER(LEN=255) :: FILENAME5 + CHARACTER(LEN=255) :: FILENAME6 + CHARACTER(LEN=255) :: FILENAME7 + CHARACTER(LEN=255) :: FILENAME8 + CHARACTER(LEN=16 ) :: TIME_STR + INTEGER :: DD, HH, DOY + INTEGER :: IT3HR, IT3H + REAL*4 :: DEG2RAD + REAL*4, ALLOCATABLE :: bq1(:,:) + REAL*4, ALLOCATABLE :: bq2(:,:) + + !================================================================= + ! GFED3_COMPUTE_BIOMASS begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + IIIPAR0 = GET_IIIPAR() + JJJPAR0 = GET_JJJPAR() + CALL INIT_GFED3_BIOMASS + + DEG2RAD = (4. * ATAN(1.) ) /180. + + ! Define GFED3 grid box lat and lon edges + XEDGE_GFED3( 1 ) = -180.d0 + DO I = 2,IGFED3+1 + XEDGE_GFED3( I ) = XEDGE_GFED3( I-1 ) + 5.d-1 + END DO + + YEDGE_GFED3( 1 ) = -90.d0 + DO J = 2, JGFED3+1 + YEDGE_GFED3( J ) = YEDGE_GFED3( J-1 ) + 5.d-1 + END DO + + DO J = 1,JGFED3+1 + YEDGE_GFED3( J ) = SIN( YEDGE_GFED3( J ) * DEG2RAD) + END DO + + ! Define global grid box lat and lon edges at model resolution + + DO I = 1,IIIPAR0+1 + XEDGE_MODELG( I ) = GET_XEDGE_G ( I ) + END DO + + DO J = 1,JJJPAR0+1 + YEDGE_MODELG( J ) = GET_YEDGE_G ( J ) + END DO + + DO J = 1,JJJPAR0+1 + YEDGE_MODELG( J ) = SIN( YEDGE_MODELG( J ) * DEG2RAD) + END DO + + FIRST = .FALSE. + + ENDIF + + ! Save in local variables + YYYY = THIS_YYYY + MM = THIS_MM + DD = GET_DAY() + HH = GET_HOUR() + DOY = GET_DAY_OF_YEAR() + + ! Check if we need to update GFED3 + CALL CHECK_GFED3( DOY, HH ) + + ! If no updating is needed, module variable BIOMASS_MODEL + ! from last update can be used + IF ( .not. UPDATED ) THEN + !CALL REARRANGE_BIOM(BIOMASS_MODEL,BIOM_OUT) + BIOM_OUT = BIOMASS_MODEL + RETURN + ENDIF + + ! If within same month, no nead to reread emission file. + ! But go to statement 999 to check if daily fractiions + ! need to be read. + IF ( .not. UPDATED_MON ) THEN + go to 999 + ENDIF + + ! Echo info + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) + & 'G F E D 3 B I O M A S S B U R N I N G E M I S S I O N S' + + + !================================================================= + ! Check GFED3 availability & get YYYYMMDD of data to read. + !================================================================= + + ! Availability of MONTHLY data + !------------------------------- + + CALL GFED3_AVAILABLE( YYYY, 1997, 2011 ) + + ! Create YYYYMMDD integer values + YYYYMMDD = YYYY*10000 + MM*100 + 01 + + !================================================================= + ! Filename, TAU0 and number of seconds + !================================================================= + + ! for monthly data + !------------------------------- + ! TAU value at start of YYYY/MM + TAU0 = GET_TAU0( MM, 1, YYYY ) + + ! Get YYYY/MM value for next month + MM1 = MM + 1 + YYYY1 = YYYY + + ! Increment year if necessary + IF ( MM1 == 13 ) THEN + MM1 = 1 + YYYY1 = YYYY + 1 + ENDIF + + ! TAU value at start of next month + TAU1 = GET_TAU0( MM1, 1, YYYY1 ) + + ! Number of seconds in this month + ! (NOTE: its value will be saved until the next month) + SECONDS = ( TAU1 - TAU0 ) * 3600d0 + + ! File name with GFED3 DM emissions + FILENAME1 = TRIM( DATA_DIR_NATIVE ) // + & 'GFED3_201212/YYYY/Monthly/GFED3_DM_AGW_YYYYMM' + FILENAME2 = TRIM( DATA_DIR_NATIVE ) // + & 'GFED3_201212/YYYY/Monthly/GFED3_DM_DEF_YYYYMM' + FILENAME3 = TRIM( DATA_DIR_NATIVE ) // + & 'GFED3_201212/YYYY/Monthly/GFED3_DM_FOR_YYYYMM' + FILENAME4 = TRIM( DATA_DIR_NATIVE ) // + & 'GFED3_201212/YYYY/Monthly/GFED3_DM_PET_YYYYMM' + FILENAME5 = TRIM( DATA_DIR_NATIVE ) // + & 'GFED3_201212/YYYY/Monthly/GFED3_DM_SAV_YYYYMM' + FILENAME6 = TRIM( DATA_DIR_NATIVE ) // + & 'GFED3_201212/YYYY/Monthly/GFED3_DM_WDL_YYYYMM' + + !================================================================= + ! Read GFED3 DM burnt [g/m2/month] + !================================================================= + + ! Replace YYYY/MM in the file name + CALL EXPAND_DATE( FILENAME1, YYYYMMDD, 000000 ) + CALL EXPAND_DATE( FILENAME2, YYYYMMDD, 000000 ) + CALL EXPAND_DATE( FILENAME3, YYYYMMDD, 000000 ) + CALL EXPAND_DATE( FILENAME4, YYYYMMDD, 000000 ) + CALL EXPAND_DATE( FILENAME5, YYYYMMDD, 000000 ) + CALL EXPAND_DATE( FILENAME6, YYYYMMDD, 000000 ) + + ! Read GFED3 DM emissions [g DM/m2/month] in the following order + ! AGW, DEF, FOR, PET, SAV, WDL + CALL READ_BPCH2_GFED3( FILENAME1, 'GFED3-BB', 91, + & TAU0, IGFED3, JGFED3, + & 1, ARRAY_GFED3, QUIET=.TRUE. ) + + DM_GFED3_MON(:,:,1) = ARRAY_GFED3(:,:,1) + + CALL READ_BPCH2_GFED3( FILENAME2, 'GFED3-BB', 92, + & TAU0, IGFED3, JGFED3, + & 1, ARRAY_GFED3, QUIET=.TRUE. ) + + DM_GFED3_MON(:,:,2) = ARRAY_GFED3(:,:,1) + + CALL READ_BPCH2_GFED3( FILENAME3, 'GFED3-BB', 93, + & TAU0, IGFED3, JGFED3, + & 1, ARRAY_GFED3, QUIET=.TRUE. ) + + DM_GFED3_MON(:,:,3) = ARRAY_GFED3(:,:,1) + + CALL READ_BPCH2_GFED3( FILENAME4, 'GFED3-BB', 94, + & TAU0, IGFED3, JGFED3, + & 1, ARRAY_GFED3, QUIET=.TRUE. ) + + DM_GFED3_MON(:,:,4) = ARRAY_GFED3(:,:,1) + + CALL READ_BPCH2_GFED3( FILENAME5, 'GFED3-BB', 95, + & TAU0, IGFED3, JGFED3, + & 1, ARRAY_GFED3, QUIET=.TRUE. ) + + DM_GFED3_MON(:,:,5) = ARRAY_GFED3(:,:,1) + + CALL READ_BPCH2_GFED3( FILENAME6, 'GFED3-BB', 96, + & TAU0, IGFED3, JGFED3, + & 1, ARRAY_GFED3, QUIET=.TRUE. ) + + DM_GFED3_MON(:,:,6) = ARRAY_GFED3(:,:,1) + + !================================================================= + ! Convert [g DM/m2/month] to [kg DM/cm2/month] + ! + ! Unit Conversions: + ! (1) g to kg --> Divide by 1000 + ! (2) 1/m2 to 1/cm2 --> Divide by 10000 + !================================================================= + + ! Loop over GFED3 GRID + DO J = 1, JGFED3 + DO I = 1, IGFED3 + DO NF = 1, N_EMFAC + + ! Set negatives to zero + DM_GFED3_MON(I,J,NF) = MAX( DM_GFED3_MON(I,J,NF), 0e0 ) + + ! Convert [g DM/m2/month] to [kg DM/cm2/month] + DM_GFED3_MON(I,J,NF) = DM_GFED3_MON(I,J,NF) * 1d-3 * 1d-4 + + ENDDO + ENDDO + ENDDO + + ! If 3-hourly emissions are used, read 3-hourly fractions + ! at the same time that monthly emissions are read because + ! these fractions are constant throughout the month + ! - note that these should be applied after daily fractions + ! are applied + + IF ( L3HRBB3 ) THEN + + DO IT3 = 1,8 + + IT3H = (IT3-1)*3 + HHMMSS = IT3H*10000 + TAU0 = GET_TAU0( MM, 01, YYYY, IT3H ) + + FILENAME7 = TRIM( DATA_DIR_NATIVE ) // + & 'GFED3_201212/YYYY/3hourly/GFED3_FR_3HR_YYYYMMDDhh' + + ! Replace YYYY/MM/HH in the file name + CALL EXPAND_DATE( FILENAME7, YYYYMMDD, HHMMSS ) + + CALL READ_BPCH2_GFED3( FILENAME7, 'GFED3-BB', 89, + & TAU0, IGFED3, JGFED3, + & 1, ARRAY_GFED3, QUIET=.TRUE.) + + FR_GFED3_3HR(:,:,IT3) = ARRAY_GFED3(:,:,1) + + END DO + + ENDIF + +999 CONTINUE + + !================================================================= + ! At this point in the code, the following cases are possible: + ! + ! UPDATED_MON=T, UPDATED_DAY=T, UPDATED_3HR=T + ! UPDATED_MON=T, UPDATED_DAY=T, UODATED_3HR=F + ! UPDATED_MON=F, UPDATED_DAY=T, UPDATED_3HR=T + ! UPDATED_MON=F, UPDATED_DAY=T, UPDATED_3HR=F + ! UPDATED_MON=F, UPDATED_DAY=F, UPDATED_3HR=T + ! + ! Note that the combination + ! UPDATED_MON=F, UPDATED_DAY=F, UPDATED_3HR=F + ! is not possible at this point in code because of the + ! of the RETURN statement when UPDATED=F near the + ! start of this subroutine + ! + ! Also note that the combinations + ! UPDATED_MON=T, UPDATED_DAY=F, UPDATED_3HR=T + ! UPDATED_MON=T, UPDATED_DAY=F, UODATED_3HR=F + ! are not possible because UPDATED_DAY=T + ! when UPDATED_MON=T + ! + ! In the following code, the module variables + ! DM_GFED3_MON and DM_GFED3_DAY contain the + ! latest updated monthly and daily (if applicable) + ! emissions, respectively. Note that + ! by making them module variables, it is ensured + ! that the correct values are always available + ! during repeated calls to this code. + ! + ! The local variable DM_GFED3 is updated appropriately + ! based on the 5 allowable cases describe above and passed + ! to the DO_REGRID_G2G_1x1 subroutine. + ! + !================================================================= + + ! Read daily fractions + IF ( UPDATED_DAY) THEN + TAU0 = GET_TAU0( MM, DD, YYYY ) + + ! Create YYYYMMDD integer value + YYYYMMDD = YYYY*10000 + MM*100 + DD + + FILENAME8 = TRIM( DATA_DIR_NATIVE ) // + & 'GFED3_201212/YYYY/Daily/GFED3_FR_DAY_YYYYMMDD' + + ! Replace YYYY/MM in the file name + CALL EXPAND_DATE( FILENAME8, YYYYMMDD, 000000 ) + + CALL READ_BPCH2_GFED3( FILENAME8, 'GFED3-BB', 88, + & TAU0, IGFED3, JGFED3, + & 1, ARRAY_GFED3, QUIET=.TRUE. ) + + FR_GFED3_DAY(:,:) = ARRAY_GFED3(:,:,1) + + ENDIF + +! Convert DM burnt from kg/cm2/month to kg/cm2/day or +! kg/cm2/3hour if needed, and grid to model grid + DO NF = 1, N_EMFAC + + DO J = 1, JGFED3 + DO I = 1, IGFED3 + DM_GFED3(I,J,NF)=DM_GFED3_MON(I,J,NF) + + IF ( UPDATED_DAY ) THEN + DM_GFED3_DAY(I,J,NF)=DM_GFED3_MON(I,J,NF) + & *FR_GFED3_DAY(I,J) + DM_GFED3(I,J,NF)=DM_GFED3_DAY(I,J,NF) + SECONDS = 24 * 3600d0 + END IF + + IF ( UPDATED_3HR ) THEN + IT3HR=T3HR/3+1 + DM_GFED3(I,J,NF)=DM_GFED3_DAY(I,J,NF) + & *FR_GFED3_3HR(I,J,IT3HR) + SECONDS = 3 * 3600d0 + END IF + + ENDDO + ENDDO + + END DO + + !================================================================= + ! Calculate biomass species emissions on GFED3 grid + ! and regrid to model grid + ! + ! Emission factors convert from [kg DM/cm2/timeperiod] to either + ! [molec/cm2/timeperiod] or [atoms C/cm2/timeperiod] + ! + ! Units: + ! [ molec/cm2/month] : NOx, CO, CH2O, SO2, NH3, CO2 + ! [atoms C/cm2/month] : ALK4, ACET, MEK, ALD2, PRPE, C3H8, + ! C2H6, BC, OC + !================================================================= + + ! Loop over biomass species + DO N = 1, N_SPEC + + DO J = 1, JGFED3 + DO I = 1, IGFED3 + BIOMASS_GFED3(I,J,N) = 0.0 + DO NF = 1, N_EMFAC + GFED3_EMFACX=GFED3_EMFAC(N,NF) + + ! Use woodland emission factors for 'deforestation' outside + ! humid tropical forest + IF(NF.EQ.2.AND.HUMTROP_GFED3(I,J).EQ.0) + & GFED3_EMFACX=GFED3_EMFAC(N,6) + BIOMASS_GFED3(I,J,N) = BIOMASS_GFED3(I,J,N) + + & DM_GFED3(I,J,NF) * + & GFED3_EMFACX + + ENDDO + ENDDO + ENDDO + + ! Regrid emissions from GFED3 grid to model grid + ALLOCATE( bq1( IGFED3, JGFED3 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'bq1' ) + ALLOCATE( bq2( IIIPAR0, JJJPAR0 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'bq2' ) + + bq1(:,:)=BIOMASS_GFED3(:,:,N) + CALL GRID_GFED3( IGFED3, JGFED3, XEDGE_GFED3, + & YEDGE_GFED3, bq1, IIIPAR0, + & JJJPAR0, XEDGE_MODELG, YEDGE_MODELG, + & bq2, 0, 0 ) + + I0 = GET_XOFFSET( GLOBAL=.TRUE. ) + J0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + DO JJ=1,JJPAR + DO II=1,IIPAR + BIOMASS_MODEL(II,JJ,N)=bq2(II+I0,JJ+J0) + END DO + END DO + + DEALLOCATE( bq1 ) + DEALLOCATE( bq2 ) + + END DO + + ! Compute future biomass emissions (if necessary) + IF ( LFUTURE ) THEN + CALL GFED3_SCALE_FUTURE( BIOMASS_MODEL ) + ENDIF + + ! Print totals in Tg/time period + IF ( UPDATED_3HR ) THEN + WRITE( 6, 412 ) YYYY, MM, DD, T3HR + 412 FORMAT( 'GFED3 3hourly emissions for year, month, day, 3hr: ', + & i4, '/', 3i2.2, / ) + go to 998 + ENDIF + IF ( UPDATED_DAY ) THEN + WRITE( 6, 411 ) YYYY, MM, DD + 411 FORMAT( 'GFED3 daily emissions for year, month, day: ', + & i4, '/', 2i2.2, / ) + go to 998 + ENDIF + WRITE( 6, 410 ) YYYY, MM + 410 FORMAT( 'GFED3 monthly emissions for year, month: ', + & i4, '/', i2.2, / ) + 998 CONTINUE + CALL GFED3_TOTAL_Tg + + ! Convert from [molec/cm2/month], [molec/cm2/day] or + ! [molec/cm2/3hr] to [molec/cm2/s] + BIOMASS_MODEL = BIOMASS_MODEL / SECONDS + + ! Rearrange the species to the same order as in the IDBxxx (fp, 6/09) + ! BIOMASS_MODEL is indexed as GFED3 + ! BIOM_OUT is indexed as IDBs + !CALL REARRANGE_BIOM( BIOMASS_MODEL, BIOM_OUT ) + BIOM_OUT = BIOMASS_MODEL + + ! Echo info + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + END SUBROUTINE GFED3_COMPUTE_BIOMASS +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: gfed3_scale_future +! +! !DESCRIPTION: Subroutine GFED3\_SCALE\_FUTURE applies the IPCC future +! emissions scale factors to the GFED3 biomass burning emisisons in order +! to compute the future emissions of biomass burning for NOx, CO, and VOC's. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GFED3_SCALE_FUTURE( BB ) +! +! !USES: +! + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_BCbb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_CObb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NH3bb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NOxbb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_OCbb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_SO2bb + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_VOCbb + USE TRACER_MOD, ONLY : ITS_A_CO2_SIM + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM + +# include "CMN_SIZE" ! Size parameters + +! +! !OUTPUT PARAMETERS: +! + ! Array w/ biomass burning emisisons [molec/cm2] + REAL*8, INTENT(INOUT) :: BB(IIPAR,JJPAR,N_SPEC) +! +! !REVISION HISTORY: +! 07 Sep 2011 - P. Kasibhatla - Initial version, based on GFED2 +! 07 Sep 2011 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL :: ITS_CO2 + LOGICAL :: ITS_CH4 + INTEGER :: I, J, N + + !================================================================= + ! GFED3_SCALE_FUTURE begins here! + !================================================================= + + ! Test if it's a CO2 simulation outside of the loop + ITS_CO2 = ITS_A_CO2_SIM() + ITS_CH4 = ITS_A_CH4_SIM() + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, N ) + + ! Loop over species and grid boxes + DO N = 1, N_SPEC + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Scale each species to IPCC future scenario + IF ( N == IDBNOx ) THEN + + ! Future biomass NOx [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_NOxbb( I, J ) + + ELSE IF ( N == IDBCO ) THEN + + ! Future biomass CO [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_CObb( I, J ) + + ELSE IF ( N == IDBSO2 ) THEN + + ! Future biomass SO2 [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_SO2bb( I, J ) + + ELSE IF ( N == IDBNH3 ) THEN + + ! Future biomass NH3 [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_NH3bb( I, J ) + + ELSE IF ( N == IDBBC ) THEN + + ! Future biomass BC [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_BCbb( I, J ) + + ELSE IF ( N == IDBOC ) THEN + + ! Future biomass OC [molec/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_OCbb( I, J ) + + ! Don't scale future emissions if CO2 or CH4 + ELSE IF ( ITS_CO2 .OR. ITS_CH4 ) THEN + + ! Nothing + + ELSE + + ! Future biomass Hydrocarbons [atoms C/cm2] + BB(I,J,N) = BB(I,J,N) * GET_FUTURE_SCALE_VOCbb( I, J ) + + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + END SUBROUTINE GFED3_SCALE_FUTURE +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: gfed3_total_Tg +! +! !DESCRIPTION: Subroutine GFED3\_TOTAL\_Tg prints the amount of biomass +! burning emissions that are emitted each month/day/3-hr in Tg or Tg C. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GFED3_TOTAL_Tg +! +! !USES: +! + USE GRID_MOD, ONLY : GET_AREA_CM2 + +# include "CMN_SIZE" ! Size parameters +! +! !REVISION HISTORY: +! 07 Sep 2011 - P. Kasibhatla - Initial version, based on GFED2 +! 07 Sep 2011 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: I, J, N + REAL*8 :: CONV, MOLWT, TOTAL + CHARACTER(LEN=4) :: NAME + CHARACTER(LEN=6) :: UNIT + + !================================================================= + ! GFED3_TOTAL_Tg begins here! + !================================================================= + + ! Loop over biomass species + DO N = 1, N_SPEC + + ! Initialize + NAME = GFED3_SPEC_NAME(N) + MOLWT = GFED3_SPEC_MOLWT(N) + UNIT = GFED3_SPEC_UNIT(N) + TOTAL = 0d0 + + ! Loop over latitudes + DO J = 1, JJPAR + + ! Convert to [Tg/gfed-period] (or [Tg C/gfed-period] for HC's) + CONV = GET_AREA_CM2( J ) * ( MOLWT / 6.023d23 ) * 1d-9 + + ! Loop over longitudes + DO I = 1, IIPAR + TOTAL = TOTAL + ( BIOMASS_MODEL(I,J,N) * CONV ) + ENDDO + ENDDO + + ! Write totals + WRITE( 6, 110 ) NAME, TOTAL, UNIT + 110 FORMAT( 'Sum Biomass ', a4, 1x, ': ', e12.5, 1x, a6 ) + ENDDO + + END SUBROUTINE GFED3_TOTAL_Tg +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: init_gfed3_biomass +! +! !DESCRIPTION: Subroutine INIT\_GFED3\_BIOMASS allocates all module arrays. +! It also reads the emission factors at the start of a GEOS-Chem +! simulation. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE INIT_GFED3_BIOMASS +! +! !USES: +! + USE DIRECTORY_MOD, ONLY : DATA_DIR_NATIVE => DATA_DIR_1x1 + USE ERROR_MOD, ONLY : ALLOC_ERR + USE FILE_MOD, ONLY : IOERROR + USE FILE_MOD, ONLY : IU_FILE + USE LOGICAL_MOD, ONLY : LDICARB + USE LOGICAL_MOD, ONLY : LDAYBB3 + USE LOGICAL_MOD, ONLY : L3HRBB3 + +# include "CMN_SIZE" ! Size parameters + +! +! !REVISION HISTORY: +! 07 Sep 2011 - P. Kasibhatla - Initial version, based on GFED2 +! 07 Sep 2011 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: AS, IOS, M, N, NDUM + REAL*4 :: ARRAY_LANDMAP(IGFED3,JGFED3,1) + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! INIT_GFED3_BIOMASS begins here! + !================================================================= + + ! Allocate array to hold GFED3 grid box lon edges + ALLOCATE( XEDGE_GFED3( IGFED3+1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'XEDGE_GFED3' ) + XEDGE_GFED3 = 0.d0 + + ! Allocate array to hold GFED3 grid box lat edges + ALLOCATE( YEDGE_GFED3( JGFED3+1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'YEDGE_GFED3' ) + YEDGE_GFED3 = 0.d0 + + ! Allocate array to hold GEOS-Chem grid box lon edges + ALLOCATE( XEDGE_MODELG( IIIPAR0+1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'XEDGE_MODELG' ) + XEDGE_MODELG = 0.d0 + + ! Allocate array to hold GEOS-Chem grid box lat edges + ALLOCATE( YEDGE_MODELG( JJJPAR0+1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'YEDGE_MODELG' ) + YEDGE_MODELG = 0.d0 + + ! Allocate array to hold GFED3 species emissions on model grid + ALLOCATE( BIOMASS_MODEL( IIPAR, JJPAR, N_SPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BIOMASS_MODEL' ) + BIOMASS_MODEL = 0d0 + + ! Allocate array to hold monthly GFED3 DM burnt GFED3 grid + ALLOCATE( DM_GFED3_MON( IGFED3, JGFED3, N_SPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DM_GFED3_MON' ) + DM_GFED3_MON = 0d0 + + ! Allocate array to hold daily GFED3 DM burnt GFED3 grid + IF ( LDAYBB3 ) THEN + ALLOCATE( DM_GFED3_DAY( IGFED3, JGFED3, N_SPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DM_GFED3_DAY' ) + DM_GFED3_DAY = 0d0 + ENDIF + + ! Allocate array to hold 3hourly fractions on GFED3 grid + IF ( L3HRBB3 ) THEN + ALLOCATE( FR_GFED3_3HR( IGFED3,JGFED3, 8 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'FR_GFED3_3HR' ) + FR_GFED3_3HR = 0d0 + ENDIF + + ! Allocate array for emission factors + ALLOCATE( GFED3_EMFAC( N_SPEC, N_EMFAC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GFED3_EMFAC' ) + GFED3_EMFAC = 0d0 + + ! Allocate array for species molecular weight + ALLOCATE( GFED3_SPEC_MOLWT( N_SPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GFED3_SPEC_MOLWT' ) + GFED3_SPEC_MOLWT = 0d0 + + ! Allocate array for species name + ALLOCATE( GFED3_SPEC_NAME( N_SPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GFED3_SPEC_NAME' ) + GFED3_SPEC_NAME = '' + + ! Allocate array for GFED3 biomass buning species mass units + ALLOCATE( GFED3_SPEC_UNIT( N_SPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GFED3_SPEC_UNIT' ) + GFED3_SPEC_UNIT = '' + + ! Allocate array for vegetation map + ALLOCATE( HUMTROP_GFED3( IGFED3, JGFED3 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'HUMTROP_GFED3' ) + + !IDBs are now the same as the ones in TRACERID AND BIOMASS_MOD + !BIOSAVE INDEX IS THE LOCATION OF THE EMISSION IN THE GFED FILE + !(fp) + ALLOCATE( BIO_SAVE( N_SPEC ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BIO_SAVE' ) + BIO_SAVE = 0 + + ! Set default values for module variables + T3HR = -1 + + !================================================================= + ! Read emission factors (which convert from kg DM to + ! either [molec species] or [atoms C]) from bpch file + !================================================================= + + ! File name + FILENAME = TRIM( DATA_DIR_NATIVE) // + & 'GFED3_201212/GFED3_emission_factors.txt' + + Print*, FILENAME + + ! Open emission factor file (ASCII format) + OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'init_gfed3:1' ) + + ! Skip header lines + DO N = 1, 9 + READ( IU_FILE, *, IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'init_gfed3:2' ) + ENDDO + + ! Read emission factors for each species + DO N = 1, N_SPEC + READ( IU_FILE, 100, IOSTAT=IOS ) + & NDUM, GFED3_SPEC_NAME(N), ( GFED3_EMFAC(N,M), M=1,N_EMFAC ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'init_gfed3:3' ) + WRITE(6,100)NDUM,GFED3_SPEC_NAME(N),(GFED3_EMFAC(N,M),M=1,N_EMFAC) + ENDDO + + ! FORMAT string + 100 FORMAT( 1x, i2, 1x, a4, 6(3x,es14.6) ) + + ! Close file + CLOSE( IU_FILE ) + + !================================================================= + ! Read GFED humid tropical forest map from bpch file + ! This is used to assign emission factors for 'deforestation' + ! 'Deforestation' occur outside of humid tropical forest + ! is assigned a 'woodlands' emission factor' + ! + ! Values: 1 = humid tropical forest + ! 0 = other + !================================================================= + + ! File name + FILENAME = TRIM( DATA_DIR_NATIVE ) // + & 'GFED3_201212/GFED3_humtropmap' + + ! Read GFED3 veg map + CALL READ_BPCH2_GFED3( FILENAME, 'LANDMAP', 1, + & 0d0, IGFED3, JGFED3, + & 1, ARRAY_LANDMAP, QUIET=.TRUE. ) + + ! Cast from REAL*4 to INTEGER + HUMTROP_GFED3(:,:) = ARRAY_LANDMAP(:,:,1) + + !================================================================= + ! Define local ID flags and arrays for the names, units, + ! and molecular weights of the GFED3 biomass species + !================================================================= + + ! Initialize + IDBNOx = 0 + IDBCO = 0 + IDBALK4 = 0 + IDBACET = 0 + IDBMEK = 0 + IDBALD2 = 0 + IDBPRPE = 0 + IDBC3H8 = 0 + IDBCH2O = 0 + IDBC2H6 = 0 + IDBBC = 0 + IDBOC = 0 + IDBSO2 = 0 + IDBNH3 = 0 + IDBCO2 = 0 + IDBGLYX = 0 + IDBMGLY = 0 + IDBBENZ = 0 + IDBTOLU = 0 + IDBXYLE = 0 + IDBC2H4 = 0 + IDBC2H2 = 0 + IDBGLYC = 0 + IDBHAC = 0 + IDBCH4 = 0 + + ! Save correspondance between GFED3 species order (N) and + ! species order of the simulation (IDBxxxs).(ccc, 2/4/10) + ! and also initialize arrays for mol wts and units + DO N = 1, N_SPEC + SELECT CASE ( TRIM( GFED3_SPEC_NAME(N) ) ) + CASE( 'NOx' ) + IDBNOx = N + GFED3_SPEC_MOLWT(N) = 14d-3 + GFED3_SPEC_UNIT(N) = '[Tg N]' + CASE( 'CO' ) + IDBCO = N + GFED3_SPEC_MOLWT(N) = 28d-3 + GFED3_SPEC_UNIT(N) = '[Tg ]' + CASE( 'ALK4' ) + IDBALK4 = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'ACET' ) + IDBACET = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'MEK' ) + IDBMEK = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'ALD2' ) + IDBALD2 = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'PRPE' ) + IDBPRPE = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'C3H8' ) + IDBC3H8 = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'CH2O' ) + IDBCH2O = N + GFED3_SPEC_MOLWT(N) = 30d-3 + GFED3_SPEC_UNIT(N) = '[Tg ]' + CASE( 'C2H6' ) + IDBC2H6 = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'SO2' ) + IDBSO2 = N + GFED3_SPEC_MOLWT(N) = 64d-3 + GFED3_SPEC_UNIT(N) = '[Tg ]' + CASE( 'NH3' ) + IDBNH3 = N + GFED3_SPEC_MOLWT(N) = 17d-3 + GFED3_SPEC_UNIT(N) = '[Tg ]' + CASE( 'BC' ) + IDBBC = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'OC' ) + IDBOC = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'GLYX' ) + IDBGLYX = N + GFED3_SPEC_MOLWT(N) = 58d-3 + GFED3_SPEC_UNIT(N) = '[Tg ]' + CASE( 'MGLY' ) + IDBMGLY = N + GFED3_SPEC_MOLWT(N) = 72d-3 + GFED3_SPEC_UNIT(N) = '[Tg ]' + CASE( 'BENZ' ) + IDBBENZ = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'TOLU' ) + IDBTOLU = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'XYLE' ) + IDBXYLE = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'C2H4' ) + IDBC2H4 = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'C2H2' ) + IDBC2H2 = N + GFED3_SPEC_MOLWT(N) = 12d-3 + GFED3_SPEC_UNIT(N) = '[Tg C]' + CASE( 'GLYC' ) + IDBGLYC = N + GFED3_SPEC_MOLWT(N) = 60d-3 + GFED3_SPEC_UNIT(N) = '[Tg ]' + CASE( 'HAC' ) + IDBHAC = N + GFED3_SPEC_MOLWT(N) = 74d-3 + GFED3_SPEC_UNIT(N) = '[Tg ]' + CASE( 'CO2' ) + IDBCO2 = N + GFED3_SPEC_MOLWT(N) = 44d-3 + GFED3_SPEC_UNIT(N) = '[Tg ]' + CASE( 'CH4' ) + IDBCH4 = N + GFED3_SPEC_MOLWT(N) = 16d-3 + GFED3_SPEC_UNIT(N) = '[Tg ]' + CASE DEFAULT + ! Nothing + + WRITE(*,*) 'NAME',TRIM( GFED3_SPEC_NAME(N) ) + END SELECT + ENDDO + + END SUBROUTINE INIT_GFED3_BIOMASS +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: rearrange_biom +! +! !DESCRIPTION: Subroutine REARRANGE\_BIOM takes GFED3 emissions (which have +! their own, unique ID numbers and associates them with the IDBxxxs of +! tracerid\_mod.F. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE REARRANGE_BIOM( BIOM_OUT, BIOM_OUTM ) + +! +! !USES: +! +# include "CMN_SIZE" ! Size parameters +! +! !INPUT PARAMETERS: +! + REAL*8, INTENT(IN) :: BIOM_OUT (IIPAR,JJPAR,N_SPEC) +! +! !OUTPUT PARAMETERS: +! + REAL*8, INTENT(OUT) :: BIOM_OUTM(IIPAR,JJPAR,N_SPEC) !+1 from CO2 +! +! !REVISION HISTORY: +! 07 Sep 2011 - P. Kasibhatla - Initial version, based on GFED2 +! 07 Sep 2011 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: N + + ! Loop over GFED3 species + DO N = 1, N_SPEC + + ! Save into array w/ proper ordering for GEOS-Chem + IF ( BIO_SAVE(N) .GT. 0 ) THEN + BIOM_OUTM(:,:,BIO_SAVE(N)) = BIOM_OUT(:,:,N) + ENDIF + + ENDDO + + END SUBROUTINE REARRANGE_BIOM +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: cleanup_gfed3_biomass +! +! !DESCRIPTION: Subroutine CLEANUP\_GFED3\_BIOMASS deallocates all module +! arrays. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE CLEANUP_GFED3_BIOMASS +! +! !REVISION HISTORY: +! 07 Sep 2011 - P. Kasibhatla - Initial version, based on GFED2 +! 07 Sep 2011 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC + !================================================================= + ! CLEANUP_GFED3_BIOMASS begins here! + !================================================================= + IF ( ALLOCATED( GFED3_EMFAC ) ) DEALLOCATE( GFED3_EMFAC ) + IF ( ALLOCATED( GFED3_SPEC_MOLWT ) ) DEALLOCATE( GFED3_SPEC_MOLWT) + IF ( ALLOCATED( GFED3_SPEC_NAME ) ) DEALLOCATE( GFED3_SPEC_NAME ) + IF ( ALLOCATED( HUMTROP_GFED3 ) ) DEALLOCATE( HUMTROP_GFED3 ) + IF ( ALLOCATED( BIOMASS_MODEL ) ) DEALLOCATE( BIOMASS_MODEL ) + + END SUBROUTINE CLEANUP_GFED3_BIOMASS +!EOC +!------------------------------------------------------------------------------ +! Prasad Kasibhatla, Duke University ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: GRID_GFED3 +! +! !DESCRIPTION: Subroutine GRID\_GFED3 regrids 0.5x0.5 GFED3 emissions +! to GEOS-Chem grid at model resolutin - adapted from Map_A2A +! S-J Lin. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GRID_GFED3( im, jm, lon1, sin1, q1, + & in, jn, lon2, sin2, q2, ig, iv ) +! +! !INPUT PARAMETERS: +! + + ! Longitude and Latitude dimensions of INPUT grid + INTEGER, INTENT(IN) :: im, jm + + ! Longitude and Latitude dimensions of OUTPUT grid + INTEGER, INTENT(IN) :: in, jn + + ! IG=0: pole to pole; + ! IG=1 J=1 is half-dy north of south pole + INTEGER, INTENT(IN) :: ig + + ! IV=0: Regrid scalar quantity + ! IV=1: Regrid vector quantity + INTEGER, INTENT(IN) :: iv + + ! Longitude edges (degrees) of INPUT and OUTPUT grids + REAL*8, INTENT(IN) :: lon1(im+1), lon2(in+1) + + ! Sine of Latitude Edges (radians) of INPUT and OUTPUT grids + REAL*8, INTENT(IN) :: sin1(jm+1), sin2(jn+1) + + ! Quantity on INPUT grid + REAL*4, INTENT(IN) :: q1(im,jm) +! +! !OUTPUT PARAMETERS: + + ! Regridded quantity on OUTPUT grid + REAL*4, INTENT(OUT) :: q2(in,jn) +! +! !AUTHOR: +! Original Map_A2A subroutine by S-J Lin (GSFC) +! Adapted by Prasad Kasibhatla (Duke University) +! +! !REVISION HISTORY: +! 06 Mar 2012 - Prasad Kasibhatla - added to code +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: i,j,k + REAL*4 :: qtmp(in,jm) + + !=================================================================== + ! GRID_GFED3 begins here! + ! + ! Mapping in the E-W direction + !=================================================================== + CALL XMAP_GFED3(im, jm-ig, lon1, + & q1(1,1+ig),in, lon2, qtmp(1,1+ig) ) + + !=================================================================== + ! Mapping in the N-S direction + !=================================================================== + CALL YMAP_GFED3(in, jm, sin1, qtmp(1,1+ig), jn, sin2, + & q2(1,1+ig), ig, iv) + + END SUBROUTINE GRID_GFED3 +!EOC +!------------------------------------------------------------------------------ +! Prasad Kasibhatla - Duke University ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: YMAP_GFED3 +! +! !DESCRIPTION: Subroutine YMAP_GFED3 performs area preserving mapping in N-S from +! an arbitrary resolution to another. NOTE - only works with lat-lon grids +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE YMAP_GFED3( im, jm, sin1, q1, jn, sin2, q2, ig, iv ) + +! +! !INPUT PARAMETERS: +! + + ! original E-W dimension + INTEGER, INTENT(IN) :: im + + ! original N-S dimension + INTEGER, INTENT(IN) :: jm + + ! Target N-S dimension + INTEGER, INTENT(IN) :: jn + + ! IG=0: scalars from SP to NP (D-grid v-wind is also IG=0) + ! IG=1: D-grid u-wind + INTEGER, INTENT(IN) :: ig + + ! IV=0: scalar; + ! IV=1: vector + INTEGER, INTENT(IN) :: iv + + ! Original southern edge of the cell sin(lat1) + REAL*8, INTENT(IN) :: sin1(jm+1-ig) + + ! Original data at center of the cell + REAL*4, INTENT(IN) :: q1(im,jm) + + ! Target cell's southern edge sin(lat2) + REAL*8, INTENT(IN) :: sin2(jn+1-ig) +! +! !OUTPUT PARAMETERS: +! + ! Mapped data at the target resolution + REAL*4, INTENT(OUT) :: q2(im,jn) +! +! !REMARKS: +! +! sin1 (1) = -1 must be south pole; sin1(jm+1)=1 must be N pole. +! +! sin1(1) < sin1(2) < sin1(3) < ... < sin1(jm) < sin1(jm+1) +! sin2(1) < sin2(2) < sin2(3) < ... < sin2(jn) < sin2(jn+1)! +! +! !AUTHOR: +! Developer: Prasad Kasibhatla +! March 6, 2012 +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: i, j0, m, mm, j + REAL*8 :: dy1(jm) + REAL*8 :: dy + REAL*4 :: qsum, sum + + ! YMAP begins here! + do j=1,jm-ig + dy1(j) = sin1(j+1) - sin1(j) + enddo + + !=============================================================== + ! Area preserving mapping + !=============================================================== + + do 1000 i=1,im + j0 = 1 + do 555 j=1,jn-ig + do 100 m=j0,jm-ig + + !========================================================= + ! locate the southern edge: sin2(i) + !========================================================= + if(sin2(j) .ge. sin1(m) .and. sin2(j) .le. sin1(m+1)) then + + if(sin2(j+1) .le. sin1(m+1)) then + + ! entire new cell is within the original cell + q2(i,j)=q1(i,m) + j0 = m + goto 555 + else + + ! South most fractional area + qsum=(sin1(m+1)-sin2(j))*q1(i,m) + + do mm=m+1,jm-ig + + ! locate the northern edge: sin2(j+1) + if(sin2(j+1) .gt. sin1(mm+1) ) then + + ! Whole layer + qsum = qsum + dy1(mm)*q1(i,mm) + else + + ! North most fractional area + dy = sin2(j+1)-sin1(mm) + qsum=qsum+dy*q1(i,mm) + j0 = mm + goto 123 + endif + enddo + goto 123 + endif + endif +100 continue +123 q2(i,j) = qsum / ( sin2(j+1) - sin2(j) ) +555 continue +1000 continue + + !=================================================================== + ! Final processing for poles + !=================================================================== + if ( ig .eq. 0 .and. iv .eq. 0 ) then + + ! South pole + sum = 0. + do i=1,im + sum = sum + q2(i,1) + enddo + + sum = sum / float(im) + do i=1,im + q2(i,1) = sum + enddo + + ! North pole: + sum = 0. + do i=1,im + sum = sum + q2(i,jn) + enddo + + sum = sum / float(im) + do i=1,im + q2(i,jn) = sum + enddo + + endif + + END SUBROUTINE YMAP_GFED3 +!EOC +!------------------------------------------------------------------------------ +! Prasad Kasibhatla, Duke University ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: XMAP_GFED3 +! +! !DESCRIPTION: Subroutine Xmap performs area preserving mapping in E-W +! from an arbitrary resolution to another. Periodic domain will be assumed, +! i.e., the eastern wall bounding cell im is $lon1(im+1) = lon1(1)$; +! Note the equal sign is true geophysically. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE XMAP_GFED3( im, jm, lon1, q1, in, lon2, q2 ) +! +! !INPUT PARAMETERS: +! + ! Original E-W dimension + INTEGER, INTENT(IN) :: im + + ! Target E-W dimension + INTEGER, INTENT(IN) :: in + + ! Original N-S dimension + INTEGER, INTENT(IN) :: jm + + ! Original western edge of the cell + REAL*8, INTENT(IN) :: lon1(im+1) + + ! Original data at center of the cell + REAL*4, INTENT(IN) :: q1(im,jm) + + ! Target cell's western edge + REAL*8, INTENT(IN) :: lon2(in+1) +! +! !OUTPUT PARAMETERS: +! + ! Mapped data at the target resolution + REAL*4, INTENT(OUT) :: q2(in,jm) +! +! !REMARKS: +! lon1(1) < lon1(2) < lon1(3) < ... < lon1(im) < lon1(im+1) +! lon2(1) < lon2(2) < lon2(3) < ... < lon2(in) < lon2(in+1) +! +! !AUTHOR: +! Developer: Prasad Kasibhatla +! March 6, 2012 +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: i1, i2, i, i0, m, mm, j + REAL*4 :: qtmp(-im:im+im) + REAL*8 :: x1(-im:im+im+1) + REAL*8 :: dx1(-im:im+im) + REAL*8 :: dx + REAL*4 :: qsum + LOGICAL :: found +! + + ! XMAP begins here! + do i=1,im+1 + x1(i) = lon1(i) + enddo + + do i=1,im + dx1(i) = x1(i+1) - x1(i) + enddo + + !=================================================================== + ! check to see if ghosting is necessary + ! Western edge: + !=================================================================== + found = .false. + i1 = 1 + do while ( .not. found ) + if( lon2(1) .ge. x1(i1) ) then + found = .true. + else + i1 = i1 - 1 + if (i1 .lt. -im) then + write(6,*) 'failed in xmap' + stop + else + x1(i1) = x1(i1+1) - dx1(im+i1) + dx1(i1) = dx1(im+i1) + endif + endif + enddo + + !=================================================================== + ! Eastern edge: + !=================================================================== + found = .false. + i2 = im+1 + do while ( .not. found ) + if( lon2(in+1) .le. x1(i2) ) then + found = .true. + else + i2 = i2 + 1 + if (i2 .gt. 2*im) then + write(6,*) 'failed in xmap' + stop + else + dx1(i2-1) = dx1(i2-1-im) + x1(i2) = x1(i2-1) + dx1(i2-1) + endif + endif + enddo + + do 1000 j=1,jm + + !================================================================= + ! Area preserving mapping + !================================================================ + + qtmp(0)=q1(im,j) + do i=1,im + qtmp(i)=q1(i,j) + enddo + qtmp(im+1)=q1(1,j) + + ! check to see if ghosting is necessary + ! Western edge + if ( i1 .le. 0 ) then + do i=i1,0 + qtmp(i) = qtmp(im+i) + enddo + endif + + ! Eastern edge: + if ( i2 .gt. im+1 ) then + do i=im+1,i2-1 + qtmp(i) = qtmp(i-im) + enddo + endif + + i0 = i1 + + do 555 i=1,in + do 100 m=i0,i2-1 + + !============================================================= + ! locate the western edge: lon2(i) + !============================================================= + if(lon2(i) .ge. x1(m) .and. lon2(i) .le. x1(m+1)) then + + if(lon2(i+1) .le. x1(m+1)) then + + ! entire new grid is within the original grid + q2(i,j)=qtmp(m) + i0 = m + goto 555 + else + + ! Left most fractional area + qsum=(x1(m+1)-lon2(i))*qtmp(m) + do mm=m+1,i2-1 + + ! locate the eastern edge: lon2(i+1) + if(lon2(i+1) .gt. x1(mm+1) ) then + + ! Whole layer + qsum = qsum + dx1(mm)*qtmp(mm) + + else + ! Right most fractional area + dx = lon2(i+1)-x1(mm) + qsum=qsum+dx*qtmp(mm) + i0 = mm + goto 123 + endif + enddo + goto 123 + endif + endif +100 continue +123 q2(i,j) = qsum / ( lon2(i+1) - lon2(i) ) +555 continue +1000 continue + + END SUBROUTINE XMAP_GFED3 +!EOC +!------------------------------------------------------------------------------ +! Prasad Kasibhatla - Duke University ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: read_bpch2_gfed3 +! +! !DESCRIPTION: Subroutine READ\_BPCH2\_GFED3 reads GFED3 DM burnt and +! and humid tropical forest map files +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE READ_BPCH2_GFED3( FILENAME, CATEGORY_IN, TRACER_IN, + & TAU0_IN, IX, JX, + & LX, ARRAY, QUIET ) +! +! !USES: +! + USE ERROR_MOD, ONLY : ERROR_STOP + USE FILE_MOD, ONLY : IU_FILE, IOERROR + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + +# include "define.h" +! +! !INPUT PARAMETERS: +! + CHARACTER(LEN=*), INTENT(IN) :: FILENAME ! Bpch file to read + CHARACTER(LEN=*), INTENT(IN) :: CATEGORY_IN ! Diag. category name + INTEGER, INTENT(IN) :: TRACER_IN ! Tracer index # + REAL*8, INTENT(IN) :: TAU0_IN ! TAU timestamp + INTEGER, INTENT(IN) :: IX, JX, LX ! Dimensions of ARRAY + LOGICAL, OPTIONAL, INTENT(IN) :: QUIET ! Don't print output +! +! !OUTPUT PARAMETERS: +! + REAL*4, INTENT(OUT) :: ARRAY(IX,JX,LX) ! Data array from file +! +! !REVISION HISTORY: +! (1 ) Adapted from READ_BPCH2 to facilitate reading of 0.5x0.5 GFED3 files (psk, 2/7/12) +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL :: FOUND, TMP_QUIET + INTEGER :: I, J, L, N, IOS, M + INTEGER :: I1, I2, J1, J2, L1, L2 + CHARACTER(LEN=255) :: MSG + + ! Make TEMPARRAY big enough for GFED3 files - 0.5x0.5 lat-lon grid + REAL*4 :: TEMPARRAY_GFED3(720,360,1) + + ! For binary punch file, version 2.0 + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + INTEGER :: NI, NJ, NL, IT3H + INTEGER :: IFIRST, JFIRST, LFIRST + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! READ_BPCH2_GFED3 begins here! + ! + ! Initialize some variables + !================================================================= + FOUND = .FALSE. + ARRAY(:,:,:) = 0e0 + TEMPARRAY_GFED3(:,:,:) = 0e0 + + ! Define a temporary variable for QUIET + IF ( PRESENT( QUIET ) ) THEN + TMP_QUIET = QUIET + ELSE + TMP_QUIET = .FALSE. + ENDIF + + !================================================================= + ! Open binary punch file and read top-of-file header. + ! Do some error checking to make sure the file is the right format. + !================================================================= + CALL OPEN_BPCH2_FOR_READ( IU_FILE, FILENAME ) + + !================================================================= + ! Read data from the binary punch file + ! + ! NOTE: IOS < 0 is end-of-file, IOS > 0 is error condition + !================================================================= + DO + READ( IU_FILE, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'read_bpch2:4' ) + + READ( IU_FILE, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_bpch2:5' ) + + READ( IU_FILE, IOSTAT=IOS ) + & ( ( ( TEMPARRAY_GFED3(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_bpch2:6' ) + + ! Test for a match + IF ( TRIM( CATEGORY_IN ) == TRIM( CATEGORY ) .and. + & TRACER_IN == NTRACER .and. + & TAU0_IN == ZTAU0 ) THEN + FOUND = .TRUE. + EXIT + ENDIF + + ENDDO + + IF ( FOUND ) THEN + + I1 = IFIRST + J1 = JFIRST + L1 = LFIRST + + + I2 = NI + I1 - 1 + J2 = NJ + J1 - 1 + L2 = NL + L1 - 1 + + ARRAY( I1:I2, J1:J2, L1:L2 ) + & = TEMPARRAY_GFED3( 1:NI, 1:NJ, 1:NL ) + + ! Flag to decide whether or not we will echo info (bmy, 3/14/03) + IF ( .not. TMP_QUIET ) THEN + WRITE( 6, 100 ) ZTAU0, NTRACER + 100 FORMAT( 'READ_BPCH2_GFED3: Found data for TAU = ', f10.2, + & ' and tracer # ', i6 ) + ENDIF + + ELSE + MSG = 'No matches found for file ' // TRIM( FILENAME ) // '!' + CALL ERROR_STOP( MSG, 'READ_BPCH2_GFED3 (bpch2_mod.f)!' ) + ENDIF + + !================================================================= + ! Close file and quit + !================================================================= + CLOSE( IU_FILE ) + + ! Return to calling program + END SUBROUTINE READ_BPCH2_GFED3 +!EOC + + END MODULE GFED3_BIOMASS_MOD diff --git a/code/global_hno3_mod.f b/code/global_hno3_mod.f new file mode 100644 index 0000000..6bd101b --- /dev/null +++ b/code/global_hno3_mod.f @@ -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 diff --git a/code/global_no3_mod.f b/code/global_no3_mod.f new file mode 100644 index 0000000..53a376a --- /dev/null +++ b/code/global_no3_mod.f @@ -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 diff --git a/code/global_nox_mod.f b/code/global_nox_mod.f new file mode 100644 index 0000000..0ca32f3 --- /dev/null +++ b/code/global_nox_mod.f @@ -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 diff --git a/code/global_o1d_mod.f b/code/global_o1d_mod.f new file mode 100644 index 0000000..439aa7e --- /dev/null +++ b/code/global_o1d_mod.f @@ -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 diff --git a/code/global_o3_mod.f b/code/global_o3_mod.f new file mode 100644 index 0000000..d1bac7c --- /dev/null +++ b/code/global_o3_mod.f @@ -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 diff --git a/code/h2_hd_mod.f b/code/h2_hd_mod.f new file mode 100644 index 0000000..7506be1 --- /dev/null +++ b/code/h2_hd_mod.f @@ -0,0 +1,1520 @@ +! $Id: h2_hd_mod.f,v 1.1 2009/06/09 21:51:51 daven Exp $ + MODULE H2_HD_MOD +! +!****************************************************************************** +! Module H2_HD_MOD contains variables and routines used for the +! geographically tagged H2-HD simulation. (lyj, hup, phs, bmy, 9/18/07) +! +! Module Variables: +! ============================================================================ +! (1 ) SUMISOPCO : Array for production of CO from Isoprene +! (2 ) SUMMONOCO : Array for production of CO from Monoterpenes +! (3 ) SUMCH3OHCO : Array for production of CO from CH3OH (methanol) +! (4 ) SUMACETCO : Array for production of CO from Acetone +!* (5 ) EMACET : Array for hold monthly mean acetone emissions +! (8 ) FMOL_H2 : molecular weight of H2 +! (9 ) XNUMOL_H2 : molec H2 / kg H2 +! (10) FMOL_ISOP : molecular weight of ISOP +! (11) XNUMOL_ISOP : molec ISOP / kg ISOP +! (12) FMOL_MONO : molecular weight of MONOTERPENES +! (13) XNUMOL_MONO : molec MONOTERPENES / kg MONOTERPENES +! (14) EMOCEAN : Array for hold monthly mean ocean H2 emissions +! (15) H2CO_YIELD : Array for photochemical yield of H2 vs CO +! +! * = shared w/ tagged_co_mod.f where it belongs. +! +! Module Routines: +! ============================================================================ +! (1 ) EMISS_H2_HD : Emissions of H2 and HD +! (2 ) CHEM_H2_HD : Does chemistry for H2 and HD tracers +! (3 ) INIT_H2_HD : Allocates and initializes module arrays +! (4 ) CLEANUP_H2_HD : Deallocates module arrays +! +! GEOS-CHEM modules referenced by h2_hd_mod.f +! ============================================================================ +! (1 ) biofuel_mod.f : Module w/ routines to read biofuel emissions +! (2 ) biomass_mod.f : Module w/ routines to read biomass emissions +! (3 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (4 ) dao_mod.f : Module w/ arrays for DAO met fields +! (5 ) diag_mod.f : Module w/ GEOS-CHEM diagnostic arrays +! (6 ) directory_mod.f : Module w/ GEOS-CHEM data & met field dirs +! (7 ) error_mod.f : Module w/ I/O error and NaN check routines +! (8 ) geia_mod : Module w/ routines to read anthro emissions +! (9 ) global_oh_mod.f : Module w/ routines to read 3-D OH field +! (10) global_nox_mod.f : Module w/ routines to read 3-D NOx field +! (11) global_ch4_mod.f : Module containing routines to read 3-D CH4 field +! (12) global_o1d_mod.f : Module containing routines to read 3-D O1D field +! (13) grid_mod.f : Module w/ horizontal grid information +! (14) logical_mod.f : Module w/ GEOS-CHEM logical switches +! (15) pressure_mod.f : Module w/ routines to compute P(I,J,L) +! (16) tagged_co_mod.f : Module w/ CO arrays and routines +! (16) time_mod.f : Module w/ routines for computing time & date +! (17) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc. +! (18) tropopause_mod.f : Module w/ routines to read ann mean tropopause +! +! Tracers +! ============================================================================ +! (1 ) Total H2 +! (2) Total HD +! +! NOTES: +! (1 ) Based on "tagged_co_mod.f" (lyj, bmy, phs, 5/10/07) +! 07 Sep 2011 - P. Kasibhatla - Modified to include GFED3 +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "h2_hd_mod.f" + !================================================================= + + ! PRIVATE module variables + PRIVATE SUMCH3OHCO + PRIVATE SUMISOPCO, SUMMONOCO, SUMACETCO + PRIVATE FMOL_H2, XNUMOL_H2 + PRIVATE FMOL_HD, XNUMOL_HD, EMOCEAN, H2CO_YIELD + PRIVATE FMOL_ISOP, XNUMOL_ISOP, FMOL_MONO, XNUMOL_MONO + + ! PRIVATE module routines + PRIVATE INIT_H2_HD, READ_OCEAN_H2 + PRIVATE READ_H2YIELD + + !================================================================= + ! MODULE VARIABLES + !================================================================= + REAL*8, ALLOCATABLE :: SUMCH3OHCO(:,:) + REAL*8, ALLOCATABLE :: SUMISOPCO(:,:) + REAL*8, ALLOCATABLE :: SUMMONOCO(:,:) + REAL*8, ALLOCATABLE :: SUMACETCO(:,:) + REAL*8, ALLOCATABLE :: EMOCEAN(:,:) + REAL*8, ALLOCATABLE :: H2CO_YIELD(:,:,:) + + ! FMOL_H2 = kg H2 / mole H2 + ! XNUMOL_H2 = molecules H2 / kg H2 + REAL*8, PARAMETER :: FMOL_H2 = 2d-3 + REAL*8, PARAMETER :: XNUMOL_H2 = 6.022d+23/FMOL_H2 + + ! FMOL_HD = kg HD / mole HD + ! XNUMOL_HD = molecules HD / kg HD + REAL*8, PARAMETER :: FMOL_HD = 3d-3 + REAL*8, PARAMETER :: XNUMOL_HD = 6.022d+23/FMOL_HD + + ! FMOL_ISOP - kg ISOP / mole ISOP + ! XNUMOL_ISOP - molecules CO / kg ISOP + REAL*8, PARAMETER :: FMOL_ISOP = 12d-3 + REAL*8, PARAMETER :: XNUMOL_ISOP = 6.022d+23/FMOL_ISOP + + ! FMOL_MONO - kg MONO / mole MONO + ! XNUMOL_MONO - molecules MONO / kg MONO + REAL*8, PARAMETER :: FMOL_MONO = 12d-3 + REAL*8, PARAMETER :: XNUMOL_MONO = 6.022d+23/FMOL_MONO + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE EMISS_H2_HD +! +!****************************************************************************** +! Subroutine EMISS_H2_HD reads in emissions for the H2/HD simulation. +! (lyj, phs, bmy, 9/18/07) +! +! NOTES: +! (1 ) Now references GET_ANNUAL_SCALAR (phs, 3/11/08) +!****************************************************************************** +! + ! References to F90 modules + USE BIOFUEL_MOD, ONLY : BIOFUEL, BIOFUEL_BURN + USE BIOMASS_MOD, ONLY : BIOMASS, IDBCO + USE DAO_MOD, ONLY : SUNCOS, BXHEIGHT + USE DIAG_MOD, ONLY : AD29, AD46, AD10em + USE GEIA_MOD, ONLY : GET_IHOUR, GET_DAY_INDEX, READ_GEIA + USE GEIA_MOD, ONLY : READ_LIQCO2, READ_TOTCO2, READ_TODX + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET, GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LANTHRO, LGFED2BB, LGFED3BB + USE LOGICAL_MOD, ONLY : LBIOMASS, LBIOFUEL, LNEI99 + USE LOGICAL_MOD, ONLY : LSTREETS, LEDGAR, LBRAVO + USE TIME_MOD, ONLY : GET_MONTH, GET_TAU + USE TIME_MOD, ONLY : GET_YEAR, GET_TS_EMIS + USE TRACER_MOD, ONLY : STT + USE TRACERID_MOD, ONLY : IDBFCO, IDTH2, IDTHD + USE TAGGED_CO_MOD, ONLY : INIT_TAGGED_CO, READ_ACETONE, EMACET + USE SCALE_ANTHRO_MOD, ONLY : GET_ANNUAL_SCALAR + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! FSCALYR, SCNR89, TODH, EMISTCO +# include "CMN_DIAG" ! Diagnostic arrays & switches + + ! Local variables + INTEGER :: I, J, L, N, I0, J0 + INTEGER :: AS, IREF, JREF, IJLOOP + INTEGER :: SCALEYEAR, IHOUR, NTAU, MONTH + + ! SAVED variables + LOGICAL, SAVE :: FIRSTEMISS = .TRUE. + INTEGER, SAVE :: LASTYEAR = -999, LASTMONTH = -999 + + ! For now these are defined in CMN_O3 + !REAL*4 :: EMISTCO(IGLOB,JGLOB) + !REAL*4 :: FLIQCO2(IGLOB,JGLOB) + + REAL*8 :: TMMP, EMXX, EMX, EMMO, EMME + REAL*8 :: EMAC, SFAC89, E_CO, E_H2, E_HD, DTSRCE + REAL*8 :: AREA_CM2, EMOC + REAL*8 :: CONVERT(NVEGTYPE) + REAL*8 :: GMONOT(NVEGTYPE) + + ! External functions + REAL*8, EXTERNAL :: XLTMMP, EMISOP, BOXVL + REAL*8, EXTERNAL :: EMMONOT, EMCH3OH + + !================================================================= + ! EMISS_H2_HD begins here! + ! + ! Do the following only on the first call to EMISS_H2_HD... + !================================================================= + IF ( FIRSTEMISS ) THEN + + ! Read polynomial coeffs' for isoprene emissions + CALL RDLIGHT + + ! Read conversion tables for isoprene & monoterpene emissions + ! Also read acetone emissions (bnd, bmy, 6/8/01) + CALL RDISOPT( CONVERT ) + CALL RDMONOT( GMONOT ) + + ! Set the base level of isoprene & monoterpene emissions + CALL SETBASE( CONVERT, GMONOT ) + + ! Read time-of-day and day-of-week scale factors for GEIA emissions + CALL READ_TODX( TODN, TODH, TODB, SCNR89 ) + + ! Read anthropogenic CO emissions from GEIA + CALL READ_GEIA( E_CO=EMISTCO ) + + ! Allocate all module arrays + CALL INIT_H2_HD + CALL INIT_TAGGED_CO + + !! Define geographic regions for both fossil fuel & biomass burning + !CALL DEFINE_FF_CO_REGIONS( FF_REGION ) + !CALL DEFINE_BB_CO_REGIONS( BB_REGION ) + + ! Set first-time flag to false + FIRSTEMISS = .FALSE. + ENDIF + + MONTH = GET_MONTH() + + !================================================================= + ! Once a month, read acetone from disk. For GEOS-3, also read + ! P(CO) from ISOPRENE, MONOTERPENES, and METHANOL from 1996. + ! Also read ocean H2 source and the relative H2/CO + ! photochemical yield. + !================================================================= + IF ( MONTH /= LASTMONTH ) THEN + + ! Read acetone for this month + CALL READ_ACETONE( MONTH ) + + ! Read ocean emissions + CALL READ_OCEAN_H2( MONTH ) + + ! Read H2/CO photochemical yield + CALL READ_H2YIELD( MONTH ) + + ! Save month for next iteration + LASTMONTH = MONTH + ENDIF + + !================================================================= + ! If FSCALYR < 0 then use this year (JYEAR) for scaling the + ! fossil fuel emissions. Otherwise, use the value of FSCALYR + ! as specified in 'input.ctm'. + ! + ! Modified to use new scaling factor (phs, 3/11/08) + !================================================================= + IF ( FSCALYR < 0 ) THEN + SCALEYEAR = GET_YEAR() +!------------------ +! prior to 3/11/08 +! ! Cap SCALEYEAR at 1998 for now (bmy, 1/13/03) +! IF ( SCALEYEAR > 1998 ) SCALEYEAR = 1998 +!------------------ + ELSE + SCALEYEAR = FSCALYR + ENDIF + + IF ( SCALEYEAR /= LASTYEAR ) THEN +!------------------ +! prior to 3/11/08 +! CALL READ_LIQCO2( SCALEYEAR, FLIQCO2 ) +!----------------- + ! now use updated scalars (phs, 3/11/08) + CALL GET_ANNUAL_SCALAR( 72, 1985, SCALEYEAR, FLIQCO2 ) + LASTYEAR = SCALEYEAR + ENDIF + + ! DTSRCE is the number of seconds per emission timestep + DTSRCE = GET_TS_EMIS() * 60d0 + + ! Get nested-grid offsets + I0 = GET_XOFFSET() + J0 = GET_YOFFSET() + + !================================================================= + ! Process Anthropogenic (Fossil Fuel) H2 emissions based on + ! CO emissions scaled by H2/CO emission ratio of 0.042 H2/CO + ! from the GEIA/Piccot inventory (Hauglustaine and Ehhalt, 2002). + ! + ! Anthropogenic emissions are enhanced by 18.5% below. This + ! accounts for production of H2 from oxidation of certain VOC's, + ! which are not explicitly carried by GEOS-CHEM as anthropogenic + ! species. This needs to be done here since a different scale + ! factor for the full chemistry run is used. The 18.5% is further + ! multiplied by the relative H2/CO photochemical yield. Also update + ! the ND29 diagnostic below, in order to archive the correct + ! emissions. (bmy, 6/14/01) + ! + ! For HD, we include an isotopic signature of -196 permil from + ! Quay and Gerst (2001). + ! + ! NOTES: + ! (1) Anthro CO emissions come from the GEIA/Piccot inventory. + ! (bmy, 1/2/01) + ! (2) Need to save ND29 diagnostics here (bmy, 1/2/01) + !================================================================= + IF ( LANTHRO ) THEN + + ! NTAU is just the integral value of TAU (ave, bmy, 6/10/03) + NTAU = GET_TAU() + + ! SFAC89 is the Weekday/Saturday/Sunday scale factor + SFAC89 = SCNR89( 2, GET_DAY_INDEX( NTAU ) ) + + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( E_CO, E_H2, E_HD, AREA_CM2, I, IHOUR, IREF, J, JREF, N ) + DO J = 1, JJPAR + JREF = J + J0 + + ! Grid box surface areas [cm2] + AREA_CM2 = GET_AREA_CM2( J ) + + DO I = 1, IIPAR + IREF = I + I0 + + ! E_CO is FF CO emissions in [molec CO/cm^2/s] + ! Scale E_CO by the day-of-week scale factor SFAC89 + E_CO = EMISTCO(IREF,JREF) * SFAC89 + + ! Scale E_CO 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_CO = E_CO * TODH(IHOUR) + + ! Scale E_CO by FLIQCO2, which reflects the yearly + ! increase in FF CO emissions for each country + E_CO = E_CO * FLIQCO2(IREF,JREF) + + + !%%% Need to also overwrite emissions with EDGAR etc %%% + IF ( LEDGAR ) THEN + ! etc + ENDIF + + IF ( LSTREETS ) THEN + ! etc + ENDIF + + IF ( LBRAVO ) THEN + ! etc + ENDIF + + IF ( LNEI99 ) THEN + ! etc + ENDIF + + + ! ND29 diagnostic -- store Fossil Fuel CO [molec/cm2/s] + IF ( ND29 > 0 ) THEN + AD29(I,J,1) = AD29(I,J,1) + E_CO * 1.185d0 + ENDIF + + ! To obtain H2 FF emissions, scale E_CO by Anthropogenic ratio + ! H2/CO of 0.042 from Hauglustaine and Ehhalt, 2002 + ! Convert from mass to molecules + ! 0.042 gH2/gCO x (28 mol/g)/(2 mol/g) = 0.588 molec H2/CO + ! Enhance H2 by 18.5% to account for oxidation + ! from Anthropogenic VOC's (bnd, bmy, 6/8/01) and + ! multiply with H2/CO photochemical yield + ! (hup, jaegle 4/20/2007) + E_H2 = E_CO * ( 0.185d0 * H2CO_YIELD(I,J,1) + 0.588d0 ) + + ! Calculate FF emissions for HD, using the -196 permil + ! signature measured by (Gerst & Quay, 2001). + ! Convert permil to D/H ratio + ! (D/H)ff = (delD/1000d0+1d0)*vsmow = 1.2523d-4 + ! with vsmow = 155.76d-6 [ Vienna Mean Standard Ocean + ! Water] and delD = -196 permil + ! We further need to multiply by 2 to get the DH/H2 + ! ratio (we count the hydrogens vs the deuteriums). + ! (DH/H2)ff = 1.2523d-4 * 2.d0 + ! (hup, jaegle, 11/16/2003) + E_HD = E_H2 * 1.2523d-4 * 2.d0 + + ! ND10 diagnostic -- store Fossil Fuel H2,HD [molec/cm2/s] + IF ( ND10 > 0 ) THEN + AD10em(I,J,1) = AD10em(I,J,1) + E_H2 + ENDIF + + ! Convert E_H2 from [molec H2/cm2/s] to [kg H2] + E_H2 = E_H2 * ( AREA_CM2 * DTSRCE / XNUMOL_H2 ) + + ! Convert E_HD from [molec HD/cm2/s] to [kg HD] + E_HD = E_HD * ( AREA_CM2 * DTSRCE / XNUMOL_HD ) + + ! Add FF H2 to Tracer #1 -- total H2 [kg H2] + ! Add FF HD to Tracer #2 -- total HD [kg HD] + STT(I,J,1,IDTH2) = STT(I,J,1,IDTH2) + E_H2 + STT(I,J,1,IDTHD) = STT(I,J,1,IDTHD) + E_HD + + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + !================================================================= + ! Process biomass burning CO emissions, stored in array + ! BIOMASS(:,:,IDBCO) which has units of [molec/cm2/s] + ! To obtain the H2 biomass burning emissions, the CO emissions + ! are scaled by a molar ratio of 0.29 molH2/molCO based on + ! Andreae and Merlet (2001, Table 2). This value is obtained + ! by taking the mean of Savannah, Grassland, Tropical Forest + ! and Extratropical Forest H2/CO ratios weighted by Dry + ! Matter Burned. + ! + ! The default Duncan et al 2001 biomass burning emissions are + ! enhanced by 11.% within here to account for the VOC. + ! + ! For HD, we include an isotopic signature of -290 permil from + ! Quay and Gerst (2001). + ! + ! GFED CO biomass burning emissions are not scaled in a full + ! chemistry, meaning that VOC oxidation is already included. + ! Then formula below for CO->H2 is modified to account for + ! that assumption (phs). + ! + ! NOTES: + ! (1) Some forest fires generate strong convection columns. + ! However, we release biomass burning emissions only into + ! the surface layer. (bnd, bmy, 1/3/01) + !================================================================= + IF ( LBIOMASS ) THEN + +!!$OMP PARALLEL DO +!!$OMP+DEFAULT( SHARED ) +!!$OMP+PRIVATE( E_H2, E_HD, I, J, N, AREA_CM2 ) + + ! Loop over latitudes + DO J = 1, JJPAR + + ! Grid box surface area [cm2] + AREA_CM2 = GET_AREA_CM2( J ) + + ! Loop over longitudes + DO I = 1, IIPAR + + ! Convert [molec CO/cm2/s] to [molec H2/cm2/s] + ! Scale by 0.29 mol H2/mol CO and increase by + ! 0.11*H2CO_YIELD to account for voc oxidation. + IF ( LGFED2BB ) THEN + BIOMASS(I,J,IDBCO) = BIOMASS(I,J,IDBCO) * + & ( H2CO_YIELD(I,J,1) + ( 0.29d0 / 0.11d0 ) ) + ELSE IF ( LGFED3BB ) THEN + BIOMASS(I,J,IDBCO) = BIOMASS(I,J,IDBCO) * + & ( H2CO_YIELD(I,J,1) + ( 0.29d0 / 0.11d0 ) ) + ELSE + BIOMASS(I,J,IDBCO) = BIOMASS(I,J,IDBCO) * + & ( ( 0.11d0 * H2CO_YIELD(I,J,1) ) + 0.29d0 ) + ENDIF + + + ! ND10 diagnostic -- store biomass burning of H2 [molec H2/cm2/s] + IF ( ND10 > 0 ) AD10em(I,J,2) = AD10em(I,J,2) + + & BIOMASS(I,J,IDBCO) + + ! Convert [molec H2/cm2/s] to [kg H2] and store in E_H2. + E_H2 = ( BIOMASS(I,J,IDBCO) / XNUMOL_H2 ) * + & ( AREA_CM2 * DTSRCE ) + + ! Convert [molec H2/cm3/s] to [kg HD] and store in E_HD. + ! Scale E_HD by biomass burning ratio 1.1d-4 molecules HD/H2 + ! accd isotopic signature of -293permil (Gerst & Quay, 2001) + ! change to -290 permil (as in Gerst and Quay) - jaegle + ! add missing factor of 2 + ! Calculate BF emissions for HD, using the -290 permil + ! isotopic signature measured by (Gerst & Quay, 2001). + ! Convert permil to D/H ratio + ! (D/H)ff = (delD/1000d0+1d0)*vsmow = 1.1059d-4 + ! with vsmow = 155.76d-6 [ Vienna Mean Standard Ocean + ! Water] and delD = -290 permil + ! We further need to multiply by 2 to get the DH/H2 + ! ratio (we count the hydrogens vs the deuteriums). + ! (DH/H2)ff = 1.1059d-4 * 2.d0 + + E_HD = ( ( BIOMASS(I,J,IDBCO) * 1.1059d-4 * 2.d0) + & / XNUMOL_HD ) * ( AREA_CM2 * DTSRCE ) + + ! Add H2 HD biomass burning to corresponding tracers - + ! - total H2/HD [kg H2/HD] + STT(I,J,1,IDTH2) = STT(I,J,1,IDTH2) + E_H2 + STT(I,J,1,IDTHD) = STT(I,J,1,IDTHD) + E_HD + + ENDDO + ENDDO +!!$OMP END PARALLEL DO + ENDIF + + !================================================================= + ! Process biofuel (formerly wood burning) CO emissions + ! stored in BIOFUEL(IDBCO,IREF,JREF) in [molec/cm3/s] + ! + ! Biofuel burning emissions must be enhanced by 18.9% + ! to account for CO production from oxidation of certain VOC's, + ! which are not explicitly carried by GEOS-CHEM as biofuel burning + ! species. + ! In case of H2/HD simulation,the scaling is done here. + ! + ! Scale CO emissions by 0.322 molH2/molCO from + ! Andreae and Merlet [2001]. + ! Scaled by the relative H2 to CO photochemical yield. + ! + ! For HD, we include an isotopic signature of -290 permil from + ! Quay and Gerst (2001) - we assume that biofuel isotopic + ! signature is the same as biomass burning. + ! + ! NOTES: + ! (1 ) Use IDBFCO to index the proper element of the + ! biofuel burning array (bmy, 6/8/01). + !================================================================= + IF ( LBIOFUEL ) THEN + CALL BIOFUEL_BURN + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( E_H2, E_HD, I, J, N ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Convert from [molec CO/cm3/s] to [kg H2] + ! BIOFUEL(IDBFCO,I,J) contains biofuel CO emissions. + ! Scale by 0.322d0 H2/CO from Andreae and Merlet + ! and enhance by 18.9% * yield h2/co from photochemical + ! oxidation (lyj, 2/10/07) + E_H2 = BIOFUEL(IDBFCO,I,J) / XNUMOL_H2 * + & BOXVL(I,J,1) * DTSRCE * + & ( ( 0.189d0 * H2CO_YIELD(I,J,1) ) + 0.322d0 ) + + + ! Calculate the HD emissions using a -290 permil + ! isotopic signature (see BB emissions above). + ! jaegle (4/20/07) + + E_HD = ( BIOFUEL(IDBFCO,I,J) * 1.1059d-4 ) * + & ( ( 0.189d0 * H2CO_YIELD(I,J,1) ) + 0.322d0 ) / + & XNUMOL_HD * ( BOXVL(I,J,1) * DTSRCE ) * 2.d0 + + ! ND10 -- store Biofuel Fuel H2 [molec/cm2/s] + IF ( ND10 > 0 ) THEN + AD10em(I,J,3) = AD10em(I,J,3) + ( BIOFUEL(IDBFCO,I,J) * + & ( ( 0.189d0 * H2CO_YIELD(I,J,1) ) + 0.322d0 ) * + & BXHEIGHT(I,J,1)*100d0 ) + ENDIF + + ! Add H2 HD biomass burning to corresponding tracers - + ! - total H2/HD [kg H2/HD] + STT(I,J,1,IDTH2) = STT(I,J,1,IDTH2) + E_H2 + STT(I,J,1,IDTHD) = STT(I,J,1,IDTHD) + E_HD + + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + !================================================================= + ! Process emissions of ISOPRENE, MONOTERPENES, METHANOL + ! and ACETONE -- save into summing arrays for later use + ! Also process ocean emissions for H2. + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, AREA_CM2, IJLOOP, TMMP, EMXX, EMMO, EMAC, EMOC ) +!$OMP+PRIVATE( E_H2, E_HD ) + DO J = 1, JJPAR + + ! Grid box surface area [cm2] + AREA_CM2 = GET_AREA_CM2( J ) + + DO I = 1, IIPAR + + ! 1-D array index + IJLOOP = ( (J-1) * IIPAR ) + I + + !=========================================================== + ! The CO and H2 yields from ISOP, MONOTERPENES, and CH3OH will be + ! computed in subroutine CHEM_H2_HD. P(CO) from CH3OH + ! will be scaled to isoprene emissions within subroutine + ! CHEM_H2_HD + !=========================================================== + + ! Surface air temperature [K] + TMMP = XLTMMP(I,J,IJLOOP) + + ! ISOP and MONOTERPENE emissions in [atoms C/box/time step] + ! SUNCOS is COSINE( solar zenith angle ) + EMXX = EMISOP( I, J, IJLOOP, SUNCOS, TMMP, XNUMOL_ISOP ) + EMMO = EMMONOT( IJLOOP, TMMP, XNUMOL_MONO ) + + ! Store ISOP and MONOTERPENE emissions [atoms C/box/time step] + ! for later use in the subroutine CHEM_H2_HD + SUMISOPCO(I,J) = SUMISOPCO(I,J) + EMXX + SUMMONOCO(I,J) = SUMMONOCO(I,J) + EMMO + + ! ND46 -- save biogenic emissions [atoms C/cm2/s] here + IF ( ND46 > 0 ) THEN + + ! Isoprene + AD46(I,J,1) = AD46(I,J,1) + ( EMXX / AREA_CM2 / DTSRCE ) + + ! Monoterpenes + AD46(I,J,4) = AD46(I,J,4) + ( EMMO / AREA_CM2 / DTSRCE ) + + ENDIF + + !=========================================================== + ! For GEOS-1, GEOS-STRAT, GEOS-3, extract acetone emission + ! fluxes the EMACET array for the current month + !=========================================================== + + ! EMAC = [atoms C/box/s] from acetone + EMAC = EMACET( I, J ) + + ! Sum acetone loss for use in chemco_decay + ! Units = [atoms C/box/timestep] + SUMACETCO(I,J) = SUMACETCO(I,J) + (EMAC * DTSRCE * AREA_CM2) + + !=========================================================== + ! For GEOS-4 (?) and GEOS-3, extract ocean emissions + ! fluxes the EMOCEAN array for the current month + !=========================================================== + + ! EMOC = [molec/cm2/s] Ocean emissions of H2 from N-fixation + EMOC = EMOCEAN( I, J ) + + ! Calculate HD ocean source (molec HD/cm2/s) + ! assume delD=-628 permil + ! add missing factor of 2 (jaegle 12/23/05) + + E_HD = EMOC * 5.79427d-5 * 2.d0 + + ! diag 10 + IF ( ND10 > 0 ) THEN + AD10em(I,J,4) = AD10em(I,J,4) + EMOC + AD10em(I,J,5) = AD10em(I,J,5) + E_HD + ENDIF + + ! Convert ocean H2 source from [molec H2/cm2/s] to [kg H2] + E_H2 = EMOC * ( AREA_CM2 * DTSRCE / XNUMOL_H2 ) + + ! Scale E_HD by ocean isotopic signature ratio + ! of -628 permil (Rice & Quay, 2007) + ! (DH/H2)ocean = 5.79427d-5 * 2 + + E_HD = ( EMOC * 5.79427d-5 * 2d0) * + & ( AREA_CM2 * DTSRCE / XNUMOL_HD ) + + ! Add H2 HD biomass burning to corresponding tracers - + ! - total H2/HD [kg H2/HD] + STT(I,J,1,IDTH2) = STT(I,J,1,IDTH2) + E_H2 + STT(I,J,1,IDTHD) = STT(I,J,1,IDTHD) + E_HD + + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE EMISS_H2_HD + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_H2_HD +! +!****************************************************************************** +! Subroutine CHEM_H2_HD performs H2 and HD chemistry. Chemical production is +! by oxidation of BVOC and CH4. Loss is via reaction with OH and uptake by +! soils. In the stratosphere, H2 is also lost by reaction with O(1D). For +! HD, we include the fractionation from photochemical oxidation (162 permil), +! and loss by OH and soil uptake. (lyj, hup, phs, 9/18/07) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : AD, AIRVOL, T + USE DIAG_MOD, ONLY : AD10 + USE ERROR_MOD, ONLY : CHECK_VALUE + USE GLOBAL_OH_MOD, ONLY : GET_GLOBAL_OH, OH + USE GLOBAL_O1D_MOD, ONLY : GET_GLOBAL_O1D, O1D + USE GLOBAL_NOX_MOD, ONLY : GET_GLOBAL_NOX, BNOX + USE GRID_MOD, ONLY : GET_YMID, GET_AREA_M2, GET_AREA_CM2 + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + USE TIME_MOD, ONLY : GET_TS_CHEM, GET_MONTH, GET_YEAR + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH, ITS_A_NEW_YEAR + USE DRYDEP_MOD, ONLY : DEPSAV + USE TRACER_MOD, ONLY : N_TRACERS, STT + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT + USE TRACERID_MOD, ONLY : IDTH2, IDTHD + USE TAGGED_CO_MOD, ONLY : GET_ALPHA_ISOP, READ_PCO_LCO_STRAT + USE TAGGED_CO_MOD, ONLY : GET_PCO_LCO_STRAT + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DEP" ! FRCLND +# include "CMN_DIAG" ! ND65 + + ! Local variables + LOGICAL, SAVE :: FIRSTCHEM = .TRUE. + INTEGER :: I, J, L, N, MONTH + REAL*8 :: ALPHA_CH4, ALPHA_ISOP, ALPHA_MONO + REAL*8 :: DTCHEM, GH2, PCO + REAL*8 :: GHD, STTHD + REAL*8 :: STTH2, KRATE, CH4 + REAL*8 :: H2_CH4, H2_ISOP, H2_MONO + REAL*8 :: H2_CH3OH, H2_OH, H2_ACET + REAL*8 :: HD_OH, O1DRATE, HD_RATE + REAL*8 :: HD_O1D, H2_O1D, HD_CH4 + REAL*8 :: CH4RATE, DENS, ALPHA_ACET + REAL*8 :: CORATE, YMID, DPHOTO + REAL*8 :: KTEST(IIPAR, JJPAR) + REAL*8 :: AREA_CM2, SVEL, FLUX + REAL*8 :: THIK, P2, DRYF, TESTVAR + REAL*8 :: FRACLOST, H2_RATE + + ! For saving CH4 latitudinal gradient + REAL*8, SAVE :: A3090S, A0030S, A0030N, A3090N + + ! External functions + REAL*8, EXTERNAL :: BOXVL + + ! WTAIR = molecular weight of air (g/mole) + REAL*8, PARAMETER :: WTAIR = 28.966d0 + + ! Switch to scale yield of isoprene from NOx concentration or not + LOGICAL, PARAMETER :: ALPHA_ISOP_FROM_NOX = .FALSE. + + ! Avoid array temporaries in CHECK_VALUE + INTEGER :: ERR_LOC(4) + CHARACTER(LEN=255) :: ERR_VAR + CHARACTER(LEN=255) :: ERR_MSG + + !================================================================= + ! CHEM_H2_HD begins here! + ! + ! Do the following on the first calla to CHEM_H2_HD... + !================================================================= + IF ( FIRSTCHEM ) THEN + FIRSTCHEM = .FALSE. + ENDIF + + ! DTCHEM is the chemistry timestep in seconds + DTCHEM = GET_TS_CHEM() * 60d0 + + !================================================================= + ! Read in OH, O1D, NOx, P(CO), and L(CO) fields for the current month + !================================================================= + IF ( ITS_A_NEW_MONTH() ) THEN + + ! Get current month + MONTH = GET_MONTH() + + ! Global OH + CALL GET_GLOBAL_OH( MONTH ) + + ! Global O1D + CALL GET_GLOBAL_O1D( MONTH ) + + ! Global NOx -- need this to determine + ! ALPHA_ISOP which is a function of NOx + IF ( ALPHA_ISOP_FROM_NOX ) CALL GET_GLOBAL_NOX( MONTH ) + + ! Read in the loss/production of CO in the stratosphere. + CALL READ_PCO_LCO_STRAT( MONTH ) + ENDIF + + !================================================================= + ! Get the yearly and latitudinal gradients for CH4 + ! This only needs to be called once per year + !================================================================= + IF ( ITS_A_NEW_YEAR() ) THEN + CALL GET_GLOBAL_CH4( GET_YEAR(), .TRUE., + & A3090S, A0030S, A0030N, A3090N ) + ENDIF + + !================================================================= + ! Do H2 and HD chemistry + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, STTH2, GH2, DENS, CH4RATE, H2_CH4, CH4 ) +!$OMP+PRIVATE( ALPHA_CH4, KRATE, H2_ISOP, H2_CH3OH, ALPHA_ISOP ) +!$OMP+PRIVATE( H2_MONO, ALPHA_MONO, H2_ACET, ALPHA_ACET, CORATE ) +!$OMP+PRIVATE( H2_OH, YMID, DPHOTO, SVEL, FLUX, AREA_CM2 ) +!$OMP+PRIVATE( GHD, STTHD, HD_OH, HD_CH4, HD_O1D, H2_RATE, HD_RATE) +!$OMP+PRIVATE( H2_O1D, DRYF, P2, THIK, FRACLOST ) + + DO L = 1, LLPAR + DO J = 1, JJPAR + + ! Latitude of grid box + YMID = GET_YMID( J ) + + DO I = 1, IIPAR + + !============================================================== + ! (0) Define useful quantities + !============================================================== + + ! STTH2 [molec H2/cm3/kg H2] converts [kg H2] --> [molec H2/cm3] + ! kg H2/box * box/cm3 * mole/0.002 kg H2 * Avog.#/mole + STTH2 = 1d0 / AIRVOL(I,J,L) / 1d6 / FMOL_H2 * 6.023d23 + + STTHD = 1d0 / AIRVOL(I,J,L) / 1d6 / FMOL_HD * 6.023d23 + + ! GH2 is H2 concentration in [molec H2/cm3] + GH2 = STT(I,J,L,IDTH2) * STTH2 + + ! GHD is HD concentration in [molec HD/cm3] + GHD = STT(I,J,L,IDTHD) * STTHD + + ! DENS is the number density of air [molec air/cm3] + DENS = AD(I,J,L) * 1000.d0 / BOXVL(I,J,L) * 6.023d23 / WTAIR + + !============================================================== + ! (1a) Production of H2 and HD by methane oxidation + !============================================================== + + ! Initialize + H2_CH4 = 0d0 + + ! Test level for stratosphere or troposphere + IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN + + !=========================================================== + ! (1a-1) Production of H2 from CH4 in the stratosphere + ! This is based on the CO production rates in the + ! stratosphere, scaled by a 0.43 H2/CO yield. + ! For HD, we deal with the stratosphere in + ! upbdflx_mod.f, using an adapted version of + ! SYNOZ. + !=========================================================== + + ! Call GET_PCO_LCO_STRAT to get the P(CO) rate from CH4 + CH4RATE = GET_PCO_LCO_STRAT( .TRUE., I, J, L ) + + ! Convert units of CH4RATE from [v/v/s] to [molec H2/cm3] + ! In the stratosphere, we use a H2/CO yield of 0.43 + H2_CH4 = CH4RATE * DTCHEM * DENS * 0.43d0 + + ! no HD from CH4 + HD_CH4 = 0d0 + + ! Set stratospheric signature of photochemical oxidation to + ! zero (lyj, 01/13/06) + DPHOTO = 0d0 + + ELSE + + !=========================================================== + ! (1a-2) Production of H2 from CH4 in the troposphere + ! From the photocissoc coef of formaldehyde one finds that + ! the channel leading to H2 + CO as dissoc products contrib + ! roughly 50% of the yield of CO accd to Novelli, 1999 + ! (hup, 5/27/2004) + ! We assume an isotopic fractionation signature from + ! photochemical oxidation fo 162 permil. See + ! Price et al. [2007] + !=========================================================== + + ! CH4 concentration [ppbv] for the given latitude band + ! (bmy, 1/2/01) + CH4 = A3090S + IF ( YMID >= -30.0 .and. YMID < 0.0 ) CH4 = A0030S + IF ( YMID >= 0.0 .and. YMID < 30.0 ) CH4 = A0030N + IF ( YMID >= 30.0 ) CH4 = A3090N + + ! Convert CH4 from [ppbv] to [molec CH4/cm3] + CH4 = CH4 * 1d-9 * DENS + + ! Yield of CO from CH4: estimated to be 95-100% (acf) + ALPHA_CH4 = 1d0 + + ! Calculate updated rate constant [s-1] (bnd, bmy, 1/2/01) + KRATE = 2.45D-12 * EXP( -1775.d0 / T(I,J,L) ) + + ! Production of CO from CH4 = alpha * k * [CH4] * [OH] * dt + ! Scale this by the H2 yield relative to CO + ! Units are [molec H2/cm3] + H2_CH4 = ALPHA_CH4 * H2CO_YIELD(I,J,L) * KRATE * + & CH4 * OH(I,J,L) * DTCHEM + + ! HD Photochemical Signature in troposphere of + ! delD(hv)=162 permil (hup, 8/14/2006) + ! This means H/D(hv)=1.8099311d-4 + ! and H2/HD(hv) = 1.8099311d-4 * 2.d0 + DPHOTO = 1.8099311d-4 * 2.d0 + + ! Calculated CH4 oxidation source of HD in troposphere + HD_CH4 = H2_CH4 * DPHOTO + + ENDIF + + ! Check H2_CH4 for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'H2_CH4' + ERR_MSG = 'STOP at h2_hd_mod:1' + CALL CHECK_VALUE( H2_CH4, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + !============================================================== + ! (1b) Production of H2 from ISOPRENE and METHANOL (CH3OH) + !============================================================== + + ! Initialize + H2_ISOP = 0d0 + H2_CH3OH = 0d0 + + ! Isoprene is emitted only into the surface layer + IF ( L == 1 ) THEN + + !=========================================================== + ! Yield of CO from ISOP: 30%, from Miyoshi et al., 1994. + ! They estimate globally 105 Tg C/yr of CO is produced + ! from isoprene oxidation. + ! + ! Increased this factor from 30% to 50% (bnd, bmy, 1/3/01) + !----------------------------------------------------------- + ! We need to scale the Isoprene flux to get the CH3OH + ! (methanol) flux. Currently, the annual isoprene flux in + ! GEOS-CHEM is ~ 397 Tg C. + ! + ! Daniel Jacob recommends a flux of 100 Tg/yr CO from CH3OH + ! oxidation based on Singh et al. 2000 [JGR 105, 3795-3805] + ! who estimate a global methanol source of 122 Tg yr-1, of + ! which most (75 Tg yr-1) is "primary biogenic". He also + ! recommends for now that the CO flux from CH3OH oxidation + ! be scaled to monthly mean isoprene flux. + ! + ! To get CO from METHANOL oxidation, we must therefore + ! multiply the ISOPRENE flux by the following scale factor: + ! ( 100 Tg CO / 397 Tg C ) * ( 12 g C/mole / 28 g CO/mole ) + !----------------------------------------------------------- + ! We now call GET_ALPHA_ISOP to get the yield factor of + ! CO produced from isoprene, as a function of NOx, or + ! as a constant. (bnd, bmy, 6/14/01) + !----------------------------------------------------------- + ! To obtain H2 sources, we scale all of these BVOC emissions + ! by the H2/CO photochemical yield. (hup,jaegle, 04/20/07) + !=========================================================== + + ! Get CO yield from isoprene + IF ( ALPHA_ISOP_FROM_NOX ) THEN + ALPHA_ISOP = GET_ALPHA_ISOP( .TRUE., BNOX(I,J,L) ) + ELSE + ALPHA_ISOP = GET_ALPHA_ISOP( .FALSE. ) + ENDIF + + ! scale ALPHA_ISOP by the relative H2/CO yield + ALPHA_ISOP = ALPHA_ISOP * H2CO_YIELD(I,J,L) + + ! P(CO) from Isoprene Flux = ALPHA_ISOP * Flux(ISOP) + ! Convert from [molec ISOP/box] to [molec CO/cm3] + ! Also account for the fact that ISOP has 5 carbons + H2_ISOP = SUMISOPCO(I,J) / BOXVL(I,J,L) / 5.d0 * ALPHA_ISOP + + ! P(CO) from CH3OH is scaled to Isoprene Flux (see above) + ! Units are [molec CO/cm3] + ! For H2, scale by the relative CO/H2 molar weights and + ! the H2/CO yields. + H2_CH3OH = ( SUMISOPCO(I,J) / BOXVL(I,J,L) ) * + & ( 100d0 / 397d0 ) * + & ( H2CO_YIELD(I,J,L) ) * + & ( 12d0 / 28d0 ) + + ! Zero SUMISOPCO and SUMCH3OHCO for the next emission step + SUMISOPCO(I,J) = 0d0 + SUMCH3OHCO(I,J) = 0d0 + + ! Check H2_ISOP for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'H2_ISOP' + ERR_MSG = 'STOP at h2_hd_mod:2' + CALL CHECK_VALUE( H2_ISOP, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + ! Check H2_CH4 for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'H2_CH3OH' + ERR_MSG = 'STOP at h2_hd_mod:3' + CALL CHECK_VALUE( H2_CH3OH, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + ENDIF + + !============================================================== + ! (1c) Production of H2 from MONOTERPENE oxidation + !============================================================== + + ! Initialize + H2_MONO = 0.d0 + + ! Monoterpenes are emitted only into the surface layer + IF ( L == 1 ) THEN + + !=========================================================== + ! Assume the production of H2 from monoterpenes is + ! instantaneous even though the lifetime of intermediate + ! species may be on the order of hours or days. This + ! assumption will likely cause H2 from monoterpene + ! oxidation to be too high in the box in which the + ! monoterpene is emitted. + !----------------------------------------------------------- + ! The CO yield here is taken from: + ! Hatakeyama et al. JGR, Vol. 96, p. 947-958 (1991) + ! Vinckier et al. Fresenius Env. Bull., Vol. 7, p.361-368 + ! (1998) + ! + ! Hatakeyama: "The ultimate yield of CO from the + ! tropospheric oxidation of terpenes (including both O3 + ! and OH reactions) was estimated to be 20% on the carbon + ! number basis." They studied ALPHA- & BETA-pinene. + ! + ! Vinckier : "R(CO)=1.8+/-0.3" : 1.8/10 is about 20%. + !----------------------------------------------------------- + ! Calculate source of CO per time step from monoterpene + ! flux (assume lifetime very short) using the C number basis: + ! + ! CO [molec CO/cm3] = Flux [atoms C from MONO/box] / + ! Grid Box Volume [cm^-3] * + ! ALPHA_MONO + ! + ! where ALPHA_MONO = 0.2 as explained above. + !----------------------------------------------------------- + ! For H2, scale by the H2 to CO photochemical yield. + !=========================================================== + + ! Yield of CO from MONOTERPENES: 20% (see above) + ALPHA_MONO = 0.20d0 + + ! P(CO) from Monoterpene Flux = alpha * Flux(Mono) + ! Units are [molec H2/cm3]. Scale by the + ! H2/CO photochemical yield. + H2_MONO = ( SUMMONOCO(I,J) / BOXVL(I,J,L) ) * + & ( ALPHA_MONO * H2CO_YIELD(I,J,L) ) + + ! Zero SUMMONOCO for the next emission step + SUMMONOCO(I,J) = 0d0 + + ! Check H2_MONO for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'H2_MONO' + ERR_MSG = 'STOP at h2_hd_mod:4' + CALL CHECK_VALUE( H2_MONO, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + ENDIF + + !============================================================== + ! (1d) Production of H2 from oxidation of ACETONE + ! + ! ALPHA_ACET = 2/3 to get a yield for CO. This accounts + ! for acetonWRITE (6, *) 'DTC 2', DTC, AREA_CM2e loss + ! from reaction with OH And photolysis. + ! The acetone sources taken into account are: + ! + ! (a) Primary emissions of acetone from biogenic sources + ! (b) Secondary production of acetone from monoterpene + ! oxidation + ! (c) Secondary production of acetone from ALK4 and + ! propane oxidation + ! (d) Direct emissions of acetone from biomass burning and + ! fossil fuels + ! (e) direct emissions from ocean + ! + ! Calculate source of CO per time step from biogenic acetone + ! # molec CO/cc = ALPHA * ACET Emission Rate * dt + !----------------------------------------------------------- + ! For H2, scale by the H2 to CO photochemical yield. + !============================================================== + + ! Initialize + H2_ACET = 0.d0 + + ! Biogenic acetone sources are emitted only into the surface layer + IF ( L == 1 ) THEN + + ! Yield of CO from ACETONE: 2/3 (see above) + ALPHA_ACET = 2.D0 / 3.D0 + + ! Units are [molec H2/cc]. Scale by the H2/CO yield. + H2_ACET = SUMACETCO(I,J) / BOXVL(I,J,L) * + & ALPHA_ACET * H2CO_YIELD (I,J,L) + + ! Zero SUMACETCO for the next emission step + SUMACETCO(I,J) = 0d0 + + ! Check H2_ACET for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'H2_ACET' + ERR_MSG = 'STOP at h2_hd_mod:5' + CALL CHECK_VALUE( H2_ACET, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + + ENDIF + + + !============================================================== + ! (2a) Loss of H2 and HD due to chemical reaction w/ OH and O1D + !============================================================== + + ! Initialize + H2_OH = 0.d0 + HD_OH = 0.d0 + H2_O1D = 0.d0 + HD_O1D = 0.d0 + + ! Select out tropospheric or stratospheric boxes + IF ( ITS_IN_THE_STRAT( I, J, L ) ) THEN + + !=========================================================== + ! (2a-1) Stratospheric loss H2 HD due to chem rxn w/OH & O1D + !=========================================================== + + ! Get the L(CO) rate in the stratosphere in [s-1] + CORATE = GET_PCO_LCO_STRAT( .FALSE., I, J, L ) + + ! Rate constants for H2+OH and HD+OH from JPL, 2004 (hup, 06/28/04) + H2_RATE = 5.5D-12 * EXP( -2000.d0 / T(I,J,L) ) + HD_RATE = 5.0D-12 * EXP( -2130.d0 / T(I,J,L) ) + + ! H2_OH = Stratospheric loss of H2 by OH [molec/cm3] + ! alpha=0.52 for HD-OH in strat 230K (Rockmann et al., 2003) + ! alpha changes with temperature so just use the explicit + ! rate constant for HD + OH rxn(hup, 5/27/2005) + H2_OH = H2_RATE * GH2 * OH(I,J,L) * DTCHEM + + ! For now we overwrite this with zero, as the + ! stratospheric HD is dealt with simply in + ! updflux_mod.f - in the future this could be improved + ! by including more explicitely the isotopic enrichment + ! of CH4 in the stratosphere (jaegle, 4/20/07) + HD_OH = 0d0 + + ! Stratospheric loss of H2 and HD by O1D. Decay rate is same + !(1.1D-10 cm3 molecule-1 s-1) in stratosphere.(hup, 4/26/2005) + O1DRATE = 1.1D-10 + + H2_O1D = O1DRATE * GH2 * O1D(I,J,L) * DTCHEM + + ! Do not deal with this for HD. + HD_O1D = 0d0 + + ! Check values for NaN or Infinity + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'H2_OH' + ERR_MSG = 'STOP at h2_hd_mod:6' + CALL CHECK_VALUE( H2_OH, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + ERR_LOC = (/ I, J, L, 0 /) + ERR_VAR = 'H2_O1D' + ERR_MSG = 'STOP at h2_hd_mod:6' + CALL CHECK_VALUE( H2_O1D, ERR_LOC, + & ERR_VAR, ERR_MSG ) + + ELSE + + !=========================================================== + ! (2b-2) Tropospheric loss of H2 due to chemical rxn w/ OH + ! + ! DECAY RATE + ! The decay rate (H2_RATE) is calculated by: + ! + ! OH + H2 -> products + ! use: H2_RATE = 5.5D-12 * EXP( -2000.d0 / T ) + ! HD + H2 -> products + ! use: HD_RATE = 5.0D-12 * EXP(-2130.d0 / T ) + ! + ! H2_RATE has units of cm^3/molec sec + ! + ! (hup, 05/28/04) + !=========================================================== + + ! Loss for H2 and HD by reaction with OH accd JPL, 2004 + ! (hup, 06/28/04) + H2_RATE = 5.5D-12 * EXP( -2000.d0 / T(I,J,L) ) + HD_RATE = 5.0D-12 * EXP( -2130.d0 / T(I,J,L) ) + + ! H2_OH = Tropospheric loss of H2 by OH [molec/cm3] + H2_OH = H2_RATE * GH2 * OH(I,J,L) * DTCHEM + + ! HD_OH = Tropospheric loss of HD by OH [molec/cm3] + ! Calculated explicitely using the HD rate constant. + ! This results in a ~0.6 fractionation effect at 300K. + HD_OH = HD_RATE * GHD * OH(I,J,L) * DTCHEM + + ! HD_O1D and H2_O1D are both zero in the troposphere + H2_O1D = 0d0 + HD_O1D = 0d0 + + ENDIF + + !============================================================== + ! Save the total chemical production from various sources + ! into the total H2 tracer STT(I,J,L,1) + !============================================================== + + ! GH2 is the total H2 before chemistry + ! is applied [molec H2/cm3]. Add production from + ! oxidation of CH4, monoterpenes, acetone, methanol, + ! isoprene and remove loss from reactions with OH and O1D + GH2 = GH2 + H2_CH4 + H2_MONO + H2_ACET + + & H2_CH3OH + H2_ISOP - H2_OH - H2_O1D + + ! For HD, do the same, scaling the BVOC terms by the + ! photochemical enrichement term (DPHOTO=162 permil) + ! For methane, this is already done. + GHD = GHD + HD_CH4 + + & ( (H2_MONO + H2_ACET + H2_CH3OH + H2_ISOP ) * DPHOTO ) + & - HD_OH - HD_O1D + + ! Convert net H2 from [molec H2/cm3] to [kg] and store in STT + STT(I,J,L,IDTH2) = GH2 / STTH2 + + ! Convert net HD from [molec H2/cm3] to [kg] and store in STT + STT(I,J,L,IDTHD) = GHD / STTHD + + !============================================================== + ! Archive ND10 diagnostics -- Production & Loss of H2 + !============================================================== + IF ( ND10 > 0 .and. L <= LD10 ) THEN + + ! Loss of H2 by OH [molec CO/cm3/s] + N = 1 + AD10(I,J,L,N) = AD10(I,J,L,N) + ( H2_OH / DTCHEM ) + + ! Production of H2 from Isoprene [molec CO/cm3/s] + N = 2 + AD10(I,J,L,N) = AD10(I,J,L,N) + ( H2_ISOP / DTCHEM ) + + ! Production of H2 from CH4 [molec CO/cm3/s] + N = 3 + AD10(I,J,L,N) = AD10(I,J,L,N) + ( H2_CH4 / DTCHEM ) + + ! Production of from CH3OH [molec CO/cm3/s] + N = 4 + AD10(I,J,L,N) = AD10(I,J,L,N) + ( H2_CH3OH / DTCHEM ) + + ! Production of H2 from MONO [molec CO/cm3/s] + N = 5 + AD10(I,J,L,N) = AD10(I,J,L,N) + ( H2_MONO / DTCHEM ) + + ! Production of H2 from ACET [molec CO/cm3/s] + N = 6 + AD10(I,J,L,N) = AD10(I,J,L,N) + ( H2_ACET / DTCHEM ) + + ! Loss of H2 by O1D in the stratosphere [molec CO/cm3/s] + N = 7 + AD10(I,J,L,N) = AD10(I,J,L,N) + ( H2_O1D / DTCHEM ) + + !Loss of HD by OH [molec CO/cm3/s] + N = 8 + AD10(I,J,L,N) = AD10(I,J,L,N) + ( HD_OH / DTCHEM ) + + ! Production of HD from Isoprene [molec CO/cm3/s] + N = 9 + AD10(I,J,L,N) = AD10(I,J,L,N)+ + & ((H2_ISOP *DPHOTO) / DTCHEM) + + ! Production of HD from CH4 [molec CO/cm3/s] + N = 10 + AD10(I,J,L,N) = AD10(I,J,L,N) + ( HD_CH4 / DTCHEM ) + + ! Production of HD from CH3OH [molec CO/cm3/s] + N = 11 + AD10(I,J,L,N) = AD10(I,J,L,N)+ + & ((H2_CH3OH*DPHOTO) / DTCHEM) + + ! Production of HD from MONO [molec CO/cm3/s] + N = 12 + AD10(I,J,L,N) = AD10(I,J,L,N) + + & ((H2_MONO * DPHOTO) / DTCHEM) + + ! Production of HD from ACET [molec CO/cm3/s] + N = 13 + AD10(I,J,L,N) = AD10(I,J,L,N) + + & ((H2_ACET * DPHOTO) / DTCHEM) + + ! Loss of HD by O1D in the stratosphere [molec CO/cm3/s] + N = 14 + AD10(I,J,L,N) = AD10(I,J,L,N) + ( HD_O1D / DTCHEM ) + + ! Alpha (ratio of OH k rates kHD/kH2) + N = 15 + AD10(I,J,L,N) = AD10(I,J,L,N) + ( HD_RATE /H2_RATE ) + ENDIF + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE CHEM_H2_HD + +!----------------------------------------------------------------------------- + + SUBROUTINE READ_OCEAN_H2( THISMONTH ) +! +!****************************************************************************** +! Subroutine READ_OCEAN_H2 reads in oceanic H2 emissions from nitrogen +! fixation. (hup, lyj, phs, bmy, 9/18/07) +! +! Ocean H2 emissions are based on the N2 oceanic fixation rates +! determined by Curtis Deutsch (University of Washington) by +! assimilating observed nutrient distributions in the oceans: +! "Spatial coupling of nitrogen inputs and losses in the ocean", +! Deutsch et al., Nature 445, 163-167 (2007). +! +! The oceanic N2 fixation rates are read in and then scaled to +! obtain a total ocean H2 source of 6 TgH2/yr. This source is +! assumed to be constant and does not vary annually. +! +! Arguments as Input +! =========================================================================== +! (1 ) THISMONTH (INTEGER) : Current month (1-12) +! +! NOTES: +!****************************************************************************** +! + ! 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_2D + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: THISMONTH + + ! Local variables + INTEGER :: I, J + REAL*4 :: ARRAY(IGLOB,JGLOB,1) + REAL*8 :: TEMP(IIPAR,JJPAR) + REAL*8 :: XTAU, YMID + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_OCEAN_H2 begins here! + !================================================================= + + ! Name of file with annual ocean H2 emissions + FILENAME = TRIM( DATA_DIR ) // + & 'hydrogen_200704/Ocean_H2_annual.' // GET_NAME_EXT() // + & '.' // GET_RES_EXT() + + ! Echo to stdout + WRITE( 6, '(8x,a)' ) 'Reading ', TRIM( FILENAME ) + + ! Initialize some variables + EMOCEAN = 0d0 + + ! TAU value at the beginning of this month for 1994 + XTAU = GET_TAU0( THISMONTH, 1, 1985 ) + + !================================================================= + ! Read ocean emissions + !================================================================= + + ! Initialize ARRAY + ARRAY = 0e0 + + ! Read data! + CALL READ_BPCH2( FILENAME, 'H2FIX', 1, + & XTAU, IGLOB, JGLOB, + & 1, ARRAY(:,:,1), QUIET=.FALSE. ) + + ! Cast from REAL*4 to REAL*8 and resize to (IIPAR,JJPAR) + CALL TRANSFER_2D( ARRAY(:,:,1), EMOCEAN ) + + ! Return to calling program + END SUBROUTINE READ_OCEAN_H2 + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_H2YIELD( THISMONTH ) +! +!****************************************************************************** +! Subroutine READ_H2YIELD reads in the relative H2/CO yield from photochemical +! production. This has been archived monthly (PH2/PCO using the PRODLOSS +! diagnostic and turning H2 on as an active species) from a full chemistry +! simulation at 4x5, v7-03-03, year 2001, GEOS-3 met fields. +! (lyj, hup, phs, bmy, 9/18/07) +! +! Arguments as Input +! =========================================================================== +! (1 ) THISMONTH (INTEGER) : Current month (1-12) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE TRANSFER_MOD, ONLY : TRANSFER_3D + USE DIRECTORY_MOD, ONLY : DATA_DIR +! USE GRID_MOD, ONLY : GET_YMID + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: THISMONTH + + ! Local variables + INTEGER :: I, J + REAL*4 :: ARRAY(IGLOB,JGLOB,LGLOB) + REAL*8 :: TEMP(IIPAR,JJPAR,LLPAR) + REAL*8 :: XTAU!, YMID + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_H2YIELD begins here! + !================================================================= + + ! File with H2/CO yields + FILENAME = TRIM( DATA_DIR ) // + & 'hydrogen_200704/H2COyield.' // GET_NAME_EXT() // + & '.' // GET_RES_EXT() + + ! Echo to stdout + WRITE( 6, '(a)' ) 'READING ', TRIM( FILENAME ) + + ! TAU value at the beginning of this month for 1985 + XTAU = GET_TAU0( THISMONTH, 1, 1985 ) + + !================================================================= + ! Read Monthly H2/CO relative yields + !================================================================= + + ! Initialize ARRAY and Yield + ARRAY = 0e0 + + ! Read data! + CALL READ_BPCH2( FILENAME, 'PORL-L=$', 1, + & XTAU, IGLOB, JGLOB, + & LGLOB, ARRAY ) + + ! Cast from REAL*4 to REAL*8 and resize to (IIPAR,JJPAR) + CALL TRANSFER_3D( ARRAY, H2CO_YIELD ) + + ! Return to calling program + END SUBROUTINE READ_H2YIELD + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_H2_HD +! +!****************************************************************************** +! Subroutine INIT_H2_HD allocates memory to module arrays. +! (lyj, hyp, phs, bmy, 9/18/07) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" + + ! Local variables + INTEGER :: AS, I, J, IJLOOP + + !================================================================= + ! INIT_H2_HD begins here! + !================================================================= + + ! Allocate SUMISOPCO -- array for CO from isoprene + ALLOCATE( SUMISOPCO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SUMISOPCO' ) + SUMISOPCO = 0d0 + + ! Allocate SUMISOPCO -- array for CO from isoprene + ALLOCATE( SUMMONOCO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SUMMONOCO' ) + SUMMONOCO = 0d0 + + ! Allocate SUMISOPCO -- array for CO from isoprene + ALLOCATE( SUMCH3OHCO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SUMCH3OHCO' ) + SUMCH3OHCO = 0d0 + + ! Allocate SUMACETCO -- array for CO from isoprene + ALLOCATE( SUMACETCO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SUMACETCO' ) + SUMACETCO = 0d0 + + ! Allocate array for H2 from ocean n2 fixation + ALLOCATE( EMOCEAN( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMOCEAN' ) + EMOCEAN = 0d0 + + ! Allocate array for H2 yield from photoch. production + ALLOCATE( H2CO_YIELD( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'H2CO_YIELD' ) + H2CO_YIELD = 0d0 + + ! Return to calling program + END SUBROUTINE INIT_H2_HD + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_H2_HD +! +!****************************************************************************** +! Subroutine CLEANUP_H2_HD deallocates memory from previously +! allocated module arrays. (lyj, hup, phs, bmy, 9/18/07) +! +! NOTES: +!****************************************************************************** +! + IF ( ALLOCATED( SUMISOPCO ) ) DEALLOCATE( SUMISOPCO ) + IF ( ALLOCATED( SUMMONOCO ) ) DEALLOCATE( SUMMONOCO ) + IF ( ALLOCATED( SUMCH3OHCO ) ) DEALLOCATE( SUMCH3OHCO ) + IF ( ALLOCATED( SUMACETCO ) ) DEALLOCATE( SUMACETCO ) + IF ( ALLOCATED( EMOCEAN ) ) DEALLOCATE( EMOCEAN ) + + ! Return to calling program + END SUBROUTINE CLEANUP_H2_HD + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE H2_HD_MOD diff --git a/code/hcn_ch3cn_mod.f b/code/hcn_ch3cn_mod.f new file mode 100644 index 0000000..a7c1206 --- /dev/null +++ b/code/hcn_ch3cn_mod.f @@ -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 diff --git a/code/htap_mod.f90 b/code/htap_mod.f90 new file mode 100644 index 0000000..0cebe5d --- /dev/null +++ b/code/htap_mod.f90 @@ -0,0 +1,1377 @@ +!------------------------------------------------------------------------------ +! CU Boulder Adjoint Modeling Group (Henze Group) ! +!------------------------------------------------------------------------------ +! +! !MODULE: htap_mod +! +! !DESCRIPTION: Module HTAP\_MOD contains variables and routines to +! read the HTAP V2 anthropogenic emissions. +!\\ +!\\ +! !INTERFACE: +! +MODULE HTAP_MOD + ! + ! !USES: + ! + IMPLICIT NONE +# include "define.h" +# include "netcdf.inc" + PRIVATE + ! + ! !PUBLIC MEMBER FUNCTIONS: + ! + PUBLIC :: CLEANUP_HTAP + PUBLIC :: EMISS_HTAP + PUBLIC :: GET_HTAP + PUBLIC :: SC_AIR, SC_SHIPS, SC_ENERGY, SC_INDUSTRY + PUBLIC :: SC_TRANSPORT, SC_RESIDENTIAL, SC_AGRICULTURE + PUBLIC :: SC_BC, SC_CO, SC_OC, SC_NH3, SC_NOX, SC_SO2 + PUBLIC :: SC_CH2O, SC_PM25, htap_rcptr_mask + PUBLIC :: LOCN, LNAM, LEUR, LSAS, LEAS + PUBLIC :: LSEA, LPAN, LNAF, LSAF, LMDE, LMCA + PUBLIC :: LSAM, LRBU, LCAS, LNPO, LSPO + PUBLIC :: LOCN20, LOCN21, LOCN22, LOCN23, LOCN24 + PUBLIC :: LOCN25, LOCN26, LOCN27, LOCN28 + PUBLIC :: LNAM31, LNAM32, LNAM33, LNAM34, LNAM35 + PUBLIC :: LNAM36, LEUR41, LEUR42, LEUR43, LEUR44 + PUBLIC :: LSAS51, LSAS52, LSAS53, LEAS61, LEAS62 + PUBLIC :: LEAS63, LEAS64, LEAS65, LEAS66, LSEA71 + PUBLIC :: LSEA72, LPAN81, LPAN82, LPAN83, LNAF91 + PUBLIC :: LNAF92, LNAF93 + PUBLIC :: LSAF101, LSAF102, LSAF103, LMDE111, LMDE112 + PUBLIC :: LMDE113, LMCA121, LMCA122, LMCA123, LMCA124 + PUBLIC :: LSAM131, LSAM132, LSAM133, LSAM134, LRBU141 + PUBLIC :: LRBU142, LRBU143, LCAS151, LNPO150, LSPO160 + PUBLIC :: LSPO161 + ! + ! !PRIVATE MEMBER FUNCTIONS: + ! + PRIVATE :: INIT_HTAP + PRIVATE :: TOTAL_HTAP_TG + ! + ! !REMARKS: + + ! (1) + ! + ! !REVISION HISTORY: + ! Sep 2013 - Yanko Davila - initial version + !------------------------------------------------------------------------------ + ! + ! !PRIVATE TYPES: + ! + ! Arrays for emissions (lat/lon) + REAL*8, ALLOCATABLE, TARGET :: BC(:,:) + REAL*8, ALLOCATABLE, TARGET :: CO(:,:) + REAL*8, ALLOCATABLE, TARGET :: NH3(:,:) + REAL*8, ALLOCATABLE, TARGET :: NOX(:,:) + REAL*8, ALLOCATABLE, TARGET :: OC(:,:) + REAL*8, ALLOCATABLE, TARGET :: SO2(:,:) + REAL*8, ALLOCATABLE, TARGET :: PM25(:,:) + REAL*8, ALLOCATABLE, TARGET :: ALK4_HTAP(:,:) + REAL*8, ALLOCATABLE, TARGET :: ACET_HTAP(:,:) + REAL*8, ALLOCATABLE, TARGET :: MEK_HTAP (:,:) + REAL*8, ALLOCATABLE, TARGET :: ALD2_HTAP(:,:) + REAL*8, ALLOCATABLE, TARGET :: PRPE_HTAP(:,:) + REAL*8, ALLOCATABLE, TARGET :: C3H8_HTAP(:,:) + REAL*8, ALLOCATABLE, TARGET :: CH2O_HTAP(:,:) + REAL*8, ALLOCATABLE, TARGET :: C2H6_HTAP(:,:) + + ! Scaling Factors + REAL*8 :: SC_AIR, SC_SHIPS, SC_ENERGY, SC_INDUSTRY + REAL*8 :: SC_TRANSPORT, SC_RESIDENTIAL, SC_AGRICULTURE + REAL*8 :: SC_BC, SC_CO, SC_OC, SC_NH3, SC_NOX, SC_SO2 + REAL*8 :: SC_CH2O, SC_PM25 + LOGICAL :: LOCN, LNAM, LEUR, LSAS, LEAS + LOGICAL :: LSEA, LPAN, LNAF, LSAF, LMDE, LMCA + LOGICAL :: LSAM, LRBU, LCAS, LNPO, LSPO + LOGICAL :: LOCN20, LOCN21, LOCN22, LOCN23, LOCN24 + LOGICAL :: LOCN25, LOCN26, LOCN27, LOCN28 + LOGICAL :: LNAM31, LNAM32, LNAM33, LNAM34, LNAM35 + LOGICAL :: LNAM36, LEUR41, LEUR42, LEUR43, LEUR44 + LOGICAL :: LSAS51, LSAS52, LSAS53, LEAS61, LEAS62 + LOGICAL :: LEAS63, LEAS64, LEAS65, LEAS66, LSEA71 + LOGICAL :: LSEA72, LPAN81, LPAN82, LPAN83, LNAF91 + LOGICAL :: LNAF92, LNAF93 + LOGICAL :: LSAF101, LSAF102, LSAF103, LMDE111, LMDE112 + LOGICAL :: LMDE113, LMCA121, LMCA122, LMCA123, LMCA124 + LOGICAL :: LSAM131, LSAM132, LSAM133, LSAM134, LRBU141 + LOGICAL :: LRBU142, LRBU143, LCAS151, LNPO150, LSPO160 + LOGICAL :: LSPO161 + + CHARACTER(LEN=255) :: htap_rcptr_mask, htap_src_mask + + ! + ! !DEFINED PARAMETERS: + ! + REAL*8, PARAMETER :: SEC_IN_YEAR = 86400d0 * 365.25d0 + +CONTAINS + ! + ! !IROUTINE: get_htap + ! + ! !DESCRIPTION: Function GET\_HTAP returns the HTAP V2 + ! emission for GEOS-Chem grid box (I,J) and tracer N. + ! Emissions ARE returned in units of [kg/cm2/s]. + !\\ + ! !INTERFACE: + ! + FUNCTION GET_HTAP( I, J, N ) & + RESULT( VALUE ) + ! + ! !USES: + ! + USE TRACERID_MOD, ONLY : IDECO, IDENOX + USE TRACERID_MOD, ONLY : IDTSO2, IDTNH3 + USE TRACERID_MOD, ONLY : IDTOCPO, IDTBCPO + USE TRACERID_MOD, ONLY : IDEALK4, IDEACET + USE TRACERID_MOD, ONLY : IDEALD2, IDEPRPE + USE TRACERID_MOD, ONLY : IDEC3H8, IDECH2O + USE TRACERID_MOD, ONLY : IDEC2H6, IDEMEK + USE ERROR_MOD, ONLY : ERROR_STOP + + + ! + ! !INPUT PARAMETERS: + ! + ! Longitude, latitude, hour, and tracer indices + INTEGER, INTENT(IN) :: I, J, N + + ! + ! !RETURN VALUE: + ! + ! Emissions output + REAL*8 :: VALUE + ! + ! !REVISION HISTORY: + ! Sep 2013 - Yanko Davila - initial version + ! + !------------------------------------------------------------------------------ + + !================================================================= + ! GET_HTAP begins here! + !================================================================= + + IF ( N==IDTBCPO ) THEN + + ! BC [kg/m2/s] + VALUE = BC(I,J) + + ELSE IF ( N==IDECO ) THEN + + ! CO[kg/m2/s] + VALUE = CO(I,J) + + ELSE IF ( N==IDTNH3 ) THEN + + ! NH3[kg/m2/s] + VALUE = NH3(I,J) + + ELSE IF ( N==IDENOX ) THEN + + ! NOX[kg/m2/s] + VALUE = NOX(I,J) + + ELSE IF ( N==IDTOCPO ) THEN + + ! OC [kg/m2/s] + VALUE = OC(I,J) + + ELSE IF ( N==IDTSO2 ) THEN + + ! SO2 [kg/m2/s] + VALUE = SO2(I,J) + + ELSE IF ( N==IDEALK4 ) THEN + + ! NMVOC[kg/m2/s] + VALUE = ALK4_HTAP(I,J) + + ELSE IF ( N==IDEACET ) THEN + + ! NMVOC[kg/m2/s] + VALUE = ACET_HTAP(I,J) + + ELSE IF ( N==IDEMEK ) THEN + + ! NMVOC[kg/m2/s] + VALUE = MEK_HTAP(I,J) + + ELSE IF ( N==IDEALD2 ) THEN + + ! NMVOC[kg/m2/s] + VALUE = ALD2_HTAP(I,J) + + ELSE IF ( N==IDEPRPE ) THEN + + ! NMVOC[kg/m2/s] + VALUE = PRPE_HTAP(I,J) + + ELSE IF ( N==IDEC3H8 ) THEN + + ! NMVOC[kg/m2/s] + VALUE = C3H8_HTAP(I,J) + + ELSE IF ( N==IDECH2O ) THEN + + ! NMVOC[kg/m2/s] + VALUE = CH2O_HTAP(I,J) + + ELSE IF ( N==IDEC2H6 ) THEN + + ! NMVOC[kg/m2/s] + VALUE = C2H6_HTAP(I,J) + + ELSE + + ! Otherwise stop simulation to indicate + ! that there are no HTAP emissions for tracer N + !VALUE = -1d0 + !RETURN + CALL ERROR_STOP('HTAP emission missing for tracer' , 'GET_HTAP, htap_mod.f90' ) + + ENDIF + + + ! Return to calling program + END FUNCTION GET_HTAP + ! + ! !IROUTINE: emiss_htap + ! + ! !DESCRIPTION: Subroutine EMISS\_HTAP reads the HTAP v2 + ! emission fields at 0.1x0.1 resolution and regrids them to the + ! current model resolution. + !\\ + !\\ + ! !INTERFACE: + ! + SUBROUTINE EMISS_HTAP + ! + ! !USES: + ! + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE REGRID_A2A_MOD, ONLY : DO_REGRID_A2A, DO_REGRID_DKH + USE TIME_MOD, ONLY : GET_YEAR, GET_MONTH, GET_DAY + USE TIME_MOD, ONLY : GET_DAY_OF_WEEK, GET_HOUR + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACERID_MOD, ONLY : IDTCO + USE TRACERID_MOD, ONLY : IDTNOX, IDTOX + USE TRACERID_MOD, ONLY : IDTSO2, IDTNH3 + USE TRACERID_MOD, ONLY : IDTOCPO, IDTBCPO + USE TRACERID_MOD, ONLY : IDEALK4, IDEACET + USE TRACERID_MOD, ONLY : IDEALD2, IDEPRPE + USE TRACERID_MOD, ONLY : IDEC3H8, IDECH2O + USE TRACERID_MOD, ONLY : IDEC2H6, IDEMEK + USE TRACERID_MOD, ONLY : NEMANTHRO + USE m_netcdf_io_open + USE m_netcdf_io_read + USE m_netcdf_io_readattr + USE m_netcdf_io_close + USE m_netcdf_io_get_dimlen + ! debug + USE GRID_MOD, ONLY : GET_AREA_M2 + +# include "CMN_SIZE" ! Size parameters + ! + ! !REVISION HISTORY: + ! Sep 2013 - Yanko Davila - initial version + ! -------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + ! + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: netCDF + INTEGER, PARAMETER :: I01x01 = 3600, J01x01 = 1800 + INTEGER :: I, J, IH, THISMONTH, THISYEAR + INTEGER :: SNo, DAY_NUM, DOYT + INTEGER :: HH, KLM, ID, MN, N + INTEGER :: OFFLINE_ID(15) + INTEGER :: fId1, fId2 + INTEGER :: CAT + INTEGER :: II, JJ, ALK + REAL*8 :: ARRAY(I01x01,J01x01), MASK(I01x01,J01x01) + REAL*8 :: TMP_MASK(I01x01,J01x01), VOC_DATA(I01x01,J01x01,1) + REAL*8 :: ALK4_TMP(I01x01,J01x01) + REAL*8 :: C2H6_TMP (I01x01,J01x01) + REAL*8 :: C3H8_TMP (I01x01,J01x01) + REAL*8 :: PRPE_TMP (I01x01,J01x01) + REAL*8 :: CH2O_TMP (I01x01,J01x01) + REAL*8 :: ALD2_TMP (I01x01,J01x01) + REAL*8 :: ACET_TMP (I01x01,J01x01) + REAL*8 :: MEK_TMP (I01x01,J01x01) + REAL*8, TARGET :: GEOS_01x01(I01x01,J01x01) + CHARACTER(LEN=244) :: DATA_DIR_HTAP + CHARACTER(LEN=244) :: FILENAME, VOC_FILE, ALK_MASK + CHARACTER(LEN=4) :: SYEAR + CHARACTER(LEN=5) :: SNAME, HTAP_YEAR_2,SId + CHARACTER(LEN=6) :: HTAP_YEAR + CHARACTER(LEN=9) :: VId + CHARACTER(LEN=255) :: LLFILENAME + CHARACTER(LEN=24) :: SPCLIST(8), EMIS_TYPE(7), VAR_NAME(8) + CHARACTER(LEN=2) :: MONTH + CHARACTER(LEN=50) :: ALK_NUM(3) + REAL*8, POINTER :: OUTGRID(:,:) => NULL() + REAL*8, POINTER :: INGRID(:,:) => NULL() + ! Days per month + REAL*8 :: DAYS_IN_MONTH + REAL*8 :: DMON(12) + + !================================================================= + ! HTAP_ANTHRO begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + CALL INIT_HTAP + FIRST = .FALSE. + ENDIF + + ! Get emissions year + THISYEAR = GET_YEAR() + + ! Get month + THISMONTH = GET_MONTH() + +#if defined( GEOS_5 ) || defined( MERRA ) || defined( GEOS_57 ) + SNAME = 'GEOS5' +#elif defined( GCAP ) + SNAME = 'GEOS4' +#elif defined( GEOS_4 ) + SNAME = 'GEOS4' +#endif + + SPCLIST = (/ 'BC','CO', 'NH3', 'NMVOC','NOx', 'OC', 'SO2', 'PM2.5' /) + + VAR_NAME = (/ 'emi_bc','emi_co', 'emi_nh3', 'emi_nmvoc','emi_nox', 'emi_oc', 'emi_so2', 'emi_pm2.5' /) + + ALK_NUM = (/ '_butanes','_pentanes', '_hexanes_and_higher_alkanes' /) + + IF ( THISYEAR .eq. 2008 ) DMON = (/ 31d0, 29d0, 31d0, 30d0, & + 31d0, 30d0, 31d0, 31d0, & + 30d0, 31d0, 30d0, 31d0 /) + + IF ( THISYEAR .eq. 2010 ) DMON = (/ 31d0, 28d0, 31d0, 30d0, & + 31d0, 30d0, 31d0, 31d0, & + 30d0, 31d0, 30d0, 31d0 /) + + ! Get days per month + DAYS_IN_MONTH = DMON( GET_MONTH() ) + + ! File with lat/lon edges for regridding + LLFILENAME = TRIM( DATA_DIR_1x1) // & + 'MAP_A2A_Regrid_201203/MAP_HTAP.nc' + + DATA_DIR_HTAP = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/edgar_HTAP_' + + + htap_src_mask = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/MASKS/HTAP_Phase2_tier1NC01x01_v2.nc' + + ALK4_TMP = 0d0 + C2H6_TMP = 0d0 + C3H8_TMP = 0d0 + PRPE_TMP = 0d0 + CH2O_TMP = 0d0 + ALD2_TMP = 0d0 + ACET_TMP = 0d0 + MEK_TMP = 0d0 + + + ! Loop over species + DO KLM = 1, SIZE( SPCLIST ) + + ! Set GEOS_01x01 + GEOS_01x01 = 0d0 + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + SId = SPCLIST( KLM ) + VId = VAR_NAME( KLM ) + ELSE + SNo = OFFLINE_ID( KLM ) + ENDIF + + + ! DataName for year + IF (THISYEAR .le. 2009) THEN + HTAP_YEAR = '_2008_' + HTAP_YEAR_2 = '_2008' + ELSE + HTAP_YEAR = '_2010_' + HTAP_YEAR_2 = '_2010' + ENDIF + + SELECT CASE ( THISMONTH ) + CASE ( 1 ) + MONTH = '1' + CASE ( 2 ) + MONTH = '2' + CASE ( 3 ) + MONTH = '3' + CASE ( 4 ) + MONTH = '4' + CASE ( 5 ) + MONTH = '5' + CASE ( 6 ) + MONTH = '6' + CASE ( 7 ) + MONTH = '7' + CASE ( 8 ) + MONTH = '8' + CASE ( 9 ) + MONTH = '9' + CASE ( 10 ) + MONTH = '10' + CASE ( 11 ) + MONTH = '11' + CASE ( 12 ) + MONTH = '12' + END SELECT + + EMIS_TYPE = (/ 'AIR', 'ENERGY', 'INDUSTRY', 'RESIDENTIAL', & + 'SHIPS', 'TRANSPORT', 'AGRICULTURE' /) + + DO CAT = 1, SIZE( EMIS_TYPE ) + + ! Set Mask + MASK = 0d0 + + ! Open model_ready mask from netCDF file + CALL Ncop_Rd(fId1, TRIM( htap_src_mask )) + + ! Read model_ready data from netCDF file + CALL NcRd(TMP_MASK, fId1, 'region_code', & + (/ 1, 1 /), & !Start + (/ I01x01, J01x01/) ) !Count lon/lat + + ! Close netCDF file + CALL NcCl( fId1 ) + + + ! Apply Source Mask Scaling + DO I = 1, I01x01 + + ! J on mask is N->S, but I on GEOS_01x01 is S->N + JJ = J01x01 + + DO J = 1, J01x01 + + IF ( LOCN ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 2d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LNAM ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 3d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LEUR ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 4d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LSAS ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 5d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LEAS ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 6d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LSEA ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 7d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LPAN ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 8d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LNAF ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 9d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LSAF ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 10d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LMDE ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 11d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LMCA ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 12d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LSAM ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 13d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LRBU ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 14d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LCAS ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 15d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LNPO ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 16d0 ) MASK(I,J) = 1d0 + ENDIF + + IF ( LSPO ) THEN + IF ( TMP_MASK(I,JJ) .EQ. 17d0 ) MASK(I,J) = 1d0 + ENDIF + + JJ = JJ - 1 + + ENDDO + ENDDO + + IF (.not. LOCN .and. .not. LNAM .and. .not. LEUR .and. & + .not. LSAS .and. .not. LEAS .and. .not. LSEA .and. & + .not. LPAN .and. .not. LNAF .and. .not. LSAF .and. & + .not. LMDE .and. .not. LMCA .and. .not. LSAM .and. & + .not. LRBU .and. .not. LCAS .and. .not. LNPO .and. & + .not. LSPO ) MASK = 1d0 + + ! Apply Sector Scaling Factor + IF ( TRIM( EMIS_TYPE(CAT) ) == 'AIR' ) & + MASK = MASK * SC_AIR + IF ( TRIM( EMIS_TYPE(CAT) ) == 'SHIPS' ) & + MASK = MASK * SC_SHIPS + IF ( TRIM( EMIS_TYPE(CAT) ) == 'ENERGY' ) & + MASK = MASK * SC_ENERGY + IF ( TRIM( EMIS_TYPE(CAT) ) == 'INDUSTRY' ) & + MASK = MASK * SC_INDUSTRY + IF ( TRIM( EMIS_TYPE(CAT) ) == 'TRANSPORT' ) & + MASK = MASK * SC_TRANSPORT + IF ( TRIM( EMIS_TYPE(CAT) ) == 'RESIDENTIAL' ) & + MASK = MASK * SC_RESIDENTIAL + IF ( TRIM( EMIS_TYPE(CAT) ) == 'AGRICULTURE' ) & + MASK = MASK * SC_AGRICULTURE + + ! Apply Species Scaling Factor + IF ( TRIM( SPCLIST(KLM) ) == 'BC' ) MASK = MASK * SC_BC + IF ( TRIM( SPCLIST(KLM) ) == 'CO' ) MASK = MASK * SC_CO + IF ( TRIM( SPCLIST(KLM) ) == 'OC' ) MASK = MASK * SC_OC + IF ( TRIM( SPCLIST(KLM) ) == 'NH3' ) MASK = MASK * SC_NH3 + IF ( TRIM( SPCLIST(KLM) ) == 'NOx' ) MASK = MASK * SC_NOX + IF ( TRIM( SPCLIST(KLM) ) == 'SO2' ) MASK = MASK * SC_SO2 + IF ( TRIM( SPCLIST(KLM) ) == 'NMVOC' ) MASK = MASK * SC_CH2O + + SELECT CASE ( EMIS_TYPE(CAT) ) + + + CASE ( 'AIR' ) + IF ( SPCLIST(KLM) == 'NH3' ) CYCLE + FILENAME = TRIM(DATA_DIR_HTAP) // TRIM(SPCLIST( KLM )) & + // '_emi_' // TRIM(EMIS_TYPE( CAT )) & + // TRIM(HTAP_YEAR_2) & + // '.0.1x0.1.nc' + + CASE ( 'SHIPS' ) + IF ( SPCLIST(KLM) == 'NH3' ) CYCLE + FILENAME = TRIM(DATA_DIR_HTAP) // TRIM(SPCLIST( KLM )) & + // '_emi_' // TRIM(EMIS_TYPE( CAT )) & + // TRIM(HTAP_YEAR_2) & + // '.0.1x0.1.nc' + + CASE ( 'AGRICULTURE' ) + IF ( SPCLIST(KLM) .NE. 'NH3' ) CYCLE + IF ( SPCLIST(KLM) == 'NH3' ) & + FILENAME = TRIM(DATA_DIR_HTAP) // TRIM(SPCLIST( KLM )) & + // '_emi_' // TRIM(EMIS_TYPE( CAT )) & + // TRIM(HTAP_YEAR) // TRIM( MONTH ) & + // '.0.1x0.1.nc' + + CASE DEFAULT + + FILENAME = TRIM(DATA_DIR_HTAP) // TRIM(SPCLIST( KLM )) & + // '_emi_' // TRIM(EMIS_TYPE( CAT )) & + // TRIM(HTAP_YEAR) // TRIM( MONTH ) & + // '.0.1x0.1.nc' + END SELECT + + IF ( TRIM( SId ) .NE. 'NMVOC') THEN + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Open model_ready data from netCDF file + CALL Ncop_Rd(fId1, TRIM(FILENAME)) + + ! Read model_ready data from netCDF file + CALL NcRd(ARRAY, fId1, TRIM(VId), & + (/ 1, 1 /), & !Start + (/ I01x01, J01x01/) ) !Count lat/lon + + ! Close netCDF file + CALL NcCl( fId1 ) + + ENDIF + + IF ( TRIM( SId ) == 'NMVOC' .and. & + .not. TRIM( EMIS_TYPE(CAT) ) == 'AIR' .and. & + .not. TRIM( EMIS_TYPE(CAT) ) == 'SHIPS' ) THEN + + DO N = 1, NEMANTHRO + + IF ( N == IDEC2H6 ) VOC_FILE = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/HTAPv2_' // TRIM( EMIS_TYPE(CAT) ) // & + '_ethane' // TRIM(HTAP_YEAR) // '0.1x0.1.nc' + + IF ( N == IDEC3H8 ) VOC_FILE = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/HTAPv2_' // TRIM( EMIS_TYPE(CAT) ) // & + '_propane' // TRIM(HTAP_YEAR) // '0.1x0.1.nc' + + IF ( N == IDEPRPE ) VOC_FILE = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/HTAPv2_' // TRIM( EMIS_TYPE(CAT) ) // & + '_propene' // TRIM(HTAP_YEAR) // '0.1x0.1.nc' + + IF ( N == IDECH2O ) VOC_FILE = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/HTAPv2_' // TRIM( EMIS_TYPE(CAT) ) // & + '_formaldehyde' // TRIM(HTAP_YEAR) // '0.1x0.1.nc' + + IF ( N == IDEALD2 ) VOC_FILE = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/HTAPv2_' // TRIM( EMIS_TYPE(CAT) ) // & + '_other_alkanals' // TRIM(HTAP_YEAR) // '0.1x0.1.nc' + + IF ( N == IDEACET ) VOC_FILE = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/HTAPv2_' // TRIM( EMIS_TYPE(CAT) ) // & + '_ketones' // TRIM(HTAP_YEAR) // '0.1x0.1.nc' + + IF ( N == IDEMEK ) VOC_FILE = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/HTAPv2_' // TRIM( EMIS_TYPE(CAT) ) // & + '_ketones' // TRIM(HTAP_YEAR) // '0.1x0.1.nc' + + IF ( N == IDEALK4 .or. N == IDEACET .or. & + N == IDEMEK .or. N == IDEPRPE .or. & + N == IDEC3H8 .or. N == IDECH2O .or. & + N == IDEC2H6 .or. N == IDEALD2 ) THEN + + ! Echo info + IF ( N .NE. IDEALK4 ) WRITE( 6, 100 ) TRIM( VOC_FILE ) + + ! Open model_ready data from netCDF file + CALL Ncop_Rd(fId1, TRIM(VOC_FILE)) + + SELECT CASE ( EMIS_TYPE(CAT) ) + + CASE ( 'ENERGY' ) + + ! Read model_ready data from netCDF file + CALL NcRd(VOC_DATA, fId1, 'emiss_ene', & + (/ 1, 1, 1 /), & !Start + (/ I01x01, J01x01, 1/) ) !Count lat/lon + + IF ( N == IDEALK4 ) THEN + DO ALK = 1, SIZE( ALK_NUM ) + + ALK_MASK = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/HTAPv2_' // & + TRIM( EMIS_TYPE(CAT) ) // & + TRIM( ALK_NUM( ALK ) ) // & + TRIM(HTAP_YEAR) // '0.1x0.1.nc' + + ! Echo info + WRITE( 6, 100 ) TRIM( ALK_MASK ) + + ! Open model_ready data from netCDF file + CALL Ncop_Rd(fId2, TRIM(ALK_MASK)) + + ! Read model_ready data from netCDF file + CALL NcRd(VOC_DATA, fId2, 'emiss_ene', & + (/ 1, 1, 1 /), & !Start + (/ I01x01, J01x01, 1/) ) !Count lat/lon + + DO I = 1, I01x01 + DO J = 1, J01x01 + IF (MASK(I,J) .GT. 0d0 ) THEN + + VOC_DATA(I,J,1) = VOC_DATA(I,J,1) * MASK(I,J) + + ENDIF + ENDDO + ENDDO + ALK4_TMP = ALK4_TMP + VOC_DATA(:,:,1) + + ! Close netCDF file + CALL NcCl( fId2 ) + + ENDDO + ENDIF + + + CASE ( 'TRANSPORT' ) + + ! Read model_ready data from netCDF file + CALL NcRd(VOC_DATA, fId1, 'emiss_tra', & + (/ 1, 1, 1 /), & !Start + (/ I01x01, J01x01, 1/) ) !Count lat/lon + + IF ( N == IDEALK4 ) THEN + DO ALK = 1, SIZE( ALK_NUM ) + + ALK_MASK = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/HTAPv2_' // & + TRIM( EMIS_TYPE(CAT) ) // & + TRIM( ALK_NUM( ALK ) ) // & + TRIM(HTAP_YEAR) // '0.1x0.1.nc' + + ! Echo info + IF ( N == IDEALK4 ) WRITE( 6, 100 ) TRIM( ALK_MASK ) + + ! Open model_ready data from netCDF file + CALL Ncop_Rd(fId2, TRIM(ALK_MASK)) + + ! Read model_ready data from netCDF file + CALL NcRd(VOC_DATA, fId2, 'emiss_tra', & + (/ 1, 1, 1 /), & !Start + (/ I01x01, J01x01, 1/) ) !Count lat/lon + + DO I = 1, I01x01 + DO J = 1, J01x01 + IF (MASK(I,J) .GT. 0d0 ) THEN + + VOC_DATA(I,J,1) = VOC_DATA(I,J,1) * MASK(I,J) + + ENDIF + ENDDO + ENDDO + ALK4_TMP = ALK4_TMP + VOC_DATA(:,:,1) + + ! Close netCDF file + CALL NcCl( fId2 ) + + ENDDO + ENDIF + + + CASE ( 'RESIDENTIAL' ) + + ! Read model_ready data from netCDF file + CALL NcRd(VOC_DATA, fId1, 'emiss_dom', & + (/ 1, 1, 1 /), & !Start + (/ I01x01, J01x01, 1/) ) !Count lat/lon + + IF ( N == IDEALK4 ) THEN + DO ALK = 1, SIZE( ALK_NUM ) + + ALK_MASK = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/HTAPv2_' // & + TRIM( EMIS_TYPE(CAT) ) // & + TRIM( ALK_NUM( ALK ) ) // & + TRIM(HTAP_YEAR) // '0.1x0.1.nc' + + ! Echo info + IF ( N == IDEALK4 ) WRITE( 6, 100 ) TRIM( ALK_MASK ) + + ! Open model_ready data from netCDF file + CALL Ncop_Rd(fId2, TRIM(ALK_MASK)) + + ! Read model_ready data from netCDF file + CALL NcRd(VOC_DATA, fId2, 'emiss_dom', & + (/ 1, 1, 1 /), & !Start + (/ I01x01, J01x01, 1/) ) !Count lat/lon + + DO I = 1, I01x01 + DO J = 1, J01x01 + IF (MASK(I,J) .GT. 0d0 ) THEN + + VOC_DATA(I,J,1) = VOC_DATA(I,J,1) * MASK(I,J) + + ENDIF + ENDDO + ENDDO + ALK4_TMP = ALK4_TMP + VOC_DATA(:,:,1) + + ! Close netCDF file + CALL NcCl( fId2 ) + + ENDDO + ENDIF + + + CASE ( 'INDUSTRY' ) + + ! Read model_ready data from netCDF file + CALL NcRd(VOC_DATA, fId1, 'emiss_ind', & + (/ 1, 1, 1 /), & !Start + (/ I01x01, J01x01, 1/) ) !Count lat/lon + + + IF ( N == IDEALK4 ) THEN + DO ALK = 1, SIZE( ALK_NUM ) + + ALK_MASK = TRIM( DATA_DIR_1x1 ) // & + 'HTAP/HTAPv2_' // & + TRIM( EMIS_TYPE(CAT) ) // & + TRIM( ALK_NUM( ALK ) ) // & + TRIM(HTAP_YEAR) // '0.1x0.1.nc' + + ! Echo info + IF ( N == IDEALK4 ) WRITE( 6, 100 ) TRIM( ALK_MASK ) + + ! Open model_ready data from netCDF file + CALL Ncop_Rd(fId2, TRIM(ALK_MASK)) + + ! Read model_ready data from netCDF file + CALL NcRd(VOC_DATA, fId2, 'emiss_ind', & + (/ 1, 1, 1 /), & !Start + (/ I01x01, J01x01, 1/) ) !Count lat/lon + + DO I = 1, I01x01 + DO J = 1, J01x01 + IF (MASK(I,J) .GT. 0d0 ) THEN + + VOC_DATA(I,J,1) = VOC_DATA(I,J,1) * MASK(I,J) + + ENDIF + ENDDO + ENDDO + ALK4_TMP = ALK4_TMP + VOC_DATA(:,:,1) + + ! Close netCDF file + CALL NcCl( fId2 ) + + ENDDO + ENDIF + + CASE DEFAULT + + !Do nothing + + END SELECT + + ! Close netCDF file + CALL NcCl( fId1 ) + + ENDIF + + DO I = 1, I01x01 + DO J = 1, J01x01 + IF (MASK(I,J) .GT. 0d0 ) THEN + + VOC_DATA(I,J,1) = VOC_DATA(I,J,1) * MASK(I,J) + + ENDIF + ENDDO + ENDDO + + !Apply VOCs Speciation + IF ( N == IDEC2H6 ) C2H6_TMP = C2H6_TMP + VOC_DATA(:,:,1) + IF ( N == IDEC3H8 ) C3H8_TMP = C3H8_TMP + VOC_DATA(:,:,1) + IF ( N == IDEPRPE ) PRPE_TMP = PRPE_TMP + VOC_DATA(:,:,1) + IF ( N == IDECH2O ) CH2O_TMP = CH2O_TMP + VOC_DATA(:,:,1) + IF ( N == IDEALD2 ) ALD2_TMP = ALD2_TMP + VOC_DATA(:,:,1) + IF ( N == IDEACET ) ACET_TMP = ACET_TMP + VOC_DATA(:,:,1) + IF ( N == IDEMEK ) MEK_TMP = MEK_TMP + VOC_DATA(:,:,1) + + ENDDO + + ENDIF + + ! Apply Regional Mask if defined + DO I = 1, I01x01 + DO J = 1, J01x01 + IF (MASK(I,J) .GT. 0d0 ) THEN + + ARRAY(I,J) = ARRAY(I,J) * MASK(I,J) + + ENDIF + ENDDO + ENDDO + + ! Add sectors before regridding + GEOS_01x01(:,:) = GEOS_01x01(:,:) + ARRAY(:,:) + + ENDDO + +100 FORMAT( ' - EMISS_HTAP_0.1x0.1: & + Reading : ', a ) + + ! Regrid from GEOS 0.1x0.1 --> current model resolution + SELECT CASE ( SId ) + + CASE ( 'BC' ) + + !----------------- + ! BCPO + !----------------- + + INGRID => GEOS_01x01(:,:) + OUTGRID => BC(:,:) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + CASE ( 'CO' ) + + !----------------- + ! CO + !----------------- + ! Point to array slices + INGRID => GEOS_01x01(:,:) + OUTGRID => CO(:,:) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + CASE ( 'NH3' ) + + !----------------- + ! NH3 + !----------------- + + ! Point to array slices + INGRID => GEOS_01x01(:,:) + OUTGRID => NH3(:,:) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + CASE ( 'NMVOC' ) + + !----------------- + ! VOC + !----------------- + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + ALK4_TMP, ALK4_HTAP, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + ACET_TMP, ACET_HTAP, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + MEK_TMP, MEK_HTAP, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + ALD2_TMP, ALD2_HTAP, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + PRPE_TMP, PRPE_HTAP, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + C3H8_TMP, C3H8_HTAP, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + CH2O_TMP, CH2O_HTAP, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + C2H6_TMP, C2H6_HTAP, IS_MASS=0, & + netCDF=.TRUE. ) + + CASE ( 'NOx' ) + + !----------------- + ! NOX + !----------------- + ! Point to array slices + INGRID => GEOS_01x01(:,:) + OUTGRID => NOX(:,:) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + CASE ( 'OC' ) + + !----------------- + ! OCPO + !----------------- + + INGRID => GEOS_01x01(:,:) + OUTGRID => OC(:,:) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + ! Reset GEOS_01x01 + GEOS_01x01 = 0d0 + + CASE ( 'SO2' ) + + !----------------- + ! SO2 + !----------------- + + ! Point to array slices + INGRID => GEOS_01x01(:,:) + OUTGRID => SO2(:,:) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + CASE ( 'PM2.5' ) + + !----------------- + ! PM2.5 + !----------------- + + ! Point to array slices + INGRID => GEOS_01x01(:,:) + OUTGRID => PM25(:,:) + + ! Regrid + CALL DO_REGRID_DKH( LLFILENAME, I01x01, J01x01, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + + END SELECT + + ENDDO + + !-------------------------- + ! Print emission totals for the day + !-------------------------- + CALL TOTAL_HTAP_Tg( DOYT ) + + ! Return to calling program + END SUBROUTINE EMISS_HTAP + ! + ! !IROUTINE: total_htap_Tg + ! + ! !DESCRIPTION: Subroutine TOTAL\_ANTHRO\_TG prints the totals for the + ! anthropogenic emissions of NOx, CO, SO2 and NH3. + !\\ + !\\ + ! !INTERFACE: + ! + SUBROUTINE TOTAL_HTAP_TG( DAY ) + ! + ! !USES: + ! + USE GRID_MOD, ONLY : GET_AREA_M2 + USE TIME_MOD, ONLY : GET_YEAR, GET_MONTH + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTCO, IDTCH2O + USE TRACERID_MOD, ONLY : IDTSO2, IDTNH3, IDTNOx + USE TRACERID_MOD, ONLY : IDTOCPO, IDTBCPO + +# include "CMN_SIZE" ! Size parameters + + ! !INPUT PARAMETERS: + ! + INTEGER, INTENT(IN) :: DAY ! Day of data to compute totals + ! + ! !REVISION HISTORY: + ! Sept 2013 - Yanko Davila - initial version + !EOP + !------------------------------------------------------------------------------ + !BOC + ! + ! !LOCAL VARIABLES: + ! + INTEGER :: II, JJ, IH, LL + REAL*8 :: T_CO, T_NOx, T_SO2, T_NH3 + REAL*8 :: T_BC, T_OC + REAL*8 :: T_PM25 + REAL*8 :: T_ALK4, T_ACET, T_MEK, T_ALD2 + REAL*8 :: T_PRPE, T_C3H8, T_CH2O, T_C2H6 + + REAL*8 :: tmpArea(IIPAR, JJPAR) + CHARACTER(LEN=3) :: UNIT + REAL*8, PARAMETER :: SEC_IN_DAY = 86400d0 + ! Days per month + REAL*8 :: DAYS_IN_MONTH + REAL*8 :: DMON(12) + + !================================================================= + ! TOTAL_HTAP_TG begins here! + !================================================================= + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, 100 ) +100 FORMAT( 'H. T. A. P. E M I S S I O N S', / ) + + DO II = 1, IIPAR + DO JJ = 1, JJPAR + tmpArea(II,JJ) = GET_AREA_M2(JJ) + ENDDO + ENDDO + + IF ( GET_YEAR() .le. 2009 ) DMON = (/ 31d0, 29d0, 31d0, 30d0, & + 31d0, 30d0, 31d0, 31d0, & + 30d0, 31d0, 30d0, 31d0 /) + + IF ( GET_YEAR() .ge. 2010 ) DMON = (/ 31d0, 28d0, 31d0, 30d0, & + 31d0, 30d0, 31d0, 31d0, & + 30d0, 31d0, 30d0, 31d0 /) + + ! Get days per month + DAYS_IN_MONTH = DMON( GET_MONTH() ) + + ! Total CO [Tg CO] + T_CO = SUM( CO * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total NOX [Tg NO2] + T_NOx = SUM( NOX * tmpArea) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total SO2 [Tg SO2] + T_SO2 = SUM( SO2 * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total NH3 [Tg NH3] + T_NH3 = SUM( NH3 * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total BC [Tg C] + T_BC = SUM( BC * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total OC [Tg C] + T_OC = SUM( OC * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total VOC [Tg C] + T_ALK4 = SUM( ALK4_HTAP * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total VOC [Tg C] + T_ACET = SUM( ACET_HTAP * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 * 0.75d0 + + ! Total VOC [Tg C] + T_MEK = SUM( MEK_HTAP * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 * 0.25d0 + + ! Total VOC [Tg C] + T_ALD2 = SUM( ALD2_HTAP * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total VOC [Tg C] + T_PRPE = SUM( PRPE_HTAP * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total VOC [Tg C] + T_C3H8 = SUM( C3H8_HTAP * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total VOC [Tg C] + T_CH2O = SUM( CH2O_HTAP * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total VOC [Tg C] + T_C2H6 = SUM( C2H6_HTAP * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + ! Total PM25 [Tg C] + T_PM25 = SUM( PM25 * tmpArea ) * & + SEC_IN_DAY * DAYS_IN_MONTH * 1d-9 + + + ! Print totals in [Tg] + WRITE( 6, 110 ) 'CO ', T_CO, '[Tg CO]' + WRITE( 6, 110 ) 'NOx ', T_NOx, '[Tg NO2]' + WRITE( 6, 110 ) 'SO2 ', T_SO2, '[Tg SO2]' + WRITE( 6, 110 ) 'NH3 ', T_NH3, '[Tg NH3]' + WRITE( 6, 110 ) 'BC ', T_BC, '[Tg C]' + WRITE( 6, 110 ) 'OC ', T_OC, '[Tg C]' + WRITE( 6, 110 ) 'PM2.5 ', T_PM25, '[Tg C]' + WRITE( 6, 110 ) 'ALK4 ', T_ALK4, '[Tg Molec]' + WRITE( 6, 110 ) 'ACET ', T_ACET, '[Tg Molec]' + WRITE( 6, 110 ) 'MEK ', T_MEK , '[Tg Molec]' + WRITE( 6, 110 ) 'ALD2 ', T_ALD2, '[Tg Molec]' + WRITE( 6, 110 ) 'PRPE ', T_PRPE, '[Tg Molec]' + WRITE( 6, 110 ) 'C3H8 ', T_C3H8, '[Tg Molec]' + WRITE( 6, 110 ) 'CH2O ', T_CH2O, '[Tg Molec]' + WRITE( 6, 110 ) 'C2H6 ', T_C2H6, '[Tg Molec]' + + ! Format statement +110 FORMAT( 'HTAP Emissions ', a6, & + ': ', f20.8, 1x, a10 ) + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Return to calling program + END SUBROUTINE TOTAL_HTAP_Tg + ! + ! !IROUTINE: init_htap + ! + ! !DESCRIPTION: Subroutine INIT\_HTAP allocates and zeroes all + ! module arrays. + !\\ + !\\ + ! !INTERFACE: + ! + SUBROUTINE INIT_HTAP + ! + ! !USES: + ! + USE ERROR_MOD, ONLY : ALLOC_ERR + USE LOGICAL_MOD, ONLY : LHTAP + +# include "CMN_SIZE" ! Size parameters! + !EOP + !------------------------------------------------------------------------------ + !BOC + ! + ! !LOCAL VARIABLES: + ! + INTEGER :: AS, J + + !================================================================= + ! INIT_NEI2008_ANTHRO begins here! + !================================================================= + + ! Return if LHTAP is false + IF ( .not. LHTAP ) RETURN + + !-------------------------------------------------- + ! Allocate and zero arrays for emissions + !-------------------------------------------------- + + ALLOCATE( BC( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) + BC = 0d0 + + ALLOCATE( CO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CO' ) + CO = 0d0 + + ALLOCATE( NH3( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NH3' ) + NH3 = 0d0 + + ALLOCATE( NOX( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NOX' ) + NOX = 0d0 + + ALLOCATE( OC( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OC' ) + OC = 0d0 + + ALLOCATE( SO2( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO2' ) + SO2 = 0d0 + + ALLOCATE( PM25( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PM25' ) + PM25 = 0d0 + + ALLOCATE( ALK4_HTAP( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ALK4' ) + ALK4_HTAP = 0d0 + + ALLOCATE( ACET_HTAP( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ACET' ) + ACET_HTAP = 0d0 + + ALLOCATE( MEK_HTAP ( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MEK' ) + MEK_HTAP = 0d0 + + ALLOCATE( ALD2_HTAP( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ALD2' ) + ALD2_HTAP = 0d0 + + ALLOCATE( PRPE_HTAP( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PRPE' ) + PRPE_HTAP = 0d0 + + ALLOCATE( C3H8_HTAP( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'C3H8' ) + C3H8_HTAP = 0d0 + + ALLOCATE( CH2O_HTAP( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CH2O' ) + CH2O_HTAP = 0d0 + + ALLOCATE( C2H6_HTAP( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'C2H6' ) + C2H6_HTAP = 0d0 + + + ! Return to calling program + END SUBROUTINE INIT_HTAP + ! + ! !IROUTINE: cleanup_htap + ! + ! !DESCRIPTION: Subroutine CLEANUP\_HTAP deallocates all module + ! arrays. + !\\ + !\\ + ! !INTERFACE: + ! + SUBROUTINE CLEANUP_HTAP + ! + ! !REVISION HISTORY: + ! Sept 2013 - Yanko Davila - Initial revision + !EOP + !------------------------------------------------------------------------------ + !BOC + !================================================================= + ! CLEANUP_NEIO2008_ANTHRO begins here! + !================================================================= + + IF ( ALLOCATED( BC ) ) DEALLOCATE( BC ) + IF ( ALLOCATED( CO ) ) DEALLOCATE( CO ) + IF ( ALLOCATED( NH3 ) ) DEALLOCATE( NH3 ) + IF ( ALLOCATED( NOX ) ) DEALLOCATE( NOX ) + IF ( ALLOCATED( OC ) ) DEALLOCATE( OC ) + IF ( ALLOCATED( SO2 ) ) DEALLOCATE( SO2 ) + IF ( ALLOCATED( PM25 ) ) DEALLOCATE( PM25 ) + IF ( ALLOCATED( ALK4_HTAP ) ) DEALLOCATE( ALK4_HTAP ) + IF ( ALLOCATED( ACET_HTAP ) ) DEALLOCATE( ACET_HTAP ) + IF ( ALLOCATED( MEK_HTAP ) ) DEALLOCATE( MEK_HTAP ) + IF ( ALLOCATED( ALD2_HTAP ) ) DEALLOCATE( ALD2_HTAP ) + IF ( ALLOCATED( PRPE_HTAP ) ) DEALLOCATE( PRPE_HTAP ) + IF ( ALLOCATED( C3H8_HTAP ) ) DEALLOCATE( C3H8_HTAP ) + IF ( ALLOCATED( CH2O_HTAP ) ) DEALLOCATE( CH2O_HTAP ) + IF ( ALLOCATED( C2H6_HTAP ) ) DEALLOCATE( C2H6_HTAP ) + + + END SUBROUTINE CLEANUP_HTAP + + !EOC +END MODULE HTAP_MOD + diff --git a/code/icoads_ship_mod.f b/code/icoads_ship_mod.f new file mode 100644 index 0000000..d286d81 --- /dev/null +++ b/code/icoads_ship_mod.f @@ -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 diff --git a/code/ifort_errmsg.f b/code/ifort_errmsg.f new file mode 100644 index 0000000..6a220b4 --- /dev/null +++ b/code/ifort_errmsg.f @@ -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 diff --git a/code/initialize.f b/code/initialize.f new file mode 100644 index 0000000..3d7a449 --- /dev/null +++ b/code/initialize.f @@ -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 diff --git a/code/inphot.f b/code/inphot.f new file mode 100644 index 0000000..0e84bce --- /dev/null +++ b/code/inphot.f @@ -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 diff --git a/code/inquireMod.F90 b/code/inquireMod.F90 new file mode 100644 index 0000000..e13ef4e --- /dev/null +++ b/code/inquireMod.F90 @@ -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 diff --git a/code/jsparse.f b/code/jsparse.f new file mode 100644 index 0000000..05a5831 --- /dev/null +++ b/code/jsparse.f @@ -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 diff --git a/code/jv_cmn.h b/code/jv_cmn.h new file mode 100644 index 0000000..559d42a --- /dev/null +++ b/code/jv_cmn.h @@ -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 ) +!----------------------------------------------------------------------- diff --git a/code/jv_index.f b/code/jv_index.f new file mode 100644 index 0000000..2a31d80 --- /dev/null +++ b/code/jv_index.f @@ -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 diff --git a/code/jv_mie.h b/code/jv_mie.h new file mode 100644 index 0000000..38d45bc --- /dev/null +++ b/code/jv_mie.h @@ -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----------------------------------------------------------------------- diff --git a/code/ksparse.f b/code/ksparse.f new file mode 100644 index 0000000..c4b765b --- /dev/null +++ b/code/ksparse.f @@ -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 diff --git a/code/lai_mod.f b/code/lai_mod.f new file mode 100644 index 0000000..352e50b --- /dev/null +++ b/code/lai_mod.f @@ -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 diff --git a/code/linux_err.c b/code/linux_err.c new file mode 100644 index 0000000..da3ff48 --- /dev/null +++ b/code/linux_err.c @@ -0,0 +1,81 @@ +/* $Id: linux_err.c,v 1.1 2009/06/09 21:51:52 daven Exp $ */ + +#include + +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 ); + +} diff --git a/code/logical_mod.f b/code/logical_mod.f new file mode 100644 index 0000000..8d0bc99 --- /dev/null +++ b/code/logical_mod.f @@ -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 diff --git a/code/lump.f b/code/lump.f new file mode 100644 index 0000000..7b4b05a --- /dev/null +++ b/code/lump.f @@ -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 + diff --git a/code/main.f b/code/main.f new file mode 100644 index 0000000..861aca3 --- /dev/null +++ b/code/main.f @@ -0,0 +1,1362 @@ +! $Id: main.f,v 1.1 2009/06/09 21:51:51 daven Exp $ +! $Log: main.f,v $ +! Revision 1.1 2009/06/09 21:51:51 daven +! Initial revision +! +! Revision 1.58 2009/05/06 14:14:45 ccarouge +! commits for v8-02-01 (ccarouge 5/6/09) +! +! Revision 1.57 2009/01/29 15:35:50 bmy +! Added protex header to emep_mod.f. Also some last-minute changes from +! Philippe, and a couple of typo fixes. (bmy, 1/29/09) +! +! Revision 1.56 2008/12/15 21:21:12 bmy +! Added various updates of diagnostics. (bmy, 12/15/08) +! +! Revision 1.55 2008/12/15 15:55:15 bmy +! Replaced TPCORE by S-J Lin and Kevin Yeh with the version +! from GMI (ccarouge, bmy, 12/15/08) +! +! Bug fix in ND51 +! +! Removed obsolete "Prior to" code from various routines +! +! (bmy, 12/15/08) +! +! Revision 1.54 2008/11/07 19:30:33 bmy +! Modifications for GEOS-5 0.5 x 0.666 nested grid simulation +! Also removed obsolete lightning_nox_nl_mod.f +! (bmy, 11/7/08) +! +! Revision 1.53 2008/08/08 17:20:36 bmy +! Updated before Bob Y. goes on vacation (bmy, 8/8/08) +! +! Revision 1.52 2008/04/03 14:19:44 bmy +! Now use RPMARES for ATE. Only compute ATE w/in tropopause. (bmy, 4/3/08) +! +! Revision 1.51 2008/02/14 18:23:49 bmy +! Added fixes to make sure tagged CO has same emissions +! as the full-chemistry CO (jaf, mak, bmy, 2/14/08) +! +! Revision 1.50 2007/11/16 18:47:43 bmy +! +! Bringing in GEOS-5 modifications to the mainline GEOS-Chem std code +! (bmy, 11/16/07) +! +! Revision 1.49 2007/11/05 16:16:22 bmy +! - Added H2/HD simulation +! - Added code for cloud overlap in FAST-J (but use same option as before) +! - Added 200hPa polar fix for variable tropopause +! - Added updated lightning scheme (non-near-land) +! - Fixed mass flux diagnostics in GEOS-3 TPCORE +! - Removed GEMISNOX array in CMN_NOX to prevent common block errors +! +! Revision 1.48 2007/02/22 18:26:28 bmy +! GEOS-Chem v7-04-11, includes the following modifications: +! - Fixed near-land lightning; now scale 2x25, 4x5 to 6 Tg N/yr (ltm,bmy) +! - Now allow ND49, ND50, ND51 to save transects of a single lon or lat (bmy) +! - Add case for T > 293K to routine GET_LWC in "mercury_mod.f" (cdh,bmy) +! - Bug fix: correct indices for embedded chemistry in "transport_mod.f" (phs) +! - Bug fix: correct typo in SEASALT_CHEM routine in "sulfate_mod.f" (bmy) +! - Now prevent seg fault errors when LBIOMASS=F (bmy) +! - Now fixed minor bug that inverted TROPP1 and TROPP2 (phs) +! - Bug fix: now define LLTROP_FIX for GCAP in CMN_SIZE (phs) +! - a3_read_mod.f: added SNOW and GETWETTOP fields for GCAP (phs) +! - main.f: remove duplicate call for unzip in GCAP case (phs) +! - time_mod.f: fix leap year problem in get_time_ahead for GCAP (phs) +! - extra fixes for the variable tropopause (phs) +! - minor diagnostic updates (phs) +! - now save SOA quantities GPROD & APROD to restart files (tmf, havala, bmy) +! - Updated TOMS/SBUV O3 columns for FAST-J photolysis (symeon, bmy) +! - Bug fix in regridding 1x1 mass quantities to 4x5 GEOS grid (tw,bmy) +! +! Revision 1.42 2006/10/17 17:51:14 bmy +! GEOS-Chem v7-04-10, includes the following modifications: +! - Includes variable tropopause with ND54 diagnostic +! - Added GFED2 biomass emissions for SO2, NH3, BC, OC, CO2 +! - Rewrote default biomass emissions routines for clarity +! - Updates for GCAP: future emissions, met-field reading, TOMS-O3 +! - Bug fix in planeflight_mod.f: set NCS variable correctly +! - Bug fix in SOA_LUMP; other minor bug fixes +! +! GEOS-Chem v7-04-09, includes the following modifications: +! - Updated CO for David Streets (2001 for China, 2000 elsewhere) +! - Now reset negative SPHU to a very small positive # +! - Remove use of TINY(1d0) to avoid NaN's on SUN platform +! - Minor bug fixes and deleted obsolete code +! +! Revision 1.38 2006/08/14 17:58:10 bmy +! GEOS-Chem v7-04-08, includes the following modifications: +! - Now add David Streets' emissions for China & SE Asia +! - Removed support for GEOS-1 and GEOS-STRAT met fields +! - Removed support for LINUX_IFC and LINUX_EFC compilers +! +! Revision 1.37 2006/06/28 17:26:52 bmy +! GEOS-Chem v7-04-06, includes the following modifications: +! - Now add BRAVO emissions (NOx, CO, SO2) over N. Mexico +! - Turn off HO2 uptake by aerosols in SMVGEAR mechanism +! - Bug fix: GEOS-4 convection now conserves mixing ratio +! - Other minor bug fixes & improvements +! +! Revision 1.36 2006/06/06 14:26:07 bmy +! GEOS-Chem v7-04-05, includes the following modifications: +! - Now gets ISOP that has reacted w/ OH from SMVGEAR (cf. D. Henze) +! - Incorporated IPCC future emission scale factors (cf. S. Wu) +! - Other minor bug fixes +! +! Revision 1.35 2006/05/26 17:45:24 bmy +! GEOS-Chem v7-04-04, includes the following modifications: +! - Now updated for SOA production from ISOP (cf D. Henze) +! - Now archive SOA concentrations in [ug/m3] ("diag42_mod.f") +! - Other minor bug fixes +! +! Revision 1.34 2006/05/15 17:52:52 bmy +! GEOS-Chem v7-04-03, includes the following modifications: +! - Added near-land formulation for lightning +! - Now can use CTH, MFLUX, PRECON params for lightning +! (NOTE: new lightning is only applied for GEOS-4 for time being) +! - Added ND56 diagnostic for lightning flash rates +! - Fixed Feb 28 -> Mar 1 transition for GCAP (i.e. no leap years) +! - Other minor bug fixes +! +! Revision 1.33 2006/03/24 20:22:53 bmy +! GEOS-CHEM v7-04-01, includes the following modifications: +! - Updates to new Hg simulation (eck, cdh, sas) +! - Changed Reynold's # criterion for aerodyn smooth surfaces in drydep +! - Standardized several bug fixes implemented in v7-03-06 patch +! - Bug fix: Now call MAKE_RH from "main.f" to avoid problems in drydep +! - Removed obsolete code +! + PROGRAM GEOS_CHEM +! +!****************************************************************************** +! +! +! GGGGGG EEEEEEE OOOOO SSSSSSS CCCCCC H H EEEEEEE M M +! G E O O S C H H E M M M M +! G GGG EEEEEE O O SSSSSSS C HHHHHHH EEEEEE M M M +! G G E O O S C H H E M M +! GGGGGG EEEEEEE OOOOO SSSSSSS CCCCCC H H EEEEEEE M M +! +! +! (formerly known as the Harvard-GEOS model) +! for 4 x 5, 2 x 2.5 global grids and 1 x 1 nested grids +! +! Contact: Bob Yantosca, Harvard University (bmy@io.as.harvard.edu) +! +!****************************************************************************** +! +! See the GEOS-Chem Web Site: +! +! http://www.as.harvard.edu/chemistry/trop/geos/ +! +! and the GEOS-Chem User's Guide: +! +! http://www.as.harvard.edu/chemistry/trop/geos/doc/man/ +! +! and the GEOS-Chem wiki: +! +! http://wiki.seas.harvard.edu/geos-chem/ +! +! for the most up-to-date GEOS-CHEM documentation on the following topics: +! +! - installation, compilation, and execution +! - coding practice and style +! - input files and met field data files +! - horizontal and vertical resolution +! - modification history +! +!****************************************************************************** +! + ! References to F90 modules + USE A3_READ_MOD, ONLY : GET_A3_FIELDS + USE A3_READ_MOD, ONLY : OPEN_A3_FIELDS + USE A3_READ_MOD, ONLY : UNZIP_A3_FIELDS + USE A6_READ_MOD, ONLY : GET_A6_FIELDS + USE A6_READ_MOD, ONLY : OPEN_A6_FIELDS + USE A6_READ_MOD, ONLY : UNZIP_A6_FIELDS + USE BENCHMARK_MOD, ONLY : STDRUN + USE CARBON_MOD, ONLY : WRITE_GPROD_APROD + USE CHEMISTRY_MOD, ONLY : DO_CHEMISTRY + USE CONVECTION_MOD, ONLY : DO_CONVECTION + USE COMODE_MOD, ONLY : INIT_COMODE + USE DIAG_MOD, ONLY : DIAGCHLORO + USE DIAG41_MOD, ONLY : DIAG41, ND41 + USE DIAG42_MOD, ONLY : DIAG42, ND42 + USE DIAG48_MOD, ONLY : DIAG48, ITS_TIME_FOR_DIAG48 + USE DIAG49_MOD, ONLY : DIAG49, ITS_TIME_FOR_DIAG49 + USE DIAG50_MOD, ONLY : DIAG50, DO_SAVE_DIAG50 + USE DIAG51_MOD, ONLY : DIAG51, DO_SAVE_DIAG51 + USE DIAG_OH_MOD, ONLY : PRINT_DIAG_OH + USE DAO_MOD, ONLY : AD, AIRQNT + USE DAO_MOD, ONLY : AVGPOLE, CLDTOPS + USE DAO_MOD, ONLY : CONVERT_UNITS, COPY_I6_FIELDS + USE DAO_MOD, ONLY : COSSZA, INIT_DAO + USE DAO_MOD, ONLY : INTERP, PS1 + USE DAO_MOD, ONLY : PS2, PSC2 + USE DAO_MOD, ONLY : T, TS + USE DAO_MOD, ONLY : SUNCOS, SUNCOSB + USE DAO_MOD, ONLY : MAKE_RH + USE DRYDEP_MOD, ONLY : DO_DRYDEP + USE EMISSIONS_MOD, ONLY : DO_EMISSIONS + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_BPCH, IU_DEBUG + USE FILE_MOD, ONLY : IU_ND48, IU_SMV2LOG + USE FILE_MOD, ONLY : CLOSE_FILES + USE GLOBAL_CH4_MOD, ONLY : INIT_GLOBAL_CH4, CH4_AVGTP + USE GCAP_READ_MOD, ONLY : GET_GCAP_FIELDS + USE GCAP_READ_MOD, ONLY : OPEN_GCAP_FIELDS + USE GCAP_READ_MOD, ONLY : UNZIP_GCAP_FIELDS + USE GWET_READ_MOD, ONLY : GET_GWET_FIELDS + USE GWET_READ_MOD, ONLY : OPEN_GWET_FIELDS + USE GWET_READ_MOD, ONLY : UNZIP_GWET_FIELDS + USE I6_READ_MOD, ONLY : GET_I6_FIELDS_1 + USE I6_READ_MOD, ONLY : GET_I6_FIELDS_2 + USE I6_READ_MOD, ONLY : OPEN_I6_FIELDS + USE I6_READ_MOD, ONLY : UNZIP_I6_FIELDS + USE INPUT_MOD, ONLY : READ_INPUT_FILE + USE LAI_MOD, ONLY : RDISOLAI + USE LIGHTNING_NOX_MOD, ONLY : LIGHTNING + USE LOGICAL_MOD, ONLY : LEMIS, LCHEM, LUNZIP, LDUST + USE LOGICAL_MOD, ONLY : LLIGHTNOX, LPRT, LSTDRUN, LSVGLB + USE LOGICAL_MOD, ONLY : LWAIT, LTRAN, LUPBD, LCONV + USE LOGICAL_MOD, ONLY : LWETD, LTURB, LDRYD, LMEGAN + USE LOGICAL_MOD, ONLY : LDYNOCEAN, LSOA, LVARTROP + USE MEGAN_MOD, ONLY : INIT_MEGAN + USE MEGAN_MOD, ONLY : UPDATE_T_15_AVG + USE MEGAN_MOD, ONLY : UPDATE_T_DAY + USE PBL_MIX_MOD, ONLY : DO_PBL_MIX + USE OCEAN_MERCURY_MOD, ONLY : MAKE_OCEAN_Hg_RESTART + USE OCEAN_MERCURY_MOD, ONLY : READ_OCEAN_Hg_RESTART + USE PLANEFLIGHT_MOD, ONLY : PLANEFLIGHT + USE PLANEFLIGHT_MOD, ONLY : SETUP_PLANEFLIGHT + USE PRESSURE_MOD, ONLY : INIT_PRESSURE + USE PRESSURE_MOD, ONLY : SET_FLOATING_PRESSURE, get_pedge + USE TIME_MOD, ONLY : GET_NYMDb, GET_NHMSb + USE TIME_MOD, ONLY : GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_A3_TIME, GET_FIRST_A3_TIME + USE TIME_MOD, ONLY : GET_A6_TIME, GET_FIRST_A6_TIME + USE TIME_MOD, ONLY : GET_I6_TIME, GET_MONTH + USE TIME_MOD, ONLY : GET_TAU, GET_TAUb + USE TIME_MOD, ONLY : GET_TS_CHEM, GET_TS_DYN + USE TIME_MOD, ONLY : GET_ELAPSED_SEC, GET_TIME_AHEAD + USE TIME_MOD, ONLY : GET_DAY_OF_YEAR, ITS_A_NEW_DAY + USE TIME_MOD, ONLY : ITS_A_NEW_SEASON, GET_SEASON + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH, GET_NDIAGTIME + USE TIME_MOD, ONLY : ITS_A_LEAPYEAR, GET_YEAR + USE TIME_MOD, ONLY : ITS_TIME_FOR_A3, ITS_TIME_FOR_A6 + USE TIME_MOD, ONLY : ITS_TIME_FOR_I6, ITS_TIME_FOR_CHEM + USE TIME_MOD, ONLY : ITS_TIME_FOR_CONV,ITS_TIME_FOR_DEL + USE TIME_MOD, ONLY : ITS_TIME_FOR_DIAG,ITS_TIME_FOR_DYN + USE TIME_MOD, ONLY : ITS_TIME_FOR_EMIS,ITS_TIME_FOR_EXIT + USE TIME_MOD, ONLY : ITS_TIME_FOR_UNIT,ITS_TIME_FOR_UNZIP + USE TIME_MOD, ONLY : ITS_TIME_FOR_BPCH + USE TIME_MOD, ONLY : SET_CT_CONV, SET_CT_DYN + USE TIME_MOD, ONLY : SET_CT_EMIS, SET_CT_CHEM + USE TIME_MOD, ONLY : SET_DIAGb, SET_DIAGe + USE TIME_MOD, ONLY : SET_CURRENT_TIME, PRINT_CURRENT_TIME + USE TIME_MOD, ONLY : SET_ELAPSED_MIN, SYSTEM_TIMESTAMP + USE TRACER_MOD, ONLY : CHECK_STT, N_TRACERS, STT, TCVV + USE TRACER_MOD, ONLY : ITS_AN_AEROSOL_SIM + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_A_H2HD_SIM + USE TRACER_MOD, ONLY : ITS_A_MERCURY_SIM + USE TRACER_MOD, ONLY : ITS_A_TAGCO_SIM + USE TRANSPORT_MOD, ONLY : DO_TRANSPORT + USE TROPOPAUSE_MOD, ONLY : READ_TROPOPAUSE, CHECK_VAR_TROP + USE RESTART_MOD, ONLY : MAKE_RESTART_FILE, READ_RESTART_FILE + USE UPBDFLX_MOD, ONLY : DO_UPBDFLX, UPBDFLX_NOY + USE UVALBEDO_MOD, ONLY : READ_UVALBEDO + USE WETSCAV_MOD, ONLY : INIT_WETSCAV, DO_WETDEP + USE XTRA_READ_MOD, ONLY : GET_XTRA_FIELDS, OPEN_XTRA_FIELDS + USE XTRA_READ_MOD, ONLY : UNZIP_XTRA_FIELDS + USE ERROR_MOD, ONLY : IT_IS_NAN, IT_IS_FINITE !yxw + ! To save CSPEC_FULL restart (dkh, 02/12/09) + USE LOGICAL_MOD, ONLY : LSVCSPEC + USE RESTART_MOD, ONLY : MAKE_CSPEC_FILE + USE CHECKPOINT_MOD, ONLY : MAKE_CONVECTION_CHKFILE + USE LOGICAL_ADJ_MOD + USE INPUT_ADJ_MOD, ONLY : READ_INPUT_ADJ_FILE + + ! Force all variables to be declared explicitly + IMPLICIT NONE + + ! Header files +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! Diagnostic switches, NJDAY +# include "CMN_GCTM" ! Physical constants + + ! Local variables + LOGICAL :: FIRST = .TRUE. + LOGICAL :: LXTRA + INTEGER :: I, IOS, J, K, L + INTEGER :: N, JDAY, NDIAGTIME, N_DYN + INTEGER :: N_DYN_STEPS, NSECb, N_STEP, DATE(2) + INTEGER :: YEAR, MONTH, DAY, DAY_OF_YEAR + INTEGER :: SEASON, NYMD, NYMDb, NHMS + INTEGER :: ELAPSED_SEC, NHMSb + REAL*8 :: TAU, TAUb + CHARACTER(LEN=255) :: ZTYPE + + !================================================================= + ! GEOS-CHEM starts here! + !================================================================= + + ! Display current grid resolution and data set type + CALL DISPLAY_GRID_AND_MODEL + + !================================================================= + ! ***** I N I T I A L I Z A T I O N ***** + !================================================================= + + ! Read input file and call init routines from other modules + CALL READ_INPUT_FILE + CALL READ_INPUT_ADJ_FILE + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a READ_INPUT_FILE' ) + + ! Initialize met field arrays from "dao_mod.f" + CALL INIT_DAO + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a INIT_DAO' ) + + ! Initialize diagnostic arrays and counters + CALL INITIALIZE( 2 ) + CALL INITIALIZE( 3 ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a INITIALIZE' ) + + ! Initialize the new hybrid pressure module. Define Ap and Bp. + CALL INIT_PRESSURE + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a INIT_PRESSURE' ) + + ! Read annual mean tropopause if not a variable tropopause + ! read_tropopause is obsolete with variable tropopause + IF ( .not. LVARTROP ) THEN + CALL READ_TROPOPAUSE + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a READ_TROPOPAUSE' ) + ENDIF + + ! Initialize allocatable SMVGEAR arrays + IF ( LEMIS .or. LCHEM ) THEN + IF ( ITS_A_FULLCHEM_SIM() ) CALL INIT_COMODE + IF ( ITS_AN_AEROSOL_SIM() ) CALL INIT_COMODE + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a INIT_COMODE' ) + ENDIF + + ! Allocate arrays from "global_ch4_mod.f" for CH4 run + IF ( ITS_A_CH4_SIM() ) CALL INIT_GLOBAL_CH4 + + ! Initialize MEGAN arrays, get 15-day avg temperatures + IF ( LMEGAN ) THEN + CALL INIT_MEGAN + CALL INITIALIZE( 2 ) + CALL INITIALIZE( 3 ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a INIT_MEGAN' ) + ENDIF + + ! Local flag for reading XTRA fields for GEOS-3 + !LXTRA = ( LDUST .or. LMEGAN ) + LXTRA = LMEGAN + + ! Define time variables for use below + NHMS = GET_NHMS() + NHMSb = GET_NHMSb() + NYMD = GET_NYMD() + NYMDb = GET_NYMDb() + TAU = GET_TAU() + TAUb = GET_TAUb() + + !================================================================= + ! ***** U N Z I P M E T F I E L D S @ start of run ***** + !================================================================= + IF ( LUNZIP ) THEN + + !--------------------- + ! Remove all files + !--------------------- + + ! Type of unzip operation + ZTYPE = 'remove all' + + ! Remove any leftover A-3, A-6, I-6, in temp dir + CALL UNZIP_A3_FIELDS( ZTYPE ) + CALL UNZIP_A6_FIELDS( ZTYPE ) + CALL UNZIP_I6_FIELDS( ZTYPE ) + +#if defined( GEOS_3 ) + ! Remove GEOS-3 GWET and XTRA files + IF ( LDUST ) CALL UNZIP_GWET_FIELDS( ZTYPE ) + IF ( LXTRA ) CALL UNZIP_XTRA_FIELDS( ZTYPE ) +#endif + +#if defined( GCAP ) + ! Unzip GCAP PHIS field (if necessary) + CALL UNZIP_GCAP_FIELDS( ZTYPE ) +#endif + + !--------------------- + ! Unzip in foreground + !--------------------- + + ! Type of unzip operation + ZTYPE = 'unzip foreground' + + ! Unzip A-3, A-6, I-6 files for START of run + CALL UNZIP_A3_FIELDS( ZTYPE, NYMDb ) + CALL UNZIP_A6_FIELDS( ZTYPE, NYMDb ) + CALL UNZIP_I6_FIELDS( ZTYPE, NYMDb ) + +#if defined( GEOS_3 ) + ! Unzip GEOS-3 GWET and XTRA fields for START of run + IF ( LDUST ) CALL UNZIP_GWET_FIELDS( ZTYPE, NYMDb ) + IF ( LXTRA ) CALL UNZIP_XTRA_FIELDS( ZTYPE, NYMDb ) +#endif + +#if defined( GCAP ) + ! Unzip GCAP PHIS field (if necessary) + CALL UNZIP_GCAP_FIELDS( ZTYPE ) +#endif + + !### Debug output + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a UNZIP' ) + ENDIF + + !================================================================= + ! ***** R E A D M E T F I E L D S @ start of run ***** + !================================================================= + + ! Open and read A-3 fields + DATE = GET_FIRST_A3_TIME() + CALL OPEN_A3_FIELDS( DATE(1), DATE(2) ) + CALL GET_A3_FIELDS( DATE(1), DATE(2) ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a 1st A3 TIME' ) + + ! For MEGAN biogenics, update hourly temps w/in 15-day window + IF ( LMEGAN ) THEN + CALL UPDATE_T_DAY + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: UPDATE T_DAY' ) + ENDIF + + ! Open & read A-6 fields + DATE = GET_FIRST_A6_TIME() + CALL OPEN_A6_FIELDS( DATE(1), DATE(2) ) + CALL GET_A6_FIELDS( DATE(1), DATE(2) ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a 1st A6 TIME' ) + + ! Open & read I-6 fields + DATE = (/ NYMD, NHMS /) + CALL OPEN_I6_FIELDS( DATE(1), DATE(2) ) + CALL GET_I6_FIELDS_1( DATE(1), DATE(2) ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a 1st I6 TIME' ) + +#if defined( GEOS_3 ) + ! Open & read GEOS-3 GWET fields + IF ( LDUST ) THEN + DATE = GET_FIRST_A3_TIME() + CALL OPEN_GWET_FIELDS( DATE(1), DATE(2) ) + CALL GET_GWET_FIELDS( DATE(1), DATE(2) ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a 1st GWET TIME' ) + ENDIF + + ! Open & read GEOS-3 XTRA fields + IF ( LXTRA ) THEN + DATE = GET_FIRST_A3_TIME() + CALL OPEN_XTRA_FIELDS( DATE(1), DATE(2) ) + CALL GET_XTRA_FIELDS( DATE(1), DATE(2) ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a 1st XTRA TIME' ) + ENDIF +#endif + +#if defined( GCAP ) + ! Read GCAP PHIS and LWI fields (if necessary) + CALL OPEN_GCAP_FIELDS + CALL GET_GCAP_FIELDS + + ! Remove temporary file (if necessary) + IF ( LUNZIP ) THEN + CALL UNZIP_GCAP_FIELDS( 'remove date' ) + ENDIF +#endif + + ! Compute avg surface pressure near polar caps + CALL AVGPOLE( PS1 ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a AVGPOLE' ) + + ! Call AIRQNT to compute air mass quantities from PS1 + CALL SET_FLOATING_PRESSURE( PS1 ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a SET_FLT_PRS' ) + + CALL AIRQNT + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a AIRQNT' ) + + ! Compute lightning NOx emissions [molec/box/6h] + IF ( LLIGHTNOX ) THEN + CALL LIGHTNING + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a LIGHTNING' ) + ENDIF + + ! Read land types and fractions from "vegtype.global" + CALL RDLAND + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a RDLAND' ) + + ! Initialize PBL quantities but do not do mixing + CALL DO_PBL_MIX( .FALSE. ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a TURBDAY:1' ) + + !================================================================= + ! ***** I N I T I A L C O N D I T I O N S ***** + !================================================================= + + ! Read initial tracer conditions + CALL READ_RESTART_FILE( NYMDb, NHMSb ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a READ_RESTART_FILE' ) + + ! Read ocean Hg initial conditions (if necessary) + IF ( ITS_A_MERCURY_SIM() .and. LDYNOCEAN ) THEN + CALL READ_OCEAN_Hg_RESTART( NYMDb, NHMSb ) + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a READ_OCEAN_RESTART' ) + ENDIF + + ! Save initial tracer masses to disk for benchmark runs + IF ( LSTDRUN ) CALL STDRUN( LBEGIN=.TRUE. ) + + !================================================================= + ! ***** 6 - H O U R T I M E S T E P L O O P ***** + !================================================================= + + ! Echo message before first timestep + WRITE( 6, '(a)' ) + WRITE( 6, '(a)' ) REPEAT( '*', 44 ) + WRITE( 6, '(a)' ) '* B e g i n T i m e S t e p p i n g !! *' + WRITE( 6, '(a)' ) REPEAT( '*', 44 ) + WRITE( 6, '(a)' ) + + ! NSTEP is the number of dynamic timesteps w/in a 6-h interval + N_DYN_STEPS = 360 / GET_TS_DYN() + + ! Start a new 6-h loop + DO + + ! Compute time parameters at start of 6-h loop + CALL SET_CURRENT_TIME + + ! NSECb is # of seconds at the start of 6-h loop + NSECb = GET_ELAPSED_SEC() + + ! Get dynamic timestep in seconds + N_DYN = 60d0 * GET_TS_DYN() + + !================================================================= + ! ***** D Y N A M I C T I M E S T E P L O O P ***** + !================================================================= + DO N_STEP = 1, N_DYN_STEPS + + ! Compute & print time quantities at start of dyn step + CALL SET_CURRENT_TIME + CALL PRINT_CURRENT_TIME + + ! Set time variables for dynamic loop + DAY_OF_YEAR = GET_DAY_OF_YEAR() + ELAPSED_SEC = GET_ELAPSED_SEC() + MONTH = GET_MONTH() + NHMS = GET_NHMS() + NYMD = GET_NYMD() + TAU = GET_TAU() + YEAR = GET_YEAR() + SEASON = GET_SEASON() + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a SET_CURRENT_TIME' ) + + !============================================================== + ! ***** W R I T E D I A G N O S T I C F I L E S ***** + !============================================================== + IF ( ITS_TIME_FOR_BPCH() ) THEN + + ! Set time at end of diagnostic timestep + CALL SET_DIAGe( TAU ) + + ! Write bpch file + CALL DIAG3 + + ! Flush file units + CALL CTM_FLUSH + + !=========================================================== + ! ***** W R I T E R E S T A R T F I L E S ***** + !=========================================================== + IF ( LSVGLB ) THEN + + ! Make atmospheric restart file + CALL MAKE_RESTART_FILE( NYMD, NHMS, TAU ) + + ! Make ocean mercury restart file + IF ( ITS_A_MERCURY_SIM() .and. LDYNOCEAN ) THEN + CALL MAKE_OCEAN_Hg_RESTART( NYMD, NHMS, TAU ) + ENDIF + + ! Save SOA quantities GPROD & APROD + IF ( LSOA .and. LCHEM ) THEN + CALL WRITE_GPROD_APROD( NYMD, NHMS, TAU ) + ENDIF + + ! Save species concentrations (CSPEC_FULL). (dkh, 02/12/09) + IF ( LCHEM .and. LSVCSPEC ) THEN + CALL MAKE_CSPEC_FILE( NYMD, NHMS ) + ENDIF + + !### Debug + IF ( LPRT ) THEN + CALL DEBUG_MSG( '### MAIN: a MAKE_RESTART_FILE' ) + ENDIF + ENDIF + + ! Set time at beginning of next diagnostic timestep + CALL SET_DIAGb( TAU ) + + !=========================================================== + ! ***** Z E R O D I A G N O S T I C S ***** + !=========================================================== + CALL INITIALIZE( 2 ) ! Zero arrays + CALL INITIALIZE( 3 ) ! Zero counters + ENDIF + + !============================================================== + ! ***** T E S T F O R E N D O F R U N ***** + !============================================================== + IF ( ITS_TIME_FOR_EXIT() ) GOTO 9999 + + !=============================================================== + ! ***** U N Z I P M E T F I E L D S ***** + !=============================================================== + IF ( LUNZIP .and. ITS_TIME_FOR_UNZIP() ) THEN + + ! Get the date & time for 12h (720 mins) from now + DATE = GET_TIME_AHEAD( 720 ) + + ! If LWAIT=T then wait for the met fields to be + ! fully unzipped before proceeding w/ the run. + ! Otherwise, unzip fields in the background + IF ( LWAIT ) THEN + ZTYPE = 'unzip foreground' + ELSE + ZTYPE = 'unzip background' + ENDIF + + ! Unzip A3, A6, I6 fields + CALL UNZIP_A3_FIELDS( ZTYPE, DATE(1) ) + CALL UNZIP_A6_FIELDS( ZTYPE, DATE(1) ) + CALL UNZIP_I6_FIELDS( ZTYPE, DATE(1) ) + +#if defined( GEOS_3 ) + ! Unzip GEOS-3 GWET & XTRA fields + IF ( LDUST ) CALL UNZIP_GWET_FIELDS( ZTYPE, DATE(1) ) + IF ( LXTRA ) CALL UNZIP_XTRA_FIELDS( ZTYPE, DATE(1) ) +#endif + ENDIF + + !=============================================================== + ! ***** R E M O V E M E T F I E L D S ***** + !=============================================================== + IF ( LUNZIP .and. ITS_TIME_FOR_DEL() ) THEN + + ! Type of operation + ZTYPE = 'remove date' + + ! Remove A-3, A-6, and I-6 files only for the current date + CALL UNZIP_A3_FIELDS( ZTYPE, NYMD ) + CALL UNZIP_A6_FIELDS( ZTYPE, NYMD ) + CALL UNZIP_I6_FIELDS( ZTYPE, NYMD ) + +#if defined( GEOS_3 ) + ! Remove GEOS-3 GWET & XTRA fields only for the current date + IF ( LDUST ) CALL UNZIP_GWET_FIELDS( ZTYPE, NYMD ) + IF ( LXTRA ) CALL UNZIP_XTRA_FIELDS( ZTYPE, NYMD ) +#endif + ENDIF + + !============================================================== + ! ***** R E A D A - 3 F I E L D S ***** + !============================================================== + IF ( ITS_TIME_FOR_A3() ) THEN + + ! Get the date/time for the next A-3 data block + DATE = GET_A3_TIME() + + ! Open & read A-3 fields + CALL OPEN_A3_FIELDS( DATE(1), DATE(2) ) + CALL GET_A3_FIELDS( DATE(1), DATE(2) ) + + ! Update daily mean temperature archive for MEGAN biogenics + IF ( LMEGAN ) CALL UPDATE_T_DAY + +#if defined( GEOS_3 ) + ! Read GEOS-3 GWET fields + IF ( LDUST ) THEN + CALL OPEN_GWET_FIELDS( DATE(1), DATE(2) ) + CALL GET_GWET_FIELDS( DATE(1), DATE(2) ) + ENDIF + + ! Read GEOS-3 PARDF, PARDR, SNOW fields + IF ( LXTRA ) THEN + CALL OPEN_XTRA_FIELDS( DATE(1), DATE(2) ) + CALL GET_XTRA_FIELDS( DATE(1), DATE(2) ) + ENDIF +#endif + ENDIF + + !============================================================== + ! ***** R E A D A - 6 F I E L D S ***** + !============================================================== + IF ( ITS_TIME_FOR_A6() ) THEN + + ! Get the date/time for the next A-6 data block + DATE = GET_A6_TIME() + + ! Open and read A-6 fields + CALL OPEN_A6_FIELDS( DATE(1), DATE(2) ) + CALL GET_A6_FIELDS( DATE(1), DATE(2) ) + + ! Since CLDTOPS is an A-6 field, update the + ! lightning NOx emissions [molec/box/6h] + IF ( LLIGHTNOX ) CALL LIGHTNING + ENDIF + + !============================================================== + ! ***** R E A D I - 6 F I E L D S ***** + !============================================================== + IF ( ITS_TIME_FOR_I6() ) THEN + + ! Get the date/time for the next I-6 data block + DATE = GET_I6_TIME() + + ! Open and read files + CALL OPEN_I6_FIELDS( DATE(1), DATE(2) ) + CALL GET_I6_FIELDS_2( DATE(1), DATE(2) ) + + ! Compute avg pressure at polar caps + CALL AVGPOLE( PS2 ) + ENDIF + + !============================================================== + ! ***** M O N T H L Y O R S E A S O N A L D A T A ***** + !============================================================== + + ! UV albedoes + IF ( LCHEM .and. ITS_A_NEW_MONTH() ) THEN + CALL READ_UVALBEDO( MONTH ) + ENDIF + + ! Fossil fuel emissions (SMVGEAR) + IF ( ITS_A_FULLCHEM_SIM() .or. ITS_A_TAGCO_SIM() ) THEN + IF ( LEMIS .and. ITS_A_NEW_SEASON() ) THEN + CALL ANTHROEMS( SEASON ) + ENDIF + ENDIF + + !============================================================== + ! ***** D A I L Y D A T A ***** + !============================================================== + IF ( ITS_A_NEW_DAY() ) THEN + + ! Read leaf-area index (needed for drydep) + CALL RDLAI( DAY_OF_YEAR, MONTH ) + + ! For MEGAN biogenics ... + IF ( LMEGAN ) THEN + + ! Read AVHRR daily leaf-area-index + CALL RDISOLAI( DAY_OF_YEAR, MONTH ) + + ! Compute 15-day average temperature for MEGAN + CALL UPDATE_T_15_AVG + ENDIF + + ! Also read soil-type info for fullchem simulation + IF ( ITS_A_FULLCHEM_SIM() .or. ITS_A_H2HD_SIM() ) THEN + CALL RDSOIL + ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG ( '### MAIN: a DAILY DATA' ) + ENDIF + + !============================================================== + ! ***** I N T E R P O L A T E Q U A N T I T I E S ***** + !============================================================== + + ! Interpolate I-6 fields to current dynamic timestep, + ! based on their values at NSEC and NSEC+N_DYN + CALL INTERP( NSECb, ELAPSED_SEC, N_DYN ) + + ! Case of variable tropopause: + ! Check LLTROP and set LMIN, LMAX, and LPAUSE + ! since this is not done with READ_TROPOPAUSE anymore. + ! (Need to double-check that LMIN, Lmax are not used before-phs) + IF ( LVARTROP ) CALL CHECK_VAR_TROP + + ! If we are not doing transport, then make sure that + ! the floating pressure is set to PSC2 (bdf, bmy, 8/22/02) + IF ( .not. LTRAN ) CALL SET_FLOATING_PRESSURE( PSC2 ) + + ! Compute airmass quantities at each grid box + CALL AIRQNT + + ! Compute the cosine of the solar zenith angle array SUNCOS + ! NOTE: SUNCOSB is not really used in PHYSPROC (bmy, 2/13/07) + CALL COSSZA( DAY_OF_YEAR, SUNCOS ) + + ! Compute tropopause height for ND55 diagnostic + IF ( ND55 > 0 ) CALL TROPOPAUSE + +#if defined( GEOS_3 ) + + ! 1998 GEOS-3 carries the ground temperature and not the air + ! temperature -- thus TS will be 2-3 K too high. As a quick fix, + ! copy the temperature at the first sigma level into TS. + ! (mje, bnd, bmy, 7/3/01) + IF ( YEAR == 1998 ) TS(:,:) = T(:,:,1) +#endif + + ! Update dynamic timestep + CALL SET_CT_DYN( INCREMENT=.TRUE. ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a INTERP, etc' ) + + ! Get averaging intervals for local-time diagnostics + ! (NOTE: maybe improve this later on) + ! Placed after interpolation to get correct value of TROPP. + ! (ccc, 12/9/08) + CALL DIAG_2PM + + !============================================================== + ! ***** U N I T C O N V E R S I O N ( kg -> v/v ) ***** + !============================================================== + IF ( ITS_TIME_FOR_UNIT() ) THEN + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a CONVERT_UNITS:1' ) + ENDIF + + !============================================================== + ! ***** S T R A T O S P H E R I C F L U X E S ***** + !============================================================== + IF ( LUPBD ) CALL DO_UPBDFLX + + !============================================================== + ! ***** T R A N S P O R T ***** + !============================================================== + IF ( ITS_TIME_FOR_DYN() ) THEN + + ! Call the appropritate version of TPCORE + IF ( LTRAN ) CALL DO_TRANSPORT + + ! Reset air mass quantities + CALL AIRQNT + + ! Repartition [NOy] species after transport + IF ( LUPBD .and. ITS_A_FULLCHEM_SIM() ) THEN + CALL UPBDFLX_NOY( 2 ) + ENDIF + +#if !defined( GEOS_5 ) + ! Get relative humidity (after recomputing pressures) + ! NOTE: for GEOS-5 we'll read this from disk instead + CALL MAKE_RH +#endif + + ! Initialize wet scavenging and wetdep fields after + ! the airmass quantities are reset after transport + IF ( LCONV .or. LWETD ) CALL INIT_WETSCAV + ENDIF + + !------------------------------- + ! Test for convection timestep + !------------------------------- + IF ( ITS_TIME_FOR_CONV() ) THEN + + ! Increment the convection timestep + CALL SET_CT_CONV( INCREMENT=.TRUE. ) + + !=========================================================== + ! ***** M I X E D L A Y E R M I X I N G ***** + !=========================================================== + CALL DO_PBL_MIX( LTURB ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a TURBDAY:2' ) + + !=========================================================== + ! ***** C L O U D C O N V E C T I O N ***** + !=========================================================== + IF ( LCONV ) THEN + CALL DO_CONVECTION + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a CONVECTION' ) + ENDIF + ENDIF + + !============================================================== + ! ***** U N I T C O N V E R S I O N ( v/v -> kg ) ***** + !============================================================== + IF ( ITS_TIME_FOR_UNIT() ) THEN + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT ) + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a CONVERT_UNITS:2' ) + ENDIF + + !------------------------------- + ! Test for emission timestep + !------------------------------- + IF ( ITS_TIME_FOR_EMIS() ) THEN + + ! Increment emission counter + CALL SET_CT_EMIS( INCREMENT=.TRUE. ) + + !======================================================== + ! ***** D R Y D E P O S I T I O N ***** + !======================================================== + IF ( LDRYD .and. ( .not. ITS_A_H2HD_SIM() ) ) CALL DO_DRYDEP + + !======================================================== + ! ***** E M I S S I O N S ***** + !======================================================== + IF ( LEMIS ) CALL DO_EMISSIONS + ENDIF + + !=========================================================== + ! ***** C H E M I S T R Y ***** + !=========================================================== + + ! Also need to compute avg P, T for CH4 chemistry (bmy, 1/16/01) + IF ( ITS_A_CH4_SIM() ) CALL CH4_AVGTP + + ! Every chemistry timestep... + IF ( ITS_TIME_FOR_CHEM() ) THEN + + ! Increment chemistry timestep counter + CALL SET_CT_CHEM( INCREMENT=.TRUE. ) + + ! Call the appropriate chemistry routine + CALL DO_CHEMISTRY + + ENDIF + + !============================================================== + ! ***** W E T D E P O S I T I O N (rainout + washout) ***** + !============================================================== + IF ( LWETD .and. ITS_TIME_FOR_DYN() ) CALL DO_WETDEP + + !============================================================== + ! ***** A R C H I V E D I A G N O S T I C S ***** + !============================================================== + IF ( ITS_TIME_FOR_DYN() ) THEN + + ! Accumulate several diagnostic quantities + CALL DIAG1 + + ! ND41: save PBL height in 1200-1600 LT (amf) + ! (for comparison w/ Holzworth, 1967) + IF ( ND41 > 0 ) CALL DIAG41 + + ! ND42: SOA concentrations [ug/m3] + IF ( ND42 > 0 ) CALL DIAG42 + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a DIAGNOSTICS' ) + ENDIF + + !============================================================== + ! ***** T I M E S E R I E S D I A G N O S T I C S ***** + ! + ! NOTE: Since we are saving soluble tracers, we must move + ! the ND40, ND49, and ND52 timeseries diagnostics + ! to after the call to DO_WETDEP (bmy, 4/22/04) + !============================================================== + + ! Plane following diagnostic + IF ( ND40 > 0 ) THEN + + ! Call SETUP_PLANEFLIGHT routine if necessary + IF ( ITS_A_NEW_DAY() ) THEN + + ! If it's a full-chemistry simulation but LCHEM=F, + ! or if it's an offline simulation, call setup routine + IF ( ITS_A_FULLCHEM_SIM() ) THEN + IF ( .not. LCHEM ) CALL SETUP_PLANEFLIGHT + ELSE + CALL SETUP_PLANEFLIGHT + ENDIF + ENDIF + + ! Archive data along the flight track + CALL PLANEFLIGHT + ENDIF + + ! Station timeseries + IF ( ITS_TIME_FOR_DIAG48() ) CALL DIAG48 + + ! 3-D timeseries + IF ( ITS_TIME_FOR_DIAG49() ) CALL DIAG49 + + ! 24-hr timeseries + IF ( DO_SAVE_DIAG50 ) CALL DIAG50 + + ! Morning or afternoon timeseries + IF ( DO_SAVE_DIAG51 ) CALL DIAG51 + + ! Comment out for now + !! Column timeseries + !IF ( ND52 > 0 .and. ITS_TIME_FOR_ND52() ) THEN + ! CALL DIAG52 + ! IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a ND52' ) + !ENDIF + + !### After diagnostics + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: after TIMESERIES' ) + + !============================================================== + ! ***** E N D O F D Y N A M I C T I M E S T E P ***** + !============================================================== + + ! Check for NaN, Negatives, Infinities in STT once per hour + IF ( ITS_TIME_FOR_DIAG() ) THEN + CALL CHECK_STT( 'End of Dynamic Loop' ) + ENDIF + + ! Increment elapsed time + CALL SET_ELAPSED_MIN + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: after SET_ELAPSED_MIN' ) + + ENDDO + + !================================================================= + ! ***** C O P Y I - 6 F I E L D S ***** + ! + ! The I-6 fields at the end of this timestep become + ! the fields at the beginning of the next timestep + !================================================================= + CALL COPY_I6_FIELDS + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: after COPY_I6_FIELDS' ) + + ENDDO + + !================================================================= + ! ***** C L E A N U P A N D Q U I T ***** + !================================================================= + 9999 CONTINUE + + NYMD = GET_NYMD() + NHMS = GET_NHMS() + TAU = GET_TAU() + + CALL MAKE_CONVECTION_CHKFILE(NYMD,NHMS,TAU) + + ! Remove all files from temporary directory + IF ( LUNZIP ) THEN + + ! Type of operation + ZTYPE = 'remove all' + + ! Remove A3, A6, I6 fields + CALL UNZIP_A3_FIELDS( ZTYPE ) + CALL UNZIP_A6_FIELDS( ZTYPE ) + CALL UNZIP_I6_FIELDS( ZTYPE ) + +#if defined( GEOS_3 ) + ! Remove GEOS-3 GWET & XTRA fields + IF ( LDUST ) CALL UNZIP_GWET_FIELDS( ZTYPE ) + IF ( LXTRA ) CALL UNZIP_XTRA_FIELDS( ZTYPE ) +#endif + +#if defined( GCAP ) + ! Remove GCAP PHIS field (if necessary) + CALL UNZIP_GCAP_FIELDS( ZTYPE ) +#endif + + ENDIF + + ! Print the mass-weighted mean OH concentration (if applicable) + CALL PRINT_DIAG_OH + + ! For model benchmarking, save final masses of + ! Rn,Pb,Be or Ox to a binary punch file + IF ( LSTDRUN ) CALL STDRUN( LBEGIN=.FALSE. ) + + ! Close all files + CALL CLOSE_FILES + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a CLOSE_FILES' ) + + ! Deallocate dynamic module arrays + CALL CLEANUP + IF ( LPRT ) CALL DEBUG_MSG( '### MAIN: a CLEANUP' ) + + ! Print ending time of simulation + CALL DISPLAY_END_TIME +! +!****************************************************************************** +! Internal procedures -- Use the F90 CONTAINS command to inline +! subroutines that only can be called from this main program. +! +! All variables referenced in the main program (local variables, F90 +! module variables, or common block variables) also have scope within +! internal subroutines. +! +! List of Internal Procedures: +! ============================================================================ +! (1 ) DISPLAY_GRID_AND_MODEL : Displays resolution, data set, & start time +! (2 ) GET_NYMD_PHIS : Gets YYYYMMDD for the PHIS data field +! (3 ) DISPLAY_SIGMA_LAT_LON : Displays sigma, lat, and lon information +! (4 ) GET_WIND10M : Wrapper for MAKE_WIND10M (from "dao_mod.f") +! (5 ) CTM_FLUSH : Flushes diagnostic files to disk +! (6 ) DISPLAY_END_TIME : Displays ending time of simulation +! (7 ) MET_FIELD_DEBUG : Prints min and max of met fields for debug +!****************************************************************************** +! + CONTAINS + +!----------------------------------------------------------------------------- + + SUBROUTINE DISPLAY_GRID_AND_MODEL + + !================================================================= + ! Internal Subroutine DISPLAY_GRID_AND_MODEL displays the + ! appropriate messages for the given model grid and machine type. + ! It also prints the starting time and date (local time) of the + ! GEOS-CHEM simulation. (bmy, 12/2/03, 10/18/05) + !================================================================= + + ! For system time stamp + CHARACTER(LEN=16) :: STAMP + + !----------------------- + ! Print resolution info + !----------------------- +#if defined( GRID4x5 ) + WRITE( 6, '(a)' ) + & REPEAT( '*', 13 ) // + & ' S T A R T I N G 4 x 5 G E O S--C H E M ' // + & REPEAT( '*', 13 ) + +#elif defined( GRID2x25 ) + WRITE( 6, '(a)' ) + & REPEAT( '*', 13 ) // + & ' S T A R T I N G 2 x 2.5 G E O S--C H E M ' // + & REPEAT( '*', 13 ) + +#elif defined( GRID1x125 ) + WRITE( 6, '(a)' ) + & REPEAT( '*', 13 ) // + & ' S T A R T I N G 1 x 1.25 G E O S--C H E M ' // + & REPEAT( '*', 13 ) + +#elif defined( GRID1x1 ) + WRITE( 6, '(a)' ) + & REPEAT( '*', 13 ) // + & ' S T A R T I N G 1 x 1 G E O S -- C H E M ' // + & REPEAT( '*', 13 ) + +#endif + + !----------------------- + ! Print machine info + !----------------------- + + ! Get the proper FORMAT statement for the model being used +#if defined( COMPAQ ) + WRITE( 6, '(a)' ) 'Created w/ HP/COMPAQ Alpha compiler' +#elif defined( IBM_AIX ) + WRITE( 6, '(a)' ) 'Created w/ IBM-AIX compiler' +#elif defined( LINUX_PGI ) + WRITE( 6, '(a)' ) 'Created w/ LINUX/PGI compiler' +#elif defined( LINUX_IFORT ) + WRITE( 6, '(a)' ) 'Created w/ LINUX/IFORT (64-bit) compiler' +#elif defined( SGI_MIPS ) + WRITE( 6, '(a)' ) 'Created w/ SGI MIPSpro compiler' +#elif defined( SPARC ) + WRITE( 6, '(a)' ) 'Created w/ Sun/SPARC compiler' +#endif + + !----------------------- + ! Print met field info + !----------------------- +#if defined( GEOS_3 ) + WRITE( 6, '(a)' ) 'Using GEOS-3 met fields' +#elif defined( GEOS_4 ) + WRITE( 6, '(a)' ) 'Using GEOS-4/fvDAS met fields' +#elif defined( GEOS_5 ) + WRITE( 6, '(a)' ) 'Using GEOS-5/fvDAS met fields' +#elif defined( GCAP ) + WRITE( 6, '(a)' ) 'Using GCAP/GISS met fields' +#endif + + !----------------------- + ! System time stamp + !----------------------- + STAMP = SYSTEM_TIMESTAMP() + WRITE( 6, 100 ) STAMP + 100 FORMAT( /, '===> SIMULATION START TIME: ', a, ' <===', / ) + + ! Return to MAIN program + END SUBROUTINE DISPLAY_GRID_AND_MODEL + +!----------------------------------------------------------------------------- + + SUBROUTINE CTM_FLUSH + + !================================================================ + ! Internal subroutine CTM_FLUSH flushes certain diagnostic + ! file buffers to disk. (bmy, 8/31/00, 7/1/02) + ! + ! CTM_FLUSH should normally be called after each diagnostic + ! output, so that in case the run dies, the output files from + ! the last diagnostic timestep will not be lost. + ! + ! FLUSH is an intrinsic FORTRAN subroutine and takes as input + ! the unit number of the file to be flushed to disk. + !================================================================ + CALL FLUSH( IU_ND48 ) + CALL FLUSH( IU_BPCH ) + CALL FLUSH( IU_SMV2LOG ) + CALL FLUSH( IU_DEBUG ) + + ! Return to MAIN program + END SUBROUTINE CTM_FLUSH + +!------------------------------------------------------------------------------ + + SUBROUTINE DISPLAY_END_TIME + + !================================================================= + ! Internal subroutine DISPLAY_END_TIME prints the ending time of + ! the GEOS-CHEM simulation (bmy, 5/3/05) + !================================================================= + + ! Local variables + CHARACTER(LEN=16) :: STAMP + + ! Print system time stamp + STAMP = SYSTEM_TIMESTAMP() + WRITE( 6, 100 ) STAMP + 100 FORMAT( /, '===> SIMULATION END TIME: ', a, ' <===', / ) + + ! Echo info + WRITE ( 6, 3000 ) + 3000 FORMAT + & ( /, '************** E N D O F G E O S -- C H E M ', + & '**************' ) + + ! Return to MAIN program + END SUBROUTINE DISPLAY_END_TIME + +!------------------------------------------------------------------------------ + + SUBROUTINE MET_FIELD_DEBUG + + !================================================================= + ! Internal subroutine MET_FIELD_DEBUG prints out the maximum + ! and minimum, and sum of DAO met fields for debugging + !================================================================= + + ! References to F90 modules + USE DAO_MOD, ONLY : AD, AIRDEN, AIRVOL, ALBD1, ALBD2 + USE DAO_MOD, ONLY : ALBD, AVGW, BXHEIGHT, CLDFRC, CLDF + USE DAO_MOD, ONLY : CLDMAS, CLDTOPS, DELP + USE DAO_MOD, ONLY : DTRAIN, GWETTOP, HFLUX, HKBETA, HKETA + USE DAO_MOD, ONLY : LWI, MOISTQ, OPTD, OPTDEP, PBL + USE DAO_MOD, ONLY : PREACC, PRECON, PS1, PS2, PSC2 + USE DAO_MOD, ONLY : RADLWG, RADSWG, RH, SLP, SNOW + USE DAO_MOD, ONLY : SPHU1, SPHU2, SPHU, SUNCOS, SUNCOSB + USE DAO_MOD, ONLY : TMPU1, TMPU2, T, TROPP, TS + USE DAO_MOD, ONLY : TSKIN, U10M, USTAR, UWND1, UWND2 + USE DAO_MOD, ONLY : UWND, V10M, VWND1, VWND2, VWND + USE DAO_MOD, ONLY : Z0, ZMEU, ZMMD, ZMMU + + ! Local variables + INTEGER :: I, J, L, IJ + + !================================================================= + ! MET_FIELD_DEBUG begins here! + !================================================================= + + ! Define box to print out + I = 23 + J = 34 + L = 1 + IJ = ( ( J-1 ) * IIPAR ) + I + + !================================================================= + ! Print out met fields at (I,J,L) + !================================================================= + IF ( ALLOCATED( AD ) ) PRINT*, 'AD : ', AD(I,J,L) + IF ( ALLOCATED( AIRDEN ) ) PRINT*, 'AIRDEN : ', AIRDEN(L,I,J) + IF ( ALLOCATED( AIRVOL ) ) PRINT*, 'AIRVOL : ', AIRVOL(I,J,L) + IF ( ALLOCATED( ALBD1 ) ) PRINT*, 'ALBD1 : ', ALBD1(I,J) + IF ( ALLOCATED( ALBD2 ) ) PRINT*, 'ALBD2 : ', ALBD2(I,J) + IF ( ALLOCATED( ALBD ) ) PRINT*, 'ALBD : ', ALBD(I,J) + IF ( ALLOCATED( AVGW ) ) PRINT*, 'AVGW : ', AVGW(I,J,L) + IF ( ALLOCATED( BXHEIGHT ) ) PRINT*, 'BXHEIGHT: ', BXHEIGHT(I,J,L) + IF ( ALLOCATED( CLDFRC ) ) PRINT*, 'CLDFRC : ', CLDFRC(I,J) + IF ( ALLOCATED( CLDF ) ) PRINT*, 'CLDF : ', CLDF(L,I,J) + IF ( ALLOCATED( CLDMAS ) ) PRINT*, 'CLDMAS : ', CLDMAS(I,J,L) + IF ( ALLOCATED( CLDTOPS ) ) PRINT*, 'CLDTOPS : ', CLDTOPS(I,J) + IF ( ALLOCATED( DELP ) ) PRINT*, 'DELP : ', DELP(L,I,J) + IF ( ALLOCATED( DTRAIN ) ) PRINT*, 'DTRAIN : ', DTRAIN(I,J,L) + IF ( ALLOCATED( GWETTOP ) ) PRINT*, 'GWETTOP : ', GWETTOP(I,J) + IF ( ALLOCATED( HFLUX ) ) PRINT*, 'HFLUX : ', HFLUX(I,J) + IF ( ALLOCATED( HKBETA ) ) PRINT*, 'HKBETA : ', HKBETA(I,J,L) + IF ( ALLOCATED( HKETA ) ) PRINT*, 'HKETA : ', HKETA(I,J,L) + IF ( ALLOCATED( LWI ) ) PRINT*, 'LWI : ', LWI(I,J) + IF ( ALLOCATED( MOISTQ ) ) PRINT*, 'MOISTQ : ', MOISTQ(L,I,J) + IF ( ALLOCATED( OPTD ) ) PRINT*, 'OPTD : ', OPTD(L,I,J) + IF ( ALLOCATED( OPTDEP ) ) PRINT*, 'OPTDEP : ', OPTDEP(L,I,J) + IF ( ALLOCATED( PBL ) ) PRINT*, 'PBL : ', PBL(I,J) + IF ( ALLOCATED( PREACC ) ) PRINT*, 'PREACC : ', PREACC(I,J) + IF ( ALLOCATED( PRECON ) ) PRINT*, 'PRECON : ', PRECON(I,J) + IF ( ALLOCATED( PS1 ) ) PRINT*, 'PS1 : ', PS1(I,J) + IF ( ALLOCATED( PS2 ) ) PRINT*, 'PS2 : ', PS2(I,J) + IF ( ALLOCATED( PSC2 ) ) PRINT*, 'PSC2 : ', PSC2(I,J) + IF ( ALLOCATED( RADLWG ) ) PRINT*, 'RADLWG : ', RADLWG(I,J) + IF ( ALLOCATED( RADSWG ) ) PRINT*, 'RADSWG : ', RADSWG(I,J) + IF ( ALLOCATED( RH ) ) PRINT*, 'RH : ', RH(I,J,L) + IF ( ALLOCATED( SLP ) ) PRINT*, 'SLP : ', SLP(I,J) + IF ( ALLOCATED( SNOW ) ) PRINT*, 'SNOW : ', SNOW(I,J) + IF ( ALLOCATED( SPHU1 ) ) PRINT*, 'SPHU1 : ', SPHU1(I,J,L) + IF ( ALLOCATED( SPHU2 ) ) PRINT*, 'SPHU2 : ', SPHU2(I,J,L) + IF ( ALLOCATED( SPHU ) ) PRINT*, 'SPHU : ', SPHU(I,J,L) + IF ( ALLOCATED( SUNCOS ) ) PRINT*, 'SUNCOS : ', SUNCOS(IJ) + IF ( ALLOCATED( SUNCOSB ) ) PRINT*, 'SUNCOSB : ', SUNCOSB(IJ) + IF ( ALLOCATED( TMPU1 ) ) PRINT*, 'TMPU1 : ', TMPU1(I,J,L) + IF ( ALLOCATED( TMPU2 ) ) PRINT*, 'TMPU2 : ', TMPU2(I,J,L) + IF ( ALLOCATED( T ) ) PRINT*, 'TMPU : ', T(I,J,L) + IF ( ALLOCATED( TROPP ) ) PRINT*, 'TROPP : ', TROPP(I,J) + IF ( ALLOCATED( TS ) ) PRINT*, 'TS : ', TS(I,J) + IF ( ALLOCATED( TSKIN ) ) PRINT*, 'TSKIN : ', TSKIN(I,J) + IF ( ALLOCATED( U10M ) ) PRINT*, 'U10M : ', U10M(I,J) + IF ( ALLOCATED( USTAR ) ) PRINT*, 'USTAR : ', USTAR(I,J) + IF ( ALLOCATED( UWND1 ) ) PRINT*, 'UWND1 : ', UWND1(I,J,L) + IF ( ALLOCATED( UWND2 ) ) PRINT*, 'UWND2 : ', UWND2(I,J,L) + IF ( ALLOCATED( UWND ) ) PRINT*, 'UWND : ', UWND(I,J,L) + IF ( ALLOCATED( V10M ) ) PRINT*, 'V10M : ', V10M(I,J) + IF ( ALLOCATED( VWND1 ) ) PRINT*, 'VWND1 : ', VWND1(I,J,L) + IF ( ALLOCATED( VWND2 ) ) PRINT*, 'VWND2 : ', VWND2(I,J,L) + IF ( ALLOCATED( VWND ) ) PRINT*, 'VWND : ', VWND(I,J,L) + IF ( ALLOCATED( Z0 ) ) PRINT*, 'Z0 : ', Z0(I,J) + IF ( ALLOCATED( ZMEU ) ) PRINT*, 'ZMEU : ', ZMEU(I,J,L) + IF ( ALLOCATED( ZMMD ) ) PRINT*, 'ZMMD : ', ZMMD(I,J,L) + IF ( ALLOCATED( ZMMU ) ) PRINT*, 'ZMMU : ', ZMMU(I,J,L) + + ! Flush the output buffer + CALL FLUSH( 6 ) + + ! Return to MAIN program + END SUBROUTINE MET_FIELD_DEBUG + +!----------------------------------------------------------------------------- + + ! End of program + END PROGRAM GEOS_CHEM + diff --git a/code/mercury_mod.f b/code/mercury_mod.f new file mode 100644 index 0000000..9b651fb --- /dev/null +++ b/code/mercury_mod.f @@ -0,0 +1,2514 @@ +! $Id: mercury_mod.f,v 1.1 2009/06/09 21:51:53 daven Exp $ + MODULE MERCURY_MOD +! +!****************************************************************************** +! Module MERCURY_MOD contains variables and routines for the GEOS-CHEM +! mercury simulation. (eck, bmy, 12/14/04, 1/19/07) +! +! Module Variables: +! ============================================================================ +! (1 ) AN_Hg0 (INTEGER) : Tracer index array for tagged anth Hg(0) regions +! (2 ) AN_Hg2 (INTEGER) : Tracer index array for tagged anth Hg(II) regions +! (3 ) AN_HgP (INTEGER) : Tracer index array for tagged anth HgP regions +! (4 ) COSZM (REAL*8 ) : Max daily value of COS( S. Z. Angle ) [unitless] +! (5 ) DRYHg2 (INTEGER) : Index for Hg2 in DEPSAV array (drydep freq) +! (6 ) DRYHgP (INTEGER) : Index for HgP in DEPSAV array (drydep freq) +! (7 ) EHg0_an (REAL*8 ) : Anthropogenic Hg0 emissions [kg/s] +! (8 ) EHg2_an (REAL*8 ) : Anthropogenic Hg2 emissions [kg/s] +! (9 ) EHgP_an (REAL*8 ) : Anthropogenic HgP emissions [kg/s] +! (10) EHg0_oc (REAL*8 ) : Hg0 emissions from oceans [kg/s] +! (11) EHg0_ln (REAL*8 ) : Re-emissions of Hg0 from land [kg/s] +! (12) EHg0_nt (REAL*8 ) : Hg0 emissions from natural land sources [kg/s] +! (13) TCOSZ (REAL*8 ) : Sum of COS( Solar Zenith Angle ) [unitless] +! (14) TTDAY (REAL*8 ) : Total daylight time at location (I,J) [minutes] +! (15) T44 (REAL*4 ) : Local array for drydep diagnostic +! (15) N_HgTAGS (INTEGER) : Number of tagged sources (1 or 8) +! (16) ZERO_DVEL(REAL*8 ) : Array with zero dry deposition velocity +! (17) ANTHRO_Hg_YEAR(INT): Anthropogenic Hg emissions year (1995 or 2000) +! +! Module Routines: +! =========================================================================== +! (1 ) CHEMMERCURY : Chemistry routine for Hg +! (2 ) CHEM_Hg0_Hg2 : Chemistry for Hg0, Hg2 and drydep of Hg2 +! (3 ) RXN_Hg0_Hg2 : Conversion of Hg(0) --> Hg(II) via reduction rxn +! (4 ) RXN_Hg0 : Conversion of Hg(0) --> Hg(II) via oxidation rxns +! (5 ) RXN_Hg2_DRYD : Prod of Hg(II) from Hg(0); also Hg(II) drydep loss +! (6 ) RXN_Hg2 : Prod of Hg(II) from Hg(0) +! (7 ) CHEM_HGP : Chemistry (via drydep loss) for HgP +! (8 ) RXN_HgP_DRYD : Loss of HgP via drydep +! (9 ) EMISSMERCURY : Emissions for Hg +! (10) SRCHG0 : Applies emissions of Hg0 +! (11) SRCHG2 : Applies emissions of Hg2 +! (12) SRCHGP : Applies emissions of HgP +! (13) MERCURY_READYR : Reads mercury emissions and converts to [kg/s] +! (14) GET_LWC : Computes liquid water content as a function of T +! (15) GET_VCLDF : Computes volume cloud fraction +! (16) GET_O3 : Returns monthly mean O3 field +! (17) GET_OH : Returns monthly mean OH field (w/ diurnal scaling) +! (18) OHNO3TIME : Computes diurnal scaling for monthly mean OH +! (19) DEFINE_TAGGED_Hg : Defines tracer number for tagged Hg tracers +! (20) INIT_MERCURY : Allocates and zeroes module arrays +! (21) CLEANUP_MERCURY : Deallocates module arrays +! +! GEOS-CHEM modules referenced by mercury_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module w/ routines for binary pch file I/O +! (2 ) comode_mod.f : Module w/ SMVGEAR allocatable arrays +! (3 ) dao_mod.f : Module w/ arrays for DAO met fields +! (4 ) diag_mod.f : Module w/ GEOS-CHEM diagnostic arrays +! (5 ) drydep_mod.f : Module w/ GEOS-CHEM dry deposition routines +! (6 ) error_mod.f : Module w/ NaN, other error check routines +! (7 ) global_o3_mod.f : Module w/ routines to read 3-D O3 field +! (8 ) global_oh_mod.f : Module w/ routines to read 3-D OH field +! (9 ) grid_mod.f : Module w/ horizontal grid information +! (10) logical_mod.f : Module w/ GEOS-CHEM logical switches +! (11) pbl_mix_mod.f : Module w/ routines for PBL height & mixing +! (12) pressure_mod.f : Module w/ routines to compute P(I,J,L) +! (13) regrid_1x1_mod.f : Module w/ routines to regrid 1x1 data +! (13) time_mod.f : Module w/ routines to compute date & time +! (14) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc. +! (15) tracerid_mod.f : Module w/ pointers to tracers & emissions +! (16) transfer_mod.f : Module w/ routines to cast & resize arrays +! +! Nomenclature: +! ============================================================================ +! (1 ) Hg(0) a.k.a. Hg0 : Elemental mercury +! (2 ) Hg(II) a.k.a. Hg2 : Divalent mercury +! (3 ) HgP : Particulate mercury +! +! Mercury Tracers (1-3 are always defined; 4-21 are defined for tagged runs) +! ============================================================================ +! (1 ) Hg(0) : Hg(0) - total tracer +! (2 ) Hg(II) : Hg(II) - total tracer +! (3 ) HgP : HgP - total tracer +! ------------------------+--------------------------------------------------- +! (4 ) Hg(0)_an : Hg(0) - North American anthropogenic +! (5 ) Hg(0)_ae : Hg(0) - European Anthropogenic +! (6 ) Hg(0)_aa : Hg(0) - Asian anthropogenic +! (7 ) Hg(0)_ar : Hg(0) - Rest of World Anthropogenic +! (8 ) Hg(0)_oc : Hg(0) - Ocean emission +! (9 ) Hg(0)_ln : Hg(0) - Land reemission +! (10) Hg(0)_nt : Hg(0) - Land natural emission +! ------------------------+--------------------------------------------------- +! (11) Hg(II)_an : Hg(II) - North American anthropogenic +! (12) Hg(II)_ae : Hg(II) - European Anthropogenic +! (13) Hg(II)_aa : Hg(II) - Asian anthropogenic +! (14) Hg(II)_ar : Hg(II) - Rest of World Anthropogenic +! (15) Hg(II)_oc : Hg(II) - Ocean emission +! (16) Hg(II)_ln : Hg(II) - Land reemission +! (17) Hg(II)_nt : Hg(II) - Land natural emission +! ------------------------+--------------------------------------------------- +! (18) HgP_an : HgP - North American anthropogenic +! (19) HgP_ae : HgP - European anthropogenic +! (20) HgP_aa : HgP - Asian anthropogenic +! (21) HgP_ar : HgP - Rest of world anthropogenic +! ------------------------+--------------------------------------------------- +! (22) HgP_oc : HgP - Ocean emission (FOR FUTURE USE) +! (23) HgP_ln : HgP - Land reemission (FOR FUTURE USE) +! (24) HgP_nt : HgP - Land natural emission (FOR FUTURE USE) +! +! References: +! ============================================================================ +! (1 ) Hall, B. (1995). "The gas phase oxidation of elemental mercury by +! ozone.", Water, Air, and Soil Pollution 80: 301-315. +! (2 ) Sommar, J., et al. (2001). "A kinetic study of the gas-phase +! reaction between the hydroxyl radical and atomic mercury." +! Atmospheric Environment 35: 3049-3054. +! +! NOTES: +! (1 ) Updated for reduction rxn and online Hg0 ocean flux. Now use +! diagnostic arrays from "diag03_mod.f". (eck, sas, bmy, 1/21/05) +! (2 ) Now references "pbl_mix_mod.f". Remove FEMIS array and routine +! COMPUTE_FEMIS. (bmy, 2/15/05) +! (3 ) Now can read data for both GEOS and GCAP grids (bmy, 8/16/05) +! (4 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (5 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +! (6 ) Various updates added for tagged Hg sim. (eck, sas, cdh, bmy, 4/6/06) +! (7 ) Updated IF statement in GET_LWC (cdh, bmy, 12/1/06) +! (8 ) Modified GET_O3 to read trop+strat O3 at all levels (phs, 1/19/07) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "mercury_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: CHEMMERCURY + PUBLIC :: CLEANUP_MERCURY + PUBLIC :: INIT_MERCURY + PUBLIC :: EMISSMERCURY + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Scalars + INTEGER :: ANTHRO_Hg_YEAR + INTEGER :: DRYHg2 + INTEGER :: DRYHgP + + ! Parameters + REAL*8, PARAMETER :: SMALLNUM = 1d-32 + + ! Arrays + INTEGER, ALLOCATABLE :: AN_Hg0(:,:) + INTEGER, ALLOCATABLE :: AN_Hg2(:,:) + INTEGER, ALLOCATABLE :: AN_HgP(:,:) + REAL*8, ALLOCATABLE :: COSZM(:,:) + REAL*8, ALLOCATABLE :: EHg0_an(:,:) + REAL*8, ALLOCATABLE :: EHg2_an(:,:) + REAL*8, ALLOCATABLE :: EHgP_an(:,:) + REAL*8, ALLOCATABLE :: EHg0_oc(:,:,:) + REAL*8, ALLOCATABLE :: EHg0_ln(:,:) + REAL*8, ALLOCATABLE :: EHg0_nt(:,:) + REAL*4, ALLOCATABLE :: T44(:,:,:,:) + REAL*8, ALLOCATABLE :: TCOSZ(:,:) + REAL*8, ALLOCATABLE :: TTDAY(:,:) + REAL*8, ALLOCATABLE :: ZERO_DVEL(:,:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEMMERCURY +! +!****************************************************************************** +! Subroutine CHEMMERCURY is the driver routine for mercury chemistry +! in the GEOS-CHEM module. (eck, bmy, 12/6/04, 4/6/06) +! +! NOTES: +! (1 ) Now references routine GET_PBL_MAX_L from "pbl_mix_mod.f". Now +! references AD44 from "diag_mod.f". Now sum the levels from T44 into +! the AD44 array. Now references N_TRACERS from "tracer_mod.f". +! (bmy, 2/24/05) +! (2 ) Bug fix: Set T44 to 0e0 for single precision. Now allow for zero +! dry deposition velocity. Now call INIT_MERCURY from "input_mod.f" +! (bmy, 4/6/06) +!****************************************************************************** +! + ! References to F90 modules + USE DIAG_MOD, ONLY : AD44 + USE DRYDEP_MOD, ONLY : DEPSAV + USE ERROR_MOD, ONLY : DEBUG_MSG + USE GLOBAL_O3_MOD, ONLY : GET_GLOBAL_O3 + USE GLOBAL_OH_MOD, ONLY : GET_GLOBAL_OH + USE PBL_MIX_MOD, ONLY : GET_PBL_MAX_L + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : GET_MONTH, ITS_A_NEW_MONTH + USE TRACER_MOD, ONLY : N_TRACERS + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND44 + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, L, MONTH, N, PBL_MAX + + !================================================================= + ! CHEMMERCURY begins here! + ! + ! Read monthly mean OH and O3 fields + !================================================================= + IF ( ITS_A_NEW_MONTH() ) THEN + + ! Get the current month + MONTH = GET_MONTH() + + ! Read monthly mean OH and O3 from disk + CALL GET_GLOBAL_OH( MONTH ) + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMMERC: a GET_GLOBAL_OH' ) + + CALL GET_GLOBAL_O3( MONTH ) + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMMERC: a GET_GLOBAL_O3' ) + + ENDIF + + !================================================================= + ! Perform chemistry on Hg tracers + !================================================================= + + ! Compute diurnal scaling for OH + CALL OHNO3TIME + IF ( LPRT ) CALL DEBUG_MSG( 'CHEMMERCURY: a OHNO3TIME' ) + + ! Zero dry deposition tmp array + IF ( ND44 > 0 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO L = 1, LLTROP + DO J = 1, JJPAR + DO I = 1, IIPAR + T44(I,J,L,N) = 0e0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + !------------------------- + ! Hg0 and Hg2 chemistry + !------------------------- + IF ( DRYHg2 > 0 ) THEN + + ! If DRYHG2 > 0 then drydep is active; + ! pass drydep frequency to CHEM_Hg0_Hg2 + CALL CHEM_Hg0_Hg2( DEPSAV(:,:,DRYHg2) ) + IF ( LPRT ) CALL DEBUG_MSG( 'CHEMMERCURY: a CHEM_Hg0_Hg2' ) + + ELSE + + ! Otherwise pass zero drydep frequency + CALL CHEM_Hg0_Hg2( ZERO_DVEL ) + IF ( LPRT ) CALL DEBUG_MSG( 'CHEMMERCURY: a CHEM_Hg0_Hg2' ) + + ENDIF + + !-------------------------- + ! HgP chemistry + !-------------------------- + IF ( DRYHgP > 0 ) THEN + + ! If DRYHgP > 0, then drydep is active; + ! Pass drydep frequency to CHEM_HgP + CALL CHEM_HgP( DEPSAV(:,:,DRYHgP) ) + IF ( LPRT ) CALL DEBUG_MSG( 'CHEMMERCURY: a CHEM_HgP' ) + + ELSE + + ! Otherwise pass zero drydep frequency + CALL CHEM_HgP( ZERO_DVEL ) + IF ( LPRT ) CALL DEBUG_MSG( 'CHEMMERCURY: a CHEM_HgP' ) + + ENDIF + + ! Archive drydep fluxes into ND44 + IF ( ND44 > 0 ) THEN + + ! Model layers where the PBL top occurs + PBL_MAX = GET_PBL_MAX_L() + + ! Sum levels into AD44 +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, N_TRACERS + DO J = 1, JJPAR + DO I = 1, IIPAR + DO L = 1, PBL_MAX + AD44(I,J,N,1) = AD44(I,J,N,1) + T44(I,J,L,N) + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ! Return to calling program + END SUBROUTINE CHEMMERCURY + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_Hg0_Hg2( V_DEP_Hg2 ) +! +!****************************************************************************** +! Subroutine CHEM_Hg0_Hg2 is the chemistry subroutine for the oxidation/ +! reduction of Hg0/Hg(II). For tracers with dry deposition, the loss rate +! of dry dep is combined in the chemistry loss term. +! (eck, bmy, 12/6/04, 1/9/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) V_DEP_Hg2 (REAL*8) : Dry deposition velocity for Hg(II) [cm/s] +! +! Description of the chemistry mechanism: +! ============================================================================ +! (1 ) Conversion from Hg(0) to Hg(II): Oxidation by O3 and OH +! +! Hg(0)(g)+ O3(g) --> Hg(II) , k = 3.0e-20 cm3 molec-1 s-1 +! Source: Hall, 1995 +! +! Hg(0)(g)+ OH(g) --> Hg(II) , k = 8.7e-14 cm3 s-1 +! Source: Sommar et al. 2001 +! +! (2 ) Aqueous-phase photochemical reduction of Hg(II) is included based +! on estimate of rate constant and scaled to OH concentrations. +! +! (3 ) Hg(II) is dry-deposited, kd = Dvel/DELZ (sec-1) +! +! NOTES: +! (1 ) Updated for reduction reaction. Now use diagnostic arrays from +! "diag03_mod.f" (eck, bmy, 1/21/05) +! (2 ) Now references GET_FRAC_UNDER_PBLTOP from "pbl_mix_mod.f". Now +! performs drydep for all levels in the PBL. Changed Kred to 2.1e-10 +! on advice of Noelle Eckley Selin. (bmy, 2/24/05) +! (3 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +! (4 ) Now prevent divide-by-zero error. Now use ID_Hg0 and ID_Hg2 index +! arrays from "tracerid_mod.f". Also modified for updated ocean +! mercury module. Updated some constants. Also saves out diagnostic +! of Hg2 lost to rxn w/ seasalt. (eck, cdh, sas, bmy, 4/6/06) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : T, AD + USE DIAG03_MOD, ONLY : AD03_Hg2_Hg0, AD03_Hg2_O3, AD03_Hg2_OH + USE DIAG03_MOD, ONLY : AD03_Hg2_SS, LD03, ND03 + USE LOGICAL_MOD, ONLY : LSPLIT + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : STT, XNUMOL + USE TRACERID_MOD, ONLY : ID_Hg0, ID_Hg2, ID_Hg_tot, N_Hg_CATS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*8, INTENT(IN) :: V_DEP_Hg2(IIPAR,JJPAR) + + ! Local variables + INTEGER :: I, J, L, N, NN + REAL*8 :: AREA_CM2, C_O3, C_OH + REAL*8 :: DRYDEP, DTCHEM, E_RKT + REAL*8 :: E_K1, E_K2, FA + REAL*8 :: FC, K1, K2 + REAL*8 :: Ko, Kr, Kt + REAL*8 :: Kr_Kt, NK1, NK2 + REAL*8 :: LOST_Hg0_O3, LOST_Hg0_OH, LWC + REAL*8 :: F_UNDER_TOP, RKT, E_SALT + REAL*8 :: LOST_Hg0(N_Hg_CATS) + REAL*8 :: LOST_SS(N_Hg_CATS) + REAL*8 :: Ox_Hg0(N_Hg_CATS) + + ! K for reaction Hg0 + O3 in cm3 molec-1 s-1 (Source: Hall '95) + REAL*8, PARAMETER :: K = 3.0d-20 + + ! K for reaction Hg2 + OH in cm3 s-1 + REAL*8, PARAMETER :: K_HG_OH = 8.7d-14 + + ! Henry's Law constant for Hg2 + REAL*8, PARAMETER :: HL = 1.4d6 + + ! Gas constant?? + REAL*8, PARAMETER :: R = 8.2d-2 + + ! K for reduction (scaled to budget and OH conc) + REAL*8, PARAMETER :: Kred = 8.4d-10 + + ! K for sea salt (eck, bmy, 4/6/06) + REAL*8, PARAMETER :: KSalt = 3.8d-5 + + ! External functions + REAL*8, EXTERNAL :: BOXVL + + !================================================================= + ! CHEM_Hg0_Hg2 begins here! + !================================================================= + + ! Chemistry timestep [s] + DTCHEM = GET_TS_CHEM() * 60d0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, NN, LOST_Hg0 ) +!$OMP+PRIVATE( F_UNDER_TOP, C_O3, C_OH, FC, LWC ) +!$OMP+PRIVATE( FA, K1, K2, Ko, Kr ) +!$OMP+PRIVATE( Kt, Kr_Kt, RKT, E_RKT, E_K1 ) +!$OMP+PRIVATE( E_K2, E_SALT, LOST_Hg0_O3, LOST_Hg0_OH, LOST_SS ) +!$OMP+PRIVATE( Ox_Hg0 ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Initialize LOST_Hg0, Ox_Hg0 arrays + DO NN = 1, N_Hg_CATS + LOST_Hg0(NN) = 0d0 + LOST_SS(NN) = 0d0 + Ox_Hg0(NN) = 0d0 + ENDDO + + ! Also initialize for ND03 diag + LOST_Hg0_O3 = 0d0 + LOST_Hg0_OH = 0d0 + + ! Fraction of box (I,J,L) underneath the PBL top [unitless] + F_UNDER_TOP = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! Monthly mean O3 and OH concentrations [molec/cm3] + C_O3 = GET_O3( I, J, L ) + C_OH = GET_OH( I, J, L ) + + ! Get fraction of cloud in the gridbox [unitless] + FC = GET_VCLDF( I, J, L ) + + ! Get liquid water content in cloudy area of gridbox (m3/m3) + LWC = GET_LWC( T(I,J,L) ) * FC + + ! Define fraction of Hg(II) which is in air + FA = ( HL * R * T(I,J,L) * LWC ) + FA = FA / ( 1d0 + FA ) + + ! Define K's for the oxidation reactions + K1 = K * C_O3 + K2 = K_HG_OH * C_OH + Ko = K1 + K2 + + ! Define K for the reduction reaction. Include the fraction of + ! Hg(II) in air within the Kreduction & scale to OH concentration + Kr = Kred * FA * C_OH + + ! Total rate constant: Oxidation + Reduction + Kt = Ko + Kr + + ! Ratio of Kr / Kt + IF ( Kt > SMALLNUM ) THEN + Kr_Kt = Kr / Kt + ELSE + Kr_Kt = SMALLNUM + ENDIF + + ! Kt * timestep (i.e. the argument for EXP) [unitless] + RKT = Kt * DTCHEM + + ! Compute the exponential terms for use below + E_RKT = EXP( -RKT ) + E_K1 = EXP( -K1 * DTCHEM ) + E_K2 = EXP( -K2 * DTCHEM ) + E_SALT = EXP( -Ksalt * DTCHEM ) + + !============================================================== + ! Hg(0) Chemistry: Conversion from Hg(0) to Hg(II) + ! + ! CASE 1: REDUCTION REACTION + ! ------------------------------------------------------------- + ! Aqueous chem occurs if Kr>0, it's cloudy, and T > -15 C. + ! In this case we have the reaction: + ! + ! New Hg(0) = { ( Old Hg(0) * EXP( -Kt * DT ) ) } + + ! { ( Old Hg(0) + Old Hg(II) ) * Kr/Kt * + ! ( 1 - EXP( -Kt * DT ) ) } + ! + ! where: Kr = K of the reduction rxn + ! Kt = K of the total rxn (oxidation + reduction) + ! DT = Chemistry timestep [s] + ! Old Hg(0) = Hg(0) at start of this timestep + ! Old Hg(II) = Hg(II) as start of this timestep + ! + ! The amount of Hg(0) lost in this rxn becomes Hg(II): + ! + ! Hg(0) converted to Hg(II) = Old Hg(0) - New Hg(0) + ! + ! CASE 2: OXIDATION REACTIONS + ! ------------------------------------------------------------- + ! If aqueous chemistry does not happen, then Hg(0) is converted + ! to Hg(II) via the oxidation rxns with rate constants K1, K2: + ! + ! New Hg(0) = Old_Hg(0) * EXP( -K1 * DT ) * EXP( -K2 * DT ) + ! + ! The amt of Hg(0) lost in these rxns rxn becomes Hg(II): + ! + ! Hg(0) converted to Hg(II) = Old Hg(0) - New Hg(0) + !============================================================== + IF ( Kr > 0d0 .and. FC > 0d0 .and. T(I,J,L) > 258d0 ) THEN + + !-------------------------------------------- + ! CASE 1: Total Hg(II) tracer, aq chem + !-------------------------------------------- + + ! Loop over all Hg0 tracers + DO NN = 1, N_Hg_CATS + + ! Conversion of total Hg(0) --> Hg(II) + CALL RXN_Hg0_Hg2( I, J, L, + & ID_Hg0(NN), ID_Hg2(NN), RKT, + & E_RKT, Kr_Kt, Kt, + & Ko, Kr, DTCHEM, + & LOST_Hg0(NN), Ox_Hg0(NN) ) + + ENDDO + + ELSE + + !-------------------------------------------- + ! CASE 2: Total Hg(II) tracer, non-aq chem + !-------------------------------------------- + + ! Loop over all Hg0 tracers + DO NN = 1, N_Hg_CATS + + ! Total Hg(0) loss by oxidation rxn + CALL RXN_Hg0( I, J, L, + & ID_Hg0(NN), E_K1, E_K2, LOST_Hg0(NN) ) + + ! Gross oxidation flux Hg(0) -> Hg(II) + Ox_Hg0(NN) = LOST_Hg0(NN) + + ENDDO + + ENDIF + + !============================================================== + ! Compute Hg(II) production from OH and O3 rxns for diagnostic + ! + ! This is for the diagnostics OH and O3 prod of Hg(II). + ! They are messed up a little since adding the reduction + ! reaction haven't fixed them yet. (eck, 12/7/04) + !============================================================== + IF ( Ox_Hg0(ID_Hg_tot) > 0d0 ) THEN + + ! Avoid division by zero + IF ( ( K1 + K2 ) > 0d0 ) THEN + + ! Production of Hg(II) from O3 rxn [kg] + LOST_Hg0_O3 = ( K1 / ( K1 + K2 ) ) * Ox_Hg0(ID_Hg_tot) + + ! Production of Hg(II) from OH rxn [kg] + LOST_Hg0_OH = ( K2 / ( K1 + K2 ) ) * Ox_Hg0(ID_Hg_tot) + + ENDIF + + ENDIF + + !============================================================== + ! Hg(II) chemistry: Conversion from Hg(0) and drydep loss + ! + ! CASE 1: WITHIN THE PLANETARY BOUNDARY LAYER (PBL) + ! ------------------------------------------------------------- + ! At the surface we have both dry deposition of Hg(II) plus + ! conversion of Hg(0) into Hg(II). In this case we use the + ! following rxns: + ! + ! CASE 1a: If Conv Hg(0) > 0: + ! --------------------------- + ! New Hg(II) = ( Old Hg(II) * EXP( -RKT ) ) + + ! ( Conv Hg(0)/RKT * ( 1 - EXP( -RKT ) ) + ! + ! + ! CASE 1b: If Conv Hg(0) <= 0: + ! ---------------------------- + ! New Hg(II) = ( Old Hg(II) + Conv Hg(0) ) * EXP( -RKT ) + ! + ! Where: RKT = DTCHEM * Drydep Vel of Hg(II) + ! "Conv Hg(0)" = Amt of Hg(0) that became Hg(II), which + ! is archived from the Hg(0) rxns above + ! + ! CASE 2: OUTSIDE THE PLANETARY BOUNDARY LAYER (PBL) + ! ------------------------------------------------------------- + ! At levels higher than the surface, we do not have drydep. + ! Therefore we only have conversion of Hg(0) into Hg(II), and + ! we use this rxn: + ! + ! New Hg(II) = Old Hg(II) + Conv Hg(0) + ! + ! + ! NOTE: ND44 diagnostics are archived in RXN_Hg2_DRYD. + !============================================================== + + ! If we are in the PBL and there is nonzero drydep velocity ... + IF ( F_UNDER_TOP > 0d0 .and. V_DEP_Hg2(I,J) > 0d0 ) THEN + + ! Hg2 drydep frequency [1/s] -- F_UNDER_TOP accounts for the + ! fraction of box (I,J,L) that is located beneath the PBL top + RKT = V_DEP_Hg2(I,J) * DTCHEM * F_UNDER_TOP + + ! Pre-compute exponential term + E_RKT = EXP( -RKT ) + + !----------------------------------------------- + ! CASE 1: Total Hg(II) tracer, in PBL + !----------------------------------------------- + + ! Loop over all Hg2 tracers + DO NN = 1, N_Hg_CATS + + ! Compute new Hg(II) concentration in PBL + ! Also return Hg2 lost to sea salt (eck, bmy, 4/6/06) + CALL RXN_Hg2_DRYD( I, J, L, + & ID_Hg2(NN), RKT, E_RKT, + & E_SALT, LOST_Hg0(NN), DTCHEM, + & LOST_SS(NN) ) + + ENDDO + + ELSE + + !-------------------------------------------- + ! CASE 2: Total Hg(II) tracer, outside PBL + !-------------------------------------------- + + ! Loop over all Hg2 tracers + DO NN = 1, N_Hg_CATS + + ! Compute new concentration of total Hg(II) outside PBL [kg] + CALL RXN_Hg2( I, J, L, ID_Hg2(NN), LOST_Hg0(NN) ) + + ENDDO + + ENDIF + + !============================================================== + ! ND03 diagnostic: Hg(II) production [kg] + !============================================================== + IF ( ND03 > 0 .and. L <= LD03 ) THEN + NN = ID_Hg_tot + AD03_Hg2_Hg0(I,J,L) = AD03_Hg2_Hg0(I,J,L) + LOST_Hg0(NN) + AD03_Hg2_OH(I,J,L) = AD03_Hg2_OH(I,J,L) + LOST_Hg0_OH + AD03_Hg2_O3(I,J,L) = AD03_Hg2_O3(I,J,L) + LOST_Hg0_O3 + + ! Sea salt diagnostic is 2-D + IF ( L == 1 ) THEN + AD03_Hg2_SS(I,J,NN) = AD03_Hg2_SS(I,J,NN) + LOST_SS(NN) + ENDIF + ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE CHEM_Hg0_Hg2 + +!------------------------------------------------------------------------------ + + SUBROUTINE RXN_Hg0_Hg2( I, J, L, N_Hg0, N_Hg2, + & RKT, E_RKT, Kr_Kt, Kt, Ko, + & Kr, DTCHEM, LOST_Hg0, Ox_Hg0 ) +! +!****************************************************************************** +! Subroutine RXN_Hg0_Hg2 computes the conversion of Hg(0) to Hg(II) via +! an aqueous chemistry reduction reaction. The formula used below is a s +! solution of the 2-box model equation. (eck, bmy, 12/14/04, 4/6/06) +! +! Arguments as Input: +! ============================================================================ +! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt grid box indices +! (4 ) N_Hg0 (INTEGER) : Index for Hg(0) total or tagged tracers +! (5 ) N_Hg2 (INTEGER) : Index for Hg(II) total or tagged tracers +! (6 ) RKT (REAL*8 ) : Value of R * k * Temp for this rxn [unitless] +! (7 ) E_RKT (REAL*8 ) : Value of EXP( - RKT ) [unitless] +! (8 ) Kr_Kt (REAL*8 ) : Ratio of Kr / Kt (redux K / total K) [unitless] +! +! Arguments as Output: +! ============================================================================ +! (9 ) LOST_Hg0 (REAL*8 ) : Loss term: Hg(0) before - Hg(0) after [kg] +! +! NOTES: +! (1 ) Changed equation to reflect reduction rxn. Also modified to output +! the gross oxidation flux. (eck, cdh, bmy, 4/6/06) +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : STT + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L, N_Hg0, N_Hg2 + REAL*8, INTENT(IN) :: RKT, E_RKT, Kr_Kt, Kt, Kr + REAL*8, INTENT(IN) :: Ko, DTCHEM + REAL*8, INTENT(OUT) :: LOST_Hg0, Ox_Hg0 + + ! Local variables + REAL*8 :: OLD_Hg0, OLD_Hg2, NEW_Hg0 + + !================================================================= + ! RXN_Hg0_Hg2 begins here! + !================================================================= + + ! Error check tracer number + IF ( N_Hg0 < 1 .or. N_Hg2 < 1 ) RETURN + + ! Initial concentrations of Hg(0) and Hg(II) [kg] + OLD_Hg0 = MAX( STT(I,J,L,N_Hg0), SMALLNUM ) + OLD_Hg2 = MAX( STT(I,J,L,N_Hg2), SMALLNUM ) + + ! New concentration of Hg(0) [kg] + NEW_Hg0 = ( OLD_Hg0 * E_RKT ) + + & ((( OLD_Hg2 + OLD_Hg0 ) * Kr_Kt ) * ( 1d0 - E_RKT ) ) + + ! Gross oxidation flux Hg(0) -> Hg(II) + Ox_Hg0 = ( Kt - Kr ) / Kt**2 * + & ( ( OLD_Hg0 + OLD_Hg2 ) * Kr * + & ( E_RKT - 1d0 + Kt * DTCHEM ) + & + OLD_Hg0 * Kt * ( 1d0 -E_RKT ) ) + + ! Set a floor of zero + OX_Hg0 = MAX( OX_Hg0, 0d0 ) + + ! Save back into STT array [kg] + NEW_Hg0 = MAX( NEW_Hg0, SMALLNUM ) + STT(I,J,L,N_Hg0) = NEW_Hg0 + + ! Compute amount of Hg(0) which has now become Hg(II) [kg] + LOST_Hg0 = OLD_Hg0 - NEW_Hg0 + + ! Return to calling program + END SUBROUTINE RXN_Hg0_Hg2 + +!------------------------------------------------------------------------------ + + SUBROUTINE RXN_Hg0( I, J, L, N, E_K1, E_K2, LOST_Hg0 ) +! +!****************************************************************************** +! Subroutine RXN_Hg0 computes the loss of Hg(0) by oxidation reactions with +! rate constants K1 and K2. (eck, bmy, 12/14/04) +! +! Arguments as Input: +! ============================================================================ +! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt grid box indices +! (4 ) N (INTEGER) : Index for Hg(0) total or tagged tracers +! (5 ) E_K1 (REAL*8 ) : Value of EXP( -K1 ) [unitless] +! (6 ) E_K2 (REAL*8 ) : Value of EXP( -K2 ) [unitless] +! +! Arguments as Output: +! ============================================================================ +! (7 ) LOST_Hg0 (REAL*8 ) : Loss term: Hg(0) before - Hg(0) after [kg] +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : STT + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L, N + REAL*8, INTENT(IN) :: E_K1, E_K2 + REAL*8, INTENT(OUT) :: LOST_Hg0 + + ! Local variables + REAL*8 :: OLD_Hg0, NEW_Hg0 + + !================================================================= + ! RXN_Hg0 begins here! + !================================================================= + + ! Error check tracer number + IF ( N < 1 ) RETURN + + ! Initial concentration of Hg(0) [kg] + OLD_Hg0 = MAX( STT(I,J,L,N), SMALLNUM ) + + ! New concentration of Hg0 after oxidation rxns [kg] + NEW_Hg0 = MAX( ( OLD_Hg0 * E_K1 * E_K2 ), SMALLNUM ) + + ! Save back into STT array [kg] + STT(I,J,L,N) = NEW_Hg0 + + ! Compute amount of Hg(0) which has been oxidized into Hg(II) [kg] + LOST_Hg0 = OLD_Hg0 - NEW_Hg0 + + ! Return to calling program + END SUBROUTINE RXN_Hg0 + +!------------------------------------------------------------------------------ + + SUBROUTINE RXN_Hg2_DRYD( I, J, L, + & N, RKT, E_RKT, + & E_SALT, LOST_Hg0, DTCHEM, LOST_SS ) +! +!****************************************************************************** +! Subroutine RXN_Hg2_DRYD computes the new concentration of Hg(II) from the +! converted Hg(0) plus the drydep of Hg(II). (eck, bmy, 12/14/04, 4/6/06) +! +! Arguments as Input: +! ============================================================================ +! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt grid box indices +! (4 ) N (INTEGER) : Index for Hg(II) total or tagged tracers +! (5 ) RKT (REAL*8 ) : Value of R * k * Temp for drydep [unitless] +! (6 ) E_RKT (REAL*8 ) : Value of EXP( - RKT ) [unitless] +! (7 ) E_SALT (REAL*8 ) : Value of EXP( -KSALT * DTCHEM ) +! (8 ) LOST_Hg0 (REAL*8 ) : Amount of Hg(0) that became Hg(II) [kg] +! (9 ) DTCHEM (INTEGER) : Chemistry timestep [s] +! +! Arguments as Output: +! ============================================================================ +! (10 ) LOST_SS (REAL*8 ) : Hg2 lost to sea salt rxn [kg] +! +! NOTES: +! (1 ) Now use 2 different solutions, depending on whether or not LOST_Hg0 +! (amt of converted Hg0 -> Hg2) is positive. Also now archive the +! amount of total Hg(II) tracer lost to drydep for the ocean flux +! routines in "ocean_mercury_mod.f". (sas, bmy, 1/19/05) +! (2 ) Remove references to "diag_mod.f" and "CMN_DIAG". Now save drydep +! fluxes into T44 array. (bmy, 2/24/05) +! (3 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +! (4 ) Now add E_SALT to account for uptake by sea salt. Now references +! IS_WATER from "dao_mod.f". Now uses ID_Hg2 and ID_Hg_tot from +! "tracerid_mod.f". Now references LDYNOCEAN from "logical_mod.f". +! Now do not call ADD_Hg2_DD if we are not using the dynamic ocean +! module. Now also return LOST_SS. (eck, cdh, bmy, 4/6/06) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : IS_WATER + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LDYNOCEAN + USE OCEAN_MERCURY_MOD, ONLY : ADD_Hg2_DD + USE TRACER_MOD, ONLY : STT, XNUMOL + USE TRACERID_MOD, ONLY : IS_Hg2 + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND44 + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L, N + REAL*8, INTENT(IN) :: RKT, E_RKT, E_SALT, LOST_Hg0, DTCHEM + REAL*8, INTENT(OUT) :: LOST_SS + + ! Local variables + INTEGER :: NN + REAL*8 :: AREA_CM2, DRYDEP, OLD_Hg2 + REAL*8 :: NEW_Hg2, TEMP_Hg2 + + !================================================================= + ! RXN_Hg2_DRYD begins here! + !================================================================= + + ! Error check tracer number + IF ( N < 1 ) RETURN + + ! Initial concentration of Hg(II) [kg] + OLD_Hg2 = MAX( STT(I,J,L,N), SMALLNUM ) + + IF ( LOST_Hg0 > 0d0 ) THEN + + !-------------------------------------------------------------- + ! CASE 1a: Amt of Hg(0) converted to Hg(II) is positive + ! Use Solution #1 of the differential equation + !-------------------------------------------------------------- + + ! Concentration of Hg(II) after drydep [kg] + ! Factor in drydep at this time + NEW_Hg2 = ( OLD_Hg2 * E_RKT ) + + & ( LOST_Hg0/RKT * ( 1d0 - E_RKT ) ) + + ELSE + + !-------------------------------------------------------------- + ! CASE 1b: Amt of Hg(0) converted to Hg(II) is negative or zero + ! Use Solution #2 of the differential equation + !-------------------------------------------------------------- + + ! New concentration of Hg(II) [kg] + ! Assume drydep takes place after chemistry + NEW_Hg2 = ( OLD_Hg2 + LOST_Hg0 ) * E_RKT + + ENDIF + + ! Also account for uptake of Hg(II) by sea salt aerosol + IF ( IS_WATER( I, J ) ) THEN + TEMP_Hg2 = NEW_Hg2 * E_SALT + ELSE + TEMP_Hg2 = NEW_Hg2 + ENDIF + + ! Amount of Hg2 lost to sea salt + LOST_SS = MAX( NEW_Hg2 - TEMP_Hg2, SMALLNUM ) + + ! Reset + NEW_Hg2 = TEMP_Hg2 + + ! Save back into STT array [kg] + NEW_Hg2 = MAX( NEW_Hg2, SMALLNUM ) + STT(I,J,L,N) = NEW_Hg2 + + !================================================================= + ! Compute amount of Hg(II) lost to drydep + !================================================================= + + ! Amount of Hg(II) lost to dry deposition [kg] + DRYDEP = ( OLD_Hg2 - NEW_Hg2 ) + LOST_Hg0 + + ! Archive Hg(II) lost to drydep [kg] for the ocean mercury flux routines + ! in "ocean_mercury_mod.f" if necessary. Do not call ADD_Hg2_DD if the + IF ( IS_Hg2(N) .and. LDYNOCEAN ) THEN + CALL ADD_Hg2_DD( I, J, N, DRYDEP ) + ENDIF + + !================================================================= + ! ND44 diagnostic: drydep flux of Hg(II) [molec/cm2/s] + !================================================================= + IF ( ND44 > 0 ) THEN + + ! Grid box surface area [cm2] + AREA_CM2 = GET_AREA_CM2( J ) + + ! Amt of Hg(II) lost to drydep [molec/cm2/s] + DRYDEP = DRYDEP * XNUMOL(N) / ( AREA_CM2 * DTCHEM ) + + ! Archive Hg(II) drydep flux in T44 array [molec/cm2/s] + T44(I,J,L,N) = T44(I,J,L,N) + DRYDEP + + ENDIF + + ! Return to calling program + END SUBROUTINE RXN_Hg2_DRYD + +!------------------------------------------------------------------------------ + + SUBROUTINE RXN_Hg2( I, J, L, N, LOST_Hg0 ) +! +!****************************************************************************** +! Subroutine RXN_Hg2 computes the new concentration of Hg(II) which is the +! old concentration plus the amount of converted Hg(0) (eck, bmy, 12/14/04) +! +! Arguments as Input: +! ============================================================================ +! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt grid box indices +! (4 ) N (INTEGER) : Index for Hg(II) total or tagged tracers +! (5 ) LOST_Hg0 (REAL*8 ) : Amount of Hg(0) that has become Hg(II) [kg] +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : STT + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L, N + REAL*8, INTENT(IN) :: LOST_Hg0 + + ! Local variables + REAL*8 :: OLD_Hg2, NEW_Hg2 + + !================================================================= + ! RXN_Hg2 begins here! + !================================================================= + + ! Error check tracer number + IF ( N < 1 ) RETURN + + ! Initial concentration of Hg(II) [kg] + OLD_Hg2 = MAX( STT(I,J,L,N), SMALLNUM ) + + ! New concentration of Hg(II) is the old concentration + ! plus the amount of Hg(0) which was converted to Hg(II) [kg] + NEW_Hg2 = MAX( ( OLD_Hg2 + LOST_Hg0 ), SMALLNUM ) + + ! Save new concentration of Hg(II) to STT array [kg] + STT(I,J,L,N) = NEW_Hg2 + + ! Return to calling program + END SUBROUTINE RXN_Hg2 + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEM_HgP( V_DEP_HgP ) +! +!****************************************************************************** +! Subroutine CHEM_HgP is the chemistry subroutine for HgP (particulate +! mercury. HgP is lost via dry deposition. (eck, bmy, 12/7/04, 4/6/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) V_DEP_HgP (REAL*8) : Dry deposition velocity for Hg(II) [cm/s] +! +! NOTES: +! (1 ) Removed references to AD44 and "CMN_DIAG". Now compute drydep for all +! levels within the PBL. Now references ND03, LD03 from "diag03_mod.f". +! (bmy, 2/24/05) +! (2 ) Now references XNUMOL & XNUMOLAIR from "tracer_mod.f" (bmy, 10/25/05) +! (3 ) Now use ID_HgP index array from "tracerid_mod.f". (cdh, bmy, 1/9/06) +!****************************************************************************** +! + ! Refernces to F90 modules + USE DIAG03_MOD, ONLY : ND03, LD03 + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LSPLIT + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP, GET_PBL_MAX_L + USE TIME_MOD, ONLY : GET_TS_CHEM + USE TRACER_MOD, ONLY : STT, XNUMOL + USE TRACERID_MOD, ONLY : ID_HgP, N_Hg_CATS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*8, INTENT(IN) :: V_DEP_HgP(IIPAR,JJPAR) + + ! Local variables + INTEGER :: I, J, L, NN, PBL_MAX + REAL*8 :: DTCHEM, E_KT, F_UNDER_TOP + + !================================================================= + ! CHEM_HgP begins here! + !================================================================= + + ! Chemistry timestep [s] + DTCHEM = GET_TS_CHEM() * 60d0 + + ! Maximum extent of the PBL + PBL_MAX = GET_PBL_MAX_L() + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, F_UNDER_TOP, E_KT, NN ) +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, PBL_MAX + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Fraction of box (I,J,L) underneath the PBL top [unitless] + F_UNDER_TOP = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! If we are in the PBL and there is nonzero drydep vel ... + IF ( F_UNDER_TOP > 0d0 .and. V_DEP_HgP(I,J) > 0d0 ) THEN + + ! Pre-compute the exponential term for use below [unitless] + E_KT = EXP( -V_DEP_HgP(I,J) * DTCHEM * F_UNDER_TOP ) + + ! Compute new conc of HgP tracers after drydep [kg] + DO NN = 1, N_Hg_CATS + + ! Do dry deposition (skip undefined HgP tagged tracers) + IF ( ID_HgP(NN) > 0 ) THEN + CALL RXN_HgP_DRYD( I, J, L, ID_HgP(NN), E_KT, DTCHEM ) + ENDIF + + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to callwing program + END SUBROUTINE CHEM_HgP + +!------------------------------------------------------------------------------ + + SUBROUTINE RXN_HgP_DRYD( I, J, L, N, E_KT, DTCHEM ) +! +!****************************************************************************** +! Subroutine RXN_Hg0_DRYD computes the new concentration of HgP +! after dry deposition. ND44 diagnostics are also archived. +! (eck, bmy, 12/14/04, 4/6/06) +! +! Arguments as Input: +! ============================================================================ +! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt grid box indices +! (4 ) N (INTEGER) : Index for HgP total or tagged tracers +! (5 ) E_KT (REAL*8 ) : Value of EXP( -KT ) for drydep rxn [unitless] +! (6 ) DTCHEM (INTEGER) : Chemistry timestep [s] +! +! NOTES: +! (1 ) Remove references to "diag_mod.f" and "CMN_DIAG". Now save drydep +! fluxes into T44 array. (bmy, 2/24/05) +! (2 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +! (3 ) Now uses ID_HgP and ID_Hg_tot from "tracerid_mod.f" (cdh, bmy,4/6/06) +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TRACER_MOD, ONLY : STT, XNUMOL + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND44 + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L, N + REAL*8, INTENT(IN) :: DTCHEM, E_KT + + ! Local variables + INTEGER :: NN + REAL*8 :: AREA_CM2, DRYDEP, OLD_HgP, NEW_HgP + + !================================================================= + ! RXN_HgP_DRYD begins here! + !================================================================= + + ! Error check tracer number + IF ( N < 1 ) RETURN + + ! Initial concentration of HgP [kg] + OLD_HgP = MAX( STT(I,J,L,N), SMALLNUM ) + + ! New concentration of HgP after drydep [kg] + NEW_HgP = MAX( ( OLD_HgP * E_KT ), SMALLNUM ) + + ! Save new concentration of HgP in STT [kg] + STT(I,J,L,N) = NEW_HgP + + !================================================================= + ! ND44 diagnostic: drydep flux of Hg(II) [molec/cm2/s] + !================================================================= + IF ( ND44 > 0 ) THEN + + ! Grid box surface area [cm2] + AREA_CM2 = GET_AREA_CM2( J ) + + ! Amt of Hg(II) lost to drydep [molec/cm2/s] + DRYDEP = OLD_HgP - NEW_HgP + DRYDEP = ( DRYDEP * XNUMOL(N) ) / ( AREA_CM2 * DTCHEM ) + + ! Archive Hg(II) drydep flux in T44 array [molec/cm2/s] + T44(I,J,L,N) = T44(I,J,L,N) + DRYDEP + + ENDIF + + ! Return to calling program + END SUBROUTINE RXN_HgP_DRYD + +!------------------------------------------------------------------------------ + + SUBROUTINE EMISSMERCURY +! +!****************************************************************************** +! Subroutine EMISSMERCURY is the driver routine for mercury emissions. +! (eck, bmy, 12/7/04, 4/6/06) +! +! NOTES: +! (1 ) Now call OCEAN_MERCURY_FLUX from "ocean_mercury_mod.f" to compute +! the emissions of Hg0 from the ocean instead of reading it from disk. +! (sas, bmy, 1/20/05) +! (2 ) Now no longer call COMPUTE_FEMIS, since we can get the same information +! from routine GET_FRAC_OF_PBL in "pbl_mix_mod.f" (bmy, 2/22/05) +! (3 ) Now modified for new ocean mercury module. (cdh, sas, bmy, 4/6/06) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : DEBUG_MSG + USE LOGICAL_MOD, ONLY : LPRT, LDYNOCEAN + USE OCEAN_MERCURY_MOD, ONLY : OCEAN_MERCURY_FLUX + USE TIME_MOD, ONLY : GET_MONTH + USE TRACER_MOD, ONLY : STT + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: THISMONTH + + !================================================================= + ! EMISSMERCURY begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + + ! Read anthro, ocean, land emissions of Hg from disk + CALL MERCURY_READYR + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + !================================================================= + ! Call emission routines for Hg(0), Hg(II), and Hg(P) + !================================================================= + + ! Ocean flux of Hg(0) + IF ( LDYNOCEAN ) THEN + CALL OCEAN_MERCURY_FLUX( EHg0_oc ) + IF ( LPRT ) CALL DEBUG_MSG( '### EMISSMERCURY: a OCEAN_FLUX' ) + ENDIF + + ! Add Hg(0) source into STT [kg] + CALL SRCHg0 + IF ( LPRT ) CALL DEBUG_MSG( '### EMISSMERCURY: a SRCHg0' ) + + ! Add Hg(II) source into STT [kg] + CALL SRCHg2 + IF ( LPRT ) CALL DEBUG_MSG( '### EMISSMERCURY: a SRCHg2' ) + + ! Add HgP source into STT [kg] + CALL SRCHgP + IF ( LPRT ) CALL DEBUG_MSG( '### EMISSMERCURY: a SRCHgP' ) + + ! Return to calling program + END SUBROUTINE EMISSMERCURY + +!------------------------------------------------------------------------------ + + SUBROUTINE SRCHg0 +! +!****************************************************************************** +! Subroutine SRCHg0 is the subroutine for Hg(0) emissions. +! Emissions of Hg(0) will be distributed throughout the boundary layer. +! (eck, cdh, bmy, 1/21/05, 4/6/06) +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) TC (REAL*8) : Tracer concentration of Hg(0) [kg] +! +! NOTES: +! (1 ) Now use diagnostic arrays from "diag03_mod.f" (bmy, 1/21/05) +! (2 ) Now references GET_FRAC_OF_PBL and GET_PBL_MAX_L from "pbl_mix_mod.f". +! Remove reference to FEMIS. (bmy, 2/22/05) +! (3 ) EHg0_an is now a 2-D array. Modified for new ocean mercury module. +! Now use ID_Hg0 index array from "tracerid_mod.f". Now make sure +! STT does not underflow. (cdh, bmy, 4/6/06) +!****************************************************************************** +! + ! Reference to diagnostic arrays + USE DIAG03_MOD, ONLY : AD03, ND03 + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LSPLIT + USE PBL_MIX_MOD, ONLY : GET_FRAC_OF_PBL, GET_PBL_MAX_L + USE TIME_MOD, ONLY : GET_TS_EMIS + USE TRACER_MOD, ONLY : STT + USE TRACERID_MOD, ONLY : ID_Hg_tot, ID_Hg_na, ID_Hg_eu, ID_Hg_as + USE TRACERID_MOD, ONLY : ID_Hg_rw, ID_Hg_oc, ID_Hg_ln, ID_Hg_nt + USE TRACERID_MOD, ONLY : ID_Hg0 + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, N, PBL_MAX + REAL*8 :: DTSRCE, E_Hg, F_OF_PBL, T_Hg, T_Hg_An + + !================================================================= + ! SRCHg0 begins here! + !================================================================= + + ! Emission timestep [s] + DTSRCE = GET_TS_EMIS() * 60d0 + + ! Maximum extent of the PBL [model levels] + PBL_MAX = GET_PBL_MAX_L() + + ! Loop over grid boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, T_Hg_An, T_Hg, F_OF_PBL, E_Hg ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Compute total anthropogenic Hg(0) emissions + T_Hg_An = EHg0_an(I,J) + + ! Compute total Hg(0) emissions (anthro+oceans+land+natural) + T_Hg = T_Hg_An + EHg0_oc(I,J,ID_Hg_tot) + + & EHg0_ln(I,J) + EHg0_nt(I,J) + + !============================================================== + ! Partition Hg0 throughout PBL; store into STT [kg] + ! Now make sure STT does not underflow (cdh, bmy, 4/6/06) + !============================================================== + + ! Loop up to max PBL level + DO L = 1, PBL_MAX + + ! Fraction of box (I,J,L) w/in the PBL [unitless] + F_OF_PBL = GET_FRAC_OF_PBL( I, J, L ) + + !----------------- + ! Total Hg tracer + !----------------- + N = ID_Hg0(ID_Hg_tot) + E_Hg = F_OF_PBL * T_Hg + STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE ) + + !----------------- + ! Tagged tracers + !----------------- + IF ( LSPLIT ) THEN + + !-------------------- + ! Primary emissions + !-------------------- + + ! Anthro Hg0 by region + N = AN_Hg0(I,J) + E_Hg = F_OF_PBL * T_Hg_an + STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE ) + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + ! Land re-emissions of Hg0 + N = ID_Hg0(ID_Hg_ln) + E_Hg = F_OF_PBL * EHg0_ln(I,J) + STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE ) + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + ! Natural land sources of Hg0 + N = ID_Hg0(ID_Hg_nt) + E_Hg = F_OF_PBL * EHg0_nt(I,J) + STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE ) + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + !-------------------- + ! Ocean re-emissions + !-------------------- + + ! Anthro re-emission from ocean in N. AMERICA + N = ID_Hg0(ID_Hg_na) + E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_na) + STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE ) + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + ! Anthro re-emission from ocean in EUROPE + N = ID_Hg0(ID_Hg_eu) + E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_eu) + STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE ) + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + ! Anthro re-emission from ocean in ASIA + N = ID_Hg0(ID_Hg_as) + E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_as) + STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE ) + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + ! Anthro re-emission from ocean in REST OF WORLD + N = ID_Hg0(ID_Hg_rw) + E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_rw) + STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE ) + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + ! Re-emission from ocean in OCEAN + N = ID_Hg0(ID_Hg_oc) + E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_oc) + STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE ) + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + ! Re-emission from ocean in LAND REEMISSION + N = ID_Hg0(ID_Hg_ln) + E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_ln) + STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE ) + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + ! Re-emission from ocean in NATURAL + N = ID_Hg0(ID_Hg_nt) + E_Hg = F_OF_PBL * EHg0_oc(I,J,ID_Hg_nt) + STT(I,J,L,N) = STT(I,J,L,N) + ( E_Hg * DTSRCE ) + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + ENDIF + ENDDO + + !============================================================== + ! ND03 diagnostic: Total Hg(0) emissions [kg] + ! 1=anthro; 3=from ocean; 4=land re-emission; 5=natural src + !============================================================== + IF ( ND03 > 0 ) THEN + N = ID_Hg_tot + AD03(I,J,1) = AD03(I,J,1) + ( T_Hg_An * DTSRCE ) + AD03(I,J,3) = AD03(I,J,3) + ( EHg0_oc(I,J,N) * DTSRCE ) + AD03(I,J,4) = AD03(I,J,4) + ( EHg0_ln(I,J) * DTSRCE ) + AD03(I,J,5) = AD03(I,J,5) + ( EHg0_nt(I,J) * DTSRCE ) + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE SRCHg0 + +!----------------------------------------------------------------------------- + + SUBROUTINE SRCHg2 +! +!****************************************************************************** +! Subroutine SRCHg2 is the subroutine for Hg(II) emissions. +! Emissions of Hg(II) will be distributed throughout the boundary layer. +! (eck, bmy, 12/7/04, 4/6/06) +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) TC (REAL*8) : Tracer concentration of Hg(II) [kg] +! +! NOTES: +! (1 ) Now use diagnostic arrays from "diag03_mod.f" (bmy, 1/21/05) +! (2 ) Now references GET_FRAC_OF_PBL and GET_PBL_MAX_L from "pbl_mix_mod.f". +! Remove reference to FEMIS. (bmy, 2/22/05) +! (3 ) EHg2_an is now a 2-D array. Now use ID_Hg2 index array from +! "tracerid_mod.f". Now make sure STT does not underflow. +! (eck, cdh, bmy, 4/6/06) +!****************************************************************************** +! + ! Reference to F90 modules + USE DIAG03_MOD, ONLY : AD03, ND03 + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LSPLIT + USE PBL_MIX_MOD, ONLY : GET_FRAC_OF_PBL, GET_PBL_MAX_L + USE TIME_MOD, ONLY : GET_TS_EMIS + USE TRACER_MOD, ONLY : STT + USE TRACERID_MOD, ONLY : ID_Hg_tot, ID_Hg2 + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J, L, N, PBL_MAX + REAL*8 :: DTSRCE, F_OF_PBL, E_Hg + + !================================================================= + ! SRCHg2 begins here! + !================================================================= + + ! Emission timestep [s] + DTSRCE = GET_TS_EMIS() * 60d0 + + ! Maximum extent of the PBL [model levels] + PBL_MAX = GET_PBL_MAX_L() + + ! Loop over grid boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, F_OF_PBL, E_Hg, N ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Loop up to the max PBL layer + DO L = 1, PBL_MAX + + ! Fraction of box (I,J,L) w/in the PBL [unitless] + F_OF_PBL = GET_FRAC_OF_PBL( I, J, L ) + + ! Partition total Hg2 into box (I,J,L) [kg] + E_Hg = F_OF_PBL * EHg2_an(I,J) * DTSRCE + + !--------------------------- + ! Total anthro Hg(II) [kg] + !--------------------------- + N = ID_Hg2(ID_Hg_tot) + STT(I,J,L,N) = STT(I,J,L,N) + E_Hg + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + !--------------------------- + ! Tagged anthro Hg(II) [kg] + !--------------------------- + IF ( LSPLIT ) THEN + N = AN_Hg2(I,J) + STT(I,J,L,N) = STT(I,J,L,N) + E_Hg + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + ENDIF + ENDDO + + !------------------------------- + ! ND03 diag: Anthro Hg(II) [kg] + !------------------------------- + IF ( ND03 > 0 ) THEN + AD03(I,J,6) = AD03(I,J,6) + ( EHg2_an(I,J) * DTSRCE ) + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE SRCHg2 + +!----------------------------------------------------------------------------- + + SUBROUTINE SRCHgP +! +!****************************************************************************** +! Subroutine SRCHgP is the subroutine for HgP emissions. +! Emissions of HgP will be distributed throughout the boundary layer. +! (eck, bmy, 12/7/04, 4/6/06) +! +! Arguments as Input/Output: +! ============================================================================ +! (1 ) TC (REAL*8) : Tracer concentration of Hg(II) [kg] +! +! NOTES: +! (1 ) Now use diagnostic arrays from "diag03_mod.f" (bmy, 1/21/05) +! (2 ) Now references GET_FRAC_OF_PBL and GET_PBL_MAX_L from "pbl_mix_mod.f". +! Remove reference to FEMIS. (bmy, 2/22/05) +! (3 ) EHgP_an is now a 2-D array. Now use ID_HgP index array from +! "tracerid_mod.f". Now make sure STT does not underflow. +! (eck, cdh, bmy, 4/6/06) +!****************************************************************************** +! + ! Reference to diagnostic arrays + USE DIAG03_MOD, ONLY : AD03, ND03 + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LSPLIT + USE PBL_MIX_MOD, ONLY : GET_FRAC_OF_PBL, GET_PBL_MAX_L + USE TIME_MOD, ONLY : GET_TS_EMIS + USE TRACER_MOD, ONLY : STT + USE TRACERID_MOD, ONLY : ID_Hg_tot, ID_HgP + +# include "CMN_SIZE" ! Size paramters + + ! Local variables + INTEGER :: I, J, L, N, PBL_MAX + REAL*8 :: DTSRCE, F_OF_PBL, E_Hg + + !================================================================= + ! SRCHgP begins here! + !================================================================= + + ! Chemistry timestep [s] + DTSRCE = GET_TS_EMIS() * 60d0 + + ! Maximum extent of the PBL [model levels] + PBL_MAX = GET_PBL_MAX_L() + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, F_OF_PBL, E_Hg, N ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Loop up to PBL top layer + DO L = 1, PBL_MAX + + ! Fraction of box (I,J,L) w/in the PBL [unitless] + F_OF_PBL = GET_FRAC_OF_PBL( I, J, L ) + + ! Partition HgP into box (I,J,L) [kg] + E_Hg = F_OF_PBL * EHgP_an(I,J) * DTSRCE + + !------------------------ + ! Total anthro HgP [kg] + !------------------------ + N = ID_HgP(ID_Hg_tot) + STT(I,J,L,N) = STT(I,J,L,N) + E_Hg + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + + !------------------------ + ! Tagged anthro HgP [kg] + !------------------------ + IF ( LSPLIT ) THEN + N = AN_HgP(I,J) + STT(I,J,L,N) = STT(I,J,L,N) + E_Hg + STT(I,J,L,N) = MAX( STT(I,J,L,N), SMALLNUM ) + ENDIF + ENDDO + + !---------------------------- + ! ND03 diag: Anthro HgP [kg] + !---------------------------- + IF ( ND03 > 0 ) THEN + AD03(I,J,9) = AD03(I,J,9) + ( EHgP_an(I,J) * DTSRCE ) + ENDIF + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE SRCHgP + +!------------------------------------------------------------------------------ + + SUBROUTINE MERCURY_READYR +! +!****************************************************************************** +! Subroutine MERCURY_READYR reads the year-invariant emissions for Mercury +! from anthropogenic, ocean, and land sources. (eck, bmy, 12/6/04, 4/6/06) +! +! NOTES: +! (1 ) Now read data from mercury_200501 subdirectory. Now compute oceanic +! Hg(0) emissions w/ ocean flux module instead of reading them from +! disk. Now use 1985 TAU values. (sas, bmy, 1/20/05) +! (2 ) Now can read data for both GEOS and GCAP grids (bmy, 8/16/05) +! (3 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (4 ) Now read anthro emissions on GEOS 1x1 grid in DATA_1x1_DIR. Also +! keep 2x25 and 4x5 files together in DATA_1x1_DIR. Also now use new +! land re-emissions files from Noelle Selin. (eck, bmy, 4/6/06) +!****************************************************************************** +! + ! 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_1x1 + USE LOGICAL_MOD, ONLY : LDYNOCEAN + USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1 + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRANSFER_MOD, ONLY : TRANSFER_2D + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: NYMD + REAL*4 :: ARRAY(IGLOB,JGLOB,1) + REAL*4 :: ARRAY1(I1x1,J1x1,1) + REAL*8 :: XTAU + REAL*8, PARAMETER :: SEC_PER_YR = 365.25d0 * 86400d0 + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! MERCURY_READYR begins here! + ! + ! Read annual anthropogenic mercury emissions [kg/s] + !================================================================= + + ! Mercury data is either for 1995 or 2000 + NYMD = ( ANTHRO_Hg_YEAR * 10000 ) + 0101 + XTAU = GET_TAU0( 1, 1, ANTHRO_Hg_YEAR ) + + !--------------------------- + ! Hg(0) emissions [kg/s] + !--------------------------- + + ! Filename for anthropogenic mercury source + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'mercury_200511/GEIA_Hg0.geos.1x1.YYYY' + + ! Add year to the filename + CALL EXPAND_DATE( FILENAME, NYMD, 000000 ) + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MERCURY_READYR: Reading ', a ) + + ! Read data in [kg/yr] + CALL READ_BPCH2( FILENAME, 'HG-SRCE', 1, + & XTAU, I1x1, J1x1, + & 1, ARRAY1, QUIET=.TRUE. ) + + ! Regrid from 1x1 to the current grid + CALL DO_REGRID_1x1( 'kg', ARRAY1, EHg0_an ) + + ! Convert from [kg/yr] to [kg/s] + EHg0_an = EHg0_an / SEC_PER_YR + + !--------------------------- + ! Hg(II) emissions [kg/s] + !--------------------------- + + ! Filename for anthropogenic mercury source + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'mercury_200511/GEIA_Hg2.geos.1x1.YYYY' + + ! Add year to the filename + CALL EXPAND_DATE( FILENAME, NYMD, 000000 ) + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Read data in [kg/yr] + CALL READ_BPCH2( FILENAME, 'HG-SRCE', 6, + & XTAU, I1x1, J1x1, + & 1, ARRAY1, QUIET=.TRUE. ) + + ! Regrid from 1x1 to the current grid + CALL DO_REGRID_1x1( 'kg', ARRAY1, EHg2_an ) + + ! Convert from [kg/yr] to [kg/s] + EHg2_an = EHg2_an / SEC_PER_YR + + !--------------------------- + ! HgP emissions [kg/s] + !--------------------------- + + ! Filename for anthropogenic mercury source + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'mercury_200511/GEIA_HgP.geos.1x1.YYYY' + + ! Add year to the filename + CALL EXPAND_DATE( FILENAME, NYMD, 000000 ) + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Read data in [kg/yr] + CALL READ_BPCH2( FILENAME, 'HG-SRCE', 9, + & XTAU, I1x1, J1x1, + & 1, ARRAY1, QUIET=.TRUE. ) + + ! Regrid from 1x1 to the current grid + CALL DO_REGRID_1x1( 'kg', ARRAY1, EHgP_an ) + + ! Convert from [kg/yr] to [kg/s] + EHgP_an = EHgP_an / SEC_PER_YR + + !================================================================= + ! Read annual emissions of anthropogenic Hg(0) which is + ! re-emitted from the land [kg/s] + !================================================================= + + ! Use "generic" year 1985 for TAU values + XTAU = GET_TAU0( 1, 1, 1985 ) + + ! Filename for re-emitted anthropogenic mercury + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'mercury_200511/Hg_land_reemission.' // + & GET_NAME_EXT_2D() // '.' // GET_RES_EXT() + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Read data in [kg/yr] + CALL READ_BPCH2( FILENAME, 'HG-SRCE', 4, + & XTAU, IGLOB, JGLOB, + & 1, ARRAY(:,:,1), QUIET=.TRUE. ) + + ! Cast to REAL*8 and resize + CALL TRANSFER_2D( ARRAY(:,:,1), EHg0_ln ) + + ! Convert from [Mg/yr] to [kg/s] + EHg0_ln = EHg0_ln * 1000d0 / SEC_PER_YR + + !================================================================= + ! Read annual emissions of Hg(0) from natural land sources [kg/s] + !================================================================= + + ! Use "generic" year 1985 for TAU values + XTAU = GET_TAU0( 1, 1, 1985 ) + + ! Filename for natural land-source mercury + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'mercury_200511/Hg_natural.' // GET_NAME_EXT_2D() // + & '.' // GET_RES_EXT() + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! TAU value corresponding to the data + XTAU = GET_TAU0( 1, 1, 1995 ) + + ! Read data in [kg/yr] + CALL READ_BPCH2( FILENAME, 'HG-SRCE', 5, + & XTAU, IGLOB, JGLOB, + & 1, ARRAY(:,:,1), QUIET=.TRUE. ) + + ! Cast to REAL*8 and resize + CALL TRANSFER_2D( ARRAY(:,:,1), EHg0_nt ) + + ! Convert from [kg/yr] to [kg/s] + EHg0_nt = EHg0_nt / SEC_PER_YR + + !================================================================= + ! Read offline ocean Hg0 emissions (if LDYNOCEAN = .FALSE.) + !================================================================= + IF ( .not. LDYNOCEAN ) THEN + + ! File name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'mercury_200511/Hg_ocean.geos.' // GET_RES_EXT() + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! TAU value corresponding to the data + XTAU = GET_TAU0( 1, 1, 1985 ) + + ! Read data in [kg/yr] + CALL READ_BPCH2( FILENAME, 'HG-SRCE', 3, + & XTAU, IGLOB, JGLOB, + & 1, ARRAY(:,:,1), QUIET=.TRUE. ) + + ! Cast to REAL*8 and resize + CALL TRANSFER_2D( ARRAY(:,:,1), EHg0_oc(:,:,1) ) + + ! Convert from [kg/yr] to [kg/s] + EHg0_oc = EHg0_oc / SEC_PER_YR + + ENDIF + + !================================================================= + ! Print totals to the screen in [Gg/yr] + !================================================================= + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, 110 ) + WRITE( 6, '(a)' ) + WRITE( 6, 111 ) SUM( EHg0_an ) * SEC_PER_YR * 1d-6 + WRITE( 6, 113 ) SUM( EHg0_ln ) * SEC_PER_YR * 1d-6 + WRITE( 6, 114 ) SUM( EHg0_nt ) * SEC_PER_YR * 1d-6 + + ! Only write ocean total if we are doing offline ocean + IF ( .not. LDYNOCEAN ) THEN + WRITE( 6, 117 ) SUM( EHg0_oc ) * SEC_PER_YR * 1d-6 + ENDIF + + WRITE( 6, 115 ) SUM( EHg2_an ) * SEC_PER_YR * 1d-6 + WRITE( 6, 116 ) SUM( EHgP_an ) * SEC_PER_YR * 1d-6 + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! FORMAT strings + 110 FORMAT( 'M E R C U R Y E M I S S I O N S' ) + 111 FORMAT( 'Total Anthro Hg(0) : ', f7.3, ' [Gg/yr]' ) + 113 FORMAT( 'Total Re-Emitted Hg(0) : ', f7.3, ' [Gg/yr]' ) + 114 FORMAT( 'Total Natural Hg(0) : ', f7.3, ' [Gg/yr]' ) + 115 FORMAT( 'Total Anthro Hg(II) : ', f7.3, ' [Gg/yr]' ) + 116 FORMAT( 'Total Anthro HgP : ', f7.3, ' [Gg/yr]' ) + 117 FORMAT( 'Total Ocean Hg(0) : ', f7.3, ' [Gg/yr]' ) + + ! Return to calling program + END SUBROUTINE MERCURY_READYR + +!------------------------------------------------------------------------------ + + FUNCTION GET_LWC( T ) RESULT( LWC ) +! +!****************************************************************************** +! Function GET_LWC returns the cloud liquid water content at a GEOS-CHEM +! grid box as a function of temperature. (rjp, bmy, 10/31/02, 12/1/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) T (REAL*8) : Temperature value at a GEOS-CHEM grid box [K] +! +! NOTES: +! (1 ) Now also add a case for T > 293 to the IF statement (cdh, bmy, 12/1/06) +!****************************************************************************** +! + ! Arguments + REAL*8, INTENT(IN) :: T + + ! Function value + REAL*8 :: LWC + + !================================================================= + ! GET_LWC begins here! + !================================================================= + + ! Compute Liquid water content in [g/m3] + IF ( T > 293d0 ) THEN + LWC = 0.2d0 + + ELSE IF ( T >= 280.d0 .AND. T <= 293.d0 ) THEN + LWC = 0.32d0 - 0.0060d0 * ( T - 273.D0 ) + + ELSE IF ( T >= 248.d0 .AND. T < 280.d0 ) THEN + LWC = 0.23d0 + 0.0065d0 * ( T - 273.D0 ) + + ELSE IF ( T < 248.d0 ) THEN + LWC = 0.07d0 + + ENDIF + + ! Convert from [g/m3] to [m3/m3] + LWC = LWC * 1.D-6 + + ! Return to calling program + END FUNCTION GET_LWC + +!------------------------------------------------------------------------------ + + FUNCTION GET_VCLDF( I, J, L ) RESULT( VCLDF ) +! +!****************************************************************************** +! Subroutine GET_VCLDF computes the volume cloud fraction for Hg0 and Hg2 +! chemistry. (eck, bmy, 12/6/04) +! +! Arguments as Input: +! ============================================================================ +! (1-3) I, J, L (INTEGER) : GEOS-CHEM lon, lat, alt indices +! +! References: +! ============================================================================ +! (1 ) Sundqvist et al. [1989] +! +! NOTES: +! (1 ) Copied from "sulfate_mod.f" but was made into a function since we are +! already looping over (I,J,L) in CHEM_Hg0_Hg2 (eck, bmy, 12/6/04) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : RH + USE PRESSURE_MOD, ONLY : GET_PCENTER, GET_PEDGE + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L + + ! Local variables + REAL*8 :: PRES, PSFC, RH2, R0, B0 + REAL*8, PARAMETER :: ZRT = 0.60d0, ZRS = 0.99d0 + + ! Function value + REAL*8 :: VCLDF + + !================================================================= + ! GET_VCLDF begins here! + !================================================================= + + ! Surface pressure + PSFC = GET_PEDGE(I,J,1) + + ! Pressure at center of grid box L + PRES = GET_PCENTER(I,J,L) + + ! RH (from "dao_mod.f") is relative humidity [%] + ! Convert to fraction and store in RH2 + RH2 = RH(I,J,L) * 1.0d-2 + + ! Terms from Sundqvist ??? + R0 = ZRT + ( ZRS - ZRT ) * EXP( 1d0 - ( PSFC / PRES )**2.5 ) + B0 = ( RH2 - R0 ) / ( 1d0 - R0 ) + + ! Force B0 into the range 0-1 + IF ( RH2 < R0 ) B0 = 0d0 + IF ( B0 > 1d0 ) B0 = 1d0 + + ! Volume cloud fraction + VCLDF = 1d0 - SQRT( 1d0 - B0 ) + + ! Return to calling program + END FUNCTION GET_VCLDF + +!------------------------------------------------------------------------------ + + FUNCTION GET_O3( I, J, L ) RESULT( O3_MOLEC_CM3 ) +! +!****************************************************************************** +! Function GET_O3 returns monthly mean O3 for offline sulfate aerosol +! simulations. (bmy, 12/16/02, 1/19/07) +! +! Arguments as Input: +! ============================================================================ +! (1-3) I, J, L (INTEGER) : Grid box indices for lon, lat, vertical level +! +! NOTES: +! (1 ) We assume SETTRACE has been called to define IDO3. (bmy, 12/16/02) +! (2 ) Now reference inquiry functions from "tracer_mod.f" (bmy, 7/20/04) +! (3 ) Now also read stratospheric O3 (phs, 1/19/07) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : AD + USE GLOBAL_O3_MOD, ONLY : O3 + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L + + ! Local variables + REAL*8 :: O3_MOLEC_CM3 + + ! External functions + REAL*8, EXTERNAL :: BOXVL + + !================================================================= + ! GET_O3 begins here! + !================================================================= + + ! Get O3 [v/v] for this gridbox & month & convert to [molec/cm3] + O3_MOLEC_CM3 = O3(I,J,L) * ( 6.022d23 / 28.97d-3 ) * + & AD(I,J,L) / BOXVL(I,J,L) + + ! Return to calling program + END FUNCTION GET_O3 + +!------------------------------------------------------------------------------ + + FUNCTION GET_OH( I, J, L ) RESULT( OH_MOLEC_CM3 ) +! +!****************************************************************************** +! Function GET_OH returns monthly mean OH and imposes a diurnal variation. +! (eck, bmy, 12/7/04) +! +! Arguments as Input: +! ============================================================================ +! (1-3) I, J, L (INTEGER) : Grid box indices for lon, lat, vertical level +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : SUNCOS + USE GLOBAL_OH_MOD, ONLY : OH + USE TIME_MOD, ONLY : GET_TS_CHEM + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L + + ! Local variables + INTEGER :: JLOOP + REAL*8 :: OH_MOLEC_CM3 + + !================================================================= + ! GET_OH begins here! + !================================================================= + + ! 1-D grid box index for SUNCOS + JLOOP = ( (J-1) * IIPAR ) + I + + ! Test for sunlight... + IF ( SUNCOS(JLOOP) > 0d0 .and. TCOSZ(I,J) > 0d0 ) THEN + + ! Impose a diurnal variation on OH during the day + OH_MOLEC_CM3 = OH(I,J,L) * + & ( SUNCOS(JLOOP) / TCOSZ(I,J) ) * + & ( 1440d0 / GET_TS_CHEM() ) + + ! Make sure OH is not negative + OH_MOLEC_CM3 = MAX( OH_MOLEC_CM3, 0d0 ) + + ELSE + + ! At night, OH goes to zero + OH_MOLEC_CM3 = 0d0 + + ENDIF + + ! Return to calling program + END FUNCTION GET_OH + +!------------------------------------------------------------------------------ + + SUBROUTINE OHNO3TIME +! +!****************************************************************************** +! Subroutine OHNO3TIME computes the sum of cosine of the solar zenith +! angle over a 24 hour day, as well as the total length of daylight. +! This is needed to scale the offline OH and NO3 concentrations. +! (rjp, bmy, 12/16/02, 12/8/04) +! +! NOTES: +! (1 ) Copy code from COSSZA directly for now, so that we don't get NaN +! values. Figure this out later (rjp, bmy, 1/10/03) +! (2 ) Now replace XMID(I) with routine GET_XMID from "grid_mod.f". +! Now replace RLAT(J) with routine GET_YMID_R from "grid_mod.f". +! Removed NTIME, NHMSb from the arg list. Now use GET_NHMSb, +! GET_ELAPSED_SEC, GET_TS_CHEM, GET_DAY_OF_YEAR, GET_GMT from +! "time_mod.f". (bmy, 3/27/03) +! (3 ) Now store the peak SUNCOS value for each surface grid box (I,J) in +! the COSZM array. (rjp, bmy, 3/30/04) +! (4 ) Also added parallel loop over grid boxes (eck, bmy, 12/8/04) +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_XMID, GET_YMID_R + USE TIME_MOD, ONLY : GET_NHMSb, GET_ELAPSED_SEC + USE TIME_MOD, ONLY : GET_TS_CHEM, GET_DAY_OF_YEAR, GET_GMT + +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! Physical constants + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, IJLOOP, J, L, N, NT, NDYSTEP + REAL*8 :: A0, A1, A2, A3, B1, B2, B3 + REAL*8 :: LHR0, R, AHR, DEC, TIMLOC, YMID_R + REAL*8 :: SUNTMP(MAXIJ) + + !================================================================= + ! OHNO3TIME begins here! + !================================================================= + + ! Solar declination angle (low precision formula, good enough for us): + A0 = 0.006918 + A1 = 0.399912 + A2 = 0.006758 + A3 = 0.002697 + B1 = 0.070257 + B2 = 0.000907 + B3 = 0.000148 + R = 2.* PI * float( GET_DAY_OF_YEAR() - 1 ) / 365. + + DEC = A0 - A1*cos( R) + B1*sin( R) + & - A2*cos(2*R) + B2*sin(2*R) + & - A3*cos(3*R) + B3*sin(3*R) + + LHR0 = int(float( GET_NHMSb() )/10000.) + + ! Only do the following at the start of a new day + IF ( FIRST .or. GET_GMT() < 1e-5 ) THEN + + ! Zero arrays + TTDAY(:,:) = 0d0 + TCOSZ(:,:) = 0d0 + COSZM(:,:) = 0d0 + + ! NDYSTEP is # of chemistry time steps in this day + NDYSTEP = ( 24 - INT( GET_GMT() ) ) * 60 / GET_TS_CHEM() + + ! NT is the elapsed time [s] since the beginning of the run + NT = GET_ELAPSED_SEC() + + ! Loop forward through NDYSTEP "fake" timesteps for this day + DO N = 1, NDYSTEP + + ! Zero SUNTMP array + SUNTMP(:) = 0d0 + + ! Loop over surface grid boxes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, YMID_R, IJLOOP, TIMLOC, AHR ) + DO J = 1, JJPAR + + ! Grid box latitude center [radians] + YMID_R = GET_YMID_R( J ) + + DO I = 1, IIPAR + + ! Increment IJLOOP + IJLOOP = ( (J-1) * IIPAR ) + I + TIMLOC = real(LHR0) + real(NT)/3600.0 + GET_XMID(I)/15.0 + + DO WHILE (TIMLOC .lt. 0) + TIMLOC = TIMLOC + 24.0 + ENDDO + + DO WHILE (TIMLOC .gt. 24.0) + TIMLOC = TIMLOC - 24.0 + ENDDO + + AHR = abs(TIMLOC - 12.) * 15.0 * PI_180 + + !=========================================================== + ! The cosine of the solar zenith angle (SZA) is given by: + ! + ! cos(SZA) = sin(LAT)*sin(DEC) + cos(LAT)*cos(DEC)*cos(AHR) + ! + ! where LAT = the latitude angle, + ! DEC = the solar declination angle, + ! AHR = the hour angle, all in radians. + ! + ! If SUNCOS < 0, then the sun is below the horizon, and + ! therefore does not contribute to any solar heating. + !=========================================================== + + ! Compute Cos(SZA) + SUNTMP(IJLOOP) = sin(YMID_R) * sin(DEC) + + & cos(YMID_R) * cos(DEC) * cos(AHR) + + ! TCOSZ is the sum of SUNTMP at location (I,J) + ! Do not include negative values of SUNTMP + TCOSZ(I,J) = TCOSZ(I,J) + MAX( SUNTMP(IJLOOP), 0d0 ) + + ! COSZM is the peak value of SUMTMP during a day at (I,J) + ! (rjp, bmy, 3/30/04) + COSZM(I,J) = MAX( COSZM(I,J), SUNTMP(IJLOOP) ) + + ! TTDAY is the total daylight time at location (I,J) + IF ( SUNTMP(IJLOOP) > 0d0 ) THEN + TTDAY(I,J) = TTDAY(I,J) + DBLE( GET_TS_CHEM() ) + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Increment elapsed time [sec] + NT = NT + ( GET_TS_CHEM() * 60 ) + ENDDO + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + ! Return to calling program + END SUBROUTINE OHNO3TIME + +!------------------------------------------------------------------------------ + + SUBROUTINE DEFINE_TAGGED_Hg +! +!****************************************************************************** +! Subroutine DEFINE_TAGGED_Hg defines the tagged tracer numbers for +! anthropogenic (by geographic region) Hg0, Hg2, and HgP. The position of +! Hg2 and HgP in the DEPSAV array is also computed for future use. This +! routine only has to be called once at the start of the simulation. +! (eck, cdh, bmy, 12/15/04, 4/6/06) +! +! NOTES: +! (1 ) Now only define AN_Hg0, AN_Hg2, AN_HgP. Now use ID_Hg0, ID_Hg2, and +! ID_HgP index arrays from "tracerid_mod.f". (eck, cdh, bmy, 4/6/06) +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_XMID, GET_YMID + USE ERROR_MOD, ONLY : ERROR_STOP + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACERID_MOD, ONLY : ID_Hg0, ID_Hg2, ID_HgP + USE TRACERID_MOD, ONLY : ID_Hg_tot, ID_Hg_na, ID_Hg_eu, ID_Hg_as + USE TRACERID_MOD, ONLY : ID_Hg_rw, ID_Hg_oc, ID_Hg_ln, ID_Hg_nt + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J + REAL*8 :: X, Y + CHARACTER(LEN=255) :: LOCATION + + !================================================================= + ! DEFINE_TAGGED_Hg begins here! + !================================================================= + + ! Location string for ERROR_STOP + LOCATION = 'DEFINE_TAGGED_Hg ("mercury_mod.f")' + + !--------------------------------- + ! Anthropogenic tracer indices + !--------------------------------- +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, X, Y ) + + ! Loop over latitudes + DO J = 1, JJPAR + + ! Grid-box latitude [degrees] + Y = GET_YMID( J ) + + ! Loop over longitudes + DO I = 1, IIPAR + + ! Grid box longitude [degrees] + X = GET_XMID( I ) + + ! North American Anthro Hg + IF ( ( X >= -172.5 .and. X < -17.5 ) .and. + & ( Y >= 24.0 .and. Y < 88.0 ) ) THEN + AN_Hg0(I,J) = ID_Hg0(ID_Hg_na) + AN_Hg2(I,J) = ID_Hg2(ID_Hg_na) + AN_HgP(I,J) = ID_HgP(ID_Hg_na) + + ! European Anthro Hg (1st sub-box) + ELSE IF ( ( X >= -17.5 .and. X < 72.5 ) .and. + & ( Y >= 36.0 .and. Y < 45.0 ) ) THEN + AN_Hg0(I,J) = ID_Hg0(ID_Hg_eu) + AN_Hg2(I,J) = ID_Hg2(ID_Hg_eu) + AN_HgP(I,J) = ID_HgP(ID_Hg_eu) + + ! European Anthro Hg (2nd sub-box) + ELSE IF ( ( X >= -17.5 .and. X < 172.5 ) .and. + & ( Y >= 45.0 .and. Y < 88.0 ) ) THEN + AN_Hg0(I,J) = ID_Hg0(ID_Hg_eu) + AN_Hg2(I,J) = ID_Hg2(ID_Hg_eu) + AN_HgP(I,J) = ID_HgP(ID_Hg_eu) + + ! Asian Anthro Hg + ELSE IF ( ( X >= 70.0 .and. X < 152.5 ) .and. + & ( Y >= 8.0 .and. Y < 45.0 ) ) THEN + AN_Hg0(I,J) = ID_Hg0(ID_Hg_as) + AN_Hg2(I,J) = ID_Hg2(ID_Hg_as) + AN_HgP(I,J) = ID_HgP(ID_Hg_as) + + ! Rest-of-world Anthro Hg + ELSE + AN_Hg0(I,J) = ID_Hg0(ID_Hg_rw) + AN_Hg2(I,J) = ID_Hg2(ID_Hg_rw) + AN_HgP(I,J) = ID_HgP(ID_Hg_rw) + + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Error check tracers: make sure they are not zero + ! since this can cause array-out-of-bounds errors + !================================================================= + + ! Tagged Hg0 + IF ( ANY( AN_Hg0 == 0 ) ) THEN + CALL ERROR_STOP( 'AN_Hg0 tracers are undefined!', LOCATION ) + ENDIF + + ! Tagged Hg2 + IF ( ANY( AN_Hg2 == 0 ) ) THEN + CALL ERROR_STOP( 'AN_Hg2 tracers are undefined!', LOCATION ) + ENDIF + + ! Tagged Hg2 + IF ( ANY( AN_HgP == 0 ) ) THEN + CALL ERROR_STOP( 'AN_HgP tracer are undefined!', LOCATION ) + ENDIF + + !--------------------------------- + ! Error check # of tracers + !--------------------------------- + IF ( N_TRACERS < 21 ) THEN + CALL ERROR_STOP( 'Too few Hg tagged tracers!', + & 'DEFINE_TAGGED_Hg ("mercury_mod.f")' ) + ENDIF + + ! Return to calling program + END SUBROUTINE DEFINE_TAGGED_Hg + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_MERCURY( THIS_ANTHRO_Hg_YEAR ) +! +!****************************************************************************** +! Subroutine INIT_MERCURY allocates and zeroes all module arrays. +! (eck, cdh, sas, bmy, 12/2/04, 4/6/06) +! +! NOTES: +! (1 ) Removed reference to FEMIS array. Now also allocates and zeroes +! the T44 array. Added reference to CMN_DIAG. Now references +! N_TRACERS from "tracer_mod.f". (bmy, 2/24/05) +! (2 ) EHg0_an, EHg2_an, EHgP_an are now 2-D arrays. Now modified for +! updated ocean mercury module. (eck, cdh, sas, bmy, 4/6/06) +!****************************************************************************** +! + ! References to F90 modules + USE DRYDEP_MOD, ONLY : DEPNAME, NUMDEP + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE LOGICAL_MOD, ONLY : LSPLIT, LDRYD + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACERID_MOD, ONLY : N_Hg_CATS + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND44 + + ! Arguments + INTEGER, INTENT(IN) :: THIS_ANTHRO_Hg_YEAR + + ! Local variables + LOGICAL, SAVE :: IS_INIT = .FALSE. + INTEGER :: AS, N + CHARACTER(LEN=255) :: LOCATION + + !================================================================= + ! INIT_MERCURY begins here! + !================================================================= + + ! Return if we have already allocated arrays + IF ( IS_INIT ) RETURN + + ! Anthropogenic Hg emissions year + ANTHRO_Hg_YEAR = THIS_ANTHRO_Hg_YEAR + + ! Location string for ERROR_STOP + LOCATION = 'DEFINE_TAGGED_Hg ("mercury_mod.f")' + + !================================================================= + ! Allocate arrays + !================================================================= + ALLOCATE( COSZM( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COSZM' ) + COSZM = 0d0 + + ALLOCATE( EHg0_an( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHg0_an' ) + EHg0_an = 0d0 + + ALLOCATE( EHg2_an( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHg2_an' ) + EHg2_an = 0d0 + + ALLOCATE( EHgP_an( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHgP_an' ) + EHgP_an = 0d0 + + ALLOCATE( EHg0_oc( IIPAR, JJPAR, N_Hg_CATS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHg0_oc' ) + EHg0_oc = 0d0 + + ALLOCATE( EHg0_ln( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHg0_ln' ) + EHg0_ln = 0d0 + + ALLOCATE( EHg0_nt( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EHg0_nt' ) + EHg0_nt = 0d0 + + ALLOCATE( TCOSZ( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TCOSZ' ) + TCOSZ = 0d0 + + ALLOCATE( TTDAY( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TTDAY' ) + TTDAY = 0d0 + + ! Allocate ZERO_DVEL if drydep is turned off + IF ( .not. LDRYD ) THEN + ALLOCATE( ZERO_DVEL( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ZERO_DVEL' ) + ZERO_DVEL = 0d0 + ENDIF + + !================================================================= + ! Allocate & initialize arrays for tagged tracer indices + !================================================================= + IF ( LSPLIT ) THEN + + ! Tracer indices for tagged anthro regions + ALLOCATE( AN_Hg0( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AN_Hg0' ) + AN_Hg0 = 0d0 + + ALLOCATE( AN_Hg2( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AN_Hg2' ) + AN_Hg2 = 0d0 + + ALLOCATE( AN_HgP( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AN_HgP' ) + AN_HgP = 0d0 + + ! Define the tagged tracer indices + CALL DEFINE_TAGGED_Hg + + ENDIF + + !================================================================= + ! Locate the drydep species w/in the DEPSAV array (for ND44) + !================================================================= + + ! Initialize flags + DRYHg2 = 0d0 + DRYHgP = 0d0 + + ! If drydep is turned on ... + IF ( LDRYD ) THEN + + ! Loop over drydep species + DO N = 1, NUMDEP + + ! Locate by DEPNAME + SELECT CASE ( TRIM( DEPNAME(N) ) ) + CASE( 'Hg2' ) + DRYHg2 = N + CASE( 'HgP' ) + DRYHgP = N + CASE DEFAULT + ! nothing + END SELECT + ENDDO + + ! Temporary array for ND44 diagnostic + !---------------------------------------------------------------- + ! Prior to 4/6/06: + ! For now, comment this out so that MERCURY MENU can be placed + ! above the DIAGNOSTIC MENU in "input.geos" (bmy, 2/27/06) + !IF ( ND44 > 0 ) THEN + !---------------------------------------------------------------- + ALLOCATE( T44( IIPAR, JJPAR, LLTROP, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'T44' ) + T44 = 0e0 + !---------------------------------------------------------------- + ! Prior to 4/6/06: + ! For now, comment this out so that MERCURY MENU can be placed + ! above the DIAGNOSTIC MENU in "input.geos" (bmy, 2/27/06) + !ENDIF + !---------------------------------------------------------------- + ENDIF + + ! Reset IS_INIT, since we have already allocated arrays + IS_INIT = .TRUE. + + ! Return to calling program + END SUBROUTINE INIT_MERCURY + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_MERCURY +! +!****************************************************************************** +! Subroutine CLEANUP_MERCURY deallocates all module arrays. +! (eck, bmy, 12/6/04, 2/24/05) +! +! NOTES: +! (1 ) Now deallocate MLD, NPP, RAD (sas, bmy, 1/18/05) +! (2 ) Now deallocate T44 (bmy, 2/24/05) +!****************************************************************************** +! + !================================================================= + ! CLEANUP_MERCURY begins here! + !================================================================= + IF ( ALLOCATED( AN_Hg0 ) ) DEALLOCATE( AN_Hg0 ) + IF ( ALLOCATED( AN_Hg2 ) ) DEALLOCATE( AN_Hg2 ) + IF ( ALLOCATED( AN_HgP ) ) DEALLOCATE( AN_HgP ) + IF ( ALLOCATED( COSZM ) ) DEALLOCATE( COSZM ) + IF ( ALLOCATED( EHg0_an ) ) DEALLOCATE( EHg0_an ) + IF ( ALLOCATED( EHg2_an ) ) DEALLOCATE( EHg2_an ) + IF ( ALLOCATED( EHgP_an ) ) DEALLOCATE( EHgP_an ) + IF ( ALLOCATED( EHg0_oc ) ) DEALLOCATE( EHg0_oc ) + IF ( ALLOCATED( EHg0_ln ) ) DEALLOCATE( EHg0_ln ) + IF ( ALLOCATED( EHg0_nt ) ) DEALLOCATE( EHg0_nt ) + IF ( ALLOCATED( TCOSZ ) ) DEALLOCATE( TCOSZ ) + IF ( ALLOCATED( T44 ) ) DEALLOCATE( T44 ) + IF ( ALLOCATED( TTDAY ) ) DEALLOCATE( TTDAY ) + + ! Return to calling program + END SUBROUTINE CLEANUP_MERCURY + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE MERCURY_MOD diff --git a/code/mmran_16.f b/code/mmran_16.f new file mode 100644 index 0000000..6195117 --- /dev/null +++ b/code/mmran_16.f @@ -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 diff --git a/code/ndxx_setup.f b/code/ndxx_setup.f new file mode 100644 index 0000000..0f5ba68 --- /dev/null +++ b/code/ndxx_setup.f @@ -0,0 +1,1095 @@ +! $Id: ndxx_setup.f,v 1.4 2012/03/01 22:00:26 daven Exp $ + SUBROUTINE NDXX_SETUP +! +!****************************************************************************** +! NDXX_SETUP dynamically allocates memory for certain diagnostic arrays that +! are declared allocatable in "diag_mod.f". (bmy, bey, 6/16/98, 12/18/08) +! +! This allows us to reduce the amount of memory that needs to be declared +! globally. We only allocate memory for arrays if the corresponding +! diagnostic is turned on. +! +! NOTES: +! (1 ) This subroutine was split off from subroutine INPUT, for clarity +! (2 ) Added call to READ49 (bey, 2/99) +! (3 ) Eliminate GISS-Specific code, and AIJ, AIL diagnostics (bmy, 3/15/99) +! (4 ) Define tracer offset TRCOFFSET for "alternate chemistry" runs. +! (5 ) Multi-level diagnostics ND21, ND22, ND43, ND45, ND66, and ND68 have +! now been split off from the AIJ arrays (bmy, 3/29/99) +! (6 ) Added code for ND14 and ND15. Also eliminated obsolete code +! and updated comments (bmy, 11/10/99) +! (7 ) Added new ND41 and ND51 diagnostics (from amf). Freed up obsolete +! diagnostics ND34. ND37, and ND42 and updated comments. (bmy, 11/15/99) +! Also note: ND41 uses allocatable array AD41. (bmy, 12/6/99) +! (8 ) The following diagnostic arrays are now declared allocatable +! in "diag_mod.f": AD21, AD22, AD38, AD39, AD43, AD45, AD47, +! AD66, AD68, CONVFLUP, TURBFLUP, MASSFLEW, MASSFLNS, MASSFLUP, TCOBOX +! Allocate memory for these arrays only if their respective +! diagnostic is turned on. This will save memory. (bmy, 11/29/99) +! (9 ) Added ND55 diagnostic for tropopause heights (hyl, bmy, 12/1/99) +! (10) ND50 and ND20 now have dynamically allocatable arrays. (bmy, 1/5/00) +! (11) ND27 diagnostic now also turns on ND24, ND25, ND26 (bmy, 1/7/00) +! (12) ND31, ND33, ND35, ND37, ND67, and ND69 now use dynamically +! allocatable arrays declared in "diag_mod.f". (bmy, 2/17/00) +! (13) ND16, ND17, ND18 now use allocatable arrays. Also now use internal +! subroutine "alloc_err" to print error messages. (bmy, 3/14/00) +! (14) AIJ is now obsolete. All diagnostic variables now use allocatable +! arrays (cf. "diag_mod.f"). This is necessary in order to keep the +! size of the 2 x 2.5 executable within machine limits. (bmy, 3/28/00) +! (15) Removed obsolete code. Added TRCOFFSET of 3 for CO run +! with parameterized OH. Removed reference to KAIJPAR. (bmy, 4/19/00) +! (16) Add TRCOFFSET of 50 for DMS/SO2/SO4/MSA. Also added arrays for +! ND13 diagnostic for sulfur emissions (bmy, 6/6/00) +! (17) Add reference to F90 module "biomass_mod.f". Also added array +! AD32_bf for biofuel NOx. (bmy, 9/11/00) +! (18) Use NTRACE + 2 prodloss families for Tagged CO for the +! ND65 diagnostic (bmy, 10/6/00) +! (19) Adjust TRCOFFSET for 10-tracer Tagged CO run. Redimensioned +! AD45 and AD47 to save memory. Renamed STATUS to AS. (bmy, 10/18/00) +! (20) Removed obsolete code from 10/00. Save out ND65 only to LLTROP +! levels for full chemistry. Save out ND43 only to LLTROP levels +! for full chemistry. Dimension DIAGCHLORO up to LLTROP for +! full chemistry (or LLPAR for CO/OH chemistry). ND24, ND25, ND26 +! can now save out less than LLPAR levels. Eliminate dependence +! on PD35, PD37, PD39 parameters (bmy, 12/5/00) +! (21) Only save out a maximum of LCONVM layers for ND14 (bmy, 12/7/00) +! (22) Removed obsolete code from 7/00, 9/00, and 12/00 (bmy, 12/21/00) +! (23) Increase to NTRACE + 4 prodloss families for Tagged CO (bmy, 1/2/01) +! (24) Add TRCOFFSET of 54 for CH4 chemistry (NSRCX == 9) (bmy, 1/16/01) +! (25) Now allocate DIAGCHLORO (ND23 diagnostic) for CH4 runs (bmy, 1/18/01) +! (26) For ND43, save up to LLTROP for full chemistry, but save up to +! LLPAR for Tagged CO or CO-OH chemistry (bmy, 2/12/01) +! (27) Now allocate AD34 for biofuel burning emissions (bmy, 3/15/01) +! (28) Add L(CH3I) to ND65 diagnostic (nad, bmy, 3/20/01) +! (29) For full chemistry, we only need to save up to LLTROP levels +! for the ND22 J-value diagnostic (bmy, 4/2/01) +! (30) Remove reference to NBIOMAX from "biomass_mod.f" (bmy, 4/17/01) +! (31) Eliminate obsolete commented-out code (bmy, 4/20/01) +! (32) Now also allocate the AD12 diagnostic array (bdf, bmy, 6/15/01) +! (33) Now assign TRCOFFSET = 40 for multi-tracer Ox run (when NSRCX = 6 +! and LSPLIT = T). Reference CMN_SETUP for LSPLIT. Allocate AD44 +! with NTRACE instead of NUMDEP for single or multi-tracer Ox runs +! (NSRCX = 6). Now define NFAM as NTRACE*2 for single or multi-tracer +! Ox runs. Updated comments & made cosmetic changes. (bmy, 7/3/01) +! (34) Added AD11 diagnostic for acetone source. Also removed obsolete +! code from 7/01. (bmy, 9/4/01) +! (35) Turn off ND23 unless NSRCX = 3, 5, or 9. This prevents us from +! referencing an unallocated DIAGCHLORO array. Add error check for +! ND65, make sure that NFAM > 0. Also clean up the code that +! allocates AD65 and FAMPL arrays. (bmy, 1/14/02) +! (36) Now set TRCOFFSET = 64 for tagged C2H6 chemistry (bmy, 1/25/02) +! (37) Eliminate obsolete code from 1/02 and 2/02. Also allocate LTNO2, +! CTNO2, LTHO2, CTHO2 for the ND43 diagnostic. (bmy, 2/27/02) +! (38) Call SETUP_PLANEFLIGHT to initialize the ND40 plane flight diagnostic +! for non-SMVGEAR chemistry runs. (mje, bmy, 7/2/02) +! (39) Now set up variables & arrays for ND01 and ND02 diagnostics (i.e. +! Rn-Pb-Be emissions and decay). (bmy, 9/20/02) +! (40) Now allocate AD05 array. Now allocate routines ALLOC_ERR and +! ERROR_STOP from "error_mod.f". Now reference NEMANTHRO from F90 +! module "tracerid_mod.f" instead of "comtrid.h". Also added array +! AD13_SO2_bf for biofuel SO2. (bmy, 1/16/03) +! (41) Now also allocate AD13_NH3_na array for ND13 (rjp, bmy, 3/23/03) +! (42) Added ND03 diagnostic for Kr85 prod/loss. Also removed special case +! TRCOFFSET for single-tracer Ox. (jsw, bmy, 8/20/03) +! (43) Now use GET_WETDEP_NMAX to get max # of soluble tracers for ND37, +! ND18, and ND19. Also set NFAM=NTRACE+5 for Tagged CO simulation. +! (3/18/04) +! (44) Now initialize AD06 and AD07* arrays (rjp, tdf, bmy, 4/5/04) +! (45) Now initialize AD08 array. Reset TRCOFFSET for tagged CO from +! 84 to 80. Also activate ND52 diagnostic for ICARTT. +! (rjp, bec, stu, cas, bmy, 4/20/04) +! (46) Now allocate AD13_SO2_sh array for ND13 (bec, bmy, 5/20/04) +! (47) Now allocate AD07_HC array for ND07 (rjp, bmy, 7/13/04) +! (48) Now references "tracer_mod.f" and "logical_mod.f" instead of "CMN" +! and "CMN_SETUP". Now references INIT_DIAG_OH from "diag_oh_mod.f" +! Adjust TRCOFFSET for various aerosol simulations. (bmy, 7/20/04) +! (49) Make sure ND21 only goes from 1-LLTROP (bmy, 9/28/04) +! (50) Now allocate AD13_SO4_bf array (bmy, 11/17/04) +! (51) Now allocate extra arrays for ND03 mercury diag. Also set up for +! mercury tracers in ND44 diagnostic. (bmy, 12/14/04) +! (52) Added separate ND21 array for cryst sulfur tracers. Now reinstated +! AD03 array for mercury simulation. Now move ND03 diagnostics into +! a separate module. Remove TCOBOX reference, it's obsolete. +! (cas, sas, bmy, 1/21/05) +! (53) Now remove references to AD41 & AFTTOT. Now call SETUP_PLANEFLIGHT +! for non-full-chemistry runs in main.f -- this will allow it to look +! for flight files for each day (bmy, 3/24/05) +! (54) Now use PD05=10 to dimension AD05 array (bmy, 4/13/05) +! (55) Now also allocates AD09 and AD09_em (bmy, 6/27/05) +! (56) Now allocates AD30 (bmy, 8/18/05) +! (57) Removed duplicate variable declarations (bmy, 2/6/06) +! (58) Now remove NBIOTRCE; it's obsolete. Replace w/ NBIOMAX (bmy, 4/5/06) +! (59) Now remove TRCOFFSET; it's obsolete (bmy, 5/16/06) +! (60) Added the ND54 for time spend in the troposphere (phs, 10/17/06) +! (61) Now allocate ND43 and ND45 counter arrays as 3-D (phs, 1/19/07) +! (62) For ND20 diagnostic, reset ND65 diagnostic with LLTROP_FIX instead of +! LLTROP. Added ND10 diagnostic setup. Added modifications for H2-HD +! simulation. (phs, bmy, 9/18/07) +! (63) Now save true pressure edges for ND31 diagnostic (bmy, 11/16/07) +! (64) Now stop the run if ND20 is defined but ND65 isn't (bmy, 12/4/07) +! (65) Allocate CTO3_24h (phs, 11/18/08) +! (66) We don't need to set LD65=1 here anymore, we now call NDXX_SETUP! +! after DIAG_PL_MOD. (phs, bmy, 12/18/08) +! (67) Added ND52 for GAMMA HO2 diagnostic. (ccc, jaegle, 2/26/09) +! (68) Add AD07_SOAGM (tmf, 1/7/09) +! (67) Added ND52 for GAMMA HO2 diagnostic. (ccc, jaegle, 2/26/09) +! (68) Add AD07_SOAGM (tmf, 1/7/09) +! (69) Now always allocate Mass Flux arrays (phs, 4/15/09) +! (70) Added ND59 for converting units to ug/m3. (lz, 10/11/10) +! (71) Add AD19, AD58, AD60 (kjw, 8/18/09, adj32_023) +!****************************************************************************** +! + ! References to F90 modules + USE BIOMASS_MOD, ONLY : NBIOMAX + USE BIOFUEL_MOD, ONLY : NBFTRACE + USE DIAG49_MOD, ONLY : DO_SAVE_DIAG49 + 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 : EMISS_ANTHR + 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, AD54 + USE DIAG_MOD, ONLY : AD19, AD58, AD60 + USE DIAG_MOD, ONLY : AD55, AD66, AD67 + USE DIAG_MOD, ONLY : AD68, AD69, CTO3 + USE DIAG_MOD, ONLY : AD10, AD10em, CTO3_24h + USE DIAG_OH_MOD, ONLY : INIT_DIAG_OH + USE DRYDEP_MOD, ONLY : NUMDEP + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE LOGICAL_MOD, ONLY : LDUST, LCARB, LSSALT, LCRYST, LDRYD + USE PLANEFLIGHT_MOD, ONLY : SETUP_PLANEFLIGHT + USE TRACER_MOD, ONLY : ITS_A_CH3I_SIM + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACER_MOD, ONLY : ITS_A_MERCURY_SIM + USE TRACER_MOD, ONLY : ITS_A_TAGOX_SIM + USE TRACER_MOD, ONLY : ITS_A_H2HD_SIM + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACERID_MOD, ONLY : NEMANTHRO + USE WETSCAV_MOD, ONLY : GET_WETDEP_NMAX + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! Diagnostic switches & arrays + + ! Local variables + INTEGER :: NMAX, AS, NEMISS, LMAX + + !================================================================= + ! NDXX_SETUP begins here! + ! + ! Initialize some multi-level variables + !================================================================= + LD01 = 1 + LD02 = 1 + LD05 = 1 + LD09 = 1 + LD10 = 1 + LD07 = 1 + LD12 = 1 + LD13 = 1 + LD14 = 1 + LD15 = 1 + LD16 = 1 + LD17 = 1 + LD18 = 1 + LD19 = 1 + LD21 = 1 + LD22 = 1 + LD24 = 1 + LD25 = 1 + LD26 = 1 + LD31 = 1 + LD37 = 1 + LD38 = 1 + LD39 = 1 + LD43 = 1 + LD45 = 1 + LD47 = 1 + LD52 = 1 + LD54 = 1 + LD64 = 1 + !----------------------------------------------------------------- + ! Prior to 12/18/08: + ! We don't need to set LD65=1 here anymore, we now call + ! NDXX_SETUP after DIAG_PL_MOD. (phs, bmy, 12/18/08) + !LD65 = 1 + !----------------------------------------------------------------- + LD66 = 1 + LD68 = 1 + + !================================================================= + ! ND01: Rn, Pb, Be emissions + !================================================================= + IF ( ND01 > 0 ) THEN + LD01 = MIN( ND01, LLPAR ) + + ALLOCATE( AD01( IIPAR, JJPAR, LD01, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD01' ) + ENDIF + + !================================================================= + ! ND02: Rn, Pb, Be decay + !================================================================= + IF ( ND02 > 0 ) THEN + LD02 = MIN( ND02, LLPAR ) + + ALLOCATE( AD02( IIPAR, JJPAR, LD02, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD02' ) + ENDIF + + !================================================================= + ! ND04: CO2 source - see ?? + ! + ! ND05: Sulfate Prod/loss + !================================================================= + IF ( ND05 > 0 ) THEN + LD05 = MIN( ND05, LLTROP ) + + ALLOCATE( AD05( IIPAR, JJPAR, LD05, PD05 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD05' ) + ENDIF + + !================================================================ + ! ND06: Dust emissions + !================================================================ + IF ( ND06 > 0 .and. LDUST ) THEN + ALLOCATE( AD06( IIPAR, JJPAR, NDSTBIN ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD06' ) + ENDIF + + !================================================================= + ! ND07: Carbonaceous aerosols emissions and chemical conversion + !================================================================= + IF ( ND07 > 0 .and. LCARB ) THEN + LD07 = MIN( ND07, LLPAR ) + + ALLOCATE( AD07( IIPAR, JJPAR, PD07 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD07' ) + + ALLOCATE( AD07_BC( IIPAR, JJPAR, LD07 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD07_BC' ) + + ALLOCATE( AD07_OC( IIPAR, JJPAR, LD07 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD07_OC' ) + + ALLOCATE( AD07_HC( IIPAR, JJPAR, LD07, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD07_HC' ) + + ALLOCATE( AD07_SOAGM( IIPAR, JJPAR, LD07, 4 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD07_SOAGM' ) + + ENDIF + + !================================================================ + ! ND08: Dust emissions + !================================================================ + IF ( ND08 > 0 .and. LSSALT ) THEN + ALLOCATE( AD08( IIPAR, JJPAR, PD08 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD08' ) + ENDIF + + !================================================================= + ! ND09: HCN / CH3CN source & sink + !================================================================= + IF ( ND09 > 0 ) THEN + LD09 = MIN( ND09, LLPAR ) + + ALLOCATE( AD09( IIPAR, JJPAR, LD09, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD09' ) + + ALLOCATE( AD09_em( IIPAR, JJPAR, PD09 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD09_em' ) + ENDIF + + !================================================================= + ! ND10: H2/HD prod, loss, sources + !================================================================= + IF ( ND10 > 0 ) THEN + + ! number of emissions tracers + NEMISS = 5 + + ! Accumulating diagnostic array + ALLOCATE( AD10( IIPAR, JJPAR, LD10, (PD10-NEMISS) ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD10' ) + + ! Accumulating diagnostic array + ALLOCATE( AD10em( IIPAR, JJPAR, NEMISS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD10em' ) + + ENDIF + + !================================================================= + ! ND11: Acetone source diagnostics [atoms C/cm2/s] + ! --> uses AD11 array (allocatable) + !================================================================= + IF ( ND11 > 0 ) THEN + ALLOCATE( AD11( IIPAR, JJPAR, PD11 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD11' ) + ENDIF + + !================================================================= + ! ND12: Distribution of emissions in boundary layer [fraction] + ! --> uses AD12 array (allocatable) + !================================================================= + LD12 = MIN( ND12, LLTROP ) + + IF ( ND12 > 0 ) THEN + ALLOCATE( AD12( IIPAR, JJPAR, LD12 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PL24H' ) + ENDIF + + !================================================================= + ! ND13: Sulfur emissions from DMS, SO2, and SO4 + !================================================================= + IF ( ND13 > 0 ) THEN + LD13 = MIN( ND13, LLPAR ) + + ALLOCATE( AD13_DMS( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_DMS' ) + + ALLOCATE( AD13_SO2_ac( IIPAR, JJPAR, LD13 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_SO2_ac' ) + + ALLOCATE( AD13_SO2_an( IIPAR, JJPAR, NOXLEVELS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_SO2_an' ) + + ALLOCATE( AD13_SO2_bb( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_SO2_bb' ) + + ALLOCATE( AD13_SO2_bf( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_SO2_bf' ) + + ALLOCATE( AD13_SO2_ev( IIPAR, JJPAR, LD13 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_SO2_ev' ) + + ALLOCATE( AD13_SO2_nv( IIPAR, JJPAR, LD13 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_SO2_nv' ) + + ALLOCATE( AD13_SO4_an( IIPAR, JJPAR, 2 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_SO4_an' ) + + ALLOCATE( AD13_SO4_bf( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_SO4_bf' ) + + ALLOCATE( AD13_SO2_sh( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_SO4_sh' ) + + ALLOCATE( AD13_NH3_an( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_NH3_an' ) + + ALLOCATE( AD13_NH3_na( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_NH3_na' ) + + ALLOCATE( AD13_NH3_bb( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_NH3_bb' ) + + ALLOCATE( AD13_NH3_bf( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD13_NH3_bf' ) + ENDIF + + !================================================================= + ! ND14: Upward flux of from wet conv [kg/s] + ! --> uses CONVFLUP array (allocatable) + !================================================================= + IF ( ND14 > 0 ) THEN + LD14 = MIN( ND14, LLCONVM ) + NMAX = MIN( N_TRACERS, NNPAR ) + + ALLOCATE( CONVFLUP( IIPAR, JJPAR, LLCONVM, NMAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CONVFLUP' ) + ENDIF + + !================================================================= + ! ND15: Mass change from BL-mixing [kg/s] + ! --> uses TURBFLUP array (allocatable) + !================================================================= + IF ( ND15 > 0 ) THEN + LD15 = MIN( ND15, LLPAR ) + NMAX = MIN( N_TRACERS, NNPAR ) + + ALLOCATE( TURBFLUP( IIPAR, JJPAR, LLPAR, NMAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TURBFLUP' ) + ENDIF + + !================================================================= + ! ND16: Fraction of grid box experiencing large-scale and + ! convective precipitation --> uses AD16 array (allocatable) + !================================================================= + IF ( ND16 > 0 ) THEN + LD16 = MIN( ND16, LLPAR ) + + ! Store both LS and convective fractions + ALLOCATE( AD16( IIPAR, JJPAR, LD16, 2 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD16' ) + + ! Counter array for AD16 + ALLOCATE( CT16( IIPAR, JJPAR, LD16, 2 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CT16' ) + ENDIF + + !================================================================= + ! ND17: Fraction of tracer lost to rainout (in both large-scale + ! and conv precipitation) --> uses AD17 array (allocatable) + !================================================================= + IF ( ND17 > 0 ) THEN + LD17 = MIN( ND17, LLPAR ) + + ! Get max # of soluble tracers for this simulation + NMAX = GET_WETDEP_NMAX() + + ! Store both LS and convective rainout fractions + ALLOCATE( AD17( IIPAR, JJPAR, LD17, NMAX, 2 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD17' ) + + ! Counter array for AD17 + ALLOCATE( CT17( IIPAR, JJPAR, LD17, 2 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CT17' ) + ENDIF + + !================================================================= + ! ND18: Fraction of tracer lost to washout (in both large-scale + ! and convective precipitation) --> uses AD18 array (alloc.) + !================================================================= + IF ( ND18 > 0 ) THEN + LD18 = MIN( ND18, LLPAR ) + + ! Get max # of soluble tracers for this simulation + NMAX = GET_WETDEP_NMAX() + + ! Store both LS and convective rainout fractions + ALLOCATE( AD18( IIPAR, JJPAR, LD18, NMAX, 2 ), STAT=AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD18' ) + + ! Counter array for AD17 + ALLOCATE( CT18( IIPAR, JJPAR, LD18, 2 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CT18' ) + ENDIF + + !================================================================= + ! ND19: CH4 loss by OH + !================================================================= + IF ( ND19 > 0 ) THEN + LD19 = MIN( ND19, LLPAR ) + + ALLOCATE( AD19( IIPAR, JJPAR, LD19 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD19' ) + + ENDIF + + !================================================================= + ! ND20: Save O3 P-L losses to disk for single-tracer O3 run + ! in the PL24H array. Also turn on ND65, since the P-L + ! rates are computed by ND65. + !================================================================= + IF ( ND20 > 0 ) THEN + IF ( ND65 == 0 ) THEN + CALL ERROR_STOP( 'ND65 must be turned on for ND20 output!', + & 'ndxx_setup.f' ) + ENDIF + ENDIF + + !================================================================= + ! ND21: Optical depths and cloud fractions [unitless] + ! --> uses AD21 array (allocatable) + !================================================================= + IF ( ND21 > 0 ) THEN + LD21 = MIN( ND21, LLTROP ) + + ! For regular + ALLOCATE( AD21( IIPAR, JJPAR, LD21, PD21 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD21' ) + + ! Separate for crystalline sulfate tracers (bmy, 1/5/05) + IF ( LCRYST ) THEN + ALLOCATE( AD21_cr( IIPAR, JJPAR, 6 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD21' ) + ENDIF + + ENDIF + + !================================================================= + ! ND22: J-value diagnostics [s^-1] + ! --> uses AD22 array (allocatable) + !================================================================= + IF ( ND22 > 0 ) THEN + + ! For full chemistry, we only consider boxes below the + ! tropopause. Cap LD22 at LLTROP (bmy, 4/2/01) + IF ( ITS_A_FULLCHEM_SIM() ) THEN + LD22 = MIN( ND22, LLTROP ) + ELSE + LD22 = MIN( ND22, LLPAR ) + ENDIF + + ! Accumulating diagnostic array + ALLOCATE( AD22( IIPAR, JJPAR, LD22, PD22 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD22' ) + + ! Locations where LT is between HR1_JV and HR2_JV + ALLOCATE( LTJV( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LTJV' ) + + ! Number of times where LT is between HR1_JV and HR2_JV + ALLOCATE( CTJV( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CTJV' ) + ENDIF + + !================================================================= + ! ND27: Flux of Ox across the annual mean tropopause [kg/s] + ! ND27 will also turn on ND24, ND25, ND26 diagnostics + !================================================================= + IF ( ND27 > 0 ) THEN + ND24 = LLPAR + ND25 = LLPAR + ND26 = LLPAR + ENDIF + +! Change allocations for ND24/25/26 diagnostics to save memory space +! if these diagnostics are not used.(ccc, 12/3/09) +! +! !================================================================= +! ! ND24: Eastward mass flux from transport [kg/s] +! ! --> uses MASSFLEW array (allocatable) +! !================================================================= +! IF ( ND24 > 0 ) LD24 = MIN( ND24, LLPAR ) +! NMAX = MIN( N_TRACERS, NNPAR ) +! +! ALLOCATE( MASSFLEW( IIPAR, JJPAR, LLPAR, NMAX ), STAT=AS) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASSFLEW' ) +! !================================================================= +! ! ND25: Northward mass flux from transport [kg/s] +! ! --> uses MASSFLNS array (allocatable) +! !================================================================= +! IF ( ND25 > 0 ) LD25 = MIN( ND25, LLPAR ) +! NMAX = MIN( N_TRACERS, NNPAR ) +! +! ALLOCATE( MASSFLNS( IIPAR, JJPAR, LLPAR, NMAX ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASSFLNS' ) +! !================================================================= +! ! ND26: Vertical mass flux from transport [kg/s] +! ! --> uses MASSFLUP array (allocatable) +! !================================================================= +! IF ( ND26 > 0 ) LD26 = MIN( ND26, LLPAR ) +! NMAX = MIN( N_TRACERS, NNPAR ) +! +! ALLOCATE( MASSFLUP( IIPAR, JJPAR, LLPAR, NMAX ), STAT=AS ) +! IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASSFLUP' ) + + !================================================================= + ! ND24: Eastward mass flux from transport [kg/s] + ! --> uses MASSFLEW array (allocatable) + !================================================================= + IF ( ND24 > 0 ) THEN + LD24 = MIN( ND24, LLPAR ) + NMAX = MIN( N_TRACERS, NNPAR ) + + ALLOCATE( MASSFLEW( IIPAR, JJPAR, LLPAR, NMAX ), STAT=AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASSFLEW' ) + ELSE + ALLOCATE( MASSFLEW( 1, 1, 1, 1 ), STAT=AS) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASSFLEW' ) + ENDIF + !================================================================= + ! ND25: Northward mass flux from transport [kg/s] + ! --> uses MASSFLNS array (allocatable) + !================================================================= + IF ( ND25 > 0 ) THEN + LD25 = MIN( ND25, LLPAR ) + NMAX = MIN( N_TRACERS, NNPAR ) + + ALLOCATE( MASSFLNS( IIPAR, JJPAR, LLPAR, NMAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASSFLNS' ) + ELSE + ALLOCATE( MASSFLNS( 1, 1, 1, 1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASSFLNS' ) + ENDIF + !================================================================= + ! ND26: Vertical mass flux from transport [kg/s] + ! --> uses MASSFLUP array (allocatable) + !================================================================= + IF ( ND26 > 0 ) THEN + LD26 = MIN( ND26, LLPAR ) + NMAX = MIN( N_TRACERS, NNPAR ) + + ALLOCATE( MASSFLUP( IIPAR, JJPAR, LLPAR, NMAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASSFLUP' ) + ELSE + ALLOCATE( MASSFLUP( 1, 1, 1, 1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASSFLUP' ) + ENDIF + + !================================================================= + ! ND28: Biomass burning diagnostic [molec/cm2/s] + ! (NO, CO, ALK4, ACET, MEK, ALD2, PRPE, C3H8, CH2O, C2H6) + ! --> uses AD28 array (allocatable) + !================================================================= + IF ( ND28 > 0 ) THEN + ALLOCATE( AD28( IIPAR, JJPAR, NBIOMAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD28' ) + ENDIF + + !================================================================= + ! ND29: CO-SRCE diagnostic [molec/cm2/s] + ! (anthro, biomass, biofuel, from monot., from methanol) + ! --> uses AD29 array (allocatable) + !================================================================= + IF ( ND29 > 0 ) THEN + ALLOCATE( AD29( IIPAR, JJPAR, PD29 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD29' ) + ENDIF + + !================================================================= + ! ND30: Land/water/ice flags + !================================================================= + IF ( ND30 > 0 ) THEN + ALLOCATE( AD30( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD30' ) + ENDIF + + !================================================================= + ! ND31: 3-D pressure edges [hPa] --> Uses AD31 array (allocatable) + !================================================================= + IF ( ND31 > 0 ) THEN + LD31 = MIN( ND31, LLPAR+1 ) + + ALLOCATE( AD31( IIPAR, JJPAR, LD31 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD31' ) + ENDIF + + !================================================================= + ! ND32: Sources of NOx [molec/cm2/s] + ! (aircraft, biomass, biofuel, lightning, + ! stratosphere, soils, fertilizer, anthropogenic) + ! --> Uses AD32_xx arrays (allocatable) + !================================================================= + IF ( ND32 > 0 ) THEN + + ! For aircraft NOx + ALLOCATE( AD32_ac( IIPAR, JJPAR, LLTROP ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD32_ac' ) + + ! For anthropogenic NOx + ALLOCATE( AD32_an( IIPAR, JJPAR, NOXEXTENT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD32_an' ) + + ! For biomass burning NOx + ALLOCATE( AD32_bb( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD32_bb' ) + + ! For biofuel NOx + ALLOCATE( AD32_bf( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD32_bf' ) + + ! For fertilizer NOx + ALLOCATE( AD32_fe( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD32_fe' ) + + ! For Lightning NOx + ALLOCATE( AD32_li( IIPAR, JJPAR, LLCONVM ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD32_li' ) + + ! For soil NOx + ALLOCATE( AD32_so( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD32_so' ) + + ! For stratospheric NOx + ALLOCATE( AD32_ub( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD32_st' ) + + ! For ship NOx + ALLOCATE( AD32_SHIP( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD32_SHIP' ) + + ! For ship NOx counter + ALLOCATE( AD32_SHIP_COUNT, STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD32_SHIP_COUNT' ) + ENDIF + + !================================================================= + ! ND33: Column sum of tracer [kg] + ! --> uses AD33 array (allocatable)! + !================================================================= + IF ( ND33 > 0 ) THEN + ALLOCATE( AD33( IIPAR, JJPAR, PD33 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD33' ) + ENDIF + + !================================================================= + ! ND34: Biofuel burning emissions [molec/cm2/s] + ! (NO, CO, ALK4, ACET, MEK, ALD2, PRPE, C3H8, CH2O, C2H6) + ! --> uses AD34 array (allocatable) + !================================================================= + IF ( ND34 > 0 ) THEN + ALLOCATE( AD34( IIPAR, JJPAR, NBFTRACE ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD34' ) + ENDIF + + !================================================================= + ! ND35: Tracer at 500 mb [v/v] (this is ~ level 9 for GEOS-CHEM) + ! --> uses AD35 array (allocatable) + !================================================================= + IF ( ND35 > 0 ) THEN + ALLOCATE( AD35( IIPAR, JJPAR, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD35' ) + ENDIF + + !================================================================= + ! ND36: Anthropogenic Emisisons [molec/cm2/s] + ! (NOx, CO, ALK4, ACET, MEK, ALD2, PRPE, C3H8, C2H6) + ! --> uses AD36 array (allocatable) + ! + ! NOTE: For a CH3I run, use ND36 for CH3I emission diagnostics.... + !================================================================= + IF ( ITS_A_CH3I_SIM() ) NEMANTHRO = 8 ! for CH3I + + IF ( ND36 > 0 ) THEN + ALLOCATE( AD36( IIPAR, JJPAR, NEMANTHRO ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD36' ) + + ALLOCATE( AD36_SHIP( IIPAR, JJPAR, NEMANTHRO ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD36_SHIP' ) + + ALLOCATE( AD36_SHIP_COUNT, STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD36_SHIP_COUNT' ) + ENDIF + + IF ( DO_SAVE_DIAG49 ) THEN + ALLOCATE( EMISS_ANTHR( IIPAR, JJPAR, NEMANTHRO ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'EMISS_ANTHR' ) + ENDIF + + + !================================================================= + ! ND37: Fraction of tracer scavenged in cloud updrafts + ! --> Uses AD37 array (allocatable) + !================================================================= + IF ( ND37 > 0 ) THEN + LD37 = MIN( ND37, LLPAR ) + + ! Get max # of soluble tracers for this simulation + NMAX = GET_WETDEP_NMAX() + + ! Allocate array accordingly + IF ( NMAX > 0 ) THEN + ALLOCATE( AD37( IIPAR, JJPAR, LD37, NMAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD37' ) + ENDIF + ENDIF + + !================================================================= + ! ND38: Rainout of tracer (nfcldmx.f) + ! --> uses AD38 array (allocatable) + !================================================================= + IF ( ND38 > 0 ) THEN + LD38 = MIN( ND38, LLPAR ) + + ! Get max # of soluble tracers for this simulation + NMAX = GET_WETDEP_NMAX() + + ! Allocate AD38 array accordingly + IF ( NMAX > 0 ) THEN + ALLOCATE( AD38( IIPAR, JJPAR, LD38, NMAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD38' ) + ENDIF + ENDIF + + !================================================================= + ! ND39: Rainout of tracer (wetdep.f) + ! --> uses AD39 array (allocatable) + !================================================================= + IF ( ND39 > 0 ) THEN + LD39 = MIN( ND39, LLPAR ) + + ! Get max # of soluble tracers for this simulation + NMAX = GET_WETDEP_NMAX() + + ! Allocate AD39 array accordingly + IF ( NMAX > 0 ) THEN + ALLOCATE( AD39( IIPAR, JJPAR, LD39, NMAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD39' ) + ENDIF + ENDIF + + !================================================================= + ! ND42: SOA concentration + ! + ! ND43: Chemical diagnostics: OH [molec/cm3/s] and NO [v/v] + ! --> uses AD43 array (allocatable) + !================================================================= + IF ( ND43 > 0 ) THEN + + ! For full chemistry, only save OH up to the tropopause. + ! For tagged CO or CO-OH, save OH everywhere (bmy, 2/12/01) + IF ( ITS_A_FULLCHEM_SIM() ) THEN + LD43 = MIN( ND43, LLTROP ) + ELSE + LD43 = MIN( ND43, LLPAR ) + ENDIF + + ! Accumulating diagnostic array + ALLOCATE( AD43( IIPAR, JJPAR, LD43, PD43 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD43' ) + + ! Locations where LT is between HR1_NO and HR2_NO + ALLOCATE( LTNO( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LTNO' ) + + ! Number of times LT was between HR1_NO and HR2_NO + ALLOCATE( CTNO( IIPAR, JJPAR, LD43 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CTNO' ) + + ! Locations where LT is between HR1_OH and HR2_OH + ALLOCATE( LTOH( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LTOH' ) + + ! Locations where LT is between HR1_OH and HR2_OH + ALLOCATE( CTOH( IIPAR, JJPAR, LD43 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CTOH' ) + + ! Locations where LT is between HR1_OH and HR2_OH + ALLOCATE( LTHO2( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LTHO2' ) + + ! Locations where LT is between HR1_OH and HR2_OH + ALLOCATE( CTHO2( IIPAR, JJPAR, LD43 ), STAT=AS ) + + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CTHO2' ) + + ! Locations where LT is between HR1_OH and HR2_OH + ALLOCATE( LTNO2( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LTHO2' ) + + ! Locations where LT is between HR1_OH and HR2_OH + ALLOCATE( CTNO2( IIPAR, JJPAR, LD43 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CTHO2' ) + + ! Locations where LT is between HR1_OH and HR2_OH + ALLOCATE( LTNO3( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LTHO2' ) + + ! Locations where LT is between HR1_OH and HR2_OH + ALLOCATE( CTNO3( IIPAR, JJPAR, LD43 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CTHO2' ) + ENDIF + + !================================================================= + ! ND44: Drydep fluxes [s-1] and drydep velocities [cm/s] + ! --> uses AD44 arrays (allocatable) + !================================================================= + + ! Turn off ND44 if drydep is turned off + IF ( .not. LDRYD ) ND44 = 0 + + ! Allocate arrays for ND44 + IF ( ND44 > 0 ) THEN + + ! Get number of tracers for ND44 + IF ( ITS_A_TAGOX_SIM() .or. ITS_A_MERCURY_SIM() ) THEN + NMAX = N_TRACERS + ELSE + NMAX = NUMDEP + ENDIF + + ! Allocate AD44 array + ALLOCATE( AD44( IIPAR, JJPAR, NMAX, 2 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD44' ) + ENDIF + + !================================================================= + ! ND45: Tracer concentrations [v/v] between HR1_OTH and HR2_OTH + ! --> uses AD45 array (allocatable) + !================================================================= + IF ( ND45 > 0 ) THEN + LD45 = MIN( ND45, LLPAR ) + NMAX = MIN( N_TRACERS+1, NNPAR+1 ) + + ! Accumulating diagnostic array + ! Resize to NMAX to save memory (bmy, 10/18/00) + ALLOCATE( AD45( IIPAR, JJPAR, LD45, NMAX ), STAT=AS ) + IF ( AS > 0 ) CALL ALLOC_ERR( 'AD45' ) + + ! Locations where LT is between HR1_OTH and HR2_OTH + ALLOCATE( LTOTH( IIPAR, JJPAR ), STAT=AS ) + IF ( AS > 0 ) CALL ALLOC_ERR( 'LTOTH' ) + + ! Number of times LT is between HR1_OTH and HR2_OTH + ALLOCATE( CTOTH( IIPAR, JJPAR ), STAT=AS ) + IF ( AS > 0 ) CALL ALLOC_ERR( 'CTOTH' ) + + ! Number of times LT is between HR1_OTH and HR2_OTH + ! and box is in the troposphere + ALLOCATE( CTO3( IIPAR, JJPAR, LD45 ), STAT=AS ) + IF ( AS > 0 ) CALL ALLOC_ERR( 'CTO3' ) + ENDIF + + !================================================================= + ! ND46: Biogenic emissions [molec/cm2/s] + ! (ISOP, PRPE, ACET, and MONOTERPENES) + ! --> uses AD46 array (allocatable) + !================================================================= + IF ( ND46 > 0 ) THEN + ALLOCATE( AD46( IIPAR, JJPAR, PD46 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD46' ) + ENDIF + + !================================================================= + ! ND47: 24-h averaged tracer concentration [v/v] + ! --> uses AD47 array (allocatable) + ! + ! NOTE: ND47 is always a 24-h average field, while ND45 + ! can be averaged over any arbitrary time period. + !================================================================= + IF ( ND47 > 0 ) THEN + LD47 = MIN( ND47, LLPAR ) + NMAX = MIN( N_TRACERS+1, NNPAR+1 ) + + ! Resize to NMAX to save memory (bmy, 10/18/00) + ALLOCATE( AD47( IIPAR, JJPAR, LD47, NMAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD47' ) + ENDIF + + + !================================================================= + ! ND47(O3) or ND65 : 24-h averaged tropospheric diagnostic + !================================================================= + IF ( ND47 > 0 .OR. ND65 > 0 ) THEN + + ! NOTE: we assume that INIT_DIAG_PL has already been called + LMAX = MAX( LD47, LD65 ) + + ! Number of times in the troposphere + ALLOCATE( CTO3_24h( IIPAR, JJPAR, LMAX ), STAT=AS ) + IF ( AS > 0 ) CALL ALLOC_ERR( 'CTO3_24h' ) + + ENDIF + + !================================================================= + ! ND52: gamma HO2 + !================================================================= + IF ( ND52 > 0 ) THEN + LD52 = MIN( ND52, LLPAR) + + ALLOCATE( AD52( IIPAR, JJPAR, LD52 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD52' ) + ENDIF + + !================================================================= + ! ND53: Free diagnostics + ! + ! ND54 - Time spend in the troposphere + ! --> uses AD54 array (allocatable) + !================================================================= + IF ( ND54 > 0 ) THEN + LD54 = MIN( ND54, LLTROP) + + ALLOCATE( AD54( IIPAR, JJPAR, LD54 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD54' ) + ENDIF + + !================================================================= + ! ND55: Tropopause diagnostics [level, height, and pressure] + ! --> uses AD55 array (allocatable) + !================================================================= + IF ( ND55 > 0 ) THEN + ALLOCATE( AD55( IIPAR, JJPAR, PD55 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD55' ) + ENDIF + + !================================================================= + ! ND56 - ND64: Free diagnostics + !================================================================= + + !================================================================= + ! ND58: CH4 emissions + !================================================================= + IF ( ND58 > 0 ) THEN + + ALLOCATE( AD58( IIPAR, JJPAR, PD58), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD58' ) + + ENDIF + + !================================================================= + ! ND59: NH3 concentration, units convert + !================================================================= + + !================================================================= + ! ND60: WETLAND FRACTION + !================================================================= + IF ( ND60 > 0 ) THEN + + ALLOCATE( AD60( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD60' ) + + ENDIF + + !================================================================= + ! ND66: DAO 3-D fields (UWND, VWND, SPHU, TMPU, RH) + ! --> uses AD66 array (allocatable) + !================================================================= + IF ( ND66 > 0 ) THEN + LD66 = MIN( ND66, LLPAR ) + + ALLOCATE( AD66( IIPAR, JJPAR, LD66, PD66 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD66' ) + ENDIF + + !================================================================= + ! ND67: DAO A-3 and surface fields + ! --> Uses AD67 array (allocatable) + !================================================================= + IF ( ND67 > 0 ) THEN + ALLOCATE( AD67( IIPAR, JJPAR, PD67 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD67' ) + ENDIF + + !================================================================= + ! ND68: Air mass diagnostics (BXHEIGHT, AD, AVGW, N_AIR) + ! --> uses AD68 array (allocatable) + !================================================================= + IF ( ND68 > 0 ) THEN + LD68 = MIN( ND68, LLPAR ) + + ALLOCATE( AD68( IIPAR, JJPAR, LD68, PD68 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD68' ) + ENDIF + + !================================================================= + ! ND69: DXYP -- grid box surface areas [m^2] + ! --> uses AD69 array (allocatable) + !================================================================= + IF ( ND69 > 0 ) THEN + ALLOCATE( AD69( IIPAR, JJPAR, PD69 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AD69' ) + ENDIF + + ! Return to calling program + END SUBROUTINE NDXX_SETUP diff --git a/code/nei2005_anthro_mod.f b/code/nei2005_anthro_mod.f new file mode 100644 index 0000000..a9da76d --- /dev/null +++ b/code/nei2005_anthro_mod.f @@ -0,0 +1,2250 @@ +!$Id: nei2005_anthro_mod.f,v 1.2 2012/03/01 22:00:26 daven Exp $ +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: nei2005_anthro_mod +! +! !DESCRIPTION: Module NEI2005\_ANTHRO\_MOD contains variables and routines to +! read the NEI2005 anthropogenic emissions. +!\\ +!\\ +! !INTERFACE: +! + MODULE NEI2005_ANTHRO_MOD +! +! !USES: +! + IMPLICIT NONE + PRIVATE +! +! !PUBLIC DATA MEMBERS: +! + REAL*8, PUBLIC, ALLOCATABLE :: USA_MASK(:,:) +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: CLEANUP_NEI2005_ANTHRO + PUBLIC :: EMISS_NEI2005_ANTHRO + PUBLIC :: EMISS_NEI2005_ANTHRO_05x0666 + PUBLIC :: GET_NEI2005_ANTHRO + !-------------------------------------- + ! Leave for future use (bmy, 12/3/09) + !PUBLIC :: GET_NEI2005_MASK + !-------------------------------------- +! +! !PRIVATE MEMBER FUNCTIONS: +! + PRIVATE :: NEI2005_SCALE_FUTURE + PRIVATE :: INIT_NEI2005_ANTHRO + PRIVATE :: TOTAL_ANTHRO_TG + PRIVATE :: READ_NEI2005_MASK + PRIVATE :: GET_NEI99_SEASON + PRIVATE :: GET_NEI99_SEASON_05x0666 + PRIVATE :: GET_VISTAS_SEASON + PRIVATE :: GET_VISTAS_SEASON_05x0666 + PRIVATE :: GET_NEI99_WKSCALE + PRIVATE :: GET_NEI99_WKSCALE_05x0666 +! +! !REMARKS: +! (1) NIT is available in the data file but not read here (it is not +! emitted in GEOS-Chem). +! +! !REVISION HISTORY: +! 07 Oct 2009 - A. van Donkelaar - initial version +! 20 Oct 2009 - P. Le Sager - added handling of VOC & masks +! 02 Nov 2009 - A. van Donkelaar - added seasonality, weekday factors +! 02 Dec 2009 - R. Yantosca - Added GET_NEI2005_MASK function +! 02 Dec 2009 - R. Yantosca - Updated comments etc. +! 10 Dec 2009 - D. Millet - Fix scaling, which is by ozone season +! 11 Dec 2009 - L. Zhang, A. Van Donkelaar - Add seasonality for NH3 +! 21 Dec 2009 - R. Yantosca - Added support for 0.5 x 0.666 nested grids +! 13 Aug 2010 - R. Yantosca - Add modifications for MERRA (treat like GEOS-5) +!EOP +!------------------------------------------------------------------------------ +! +! !PRIVATE TYPES: +! + ! Array for surface area + REAL*8, ALLOCATABLE :: A_CM2(:) + + ! Arrays for emissions + REAL*8, ALLOCATABLE :: NOx(:,:,:) + REAL*8, ALLOCATABLE :: CO(:,:,:) + REAL*8, ALLOCATABLE :: SO2(:,:,:) + REAL*8, ALLOCATABLE :: SO4(:,:,:) + REAL*8, ALLOCATABLE :: NH3(:,:,:) + REAL*8, ALLOCATABLE :: OC(:,:,:) + REAL*8, ALLOCATABLE :: BC(:,:,:) + + REAL*8, ALLOCATABLE :: ALK4(:,:,:) ! 105 + REAL*8, ALLOCATABLE :: ACET(:,:,:) ! 109 + REAL*8, ALLOCATABLE :: MEK (:,:,:) ! 110 + REAL*8, ALLOCATABLE :: ALD2(:,:,:) ! 111 + REAL*8, ALLOCATABLE :: PRPE(:,:,:) ! 118 + REAL*8, ALLOCATABLE :: C2H6(:,:,:) ! 121 + REAL*8, ALLOCATABLE :: C3H8(:,:,:) ! 119 + REAL*8, ALLOCATABLE :: CH2O(:,:,:) ! 120 + + REAL*8, ALLOCATABLE :: NOx_WKEND(:,:,:) + REAL*8, ALLOCATABLE :: CO_WKEND(:,:,:) + REAL*8, ALLOCATABLE :: SO2_WKEND(:,:,:) + REAL*8, ALLOCATABLE :: SO4_WKEND(:,:,:) + REAL*8, ALLOCATABLE :: NH3_WKEND(:,:,:) + REAL*8, ALLOCATABLE :: OC_WKEND(:,:,:) + REAL*8, ALLOCATABLE :: BC_WKEND(:,:,:) + + REAL*8, ALLOCATABLE :: ALK4_WKEND(:,:,:) ! 105 + REAL*8, ALLOCATABLE :: ACET_WKEND(:,:,:) ! 109 + REAL*8, ALLOCATABLE :: MEK_WKEND(:,:,:) ! 110 + REAL*8, ALLOCATABLE :: ALD2_WKEND(:,:,:) ! 111 + REAL*8, ALLOCATABLE :: PRPE_WKEND(:,:,:) ! 118 + REAL*8, ALLOCATABLE :: C2H6_WKEND(:,:,:) ! 121 + REAL*8, ALLOCATABLE :: C3H8_WKEND(:,:,:) ! 119 + REAL*8, ALLOCATABLE :: CH2O_WKEND(:,:,:) ! 120 +! +! !DEFINED PARAMETERS: +! + REAL*8, PARAMETER :: SEC_IN_YEAR = 86400d0 * 365.25d0 + + CONTAINS +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: get_nei2005_anthro +! +! !DESCRIPTION: Function GET\_NEI2005\_ANTHRO returns the NEI2005 +! emission for GEOS-Chem grid box (I,J,L) and tracer N. Emissions can be +! returned in units of [kg/s] or [molec/cm2/s]. +!\\ +!\\ +! !INTERFACE: +! + FUNCTION GET_NEI2005_ANTHRO( I, J, L, N, WEEKDAY, + & MOLEC_CM2_S, KG_S ) RESULT( VALUE ) +! +! !USES: +! + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTACET, IDTALK4, IDTC2H6, IDTC3H8 + USE TRACERID_MOD, ONLY : IDTALD2, IDTCH2O, IDTPRPE, IDTMEK + USE TRACERID_MOD, ONLY : IDTNOx, IDTCO, IDTSO2, IDTNH3 + USE TRACERID_MOD, ONLY : IDTSO4 +! +! !INPUT PARAMETERS: +! + ! Longitude, latitude, and tracer indices + INTEGER, INTENT(IN) :: I, J, L, N + + ! OPTIONAL -- return emissions in [molec/cm2/s] + LOGICAL, INTENT(IN), OPTIONAL :: WEEKDAY, MOLEC_CM2_S + + ! OPTIONAL -- return emissions in [kg/s] or [kg C/s] + LOGICAL, INTENT(IN), OPTIONAL :: KG_S +! +! !RETURN VALUE: +! + ! Emissions output + REAL*8 :: VALUE +! +! !REVISION HISTORY: +! 7 Oct 2009 - A. van Donkelaar - initial version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL :: DO_KGS, DO_MCS + + !================================================================= + ! GET_NEI2005_ANTHRO 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 ( WEEKDAY ) THEN + + IF ( N == IDTNOx ) THEN + + ! NOx [kg/yr] + VALUE = NOx(I,J,L) + + ELSE IF ( N == IDTCO ) THEN + + ! CO [kg/yr] + VALUE = CO(I,J,L) + + ELSE IF ( N == IDTSO2 ) THEN + + ! SO2 [kg/yr] + VALUE = SO2(I,J,L) + + ELSE IF ( N == IDTSO4 ) THEN + + ! SO4 [kg/yr] + VALUE = SO4(I,J,L) + + ELSE IF ( N == IDTNH3 ) THEN + + ! NH3 [kg/yr] + VALUE = NH3(I,J,L) + + ELSE IF ( N == IDTALK4 ) THEN + + ! [kg C/yr] + VALUE = ALK4(I,J,L) + + ELSE IF ( N == IDTACET ) THEN + + ! [kg C/yr] + VALUE = ACET(I,J,L) + + ELSE IF ( N == IDTMEK ) THEN + + ! [kg C/yr] + VALUE = MEK(I,J,L) + + ELSE IF ( N == IDTPRPE ) THEN + + ! [kg C/yr] + VALUE = PRPE(I,J,L) + + ELSE IF ( N == IDTC3H8 ) THEN + + ! [kg C/yr] + VALUE = C3H8(I,J,L) + + ELSE IF ( N == IDTCH2O ) THEN + + ! [kg C/yr] + VALUE = CH2O(I,J,L) + + ELSE IF ( N == IDTC2H6 ) THEN + + ! [kg C/yr] + VALUE = C2H6(I,J,L) + + ELSE IF ( N == IDTALD2 ) THEN + + ! [kg C/yr] + VALUE = ALD2(I,J,L) + + ELSE + + ! Otherwise return a negative value to indicate + ! that there are no NEI2005 emissions for tracer N + VALUE = -1d0 + RETURN + + ENDIF + + ELSE + IF ( N == IDTNOx ) THEN + + ! NOx [kg/yr] + VALUE = NOx_WKEND(I,J,L) + + ELSE IF ( N == IDTCO ) THEN + + ! CO [kg/yr] + VALUE = CO_WKEND(I,J,L) + + ELSE IF ( N == IDTSO2 ) THEN + + ! SO2 [kg/yr] + VALUE = SO2_WKEND(I,J,L) + + ELSE IF ( N == IDTSO4 ) THEN + + ! SO4 [kg/yr] + VALUE = SO4_WKEND(I,J,L) + + ELSE IF ( N == IDTNH3 ) THEN + + ! NH3 [kg/yr] + VALUE = NH3_WKEND(I,J,L) + + ELSE IF ( N == IDTALK4 ) THEN + + ! [kg C/yr] + VALUE = ALK4_WKEND(I,J,L) + + ELSE IF ( N == IDTACET ) THEN + + ! [kg C/yr] + VALUE = ACET_WKEND(I,J,L) + + ELSE IF ( N == IDTMEK ) THEN + + ! [kg C/yr] + VALUE = MEK_WKEND(I,J,L) + + ELSE IF ( N == IDTPRPE ) THEN + + ! [kg C/yr] + VALUE = PRPE_WKEND(I,J,L) + + ELSE IF ( N == IDTC3H8 ) THEN + + ! [kg C/yr] + VALUE = C3H8_WKEND(I,J,L) + + ELSE IF ( N == IDTCH2O ) THEN + + ! [kg C/yr] + VALUE = CH2O_WKEND(I,J,L) + + ELSE IF ( N == IDTC2H6 ) THEN + + ! [kg C/yr] + VALUE = C2H6_WKEND(I,J,L) + + ELSE IF ( N == IDTALD2 ) THEN + + ! [kg C/yr] + VALUE = ALD2_WKEND(I,J,L) + + ELSE + + ! Otherwise return a negative value to indicate + ! that there are no NEI2005 emissions for tracer N + VALUE = -1d0 + RETURN + + ENDIF + + ENDIF + + !------------------------------ + ! Convert units (if necessary) + !------------------------------ + IF ( DO_KGS ) THEN + + ! Convert from [kg/yr] to [kg/s] or from [kgC/yr] to [kgC/s] + VALUE = VALUE / SEC_IN_YEAR + + ELSE IF ( DO_MCS ) THEN + + ! Convert NOx from [kg/yr] to [molec/cm2/s] or from + ! [kg C/yr] to [atom C/cm2/s] + VALUE = VALUE * XNUMOL(N) / ( A_CM2(J) * SEC_IN_YEAR ) + + ENDIF + + ! Return to calling program + END FUNCTION GET_NEI2005_ANTHRO +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: emiss_nei2005_anthro +! +! !DESCRIPTION: Subroutine EMISS\_NEI2005\_ANTHRO reads the NEI2005 +! emission fields at 1x1 resolution and regrids them to the +! current model resolution. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE EMISS_NEI2005_ANTHRO +! +! !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 + USE TRACERID_MOD, ONLY : IDTACET, IDTALK4, IDTC2H6, IDTC3H8 + USE TRACERID_MOD, ONLY : IDTALD2, IDTCH2O, IDTPRPE, IDTMEK + USE TRACERID_MOD, ONLY : IDTNOx, IDTCO, IDTSO2, IDTNH3 + USE TRACERID_MOD, ONLY : IDTSO4, IDTOCPI, IDTBCPI + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! FSCALYR +! +! !REVISION HISTORY: +! 07 Oct 2009 - A. van Donkelaar - initial version +! 20 Oct 2009 - P. Le Sager - added VOC, account for mask to get better total +! 12 Jul 2010 - R. Yantosca - Now point to NEI2005_201007 directory, to read +! in updated files (by Aaron van Donkelaar) to +! fix a problem in the VOC emissions. +! 13 Aug 2010 - R. Yantosca - Treat MERRA like GEOS-5 +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, THISYEAR, SNo, ScNo + INTEGER :: L, KLM, ID, MN + INTEGER :: SPECIES_ID(15), SPECIES_ID_SAVE(15) + REAL*4 :: ARRAY(I1x1,J1x1,5) + REAL*8 :: GEOS_1x1(I1x1,J1x1,5) + REAL*8 :: SC_1x1(I1x1,J1x1) + REAL*8 :: TAU2005, TAU + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=4) :: SYEAR + CHARACTER(LEN=5) :: SNAME + CHARACTER(LEN=1) :: SSMN + CHARACTER(LEN=2) :: SMN + + !================================================================= + ! EMISS_NEI2005_ANTHRO begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + CALL INIT_NEI2005_ANTHRO + FIRST = .FALSE. + ENDIF + + ! Get emissions year + IF ( FSCALYR < 0 ) THEN + THISYEAR = GET_YEAR() + ELSE + THISYEAR = FSCALYR + ENDIF + +#if defined( GEOS_5 ) || defined( MERRA ) || defined( GEOS_FP ) + SNAME = 'GEOS5' +#elif defined( GEOS_4 ) + SNAME = 'GEOS4' +#elif defined( GEOS_3 ) + SNAME = 'GEOS3' +#endif + + + ! (zhe, dkh, 01/16/12, adj32_015) + IF ( .not. ITS_A_FULLCHEM_SIM() ) THEN + + SPECIES_ID_SAVE = (/ IDTNOX, IDTCO, IDTSO2, IDTSO4, IDTNH3, + $ IDTACET, IDTALK4, IDTC2H6, IDTC3H8, + $ IDTOCPI, IDTBCPI, + $ IDTALD2, IDTCH2O, IDTPRPE, IDTMEK + $ /) + + IDTNOX = 1 + IDTCO = 4 + IDTSO2 = 26 + IDTSO4 = 27 + IDTNH3 = 30 + IDTACET = 9 + IDTALK4 = 5 + IDTC2H6 = 21 + IDTC3H8 = 19 + IDTOCPI = 35 + IDTBCPI = 34 + IDTALD2 = 11 + IDTCH2O = 20 + IDTPRPE = 18 + IDTMEK = 10 + + ENDIF + + ! list of ID of available species + SPECIES_ID = (/ IDTNOX, IDTCO, IDTSO2, IDTSO4, IDTNH3, + $ IDTACET, IDTALK4, IDTC2H6, IDTC3H8, + $ IDTOCPI, IDTBCPI, + $ IDTALD2, IDTCH2O, IDTPRPE, IDTMEK + $ /) + + ! Loop over species + DO KLM = 1, SIZE( SPECIES_ID ) + + SNo = SPECIES_ID( KLM ) + + ! corresponding annual scale factor # if any + ScNo = 0 + IF ( SNo == IDTNOx ) ScNo = 71 + IF ( SNo == IDTCO ) ScNo = 72 + IF ( SNo == IDTSO2 .or. SNo == IDTSO4 ) ScNo = 73 + + ! TAU values for 2005 + TAU2005 = GET_TAU0( 1, 1, 2005 ) + + ! File name + FILENAME = TRIM( DATA_DIR_1x1 ) // 'NEI2005_201007/' // + & 'NEI2005.' // TRIM( SNAME ) // '.1x1.AVG.bpch' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - EMISS_NEI2005_ANTHRO: Reading ', a ) + + CALL READ_BPCH2( FILENAME, 'ANTHSRCE', SNo, + & TAU2005, I1x1, J1x1, + & 5, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 before regridding + GEOS_1x1(:,:,:) = ARRAY(:,:,:) + + ! Apply annual scalar factor. Available for 1985-2005, + ! and NOx, CO and SO2 only. + IF ( ScNo .ne. 0 ) THEN + + CALL GET_ANNUAL_SCALAR_1x1( ScNo, 2005, + & THISYEAR, SC_1x1 ) + + DO L = 1, 5 + GEOS_1x1(:,:,L) = GEOS_1x1(:,:,L) * SC_1x1(:,:) + ENDDO + + ENDIF + + ! Apply Seasonality + IF ( SNo .eq. IDTNOx ) THEN + CALL GET_VISTAS_SEASON( ARRAY ) + ELSE + CALL GET_NEI99_SEASON( SNo, ARRAY ) + ENDIF + GEOS_1x1(:,:,:) = GEOS_1x1(:,:,:) * ARRAY(:,:,:) + + + ! Get Weekday/Weekend scaling + CALL GET_NEI99_WKSCALE( SNo, ARRAY ) + + + ! Regrid from GEOS 1x1 --> current model resolution + IF ( SNo .eq. IDTNOx ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, NOx ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), NOx_WKEND ) + DO L = 1, 5 + NOx(:,:,L) = NOx(:,:,L) * USA_MASK(:,:) + NOx_WKEND(:,:,L) = + & NOx_WKEND(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTCO ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, CO ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), CO_WKEND ) + DO L = 1, 5 + CO(:,:,L) = CO(:,:,L) * USA_MASK(:,:) + CO_WKEND(:,:,L) = + & CO_WKEND(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTSO2 ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, SO2 ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), SO2_WKEND ) + DO L = 1, 5 + SO2_WKEND(:,:,L) = + & SO2_WKEND(:,:,L) * USA_MASK(:,:) + SO2(:,:,L) = SO2(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTSO4 ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, SO4 ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), SO4_WKEND ) + DO L = 1, 5 + SO4_WKEND(:,:,L) = + & SO4_WKEND(:,:,L) * USA_MASK(:,:) + SO4(:,:,L) = SO4(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTNH3 ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, NH3 ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), NH3_WKEND ) + DO L = 1, 5 + NH3_WKEND(:,:,L) = + & NH3_WKEND(:,:,L) * USA_MASK(:,:) + NH3(:,:,L) = NH3(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTOCPI ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, OC ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), OC_WKEND ) + DO L = 1, 5 + OC_WKEND(:,:,L) = + & OC_WKEND(:,:,L) * USA_MASK(:,:) + OC(:,:,L) = OC(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTBCPI ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, BC ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), BC_WKEND ) + DO L = 1, 5 + BC_WKEND(:,:,L) = + & BC_WKEND(:,:,L) * USA_MASK(:,:) + BC(:,:,L) = BC(:,:,L) * USA_MASK(:,:) + ENDDO + + !--VOC + ELSEIF ( SNo == IDTALK4 ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, ALK4 ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), ALK4_WKEND ) + DO L = 1, 5 + ALK4_WKEND(:,:,L) = + & ALK4_WKEND(:,:,L) * USA_MASK(:,:) + ALK4(:,:,L) = ALK4(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTACET ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, ACET ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), ACET_WKEND ) + DO L = 1, 5 + ACET_WKEND(:,:,L) = + & ACET_WKEND(:,:,L) * USA_MASK(:,:) + ACET(:,:,L) = ACET(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTMEK ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, MEK ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), MEK_WKEND ) + DO L = 1, 5 + MEK_WKEND(:,:,L) = + & MEK_WKEND(:,:,L) * USA_MASK(:,:) + MEK(:,:,L) = MEK(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTPRPE ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, PRPE ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), PRPE_WKEND ) + DO L = 1, 5 + PRPE_WKEND(:,:,L) = + & PRPE_WKEND(:,:,L) * USA_MASK(:,:) + PRPE(:,:,L) = PRPE(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTC3H8 ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, C3H8 ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), C3H8_WKEND ) + DO L = 1, 5 + C3H8_WKEND(:,:,L) = + & C3H8_WKEND(:,:,L) * USA_MASK(:,:) + C3H8(:,:,L) = C3H8(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTCH2O ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, CH2O ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), CH2O_WKEND ) + DO L = 1, 5 + CH2O_WKEND(:,:,L) = + & CH2O_WKEND(:,:,L) * USA_MASK(:,:) + CH2O(:,:,L) = CH2O(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTC2H6 ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, C2H6 ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), C2H6_WKEND ) + DO L = 1, 5 + C2H6_WKEND(:,:,L) = + & C2H6_WKEND(:,:,L) * USA_MASK(:,:) + C2H6(:,:,L) = C2H6(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTALD2 ) THEN + + CALL DO_REGRID_1x1( 5, 'kg/yr', GEOS_1x1, ALD2 ) + CALL DO_REGRID_1x1( 5, 'kg/yr', + & GEOS_1x1(:,:,:) * ARRAY(:,:,:), ALD2_WKEND ) + DO L = 1, 5 + ALD2_WKEND(:,:,L) = + & ALD2_WKEND(:,:,L) * USA_MASK(:,:) + ALD2(:,:,L) = ALD2(:,:,L) * USA_MASK(:,:) + ENDDO + + ENDIF + + ENDDO + + ! (zhe, dkh, 01/16/12, adj32_015) + IF ( .not. ITS_A_FULLCHEM_SIM() ) THEN + + IDTNOX = SPECIES_ID_SAVE( 1 ) + IDTCO = SPECIES_ID_SAVE( 2 ) + IDTSO2 = SPECIES_ID_SAVE( 3 ) + IDTSO4 = SPECIES_ID_SAVE( 4 ) + IDTNH3 = SPECIES_ID_SAVE( 5 ) + IDTACET = SPECIES_ID_SAVE( 6 ) + IDTALK4 = SPECIES_ID_SAVE( 7 ) + IDTC2H6 = SPECIES_ID_SAVE( 8 ) + IDTC3H8 = SPECIES_ID_SAVE( 9 ) + IDTOCPI = SPECIES_ID_SAVE( 10 ) + IDTBCPI = SPECIES_ID_SAVE( 11 ) + IDTALD2 = SPECIES_ID_SAVE( 12 ) + IDTCH2O = SPECIES_ID_SAVE( 13 ) + IDTPRPE = SPECIES_ID_SAVE( 14 ) + IDTMEK = SPECIES_ID_SAVE( 15 ) + + ENDIF + + !-------------------------- + ! Compute future emissions + !-------------------------- + IF ( LFUTURE ) THEN + CALL NEI2005_SCALE_FUTURE + ENDIF + + !-------------------------- + ! Print emission totals + !-------------------------- + CALL TOTAL_ANTHRO_Tg( THISYEAR ) + + ! Return to calling program + END SUBROUTINE EMISS_NEI2005_ANTHRO +!EOC +!------------------------------------------------------------------------------ +! Dalhousie University Atmospheric Compositional Analysis Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: emiss_nei2005_anthro_05x0666 +! +! !DESCRIPTION: Subroutine EMISS\_NEI2005\_ANTHRO reads the NEI2005 +! emission fields at 1/2 x 2.3 resolution +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE EMISS_NEI2005_ANTHRO_05x0666 +! +! !USES: +! + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE LOGICAL_MOD, ONLY : LFUTURE + USE TIME_MOD, ONLY : GET_YEAR, GET_MONTH + USE SCALE_ANTHRO_MOD, ONLY : GET_ANNUAL_SCALAR_05x0666_NESTED + USE TRACERID_MOD, ONLY : IDTACET, IDTALK4, IDTC2H6, IDTC3H8 + USE TRACERID_MOD, ONLY : IDTALD2, IDTCH2O, IDTPRPE, IDTMEK + USE TRACERID_MOD, ONLY : IDTNOx, IDTCO, IDTSO2, IDTNH3 + USE TRACERID_MOD, ONLY : IDTSO4, IDTOCPI, IDTBCPI + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! FSCALYR +! +! !REVISION HISTORY: +! 03 Nov 2009 - A. van Donkelaar - initial version +! 12 Jul 2010 - R. Yantosca - Now point to NEI2005_201007 directory, to read +! in updated files (by Aaron van Donkelaar) to +! fix a problem in the VOC emissions. +! 13 Aug 2010 - R. Yantosca - Treat MERRA like GEOS-5 (leave for future use) +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J,THISYEAR, SNo, ScNo + INTEGER :: L, KLM, SPECIES_ID(15), ID, MN + INTEGER :: SPECIES_ID_SAVE(15) + REAL*4 :: ARRAY(IIPAR,JJPAR,5) + REAL*8 :: GEOS_05x0666(IIPAR,JJPAR,5) + REAL*4 :: SC_05x0666(IIPAR,JJPAR) + REAL*8 :: TAU2005, TAU + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=4) :: SYEAR + CHARACTER(LEN=5) :: SNAME + CHARACTER(LEN=1) :: SSMN + CHARACTER(LEN=2) :: SMN + + !================================================================= + ! EMISS_NEI2005_ANTHRO begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + CALL INIT_NEI2005_ANTHRO + FIRST = .FALSE. + ENDIF + + ! Get emissions year + IF ( FSCALYR < 0 ) THEN + THISYEAR = GET_YEAR() + ELSE + THISYEAR = FSCALYR + ENDIF + +#if defined( GEOS_5 ) || defined( MERRA ) || defined( GEOS_FP ) + SNAME = 'GEOS5' +#elif defined( GEOS_4 ) + SNAME = 'GEOS4' +#elif defined( GEOS_3 ) + SNAME = 'GEOS3' +#endif + + ! (zhe, dkh, 01/16/12, adj32_015) + IF ( .not. ITS_A_FULLCHEM_SIM() ) THEN + + SPECIES_ID_SAVE = (/ IDTNOX, IDTCO, IDTSO2, IDTSO4, IDTNH3, + $ IDTACET, IDTALK4, IDTC2H6, IDTC3H8, + $ IDTOCPI, IDTBCPI, + $ IDTALD2, IDTCH2O, IDTPRPE, IDTMEK + $ /) + + IDTNOX = 1 + IDTCO = 4 + IDTSO2 = 26 + IDTSO4 = 27 + IDTNH3 = 30 + IDTACET = 9 + IDTALK4 = 5 + IDTC2H6 = 21 + IDTC3H8 = 19 + IDTOCPI = 35 + IDTBCPI = 34 + IDTALD2 = 11 + IDTCH2O = 20 + IDTPRPE = 18 + IDTMEK = 10 + + ENDIF + + ! list of ID of available species + SPECIES_ID = (/ IDTNOX, IDTCO, IDTSO2, IDTSO4, IDTNH3, + $ IDTACET, IDTALK4, IDTC2H6, IDTC3H8, + $ IDTOCPI, IDTBCPI, + $ IDTALD2, IDTCH2O, IDTPRPE, IDTMEK + $ /) + + ! Loop over species + DO KLM = 1, SIZE( SPECIES_ID ) + + SNo = SPECIES_ID( KLM ) + + ! corresponding annual scale factor # if any + ScNo = 0 + IF ( SNo == IDTNOx ) ScNo = 71 + IF ( SNo == IDTCO ) ScNo = 72 + IF ( SNo == IDTSO2 .or. SNo == IDTSO4 ) ScNo = 73 + + ! TAU values for 2005 + TAU2005 = GET_TAU0( 1, 1, 2005 ) + + ! File name + FILENAME = TRIM( DATA_DIR ) // 'NEI2005_201007/' // + & 'NEI2005.' // TRIM( SNAME ) + & // '.1t2x2t3.AVG.na.bpch' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - EMISS_NEI2005_ANTHRO_05x0666: + & Reading ', a ) + + CALL READ_BPCH2( FILENAME, 'ANTHSRCE', SNo, + & TAU2005, IIPAR, JJPAR, + & 5, ARRAY, QUIET=.TRUE. ) + + GEOS_05x0666(:,:,:) = ARRAY(:,:,:) + + ! Apply annual scalar factor. Available for 1985-2005, + ! and NOx, CO and SO2 only. + IF ( ScNo .ne. 0 ) THEN + + CALL GET_ANNUAL_SCALAR_05x0666_NESTED( ScNo,2005, + & THISYEAR, SC_05x0666 ) + + DO L = 1, 5 + GEOS_05x0666(:,:,L) = GEOS_05x0666(:,:,L) + & * SC_05x0666(:,:) + ENDDO + + ENDIF + + ! Apply Seasonality + IF ( SNo .eq. IDTNOx ) THEN + CALL GET_VISTAS_SEASON_05x0666( ARRAY ) + ELSE + CALL GET_NEI99_SEASON_05x0666( SNo, ARRAY ) + ENDIF + GEOS_05x0666(:,:,:) = GEOS_05x0666(:,:,:) + & * ARRAY(:,:,:) + + CALL GET_NEI99_WKSCALE_05x0666( SNo, ARRAY ) + + IF ( SNo .eq. IDTNOx) THEN + + NOx(:,:,:) = GEOS_05x0666 + NOx_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + NOx(:,:,L) = NOx(:,:,L) * USA_MASK(:,:) + NOx_WKEND(:,:,L) = + & NOx_WKEND(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTCO ) THEN + + CO(:,:,:) = GEOS_05x0666 + CO_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + CO(:,:,L) = CO(:,:,L) * USA_MASK(:,:) + CO_WKEND(:,:,L) = + & CO_WKEND(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTSO2 ) THEN + + SO2(:,:,:) = GEOS_05x0666 + SO2_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + SO2_WKEND(:,:,L) = + & SO2_WKEND(:,:,L) * USA_MASK(:,:) + SO2(:,:,L) = SO2(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTSO4 ) THEN + + SO4(:,:,:) = GEOS_05x0666 + SO4_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + SO4_WKEND(:,:,L) = + & SO4_WKEND(:,:,L) * USA_MASK(:,:) + SO4(:,:,L) = SO4(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTNH3 ) THEN + + NH3(:,:,:) = GEOS_05x0666 + NH3_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + NH3_WKEND(:,:,L) = + & NH3_WKEND(:,:,L) * USA_MASK(:,:) + NH3(:,:,L) = NH3(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTOCPI ) THEN + + OC(:,:,:) = GEOS_05x0666 + OC_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + OC_WKEND(:,:,L) = + & OC_WKEND(:,:,L) * USA_MASK(:,:) + OC(:,:,L) = OC(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSEIF ( SNo .eq. IDTBCPI ) THEN + + BC(:,:,:) = GEOS_05x0666 + BC_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + BC_WKEND(:,:,L) = + & BC_WKEND(:,:,L) * USA_MASK(:,:) + BC(:,:,L) = BC(:,:,L) * USA_MASK(:,:) + ENDDO + + !--VOC + ELSEIF ( SNo == IDTALK4 ) THEN + + ALK4(:,:,:) = GEOS_05x0666 + ALK4_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + ALK4_WKEND(:,:,L) = + & ALK4_WKEND(:,:,L) * USA_MASK(:,:) + ALK4(:,:,L) = ALK4(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTACET ) THEN + + ACET(:,:,:) = GEOS_05x0666 + ACET_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + ACET_WKEND(:,:,L) = + & ACET_WKEND(:,:,L) * USA_MASK(:,:) + ACET(:,:,L) = ACET(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTMEK ) THEN + + MEK(:,:,:) = GEOS_05x0666 + MEK_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + MEK_WKEND(:,:,L) = + & MEK_WKEND(:,:,L) * USA_MASK(:,:) + MEK(:,:,L) = MEK(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTPRPE ) THEN + + PRPE(:,:,:) = GEOS_05x0666 + PRPE_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + PRPE_WKEND(:,:,L) = + & PRPE_WKEND(:,:,L) * USA_MASK(:,:) + PRPE(:,:,L) = PRPE(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTC3H8 ) THEN + + C3H8(:,:,:) = GEOS_05x0666 + C3H8_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + C3H8_WKEND(:,:,L) = + & C3H8_WKEND(:,:,L) * USA_MASK(:,:) + C3H8(:,:,L) = C3H8(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTCH2O ) THEN + + CH2O(:,:,:) = GEOS_05x0666 + CH2O_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + CH2O_WKEND(:,:,L) = + & CH2O_WKEND(:,:,L) * USA_MASK(:,:) + CH2O(:,:,L) = CH2O(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTC2H6 ) THEN + + C2H6(:,:,:) = GEOS_05x0666 + C2H6_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + C2H6_WKEND(:,:,L) = + & C2H6_WKEND(:,:,L) * USA_MASK(:,:) + C2H6(:,:,L) = C2H6(:,:,L) * USA_MASK(:,:) + ENDDO + + ELSE IF ( SNo == IDTALD2 ) THEN + + ALD2(:,:,:) = GEOS_05x0666 + ALD2_WKEND(:,:,:) = GEOS_05x0666 * ARRAY(:,:,:) + DO L = 1, 5 + ALD2_WKEND(:,:,L) = + & ALD2_WKEND(:,:,L) * USA_MASK(:,:) + ALD2(:,:,L) = ALD2(:,:,L) * USA_MASK(:,:) + ENDDO + + ENDIF + + ENDDO + + ! (zhe, dkh, 01/16/12, adj32_015) + IF ( .not. ITS_A_FULLCHEM_SIM() ) THEN + + IDTNOX = SPECIES_ID_SAVE( 1 ) + IDTCO = SPECIES_ID_SAVE( 2 ) + IDTSO2 = SPECIES_ID_SAVE( 3 ) + IDTSO4 = SPECIES_ID_SAVE( 4 ) + IDTNH3 = SPECIES_ID_SAVE( 5 ) + IDTACET = SPECIES_ID_SAVE( 6 ) + IDTALK4 = SPECIES_ID_SAVE( 7 ) + IDTC2H6 = SPECIES_ID_SAVE( 8 ) + IDTC3H8 = SPECIES_ID_SAVE( 9 ) + IDTOCPI = SPECIES_ID_SAVE( 10 ) + IDTBCPI = SPECIES_ID_SAVE( 11 ) + IDTALD2 = SPECIES_ID_SAVE( 12 ) + IDTCH2O = SPECIES_ID_SAVE( 13 ) + IDTPRPE = SPECIES_ID_SAVE( 14 ) + IDTMEK = SPECIES_ID_SAVE( 15 ) + + ENDIF + + !-------------------------- + ! Compute future emissions + !-------------------------- + IF ( LFUTURE ) THEN + CALL NEI2005_SCALE_FUTURE + ENDIF + + !-------------------------- + ! Print emission totals + !-------------------------- + CALL TOTAL_ANTHRO_Tg( THISYEAR ) + + ! Return to calling program + END SUBROUTINE EMISS_NEI2005_ANTHRO_05x0666 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: get_nei99_season +! +! !DESCRIPTION: Subroutine GET\_NEI99\_SEASON returns monthly scale +! factors from EPA 1999 +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GET_NEI99_SEASON( TRACER, AS ) +! +! !USES: +! + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE TIME_MOD, ONLY : GET_MONTH + USE TRACERID_MOD, ONLY : IDTACET, IDTALK4, IDTC2H6, IDTC3H8 + USE TRACERID_MOD, ONLY : IDTALD2, IDTCH2O, IDTPRPE, IDTMEK + USE TRACERID_MOD, ONLY : IDTNOx, IDTCO, IDTSO2, IDTNH3 + USE TRACERID_MOD, ONLY : IDTSO4 + +# include "CMN_SIZE" ! Size parameters +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: TRACER ! Tracer number +! +! !INPUT/OUTPUT PARAMETERS: +! + REAL*4, INTENT(OUT) :: AS(I1x1,J1x1,5) ! Scale factor array +! +! !REVISION HISTORY: +! 30 Oct 2009 - A. van Donkelaar - Initial Version +! 3 Nov 2009 - P. Le Sager - update handling of boxes w/ zero emissions +! 10 Dec 2009 - D. Millet - Now scale to August, not an annual average +! 11 Dec 2009 - L. Zhang, A. van Donkelaar - Add seasonality for NH3 +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*4 :: ARRAY(I1x1,J1x1,1) +! REAL*4 :: ANNUAL(I1x1,J1x1,1) dbm, 12/9/2009 + REAL*4 :: AUGUST(I1x1,J1x1,1) ! dbm, 12/9/2009 + REAL*4 :: MONTHLY(I1x1,J1x1,1) + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=6) :: MYEAR + REAL*8 :: TAU + INTEGER :: MN, ThisMN, L + + ! New seasonal NH3 emission scalar based on Zhang et al. ACP 2012 (lzh, 03/2012) + REAL*8, PARAMETER :: NH3_SCALE(12) = (/ + & 0.216d0, 0.418d0, 0.622d0, 0.815d0, 0.982d0, 0.974d0, + & 1.000d0, 0.900d0, 0.960d0, 0.600d0, 0.280d0, 0.236d0 /) + + !================================================================= + ! GET_NEI99_SEASON begins here! + !================================================================= + + ARRAY(:,:,1) = 0.d0 +! ANNUAL(:,:,1) = 0.d0 dbm, 12/9/2009 + AUGUST(:,:,1) = 0.d0 ! dbm, 12/9/2009 + MONTHLY(:,:,1) = 0.d0 + + ThisMN = GET_MONTH() + + ! lzh, amv, 12/11/2009 add NH3 emission seasonality + IF ( TRACER == IDTALD2 .or. TRACER == IDTCH2O ) THEN + AS = 1.d0 + RETURN + ELSEIF ( TRACER == IDTNH3 ) THEN + AS = NH3_SCALE(ThisMN) ! (lzh, 03/2012) + RETURN + ENDIF + + ! Echo info + WRITE( 6, 100 ) TRACER + 100 FORMAT( ' - GET_NEI99_SEASON: Reading TRACER: ', i ) + + !--------------------------------- + ! Read in data for August + !--------------------------------- + + ! File name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'EPA_NEI_200708/wkday_avg_an.199908.geos.1x1' + + ! TAU0 for 1999/08/01 + TAU = GET_TAU0( 8, 1, 1999 ) + + ! Read data + CALL READ_BPCH2( FILENAME, 'ANTHSRCE', TRACER, + & TAU, I1x1, J1x1, + & 1, ARRAY, QUIET=.TRUE. ) + + AUGUST(:,:,1) = ARRAY(:,:,1) + + !--------------------------------- + ! Read in data for current month + !--------------------------------- + + WRITE(MYEAR, '(i6)') 199900 + ThisMN + + ! File name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'EPA_NEI_200708/wkday_avg_an.' // MYEAR // '.geos.1x1' + + ! TAU for this month of 1999 + TAU = GET_TAU0( ThisMN, 1, 1999 ) + + ! Read data + CALL READ_BPCH2( FILENAME, 'ANTHSRCE', TRACER, + & TAU, I1x1, J1x1, + & 1, ARRAY, QUIET=.TRUE. ) + + MONTHLY(:,:,1) = ARRAY(:,:,1) + + !--------------------------------- + ! Normalize + !------------- ------------------- + + WHERE ( AUGUST == 0d0 ) + ARRAY = 1d0 + ELSEWHERE + ARRAY = MONTHLY / AUGUST + ENDWHERE + + DO L = 1, SIZE(AS,3) + AS(:,:,L) = ARRAY(:,:,1) + ENDDO + + END SUBROUTINE GET_NEI99_SEASON +!EOC +!------------------------------------------------------------------------------ +! Dalhousie University Atmospheric Composition Analysis Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: get_nei99_season_05x0666 +! +! !DESCRIPTION: Subroutine GET\_NEI\_SEASON returns monthly scale +! factors from EPA 1999, for the 0.5 x 0.666 nested grids. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GET_NEI99_SEASON_05x0666( TRACER, AS ) +! +! !USES: +! + USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1 + +# include "CMN_SIZE" ! Size parameters +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: TRACER ! Tracer number +! +! !INPUT/OUTPUT PARAMETERS: +! + REAL*4, INTENT(INOUT) :: AS(IIPAR,JJPAR,5) ! Scale factor array +! +! !REVISION HISTORY: +! 30 Oct 2009 - A. van Donkelaar - Initial Version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*4 :: ARRAY(I1x1,J1x1,5) + REAL*8 :: ARRAY_R8(IIPAR,JJPAR,5) + + !================================================================= + ! GET_NEI99_SEASON_05x0666 begins here! + !================================================================= + + ARRAY(:,:,:) = 0.d0 + + CALL GET_NEI99_SEASON( TRACER, ARRAY ) + + CALL DO_REGRID_1x1( 5, 'unitless', ARRAY, ARRAY_R8 ) + AS(:,:,:) = ARRAY_R8(:,:,:) + + END SUBROUTINE GET_NEI99_SEASON_05x0666 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: get_vistas_season +! +! !DESCRIPTION: Subroutine GET\_VISTAS\_SEASON returns monthly scale +! factors to account for monthly variations in NOx emissions +! on 1x1 resolution grid (amv, 11/02/09) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GET_VISTAS_SEASON( AS ) +! +! !USES: +! + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE TIME_MOD, ONLY : GET_MONTH, GET_YEAR + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! FSCALYR +! +! !INPUT/OUTPUT PARAMETERS: +! + REAL*4, INTENT(INOUT) :: AS(I1x1,J1x1,5) ! Scale factor array +! +! !REVISION HISTORY: +! 30 Oct 2009 - A. van Donkelaar - Initial Version +! 3 Nov 2009 - P. Le Sager - update handling of boxes w/ zero emissions +! 10 Dec 2009 - D. Millet - Now scale to August, not an annual average +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*4 :: ARRAY(I1x1,J1x1,1) + REAL*4 :: AUGUST(I1x1,J1x1,1) ! dbm, 12/9/2009 + REAL*4 :: MONTHLY(I1x1,J1x1,1) + REAL*4 :: O3SEASON(I1x1,J1x1,1) + REAL*4 :: O3SEASON_AUGUST(I1x1,J1x1,1) ! dbm, 12/9/2009 + CHARACTER(LEN=255) :: FILENAME, VISTAS_DIR + CHARACTER(LEN=4) :: SYEAR + CHARACTER(LEN=1) :: SSMN + CHARACTER(LEN=2) :: SMN + REAL*8 :: TAU2002 + INTEGER :: MN, THISMONTH, LEV + INTEGER :: THISYEAR + + !================================================================= + ! GET_NEI99_SEASON begins here! + !================================================================= + + ARRAY(:,:,1) = 0.d0 + AUGUST(:,:,1) = 0.d0 ! dbm, 12/9/2009 + MONTHLY(:,:,1) = 0.d0 + O3SEASON(:,:,1) = 0.d0 + O3SEASON_AUGUST(:,:,1) = 0.d0 ! dbm, 12/9/2009 + + ! Get emissions year + IF ( FSCALYR < 0 ) THEN + THISYEAR = GET_YEAR() + ELSE + THISYEAR = FSCALYR + ENDIF + + ! cap maximum scaling year + IF ( THISYEAR .gt. 2007 ) THEN + THISYEAR = 2007 + ENDIF + + VISTAS_DIR = TRIM( DATA_DIR_1x1 ) // 'VISTAS_200811/' + + TAU2002 = GET_TAU0( 1, 1, 2002) + THISMONTH = GET_MONTH() + + ! ------------------- + ! Read in data for August + ! ------------------- + + FILENAME = TRIM( VISTAS_DIR ) + & // 'Vistas-NOx-8.1x1' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - GET_VISTAS_SEASON: Reading ', a ) + + ! Read data + CALL READ_BPCH2( FILENAME, 'ANTHSRCE', 1, + & TAU2002, I1x1, J1x1, + & 1, ARRAY, QUIET=.TRUE. ) + + AUGUST(:,:,1) = ARRAY(:,:,1) + + ! ------------------- + ! Read in data for current month + ! ------------------- + + IF (THISMONTH .lt. 10) THEN + WRITE( SSMN, '(i1)' ) THISMONTH + FILENAME = TRIM( VISTAS_DIR ) + & // 'Vistas-NOx-' // SSMN // '.1x1' + ELSE + WRITE( SMN, '(i2)' ) THISMONTH + FILENAME = TRIM( VISTAS_DIR ) + & // 'Vistas-NOx-' // SMN // '.1x1' + ENDIF + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Read data + CALL READ_BPCH2( FILENAME, 'ANTHSRCE', 1, + & TAU2002, I1x1, J1x1, + & 1, ARRAY, QUIET=.TRUE. ) + + MONTHLY(:,:,1) = ARRAY(:,:,1) + + WRITE( SYEAR, '(i4)') THISYEAR + + ! Load ozone season regulation factors + IF (THISMONTH .lt. 10) THEN + WRITE( SSMN, '(i1)' ) THISMONTH + FILENAME = TRIM( VISTAS_DIR ) + & // 'ARP-SeasonalVariation-' // SYEAR // '-' + & // SSMN // '.1x1' + ELSE + WRITE( SMN, '(i2)' ) THISMONTH + FILENAME = TRIM( VISTAS_DIR ) + & // 'ARP-SeasonalVariation-' // SYEAR // '-' + & // SMN // '.1x1' + ENDIF + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Read data + CALL READ_BPCH2( FILENAME, 'RATIO-2D', 71, + & GET_TAU0(1,1,2002), I1x1, J1x1, + & 1, ARRAY, QUIET=.TRUE. ) + O3SEASON(:,:,1) = ARRAY(:,:,1) + + ! August ozone season regulation factors + FILENAME = TRIM( VISTAS_DIR ) + & // 'ARP-SeasonalVariation-' // SYEAR // '-8.1x1' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Read data + CALL READ_BPCH2( FILENAME, 'RATIO-2D', 71, + & GET_TAU0(1,1,2002), I1x1, J1x1, + & 1, ARRAY, QUIET=.TRUE. ) + O3SEASON_AUGUST(:,:,1) = ARRAY(:,:,1) + + ! First do seasonal scaling according to VISTAS + WHERE ( AUGUST == 0d0 ) + ARRAY = 1d0 + ELSEWHERE + ARRAY = MONTHLY / AUGUST + ENDWHERE + + ! Now scale for summertime NOx reductions + ARRAY = ARRAY * O3SEASON / O3SEASON_AUGUST + + DO LEV = 1, SIZE(AS,3) + AS(:,:,LEV) = ARRAY(:,:,1) + ENDDO + + + END SUBROUTINE GET_VISTAS_SEASON +!EOC +!------------------------------------------------------------------------------ +! Dalhousie University Atmospheric Composition Analysis Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: get_vistas_season_05x0666 +! +! !DESCRIPTION: Subroutine GET\_VISTAS\_SEASON\_05x0666 returns monthly scale +! factors to account for monthly variations in NOx emissions +! for the 0.5 x 0.666 nested grids. (amv, 11/02/09) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GET_VISTAS_SEASON_05x0666( AS ) +! +! !USES: +! + USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1 + +# include "CMN_SIZE" ! Size parameters +! +! !INPUT/OUTPUT PARAMETERS: +! + REAL*4, INTENT(INOUT) :: AS(IIPAR,JJPAR,5) ! Scale factor array +! +! !REVISION HISTORY: +! 03 Nov 2009 - A. van Donkelaar - Initial Version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*4 :: ARRAY(I1x1,J1x1,5) + REAL*8 :: ARRAY_R8(IIPAR,JJPAR,5) + + !================================================================= + ! GET_VISTAS_SEASON_05x0666 begins here! + !================================================================= + + ARRAY(:,:,:) = 0.d0 + + CALL GET_VISTAS_SEASON( ARRAY ) + + CALL DO_REGRID_1x1( 5, 'unitless', ARRAY, ARRAY_R8 ) + AS(:,:,:) = ARRAY_R8(:,:,:) + + END SUBROUTINE GET_VISTAS_SEASON_05x0666 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: get_nei99_wkscale +! +! !DESCRIPTION: Subroutine GET\_NEI99\_WKSCALE returns the scale +! factors to convert weekday to weekend emissions based +! on the NEI99. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GET_NEI99_WKSCALE( TRACER, AS ) +! +! !USES: +! + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE TIME_MOD, ONLY : GET_MONTH + USE TRACERID_MOD, ONLY : IDTACET, IDTALK4, IDTC2H6, IDTC3H8 + USE TRACERID_MOD, ONLY : IDTALD2, IDTCH2O, IDTPRPE, IDTMEK + USE TRACERID_MOD, ONLY : IDTNOx, IDTCO, IDTSO2, IDTNH3 + USE TRACERID_MOD, ONLY : IDTSO4 + +# include "CMN_SIZE" ! Size parameters +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: TRACER ! Tracer number +! +! !INPUT/OUTPUT PARAMETERS: +! + REAL*4, INTENT(INOUT) :: AS(I1x1,J1x1,5) ! Scale factor array +! +! !REVISION HISTORY: +! 30 Oct 2009 - A. van Donkelaar - Initial Version +! 3 Nov 2009 - P. Le Sager - update handling of boxes w/ zero emissions +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*4 :: WEEKDAY(I1x1,J1x1,1) + REAL*4 :: WEEKEND(I1x1,J1x1,1) + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=6) :: MYEAR + REAL*8 :: TAU + INTEGER :: MN, L + + !================================================================= + ! GET_NEI99_WKSCALE begins here! + !================================================================= + + WEEKDAY(:,:,1) = 0.d0 + WEEKEND(:,:,1) = 0.d0 + + MN = GET_MONTH() + + ! NH3/ALD2/ISOP not available + IF (( TRACER .eq. IDTNH3 ) .or. (TRACER .eq. IDTALD2) .or. + & ( TRACER .eq. IDTCH2O )) THEN + AS(:,:,:) = 1.d0 + RETURN + ENDIF + + ! Echo info + WRITE( 6, 100 ) TRACER + 100 FORMAT( ' - GET_NEI99_WKSCALE: Reading TRACER: ', i ) + + WRITE(MYEAR, '(i6)') 199900 + MN + + ! File name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'EPA_NEI_200708/wkday_avg_an.' // MYEAR // '.geos.1x1' + + ! Read data + CALL READ_BPCH2( FILENAME, 'ANTHSRCE', TRACER, + & GET_TAU0(MN,1,1999), I1x1, J1x1, + & 1, WEEKDAY, QUIET=.TRUE. ) + + WRITE(MYEAR, '(i6)') 199900 + MN + + ! File name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'EPA_NEI_200708/wkend_avg_an.' // MYEAR // '.geos.1x1' + + ! Read data + CALL READ_BPCH2( FILENAME, 'ANTHSRCE', TRACER, + & GET_TAU0(MN,1,1999), I1x1, J1x1, + & 1, WEEKEND, QUIET=.TRUE. ) + +!---see below +! ! avoid 0 / 0 +! WEEKDAY(:,:,1) = WEEKDAY(:,:,1) + 1.d0 +! WEEKEND(:,:,1) = WEEKEND(:,:,1) + 1.d0 +! +! DO L = 1,5 +! AS(:,:,L) = WEEKEND(:,:,1) / WEEKDAY(:,:,1) +! ENDDO + + + ! --Get scalings + WHERE ( WEEKDAY == 0d0 ) + WEEKEND = 1d0 + ELSEWHERE + WEEKEND = WEEKEND / WEEKDAY + ENDWHERE + + DO L = 1, SIZE(AS,3) + AS(:,:,L) = WEEKEND(:,:,1) + ENDDO + + + END SUBROUTINE GET_NEI99_WKSCALE +!EOC +!------------------------------------------------------------------------------ +! Dalhousie University Atmospheric Composition Analysis Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: get_nei99_wkscale_05x0666 +! +! !DESCRIPTION: Subroutine GET\_NEI99\_WKSCALE\_05x0666 returns the scale +! factors (for 0.5 x 0.666 nested grids) to convert weekday to weekend +! emissions based on the NEI99. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GET_NEI99_WKSCALE_05x0666( TRACER, AS ) +! +! !USES: +! + USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1 + +# include "CMN_SIZE" ! Size parameters +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: TRACER ! Tracer number +! +! !INPUT/OUTPUT PARAMETERS: +! + REAL*4, INTENT(INOUT) :: AS(IIPAR,JJPAR,5) ! Scale factor array +! +! !REVISION HISTORY: +! 30 Oct 2009 - A. van Donkelaar - Initial Version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*4 :: ARRAY(I1x1,J1x1,5) + REAL*8 :: ARRAY_R8(IIPAR,JJPAR,5) + + !================================================================= + ! GET_NEI99_SEASON_05x0666 begins here! + !================================================================= + + ARRAY(:,:,:) = 0.d0 + + CALL GET_NEI99_WKSCALE( TRACER, ARRAY ) + + CALL DO_REGRID_1x1( 5, 'unitless', ARRAY, ARRAY_R8 ) + AS(:,:,:) = ARRAY_R8(:,:,:) + + END SUBROUTINE GET_NEI99_WKSCALE_05x0666 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: read_nei2005_mask +! +! !DESCRIPTION: Subroutine READ\_NEI2005\_MASK reads the mask for NEI data +!\\ +!\\ +! !INTERFACE: + + SUBROUTINE READ_NEI2005_MASK +! +! !USES: +! + ! Reference to F90 modules + USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE LOGICAL_MOD, ONLY : LCAC, LBRAVO + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1 + USE TRANSFER_MOD, ONLY : TRANSFER_2D + +# include "CMN_SIZE" ! Size parameters +! +! !REMARKS: +! temporary mask: same as EPA 99 +! +! !REVISION HISTORY: +! 20 Oct 2009 - P. Le Sager - init +! 26 Oct 2009 - P. Le Sager - new masks +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*4 :: ARRAY2(I1x1,J1x1,1) + REAL*8 :: XTAU, GEOS_1x1(I1x1,J1x1,1) + CHARACTER(LEN=255) :: FILENAME, SNAME + + !================================================================= + ! Mask specific to NEI2005 data + !================================================================= + + SNAME = 'usa.' + + ! NEI2005 covers CANADA if we do not use CAC + IF ( .NOT. LCAC ) SNAME = TRIM( SNAME ) // 'can.' + + ! NEI2005 covers Mexico if we do not use BRAVO + IF ( .NOT. LBRAVO ) SNAME = TRIM( SNAME ) // 'mex.' + + + FILENAME = TRIM( DATA_DIR_1x1 ) // 'NEI2005_200910/' // + & TRIM( SNAME ) // 'mask.nei2005.geos.1x1' + + ! Echo info + WRITE( 6, 200 ) TRIM( FILENAME ) +200 FORMAT( ' - READ_NEI2005_MASK: Reading ', a ) + + + CALL READ_BPCH2( FILENAME, 'LANDMAP', 2, + & 0d0, I1x1, J1x1, + & 1, ARRAY2, QUIET=.TRUE. ) + + + ! Cast to REAL*8 before regridding + GEOS_1x1(:,:,:) = ARRAY2(:,:,:) + + ! Regrid from GEOS 1x1 --> current model resolution + CALL DO_REGRID_1x1( 'unitless', GEOS_1x1, USA_MASK ) + + WHERE ( USA_MASK /= 0D0 ) USA_MASK = 1D0 + + + ! Return to calling program + END SUBROUTINE READ_NEI2005_MASK +!------------------------------------------------------------------------------ +! Prior to 12/3/09: +! Leave for future use (bmy, 12/3/09) +!!EOC +!!------------------------------------------------------------------------------ +!! Harvard University Atmospheric Chemistry Modeling Group ! +!!------------------------------------------------------------------------------ +!!BOP +!! +!! !IROUTINE: get_nei2005_mask +!! +!! !DESCRIPTION: Subroutine GET\_NEI2005\_MASK returns the value of the +!! NEI 2005 mask to the calling program. Values of 1 denote grid boxes +!! within the EPA/NEI2005 emission region.! +!!\\ +!!\\ +!! !INTERFACE: +! +! FUNCTION GET_NEI2005_MASK( I, J ) RESULT ( USA ) +!! +!! !INPUT PARAMETERS: +!! +! INTEGER, INTENT(IN) :: I, J ! GEOS-Chem lon & lat indices +!! +!! !RETURN VALUE: +!! +! REAL*8 :: USA ! Value of the mask +!! +!! !REMARKS: +!! This is entended to encapsulate the USA_MASK variable. +!! +!! !REVISION HISTORY: +!! 02 Dec 2009 - R. Yantosca - Initial version +!!EOP +!!------------------------------------------------------------------------------ +!!BOC +!! +!! !LOCAL VARIABLES: +!! +! USA = USA_MASK(I,J) +! +! END FUNCTION GET_NEI2005_MASK +!------------------------------------------------------------------------------ +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: nei2005_scale_future +! +! !DESCRIPTION: Subroutine NEI2005\_SCALE\_FUTURE applies the IPCC future +! scale factors to the NEI2005 anthropogenic emissions. +!\\ +!\\ +! !INTERFACE: + + SUBROUTINE NEI2005_SCALE_FUTURE +! +! !USES: +! + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_COff + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NH3an + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NOxff + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_SO2ff + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_OCff + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_BCff + +# include "CMN_SIZE" ! Size parameters +! +! !REMARKS: +! VOC are not scaled, however scale factors are available (see +! epa_nei_mod.f for procedure) +! +! !REVISION HISTORY: +! 7 Oct 2009 - A. van Donkelaar - initial version +! 20 Oct 2009 - P. Le Sager - set L OpenMP private, put L loop first +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: I, J, L + + !================================================================= + ! NEI2005_SCALE_FUTURE begins here! + !================================================================= + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L ) + DO L = 1, 5 + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Future NOx [kg NO2/yr] + NOx(I,J,L) = NOx(I,J,L) * GET_FUTURE_SCALE_NOxff( I, J ) + + ! Future CO [kg CO /yr] + CO(I,J,L) = CO(I,J,L) * GET_FUTURE_SCALE_COff( I, J ) + + ! Future SO2 [kg SO2/yr] + SO2(I,J,L) = SO2(I,J,L) * GET_FUTURE_SCALE_SO2ff( I, J ) + + ! Future SO4 [kg SO4/yr] + SO4(I,J,L) = SO4(I,J,L) * GET_FUTURE_SCALE_SO2ff( I, J ) + + ! Future NH3 [kg NH3/yr] + NH3(I,J,L) = NH3(I,J,L) * GET_FUTURE_SCALE_NH3an( I, J ) + + ! Future OC [kg NH3/yr] + OC(I,J,L) = OC(I,J,L) * GET_FUTURE_SCALE_OCff( I, J ) + + ! Future BC [kg NH3/yr] + BC(I,J,L) = BC(I,J,L) * GET_FUTURE_SCALE_BCff( I, J ) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE NEI2005_SCALE_FUTURE +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: total_anthro_Tg +! +! !DESCRIPTION: Subroutine TOTAL\_ANTHRO\_TG prints the totals for the +! anthropogenic emissions of NOx, CO, SO2 and NH3. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE TOTAL_ANTHRO_TG( YEAR ) +! +! !USES: +! +# include "CMN_SIZE" ! Size parameters +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: YEAR ! Year of data to compute totals +! +! !REVISION HISTORY: +! 7 Oct 2009 - A. van Donkelaar - initial version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: I, J, L + REAL*8 :: T_NOX, T_CO, T_SO2, T_NH3 + REAL*8 :: T_SO4, T_OC, T_BC, T_ALK4 + REAL*8 :: T_ACET, T_MEK, T_PRPE, T_C3H8 + REAL*8 :: T_CH2O, T_C2H6,T_ALD2 + CHARACTER(LEN=3) :: UNIT + + !================================================================= + ! TOTAL_ANTHRO_TG begins here! + !================================================================= + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, 100 ) + 100 FORMAT( 'N. E. I. 2005 U. S. A. 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 ) + + ! Total SO4 [Tg S] + T_SO4 = SUM( SO4 ) * 1d-9 * ( 32d0 / 96d0 ) + + ! Total NH3 [Tg NH3] + T_NH3 = SUM( NH3 ) * 1d-9 + + ! Total OC [Tg] + T_OC = SUM( OC ) * 1d-9 + + ! Total OC [Tg] + T_BC = SUM( BC ) * 1d-9 + + ! Total ALK4 [Tg C] + T_ALK4 = SUM( ALK4 ) * 1d-9 + + ! Total ACET [Tg C] + T_ACET = SUM( ACET ) * 1d-9 + + ! Total MEK [Tg C] + T_MEK = SUM( MEK ) * 1d-9 + + ! Total PRPE [Tg C] + T_PRPE = SUM( PRPE ) * 1d-9 + + ! Total C3H8 [Tg C] + T_C3H8 = SUM( C3H8 ) * 1d-9 + + ! Total CH2O [Tg C] + T_CH2O = SUM( CH2O ) * 1d-9 + + ! Total C2H6 [Tg C] + T_C2H6 = SUM( C2H6 ) * 1d-9 + + ! Total ALD2 [Tg C] + T_ALD2 = SUM( ALD2 ) * 1d-9 + + + + ! Print totals in [Tg] + WRITE( 6, 110 ) 'NOx ', YEAR, T_NOx, '[Tg N ]' + WRITE( 6, 110 ) 'CO ', YEAR, T_CO, '[Tg CO ]' + WRITE( 6, 110 ) 'SO2 ', YEAR, T_SO2, '[Tg S ]' + WRITE( 6, 110 ) 'SO4 ', YEAR, T_SO4, '[Tg S ]' + WRITE( 6, 110 ) 'NH3 ', YEAR, T_NH3, '[Tg NH3]' + WRITE( 6, 110 ) 'OC ' , YEAR, T_OC, '[Tg C]' + WRITE( 6, 110 ) 'BC ' , YEAR, T_BC, '[Tg C]' + WRITE( 6, 110 ) 'ALK4 ', YEAR, T_ALK4, '[Tg C]' + WRITE( 6, 110 ) 'ACET ', YEAR, T_ACET, '[Tg C]' + WRITE( 6, 110 ) 'MEK ' , YEAR, T_MEK, '[Tg C]' + WRITE( 6, 110 ) 'PRPE ', YEAR, T_PRPE, '[Tg C]' + WRITE( 6, 110 ) 'C3H8 ', YEAR, T_C3H8, '[Tg C]' + WRITE( 6, 110 ) 'CH2O ', YEAR, T_CH2O, '[Tg C]' + WRITE( 6, 110 ) 'C2H6 ', YEAR, T_C2H6, '[Tg C]' + WRITE( 6, 110 ) 'ALD2 ', YEAR, T_ALD2, '[Tg C]' + + ! Format statement + 110 FORMAT( 'NEI2005 anthro ', a5, + & 'for year ', i4, ': ', f11.4, 1x, a8 ) + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Return to calling program + END SUBROUTINE TOTAL_ANTHRO_Tg +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: init_nei2005_anthro +! +! !DESCRIPTION: Subroutine INIT\_NEI2005\_ANTHRO allocates and zeroes all +! module arrays. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE INIT_NEI2005_ANTHRO +! +! !USES: +! + USE ERROR_MOD, ONLY : ALLOC_ERR + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LNEI05 + +# include "CMN_SIZE" ! Size parameters +! +! !REVISION HISTORY: +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: AS, J + + !================================================================= + ! INIT_NEI2005_ANTHRO begins here! + !================================================================= + + ! Return if LNEI05 is false + IF ( .not. LNEI05 ) RETURN + + !-------------------------------------------------- + ! Allocate and zero arrays for emissions + !-------------------------------------------------- + + ! allocate and read USA Mask + ALLOCATE( USA_MASK( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'USA_MASK' ) + USA_MASK = 0d0 + + CALL READ_NEI2005_MASK + + ALLOCATE( NOx( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NOx' ) + NOx = 0d0 + + ALLOCATE( CO( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CO' ) + CO = 0d0 + + ALLOCATE( SO2( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO2' ) + SO2 = 0d0 + + ALLOCATE( SO4( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO4' ) + SO4 = 0d0 + + ALLOCATE( NH3( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NH3' ) + NH3 = 0d0 + + ALLOCATE( OC( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OC' ) + OC = 0d0 + + ALLOCATE( BC( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC' ) + BC = 0d0 + + ALLOCATE( ALK4( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ALK4' ) + ALK4 = 0d0 + + ALLOCATE( ACET( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ACET' ) + ACET = 0d0 + + ALLOCATE( MEK( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MEK' ) + MEK = 0d0 + + ALLOCATE( ALD2( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ALD2' ) + ALD2 = 0d0 + + ALLOCATE( PRPE( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PRPE' ) + PRPE = 0d0 + + ALLOCATE( C2H6( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'C2H6' ) + C2H6 = 0d0 + + ALLOCATE( C3H8( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'C3H8' ) + C3H8 = 0d0 + + ALLOCATE( CH2O( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CH2O' ) + CH2O = 0d0 + + ALLOCATE( NOx_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NOx_WKEND' ) + NOx_WKEND = 0d0 + + ALLOCATE( CO_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CO_WKEND' ) + CO_WKEND = 0d0 + + ALLOCATE( SO2_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO2_WKEND' ) + SO2_WKEND = 0d0 + + ALLOCATE( SO4_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SO4_WKEND' ) + SO4_WKEND = 0d0 + + ALLOCATE( NH3_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NH3_WKEND' ) + NH3_WKEND = 0d0 + + ALLOCATE( OC_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'OC_WKEND' ) + OC_WKEND = 0d0 + + ALLOCATE( BC_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BC_WKEND' ) + BC_WKEND = 0d0 + + ALLOCATE( ALK4_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ALK4_WKEND' ) + ALK4_WKEND = 0d0 + + ALLOCATE( ACET_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ACET_WKEND' ) + ACET_WKEND = 0d0 + + ALLOCATE( MEK_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MEK_WKEND' ) + MEK_WKEND = 0d0 + + ALLOCATE( ALD2_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ALD2_WKEND' ) + ALD2_WKEND = 0d0 + + ALLOCATE( PRPE_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PRPE_WKEND' ) + PRPE_WKEND = 0d0 + + ALLOCATE( C2H6_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'C2H6_WKEND' ) + C2H6_WKEND = 0d0 + + ALLOCATE( C3H8_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'C3H8_WKEND' ) + C3H8_WKEND = 0d0 + + ALLOCATE( CH2O_WKEND( IIPAR, JJPAR, 5 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CH2O_WKEND' ) + CH2O_WKEND = 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 + + ! Return to calling program + END SUBROUTINE INIT_NEI2005_ANTHRO +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: cleanup_nei2005_anthro +! +! !DESCRIPTION: Subroutine CLEANUP\_NEI2005\_ANTHRO deallocates all module +! arrays. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE CLEANUP_NEI2005_ANTHRO +! +! !REVISION HISTORY: +!EOP +!------------------------------------------------------------------------------ +!BOC + !================================================================= + ! CLEANUP_NEIO2005_ANTHRO begins here! + !================================================================= + ! USA mask + IF ( ALLOCATED( USA_MASK) ) DEALLOCATE( USA_MASK ) + IF ( ALLOCATED( A_CM2 ) ) DEALLOCATE( A_CM2 ) + IF ( ALLOCATED( NOx ) ) DEALLOCATE( NOx ) + IF ( ALLOCATED( CO ) ) DEALLOCATE( CO ) + IF ( ALLOCATED( SO2 ) ) DEALLOCATE( SO2 ) + IF ( ALLOCATED( SO4 ) ) DEALLOCATE( SO4 ) + IF ( ALLOCATED( NH3 ) ) DEALLOCATE( NH3 ) + IF ( ALLOCATED( OC ) ) DEALLOCATE( OC ) + IF ( ALLOCATED( BC ) ) DEALLOCATE( BC ) + IF ( ALLOCATED( ALK4 ) ) DEALLOCATE( ALK4 ) + IF ( ALLOCATED( ACET ) ) DEALLOCATE( ACET ) + IF ( ALLOCATED( MEK ) ) DEALLOCATE( MEK ) + IF ( ALLOCATED( ALD2 ) ) DEALLOCATE( ALD2 ) + IF ( ALLOCATED( PRPE ) ) DEALLOCATE( PRPE ) + IF ( ALLOCATED( C2H6 ) ) DEALLOCATE( C2H6 ) + IF ( ALLOCATED( C3H8 ) ) DEALLOCATE( C3H8 ) + IF ( ALLOCATED( CH2O ) ) DEALLOCATE( CH2O ) + IF (ALLOCATED(NOx_WKEND) ) DEALLOCATE(NOx_WKEND ) + IF (ALLOCATED(CO_WKEND )) DEALLOCATE(CO_WKEND ) + IF (ALLOCATED(SO2_WKEND )) DEALLOCATE(SO2_WKEND ) + IF (ALLOCATED(SO4_WKEND )) DEALLOCATE(SO4_WKEND ) + IF (ALLOCATED(NH3_WKEND )) DEALLOCATE(NH3_WKEND ) + IF (ALLOCATED(OC_WKEND )) DEALLOCATE(OC_WKEND ) + IF (ALLOCATED(BC_WKEND )) DEALLOCATE(BC_WKEND ) + IF (ALLOCATED(ALK4_WKEND)) DEALLOCATE(ALK4_WKEND) + IF (ALLOCATED(ACET_WKEND)) DEALLOCATE(ACET_WKEND) + IF (ALLOCATED(MEK_WKEND )) DEALLOCATE(MEK_WKEND ) + IF (ALLOCATED(ALD2_WKEND)) DEALLOCATE(ALD2_WKEND) + IF (ALLOCATED(PRPE_WKEND)) DEALLOCATE(PRPE_WKEND) + IF (ALLOCATED(C2H6_WKEND)) DEALLOCATE(C2H6_WKEND) + IF (ALLOCATED(C3H8_WKEND)) DEALLOCATE(C3H8_WKEND) + IF (ALLOCATED(CH2O_WKEND)) DEALLOCATE(CH2O_WKEND) + + END SUBROUTINE CLEANUP_NEI2005_ANTHRO +!EOC + END MODULE NEI2005_ANTHRO_MOD diff --git a/code/nei2008_anthro_mod.F90 b/code/nei2008_anthro_mod.F90 new file mode 100644 index 0000000..0ae1ddb --- /dev/null +++ b/code/nei2008_anthro_mod.F90 @@ -0,0 +1,3178 @@ +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: nei2008_anthro_mod +! +! !DESCRIPTION: Module NEI2008\_ANTHRO\_MOD contains variables and routines to +! read the NEI2008 anthropogenic emissions. +!\\ +!\\ +! !INTERFACE: +! + MODULE NEI2008_ANTHRO_MOD +! +! !USES: +! + IMPLICIT NONE +# include "define.h" +# include "netcdf.inc" + PRIVATE +! +! !PUBLIC DATA MEMBERS: +! + REAL*8, PUBLIC, ALLOCATABLE :: USA_MASK(:,:) +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: CLEANUP_NEI2008_ANTHRO + PUBLIC :: EMISS_NEI2008_ANTHRO + PUBLIC :: EMISS_NEI2008_ANTHRO_NATIVE + PUBLIC :: GET_NEI2008_ANTHRO + !-------------------------------------- + ! Leave for future use (bmy, 12/3/09) + !PUBLIC :: GET_NEI2005_MASK + !-------------------------------------- +! +! !PRIVATE MEMBER FUNCTIONS: +! No longer need scaling except for future emissions + PRIVATE :: NEI2008_SCALE_FUTURE + PRIVATE :: INIT_NEI2008_ANTHRO + PRIVATE :: TOTAL_ANTHRO_TG + PRIVATE :: READ_NEI2008_MASK +! +! !REMARKS: + +! (1) +! +! !REVISION HISTORY: +! 12 Feb 2013 - K. Travis - initial version, adapted from Aaron von Donkelaar's NEI05 +! Note that NEI2008 does not have MEK, ACET, or C3H8 +!------------------------------------------------------------------------------ +! +! !PRIVATE TYPES: +! + ! Arrays for emissions (lat/lon/lev/hrs) + !REAL*8, ALLOCATABLE, TARGET :: NOX(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: CO(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: NO(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: NO2(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: HNO2(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: SO2(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: NH3(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: ALD2(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: RCHO(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: BENZ(:,:,:,:) + !REAL*8, ALLOCATABLE, TARGET :: CH4(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: C2H6(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: PRPE(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: ALK4(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: TOLU(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: XYLE(:,:,:,:) + !REAL*8, ALLOCATABLE, TARGET :: C2H4(:,:,:,:) + !REAL*8, ALLOCATABLE, TARGET :: MOH(:,:,:,:) + !REAL*8, ALLOCATABLE, TARGET :: EOH(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: CH2O(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: OCPO(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: BCPO(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: SO4(:,:,:,:) + + REAL*8, ALLOCATABLE, TARGET :: NOX_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: CO_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: NO_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: NO2_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: HNO2_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: SO2_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: NH3_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: ALD2_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: RCHO_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: BENZ_WKEND(:,:,:,:) + !REAL*8, ALLOCATABLE, TARGET :: CH4_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: C2H6_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: PRPE_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: ALK4_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: TOLU_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: XYLE_WKEND(:,:,:,:) + !REAL*8, ALLOCATABLE, TARGET :: C2H4_WKEND(:,:,:,:) + !REAL*8, ALLOCATABLE, TARGET :: MOH_WKEND(:,:,:,:) + !REAL*8, ALLOCATABLE, TARGET :: EOH_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: CH2O_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: OCPO_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: BCPO_WKEND(:,:,:,:) + REAL*8, ALLOCATABLE, TARGET :: SO4_WKEND(:,:,:,:) + + ! + ! !DEFINED PARAMETERS: + ! + REAL*8, PARAMETER :: SEC_IN_YEAR = 86400d0 * 365.25d0 + +CONTAINS + !EOC + !------------------------------------------------------------------------------ + ! Harvard University Atmospheric Chemistry Modeling Group ! + !------------------------------------------------------------------------------ + !BOP + ! + ! !IROUTINE: get_nei2008_anthro + ! + ! !DESCRIPTION: Function GET\_NEI2008\_ANTHRO returns the NEI2008 + ! emission for GEOS-Chem grid box (I,J) and tracer N and hour IH. + ! Emissions can be returned in units of [kg/s] or [molec/cm2/s]. + !\\ (krt, 2/10/13), now need IH + !\\ + ! !INTERFACE: + ! + FUNCTION GET_NEI2008_ANTHRO( I, J, L, IH, N, WEEKDAY ) RESULT( VALUE ) + ! + ! !USES: + ! + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTCO, IDTNO,IDTNO2, IDTHNO2 + USE TRACERID_MOD, ONLY : IDTSO2, IDTNH3 + USE TRACERID_MOD, ONLY : IDTNOX + USE TRACERID_MOD, ONLY : IDTALD2, IDTRCHO, IDTC2H6 + USE TRACERID_MOD, ONLY : IDTPRPE, IDTALK4, IDTC2H4 + USE TRACERID_MOD, ONLY : IDTBENZ, IDTTOLU, IDTXYLE + USE TRACERID_MOD, ONLY : IDTSO4, IDTCH2O + USE TRACERID_MOD, ONLY : IDTOCPO, IDTBCPO + USE TRACERID_MOD, ONLY : IDTMOH, IDTEOH, IDTCH4 + + ! + ! !INPUT PARAMETERS: + ! + ! Longitude, latitude, hour, and tracer indices + INTEGER, INTENT(IN) :: I, J, L, IH, N + + ! OPTIONAL -- return emissions in [molec/cm2/s] + LOGICAL, INTENT(IN), OPTIONAL :: WEEKDAY + ! + ! !RETURN VALUE in molec/cm2/s + ! + ! Emissions output + REAL*8 :: VALUE + ! + ! !REVISION HISTORY: + ! 12 Feb 2013 - K. Travis - initial version + !EOP + !------------------------------------------------------------------------------ + !BOC + ! + ! !LOCAL VARIABLES: + ! + + !================================================================= + ! GET_NEI2008_ANTHRO begins here! + !================================================================= + + ! Initialize + + IF ( WEEKDAY ) THEN ! First IF + IF ( N == IDTCO ) THEN ! Second IF + + ! CO [molec/cm2/s] + VALUE = CO(I,J,L,IH) + ELSE IF ( N == IDTNO ) THEN + + ELSE IF ( N == IDTNO ) THEN + + ! NOX[molec/cm2/s] + ! NOX(I,J,L,IH) = NO(I,J,L,IH)!+NO2(I,J,L,IH)+HNO2(I,J,L,IH) + VALUE = NO(I,J,L,IH) + + ELSE IF ( N == IDTNO2 ) THEN + + ! NO2[molec/cm2/s] + VALUE = NO2(I,J,L,IH) + + ELSE IF ( N == IDTHNO2 ) THEN + + ! HNO2[molec/cm2/s] + VALUE = HNO2(I,J,L,IH) + + !fp bckw compatibility + + ELSE IF (N == IDTNOX ) THEN + + VALUE = HNO2(I,J,L,IH) & + + NO(I,J,L,IH) & + + NO2(I,J,L,IH) + + ELSE IF ( N == IDTSO2 ) THEN + + ! SO2 [molec/cm2/s] + VALUE = SO2(I,J,L,IH) + + ELSE IF ( N == IDTNH3 ) THEN + + ! NH3 [molec/cm2/s] + VALUE = NH3(I,J,L,IH) + + ELSE IF ( N == IDTALD2 ) THEN + + ! [molec/cm2/s] + VALUE = ALD2(I,J,L,IH) + + ELSE IF ( N == IDTRCHO ) THEN + + ! [molec/cm2/s] + VALUE = RCHO(I,J,L,IH) + + ELSE IF ( N == IDTBENZ ) THEN + + ! [molec/cm2/s] + VALUE = BENZ(I,J,L,IH) + + ELSE IF ( N == IDTC2H6 ) THEN + + ! [molec/cm2/s] + VALUE = C2H6(I,J,L,IH) + + ELSE IF ( N == IDTPRPE ) THEN + + ! [molec/cm2/s] + VALUE = PRPE(I,J,L,IH) + + ELSE IF ( N == IDTALK4 ) THEN + + ! [molec/cm2/s] + VALUE = ALK4(I,J,L,IH) + + ELSE IF ( N == IDTTOLU ) THEN + + ! [molec/cm2/s] + VALUE = TOLU(I,J,L,IH) + + ELSE IF ( N == IDTXYLE ) THEN + + ! [molec/cm2/s] + VALUE = XYLE(I,J,L,IH) + + !ELSE IF ( N == IDTC2H4 ) THEN + + ! [molec/cm2/s] + ! VALUE = C2H4(I,J,L,IH) + + ELSE IF ( N == IDTCH2O ) THEN + + ! [molec/cm2/s] + VALUE = CH2O(I,J,L,IH) + + ELSE IF ( N == IDTOCPO ) THEN + + ! [g/cm2/s] + VALUE = OCPO(I,J,L,IH) + + ELSE IF ( N == IDTBCPO ) THEN + + ! [g/cm2/s] + VALUE = BCPO(I,J,L,IH) + + ELSE IF ( N == IDTSO4 ) THEN + + ! [g/cm2/s] + VALUE = SO4(I,J,L,IH) + + ! ELSE IF ( N == IDTEOH ) THEN + + ! [molec/cm2/s] + ! VALUE = EOH(I,J,L,IH) + + !ELSE IF ( N == IDTMOH ) THEN + + ! [molec/cm2/s] + ! VALUE = MOH(I,J,L,IH) + + !ELSE IF ( N == IDTCH4 ) THEN + + ! [molec/cm2/s] + ! VALUE = CH4(I,J,L,IH) + ELSE + ! Otherwise return a negative value to indicate + ! that there are no NEI2008 emissions for tracer N + VALUE = -1d0 + RETURN + + ENDIF ! END Second IF + + ELSE + + IF ( N == IDTCO ) THEN ! NEW SECOND IF + + ! CO [molec/cm2/s] + VALUE = CO_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTNO ) THEN + + ! NO [molec/cm2/s] + !NO_WKEND(I,J,L,IH) = NO_WKEND(I,J,L,IH)+NO2_WKEND(I,J,L,IH) & + ! + HNO2_WKEND(I,J,L,IH) + VALUE = NO_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTNO2 ) THEN + + ! NO2 [molec/cm2/s] + VALUE = NO2_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTHNO2 ) THEN + + ! HNO2 [molec/cm2/s] + VALUE = HNO2_WKEND(I,J,L,IH) + + !fp bckw compatibility + + ELSE IF (N == IDTNOX ) THEN + VALUE = HNO2_WKEND(I,J,L,IH) & + + NO_WKEND(I,J,L,IH) & + + NO2_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTSO2 ) THEN + + ! SO2 [molec/cm2/s] + VALUE = SO2_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTNH3 ) THEN + + ! NH3 [molec/cm2/s] + VALUE = NH3_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTALD2 ) THEN + + ! [molec/cm2/s] + VALUE = ALD2_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTRCHO ) THEN + + ! [molec/cm2/s] + VALUE = RCHO_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTBENZ ) THEN + + ! [molec/cm2/s] + VALUE = BENZ_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTC2H6 ) THEN + + ! [molec/cm2/s] + VALUE = C2H6_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTPRPE ) THEN + + ! [molec/cm2/s] + VALUE = PRPE_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTALK4 ) THEN + + ! [molec/cm2/s] + VALUE = ALK4_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTTOLU ) THEN + + ! [molec/cm2/s] + VALUE = TOLU_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTXYLE ) THEN + + ! [molec/cm2/s] + VALUE = XYLE_WKEND(I,J,L,IH) + + ! ELSE IF ( N == IDTC2H4 ) THEN + + ! [molec/cm2/s] + ! VALUE = C2H4_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTCH2O ) THEN + + ! [molec/cm2/s] + VALUE = CH2O_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTOCPO ) THEN + + ! [g/cm2/s] + VALUE = OCPO_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTBCPO ) THEN + + ! [g/cm2/s] + VALUE = BCPO_WKEND(I,J,L,IH) + + ELSE IF ( N == IDTSO4 ) THEN + + ! [g/cm2/s] + VALUE = SO4_WKEND(I,J,L,IH) + + !ELSE IF ( N == IDTEOH ) THEN + + ! [molec/cm2/s] + ! VALUE = EOH_WKEND(I,J,L,IH) + + !ELSE IF ( N == IDTMOH ) THEN + + ! [molec/cm2/s] + ! VALUE = MOH_WKEND(I,J,L,IH) + + !ELSE IF ( N == IDTCH4 ) THEN + + ! [molec/cm2/s] + ! VALUE = CH4_WKEND(I,J,L,IH) + + ELSE + ! Otherwise return a negative value to indicate + ! that there are no NEI2008 emissions for tracer N + VALUE = -1d0 + RETURN + ENDIF !END SECOND IF + ENDIF !END FIRST IF + + ! Return to calling program + END FUNCTION GET_NEI2008_ANTHRO +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: emiss_nei2008_anthro +! +! !DESCRIPTION: Subroutine EMISS\_NEI2008\_ANTHRO reads the NEI2008 +! emission fields at 1x1 resolution and regrids them to the +! current model resolution. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE EMISS_NEI2008_ANTHRO +! +! !USES: +! + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE LOGICAL_MOD, ONLY : LFUTURE + USE REGRID_A2A_MOD, ONLY : DO_REGRID_A2A + USE TIME_MOD, ONLY : GET_YEAR, GET_MONTH, GET_DAY + USE TIME_MOD, ONLY : GET_DAY_OF_WEEK, GET_HOUR + !USE SCALE_ANTHRO_MOD, ONLY : GET_ANNUAL_SCALAR_1x1 + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACERID_MOD, ONLY : IDTCO, IDTNO, IDTNO2, IDTHNO2 + USE TRACERID_MOD, ONLY : IDTNOX !fp + USE TRACERID_MOD, ONLY : IDTSO2, IDTNH3 + USE TRACERID_MOD, ONLY : IDTALD2, IDTRCHO, IDTC2H6 + USE TRACERID_MOD, ONLY : IDTPRPE, IDTALK4, IDTC2H4 + USE TRACERID_MOD, ONLY : IDTBENZ, IDTTOLU, IDTXYLE + USE TRACERID_MOD, ONLY : IDTSO4, IDTCH2O + USE TRACERID_MOD, ONLY : IDTOCPO, IDTBCPO + USE TRACERID_MOD, ONLY : IDTCH4, IDTEOH, IDTMOH + USE m_netcdf_io_open + USE m_netcdf_io_read + USE m_netcdf_io_readattr + USE m_netcdf_io_close + USE m_netcdf_io_get_dimlen + +# include "CMN_SIZE" ! Size parameters +!# include "CMN_O3" ! FSCALYRXS + + ! + ! !REVISION HISTORY: + ! 11 Feb 2013 - K. Travis - initial version + ! -------------------------------------------------------- + ! + ! !LOCAL VARIABLES: + ! + + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: WEEKDAY + INTEGER :: I, J, IH, THISMONTH, THISYEAR + INTEGER :: SNo,KLM2, DAY_NUM, DOYT + INTEGER :: L, HH, KLM, SPECIES_ID(18), ID, MN + INTEGER :: OFFLINE_ID(15) + INTEGER :: st3d(3), ct3d(3), st4d(4) + INTEGER :: ct4da(4), ct4db(4) + INTEGER :: fId1, fId1b, fId1c, fId1d + INTEGER :: fId2, fId2b, fId2c, fId2d ! netCDF file ID + REAL*4 :: ARRAYWD(I1x1,J1x1,24) + REAL*4 :: ARRAYWE(I1x1,J1x1,24) + REAL*4 :: ARRAYWDPT(2,I1x1,J1x1,24) + REAL*4 :: ARRAYWEPT(2,I1x1,J1x1,24) + REAL*4 :: ARRAYWDPTN(3,I1x1,J1x1,24) + REAL*4 :: ARRAYWEPTN(3,I1x1,J1x1,24) + REAL*4 :: ARRAYWDC3(I1x1,J1x1,24) + REAL*4 :: ARRAYWEC3(I1x1,J1x1,24) + REAL*8, TARGET :: GEOS_1x1WD(I1x1,J1x1,3,24) + REAL*8, TARGET :: GEOS_1x1WE(I1x1,J1x1,3,24) + REAL*4 :: ScCO, ScNOx, ScPM10, ScPM25 + REAL*4 :: ScVOC, ScNH3, ScSO2 + CHARACTER(LEN=255) :: DATA_DIR_NEI + CHARACTER(LEN=255) :: FILENAMEWD, FILENAMEWE + CHARACTER(LEN=255) :: FILENAMEWDPT, FILENAMEWEPT + CHARACTER(LEN=255) :: FILENAMEWDPTN, FILENAMEWEPTN + CHARACTER(LEN=255) :: FILENAMEWDC3, FILENAMEWEC3 + CHARACTER(LEN=4) :: SYEAR, SId + CHARACTER(LEN=5) :: SNAME + CHARACTER(LEN=1) :: SSMN + CHARACTER(LEN=2) :: SMN + CHARACTER(LEN=255) :: LLFILENAME + CHARACTER(LEN=3) :: TTMON + CHARACTER(LEN=24) :: SPCLIST(18) + REAL*8, POINTER :: OUTGRID(:,:) => NULL() + REAL*8, POINTER :: INGRID(:,:) => NULL() + + !================================================================= + ! EMISS_NEI2008_ANTHRO begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + CALL INIT_NEI2008_ANTHRO + FIRST = .FALSE. + ENDIF + + ! Get emissions year + THISYEAR = GET_YEAR() + + ! Get month + THISMONTH = GET_MONTH() + +#if defined( GEOS_5 ) || defined( MERRA ) || defined( GEOS_FP ) + SNAME = 'GEOS5' +#elif defined( GEOS_4 ) + SNAME = 'GEOS4' +#endif + + SPECIES_ID = (/ IDTCO, IDTNOX, IDTNOX, IDTNOX, & + IDTSO2, IDTNH3, IDTALD2, IDTRCHO, IDTC2H6, & + IDTPRPE, IDTALK4, IDTSO4, IDTCH2O, IDTOCPO, & + IDTBCPO, IDTTOLU, IDTXYLE, IDTBENZ/)!, IDTC2H4/) + !IDTMOH, IDTEOH, IDTCH4/) + + SPCLIST = (/ 'CO', 'NO2', 'HNO2','NO', 'SO2', 'NH3', & + 'ALD2','RCHO', 'C2H6', 'PRPE', 'ALK4', 'SO4', & + 'CH2O', 'OC', 'BC','TOLU','XYLE', 'BENZ'/)!, & + !'C2H4'/)!,'MOH', 'EOH','CH4' /) + + ! ID #'s for that are not tied to IDTxxxx flags + ! Needs to be updated for NOx partitioning + OFFLINE_ID = (/ 2, 1, 1, 1, 26, 30, 11, 12, & + 21, 18, 5, 27, 20, 36, 37 /) + + ! File with lat/lon edges for regridding + LLFILENAME = TRIM( DATA_DIR_1x1) // & + 'MAP_A2A_Regrid_201203/MAP_A2A_latlon_geos1x1.nc' + + + ! DataDir for year + IF (THISYEAR .lt. 2010) THEN + ! model ready + DATA_DIR_NEI = TRIM(DATA_DIR_1x1) // & + 'NEI2008_201307/NEI08_2006_1x1_' + ELSEIF (THISYEAR .ge. 2010) THEN + ! model ready + DATA_DIR_NEI = TRIM(DATA_DIR_1x1) // & + 'NEI2008_201307/NEI08_2010_1x1_' + ENDIF + + + ! Loop over species + DO KLM = 1, SIZE( SPCLIST ) + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + SId = SPCLIST( KLM ) + SNo = SPECIES_ID( KLM ) + ELSE + SNo = OFFLINE_ID( KLM ) + ENDIF + + ! Skip undefined tracers + IF ( SNo == 0 ) CYCLE + + ! + ! GET NEI2008 FILES! 1 for wday, 1 for wkend + IF (THISMONTH == 1) THEN + TTMON = 'Jan' + ELSEIF (THISMONTH == 2) THEN + TTMON = 'Feb' + ELSEIF (THISMONTH == 3) THEN + TTMON = 'Mar' + ELSEIF (THISMONTH == 4) THEN + TTMON = 'Apr' + ELSEIF (THISMONTH == 5) THEN + TTMON = 'May' + ELSEIF (THISMONTH == 6) THEN + TTMON = 'Jun' + ELSEIF (THISMONTH == 7) THEN + TTMON = 'Jul' + ELSEIF (THISMONTH == 8) THEN + TTMON = 'Aug' + ELSEIF (THISMONTH == 9) THEN + TTMON = 'Sep' + ELSEIF (THISMONTH == 10) THEN + TTMON = 'Oct' + ELSEIF (THISMONTH == 11) THEN + TTMON = 'Nov' + ELSEIF (THISMONTH == 12) THEN + TTMON = 'Dec' + ENDIF + + ! model ready + FILENAMEWD = TRIM(DATA_DIR_NEI) // & + TRIM(TTMON) // '_wkday_regrid.nc' + FILENAMEWE = TRIM(DATA_DIR_NEI) // & + TRIM(TTMON) // '_wkend_regrid.nc' + ! ptipm + FILENAMEWDPT = TRIM(DATA_DIR_NEI) // 'ptipm_' // & + TRIM(TTMON) // '_wkday_regrid.nc' + FILENAMEWEPT = TRIM(DATA_DIR_NEI) // 'ptipm_' // & + TRIM(TTMON) // '_wkend_regrid.nc' + ! ptnonipm + FILENAMEWDPTN = TRIM(DATA_DIR_NEI) // 'ptnonipm_' // & + TRIM(TTMON) // '_wkday_regrid.nc' + FILENAMEWEPTN = TRIM(DATA_DIR_NEI) // 'ptnonipm_' // & + TRIM(TTMON) // '_wkend_regrid.nc' + ! c3marine + FILENAMEWDC3 = TRIM(DATA_DIR_NEI) // 'c3marine_' // & + TRIM(TTMON) // '_wkday_regrid.nc' + FILENAMEWEC3= TRIM(DATA_DIR_NEI) // 'c3marine_' // & + TRIM(TTMON) // '_wkend_regrid.nc' + + ! Called once per month by emissions_mod.F + ! Allocate start and count arrays + st3d = (/1, 1, 1/) + st4d = (/1, 1, 1, 1/) + ct3d = (/I1x1, J1x1, 24/) + ct4da = (/2, I1x1, J1x1, 24/) + ct4db= (/3, I1x1, J1x1, 24/) + WRITE( 6, 100 ) TRIM(FILENAMEWD ), SId + WRITE( 6, 100 ) TRIM(FILENAMEWE ), SId + WRITE( 6, 100 ) TRIM(FILENAMEWDPT ), SId + WRITE( 6, 100 ) TRIM(FILENAMEWDPTN ), SId + WRITE( 6, 100 ) TRIM(FILENAMEWDC3 ), Sid + WRITE( 6, 100 ) TRIM(FILENAMEWEPT ), SId + WRITE( 6, 100 ) TRIM(FILENAMEWEPTN ), SId + WRITE( 6, 100 ) TRIM(FILENAMEWEC3 ), SId + + ! Open and read model_ready data from netCDF file - wkday + CALL Ncop_Rd(fId1, TRIM(FILENAMEWD)) + ! Open and read ptipm data from netCDF file - wkday + CALL Ncop_Rd(fId1b, TRIM(FILENAMEWDPT)) + ! Open and read ptnonipm data from netCDF file - wkday + CALL Ncop_Rd(fId1c, TRIM(FILENAMEWDPTN)) + ! Open and read c3marine data from netCDF file - wkday + CALL Ncop_Rd(fId1d, TRIM(FILENAMEWDC3)) + + !----WKDAY------- + Call NcRd(ARRAYWD, fId1, TRIM(SId), & + st3d, ct3d ) !Start andCount lat/lon/time + Call NcRd(ARRAYWDPT, fId1b, TRIM(SId), & + st4d, ct4da ) !start and count lat/lon/time/lev + Call NcRd(ARRAYWDPTN, fId1c, TRIM(SId), & + st4d, ct4db ) !start and count lat/lon/time/lev + Call NcRd(ARRAYWDC3, fId1d, TRIM(SId), & + st3d, ct3d ) !Start and Count lat/lon/time + + ! Close netCDF file + CALL NcCl( fId1 ) + CALL NcCl( fId1b ) + CALL NcCl( fId1c ) + CALL NcCl( fId1d ) + + ! Cast to REAL*8 before regridding + GEOS_1x1WD(:,:,1,:) = ARRAYWD(:,:,:)+ARRAYWDPT(1,:,:,:) + & + ARRAYWDPTN(1,:,:,:)+ARRAYWDC3(:,:,:) + GEOS_1x1WD(:,:,2,:) = ARRAYWDPT(2,:,:,:) + ARRAYWDPTN(2,:,:,:) + GEOS_1x1WD(:,:,3,:) = ARRAYWDPTN(3,:,:,:) !molecules/cm2/s + !ELSE + ! Open and read data from netCDF file - wkend + + WRITE( 6, 100 ) TRIM( FILENAMEWE ), SId + + CALL Ncop_Rd(fId2, TRIM(FILENAMEWE)) + CALL Ncop_Rd(fId2b, TRIM(FILENAMEWEPT)) + CALL Ncop_Rd(fId2c, TRIM(FILENAMEWEPTN)) + CALL Ncop_Rd(fId2d, TRIM(FILENAMEWEC3)) + + ! Get variable / SNo + !----WEEKEND------- + Call NcRd(ARRAYWE,fId2,TRIM(SId), & + (/1, 1, 1/), & !Start + (/ I1x1, J1x1, 24 /) ) !Count + Call NcRd(ARRAYWEPT, fId2b, TRIM(SId), & + (/ 1, 1, 1, 1 /), & !Start + (/ 2, I1x1, J1x1, 24 /) ) !Count lat/lon/time/lev + Call NcRd(ARRAYWEPTN, fId2c, TRIM(SId), & + (/ 1, 1, 1, 1 /), & !Start + (/ 3, I1x1, J1x1, 24 /) ) !Count lat/lon/time/lev + Call NcRd(ARRAYWEC3, fId2d, TRIM(SId), & + (/ 1, 1, 1 /), & !Start + (/ I1x1, J1x1, 24 /) ) !Count lat/lon/time + + CALL NcCl( fId2 ) + CALL NcCl( fId2b ) + CALL NcCl( fId2c ) + CALL NcCl( fId2d ) + + ! Cast to REAL*8 before regridding + GEOS_1x1WE(:,:,1,:) = ARRAYWE(:,:,:)+ARRAYWEPT(1,:,:,:) + & + ARRAYWEPTN(1,:,:,:)+ARRAYWEC3(:,:,:) + GEOS_1x1WE(:,:,2,:) = ARRAYWEPT(2,:,:,:) + ARRAYWEPTN(2,:,:,:) + GEOS_1x1WE(:,:,3,:) = ARRAYWEPTN(3,:,:,:) + + !ENDIF + + 100 FORMAT( ' - EMISS_NEI2008_ANTHRO_1x1: & + Reading : ', a , ' -> ', a ) + + ! Initialize scaling factors + ScCO = 1.0 + ScNOx = 1.0 + ScPM10 = 1.0 + ScPM25 = 1.0 + ScSO2 = 1.0 + ScVOC = 1.0 + ScNH3 = 1.0 + + ! Apply annual scalar factor. + ! Using EPA's National Tier1 CAPS (http://www.epa.gov/ttnchie1/trends/) + IF (THISYEAR .eq. 2007) THEN ! scale based on 2006 + ScCO = 0.939 + ScNOx = 0.966 + ScPM10 = 1.001 + ScSO2 = 0.887 + ScPM25 = 1.016 + ScVOC = 0.996 + ScNH3 = 1.018 + ELSEIF (THISYEAR .eq. 2008) THEN ! scale based on 2006 + ScCO = 0.877 + ScNOx = 0.933 + ScPM10 = 1.003 + ScPM25 = 1.092 + ScSO2 = 0.775 + ScVOC = 0.933 + ScNH3 = 1.035 + ELSEIF (THISYEAR .eq. 2009) THEN ! scale based on 2006 + ScCO = 0.854 + ScNOx = 0.850 + ScPM10 = 1.002 + ScPM25 = 1.088 + ScSO2 = 0.619 + ScVOC = 0.919 + ScNH3 = 1.033 + ELSEIF (THISYEAR .eq. 2011) THEN ! scale based on 2010 + ScCO = 0.916 + ScNOx = 0.897 + ScPM10 = 0.998 + ScPM25 = 0.990 + ScSO2 = 0.905 + ScVOC = 0.955 + ScNH3 = 0.996 + ELSEIF (THISYEAR .ge. 2012) THEN ! scale based on 2010 + ScCO = 0.820 + ScNOx = 0.773 + ScPM10 = 0.995 + ScPM25 = 0.979 + ScSO2 = 0.725 + ScVOC = 0.905 + ScNH3 = 0.991 + ENDIF + + DO L=1,3 + DO HH=1,24 ! check on whether this is correct + SELECT CASE ( SId) + CASE ('CO') + GEOS_1x1WD(:,:,L,HH) = GEOS_1x1WD(:,:,L,HH) * ScCO + GEOS_1x1WE(:,:,L,HH) = GEOS_1x1WE(:,:,L,HH) * ScCO + CASE ('NO','NO2','HNO2') + GEOS_1x1WD(:,:,L,HH) = GEOS_1x1WD(:,:,L,HH) * ScNOx + GEOS_1x1WE(:,:,L,HH) = GEOS_1x1WE(:,:,L,HH) * ScNOx + CASE ('BENZ','TOLU','XYLE','RCHO','CH2O','ALD2','C2H6','PRPE','ALK4') + GEOS_1x1WD(:,:,L,HH) = GEOS_1x1WD(:,:,L,HH) * ScVOC + GEOS_1x1WE(:,:,L,HH) = GEOS_1x1WE(:,:,L,HH) * ScVOC + CASE('BC','OC') + GEOS_1x1WD(:,:,L,HH) = GEOS_1x1WD(:,:,L,HH) * ScPM25 + GEOS_1x1WE(:,:,L,HH) = GEOS_1x1WE(:,:,L,HH) * ScPM25 + CASE('SO2') + GEOS_1x1WD(:,:,L,HH) = GEOS_1x1WD(:,:,L,HH) * ScSO2 + GEOS_1x1WE(:,:,L,HH) = GEOS_1x1WE(:,:,L,HH) * ScSO2 + CASE ('NH3') + GEOS_1x1WD(:,:,L,HH) = GEOS_1x1WD(:,:,L,HH) * ScNH3 + GEOS_1x1WE(:,:,L,HH) = GEOS_1x1WE(:,:,L,HH) * ScNH3 + END SELECT + ENDDO + ENDDO + + ! Regrid from GEOS 1x1 --> current model resolution [molec/cm2/2] + + IF ( SId .eq. 'CO' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! CO + !----------------- + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => CO(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + !----------------- + ! Apply masks + !----------------- + !CO(:,:,L,HH) = CO(:,:,L,HH) * USA_MASK(:,:) + ! should still be molecules/cm2/s + ENDDO + ENDDO + ELSEIF ( SId .eq. 'NO' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! NO + !----------------- + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => NO(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + !----------------- + ! Apply masks + !----------------- + !NO(:,:,L,HH) = NO(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + + ELSEIF ( TRIM(SId) .eq. 'NO2' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! NO2 + !----------------- + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => NO2(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !NO2(:,:,L,HH) = NO2(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( TRIM(SId) .eq. 'HNO2' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! HNO2 + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => HNO2(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + ! HNO2(:,:,L,HH) = HNO2(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( TRIM(SId) .eq. 'SO2') THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! SO2 + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => SO2(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + ! SO2(:,:,L,HH) = SO2(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( TRIM(SId) .eq. 'NH3' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! NH3 + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => NH3(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + !----------------- + ! Apply masks + !----------------- + !NH3(:,:,L,HH) = NH3(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( TRIM(SId) .eq. 'ALD2' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! ALD2 + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => ALD2(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !ALD2(:,:,L,HH) = ALD2(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( TRIM(SId) == 'RCHO' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! RCHO + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => RCHO(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !RCHO(:,:,L,HH) = RCHO(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'BENZ' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! BENZ + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => BENZ(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !BENZ(:,:,L,HH) = BENZ(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'C2H6' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! C2H6 + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => C2H6(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + !----------------- + ! Apply masks + !----------------- + !C2H6(:,:,L,HH) = C2H6(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'PRPE' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! PRPE + !----------------- + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => PRPE(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + !----------------- + ! Apply masks + !----------------- + !PRPE(:,:,L,HH) = PRPE(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'ALK4' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! ALK4 + !----------------- + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => ALK4(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + !----------------- + ! Apply masks + !----------------- + !ALK4(:,:,L,HH) = ALK4(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'TOLU' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! TOLU + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => TOLU(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !TOLU(:,:,L,HH) = TOLU(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'XYLE' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! XYLE + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => XYLE(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !XYLE(:,:,L,HH) = XYLE(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ! ELSE IF ( TRIM(SId) == 'C2H4' ) THEN + ! DO L=1,3 + ! DO HH=1,24 + !----------------- + ! C2H4 + !----------------- + + ! INGRID => GEOS_1x1WD(:,:,L,HH) + ! OUTGRID => C2H4(:,:,L,HH) + + ! Regrid + ! CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + ! INGRID, OUTGRID, IS_MASS=0,& + ! netCDF=.TRUE. ) + + ! Free pointers + ! NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !C2H4(:,:,L,HH) = C2H4(:,:,L,HH) * USA_MASK(:,:) + ! ENDDO + !ENDDO + ELSE IF ( TRIM(SId) == 'CH2O' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! CH2O + !----------------- + + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => CH2O(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !CH2O(:,:,L,HH) = CH2O(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'BC' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! BCPO + !----------------- + + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => BCPO(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !BCPO(:,:,L,HH) = BCPO(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'OC' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! OCPO + !----------------- + + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => OCPO(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !OCPO(:,:,L,HH) = OCPO(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'SO4' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! SO4 + !----------------- + INGRID => GEOS_1x1WD(:,:,L,HH) + OUTGRID => SO4(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !SO4(:,:,L,HH) = SO4(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + !ELSE IF ( TRIM(SId) == 'CH4' ) THEN + ! DO L=1,3 + ! DO HH=1,24 + !----------------- + ! CH4 + !----------------- + + ! INGRID => GEOS_1x1WD(:,:,L,HH) + ! OUTGRID => CH4(:,:,L,HH) + + ! Regrid + ! CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& + ! INGRID, OUTGRID, IS_MASS=0,& + ! netCDF=.TRUE. ) + + ! Free pointers + ! NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + ! CH4(:,:,L,HH) = CH4(:,:,L,HH) * USA_MASK(:,:) + ! ENDDO + !ENDDO + ! ELSE IF ( TRIM(SId) == 'EOH' ) THEN + + !----------------- + ! EOH + !----------------- + ! DO L=1,3 + ! DO HH=1,24 + ! INGRID => GEOS_1x1WD(:,:,L,HH) + ! OUTGRID => EOH(:,:,L,HH) + + ! Regrid + ! CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& + ! INGRID, OUTGRID, IS_MASS=0,& + ! netCDF=.TRUE. ) + + ! Free pointers + !NULLIFY( INGRID, OUTGRID ) + !ENDDO + !ENDDO + !ELSE IF ( TRIM(SId) == 'MOH' ) THEN + ! DO L=1,3 + ! DO HH=1,24 + !----------------- + ! MOH + !----------------- + + ! INGRID => GEOS_1x1WD(:,:,L,HH) + ! OUTGRID => MOH(:,:,L,HH) + + ! Regrid + !CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& + ! INGRID, OUTGRID, IS_MASS=0,& + ! netCDF=.TRUE. ) + + ! Free pointers + !NULLIFY( INGRID, OUTGRID ) + !ENDDO + !ENDDO + + ENDIF ! END loop through weekdays + ! BEGIN WEEKEND + !ELSE + + IF ( SId .eq. 'CO' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! CO_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => CO_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !CO_WKEND(:,:,L,HH) = CO_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( SId .eq. 'NO' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! NO_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => NO_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + !----------------- + ! Apply masks + !----------------- + !NO_WKEND(:,:,L,HH) = NO_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( TRIM(SId) .eq. 'NO2' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! NO2_WKEND + !----------------- + + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => NO2_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !NO2_WKEND(:,:,L,HH) = NO2_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( TRIM(SId) .eq. 'HNO2' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! HNO2_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => HNO2_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + !----------------- + ! Apply masks + !----------------- + !HNO2_WKEND(:,:,L,HH) = HNO2_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( TRIM(SId) .eq. 'SO2') THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! SO2_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => SO2_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !SO2_WKEND(:,:,L,HH) = SO2_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( TRIM(SId) .eq. 'NH3' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! NH3_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => NH3_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !NH3_WKEND(:,:,L,HH) = NH3_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( TRIM(SId) .eq. 'ALD2' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! ALD2_WKEND + !----------------- + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => ALD2_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + !----------------- + ! Apply masks + !----------------- + !ALD2_WKEND(:,:,L,HH) = ALD2_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSEIF ( TRIM(SId) == 'RCHO' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! RCHO_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => RCHO_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !RCHO_WKEND(:,:,L,HH) = RCHO_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'BENZ' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! BENZ_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => BENZ_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !BENZ_WKEND(:,:,L,HH) = BENZ_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'C2H6' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! C2H6_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => C2H6_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !C2H6_WKEND(:,:,L,HH) = C2H6_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'PRPE' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! PRPE_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => PRPE_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !PRPE_WKEND(:,:,L,HH) = PRPE_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'ALK4' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! ALK4_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => ALK4_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !ALK4_WKEND(:,:,L,HH) = ALK4_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'TOLU' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! TOLU_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => TOLU_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !TOLU_WKEND(:,:,L,HH) = TOLU_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'XYLE' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! XYLE_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => XYLE_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + ! XYLE_WKEND(:,:,L,HH) = XYLE_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + !ELSE IF ( TRIM(SId) == 'C2H4' ) THEN + ! DO L=1,3 + ! DO HH=1,24 + !----------------- + ! C2H4_WKEND + !----------------- + + ! Point to array slices + ! INGRID => GEOS_1x1WE(:,:,L,HH) + ! OUTGRID => C2H4_WKEND(:,:,L,HH) + + ! Regrid + ! CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& + ! INGRID, OUTGRID, IS_MASS=0,& + ! netCDF=.TRUE. ) + + ! Free pointers + ! NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + ! C2H4_WKEND(:,:,L,HH) = C2H4_WKEND(:,:,L,HH) * USA_MASK(:,:) + ! ENDDO + !ENDDO + ELSE IF ( TRIM(SId) == 'CH2O' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! CH2O_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => CH2O_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !CH2O_WKEND(:,:,L,HH) = CH2O_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'BC' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! BCPO_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => BCPO_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !BCPO_WKEND(:,:,L,HH) = BCPO_WKEND(:,:,L,HH) * USA_MASK(:,:) + !BCPO(:,:,L,HH) = BCPO(:,:,L,HH) * USA_MASK(:,:) + + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'OC' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! OCPO_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => OCPO_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& + INGRID, OUTGRID, IS_MASS=0,& + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !OCPO_WKEND(:,:,L,HH) = OCPO_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO + ELSE IF ( TRIM(SId) == 'SO4' ) THEN + DO L=1,3 + DO HH=1,24 + !----------------- + ! SO4_WKEND + !----------------- + + ! Point to array slices + INGRID => GEOS_1x1WE(:,:,L,HH) + OUTGRID => SO4_WKEND(:,:,L,HH) + + ! Regrid + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, OUTGRID, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointers + NULLIFY( INGRID, OUTGRID ) + + !----------------- + ! Apply masks + !----------------- + !SO4_WKEND(:,:,L,HH) = SO4_WKEND(:,:,L,HH) * USA_MASK(:,:) + ENDDO + ENDDO +!!$ ELSE IF ( TRIM(SId) == 'CH4' ) THEN +!!$ DO L=1,3 +!!$ DO HH=1,24 +!!$ !----------------- +!!$ ! CH4_WKEND +!!$ !----------------- +!!$ +!!$ ! Point to array slices +!!$ INGRID => GEOS_1x1WE(:,:,L,HH) +!!$ OUTGRID => CH4_WKEND(:,:,L,HH) +!!$ +!!$ ! Regrid +!!$ CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& +!!$ INGRID, OUTGRID, IS_MASS=0,& +!!$ netCDF=.TRUE. ) +!!$ +!!$ ! Free pointers +!!$ NULLIFY( INGRID, OUTGRID ) +!!$ +!!$ !----------------- +!!$ ! Apply masks +!!$ !----------------- +!!$ CH4_WKEND(:,:,L,HH) = CH4_WKEND(:,:,L,HH) * USA_MASK(:,:) +!!$ ENDDO +!!$ ENDDO +!!$ ELSE IF ( TRIM(SId) == 'EOH' ) THEN +!!$ DO L=1,3 +!!$ DO HH=1,24 +!!$ !----------------- +!!$ ! EOH_WKEND +!!$ !----------------- +!!$ +!!$ ! Point to array slices +!!$ INGRID => GEOS_1x1WE(:,:,L,HH) +!!$ OUTGRID => EOH_WKEND(:,:,L,HH) +!!$ +!!$ ! Regrid +!!$ CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& +!!$ INGRID, OUTGRID, IS_MASS=0,& +!!$ netCDF=.TRUE. ) +!!$ +!!$ ! Free pointers +!!$ NULLIFY( INGRID, OUTGRID ) +!!$ !----------------- +!!$ ! Apply masks +!!$ !----------------- +!!$ EOH_WKEND(:,:,L,HH) = EOH_WKEND(:,:,L,HH) * USA_MASK(:,:) +!!$ ENDDO +!!$ ENDDO +!!$ ELSE IF ( TRIM(SId) == 'MOH' ) THEN +!!$ DO L=1,3 +!!$ DO HH=1,24 +!!$ !----------------- +!!$ ! MOH_WKEND +!!$ !----------------- +!!$ +!!$ ! Point to array slices +!!$ INGRID => GEOS_1x1WE(:,:,L,HH) +!!$ OUTGRID => MOH_WKEND(:,:,L,HH) +!!$ +!!$ ! Regrid +!!$ CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1,& +!!$ INGRID, OUTGRID, IS_MASS=0,& +!!$ netCDF=.TRUE. ) +!!$ +!!$ ! Free pointers +!!$ NULLIFY( INGRID, OUTGRID ) +!!$ !----------------- +!!$ ! Apply masks +!!$ !----------------- +!!$ MOH_WKEND(:,:,L,HH) = MOH_WKEND(:,:,L,HH) * USA_MASK(:,:) +!!$ ENDDO +!!$ ENDDO + ENDIF ! END LOOPTHROUGHS + ENDDO + + !-------------------------- + ! Compute future emissions + !-------------------------- + IF ( LFUTURE ) THEN + CALL NEI2008_SCALE_FUTURE + ENDIF + + !-------------------------- + ! Print emission totals for the day + !-------------------------- + CALL TOTAL_ANTHRO_Tg( THISMONTH ) + + ! Return to calling program + END SUBROUTINE EMISS_NEI2008_ANTHRO +!EOC +!------------------------------------------------------------------------------ +! Adopted from NEI05 from +! Dalhousie University Atmospheric Compositional Analysis Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: emiss_nei2008_anthro_native +! +! !DESCRIPTION: Subroutine EMISS\_NEI2008\_ANTHRO reads the NEI2008 +! emission fields at 1/2 x 2.3 or .25 x 0.3125 resolution +! Designed to work with IIPAR and JJPAR as long as emissions are on the +! same nested grid. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE EMISS_NEI2008_ANTHRO_NATIVE + ! + ! !USES: + ! + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE LOGICAL_MOD, ONLY : LFUTURE + USE TIME_MOD, ONLY : GET_YEAR, GET_MONTH, GET_DAY + USE TIME_MOD, ONLY : GET_DAY_OF_WEEK, GET_HOUR + !USE SCALE_ANTHRO_MOD, ONLY : GET_ANNUAL_SCALAR_05x0666_NESTED + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACERID_MOD, ONLY : IDTCO, IDTNO, IDTHNO2, IDTNO2 + USE TRACERID_MOD, ONLY : IDTSO2, IDTNH3, IDTNOX + USE TRACERID_MOD, ONLY : IDTALD2, IDTRCHO, IDTC2H6 + USE TRACERID_MOD, ONLY : IDTPRPE, IDTALK4!, IDTC2H4 + USE TRACERID_MOD, ONLY : IDTBENZ, IDTTOLU, IDTXYLE + USE TRACERID_MOD, ONLY : IDTSO4, IDTCH2O + USE TRACERID_MOD, ONLY : IDTOCPO, IDTBCPO + !USE TRACERID_MOD, ONLY : IDTEOH, IDTMOH, IDTCH4 + + USE m_netcdf_io_open + USE m_netcdf_io_read + USE m_netcdf_io_readattr + USE m_netcdf_io_close + USE m_netcdf_io_get_dimlen + +# include "CMN_SIZE" ! Size parameters +!# include "CMN_O3" ! FSCALYR + +! +! !REVISION HISTORY: +! 16 Feb 2013 - K. Travis - initial version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, IH, THISYEAR, THISMONTH + INTEGER :: WEEKDAY, DAY_NUM, DOYT + INTEGER :: L, HH, KLM, SPECIES_ID(18), ID, MN + INTEGER :: OFFLINE_ID(15), SNo + INTEGER :: fId1, fId1b, fId1c, fId1d + INTEGER :: fId2, fId2b, fId2c, fId2d ! netCDF file ID + REAL*4 :: ARRAYWD(IIPAR,JJPAR,24) + REAL*4 :: ARRAYWE(IIPAR,JJPAR,24) + REAL*4 :: ARRAYWDPT(2,IIPAR,JJPAR,24) + REAL*4 :: ARRAYWEPT(2,IIPAR,JJPAR,24) + REAL*4 :: ARRAYWDPTN(3,IIPAR,JJPAR,24) + REAL*4 :: ARRAYWEPTN(3,IIPAR,JJPAR,24) + REAL*4 :: ARRAYWDC3(IIPAR,JJPAR,24) + REAL*4 :: ARRAYWEC3(IIPAR,JJPAR,24) + REAL*8 :: GEOS_NATIVEWD(IIPAR,JJPAR,3,24) + REAL*8 :: GEOS_NATIVEWE(IIPAR,JJPAR,3,24) + REAL*4 :: ScCO, ScNOx, ScSO2, ScNH3, ScPM10 + REAL*4 :: ScPM25, ScVOC + CHARACTER(LEN=255) :: DATA_DIR_NEI + CHARACTER(LEN=255) :: FILENAMEWD, FILENAMEWE + CHARACTER(LEN=255) :: FILENAMEWDPT, FILENAMEWEPT + CHARACTER(LEN=255) :: FILENAMEWDPTN, FILENAMEWEPTN + CHARACTER(LEN=255) :: FILENAMEWDC3, FILENAMEWEC3 + CHARACTER(LEN=24) :: SPCLIST(18) + CHARACTER(LEN=4) :: SYEAR, SId + CHARACTER(LEN=5) :: SNAME + CHARACTER(LEN=1) :: SSMN + CHARACTER(LEN=2) :: SMN + CHARACTER(LEN=3) :: TTMON + + !fp (for SD domain) +#if defined( NESTED_SD ) + + INTEGER, PARAMETER :: ini_lon = 22 + INTEGER, PARAMETER :: ini_lat = 7 + +#else + + INTEGER, PARAMETER :: ini_lon = 1 + INTEGER, PARAMETER :: ini_lat = 1 + +#endif + + + !================================================================= + ! EMISS_NEI2008_ANTHRO begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + CALL INIT_NEI2008_ANTHRO + FIRST = .FALSE. + ENDIF + + ! Get emissions year + THISYEAR = GET_YEAR() + + ! Get month + THISMONTH = GET_MONTH() + WRITE(*,*) 'MONTH', THISMONTH + +#if defined( GEOS_5 ) || defined( MERRA ) || defined( GEOS_FP ) + SNAME = 'GEOS5' +#elif defined( GEOS_4 ) + SNAME = 'GEOS4' +#endif + + SPECIES_ID = (/ IDTCO, IDTNOX, IDTNOX, IDTNOX, & + IDTSO2, IDTNH3, IDTALD2, IDTRCHO, IDTC2H6, & + IDTPRPE, IDTALK4, IDTSO4, IDTCH2O, IDTOCPO, & + IDTBCPO, IDTTOLU, IDTXYLE, IDTBENZ/)!, IDTC2H4/) + ! IDTMOH, IDTEOH,IDTCH4/) + + SPCLIST = (/ 'CO', 'NO', 'NO2', 'HNO2', 'SO2', 'NH3', & + 'ALD2','RCHO', 'C2H6', 'PRPE', 'ALK4', 'SO4', & + 'CH2O', 'OC', 'BC','TOLU','XYLE', 'BENZ'/)!, & + ! 'C2H4'/)!,'MOH', 'EOH','CH4' /) + + ! ID #'s for that are not tied to IDTxxxx flags + OFFLINE_ID = (/ 2, 1, 64, 66, 26, 30, 11, 12, & + 21, 18, 5, 27, 20, 36, 37 /) + +! Fabien's fix (hml, 10/14/13) +#if defined( GRID05x0666 ) + ! DataDir for year + IF (THISYEAR .lt. 2010 ) THEN + !force 2010 (fp) + THISYEAR = 2010 + ENDIF + + DATA_DIR_NEI = TRIM(DATA_DIR) // 'NEI2008_201307/NEI08_2010_05x667_' + + ! model ready +! DATA_DIR_NEI = TRIM(DATA_DIR) // 'NEI2008_201307/NEI08_2006_05x667_' +! ELSEIF (THISYEAR .ge. 2010) THEN +! ! model ready +! DATA_DIR_NEI = TRIM(DATA_DIR) // 'NEI2008_201307/NEI08_2010_05x667_' +! ENDIF + +#elif defined( GRID025x03125) + ! DataDir for year + ! model ready + DATA_DIR_NEI = '/as/data/geos/GEOS_0.25x0.3125_NA/' // & + 'NEI2008_201307/NEI08_2010_25x3125_' + WRITE(*,*) 'DATA ONLY AVAILABLE AT 25x3125 FOR 2010' + IF (THISYEAR .lt. 2010) THEN + THISYEAR = 2010 + ENDIF +#endif + + ! Loop over species + DO KLM = 1, SIZE( SPECIES_ID ) + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + SId = SPCLIST( KLM ) + SNo = SPECIES_ID( KLM ) + ELSE + SNo = OFFLINE_ID( KLM ) + ENDIF + + ! Skip undefined tracers + IF ( SNo == 0 ) CYCLE + + ! GET NEI2008 FILES! 1 for wday, 1 for wkend + IF (THISMONTH == 1) THEN + TTMON = 'Jan' + ELSEIF (THISMONTH == 2) THEN + TTMON = 'Feb' + ELSEIF (THISMONTH == 3) THEN + TTMON = 'Mar' + ELSEIF (THISMONTH == 4) THEN + TTMON = 'Apr' + ELSEIF (THISMONTH == 5) THEN + TTMON = 'May' + ELSEIF (THISMONTH == 6) THEN + TTMON = 'Jun' + ELSEIF (THISMONTH == 7) THEN + TTMON = 'Jul' + ELSEIF (THISMONTH == 8) THEN + TTMON = 'Aug' + ELSEIF (THISMONTH == 9) THEN + TTMON = 'Sep' + ELSEIF (THISMONTH == 10) THEN + TTMON = 'Oct' + ELSEIF (THISMONTH == 11) THEN + TTMON = 'Nov' + ELSEIF (THISMONTH == 12) THEN + TTMON = 'Dec' + ENDIF + + ! model ready + FILENAMEWD = TRIM(DATA_DIR_NEI) // & + TRIM(TTMON) // '_wkday_regrid.nc' + FILENAMEWE = TRIM(DATA_DIR_NEI) // & + TRIM(TTMON) // '_wkend_regrid.nc' + ! ptipm + FILENAMEWDPT = TRIM(DATA_DIR_NEI) // 'ptipm_' // & + TRIM(TTMON) // '_wkday_regrid.nc' + FILENAMEWEPT = TRIM(DATA_DIR_NEI) // 'ptipm_' // & + TRIM(TTMON) // '_wkend_regrid.nc' + ! ptnonipm + FILENAMEWDPTN = TRIM(DATA_DIR_NEI) // 'ptnonipm_' // & + TRIM(TTMON) // '_wkday_regrid.nc' + FILENAMEWEPTN = TRIM(DATA_DIR_NEI) // 'ptnonipm_' // & + TRIM(TTMON) // '_wkend_regrid.nc' + ! c3marine + FILENAMEWDC3 = TRIM(DATA_DIR_NEI) // 'c3marine_' // & + TRIM(TTMON) // '_wkday_regrid.nc' + FILENAMEWEC3= TRIM(DATA_DIR_NEI) // 'c3marine_' // & + TRIM(TTMON) // '_wkend_regrid.nc' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAMEWD ) + WRITE( 6, 100 ) TRIM( FILENAMEWE ) + 100 FORMAT( ' - EMISS_NEI2008_ANTHRO_NATIVE: & + Reading ', a ) + ! Called once per month by emissions_mod.F + + ! Open and read model_ready data from netCDF file - wkday + CALL Ncop_Rd(fId1, TRIM(FILENAMEWD)) + ! Open and read ptipm data from netCDF file - wkday + CALL Ncop_Rd(fId1b, TRIM(FILENAMEWDPT)) + ! Open and read ptnonipm data from netCDF file - wkday + CALL Ncop_Rd(fId1c, TRIM(FILENAMEWDPTN)) + ! Open and read c3marine data from netCDF file - wkday + CALL Ncop_Rd(fId1d, TRIM(FILENAMEWDC3)) + + !----WKDAY------- + Call NcRd(ARRAYWD, fId1, TRIM(SId), & + (/ ini_lon, ini_lat, 1 /), & !Start + (/ IIPAR, JJPAR, 24 /) ) !Count lat/lon/time + Call NcRd(ARRAYWDPT, fId1b, TRIM(SId), & + (/ 1, ini_lon, ini_lat, 1 /), & !Start + (/ 2, IIPAR, JJPAR, 24 /) ) !Count lat/lon/time/lev + Call NcRd(ARRAYWDPTN, fId1c, TRIM(SId), & + (/ 1, ini_lon, ini_lat, 1 /), & !Start + (/ 3, IIPAR, JJPAR, 24 /) ) !Count lat/lon/time/lev + Call NcRd(ARRAYWDC3, fId1d, TRIM(SId), & + (/ ini_lon, ini_lat, 1 /), & !Start + (/ IIPAR, JJPAR, 24 /) ) !Count lat/lon/time + ! Close netCDF file + CALL NcCl( fId1 ) + CALL NcCl( fId1b ) + CALL NcCl( fId1c ) + CALL NcCl( fId1d ) + + ! Cast to REAL*8 before regridding + GEOS_NATIVEWD(:,:,1,:) = ARRAYWD(:,:,:)+ARRAYWDPT(1,:,:,:) + & + ARRAYWDPTN(1,:,:,:)+ARRAYWDC3(:,:,:) + GEOS_NATIVEWD(:,:,2,:) = ARRAYWDPT(2,:,:,:) + ARRAYWDPTN(2,:,:,:) + GEOS_NATIVEWD(:,:,3,:) = ARRAYWDPTN(3,:,:,:) + + ! ELSE + ! Open and read data from netCDF file - wkend + CALL Ncop_Rd(fId2, TRIM(FILENAMEWE)) + CALL Ncop_Rd(fId2b, TRIM(FILENAMEWEPT)) + CALL Ncop_Rd(fId2c, TRIM(FILENAMEWEPTN)) + CALL Ncop_Rd(fId2d, TRIM(FILENAMEWEC3)) + + ! Get variable / SNo + !----WEEKEND------- + Call NcRd(ARRAYWE,fId2,TRIM(SId), & + (/ini_lon, ini_lat, 1/), & !Start + (/IIPAR, JJPAR, 24/) ) !Count + Call NcRd(ARRAYWEPT, fId2b, TRIM(SId), & + (/ 1, ini_lon, ini_lat, 1 /), & !Start + (/ 2, IIPAR, JJPAR, 24 /) ) !Count lat/lon/time/lev + Call NcRd(ARRAYWEPTN, fId2c, TRIM(SId), & + (/ 1, ini_lon, ini_lat, 1 /), & !Start + (/ 3, IIPAR, JJPAR, 24 /) ) !Count lat/lon/time/lev + Call NcRd(ARRAYWEC3, fId2d, TRIM(SId), & + (/ ini_lon, ini_lat, 1 /), & !Start + (/ IIPAR, JJPAR, 24 /) ) !Count lat/lon/time + CALL NcCl( fId2 ) + CALL NcCl( fId2b ) + CALL NcCl( fId2c ) + CALL NcCl( fId2d ) + ! Cast to REAL*8 before regridding + GEOS_NATIVEWE(:,:,1,:) = ARRAYWE(:,:,:)+ARRAYWEPT(1,:,:,:) + & + ARRAYWEPTN(1,:,:,:)+ARRAYWEC3(:,:,:) + GEOS_NATIVEWE(:,:,2,:) = ARRAYWEPT(2,:,:,:) + ARRAYWEPTN(2,:,:,:) + GEOS_NATIVEWE(:,:,3,:) = ARRAYWEPTN(3,:,:,:) + !ENDIF + + ! Get variable / SNo + ! Apply annual scalar factor. Available for 1985-2005, + ! and NOx, CO and SO2 only. + ! Initialize scaling factors + ScCO = 1.0 + ScNOx = 1.0 + ScPM10 = 1.0 + ScPM25 = 1.0 + ScSO2 = 1.0 + ScVOC = 1.0 + ScNH3 = 1.0 + ! Apply annual scalar factor. + ! Using EPA's National Tier1 CAPS (http://www.epa.gov/ttnchie1/trends/) + IF (THISYEAR .eq. 2007) THEN !Scale based on 2006 + ScCO = 0.939 + ScNOx = 0.966 + ScPM10 = 1.001 + ScSO2 = 0.887 + ScPM25 = 1.016 + ScVOC = 0.996 + ScNH3 = 1.018 + ELSEIF (THISYEAR .eq. 2008) THEN !Scale based on 2006 + ScCO = 0.877 + ScNOx = 0.933 + ScPM10 = 1.003 + ScPM25 = 1.092 + ScSO2 = 0.775 + ScVOC = 0.933 + ScNH3 = 1.035 + ELSEIF (THISYEAR .eq. 2009) THEN !Scale based on 2006 + ScCO = 0.854 + ScNOx = 0.850 + ScPM10 = 1.002 + ScPM25 = 1.088 + ScSO2 = 0.619 + ScVOC = 0.919 + ScNH3 = 1.033 + ELSEIF (THISYEAR .eq. 2011) THEN !Scale based on 2010 + ScCO = 0.916 + ScNOx = 0.897 + ScPM10 = 0.998 + ScPM25 = 0.990 + ScSO2 = 0.905 + ScVOC = 0.955 + ScNH3 = 0.996 + ELSEIF (THISYEAR .ge. 2012) THEN !Scale based on 2010 + ScCO = 0.820 + ScNOx = 0.773 + ScPM10 = 0.995 + ScPM25 = 0.979 + ScSO2 = 0.725 + ScVOC = 0.905 + ScNH3 = 0.991 + ENDIF + + DO L=1,3 + DO HH=1,24 ! check on whether this is correct + SELECT CASE ( SId) + CASE ('CO') + GEOS_NATIVEWD(:,:,L,HH) = GEOS_NATIVEWD(:,:,L,HH) * ScCO + GEOS_NATIVEWE(:,:,L,HH) = GEOS_NATIVEWE(:,:,L,HH) * ScCO + CASE ('NO','NO2','HNO2') + GEOS_NATIVEWD(:,:,L,HH) = GEOS_NATIVEWD(:,:,L,HH) * ScNOx + GEOS_NATIVEWE(:,:,L,HH) = GEOS_NATIVEWE(:,:,L,HH) * ScNOx + CASE ('BENZ','TOLU','XYLE','RCHO','CH2O','ALD2','C2H6','PRPE','ALK4') + GEOS_NATIVEWD(:,:,L,HH) = GEOS_NATIVEWD(:,:,L,HH) * ScVOC + GEOS_NATIVEWE(:,:,L,HH) = GEOS_NATIVEWE(:,:,L,HH) * ScVOC + CASE('BC','OC') + GEOS_NATIVEWD(:,:,L,HH) = GEOS_NATIVEWD(:,:,L,HH) * ScPM25 + GEOS_NATIVEWE(:,:,L,HH) = GEOS_NATIVEWE(:,:,L,HH) * ScPM25 + CASE('SO2') + GEOS_NATIVEWD(:,:,L,HH) = GEOS_NATIVEWD(:,:,L,HH) * ScSO2 + GEOS_NATIVEWE(:,:,L,HH) = GEOS_NATIVEWE(:,:,L,HH) * ScSO2 + CASE ('NH3') + GEOS_NATIVEWD(:,:,L,HH) = GEOS_NATIVEWD(:,:,L,HH) * ScNH3 + GEOS_NATIVEWE(:,:,L,HH) = GEOS_NATIVEWE(:,:,L,HH) * ScNH3 + END SELECT + ENDDO + ENDDO + + ! Begin loopthrough tracers + IF ( SId .eq. 'CO') THEN !CO + CO_WKEND(:,:,:,:) = GEOS_NATIVEWE !CO + CO(:,:,:,:) = GEOS_NATIVEWD + ELSEIF ( SId .eq. 'NO') THEN !NO + NO(:,:,:,:) = GEOS_NATIVEWD + NO_WKEND(:,:,:,:) = GEOS_NATIVEWE !NO + ELSEIF ( SId .eq. 'NO2') THEN !NO2 + NO2(:,:,:,:) = GEOS_NATIVEWD + NO2_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'HNO2') THEN !HNO2 + HNO2(:,:,:,:) = GEOS_NATIVEWD + HNO2_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'SO2') THEN !SO2 + SO2(:,:,:,:) = GEOS_NATIVEWD + SO2_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'NH3') THEN !NH3 + NH3(:,:,:,:) = GEOS_NATIVEWD + NH3_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'ALD2') THEN !ALD2 + ALD2(:,:,:,:) = GEOS_NATIVEWD + ALD2_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'RCHO') THEN !RCHO + RCHO(:,:,:,:) = GEOS_NATIVEWD + RCHO_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'C2H6') THEN !C2H6 + C2H6(:,:,:,:) = GEOS_NATIVEWD + C2H6_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'PRPE' ) THEN !PRPE + PRPE(:,:,:,:) = GEOS_NATIVEWD + PRPE_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'ALK4' ) THEN !ALK4 + ALK4(:,:,:,:) = GEOS_NATIVEWD + ALK4_WKEND(:,:,:,:) = GEOS_NATIVEWE + !ELSEIF ( SId .eq. 'C2H4' ) THEN !C2H4 + ! C2H4(:,:,:,:) = GEOS_NATIVEWD + ! C2H4_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'BENZ' ) THEN !BENZ + BENZ(:,:,:,:) = GEOS_NATIVEWD + BENZ_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'TOLU' ) THEN !TOLU + TOLU(:,:,:,:) = GEOS_NATIVEWD + TOLU_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'XYLE') THEN !XYLE + XYLE(:,:,:,:) = GEOS_NATIVEWD + XYLE_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'SO4') THEN !SO4 + SO4(:,:,:,:) = GEOS_NATIVEWD + SO4_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'CH2O') THEN !CH2O + CH2O(:,:,:,:) = GEOS_NATIVEWD + CH2O_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'OCPO') THEN !OCPO + OCPO(:,:,:,:) = GEOS_NATIVEWD + OCPO_WKEND(:,:,:,:) = GEOS_NATIVEWE + ELSEIF ( SId .eq. 'BCPO') THEN !BCPO + BCPO(:,:,:,:) = GEOS_NATIVEWD + BCPO_WKEND(:,:,:,:) = GEOS_NATIVEWE + !ELSEIF ( SId .eq. 'MOH') THEN !MOH + ! MOH(:,:,:,:) = GEOS_NATIVEWD + ! MOH_WKEND(:,:,:,:) = GEOS_NATIVEWE + !ELSEIF ( SId .eq. 'EOH') THEN !EOH + ! EOH(:,:,:,:) = GEOS_NATIVEWD + ! EOH_WKEND(:,:,:,:) = GEOS_NATIVEWE + !ELSEIF ( SId .eq. 'CH4') THEN !CH4 + ! CH4(:,:,:,:) = GEOS_NATIVEWD + ! CH4_WKEND(:,:,L,HH) = GEOS_NATIVEWE + ENDIF ! END LOOP THROUGH WKEND/WKDAY + + ENDDO + + + !-------------------------- + ! Compute future emissions + !-------------------------- + IF ( LFUTURE ) THEN + CALL NEI2008_SCALE_FUTURE + ENDIF + + !-------------------------- + ! Print emission totals + !-------------------------- + + CALL TOTAL_ANTHRO_Tg( THISMONTH ) + + ! Return to calling program + END SUBROUTINE EMISS_NEI2008_ANTHRO_NATIVE + +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: read_nei2008_mask +! +! !DESCRIPTION: Subroutine READ\_NEI2008\_MASK reads the mask for NEI data +!\\ +!\\ +! !INTERFACE: + + SUBROUTINE READ_NEI2008_MASK +! +! !USES: +! + ! Reference to F90 modules + USE BPCH2_MOD, ONLY : GET_NAME_EXT_2D, GET_RES_EXT + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE LOGICAL_MOD, ONLY : LCAC, LBRAVO + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1, DATA_DIR + USE REGRID_A2A_MOD, ONLY : DO_REGRID_A2A + USE TRANSFER_MOD, ONLY : TRANSFER_2D + + USE m_netcdf_io_open + USE m_netcdf_io_read + USE m_netcdf_io_readattr + USE m_netcdf_io_close + USE m_netcdf_io_get_dimlen + +# include "CMN_SIZE" ! Size parameters + +! +! !REMARKS: +! +! !REVISION HISTORY: +! 20 Oct 2009 - P. Le Sager - init +! 26 Oct 2009 - P. Le Sager - new masks +! 13 Mar 2012 - M. Cooper - Changed regrid algorithm to map_a2a +! 24 May 2012 - R. Yantosca - Fixed minor bugs in map_a2a implementation +! 15 Aug 2012 - M. Payer - Fixed minor bugs in regridding of mask; Also +! set mask to 1 if greater than 0 (L. Murray) +! 24 Aug 2012 - R. Yantosca - DO_REGRID_A2A now reads netCDF input file +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*4 :: ARRAY2(I1x1,J1x1) + REAL*8, TARGET :: GEOS_1x1(I1x1,J1x1) + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: LLFILENAME + REAL*8, POINTER :: INGRID(:,:) => NULL() + INTEGER :: st2d(2), ct2d(2) + INTEGER :: fId1 + !================================================================= + ! Mask specific to NEI2008 data + !================================================================= + + !SNAME = 'usa.' + + ! NEI2008 covers CANADA if we do not use CAC + !IF ( .NOT. LCAC ) SNAME = TRIM( SNAME ) // 'can.' + + ! NEI2008 covers Mexico if we do not use BRAVO + !IF ( .NOT. LBRAVO ) SNAME = TRIM( SNAME ) // 'mex.' + + !fp + !FILENAME = '/as/home/ktravis/' // & + ! 'usa.mask.nei2008.geos.1x1.nc' + + FILENAME = TRIM(DATA_DIR_1x1) // & + 'NEI2008_201307/usa.mask.nei2008.geos.1x1.nc' + + ! Echo info + WRITE( 6, 200 ) TRIM( FILENAME ) +200 FORMAT( ' - READ_NEI2008_MASK: Reading ', a ) + + ! Allocate start and count arrays + st2d = (/1, 1/) + ct2d = (/I1x1, J1x1/) + ! Open and read model_ready data from netCDF file - wkday + CALL Ncop_Rd(fId1, TRIM(FILENAME)) + Call NcRd(ARRAY2, fId1, 'MASK', & + st2d, ct2d ) !Start andCount lat/lon + ! Close netCDF file + CALL NcCl( fId1 ) + + ! Cast to REAL*8 before regridding + GEOS_1x1(:,:) = ARRAY2(:,:) + + ! File with lat/lon edges for regridding + LLFILENAME = TRIM( DATA_DIR_1x1) // & + 'MAP_A2A_Regrid_201203/MAP_A2A_latlon_geos1x1.nc' + ! Regrid from GEOS 1x1 --> current model resolution [unitless] + INGRID => GEOS_1x1(:,:) + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1, & + INGRID, USA_MASK, IS_MASS=0, & + netCDF=.TRUE. ) + + ! Free pointer + NULLIFY( INGRID ) + + WHERE ( USA_MASK > 0D0 ) USA_MASK = 1D0 + ! Return to calling program + END SUBROUTINE READ_NEI2008_MASK +!------------------------------------------------------------------------------ +! Prior to 12/3/09: +! Leave for future use (bmy, 12/3/09) +!!EOC +!!------------------------------------------------------------------------------ +!! Harvard University Atmospheric Chemistry Modeling Group ! +!!------------------------------------------------------------------------------ +!!BOP +!! +!! !IROUTINE: get_nei2005_mask +!! +!! !DESCRIPTION: Subroutine GET\_NEI2005\_MASK returns the value of the +!! NEI 2005 mask to the calling program. Values of 1 denote grid boxes +!! within the EPA/NEI2005 emission region.! +!!\\ +!!\\ +!! !INTERFACE: +! +! FUNCTION GET_NEI2005_MASK( I, J ) RESULT ( USA ) +!! +!! !INPUT PARAMETERS: +!! +! INTEGER, INTENT(IN) :: I, J ! GEOS-Chem lon & lat indices +!! +!! !RETURN VALUE: +!! +! REAL*8 :: USA ! Value of the mask +!! +!! !REMARKS: +!! This is entended to encapsulate the USA_MASK variable. +!! +!! !REVISION HISTORY: +!! 02 Dec 2009 - R. Yantosca - Initial version +!!EOP +!!------------------------------------------------------------------------------ +!!BOC +!! +!! !LOCAL VARIABLES: +!! +! USA = USA_MASK(I,J) +! +! END FUNCTION GET_NEI2005_MASK +!------------------------------------------------------------------------------ +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: nei2008_scale_future +! +! !DESCRIPTION: Subroutine NEI2008\_SCALE\_FUTURE applies the IPCC future +! scale factors to the NEI2008 anthropogenic emissions. +!\\ +!\\ +! !INTERFACE: + + SUBROUTINE NEI2008_SCALE_FUTURE +! +! !USES: +! + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_COff + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NH3an + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NOxff + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_SO2ff + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_OCff + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_BCff + +# include "CMN_SIZE" ! Size parameters +! +! !REMARKS: +! VOC are not scaled, however scale factors are available (see +! epa_nei_mod.f for procedure) +! +! !REVISION HISTORY: +! 7 Oct 2009 - A. van Donkelaar - initial version +! 20 Oct 2009 - P. Le Sager - set L OpenMP private, put L loop first +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: I, J, L, HH + + !================================================================= + ! NEI2008_SCALE_FUTURE begins here! + !================================================================= + +!$OMP PARALLEL DO + + DO J = 1, JJPAR + DO I = 1, IIPAR + DO L = 1,3 + DO HH=1,24 + ! Future NO2 [molec/cm2/s] + NO2(I,J,L,HH) = NO2(I,J,L,HH) * GET_FUTURE_SCALE_NOxff( I, J ) + + ! Future CO [molec/cm2/s] + CO(I,J,L,HH) = CO(I,J,L,HH) * GET_FUTURE_SCALE_COff( I, J ) + + ! Future SO2 [molec/cm2/s] + SO2(I,J,L,HH) = SO2(I,J,L,HH) * GET_FUTURE_SCALE_SO2ff( I, J ) + + ! Future SO4 [molec/cm2/s] + SO4(I,J,L,HH) = SO4(I,J,L,HH) * GET_FUTURE_SCALE_SO2ff( I, J ) + + ! Future NH3 [molec/cm2/s] + NH3(I,J,L,HH) = NH3(I,J,L,HH) * GET_FUTURE_SCALE_NH3an( I, J ) + + ! Future OC [molec/cm2/s] + OCPO(I,J,L,HH) = OCPO(I,J,L,HH) * GET_FUTURE_SCALE_OCff( I, J ) + + ! Future BC [molec/cm2/s] + BCPO(I,J,L,HH) = BCPO(I,J,L,HH) * GET_FUTURE_SCALE_BCff( I, J ) + + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE NEI2008_SCALE_FUTURE +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: total_anthro_Tg +! +! !DESCRIPTION: Subroutine TOTAL\_ANTHRO\_TG prints the totals for the +! anthropogenic emissions of NOx, CO, SO2 and NH3. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE TOTAL_ANTHRO_TG( MONTH ) +! +! !USES: +! + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTCO, IDTNO,IDTNO2, IDTHNO2 + USE TRACERID_MOD, ONLY : IDTSO2, IDTNH3, IDTNOX + USE TRACERID_MOD, ONLY : IDTALD2, IDTRCHO, IDTC2H6 + USE TRACERID_MOD, ONLY : IDTPRPE, IDTALK4!, IDTC2H4 + USE TRACERID_MOD, ONLY : IDTBENZ, IDTTOLU, IDTXYLE + USE TRACERID_MOD, ONLY : IDTSO4, IDTCH2O + USE TRACERID_MOD, ONLY : IDTOCPO, IDTBCPO + !USE TRACERID_MOD, ONLY : IDTMOH, IDTEOH, IDTCH4 + +# include "CMN_SIZE" ! Size parameters + +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: MONTH ! Month of data to compute totals +! +! !REVISION HISTORY: +! 7 Oct 2009 - A. van Donkelaar - initial version +! 9 May 2013 - K. Travis - revised for NEI2008 +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: II, JJ, IH, LL + INTEGER :: DAY_LIST(12), DL + REAL*8 :: T_CO, T_NO, T_NO2, T_HNO2, T_SO2, T_NH3 + REAL*8 :: T_ALD2, T_RCHO, T_C2H6 + REAL*8 :: T_PRPE, T_ALK4, T_TOLU, T_XYLE + REAL*8 :: T_CH2O,T_BC, T_OC, T_SO4 + REAL*8 :: T_BENZ!, T_C2H4 + REAL*8 :: T_NOX ! fp + REAL*8 :: tmpArea(IIPAR, JJPAR,3) + REAL*4 :: WDFRAC, WEFRAC + CHARACTER(LEN=3) :: UNIT + REAL*8, PARAMETER :: SEC_IN_HOUR = 3600d0! * 365.25d0 + + !================================================================= + ! TOTAL_ANTHRO_TG begins here! + !================================================================= + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, 100 ) + 100 FORMAT( 'N. E. I. 2008 U. S. A. E M I S S I O N S', / ) + + DO II = 1, IIPAR + DO JJ = 1, JJPAR + DO LL=1, 3 + tmpArea(II,JJ,LL) = GET_AREA_CM2(JJ) + ENDDO + ENDDO + ENDDO + + T_CO = 0d0 + T_NOx = 0d0 + T_NO = 0d0 + T_NO2 = 0d0 + T_HNO2 = 0d0 + T_SO2 = 0d0 + T_NH3 = 0d0 + T_ALD2 = 0d0 + T_RCHO = 0d0 + T_BENZ = 0d0 + T_C2H6 = 0d0 + T_PRPE = 0d0 + T_TOLU = 0d0 + T_XYLE = 0d0 + + ! J, F, M, A, Ma, Ju, J, Au, Se, Oc, No, Dec + !DAY_LIST = (/31,28,31,30,31,30,31,31,30,31,30,31/) + !DL = DAY_LIST(MONTH) + ! Annual average weekends and weekdays + WDFRAC = 21.7d0 + WEFRAC = 8.7d0 + + WRITE(6,101) WDFRAC + 101 FORMAT('WEEKDAY FRACTION = ', f11.4) + + ! Total CO [Tg CO] + IF ( IDTCO .NE. 0 ) & + T_CO = SUM(SUM( CO,4) * tmpArea ) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTCO)* WDFRAC + & + SUM(SUM( CO_WKEND,4) * tmpArea ) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTCO) * WEFRAC + + ! Total NOX [Tg N] + IF ( IDTNOx .NE. 0 ) & + T_NOx = SUM(SUM( NO+NO2+HNO2,4) * tmpArea ) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTNOx) * 14/46 * WDFRAC + & + SUM(SUM( NO_WKEND+NO2_WKEND+HNO2_WKEND,4) * tmpArea ) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTNOx) * 14/46 * WEFRAC + + IF ( IDTNO .NE. 0 ) & + ! Total NOX [Tg N] + T_NO = SUM(SUM(NO, 4)*tmpArea ) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTNO)*14/30 * WDFRAC + & + SUM(SUM(NO_WKEND, 4)*tmpArea ) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTNO)*14/30 * WEFRAC + + IF ( IDTNO2 .NE. 0 ) & + ! Total NO2 [Tg N] + T_NO2 = SUM(SUM( NO2, 4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTNO2)*14/46 * WDFRAC + & + SUM(SUM( NO2_WKEND, 4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTNO2)*14/46 * WEFRAC + + IF ( IDTHNO2 .NE. 0 ) & + ! Total HNO2 [Tg N] + T_HNO2 = SUM(SUM( HNO2,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTHNO2)*14/47 * WDFRAC + & + SUM(SUM( HNO2_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTHNO2)*14/47 * WEFRAC + + ! Total SO2 [Tg S] + IF ( IDTSO2 .NE. 0 ) & + T_SO2 = SUM( SUM( SO2,4) * tmpArea )* & + SEC_IN_HOUR *1d-9/XNUMOL(IDTSO2) * WDFRAC + & + SUM(SUM( SO2_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTSO2) * WEFRAC + + ! Total NH3 [Tg NH3] + IF ( IDTNH3 .NE. 0 ) & + T_NH3 = SUM( SUM( NH3,4) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTNH3) * WDFRAC + & + SUM(SUM( NH3_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTNH3) * WEFRAC + + ! Total ALD2 [Tg C] + IF ( IDTALD2 .NE. 0 ) & + T_ALD2 = SUM( SUM( ALD2,4) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTALD2) * WDFRAC + & + SUM(SUM( ALD2_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTALD2) * WEFRAC +! WRITE(*,*) XNUMOL(IDTALD2) + + ! Total RCHO [Tg C] + IF ( IDTRCHO .NE. 0 ) & + T_RCHO = SUM( SUM( RCHO,4) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTRCHO) * WDFRAC + & + SUM(SUM( RCHO_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTRCHO) * WEFRAC + + ! Total BENZ [Tg C] + IF ( IDTBENZ .NE. 0 ) & + T_BENZ = SUM( SUM( BENZ,4) * tmpArea )* & + SEC_IN_HOUR *1d-9/XNUMOL(IDTBENZ) * WDFRAC + & + SUM(SUM( BENZ_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTBENZ) * WEFRAC + + ! Total C2H6 [Tg C] + IF ( IDTC2H6 .NE. 0 ) & + T_C2H6 = SUM( SUM( C2H6,4) * tmpArea )* & + SEC_IN_HOUR *1d-9/XNUMOL(IDTC2H6) * WDFRAC + & + SUM(SUM( C2H6_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTC2H6) * WEFRAC +! WRITE(*,*) XNUMOL(IDTC2H6) + + ! Total PRPE [Tg C] + IF ( IDTPRPE .NE. 0 ) & + T_PRPE = SUM( SUM( PRPE,4) * tmpArea )* & + SEC_IN_HOUR *1d-9/XNUMOL(IDTPRPE) * WDFRAC + & + SUM(SUM( PRPE_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTPRPE) * WEFRAC +! WRITE(*,*) XNUMOL(IDTPRPE) + + ! Total ALK4 [Tg C] + IF ( IDTALK4 .NE. 0 ) & + T_ALK4 = SUM( SUM( ALK4,4) * tmpArea )* & + SEC_IN_HOUR *1d-9/XNUMOL(IDTALK4) * WDFRAC + & + SUM(SUM( ALK4_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTALK4)* WEFRAC +! WRITE(*,*) XNUMOL(IDTALK4) + + ! Total TOLU [Tg C] + IF ( IDTTOLU .NE. 0 ) & + T_TOLU = SUM( SUM( TOLU,4) *tmpArea )* & + SEC_IN_HOUR *1d-9/XNUMOL(IDTTOLU) * WDFRAC + & + SUM(SUM( TOLU_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTTOLU) * WEFRAC + + ! Total XYLE [Tg C] + IF ( IDTXYLE .NE. 0 ) & + T_XYLE = SUM( SUM( XYLE,4) * tmpArea )* & + SEC_IN_HOUR *1d-9/XNUMOL(IDTXYLE) * WDFRAC + & + SUM(SUM( XYLE_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTXYLE) * WEFRAC + + ! Total C2H4 [Tg C] + !T_C2H4 = SUM( C2H4 * tmpArea )* & + ! SEC_IN_HOUR *1d-9/XNUMOL(IDTC2H4) * WDFRAC + & + ! SUM(SUM( C2H4_WKEND,4 ) * tmpArea) * & + ! SEC_IN_HOUR *1d-12/XNUMOL(C2H4)*14/47 * WEFRAC + + ! Total CH2O [Tg C] + IF ( IDTCH2O .NE. 0 ) & + T_CH2O = SUM( SUM( CH2O,4) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTCH2O) * WDFRAC + & + SUM(SUM( CH2O_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-9/XNUMOL(IDTCH2O) * WEFRAC + + ! Total BC [Tg] + IF ( IDTBCPO .NE. 0 ) & + T_BC = SUM( SUM( BCPO,4) * tmpArea) * & + SEC_IN_HOUR *1d-12 * WDFRAC + & + SUM(SUM( BCPO_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-12 * WEFRAC + + ! Total OC [Tg] + IF ( IDTOCPO .NE. 0 ) & + T_OC = SUM( SUM( OCPO,4) * tmpArea )* & + SEC_IN_HOUR *1d-12 * WDFRAC + & + SUM(SUM( OCPO_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-12 * WEFRAC + + ! Total SO4 [Tg S] + IF ( IDTSO4 .NE. 0 ) & + T_SO4 = SUM( SUM( SO4,4) * tmpArea) * & + SEC_IN_HOUR *1d-12 * WDFRAC + & + SUM(SUM( SO4_WKEND,4 ) * tmpArea) * & + SEC_IN_HOUR *1d-12* WEFRAC + + ! Print totals in [Tg] + WRITE( 6, 110 ) 'CO ', MONTH, T_CO, '[Tg CO ]' + !fp for bckwd compatibility + IF ( IDTNOX .ne. 0 ) THEN + WRITE( 6, 110 ) 'NOX ', MONTH, T_NOX, '[Tg N ]' + ELSE + WRITE( 6, 110 ) 'NO ', MONTH, T_NO, '[Tg N ]' + WRITE( 6, 110 ) 'NO2 ', MONTH, T_NO2, '[Tg N ]' + WRITE( 6, 110 ) 'HNO2 ', MONTH, T_HNO2, '[Tg N ]' + ENDIF + WRITE( 6, 110 ) 'SO2 ', MONTH, T_SO2, '[Tg S]' + WRITE( 6, 110 ) 'NH3 ', MONTH, T_NH3, '[Tg NH3]' + WRITE( 6, 110 ) 'ALD2 ', MONTH, T_ALD2, '[Tg C]' + WRITE( 6, 110 ) 'RCHO ', MONTH, T_RCHO, '[Tg C]' + WRITE( 6, 110 ) 'BENZ ', MONTH, T_BENZ, '[Tg C]' + WRITE( 6, 110 ) 'C2H6 ', MONTH, T_C2H6, '[Tg C]' + WRITE( 6, 110 ) 'PRPE ', MONTH, T_PRPE, '[Tg C]' + WRITE( 6, 110 ) 'ALK4 ', MONTH, T_ALK4, '[Tg C]' + WRITE( 6, 110 ) 'TOLU ', MONTH, T_TOLU, '[Tg C]' + WRITE( 6, 110 ) 'XYLE ', MONTH, T_XYLE, '[Tg C]' + !WRITE( 6, 110 ) 'C2H4 ', MONTH, T_C2H4, '[Tg C]' + WRITE( 6, 110 ) 'CH2O ', MONTH, T_CH2O, '[Tg C]' + WRITE( 6, 110 ) 'BC ', MONTH, T_BC, '[Tg ]' + WRITE( 6, 110 ) 'OC ', MONTH, T_OC, '[Tg ]' + WRITE( 6, 110 ) 'SO4 ', MONTH, T_SO4, '[Tg S]' + + ! Format statement + 110 FORMAT( 'NEI2008 anthro ', a5, & + 'for month', i4, ': ', f11.4, 1x, a8 ) + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Return to calling program + END SUBROUTINE TOTAL_ANTHRO_Tg +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: init_nei2008_anthro +! +! !DESCRIPTION: Subroutine INIT\_NEI2008\_ANTHRO allocates and zeroes all +! module arrays. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE INIT_NEI2008_ANTHRO +! +! !USES: +! + USE ERROR_MOD, ONLY : ALLOC_ERR + USE LOGICAL_MOD, ONLY : LNEI08 + +# include "CMN_SIZE" ! Size parameters! + !EOP + !------------------------------------------------------------------------------ + !BOC + ! + ! !LOCAL VARIABLES: + ! + INTEGER :: RC, J + + !================================================================= + ! INIT_NEI2008_ANTHRO begins here! + !================================================================= + + ! Return if LNEI08 is false + IF ( .not. LNEI08 ) RETURN + + !-------------------------------------------------- + ! Allocate and zero arrays for emissions + !-------------------------------------------------- + + ! allocate and read USA Mask + ALLOCATE( USA_MASK( IIPAR, JJPAR ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'USA_MASK' ) + USA_MASK = 0d0 + + CALL READ_NEI2008_MASK + + ALLOCATE( CO( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'CO' ) + CO = 0d0 + + !ALLOCATE( NOX( IIPAR, JJPAR, 3, 24 ), STAT=RC) + !IF ( RC /= 0 ) CALL ALLOC_ERR( 'NOX' ) + !NOX = 0d0 + + ALLOCATE( NO( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'NO' ) + NO = 0d0 + + ALLOCATE( NO2( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'NO2' ) + NO2 = 0d0 + + ALLOCATE( HNO2( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'HNO2' ) + HNO2 = 0d0 + + ALLOCATE( SO2( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'SO2' ) + SO2 = 0d0 + + ALLOCATE( NH3( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'NH3' ) + NH3 = 0d0 + + ALLOCATE( ALD2( IIPAR, JJPAR, 3, 24), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'ALD2' ) + ALD2 = 0d0 + + ALLOCATE( RCHO( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'RCHO' ) + RCHO = 0d0 + + ALLOCATE( BENZ( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'BENZ' ) + BENZ = 0d0 + + ALLOCATE( C2H6( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'C2H6' ) + C2H6 = 0d0 + + ALLOCATE( PRPE( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'PRPE' ) + PRPE = 0d0 + + ALLOCATE( ALK4( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'ALK4' ) + ALK4 = 0d0 + + ALLOCATE( TOLU( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'TOLU' ) + TOLU = 0d0 + + ALLOCATE( XYLE( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'XYLE' ) + XYLE = 0d0 + + !ALLOCATE( C2H4( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + !IF ( RC /= 0 ) CALL ALLOC_ERR( 'C2H4' ) + !C2H4 = 0d0 + + ALLOCATE( CH2O( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'CH2O' ) + CH2O = 0d0 + + ALLOCATE( BCPO( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'BCPO' ) + BCPO = 0d0 + + ALLOCATE( OCPO( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'OCPO' ) + OCPO = 0d0 + + ALLOCATE( SO4( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'SO4' ) + SO4 = 0d0 + + !ALLOCATE( EOH( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + !IF ( RC /= 0 ) CALL ALLOC_ERR( 'EOH' ) + !EOH = 0d0 + + !ALLOCATE( MOH( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + !IF ( RC /= 0 ) CALL ALLOC_ERR( 'MOH' ) + !MOH = 0d0 + + !ALLOCATE( CH4( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + !IF ( RC /= 0 ) CALL ALLOC_ERR( 'CH4' ) + !CH4 = 0d0 + +! Weekend + + ALLOCATE( CO_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'CO_WKEND' ) + CO_WKEND = 0d0 + + !ALLOCATE( NOX_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + !IF ( RC /= 0 ) CALL ALLOC_ERR( 'NOX_WKEND' ) + !NOX_WKEND = 0d0 + + ALLOCATE( NO_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'NO_WKEND' ) + NO_WKEND = 0d0 + + ALLOCATE( NO2_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'NO2_WKEND' ) + NO2_WKEND = 0d0 + + ALLOCATE( HNO2_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'HNO2_WKEND' ) + HNO2_WKEND = 0d0 + + ALLOCATE( SO2_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'SO2_WKEND' ) + SO2_WKEND = 0d0 + + ALLOCATE( NH3_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'NH3_WKEND' ) + NH3_WKEND = 0d0 + + ALLOCATE( ALD2_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'ALD2_WKEND' ) + ALD2_WKEND = 0d0 + + ALLOCATE( RCHO_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'RCHO_WKEND' ) + RCHO_WKEND = 0d0 + + ALLOCATE( BENZ_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'BENZ_WKEND' ) + BENZ_WKEND = 0d0 + + ALLOCATE( C2H6_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'C2H6_WKEND' ) + C2H6_WKEND = 0d0 + + ALLOCATE( PRPE_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'PRPE_WKEND' ) + PRPE_WKEND = 0d0 + + ALLOCATE( ALK4_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'ALK4_WKEND' ) + ALK4_WKEND = 0d0 + + ALLOCATE( TOLU_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'TOLU_WKEND' ) + TOLU_WKEND = 0d0 + + ALLOCATE( XYLE_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'XYLE_WKEND' ) + XYLE_WKEND = 0d0 + + !ALLOCATE( C2H4_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + !IF ( RC /= 0 ) CALL ALLOC_ERR( 'C2H4_WKEND' ) + !C2H4_WKEND = 0d0 + + ALLOCATE( CH2O_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'CH2O_WKEND' ) + CH2O_WKEND = 0d0 + + ALLOCATE( BCPO_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'BCPO_WKEND' ) + BCPO_WKEND = 0d0 + + ALLOCATE( OCPO_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'OCPO_WKEND' ) + OCPO_WKEND = 0d0 + + ALLOCATE( SO4_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + IF ( RC /= 0 ) CALL ALLOC_ERR( 'SO4_WKEND' ) + SO4_WKEND = 0d0 + + !ALLOCATE( EOH_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + !IF ( RC /= 0 ) CALL ALLOC_ERR( 'EOH_WKEND' ) + !EOH_WKEND = 0d0 + + !ALLOCATE( MOH_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + !IF ( RC /= 0 ) CALL ALLOC_ERR( 'MOH_WKEND' ) + !MOH_WKEND = 0d0 + + !ALLOCATE( CH4_WKEND( IIPAR, JJPAR, 3, 24 ), STAT=RC ) + !IF ( RC /= 0 ) CALL ALLOC_ERR( 'CH4_WKEND' ) + !CH4_WKEND = 0d0 + + ! Return to calling program + END SUBROUTINE INIT_NEI2008_ANTHRO +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: cleanup_nei2008anthro +! +! !DESCRIPTION: Subroutine CLEANUP\_NEI2008\_ANTHRO deallocates all module +! arrays. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE CLEANUP_NEI2008_ANTHRO +! +! !REVISION HISTORY: +! 01 Mar 2012 - R. Yantosca - Remove reference to A_CM2 array +!EOP +!------------------------------------------------------------------------------ +!BOC + !================================================================= + ! CLEANUP_NEIO2008_ANTHRO begins here! + !================================================================= + ! USA mask + IF ( ALLOCATED( USA_MASK) ) DEALLOCATE( USA_MASK ) + IF ( ALLOCATED( CO ) ) DEALLOCATE( CO ) + !IF ( ALLOCATED( NOX ) ) DEALLOCATE( NOX ) + IF ( ALLOCATED( NO ) ) DEALLOCATE( NO ) + IF ( ALLOCATED( NO2 ) ) DEALLOCATE( NO2 ) + IF ( ALLOCATED( HNO2 ) ) DEALLOCATE( HNO2 ) + IF ( ALLOCATED( SO2 ) ) DEALLOCATE( SO2 ) + IF ( ALLOCATED( NH3 ) ) DEALLOCATE( NH3 ) + IF ( ALLOCATED( ALD2 ) ) DEALLOCATE( ALD2 ) + IF ( ALLOCATED( RCHO ) ) DEALLOCATE( RCHO ) + IF ( ALLOCATED( BENZ ) ) DEALLOCATE( BENZ ) + IF ( ALLOCATED( C2H6 ) ) DEALLOCATE( C2H6 ) + IF ( ALLOCATED( PRPE ) ) DEALLOCATE( PRPE ) + IF ( ALLOCATED( ALK4 ) ) DEALLOCATE( ALK4 ) + IF ( ALLOCATED( TOLU ) ) DEALLOCATE( TOLU ) + IF ( ALLOCATED( XYLE ) ) DEALLOCATE( XYLE ) + !IF ( ALLOCATED( C2H4 ) ) DEALLOCATE( C2H4 ) + IF ( ALLOCATED( CH2O ) ) DEALLOCATE( CH2O ) + IF ( ALLOCATED( BCPO ) ) DEALLOCATE( BCPO ) + IF ( ALLOCATED( OCPO ) ) DEALLOCATE( OCPO ) + IF ( ALLOCATED( SO4 ) ) DEALLOCATE( SO4 ) + !IF ( ALLOCATED( EOH ) ) DEALLOCATE( EOH ) + !IF ( ALLOCATED( MOH ) ) DEALLOCATE( MOH ) + !IF ( ALLOCATED( CH4 ) ) DEALLOCATE( CH4 ) + + IF ( ALLOCATED( CO_WKEND ) ) DEALLOCATE( CO_WKEND ) + !IF ( ALLOCATED( NOX_WKEND ) ) DEALLOCATE( NOX_WKEND ) + IF ( ALLOCATED( NO_WKEND ) ) DEALLOCATE( NO_WKEND ) + IF ( ALLOCATED( NO2_WKEND ) ) DEALLOCATE( NO2_WKEND ) + IF ( ALLOCATED( HNO2_WKEND ) ) DEALLOCATE( HNO2_WKEND ) + IF ( ALLOCATED( SO2_WKEND ) ) DEALLOCATE( SO2_WKEND ) + IF ( ALLOCATED( NH3_WKEND ) ) DEALLOCATE( NH3_WKEND ) + IF ( ALLOCATED( ALD2_WKEND ) ) DEALLOCATE( ALD2_WKEND ) + IF ( ALLOCATED( RCHO_WKEND ) ) DEALLOCATE( RCHO_WKEND ) + IF ( ALLOCATED( BENZ_WKEND ) ) DEALLOCATE( BENZ_WKEND ) + IF ( ALLOCATED( C2H6_WKEND ) ) DEALLOCATE( C2H6_WKEND ) + IF ( ALLOCATED( PRPE_WKEND ) ) DEALLOCATE( PRPE_WKEND ) + IF ( ALLOCATED( ALK4_WKEND ) ) DEALLOCATE( ALK4_WKEND ) + IF ( ALLOCATED( TOLU_WKEND ) ) DEALLOCATE( TOLU_WKEND ) + IF ( ALLOCATED( XYLE_WKEND ) ) DEALLOCATE( XYLE_WKEND ) + !IF ( ALLOCATED( C2H4_WKEND ) ) DEALLOCATE( C2H4_WKEND ) + IF ( ALLOCATED( CH2O_WKEND ) ) DEALLOCATE( CH2O_WKEND ) + IF ( ALLOCATED( BCPO_WKEND ) ) DEALLOCATE( BCPO_WKEND ) + IF ( ALLOCATED( OCPO_WKEND ) ) DEALLOCATE( OCPO_WKEND ) + IF ( ALLOCATED( SO4_WKEND ) ) DEALLOCATE( SO4_WKEND ) + !IF ( ALLOCATED( EOH_WKEND ) ) DEALLOCATE( EOH_WKEND ) + !IF ( ALLOCATED( MOH_WKEND ) ) DEALLOCATE( MOH_WKEND ) + !IF ( ALLOCATED( CH4_WKEND ) ) DEALLOCATE( CH4_WKEND ) + + END SUBROUTINE CLEANUP_NEI2008_ANTHRO +!EOC + END MODULE NEI2008_ANTHRO_MOD diff --git a/code/objects.sh b/code/objects.sh new file mode 100644 index 0000000..4236ced --- /dev/null +++ b/code/objects.sh @@ -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 diff --git a/code/objects.sh~ b/code/objects.sh~ new file mode 100644 index 0000000..11d4177 --- /dev/null +++ b/code/objects.sh~ @@ -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 diff --git a/code/ocean_mercury_mod.f b/code/ocean_mercury_mod.f new file mode 100644 index 0000000..eff419a --- /dev/null +++ b/code/ocean_mercury_mod.f @@ -0,0 +1,2223 @@ +! $Id: ocean_mercury_mod.f,v 1.2 2009/11/18 07:09:33 daven Exp $ + MODULE OCEAN_MERCURY_MOD +! +!****************************************************************************** +! Module OCEAN_MERCURY_MOD contains variables and routines needed to compute +! the oceanic flux of mercury. Original code by Sarah Strode at UWA/Seattle. +! (sas, bmy, 1/21/05, 4/17/06) +! +! Module Variables: +! ============================================================================ +! (1 ) Hg_RST_FILE (CHAR ) : Name of restart file with ocean tracers +! (2 ) USE_CHECKS (LOGICAL) : Flag for turning on error-checking +! (3 ) MAX_RELERR (REAL*8 ) : Max error for total-tag error check [unitless] +! (4 ) MAX_ABSERR (REAL*8 ) : Max abs error for total-tag err chk [unitless] +! (5 ) MAX_FLXERR (REAL*8 ) : Max error tol for flux error check [unitless] +! (6 ) CDEEP (REAL*8 ) : Conc. of Hg0, Hg2, HgC below MLD [pM ] +! (7 ) DD_Hg2 (REAL*8 ) : Array for Hg(II) dry dep'd to ocean [kg ] +! (8 ) dMLD (REAL*8 ) : Array for Change in ocean MLD [cm ] +! (9 ) Hg0aq (REAL*8 ) : Array for ocean mass of Hg(0) [kg ] +! (10) Hg2aq (REAL*8 ) : Array for ocean mass of Hg(II) [kg ] +! (11) HgC (REAL*8 ) : Array for ocean mass of HgC [kg ] +! (12) MLD (REAL*8 ) : Array for instantaneous ocean MLD [cm ] +! (13) MLDav (REAL*8 ) : Array for monthly mean ocean MLD [cm ] +! (14) newMLD (REAL*8 ) : Array for next month's ocean MLD [cm ] +! (15) NPP (REAL*8 ) : Array for mean net primary prod. [unitless] +! (16) RAD (REAL*8 ) : Array for mean solar radiation [W/m2 ] +! (17) UPVEL (REAL*8 ) : Array for ocean upwelling velocity [m/s ] +! (18) WD_Hg2 (REAL*8 ) : Array for Hg(II) wet dep'd to ocean [kg ] +! +! Module Routines: +! ============================================================================ +! (1 ) ADD_Hg2_DD : Archives Hg2 lost to drydep in DD_HG2 +! (2 ) ADD_Hg2_WD : Archives Hg2 lost to wetdep in WD_HG2 +! (3 ) OCEAN_MERCURY_FLUX : Routine to compute flux of oceanic mercury +! (4 ) OCEAN_MERCURY_READ : Routine to read MLD, NPP, RADSWG data fields +! (5 ) GET_MLD_FOR_NEXT_MONTH : Routine to read MLD for the next month +! (6 ) MLD_ADJUSTMENT : Adjusts MLD +! (7 ) READ_OCEAN_Hg_RESTART : Reads restart file with ocean Hg tracers +! (8 ) CHECK_DIMENSIONS : Checks dims of data blocks from restart file +! (9 ) CHECK_DATA_BLOCKS : Checks for missing/multiple data blocks +! (10) MAKE_OCEAN_Hg_RESTART : Writes new restart file with ocean Hg tracers +! (11) CHECK_ATMOS_MERCURY : Checks mass of total & tagged atm Hg0 & Hg2 +! (12) CHECK_OCEAN_MERCURY : Checks mass of total & tagged oc Hg0 & Hg2 +! (13) CHECK_OCEAN_FLUXES : Checks mass of total & tagged DD & WD fluxes +! (14) INIT_OCEAN_MERCURY : Allocates and zeroes all module variables +! (15) CLEANUP_OCEAN_MERCURY : Deallocates all module variables +! +! GEOS-CHEM modules referenced by ocean_mercury_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module w/ routines for binary pch file I/O +! (2 ) dao_mod.f : Module w/ arrays for DAO met fields +! (3 ) diag03_mod.f : Module w/ ND03 diagnostic arrays +! (2 ) file_mod.f : Module w/ file unit numbers and error checks +! (9 ) grid_mod.f : Module w/ horizontal grid information +! (10) logical_mod.f : Module w/ GEOS-CHEM logical switches +! (11) pressure_mod.f : Module w/ routines to compute P(I,J,L) +! (12) time_mod.f : Module w/ routines to compute date & time +! (13) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc. +! (14) tracerid_mod.f : Module w/ pointers to tracers & emissions +! (15) transfer_mod.f : Module w/ routines to cast & resize arrays +! +! References: +! ============================================================================ +! (1 ) Xu et al (1999). Formulation of bi-directional atmosphere-surface +! exchanges of elemental mercury. Atmospheric Environment +! 33, 4345-4355. +! (2 ) Nightingale et al (2000). In situ evaluation of air-sea gas exchange +! parameterizations using novel conservative and volatile tracers. +! Global Biogeochemical Cycles, 14, 373-387. +! (3 ) Lin and Tau (2003). A numerical modelling study on regional mercury +! budget for eastern North America. Atmos. Chem. Phys. Discuss., +! 3, 983-1015. And other references therein. +! (4 ) Poissant et al (2000). Mercury water-air exchange over the upper St. +! Lawrence River and Lake Ontario. Environ. Sci. Technol., 34, +! 3069-3078. And other references therein. +! (5 ) Wangberg et al. (2001). Estimates of air-sea exchange of mercury in +! the Baltic Sea. Atmospheric Environment 35, 5477-5484. +! (6 ) Clever, Johnson and Derrick (1985). The Solubility of Mercury and some +! sparingly soluble mercury salts in water and aqueous electrolyte +! solutions. J. Phys. Chem. Ref. Data, Vol. 14, No. 3, 1985. +! +! Nomenclature: +! ============================================================================ +! (1 ) Hg(0) a.k.a. Hg0 : Elemental mercury +! (2 ) Hg(II) a.k.a. Hg2 : Divalent mercury +! (3 ) HgC : Colloidal mercury +! +! NOTES: +! (1 ) Modified ocean flux w/ Sarah's new Ks value (sas, bmy, 2/24/05) +! (2 ) Now get HALFPOLAR for GCAP or GEOS grids (bmy, 6/28/05) +! (3 ) Now can read data for both GCAP or GEOS grids (bmy, 8/16/05) +! (4 ) Include updates from S. Strode and C. Holmes (cdh, sas, bmy, 4/6/06) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "ocean_mercury_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: ADD_Hg2_DD + PUBLIC :: ADD_Hg2_WD + PUBLIC :: INIT_OCEAN_MERCURY + PUBLIC :: CLEANUP_OCEAN_MERCURY + PUBLIC :: OCEAN_MERCURY_FLUX + PUBLIC :: READ_OCEAN_Hg_RESTART + PUBLIC :: MAKE_OCEAN_Hg_RESTART + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Scalars + LOGICAL :: USE_CHECKS + CHARACTER(LEN=255) :: Hg_RST_FILE + + ! Parameters + REAL*4, PARAMETER :: MAX_RELERR = 5.0d-2 + REAL*4, PARAMETER :: MAX_ABSERR = 5.0d-3 + REAL*4, PARAMETER :: MAX_FLXERR = 5.0d-1 + REAL*8, PARAMETER :: CDEEP(3) = (/ 6d-11, 5d-10, 5d-10 /) + REAL*8, PARAMETER :: SMALLNUM = 1d-32 + + ! Arrays + REAL*8, ALLOCATABLE :: DD_Hg2(:,:,:) + REAL*8, ALLOCATABLE :: dMLD(:,:) + REAL*8, ALLOCATABLE :: Hg0aq(:,:,:) + REAL*8, ALLOCATABLE :: Hg2aq(:,:,:) + REAL*8, ALLOCATABLE :: HgC(:,:) + REAL*8, ALLOCATABLE :: MLD(:,:) + REAL*8, ALLOCATABLE :: MLDav(:,:) + REAL*8, ALLOCATABLE :: newMLD(:,:) + REAL*8, ALLOCATABLE :: NPP(:,:) + REAL*8, ALLOCATABLE :: RAD(:,:) + REAL*8, ALLOCATABLE :: UPVEL(:,:) + REAL*8, ALLOCATABLE :: WD_Hg2(:,:,:) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE ADD_Hg2_DD( I, J, N, DRY_Hg2 ) +! +!****************************************************************************** +! Subroutine ADD_Hg2_WD computes the amount of Hg(II) dry deposited +! out of the atmosphere into the column array DD_Hg2. +! (sas, cdh, bmy, 1/19/05, 3/28/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : GEOS-CHEM longitude index +! (2 ) J (INTEGER) : GEOS-CHEM latitude index +! (3 ) N (INTEGER) : GEOS-CHEM tracer index +! (4 ) DRY_Hg2 (REAL*8 ) : Hg(II) dry deposited out of the atmosphere [kg] +! +! NOTES: +! (1 ) DD_Hg2 is now a 3-D array. Also pass N via the argument list. Now +! call GET_Hg2_CAT to return the Hg category #. (cdh, bmy, 3/28/06) +!****************************************************************************** +! + ! References to F90 modules + USE LOGICAL_MOD, ONLY : LDYNOCEAN + USE TRACERID_MOD, ONLY : GET_Hg2_CAT + + ! Arguments as input + INTEGER, INTENT(IN) :: I, J, N + REAL*8, INTENT(IN) :: DRY_Hg2 + + ! Local variables + INTEGER :: NN + + !================================================================= + ! ADD_Hg2_DD begins here! + !================================================================= + + ! Get the index for DD_Hg2 based on the tracer number + NN = GET_Hg2_CAT( N ) + + ! Store dry deposited Hg(II) into DD_Hg2 array + IF ( NN > 0 ) THEN + DD_Hg2(I,J,NN) = DD_Hg2(I,J,NN) + DRY_Hg2 + ENDIF + + ! Return to calling program + END SUBROUTINE ADD_Hg2_DD + +!------------------------------------------------------------------------------ + + SUBROUTINE ADD_Hg2_WD( I, J, N, WET_Hg2 ) +! +!****************************************************************************** +! Subroutine ADD_Hg2_WD computes the amount of Hg(II) wet scavenged +! out of the atmosphere into the column array WD_Hg2. +! (sas, cdh, bmy, 1/19/05, 3/28/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : GEOS-CHEM longitude index +! (2 ) J (INTEGER) : GEOS-CHEM latitude index +! (3 ) N (INTEGER) : GEOS-CHEM tracer index +! (4 ) WET_Hg2 (REAL*8 ) : Hg(II) scavenged out of the atmosphere +! +! NOTES: +! (1 ) DD_Hg2 is now a 3-D array. Also pass N via the argument list. Now +! call GET_Hg2_CAT to return the Hg category #. (cdh, bmy, 3/28/06) +!****************************************************************************** +! + ! References to F90 modules + USE TRACERID_MOD, ONLY : GET_Hg2_CAT + + ! Arguments as input + INTEGER, INTENT(IN) :: I, J, N + REAL*8, INTENT(IN) :: WET_Hg2 + + ! Local variables + INTEGER :: NN + + !================================================================= + ! ADD_Hg2_WD begins here! + !================================================================= + + ! Get Hg2 category number + NN = GET_Hg2_CAT( N ) + + ! Store wet deposited Hg(II) into WD_Hg2 array + IF ( NN > 0 ) THEN + WD_Hg2(I,J,NN) = WD_Hg2(I,J,NN) + WET_Hg2 + ENDIF + + ! Return to calling program + END SUBROUTINE ADD_Hg2_WD + +!------------------------------------------------------------------------------ + + SUBROUTINE OCEAN_MERCURY_FLUX( FLUX ) +! +!****************************************************************************** +! Subroutine OCEAN_MERCURY_FLUX calculates emissions of Hg(0) from +! the ocean in [kg/s]. (sas, bmy, 1/19/05, 4/17/06) +! +! NOTE: The emitted flux may be negative when ocean conc. is very low. +! +! ALSO NOTE: The ocean flux was tuned with GEOS-4 4x5 met fields. We also +! now account for the smaller grid size if using GEOS-4 2x25 met fields. +! +! Arguments as Output +! ============================================================================ +! (1 ) FLUX (REAL*8) : Flux of Hg(0) from the ocean [kg/s] +! +! NOTES: +! (1 ) Change Ks to make ocean flux for 2001 = 2.03e6 kg/year. +! (sas, bmy, 2/24/05) +! (2 ) Rewritten to include Sarah Strode's latest ocean Hg model code. +! Also now accounts for 2x25 grid. (sas, cdh, bmy, 4/6/06) +! (3 ) Bug fix to prevent error on XLF compiler (morin, bmy, 7/8/09) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : AIRVOL, ALBD, TS, RADSWG + USE DIAG03_MOD, ONLY : AD03, ND03 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE GRID_MOD, ONLY : GET_AREA_M2 + USE LOGICAL_MOD, ONLY : LSPLIT + USE TIME_MOD, ONLY : GET_TS_EMIS, GET_MONTH + USE TIME_MOD, ONLY : ITS_A_NEW_MONTH, ITS_MIDMONTH + USE TRACER_MOD, ONLY : STT, TRACER_MW_KG + USE TRACERID_MOD, ONLY : ID_Hg_tot, ID_Hg_oc + USE TRACERID_MOD, ONLY : ID_Hg0, N_Hg_CATS + USE TRANSFER_MOD, ONLY : TRANSFER_2D + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DEP" ! FRCLND + + ! Arguments + REAL*8, INTENT(OUT) :: FLUX(IIPAR,JJPAR,N_Hg_CATS) + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + CHARACTER(LEN=255) :: FILENAME + INTEGER :: I, J, NN, C + INTEGER :: N, N_tot_oc + INTEGER :: NEXTMONTH, THISMONTH + + REAL*8 :: A_M2, DTSRCE, MLDCM, MLDCMC + REAL*8 :: CHg0aq, CHg0 + REAL*8 :: K1, Kc, Ks, Kw + REAL*8 :: Kcon, Ksink, TC, TK + REAL*8 :: Sc, ScCO2, USQ, MHg + REAL*8 :: Hg2_RED, Hg2_GONE, Hg2_CONV, HgC_SUNK + REAL*8 :: FRAC_L, FRAC_O, H, TOTDEP + REAL*8 :: EF, oldMLD, XTAU + REAL*8 :: E_CONV, E_SINK, E_RED + REAL*8 :: DIFFUSION(3) + + ! Conversion factor from [cm/h * ng/L] --> [kg/m2/s] + REAL*8, PARAMETER :: TO_KGM2S = 1.0D-11 / 3600D0 + + ! External functions + REAL*8, EXTERNAL :: SFCWINDSQR + + !================================================================= + ! OCEAN_MERCURY_FLUX begins here! + !================================================================= + + ! Loop limit for use below + IF ( LSPLIT ) THEN + N_tot_oc = 2 + ELSE + N_tot_oc = 1 + ENDIF + + ! Molecular weight of Hg (applicable to all tagged tracers) + MHg = TRACER_MW_KG(ID_Hg_tot) + + !----------------------------------------------- + ! Check tagged & total sums (if necessary) + !----------------------------------------------- + IF ( USE_CHECKS .and. LSPLIT ) THEN + CALL CHECK_ATMOS_MERCURY( 'start of OCEAN_MERCURY_FLUX' ) + CALL CHECK_OCEAN_MERCURY( 'start of OCEAN_MERCURY_FLUX' ) + CALL CHECK_OCEAN_FLUXES ( 'start of OCEAN_MERCURY_FLUX' ) + ENDIF + + !----------------------------------------------- + ! Read monthly NPP, RADSW, MLD, UPVEL data + !----------------------------------------------- + IF ( ITS_A_NEW_MONTH() ) THEN + + ! Get current month + THISMONTH = GET_MONTH() + + ! Get monthly MLD, NPP, etc. + CALL OCEAN_MERCURY_READ( THISMONTH ) + + ENDIF + + !----------------------------------------------- + ! MLD and entrainment change in middle of month + !----------------------------------------------- + IF ( ITS_MIDMONTH() ) THEN + + ! Get current month + THISMONTH = GET_MONTH() + + ! Read next month's MLD + CALL GET_MLD_FOR_NEXT_MONTH( THISMONTH ) + + ENDIF + + !================================================================= + ! Compute flux of Hg0 from the ocean (notes by Sarah Strode): + ! + ! Net flux is given by the equation: + ! + ! F = Kw * ( Caq - Cg/H ) [Xu et al, 1999] + ! + ! Kw is the exchange parameter (piston velocity) [cm/h] given by: + ! + ! Kw = 0.25 * u^2 / SQRT( Sc / ScCO2 ) [Nightingale, 2000] + ! + ! u^2 is the square of the wind speed (10m above ground) [m/s]. + ! + ! Sc is the Schmidt number [unitless] for Hg(0): + ! + ! Sc = nu/D = ( 0.017*exp(-0.025T) ) / ( 6.0*10^-7*T + 10^-5 ) + ! with T in deg. C + ! [Lin and Tao, 2003 and Poissant et al., 2000] + ! + ! Caq = 1.5 pM is the surface water concentration + ! [Lamborg et al., 2002] + ! + ! Convert Caq to ng/L via 1.5 * 10^-12 * atomicWeight(Hg) * 10^9 + ! + ! Cg is the gas-phase concentration + ! + ! H is the dimensionless Henry coefficient for elemental mercury + ! + ! H = exp(4633.3/T - 14.52) where T is sea temp. in Kelvin + ! [Wangberg et al., 1999 and Clever et al, 1985] + !================================================================= + + ! Emission timestep [s] + DTSRCE = GET_TS_EMIS() * 60d0 + + ! Determine Ks (sinking term) [unitless] + ! NOTE: This constant was tuned using the GEOS-4 4x5 met fields + Ks = 1.0d-21 * DTSRCE + + ! Hg2 --> colloidal conversion rate + ! NOTE: This constant was tuned using the GEOS-4 4x5 met fields + Kc = 6.9d-22 * DTSRCE + +#if defined( GRID2x25 ) + ! If we are using the 2x25 grid, then multiply Ks and Kc by 4 + ! to account for the smaller grid size (sas, bmy, 4/17/06) + Ks = Ks * 4d0 + Kc = Kc * 4d0 +#endif + + ! Diffused mass of (Hg0, Hg2, HgC) across thermocline [kg/m2/timestep] + ! Based on a fixed gradient at the thermocline + ! DIFFUSION = (Diff. coeff.) * (Gradient) * (Hg molar mass) * DT + DIFFUSION(1) = 5.0d-5 * 3.0d-12 * MHg * DTSRCE + DIFFUSION(2) = 5.0d-5 * 5.0d-12 * MHg * DTSRCE + DIFFUSION(3) = 5.0d-5 * 5.0d-12 * MHg * DTSRCE + + ! Loop over latitudes +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, A_M2, OLDMLD, MLDCM ) +!$OMP+PRIVATE( MLDCMC, Kw, K1, HgC_SUNK, Hg2_CONV ) +!$OMP+PRIVATE( TK, TC, FRAC_L, FRAC_O, H ) +!$OMP+PRIVATE( Sc, ScCO2, EF, Ksink, Kcon ) +!$OMP+PRIVATE( Usq, C, NN, E_RED, E_CONV ) +!$OMP+PRIVATE( E_SINK, TOTDEP, Hg2_RED, Hg2_GONE, N ) +!$OMP+PRIVATE( CHg0aq, CHg0 ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + + ! Grid box surface area [m2] + A_M2 = GET_AREA_M2( J ) + + ! Loop over longitudes + DO I = 1, IIPAR + + ! Initialize values + OLDMLD = MLDav(I,J) + MLDav(I,J) = MLDav(I,J) + dMLD(I,J) * DTSRCE + MLDcm = MLDav(I,J) + MLDcmc = MLDCM + Kw = 0d0 + K1 = 0d0 + HgC_SUNK = 0d0 + Hg2_CONV = 0d0 + TK = 0d0 + TC = 0d0 + + ! Get fractions of land and ocean in the grid box [unitless] + FRAC_L = FRCLND(I,J) + FRAC_O = 1d0 - FRAC_L + + ! Change ocean mass due to mixed layer depth change + ! Keep before next IF so that we adjust mass in ice-covered boxes + CALL MLD_ADJUSTMENT( I, J, OLDMLD*1d-2, MLDcm*1d-2 ) + + !=========================================================== + ! Make sure we are in an ocean box + !=========================================================== + IF ( ( ALBD(I,J) <= 0.4d0 ) .and. + & ( FRAC_L < 0.8d0 ) .and. + & ( MLDCM > 0.99d0 ) ) THEN + + !-------------------------------------------------------- + ! Calculate K1 (reduction) based on NPP & RAD + !-------------------------------------------------------- + + ! For Daily RADSWG fields + ! NOTE: This constant was tuned using GEOS-4 4x5 met fields! + K1 = 6.1D-24 * DTSRCE * NPP(I,J) * RADSWG(I,J) + & * A_M2 * FRAC_O !for Reed ScHg + +#if defined( GRID2x25 ) + ! If we are using the 2x25 grid, then multiply K1 by 4 + ! to account for the smaller grid size (sas, bmy, 4/17/06) + K1 = K1 * 4d0 +#endif + + ! Surface air temperature in both [K] and [C] + ! (Use as surrogate for SST, cap at freezing point) + TK = MAX( TS(I,J), 273.15d0 ) + TC = TK - 273.15d0 + + ! Henry's law constant (liquid->gas) [unitless] [L air/L water] + H = EXP( 4633.3d0 / TK - 14.52d0 ) + + ! Schmidt # for Hg [unitless] + Sc = ( 0.017d0 * EXP( -0.025d0 * TC ) ) / + & ( 7.4D-8 * sqrt(2.6*18.0)*TK / 14.8) ! Reid + + ! Schmidt # of CO2 [unitless] + ScCO2 = 644.7d0 + TC * ( -6.16d0 + TC * ( 0.11d0 ) ) + + ! EF ratio for particle sinking based on Laws et al. 2000 + !---------------------------------------------------------------- + ! Prior to 7/8/09: + ! Now use 0d0 etc to prevent choking on XLF compiler (bmy, 7/8/09) + !EF = MAX( (0.63 - 0.02 * TC), 0.0) ! keep export > 0 + !---------------------------------------------------------------- + EF = MAX( (0.63d0 - 0.02d0 * TC ), 0d0 ) ! keep export > 0 + + Ksink = Ks * EF * NPP(I,J) * A_M2 *FRAC_O + + ! Conversion rate Hg2 -> HgC [unitless] + Kcon = Kc * NPP(I,J) * A_M2 * FRAC_O + + ! Square of surface (actually 10m) wind speed [m2/s2] + Usq = SFCWINDSQR(I,J) + + ! Piston velocity [cm/h], now from Nightingale + Kw = ( 0.25d0 * Usq ) / SQRT( Sc / ScCO2 ) + + ! Cap mixed layer depth for Hg2 reduction at 100m + MLDcmc = MIN( MLDcmc, 1d4 ) + + !----------------------------------------------------------- + ! Physical transport for tracers, Part I: + ! Diffusion from below thermocline + !----------------------------------------------------------- + + ! Loop over total Hg (and ocean Hg if necessary) + DO C = 1, N_tot_oc + + ! Get Hg category # + IF ( C == 1 ) NN = ID_Hg_tot + IF ( C == 2 ) NN = ID_Hg_oc + + ! Hg0 + Hg0aq(I,J,NN) = Hg0aq(I,J,NN) + & + ( DIFFUSION(1) * A_M2 * FRAC_O ) + + ! Hg2 + Hg2aq(I,J,NN) = Hg2aq(I,J,NN) + & + ( DIFFUSION(2) * A_M2 * FRAC_O ) + + ! Hg colloidal + IF ( C == 1 ) THEN + HgC(I,J) = HgC(I,J) + & + ( DIFFUSION(3) * A_M2 * FRAC_O ) + ENDIF + + ENDDO + + !----------------------------------------------------------- + ! Physical transport for tracers, Part II: + ! Upward current transport (Ekman pumping) + ! Upward mass flux is: + ! Mass = (Vol upwelling water) * (Conc. below thermocline) + ! Mass = (VEL * AREA * TIME ) * (C * Molar Mass ) + !----------------------------------------------------------- + IF ( UPVEL(I,J) > 0d0 ) THEN + + ! Loop over total Hg (and ocean Hg if necessary) + DO C = 1, N_tot_oc + + ! Get Hg category # + IF ( C == 1 ) NN = ID_Hg_tot + IF ( C == 2 ) NN = ID_Hg_oc + + ! Hg0 + Hg0aq(I,J,NN) = Hg0aq(I,J,NN) + UPVEL(I,J) + & * ( MHg * A_M2 * FRAC_O * DTSRCE * CDeep(1) ) + + ! Hg2 + Hg2aq(I,J,NN) = Hg2aq(I,J,NN) + UPVEL(I,J) + & * ( MHg * A_M2 * FRAC_O * DTSRCE * CDeep(2) ) + + ! Hg colloidal + IF ( C == 1 ) THEN + HgC(I,J) = HgC(I,J) + UPVEL(I,J) + & * ( MHg * A_M2 * FRAC_O * DTSRCE * CDeep(3) ) + ENDIF + + ENDDO + + !---------------------------------------------------------- + ! Physical transport for TOTAL TRACERS, Part III: + ! Downward current transport (Ekman pumping) + ! Treated as a deposition velocity + ! d(Mass)/dt = - VEL * Mass / BoxHeight + !---------------------------------------------------------- + ELSE + + ! Loop over all types of tagged tracers + DO NN = 1, N_Hg_CATS + + ! Hg0 + Hg0aq(I,J,NN) = Hg0aq(I,J,NN) + & * ( 1d0 + UPVEL(I,J) * DTSRCE / ( MLDcm * 1d-2 ) ) + + ! Hg2 + Hg2aq(I,J,NN) = Hg2aq(I,J,NN) + & * ( 1d0 + UPVEL(I,J) * DTSRCE / ( MLDcm * 1d-2 ) ) + + ! Hg colloidal + IF ( NN == 1 ) THEN + HgC(I,J) = HgC(I,J) + & * ( 1d0 + UPVEL(I,J) * DTSRCE / ( MLDcm * 1d-2 ) ) + ENDIF + + ENDDO + + ENDIF + + !=========================================================== + ! Calculate reduction, conversion, sinking, evasion + ! + ! (1) Hg2 -> HgC and HgC sinks + ! (2) Hg2 -> Hg0 and Hg0 evades + ! + ! NOTE: N is the GEOS-CHEM tracer # (for STT) + ! and NN is the Hg category # (for Hg0aq, Hg2aq, HgC) + !=========================================================== + + ! Loop over all Hg categories + DO NN = 1, N_Hg_CATS + + ! Reset flux each timestep + FLUX(I,J,NN) = 0d0 + + !-------------------------------------------------------- + ! Precompute exponents + !-------------------------------------------------------- + + ! Exponent for reduction [unitless] + E_RED = EXP( -K1 * MLDCMC / MLDCM ) + + ! Exponent for conversion of Hg(II) -> Hg(C) [unitless] + E_CONV = EXP( - Kcon ) + + ! Exponent for sinking Hg(C) --> deep ocean [unitless] + E_SINK = EXP( - Ksink ) + + !-------------------------------------------------------- + ! Calculate new Hg(II) mass + !-------------------------------------------------------- + + ! Total Hg(II) deposited on ocean surface [kg] + TOTDEP = (WD_Hg2(I,J,NN) + DD_Hg2(I,J,NN))*FRAC_O + + ! Add deposited Hg(II) to the Hg(II) ocean mass [kg] + Hg2aq(I,J,NN) = Hg2aq(I,J,NN) + TOTDEP + + ! Mass of Hg(II) --> Hg(C) + Hg2_CONV = Hg2aq(I,J,NN) * ( 1d0 - E_CONV ) + + ! Mass of Hg(II) --> Hg(0) + Hg2_RED = Hg2aq(I,J,NN) * ( 1d0 - E_RED ) + + ! Amount of Hg(II) that is lost [kg] + Hg2_GONE = Hg2_CONV + Hg2_RED + + ! Cap Hg2_GONE with available Hg2 + IF ( Hg2_GONE > Hg2aq(I,J,NN) ) THEN + Hg2_GONE = MIN( Hg2_GONE, Hg2aq(I,J,NN) ) + ENDIF + + ! Hg(II) ocean mass after reduction and conversion [kg] + Hg2aq(I,J,NN) = Hg2aq(I,J,NN) - Hg2_GONE + + !-------------------------------------------------------- + ! Calculate new Hg(C) mass + !-------------------------------------------------------- + IF ( NN == 1 ) THEN + + ! HgC ocean mass after conversion + HgC(I,J) = HgC(I,J) + Hg2_CONV + + ! Archive Hg(C) sinking loss for ND03 [kg] + HgC_SUNK = HgC(I,J) * ( 1d0 - E_SINK ) + + ! HgC ocean mass after sinking [kg] + HgC(I,J) = HgC(I,J) - HgC_SUNK + + ! Store Hg2_CONV for total tracer only + IF ( ND03 > 0 ) THEN + AD03(I,J,12) = AD03(I,J,12) + Hg2_CONV + ENDIF + + ENDIF + + !-------------------------------------------------------- + ! Calculate new Hg(0) mass + !-------------------------------------------------------- + + ! Hg0 tracer number (for STT) + N = ID_Hg0(NN) + + ! Add converted Hg(II) to the ocean mass of Hg(0) [kg] + Hg0aq(I,J,NN) = Hg0aq(I,J,NN) + Hg2_RED + + !-------------------------------------------------------- + ! Calculate oceanic and gas-phase concentration of Hg(0) + !-------------------------------------------------------- + + ! Concentration of Hg(0) in the ocean [ng/L] + CHg0aq = ( Hg0aq(I,J,NN) * 1d11 ) / + & ( A_M2 * FRAC_O ) / MLDcm + + ! Gas phase Hg(0) concentration: convert [kg] -> [ng/L] + CHg0 = STT(I,J,1,N) * 1.0D9 / AIRVOL(I,J,1) + + !-------------------------------------------------------- + ! Compute flux of Hg(0) from the ocean to the air + !-------------------------------------------------------- + + ! Compute ocean flux of Hg0 [cm/h*ng/L] + FLUX(I,J,NN) = Kw * ( CHg0aq - ( H * CHg0 ) ) + + ! Convert [cm/h*ng/L] --> [kg/m2/s] --> [kg/s] + ! Also account for ocean fraction of grid box + FLUX(I,J,NN) = FLUX(I,J,NN) * TO_KGM2S * A_M2 *FRAC_O + + !-------------------------------------------------------- + ! Flux limited by ocean and atm Hg(0) + !-------------------------------------------------------- + + ! Cap the flux w/ the available Hg(0) ocean mass + IF ( FLUX(I,J,NN) * DTSRCE > Hg0aq(I,J,NN) ) THEN + FLUX(I,J,NN) = Hg0aq(I,J,NN) / DTSRCE + ENDIF + + ! Cap the neg flux w/ the available Hg(0) atm mass + IF ( (-FLUX(I,J,NN) * DTSRCE ) > STT(I,J,1,N) ) THEN + FLUX(I,J,NN) = -STT(I,J,1,N) / DTSRCE + ENDIF + + !-------------------------------------------------------- + ! Remove amt of Hg(0) that is leaving the ocean [kg] + !-------------------------------------------------------- + Hg0aq(I,J,NN) = Hg0aq(I,J,NN) - ( FLUX(I,J,NN) * DTSRCE ) + + ! Make sure Hg0aq does not underflow (cdh, bmy, 3/28/06) + Hg0aq(I,J,NN) = MAX( Hg0aq(I,J,NN), SMALLNUM ) + + ENDDO + + !----------------------------------------------------------- + ! ND03 diagnostics ("OCEAN-HG") + !----------------------------------------------------------- + IF ( ND03 > 0 ) THEN + + ! Aqueous Hg(0) mass [kg] + AD03(I,J,2) = AD03(I,J,2) + Hg0aq(I,J,ID_Hg_tot) + + ! Aqueous Hg(II) mass [kg] + AD03(I,J,7) = AD03(I,J,7) + Hg2aq(I,J,ID_Hg_tot) + + ! Hg2 sunk deep into the ocean [kg] + AD03(I,J,8) = AD03(I,J,8) + HgC_SUNK + + ! Kw (piston velocity) [cm/s] + AD03(I,J,10) = AD03(I,J,10) + Kw + + ! Hg converted to colloidal [kg/m2/s] + AD03(I,J,11) = AD03(I,J,11) + HgC(I,J) + ENDIF + + !============================================================== + ! If we are not in an ocean box, set Hg(0) flux to zero + !============================================================== + ELSE + + DO NN = 1, N_Hg_CATS + FLUX(I,J,NN) = 0d0 + ENDDO + + ENDIF + + !============================================================== + ! Zero amts of deposited Hg2 for next timestep [kg] + !============================================================== + DO NN = 1, N_Hg_CATS + DD_Hg2(I,J,NN) = 0d0 + WD_Hg2(I,J,NN) = 0d0 + ENDDO + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Check tagged & total sums (if necessary) + !================================================================= + IF ( USE_CHECKS .and. LSPLIT ) THEN + CALL CHECK_ATMOS_MERCURY( 'end of OCEAN_MERCURY_FLUX' ) + CALL CHECK_OCEAN_MERCURY( 'end of OCEAN_MERCURY_FLUX' ) + CALL CHECK_OCEAN_FLUXES ( 'end of OCEAN_MERCURY_FLUX' ) + CALL CHECK_FLUX_OUT( FLUX, 'end of OCEAN_MERCURY_FLUX' ) + ENDIF + + ! Return to calling program + END SUBROUTINE OCEAN_MERCURY_FLUX + +!------------------------------------------------------------------------------ + + SUBROUTINE OCEAN_MERCURY_READ( THISMONTH ) +! +!****************************************************************************** +! Subroutine OCEAN_MERCURY_READ reads in the mixed layer depth, net primary +! productivity, upwelling and radiation climatology for each month. +! This is needed for the ocean flux computation. +! (sas, cdh, bmy, 1/20/05, 3/28/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) THISMONTH (INTEGER) : Month to read fields (1-12) +! +! NOTES: +! (1 ) Modified for S. Strode's latest ocean Hg code. Now read files +! from DATA_DIR_1x1/mercury_200511. (sas, cdh, bmy, 3/28/06) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE TRANSFER_MOD, ONLY : TRANSFER_2D + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: THISMONTH + + ! Local Variables + LOGICAL, SAVE :: FIRST = .TRUE. + REAL*4 :: ARRAY(IGLOB,JGLOB,1) + REAL*8 :: TAU + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! OCEAN_MERCURY_READ begins here! + !================================================================= + + !------------------------------ + ! Mixed layer depth [cm] + !------------------------------ + + ! MLD file name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'mercury_200511/mld.geos.' // GET_RES_EXT() + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - OCEAN_MERCURY_READ: Reading ', a ) + + ! TAU0 value (uses year 1985) + TAU = GET_TAU0( THISMONTH, 1, 1985 ) + + ! Read from disk; original units are [m] + CALL READ_BPCH2( FILENAME, 'BXHGHT-$', 5, + & TAU, IGLOB, JGLOB, + & 1, ARRAY(:,:,1), QUIET=.TRUE. ) + + ! Resize and cast to REAL*8 + CALL TRANSFER_2D( ARRAY(:,:,1), MLD ) + + ! Convert [m] to [cm] + MLD = MLD * 100d0 + + ! First-time only: Set MDLav [cm] to MLD of first month + IF ( FIRST ) THEN + MLDav = MLD + dMLD = 0.0 + FIRST = .FALSE. + ENDIF + + !-------------------------------- + ! Net primary productivity + !-------------------------------- + + ! NPP file name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'mercury_200511/modis_npp.geos.' // GET_RES_EXT() + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! TAU0 values (uses year 2003) + TAU = GET_TAU0( THISMONTH, 1, 2003 ) + + ! Read data + CALL READ_BPCH2( FILENAME, 'GLOB-NPP', 1, + & TAU, IGLOB, JGLOB, + & 1, ARRAY(:,:,1), QUIET=.TRUE. ) + + ! Resize and cast to REAL*8 + CALL TRANSFER_2D( ARRAY(:,:,1), NPP ) + + !--------------------------------- + ! Ekman upwelling velocity [cm/s] + !--------------------------------- + + ! NPP file name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'mercury_200511/ekman_upvel.geos.' // GET_RES_EXT() + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! TAU0 value (uses year 1985) + TAU = GET_TAU0( THISMONTH, 1, 1985 ) + + ! Read from disk; original units are [cm/s] + CALL READ_BPCH2( FILENAME, 'EKMAN-V', 1, + & TAU, IGLOB, JGLOB, + & 1, ARRAY(:,:,1), QUIET=.TRUE. ) + + ! Resize and cast to REAL*8 + CALL TRANSFER_2D( ARRAY(:,:,1), UPVEL ) + + ! convert [cm/s] to [m/s] + UPVEL = UPVEL * 1.D-2 + + ! Return to calling program + END SUBROUTINE OCEAN_MERCURY_READ + +!------------------------------------------------------------------------------ + + SUBROUTINE GET_MLD_FOR_NEXT_MONTH( THISMONTH ) +! +!****************************************************************************** +! Subroutine GET_MLD_FOR_NEXT_MONTH reads the mixed-layer depth (MLD) +! values for the next month. (sas, cdh, bmy, 3/28/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) THISMONTH (INTEGER) : Current month number (1-12) +! +! NOTES: +! (1 ) Now read files from DATA_DIR_1x1/mercury_200511 (bmy, 3/28/06) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_TAU0, GET_RES_EXT, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE TRANSFER_MOD, ONLY : TRANSFER_2D + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: THISMONTH + + ! Local variables + INTEGER :: I, J, NEXTMONTH + REAL*4 :: ARRAY(IGLOB,JGLOB,1) + REAL*8 :: TAU + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! GET_MLD_FOR_NEXT_MONTH begins here! + !================================================================= + + ! MLD file name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'mercury_200511/mld.geos.' // GET_RES_EXT() + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - GET_MLD_FOR_NEXT_MONTH: Reading ', a ) + + ! Get the next month + NEXTMONTH = MOD( THISMONTH, 12 ) +1 + + ! TAU0 value for next month (uses year 1985) + TAU = GET_TAU0( NEXTMONTH, 1, 1985 ) + + ! Read from disk; original units are [m] + CALL READ_BPCH2( FILENAME, 'BXHGHT-$', 5, + & TAU, IGLOB, JGLOB, + & 1, ARRAY(:,:,1), QUIET=.TRUE. ) + + ! Resize and cast to REAL*8 + CALL TRANSFER_2D( ARRAY(:,:,1), newMLD ) + + ! Convert [m] to [cm] + newMLD = newMLD * 100d0 + + ! get rate of change of MLD; convert [cm/month] -> [cm/s] + DO J = 1, JJPAR + DO I = 1, IIPAR + dMLD(I,J) = (newMLD(I,J) - MLD(I,J)) / ( 3.6d3 *24d0 * 30.5d0 ) + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE GET_MLD_FOR_NEXT_MONTH + +!------------------------------------------------------------------------------ + + SUBROUTINE MLD_ADJUSTMENT( I, J, MLDold, MLDnew ) +! +!****************************************************************************** +! Subroutine MLD_ADJUSTMENT entrains new water when mixed layer depth deepens +! and conserves concentration (leaves mass behind) when mixed layer shoals. +! (sas, cdh, bmy, 4/18/05, 3/28/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : GEOS-CHEM longitude index +! (2 ) J (INTEGER) : GEOS-CHEM latitude index +! (3 ) MLDold (REAL*8 ) : Old ocean mixed layer depth [m] +! (4 ) MLDnew (REAL*8 ) : New ocean mixed layer depth [m] +! +! NOTES: +!****************************************************************************** +! + ! Reference to fortran90 modules + USE GRID_MOD, ONLY : GET_AREA_M2 + USE LOGICAL_MOD, ONLY : LSPLIT + USE TRACER_MOD, ONLY : TRACER_MW_KG + USE TRACERID_MOD, ONLY : ID_Hg_tot, ID_Hg_oc, N_Hg_CATS + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DEP" ! FRCLND + + ! Arguments + INTEGER, INTENT(IN) :: I, J + REAL*8, INTENT(IN) :: MLDold, MLDnew + + ! Local variables + INTEGER :: C, NN, N_tot_oc + REAL*8 :: A_M2, DELTAH, FRAC_O, MHg + + !================================================================= + ! MLD_ADJUSTMENT begins here! + !================================================================= + + ! Loop limit for use below + IF ( LSPLIT ) THEN + N_tot_oc = 2 + ELSE + N_tot_oc = 1 + ENDIF + + ! Grid box surface area [m2] + A_M2 = GET_AREA_M2( J ) + + ! Fraction of box that is ocean + FRAC_O = 1d0 - FRCLND(I,J) + + ! Molecular weight of Hg (valid for all tagged tracers) + MHg = TRACER_MW_KG(ID_Hg_tot) + + ! Test if MLD increased + IF ( MLDnew > MLDold ) THEN + + !============================================================== + ! IF MIXED LAYER DEPTH HAS INCREASED: + ! + ! Entrain water with a concentration specified by CDeep + ! + ! Entrained Mass = ( Vol water entrained ) * CDeep * Molar mass + ! = ( DELTAH * AREA * FRAC_O ) * CDeep * MHg + !============================================================== + + ! Increase in MLD [m] + DELTAH = MLDnew - MLDold + + ! Loop over total Hg (and ocean Hg if necessary) + DO C = 1, N_tot_oc + + ! Get Hg category number + IF ( C == 1 ) NN = ID_Hg_tot + IF ( C == 2 ) NN = ID_Hg_oc + + ! Hg0 + Hg0aq(I,J,NN) = Hg0aq(I,J,NN) + & + ( DELTAH * CDeep(1) * MHg * A_M2 * FRAC_O ) + + ! Hg2 + Hg2aq(I,J,NN) = Hg2aq(I,J,NN) + & + ( DELTAH * CDeep(2) * MHg * A_M2 * FRAC_O ) + + ! HgC + IF ( C == 1 ) THEN + HgC(I,J) = HgC(I,J) + & + ( DELTAH * CDeep(3) * MHg * A_M2 * FRAC_O ) + ENDIF + + ENDDO + + ELSE + + !============================================================== + ! IF MIXED LAYER DEPTH HAS DECREASED: + ! + ! Conserve concentration, but shed mass for ALL tracers. + ! Mass changes by same ratio as volume. + !============================================================== + + ! Avoid dividing by zero + IF ( MLDold > 0d0 ) THEN + + ! Update Hg0 and Hg2 categories + DO NN = 1, N_Hg_CATS + Hg0aq(I,J,NN) = Hg0aq(I,J,NN) * ( MLDnew / MLDold ) + Hg2aq(I,J,NN) = Hg2aq(I,J,NN) * ( MLDnew / MLDold ) + ENDDO + + ! Update colloidal Hg + HgC(I,J) = HgC(I,J) * ( MLDnew / MLDold ) + + ENDIF + + ENDIF + + ! Return to calling program + END SUBROUTINE MLD_ADJUSTMENT + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_OCEAN_Hg_RESTART( YYYYMMDD, HHMMSS ) +! +!****************************************************************************** +! Subroutine READ_OCEAN_Hg_RESTART initializes GEOS-CHEM oceanic mercury +! tracer masses from a restart file. (sas, cdh, bmy, 3/28/06) +! +! Arguments as input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Day +! (2 ) HHMMSS : and Hour-Min-Sec for which to read restart file +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : OPEN_BPCH2_FOR_READ + USE ERROR_MOD, ONLY : DEBUG_MSG + USE FILE_MOD, ONLY : IU_FILE, IOERROR + USE LOGICAL_MOD, ONLY : LSPLIT, LPRT + USE TIME_MOD, ONLY : EXPAND_DATE + USE TRACER_MOD, ONLY : STT, TRACER_NAME, TRACER_MW_G + USE TRACERID_MOD, ONLY : GET_Hg0_CAT, GET_Hg2_CAT, N_Hg_CATS + USE TRACERID_MOD, ONLY : ID_Hg0, ID_Hg2 + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: YYYYMMDD, HHMMSS + + ! Local Variables + INTEGER :: I, IOS, J, L, NN, N_oc + INTEGER :: YEAR, MONTH, DAY + INTEGER :: NCOUNT(NNPAR) + REAL*4 :: Hg_OCEAN(IIPAR,JJPAR,1) + CHARACTER(LEN=255) :: FILENAME + + ! For binary punch file, version 2.0 + INTEGER :: NI, NJ, NL + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: NTRACER, NSKIP + INTEGER :: HALFPOLAR, CENTER180 + REAL*4 :: LONRES, LATRES + REAL*8 :: ZTAU0, ZTAU1 + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY + CHARACTER(LEN=40) :: UNIT + CHARACTER(LEN=40) :: RESERVED + + !================================================================= + ! READ_OCEAN_Hg_RESTART begins here! + !================================================================= + + ! Initialize some variables + NCOUNT(:) = 0 + Hg_OCEAN(:,:,:) = 0e0 + + ! Copy input file name to a local variable + FILENAME = TRIM( Hg_RST_FILE ) + + ! Replace YYYY, MM, DD, HH tokens in FILENAME w/ actual values + CALL EXPAND_DATE( FILENAME, YYYYMMDD, HHMMSS ) + + ! Echo some input to the screen + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, 100 ) + WRITE( 6, 110 ) TRIM( FILENAME ) + 100 FORMAT( 'O C E A N H g R E S T A R T F I L E I N P U T' ) + 110 FORMAT( /, 'READ_OCEAN_Hg_RESTART: Reading ', a ) + + ! Open the binary punch file for input + CALL OPEN_BPCH2_FOR_READ( IU_FILE, FILENAME ) + + ! Echo more output + WRITE( 6, 120 ) + 120 FORMAT( /, 'Min and Max of each tracer, as read from the file:', + & /, '(in volume mixing ratio units: v/v)' ) + + !================================================================= + ! Read concentrations -- store in the TRACER array + !================================================================= + DO + READ( IU_FILE, IOSTAT=IOS ) + & MODELNAME, LONRES, LATRES, HALFPOLAR, CENTER180 + + ! IOS < 0 is end-of-file, so exit + IF ( IOS < 0 ) EXIT + + ! IOS > 0 is a real I/O error -- print error message + IF ( IOS > 0 ) CALL IOERROR( IOS, IU_FILE, 'rd_oc_hg_rst:1' ) + + READ( IU_FILE, IOSTAT=IOS ) + & CATEGORY, NTRACER, UNIT, ZTAU0, ZTAU1, RESERVED, + & NI, NJ, NL, IFIRST, JFIRST, LFIRST, + & NSKIP + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'rd_oc_hg_rst:2' ) + + READ( IU_FILE, IOSTAT=IOS ) + & ( ( ( Hg_OCEAN(I,J,L), I=1,NI ), J=1,NJ ), L=1,NL ) + + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'rd_oc_hg_rst:3' ) + + !============================================================== + ! Assign data from the TRACER array to the STT array. + !============================================================== + + ! Only process concentration data (i.e. mixing ratio) + IF ( CATEGORY(1:8) == 'OCEAN-HG' ) THEN + + ! Make sure array dimensions are of global size + ! (NI=IIPAR; NJ=JJPAR, NL=LLPAR), or stop the run + CALL CHECK_DIMENSIONS( NI, NJ, NL ) + + ! Save into arrays + IF ( ANY( ID_Hg0 == NTRACER ) ) THEN + + !---------- + ! Hg(0) + !---------- + + ! Get the Hg category # + NN = GET_Hg0_CAT( NTRACER ) + + ! Store ocean Hg(0) in Hg0aq array + Hg0aq(:,:,NN) = Hg_OCEAN(:,:,1) + + ! Increment NCOUNT + NCOUNT(NTRACER) = NCOUNT(NTRACER) + 1 + + ELSE IF ( ANY( ID_Hg2 == NTRACER ) ) THEN + + !---------- + ! Hg(II) + !---------- + + ! Get the Hg category # + NN = GET_Hg2_CAT( NTRACER ) + + ! Store ocean Hg(II) in Hg2_aq array + Hg2aq(:,:,NN) = Hg_OCEAN(:,:,1) + + ! Increment NCOUNT + NCOUNT(NTRACER) = NCOUNT(NTRACER) + 1 + + ELSE IF ( NTRACER == 3 ) THEN + + !---------- + ! Hg(C) + !---------- + + ! Colloidal Hg + HgC(:,:) = Hg_OCEAN(:,:,1) + + ! Increment NCOUNT + NCOUNT(NTRACER) = NCOUNT(NTRACER) + 1 + + ENDIF + ENDIF + ENDDO + + ! Close file + CLOSE( IU_FILE ) + + !================================================================= + ! Examine data blocks, print totals, and return + !================================================================= + + ! Tagged simulation has 17 ocean tracers; otherwise 3 + IF ( LSPLIT ) THEN + N_oc = 17 + ELSE + N_oc = 3 + ENDIF + + ! Check for missing or duplicate data blocks + CALL CHECK_DATA_BLOCKS( N_oc, NCOUNT ) + + !================================================================= + ! Print totals + !================================================================= + + ! Echo info + WRITE( 6, 130 ) + + ! Hg0 + DO NN = 1, N_Hg_CATS + WRITE( 6, 140 ) ID_Hg0(NN), TRACER_NAME( Id_Hg0(NN) ), + & SUM( Hg0aq(:,:,NN) ), 'kg' + ENDDO + + ! Hg2 + DO NN = 1, N_Hg_CATS + WRITE( 6, 140 ) ID_Hg2(NN), TRACER_NAME( Id_Hg2(NN) ), + & SUM( Hg0aq(:,:,NN) ), 'kg' + ENDDO + + ! HgC + WRITE( 6, 140 ) 3, 'HgC ', SUM( HgC ), 'kg' + + ! Format strings + 130 FORMAT( /, 'Total masses for each ocean tracer: ' ) + 140 FORMAT( 'Tracer ', i3, ' (', a10, ') ', es12.5, 1x, a4) + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Make sure tagged & total tracers sum up + IF ( USE_CHECKS .and. LSPLIT ) THEN + CALL CHECK_OCEAN_MERCURY( 'end of READ_OCEAN_Hg_RESTART' ) + ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### READ_OCEAN_Hg_RST: read file' ) + + ! Return to calling program + END SUBROUTINE READ_OCEAN_Hg_RESTART + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_DIMENSIONS( NI, NJ, NL ) +! +!****************************************************************************** +! Subroutine CHECK_DIMENSIONS makes sure that the dimensions of the Hg +! restart file extend to cover the entire grid. (sas, cdh, bmy, 3/28/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) NI (INTEGER) : Number of longitudes read from restart file +! (2 ) NJ (INTEGER) : Number of latitudes read from restart file +! (3 ) NL (INTEGER) : Numbef of levels read from restart file +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + + ! Arguments + INTEGER, INTENT(IN) :: NI, NJ, NL + +# include "CMN_SIZE" + + !================================================================= + ! CHECK_DIMENSIONS begins here! + !================================================================= + + ! Error check longitude dimension: NI must equal IIPAR + IF ( NI /= IIPAR ) THEN + WRITE( 6, 100 ) + 100 FORMAT( 'ERROR reading in Hg restart file', / + & 'Wrong number of longitudes encountered', / + & 'STOP in CHECK_DIMENSIONS ("ocean_mercury_mod.f")' ) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + ! Error check latitude dimension: NJ must equal JJPAR + IF ( NJ /= JJPAR ) THEN + WRITE( 6, 110 ) + 110 FORMAT( 'ERROR reading in Hg restart file', / + & 'Wrong number of longitudes encountered', / + & 'STOP in CHECK_DIMENSIONS ("ocean_mercury_mod.f")' ) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + ! Error check vertical dimension: NL must equal LLPAR + IF ( NL /= 1 ) THEN + WRITE( 6, 120 ) + 120 FORMAT( 'ERROR reading in Hg restart file', / + & 'Wrong number of longitudes encountered', / + & 'STOP in CHECK_DIMENSIONS ("ocean_mercury_mod.f")' ) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK_DIMENSIONS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_DATA_BLOCKS( N_TRACERS, NCOUNT ) +! +!****************************************************************************** +! Subroutine CHECK_DATA_BLOCKS checks to see if we have multiple or +! missing data blocks for a given tracer. (sas, cdh, bmy, 3/28/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) N_TRACERS (INTEGER) : Number of tracers +! (2 ) NCOUNT (INTEGER) : Ctr array - # of data blocks found per tracer +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: N_TRACERS, NCOUNT(NNPAR) + + ! Local variables + INTEGER :: N + + !================================================================= + ! CHECK_DATA_BLOCKS begins here! + !================================================================= + + ! Loop over all tracers + DO N = 1, N_TRACERS + + ! Stop if a tracer has more than one data block + IF ( NCOUNT(N) > 1 ) THEN + WRITE( 6, 100 ) N + WRITE( 6, 120 ) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + ! Stop if a tracer has no data blocks + IF ( NCOUNT(N) == 0 ) THEN + WRITE( 6, 110 ) N + WRITE( 6, 120 ) + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + ENDDO + + ! FORMAT statements + 100 FORMAT( 'More than one record found for tracer : ', i4 ) + 110 FORMAT( 'No records found for tracer : ', i4 ) + 120 FORMAT( 'STOP in CHECK_DATA_BLOCKS (restart_mod.f)' ) + + ! Return to calling program + END SUBROUTINE CHECK_DATA_BLOCKS + +!------------------------------------------------------------------------------ + + SUBROUTINE MAKE_OCEAN_Hg_RESTART( NYMD, NHMS, TAU ) +! +!****************************************************************************** +! Subroutine MAKE_OCEAN_Hg_RESTART writes an ocean mercury restart file. +! (sas, cdh, bmy, 3/28/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) YYYYMMDD : Year-Month-Date +! (2 ) HHMMSS : and Hour-Min-Sec for which to create a restart file +! (3 ) TAU : GEOS-CHEM TAU value corresponding to YYYYMMDD, HHMMSS +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD + USE FILE_MOD, ONLY : IU_FILE + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + USE LOGICAL_MOD, ONLY : LSPLIT + USE TIME_MOD, ONLY : EXPAND_DATE, GET_TAU + USE TRACERID_MOD, ONLY : ID_Hg_tot, ID_Hg0 + USE TRACERID_MOD, ONLY : ID_Hg2, N_Hg_CATS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: NYMD, NHMS + REAL*8, INTENT(IN) :: TAU + + ! Local variables + INTEGER :: HALFPOLAR, CENTER180 + INTEGER :: IFIRST, JFIRST, LFIRST + INTEGER :: N, NN + REAL*4 :: LONRES, LATRES, ARRAY(IGLOB,JGLOB,1) + CHARACTER(LEN=20) :: MODELNAME + CHARACTER(LEN=40) :: CATEGORY, UNIT, RESERVED + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! MAKE_OCEAN_Hg_RESTART begins here! + !================================================================= + + ! Initialize values + IFIRST = GET_XOFFSET( GLOBAL=.TRUE. ) + 1 + JFIRST = GET_YOFFSET( GLOBAL=.TRUE. ) + 1 + LFIRST = 1 + HALFPOLAR = GET_HALFPOLAR() + CENTER180 = 1 + LONRES = DISIZE + LATRES = DJSIZE + MODELNAME = GET_MODELNAME() + CATEGORY = 'OCEAN-HG' + RESERVED = '' + UNIT = 'kg' + + ! Expand date in filename + FILENAME = Hg_RST_FILE + CALL EXPAND_DATE( FILENAME, NYMD, NHMS ) + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - MAKE_RESTART_FILE: Writing ', a ) + + ! Open BPCH file for output + CALL OPEN_BPCH2_FOR_WRITE( IU_FILE, FILENAME ) + + !--------------------------- + ! Total Hg(0) in ocean + !--------------------------- + N = ID_Hg0(Id_Hg_tot) + ARRAY(:,:,1) = Hg0aq(:,:,ID_Hg_tot) + + CALL BPCH2( IU_FILE, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IIPAR, JJPAR, 1, IFIRST, + & JFIRST, LFIRST, ARRAY(:,:,1) ) + + !--------------------------- + ! Total Hg(II) in ocean + !--------------------------- + N = ID_Hg2(ID_Hg_tot) + ARRAY(:,:,1) = Hg2aq(:,:,ID_Hg_tot) + + CALL BPCH2( IU_FILE, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IIPAR, JJPAR, 1, IFIRST, + & JFIRST, LFIRST, ARRAY(:,:,1) ) + + !--------------------------- + ! Total HgC in ocean + !--------------------------- + N = 3 + ARRAY(:,:,1) = HgC(:,:) + + CALL BPCH2( IU_FILE, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IIPAR, JJPAR, 1, IFIRST, + & JFIRST, LFIRST, ARRAY(:,:,1) ) + + ! Save tagged ocean tracers if present + IF ( LSPLIT ) THEN + + !------------------------ + ! Tagged Hg(0) in ocean + !------------------------ + DO NN = 2, N_Hg_CATS + N = ID_Hg0(NN) + ARRAY(:,:,1) = Hg0aq(:,:,NN) + + CALL BPCH2( IU_FILE, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IIPAR, JJPAR, 1, IFIRST, + & JFIRST, LFIRST, ARRAY(:,:,1) ) + ENDDO + + !------------------------ + ! Tagged Hg(II) in ocean + !------------------------ + DO NN = 2, N_Hg_CATS + N = ID_Hg2(NN) + ARRAY(:,:,1) = Hg2aq(:,:,NN) + + CALL BPCH2( IU_FILE, MODELNAME, LONRES, LATRES, + & HALFPOLAR, CENTER180, CATEGORY, N, + & UNIT, TAU, TAU, RESERVED, + & IIPAR, JJPAR, 1, IFIRST, + & JFIRST, LFIRST, ARRAY(:,:,1) ) + ENDDO + ENDIF + + ! Close file + CLOSE( IU_FILE ) + + ! Make sure tagged & total tracers sum up + IF ( USE_CHECKS .and. LSPLIT ) THEN + CALL CHECK_OCEAN_MERCURY( 'end of MAKE_OCEAN_Hg_RESTART' ) + ENDIF + + ! Return to calling program + END SUBROUTINE MAKE_OCEAN_Hg_RESTART + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_ATMOS_MERCURY( LOC ) +! +!****************************************************************************** +! Subroutine CHECK_ATMOS_MERCURY tests whether the total and tagged tracers +! the GEOS-CHEM tracer array STT sum properly within each grid box. +! (cdh, bmy, 3/28/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) LOC (CHARACTER) : Name of routine where CHECK_ATMOS_MERCURY is called +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : STT + USE ERROR_MOD, ONLY : ERROR_STOP + USE TRACERID_MOD, ONLY : ID_Hg0, ID_Hg2, ID_HgP + USE TRACERID_MOD, ONLY : ID_Hg_tot, N_Hg_CATS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments as Input + CHARACTER(LEN=*), INTENT(IN) :: LOC + + ! Local variables + LOGICAL :: FLAG + INTEGER :: I, J, L + INTEGER :: N, NN + REAL*8 :: Hg0_tot, Hg0_tag, RELERR0, ABSERR0 + REAL*8 :: Hg2_tot, Hg2_tag, RELERR2, ABSERR2 + REAL*8 :: HgP_tot, HgP_tag, RELERRP, ABSERRP + + !================================================================= + ! CHECK_ATMOS_MERCURY begins here! + !================================================================= + + ! Set error flags + FLAG = .FALSE. + + ! Loop over grid boxes +! OMP PARALLEL DO +! OMP+DEFAULT( SHARED ) +! OMP+PRIVATE( I, J, L, N, NN ) +! OMP+PRIVATE( Hg0_tot, RELERR0, ABSERR0 ) +! OMP+PRIVATE( Hg2_tot, RELERR2, ABSERR2 ) +! OMP+PRIVATE( HgP_tot, RELERRP, ABSERRP ) +! OMP+REDUCTION( +: Hg0_tag, Hg2_tag, HgP_tag ) + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Initialize + Hg0_tot = 0d0 + Hg0_tag = 0d0 + RELERR0 = 0d0 + ABSERR0 = 0d0 + Hg2_tot = 0d0 + Hg2_tag = 0d0 + RELERR2 = 0d0 + ABSERR2 = 0d0 + HgP_tot = 0d0 + Hgp_tag = 0d0 + RELERRP = 0d0 + ABSERRP = 0d0 + + !-------- + ! Hg(0) + !-------- + + ! Total Hg(0) + N = ID_Hg0(ID_Hg_tot) + Hg0_tot = STT(I,J,L,N) + + ! Sum of tagged Hg(0) + DO NN = 2, N_Hg_CATS + N = ID_Hg0(NN) + Hg0_tag = Hg0_tag + STT(I,J,L,N) + ENDDO + + ! Absolute error for Hg0 + ABSERR0 = ABS( Hg0_tot - Hg0_tag ) + + ! Relative error for Hg0 (avoid div by zero) + IF ( Hg0_tot > 0d0 ) THEN + RELERR0 = ABS( ( Hg0_tot - Hg0_tag ) / Hg0_tot ) + ELSE + RELERR0 = -999d0 + ENDIF + + !-------- + ! Hg(II) + !-------- + + ! Total Hg(II) + N = ID_Hg2(ID_Hg_tot) + Hg2_tot = STT(I,J,L,N) + + ! Sum of tagged Hg(II) + DO NN = 2, N_Hg_CATS + N = ID_Hg2(NN) + Hg2_tag = Hg2_tag + STT(I,J,L,N) + ENDDO + + ! Absolute error for Hg2 + ABSERR2 = ABS( Hg2_tot - Hg2_tag ) + + ! Relative error for Hg2 (avoid div by zero) + IF ( Hg2_tot > 0d0 ) THEN + RELERR2 = ABS( ( Hg2_tot - Hg2_tag ) / Hg2_tot ) + ELSE + RELERR2 = -999d0 + ENDIF + + !-------- + ! HgP + !-------- + + ! Total Hg(P) + N = ID_HgP(ID_Hg_tot) + HgP_tot = STT(I,J,L,N) + + ! Sum of tagged Hg(P) + DO NN = 2, N_Hg_CATS + N = ID_HgP(NN) + IF ( N > 0 ) HgP_tag = HgP_tag + STT(I,J,L,N) + ENDDO + + ! Absolute error for HgP + ABSERRP = ABS( HgP_tot - HgP_tag ) + + ! Relative error for HgP (avoid div by zero) + IF ( HgP_tot > 0d0 ) THEN + RELERRP = ABS( ( HgP_tot - HgP_tag ) / HgP_tot ) + ELSE + RELERRP = -999d0 + ENDIF + + !---------------------------- + ! Hg(0) error is too large + !---------------------------- + IF ( RELERR0 > MAX_RELERR .and. ABSERR0 > MAX_ABSERR ) THEN +! OMP CRITICAL + FLAG = .TRUE. + WRITE( 6, 100 ) I, J, L, Hg0_tot, Hg0_tag, RELERR0, ABSERR0 +! OMP END CRITICAL + ENDIF + + !---------------------------- + ! Hg(0) error is too large + !---------------------------- + IF ( RELERR2 > MAX_RELERR .and. ABSERR2 > MAX_ABSERR ) THEN +! OMP CRITICAL + FLAG = .TRUE. + WRITE( 6, 110 ) I, J, L, Hg2_tot, Hg2_tag, RELERR2, ABSERR2 +! OMP END CRITICAL + ENDIF + + !---------------------------- + ! HgP error is too large + !---------------------------- + IF ( RELERRP > MAX_RELERR .and. ABSERRP > MAX_ABSERR ) THEN +! OMP CRITICAL + FLAG = .TRUE. + WRITE( 6, 120 ) I, J, L, HgP_tot, HgP_tag, RELERRP, ABSERRP +! OMP END CRITICAL + ENDIF + ENDDO + ENDDO + ENDDO +! OMP END PARALLEL DO + + ! FORMAT strings + 100 FORMAT( 'Hg0 error: ', 3i5, 4es13.6 ) + 110 FORMAT( 'Hg2 error: ', 3i5, 4es13.6 ) + 120 FORMAT( 'HgP error: ', 3i5, 4es13.6 ) + + ! Stop if Hg0 and Hg2 errors are too large + IF ( FLAG ) THEN + CALL ERROR_STOP( 'Tagged Hg0, Hg2, HgP do not add up!', LOC ) + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK_ATMOS_MERCURY + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_OCEAN_MERCURY( LOC ) +! +!****************************************************************************** +! Subroutine CHECK_TAGGED_HG_OC tests whether tagged tracers in Hg0aq and +! Hg2aq add properly within each grid box. (cdh, bmy, 3/28/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) LOC (CHARACTER) : Name of routine where CHECK_OCEAN_MERCURY is called +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LSPLIT + USE TRACERID_MOD, ONLY : ID_Hg_tot, N_Hg_CATS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: LOC + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: FLAG + INTEGER :: I, J + REAL*8 :: Hg0_tot, Hg0_tag, RELERR0, ABSERR0 + REAL*8 :: Hg2_tot, Hg2_tag, RELERR2, ABSERR2 + + !================================================================= + ! CHECK_OCEAN_MERCURY begins here! + !================================================================= + + ! Set error condition flag + FLAG = .FALSE. + + ! Loop over ocean surface boxes +! OMP PARALLEL DO +! OMP+DEFAULT( SHARED ) +! OMP+PRIVATE( I, J, Hg0_tot, Hg0_tag, RELERR0, ABSERR0 ) +! OMP+PRIVATE Hg2_tot, Hg2_tag, RELERR2, ABSERR2 ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + !-------------------------------------- + ! Relative and absolute errors for Hg0 + !-------------------------------------- + Hg0_tot = Hg0aq(I,J,ID_Hg_tot) + Hg0_tag = SUM( Hg0aq(I,J,2:N_Hg_CATS) ) + ABSERR0 = ABS( Hg0_tot - Hg0_tag ) + + ! Avoid div by zero + IF ( Hg0_tot > 0d0 ) THEN + RELERR0 = ABS( ( Hg0_tot - Hg0_tag ) / Hg0_tot ) + ELSE + RELERR0 = -999d0 + ENDIF + + !-------------------------------------- + ! Relative and absolute errors for Hg2 + !-------------------------------------- + Hg2_tot = Hg2aq(I,J,ID_Hg_tot) + Hg2_tag = SUM( Hg2aq(I,J,2:N_Hg_CATS) ) + ABSERR2 = ABS( Hg2_tot - Hg2_tag ) + + ! Avoid div by zero + IF ( Hg2_tot > 0d0 ) THEN + RELERR2 = ABS( ( Hg2_tot - Hg2_tag ) / Hg2_tot ) + ELSE + RELERR2 = -999d0 + ENDIF + + !-------------------------------------- + ! Hg(0) error is too large + !-------------------------------------- + IF ( RELERR0 > MAX_RELERR .and. ABSERR0 > MAX_ABSERR ) THEN +! OMP CRITICAL + FLAG = .TRUE. + WRITE( 6, 100 ) I, J, Hg0_tot, Hg0_tag, RELERR0, ABSERR0 +! OMP END CRITICAL + ENDIF + + !-------------------------------------- + ! Hg(II) error is too large + !-------------------------------------- + IF ( RELERR2 > MAX_RELERR .and. ABSERR2 > MAX_ABSERR ) THEN +! OMP CRITICAL + FLAG = .TRUE. + WRITE( 6, 110 ) I, J, Hg2_tot, Hg2_tag, RELERR2, ABSERR2 +! OMP END CRITICAL + ENDIF + ENDDO + ENDDO +! OMP END PARALLEL DO + + ! FORMAT strings + 100 FORMAT( 'Hg0aq error: ', 2i5, 4es13.6 ) + 110 FORMAT( 'Hg2aq error: ', 2i5, 4es13.6 ) + + ! Stop if Hg0 and Hg2 errors are too large + IF ( FLAG ) THEN + CALL ERROR_STOP( 'Tagged Hg0aq, Hg2aq do not add up!', LOC ) + ENDIF + + ! Return to calling program + END SUBROUTINE CHECK_OCEAN_MERCURY + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_OCEAN_FLUXES( LOC ) +! +!****************************************************************************** +! Subroutine CHECK_OCEAN_FLUXES tests whether the drydep and wetdep fluxes in +! DD_Hg2 and WD_Hg2 sum together in each grid box. (cdh, bmy, 3/28/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) LOC (CHARACTER) : Name of routine where CHECK_OCEAN_FLUXES is called +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LSPLIT + USE TRACERID_MOD, ONLY : ID_Hg_tot, N_Hg_CATS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: LOC + + ! Local variables + LOGICAL :: FLAG + INTEGER :: I, J + REAL*8 :: DD_tot, DD_tag + REAL*8 :: DD_RELERR, DD_ABSERR + REAL*8 :: WD_tot, WD_tag + REAL*8 :: WD_RELERR, WD_ABSERR + + !================================================================= + ! CHECK_OCEAN_MERCURY begins here! + !================================================================= + + ! Echo + WRITE( 6, 100 ) + 100 FORMAT( ' - In CHECK_OCEAN_FLUXES' ) + + ! Set error condition flag + FLAG = .FALSE. + + ! Loop over ocean surface boxes +! OMP PARALLEL DO +! OMP+DEFAULT( SHARED ) +! OMP+PRIVATE( I, J, DD_tot, DD_tag, DD_RELERR, DD_ABSERR ) +! OMP+PRIVATE( WD_tot, WD_tag, WD_RELERR, WD_ABSERR ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + !--------------------------------------- + ! Absolute & relative errors for DD_Hg2 + !--------------------------------------- + DD_tot = DD_Hg2(I,J,1) + DD_tag = SUM( DD_Hg2(I,J,2:N_Hg_CATS) ) + DD_ABSERR = ABS( DD_tot - DD_tag ) + + ! Avoid div by zero + IF ( DD_tot > 0d0 ) THEN + DD_RELERR = ABS( ( DD_tot - DD_tag ) / DD_tot ) + ELSE + DD_RELERR = -999d0 + ENDIF + + !--------------------------------------- + ! Absolute & relative errors for WD_Hg2 + !--------------------------------------- + WD_tot = WD_Hg2(I,J,1) + WD_tag = SUM( WD_Hg2(I,J,2:N_Hg_CATS) ) + WD_ABSERR = ABS( WD_tot - WD_tag ) + + ! Avoid div by zero + IF ( WD_tot > 0d0 ) THEN + WD_RELERR = ABS( ( WD_tot - WD_tag ) / WD_tot ) + ELSE + WD_RELERR = -999d0 + ENDIF + + !--------------------------------------- + ! DD flux error is too large + !--------------------------------------- + IF ( DD_RELERR > MAX_RELERR .and. DD_ABSERR > MAX_FLXERR ) THEN +! OMP CRITICAL + FLAG = .TRUE. + WRITE( 6, 110 ) I, J, DD_tot, DD_tag, DD_RELERR, DD_ABSERR +! OMP END CRITICAL + ENDIF + + !--------------------------------------- + ! WD flux error is too large + !--------------------------------------- + IF ( WD_RELERR > MAX_RELERR .and. WD_ABSERR > MAX_FLXERR ) THEN +! OMP CRITICAL + FLAG = .TRUE. + WRITE( 6, 120 ) I, J, WD_tot, WD_tag, WD_RELERR, WD_ABSERR +! OMP END CRITICAL + ENDIF + ENDDO + ENDDO +! OMP END PARALLEL DO + + ! FORMAT strings + 110 FORMAT( 'DD_Hg2 flux error: ', 2i5, 4es13.6 ) + 120 FORMAT( 'WD_Hg2 flux error: ', 2i5, 4es13.6 ) + + ! Stop if Hg0 and Hg2 errors are too large + IF ( FLAG ) THEN + CALL ERROR_STOP( 'Tagged DD, WD fluxes do not add up!', LOC ) + ENDIf + + ! Return to calling program + END SUBROUTINE CHECK_OCEAN_FLUXES + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_FLUX_OUT( FLUX, LOC ) +! +!****************************************************************************** +! Subroutine CHECK_FLUX_OUT tests whether tagged quantities in FLUX sum +! together in each grid box. (cdh, bmy, 3/20/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FLUX (REAL*8) : Flux array (output of OCEAN_MERCURY_FLUX) +! (2 ) LOC (CHARACTER) : Name of routine where CHECK_FLUX_OUT is called +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP + USE LOGICAL_MOD, ONLY : LSPLIT + USE TRACERID_MOD, ONLY : ID_Hg_tot, N_Hg_CATS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*8, INTENT(IN) :: FLUX(IIPAR,JJPAR,N_Hg_CATS) + CHARACTER(LEN=*), INTENT(IN) :: LOC + + ! Local variables + LOGICAL :: FLAG + INTEGER :: I, J + REAL*8 :: FLX_tot, FLX_tag + REAL*8 :: FLX_RELERR, FLX_ABSERR + + !================================================================= + ! CHECK_FLUX_OUT begins here! + !================================================================= + + ! Echo + WRITE( 6, 100 ) + 100 FORMAT( ' - In CHECK_FLUX_OUT' ) + + ! Set error condition flag + FLAG = .FALSE. + + ! Loop over ocean surface boxes +! OMP PARALLEL DO +! OMP+DEFAULT( SHARED ) +! OMP+PRIVATE( I, J, FLX_tot, FLX_tag, FLX_err ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + !---------------------------------------- + ! Absolute & relative errors for FLX_Hg2 + !---------------------------------------- + FLX_tot = FLUX(I,J,1) + FLX_tag = SUM( FLUX(I,J,2:N_Hg_CATS) ) + FLX_ABSERR = ABS( FLX_tot - FLX_tag ) + + ! Avoid div by zero + IF ( FLX_tot > 0d0 ) THEN + FLX_RELERR = ABS( ( FLX_tot - FLX_tag ) / FLX_tot ) + ELSE + FLX_RELERR = -999d0 + ENDIF + + !---------------------------- + ! Flux error is too large + !---------------------------- + IF ( FLX_RELERR > MAX_RELERR .and. + & FLX_ABSERR > MAX_ABSERR ) THEN +! OMP CRITICAL + FLAG = .TRUE. + WRITE( 6, 110 ) I, J, FLX_tot, FLX_tag, + & FLX_RELERR, FLX_ABSERR +! OMP END CRITICAL + ENDIF + + ENDDO + ENDDO +! OMP END PARALLEL DO + + ! FORMAT strings + 110 FORMAT( 'FLX_Hg2 flux error: ', 2i5, 4es13.6 ) + + ! Stop if Hg0 and Hg2 errors are too large + IF ( FLAG ) THEN + CALL ERROR_STOP( 'Tagged emission fluxes do not add up!', LOC ) + ENDIf + + ! Return to calling program + END SUBROUTINE CHECK_FLUX_OUT + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_OCEAN_MERCURY( THIS_Hg_RST_FILE, THIS_USE_CHECKS ) +! +!****************************************************************************** +! Subroutine INIT_OCEAN_MERCURY allocates and zeroes module arrays. +! (sas, cdh, bmy, 1/19/05, 3/28/06) +! +! NOTES: +! (1 ) Now make sure all USE statements are USE, ONLY (bmy, 10/3/05) +! (2 ) Now just allocates arrays. We have moved the reading of the ocean +! Hg restart file to READ_OCEAN_Hg_RESTART. Now make Hg0aq and Hg2aq +! 3-D arrays. Now pass Hg_RST_FILE and USE_CHECKS from "input_mod.f" +! via the argument list. (cdh, sas, bmy, 2/27/06) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE TRACERID_MOD, ONLY : N_Hg_CATS + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: THIS_Hg_RST_FILE + LOGICAL, INTENT(IN) :: THIS_USE_CHECKS + + ! Local variables + INTEGER :: AS + + !================================================================= + ! INIT_OCEAN_MERCURY begins here! + !================================================================= + + ! Ocean Hg restart file name + Hg_RST_FILE = THIS_Hg_RST_FILE + + ! Turn on error checks for tagged & total sums? + USE_CHECKS = THIS_USE_CHECKS + + ! Allocate arrays + ALLOCATE( DD_Hg2( IIPAR, JJPAR, N_Hg_CATS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DD_Hg2' ) + DD_Hg2 = 0d0 + + ALLOCATE( dMLD( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'dMLD' ) + dMLD = 0d0 + + ALLOCATE( Hg0aq( IIPAR, JJPAR, N_Hg_CATS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'Hg0aq' ) + Hg0aq = 0d0 + + ALLOCATE( Hg2aq( IIPAR, JJPAR, N_Hg_CATS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'Hg2aq' ) + Hg2aq = 0d0 + + ALLOCATE( HgC( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'HgC' ) + HgC = 0d0 + + ALLOCATE( MLD( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MLD' ) + MLD = 0d0 + + ALLOCATE( MLDav( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MLDav' ) + MLDav = 0d0 + + ALLOCATE( newMLD( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'newMLD' ) + newMLD = 0d0 + + ALLOCATE( NPP( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NPP' ) + NPP = 0d0 + + ALLOCATE( UPVEL( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'UPVEL' ) + UPVEL = 0d0 + + ALLOCATE( WD_Hg2( IIPAR, JJPAR, N_Hg_CATS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'WD_Hg2' ) + WD_Hg2 = 0d0 + + ! Return to calling program + END SUBROUTINE INIT_OCEAN_MERCURY + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_OCEAN_MERCURY +! +!****************************************************************************** +! Subroutine CLEANUP_OCEAN_MERCURY deallocates all arrays. +! (sas, cdh, bmy, 1/20/05, 3/28/06) +! +! NOTES: +! (1 ) Now call GET_HALFPOLAR from "bpch2_mod.f" to get the HALFPOLAR flag +! value for GEOS or GCAP grids. (bmy, 6/28/05) +! (2 ) Now just deallocate arrays. We have moved the writing of the Hg +! restart file to MAKE_OCEAN_Hg_RESTART. Now also deallocate HgC, dMLD +! and MLDav arrays. (sas, cdh, bmy, 3/28/06) +!****************************************************************************** +! + !================================================================= + ! CLEANUP_OCEAN_MERCURY begins here! + !================================================================= + IF ( ALLOCATED( DD_Hg2 ) ) DEALLOCATE( DD_Hg2 ) + IF ( ALLOCATED( dMLD ) ) DEALLOCATE( dMLD ) + IF ( ALLOCATED( Hg0aq ) ) DEALLOCATE( Hg0aq ) + IF ( ALLOCATED( Hg2aq ) ) DEALLOCATE( Hg2aq ) + IF ( ALLOCATED( HgC ) ) DEALLOCATE( HgC ) + IF ( ALLOCATED( MLD ) ) DEALLOCATE( MLD ) + IF ( ALLOCATED( MLDav ) ) DEALLOCATE( MLDav ) + IF ( ALLOCATED( newMLD ) ) DEALLOCATE( newMLD ) + IF ( ALLOCATED( NPP ) ) DEALLOCATE( NPP ) + IF ( ALLOCATED( UPVEL ) ) DEALLOCATE( UPVEL ) + IF ( ALLOCATED( WD_Hg2 ) ) DEALLOCATE( WD_Hg2 ) + + ! Return to calling program + END SUBROUTINE CLEANUP_OCEAN_MERCURY + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE OCEAN_MERCURY_MOD diff --git a/code/ohsave.f b/code/ohsave.f new file mode 100644 index 0000000..6cf0722 --- /dev/null +++ b/code/ohsave.f @@ -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 diff --git a/code/optdepth_mod.f b/code/optdepth_mod.f new file mode 100644 index 0000000..7fe5298 --- /dev/null +++ b/code/optdepth_mod.f @@ -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 + + + + + diff --git a/code/paranox_mod.f b/code/paranox_mod.f new file mode 100644 index 0000000..05c340a --- /dev/null +++ b/code/paranox_mod.f @@ -0,0 +1,1009 @@ +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: paranox_mod +! +! !DESCRIPTION: Module PARANOX\_MOD contains subroutines for reading and +! interpolating look up tables necessary for the PARANOX (PARAmeterization +! of emitted NOX) ship plume model developed by G.C.M. Vinken. +!\\ +!\\ +! !INTERFACE: +! + MODULE PARANOX_MOD +! +! !USES: +! + USE inquireMod, ONLY : findFreeLUN + + IMPLICIT NONE + PRIVATE +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: READ_PARANOX_LUT +!############################################## +! Prior to 5/31/13: +! Comment out, this is not used (bmy, 5/31/13) +! PUBLIC :: INTERPOLATE_LUT +!############################################## + PUBLIC :: INTERPOLATE_LUT2 + PUBLIC :: FRACNOX, INTOPE +! +! !MODULE VARIABLES +! + ! fracnox = look up table for fraction of NOx remaining + ! for ship emissions (gvinken, 6/6/10) + ! intope = look up table for integrated Ozone Production + ! Efficiency for ship emiss (gvinken, 6/6/10) + REAL*4 :: fracnox(4,4,4,12,12,4,5) + REAL*4 :: intope(4,4,4,12,12,4,5) +! +! !REMARKS +! References: +! ============================================================================ +! (1 ) Vinken, G.C.M., Boersma, K.F., Jacob, D.J., and Meijer, E.W.: +! Accounting for non-linear chemistry of ship plumes in the GEOS-Chem +! global chemistry transport model, Atmos. Chem. Phys., 11, 11707-11722, +! doi:10.5194/acp-11-11707-2011, 2011. +! +! !REVISION HISTORY: +! 06 Feb 2012 - M. Payer - Initial version +! 01 Mar 2012 - R. Yantosca - Use updated GET_LOCALTIME from time_mod.F +! 03 Aug 2012 - R. Yantosca - Move calls to findFreeLUN out of DEVEL block +!EOP +!------------------------------------------------------------------------------ +!BOC + CONTAINS +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: read_paranox_lut +! +! !DESCRIPTION: Subroutine READ\_PARANOX\_LUT reads look up tables for use in +! the PARANOX ship plume model (G.C.M. Vinken) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE READ_PARANOX_LUT +! +! !USES: +! + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE FILE_MOD, ONLY : IOERROR +! +! !REVISION HISTORY: +! 06 Feb 2012 - M. Payer - Initial version modified from code provided by +! G.C.M. Vinken +! 01 Aug 2012 - R. Yantosca - Add reference to findFreeLUN from inqure_mod.F90 +! 03 Aug 2012 - R. Yantosca - Move calls to findFreeLUN out of DEVEL block +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: + INTEGER :: IOS + CHARACTER(LEN=255) :: FILENAME + INTEGER :: IU_FILE + + !================================================================= + ! READ_PARANOX_LUT begins here + !================================================================= + + !================================================================= + ! Read look up table for fraction of NOx remaining for ship + ! emissions [unitless] + !================================================================= + + ! File name + FILENAME = TRIM( DATA_DIR_1x1 ) // 'PARANOX_201202/' // + & 'FracNOx_binary_5hrs_20gs.dat' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( 'READ_PARANOX_LUT: Reading ', a ) + + ! Find a free file LUN + IU_FILE = findFreeLUN() + + ! Open file to read + OPEN( IU_FILE, FILE=TRIM( FILENAME ), FORM="binary", + & IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_paranox_lut:1' ) + + ! Read file + READ( IU_FILE, IOSTAT=IOS ) FRACNOX + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_paranox_lut:2' ) + + !PRINT*, "binary_fracnox: ", FRACNOX(1:4,1,1,2,3,4,4) + + ! Close file + CLOSE( IU_FILE ) + + !================================================================= + ! Read look up table for integrated Ozone Production Efficiency + ! for ship emissions [molec O3 produced / molec NOx lost] + !================================================================= + + ! File name + FILENAME = TRIM( DATA_DIR_1x1 ) // 'PARANOX_201202/' // + & 'IntOPE_binary_5hrs_20gs.dat' + + ! Echo info + WRITE( 6, 101 ) TRIM( FILENAME ) + 101 FORMAT( 'READ_PARANOX_LUT: Reading ', a ) + + ! Find a free file LUN + IU_FILE = findFreeLUN() + + ! Open file to read + OPEN( IU_FILE, FILE=TRIM( FILENAME ), FORM="BINARY" ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_paranox_lut:3' ) + + ! Read file + READ( IU_FILE, IOSTAT=IOS ) INTOPE + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_paranox_lut:4' ) + + !PRINT*, "binary_intope: ", INTOPE(1:4,1,1,2,3,4,4) + + ! Close file + CLOSE( IU_FILE ) + + END SUBROUTINE READ_PARANOX_LUT +!EOC +!############################################################################### +! Prior to 5/31/13: +! Comment out, this subroutine is not used here (bmy, 5/31/13) +!!------------------------------------------------------------------------------ +!! Harvard University Atmospheric Chemistry Modeling Group ! +!!------------------------------------------------------------------------------ +!!BOP +!! +!! !IROUTINE: interpolate_lut +!! +!! !DESCRIPTION: Subroutine INTERPOLATE\_LUT returns FracNOx or IntOPE from the +!! lookup table (G.C.M. Vinken, KNMI, June 2010) +!!\\ +!!\\ +!! !INTERFACE: +!! +! SUBROUTINE INTERPOLATE_LUT( I, J, JO1D, JNO2, fraction_nox, int_ope, +! & Input_Opt, State_Met, State_Chm ) +!! +!! !USES: +!! +! USE TRACERID_MOD, ONLY : IDO3, IDTO3, IDTCO +! USE GIGC_Input_Opt_Mod, ONLY : OptInput +! USE GIGC_State_Chm_Mod, ONLY : ChmState +! USE TIME_MOD, ONLY : GET_LOCALTIME +! USE ERROR_MOD, ONLY : ERROR_STOP +! USE GIGC_State_Met_Mod, ONLY : MetState +! +! USE CMN_FJ_MOD ! Photolysis parameters +! USE CMN_SIZE_MOD +!! +!! !INPUT PARAMETERS: +!! +! INTEGER, INTENT(IN) :: I, J +! REAL*8, INTENT(IN) :: JO1D, JNO2 +! TYPE(OptInput), INTENT(IN) :: OptInput ! Input options object +! TYPE(MetState), INTENT(IN) :: State_Met ! Meteorology State object +!! +!! !INPUT/OUTPUT PARAMETERS: +!! +! TYPE(ChmState), INTENT(INOUT) :: State_Chm ! Chemistry State object +!! +!! !OUTPUT PARAMETERS: +!! +! REAL, INTENT(OUT) :: fraction_nox, int_ope +!! +!! !REVISION HISTORY: +!! Jun 2010 - G.C.M. Vinken - Initial version +!! 06 Feb 2012 - M. Payer - Moved from emissions_mod.F to paranox_mod.F; +!! Added ProTeX headers +!! 15 Feb 2012 - M. Payer - Add error trap to ensure 0 < fracnox < 1. +!! 09 Nov 2012 - M. Payer - Replaced all met field arrays with State_Met +!! derived type object +!! 28 Nov 2012 - R. Yantosca - Replace SUNCOS_MID w/ State_Met%SUNCOSmid +!! 28 Nov 2012 - R. Yantosca - Replace SUNCOS_MID_5hr w/ State_Met%SUNCOSmid5 +!! 14 Mar 2013 - M. Payer - Replace Ox with O3 as part of removal of +!! NOx-Ox partitioning +!! 30 May 2013 - R. Yantosca - Replace TCVV with Input_Opt%TCVV +! +!!EOP +!!------------------------------------------------------------------------------ +!!BOC +!! +!! !LOCAL VARIABLES: +!! +! !======================================================================= +! ! temp : model temperature +! ! jno2 : J(NO2) value +! ! cao3 : concentration O3 in ambient air +! ! alfa0 : solar zenith angle 5 hours ago +! ! alfa5 : solar zenith angle at this time +! ! jo1d : ratio J(O1D)/J(NO2) +! ! caco : concentration CO in ambient air +! !======================================================================= +! +! INTEGER :: IJLOOP +! INTEGER, PARAMETER :: ntemp = 4 +! INTEGER, PARAMETER :: njno2 = 4 +! INTEGER, PARAMETER :: ncao3 = 4 +! integer, PARAMETER :: nalfa0 = 12 +! INTEGER, PARAMETER :: nalfa5 = 12 +! INTEGER, PARAMETER :: njo1d = 4 +! INTEGER, PARAMETER :: ncaco = 4 +! +! REAL, DIMENSION(ntemp) :: templev +! REAL, DIMENSION(njno2) :: jno2lev +! REAL, DIMENSION(ncao3) :: cao3lev +! REAL, DIMENSION(nalfa0) :: alfa0lev +! REAL, DIMENSION(nalfa5) :: alfa5lev +! REAL, DIMENSION(njo1d) :: jo1dlev +! REAL, DIMENSION(ncaco) :: cacolev +! +! ! Temporary variable storage +! REAL :: temp_tmp, jno2_tmp, cao3_tmp +! REAL :: alfa0_tmp, alfa5_tmp, jo1d_tmp +! REAL :: caco_tmp +! +! ! Interpolation parameters +! REAL, DIMENSION(2) :: xtemp, xjno2, xcao3, xalfa0 +! REAL, DIMENSION(2) :: xalfa5, xjo1d, xcaco +! +! ! For loops +! INTEGER :: itemp, ijno2, icao3, ialfa0 +! INTEGER :: ialfa5, ijo1d, icaco +! INTEGER :: i0,i1,i2,i3,i4,i5,i6,i7 +! +! ! array contain temp, jno2, cao3, alfa_0, alfa_5, jo1d, caco +! REAL,DIMENSION(7) :: var_array +! +! CHARACTER(LEN=255) :: MSG +! +! ! Pointers +! ! We need to define local arrays to hold corresponding values +! ! from the Chemistry State (State_Chm) object. (mpayer, 12/6/12) +! REAL*8, POINTER :: STT(:,:,:,:) +! +! !================================================================= +! ! INTERPOLATE_LUT begins here! +! !================================================================= +! +! stt => State_Chm%TRACERS +! +! ! Set the levels that were chosen in the look up table +! templev = (/ 275., 280., 285., 300. /) +! jno2lev = (/ 5.e-4, 0.0025, 0.0050, 0.012 /) +! cao3lev = (/ 5., 20., 35., 75. /) +! alfa0lev = (/ -90., -60., -45., -30., +! $ -15., 0., 15., 30., +! $ 45., 60., 75., 90. /) +! alfa5lev = (/ -90., -60., -45., -30., +! $ -15., 0., 15., 30., +! $ 45., 60., 75., 90. /) +! jo1dlev = (/ 5.e-4, 0.0015, 0.0025, 0.0055 /) +! cacolev = (/ 50., 100., 150., 1200. /) +! +!! PRINT*,"Temperature levels are: ",templev +!! PRINT*,"This is grid cell: ",I,J +! +! ! Temperature +!! PRINT*,"Temperature here is: ",State_Met%TS(I,J) +!! PRINT*,"USA: ", State_Met%TS(32,64) +! +! ! Tracer concentrations in v/v +!! PRINT*,"[O3] is: ",STT(I,J,1,IDTOX3)/ State_Met%AD(I,J,1) * TCVV(IDTO3) +!! PRINT*,"[CO] is: ",STT(I,J,1,IDTCO)/ State_Met%AD(I,J,1) * TCVV(IDTCO) +!! PRINT*,"IDTO3 is: ", IDTO3 +!! PRINT*,"IDO3 is: ", IDO3 +!! PRINT*,"In USA: ",STT(32,64,1,IDTO3)/State_Met%AD(32,64,1) * TCVV(IDTO3) +! +! ! SOLAR ZENITH ANGLES IN DEGREES +!! IJLOOP = ( (J-1) * IIPAR ) + I +!! PRINT*,"Local Time: ",GET_LOCALTIME(I,1,1) +!! PRINT*,"Solar Zenith Angle at this location: ", +!! $ ASIND(State_Met%SUNCOSmid(I,J)) +!! IJLOOP = ( (64-1) * IIPAR ) + 32 +!! PRINT*,"Local USA time: ", GET_LOCALTIME(32,1,1) +!! PRINT*,"Solar Zenith Angle at USA: ", +!! & ASIND(State_Met%SUNCOSmid(I,J)) +!! PRINT*,"Solar Zenith Angle at USA - 5: ", +!! & ASIND(State_Met%SUNCOSmid5(I,J)) +! +! ! Set the variables +! IJLOOP = ( (J-1) * IIPAR ) + I +! var_array(1) = State_Met%TS(I,J) ! Temperature +! var_array(2) = JNO2 ! J(NO2) +! var_array(3) = STT(I,J,1,IDTO3) / ! [O3] in ppbv +! $ State_Met%AD(I,J,1) * +! $ Input_OPt%TCVV(IDTO3) * 1.E9 +! var_array(4) = ASIND(State_Met%SUNCOSmid5(I,J)) ! alfa0 +! var_array(5) = ASIND(State_Met%SUNCOSmid(I,J)) ! alfa5 +! var_array(6) = JO1D / JNO2 ! J(O1D)/J(NO2) +! var_array(7) = STT(I,J,1,IDTCO) / ! [CO] in ppbv +! $ State_Met%AD(I,J,1) * +! $ Input_Opt%TCVV(IDTCO) * 1.E9 +! +! ! prevent NaN when jvalues are 0. +! IF (JNO2 .eq. 0.) var_array(6) = 0. +! +! ! First some error checking +! ! ########### MAYBE CHECK HERE FOR NEGATIVE VALUES?########## +! +! ! +! ! Determine reference index ( itemp, ijno2, icao3, ialfa0, +! ! ialfa5, ialfa, ijo1d, icaco ) +! ! +! !================================================================= +! ! Find smallest temperature reference level (i) for which actual +! ! temperature is smaller, then do +! ! +! ! x(1) = ( temperature_level(i+1) - actual temperature ) +! ! ------------------------------------------------- +! ! ( temperature_level(i+1) - temperature_level(i) ) +! ! +! ! then x(2) = 1.0 - x(1) +! ! +! !================================================================= +! +! !---------------------- +! ! Temperature: +! !---------------------- +! temp_tmp = var_array(1) +! +! ! If temperature larger than largest in LUT, assign largest temp +! IF ( var_array(1) > templev( ntemp ) ) temp_tmp = templev(ntemp) +! +! ! If temp smaller, assign smallest temp level +! IF ( var_array(1) < templev(1) ) temp_tmp = templev(1) +! +! DO i0=1,ntemp-1 +! itemp = i0 +! IF( templev( itemp+1 ) > temp_tmp ) EXIT +! END DO +! +! xtemp(1) = ( templev( itemp+1 ) - temp_tmp ) / +! $ ( templev( itemp+1 ) - templev( itemp ) ) +! xtemp(2) = 1.0 - xtemp(1) +! +! !---------------------- +! ! J(NO2): +! !---------------------- +! jno2_tmp = var_array(2) +! +! ! If larger than largest in LUT, assign largest level values +! IF ( var_array(2) > jno2lev( njno2 ) ) jno2_tmp = jno2lev(njno2) +! +! ! If smaller, assign smallest level value +! IF ( var_array(2) < jno2lev(1) ) jno2_tmp = jno2lev(1) +! +! DO i0=1,njno2-1 +! ijno2 = i0 +! IF( jno2lev( ijno2+1 ) > jno2_tmp ) EXIT +! END DO +! +! xjno2(1) = ( jno2lev( ijno2+1 ) - jno2_tmp ) / +! $ ( jno2lev( ijno2+1 ) - jno2lev( ijno2 ) ) +! xjno2(2) = 1.0 - xjno2(1) +! +! !---------------------- +! ! [O3]: +! !---------------------- +! cao3_tmp = var_array(3) +! +! ! If larger than largest in LUT, assign largest level values +! IF ( var_array(3) > cao3lev( ncao3 ) ) cao3_tmp = cao3lev(ncao3) +! +! ! If smaller, assign smallest level value +! IF ( var_array(3) < cao3lev(1) ) cao3_tmp = cao3lev(1) +! +! DO i0=1,ncao3-1 +! icao3 = i0 +! IF( cao3lev( icao3+1 ) > cao3_tmp ) EXIT +! END DO +! +! xcao3(1) = ( cao3lev( icao3+1 ) - cao3_tmp ) / +! $ ( cao3lev( icao3+1 ) - cao3lev( icao3 ) ) +! xcao3(2) = 1.0 - xcao3(1) +! +! !---------------------- +! ! alfa0: +! !---------------------- +! alfa0_tmp = var_array(4) +! +! ! If larger than largest in LUT, assign largest level values +! IF ( var_array(4) > alfa0lev( nalfa0 ) ) alfa0_tmp = +! $ alfa0lev(nalfa0) +! +! ! If smaller, assign smallest level value +! IF ( var_array(4) < alfa0lev(1) ) alfa0_tmp = alfa0lev(1) +! +! DO i0=1,nalfa0-1 +! ialfa0 = i0 +! IF( alfa0lev( ialfa0+1 ) > alfa0_tmp ) EXIT +! END DO +! +! xalfa0(1) = ( alfa0lev( ialfa0+1 ) - alfa0_tmp ) / +! $ ( alfa0lev( ialfa0+1 ) - alfa0lev( ialfa0 ) ) +! xalfa0(2) = 1.0 - xalfa0(1) +! +! !---------------------- +! ! alfa5: +! !---------------------- +! alfa5_tmp = var_array(5) +! +! ! If larger than largest in LUT, assign largest level values +! IF ( var_array(5) > alfa5lev( nalfa5 ) ) alfa5_tmp = +! $ alfa5lev(nalfa5) +! +! ! If smaller, assign smallest level value +! IF ( var_array(5) < alfa5lev(1) ) alfa5_tmp = alfa5lev(1) +! +! DO i0=1,nalfa5-1 +! ialfa5 = i0 +! IF( alfa5lev( ialfa5+1 ) > alfa5_tmp ) EXIT +! END DO +! +! xalfa5(1) = ( alfa5lev( ialfa5+1 ) - alfa5_tmp ) / +! $ ( alfa5lev( ialfa5+1 ) - alfa5lev( ialfa5 ) ) +! xalfa5(2) = 1.0 - xalfa5(1) +! +! !---------------------- +! ! jo1d: +! !---------------------- +! jo1d_tmp = var_array(6) +! +! ! If larger than largest in LUT, assign largest level values +! IF ( var_array(6) > jo1dlev( njo1d ) ) jo1d_tmp = jo1dlev(njo1d) +! +! ! If smaller, assign smallest level value +! IF ( var_array(6) < jo1dlev(1) ) jo1d_tmp = jo1dlev(1) +! +! DO i0=1,njo1d-1 +! ijo1d = i0 +! IF( jo1dlev( ijo1d+1 ) > jo1d_tmp ) EXIT +! END DO +! +! xjo1d(1) = ( jo1dlev( ijo1d+1 ) - jo1d_tmp ) / +! $ ( jo1dlev( ijo1d+1 ) - jo1dlev( ijo1d ) ) +! xjo1d(2) = 1.0 - xjo1d(1) +! +! !---------------------- +! ! [CO]: +! !---------------------- +! caco_tmp = var_array(7) +! +! ! If larger than largest in LUT, assign largest level values +! IF ( var_array(7) > cacolev( ncaco ) ) caco_tmp = cacolev(ncaco) +! +! ! If smaller, assign smallest level value +! IF ( var_array(7) < cacolev(1) ) caco_tmp = cacolev(1) +! +! DO i0=1,ncaco-1 +! icaco = i0 +! IF( cacolev( icaco+1 ) > caco_tmp ) EXIT +! END DO +! +! xcaco(1) = ( cacolev( icaco+1 ) - caco_tmp ) / +! $ ( cacolev( icaco+1 ) - cacolev( icaco ) ) +! xcaco(2) = 1.0 - xcaco(1) +! +!! PRINT*,"The i-values are:", itemp, ijno2, icao3, ialfa0, +!! $ ialfa5, ijo1d, icaco +!! PRINT*,"Variables are: ", var_array +!! PRINT*,"For testing, xtemp: ", xtemp +! +! !======================== +! ! Linear interpolation +! !======================== +! +! fraction_nox = 0.0 +! int_ope = 0.0 +! +! DO i1=1,2 +! DO i2=1,2 +! DO i3=1,2 +! DO i4=1,2 +! DO i5=1,2 +! DO i6=1,2 +! DO i7=1,2 +! +! !IF ENCOUNTER -999 IN THE LUT PRINT ERROR!! +! IF ( ( fracnox( itemp+i1-1, ijno2+i2-1, icao3+i3-1, +! $ ialfa0+i4-1, ialfa5+i5-1, ijo1d+i6-1, +! $ icaco+i7-1 ) < 0. ) .or. +! $ ( fracnox( itemp+i1-1, ijno2+i2-1, icao3+i3-1, +! $ ialfa0+i4-1, ialfa5+i5-1, ijo1d+i6-1, +! $ icaco+i7-1 ) > 1. ) ) THEN +! +!! PRINT*, 'INTERPOLATE_LUT: fracnox = ,', +!! $ fracnox( itemp+i1-1, ijno2+i2-1, icao3+i3-1, +!! $ ialfa0+i4-1, ialfa5+i5-1, ijo1d+i6-1, +!! $ icaco+i7-1 ) +! +! MSG = 'LUT error: Fracnox should be between 0 and 1!' +! CALL ERROR_STOP( MSG, 'INTERPOLATE_LUT ("paranox_mod.F")' ) +! ENDIF +! +! !Cycle if both angles are 0 +! IF ((ialfa0+i4-1 .eq. 6) .and. (ialfa5+i5-1 .eq. 6) ) +! $ CYCLE +! +! ! fracnox is the array with the actual lut data +! fraction_nox = fraction_nox + xtemp(i1) * xjno2(i2) * +! $ xcao3(i3) * xalfa0(i4) * xalfa5(i5) * +! $ xjo1d(i6) * xcaco(i7) * +! $ fracnox( itemp+i1-1, ijno2+i2-1, +! $ icao3+i3-1, ialfa0+i4-1, ialfa5+i5-1, +! $ ijo1d+i6-1, icaco+i7-1 ) +! +! ! intope is the array with the actual lut data +! int_ope = int_ope + xtemp(i1) * xjno2(i2) * +! $ xcao3(i3) * xalfa0(i4) * xalfa5(i5) * +! $ xjo1d(i6) * xcaco(i7) * +! $ intope( itemp+i1-1, ijno2+i2-1, +! $ icao3+i3-1, ialfa0+i4-1, ialfa5+i5-1, +! $ ijo1d+i6-1, icaco+i7-1 ) +! +! END DO +! END DO +! END DO +! END DO +! END DO +! END DO +! END DO +!! +!! IF ((I .eq. 108) .and. (J .eq. 49)) THEN +!! PRINT*,"----INTERPOLATE_LUT-----" +!! PRINT*,"fraction_nox and int_OPE: ",fraction_nox, +!! $ int_ope +!! PRINT*,"Jvalues are: ", jvalues(I, J,:) +!! PRINT*,"Vars are: ", var_array +!! PRINT*,"[O3] in interpolate_lut: ", var_array(3) +!! PRINT*,"[CO] in interpolate_lut: ", var_array(7) +!! PRINT*,"The i-values are:", itemp, ijno2, icao3, +!! $ ialfa0, ialfa5, ijo1d, +!! $ icaco +!! ENDIF +!! +!! PRINT*,"fraction_nox is: ",fraction_nox +!! PRINT*,"integrated OPE: ",int_ope +! +! NULLIFY( STT ) +! +! END SUBROUTINE INTERPOLATE_LUT +!!EOC +!############################################################################## +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: interpolate_lut2 +! +! !DESCRIPTION: Subroutine INTERPOLATE\_LUT2 returns FracNOx or IntOPE from +! the lookup tables (G.C.M. Vinken, KNMI, June 2010) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE INTERPOLATE_LUT2( I, J, o3, no, no2, dens, JO1D, JNO2, + & fraction_nox, int_ope ) +! +! !USES: +! + USE TIME_MOD, ONLY : GET_LOCALTIME + USE ERROR_MOD, ONLY : ERROR_STOP, SAFE_DIV + USE DAO_MOD, ONLY : TS, SUNCOS, SUNCOS_5hr + +# include "CMN_SIZE" ! Size parameters + +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: I, J + REAL*8, INTENT(IN) :: o3, no, no2, dens, JNO2, JO1D + +! +! !OUTPUT PARAMETERS: +! + REAL*4, INTENT(OUT) :: fraction_nox, int_ope +! +! !REVISION HISTORY: +! Jun 2010 - G.C.M. Vinken - Initial version +! 21 Feb 2011 - G.C.M. Vinken - Updated for NOx in LUT +! 06 Feb 2012 - M. Payer - Moved from emissions_mod.F to paranox_mod.F; +! Added ProTeX headers +! 15 Feb 2012 - M. Payer - Add error trap to ensure 0 < fracnox < 1. +! 09 Nov 2012 - M. Payer - Replaced all met field arrays with State_Met +! derived type object +! 28 Nov 2012 - R. Yantosca - Replace SUNCOS_MID w/ State_Met%SUNCOSmid +! 28 Nov 2012 - R. Yantosca - Replace SUNCOS_MID_5hr w/ State_Met%SUNCOSmid5 +! 17 Jun 2013 - R. Yantosca - Bug fix: declare all REAL variables with +! REAL*4 in order to avoid numerical precision +! errors when compiling with OMP=yes. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + + !======================================================================= + ! temp : model temperature + ! jno2 : J(NO2) value + ! cao3 : concentration O3 in ambient air + ! alfa0 : solar zenith angle 5 hours ago + ! alfa5 : solar zenith angle at this time + ! jo1d : ratio J(O1D)/J(NO2) + ! canox : concentration NOx in ambient air + ! + ! o3 : incoming o3 concentration + ! no : incoming no + ! no2 : incoming no2 + ! dens : incoming air density + !======================================================================= + + INTEGER :: IJLOOP + INTEGER, PARAMETER :: ntemp = 4 + INTEGER, PARAMETER :: njno2 = 4 + INTEGER, PARAMETER :: ncao3 = 4 + INTEGER, PARAMETER :: nalfa0 = 12 + INTEGER, PARAMETER :: nalfa5 = 12 + INTEGER, PARAMETER :: njo1d = 4 + INTEGER, PARAMETER :: ncanox = 5 + + REAL*4, DIMENSION(ntemp) :: templev + REAL*4, DIMENSION(njno2) :: jno2lev + REAL*4, DIMENSION(ncao3) :: cao3lev + REAL*4, DIMENSION(nalfa0) :: alfa0lev + REAL*4, DIMENSION(nalfa5) :: alfa5lev + REAL*4, DIMENSION(njo1d) :: jo1dlev + REAL*4, DIMENSION(ncanox) :: canoxlev + + ! Temporary variable storage + REAL*4 :: temp_tmp, jno2_tmp, cao3_tmp + REAL*4 :: alfa0_tmp, alfa5_tmp, jo1d_tmp + REAL*4 :: canox_tmp + + ! Interpolation parameters + REAL*4, DIMENSION(2) :: xtemp, xjno2, xcao3, xalfa0 + REAL*4, DIMENSION(2) :: xalfa5, xjo1d, xcanox + + ! For loops + INTEGER :: itemp, ijno2, icao3, ialfa0 + INTEGER :: ialfa5, ijo1d, icanox + INTEGER :: i0,i1,i2,i3,i4,i5,i6,i7 + + ! array contain temp, jno2, cao3, alfa_0, alfa_5, jo1d, canox + REAL*4, DIMENSION(7) :: var_array + + CHARACTER(LEN=255) :: MSG + + !================================================================= + ! INTERPOLATE_LUT2 begins here! + !================================================================= + + ! Set the levels that were chosen in the look up table + templev = (/ 275., 280., 285., 310. /) + jno2lev = (/ 5.e-4, 0.0025, 0.0050, 0.012 /) + cao3lev = (/ 5., 20., 35., 75. /) + alfa0lev = (/ -90., -60., -45., -30., + $ -15., 0., 15., 30., + $ 45., 60., 75., 90. /) + alfa5lev = (/ -90., -60., -45., -30., + $ -15., 0., 15., 30., + $ 45., 60., 75., 90. /) + jo1dlev = (/ 5.e-4, 0.0015, 0.0025, 0.0055 /) + canoxlev = (/ 10., 200., 1000., 2000., 6000. /) + +! PRINT*,"Temperature levels are: ",templev +! PRINT*,"This is grid cell: ",I,J + + ! Temperature +! PRINT*,"Temperature here is: ",TS(I,J) +! PRINT*,"USA: ",TS(32,64) + + ! Tracer concentrations in v/v +! PRINT*,"[O3] is: ",STT(I,J,1,IDTO3)/ State_Met%AD(I,J,1) * TCVV(IDTO3) +! PRINT*,"[CO] is: ",STT(I,J,1,IDTCO)/ State_Met%AD(I,J,1) * TCVV(IDTCO) +! PRINT*,"IDTO3 is: ", IDTO3 +! PRINT*,"IDO3 is: ", IDO3 +! PRINT*,"In USA: ",STT(32,64,1,IDTO3)/State_Met%AD(32,64,1) * TCVV(IDTO3) + + ! SOLAR ZENITH ANGLES IN DEGREES +! IJLOOP = ( (J-1) * IIPAR ) + I +! PRINT*,"Local Time: ",GET_LOCALTIME(I) +! PRINT*,"Solar Zenith Angle at this location: ", +! $ ASIND(SUNCOS(IJLOOP)) +! IJLOOP = ( (64-1) * IIPAR ) + 32 +! PRINT*,"Local USA time: ", GET_LOCALTIME(32) +! PRINT*,"Solar Zenith Angle at USA: ", +! & ASIND(SUNCOS(I,J)) +! PRINT*,"Solar Zenith Angle at USA - 5: ", +! & ASIND(SUNCOS_5hr(IJLOOP)) + + ! Set the variables + IJLOOP = ( (J-1) * IIPAR ) + I + var_array(1) = TS(I,J) ! Temperature + var_array(2) = JNO2 ! J(NO2), 1/s + var_array(3) = o3 / dens * 1.E9 ! [O3] in ppbv + var_array(4) = ASIND(SUNCOS(IJLOOP)) ! alfa0 + var_array(5) = ASIND(SUNCOS_5hr(IJLOOP)) ! alfa5 + var_array(6) = SAFE_DIV( JO1D, JNO2, 0d0 ) ! J(O1D)/J(NO2) + var_array(7) = (no + no2) / dens * 1.E12 ! [NOx] in pptv + + ! prevent NaN when jvalues are 0. + IF (JNO2 .eq. 0.) var_array(6) = 0. + + ! First some error checking + ! ########### MAYBE CHECK HERE FOR NEGATIVE VALUES?########## + + ! + ! Determine reference index ( itemp, ijno2, icao3, ialfa0, + ! ialfa5, ialfa, ijo1d, icaco ) + ! + !======================================================================== + ! Find smallest temperature reference level (i) for which actual + ! temperature is smaller, then do + ! + ! x(1) = ( temperature_level(i+1) - actual temperature ) + ! ------------------------------------------------- + ! ( temperature_level(i+1) - temperature_level(i) ) + ! + ! then x(2) = 1.0 - x(1) + ! + !======================================================================== + + !--------------------- + ! Temperature: + !--------------------- + temp_tmp = var_array(1) + + ! If temperature larger than largest in LUT, assign largest temp + IF ( var_array(1) > templev( ntemp ) ) temp_tmp = templev(ntemp) + + ! If temp smaller, assign smallest temp level + IF ( var_array(1) < templev(1) ) temp_tmp = templev(1) + + DO i0=1,ntemp-1 + itemp = i0 + IF( templev( itemp+1 ) > temp_tmp ) EXIT + END DO + + xtemp(1) = ( templev( itemp+1 ) - temp_tmp ) / + $ ( templev( itemp+1 ) - templev( itemp ) ) + xtemp(2) = 1.0 - xtemp(1) + + !--------------------- + ! J(NO2): + !--------------------- + jno2_tmp = var_array(2) + + ! If larger than largest in LUT, assign largest level values + IF ( var_array(2) > jno2lev( njno2 ) ) jno2_tmp = jno2lev(njno2) + + ! If smaller, assign smallest level value + IF ( var_array(2) < jno2lev(1) ) jno2_tmp = jno2lev(1) + + DO i0=1,njno2-1 + ijno2 = i0 + IF( jno2lev( ijno2+1 ) > jno2_tmp ) EXIT + END DO + + xjno2(1) = ( jno2lev( ijno2+1 ) - jno2_tmp ) / + $ ( jno2lev( ijno2+1 ) - jno2lev( ijno2 ) ) + xjno2(2) = 1.0 - xjno2(1) + + !--------------------- + ! [O3]: + !--------------------- + cao3_tmp = var_array(3) + + ! If larger than largest in LUT, assign largest level values + IF ( var_array(3) > cao3lev( ncao3 ) ) cao3_tmp = cao3lev(ncao3) + + ! If smaller, assign smallest level value + IF ( var_array(3) < cao3lev(1) ) cao3_tmp = cao3lev(1) + + DO i0=1,ncao3-1 + icao3 = i0 + IF( cao3lev( icao3+1 ) > cao3_tmp ) EXIT + END DO + + xcao3(1) = ( cao3lev( icao3+1 ) - cao3_tmp ) / + $ ( cao3lev( icao3+1 ) - cao3lev( icao3 ) ) + xcao3(2) = 1.0 - xcao3(1) + + !--------------------- + ! alfa0: + !--------------------- + alfa0_tmp = var_array(4) + + ! If larger than largest in LUT, assign largest level values + IF ( var_array(4) > alfa0lev( nalfa0 ) ) alfa0_tmp = + $ alfa0lev(nalfa0) + + ! If smaller, assign smallest level value + IF ( var_array(4) < alfa0lev(1) ) alfa0_tmp = alfa0lev(1) + + DO i0=1,nalfa0-1 + ialfa0 = i0 + IF( alfa0lev( ialfa0+1 ) > alfa0_tmp ) EXIT + END DO + + xalfa0(1) = ( alfa0lev( ialfa0+1 ) - alfa0_tmp ) / + $ ( alfa0lev( ialfa0+1 ) - alfa0lev( ialfa0 ) ) + xalfa0(2) = 1.0 - xalfa0(1) + + !--------------------- + ! alfa5: + !--------------------- + alfa5_tmp = var_array(5) + + ! If larger than largest in LUT, assign largest level values + IF ( var_array(5) > alfa5lev( nalfa5 ) ) alfa5_tmp = + $ alfa5lev(nalfa5) + + ! If smaller, assign smallest level value + IF ( var_array(5) < alfa5lev(1) ) alfa5_tmp = alfa5lev(1) + + DO i0=1,nalfa5-1 + ialfa5 = i0 + IF( alfa5lev( ialfa5+1 ) > alfa5_tmp ) EXIT + END DO + + xalfa5(1) = ( alfa5lev( ialfa5+1 ) - alfa5_tmp ) / + $ ( alfa5lev( ialfa5+1 ) - alfa5lev( ialfa5 ) ) + xalfa5(2) = 1.0 - xalfa5(1) + + !--------------------- + ! jo1d: + !--------------------- + jo1d_tmp = var_array(6) + + ! If larger than largest in LUT, assign largest level values + IF ( var_array(6) > jo1dlev( njo1d ) ) jo1d_tmp = jo1dlev(njo1d) + + ! If smaller, assign smallest level value + IF ( var_array(6) < jo1dlev(1) ) jo1d_tmp = jo1dlev(1) + + DO i0=1,njo1d-1 + ijo1d = i0 + IF( jo1dlev( ijo1d+1 ) > jo1d_tmp ) EXIT + END DO + + xjo1d(1) = ( jo1dlev( ijo1d+1 ) - jo1d_tmp ) / + $ ( jo1dlev( ijo1d+1 ) - jo1dlev( ijo1d ) ) + xjo1d(2) = 1.0 - xjo1d(1) + + !--------------------- + ! [NOx]: + !--------------------- + canox_tmp = var_array(7) + + ! If larger than largest in LUT, assign largest level values + IF ( var_array(7) > canoxlev( ncanox ) ) canox_tmp = + $ canoxlev(ncanox) + + ! If smaller, assign smallest level value + IF ( var_array(7) < canoxlev(1) ) canox_tmp = canoxlev(1) + + DO i0=1,ncanox-1 + icanox = i0 + IF( canoxlev( icanox+1 ) > canox_tmp ) EXIT + END DO + + xcanox(1) = ( canoxlev( icanox+1 ) - canox_tmp ) / + $ ( canoxlev( icanox+1 ) - canoxlev( icanox ) ) + xcanox(2) = 1.0 - xcanox(1) + +! PRINT*,"The i-values are:", itemp, ijno2, icao3, ialfa0, +! $ ialfa5, ijo1d, icanox +! PRINT*,"Variables are: ", var_array +! PRINT*,"For testing, xtemp: ", xtemp + + !====================== + ! Linear interpolation + !====================== + + fraction_nox = 0.0 + int_ope = 0.0 + + DO i1=1,2 + DO i2=1,2 + DO i3=1,2 + DO i4=1,2 + DO i5=1,2 + DO i6=1,2 + DO i7=1,2 + + !IF ENCOUNTER -999 IN THE LUT PRINT ERROR!! + IF ( ( fracnox( itemp+i1-1, ijno2+i2-1, icao3+i3-1, + $ ialfa0+i4-1, ialfa5+i5-1, ijo1d+i6-1, + $ icanox+i7-1 ) < 0. ) .or. + $ ( fracnox( itemp+i1-1, ijno2+i2-1, icao3+i3-1, + $ ialfa0+i4-1, ialfa5+i5-1, ijo1d+i6-1, + $ icanox+i7-1 ) > 1. ) ) THEN + + PRINT*, 'INTERPOLATE_LUT2: fracnox = ', + $ fracnox( itemp+i1-1, ijno2+i2-1, icao3+i3-1, + $ ialfa0+i4-1, ialfa5+i5-1, ijo1d+i6-1, + $ icanox+i7-1 ) + + MSG = 'LUT error: Fracnox should be between 0 and 1!' + CALL ERROR_STOP( MSG, 'INTERPOLATE_LUT2 ("paranox_mod.F")' ) + ENDIF + + ! fracnox is the array with the actual lut data + fraction_nox = fraction_nox + xtemp(i1) * xjno2(i2) * + $ xcao3(i3) * xalfa0(i4) * xalfa5(i5) * + $ xjo1d(i6) * xcanox(i7) * + $ fracnox( itemp+i1-1, ijno2+i2-1, + $ icao3+i3-1, ialfa0+i4-1, ialfa5+i5-1, + $ ijo1d+i6-1, icanox+i7-1 ) + + ! intope is the array with the actual lut data + int_ope = int_ope + xtemp(i1) * xjno2(i2) * + $ xcao3(i3) * xalfa0(i4) * xalfa5(i5) * + $ xjo1d(i6) * xcanox(i7) * + $ intope( itemp+i1-1, ijno2+i2-1, + $ icao3+i3-1, ialfa0+i4-1, ialfa5+i5-1, + $ ijo1d+i6-1, icanox+i7-1 ) + + END DO + END DO + END DO + END DO + END DO + END DO + END DO + +! IF ((I .eq. 108) .and. (J .eq. 49)) THEN +! PRINT*,"-----INTERPOLATE_LUT2, for 108,49-----" +! PRINT*,"Fraction_nox and int_OPE: ", fraction_nox, +! & int_ope +! PRINT*,"Jvalues are: ", JNO2, JO1D +! PRINT*,"Vars are: ", var_array +! PRINT*,"[O3] in interpolate_lut: ", var_array(3) +! PRINT*,"[NOx] in interpolate_lut: ", var_array(7) +! PRINT*,"J(O1D)/J(NO2) : ", var_array(6) +! PRINT*,"The i-values are:", itemp, ijno2, icao3, +! $ ialfa0, ialfa5, ijo1d, +! $ icanox +! PRINT*,"Interpolation parameters: ", xtemp, xjno2, xcao3, +! $ xalfa0, xalfa5, xjo1d, +! $ xcanox +! PRINT*,"---------------------------------" +! ENDIF +! +! IF ((I .eq. 73) .and. (J .eq. 76)) THEN +! PRINT*,"-----INTERPOLATE_LUT2, for 73,76-----" +! PRINT*,"Fraction_nox and int_OPE: ", fraction_nox, +! & int_ope +! PRINT*,"Jvalues are: ", JNO2, JO1D +! PRINT*,"Vars are: ", var_array +! PRINT*,"[O3] in interpolate_lut: ", var_array(3) +! PRINT*,"[NOx] in interpolate_lut: ", var_array(7) +! PRINT*,"J(O1D)/J(NO2) : ", var_array(6) +! PRINT*,"The i-values are:", itemp, ijno2, icao3, +! $ ialfa0, ialfa5, ijo1d, +! $ icanox +! PRINT*,"Interpolation parameters: ", xtemp, xjno2, xcao3, +! $ xalfa0, xalfa5, xjo1d, +! $ xcanox +! PRINT*,"------------------------------------" +! ENDIF + + END SUBROUTINE INTERPOLATE_LUT2 +!EOC + END MODULE PARANOX_MOD + diff --git a/code/pderiv.f b/code/pderiv.f new file mode 100644 index 0000000..4f375ce --- /dev/null +++ b/code/pderiv.f @@ -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 diff --git a/code/pjc_pfix_mod.f b/code/pjc_pfix_mod.f new file mode 100644 index 0000000..57aba04 --- /dev/null +++ b/code/pjc_pfix_mod.f @@ -0,0 +1,2157 @@ +! $Id: pjc_pfix_mod.f,v 1.1 2009/06/09 21:51:50 daven Exp $ +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: Pjc_Pfix_Mod +! +! !DESCRIPTION: Module Pjc\_Pfix\_Mod contains routines which implements the +! Philip Cameron-Smith pressure fixer for the new fvDAS transport +! scheme. (bdf, bmy, 5/8/03, 10/27/03) +!\\ +!\\ +! !INTERFACE: +! + MODULE Pjc_Pfix_Mod +! +! !USES: +! + IMPLICIT NONE +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: Do_Pjc_Pfix + PUBLIC :: Cleanup_Pjc_Pfix +! +! !PRIVATE MEMBER FUNCTIONS: +! + PRIVATE :: Calc_Pressure + PRIVATE :: Calc_Advection_Factors + PRIVATE :: Adjust_Press + PRIVATE :: Init_Press_Fix + PRIVATE :: Do_Press_Fix_LLNL + PRIVATE :: Average_Press_Poles + PRIVATE :: Convert_Winds + PRIVATE :: Calc_Horiz_Mass_Flux + PRIVATE :: Calc_Divergence + PRIVATE :: Set_Press_Terms + PRIVATE :: Do_Divergence_Pole_Sum + PRIVATE :: Xpavg + PRIVATE :: Init_Pjc_Pfix +! +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! Brendan Field and Bob Yantosca (5/8/03) +! Modified for new GMI TPCORE by Claire Carouge (ccarouge@seas.harvard.edu) +! +! !REVISION HISTORY: +! (1 ) Bug fix for Linux/PGI compiler in routines ADJUST_PRESS and +! INIT_PRESS_FIX. (bmy, 6/23/03) +! (2 ) Now make P1, P2 true surface pressure in DO_PJC_PFIX (bmy, 10/27/03) +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !PRIVATE DATA MEMBERS: +! + PRIVATE :: AI, BI, DAP, DBK, COSE_FV + PRIVATE :: COSP_FV, CLAT_FV, DLAT_FV, ELAT_FV, GEOFAC + PRIVATE :: GW_FV, MCOR, REL_AREA, RGW_FV, SINE_FV + PRIVATE :: GEOFAC_PC, DLON_FV, LOC_PROC, PR_DIAG, IMP_NBORDER + PRIVATE :: I1_GL, I2_GL, JU1_GL, JV1_GL, J2_GL + PRIVATE :: K1_GL, K2_GL, ILO_GL, IHI_GL, JULO_GL + PRIVATE :: JVLO_GL, JHI_GL, I1, I2, JU1 + PRIVATE :: JV1, J2, K1, K2, ILO + PRIVATE :: IHI, JULO, JVLO, JHI, ILAT + PRIVATE :: ILONG, IVERT, J1P, J2P + +! ============================================================================ +! Module Variables: +! ============================================================================ +! (1 ) AI (REAL*8 ) : Vertical coord "A" for hybrid grid [hPa] +! (2 ) BI (REAL*8 ) : Vertical coord "B" for hybrid grid [unitless] +! (3 ) CLAT_FV (REAL*8 ) : Grid box center latitude [radians] +! (4 ) COSE_FV (REAL*8 ) : COSINE of grid box edge latitudes [radians] +! (5 ) COSP_FV (REAL*8 ) : COSINE of grid box center latitudes [radians] +! (6 ) DAP (REAL*8 ) : Delta-A vertical coordinate [hPa] +! (7 ) DBK (REAL*8 ) : Delta-B vertical coordinate [unitless] +! (8 ) DLAT_FV (REAL*8 ) : Latitude extent of grid boxes [radians] +! (9 ) ELAT_FV (REAL*8 ) : Grid box edge latitudes [radians] +! (10) GEOFAC (REAL*8 ) : Geometric factor for N-S advection +! (11) GW_FV (REAL*8 ) : Diff of SINE btw grid box lat edges [unitless] +! (12) MCOR (REAL*8 ) : Grid box surface areas [m2] +! (13) REL_AREA (REAL*8 ) : Relative surface area of grid box [fraction] +! (14) RGW_FV (REAL*8 ) : Reciprocal of GW_FV [radians +! (15) SINE_FV (REAL*8 ) : SINE of lat at grid box edges [unitless] +! (16) GEOFAC_PC (REAL*8 ) : Geometric factor for N-S advection @ poles +! (17) DLON_FV (REAL*8 ) : Longitude extent of a grid box [radians] +! (18) LOC_PROC (REAL*8 ) : Local processor number +! (19) PR_DIAG (LOGICAL) : Flag for printing diagnostic message +! (20) IMP_NBORDER (INTEGER) : Used for ghost zones for MPI ??? +! (21) I1_GL (INTEGER) : ind of 1st global lon (no ghost zones) +! (22) I2_GL (INTEGER) : ind of last global lon (no ghost zones) +! (23) JU1_GL (INTEGER) : ind of 1st global "u" lat (no ghost zones) +! (24) JV1_GL (INTEGER) : ind of 1st global "v" lat (no ghost zones) +! (25) J2_GL (INTEGER) : ind of last global "u&v" lat (no ghost zones) +! (26) K1_GL (INTEGER) : ind of 1st global alt (no ghost zones) +! (27) K2_GL (INTEGER) : ind of last global alt (no ghost zones) +! (28) ILO_GL (INTEGER) : I1_GL - IMP_NBORDER (has ghost zones) +! (29) IHI_GL (INTEGER) : I2_GL + IMP_NBORDER (has ghost zones) +! (30) JULO_GL (INTEGER) : JU1_GL - IMP_NBORDER (has ghost zones) +! (31) JVLO_GL (INTEGER) : JV1_GL - IMP_NBORDER (has ghost zones) +! (32) JHI_GL (INTEGER) : J2_GL + IMP_NBORDER (has ghost zones) +! (33) I1 (INTEGER) : ind of first local lon (no ghost zones) +! (34) I2 (INTEGER) : ind of last local lon (no ghost zones) +! (35) JU1 (INTEGER) : ind of first local "u" lat (no ghost zones) +! (36) JV1 (INTEGER) : ind of first local "v" lat (no ghost zones) +! (37) J2 (INTEGER) : ind of last local "u&v" lat (no ghost zones) +! (38) K1 (INTEGER) : index of first local alt (no ghost zones) +! (39) K2 (INTEGER) : index of last local alt (no ghost zones) +! (40) ILO (INTEGER) : I1 - IMP_NBORDER (has ghost zones) +! (41) IHI (INTEGER) : I2 + IMP_NBORDER (has ghost zones) +! (42) JULO (INTEGER) : JU1 - IMP_NBORDER (has ghost zones) +! (43) JVLO (INTEGER) : JV1 - IMP_NBORDER (has ghost zones) +! (44) JHI (INTEGER) : J2 + IMP_NBORDER (has ghost zones) +! + ! Allocatable arrays + REAL*8, ALLOCATABLE :: AI(:) + REAL*8, ALLOCATABLE :: BI(:) + REAL*8, ALLOCATABLE :: CLAT_FV(:) + REAL*8, ALLOCATABLE :: COSE_FV(:) + REAL*8, ALLOCATABLE :: COSP_FV(:) + REAL*8, ALLOCATABLE :: DAP(:) + REAL*8, ALLOCATABLE :: DBK(:) + REAL*8, ALLOCATABLE :: DLAT_FV(:) + REAL*8, ALLOCATABLE :: ELAT_FV(:) + REAL*8, ALLOCATABLE :: GEOFAC(:) + REAL*8, ALLOCATABLE :: GW_FV(:) + REAL*8, ALLOCATABLE :: MCOR(:,:) + REAL*8, ALLOCATABLE :: REL_AREA(:,:) + REAL*8, ALLOCATABLE :: RGW_FV(:) + REAL*8, ALLOCATABLE :: SINE_FV(:) + + ! Scalar variables + LOGICAL :: PR_DIAG + INTEGER :: LOC_PROC + REAL*8 :: GEOFAC_PC + REAL*8 :: DLON_FV + + ! Dimensions for GMI code (from "imp_dims") + INTEGER :: IMP_NBORDER + INTEGER :: I1_GL, I2_GL, JU1_GL, JV1_GL + INTEGER :: J2_GL, K1_GL, K2_GL, ILO_GL + INTEGER :: IHI_GL, JULO_GL, JVLO_GL, JHI_GL + INTEGER :: I1, I2, JU1, JV1 + INTEGER :: J2, K1, K2, ILO + INTEGER :: IHI, JULO, JVLO, JHI + INTEGER :: ILAT, ILONG, IVERT, J1P + INTEGER :: J2P + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Do_Pjc_Pfix +! +! !DESCRIPTION: Subroutine Do\_Pjc\_Pfix is the driver routine for the Philip +! Cameron-Smith pressure fixer for the fvDAS transport scheme. +! (bdf, bmy, 5/8/03, 3/5/07) +!\\ +!\\ +! We assume that the winds are on the A-GRID, since this is the input that +! the fvDAS transport scheme takes. (bdf, bmy, 5/8/03) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Do_Pjc_Pfix( D_DYN, P1, P2, UWND, VWND, XMASS, YMASS ) +! +! !USES: +! +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! Physical constants +! +! !INPUT PARAMETERS: +! + ! Dynamic timestep [s] + REAL*8, INTENT(IN) :: D_DYN + + ! True PSurface at middle of dynamic timestep [hPa] + REAL*8, INTENT(IN) :: P1(:,:) + + ! True PSurface at end of dynamic timestep [hPa] + REAL*8, INTENT(IN) :: P2(:,:) + + ! Zonal (E-W) wind [m/s] + REAL*8, INTENT(IN) :: UWND(IIPAR,JJPAR,LLPAR) + + ! Meridional (N-S) wind [m/s] + REAL*8, INTENT(IN) :: VWND(IIPAR,JJPAR,LLPAR) +! +! !OUTPUT PARAMETERS: +! + ! E-W mass fluxes [mixing ratio] + REAL*8, INTENT(OUT) :: XMASS(IIPAR,JJPAR,LLPAR) + + ! N-S mass fluxes [mixing ratio] + REAL*8, INTENT(OUT) :: YMASS(IIPAR,JJPAR,LLPAR) +! +! !AUTHOR: +! Brendan Field and Bob Yantosca (5/8/03) +! +! !REMARKS: +! (1 ) Now P1 and P2 are "true" surface pressures, and not PS-PTOP. If using +! this P-fixer w/ GEOS-3 winds, pass true surface pressure to this +! routine. (bmy, 10/27/03) +! (2 ) Now define P2_TMP array for passing to ADJUST_PRESS (yxw, bmy, 3/5/07) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, K + REAL*8 :: P2_TMP(IIPAR,JJPAR) +! +! !DEFINED PARAMETERS: +! + LOGICAL, PARAMETER :: INTERP_WINDS = .TRUE. ! winds are interp'd + INTEGER, PARAMETER :: MET_GRID_TYPE = 0 ! A-GRID + INTEGER, PARAMETER :: ADVEC_CONSRV_OPT = 0 ! 2=floating pressure + INTEGER, PARAMETER :: PMET2_OPT = 1 ! leave at 1 + INTEGER, PARAMETER :: PRESS_FIX_OPT = 1 ! Turn on P-Fixer + + !================================================================= + ! DO_PJC_PFIX begins here! + !================================================================= + + ! Initialize on first call + IF ( FIRST ) THEN + + ! Initialize/allocate module variables + CALL INIT_PJC_PFIX + + ! Calculate advection surface-area factors + CALL CALC_ADVECTION_FACTORS( MCOR, REL_AREA, GEOFAC, GEOFAC_PC) + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + + ! Copy P2 into P2_TMP (yxw, bmy, 3/5/07) + P2_TMP = P2 + + + ! Call PJC pressure fixer w/ the proper arguments + ! NOTE: P1 and P2 are now "true" surface pressure, not PS-PTOP!!! + CALL ADJUST_PRESS( 'GEOS-CHEM', INTERP_WINDS, + & .TRUE., MET_GRID_TYPE, + & ADVEC_CONSRV_OPT, PMET2_OPT, + & PRESS_FIX_OPT, D_DYN, + & GEOFAC_PC, GEOFAC, + & COSE_FV, COSP_FV, + & REL_AREA, DAP, + & DBK, P1, + & P2_TMP, P2_TMP, + & UWND, VWND, + & XMASS, YMASS ) + + + ! Return to calling program + END SUBROUTINE Do_Pjc_Pfix +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Calc_Pressure +! +! !DESCRIPTION: Subroutine Calc\_Pressure recalculates the new surface +! pressure from the adjusted air masses XMASS and YMASS. This is useful +! for debugging purposes. (bdf, bmy, 5/8/03) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Calc_Pressure( XMASS, YMASS, RGW_FV, PS_NOW, PS_AFTER ) +! +! !USES: +! +# include "CMN_SIZE" ! Size parameters +# include "CMN" ! STT, NTRACE, LPRT, LWINDO +! +! !INPUT PARAMETERS: +! + ! E-W mass flux from pressure fixer + REAL*8, INTENT(IN) :: XMASS(IIPAR,JJPAR,LLPAR) + + ! N-S mass flux from pressure fixer + REAL*8, INTENT(IN) :: YMASS(IIPAR,JJPAR,LLPAR) + + ! Surface pressure - PTOP at current time + REAL*8, INTENT(IN) :: PS_NOW(IIPAR,JJPAR) + + ! 1 / ( SINE(J+1) - SINE(J) ) -- latitude factor + REAL*8, INTENT(IN) :: RGW_FV(JJPAR) +! +! !OUTPUT PARAMETERS: +! + ! Surface pressure - PTOP adjusted by P-fixer + REAL*8, INTENT(OUT) :: PS_AFTER(IIPAR,JJPAR) +! +! !AUTHOR: +! Brendan Field and Bob Yantosca (5/8/03) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: I, J, L + REAL*8 :: DELP(IIPAR,JJPAR,LLPAR) + REAL*8 :: DELP1(IIPAR,JJPAR,LLPAR) + REAL*8 :: PE(IIPAR,LLPAR+1,JJPAR) + + !================================================================= + ! CALC_PRESSURE begins here! + !================================================================= + DO L = 1, LLPAR + DO J = 1, JJPAR + DO I = 1, IIPAR + DELP1(I,J,L) = DAP(L) + ( DBK(L) * PS_NOW(I,J) ) + ENDDO + ENDDO + ENDDO + + DO L = 1, LLPAR + DO J = 2, JJPAR-1 + + DO I =1, IIPAR-1 + DELP(I,J,L) = DELP1(I,J,L) + + & XMASS(I,J,L) - XMASS(I+1,J,L) + + & ( YMASS(I,J,L) - YMASS(I,J+1,L) ) * RGW_FV(J) + ENDDO + + DELP(IIPAR,J,L) = + & DELP1(IIPAR,J,L) + + & XMASS(IIPAR,J,L) - XMASS(1,J,L) + + & ( YMASS(IIPAR,J,L) - YMASS(IIPAR,J+1,L) ) * RGW_FV(J) + ENDDO + + DO I = 1, IIPAR + DELP(I,1,L) = DELP1(I,1,L) - YMASS(I,2,L) * RGW_FV(1) + ENDDO + + ! Compute average + CALL XPAVG( DELP(1,1,L), IIPAR ) + + DO I = 1, IIPAR + DELP(I,JJPAR,L) = DELP1(I,JJPAR,L) + + & YMASS(I,JJPAR,L) * RGW_FV(JJPAR) + ENDDO + + ! Compute average + CALL XPAVG( DELP(1,JJPAR,L), IIPAR ) + ENDDO + + !================================================================= + ! Make the pressure + !================================================================= + DO J = 1, JJPAR + DO I = 1, IIPAR + PE(I,1,J) = PTOP + ENDDO + + DO L = 1,LLPAR + DO I = 1,IIPAR + PE(I,L+1,J) = PE(I,L,J) + DELP(I,J,L) + ENDDO + ENDDO + + DO I = 1,IIPAR + PS_AFTER(I,J) = PE(I,LLPAR+1,J) + ENDDO + ENDDO + + ! Return to calling program + END SUBROUTINE Calc_Pressure +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Calc_Advection_Factors +! +! !DESCRIPTION: Subroutine Calc\_Advection\_Factors calculates the relative +! area of each grid box, and the geometrical factors used by this modified +! version of TPCORE. These geomoetrical DO assume that the space is +! regularly gridded, but do not assume any link between the surface area +! and the linear dimensions. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Calc_Advection_Factors + & (mcor, rel_area, geofac, geofac_pc) +! +! !USES: +! +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! Physical constants +! +! !INPUT PARAMETERS: +! + ! Area of grid box (m^2) + REAL*8, INTENT(IN) :: mcor(i1_gl :i2_gl, ju1_gl:j2_gl) +! +! !OUTPUT PARAMETERS: +! + ! relative surface area of grid box (fraction) + REAL*8, INTENT(OUT) :: rel_area(i1_gl :i2_gl, ju1_gl:j2_gl) + + ! Geometrical factor for meridional advection; geofac uses + ! correct spherical geometry, and replaces acosp as the + ! meridional geometrical factor in tpcore + REAL*8, INTENT(OUT) :: geofac(ju1_gl:j2_gl) + + ! Special geometrical factor (geofac) for Polar cap + REAL*8, INTENT(OUT) :: geofac_pc +! +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! +! !REMARKS: +! Now reference PI from "CMN_GCTM" for consistency. Also force +! double-precision with the "D" exponent. (bmy, 5/6/03) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: ij + + REAL*8 :: dp ! spacing in latitude (rad) + REAL*8 :: ri2_gl + REAL*8 :: rj2m1 + REAL*8 :: total_area + + !---------------- + !Begin execution. + !---------------- + + ri2_gl = i2_gl + + !--------------------------------- + !Set the relative area (rel_area). + !--------------------------------- + + total_area = Sum (mcor(:,:)) + + rel_area(:,:) = mcor(:,:) / total_area + + + !--------------------------------------------------------- + !Calculate geometrical factor for meridional advection. + !Note that it is assumed that all grid boxes in a latitude + !band are the same. + !--------------------------------------------------------- + + rj2m1 = j2_gl - 1 + dp = PI / rj2m1 + + do ij = ju1_gl, j2_gl + geofac(ij) = dp / (2.0d0 * rel_area(1,ij) * ri2_gl) + end do + + geofac_pc = + & dp / (2.0d0 * Sum (rel_area(1,ju1_gl:ju1_gl+1)) * ri2_gl) + + ! Return to calling program + END SUBROUTINE Calc_Advection_Factors +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Adjust_Press +! +! !DESCRIPTION: Subroutine Adjust\_Press initializes and calls the +! pressure fixer code. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Adjust_Press + & (metdata_name_org, do_timinterp_winds, new_met_rec, + & met_grid_type, advec_consrv_opt, pmet2_opt, press_fix_opt, + & tdt, geofac_pc, geofac, cose, cosp, rel_area, dap, dbk, + & pctm1, pctm2, pmet2, uu, vv, xmass, ymass) +! +! !INPUT PARAMETERS: +! + ! First part of metdata_name, e.g., "NCAR" + CHARACTER(LEN=*) :: metdata_name_org + + ! Time interpolate wind fields? + LOGICAL :: do_timinterp_winds + + ! New met record? + LOGICAL :: new_met_rec + + ! Met grid type, A or C + INTEGER :: met_grid_type + + ! Advection_conserve option + INTEGER :: advec_consrv_opt + + ! pmet2 option + INTEGER :: pmet2_opt + + ! pressure fixer option + INTEGER :: press_fix_opt + + ! Model time step [s] + REAL*8 :: tdt + + ! Special geometrical factor (geofac) for Polar cap + REAL*8 :: geofac_pc + + ! Geometrical factor for meridional advection; geofac uses + ! correct spherical geometry, and replaces acosp as the + ! meridional geometrical factor in tpcore + REAL*8 :: geofac (ju1_gl:j2_gl) + + ! Cosines of grid box edges and centers + REAL*8 :: cose (ju1_gl:j2_gl) + REAL*8 :: cosp (ju1_gl:j2_gl) + + ! Pressure difference across layer from (ai * pt) term [hPa] + REAL*8 :: dap (k1:k2) + + ! Difference in bi across layer - the dSigma term + REAL*8 :: dbk (k1:k2) + + ! Relative surface area of grid box (fraction) + REAL*8 :: rel_area( i1_gl:i2_gl, ju1_gl:j2_gl) + + ! Metfield surface pressure at t1+tdt [hPa] + REAL*8 :: pmet2(ilo_gl:ihi_gl, julo_gl:jhi_gl) + + ! CTM surface pressure at t1 [hPa] + REAL*8 :: pctm1(ilo_gl:ihi_gl, julo_gl:jhi_gl) + + ! CTM surface pressure at t1+tdt [hPa] + REAL*8 :: pctm2(ilo_gl:ihi_gl, julo_gl:jhi_gl) + + ! Wind velocity, x direction at t1+tdt/2 [m/s] + REAL*8 :: uu(ilo_gl:ihi_gl, julo_gl:jhi_gl, k1_gl:k2_gl) + + ! Wind velocity, y direction at t1+tdt/2 [m/s] + REAL*8 :: vv(ilo_gl:ihi_gl, julo_gl:jhi_gl, k1_gl:k2_gl) +! +! !INPUT/OUTPUT PARAMETERS: +! + ! Horizontal mass flux in E-W direction [hPa] + REAL*8 :: xmass(ilo_gl:ihi_gl, julo_gl:jhi_gl, k1_gl:k2_gl) + + ! Horizontal mass flux in N-S direction [hPa] + REAL*8 :: ymass(ilo_gl:ihi_gl, julo_gl:jhi_gl, k1_gl:k2_gl) +! +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + logical, save :: DO_ADJUST_PRESS_DIAG = .TRUE. + + + !---------------------- + !Variable declarations. + !---------------------- + + logical, save :: first = .true. + + !-------------------------------------------------- + !dgpress : global-pressure discrepancy + !press_dev : RMS difference between pmet2 and pctm2 + ! (weighted by relative area) + !-------------------------------------------------- + + real*8 :: dgpress + real*8 :: press_dev + + !------------------------------------------------------------- + !dps : change of surface pressure from met field pressure [hPa] + !------------------------------------------------------------- + + real*8 :: dps(i1_gl:i2_gl, ju1_gl:j2_gl) + + !-------------------------------------------- + !dps_ctm : CTM surface pressure tendency [hPa] + !-------------------------------------------- + + real*8 :: dps_ctm(i1_gl:i2_gl, ju1_gl:j2_gl) + + !--------------------------------------------------------------------- + !xmass_fixed : horizontal mass flux in E-W direction after fixing [hPa] + !ymass_fixed : horizontal mass flux in N-S direction after fixing [hPa] + !--------------------------------------------------------------------- + + real*8 :: xmass_fixed(ilo_gl:ihi_gl, julo_gl:jhi_gl, k1:k2) + real*8 :: ymass_fixed(ilo_gl:ihi_gl, julo_gl:jhi_gl, k1:k2) + + !------------- + !Dummy indexes + !------------- + + !integer :: ij, il + + !---------------- + !Begin execution. + !---------------- + + if (pr_diag) then + Write (6, *) 'Adjust_Press called by ', loc_proc + end if + + dps_ctm(:,:) = 0.0d0 + + dgpress = Sum ( (pmet2(i1_gl:i2_gl, ju1_gl:j2_gl) - + & pctm1(i1_gl:i2_gl, ju1_gl:j2_gl) ) + & * rel_area(i1_gl:i2_gl, ju1_gl:j2_gl) ) + + if (pmet2_opt == 1) then + pmet2(:,:) = pmet2(:,:) - dgpress + end if + +!### Debug +!### if (DO_ADJUST_PRESS_DIAG) then +!### Write (6, *) 'Global mean surface pressure change [hPa] = ', +!### & dgpress +!### end if + + !=================== + call Init_Press_Fix + !=================== + & (metdata_name_org, met_grid_type, tdt, geofac_pc, geofac, + & cose, cosp, dap, dbk, dps, dps_ctm, rel_area, pctm1, pmet2, + & uu, vv, xmass, ymass) + + if (press_fix_opt == 1) then + + !====================== + call Do_Press_Fix_Llnl + !====================== + & (geofac_pc, geofac, dbk, dps, dps_ctm, rel_area, + & xmass, ymass, xmass_fixed, ymass_fixed ) + + xmass(:,:,:) = xmass_fixed(:,:,:) + ymass(:,:,:) = ymass_fixed(:,:,:) + + end if + + if ((advec_consrv_opt == 0) .or. + & (advec_consrv_opt == 1)) then + + dps_ctm(i1_gl:i2_gl, ju1_gl:j2_gl) = + & pmet2(i1_gl:i2_gl, ju1_gl:j2_gl) - + & pctm1(i1_gl:i2_gl, ju1_gl:j2_gl) + + !----------------------------------------------- + !else if (advec_consrv_opt == 2) then do nothing + !----------------------------------------------- + + end if + + + pctm2(i1_gl:i2_gl, ju1_gl:j2_gl) = + & pctm1(i1_gl:i2_gl, ju1_gl:j2_gl) + + & dps_ctm(i1_gl:i2_gl, ju1_gl:j2_gl) + + + if (DO_ADJUST_PRESS_DIAG) then + + !------------------------------------------------------- + !Calculate the RMS pressure deviation (diagnostic only). + !------------------------------------------------------- + + press_dev = + & Sqrt (Sum (((pmet2(i1_gl:i2_gl,ju1_gl:j2_gl) - + & pctm2(i1_gl:i2_gl,ju1_gl:j2_gl))**2 * + & rel_area(i1_gl:i2_gl,ju1_gl:j2_gl)))) + +!### Debug +!### Write (6, *) 'RMS deviation between pmet2 & pctm2 [hPa] = ', +!### & press_dev + + end if + + ! Return to calling program + END SUBROUTINE Adjust_Press +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Init_Press_Fix +! +! !DESCRIPTION: Subroutine Init\_Press\_Fix initializes the pressure fixer. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Init_Press_Fix + & (metdata_name_org, met_grid_type, tdt, geofac_pc, geofac, + & cose, cosp, dap, dbk, dps, dps_ctm, rel_area, pctm1, pmet2, + & uu, vv, xmass, ymass) +! +! !INPUT PARAMETERS: +! + ! Model Time step [s] + REAL*8 :: tdt + + ! First part of metdata_name, e.g., "NCAR" + CHARACTER(LEN=*) :: metdata_name_org + + ! Met grid type, A or C + INTEGER :: met_grid_type + + ! Special geometrical factor (geofac) for Polar cap + REAL*8 :: geofac_pc + + ! Cosine of grid box edges and centers + REAL*8 :: cose(ju1_gl:j2_gl) + REAL*8 :: cosp(ju1_gl:j2_gl) + + ! Geometrical factor for meridional advection; geofac uses + ! correct spherical geometry, and replaces acosp as the + ! meridional geometrical factor in tpcore + REAL*8 :: geofac(ju1_gl:j2_gl) + + ! Pressure difference across layer from (ai * pt) term [hPa] + REAL*8 :: dap(k1:k2) + + ! Difference in bi across layer - the dSigma term + REAL*8 :: dbk(k1:k2) + + ! relative surface area of grid box (fraction) + REAL*8 :: rel_area( i1_gl:i2_gl, ju1_gl:j2_gl) + + ! Metfield surface pressure at t1 [hPa] + REAL*8 :: pmet2(ilo_gl:ihi_gl, julo_gl:jhi_gl) + + ! CTM surface pressure at t1 [hPa] + REAL*8 :: pctm1(ilo_gl:ihi_gl, julo_gl:jhi_gl) + + ! CTM surface pressure at t1+tdt [hPa] + REAL*8 :: pctm2(ilo_gl:ihi_gl, julo_gl:jhi_gl) + + ! Wind velocity, x direction at t1+tdt/2 [m/s] + REAL*8 :: uu(ilo_gl:ihi_gl, julo_gl:jhi_gl, k1_gl:k2_gl) + + ! Wind velocity, y direction at t1+tdt/2 [m/s] + REAL*8 :: vv(ilo_gl:ihi_gl, julo_gl:jhi_gl, k1_gl:k2_gl) +! +! !OUTPUT PARAMETERS: +! + ! Horizontal mass flux in E-W direction [hPa] + REAL*8 :: xmass(ilo_gl:ihi_gl, julo_gl:jhi_gl, k1_gl:k2_gl) + + ! Horizontal mass flux in N-S direction [hPa] + REAL*8 :: ymass(ilo_gl:ihi_gl, julo_gl:jhi_gl, k1_gl:k2_gl) + + ! Change of surface pressure from met field pressure [hPa] + REAL*8 :: dps(i1_gl:i2_gl, ju1_gl:j2_gl) + + ! CTM surface pressure tendency [hPa] + REAL*8 :: dps_ctm(i1_gl:i2_gl, ju1_gl:j2_gl) +! +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + !-------------------------------------------------------------- + !dpi : divergence at a grid point; used to calculate vertical + ! motion [hPa] + !-------------------------------------------------------------- + + real*8 :: dpi(i1:i2, ju1:j2, k1:k2) + + !--------------------------------------------------------------------- + !crx : Courant number in E-W direction + !cry : Courant number in N-S direction + !delp1 : pressure thickness, the psudo-density in a hydrostatic system + ! at t1 [hPa] + !delpm : pressure thickness, the psudo-density in a hydrostatic system + ! at t1+tdt/2 (approximate) [hPa] + !pu : pressure at edges in "u" [hPa] + !--------------------------------------------------------------------- + + real*8 :: crx (ilo:ihi, julo:jhi, k1:k2) + real*8 :: cry (ilo:ihi, julo:jhi, k1:k2) + real*8 :: delp1(ilo:ihi, julo:jhi, k1:k2) + real*8 :: delpm(ilo:ihi, julo:jhi, k1:k2) + real*8 :: pu (ilo:ihi, julo:jhi, k1:k2) + + !---------------- + !Begin execution. + !---------------- + + if (pr_diag) then + Write (6,*) 'Init_Press_Fix called by ', loc_proc + end if + + !======================== + call Average_Press_Poles + !======================== + & (rel_area, pctm1) + + !======================== + call Average_Press_Poles + !======================== + & (rel_area, pmet2) + + !------------------------------------------------------------------- + !We need to calculate pressures at t1+tdt/2. One ought to use pctm2 + !in the call to Set_Press_Terms, but since we don't know it yet, we + !are forced to use pmet2. This should be good enough because it is + !only used to convert the winds to the mass fluxes, which is done + !crudely anyway and the mass fluxes will still get fixed OK. + !------------------------------------------------------------------- + + dps(i1:i2,ju1:j2) = pmet2(i1:i2,ju1:j2) - pctm1(i1:i2,ju1:j2) + + !==================== + call Set_Press_Terms + !==================== + & (dap, dbk, pctm1, pmet2, delp1, delpm, pu) + + + !=================== + call Convert_Winds + !=================== + & (met_grid_type, tdt, cosp, crx, cry, uu, vv) + + + !========================= + call Calc_Horiz_Mass_Flux + !========================= + & (cose, delpm, uu, vv, xmass, ymass, tdt, cosp) + + !==================== + call Calc_Divergence + !==================== + & (.false., geofac_pc, geofac, dpi, xmass, ymass) + + + dps_ctm(i1:i2,ju1:j2) = Sum (dpi(i1:i2,ju1:j2,:), dim=3) + + ! Return to calling program + END SUBROUTINE Init_Press_Fix +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Do_Press_Fix_Llnl +! +! !DESCRIPTION: Subroutine Do\_Press\_Fix\_Llnl fixes the mass fluxes to +! match the met field pressure tendency. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Do_Press_Fix_Llnl + & (geofac_pc, geofac, dbk, dps, dps_ctm, rel_area, + & xmass, ymass, xmass_fixed, ymass_fixed) +! +! !INPUT PARAMETERS: +! + ! Special geometrical factor (geofac) for Polar cap + REAL*8, INTENT(IN) :: geofac_pc + + ! Geometrical factor for meridional advection; geofac uses + ! correct spherical geometry, and replaces acosp as the + ! meridional geometrical factor in tpcore + REAL*8, INTENT(IN) :: geofac(ju1_gl:j2_gl) + + ! Difference in bi across layer - the dSigma term + REAL*8, INTENT(IN) :: dbk(k1:k2) + + ! Change of surface pressure from met field pressure [hPa] + REAL*8, INTENT(IN) :: dps(i1:i2, ju1:j2) + + ! Relative surface area of grid box (fraction) + REAL*8, INTENT(IN) :: rel_area(i1:i2, ju1:j2) + + ! Horizontal mass fluxes in E-W and N-S directions [hPa] + REAL*8, INTENT(IN) :: xmass(ilo:ihi, julo:jhi, k1:k2) + REAL*8, INTENT(IN) :: ymass(ilo:ihi, julo:jhi, k1:k2) +! +! !OUTPUT PARAMETERS: +! + ! Sum over vertical of dpi calculated from original mass fluxes [hPa] + REAL*8, INTENT(OUT) :: dps_ctm(i1:i2, ju1:j2) + + ! Horizontal mass flux in E-W and N-S directions after fixing [hPa] + REAL*8, INTENT(OUT) :: xmass_fixed(ilo:ihi, julo:jhi, k1:k2) + REAL*8, INTENT(OUT) :: ymass_fixed(ilo:ihi, julo:jhi, k1:k2) +! +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: il, ij, ik + + REAL*8 :: dgpress + REAL*8 :: fxmean + REAL*8 :: ri2 + + ! Arrays + REAL*8 :: fxintegral(i1:i2+1) + REAL*8 :: mmfd(ju1:j2) + REAL*8 :: mmf (ju1:j2) + REAL*8 :: ddps(i1:i2, ju1:j2) + + !------------------------------------------------------------------------ + !dpi: divergence at a grid point; used to calculate vertical motion [hPa] + !------------------------------------------------------------------------ + + real*8 :: dpi(i1:i2, ju1:j2, k1:k2) + + real*8 :: xcolmass_fix(ilo:ihi, julo:jhi) + + + !---------------- + !Begin execution. + !---------------- + + if (pr_diag) then + Write (6,*) 'Do_Press_Fix_Llnl called by ', loc_proc + end if + + + ri2 = i2_gl + + mmfd(:) = 0.0d0 + + xcolmass_fix(:,:) = 0.0d0 + + xmass_fixed (:,:,:) = xmass(:,:,:) + ymass_fixed (:,:,:) = ymass(:,:,:) + + + !------------------------------------------------------------ + !Calculate difference between GCM and LR predicted pressures. + !------------------------------------------------------------ + + ddps(:,:) = dps(:,:) - dps_ctm(:,:) + + +c -------------------------------------- +c Calculate global-pressure discrepancy. +c -------------------------------------- + + dgpress = + & Sum (ddps(i1:i2,ju1:j2) * rel_area(i1:i2,ju1:j2)) + + + !---------------------------------------------------------- + !Calculate mean meridional flux divergence (df/dy). + !Note that mmfd is actually the zonal mean pressure change, + !which is related to df/dy by geometrical factors. + !---------------------------------------------------------- + + !------------------------ + !Handle non-Pole regions. + !------------------------ + + do ij = j1p, j2p + mmfd(ij) = -(sum(ddps(:,ij)) / ri2 - dgpress) + end do + + !--------------------------------------------- + !Handle poles. + !Note that polar boxes have all been averaged. + !--------------------------------------------- + + mmfd(ju1) = -(ddps(1,ju1) - dgpress) + mmfd(ju1+1) = -(ddps(1,ju1+1) - dgpress) + mmfd(j2-1) = -(ddps(1,j2-1) - dgpress) + mmfd(j2) = -(ddps(1,j2) - dgpress) + + + !--------------------------------------------- + !Calculate mean meridional fluxes (cos(e)*fy). + !--------------------------------------------- + + mmf(j1p) = mmfd(ju1) / geofac_pc + + do ij = j1p, j2p + mmf(ij+1) = mmf(ij) + mmfd(ij) / geofac(ij) + end do + + + !------------------------------------------------------------ + !Fix latitude bands. + !Note that we don't need to worry about geometry here because + !all boxes in a latitude band are identical. + !Note also that fxintegral(i2+1) should equal fxintegral(i1), + !i.e., zero. + !------------------------------------------------------------ + + do ij = j1p, j2p + + fxintegral(:) = 0.0d0 + + do il = i1, i2 + fxintegral(il+1) = + & fxintegral(il) - + & (ddps(il,ij) - dgpress) - + & mmfd(ij) + end do + + fxmean = Sum (fxintegral(i1+1:i2+1)) / ri2 + + do il = i1, i2 + xcolmass_fix(il,ij) = fxintegral(il) - fxmean + end do + + end do + + !------------------------------------- + !Distribute colmass_fix's in vertical. + !------------------------------------- + + do ik = k1, k2 + do ij = j1p, j2p + do il = i1, i2 + + xmass_fixed(il,ij,ik) = xmass(il,ij,ik) + + & xcolmass_fix(il,ij) * dbk(ik) + + end do + end do + end do + + do ik = k1, k2 + do ij = j1p, j2p+1 + do il = i1, i2 + + ymass_fixed(il,ij,ik) = ymass(il,ij,ik) + + & mmf(ij) * dbk(ik) + + end do + end do + end do + + !==================== + call Calc_Divergence + !==================== + & (.false., geofac_pc, geofac, dpi, xmass_fixed, ymass_fixed) + + + dps_ctm(i1:i2,ju1:j2) = Sum (dpi(i1:i2,ju1:j2,:), dim=3) + + ! Return to calling program + END SUBROUTINE Do_Press_Fix_Llnl +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Average_Press_Poles +! +! !DESCRIPTION: Subroutine Average\_Press\_Poles averages pressure at the +! Poles when the Polar cap is enlarged. It makes the last two latitudes +! equal. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Average_Press_Poles + & (rel_area, press) +! +! !INPUT PARAMETERS: +! + ! Relative surface area of grid box (fraction) + REAL*8, INTENT(IN) :: rel_area(i1:i2, ju1:j2) +! +! !OUTPUT PARAMETERS: +! + ! Surface pressure [hPa] + REAL*8, INTENT(INOUT) :: press (ilo:ihi, julo:jhi) +! +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*8 :: meanp + + + !---------------- + !Begin execution. + !---------------- + + if (pr_diag) then + Write (6,*) 'Average_Press_Poles called by ', loc_proc + end if + + meanp = + & Sum (rel_area(i1:i2,ju1:ju1+1) * + & press (i1:i2,ju1:ju1+1)) / + & Sum (rel_area(i1:i2,ju1:ju1+1)) + + press(i1:i2,ju1:ju1+1) = meanp + + meanp = + & Sum (rel_area(i1:i2,j2-1:j2) * + & press (i1:i2,j2-1:j2)) / + & Sum (rel_area(i1:i2,j2-1:j2)) + + press(i1:i2,j2-1:j2) = meanp + + ! Return to calling program + END SUBROUTINE Average_Press_Poles +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Convert_Winds +! +! !DESCRIPTION: Subroutine Convert\_Winds converts winds on A or C grid to +! Courant \# on C grid. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Convert_Winds + & (igd, tdt, cosp, crx, cry, uu, vv) +! +! !USES: +! +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! Re, PI +! +! !INPUT PARAMETERS: +! + ! A or C grid + INTEGER, INTENT(IN) :: igd + + ! Model time step [s] + REAL*8, INTENT(IN) :: tdt + + ! Cosine of grid box centers + REAL*8, INTENT(IN) :: cosp(ju1_gl:j2_gl) + + ! Wind velocity in E-W (UU) and N-S (VV) directions at t1+tdt/2 [m/s] + REAL*8, INTENT(IN) :: uu (ilo:ihi, julo:jhi, k1:k2) + REAL*8, INTENT(IN) :: vv (ilo:ihi, julo:jhi, k1:k2) +! +! !OUTPUT PARAMETERS: +! + ! Courant number in E-W (CRX) and N-S (CRY) directions + REAL*8, INTENT(OUT) :: crx (ilo:ihi, julo:jhi, k1:k2) + REAL*8, INTENT(OUT) :: cry (ilo:ihi, julo:jhi, k1:k2) + +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! +! !REMARKS: +! Use GEOS-CHEM physical constants Re, PI to be consistent with other +! usage everywhere (bmy, 5/5/03) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + logical, save :: first = .true. + + integer :: il, ij + + !------------------------------- + !dl : spacing in longitude (rad) + !dp : spacing in latitude (rad) + !------------------------------- + + real*8 :: dl + real*8 :: dp + + real*8 :: ri2 + real*8 :: rj2m1 + + !------------------------ + !dtdy : dt/dy (s/m) + !dtdy5 : 0.5 * dtdy (s/m) + !------------------------ + + real*8, save :: dtdy + real*8, save :: dtdy5 + + !------------------------ + !dtdx : dt/dx (s/m) + !dtdx5 : 0.5 * dtdx (s/m) + !------------------------ + + real*8, allocatable, save :: dtdx (:) + real*8, allocatable, save :: dtdx5(:) + + !---------------- + !Begin execution. + !---------------- + + if (pr_diag) then + Write (6, *) 'Convert_Winds called by ', loc_proc + end if + + + !========== + if (first) then + !========== + + first = .false. + + + Allocate (dtdx (ju1_gl:j2_gl)) + Allocate (dtdx5(ju1_gl:j2_gl)) + dtdx = 0.0d0; dtdx5 = 0.0d0 + + ri2 = i2_gl + rj2m1 = j2_gl - 1 + + dl = 2.0d0 * PI / ri2 + dp = PI / rj2m1 + + dtdy = tdt / (Re * dp) + dtdy5 = 0.5d0 * dtdy + + + dtdx (ju1_gl) = 0.0d0 + dtdx5(ju1_gl) = 0.0d0 + + do ij = ju1_gl + 1, j2_gl - 1 + + dtdx (ij) = tdt / (dl * Re * cosp(ij)) + dtdx5(ij) = 0.5d0 * dtdx(ij) + + end do + + dtdx (j2_gl) = 0.0d0 + dtdx5(j2_gl) = 0.0d0 + + end if + + + !============= + if (igd == 0) then ! A grid. + !============= + + do ij = ju1+1, j2-1 + do il = i1+1, i2 + crx(il,ij,:) = + & dtdx5(ij) * + & (uu(il,ij,:) + uu(il-1,ij, :)) + end do + crx(1,ij,:) = + & dtdx5(ij) * + & (uu(1,ij,:) + uu(i2,ij, :)) + end do + + do ij = ju1+1, j2 + do il = i1, i2 + cry(il,ij,:) = + & dtdy5 * + & (vv(il,ij,:) + vv(il, ij-1,:)) + end do + end do + + + !==== + else ! C grid. + !==== + + do ij = ju1, j2 + do il = i1, i2 + + crx(il,ij,:) = + & dtdx(ij) * uu(il-1,ij, :) + + cry(il,ij,:) = + & dtdy * vv(il, ij-1,:) + + end do + end do + + end if + + ! Return to calling program + END SUBROUTINE Convert_Winds +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Calc_Horiz_Mass_Flux +! +! !DESCRIPTION: Subroutine Calc\_Horiz\_Mass\_Flux calculates the horizontal +! mass flux for non-GISS met data. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Calc_Horiz_Mass_Flux + & (cose, delpm, uu, vv, xmass, ymass, tdt, cosp) +! +! !USES: +! +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! Re, Pi +! +! !INPUT PARAMETERS: +! + ! Timestep [s] + REAL*8, INTENT(IN) :: tdt + + ! Cosine of grid box edges + REAL*8, INTENT(IN) :: cose (ju1_gl:j2_gl) + + ! Cosine of grid box centers + REAL*8, INTENT(IN) :: cosp (ju1_gl:j2_gl) + + ! Pressure thickness, the pseudo-density in a + ! hdrostatic system at t1+tdt/2 (approximate) [hPa] + REAL*8, INTENT(IN) :: delpm(ilo:ihi, julo:jhi, k1:k2) + + ! E-W (UU) and N-S (VV) winds [m/s] + REAL*8, INTENT(IN) :: uu (ilo:ihi, julo:jhi, k1:k2) + REAL*8, INTENT(IN) :: vv (ilo:ihi, julo:jhi, k1:k2) +! +! !OUTPUT PARAMETERS: +! + ! Horizontal mass flux in E-W and N-S directions [hPa] + REAL*8, INTENT(OUT) :: xmass(ilo:ihi, julo:jhi, k1:k2) + REAL*8, INTENT(OUT) :: ymass(ilo:ihi, julo:jhi, k1:k2) + +! !AUTHOR: +! Original code from Shian-Jiann Lin, DAO +! John Tannahill, LLNL (jrt@llnl.gov) +! +! !REMARKS: +! Use GEOS-CHEM physical constants Re, PI to be consistent with other +! usage everywhere (bmy, 5/5/03) + +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: ij + INTEGER :: il + INTEGER :: jst, jend + REAL*8 :: dl + REAL*8 :: dp + + REAL*8 :: ri2 + REAL*8 :: rj2m1 + REAL*8 :: factx + REAL*8 :: facty + + + !---------------- + !Begin execution. + !---------------- + + if (pr_diag) then + Write (6,*) 'Calc_Horiz_Mass_Flux called by ', loc_proc + end if + + ri2 = i2_gl + rj2m1 = j2_gl - 1 + + dl = 2.0d0 * PI / ri2 + dp = PI / rj2m1 + + facty = 0.5d0 * tdt / (Re * dp) + + !----------------------------------- + !Calculate E-W horizontal mass flux. + !----------------------------------- + + do ij = ju1, j2 + + factx = 0.5d0 * tdt / (dl * Re * cosp(ij)) + + do il = i1+1, i2 + xmass(il,ij,:) = factx * + & (uu(il,ij,:) * delpm(il,ij,:)+ + & uu(il-1,ij,:) * delpm(il-1,ij,:)) + end do + + xmass(i1,ij,:) = factx * + & (uu(i1,ij,:) * delpm(i1,ij,:)+ + & uu(i2,ij,:) * delpm(i2,ij,:)) + + end do + + !----------------------------------- + !Calculate N-S horizontal mass flux. + !----------------------------------- + + do ij = ju1+1, j2 + + ymass(i1:i2,ij,:) = facty * + & cose(ij) * (vv(i1:i2,ij,:)*delpm(i1:i2,ij,:)+ + & vv(i1:i2,ij-1,:)*delpm(i1:i2,ij-1,:)) + + end do + + ymass(i1:i2,ju1,:) = facty * + & cose(ju1) * (vv(i1:i2,ju1,:)*delpm(i1:i2,ju1,:)) + + + ! Return to calling program + END SUBROUTINE Calc_Horiz_Mass_Flux +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Calc_Divergence +! +! !DESCRIPTION: Subroutine Calc\_Divergence calculates the divergence. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Calc_Divergence + & (do_reduction, geofac_pc, geofac, dpi, xmass, ymass) +! +! !INPUT PARAMETERS: +! + ! Set to F if called on Master; set to T if called by Slaves + ! (NOTE: this doesn't seem to be used!) + LOGICAL, INTENT(IN) :: do_reduction + + ! Special geometrical factor (geofac) for Polar cap + REAL*8, INTENT(IN) :: geofac_pc + + ! geometrical factor for meridional advection; geofac uses + ! correct spherical geometry, and replaces acosp as the + ! meridional geometrical factor in tpcore + REAL*8, INTENT(IN) :: geofac(ju1_gl:j2_gl) + + ! horizontal mass fluxes in E-W and N-S directions [hPa] + REAL*8, INTENT(IN) :: xmass (ilo:ihi, julo:jhi, k1:k2) + REAL*8, INTENT(IN) :: ymass (ilo:ihi, julo:jhi, k1:k2) +! +! !INPUT/OUTPUT PARAMETERS: +! + ! Divergence at a grid point; used to calculate vertical motion [hPa] + REAL*8, INTENT(INOUT) :: dpi (i1:i2, ju1:j2, k1:k2) +! +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + integer :: il, ij + integer :: jst, jend + + !---------------- + !Begin execution. + !---------------- + + if (pr_diag) then + Write (6,*) 'Calc_Divergence called by ', loc_proc + end if + + !------------------------- + !Calculate N-S divergence. + !------------------------- + + do ij = j1p, j2p + + dpi(i1:i2,ij,:) = + & (ymass(i1:i2,ij,:) - ymass(i1:i2,ij+1,:)) * + & geofac(ij) + + end do + + !------------------------- + !Calculate E-W divergence. + !------------------------- + + do ij = j1p,j2p + do il = i1, i2-1 + dpi(il,ij,:) = + & dpi(il,ij,:) + + & xmass(il,ij,:) - xmass(il+1,ij,:) + end do + dpi(i2,ij,:) = + & dpi(i2,ij,:) + + & xmass(i2,ij,:) - xmass(1,ij,:) + end do + + !=========================== + call Do_Divergence_Pole_Sum + !=========================== + & (do_reduction, geofac_pc, dpi, ymass) + + + ! Added this IF statemetn (ccarouge, 12/3/08) + if (j1p /= ju1_gl+1) then + +! -------------------------------------------- +! Polar cap enlarged: copy dpi to polar ring. +! -------------------------------------------- + + if (ju1 == ju1_gl) then + + dpi(:,ju1+1,:) = dpi(:,ju1,:) + + end if + + if (j2 == j2_gl) then + + dpi(:,j2-1,:) = dpi(:,j2,:) + + end if + + end if + + ! Return to calling program + END SUBROUTINE Calc_Divergence +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Set_Press_Terms +! +! !DESCRIPTION: Subroutine Set\_Press\_Terms sets the pressure terms. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Set_Press_Terms + & (dap, dbk, pres1, pres2, delp1, delpm, pu) +! +! !INPUT PARAMETERS: +! + ! Pressure difference across layer from (ai * pt) term [hPa] + REAL*8, INTENT(IN) :: dap (k1:k2) + + ! Difference in bi across layer - the dSigma term + REAL*8, INTENT(IN) :: dbk (k1:k2) + + ! Surface pressure at t1 [hPa] + REAL*8, INTENT(IN) :: pres1(ilo:ihi, julo:jhi) + + ! Surface pressure at t1+tdt [hPa] + REAL*8, INTENT(IN) :: pres2(ilo:ihi, julo:jhi) +! +! !OUTPUT PARAMETERS: +! + ! Pressure thickness, the psudo-density in a + ! hydrostatic system at t1 [hPa] + REAL*8, INTENT(OUT) :: delp1(ilo:ihi, julo:jhi, k1:k2) + + ! Pressure thickness, the psudo-density in a + ! hydrostatic system at t1+tdt/2 (approximate) [hPa] + REAL*8, INTENT(OUT) :: delpm(ilo:ihi, julo:jhi, k1:k2) + + ! Pressure at edges in "u" [hPa] + REAL*8, INTENT(OUT) :: pu (ilo:ihi, julo:jhi, k1:k2) +! +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + integer :: il, ij, ik + integer :: jst, jend + + !---------------- + !Begin execution. + !---------------- + + if (pr_diag) then + Write (6,*) 'Set_Press_Terms called by ', loc_proc + end if + + do ik = k1, k2 + + delp1(:,:,ik) = + & dap(ik) + (dbk(ik) * pres1(:,:)) + + delpm(:,:,ik) = + & dap(ik) + + & (dbk(ik) * 0.5d0 * (pres1(:,:) + pres2(:,:))) + + end do + + do ij = ju1, j2 + do il = i1+1, i2 + pu(il,ij,:) = + & 0.5d0 * (delpm(il,ij,:) + delpm(il-1,ij,:)) + end do + + pu(i1,ij,:) = + & 0.5d0 * (delpm(i1,ij,:) + delpm(i2,ij,:)) + + end do + + ! Return to calling program + END SUBROUTINE Set_Press_Terms +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Do_Divergence_Pole_Sum +! +! !DESCRIPTION: Do\_Divergence\_Pole\_Sum sets the divergence at the Poles. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Do_Divergence_Pole_Sum + & (do_reduction, geofac_pc, dpi, ymass) +! +! !INPUT PARAMETERS: +! + ! Set to T if called on Master; set to F if called by Slaves + ! (NOTE: This does not seem to be used!) + LOGICAL :: do_reduction + + ! Special geometrical factor (geofac) for Polar cap + REAL*8 :: geofac_pc + + ! horizontal mass flux in N-S direction [hPa] + REAL*8 :: ymass(ilo:ihi, julo:jhi, k1:k2) +! +! !OUTPUT PARAMETERS: +! + ! Divergence at a grid point; used to calculate vertical motion [hPa] + REAL*8 :: dpi ( i1:i2, ju1:j2, k1:k2) +! +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Declare all REAL variables as REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! +! + !---------------------- + !Variable declarations. + !---------------------- + + integer :: il, ik + + real*8 :: ri2 + + real*8 :: mean_np(k1:k2) + real*8 :: mean_sp(k1:k2) + real*8 :: sumnp (k1:k2) + real*8 :: sumsp (k1:k2) + + + !---------------- + !Begin execution. + !---------------- + + ri2 = i2_gl + + !================== + if (ju1 == ju1_gl) then + !================== + + do ik = k1, k2 + + sumsp(ik) = 0.0d0 + + do il = i1, i2 + + sumsp(ik) = sumsp(ik) + ymass(il,j1p,ik) + + end do + + end do + + do ik = k1, k2 + + mean_sp(ik) = -sumsp(ik) / ri2 * geofac_pc + + do il = i1, i2 + + dpi(il,ju1,ik) = mean_sp(ik) + + end do + + end do + + !====== + end if + !====== + + + !================ + if (j2 == j2_gl) then + !================ + + do ik = k1, k2 + + sumnp(ik) = 0.0d0 + + do il = i1, i2 + + sumnp(ik) = sumnp(ik) + ymass(il,j2p+1,ik) + + end do + + end do + + do ik = k1, k2 + + mean_np(ik) = sumnp(ik) / ri2 * geofac_pc + + do il = i1, i2 + + dpi(il,j2,ik) = mean_np(ik) + + end do + + end do + + !====== + end if + !====== + + ! Return to calling program + END SUBROUTINE Do_Divergence_Pole_Sum +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Xpavg +! +! !description: Subroutine Xpavg replaces each element of a vector with +! the average of the entire array. (bmy, 5/7/03) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Xpavg( P, IM ) +! +! !USES: +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ERROR_STOP +! +! !INPUT PARAMETERS: +! + ! Dimension of P + INTEGER, INTENT(IN) :: IM +! +! !INPUT/OUTPUT PARAMETERS: +! + ! 1-D vector to be averaged + REAL*8, INTENT(INOUT) :: P(IM) + +! !AUTHOR: +! Philip Cameron-Smith and John Tannahill, GMI project @ LLNL (2003) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +! Now make all REAL variables REAL*8. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*8 :: AVG + + !================================================================= + ! XPAVG begins here! + !================================================================= + + ! Error check IM + IF ( IM == 0 ) THEN + CALL ERROR_STOP( 'Div by zero!', 'XPAVG ("pjc_pfix_mod.f")' ) + ENDIF + + ! Take avg of entire P array + AVG = SUM( P ) / DBLE( IM ) + + ! Store average value in all elements of P + P(:) = AVG + + ! Return to calling program + END SUBROUTINE Xpavg +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Init_Pjc_Pfix +! +! !DESCRIPTION: Subroutine Init\_Pjc\_Pfix allocates and initializes module +! arrays and variables. GMI dimension variables will be used for +! compatibility with the Phil Cameron-Smith P-fixer. (bdf, bmy, 5/8/03) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Init_Pjc_Pfix +! +! !USES: +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_AREA_M2, GET_YMID_R + USE ERROR_MOD, ONLY : ALLOC_ERR, ERROR_STOP + USE PRESSURE_MOD, ONLY : GET_AP, GET_BP + +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! Re, PI, etc... +! +! +! !AUTHOR: +! Brendan Field and Bob Yantosca (5/8/03) +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Local variables + INTEGER :: AS, I, J, L + + !================================================================= + ! INIT_PJC_PFIX begins here! + ! + ! Initialize dimensions for GMI pressure-fixer code + !================================================================= + IMP_NBORDER = 0 + I1_GL = 1 + I2_GL = IIPAR + JU1_GL = 1 + JV1_GL = 1 + J2_GL = JJPAR + K1_GL = 1 + K2_GL = LLPAR + ILO_GL = I1_GL - IMP_NBORDER + IHI_GL = I2_GL + IMP_NBORDER + JULO_GL = JU1_GL - IMP_NBORDER + JVLO_GL = JV1_GL - IMP_NBORDER + JHI_GL = J2_GL + IMP_NBORDER + I1 = I1_GL + I2 = I2_GL + JU1 = JU1_GL + JV1 = JV1_GL + J2 = J2_GL + K1 = K1_GL + K2 = K2_GL + ILO = ILO_GL + IHI = IHI_GL + JULO = JULO_GL + JVLO = JVLO_GL + JHI = JHI_GL + ILAT = J2_GL - JU1_GL + 1 + ILONG = I2_GL - I1_GL + 1 + IVERT = K2_GL - K1_GL + 1 + J1P = 3 + J2P = J2_GL - J1P + 1 + + ! Error check longitude + IF ( ILONG /= IIPAR ) THEN + CALL ERROR_STOP( 'Invalid longitude dimension ILONG!', + & 'INIT_PJC_FIX ("pjc_pfix_mod.f")' ) + ENDIF + + ! Error check latitude + IF ( ILAT /= JJPAR ) THEN + CALL ERROR_STOP( 'Invalid latitude dimension ILAT!', + & 'INIT_PJC_FIX ("pjc_pfix_mod.f")' ) + ENDIF + + ! Error check altitude + IF ( IVERT /= LLPAR ) THEN + CALL ERROR_STOP( 'Invalid altitude dimension IVERT!', + & 'INIT_PJC_FIX ("pjc_pfix_mod.f")' ) + ENDIF + + !================================================================= + ! Allocate module arrays (use dimensions from GMI code) + !================================================================= + ALLOCATE( AI( K1_GL-1:K2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'AI' ) + + ALLOCATE( BI( K1_GL-1:K2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BI' ) + + ALLOCATE( DAP( K1_GL:K2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DAP' ) + + ALLOCATE( DBK( K1_GL:K2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DBK' ) + + ALLOCATE( CLAT_FV( JU1_GL:J2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CLAT_FV' ) + + ALLOCATE( COSE_FV( JU1_GL:J2_GL+1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COSE_FV' ) + + ALLOCATE( COSP_FV( JU1_GL:J2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'COSP_FV' ) + + ALLOCATE( DLAT_FV( JU1_GL:J2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DLAT_FV' ) + + ALLOCATE( ELAT_FV( JU1_GL:J2_GL+1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ELAT_FV' ) + + ALLOCATE( GEOFAC( JU1_GL:J2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GEOFAC' ) + + ALLOCATE( GW_FV( JU1_GL:J2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GW_FV' ) + + ALLOCATE( MCOR( I1_GL:I2_GL, JU1_GL:J2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MCOR' ) + + ALLOCATE( REL_AREA( I1_GL:I2_GL, JU1_GL:J2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REL_AREA' ) + + ALLOCATE( RGW_FV( JU1_GL:J2_GL ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RGW_FV' ) + + ALLOCATE( SINE_FV( JU1_GL:J2_GL+1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SINE_FV' ) + + !================================================================= + ! Initialize arrays and variables + !================================================================= + + ! Grid box surface areas [m2] + DO J = JU1_GL, J2_GL + DO I = I1_GL, I2_GL + MCOR(I,J) = GET_AREA_M2(J) + ENDDO + ENDDO + + ! Hybrid grid vertical coords: Ai [hPa] and Bi [unitless] + DO L = K1_GL-1, K2_GL + AI(L) = GET_AP( L+1 ) + BI(L) = GET_BP( L+1 ) + ENDDO + + ! Delta A [hPa] and Delta B [unitless] + DO L = K1_GL, K2_GL + !------------------------------------------------------------- + ! NOTE:, this was the original code. But since AI is already + ! in hPa, we shouldn't need to multiply by PTOP again. This + ! should only matter for the fvDAS fields. Also, DBK needs + ! to be positive (bmy, 5/8/03) + !DAP(L) = ( AI(L) - AI(L-1) ) * PTOP + !DBK(L) = BI(L) - BI(L-1) + !------------------------------------------------------------- + DAP(L) = AI(L-1) - AI(L) + DBK(L) = BI(L-1) - BI(L) + ENDDO + + ! Grid box center latitudes [radians] + DO J = JU1_GL, J2_GL + CLAT_FV(J) = GET_YMID_R(J) + ENDDO + + ! Longitude spacing + DLON_FV = 2.d0 * PI / DBLE( I2_GL ) + + ! Latitude edge at south pole [radians] + ELAT_FV(1) = -0.5d0 * PI + + ! SIN and COS of lat edge at south pole [unitless] + SINE_FV(1) = -1.d0 + COSE_FV(1) = 0.d0 + + ! Latitude edges [radians] (w/ SIN & COS) at intermediate latitudes + DO J = JU1_GL+1, J2_GL !2, JJPAR + ELAT_FV(J) = 0.5d0 * ( CLAT_FV(J-1) + CLAT_FV(J) ) + SINE_FV(J) = SIN( ELAT_FV(J) ) + COSE_FV(J) = COS( ELAT_FV(J) ) + ENDDO + + ! Latitude edge at North Pole [radians] + ELAT_FV(J2_GL+1) = 0.5d0 * PI + + ! SIN of lat edge at North Pole + SINE_FV(J2_GL+1) = 1.d0 + + ! Latitude extent of South polar box [radians] + DLAT_FV(1) = 2.d0 * ( ELAT_FV(2) - ELAT_FV(1) ) + + ! Latitude extent of boxes at intermediate latitudes [radians] + DO J = JU1_GL+1, J2_GL-1 ! 2, JJPAR-1 + DLAT_FV(J) = ELAT_FV(J+1) - ELAT_FV(J) + ENDDO + + ! Latitude extent of North polar box [radians] + DLAT_FV(J2_GL) = 2.d0 * ( ELAT_FV(J2_GL+1) - ELAT_FV(J2_GL) ) + + ! Other stuff + DO J = JU1_GL, J2_GL + GW_FV(J) = SINE_FV(J+1) - SINE_FV(J) + COSP_FV(J) = GW_FV(J) / DLAT_FV(J) + RGW_FV(J) = 1.d0 / GW_FV(J) + ENDDO + + ! Return to calling program + END SUBROUTINE Init_Pjc_Pfix +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: Cleanup_Pjc_Pfix +! +! !DESCRIPTION: Subroutine Cleanup\_Pjc\_Pfix deallocates all module arrays +! (bmy, 5/8/03) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE Cleanup_Pjc_Pfix +! +! !REVISION HISTORY: +! 02 Dec 2008 - R. Yantosca - Updated documentation and added ProTeX headers. +!EOP +!------------------------------------------------------------------------------ +!BOC + !================================================================= + ! CLEANUP_PJC_PFIX begins here! + !================================================================= + IF ( ALLOCATED( AI ) ) DEALLOCATE( AI ) + IF ( ALLOCATED( BI ) ) DEALLOCATE( BI ) + IF ( ALLOCATED( CLAT_FV ) ) DEALLOCATE( CLAT_FV ) + IF ( ALLOCATED( COSE_FV ) ) DEALLOCATE( COSE_FV ) + IF ( ALLOCATED( COSP_FV ) ) DEALLOCATE( COSP_FV ) + IF ( ALLOCATED( DAP ) ) DEALLOCATE( DAP ) + IF ( ALLOCATED( DBK ) ) DEALLOCATE( DBK ) + IF ( ALLOCATED( DLAT_FV ) ) DEALLOCATE( DLAT_FV ) + IF ( ALLOCATED( ELAT_FV ) ) DEALLOCATE( ELAT_FV ) + IF ( ALLOCATED( GEOFAC ) ) DEALLOCATE( GEOFAC ) + IF ( ALLOCATED( GW_FV ) ) DEALLOCATE( GW_FV ) + IF ( ALLOCATED( MCOR ) ) DEALLOCATE( MCOR ) + IF ( ALLOCATED( REL_AREA ) ) DEALLOCATE( REL_AREA ) + IF ( ALLOCATED( RGW_FV ) ) DEALLOCATE( RGW_FV ) + IF ( ALLOCATED( SINE_FV ) ) DEALLOCATE( SINE_FV ) + + ! Return to calling program + END SUBROUTINE Cleanup_Pjc_Pfix + + END MODULE Pjc_Pfix_Mod +!EOC diff --git a/code/planeflight_mod.f b/code/planeflight_mod.f new file mode 100644 index 0000000..21ce69d --- /dev/null +++ b/code/planeflight_mod.f @@ -0,0 +1,1643 @@ +! $Id: planeflight_mod.f,v 1.2 2009/11/18 07:09:33 daven Exp $ + MODULE PLANEFLIGHT_MOD +! +!****************************************************************************** +! Module PLANEFLIGHT_MOD contains variables and routines which are used to +! "fly" a plane through the GEOS-Chem model simulation. This is useful for +! comparing model results with aircraft observations. +! (mje, bmy, 7/30/02, 4/23/07) +! +! Module Variables: +! ============================================================================ +! (1 ) MAXVARS (INTEGER ) : Maximum # of variables allowed +! (2 ) MAXPOINTS (INTEGER ) : Maximum # of flight track points allowed +! (3 ) MAXREAC (INTEGER ) : Maximum # of SMVGEAR reactions allowed +! (4 ) MAXRO2 (INTEGER ) : Maximum # of RO2 constituents allowed +! (5 ) NPOINTS (INTEGER ) : Number of flight track points +! (6 ) PPOINT (INTEGER ) : Pointer to last measured output +! (7 ) PDATE (REAL*4 ) : Array of dates at each flight point +! (8 ) PTIME (REAL*4 ) : Array of times at each flight point +! (9 ) PTAU (REAL*4 ) : Array of TAU's at each flight point +! (10) PLAT (REAL*4 ) : Array of latitude at each flight point +! (11) PLON (REAL*4 ) : Array of longitude at each flight point +! (12) PPRESS (REAL*4 ) : Array of pressure at each flight point +! (13) PTYPE (CHARACTER) : Array of ID'#S at each flight point +! (14) NPVAR (INTEGER ) : # of var's to be saved at each flight point +! (15) PVAR (INTEGER ) : Array of variable indices +! (16) PNAME (CHARACTER) : Array of variable names corresponding to PVAR +! (17) NPREAC (INTEGER ) : # of variables that are really SMVGEAR rxns +! (18) PREAC (INTEGER ) : Array of SMVGEAR rxn index numbers +! (19) PRRATE (REAL*4 ) : Array of rxn rates for each entry in PREAC +! (20) NRO2 (INTEGER ) : # number of RO2 constituents +! (21) PRO2 (INTEGER ) : Array of SMVGEAR species that are RO2 const's +! (22) INFILENAME (CHARACTER) : Name of input file defining the flight track +! (23) OUTFILENAME (CHARACTER) : Name of output file +! +! Module Routines: +! ============================================================================ +! (1 ) SETUP_PLANEFLIGHT : Reads species, points from input file +! (2 ) READ_VARIABLES : Reads info about variables to be saved out +! (3 ) READ_POINTS : Reads info for each point in the flight track +! (4 ) RO2_SETUP : Saves species indices for RO2 components +! (5 ) PLANEFLIGHT : Saves data for each species & point +! (6 ) TEST_VALID : Tests if we are in the SMVGEAR chem region +! (7 ) WRITE_VARS_TO_FILE : Writes planetrack data to the output file +! (8 ) ARCHIVE_RXNS_FOR_PF : Archives SMVGEAR rxns from "calcrate.f" +! (9 ) SET_PLANEFLIGHT : Gets filename info from "input_mod.f" +! (10) INIT_PLANEFLIGHT : Gets # of species, points; allocates arrays +! (11) CLEANUP_PLANEFLIGHT : Deallocates all allocated arrays +! +! GEOS-Chem modules referenced by planeflight_mod.f +! ============================================================================ +! (1 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (2 ) error_mod.f : Module w/ NaN and other error check routines +! (3 ) file_mod.f : Module w/ file unit numbers and error checks +! (4 ) pressure_mod.f : Module w/ routines to compute P(I,J,L) +! (5 ) time_mod.f : Module w/ routines to compute date & time +! (6 ) tracer_mod.f : Module w/ GEOS-Chem tracer array STT etc. +! +! NOTES: +! (1 ) Now references "pressure_mod.f" (dsa, bdf, bmy, 8/21/02) +! (2 ) Now reference AD from "dao_mod.f". Now also references "error_mod.f". +! (bmy, 10/15/02) +! (3 ) Bug fix: replace missing commas in FORMAT statement (bmy, 3/23/03) +! (4 ) Now references "time_mod.f". (bmy, 3/27/03) +! (5 ) Renamed PRATE to PRRATE to avoid conflict w/ SMVGEAR II (bmy, 4/1/03) +! (6 ) Bug fix: use NAMEGAS instead of NAMESPEC (lyj, bmy, 7/9/03) +! (7 ) Bug fix: avoid referencing JLOP for non-SMVGEAR runs (bmy, 7/18/03) +! (8 ) Bug fix: Use T instead of T3 for GMAO temperature. Also replace +! NAMESPEC w/ NAMEGAS in RO2_SETUP. Now locate reordered rxn +! numbers for SMVGEAR II.(tdf, mje, bmy, 8/1/03) +! (9 ) Now print out N2O5 hydrolysis rxn as a special case. Also rename +! output file. (bmy, 8/8/03) +! (10) Changed "DAO" to "GMAO" for met field variable names. Now can save +! aerosol optical depths. Bug fix in TEST_VALID. (bmy, 4/23/03) +! (11) Now references "tracer_mod.f" (bmy, 7/20/04) +! (12) Bug fix in READ_VARIABLES (1/7/05) +! (13) Modified the plane flight diagnostic so that it writes output files +! for each day where flight track files are defined. (bmy, 3/24/05) +! (14) Minor bug fix in ARCHIVE_RXNS_FOR_PF (bmy, 5/20/05) +! (15) Now split AOD's into column AOD's and AOD's below plane. Also scale +! AOD's to 400nm. (bmy, 10/25/05) +! (16) Bug fixes in READ_VARIABLES (bmy, 10/16/06) +! (17) Bug fix in PLANEFLIGHT (cdh, bmy, 12/12/06) +! (18) Bug fix in RO2_SETUP (tmf, bmy, 4/23/07) +! (19) Set very small values to zero. (tmf, 1/7/09) +! (20) Add new RO2 species according to 'globchem.dat' (tmf, 1/7/09) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "planeflight_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: ARCHIVE_RXNS_FOR_PF + PUBLIC :: CLEANUP_PLANEFLIGHT + PUBLIC :: PLANEFLIGHT + PUBLIC :: SETUP_PLANEFLIGHT + PUBLIC :: SET_PLANEFLIGHT + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Logicals + LOGICAL :: DO_PF + + ! Parameters + INTEGER, PARAMETER :: MAXVARS = 95 + INTEGER, PARAMETER :: MAXPOINTS = 10000 + INTEGER, PARAMETER :: MAXREAC = 50 + INTEGER, PARAMETER :: MAXRO2 = 45 + + ! For specifying flight track points + INTEGER :: NPOINTS + INTEGER :: PPOINT + + ! For specifying date/time + INTEGER, ALLOCATABLE :: PDATE(:) + INTEGER, ALLOCATABLE :: PTIME(:) + REAL*4, ALLOCATABLE :: PTAU(:) + + ! For specifying lat/lon/alt and ID type + REAL*4, ALLOCATABLE :: PLAT(:) + REAL*4, ALLOCATABLE :: PLON(:) + REAL*4, ALLOCATABLE :: PPRESS(:) + CHARACTER(LEN=5), ALLOCATABLE :: PTYPE(:) + + ! For specifying variables to save at each flight point + INTEGER :: NPVAR + INTEGER, ALLOCATABLE :: PVAR(:) + CHARACTER(LEN=10), ALLOCATABLE :: PNAME(:) + + ! For specifying SMVGEAR rxns to save at each flight point + INTEGER :: NPREAC + INTEGER, ALLOCATABLE :: PREAC(:) + REAL*8, ALLOCATABLE :: PRRATE(:,:) + + ! For specifying RO2 constituents at each flight point + INTEGER :: NPRO2 + INTEGER :: PRO2(MAXRO2) + + ! Input/output file names + CHARACTER(LEN=255) :: INFILENAME, INF + CHARACTER(LEN=255) :: OUTFILENAME, OUTF + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE SETUP_PLANEFLIGHT +! +!****************************************************************************** +! Subroutine SETUP_PLANEFLIGHT reads information from the input file in order +! to initialize the planeflight diagnostic. Also calls INIT_PLANEFLIGHT +! to allocate and zero module arrays. (mje, bmy, 7/30/02, 3/24/05) +! +! For SMVGEAR simulations, the call to SETUP_PLANEFLIGHT is made from routine +! "chemdr.f", after the "chem.dat" file is read. This is necessary since +! we have to reference the SMVGEAR rxn rate and species numbers. +! +! For non-SMVGEAR simulations, the call to SETUP_PLANEFLIGHT can be made +! at the start of the GEOS-Chem run (in "ndxx_setup.f" or similar routine). +! +! NOTES: +! (1 ) Rename from "plane.dat" to "plane.log", since "*.dat" implies an input +! file name. (bmy, 8/8/03) +! (2 ) Add fancy output string (bmy, 4/26/04) +! (3 ) Now references GET_NYMD, GET_NHMS, and EXPAND_DATE from "time_mod.f". +! Now also replaces date & time tokens in the filenames. (bmy, 7/20/04) +! (4 ) Now references FILE_EXISTS from "file_mod.f". Modified so that we +! check if a flight track file exists on each day. Open file for +! output on each day and write header. (bmy, 3/25/05) +!****************************************************************************** +! + ! References to F90 modules + USE FILE_MOD, ONLY : FILE_EXISTS, IOERROR, IU_FILE, IU_PLANE + USE TIME_MOD, ONLY : EXPAND_DATE, GET_NYMD, GET_NHMS + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, IP, N, TEMP, LENGTH + INTEGER :: RN, COUNTER, IOS, NYMD, NHMS + CHARACTER(LEN=7) :: NAMES + CHARACTER(LEN=20) :: LINE + CHARACTER(LEN=10) :: TYPE + + !================================================================= + ! SETUP_PLANEFLIGHT begins here! + !================================================================= + + ! Assume that there is flight data for today + DO_PF = .TRUE. + + ! Get date & time + NYMD = GET_NYMD() + NHMS = GET_NHMS() + + ! Copy file names to local variables + INF = INFILENAME + OUTF = OUTFILENAME + + ! Replace any date & time tokens in the file names + CALL EXPAND_DATE( INF, NYMD, NHMS ) + CALL EXPAND_DATE( OUTF, NYMD, NHMS ) + + ! If we can't find a flighttrack file for today's date, return + IF ( .not. FILE_EXISTS( INF ) ) THEN + DO_PF = .FALSE. + RETURN + ENDIF + + ! Echo info + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'P L A N E F L I G H T D I A G N O S T I C' + WRITE( 6, 100 ) TRIM( INF ) + 100 FORMAT( /, 'SETUP_PLANEFLIGHT: Reading ',a ) + WRITE( 6, '(a)' ) + + ! Compute # of species and # of points & allocate arrays + CALL INIT_PLANEFLIGHT + + ! Return if there are no flight track points for today + IF ( NPOINTS == 0 ) THEN + WRITE( 6, '(a)' ) 'No flight track found for today!' + DO_PF = .FALSE. + RETURN + ENDIF + + !================================================================= + ! Open file and read info + !================================================================= + OPEN( IU_FILE, FILE=TRIM( INF ), IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'setup_planeflight:1') + + ! Read variables to be output -- sort into PVAR array by type + CALL READ_VARIABLES + + ! Read information about each point (date/time/lon/lat/alt) + CALL READ_POINTS + + ! Close the file + CLOSE( IU_FILE ) + + ! Set the pointer to the first record + PPOINT = 1 + + !================================================================= + ! Find the species # for all components of RO2 (SMVGEAR only) + !================================================================= + CALL RO2_SETUP + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + !================================================================= + ! Open today's plane.log file and write file header + !================================================================= + + ! Close previously-opened file + CLOSE( IU_PLANE ) + + ! Open new file + OPEN( IU_PLANE, FILE=TRIM( OUTF ), STATUS='UNKNOWN', IOSTAT=IOS ) + + ! Error check + IF ( IOS /= 0 ) THEN + CALL IOERROR( IOS, IU_PLANE, 'setup_planeflight:1' ) + ENDIF + + ! Write header + WRITE( IU_PLANE, 110 ) 'POINT', 'TYPE', 'YYYYMMDD', 'HHMM', + & 'LAT', 'LON', 'PRESS', ( PNAME(I), I=1,NPVAR ) + + ! FORMAT string + 110 FORMAT( A5,X,A5,X,A8,X,A4,X,A7,X,A7,X,A7,X,95(a10,x) ) + + ! Return to calling program + END SUBROUTINE SETUP_PLANEFLIGHT + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_VARIABLES +! +!****************************************************************************** +! Subroutine READ_VARIABLES reads the list of variables (SMVGEAR species, +! SMVGEAR rxn rates, GMAO met fields, or GEOS-Chem tracers) to be printed +! out and sorts the information into the appropriate module variables. +! (mje, bmy, 7/30/02, 10/16/06) +! +! NOTES: +! (1 ) Now references GEOS_CHEM_STOP from "error_mod.f", which frees all +! allocated memory before stopping the run. (bmy, 10/15/02) +! (2 ) Bug fix: replace missing commas in FORMAT statement (bmy, 3/23/03) +! (3 ) Bug fix: replace NAMESPEC w/ NAMEGAS for SMVGEAR II (lyj, bmy, 7/9/09) +! (4 ) Now locate reordered rxn numbers for SMVGEAR II. (mje, bmy, 8/1/03) +! (5 ) Now flag N2O5 hydrolysis rxn as a special case (bmy, 8/8/03) +! (6 ) Changed variable name prefix "DAO" to "GMAO". Also added aerosol +! optical depths w/ tracer offset 2000. (bmy, 4/23/04) +! (7 ) Now references N_TRACERS & ITS_A_FULLCHEM_SIM from "tracer_mod.f" +! (bmy, 7/20/04) +! (8 ) Bug fix: extract tracer # when reading rxn rates (bmy, 1/7/05) +! (9 ) Now computes column AOD's and AOD's below plane (bmy, 10/24/05) +! (10) We need to trim NAMEGAS before comparing to LINE so that comparisons +! for species like "O3" will work. Also set NCS=NCSURBAN at the top +! of the subroutine, to avoid out of bounds error. (dbm, bmy, 10/16/06) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE FILE_MOD, ONLY : IU_FILE, IOERROR + USE TRACER_MOD, ONLY : N_TRACERS, ITS_A_FULLCHEM_SIM + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NAMEGAS, NSPEC + + ! Local variables + LOGICAL :: IS_FULLCHEM + INTEGER :: M, N, NUM, R, IK, IOS + CHARACTER(LEN=255) :: LINE + + !================================================================= + ! READ_VARIABLES begins here! + !================================================================= + + ! Reset NCS to NCSURBAN for safety's sake (dbm, bmy, 10/16/06) + NCS = NCSURBAN + + ! Test if this is a fullchem run + IS_FULLCHEM = ITS_A_FULLCHEM_SIM() + + ! Read four lines of header + DO N = 1, 4 + READ( IU_FILE, '(a)', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_variables:1') + ENDDO + + ! Read in the number of species to be output + READ( IU_FILE, '(i3)', IOSTAT=IOS ) NPVAR + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_variables:2' ) + + ! Read in a separation line + READ( IU_FILE, '(a)', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_variables:3' ) + + ! Echo to stdout + WRITE( 6, '(a)' ) ' # Species PVAR' + WRITE( 6, '(a)' ) '-----------------------------' + + !================================================================= + ! Sort variables by type; assign indices to PVAR, PREAC arrays + ! NOTE: Variables for which PVAR(N) = 0 will be skipped! + !================================================================= + + ! Zero reaction counter + R = 0 + + ! Loop over all variables + DO N = 1, NPVAR + + ! Read each line + READ( IU_FILE, '(a)', IOSTAT=IOS ) LINE + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_variables:4') + + ! Save the name of each variable into the global PNAME array + PNAME(N) = LINE(1:10) + + ! We are searching for a ... + SELECT CASE ( LINE(1:4) ) + + !=========================================================== + ! GEOS-CHEM tracer: listed as "TRA_001", etc. + ! PVAR offset: 100000 + !=========================================================== + CASE ( 'TRA_' ) + + ! Extract tracer # from the string + READ( LINE(5:14), '(i10)' ) NUM + + ! Make sure the tracer # is valid! + IF ( NUM < 0 .or. NUM > N_TRACERS ) THEN + WRITE( 6, 100 ) TRIM( LINE ) + 100 FORMAT( 'TRACER ', i4, ' is out of range!' ) + WRITE( 6, '(a)' ) 'STOP in SETUP_PLANEFLIGHT!' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + ! Save in PVAR -- add offset of 100000 + PVAR(N) = 100000 + NUM + + !=========================================================== + ! GMAO met field: listed as "GMAO_TEMP", etc. + ! PVAR offset: 1000 + !=========================================================== + CASE ( 'GMAO' ) + + IF ( LINE == 'GMAO_TEMP' ) PVAR(N) = 1001 + IF ( LINE == 'GMAO_ABSH' ) PVAR(N) = 1002 + IF ( LINE == 'GMAO_SURF' ) PVAR(N) = 1003 + IF ( LINE == 'GMAO_PSFC' ) PVAR(N) = 1004 + IF ( LINE == 'GMAO_UWND' ) PVAR(N) = 1005 + IF ( LINE == 'GMAO_VWND' ) PVAR(N) = 1006 + + !=========================================================== + ! Column aerosol optical depths (same order as for FAST-J) + ! PVAR offset: 2000 + !=========================================================== + CASE ( 'AODC' ) + + IF ( LINE == 'AODC_SULF' ) PVAR(N) = 2001 + IF ( LINE == 'AODC_BLKC' ) PVAR(N) = 2002 + IF ( LINE == 'AODC_ORGC' ) PVAR(N) = 2003 + IF ( LINE == 'AODC_SALA' ) PVAR(N) = 2004 + IF ( LINE == 'AODC_SALC' ) PVAR(N) = 2005 + + !=========================================================== + ! Aerosol optical depths below the plane + ! (same order as for FAST-J) PVAR offset: 3000 + !=========================================================== + CASE ( 'AODB' ) + + IF ( LINE == 'AODB_SULF' ) PVAR(N) = 3001 + IF ( LINE == 'AODB_BLKC' ) PVAR(N) = 3002 + IF ( LINE == 'AODB_ORGC' ) PVAR(N) = 3003 + IF ( LINE == 'AODB_SALA' ) PVAR(N) = 3004 + IF ( LINE == 'AODB_SALC' ) PVAR(N) = 3005 + + !=========================================================== + ! SMVGEAR rxn rate: listed as "REA_001", etc. + ! PVAR offset: 10000 + !=========================================================== + CASE ( 'REA_' ) + + ! Skip if not SMVGEAR! + IF ( IS_FULLCHEM ) THEN + + ! Increment rxn counter + R = R + 1 + + IF ( TRIM( LINE ) == 'REA_O1D' ) THEN + + ! O1D is a special rxn, give it offset of 20000 + PVAR(N) = 20000 + PREAC(R) = 20000 + + ELSE IF ( TRIM( LINE ) == 'REA_N2O5' ) THEN + + ! N2O5 hydrolysis is another special rxn + ! give it an offset of 21000 + PVAR(N) = 21000 + PREAC(R) = 21000 + + ELSE + !================================================== + ! NOTE: the reaction numbers listed in smv2.log + ! aren't really used to index SMVGEAR II rxns. The + ! rxns get reordered. Find the right rxn number, + ! which is stored in NOLDFNEW. We assume only one + ! chemistry scheme. (mje, bmy, 8/1/03) + !================================================== + + ! Extract tracer # from the string + READ( LINE(5:14), '(i10)' ) NUM + + ! Initialize + PVAR(N) = -999 + PREAC(R) = -999 + + ! Search for proper rxn number + DO IK = 1, NMTRATE + + ! Offset other reaction rates by 10000 + IF ( NOLDFNEW(IK,1) == NUM ) THEN + PVAR(N) = 10000 + IK + PREAC(R) = 10000 + IK + EXIT + ENDIF + ENDDO + + ! Stop w/ error + IF ( PVAR(N) == -999 ) THEN + WRITE (6,*) 'Cant match up reaction number' + WRITE (6,*) NUM + WRITE (6,*) 'Is it the second line of the' + WRITE (6,*) 'Three body reaction' + WRITE (6,*) 'Stopping' + CALL GEOS_CHEM_STOP + ENDIF + ENDIF + ENDIF + + !=========================================================== + ! SMVGEAR chem species: listed as "O3", "C2H6", etc. + ! PVAR offset: 0 + !=========================================================== + CASE DEFAULT + + ! Skip if not SMVGEAR! + IF ( IS_FULLCHEM ) THEN + + ! Loop over all SMVGEAR species -- + ! match w/ species as read from disk + DO M = 1, NSPEC(NCS) + IF ( TRIM( NAMEGAS(M) ) == TRIM( LINE ) ) THEN + PVAR(N) = M + EXIT + ENDIF + ENDDO + + ! Special flag for RO2 species + IF ( TRIM( LINE ) == 'RO2' ) PVAR(N) = 999 + + ! Error check + IF ( PVAR(N) == 0 ) THEN + WRITE( 6, '(a)' ) 'ERROR: invalid species!' + WRITE( 6, 110 ) TRIM( LINE ) + 110 FORMAT( 'Species ', a, ' not found!' ) + WRITE( 6, '(a)' ) 'STOP in PLANEFLIGHT!' + CALL GEOS_CHEM_STOP + ENDIF + ENDIF + + END SELECT + + ! Echo species names/numbers to screen + WRITE( 6, 120 ) N, TRIM( LINE ), PVAR(N) + 120 FORMAT( i4, 1x, a10, 1x, i10 ) + + ENDDO + + ! REturn to calling program + END SUBROUTINE READ_VARIABLES + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_POINTS +! +!****************************************************************************** +! Subroutine READ_POINTS reads the information (ID, date, time, lat, lon, +! pressure) for each measurement listed in the input file, and sorts these +! into the appropriate module variables. (mje, bmy, 7/30/02, 10/15/02) +! +! NOTES: +! (1 ) Now references GEOS_CHEM_STOP from "error_mod.f", which frees all +! allocated memory before stopping the run. (bmy, 10/15/02) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_TAU0 + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE FILE_MOD, ONLY : IU_FILE, IOERROR + + ! Local variabes + INTEGER :: N, IOS, QYY, QMM, QDD, QHH, QMN + REAL*4 :: LAT, LON, PRES + CHARACTER(LEN=10) :: TYPE + + !================================================================= + ! READ_POINTS begins here! + !================================================================= + + ! Read 4 header lines + DO N = 1, 4 + READ( IU_FILE, '(a)', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_points:1' ) + ENDDO + + !================================================================= + ! Read plane track points -- plane, lat/lon/alt, date/time + ! We have previously computed NPOINTS in INIT_PLANEFLIGHT + !================================================================= + DO N = 1, NPOINTS + + ! Read a line from the file + READ( IU_FILE, 100, IOSTAT=IOS ) + & TYPE, QDD, QMM, QYY, QHH, QMN, LAT, LON, PRES + 100 FORMAT( 6x,a5,x,i2,x,i2,x,i4,x,i2,x,i2,x,f7.2,x,f7.2,x,f7.2 ) + + ! Error check + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'read_points:2' ) + + ! Exit if the word END is found + IF ( INDEX( TYPE, 'END' ) > 0 ) EXIT + + !============================================================== + ! Read date and time coordinates -- also do error checks + !============================================================== + + ! Error check MONTH + IF ( QMM < 1 .or. QMM > 12 ) THEN + WRITE( 6, 105 ) QMM + 105 FORMAT( 'ERROR: MONTH out of range: ', f8.3 ) + WRITE( 6, '(a)' ) 'STOP in READ_POINTS (planeflight_mod.f)' + CALL GEOS_CHEM_STOP + ENDIF + + ! Error check DAY + IF ( QDD < 1 .or. QDD > 31 ) THEN + WRITE( 6, 110 ) QDD + 110 FORMAT( 'ERROR: DAY out of range: ', f8.3 ) + WRITE( 6, '(a)' ) 'STOP in READ_POINTS (planeflight_mod.f)' + CALL GEOS_CHEM_STOP + ENDIF + + ! Error check HOUR + IF ( QHH < 0 .or. QHH > 23 ) THEN + WRITE( 6, 115 ) QHH + 115 FORMAT( 'ERROR: HOUR out of range: ', f8.3 ) + WRITE( 6, '(a)' ) 'STOP in READ_POINTS (planeflight_mod.f)' + CALL GEOS_CHEM_STOP + ENDIF + + ! Error check MINUTES + IF ( QMN < 0 .or. QMN > 59 ) THEN + WRITE( 6, 120 ) QMN + 120 FORMAT( 'ERROR: MINUTES out of range: ', f8.3 ) + WRITE( 6, '(a)' ) 'STOP in READ_POINTS (planeflight_mod.f)' + CALL GEOS_CHEM_STOP + ENDIF + + ! Store type in the global PTYPE array + PTYPE(N) = TYPE + + ! Store YYYYMMDD in the global PDATE array + PDATE(N) = ( QYY * 10000 ) + ( QMM * 100 ) + QDD + + ! Store HHMMSS in the global PTIME array + ! (actaully we read in just HHMM, assume seconds = 00) + PTIME(N) = ( QHH * 100 ) + QMN + + ! Store TAU (hours since 1 Jan 1985) in the global PTAU array + PTAU(N) = GET_TAU0( QMM, QDD, QYY, QHH, QMN, 0 ) + + !============================================================== + ! Read lon/lat/alt coordinates -- also do error checks + !============================================================== + + ! Put LONGITUDE in the range [-180...180] + IF ( LON > 180.0 ) LON = LON - 360e0 + + ! Error check LONGITUDE + IF ( LON < -180 .OR. LON > 180 ) THEN + WRITE( 6, 125 ) LON + 125 FORMAT( 'ERROR: Longitude out of range: ', f8.3 ) + WRITE( 6, '(a)' ) 'STOP in READ_POINTS (planeflight_mod.f)' + CALL GEOS_CHEM_STOP + ENDIF + + ! Error check LATITUDE + IF ( LAT < -90.0 .OR. LAT > 90.0 ) THEN + WRITE( 6, 130 ) LAT + 130 FORMAT( 'ERROR: Latitude out of range: ', f8.3 ) + WRITE( 6, '(a)' ) 'STOP in READ_POINTS (planeflight_mod.f)' + CALL GEOS_CHEM_STOP + ENDIF + + ! Assign LAT value into global PLAT array + PLAT(N) = LAT + + ! Assign LON value into global PLON array + PLON(N) = LON + + ! Assign PRES value into global PPRESS array + PPRESS(N) = PRES + + ENDDO + + !================================================================= + ! Echo number of points found and quit + !================================================================= + WRITE( 6, 135 ) NPOINTS + 135 FORMAT( /, 'Number of flight track points : ', i6 ) + + ! Return to calling program + END SUBROUTINE READ_POINTS + +!------------------------------------------------------------------------------ + + SUBROUTINE RO2_SETUP +! +!****************************************************************************** +! Subroutine RO2_SETUP saves the SMVGEAR species indices of RO2 +! constituents in the PRO2 array. Also computes the count NPRO2. +! (mje, bmy, 8/1/03, 4/23/07) +! +! NOTES: +! (1 ) Now references GEOS_CHEM_STOP from "error_mod.f", which frees all +! allocated memory before stopping the run. (bmy, 10/15/02) +! (2 ) Now replace NAMESPEC w/ NAMEGAS for SMVGEAR II (bmy, 8/1/03) +! (3 ) Now references ITS_A_FULLCHEM_SIM from "tracer_mod.f" (bmy, 7/20/04) +! (4 ) Bug fix: PO3 should be PO2 (tmf, bmy, 4/23/07) +! (5 ) NOTE: PO3 was a bug, that should have been PO2 (tmf, 2/10/09) +! (6 ) Add new RO2 species according to 'globchem.dat' (tmf, 3/10/09) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! NSPEC, NAMEGAS, NCS + + ! Local variables + INTEGER :: M + + !================================================================= + ! RO2_SETUP begins here! + !================================================================= + + ! Initialize + NPRO2 = 0 + + ! We only need to proceed for SMVGEAR chemistry + IF ( .not. ITS_A_FULLCHEM_SIM() ) RETURN + + !================================================================= + ! Loop over all SMVGEAR species, test for RO2 components + !================================================================= + DO M = 1, NSPEC(NCS) + + ! If we have found an RO2 compoent, add its species # to + ! the PRO2 global array, and increment counter + ! NOTE: PO3 was a bug, that should have been PO2 (tmf, 2/10/09) + SELECT CASE( TRIM( NAMEGAS(M) ) ) + + CASE ( 'HO2', 'MO2', 'A3O2', 'ATO2', 'B3O2', + & 'ETO2', 'GCO3', 'IAO2', 'KO2', 'MAO3', + & 'MCO3', 'MRO2', 'PO2', 'RIO2', 'VRO2', + & 'ACO3', 'EO2', 'ENCO3', 'ENO2', 'GLCO3', + & 'IACO3', 'INO2', 'MACO3', 'NICO3', 'NIO2', + & 'VOHRO2', 'RIO1', 'C59O2') + NPRO2 = NPRO2 + 1 + PRO2(NPRO2) = M + + CASE DEFAULT + ! Nothing + + END SELECT + + ENDDO + + ! Error check + IF ( NPRO2 > MAXRO2 ) THEN + WRITE( 6, '(a)' ) 'NPRO2 exceeds maximum allowed value!' + WRITE( 6, '(a)' ) 'STOP in RO2_SETUP (planeflight_mod.f)' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + !================================================================= + ! Echo number of points found and quit + !================================================================= + WRITE( 6, 100 ) NPRO2 + 100 FORMAT( 'Number of RO2 components : ', i6 ) + + ! Return to calling program + END SUBROUTINE RO2_SETUP + +!------------------------------------------------------------------------------ + + SUBROUTINE PLANEFLIGHT +! +!****************************************************************************** +! Subroutine PLANEFLIGHT saves concentrations to disk at locations +! corresponding to a flight track (mje, bmy, 7/8/02, 12/12/06) +! +! NOTES: +! (1 ) Now reference AD from "dao_mod.f". Now references GEOS_CHEM_STOP from +! "error_mod.f", which frees memory before stopping. (bmy, 10/15/02) +! (2 ) Now uses functions GET_TAU, GET_TS_CHEM from "time_mod.f". +! (bmy, 3/27/03) +! (3 ) Updated comments, cosmetic changes (bmy, 7/18/03) +! (4 ) Now references T from "dao_mod.f", so that we can save out temperature +! for non-SMVGEAR runs. (bmy, 8/1/03) +! (5 ) Now references UWND and VWND from "dao_mod.f". Now references +! GET_PEDGE from "pressure_mod.f". Added CASEs for surface pressure, +! UWND, VWND to the CASE statement (bmy, 4/23/04) +! (6 ) Now references STT & TCVV from "tracer_mod.f" (bmy, 7/20/04) +! (7 ) Now return if DO_PF = .FALSE. (bmy, 3/24/05) +! (8 ) Now compute column AOD's and AOD's below plane. Also now scale +! AOD's to 400nm. (bmy, 10/24/05) +! (9 ) Bug fix: exit if PTAU(M) == PTAUE, so that we write out on the next ! +! planeflight timestep (cdh, bmy, 12/12/06) +!****************************************************************************** +! + ! Reference to F90 modules + USE COMODE_MOD, ONLY : AIRDENS, CSPEC, JLOP, T3 + USE COMODE_MOD, ONLY : VOLUME, ABSHUM, TAREA + USE DAO_MOD, ONLY : AD, T, UWND, VWND + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE PRESSURE_MOD, ONLY : GET_PEDGE + USE TIME_MOD, ONLY : GET_TAU, GET_TS_CHEM + USE TRACER_MOD, ONLY : STT, TCVV + + IMPLICIT NONE + +# include "cmn_fj.h" ! FAST-J parameters (includes CMN_SIZE) +# include "jv_cmn.h" ! ODAER, QAA, QAA_AOD +# include "comode.h" ! CSPEC, etc. + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: PCHEM + INTEGER :: I, IP, IRHN, J, L, JLOOP, M, N, R, RH, V + INTEGER :: LPLANE + REAL*8 :: TK, PTAUS, PTAUE, CONSEXP, VPRESH2O, SAODnm + REAL*8 :: VARI(NPVAR) + REAL*8, PARAMETER :: MISSING = -999.99999999d0 + + REAL*8, PARAMETER :: TINY = 1.d-36 ! arbitary small number to avoid faulty output + + ! Aerosol types: SULF, BLKC, ORGC, SALA, SALC + INTEGER :: IND(5) = (/ 22, 29, 36, 43, 50 /) + + !================================================================= + ! PLANEFLIGHT begins here! + !================================================================= + + ! Return if there is no flighttrack data for today + IF ( .not. DO_PF ) RETURN + + ! Loop over all the locations that have not yet been found + DO M = PPOINT, NPOINTS + + ! Starting & end times of chemistry interval + PTAUS = GET_TAU() + PTAUE = PTAUS + ( GET_TS_CHEM() / 60d0 ) + + ! Initialize VARI to missing value for this point + DO V = 1, NPVAR + VARI(V) = MISSING + ENDDO + + !============================================================== + ! We haven't found the first plane point yet... + !============================================================== + IF ( PTAU(M) < PTAUS ) THEN + + ! Write all missing values to disk for point #M + CALL WRITE_VARS_TO_FILE( M, VARI ) + + ! Increment pointer + PPOINT = PPOINT + 1 + + !============================================================== + ! We have already found all of the plane points... + !============================================================== + ELSE IF ( PTAU(M) >= PTAUE ) THEN + + ! Exit this loop and the subroutine + EXIT + + !============================================================== + ! We have found a plane point at the proper time & location! + !============================================================== + ELSE + + ! Print the flight track point number + WRITE( 6, 100 ) PTYPE(M), PDATE(M), PTIME(M) + 100 FORMAT( ' - PLANEFLIGHT: Archived ',a5,1x,i8.8,1x,i4.4 ) + + ! Return grid box indices for the chemistry region + ! NOTE: PCHEM and JLOOP are only defined for SMVGEAR runs! + CALL TEST_VALID( M, PCHEM, JLOOP, I, J, L ) + + ! Initialize SMVGEAR reaction counter + R = 0 + + ! Loop over all variables to save out + DO V = 1, NPVAR + + ! Handle each variable + SELECT CASE ( PVAR(V) ) + + !------------------------- + ! SMVGEAR species + !------------------------- + CASE ( 1:998 ) + + ! Only archive where SMVGEAR chem is done + ! Save as mixing ratio [v/v] + IF ( PCHEM ) THEN + VARI(V) = CSPEC(JLOOP,PVAR(V)) / AIRDENS(JLOOP) + ENDIF + + !------------------------- + ! RO2 family + !------------------------- + CASE ( 999 ) + + ! Only archive where SMVGEAR chem is done + ! Sum all RO2 contributions, save as [v/v] + IF ( PCHEM ) THEN + VARI(V) = 0d0 + + DO N = 1, NPRO2 + VARI(V) = VARI(V) + CSPEC(JLOOP,PRO2(N)) + ENDDO + + VARI(V) = VARI(V) / AIRDENS(JLOOP) + ENDIF + + !-------------------------- + ! GMAO temperature [K] + !-------------------------- + CASE ( 1001 ) + VARI(V) = T(I,J,L) + + !-------------------------- + ! GMAO abs humidity [frac] + !-------------------------- + CASE ( 1002 ) + + ! Only archive where SMVGEAR chem is done + ! Code skalooched from "calcrate.f" + IF ( PCHEM ) THEN + TK = T3(JLOOP) + CONSEXP = 17.2693882d0 * + & (TK - 273.16d0) / (TK - 35.86d0) + + VPRESH2O = CONSVAP * EXP(CONSEXP) * 1d0 / TK + + VARI(V) = ABSHUM(JLOOP) * + & VPRESH2O / AIRDENS(JLOOP) + ENDIF + + !-------------------------- + ! GMAO aerosol sfc area + !-------------------------- + CASE ( 1003 ) + + ! Only archive where SMVGEAR chem is done + IF ( PCHEM ) THEN + VARI(V) = 0d0 + + DO N = 1, NDUST + NAER + VARI(V) = VARI(V) + TAREA(JLOOP,N) + ENDDO + ENDIF + + !-------------------------- + ! GMAO sfc pressure [hPa] + !-------------------------- + CASE ( 1004 ) + VARI(V) = GET_PEDGE(I,J,1) + + !------------------------- + ! GMAO U-wind [m/s] + !------------------------- + CASE ( 1005 ) + VARI(V) = UWND(I,J,L) + + !-------------------------- + ! GMAO V-wind [m/s] + !-------------------------- + CASE ( 1006 ) + VARI(V) = VWND(I,J,L) + + !-------------------------- + ! Column aerosol optical + ! depths [unitless] + !-------------------------- + CASE ( 2001:2005 ) + + ! Only archive where SMVGEAR chem is done + IF ( PCHEM ) THEN + + ! Remove MISSING flag + VARI(V) = 0d0 + + ! Aerosol number + N = PVAR(V) - 2000 + + ! Loop over RH bins + DO RH = 1, NRH + + ! Scaling factor for wavelength specified in + ! jv_spec_aod.dat + SAODnm = QAA_AOD(IND(N)+RH-1) / + & QAA(4,IND(N)+RH-1) + + ! Index for type of aerosol and RH value + IRHN = ( (N-1) * NRH ) + RH + + ! Sum AOD over all RH bins and store in VARI(V) + ! Sum over all vertical levels (bmy, 10/24/05) + VARI(V) = VARI(V) + + & SUM( SAODnm * ODAER(I,J,:,IRHN) ) + ENDDO + ENDIF + + !-------------------------- + ! Aerosol optical depths + ! below plane [unitless] + !-------------------------- + CASE ( 3001:3005 ) + + ! Only archive where SMVGEAR chem is done + IF ( PCHEM ) THEN + + ! Remove MISSING flag + VARI(V) = 0d0 + + ! Aerosol number + N = PVAR(V) - 3000 + + ! Loop over RH bins + DO RH = 1, NRH + + ! Scaling factor for wavelength specified in + ! jv_spec_aod.dat + SAODnm = QAA_AOD(IND(N)+RH-1) / + & QAA(4,IND(N)+RH-1) + + ! Index for type of aerosol and RH value + IRHN = ( (N-1) * NRH ) + RH + + ! Level of the plane. AOD's are only computed + ! up to the tropopause, so if the plane goes into + ! the stratosphere, the AOD below plane will be + ! the same as the trop column at that point. + ! (bmy, 10/24/05) + LPLANE = MIN( L, LLTROP ) + + ! Sum AOD over all RH bins and store in VARI(V) + ! Sum from surface to level where the plane is + VARI(V) = VARI(V) + + & SUM( SAODnm * ODAER(I,J,1:LPLANE,IRHN) ) + + ENDDO + ENDIF + + !-------------------------- + ! SMVGEAR reaction rates + !-------------------------- + CASE ( 10000:99999 ) + + ! Increment reaction count + R = R + 1 + + ! Only archive where SMVGEAR chem is done + IF ( PCHEM ) VARI(V) = PRRATE(JLOOP,R) + + !-------------------------- + ! GEOS-CHEM tracers [v/v] + !-------------------------- + CASE( 100000:199999 ) + + ! Remove offset from PVAR + N = PVAR(V) - 100000 + + ! Convert from [kg] --> [v/v] + VARI(V) = STT(I,J,L,N) * TCVV(N) / AD(I,J,L) + + IF ( VARI(V) < TINY ) VARI(V) = 0.d0 + + !-------------------------- + ! Otherwise it's an error! + !-------------------------- + CASE DEFAULT + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'PLANEFLIGHT: Bad variable #!' + WRITE( 6, '(a)' ) 'STOP in PLANEFLIGHT!' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + + END SELECT + ENDDO + + ! Write data for the Mth plane point out to disk + CALL WRITE_VARS_TO_FILE( M, VARI ) + + ! Increment the record pointer + PPOINT = PPOINT + 1 + + ENDIF + ENDDO + + ! Return to calling program + END SUBROUTINE PLANEFLIGHT + +!------------------------------------------------------------------------------ + + SUBROUTINE TEST_VALID( IND, PCHEM, JLOOP, I, J, L ) +! +!****************************************************************************** +! Subroutine TEST_VALID tests to see if we are w/in the tropopause, which +! is where SMVGEAR chemistry is done (mje, bmy, 7/8/02, 8/22/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IND (INTEGER) : Point index +! +! Arguments as Output: +! ============================================================================ +! (2 ) PCHEM (LOGICAL) : = T if this is a box where SMVGEAR chemistry is done +! (3 ) JLOOP (INTEGER) : 1-D grid box index for SMVGEAR +! (4-6) I,J,L (INTEGER) : Lon/Lat/Alt grid box indices +! +! NOTES: +! (1 ) Now use GET_PEDGE of "pressure_mod.f" to return the pressure at the +! bottom edge of box (I,J,L), for hybrid grid. (dsa, bdf, bmy, 8/21/02) +! (2 ) Since JLOP is not allocated for non-SMVGEAR runs, set PCHEM=F and +! JLOOP=0 even if we are in the troposphere. (bmy, 7/18/03) +! (3 ) Bug fix: add 0.5 in expression for I so that the rounding will +! be done correctly. Also make sure that I is computed correctly +! for points near the date line. (bmy, 4/23/04) +! (4 ) Now references ITS_A_FULLCHEM_SIM from "tracer_mod.f" (bmy, 7/20/04) +! (5 ) Now references ITS_IN_THE_TROP from "tropopause_mod.f" (bmy, 8/22/05) +!****************************************************************************** +! + ! References to F90 modules + USE COMODE_MOD, ONLY : JLOP + USE PRESSURE_MOD, ONLY : GET_PEDGE + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: IND + LOGICAL, INTENT(OUT) :: PCHEM + INTEGER, INTENT(OUT) :: JLOOP, I, J, L + + ! Local variables + INTEGER :: IL + LOGICAL :: FOUND + + !================================================================= + ! TEST_VALID begins here! + !================================================================= + + ! We have not found a valid point + FOUND = .FALSE. + + ! Get I corresponding to PLON(IND) + I = INT( ( PLON(IND) + 180d0 ) / DISIZE + 1.5d0 ) + + ! Handle date line correctly (bmy, 4/23/04) + IF ( I > IIPAR ) I = I - IIPAR + + ! Get J corresponding to PLAT(IND) + J = INT( ( PLAT(IND) + 90d0 ) / DJSIZE + 1.5d0 ) + + ! Get L corresponding to PRESS(IND) + L = 1 + DO IL = 1, LLPAR + IF ( GET_PEDGE(I,J,IL) <= PPRESS(IND) .AND..NOT. FOUND ) THEN + L = IL-1 + FOUND =.TRUE. + EXIT + ENDIF + ENDDO + + ! Error check: L must be 1 or higher + IF ( L == 0 ) L = 1 + + !================================================================= + ! We only do full-chemistry in the troposphere + !================================================================= + IF ( ITS_IN_THE_TROP( I, J, L ) ) THEN + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + ! This is a tropospheric box where SMVGEAR chemistry is done + PCHEM = .TRUE. + JLOOP = JLOP(I,J,L) + + ELSE + + ! For non-SMVGEAR runs, PCHEM has no meaning. + ! Set it to false to avoid out-of-bounds array errors. + PCHEM = .FALSE. + JLOOP = 0 + + ENDIF + + ELSE + + ! This is a stratospheric box where SMVGEAR chem is not done + PCHEM = .FALSE. + JLOOP = 0 + + ENDIF + + ! Return to calling program + END SUBROUTINE TEST_VALID + +!------------------------------------------------------------------------------ + + SUBROUTINE WRITE_VARS_TO_FILE( IND, VARI ) +! +!****************************************************************************** +! Subroutine WRITE_VARS_TO_FILE writes the values of all the variables for +! a given flight track point to the output file. (mje, bmy, 7/8/02. 3/25/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) IND (INTEGER) : Number of the flight track point to print to file +! (2 ) VARI (REAL*4 ) : Array holding variable values to print to file +! +! NOTES: +! (1 ) The max line length for output seems to be 1024 characters. Adjust +! MAXVARS accordingly so that we don't exceed this. (bmy, 7/8/02) +! (2 ) Now do not write file header -- this is now done in subroutine +! SETUP_PLANEFLIGHT at the start of each day (bmy, 3/25/05) +!****************************************************************************** +! + ! References to F90 modules + USE FILE_MOD, ONLY : IU_PLANE, IOERROR + + ! Arguments + INTEGER, INTENT(IN) :: IND + REAL*8, INTENT(IN) :: VARI(NPVAR) + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, IOS + + !================================================================= + ! WRITE_VARS_TO_FILE begins here! + !================================================================= + + ! Write data to file + WRITE( IU_PLANE, 110, IOSTAT=IOS ) + & IND, PTYPE(IND), INT( PDATE(IND) ), INT( PTIME(IND) ), + & PLAT(IND), PLON(IND), PPRESS(IND), ( VARI(I), I=1,NPVAR ) + + ! Format string +!------------------------------------------------------------------------------ +! Prior to 7/13/09: +! Always make sure we have 3 spaces in the exponential (phs, 7/13/09) +! 110 FORMAT(I5,X,A5,X,I8.8,X,I4.4,X,F7.2,X,F7.2,X,F7.2,X,95(es10.3,x)) +!------------------------------------------------------------------------------ + 110 FORMAT( I5, X, A5, X, I8.8, X, I4.4, X, + & F7.2, X, F7.2, X, F7.2, X, 95(es11.3e3,x) ) + + ! Error check + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_PLANE,'write_vars_to_file:1') + + ! Flush the file to disk + CALL FLUSH( IU_PLANE ) + + ! Return to calling program + END SUBROUTINE WRITE_VARS_TO_FILE + +!------------------------------------------------------------------------------ + + SUBROUTINE ARCHIVE_RXNS_FOR_PF( JO1D, N2O5 ) +! +!****************************************************************************** +! Subroutine ARCHIVE_RXNS_FOR_PF is called from "calcrate.f" to pass reaction +! rates from the SMVGEAR solver for the planeflight diagnostic. +! (mje, bmy, 7/8/02, 5/20/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) JO1D (REAL*8) : Array w/ JO1D photolysis rates [s-1] from "calcrate.f" +! (2 ) N2O5 (REAL*8) : Array w/ JO1D photolysis rates [s-1] from "calcrate.f" +! +! NOTES: +! (1 ) Now avoid overflow/underflow errors in PRATE (bmy, 7/8/02) +! (2 ) Now reference GEOS_CHEM_STOP from "error_mod.f", which frees all +! allocated memory before stopping the run (bmy, 10/15/02) +! (3 ) Renamed PRATE to PRRATE to avoid conflict w/ SMVGEAR II (bmy, 4/1/03) +! (4 ) Now also pass N2O5 hydrolysis rxn rate array via the arg list. +! Also bug fix: replace TMP with RATE in under/overflow checking +! for JO1D and N2O5. (bmy, 8/8/03) +! (5 ) Bug fix: Replace with DO_PF since this variable is reset to either T +! or F each day depending on whether there is plane flight data +! available (bmy, 5/20/05) +!****************************************************************************** +! + ! References to F90 modules + USE COMODE_MOD, ONLY : IXSAVE, IYSAVE, IZSAVE + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND40 switch +# include "comode.h" ! RRATE, JLOOPLO, KBLOOP + + ! Arguments + REAL*8, INTENT(IN) :: JO1D(KBLOOP) + REAL*8, INTENT(IN) :: N2O5(KBLOOP) + + ! Local variables + INTEGER :: KLOOP, JLOOP, V, R, I, J, L + REAL*8 :: RATE + + ! Smallest, largest REAL*4 #'s representable on this machine + REAL*4, PARAMETER :: SMALLEST=TINY(1e0), LARGEST=HUGE(1e0) + + !================================================================= + ! ARCHIVE_RXNS_FOR_PF begins here! + !================================================================= + IF ( DO_PF ) THEN + + ! Loop over SMVGEAR reactions + DO R = 1, NPREAC + + ! Test SMVGEAR rxn number + SELECT CASE ( PREAC(R) ) + + !----------------------- + ! All except JO1D, N2O5 + !----------------------- + CASE( 10000:19999 ) + + ! Store rate in PRRATE + DO KLOOP = 1, KTLOOP + JLOOP = JLOOPLO + KLOOP + RATE = RRATE(KLOOP,PREAC(R)-10000) + + ! Avoid overflow/underflow + IF ( RATE < SMALLEST ) RATE = 0e0 + IF ( RATE > LARGEST ) RATE = LARGEST + + PRRATE(JLOOP,R) = RATE + ENDDO + + !----------------------- + ! JO1D photolysis rxn + !----------------------- + CASE ( 20000 ) + + ! Store rate in PRATE + DO KLOOP = 1, KTLOOP + JLOOP = JLOOPLO + KLOOP + RATE = JO1D(KLOOP) + + ! Avoid overflow/underflow + IF ( RATE < SMALLEST ) RATE = 0e0 + IF ( RATE > LARGEST ) RATE = LARGEST + + PRRATE(JLOOP,R) = RATE + ENDDO + + !----------------------- + ! N2O5 hydrolysis rxn + !----------------------- + CASE ( 21000 ) + + ! Store rate in PRATE + DO KLOOP = 1, KTLOOP + JLOOP = JLOOPLO + KLOOP + RATE = N2O5(KLOOP) + + ! Avoid overflow/underflow + IF ( RATE < SMALLEST ) RATE = 0e0 + IF ( RATE > LARGEST ) RATE = LARGEST + + PRRATE(JLOOP,R) = RATE + ENDDO + + !----------------------- + ! Error: invalid rxn + !----------------------- + CASE DEFAULT + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) 'ERROR -- Invalid SMVGEAR rxn #!' + WRITE( 6, '(a)' ) 'STOP in ARCHIVE_RXNS_FOR_PF!' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + + END SELECT + ENDDO + ENDIF + + ! Return to calling program + END SUBROUTINE ARCHIVE_RXNS_FOR_PF + +!------------------------------------------------------------------------------ + + SUBROUTINE SET_PLANEFLIGHT( PF, IN_FILE, OUT_FILE ) +! +!****************************************************************************** +! Subroutine SET_PLANEFLIGHT is used to pass values read in from the +! GEOS-Chem input file to "planeflight_mod.f" (bmy, 7/20/04) +! +! Arguments as Input: +! ============================================================================ +! (1 ) PF (LOGICAL ) : Flag for turning on planeflight diagnostic +! (2 ) IN_FILE (CHARACTER) : Input file name (w/ plane flight track points) +! (3 ) OUT_FILE (CHARACTER) : Output file name +! +! NOTES: +!****************************************************************************** +! + ! Arguments + LOGICAL, INTENT(IN) :: PF + CHARACTER(LEN=255), INTENT(IN) :: IN_FILE + CHARACTER(LEN=255), INTENT(IN) :: OUT_FILE + + !================================================================= + ! SET_PLANEFLIGHT begins here! + !================================================================= + DO_PF = PF + INFILENAME = TRIM( IN_FILE ) + OUTFILENAME = TRIM( OUT_FILE ) + + ! Return to calling program + END SUBROUTINE SET_PLANEFLIGHT + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_PLANEFLIGHT +! +!****************************************************************************** +! Subroutine INIT_PLANEFLIGHT reads the input file to compute the number +! of variables and flight track points to print out. Also allocates all +! module arrays. (mje, bmy, 7/8/02, 3/25/05) +! +! NOTES: +! (1 ) Now reference GEOS_CHEM_STOP from "error_mod.f", which frees all +! allocated memory before stopping the run. Also reference ALLOC_ERR +! from "error_mod.f" (bmy, 10/15/02) +! (2 ) Renamed PRATE to PRRATE to avoid conflict w/ SMVGEAR II (bmy, 4/1/03) +! (3 ) INIT_PLANEFLIGHT is now called each day but the arrays are only +! allocated once. Arrays are now allocated to the maximum size. +! (bmy, 3/25/05) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR, GEOS_CHEM_STOP + USE FILE_MOD, ONLY : IU_FILE, IOERROR + +# include "CMN_SIZE" ! Size Parameters +# include "comode.h" ! ITLOOP + + ! Local variables + LOGICAL :: IS_INIT = .FALSE. + INTEGER :: N, AS, IOS + CHARACTER(LEN=20) :: LINE + + !================================================================= + ! INIT_PLANEFLIGHT begins here! + !================================================================= + + ! Open file + OPEN( IU_FILE, FILE=TRIM( INF ), IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'init_planeflight:1' ) + + ! Read four lines of header + DO N = 1, 4 + READ( IU_FILE, '(a)', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_FILE,'init_planeflight:2') + ENDDO + + !================================================================= + ! Read in the number of variables to be output -- store in NPVAR + !================================================================= + READ( IU_FILE, '(i3)', IOSTAT=IOS ) NPVAR + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'init_planeflight:3' ) + + ! Make sure NPVAR is at least 1 + IF ( NPVAR < 1 ) THEN + WRITE( 6, '(a)') 'NPVAR cannot be zero or negative!' + WRITE( 6, '(a)') 'STOP in INIT_PLANEFLIGHT (planeflight_mod.f)' + WRITE( 6, '(a)') REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + ! Make sure NPVAR is less than MAXVARS + IF ( NPVAR > MAXVARS ) THEN + WRITE( 6, '(a)') 'NPVAR exceeds maximum allowed value!' + WRITE( 6, '(a)') 'STOP in INIT_PLANEFLIGHT (planeflight_mod.f)' + WRITE( 6, '(a)') REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + ! Read in a separation line + READ( IU_FILE, '(a)', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_FILE, 'init_planeflight:4' ) + + ! Initialize SMVGEAR reaction counter + NPREAC = 0 + + ! Skip past the species declarations + DO N = 1, NPVAR + READ( IU_FILE, '(a)', IOSTAT=IOS ) LINE + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_FILE,'init_planeflight:5') + + ! Increment number of SMVGEAR reactions found + IF ( INDEX( LINE, 'REA_' ) > 0 ) NPREAC = NPREAC + 1 + ENDDO + + ! Read 4 header lines + DO N = 1, 4 + READ( IU_FILE, '(a)', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS,IU_FILE,'init_planeflight:6') + ENDDO + + !================================================================= + ! Read plane track points -- plane, lat/lon/alt, date/time + !================================================================= + NPOINTS = 0 + + DO + + ! Read a line from the file + READ( IU_FILE, '(a)', IOSTAT=IOS ) LINE + + ! Exit at end of file + IF ( IOS < 0 ) EXIT + IF ( IOS > 0 ) CALL IOERROR( IOS,IU_FILE,'init_planeflight:7' ) + + ! Check for END + IF ( INDEX( LINE, 'END' ) == 0 ) THEN + NPOINTS = NPOINTS + 1 + ELSE + EXIT + ENDIF + ENDDO + + ! Close file + CLOSE( IU_FILE ) + + ! If there are no flight-track points then just return + IF ( NPOINTS < 1 ) THEN + DO_PF = .FALSE. + RETURN + ENDIF + + ! Make sure NPOINTS is less than MAXPOINTS + IF ( NPOINTS > MAXPOINTS ) THEN + WRITE( 6, '(a)') 'NPOINTS exceeds maximum allowed value!' + WRITE( 6, '(a)') 'STOP in INIT_PLANEFLIGHT (planeflight_mod.f)' + WRITE( 6, '(a)') REPEAT( '=', 79 ) + CALL GEOS_CHEM_STOP + ENDIF + + !================================================================= + ! Allocate arrays to maximum sizes + ! + ! NOTE: To save space, NPREAC is the actual number of reactions + ! found. We will worry about this later. (bmy, 3/25/05) + !================================================================= + IF ( .not. IS_INIT ) THEN + + !------------------------- + ! Arrays of size NPREAC + !------------------------- + ALLOCATE( PREAC( MAX( NPREAC, 1 ) ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PREAC' ) + + ALLOCATE( PRRATE( ITLOOP, MAX( NPREAC, 1 ) ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PRRATE' ) + + !-------------------------- + ! Arrays of size MAXVARS + !-------------------------- + ALLOCATE( PVAR( MAXVARS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PVAR' ) + + ALLOCATE( PNAME( MAXVARS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PNAMES' ) + + !--------------------------- + ! Arrays of size MAXPOINTS + !--------------------------- + ALLOCATE( PTYPE( MAXPOINTS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PTYPE' ) + + ALLOCATE( PDATE( MAXPOINTS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PDATE' ) + + ALLOCATE( PTIME( MAXPOINTS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PTIME' ) + + ALLOCATE( PTAU( MAXPOINTS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PTAU' ) + + ALLOCATE( PLAT( MAXPOINTS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PLAT' ) + + ALLOCATE( PLON( MAXPOINTS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PLON' ) + + ALLOCATE( PPRESS( MAXPOINTS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PPRESS' ) + + ! Reset IS_INIT flag + IS_INIT = .TRUE. + ENDIF + + !================================================================= + ! Initialize arrays + !================================================================= + PREAC = 0 + PRRATE = 0e0 + PVAR = 0 + PNAME = '' + PTYPE = '' + PDATE = 0e0 + PTIME = 0e0 + PTAU = 0e0 + PLAT = 0e0 + PLON = 0e0 + PPRESS = 0e0 + + ! Return to calling program + END SUBROUTINE INIT_PLANEFLIGHT + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_PLANEFLIGHT +! +!****************************************************************************** +! Subroutine CLEANUP_PLANEFLIGHT deallocates all allocatable module arrays. +! (mje, bmy, 7/1/02, 4/1/03) +! +! NOTES: +! (1 ) Renamed PRATE to PRRATE to avoid conflict w/ SMVGEAR II (bmy, 4/1/03) +!****************************************************************************** +! + IF ( ALLOCATED( PVAR ) ) DEALLOCATE( PVAR ) + IF ( ALLOCATED( PREAC ) ) DEALLOCATE( PREAC ) + IF ( ALLOCATED( PNAME ) ) DEALLOCATE( PNAME ) + IF ( ALLOCATED( PRRATE ) ) DEALLOCATE( PRRATE ) + IF ( ALLOCATED( PTYPE ) ) DEALLOCATE( PTYPE ) + IF ( ALLOCATED( PDATE ) ) DEALLOCATE( PDATE ) + IF ( ALLOCATED( PTIME ) ) DEALLOCATE( PTIME ) + IF ( ALLOCATED( PTAU ) ) DEALLOCATE( PTAU ) + IF ( ALLOCATED( PLAT ) ) DEALLOCATE( PLAT ) + IF ( ALLOCATED( PLON ) ) DEALLOCATE( PLON ) + IF ( ALLOCATED( PPRESS ) ) DEALLOCATE( PPRESS ) + + ! Return to calling program + END SUBROUTINE CLEANUP_PLANEFLIGHT + +!------------------------------------------------------------------------------ + + END MODULE PLANEFLIGHT_MOD diff --git a/code/precipfrac.f b/code/precipfrac.f new file mode 100644 index 0000000..b3661ba --- /dev/null +++ b/code/precipfrac.f @@ -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 + + diff --git a/code/pulsing.f b/code/pulsing.f new file mode 100644 index 0000000..623d101 --- /dev/null +++ b/code/pulsing.f @@ -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 diff --git a/code/rcp_mod.f b/code/rcp_mod.f new file mode 100644 index 0000000..d017242 --- /dev/null +++ b/code/rcp_mod.f @@ -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 diff --git a/code/rd_aod.f b/code/rd_aod.f new file mode 100644 index 0000000..b62afb8 --- /dev/null +++ b/code/rd_aod.f @@ -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 diff --git a/code/rd_js.f b/code/rd_js.f new file mode 100644 index 0000000..ce16ebc --- /dev/null +++ b/code/rd_js.f @@ -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 diff --git a/code/rd_prof.f b/code/rd_prof.f new file mode 100644 index 0000000..6ba643d --- /dev/null +++ b/code/rd_prof.f @@ -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 diff --git a/code/rdisopt.f b/code/rdisopt.f new file mode 100644 index 0000000..503db0b --- /dev/null +++ b/code/rdisopt.f @@ -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 diff --git a/code/rdlai.f b/code/rdlai.f new file mode 100644 index 0000000..f1ed138 --- /dev/null +++ b/code/rdlai.f @@ -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 diff --git a/code/rdland.f b/code/rdland.f new file mode 100644 index 0000000..8bd426e --- /dev/null +++ b/code/rdland.f @@ -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 diff --git a/code/rdlight.f b/code/rdlight.f new file mode 100644 index 0000000..83bbcfb --- /dev/null +++ b/code/rdlight.f @@ -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 diff --git a/code/rdmonot.f b/code/rdmonot.f new file mode 100644 index 0000000..4b42dbc --- /dev/null +++ b/code/rdmonot.f @@ -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 diff --git a/code/rdsoil.f b/code/rdsoil.f new file mode 100644 index 0000000..3d0f4a3 --- /dev/null +++ b/code/rdsoil.f @@ -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 + + + + + + diff --git a/code/readchem.f b/code/readchem.f new file mode 100644 index 0000000..2f649e3 --- /dev/null +++ b/code/readchem.f @@ -0,0 +1,1182 @@ +! $Id: readchem.f,v 1.1 2009/06/09 21:51:53 daven Exp $ + SUBROUTINE READCHEM +! +!****************************************************************************** +! Subroutine READCHEM reads species 2names, chemical rxns, and photolysis +! reactions from the "globchem.dat" chemistry mechanism file for SMVGEAR II. +! (M. Jacobson 1997; bdf, bmy, 5/9/03, 8/9/06) +! +! NOTES: +! (1 ) Added space in FORMAT strings for more products. Also now references +! MAXDEP from "drydep_mod.f". Now also writes species and reactions +! to the "smv2.log" output file as unit #93. Now call GEOS_CHEM_STOP +! to deallocate all arrays and stop the run safely. Add NNADDG and +! NKSPECG for DMS+OH+O2 rxn. Now also force double precision with +! the "D" exponent. Now call SETPL before JSPARSE so that the prod/loss +! families will be computed correctly. (bmy, 5/9/03) +! (2 ) Now initialize ICH4 -- the location of CH4 in the CSPEC array. Now +! define lookup table ITS_NOT_A_ND65_FAMILY, which is used to exclude +! ND65 prod/loss families from modifying the SMVGEAR II convergence +! criteria. (bnd, bmy, 7/9/03) +! (3 ) Now declare ININT as a local variable instead of being declared w/in +! "comode.h". Remove reference to IPORD. (bmy, 7/16/03) +! (4 ) Now flag the N2O5 hydrolysis rxn for later use. (mje, bmy, 8/7/03) +! (5 ) Now references SETJFAM & SETPL from "diag_pl_mod.f" (bmy, 7/20/04) +! (6 ) Now look up ILISOPOH, the index of ISOP lost to OH (dkh, bmy, 6/1/06) +! (7 ) Increase FORMAT 510 so that it has space for 14 products (bmy, 8/9/06) +! (8 ) Now flag the HO2 heterogeneous uptake rxn for later use +! (jaegle, 02/26/09) +! (9 ) Added identifier to mark branching rxns for HOC2H4O (tmf, 1/7/09) +! HOC2H4O ------> HO2 + 2CH2O : marked as 'F' in P column +! HOC2H4O --O2--> HO2 + GLYC : marked as 'H' in P column +! +! The same branching rxns are also implemented in EP photolysis +! HOC2H4O ------> HO2 + 2CH2O : marked as 'I' in P column +! HOC2H4O --O2--> HO2 + GLYC : marked as 'J' in P column +!****************************************************************************** +! + ! References to F90 modules + USE DRYDEP_MOD, ONLY : MAXDEP + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + USE DIAG_PL_MOD, ONLY : SETJFAM, SETPL + + IMPLICIT NONE + +# include "CMN_SIZE" ! Size parameters +# include "comode.h" ! SMVGEAR II arrays +C +C ********************************************************************* +C ************ WRITTEN BY MARK JACOBSON (1990-4) ************ +C *** (650) 723-6836 *** +C ********************************************************************* +C +C RRRRRR EEEEEEE A DDDDDD CCCCCCC H H EEEEEEE M M +C R R E A A D D C H H E M M M M +C RRRRRR EEEE A A D D C HHHHHHH EEEEEEE M M M +C R R E AAAAAAA D D C H H E M M +C R R EEEEEEE A A DDDDDD CCCCCCC H H EEEEEEE M M +C +C ********************************************************************* +C * THIS IS THE SETUP ROUTINE FOR GAS-PHASE CHEMISTRY. IT READS * +C * SPECIES NAMES, CHEMICAL REACTIONS, AND PHOTOPROCESSES FROM AN * +C * INPUT DATA SET. IT THEN PLACES ALL NECESSARY INFORMATION INTO * +C * ARRAYS AND PRINTS OUT THE INPUT INFORMATION. * +C * * +C * HOW TO CALL SUBROUTINE: * +C * ---------------------- * +C * CALL READCHEM.F FROM MAIN.F * +C * * +C ********************************************************************* +C +C ********************************************************************* +C * SOME PARAMETER DEFINITIONS * +C ********************************************************************* +C +C DEFPRAT = DEFAULT PHOTORATE (SEC-1) +C IGAS = DIMENSION OF MAXIMUM NUMBER OF GAS SPECIES, ACTIVE + INACTIVE. +C IPHOT = MAXIMUM NUMBER OF RADIATIVELY ACTIVE SPECIES +C IPORD = ORDINAL # OF PHOTOPROCESS (USED TO IDENTIFY REACTION) +C IRORD = ORDINAL # OF KINET. REACT. (USED TO IDENTIFY REACTION) +C JMBCOMP = SPECIES NUMBER FOR EACH SPECIES IN A MASS BAL. GROUP +C MBCOMP = COUNTS THE MASS BALANCE SPECIES IN EACH M.B. GROUP (I.E. +C SULFUR IS A M.B. GROUP. +C NACTIVE = NUMBER OF ACTIVE SPECIES READ IN -- (A) IN COLUMN ONE +C OF INPUT DATA SET, CONVERTED TO NSPEC LATER +C NALLREAC = TOTAL NUMBER OF REACTANT POSITIONS IN A REACTION (BUT +C NUMBER OF ACTIVE POSITIONS IN NMREAC) +C NAMD = NAMES OF SPECIES WHICH MAY APPEAR IN REACTIONS BUT WHICH ARE +C "DEAD" WITH RESPECT TO THE PHOTOCHEMISTRY AND THUS ARE NOT +C PRINTED OUT. +C NAMEGAS = CHARACTER ARRAY OF SPECIES NAMES. +C NAMENCS = CHARACTER ARRAY OF SPECIES NAMES. +C NCS = 1..NCSGAS FOR GAS CHEMISTRY +C NGAS = NSPEC, THE NUMBER OF ACTIVE SPECIES +C NINAC = NUMBER OF INACTIVE SPECIES READ -- (I) IN COLUMN ONE +C NMAIR = # REACTIONS WHERE THE SPECIES IN THE THIRD POSITION +C IS 'M' = 'O2 + N2' +C NMASBAL = NUMBER OF MASS BALANCE GROUPS (E.G. S, N, C ARE GROUPS) +C NMN2 = # REACTIONS WHERE SPECIES IN THE THIRD POSITION IS N2 +C NMO2 = # REACTIONS WHERE SPECIES IN THE THIRD POSITION IS O2 +C NM3BOD = # REACTIONS WHERE SPECIES IN THE THIRD POSITION +C IS ANY OTHER SPECIES: IRM(3,NK) = -SPECIES NUMBER +C NMPROD = MAXIMUM NUMBER OF ACTIVE PRODUCTS IN A REACTION (READER.F) +C NMREAC = MAXIMUM NUMBER OF ACTIVE REACTANTS IN A REACTION +C OF INPUT DATA SET. (DEFINED IN READER.F) +C NNEQ = # THERMALLY DISSOCIATING EQUILIBRIUM REACTIONS. PREVIOUS +C EQUATION MUST BE PRESSURE-DEPENDENT. +C NPHOTALL = NUMBER OF ACTIVE GAS PHOTOPROCESSES +C NPRESM = # PRESSURE DEPENDENT 3-BODY REACTIONS +C NPRODHI = HIGHEST PRODUCT POSITON IN A REACTION +C NPRODLO = LOWEST PRODUCT POSITON IN A REACTION +C NRATES = NUMBER OF ACTIVE REACTIONS (EXCLUDING PHOTPROCESSES) +C NSDEAD = NUMBER OF DEAD SPECIES READ IN -- (D) IN COLUMN ONE OF +C INPUT DATA SET. +C NSPEC = TOTAL NUMBER OF ACTIVE SPECIES. +C NTRATES = NUMBER OF ACTIVE KINETIC REACTIONS PLUS PHOTOPROCESSES +C NTSPEC = ACTUAL NUMBER OF ACTIVE + INACTIVE (BUT NOT DEAD) SPECIES. +C QBKGAS = DEFAULT BACKGROUND CONCENTRATION (VOL MIXING RATIO) +C RINP = CHARACTER ARRAY FOR READING IN INFORMATION FROM DATA SETS. +C WTMB = MASS BALANCE WEIGHT FOR EACH M. B. SPECIES +C XINP = CHARACTER ARRAY FOR READING IN INFORMATION FROM DATA SETS. +C +C ********************************************************************* +C * SET INITIAL VALUES AND READ INITIAL COMMENTS FROM INPUT DATA SET * +C ********************************************************************* +C + + INTEGER NINAC,NACTIVE,NSDEAD,NOTHGS,IDOPHOT,I,NMBGAS,NM,JGAS + INTEGER MB,MBP,INACT1,JGAS1,J,IORD,NCOF,JORD,NDUM,NK,NAR,NK1 + INTEGER JPR,JNUM,ITHIRDB,NM2,NR,NN,JGAS2,JGAS3,NA,N,NS2 + + REAL*8 C1,CSTRAT,CTROPL,CTROPS,CURBAN,QTHERMG + + ! ININT used to be defined w/in "comode.h", but it is only ever used + ! w/in "readchem.f". Declare here as a local variable. (bmy, 7/16/03) + INTEGER :: ININT(10) + + !================================================================= + ! READCHEM begins here! + !================================================================= + NINAC = 0 + NACTIVE = 0 + NSDEAD = 0 + NOTHGS = 0 + NPHOTALL = 0 + IDOPHOT = 0 +C + NAMEGAS(0) = ' ' +C + ! Initialize flag for N2O5 hydrolysis rxn (bmy, 8/7/03) + NKN2O5 = 0 + + ! Initialize flag for HO2 hydrolysis rxn (jaegle, 02/26/09) + NKHO2 = 0 + + DO 44 I = 1, NMDEAD + NAMD(I) = ' ' + 44 CONTINUE +C + DO 46 I = 1, IGAS + NAMEGAS(I) = ' ' + WTGAS( I) = 0.d0 + QBKGAS( I) = 0.d0 + 46 CONTINUE +C + DO 47 I = 1, MXGSAER + CPREV( I) = 0.d0 + CMODEL(I) = 0.d0 + 47 CONTINUE +C + DO 48 I = 1, MAXGL4 + NKSURF(I) = 0 + NCOATG(I) = 0 + 48 CONTINUE +C + DO 49 I = 1, IPHOT + DEFPRAT(I,:) = 0.d0 + 49 CONTINUE +C + READ(KGLC,21) HEADING + !WRITE(6,21) HEADING + 13 READ(KGLC,21) HEADING + IF (HEADING.NE.'BEGIN') GOTO 13 + 21 FORMAT(A76) +C +C ********************************************************************* +C READ IN MASS BALANCE GROUPS USED +C ********************************************************************* +C + NMBGAS = 9 + READ(KGLC,59) (RINP(I), I = 1, NMBGAS) + READ(KGLC,61) (SINP(I), I = 1, NMBGAS) +C + DO 36 I = 1, NMBGAS + MBTRACE(I) = 0 + IF (SINP(I).EQ.'A') THEN + DO 34 NM = 1, NMASBAL + IF((NAMEMB(NM).EQ.'SULFUR ATOMS' .AND.RINP(I).EQ.'SUL').OR. + 1 (NAMEMB(NM).EQ.'NITROGEN NO3' .AND.RINP(I).EQ.'NO3').OR. + 2 (NAMEMB(NM).EQ.'NITROGEN NH4' .AND.RINP(I).EQ.'NH4').OR. + 3 (NAMEMB(NM).EQ.'CARBON ATOMS' .AND.RINP(I).EQ.'CAR').OR. + 4 (NAMEMB(NM).EQ.'CHLORINE ATOMS'.AND.RINP(I).EQ.'CHL').OR. + 5 (NAMEMB(NM).EQ.'BROMINE ATOMS' .AND.RINP(I).EQ.'BRO').OR. + 6 (NAMEMB(NM).EQ.'FLOURINE ATOMS'.AND.RINP(I).EQ.'FLO').OR. + 7 (NAMEMB(NM).EQ.'HYDROGEN ATOMS'.AND.RINP(I).EQ.'HYD').OR. + 8 (NAMEMB(NM).EQ.'OXYGEN ATOMS' .AND.RINP(I).EQ.'OXY'))THEN + MBTRACE(I) = NM + GOTO 36 + ENDIF + 34 CONTINUE + WRITE(6,33) RINP(I) + CALL GEOS_CHEM_STOP + ENDIF +C + 36 CONTINUE +C + 59 FORMAT(20X,A3,8(1X,A3)) + 61 FORMAT(21X,A1,8(3X,A1)) + 33 FORMAT('READCHEM: MASS BALANCE GROUP ',A14,' NOT SET') +C +C ********************************************************************* +C * READ IN THE SPECIES AND OTHER DATA FOR THIS RUN FROM INPUT DATA * +C ********************************************************************* +C +C ITEMS IN THE FIRST READ STATEMENT +C --------------------------------- +C +C A/I/D +C D = SPECIES IS DEAD AND NOT USED +C I = INACTIVE BUT USED (THESE SPECIES MUST ALSO BE INITIALIZED) +C A = SPECIES USED WHEN IFURBAN, IFTROP, OR IFSTRAT > 0 +C (URBAN, TROPSOSPHERIC AND STRATOSPHERIC SETS) +C U = SPECIES USED WHEN IFURBAN > 0 +C S = SPECIES USED WHEN IFSTRAT > 0 +C T = SPECIES USED WHEN IFTROP > 0 +C R = SPECIES USED WHEN IFURBAN OR IFTROP > 0 +C H = SPECIES USED WHEN IFTROP OR IFSTRAT > 0 +C SPEC = NAME OF THE SPECIES, +C AB TELLS WHETHER SPECIES ABSORBS RADIATION (THE SPECIES +C DOES NOT NECESSARILY PHOTOLYZE) +C MW = ATOMIC MASS IN AMU; +C IFSTRAT = 1: SOLVE STRATOSPHERIC CHEMISTRY +C IFTROP = 1: SOLVE FREE TROPOSPHERIC CHEMISTRY +C IFURBAN = 1: SOLVE URBAN CHEMISTRY +C INITCONC = DEF'T BACKGROUND CONC. AT LOWEST LEVEL (VOL MIXING RATIO); +C CSTRAT = DEFAULT VOL MIX RATIO (FRACTION) IN STRATOSPHERE (25 KM) +C CTROPL = DEFAULT VOL MIX RATIO (FRACTION) IN FREE TROP OVER LAND (0 KM) +C CTROPS = DEFAULT VOL MIX RATIO (FRACTION) IN FREE TROP OVER SEA (0 KM) +C CURBAN = DEFAULT VOL MIX RATIO (FRACTION) IN URBAN REGIONS (0 KM) +C +C ********************************************************************* +C ******************** READ IN SPECIES INFORMATION ******************** +C ********************************************************************* +C +C FORMAT OF ITEMS IN THE SPECIES-LIST READ STATEMENT +C +C A/I/D SPEC AB MW CSTRAT CTROPL CTROPS CURBAN +C A1,1X, A14,A2,1X,F6.0,E9.2, E9.2, E9.2 E9.2 +C +C S NO3 NH4 C CL BR F H O +C 20X, I2,2X,I2,2X,I2,2X,I2,2X,I2,2X,I2,2X,I2,2X,I2,2X,I2 +C + + ! Read 1st line of species list + 10 READ(KGLC,11) (XINP(I), I=1,3),C1,CSTRAT,CTROPL,CTROPS,CURBAN + 11 FORMAT(A1,1X,A14,A2,1X,0PF6.2,4(1PE10.3)) + + ! Test for "END" here (bmy, 4/7/03) + IF (XINP(2).EQ.'END') GOTO 15 + + ! Read 2nd line of species list + READ(KGLC,14) (ININT(I),I = 1, NMBGAS) + 14 FORMAT(20X,I2,8(2X,I2)) +C +C ********************************************************************* +C * COUNT ACTIVE, INACTIVE, AND DEAD SPECIES. ALSO, SET UP ARRAYS * +C * FOR OTHER INFORMATION. * +C ********************************************************************* + + IF (XINP(2).EQ.'END') GOTO 15 +C + IF (XINP(1).EQ.'U'.OR.XINP(1).EQ.'T'.OR.XINP(1).EQ.'S'.OR. + 1 XINP(1).EQ.'R'.OR.XINP(1).EQ.'H') THEN + IF ((XINP(1).EQ.'U'.AND.IFURBAN.EQ.0).OR. + 1 (XINP(1).EQ.'T'.AND.IFTROP .EQ.0).OR. + 2 (XINP(1).EQ.'S'.AND.IFSTRAT.EQ.0).OR. + 3 (XINP(1).EQ.'R'.AND.IFURBAN.EQ.0.AND.IFTROP.EQ.0).OR. + 4 (XINP(1).EQ.'H'.AND.IFSTRAT.EQ.0.AND.IFTROP.EQ.0)) THEN + XINP(1) = 'D' + ELSE + XINP(1) = 'A' + ENDIF + ENDIF +C + IF (XINP(1).EQ.'D') THEN + NSDEAD = NSDEAD + 1 + NAMD(NSDEAD) = XINP(2) + GOTO 10 + ELSEIF (XINP(1).EQ.'I') THEN + NINAC = NINAC + 1 + JGAS = IGAS - NINAC + 1 + ELSEIF (XINP(1).EQ.'A') THEN + NACTIVE = NACTIVE + 1 + JGAS = NACTIVE +C + DO 41 I = 1, NMBGAS + MB = MBTRACE(I) + IF (MB.GT.0.AND.ININT(I).GT.0) THEN + MBCOMP(MB,MB1) = MBCOMP(MB,MB1) + 1 + MBP = MBCOMP(MB,MB1) + JMBCOMP(MB,MBP,MB1) = NACTIVE + WTMB(MB,NACTIVE,MB1) = ININT(I) + ENDIF + 41 CONTINUE + ELSE + WRITE(6,19) XINP(2), XINP(1) + CALL GEOS_CHEM_STOP + ENDIF +C + NAMEGAS(JGAS) = XINP(2) + WTGAS( JGAS) = C1 +C + IF (IFSTRAT.EQ.1.AND.IFTROP.EQ.0.AND.IFURBAN.EQ.0) THEN + QBKGAS( JGAS) = CSTRAT + ELSEIF (IFSTRAT.EQ.0.AND.IFTROP.EQ.1.AND.IFURBAN.EQ.0) THEN + QBKGAS( JGAS) = CTROPL + ELSEIF (IFSTRAT.EQ.0.AND.IFTROP.EQ.0.AND.IFURBAN.EQ.1) THEN + QBKGAS( JGAS) = CURBAN + ELSE + QBKGAS( JGAS) = CTROPL + ENDIF +C + GOTO 10 +C +C ********************************************************************* +C * SET NSPEC AS NUMBER OF ACTIVE SPECIES - 1 SINCE JUST INCREASED * +C * NACTIVE BEFORE THE 'END' STATEMENT. ALSO, CHECK SOME DIMENSIONS. * +C ********************************************************************* +C + 15 CONTINUE + NGAS = NACTIVE + NTSPECGAS = NGAS + NINAC + + !================================================================= + ! Chemical prod-loss diagnostic (bdf, bmy, 4/18/03) + !================================================================= + IF ( LFAMILY ) THEN + + ! Find species and rxns for ND65 diagnostic families + CALL SETJFAM( NACTIVE, NINAC ) + + ! Reset quantities after SETJFAM + NSPEC(NCS) = NACTIVE - 1 + NGAS = NSPEC(NCS) + NTSPECGAS = NGAS + NINAC + NTSPEC(NCS) = NGAS + NINAC + ENDIF +C + IF (NTSPECGAS.GT.IGAS .OR. NSDEAD.GT. NMDEAD) THEN + WRITE(6,18) IGAS, NTSPECGAS, NMDEAD, NSDEAD + CALL GEOS_CHEM_STOP + ENDIF +C + 18 FORMAT('READCHEM: ONE OF THE DIMENSIONS BELOW IS TOO SMALL:',/, + 1 'DIMENSION: IGAS = ',I3,' VARIABLE: NTSPECGS = ',I3,/, + 2 'DIMENSION: NMDEAD = ',I3,' VARIABLE: NSDEAD = ',I3) +C +C ********************************************************************* +C * RE-ARRANGE INACTIVE GAS ARRAYS SO THAT INFORMATION OF INACTIVE * +C * SPECIES APPEARS IMMEDIATELY AFTER INFORMATION OF ACTIVE SPECIES * +C ********************************************************************* +C + + IF (NINAC.GT.0) THEN + INACT1 = IGAS - NINAC + DO 26 N = 1, NINAC + JGAS = NGAS + N + JGAS1 = INACT1 + N + NAMEGAS(JGAS) = NAMEGAS(JGAS1) + QBKGAS( JGAS) = QBKGAS( JGAS1) + WTGAS( JGAS) = WTGAS( JGAS1) + 26 CONTINUE + END IF +C +C ********************************************************************* +C * PRINT SPECIES INFORMATION IF IOSPEC = 1 + PRINT MASS BALANCE INFO * +C ********************************************************************* +C + IF (IOSPEC.EQ.1) THEN + + ! Write species header + WRITE( IO93, '(/,a)' ) REPEAT( '=', 79 ) + WRITE( IO93, 23 ) + WRITE( IO93, '(a,/)' ) REPEAT( '=', 79 ) + WRITE( IO93, 22 ) + + ! Write species to "smv2.log" + DO 25 N = 1, NGAS + WRITE(IO93,24) N, NAMEGAS(N), WTGAS( N), QBKGAS(N) + 25 CONTINUE + IF (NINAC.GT.0) WRITE(IO93,28)(NAMEGAS(NGAS+N),N=1,NINAC) + IF (NSDEAD.GT.0) WRITE(IO93,31)(NAMD(N),N=1,NSDEAD) + END IF +C + WRITE(6,*) + DO 77 I = 1, NMASBAL + IF (MBCOMP(I,MB1).GT.0) THEN + WRITE(6,98) NAMEMB(I) + WRITE(6,99)(WTMB( I,JMBCOMP(I,J,MB1),MB1), + 1 NAMEGAS(JMBCOMP(I,J,MB1)), J = 1, MBCOMP(I,MB1)) + ENDIF + 77 CONTINUE +C + 19 FORMAT('SPECIES ACTIVITY IS UNDEFINED ',A14,' TYPE = ',A2 ) + 23 FORMAT('SPECIES FOR THIS RUN. PHYSICAL CONSTS AND BOUNDARY', + 1 ' CONDITIONS ALSO GIVEN.') + 22 FORMAT( 'NBR', 1X, 'NAME', 12X, 'MW', 1X, 'BKGAS(VMRAT)' ) + 24 FORMAT(I3,1X, A14,F7.2,1PE9.2) + 28 FORMAT(/'INACTIVE SPECIES FOR THIS RUN ARE:'//4(1X,A14)) + 31 FORMAT(/'THE DEAD SPECIES FOR THIS RUN ARE:'//4(1X,A14)) + 98 FORMAT('WEIGHTS AND SPECIES FOR MASS BALANCE EQUATION # ',A14) + 99 FORMAT(4(0PF5.1,1X,A14)) +C +C ********************************************************************* +C * SEARCH FOR SPECIFIC SPECIES NUMBERS USED IN OTHER SUBROUTINES * +C ********************************************************************* +C + ! Initialize for safety's sake (bmy, 7/7/03) + IOXYGEN = 0 + IH2O = 0 + ICH4 = 0 + ILISOPOH =0 + + ! Locate positions of O2, H2O, CH4, LISOPOH in CSPEC array + DO I = 1, NTSPECGAS + SELECT CASE ( TRIM( NAMEGAS(I) ) ) + CASE( 'O2' ) + IOXYGEN = I + CASE( 'H2O' ) + IH2O = I + CASE( 'CH4' ) + ICH4 = I + CASE( 'LISOPOH' ) + ILISOPOH = I + CASE DEFAULT + ! Nothing + END SELECT + ENDDO +C +C ********************************************************************* +C ***************** READ IN REACTION RATES *********************** +C ********************************************************************* +C +C HERE, WE CAN HAVE 3 REACTANTS (EACH WITH COEFFICIENT OF 1) AND 12 +C PRODUCTS [EACH WITH ANY REAL COEFFICIENT]. +C FOR A 3-BODY M REACTION, PLACE AN M IN THE THIRD REACTANT POSITION +C [NO [+] BEFORE IT] +C FOR A 3-BODY OTHER SPECIES REACTION, PLACE THE SPECIES NAME IN THE THIRD +C REACTANT POSITION [NO [+] BEFORE IT] +C FOR A 3RD REACTANT, PLACE THE SPECIES NAME IN THE THIRD REACTANT POSITION +C WITH A PLUS BEFORE IT. +C FOR A REACTANT NOT INCLUDED IN THE REACTION RATE [I.E.02] PLACE THE +C SPECIES NAME IN THE FOURTH REACTANT POSITION [NO [+] +C BEFORE IT]. THE SPECIES MAY HAVE A COEFFICIENT PRECEDING IT. +C A PRODUCT MAY EITHER BE LISTED TWICE [OR MORE TIMES] OR +C HAVE A COEFFICIENT [I.E. 2 OR 3, 0.34] IMMEDIATELY BEFORE IT. +C N COLUMN: NUMBER OF RATE COEFFICIENT LINES FOLLOWING TOP LINE +C P COLUMN: +C P = REACTION IS PRESSURE DEPENDENT 3-BODY REACTION. +C THE FIRST COEFFICIENT IS A 3-BODY COEF. THE SECOND IS 2-BODY. +C S = IDENTIFIES A ONE-BODY SURFACE REACTION +C E = IDENTIFIES REVERSE EQUILIBRIUM REACTION +C V = IDENTIFIES CH3SCH3 + OH --> CH3S(OH)CH3 +C W = IDENTIFIES O(1D) + N2 OR O2 +C X = IDENTIFIES OH + HNO3 +C Y = IDENTIFIES OH + CO +C Z = IDENTIFIES HO2 + HO2 +C G = IDENTIFIES DMS + OH + O2 +C K = IDENTIFIES WETDEP or HYDROLYSIS REACTIONS +C +C Fc COLUMN = VALUE OF Fc FOR THREE-BODY RATE REACTIONS (SEE REF 9, P.1145) +C Fc(T) = Fc CALCULATED AS EXP(-T(K)/Fc(T)) +C +C REACTION RATES HAVE THE FORM K = A * (300 / T)**B * EXP(C / T) +C +C ********************************************************************* +C * READ PRELIMINARY COMMENTS * +C ********************************************************************* +C +C ----- REACTION RATE FORMAT ----- +C +C A/D ORD AR BR CR N P Fc FcT COM X +Y +Z IV =aA +bB +cC +dD +... +C +C A/D +C D = REACTION IS DEAD. SKIP THIS REACTION. +C A = REACTION ACTIVE AND INCLUDED IN ALL CHEMISTRY SETS +C (URBAN, TROPSOSPHERIC AND STRATOSPHERIC SETS) +C U = REACTION IN URBAN CHEMISTRY SET +C S = REACTION IN STRATOSPHERIC CHEMISTRY SET +C T = REACTION IN TROPOSPHERIC CHEMISTRY SET +C R = REACTION IN TROPOSPHERIC AND URBAN CHEMISTRY SETS +C H = REACTION IN TROPOSPHERIC AND STRATOSPHERIC CHEMISTRY SETS +C ORD = ORDINAL NUMBER OF REACTION +C AR,BR,CR = RATE COEFFICIENTS: K = AR * (300/T) * BR * EXP( CR / T) +C AR = DEFAULT PHOTORATE (S-1) FOR PHOTOPROCESSES +C NCOF = DESCRIBED IN 'N COLUMN' ABOVE +C P = DESCRIBED IN 'P COLUMN' ABOVE +C FCVT = CHARACTERIZES FALLOFF CURVE IN PRESSURE-DEPENDENT REACTION +C FCT1T,2T = EXPONENTS GIVING TEMPERATURE DEPENDENCE OF FCVT +C FCVT = EXP(-T/FCT1) OR +C FCVT = EXP(-T/FCT1) + EXP(-FCT2/T) +C COM = A9 AT THE END IS CURRENTLY FOR COMMENTS. +C X,Y,Z = REACTANTS +C Z = REACTANT OR 3RD BODY 'M' OR OTHER THIRD BODY +C I = COEFFICIENT (INTEGER) FOR V +C V = REACT NOT INCLUDED IN REACT. RATE, BUT WHICH IS LOST IN REACTION. +C a,b,c,d. = COEFFICIENTS FOR PRODUCTS (1,2,3,0.45,1.32, ETC (>=0.)) +C A,B,C,D.. = PRODUCTS +C +C ********************************************************************* +C * READ REACTIONS * +C ********************************************************************* +C + 102 READ(KGLC,21) HEADING + IF (HEADING.NE.'BEGIN') GOTO 102 +C + 310 READ(KGLC,330) DINP,IORD,ARRT(1),BRRT(1),KCRRT(1),NCOF,SPECL(1), + 1 FCVT(1),FCT1T(1),FCT2T(1),COMMENT + + IF (NCOF+1.GT.MXCOF) THEN + WRITE(6,155) NCOF+1, MXCOF, IORD + CALL GEOS_CHEM_STOP + ENDIF +C + DO 350 I = 2, NCOF + 1 + READ(KGLC,330) JST,JORD,ARRT(I),BRRT(I),KCRRT(I),NDUM,SPECL(I), + 1 FCVT(I),FCT1T(I),FCT2T(I),COMMENT + 350 CONTINUE +C + ! Now read 20 entries instead of 16 (bdf, bmy, 4/1/03) + READ(KGLC,332) (RINP(I),PINP(I),XINP(I),I=1,20) +C + 155 FORMAT('READCHEM: NCOF + 1 > MXCOF IN GLOBCHEM.DAT',3I4) + 330 FORMAT(A1,1X,I4,1X,ES8.2,1X,ES8.1,1X,I6,1X,I1,1X,A2,F6.2,1X, + 1 2(F6.0,1X),A20) + + ! Increase format string to 14 products (bdf, 4/1/03) + 332 FORMAT(4(A1,0PF5.3,A14)/4(A1,0PF5.3,A14)/ + 1 4(A1,0PF5.3,A14)/4(A1,0PF5.3,A14)/4(A1,0PF5.3,A14)) +C + IF (DINP.NE.'A'.AND.DINP.NE.'U'.AND.DINP.NE.'T'.AND. + 1 DINP.NE.'S'.AND.DINP.NE.'R'.AND.DINP.NE.'H') DINP = 'D' +C + IF ((DINP.EQ.'U'.AND.IFURBAN.EQ.0).OR. + 1 (DINP.EQ.'T'.AND.IFTROP .EQ.0).OR. + 2 (DINP.EQ.'S'.AND.IFSTRAT.EQ.0).OR. + 3 (DINP.EQ.'R'.AND.IFURBAN.EQ.0.AND.IFTROP.EQ.0).OR. + 4 (DINP.EQ.'H'.AND.IFSTRAT.EQ.0.AND.IFTROP.EQ.0)) DINP = 'D' +C + IF (XINP(1).EQ.'END KINETIC') THEN +C + DO 323 NCS = 1, NCSGAS + NRATES(NCS) = NTRATES(NCS) + 323 CONTINUE +C + IDOPHOT = 1 + GOTO 102 + ELSEIF (XINP(1).EQ.'END PHOTOLYSIS') THEN + GOTO 660 + ELSEIF (DINP.EQ.'D') THEN + GOTO 310 + ENDIF +C +C ********************************************************************* +C * UPDATE REACTION NUMBER FOR REACTIONS THAT ARE USED * +C ********************************************************************* +C NRATCUR = CURRENT REACTION RATE NUMBER FOR A SET OF RATE COEFFICIENTS +C NTRATES = CURRENT RATE COEFFICIENT NUMBER +C NALLRAT = COUNTS THE NUMBER OF ACTUAL REACTIONS +C SKIP URBAN ('A', 'U', OR 'R') REACTIONS IF NOT USED +C SKIP TROPOSPHERIC ('A', 'T', 'R', OR 'H') REACTIONS IF NOT USED +C SKIP STRATOSPHERIC ('A', 'S', OR 'H') REACTIONS IF NOT USED +C + DO 325 NCS = 1, NCSGAS +C + NOUSE(NCS) = 1 + IF (NCS.EQ.NCSALL .AND.(DINP.EQ.'A'.OR.DINP.EQ.'U'.OR. + 1 DINP.EQ.'R'.OR.DINP.EQ.'S'.OR.DINP.EQ.'T'.OR. + 2 DINP.EQ.'H')) NOUSE(NCS) = 0 + IF (NCS.EQ.NCSTRST .AND.(DINP.EQ.'A'.OR.DINP.EQ.'R'.OR. + 1 DINP.EQ.'T'.OR.DINP.EQ.'S'.OR.DINP.EQ.'H')) + 2 NOUSE(NCS) = 0 + IF (NCS.EQ.NCSURBAN.AND.(DINP.EQ.'A'.OR.DINP.EQ.'U'.OR. + 1 DINP.EQ.'R')) NOUSE(NCS) = 0 + IF (NCS.EQ.NCSTROP .AND.(DINP.EQ.'A'.OR.DINP.EQ.'T'.OR. + 1 DINP.EQ.'R'.OR.DINP.EQ.'H')) NOUSE(NCS) = 0 + IF (NCS.EQ.NCSSTRAT.AND.(DINP.EQ.'A'.OR.DINP.EQ.'S'.OR. + 1 DINP.EQ.'H')) NOUSE(NCS) = 0 +C + IF (NOUSE(NCS).EQ.0) THEN + NK = NTRATES(NCS) + 1 + NRATCUR(NCS) = NK + NALLRAT(NCS) = NALLRAT(NCS) + 1 + NAR = NALLRAT(NCS) + NCEQUAT(NAR,NCS) = NK +C + DO 320 I = 1, NCOF + 1 + NTRATES(NCS) = NTRATES( NCS) + 1 + NK1 = NTRATES( NCS) + IRORD( NK1,NCS) = IORD + ARR( NK1,NCS) = ARRT(I) + BRR( NK1,NCS) = BRRT(I) + KCRR( NK1,NCS) = KCRRT(I) + FCV( NK1,NCS) = FCVT( I) + FCTEMP1(NK1,NCS) = FCT1T(I) + FCTEMP2(NK1,NCS) = FCT2T(I) + 320 CONTINUE + ENDIF + 325 CONTINUE + +C ********************************************************************* +C SET UP A DEFAULT PHOTORATE (SEC-1), STORE ORDINAL NUMBER +C ********************************************************************* +C + IF (IDOPHOT.EQ.1) THEN + NPHOTALL = NPHOTALL + 1 + ! record photalysis numbers for harvard-geos code (bdf, 4/18/03) + NPHOT = NPHOTALL + !DEFPRAT(NPHOTALL) = ARRT(1) + + DO 640 NCS = 1, NCSGAS + IF (NOUSE(NCS).EQ.0) THEN + NK = NRATCUR(NCS) + DEFPRAT(NK,NCS) = ARRT(1) + JPHOTRAT(NCS) = JPHOTRAT(NCS) + 1 + JPR = JPHOTRAT(NCS) + NKPHOTRAT(JPR,NCS) = NK + NPPHOTRAT(JPR,NCS) = NPHOTALL + JPHOTNK( NK, NCS) = JPR + ENDIF + 640 CONTINUE + ENDIF +C +C ********************************************************************* +C * CHECK WHETHER EACH SPECIES SPOT IN INPUT REACTION SET IS ACTIVE, * +C * INACTIVE, BLANK, DEAD, OR 'M'. STOP IF THE SPECIES IS NONE * +C * JNUM = -J = NON 'M' THIRD BODY IN PRESSURE-DEPENDENT REACTION. * +C ********************************************************************* +C + DO 360 I = 1, NPRODHI + IF (XINP(I).NE.' ') THEN +C + IF (I.LE.NMREAC.AND.PINP(I).NE.0.) THEN + WRITE(6,450) IORD + CALL GEOS_CHEM_STOP + ENDIF +C + JNUM = 0 + IF (I.EQ.NMREAC.AND.RINP(3).EQ.' ') THEN + IF (XINP(I).EQ.'M' ) JNUM = -9999 + IF (XINP(I).EQ.'O2') JNUM = -9998 + IF (XINP(I).EQ.'N2') JNUM = -9997 + IF (JNUM.LT.0) GOTO 380 + ENDIF + + DO 370 J = 1, NTSPECGAS + IF(XINP(I).EQ.NAMEGAS(J)) THEN + IF (I.EQ.NMREAC.AND.RINP(3).EQ.' ') THEN + JNUM = -J + ELSE + JNUM = J + ENDIF + GOTO 380 + ENDIF + 370 CONTINUE +C + IF (I.GT.NMREAC) THEN + DO 390 J = 1, NSDEAD + IF (XINP(I).EQ.NAMD(J)) GOTO 360 + 390 CONTINUE + ENDIF +C + WRITE(6,400) IORD, XINP(I) + CALL GEOS_CHEM_STOP +C + 380 DO 410 NCS = 1, NCSGAS + IF (NOUSE(NCS).EQ.0) THEN + NK = NRATCUR(NCS) + IRM(I,NK,NCS) = JNUM + NPRODUC(NK,NCS) = I + IF (PINP(I).EQ.0.) THEN + FKOEF(I,NK,NCS) = 1.0d0 + ELSE + FKOEF(I,NK,NCS) = PINP(I) + ENDIF + ENDIF + 410 CONTINUE +C + IF (IDOPHOT.EQ.1) NAMEPHOT(I,NPHOTALL) = XINP(I) + ENDIF + 360 CONTINUE +C + DO 415 NCS = 1, NCSGAS + IF (NOUSE(NCS).EQ.0) THEN + NK = NRATCUR(NCS) + IF (IRM(1,NK,NCS).EQ.0.OR.(IRM(3,NK,NCS).GT.0.AND. + 1 IRM(2,NK,NCS).EQ.0)) THEN + WRITE(6,430) IORD + CALL GEOS_CHEM_STOP + ENDIF + ENDIF + 415 CONTINUE +C +C ********************************************************************* +C * PLACE SPECIAL-RATE INFORMATION INTO ARRAYS * +C ********************************************************************* +C +C NMAIR = # REACTIONS WHERE THE SPECIES IN THE THIRD POSITION +C IS 'M' = 'O2 + N2': IRM(3,NK) = -9999 +C NMO2 = # REACTIONS WHERE THE SPECIES IN THE THIRD POSITION +C IS O2: IRM(3,NK) = -9998 +C NMN2 = # REACTIONS WHERE THE SPECIES IN THE THIRD POSITION +C IS N2: IRM(3,NK) = -9997 +C NM3BOD = # REACTIONS WHERE THE SPECIES IN THE THIRD POSITION +C IS ANY OTHER SPECIES: IRM(3,NK) = -SPECIES NUMBER +C NNEQ = # THERMALLY DISSOCIATING EQUILIBRIUM REACTIONS. PREVIOUS +C EQUATION MUST BE PRESSURE-DEPENDENT. (SPECIAL = 'E') +C THUS: REQUIRES 3 REACTIONS TOTAL (2 FOR PRESS. DEP, 1 EQ.) +C NPRESM = # PRESSURE DEPENDENT 3-BODY REACTIONS (SPECIAL = 'P') +C + +! bdf smv2 count number of emission and drydep reactions. Used in calcrate +! to put emissions into the chemistry, and drydep out of chemistry. + + + DO NCS=1,NCSGAS + IF (NOUSE(NCS) .EQ. 0 ) THEN + NK = NRATCUR(NCS) + IF (XINP(1).EQ.'EMISSION') THEN + NEMIS(NCS) = NEMIS(NCS) + 1 + IF (NEMIS(NCS) .GT. MAXGL3) THEN + WRITE(*,*) 'ERROR NEMIS Greater then MAXGL3', + x ' NEMIS(NCS) = ',NEMIS(NCS), 'MAXGL3 = ',MAXGL3 + WRITE( 6, '(a)' ) 'STOP 124' + CALL GEOS_CHEM_STOP + ENDIF + NKEMIS(NEMIS(NCS),NCS) = NK + ENDIF + ENDIF +C +C NDRYDEP = number of dry deposition reactions read in +C NKDRY = reaction numbers of dry deposition reactions + IF (NOUSE(NCS) .EQ. 0) THEN + NK = NRATCUR(NCS) + IF (XINP(NPRODLO).EQ.'DRYDEP') THEN + NDRYDEP(NCS) = NDRYDEP(NCS) + 1 + IF (NDRYDEP(NCS) .GT. MAXDEP) THEN + WRITE(*,*) 'ERROR NDRYDEP Greater then MAXDEP', + x ' NDRYDEP(NCS)=',NDRYDEP(NCS),'MAXDEP=',MAXDEP + WRITE( 6, '(a)' ) 'STOP 125' + CALL GEOS_CHEM_STOP + ENDIF + NKDRY(NDRYDEP(NCS),NCS) = NK + ENDIF + ENDIF + +! bdf smv2 use Q to flag O3 photolysis, code is not confused by 'A''s + IF (NOUSE(NCS) .EQ. 0) THEN + NK = NRATCUR(NCS) + IF (SPECL(1).EQ.'Q') NKO3PHOT(NCS)=NK !Flag O3 photolysis + IF (SPECL(1).EQ.'T') NKHNO4(NCS) =NK !Flag HNO4 photolysis (gcc) + IF (SPECL(1).EQ.'I') NKHOROI(NCS) = NK !Flag CH2O-producing branch in EP photolysis + IF (SPECL(1).EQ.'J') NKHOROJ(NCS) = NK !Flag GLYC-producing branch in EP photolysis + + ENDIF + ENDDO + + IF (IDOPHOT.EQ.0) THEN + IF ((SPECL(1).EQ.'V'.AND.NCOF.NE.1).OR. + 1 (SPECL(1).EQ.'W'.AND.NCOF.NE.1).OR. + 2 (SPECL(1).EQ.'X'.AND.NCOF.NE.2).OR. + 3 (SPECL(1).EQ.'Y'.AND.NCOF.NE.0).OR. + 4 (SPECL(1).EQ.'Z'.AND.NCOF.NE.1).OR. + 5 (SPECL(1).EQ.'P'.AND.NCOF.NE.1).OR. + 6 (SPECL(1).EQ.'E'.AND.NCOF.NE.0).OR. + 7 (SPECL(1).EQ.'S'.AND.NCOF.NE.0)) THEN + WRITE(6,440) IORD, SPECL(1), NCOF + CALL GEOS_CHEM_STOP + ENDIF +C + DO 420 NCS = 1, NCSGAS + IF (NOUSE(NCS).EQ.0) THEN + NK = NRATCUR(NCS) +C + ITHIRDB = IRM(3,NK,NCS) +C + IF (ITHIRDB.EQ.-9999) THEN + NMAIR(NCS) = NMAIR(NCS) + 1 + NM2 = NMAIR(NCS) + NREACAIR(NM2,NCS) = NK + ELSEIF (ITHIRDB.EQ.-9998) THEN + NMO2(NCS) = NMO2(NCS) + 1 + NM2 = NMO2(NCS) + NREACO2(NM2,NCS) = NK + ELSEIF (ITHIRDB.EQ.-9997) THEN + NMN2(NCS) = NMN2(NCS) + 1 + NM2 = NMN2(NCS) + NREACN2(NM2,NCS) = NK + ELSEIF (ITHIRDB.LT.0) THEN + NM3BOD(NCS) = NM3BOD(NCS) + 1 + NM2 = NM3BOD(NCS) + NREAC3B(NM2,NCS) = NK + LGAS3BOD(NM2,NCS) = -ITHIRDB + ENDIF +C + IF (SPECL(1).EQ.'P') THEN + NPRESM(NCS) = NPRESM(NCS) + 1 + NR = NPRESM(NCS) + NREACPM(NR,NCS) = NK + ELSEIF (SPECL(1).EQ.'E') THEN + NNEQ(NCS) = NNEQ(NCS) + 1 + NN = NNEQ(NCS) + NREACEQ(NN,NCS) = NK +C +C EQUILIBRIUM REACTIONS USE THE PREVIOUS REACTION AS PART OF THE +C RATE CALCULATION (SEE CALCRATE.F). THE PREVIOUS REACTION MAY BE +C PRESSURE DEPENDENT. +C + NREQOTH(NN,NCS) = NCEQUAT(NALLRAT(NCS)-1,NCS) + ENDIF +C +C NKSPECV = SPECIAL REACTION CH3SCH3 + OH = CH3S(OH)CH3 (SPECL = 'V') +C NKSPECW = SPECIAL REACTION O(1D) + O2,N2 (SPECL = 'W') +C NKSPECX = SPECIAL REACTION OH + HNO3 (SPECL = 'X') +C NKSPECY = SPECIAL REACTION OH + CO (SPECL = 'Y') +C NKSPECZ = SPECIAL REACTION HO2 + HO2 (SPECL = 'Z') +C + ! bdf smv2 'V' reaction has a special rate. + ! More than one reaction of this type + IF (SPECL(1).EQ.'V') THEN + NNADDV(NCS) = NNADDV(NCS)+1 + NKSPECV( NNADDV(NCS),NCS ) = NK + ENDIF + + ! Added for DMS+OH+O2 rxn (bdf, bmy, 4/18/03) + IF (SPECL(1).EQ.'G') THEN + NNADDG(NCS) = NNADDG(NCS)+1 + NKSPECG( NNADDG(NCS),NCS ) = NK + ENDIF + + ! add flag for wet dep reaction (bdf, bmy, 4/18/03) + IF (SPECL(1).EQ.'K') THEN + NNADDK(NCS) = NNADDK(NCS) + 1 + NKSPECK( NNADDK(NCS),NCS) = NK + + ! Also denote N2O5 hydrolysis rxn (mje, bmy, 8/7/03) + IF ( XINP(1) == 'N2O5' ) THEN + NKN2O5 = NK + ENDIF + + ! Same for HO2 hydrolysis rxn (jaegle, 02/26/09) + IF ( XINP(1) == 'HO2' ) THEN + NKHO2 = NK + ENDIF + + ENDIF +C + IF (SPECL(1).EQ.'HR') THEN !modification of the rate for HO2+RO2 + NNRO2HO2(NCS) = NNRO2HO2(NCS) + 1 + NKSPECRO2HO2( NNRO2HO2(NCS),NCS) = NK + ENDIF + + IF (SPECL(1).EQ.'D') THEN + NNADDD(NCS) = NNADDD(NCS) + 1 + NKSPECD( NNADDD(NCS),NCS) = NK + ENDIF +C + IF (SPECL(1).EQ.'A') THEN + NNADDA(NCS) = NNADDA(NCS) + 1 + NKSPECA( NNADDA(NCS),NCS) = NK + ENDIF +C + IF (SPECL(1).EQ.'B') THEN + NNADDB(NCS) = NNADDB(NCS) + 1 + NKSPECB( NNADDB(NCS),NCS) = NK + ENDIF +C + IF (SPECL(1).EQ.'C') THEN + NNADDC(NCS) = NNADDC(NCS) + 1 + NKSPECC( NNADDC(NCS),NCS) = NK + ENDIF + + ! F: HOC2H4O ------> HO2 + 2CH2O + IF (SPECL(1).EQ.'F') THEN + NNADDF(NCS) = NNADDF(NCS) + 1 + NKSPECF( NNADDF(NCS),NCS) = NK + ENDIF + + ! H: HOC2H4O --O2--> HO2 + GLYC + IF (SPECL(1).EQ.'H') THEN + NNADDH(NCS) = NNADDH(NCS) + 1 + NKSPECH( NNADDH(NCS),NCS) = NK + ENDIF + + IF (SPECL(1).EQ.'W') THEN + NKSPECW(NCS) = NK + ENDIF + IF (SPECL(1).EQ.'X') THEN + NKSPECX(NCS) = NK + ENDIF + IF (SPECL(1).EQ.'Y') THEN + NKSPECY(NCS) = NK + ENDIF + IF (SPECL(1).EQ.'Z') THEN + NKSPECZ(NCS) = NK + ENDIF +C +C ********************************************************************* +C * SURFACE REACTIONS * +C ********************************************************************* +C ARR(INIT) = REACTION PROBABILITY +C ARR(FINAL) = REACTION PROBABILITY * QTHERMG +C QTHERMG * SQRT(T) = (1/4) * THERMAL VELOCITY OF GAS (CM S-1) +C + IF (SPECL(1).EQ.'S') THEN + NSURFACE(NCS) = NSURFACE(NCS) + 1 + NS2 = NSURFACE(NCS) + JGAS1 = IRM(1,NK,NCS) + JGAS2 = IRM(2,NK,NCS) + JGAS3 = IRM(3,NK,NCS) + QTHERMG = 0.25d0*SQRT(EIGHTDPI*RSTARG/WTGAS(JGAS1)) + ARR(NK,NCS) = ARR(NK,NCS) * QTHERMG + NKSURF(NS2) = NK + NCOATG(NS2) = JGAS2 +C + IF (JGAS3.NE.0) THEN + WRITE(6,470) NK + CALL GEOS_CHEM_STOP + ENDIF + ENDIF +C +C ********************************************************************* +C * SET ARRAYS FOR CALCULATING REACTION RATES EFFICIENTLY * +C ********************************************************************* +C NARR = NUMBER OF REACTIONS OF THE FORM K = A +C NABR = NUMBER OF REACTIONS OF THE FORM K = A * (300 / T)**B +C NACR = NUMBER OF REACTIONS OF THE FORM K = A * EXP(C / T) +C NABC = NUMBER OF REACTIONS OF THE FORM K = A * (300 / T)**B * EXP(C / T) +C NKARR, NKBRR, NKACR, NKABC = REACTION RATE NUMBERS OF EACH +C NARR, NABR, NACR, NABC REACTION +C + + + NK1 = NK - 1 + + DO 425 I = 1, NCOF + 1 + NK1 = NK1 + 1 + IF (KCRR(NK1,NCS).EQ.0) THEN + IF (BRR(NK1,NCS).EQ.0.) THEN + NARR(NCS) = NARR(NCS) + 1 + NA = NARR(NCS) + NKARR(NA,NCS) = NK1 + ELSE + NABR(NCS) = NABR(NCS) + 1 + NA = NABR(NCS) + NKABR(NA,NCS) = NK1 + ENDIF + ELSE + IF (BRR(NK1,NCS).EQ.0.) THEN + NACR(NCS) = NACR(NCS) + 1 + NA = NACR(NCS) + NKACR(NA,NCS) = NK1 + ELSE + NABC(NCS) = NABC(NCS) + 1 + NA = NABC(NCS) + NKABC(NA,NCS) = NK1 + ENDIF + ENDIF + 425 CONTINUE +C + ENDIF +C ENDIF NOUSE(NCS).EQ.0 +C + 420 CONTINUE + ENDIF +C ENDIF IDOPHOT.EQ.0 +C + GOTO 310 +C + 400 FORMAT('INVALID REACT',I4,' W UNRECOGNIZABLE OR DEAD SPEC ',A14, + 1 'ALL REACTANTS MUST BE ACTIVE/INACTIVE. PRODS CAN BE DEAD') + 430 FORMAT('READCHEM:REACT ',I3,' 1ST SPOT EMPTY OR 3RD SPOT FILLED ', + 1 ' BUT 2ND EMPTY') + 440 FORMAT('READCHEM: REACT ',I3,'OR BEFORE: SPECIAL REACTION WITH ', + 1 'DELIMETER ',A2,' HAD INCORRECT # OF REACTIONS ',I5) + 450 FORMAT('READCHEM: ORD# REACT ',I3,' CANT HAVE COEFF > 1') + 470 FORMAT('READCHEM: SURFACE REACTION ',I5,'HAS THREE REACTANTS ') + 510 FORMAT(I3,1X,ES7.1,1X,ES7.1,I6,1X,0PF3.2,1X, + 1 A6,2(A1,A6),14(A1,0PF3.1,A6)) + 520 FORMAT( 'KINETIC REACTIONS FOR ', A,' CHEMISTRY',/, + 1 'RATE CONSTANTS HAVE FORM K = A * (300/T)**B * EXP(C/T).') + 521 FORMAT( 'NMBR A B C Fv REACTION' ) + 525 FORMAT( 'PHOTOPROCESS REACTIONS FOR ', A,' CHEMISTRY' ) + 526 FORMAT( 'NMBR DEFP (S-1) REACTION' ) +C +C ********************************************************************* +C * PRINT OUT REACTION INFORMATION * +C ********************************************************************* +C + 660 IF (IOREAC.EQ.1) THEN + DO 502 NCS = 1, NCSGAS + + ! Write reaction header + WRITE( IO93, '(/,a)' ) REPEAT( '=', 79 ) + WRITE( IO93, 520 ) TRIM( CHEMTYP(NCS) ) + WRITE( IO93, '(a,/)' ) REPEAT( '=', 79 ) + WRITE( IO93, 521 ) + + DO 500 NK = 1, NTRATES(NCS) + + ! Write photo rxn header + IF ( NK .EQ. NRATES(NCS)+1 ) THEN + WRITE( IO93, '(/,a)' ) REPEAT( '=', 79 ) + WRITE( IO93, 525 ) TRIM( CHEMTYP(NCS) ) + WRITE( IO93, '(a,/)' ) REPEAT( '=', 79 ) + WRITE( IO93, 526 ) + ENDIF + + DO 490 I = 1, NPRODHI + RINP(I) = '+' + PINP(I) = FKOEF(I,NK,NCS) + JGAS = IRM(I,NK,NCS) + IF (JGAS.GE.0) XINP(I) = NAMEGAS(JGAS) + IF (JGAS.EQ.-9999) XINP(I) = 'M' + IF (JGAS.EQ.-9998) XINP(I) = 'O2' + IF (JGAS.EQ.-9997) XINP(I) = 'N2' + IF (JGAS.LT.0.AND.JGAS.GT.-NTSPECGAS) XINP(I) = NAMEGAS(-JGAS) + 490 CONTINUE +C + RINP(5) = '=' + WRITE(IO93,510) NK,ARR(NK,NCS),BRR(NK,NCS),KCRR(NK,NCS), + 1 FCV(NK,NCS),XINP(1),'+',XINP(2), + 2 '+',XINP(3),(RINP(I),PINP(I),XINP(I), + 3 I = 5,NPRODUC(NK,NCS)) + 500 CONTINUE + 502 CONTINUE + ENDIF + +C +C ********************************************************************* +C *********************** CHECK SOME DIMENSIONS ********************* +C ********************************************************************* +C + DO 670 NCS = 1, NCSGAS + IF (NTRATES(NCS) .GT. NMTRATE .OR. NPHOTALL .GT. IPHOT .OR. + 1 NTSPECGAS .GT. IGAS .OR. NSDEAD .GT. NMDEAD .OR. + 2 NPRODHI .GT. NMRPROD .OR. + 3 NMAIR(NCS) .GT. MAXGL3 .OR. NMO2(NCS) .GT. MAXGL3 .OR. + 4 NMN2(NCS) .GT. MAXGL2 .OR. NPRESM(NCS).GT. MAXGL2 .OR. + 5 NSURFACE(NCS).GT. MAXGL4 .OR. NM3BOD(NCS).GT. MAXGL3) THEN +C + WRITE(6,680) + 1 NMTRATE,NTRATES(NCS), IPHOT , NPHOTALL, IGAS ,NTSPECGAS, + 2 NMDEAD ,NSDEAD, NMRPROD, NPRODHI, + 3 MAXGL3 ,NMAIR(NCS), MAXGL3 , NMO2(NCS), MAXGL2,NMN2(NCS), + 4 MAXGL2 ,NPRESM(NCS), MAXGL4 , NSURFACE(NCS),MAXGL3,NM3BOD(NCS) + CALL GEOS_CHEM_STOP + ENDIF + 670 CONTINUE +C + 680 FORMAT('ONE OF THE DIMENSIONS BELOW IS TOO SMALL:',/, + 1 'DIMENSION: NMTRATE = ',I4,' VARIABLE: NTRATES = ',I4/ + 2 'DIMENSION: IPHOT = ',I4,' VARIABLE: NPHOTALL = ',I4/ + 3 'DIMENSION: IGAS = ',I4,' VARIABLE: NTSPECGS = ',I4/ + 4 'DIMENSION: NMDEAD = ',I4,' VARIABLE: NSDEAD = ',I4/ + 6 'DIMENSION: NMRPROD = ',I4,' VARIABLE: NPRODHI = ',I4/ + 7 'DIMENSION: MAXGL3 = ',I4,' VARIABLE: NMAIR = ',I4/ + 8 'DIMENSION: MAXGL3 = ',I4,' VARIABLE: NMO2 = ',I4/ + 9 'DIMENSION: MAXGL2 = ',I4,' VARIABLE: NMN2 = ',I4/ + 1 'DIMENSION: MAXGL2 = ',I4,' VARIABLE: NPRESM = ',I4/ + 2 'DIMENSION: MAXGL4 = ',I4,' VARIABLE: NSURFACE = ',I4/ + 3 'DIMENSION: MAXGL3 = ',I4,' VARIABLE: NM3BOD = ',I4) +C +C ********************************************************************* +C ************************** SET KEY PARAMETERS *********************** +C ********************************************************************* +C + DO 702 NCS = 1, NCSGAS + NSPEC(NCS) = NGAS + NTSPEC(NCS) = NTSPECGAS +C + DO 700 JGAS = 1, NTSPECGAS + NAMENCS(JGAS,NCS) = NAMEGAS(JGAS) + QBKCHEM(JGAS,NCS) = QBKGAS( JGAS) + 700 CONTINUE + 702 CONTINUE + +!---smv2-s +! Update (gcc) +C bdf smv2, put this in here for now. +C ********************************************************************* +C **************** READ INFO FOR AEROSOL REACTIONS **************** +C ********************************************************************* + +C astkcf -- sticking coefficient (no unit), order of 0.1 +C xgdfcf -- gas phase diffusion coefficient (cm2/s), order of 0.1 +C iarsfa -- fortran unit number for reading sulfate abundance file +C mwarsl -- aerosol molecular wright (g/mol) [H2SO4=98] +C ruarsl -- density of aerosol (g/cc) +C RH100 -- deliquescence point, relative humidity below which we +C have no wet aerosols +C + OPEN(7,FILE='chemga.dat',FORM='FORMATTED',STATUS='OLD') + READ(7,*) + READ(7,610) ASTKCF + READ(7,*) + READ(7,610) + READ(7,*) + READ(7,620) MWARSL + READ(7,610) RUARSL + READ(7,630) RH100 + READ(7,620) IARSFA + CLOSE(7) + 610 FORMAT(E10.3) + 620 FORMAT(I10) + 630 FORMAT(F10.2) + +C +C ********************************************************************* +C ***** CALL JSPARSE TO SET ARRAYS FOR SOLVING CHEMICAL EQUATIONS ***** +C ********************************************************************* +C + ! Call SETPL to setup ND65 prod/loss diagnostic + ! SETPL must be called before JSPARSE (ljm, bmy, 5/9/03) + IF ( LFAMILY ) CALL SETPL + + ! IFSOLVE = 1 means we are calling the chemistry solver + IF ( IFSOLVE .EQ. 1 ) THEN + + ! Loop over chemistry regimes (for now NCSGAS=NCSURBAN=1) + DO NCS = 1, NCSGAS + + ! Set up sparse matrix stuff + CALL JSPARSE + + !=========================================================== + ! Determine which species are ND65 families and which are + ! not. Do this once (after JSPARSE) & store in the lookup + ! table ITS_NOT_A_ND65_FAMILY. (bmy, 7/9/03) + !=========================================================== + + ! Loop over all species + DO J = 1, ISCHANG(NCS) + + ! Initialize lookup table + ITS_NOT_A_ND65_FAMILY(J) = .TRUE. + + ! Test if species J is a ND65 prodloss family + ! MAPPL is the reordered species index after JSPARSE + DO N = 1, NFAMILIES + IF ( J == MAPPL(IFAM(N),NCS) ) THEN + ITS_NOT_A_ND65_FAMILY(J) = .FALSE. + EXIT + ENDIF + ENDDO + ENDDO + ENDDO + + ELSE + + ! If we are not calling the chemistry solver, then + ! set number of active gas photoprocesses to zero + NPHOTALL = 0 + + ENDIF +C +C ********************************************************************* +C ******************* END OF SUBROUTINE READCHEM ****************** +C ********************************************************************* +C + + RETURN + END SUBROUTINE READCHEM diff --git a/code/reader.f b/code/reader.f new file mode 100644 index 0000000..5acbbfd --- /dev/null +++ b/code/reader.f @@ -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 diff --git a/code/readlai.f b/code/readlai.f new file mode 100644 index 0000000..7b740fb --- /dev/null +++ b/code/readlai.f @@ -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 diff --git a/code/regrid_1x1_mod.f b/code/regrid_1x1_mod.f new file mode 100644 index 0000000..430a327 --- /dev/null +++ b/code/regrid_1x1_mod.f @@ -0,0 +1,2435 @@ +! $Id: regrid_1x1_mod.f,v 1.2 2012/03/01 22:00:26 daven Exp $ + MODULE REGRID_1x1_MOD +! +!****************************************************************************** +! Module REGRID_1x1_MOD does online regridding of data on the GEOS-Chem 1x1 +! grid to 1x1, 2x25, or 4x5 GEOS/GCAP grids. (bdf, bmy, 10/24/05, 11/6/08) +! +! Module Variables: +! ============================================================================ +! (1 ) A1x1 (REAL*8) : Surface areas [m2] of 1x1 GEOS-Chem grid +! (2 ) A_GEN_1x1 (REAL*8) : Surface areas [m2] of 1x1 GENERIC grid +! +! Module Routines: +! ============================================================================ +! (1 ) DO_REGRID_G2G_1x1 : Regrids GENERIC 1x1 to GEOS-Chem 1x1 GRID +! (2 ) DO_REGRID_1x1_R4 : Passes 3D, REAL*4 to DO_THE_REGRIDDING +! (3 ) DO_REGRID_1x1_R4_2D : Passes 2D, REAL*4 to DO_THE_REGRIDDING +! (4 ) DO_REGRID_1x1_R8 : Passes 3D, REAL*8 to DO_THE_REGRIDDING +! (5 ) DO_REGRID_1x1_R8_2D : Passes 2D, REAL*8 to DO_THE_REGRIDDING +! (6 ) DO_THE_REGRIDDING : Driver routine for regridding from 1x1 +! (7 ) DO_THE_REGRIDDING_05x0666 : Driver routines for regridding from +! (8 ) DO_THE_REGRIDDING_05x0666_2 : to 0.5 x 0.667 GEOS-5 nested grid +! (9 ) ITS_CONCENTRATION_DATA : Returns TRUE if it's concentration data +! (10) REGRID_CONC_TO_4x5_GCAP : Regrids conc from GEOS 1x1 -> GCAP 4x5 +! (11) REGRID_MASS_TO_4x5_GCAP : Regrids mass from GEOS 1x1 -> GCAP 4x5 +! (12) REGRID_CONC_TO_4x5 : Regrids conc from GEOS 1x1 -> GEOS 4x5 +! (13) REGRID_MASS_TO_4x5 : Regrids mass from GEOS 1x1 -> GEOS 4x5 +! (14) REGRID_CONC_TO_2x25 : Regrids conc from GEOS 1x1 -> GEOS 2x25 +! (15) REGRID_MASS_TO_2x25 : Regrids mass from GEOS 1x1 -> GEOS 2x25 +! (16) REGRID_CONC_TO_1x125 : Regrids conc from GEOS 1x1 -> GEOS 1x125 +! (17) REGRID_MASS_TO_1x125 : Regrids mass from GEOS 1x1 -> GEOS 1x125 +! (18) INIT_REGRID_1x1 : Initializes all module variables +! (19) CLEANUP_REGRID_1x1 : Deallocates all module variables +! +! GEOS-Chem modules referenced by "regrid_1x1_mod.f" +! ============================================================================ +! (1 ) charpak_mod.f : Module w/ string handling routines +! (2 ) grid_mod.f : Module w/ horizontal grid information +! +! NOTES: +! (1 ) Added DO_REGRID_G2G_1x1 to regrid from GENERIC 1x1 to GEOS 1x1 grid. +! (psk, bmy, 4/18/06) +! (2 ) Added routines REGRID_CONC_TO_1x125 and REGRID_MASS_TO_1x125 to regrid +! 1x1 data to the GEOS-Chem 1x1.25 grid. (bdf, bmy, 8/2/06) +! (3 ) DO_REGRID_G2G_1x1 now takes UNIT via the arg list (bmy, 8/9/06) +! (4 ) Bug fix in REGRID_MASS_TO_4x5 (tw, bmy, 2/20/07) +! (5 ) Bug fix in REGRID_MASS_TO_2x25 (barkley, bmy, 10/17/07) +! (6 ) Added routines for regridding to 0.5 x 0.666 GEOS-5 nested grid +! (yxw, dan, bmy, 11/6/08) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "regrid_1x1_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: CLEANUP_REGRID_1x1 + PUBLIC :: DO_REGRID_1x1 + PUBLIC :: DO_REGRID_G2G_1x1 + PUBLIC :: DO_REGRID_05x0666 + PUBLIC :: DO_REGRID_025x03125 ! (lzh,02/01/2015) + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Arrays + REAL*8, ALLOCATABLE :: A1x1(:) + REAL*8, ALLOCATABLE :: A_GEN_1x1(:) + + !================================================================= + ! MODULE INTERFACES -- "bind" two or more routines with different + ! argument types or # of arguments under one unique name + !================================================================= + INTERFACE DO_REGRID_1x1 + MODULE PROCEDURE DO_REGRID_1x1_R4 + MODULE PROCEDURE DO_REGRID_1x1_R4_2D + MODULE PROCEDURE DO_REGRID_1x1_R8 + MODULE PROCEDURE DO_REGRID_1x1_R8_2D + END INTERFACE + + INTERFACE DO_REGRID_05x0666 + MODULE PROCEDURE DO_THE_REGRIDDING_05x0666_2D + MODULE PROCEDURE DO_THE_REGRIDDING_05x0666_3D + END INTERFACE + + ! (lzh, 02/01/2015) + INTERFACE DO_REGRID_025x03125 + MODULE PROCEDURE DO_THE_REGRIDDING_025x03125_2D + MODULE PROCEDURE DO_THE_REGRIDDING_025x03125_3D + END INTERFACE + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_REGRID_G2G_1x1( UNIT, GEN1x1, GEOS1x1 ) +! +!****************************************************************************** +! Subroutine DO_REGRID_G2G_1x1 regrids 2-D data on the GENERIC 1x1 +! grid (1st box edged at -180, -90) to the GEOS-Chem 1x1 grid. +! (psk, bmy, 4/5/06, 8/9/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) UNIT (CHARACTER) : Unit of the data to be regridded +! (2 ) GEN1x1 (REAL*4 ) : Data array on the GENERIC 1x1 grid +! +! Arguments as Output: +! ============================================================================ +! (3 ) GEOS1x1 (REAL*4 ) : Data array on the GEOS 1x1 grid +! +! NOTES: +! (1 ) Now pass UNIT via the arg list and pass that to ITS_CONCENTRATION_DATA +! to determine if the data to be regridded is concentration data +! or mass data. This is now consistent with routine DO_REGRID_1x1. +! (bmy, 8/9/06) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! Physical constants + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: UNIT + REAL*8, INTENT(IN) :: GEN1x1(I1x1,J1x1-1) + REAL*8, INTENT(OUT) :: GEOS1x1(I1x1,J1x1) + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: ITS_PER_UNIT_AREA + INTEGER :: I, J, IX, JX, IE(2), JE(2) + REAL*8 :: RE_cm, LAT, DLAT2 + REAL*8 :: A_GEN(J1x1-1) + REAL*8 :: A_GEOS(J1x1) + + !================================================================= + ! DO_REGRID_G2G_1x1 begins here! + !================================================================= + + ! Initialize on first call (if necessary) + IF ( FIRST ) THEN + CALL INIT_REGRID_1x1 + FIRST = .FALSE. + ENDIF + + ! Is this concentration data? + ITS_PER_UNIT_AREA = ITS_CONCENTRATION_DATA( UNIT ) + + ! Surface area on generic grid [m2] + A_GEN(:) = A_GEN_1x1(:) + + ! Surface area on GEOS-Chem grid [m2] + A_GEOS(:) = A1x1(:) + + !----------------------------------- + ! Regrid quantity in mass units + ! from GENERIC to GEOS-Chem grid + !----------------------------------- + + ! Loop over GEOS-Chem latitudes + DO J = 1, J1x1 + + ! Set limits + JE(1) = J - 1 + JE(2) = J + + ! Special case for South Pole + IF ( J == 1 ) THEN + JE(1) = 1 + JE(2) = 1 + ENDIF + + ! Special case for North Pole + IF ( J == J1x1 ) THEN + JE(1) = J1x1-1 + JE(2) = J1x1-1 + ENDIF + + ! Loop over GEOS-Chem longitudes + DO I = 1, I1x1 + + ! Zero quantity on GEOS-Chem 1x1 GRID + GEOS1x1(I,J) = 0d0 + + ! Set limits + IE(1) = I - 1 + IE(2) = I + + ! Date line + IF ( I == 1 ) THEN + IE(1) = I1x1 + IE(2) = 1 + ENDIF + + ! Save into GEOS 1x1 grid + IF ( ITS_PER_UNIT_AREA ) THEN + + ! Data on GENERIC 1x1 grid is per unit area + ! We have to multiply by the generic grid area (A_GEN) + DO JX = 1, 2 + DO IX = 1, 2 + GEOS1x1(I,J) = GEOS1x1(I,J) + + & 0.25d0 * GEN1x1( IE(IX), JE(JX) ) * A_GEN( JE(JX) ) + ENDDO + ENDDO + + ELSE + + ! Data on GENERIC 1x1 grid is a mass quantity + ! We do not have to multiply by the generic grid area + DO JX = 1, 2 + DO IX = 1, 2 + GEOS1x1(I,J) = GEOS1x1(I,J) + + & 0.25d0 * GEN1x1( IE(IX), JE(JX) ) + ENDDO + ENDDO + + ENDIF + + ENDDO + ENDDO + + ! If the data on the GENERIC 1x1 grid is per unit area...we also + ! want to return data on the GEOS 1x1 grid as per unit area. + ! Thus, we have to divide by the GEOS 1x1 area (A_GEOS). + IF ( ITS_PER_UNIT_AREA ) THEN + DO J = 1, J1x1 + DO I = 1, I1x1 + GEOS1x1(I,J) = GEOS1x1(I,J) / A_GEOS(J) + ENDDO + ENDDO + ENDIF + + ! Return to calling program + END SUBROUTINE DO_REGRID_G2G_1x1 + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_REGRID_1x1_R4( L1x1, UNIT, INDATA, OUTDATA ) +! +!****************************************************************************** +! Subroutine DO_REGRID_1x1_R4 is a wrapper routine for DO_THE_REGRIDDING. +! It takes a REAL*4 array as input and returns a 3-D REAL*8 array as output. +! (bdf, bmy, 10/24/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) L1x1 (INTEGER ) : Level dimension for INDATA and OUTDATA +! (2 ) UNIT (CHAR*(*)) : String containing the units of INDATA & OUTDATA +! (3 ) INDATA (REAL*4 ) : Input data array on 1x1 grid +! +! Arguments as Output: +! ============================================================================ +! (4 ) OUTDATA (REAL*8 ) : Output data array +! +! NOTES: +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: L1x1 + REAL*4, INTENT(IN) :: INDATA(I1x1,J1x1,L1x1) + REAL*8, INTENT(OUT) :: OUTDATA(IIPAR,JJPAR,L1x1) + CHARACTER(LEN=*), INTENT(IN) :: UNIT + + !================================================================= + ! DO_REGRID_1x1_R4 begins here + !================================================================= + + ! Regrid data + CALL DO_THE_REGRIDDING( L1x1, UNIT, DBLE( INDATA ), OUTDATA ) + + ! Return to calling program + END SUBROUTINE DO_REGRID_1x1_R4 + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_REGRID_1x1_R8( L1x1, UNIT, INDATA, OUTDATA ) +! +!****************************************************************************** +! Subroutine DO_REGRID_1x1_R8 is a wrapper routine for DO_THE_REGRIDDING. +! It takes a REAL*8 array as input and returns a 3-D REAL*8 array as output. +! (bdf, bmy, 10/24/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) L1x1 (INTEGER ) : Level dimension for INDATA and OUTDATA +! (2 ) UNIT (CHAR*(*)) : String containing the units of INDATA & OUTDATA +! (3 ) INDATA (REAL*8 ) : Input data array on 1x1 grid +! +! Arguments as Output: +! ============================================================================ +! (4 ) OUTDATA (REAL*8 ) : Output data array +! +! NOTES: +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: L1x1 + REAL*8, INTENT(IN) :: INDATA(I1x1,J1x1,L1x1) + REAL*8, INTENT(OUT) :: OUTDATA(IIPAR,JJPAR,L1x1) + CHARACTER(LEN=*), INTENT(IN) :: UNIT + + !================================================================= + ! DO_REGRID_1x1_R8 begins here + !================================================================= + + ! Regrid data + CALL DO_THE_REGRIDDING( L1x1, UNIT, INDATA, OUTDATA ) + + ! Return to calling program + END SUBROUTINE DO_REGRID_1x1_R8 + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_REGRID_1x1_R4_2D( UNIT, INDATA, OUTDATA ) +! +!****************************************************************************** +! Subroutine DO_REGRID_1x1_R4 is a wrapper routine for DO_THE_REGRIDDING. +! It takes a REAL*4 array as input and saves a 2-D REAL*8 array as output. +! (bdf, bmy, 10/24/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) L1x1 (INTEGER ) : Level dimension for INDATA and OUTDATA +! (2 ) UNIT (CHAR*(*)) : String containing the units of INDATA & OUTDATA +! (3 ) INDATA (REAL*4 ) : Input data array on 1x1 grid +! +! Arguments as Output: +! ============================================================================ +! (4 ) OUTDATA (REAL*8 ) : Output data array +! +! NOTES: +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*4, INTENT(IN) :: INDATA(I1x1,J1x1,1) + REAL*8, INTENT(OUT) :: OUTDATA(IIPAR,JJPAR) + CHARACTER(LEN=*), INTENT(IN) :: UNIT + + ! Local variables + REAL*8 :: TMP_OUT(IIPAR,JJPAR,1) + + !================================================================= + ! DO_REGRID_1x1_R4 begins here + !================================================================= + + ! Regrid data + CALL DO_THE_REGRIDDING( 1, UNIT, DBLE( INDATA ), TMP_OUT ) + + ! Save output data to a 2D array + OUTDATA(:,:) = TMP_OUT(:,:,1) + + ! Return to calling program + END SUBROUTINE DO_REGRID_1x1_R4_2D + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_REGRID_1x1_R8_2D( UNIT, INDATA, OUTDATA ) +! +!****************************************************************************** +! Subroutine DO_REGRID_1x1_R8_2D is a wrapper routine for DO_THE_REGRIDDING. +! It takes a REAL*8 array as input and saves to a 2-D REAL*8 array as output. +! (bdf, bmy, 10/24/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) L1x1 (INTEGER ) : Level dimension for INDATA and OUTDATA +! (2 ) UNIT (CHAR*(*)) : String containing the units of INDATA & OUTDATA +! (3 ) INDATA (REAL*8 ) : Input data array on 1x1 grid +! +! Arguments as Output: +! ============================================================================ +! (4 ) OUTDATA (REAL*8 ) : Output data array +! +! NOTES: +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + REAL*8, INTENT(IN) :: INDATA(I1x1,J1x1,1) + REAL*8, INTENT(OUT) :: OUTDATA(IIPAR,JJPAR) + CHARACTER(LEN=*), INTENT(IN) :: UNIT + + ! Local variables + REAL*8 :: TMP_OUT(IIPAR,JJPAR,1) + + !================================================================= + ! DO_REGRID_1x1_R8 begins here + !================================================================= + + ! Regrid data + CALL DO_THE_REGRIDDING( 1, UNIT, INDATA, TMP_OUT ) + + ! Copy output data to a 2D array + OUTDATA(:,:) = TMP_OUT(:,:,1) + + ! Return to calling program + END SUBROUTINE DO_REGRID_1x1_R8_2D + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_THE_REGRIDDING( L1x1, UNIT, INDATA, OUTDATA ) +! +!****************************************************************************** +! Subroutine DO_THE_REGRIDDING is the driver routine for the regridding from +! the GEOS-Chem 1x1 grid to other CTM grids. (bmy, 10/24/05, 8/2/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) L1x1 (INTEGER ) : Level dimension for INDATA and OUTDATA +! (2 ) UNIT (CHAR*(*)) : String containing the units of INDATA & OUTDATA +! (3 ) INDATA (REAL*8 ) : Input data array on 1x1 grid +! +! Arguments as Output: +! ============================================================================ +! (4 ) OUTDATA (REAL*8 ) : Output data array +! +! NOTES: +! (1 ) Added #if block for 1 x 1.25 grid (bdf, bmy, 8/2/06) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: L1x1 + REAL*8, INTENT(IN) :: INDATA(I1x1,J1x1,L1x1) + REAL*8, INTENT(OUT) :: OUTDATA(IIPAR,JJPAR,L1x1) + CHARACTER(LEN=*), INTENT(IN) :: UNIT + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: IS_CONC + + !================================================================= + ! DO_REGRID_1x1 begins here! + !================================================================= + + ! Initialize on first call (if necessary) + IF ( FIRST ) THEN + CALL INIT_REGRID_1x1 + FIRST = .FALSE. + ENDIF + + ! Is this concentration data? + IS_CONC = ITS_CONCENTRATION_DATA( UNIT ) + +#if defined( GCAP ) + + !-------------------------------------------- + ! Regrid GEOS 1x1 grid to GCAP 4x5 grid + !-------------------------------------------- + + IF ( IS_CONC ) THEN + + ! Regrid concentration field to GCAP 4x5 + CALL REGRID_CONC_TO_4x5_GCAP( I1x1, J1x1, L1x1, INDATA, + & IIPAR, JJPAR, OUTDATA ) + + ELSE + + ! Regrid mass field to GCAP 4x5 + CALL REGRID_MASS_TO_4x5_GCAP( I1x1, J1x1, L1x1, INDATA, + & IIPAR, JJPAR, OUTDATA ) + + ENDIF + +#elif defined( GRID4x5 ) + + !-------------------------------------------- + ! Regrid GEOS 1x1 grid to GEOS 4x5 grid + !-------------------------------------------- + + IF ( IS_CONC ) THEN + + ! Regrid concentration field to 4x5 + CALL REGRID_CONC_TO_4x5( I1x1, J1x1, L1x1, INDATA, + & IIPAR, JJPAR, OUTDATA ) + + ELSE + + ! Regrid mass field to 4x5 + CALL REGRID_MASS_TO_4x5( I1x1, J1x1, L1x1, INDATA, + & IIPAR, JJPAR, OUTDATA ) + + ENDIF + +#elif defined( GRID2x25 ) + + !------------------------------------------- + ! Regrid GEOS 1x1 grid to GEOS 2x2.5 grid + !------------------------------------------- + + IF ( IS_CONC ) THEN + + ! Regrid concentration field to 2x25 + CALL REGRID_CONC_TO_2x25( I1x1, J1x1, L1x1, INDATA, + & IIPAR, JJPAR, OUTDATA ) + + ELSE + ! Regrid mass field to 2x25 + CALL REGRID_MASS_TO_2x25( I1x1, J1x1, L1x1, INDATA, + & IIPAR, JJPAR, OUTDATA ) + + ENDIF + +#elif defined( GRID1x125 ) + + !-------------------------------------------- + ! Regrid GEOS 1x1 grid to GEOS 1x1.25 GRID + !-------------------------------------------- + + IF ( IS_CONC ) THEN + + ! Regrid concentration field to 1x125 + CALL REGRID_CONC_TO_1X125( I1x1, J1x1, L1x1, INDATA, + & IIPAR, JJPAR, OUTDATA ) + + ELSE + + ! Regrid mass field to 1x125 + CALL REGRID_MASS_TO_1X125( I1x1, J1x1, L1x1, INDATA, + & IIPAR, JJPAR, OUTDATA ) + + ENDIF + +#elif defined( GRID1x1 ) && defined( NESTED_CH ) + + !-------------------------------------------- + ! Regrid GEOS 1x1 grid to nested China grid + !-------------------------------------------- + + ! China nested grid has corners (70E,11S) and (150E,55N) + ! which corresponds to 1x1 indices (251,80) and (331,146) + OUTDATA = INDATA( 251:331, 80:146, : ) + +#elif defined( GRID1x1 ) && defined( NESTED_NA ) + + !-------------------------------------------- + ! Regrid GEOS 1x1 grid to nested N. Am. grid + !-------------------------------------------- + + ! N. Am. nested grid has corners (10N,140W) and (60N,40W) + ! which corresponds to 1x1 indices (41,101) and (141,151) + OUTDATA = INDATA( 41:141, 101:151, : ) + +#elif defined( GRID1x1 ) + + !-------------------------------------------- + ! GEOS 1x1 grid (no regridding necessary) + !-------------------------------------------- + + ! Copy data array + OUTDATA = INDATA + +!prior to 5/5/09 +!#endif +!New addition (win, 5/5/09) + + !-------------------------------------------- + ! Regrid GEOS 1x1 grid to nested China grid 0.5x0.667 res + !-------------------------------------------- + + ! Bug fix for China nested 0.5x0.667 run (win, 5/1/09) + ! Prior to 5/1/09, there is no option for this and also + ! no #else statement below, which is bad b/c any non-matched + ! case would just slipped through and did not get any proper returning array +#elif defined( GRID05x0666 ) && defined( NESTED_CH ) + + CALL REGRID_05x0666_NESTED( I1x1, J1x1, L1x1, UNIT, + & INDATA, OUTDATA ) + +#elif defined( GRID05x0666 ) && defined( NESTED_NA ) + + CALL REGRID_05x0666_NESTED( I1x1, J1x1, L1x1, UNIT, + & INDATA, OUTDATA ) + +#elif defined( GRID025x03125 ) && defined( NESTED_CH ) + + CALL DO_REGRID_025x03125( L1x1, UNIT, INDATA, OUTDATA ) + +#elif defined( GRID025x03125 ) && defined( NESTED_NA ) + + CALL DO_REGRID_025x03125( L1x1, UNIT, INDATA, OUTDATA ) + +#else + + write(*,*) 'regrid_1x1_mod.f : no match in DO_THE_REGRIDDING ' + STOP + +#endif +!end new addition (win, 5/5/09) + + ! Return to calling program + END SUBROUTINE DO_THE_REGRIDDING + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_THE_REGRIDDING_05x0666_3D( L05x0666, UNIT, + & INDATA, OUTDATA ) +! +!****************************************************************************** +! Subroutine DO_THE_REGRIDDING_05x0666_3D is the driver routine for the +! regridding global 3-D GEOS-5 0.5 x 0.667 data to the GEOS-5 nested grids. +! (bmy, 11/6/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) L1x1 (INTEGER ) : Level dimension for INDATA and OUTDATA +! (2 ) UNIT (CHAR*(*)) : String containing the units of INDATA & OUTDATA +! (3 ) INDATA (REAL*8 ) : Input data array on 1x1 grid +! +! Arguments as Output: +! ============================================================================ +! (4 ) OUTDATA (REAL*8 ) : Output data array +! +! NOTES: +! (1 ) Updated for adjoint nested domains (zhej, dkh, 01/20/12, adj32_015) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: L05x0666 + REAL*8, INTENT(IN) :: INDATA(I05x0666,J05x0666,L05x0666) + REAL*8, INTENT(OUT):: OUTDATA(IIPAR,JJPAR,L05x0666) + CHARACTER(LEN=*), INTENT(IN) :: UNIT + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: IS_CONC + + !================================================================= + ! DO_THE_REGRIDDING_05x0666_3D begins here! + !================================================================= + + ! Is this concentration data? + IS_CONC = ITS_CONCENTRATION_DATA( UNIT ) + +#if defined( GRID05x0666 ) && defined( NESTED_CH ) && !defined( NESTED_SD ) + + !------------------------------------------------ + ! Regrid GEOS 05x0666 grid to nested China grid + !------------------------------------------------ + + ! China nested grid has corners (70E,11S) and (150E,55N) + ! which corresponds to 05x0666 indices (376,159) and (496,291) + OUTDATA(1:IIPAR,1:JJPAR,1) = INDATA( 376:496, 159:291,1) + +#elif defined( GRID05x0666 ) && defined( NESTED_NA ) && !defined( NESTED_SD ) + + ! NA nested grid has corners (140W,10N) and (40W,70N) + ! which corresponds to 05x0666 indices (61,201) and (211,321) + OUTDATA(1:IIPAR,1:JJPAR,1) = INDATA( 61:211, 201:321,1) + +#elif defined( GRID05x0666 ) && (defined( NESTED_NA ) || defined( NESTED_CH )) && defined( NESTED_SD ) + + ! Parameters for smaller domain + OUTDATA(1:IIPAR,1:JJPAR,1) = INDATA( 82:172, 207:295,1) + +#endif + + ! Return to calling program + END SUBROUTINE DO_THE_REGRIDDING_05x0666_3D + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_THE_REGRIDDING_05x0666_2D( L05x0666, UNIT, + & INDATA, OUTDATA ) +! +!****************************************************************************** +! Subroutine DO_THE_REGRIDDING_05x0666_2D is the driver routine for the +! regridding global 3-D GEOS-5 0.5 x 0.667 data to the GEOS-5 nested grids. +! (bmy, 11/6/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) L1x1 (INTEGER ) : Level dimension for INDATA and OUTDATA +! (2 ) UNIT (CHAR*(*)) : String containing the units of INDATA & OUTDATA +! (3 ) INDATA (REAL*8 ) : Input data array on 1x1 grid +! +! Arguments as Output: +! ============================================================================ +! (4 ) OUTDATA (REAL*8 ) : Output data array +! +! NOTES: +! (1 ) Updated for adjoint nested domains (zhej, dkh, 01/20/12, adj32_015) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: L05x0666 + REAL*8, INTENT(IN) :: INDATA(I05x0666,J05x0666,L05x0666) + REAL*8, INTENT(OUT):: OUTDATA(IIPAR,JJPAR) + CHARACTER(LEN=*), INTENT(IN) :: UNIT + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: IS_CONC + + !================================================================= + ! DO_THE_REGRIDDING_05x0666_2D begins here! + !================================================================= + + ! Is this concentration data? + IS_CONC = ITS_CONCENTRATION_DATA( UNIT ) + +#if defined( GRID05x0666 ) && defined( NESTED_CH ) && !defined( NESTED_SD ) + + !----------------------------------------------- + ! Regrid GEOS 05x0666 grid to nested China grid + !----------------------------------------------- + + ! China nested grid has corners (70E,11S) and (150E,55N) + ! which corresponds to 05x0666 indices (376,159) and (496,291) + OUTDATA(1:IIPAR,1:JJPAR) = INDATA( 376:496, 159:291, 1) + +#elif defined( GRID05x0666 ) && defined( NESTED_NA ) && !defined( NESTED_SD ) + + ! NA nested grid has corners (140W,10N) and (40W,70N) + ! which corresponds to 05x0666 indices (61,201) and (211,321) + OUTDATA(1:IIPAR,1:JJPAR) = INDATA( 61:211, 201:321,1) + +#elif defined( GRID05x0666 ) && (defined( NESTED_NA ) || defined( NESTED_CH )) && defined( NESTED_SD ) + + ! Parameters for smaller domain + OUTDATA(1:IIPAR,1:JJPAR) = INDATA( 82:172, 207:295,1) + +#endif + + ! Return to calling program + END SUBROUTINE DO_THE_REGRIDDING_05x0666_2D + +!------------------------------------------------------------------------------ +!!=========================================== +!!!!! (lzh, 02/01/2015) +!------------------------------------------------------------------------------ + + SUBROUTINE DO_THE_REGRIDDING_025x03125_3D( L025x031, UNIT, + & INDATA, OUTDATA ) +! +!****************************************************************************** +! Subroutine DO_THE_REGRIDDING_025x03125_3D is the driver routine for the +! regridding global 3-D GEOS-5 0.5 x 0.667 data to the GEOS-5 nested grids. +! (bmy, 11/6/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) L1x1 (INTEGER ) : Level dimension for INDATA and OUTDATA +! (2 ) UNIT (CHAR*(*)) : String containing the units of INDATA & OUTDATA +! (3 ) INDATA (REAL*8 ) : Input data array on 1x1 grid +! +! Arguments as Output: +! ============================================================================ +! (4 ) OUTDATA (REAL*8 ) : Output data array +! +! NOTES: +! (1 ) Updated for adjoint nested domains (zhej, dkh, 01/20/12, adj32_015) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: L025x031 + REAL*8, INTENT(IN) :: INDATA(I025x031,J025x031,L025x031) + REAL*8, INTENT(OUT):: OUTDATA(IIPAR,JJPAR,L025x031) + CHARACTER(LEN=*), INTENT(IN) :: UNIT + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: IS_CONC + + !================================================================= + ! DO_THE_REGRIDDING_025x03125_3D begins here! + !================================================================= + + ! Is this concentration data? + IS_CONC = ITS_CONCENTRATION_DATA( UNIT ) + +#if defined( GRID025x03125 ) && defined( NESTED_CH ) && !defined( NESTED_SD ) + + !------------------------------------------------ + ! Regrid GEOS 025x03125 grid to nested China grid + !------------------------------------------------ + + ! China nested grid has corners (70E,15S) and (140E,55N) + ! which corresponds to 025x03125 indices (801,412) and (1025,581) + OUTDATA(1:IIPAR,1:JJPAR,1) = INDATA( 801:1025,421:581,1) + +#elif defined( GRID025x03125 ) && defined( NESTED_NA ) && !defined( NESTED_SD ) + + !----------------------------------------------- + ! Regrid GEOS 025x03125 grid to nested NA grid + !----------------------------------------------- + + ! China nested grid has corners (130W,9.75N) and (60W,60N) + ! which corresponds to 025x03126 indices (801,421) and (1025,581) + OUTDATA(1:IIPAR,1:JJPAR,1:LLPAR) = INDATA(161:385,400:601,1:LLPAR) + +#endif + + ! Return to calling program + END SUBROUTINE DO_THE_REGRIDDING_025x03125_3D + +!------------------------------------------------------------------------------ + + SUBROUTINE DO_THE_REGRIDDING_025x03125_2D( L025x031, UNIT, + & INDATA, OUTDATA ) +! +!****************************************************************************** +! Subroutine DO_THE_REGRIDDING_025x03125_2D is the driver routine for the +! regridding global 3-D GEOS-5 0.5 x 0.667 data to the GEOS-5 nested grids. +! (bmy, 11/6/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) L1x1 (INTEGER ) : Level dimension for INDATA and OUTDATA +! (2 ) UNIT (CHAR*(*)) : String containing the units of INDATA & OUTDATA +! (3 ) INDATA (REAL*8 ) : Input data array on 1x1 grid +! +! Arguments as Output: +! ============================================================================ +! (4 ) OUTDATA (REAL*8 ) : Output data array +! +! NOTES: +! (1 ) Updated for adjoint nested domains (zhej, dkh, 01/20/12, adj32_015) +!****************************************************************************** +! +# include "CMN_SIZE" ! Size parameters + + ! Arguments + INTEGER, INTENT(IN) :: L025x031 + REAL*8, INTENT(IN) :: INDATA(I025x031,J025x031,L025x031) + REAL*8, INTENT(OUT):: OUTDATA(IIPAR,JJPAR) + CHARACTER(LEN=*), INTENT(IN) :: UNIT + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + LOGICAL :: IS_CONC + + !================================================================= + ! DO_THE_REGRIDDING_025x03125_2D begins here! + !================================================================= + + ! Is this concentration data? + IS_CONC = ITS_CONCENTRATION_DATA( UNIT ) + + +#if defined( GRID025x03125 ) && defined( NESTED_CH ) && !defined( NESTED_SD ) + + !----------------------------------------------- + ! Regrid GEOS 025x03125 grid to nested China grid + !----------------------------------------------- + + ! China nested grid has corners (70E,15S) and (140E,55N) + ! which corresponds to 025x03126 indices (801,421) and (1025,581) + OUTDATA(1:IIPAR,1:JJPAR) = INDATA( 801:1025,421:581, 1) + +#elif defined( GRID025x03125 ) && defined( NESTED_NA ) && !defined( NESTED_SD ) + + !----------------------------------------------- + ! Regrid GEOS 025x03125 grid to nested NA grid + !----------------------------------------------- + + ! China nested grid has corners (130W,9.75N) and (60W,60N) + ! which corresponds to 025x03126 indices (801,421) and (1025,581) + OUTDATA(1:IIPAR,1:JJPAR) = INDATA( 161:385,400:601, 1) + +#endif + + ! Return to calling program + END SUBROUTINE DO_THE_REGRIDDING_025x03125_2D + +!------------------------------------------------------------------------------ + + SUBROUTINE REGRID_05x0666_NESTED( I1, J1, L1, UNIT, + & IN1x1, OUTNEST ) +! +!****************************************************************************** +! Subroutine REGRID_05x0666_NESTED regrid 1x1 data to 0.5 x 0.667 data and +! can work with different /geos/u23/GC_DATA_/ctm/GEOS_1x1/anth_scale_factors_200811/NOxScalar-2005-2000.geos.1x1nested region (win, 5/5/09) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I1 (INTEGER ) : Lon dimension for INDATA +! (2 ) J1 (INTEGER ) : Lat dimension for INDATA +! (3 ) L1 (INTEGER ) : Level dimension for INDATA and OUTDATA +! (4 ) UNIT (CHAR*(*)) : String containing the units of INDATA & OUTDATA +! (5 ) IN1x1 (REAL*8 ) : Input data array on 1x1 grid +! +! Arguments as Output: +! ============================================================================ +! (6 ) OUTNEST (REAL*8 ) : Output data array on 0.5x0.667 grid nested region +! +! NOTES: +! (1 ) Currently the code is hard-wired for China and N.America regions +! so this needs modifications for other regions in the future (win, 5/5/09) +! (2 ) Updated for adjoint nested domains (zhej, dkh, 01/20/12, adj32_015) +!****************************************************************************** +! + +# include "CMN_SIZE" ! Size parameters IIPAR, JJPAR + + ! Arguments + INTEGER, INTENT(IN) :: I1, J1, L1 + REAL*8, INTENT(IN) :: IN1x1(I1,J1,L1) + REAL*8, INTENT(OUT):: OUTNEST(IIPAR,JJPAR,L1) + CHARACTER(LEN=*), INTENT(IN) :: UNIT + + ! Local variables + LOGICAL :: IS_CONC + INTEGER :: I, J, L, X, Y + REAL*8 :: OUT_05x06(I05x0666,J05x0666,L1) + REAL*8 :: FAC1, FAC2, FAC3 + REAL*8 :: FAC4, FAC5, FAC6 + + !================================================================== + ! REGRID_05x0666_NESTED begins here! + !================================================================== + + ! Is this concentration data? + IS_CONC = ITS_CONCENTRATION_DATA( UNIT ) + + IF ( IS_CONC ) THEN + FAC1 = 1d0 + FAC2 = 0.25d0 + FAC3 = 0.75d0 + FAC4 = 0.50d0 + FAC5 = 0.125d0 + FAC6 = 0.375d0 + ELSE + FAC1 = 0.333333333d0 + FAC2 = 0.083333333d0 + FAC3 = 0.25000d0 + FAC4 = 0.16666667d0 + FAC5 = 0.041666667d0 + FAC6 = 0.12500d0 + ENDIF + + ! Loop over levels +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, X, Y) + DO L = 1, L1 + + Y = 1 ! counter for LAT box in 0.5x0.667 + + DO J = 1, J1X1 - 1 + + X = 1 ! counter for LON box in 0.5x0.667 + + DO I = 1, I1X1 - 3, 2 + ! The concept is: + ! - every two 1x1 LON boxes make three 0.5x0.667 LON boxes + ! - every one 1x1 LAT box makes two 0.5x0.667 LAT boxes + ! So for each I and J loop, we make six 0.5x0.667 boxes + + ! CASE 1: 1x1 and 0.5x0.667 box have same grid center + OUT_05x06(X,Y,L) = IN1x1(I,J,L) * FAC1 + + ! CASE 2: Lon overlap 1/4 & 3/4 and same Lat + OUT_05x06(X+1,Y,L) = IN1x1(I,J,L)* FAC2 + + & IN1x1(I+1,J,L)* FAC3 + + ! CASE 3: Lon overlap 3/4 & 1/4 and same Lat + OUT_05x06(X+2,Y,L) = IN1x1(I+1,J,L)* FAC3 + + & IN1x1(I+2,J,L)* FAC2 + + ! CASE 4: like CASE1 but need 1:1 averaging of 2 Lat boxes + OUT_05x06(X,Y+1,L) = IN1x1(I,J,L)*FAC4 + + & IN1x1(I,J+1,L)*FAC4 + + ! CASE 5: Averaging 1/8 LL & 3/8 LR & 3/8 UR & 1/8 UL + OUT_05x06(X+1,Y+1,L) = IN1x1(I ,J ,L)*FAC5 + + & IN1x1(I+1,J ,L)*FAC6 + + & IN1x1(I+1,J+1,L)*FAC6 + + & IN1x1(I ,J+1,L)*FAC5 + + ! CASE 6: Averaging 3/8 LL & 1/8 LR & 1/8 UR & 3/8 UL + OUT_05x06(X+2,Y+1,L) = IN1x1(I+1,J ,L)*FAC6 + + & IN1x1(I+2,J ,L)*FAC5 + + & IN1x1(I+2,J+1,L)*FAC5 + + & IN1x1(I+1,J+1,L)*FAC6 + X = X+3 + + ENDDO + + Y = Y+2 + + ENDDO + + !For the North Edge + J = J1X1 + Y = J05x0666 + X = 1 + DO I = 1, I1X1 - 3, 2 + + !CASE 1: 1x1 and 0.5x0.667 box have same grid center + OUT_05x06(X,Y,L) = IN1x1(I,J,L) * FAC1 + + !CASE 2: Lon overlap 1/4 & 3/4 and same Lat + OUT_05x06(X+1,Y,L) = IN1x1(I,J,L) * FAC2 + + & IN1x1(I+1,J,L) * FAC3 + + !CASE 3: Lon overlap 3/4 & 1/4 and same Lat + OUT_05x06(X+2,Y,L) = IN1x1(I+1,J,L) * FAC3 + + & IN1x1(I+2,J,L) * FAC2 + + X = X+3 + + ENDDO + + !For the East Edge + X = I05x0666 - 2 + I = I1X1 - 1 + Y = 1 + DO J = 1, J1X1 - 1 + + !CASE 1: 1x1 and 0.5x0.667 box have same grid center + OUT_05x06(X,Y,L) = IN1x1(I,J,L) * FAC1 + + !CASE 2: Lon overlap 1/4 & 3/4 and same Lat + OUT_05x06(X+1,Y,L) = IN1x1(I,J,L)* FAC2 + + & IN1x1(I+1,J,L)* FAC3 + + !CASE 3: Lon overlap 3/4 & 1/4 and same Lat + OUT_05x06(X+2,Y,L) = IN1x1(I+1,J,L)* FAC1 + + !CASE 4: like CASE1 but need 1:1 averaging of 2 Lat boxes + OUT_05x06(X,Y+1,L) = IN1x1(I,J,L)*FAC4 + + & IN1x1(I,J+1,L)*FAC4 + + !CASE 5: Averaging 1/8 LL & 3/8 LR & 3/8 UR & 1/8 UL + OUT_05x06(X+1,Y+1,L) = IN1x1(I ,J ,L)*FAC5 + + & IN1x1(I+1,J ,L)*FAC6 + + & IN1x1(I+1,J+1,L)*FAC6 + + & IN1x1(I ,J+1,L)*FAC5 + + !CASE 6: Averaging 3/8 LL & 1/8 LR & 1/8 UR & 3/8 UL + OUT_05x06(X+2,Y+1,L) = IN1x1(I+1,J ,L)*FAC4 + + & IN1x1(I+1,J+1,L)*FAC4 + + Y = Y+2 + + ENDDO + + !The North-East Corner + OUT_05x06(I05x0666-2, J05x0666, L) = + & IN1x1(I1X1-1, J1X1, L) * FAC1 + + OUT_05x06(I05x0666-1, J05x0666, L) = + & IN1x1(I1X1-1, J1X1, L) * FAC2 + IN1x1(I1X1, J1X1, L) * FAC3 + + OUT_05x06(I05x0666, J05x0666, L) = + & IN1x1(I1X1, J1X1, L) * FAC1 + + ENDDO +!$OMP END PARALLEL DO + + +#if defined( GRID05x0666 ) && defined( NESTED_CH ) && !defined( NESTED_SD ) + + !------------------------------------------------ + ! Regrid GEOS 05x0666 grid to nested China grid + !------------------------------------------------ + + ! China nested grid has corners (70E,11S) and (150E,55N) + ! which corresponds to 05x0666 indices (376,159) and (496,291) + OUTNEST(1:IIPAR,1:JJPAR,1:L1) = OUT_05x06( 376:496, 159:291,1:L1) + +#elif defined( GRID05x0666 ) && defined( NESTED_NA ) && !defined( NESTED_SD ) + + ! NA nested grid has corners (140W,10N) and (40W,70N) + ! which corresponds to 05x0666 indices (61,201) and (211,321) + OUTNEST(1:IIPAR,1:JJPAR,1:L1) = OUT_05x06( 61:211, 201:321,1:L1) + +#elif defined( GRID05x0666 ) && (defined( NESTED_NA ) || defined( NESTED_CH )) && defined( NESTED_SD ) + + ! Parameters for smaller domain + OUTNEST(1:IIPAR,1:JJPAR,1:L1) = OUT_05x06( 82:172, 207:295,1:L1) + +#endif + + ! Return to calling program + END SUBROUTINE REGRID_05x0666_NESTED + + +!------------------------------------------------------------------------------ + + FUNCTION ITS_CONCENTRATION_DATA( UNIT ) RESULT( IS_CONC ) +! +!****************************************************************************** +! Subroutine ITS_CONCENTRATION_DATA returns TRUE if UNIT is a concentration +! (i.e. is per unit area such as molec/cm2/s or is a ratio such as kg/kg). +! (bmy, 10/24/05, 8/9/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) UNIT (CHAR*(*)) : String with unit of data +! +! NOTES: +! (1 ) Added kg/s, kg/month, kg/season to CASE statement (bmy, 8/9/06) +!****************************************************************************** +! + ! References to F90 modules + USE CHARPAK_MOD, ONLY : STRSQUEEZE + USE ERROR_MOD, ONLY : ERROR_STOP + + ! Arguments + CHARACTER(LEN=* ) :: UNIT + + ! Local variables + LOGICAL :: IS_CONC + CHARACTER(LEN=40) :: THISUNIT + CHARACTER(LEN=255) :: MSG, LOC + + !================================================================= + ! ITS_CONCENTRATION_DATA begins here! + !================================================================= + + ! Copy UNIT to local variable + THISUNIT = UNIT + + ! Remove all leading/trailing blanks + CALL STRSQUEEZE( THISUNIT ) + + ! Test if UNIT is a concentration unit (i.e. per unit area or a ratio) + SELECT CASE ( TRIM( THISUNIT ) ) + + ! Concentration units + CASE ( 'gC/m2/s' ) + IS_CONC = .TRUE. + CASE ( 'unitless' ) + IS_CONC = .TRUE. + CASE ( 'molec/cm2' ) + IS_CONC = .TRUE. + CASE ( 'molec/cm2/s' ) + IS_CONC = .TRUE. + CASE ( 'molec C/cm2/s') + IS_CONC = .TRUE. + CASE ( 'atom C/cm2/s' ) + IS_CONC = .TRUE. + CASE ( 'atoms C/cm2/s' ) + IS_CONC = .TRUE. + CASE ( 's-1' ) + IS_CONC = .TRUE. + CASE ( 'K' ) + IS_CONC = .TRUE. + CASE ( 'kg/kg' ) + IS_CONC = .TRUE. + CASE ( 'factor' ) + IS_CONC = .TRUE. + CASE ( 'm2/m2' ) + IS_CONC = .TRUE. + CASE ( 'cm2/cm2' ) + IS_CONC = .TRUE. + CASE ( 'DU' ) + IS_CONC = .TRUE. + CASE ( 'DU/day' ) + IS_CONC = .TRUE. + CASE ( 'mg C/m2/hr' ) + IS_CONC = .TRUE. + CASE ( 'ug C/m2/hr' ) + IS_CONC = .TRUE. + + ! Mass units + CASE ( 'kg' ) + IS_CONC = .FALSE. + CASE ( 'kg/s' ) + IS_CONC = .FALSE. + CASE ( 'kg/month' ) + IS_CONC = .FALSE. + CASE ( 'kg/season' ) + IS_CONC = .FALSE. + CASE ( 'kg/yr' ) + IS_CONC = .FALSE. + CASE ( 'kgC/yr' ) + IS_CONC = .FALSE. + CASE ( 'kg C/yr' ) + IS_CONC = .FALSE. + CASE ( 'kgN' ) + IS_CONC = .FALSE. + CASE ( 'kgEC' ) + IS_CONC = .FALSE. + CASE ( 'kgOC' ) + IS_CONC = .FALSE. + CASE ( 'kgEC/yr' ) + IS_CONC = .FALSE. + CASE ( 'kgOC/yr' ) + IS_CONC = .FALSE. + + ! Unit not recognized + CASE DEFAULT + + ! Set IS_CONC to false + IS_CONC = .FALSE. + + ! Error msg + MSG = TRIM( UNIT ) // ' is an unrecognized unit, ' // + & ' it must be added to the CASE statement!' + + ! Location of error + LOC = 'IS_CONCENTRATION_DATA ("regrid_mod.f")' + + ! Stop run w/ error + CALL ERROR_STOP( MSG, LOC ) + + END SELECT + + ! Return to calling program + END FUNCTION ITS_CONCENTRATION_DATA + +!------------------------------------------------------------------------------ + + SUBROUTINE REGRID_CONC_TO_4x5_GCAP( I1, J1, L1, IN, I4, J4, OUT ) +! +!****************************************************************************** +! Subroutine REGRID_CONC_TO_4x5_GCAP regrids concentration data from the +! GEOS-Chem 1x1 grid to the GEOS-Chem 4x5 GCAP grid. (bdf, bmy, 10/24/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I1 (INTEGER) : 1x1 longitude dimension of IN array +! (2 ) J1 (INTEGER) : 1x1 latitude dimension of IN array +! (3 ) L1 (INTEGER) : 1x1 altitude dimension of IN array +! (4 ) IN (REAL*8 ) : Array containing input data on GEOS-Chem 1x1 grid +! (5 ) I4 (INTEGER) : 4x5 longitude dimension of OUT array +! (6 ) J4 (INTEGER) : 4x5 latitude dimension of OUT array +! +! Arguments as Output: +! ============================================================================ +! (7 ) OUT (REAL*8 ) : Array containing output data on GCAP 4x5 grid +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_AREA_M2 + + ! Arguments + INTEGER, INTENT(IN) :: I1, J1, L1, I4, J4 + REAL*8, INTENT(IN) :: IN(I1,J1,L1) + REAL*8, INTENT(OUT) :: OUT(I4,J4,L1) + + ! Local variables + INTEGER :: I, J, L, W, E, S, N + REAL*8 :: M_TOT + + !================================================================== + ! REGRID_CONC_TO_4x5_GCAP begins here! + !================================================================== + + ! Loop over levels +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, W, E, M_TOT, S, N ) + DO L = 1, L1 + + !----------------------- + ! S and N Poles + !----------------------- + DO I = 1, I4 + + ! 1x1 lon index at W edge of 4x5 box + W = MOD( 5 * ( I - 1 ) - 1 + I1, I1 ) + + ! 1x1 lon index at E edge of 4x5 box + E = 5 * ( I - 1 ) + 3 + + ! Total mass of 1x1 boxes w/in to 4x5 S pole box + M_TOT = SUM( IN( W :W+1, 1, L ) ) * A1x1(1) + + & SUM( IN( W :W+1, 2, L ) ) * A1x1(2) + + & SUM( IN( W :W+1, 3, L ) ) * A1x1(3) + + & SUM( IN( W :W+1, 4, L ) ) * A1x1(4) + + & 0.5d0*SUM( IN( W :W+1, 5, L ) ) * A1x1(5) + + & SUM( IN( E-2:E, 1, L ) ) * A1x1(1) + + & SUM( IN( E-2:E, 2, L ) ) * A1x1(2) + + & SUM( IN( E-2:E, 3, L ) ) * A1x1(3) + + & SUM( IN( E-2:E, 4, L ) ) * A1x1(4) + + & 0.5d0*SUM( IN( E-2:E, 5, L ) ) * A1x1(5) + + ! Output field at 4x5 S pole box + OUT(I,1,L) = M_TOT / ( 5d0 * ( A1x1(1) + A1x1(2) + + & A1x1(3) + A1x1(4) + + & 0.5d0 * A1x1(5) ) ) + + ! Total mass of 1x1 boxes w/in to 4x5 N pole box + M_TOT = SUM( IN( W :W+1, J1, L ) ) * A1x1(J1 ) + + & SUM( IN( W :W+1, J1-1, L ) ) * A1x1(J1-1) + + & SUM( IN( W :W+1, J1-2, L ) ) * A1x1(J1-2) + + & SUM( IN( W :W+1, J1-3, L ) ) * A1x1(J1-3) + + & 0.5d0*SUM( IN( W :W+1, J1-4, L ) ) * A1x1(J1-4) + + & SUM( IN( E-2:E, J1, L ) ) * A1x1(J1 ) + + & SUM( IN( E-2:E, J1-1, L ) ) * A1x1(J1-1) + + & SUM( IN( E-2:E, J1-2, L ) ) * A1x1(J1-2) + + & SUM( IN( E-2:E, J1-3, L ) ) * A1x1(J1-3) + + & 0.5d0*SUM( IN( E-2:E, J1-4, L ) ) * A1x1(J1-4) + + ! Output field at 4x5 N pole box + OUT(I,J4,L) = M_TOT / ( 5d0 * ( A1x1(J1) + A1x1(J1-1) + + & A1x1(J1-2) + A1x1(J1-3) + + & 0.5d0 * A1x1(J1-4) ) ) + ENDDO + + !----------------------- + ! Non-polar latitudes + !----------------------- + DO J = 2, J4-1 + + ! 1x1 lat index at S edge of 4x5 box + S = ( 4 * ( J - 1 ) ) + 1 + + ! 1x1 lat index at N edge of 4x5 box + N = ( J * 4 ) + 1 + + DO I = 1, I4 + + ! 1x1 lon index at W edge of 4x5 box + W = MOD( 5*( I - 1 ) - 1 + I1, I1 ) + + ! 1x1 lon index at E edge of 4x5 box + E = 5*( I -1 ) + 3 + + ! Total mass w/in the 4x5 box at (I,J,L) + M_TOT = 0.5d0 * SUM( IN( W :W+1, S, L ) ) * A1x1(S ) + + & 0.5d0 * SUM( IN( E-2:E, S, L ) ) * A1x1(S ) + + & SUM( IN( W :W+1, S+1, L ) ) * A1x1(S+1) + + & SUM( IN( E-2:E, S+1, L ) ) * A1x1(S+1) + + & SUM( IN( W :W+1, S+2, L ) ) * A1x1(S+2) + + & SUM( IN( E-2:E, S+2, L ) ) * A1x1(S+2) + + & SUM( IN( W :W+1, S+3, L ) ) * A1x1(S+3) + + & SUM( IN( E-2:E, S+3, L ) ) * A1x1(S+3) + + & 0.5d0 * SUM( IN( W :W+1, N, L ) ) * A1x1(N ) + + & 0.5d0 * SUM( IN( E-2:E, N, L ) ) * A1x1(N ) + + ! 4x5 output field at (I,J,L) + OUT(I,J,L) = M_TOT / GET_AREA_M2( J ) + ENDDO + ENDDO + + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE REGRID_CONC_TO_4x5_GCAP + +!------------------------------------------------------------------------------ + + SUBROUTINE REGRID_MASS_TO_4x5_GCAP( I1, J1, L1, IN, I4, J4, OUT ) +! +!****************************************************************************** +! Subroutine REGRID_MASS_TO_4x5_GCAP regrids mass data from the +! GEOS-Chem 1x1 grid to the GEOS-Chem 4x5 GCAP grid. (bdf, bmy, 10/24/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I1 (INTEGER) : 1x1 longitude dimension of IN array +! (2 ) J1 (INTEGER) : 1x1 latitude dimension of IN array +! (3 ) L1 (INTEGER) : 1x1 altitude dimension of IN array +! (4 ) IN (REAL*8 ) : Array containing input data on GEOS-Chem 1x1 grid +! (5 ) I4 (INTEGER) : 4x5 longitude dimension of OUT array +! (6 ) J4 (INTEGER) : 4x5 latitude dimension of OUT array +! +! Arguments as Output: +! ============================================================================ +! (7 ) OUT (REAL*8 ) : Array containing output data on GEOS-Chem 4x5 grid +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I1, J1, L1, I4, J4 + REAL*8, INTENT(IN) :: IN(I1,J1,L1) + REAL*8, INTENT(OUT) :: OUT(I4,J4,L1) + + ! Local variables + INTEGER :: I, J, L, W, E, S, N + + !================================================================== + ! REGRID_MASS_TO_4x5_GCAP begins here! + !================================================================== + + ! Loop over levels +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, W, E, S, N ) + DO L = 1, L1 + + !----------------------- + ! S and N Poles + !----------------------- + DO I = 1, I4 + + ! 1x1 lon index at W edge of 4x5 box + W = MOD( 5 * ( I - 1 ) - 1 + I1, I1 ) + + ! 1x1 lon index at E edge of 4x5 box + E = 5 * ( I - 1 ) + 3 + + ! Total mass of 1x1 boxes w/in to 4x5 S pole box + OUT(I,1,L) = SUM( IN( W :W+1, 1, L ) ) + + & SUM( IN( W :W+1, 2, L ) ) + + & SUM( IN( W :W+1, 3, L ) ) + + & SUM( IN( W :W+1, 4, L ) ) + + & 0.5d0 * SUM( IN( W :W+1, 5, L ) ) + + & SUM( IN( E-2:E, 1, L ) ) + + & SUM( IN( E-2:E, 2, L ) ) + + & SUM( IN( E-2:E, 3, L ) ) + + & SUM( IN( E-2:E, 4, L ) ) + + & 0.5d0 * SUM( IN( E-2:E, 5, L ) ) + + ! Total mass of 1x1 boxes w/in to 4x5 N pole box + OUT(I,J4,L) = SUM( IN( W :W+1, J1, L ) ) + + & SUM( IN( W :W+1, J1-1, L ) ) + + & SUM( IN( W :W+1, J1-2, L ) ) + + & SUM( IN( W :W+1, J1-3, L ) ) + + & 0.5d0 * SUM( IN( W :W+1, J1-4, L ) ) + + & SUM( IN( E-2:E, J1, L ) ) + + & SUM( IN( E-2:E, J1-1, L ) ) + + & SUM( IN( E-2:E, J1-2, L ) ) + + & SUM( IN( E-2:E, J1-3, L ) ) + + & 0.5d0 * SUM( IN( E-2:E, J1-4, L ) ) + + ENDDO + + !----------------------- + ! Non-polar latitudes + !----------------------- + DO J = 2, J4-1 + + ! 1x1 lat index at S edge of 4x5 box + S = ( 4 * ( J - 1 ) ) + 1 + + ! 1x1 lat index at N edge of 4x5 box + N = ( J * 4 ) + 1 + + DO I = 1, I4 + + ! 1x1 lon index at W edge of 4x5 box + W = MOD( 5*( I - 1 ) - 1 + I1, I1 ) + + ! 1x1 lon index at E edge of 4x5 box + E = 5*( I -1 ) + 3 + + ! Total mass w/in the 4x5 box at (I,J,L) + OUT(I,J,L) = 0.5d0 * SUM( IN( W :W+1, S, L ) ) + + & 0.5d0 * SUM( IN( E-2:E, S, L ) ) + + & SUM( IN( W :W+1, S+1, L ) ) + + & SUM( IN( E-2:E, S+1, L ) ) + + & SUM( IN( W :W+1, S+2, L ) ) + + & SUM( IN( E-2:E, S+2, L ) ) + + & SUM( IN( W :W+1, S+3, L ) ) + + & SUM( IN( E-2:E, S+3, L ) ) + + & 0.5d0 * SUM( IN( W :W+1, N, L ) ) + + & 0.5d0 * SUM( IN( E-2:E, N, L ) ) + + ENDDO + ENDDO + + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE REGRID_MASS_TO_4x5_GCAP + +!------------------------------------------------------------------------------ + + SUBROUTINE REGRID_CONC_TO_4x5( I1, J1, L1, IN, I4, J4, OUT ) +! +!****************************************************************************** +! Subroutine REGRID_CONC_TO_4x5 regrids concentration data from the +! GEOS-Chem 1x1 grid to the GEOS_CHEM 4x5 grid. (bdf, bmy, 10/24/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I1 (INTEGER) : 1x1 longitude dimension of IN array +! (2 ) J1 (INTEGER) : 1x1 latitude dimension of IN array +! (3 ) L1 (INTEGER) : 1x1 altitude dimension of IN array +! (4 ) IN (REAL*8 ) : Array containing input data on GEOS-Chem 1x1 grid +! (5 ) I4 (INTEGER) : 4x5 longitude dimension of OUT array +! (6 ) J4 (INTEGER) : 4x5 latitude dimension of OUT array +! +! Arguments as Output: +! ============================================================================ +! (7 ) OUT (REAL*8 ) : Array containing output data on GEOS-Chem 4x5 grid +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_AREA_M2 + + ! Arguments + INTEGER, INTENT(IN) :: I1, J1, L1, I4, J4 + REAL*8, INTENT(IN) :: IN(I1,J1,L1) + REAL*8, INTENT(OUT) :: OUT(I4,J4,L1) + + ! Local variables + INTEGER :: I, J, L, W, E, S, N + REAL*8 :: M_TOT + + !================================================================== + ! REGRID_CONC_TO_4x5 begins here! + !================================================================== + + ! Loop over levels +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, W, E, M_TOT, S, N ) + DO L = 1, L1 + + !----------------------- + ! S and N Poles + !----------------------- + DO I = 1, I4 + + ! 1x1 lon index at W edge of 4x5 box + W = MOD( 5 * ( I - 1 ) - 1 + I1, I1 ) + + ! 1x1 lon index at E edge of 4x5 box + E = 5 * ( I - 1 ) + 3 + + ! Total mass of 1x1 boxes w/in to 4x5 S pole box + M_TOT = SUM( IN( W :W+1, 1, L ) ) * A1x1(1) + + & SUM( IN( W :W+1, 2, L ) ) * A1x1(2) + + & SUM( IN( E-2:E, 1, L ) ) * A1x1(1) + + & SUM( IN( E-2:E, 2, L ) ) * A1x1(2) + + & 0.5d0*SUM( IN( W :W+1, 3, L ) ) * A1x1(3) + + & 0.5d0*SUM( IN( E-2:E, 3, L ) ) * A1x1(3) + + ! Output field at 4x5 S pole box + OUT(I,1,L) = M_TOT / + & ( 5d0* ( A1x1(1) + A1x1(2) + 0.5d0*A1x1(3) ) ) + + ! Total mass of 1x1 boxes w/in to 4x5 N pole box + M_TOT = SUM( IN( W :W+1, J1, L ) ) * A1x1(J1 ) + + & SUM( IN( W :W+1, J1-1, L ) ) * A1x1(J1-1) + + & SUM( IN( E-2:E, J1, L ) ) * A1x1(J1 ) + + & SUM( IN( E-2:E, J1-1, L ) ) * A1x1(J1-1) + + & 0.5d0*SUM( IN( W :W+1, J1-2, L ) ) * A1x1(J1-2) + + & 0.5d0*SUM( IN( E-2:E, J1-2, L ) ) * A1x1(J1-2) + + ! Output field at 4x5 N pole box + OUT(I,J4,L) = M_TOT/ + & ( 5d0* ( A1x1(J1) + A1x1(J1-1)+ 0.5*A1x1(J1-2))) + + ENDDO + + !----------------------- + ! Non-polar latitudes + !----------------------- + DO J = 2, J4-1 + + ! 1x1 lat index at S edge of 4x5 box + S = ( 4 * ( J - 1 ) ) - 1 + + ! 1x1 lat index at N edge of 4x5 box + N = ( J * 4 ) - 1 + + DO I = 1, I4 + + ! 1x1 lon index at W edge of 4x5 box + W = MOD( 5*( I - 1 ) - 1 + I1, I1 ) + + ! 1x1 lon index at E edge of 4x5 box + E = 5*( I -1 ) + 3 + + ! Total mass w/in the 4x5 box at (I,J,L) + M_TOT = 0.5d0*SUM( IN( W :W+1, S, L ) ) * A1x1(S ) + + & 0.5d0*SUM( IN( E-2:E, S, L ) ) * A1x1(S ) + + & SUM( IN( W :W+1, S+1, L ) ) * A1x1(S+1) + + & SUM( IN( E-2:E, S+1, L ) ) * A1x1(S+1) + + & SUM( IN( W :W+1, S+2, L ) ) * A1x1(S+2) + + & SUM( IN( E-2:E, S+2, L ) ) * A1x1(S+2) + + & SUM( IN( W :W+1, S+3, L ) ) * A1x1(S+3) + + & SUM( IN( E-2:E, S+3, L ) ) * A1x1(S+3) + + & 0.5d0*SUM( IN( W :W+1, N, L ) ) * A1x1(N ) + + & 0.5d0*SUM( IN( E-2:E, N, L ) ) * A1x1(N ) + + ! 4x5 output field at (I,J,L) + OUT(I,J,L) = M_TOT / GET_AREA_M2( J ) + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE REGRID_CONC_TO_4x5 + +!------------------------------------------------------------------------------ + + SUBROUTINE REGRID_MASS_TO_4x5( I1, J1, L1, IN, I4, J4, OUT ) +! +!****************************************************************************** +! Subroutine REGRID_MASS_TO_4x5 regrids mass data from the GEOS-Chem 1x1 +! grid to the GEOS_CHEM 4x5 grid. (bdf, bmy, 10/24/05, 2/20/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I1 (INTEGER) : 1x1 longitude dimension of IN array +! (2 ) J1 (INTEGER) : 1x1 latitude dimension of IN array +! (3 ) L1 (INTEGER) : 1x1 altitude dimension of IN array +! (4 ) IN (REAL*8 ) : Array containing input data on GEOS-Chem 1x1 grid +! (5 ) I4 (INTEGER) : 4x5 longitude dimension of OUT array +! (6 ) J4 (INTEGER) : 4x5 latitude dimension of OUT array +! +! Arguments as Output: +! ============================================================================ +! (7 ) OUT (REAL*8 ) : Array containing output data on GEOS-Chem 4x5 grid +! +! NOTES: +! (1 ) Bug fix: the lat index should be N, not S in the last 2 lines of the +! non-polar latitude regridding. (tw, bmy, 2/20/07) +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I1, J1, L1, I4, J4 + REAL*8, INTENT(IN) :: IN(I1,J1,L1) + REAL*8, INTENT(OUT) :: OUT(I4,J4,L1) + + ! Local variables + INTEGER :: I, J, L, W, E, S, N + REAL*8 :: M_TOT + + !================================================================= + ! REGRID_MASS_TO_4x5 begins here! + !================================================================= + + ! Loop over levels +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, W, E, S, N ) + DO L = 1, L1 + + !----------------------- + ! S and N Poles + !----------------------- + DO I = 1, I4 + + ! 1x1 lon index at W edge of 4x5 box + W = MOD( 5 * ( I - 1 ) - 1 + I1, I1 ) + + ! 1x1 lon index at E edge of 4x5 box + E = 5 * ( I - 1 ) + 3 + + ! Output field at 4x5 S Pole box + OUT(I,1,L) = SUM( IN( W :W+1, 1:2, L ) ) + + & SUM( IN( E-2:E, 1:2, L ) ) + + & 0.5d0*SUM( IN( W :W+1, 3, L ) ) + + & 0.5d0*SUM( IN( E-2:E, 3, L ) ) + + ! Output field at 4x5 N pole box + OUT(I,J4,L) = SUM( IN( W :W+1, J1-1:J1, L ) ) + + & SUM( IN( E-2:E, J1-1:J1, L ) ) + + & 0.5d0*SUM( IN( W :W+1, J1-2, L ) ) + + & 0.5d0*SUM( IN( E-2:E, J1-2, L ) ) + ENDDO + + !----------------------- + ! Non-polar latitudes + !----------------------- + DO J = 2, J4-1 + + ! 1x1 lat index at S edge of 4x5 box + S = ( 4 * ( J - 1 ) ) - 1 + + ! 1x1 lat index at Northern edge of 4x5 box + N = ( J * 4 ) - 1 + + DO I = 1, I4 + + ! 1x1 lon index at W edge of the 4x5 box + W = MOD( 5 * ( I - 1 ) - 1 + I1, I1 ) + + ! 1x1 lon index at E edge of 4x5 box + E = 5 * ( I - 1 ) + 3 + + ! Output value for 4x5 grid box (I,J,L) + OUT(I,J,L) = 0.5d0*SUM( IN( W :W+1, S, L ) ) + + & 0.5d0*SUM( IN( E-2:E, S, L ) ) + + & SUM( IN( W :W+1, S+1:N-1, L ) ) + + & SUM( IN( E-2:E, S+1:N-1, L ) ) + + & 0.5d0*SUM( IN( W :W+1, N, L ) ) + + & 0.5d0*SUM( IN( E-2:E, N, L ) ) + + ENDDO + ENDDO + + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE REGRID_MASS_TO_4x5 + +!------------------------------------------------------------------------------ + + SUBROUTINE REGRID_CONC_TO_2x25( I1, J1, L1, IN, I2, J2, OUT ) +! +!****************************************************************************** +! Subroutine REGRID_CONC_TO_2x25 regrids concentration data from the +! GEOS-Chem 1x1 grid to the GEOS_CHEM 2x25 grid. (bdf, bmy, 10/24/05) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I1 (INTEGER) : 1x1 longitude dimension of IN array +! (2 ) J1 (INTEGER) : 1x1 latitude dimension of IN array +! (3 ) L1 (INTEGER) : 1x1 altitude dimension of IN array +! (4 ) IN (REAL*8 ) : Array containing input data on GEOS-Chem 1x1 grid +! (5 ) I2 (INTEGER) : 2x25 longitude dimension of OUT array +! (6 ) J2 (INTEGER) : 2x25 latitude dimension of OUT array +! +! Arguments as Output: +! ============================================================================ +! (7 ) OUT (REAL*8 ) : Array containing output data on GEOS-Chem 2x25 grid +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_AREA_M2 + + ! Arguments + INTEGER, INTENT(IN) :: I1, J1, L1, I2, J2 + REAL*8, INTENT(IN) :: IN(I1,J1,L1) + REAL*8, INTENT(OUT) :: OUT(I2,J2,L1) + + ! Local variables + INTEGER :: I, J, L, W, E, S, N + REAL*8 :: M_TOT + + !================================================================= + ! REGRID_CONC_TO_2x25 begins here! + !================================================================= + + ! Loop over levels +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, W, E, M_TOT, S, N ) + DO L = 1, L1 + + !----------------------- + ! S and N Poles + !----------------------- + DO I = 1, I2 + + ! 1x1 lon index at W edge of 2x25 box + W = FLOOR( 2.5d0 * ( I - 1 ) ) + IF ( W == 0 ) W = 360 + + ! 1x1 lon index at E edge of 2x25 box + E = FLOOR( 2.5d0 * I ) + + ! Test for 3 or 4 contributing 1x1 longitude boxes + IF ( MOD( I, 2 ) == 1 ) THEN + + !--------------------------------------- + ! 3 contributing 1x1 lon boxes at poles + !--------------------------------------- + + ! Total mass (w/ 3 contributing 1x1 boxes) at S Pole + M_TOT = 0.75d0 * IN( W, 1, L ) * A1x1(1) + + & 0.375d0 * IN( W, 2, L ) * A1x1(2) + + & IN( E-1, 1, L ) * A1x1(1) + + & 0.5d0 * IN( E-1, 2, L ) * A1x1(2) + + & 0.75d0 * IN( E, 1, L ) * A1x1(1) + + & 0.375d0 * IN( E, 2, L ) * A1x1(2) + + ! Output field at 2 x 2.5 S pole box + OUT(I,1,L) = M_TOT / + & ( 2.5d0 * ( A1x1(1) + 0.5d0*A1x1(2) ) ) + + ! Total mass (w/ 3 contributing 1x1 lon boxes) at N pole + M_TOT = 0.75d0 * IN( W, J1, L ) * A1x1(J1 ) + + & 0.375d0 * IN( W, J1-1, L ) * A1x1(J1-1) + + & IN( E-1, J1, L ) * A1x1(J1 ) + + & 0.5d0 * IN( E-1, J1-1, L ) * A1x1(J1-1) + + & 0.75d0 * IN( E, J1, L ) * A1x1(J1 ) + + & 0.375d0 * IN( E, J1-1, L ) * A1x1(J1-1) + + ! Output field at 2 x 2.5 N pole box + OUT(I,J2,L) = M_TOT/ + & ( 2.5d0 * ( A1x1(J1) + 0.5d0*A1x1(J1-1) ) ) + + ELSE + + !--------------------------------------- + ! 4 contributing 1x1 lon boxes at poles + !--------------------------------------- + + ! Total mass (w/ 4 contributing 1x1 lon boxes) at S pole + M_TOT = + & 0.25d0 * IN( W, 1, L ) * A1x1(1) + + & 0.125d0 * IN( W, 2, L ) * A1X1(2) + + & SUM( IN( W+1:E-1, 1, L ) ) * A1x1(1) + + & 0.5d0 * SUM( IN( W+1:E-1, 2, L ) ) * A1x1(2) + + & 0.25d0 * IN( E, 1, L ) * A1x1(1) + + & 0.125d0 * IN( E, 2, L ) * A1x1(2) + + ! Output field at 2 x 2.5 S pole box + OUT(I,1,L) = M_TOT/ + & ( 2.5d0* ( A1x1(1) + 0.5d0*A1x1(2) ) ) + + ! Total mass (w/ 4 contributing 1x1 lon boxes) at N pole + M_TOT = + & 0.25d0 * IN( W, J1, L ) * A1x1(J1 ) + + & 0.125d0 * IN( W, J1-1, L ) * A1x1(J1-1) + + & SUM( IN( W+1:E-1, J1, L ) ) * A1x1(J1 ) + + & 0.5d0 * SUM( IN( W+1:E-1, J1-1, L ) ) * A1x1(J1-1) + + & 0.25d0 * IN( E, J1, L ) * A1x1(J1 ) + + & 0.125d0 * IN( E, J1-1, L ) * A1x1(J1-1) + + ! Output field at 2 x 2.5 N pole box + OUT(I,J2,L) = M_TOT/ + & ( 2.5d0* ( A1x1(J1) + 0.5d0*A1x1(J1-1) ) ) + + ENDIF + ENDDO + + !----------------------- + ! Non-polar latitudes + !----------------------- + DO J = 2, J2-1 + + ! 1x1 lat index at S edge of 2 x 2.5 box + S = 2 * ( J - 1 ) + + ! 1x1 lat index at N edge of 2 x 2.5 box + N = 2 * J + + DO I = 1, I2 + + ! 1x1 lon index at W edge of 2 x 2.5 box + W = FLOOR( 2.5d0 * ( I - 1 ) ) + IF ( W == 0 ) W = 360 + + ! 1x1 lon index at E edge of 2 x 2.5 box + E = FLOOR( 2.5d0 * I ) + + ! Test for 3 or 4 contributing 1x1 lon boxes + IF ( MOD( I, 2 ) == 1 ) THEN + + !------------------------------ + ! 3 contributing 1x1 lon boxes + !------------------------------ + + ! Total mass (w/ 3 contributing 1x1 lon boxes) in 2 x 2.5 box + M_TOT = 0.375d0 * IN(W, S, L) * A1x1(S ) + + & 0.75d0 * IN(W, S+1,L) * A1x1(S+1) + + & 0.375d0 * IN(W, N, L) * A1x1(N ) + + & 0.5d0 * IN(E-1,S, L) * A1x1(S ) + + & IN(E-1,S+1,L) * A1x1(S+1) + + & 0.5d0 * IN(E-1,N, L) * A1x1(N ) + + & 0.375d0 * IN(E, S, L) * A1x1(S ) + + & 0.75d0 * IN(E, S+1,L) * A1x1(S+1) + + & 0.375d0 * IN(E, N, L) * A1x1(N ) + + ! 2 x 2.5 output field at (I,J,L) + OUT(I,J,L) = M_TOT / GET_AREA_M2( J ) + + ELSE + + !------------------------------ + ! 4 contributing 1x1 lon boxes + !------------------------------ + + ! Total mass (w/ 4 contributing 1x1 lon boxes) in 2 x 2.5 box + M_TOT = + & 0.125d0 * IN( W, S, L ) * A1x1(S ) + + & 0.25d0 * IN( W, S+1,L ) * A1x1(S+1) + + & 0.125d0 * IN( W, N, L ) * A1x1(N ) + + & 0.5d0 * SUM( IN( W+1:E-1, S, L ) ) * A1x1(S ) + + & SUM( IN( W+1:E-1, S+1,L ) ) * A1x1(S+1) + + & 0.5d0 * SUM( IN( W+1:E-1, N, L ) ) * A1x1(N ) + + & 0.125d0 * IN( E, S, L ) * A1x1(S ) + + & 0.25d0 * IN( E, S+1,L ) * A1x1(S+1) + + & 0.125d0 * IN( E, N, L ) * A1X1(N ) + + ! 2 x 2.5 output field at (I,J,L) + OUT(I,J,L) = M_TOT / GET_AREA_M2( J ) + ENDIF + ENDDO + ENDDO + + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE REGRID_CONC_TO_2x25 + +!------------------------------------------------------------------------------ + + SUBROUTINE REGRID_MASS_TO_2x25( I1, J1, L1, IN, I2, J2, OUT ) +! +!****************************************************************************** +! Subroutine REGRID_CONC_TO_2x25 regrids mass data from the GEOS-Chem 1x1 +! grid to the GEOS_CHEM 2x25 grid. (bdf, bmy, 10/24/05, 10/17/07) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I1 (INTEGER) : 1x1 longitude dimension of IN array +! (2 ) J1 (INTEGER) : 1x1 latitude dimension of IN array +! (3 ) L1 (INTEGER) : 1x1 altitude dimension of IN array +! (4 ) IN (REAL*8 ) : Array containing input data on GEOS-Chem 1x1 grid +! (5 ) I2 (INTEGER) : 2x25 longitude dimension of OUT array +! (6 ) J2 (INTEGER) : 2x25 latitude dimension of OUT array +! +! Arguments as Output: +! ============================================================================ +! (7 ) OUT (REAL*8 ) : Array containing output data on GEOS-Chem 2x25 grid +! +! NOTES: +! (1 ) Fixed typo: J should be J1 in "4 contrib boxes at poles" section. +! (bmy, 4/18/06) +! (2 ) Fixed typo: J1 should be I2 in "Non-polar boxes" section +! (barkley, bmy, 10/17/07) +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I1, J1, L1, I2, J2 + REAL*8, INTENT(IN) :: IN(I1,J1,L1) + REAL*8, INTENT(OUT) :: OUT(I2,J2,L1) + + ! Local variables + INTEGER :: I, J, L, W, E, S, N + REAL*8 :: M_TOT + + !================================================================= + ! REGRID_MASS_TO_2x25 begins here! + !================================================================= + + ! Loop over levels +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, W, E, S, N ) + DO L = 1, L1 + + !----------------------- + ! S and N Poles + !----------------------- + + DO I = 1, I2 + + ! 1x1 lon index at W edge of 2x25 box + W = FLOOR( 2.5d0 * ( I - 1 ) ) + IF ( W == 0 ) W = 360 + + ! 1x1 lon index at E edge of 2x25 box + E = FLOOR( 2.5d0 * I ) + + ! Test for 3 or 4 contributing 1x1 longitude boxes + IF ( MOD( I, 2 ) == 1 ) THEN + + !--------------------------------------- + ! 3 contributing 1x1 lon boxes at poles + !--------------------------------------- + + ! Output field at 2 x 2.5 S Pole box + OUT(I,1,L) = 0.75d0 * IN( W, 1, L ) + + & 0.375d0 * IN( W, 2, L ) + + & IN( E-1, 1, L ) + + & 0.5d0 * IN( E-1, 2, L ) + + & 0.75d0 * IN( E, 1, L ) + + & 0.375d0 * IN( E, 2, L ) + + ! Output field at 2 x 2.5 N pole box + OUT(I,J2,L) = 0.75d0 * IN( W, J1, L ) + + & 0.375d0 * IN( W, J1-1, L ) + + & IN( E-1, J1, L ) + + & 0.5d0 * IN( E-1, J1-1, L ) + + & 0.75d0 * IN( E, J1, L ) + + & 0.375d0 * IN( E, J1-1, L ) + ELSE + + !--------------------------------------- + ! 4 contributing 1x1 lon boxes at poles + !--------------------------------------- + + ! Output field at 2 x 2.5 S Pole box + OUT(I,1,L) = 0.25d0 * IN( W, 1, L ) + + & 0.125d0 * IN( W, 2, L ) + + & SUM( IN( W+1:E-1, 1, L ) ) + + & 0.5d0 * SUM( IN( W+1:E-1, 2, L ) ) + + & 0.25d0 * IN( E, 1, L ) + + & 0.125d0 * IN( E, 2, L ) + + ! Output field at 2 x 2.5 N pole box + OUT(I,J2,L) = 0.25d0 * IN( W, J1, L ) + + & 0.125d0 * IN( W, J1-1, L ) + + & SUM( IN( W+1:E-1, J1, L ) ) + + & 0.5d0 * SUM( IN( W+1:E-1, J1-1, L ) ) + + & 0.25d0 * IN( E, J1, L ) + + & 0.125d0 * IN( E, J1-1, L ) + ENDIF + + ENDDO + + !----------------------- + ! Non-polar latitudes + !----------------------- + DO J = 2, J2-1 + + ! 1x1 lat index at S edge of 2x25 box + S = 2 * ( J - 1 ) + + ! 1x1 lat index at N edge of 2x25 box + N = 2 * J + + DO I = 1, I2 + + ! 1x1 lon index at W edge of 2x25 box + W = FLOOR( 2.5d0 * ( I - 1 ) ) + IF ( W == 0 ) W = 360 + + ! 1x1 lon index at E edge of 2x25 box + E = FLOOR( 2.5d0 * I ) + + ! Test for 3 or 4 contributing 1x1 lon boxes + IF ( MOD( I, 2 ) == 1 ) THEN + + !------------------------------ + ! 3 contributing 1x1 lon boxes + !------------------------------ + + ! Output value at 2x25 box (I,J,L) + OUT(I,J,L) = 0.375d0 * IN( W, S, L ) + + & 0.75d0 * IN( W, S+1, L ) + + & 0.375d0 * IN( W, N, L ) + + & 0.5d0 * IN( E-1, S, L ) + + & IN( E-1, S+1, L ) + + & 0.5d0 * IN( E-1, N, L ) + + & 0.375d0 * IN( E, S, L ) + + & 0.75d0 * IN( E, S+1, L ) + + & 0.375d0 * IN( E, N, L ) + ELSE + + !------------------------------ + ! 4 contributing 1x1 lon boxes + !------------------------------ + + ! Output value at 2 x 2.5 box (I,J,L) + OUT(I,J,L) = 0.125d0 * IN( W, S, L ) + + & 0.25d0 * IN( W, S+1, L ) + + & 0.125d0 * IN( W, N, L ) + + & 0.5d0 * SUM( IN( W+1:E-1, S, L ) ) + + & SUM( IN( W+1:E-1, S+1, L ) ) + + & 0.5d0 * SUM( IN( W+1:E-1, N, L ) ) + + & 0.125d0 * IN( E, S, L ) + + & 0.25d0 * IN( E, S+1, L ) + + & 0.125d0 * IN( E, N, L ) + ENDIF + ENDDO + ENDDO + + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE REGRID_MASS_TO_2x25 + +!------------------------------------------------------------------------------ + + SUBROUTINE REGRID_CONC_TO_1x125( I1, J1, L1, IN, I2, J2, OUT ) +! +!****************************************************************************** +! Subroutine REGRID_CONC_TO_1x125 regrids conc data from the GEOS-Chem +! 1x1 grid to the GEOS_CHEM 1x125 grid. (bdf, bmy, 8/2/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I1 (INTEGER) : 1x1 longitude dimension of IN array +! (2 ) J1 (INTEGER) : 1x1 latitude dimension of IN array +! (3 ) L1 (INTEGER) : 1x1 altitude dimension of IN array +! (4 ) IN (REAL*8 ) : Array containing input data on GEOS-Chem 1x1 grid +! (5 ) I2 (INTEGER) : 1x125 longitude dimension of OUT array +! (6 ) J2 (INTEGER) : 1x125 latitude dimension of OUT array +! +! Arguments as Output: +! ============================================================================ +! (7 ) OUT (REAL*8 ) : Array containing output data on GEOS-Chem 1x125 grid +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_AREA_M2 + + ! Arguments + INTEGER, INTENT(IN) :: I1, J1, L1, I2, J2 + REAL*8, INTENT(IN) :: IN(I1,J1,L1) + REAL*8, INTENT(OUT) :: OUT(I2,J2,L1) + + ! Local variables + INTEGER :: I, J, L, W, E, C, OFFSET, PLACE + REAL*8 :: M_TOT + + !================================================================= + ! REGRID_CONC_TO_1x125 begins here! + !================================================================= + + ! Loop over levels +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, OFFSET, W, C, E, PLACE, M_TOT ) + DO L = 1, L1 + + ! Poles can be done at same time, no latitude differences + DO J = 1, J2 + DO I = 1, I2 + + ! 1x1 offset. there is 1 extra 1x1 box for every 4 1x125 boxes + OFFSET = FLOOR( ( I - 1 ) / 4d0 ) + + ! West, center, east longitude indices + W = I - 1 + OFFSET + C = I + OFFSET + E = I + 1 + OFFSET + + ! Special handling + IF ( W == 0 ) W = 360 + + ! There are 4 possible cases for overlap + PLACE = MOD( ( I - 1 ), 4 ) + + !----------------------------------------------------------- + ! Pick the right case for the overlap + ! + ! Because there is no difference in the latitude coordinates + ! between 1x1 and 1x1.25 grids, the concentration ratio is: + ! + ! [ area(1x1) / (1.24 or 1.26)*area(1x1) ] + ! + ! The 1.24 or 1.26 depends on how much overlap the 1x125 + ! grid has with the 1x1 grid. + !----------------------------------------------------------- + + SELECT CASE ( PLACE ) + + !---------------------------------------------- + ! CASE 0: 1x1 and 1x125 are centered the same + !---------------------------------------------- + CASE( 0 ) + M_TOT = 0.12d0 * IN(W,J,L) + + & IN(C,J,L) + + & 0.12d0 * IN(E,J,L) + + ! Overlap factor for CASE 0 is 1.24 + OUT(I,J,L) = M_TOT / 1.24d0 + + !---------------------------------------------- + ! CASE 1: one to the right of a centered box + !---------------------------------------------- + CASE ( 1 ) + M_TOT = 0.88d0 * IN(C,J,L) + + & 0.38d0 * IN(E,J,L) + + ! Overlap factor for CASE 1 is 1.26 + OUT(I,J,L) = M_TOT / 1.26d0 + + !---------------------------------------------- + ! CASE 2: 1x1 and 1x125 are edged the same + !---------------------------------------------- + CASE ( 2 ) + M_TOT = 0.62d0 * IN(C,J,L) + + & 0.62d0 * IN(E,J,L) + + ! Overlap factor for CASE 2 is 1.24 + OUT(I,J,L) = M_TOT / 1.24d0 + + !---------------------------------------------- + ! CASE 3: one to the left of a centered box + !---------------------------------------------- + CASE ( 3 ) + M_TOT = 0.38d0 * IN(C,J,L) + + & 0.88d0 * IN(E,J,L) + + ! Overlap factor for CASE 3 is 1.26 + OUT(I,J,L) = M_TOT / 1.26d0 + + END SELECT + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE REGRID_CONC_TO_1x125 + +!------------------------------------------------------------------------------ + + SUBROUTINE REGRID_MASS_TO_1x125( I1, J1, L1, IN, I2, J2, OUT ) +! +!****************************************************************************** +! Subroutine REGRID_MASS_TO_1x125 regrids mass data from the +! GEOS-Chem 1x1 grid to the GEOS-Chem 1x125 grid. (bdf, bmy, 8/2/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I1 (INTEGER) : 1x1 longitude dimension of IN array +! (2 ) J1 (INTEGER) : 1x1 latitude dimension of IN array +! (3 ) L1 (INTEGER) : 1x1 altitude dimension of IN array +! (4 ) IN (REAL*8 ) : Array containing input data on GEOS-Chem 1x1 grid +! (5 ) I2 (INTEGER) : 1x125 longitude dimension of OUT array +! (6 ) J2 (INTEGER) : 1x125 latitude dimension of OUT array +! +! Arguments as Output: +! ============================================================================ +! (7 ) OUT (REAL*8 ) : Array containing output data on GEOS-Chem 1x125 grid +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE GRID_MOD, ONLY : GET_AREA_M2 + + ! Arguments + INTEGER, INTENT(IN) :: I1, J1, L1, I2, J2 + REAL*8, INTENT(IN) :: IN(I1,J1,L1) + REAL*8, INTENT(OUT) :: OUT(I2,J2,L1) + + ! Local variables + INTEGER :: I, J, L, W, E, C, OFFSET, PLACE + REAL*8 :: M_TOT + + !================================================================= + ! REGRID_MASS_TO_1x125 begins here! + !================================================================= + + ! Loop over levels +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, OFFSET, W, C, E, PLACE ) + DO L = 1, L1 + + ! Poles can be done at same time, no latitude differences + DO J = 1, J2 + DO I = 1, I2 + + ! 1x1 offset. there is 1 extra 1x1 box for every 4 1x125 boxes + OFFSET = FLOOR( ( I - 1 ) / 4d0 ) + + ! West, center, east longitude indices + W = I - 1 + OFFSET + C = I + OFFSET + E = I + 1 + OFFSET + + ! Special handling + IF ( W == 0 ) W = 360 + + ! There are 4 possible casses for overlap + PLACE = MOD( ( I -1 ), 4 ) + + SELECT CASE ( PLACE ) + + !---------------------------------------------- + ! CASE 0: 1x1 and 1x125 are centered the same + !---------------------------------------------- + CASE( 0 ) + OUT(I,J,L) = 0.12d0 * IN(W,J,L) + + & IN(C,J,L) + + & 0.12d0 * IN(E,J,L) + + !---------------------------------------------- + ! CASE 1: one to the right of a centered box + !---------------------------------------------- + CASE ( 1 ) + OUT(I,J,L) = 0.88d0 * IN(C,J,L) + + & 0.38d0 * IN(E,J,L) + + !---------------------------------------------- + ! CASE 2: 1x1 and 1x125 are edged the same + !---------------------------------------------- + CASE ( 2 ) + OUT(I,J,L) = 0.62d0 * IN(C,J,L) + + & 0.62d0 * IN(E,J,L) + + !---------------------------------------------- + ! CASE 3: one to the left of a centered box + !---------------------------------------------- + CASE ( 3 ) + OUT(I,J,L) = 0.38d0 * IN(C,J,L) + + & 0.88d0 * IN(E,J,L) + + END SELECT + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE REGRID_MASS_TO_1x125 + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_REGRID_1x1 +! +!****************************************************************************** +! Subroutine INIT_REGRID_1x1 initializes module arrays +! (bdf, bmy, 10/24/05, 4/18/06) +! +! NOTES: +! (1 ) Now exit if we have already initialized (bmy, 4/18/06) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! Physical constants + + ! Local variables + LOGICAL, SAVE :: IS_INIT = .FALSE. + INTEGER :: AS, J + REAL*8 :: S, N, RLAT, YEDGE(J1x1+1) + + !================================================================= + ! INIT_REGRID_1x1 begins here! + !================================================================= + + ! Return if we have already initialized + IF ( IS_INIT ) RETURN + + !--------------------------------------- + ! Surface area on GEOS-Chem 1x1 grid + ! Uses same algorithm from "grid_mod.f" + !--------------------------------------- + + ! Allocate array + ALLOCATE( A1x1( J1x1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'A1x1' ) + + ! Initialize + YEDGE(:) = 0d0 + + ! 1x1 latitude edges + DO J = 2, J1x1 + YEDGE(J) = -90.5d0 + ( J - 1 ) + ENDDO + + ! Special cases at poles + YEDGE(1) = -90.0d0 + YEDGE(2) = -89.5d0 + YEDGE(J1x1+1) = 90.0d0 + + ! Compute 1x1 surface area + DO J = 1, J1x1 + + ! Lat at S and N edges of 1x1 box [radians] + S = PI_180 * YEDGE(J ) + N = PI_180 * YEDGE(J+1) + + ! S to N extent of grid box [unitless] + RLAT = SIN( N ) - SIN( S ) + + ! 1x1 surface area [m2] (see "grid_mod.f" for algorithm) + A1x1(J) = 2d0 * PI * Re * Re / DBLE( I1x1 ) * RLAT + ENDDO + + !--------------------------------------- + ! Surface area on GENERIC 1x1 grid + ! Uses same algorithm from "grid_mod.f" + !--------------------------------------- + + ! Initialize + YEDGE(:) = 0d0 + + ! Allocate array + ALLOCATE( A_GEN_1x1( J1x1-1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'A_GEN_1x1' ) + + ! 1x1 latitude edges + DO J = 1, J1x1 + YEDGE(J) = -90d0 + ( J - 1 ) + ENDDO + + ! Compute 1x1 surface area + DO J = 1, J1x1-1 + + ! Lat at S and N edges of 1x1 box [radians] + S = PI_180 * YEDGE(J ) + N = PI_180 * YEDGE(J+1) + + ! S to N extent of grid box [unitless] + RLAT = SIN( N ) - SIN( S ) + + ! 1x1 surface area [m2] (see "grid_mod.f" for algorithm) + A_GEN_1x1(J) = 2d0 * PI * Re * Re / DBLE( I1x1 ) * RLAT + ENDDO + + ! We have now initialized + IS_INIT = .TRUE. + + ! Return to calling program + END SUBROUTINE INIT_REGRID_1x1 + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_REGRID_1x1 +! +!****************************************************************************** +! Subroutine CLEANUP_REGRID_1x1 deallocates all module arrays. +! (bdf, bmy, 10/24/05) +! +! NOTES: +!****************************************************************************** +! + !================================================================= + ! CLEANUP_REGRID_1x1 begins here! + !================================================================= + IF ( ALLOCATED( A1x1 ) ) DEALLOCATE( A1x1 ) + IF ( ALLOCATED( A_GEN_1x1 ) ) DEALLOCATE( A_GEN_1x1 ) + + ! Return to calling program + END SUBROUTINE CLEANUP_REGRID_1x1 + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE REGRID_1x1_MOD diff --git a/code/regrid_a2a_mod.F90 b/code/regrid_a2a_mod.F90 new file mode 100644 index 0000000..51a98ab --- /dev/null +++ b/code/regrid_a2a_mod.F90 @@ -0,0 +1,1203 @@ +!------------------------------------------------------------------------------ +! Matthew Cooper - Dalhousie University ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: regrid_a2a_mod.F90 +! +! !DESCRIPTION: Module REGRID\_A2A\_MOD uses an algorithm adapted from MAP\_A2A +! code to regrid from one horizonatal grid to another. +!\\ +!\\ +! !INTERFACE: +! +MODULE REGRID_A2A_MOD +! +! !USES: +! + IMPLICIT NONE + PRIVATE +! +! !PRIVATE MEMBER FUNCTIONS: +! + PRIVATE :: XMAP + PRIVATE :: YMAP + PRIVATE :: READ_INPUT_GRID +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: DO_REGRID_A2A + PUBLIC :: DO_REGRID_DKH + PUBLIC :: MAP_A2A +! +! !REVISION HISTORY: +! 13 Mar 2012 - M. Cooper - Initial version +! 03 Apr 2012 - M. Payer - Now use functions GET_AREA_CM2(I,J,L), +! GET_YEDGE(I,J,L) and GET_YSIN(I,J,L) from the +! new grid_mod.F90 +! 22 May 2012 - L. Murray - Implemented several bug fixes +! 23 Aug 2012 - R. Yantosca - Add capability for starting from hi-res grids +! (generic 0.5x0.5, generic 0.25x0.25, etc.) +! 23 Aug 2012 - R. Yantosca - Add subroutine READ_INPUT_GRID, which reads the +! grid parameters (lon & lat edges) w/ netCDF +! 27 Aug 2012 - R. Yantosca - Now parallelize key DO loops +!EOP +!------------------------------------------------------------------------------ +!BOC + CONTAINS +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: do_regrid_a2a +! +! !DESCRIPTION: Subroutine DO\_REGRID\_A2A regrids 2-D data in the +! horizontal direction. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE DO_REGRID_A2A( FILENAME, IM, JM, INGRID, OUTGRID, IS_MASS, & + netCDF ) +! +! !USES: +! + USE GRID_MOD, ONLY : GET_XEDGE + USE GRID_MOD, ONLY : GET_YSIN + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE GRID_MOD, ONLY : GET_IJ + USE FILE_MOD, ONLY : IOERROR + USE inquireMod, ONLY : findFreeLUN + +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! Size parameters +! +! !INPUT PARAMETERS: +! + ! Name of file with lon and lat edge information on the INPUT GRID + CHARACTER(LEN=*), INTENT(IN) :: FILENAME + + ! Number of lon centers and lat centers on the INPUT GRID + INTEGER, INTENT(IN) :: IM + INTEGER, INTENT(IN) :: JM + + ! Data array on the input grid + REAL*8, INTENT(IN) :: INGRID(IM,JM) + + ! IS_MASS=0 if data is units of concentration (molec/cm2/s, unitless, etc.) + ! IS_MASS=1 if data is units of mass (kg/yr, etc.) + INTEGER, INTENT(IN) :: IS_MASS + + ! Read from netCDF file? (needed for debugging, will disappear later) + LOGICAL, OPTIONAL,INTENT(IN) :: netCDF +! +! !OUTPUT PARAMETERS: +! + ! Data array on the OUTPUT GRID + REAL*8, INTENT(OUT) :: OUTGRID(IIPAR,JJPAR) +! +! !REVISION HISTORY: + +! 13 Mar 2012 - M. Cooper - Initial version +! 22 May 2012 - L. Murray - Bug fix: INSIN should be allocated w/ JM+1. +! 22 May 2012 - R. Yantosca - Updated comments, cosmetic changes +! 25 May 2012 - R. Yantosca - Bug fix: declare the INGRID argument as +! INTENT(IN) to preserve the values of INGRID +! in the calling routine +! 06 Aug 2012 - R. Yantosca - Now make IU_REGRID a local variable +! 06 Aug 2012 - R. Yantosca - Move calls to findFreeLUN out of DEVEL block +! 23 Aug 2012 - R. Yantosca - Now use f10.4 format for hi-res grids +! 23 Aug 2012 - R. Yantosca - Now can read grid info from netCDF files +! 27 Aug 2012 - R. Yantosca - Add parallel DO loops +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: I, J + INTEGER :: IOS, M + INTEGER :: IU_REGRID + REAL*8 :: INAREA, RLAT + CHARACTER(LEN=15) :: HEADER1 + CHARACTER(LEN=20) :: FMT_LAT, FMT_LON, FMT_LEN + LOGICAL :: USE_NETCDF + + ! Arrays + REAL*8 :: INLON (IM +1) ! Lon edges on INPUT GRID + REAL*8 :: INSIN (JM +1) ! SIN( lat edges ) on INPUT GRID + REAL*8 :: OUTLON (IIPAR+1) ! Lon edges on OUTPUT GRID + REAL*8 :: OUTSIN (JJPAR+1) ! SIN( lat edges ) on OUTPUT GRID + REAL*8 :: IN_GRID(IM,JM ) ! Shadow variable for INGRID + + ! dkh debug + REAL*8 :: total + REAL*4 :: LON + REAL*4 :: LAT + INTEGER :: IIJJ(2) + + !====================================================================== + ! Initialization + ! + ! NOTE: In the near future ASCII input will be replaced by netCDF! + !====================================================================== + + ! Save value of netCDF to shadow variable + IF ( PRESENT( netCDF ) ) THEN + USE_netCDF = netCDF + ELSE + USE_netCDF = .FALSE. + ENDIF + + ! Longitude edges on the OUTPUT GRID + ! NOTE: May have to make OUTLON a 2-D array later for the GI model + DO I = 1, IIPAR+1 + OUTLON(I) = GET_XEDGE( I ) + ENDDO + + ! SIN( lat edges ) on the OUTPUT GRID + ! NOTE: May have to make OUTSIN a 2-D array later for the GI model + DO J = 1, JJPAR+1 + OUTSIN(J) = GET_YSIN( 1, J, 1 ) + ENDDO + + ! Read the input grid specifications + IF ( USE_netCDF ) THEN + + !------------------------------------------ + ! %%% FROM NETCDF FILE %%% + !------------------------------------------ + + ! Read the grid specifications from a netCDF file + CALL READ_INPUT_GRID( IM, JM, FILENAME, INLON, INSIN ) + + ELSE + + !------------------------------------------ + ! %%% FROM ASCII FILE %%% + ! + ! NOTE: Deprecated, will be removed later. + !------------------------------------------ + + ! Find a free file LUN + IU_REGRID = findFreeLUN() + + ! Open file containing lon & lat edges on the INPUT GRID + OPEN( IU_REGRID, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_REGRID, 'latlonread' ) + + ! Create the approprate FORMAT strings + WRITE(FMT_LEN,*) IM+1 + + ! NOTE: If the resolution of the grid is high enough, we have + ! to allow for an extra digit in the input file. This will + ! become obsolete once we migrate to netCDF format (bmy, 8/23/12) + IF ( IM > 1000 ) THEN + FMT_LON='(' // TRIM ( FMT_LEN ) // 'F10.4)' ! For hi-res grids + ELSE + FMT_LON='(' // TRIM ( FMT_LEN ) // 'F9.3)' ! For all other grids + ENDIF + + WRITE(FMT_LEN,*) JM + FMT_LAT='(' // TRIM ( FMT_LEN ) // 'F15.10)' + + ! Read lon edges & SIN( lat edges ) on the INPUT GRID + READ( IU_REGRID, '(A15)',IOSTAT=IOS ) HEADER1 + READ( IU_REGRID,FMT_LON,IOSTAT=IOS ) ( INLON(M), M=1,IM+1 ) + READ( IU_REGRID,FMT_LAT,IOSTAT=IOS ) ( INSIN(M), M=1,JM+1 ) + + ! Close file + CLOSE( IU_REGRID ) + + ENDIF + + + + !====================================================================== + ! Regridding + !====================================================================== + + ! Copy the input argument INGRID to a local shadow variable, + ! so that we can preserve the value of INGRID in the calling routine + IN_GRID = INGRID + + ! Convert input to per area units if necessary + IF ( IS_MASS == 1 ) THEN + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( I, J, RLAT, INAREA ) + DO J = 1, JM + RLAT = INSIN(J+1) - INSIN(J) + INAREA = ( 2d0 * PI * Re * RLAT * 1d4 * Re ) / DBLE( IM ) + DO I = 1, IM + IN_GRID(I,J) = IN_GRID(I,J) / INAREA + ENDDO + ENDDO + !$OMP END PARALLEL DO + + ENDIF + + ! dkh debug + ! display total ingrid + IF ( IS_MASS == 3 ) THEN + total = 0d0 + DO J = 1, JM + RLAT = INSIN(J+1) - INSIN(J) + INAREA = ( 2d0 * PI * Re * RLAT * 1d4 * Re ) / DBLE( IM ) + DO I = 1, IM + total = total + IN_GRID(I,J) * INAREA * 1d-4 ! 1d-4 because INAREA is cm2, but HTAP is per m2 + ENDDO + ENDDO + ! and convert from kg per s to kg per month (July) + print*, ' HTAP CO sum in = ', total * 60d0 * 60d0 * 24d0 * 31d0 + ENDIF + +! DO J = 1, JM +! RLAT = INSIN(J+1) - INSIN(J) +! INAREA = ( 2d0 * PI * Re * RLAT * 1d4 * Re ) / DBLE( IM ) +! DO I = 1, IM +! LAT = -179.95d0 + (JM - 1 ) * 0.1d0 +! LON = - 89.95d0 + (IM - 1 ) * 0.1d0 +! IIJJ = GET_IJ(LON, LAT) +! OUTGRID(IIJJ(1),IIJJ(2)) = OUTGRID(IIJJ(1),IIJJ(2)) & +! + IN_GRID(I,J) * INAREA * 1d-4 ! 1d-4 because INAREA is cm2, but HTAP is per m2 +! ENDDO +! ENDDO +! DO J = 1, JJPAR +! DO I = 1, IIPAR +! OUTGRID(I,J) = OUTGRID(I,J) / GET_AREA_CM2( J ) * 1d4 ! cm2 to m2 +! ENDDO +! ENDDO + + ! Call MAP_A2A to do the regridding + CALL MAP_A2A( IM, JM, INLON, INSIN, IN_GRID, & + IIPAR, JJPAR, OUTLON, OUTSIN, OUTGRID, 0, 0 ) + + ! Convert back from "per area" if necessary + IF ( IS_MASS == 1 ) THEN + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + OUTGRID(I,J) = OUTGRID(I,J) * GET_AREA_CM2( J ) + ENDDO + ENDDO + !$OMP END PARALLEL DO + + ENDIF + + ! dkh debug + ! display total ingrid + IF ( IS_MASS == 3 ) THEN + total = 0d0 + DO J = 1, JJPAR + DO I = 1, IIPAR + total = total + OUTGRID(I,J) * GET_AREA_CM2( J ) * 1d-4 ! cm2 to m2 + ENDDO + ENDDO + print*, ' HTAP CO sum in = ', total * 60d0 * 60d0 * 24d0 * 31d0 + ENDIF + END SUBROUTINE DO_REGRID_A2A +!EOC +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: do_regrid_dkh +! +! !DESCRIPTION: Subroutine DO\_REGRID\_DKH regrids 2-D data in the +! horizontal direction. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE DO_REGRID_DKH( FILENAME, IM, JM, INGRID, OUTGRID, IS_MASS, & + netCDF ) +! +! !USES: +! + USE GRID_MOD, ONLY : GET_XEDGE + USE GRID_MOD, ONLY : GET_YSIN + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE GRID_MOD, ONLY : GET_IJ + USE GRID_MOD, ONLY : GET_IJ_GLOBAL + USE FILE_MOD, ONLY : IOERROR + USE inquireMod, ONLY : findFreeLUN + USE GRID_MOD, ONLY : GET_XOFFSET, GET_YOFFSET + +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! Size parameters +! +! !INPUT PARAMETERS: +! + ! Name of file with lon and lat edge information on the INPUT GRID + CHARACTER(LEN=*), INTENT(IN) :: FILENAME + + ! Number of lon centers and lat centers on the INPUT GRID + INTEGER, INTENT(IN) :: IM + INTEGER, INTENT(IN) :: JM + + ! Data array on the input grid + REAL*8, INTENT(IN) :: INGRID(IM,JM) + + ! IS_MASS=0 if data is units of concentration (molec/cm2/s, unitless, etc.) + ! IS_MASS=1 if data is units of mass (kg/yr, etc.) + INTEGER, INTENT(IN) :: IS_MASS + + ! Read from netCDF file? (needed for debugging, will disappear later) + LOGICAL, OPTIONAL,INTENT(IN) :: netCDF +! +! !OUTPUT PARAMETERS: +! + ! Data array on the OUTPUT GRID + REAL*8, INTENT(OUT) :: OUTGRID(IIPAR,JJPAR) +! +! !REVISION HISTORY: + +! 17 Nov 2013 - D. Henze - Initial version, based on A2A +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: I, J + INTEGER :: IOS, M + INTEGER :: IU_REGRID + REAL*8 :: INAREA, RLAT + CHARACTER(LEN=15) :: HEADER1 + CHARACTER(LEN=20) :: FMT_LAT, FMT_LON, FMT_LEN + LOGICAL :: USE_NETCDF + + ! Arrays + REAL*8 :: INLON (IM +1) ! Lon edges on INPUT GRID + REAL*8 :: INSIN (JM +1) ! SIN( lat edges ) on INPUT GRID + REAL*8 :: OUTLON (IIPAR+1) ! Lon edges on OUTPUT GRID + REAL*8 :: OUTSIN (JJPAR+1) ! SIN( lat edges ) on OUTPUT GRID + REAL*8 :: IN_GRID(IM,JM ) ! Shadow variable for INGRID + + ! (yd 2015/6/19 Global offset for nested) + INTEGER :: P, Q + REAL*8 :: P0, Q0 + REAL*8 :: OUTGRID_GLOB(IIPAR_L,JJPAR_L) + !(quzhen 2016/2/1) + INTEGER :: LON_COUNT + INTEGER :: IIJJ_PREV !lon index of previous longitude + REAL*8 :: RATIO + + ! dkh debug + REAL*8 :: total + REAL*4 :: LON + REAL*4 :: LAT + INTEGER :: IIJJ(2) + + !====================================================================== + ! Initialization + ! + ! NOTE: In the near future ASCII input will be replaced by netCDF! + !====================================================================== + + ! Save value of netCDF to shadow variable + IF ( PRESENT( netCDF ) ) THEN + USE_netCDF = netCDF + ELSE + USE_netCDF = .FALSE. + ENDIF + + ! Longitude edges on the OUTPUT GRID + ! NOTE: May have to make OUTLON a 2-D array later for the GI model + DO I = 1, IIPAR+1 + OUTLON(I) = GET_XEDGE( I ) + ENDDO + + ! SIN( lat edges ) on the OUTPUT GRID + ! NOTE: May have to make OUTSIN a 2-D array later for the GI model + DO J = 1, JJPAR+1 + OUTSIN(J) = GET_YSIN( 1, J, 1 ) + ENDDO + + ! Read the input grid specifications + IF ( USE_netCDF ) THEN + + !------------------------------------------ + ! %%% FROM NETCDF FILE %%% + !------------------------------------------ + + ! Read the grid specifications from a netCDF file + CALL READ_INPUT_GRID( IM, JM, FILENAME, INLON, INSIN ) + + ELSE + + !------------------------------------------ + ! %%% FROM ASCII FILE %%% + ! + ! NOTE: Deprecated, will be removed later. + !------------------------------------------ + + ! Find a free file LUN + IU_REGRID = findFreeLUN() + + ! Open file containing lon & lat edges on the INPUT GRID + OPEN( IU_REGRID, FILE=TRIM( FILENAME ), STATUS='OLD', IOSTAT=IOS ) + IF ( IOS /= 0 ) CALL IOERROR( IOS, IU_REGRID, 'latlonread' ) + + ! Create the approprate FORMAT strings + WRITE(FMT_LEN,*) IM+1 + + ! NOTE: If the resolution of the grid is high enough, we have + ! to allow for an extra digit in the input file. This will + ! become obsolete once we migrate to netCDF format (bmy, 8/23/12) + IF ( IM > 1000 ) THEN + FMT_LON='(' // TRIM ( FMT_LEN ) // 'F10.4)' ! For hi-res grids + ELSE + FMT_LON='(' // TRIM ( FMT_LEN ) // 'F9.3)' ! For all other grids + ENDIF + + WRITE(FMT_LEN,*) JM + FMT_LAT='(' // TRIM ( FMT_LEN ) // 'F15.10)' + + ! Read lon edges & SIN( lat edges ) on the INPUT GRID + READ( IU_REGRID, '(A15)',IOSTAT=IOS ) HEADER1 + READ( IU_REGRID,FMT_LON,IOSTAT=IOS ) ( INLON(M), M=1,IM+1 ) + READ( IU_REGRID,FMT_LAT,IOSTAT=IOS ) ( INSIN(M), M=1,JM+1 ) + + ! Close file + CLOSE( IU_REGRID ) + + ENDIF + + + + !====================================================================== + ! Regridding + !====================================================================== + + ! Copy the input argument INGRID to a local shadow variable, + ! so that we can preserve the value of INGRID in the calling routine + IN_GRID = INGRID + + ! Convert input to per area units if necessary + IF ( IS_MASS == 1 ) THEN + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( I, J, RLAT, INAREA ) + DO J = 1, JM + RLAT = INSIN(J+1) - INSIN(J) + INAREA = ( 2d0 * PI * Re * RLAT * 1d4 * Re ) / DBLE( IM ) + DO I = 1, IM + IN_GRID(I,J) = IN_GRID(I,J) / INAREA + ENDDO + ENDDO + !$OMP END PARALLEL DO + + ENDIF + + DO J = 1, JM + RLAT = INSIN(J+1) - INSIN(J) + INAREA = ( 2d0 * PI * Re * RLAT * 1d4 * Re ) / DBLE( IM ) + DO I = 1, IM + LON = 0.05d0 + (I - 1 ) * 0.1d0 + IF ( LON > 180d0 ) LON = LON - 360d0 + LAT = - 89.95d0 + (J - 1 ) * 0.1d0 +#if .not. defined(NESTED_CH) + IIJJ = GET_IJ(LON, LAT) +#elif defined(NESTED_CH) + !(quzhen 2014/12/31) + IIJJ = GET_IJ_GLOBAL(LON, LAT) + RATIO = 1d0 + + !(quzhen 2016/2/1 ONLY DO THIS IN NESTED_CH DOMAIN) + IF (LON .GT. 69.65 .AND. LON .LT. 150.35) THEN !in domain + IF (MOD(IIJJ(1), 3) .EQ. 1) THEN + ! lower boundary + IF (IIJJ(1) .NE. IIJJ_PREV) THEN ! a new grid + RATIO = (0.75 - 2./3.)/0.1 + LON_COUNT = 0 + ENDIF + LON_COUNT = LON_COUNT + 1 + IF(LON_COUNT .EQ. 6) THEN + ! upper boundary + RATIO = (1./3. - 0.25)/0.1 + ENDIF + ENDIF + + IF (MOD(IIJJ(1), 3) .EQ. 2) THEN ! 2nd pattern + ! lower boundary + IF (IIJJ(1) .NE. IIJJ_PREV) THEN + RATIO = (0.35 - 1./3.)/0.1 + LON_COUNT = 0 + ENDIF + LON_COUNT = LON_COUNT + 1 + IF(LON_COUNT .EQ. 7) THEN + ! upper boundary + RATIO = 0.05/0.1 + ENDIF + ENDIF + + IF (MOD(IIJJ(1), 3) .EQ. 0) THEN ! 3rd pattern + ! lower boundary + IF (IIJJ(1) .NE. IIJJ_PREV) THEN + !INAREA = INAREA * 0.05/0.1 + RATIO = 0.05/0.1 + LON_COUNT = 0 + ENDIF + LON_COUNT = LON_COUNT + 1 + !print*,'quzhen 3rd pattern,lon_count',lon_count, ratio + IF(LON_COUNT .EQ. 7) THEN + ! upper boundary + !INAREA = INAREA * (2./3. - 0.65)/0.1 + RATIO = (2./3. - 0.65)/0.1 + ENDIF + ENDIF + + ENDIF + IIJJ_PREV = IIJJ(1) + + !(quzhen 2015/1/23 regrid globally first) + OUTGRID_GLOB(IIJJ(1),IIJJ(2)) = OUTGRID_GLOB(IIJJ(1),IIJJ(2)) & + + IN_GRID(I,J) * INAREA * 1d-4 * RATIO ! 1d-4 because INAREA is cm2, but HTAP is per m2 +#endif + +#if .not. defined(NESTED_CH) + OUTGRID(IIJJ(1),IIJJ(2)) = OUTGRID(IIJJ(1),IIJJ(2)) & + + IN_GRID(I,J) * INAREA * 1d-4 ! 1d-4 because INAREA is cm2, but HTAP is per m2 +#endif + + ENDDO + ENDDO + +#if (defined (NESTED_NA) || defined (NESTED_CH) || defined (NESTED_SD) ) + !(quzhen 2015/1/23 select data in the window area) + P0 = GET_XOFFSET( GLOBAL=.TRUE. ) + Q0 = GET_YOFFSET( GLOBAL=.TRUE. ) + + DO P = 1, IIPAR + DO Q = 1, JJPAR + OUTGRID( P, Q ) = OUTGRID_GLOB ( P+P0, Q+Q0) + ENDDO + ENDDO +#endif + + DO J = 1, JJPAR + DO I = 1, IIPAR + OUTGRID(I,J) = OUTGRID(I,J) / GET_AREA_CM2( J ) * 1d4 ! cm2 to m2 + ENDDO + ENDDO + + ! Convert back from "per area" if necessary + IF ( IS_MASS == 1 ) THEN + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + OUTGRID(I,J) = OUTGRID(I,J) * GET_AREA_CM2( J ) + ENDDO + ENDDO + !$OMP END PARALLEL DO + + ENDIF + + END SUBROUTINE DO_REGRID_DKH +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: map_a2a +! +! !DESCRIPTION: Subroutine MAP\_A2A is a horizontal arbitrary grid to arbitrary +! grid conservative high-order mapping regridding routine by S-J Lin. +!\\ +!\\ +! !INTERFACE: +! +! (1 ) INLON (REAL*8 ) : Longitude edges of input grid +! (2 ) INSIN (REAL*8 ) : Sine of input grid latitude edges +! (3 ) INGRID (REAL*8 ) : Data array to be regridded + + SUBROUTINE map_a2a( im, jm, lon1, sin1, q1, & + in, jn, lon2, sin2, q2, ig, iv) +! +! !INPUT PARAMETERS: +! + ! Longitude and Latitude dimensions of INPUT grid + INTEGER, INTENT(IN) :: im, jm + + ! Longitude and Latitude dimensions of OUTPUT grid + INTEGER, INTENT(IN) :: in, jn + + ! IG=0: pole to pole; + ! IG=1 J=1 is half-dy north of south pole + INTEGER, INTENT(IN) :: ig + + ! IV=0: Regrid scalar quantity + ! IV=1: Regrid vector quantity + INTEGER, INTENT(IN) :: iv + + ! Longitude edges (degrees) of INPUT and OUTPUT grids + REAL*8, INTENT(IN) :: lon1(im+1), lon2(in+1) + + ! Sine of Latitude Edges (radians) of INPUT and OUTPUT grids + REAL*8, INTENT(IN) :: sin1(jm+1), sin2(jn+1) + + ! Quantity on INPUT grid + REAL*8, INTENT(IN) :: q1(im,jm) +! +! !OUTPUT PARAMETERS: +! + ! Regridded quantity on OUTPUT grid + REAL*8, INTENT(OUT) :: q2(in,jn) +! +! !REVISION HISTORY: +! (1) Original subroutine by S-J Lin. Converted to F90 freeform format +! and inserted into "Geos3RegridModule" by Bob Yantosca (9/21/00) +! (2) Added F90 type declarations to be consistent w/ TypeModule.f90. +! Also updated comments. (bmy, 9/21/00) +! 21 Sep 2000 - R. Yantosca - Initial version +! 27 Aug 2012 - R. Yantosca - Add parallel DO loops +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: i,j,k + REAL*8 :: qtmp(in,jm) + + !=================================================================== + ! E-W regridding + !=================================================================== + IF ( im .eq. in ) THEN + + ! Don't call XMAP if both grids have the same # of longitudes + ! but save the input data in the QTMP array + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( I, J ) + DO j=1,jm-ig + DO i=1,im + qtmp(i,j+ig) = q1(i,j+ig) + ENDDO + ENDDO + !$OMP END PARALLEL DO + + ELSE + + ! Otherwise, call XMAP to regrid in the E-W direction + CALL xmap(im, jm-ig, lon1, q1(1,1+ig),in, lon2, qtmp(1,1+ig) ) + + ENDIF + + !=================================================================== + ! N-S regridding + !=================================================================== + IF ( jm .eq. jn ) THEN + + ! Don't call XMAP if both grids have the same # of longitudes, + ! but assign the value of QTMP to the output Q2 array + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( I, J ) + DO j=1,jm-ig + DO i=1,in + q2(i,j+ig) = qtmp(i,j+ig) + ENDDO + ENDDO + !$OMP END PARALLEL DO + + ELSE + + ! Otherwise, call YMAP to regrid in the N-S direction + CALL ymap(in, jm, sin1, qtmp(1,1+ig), jn, sin2, q2(1,1+ig), ig, iv) + + ENDIF + + END SUBROUTINE map_a2a +!EOC +!------------------------------------------------------------------------------ +! Prasad Kasibhatla - Duke University ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: ymap +! +! !DESCRIPTION: Routine to perform area preserving mapping in N-S from an +! arbitrary resolution to another. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE ymap(im, jm, sin1, q1, jn, sin2, q2, ig, iv) +! +! !INPUT PARAMETERS: +! + + ! original E-W dimension + INTEGER, INTENT(IN) :: im + + ! original N-S dimension + INTEGER, INTENT(IN) :: jm + + ! Target N-S dimension + INTEGER, INTENT(IN) :: jn + + ! IG=0: scalars from SP to NP (D-grid v-wind is also IG=0) + ! IG=1: D-grid u-wind + INTEGER, INTENT(IN) :: ig + + ! IV=0: scalar; + ! IV=1: vector + INTEGER, INTENT(IN) :: iv + + ! Original southern edge of the cell sin(lat1) + REAL*8, INTENT(IN) :: sin1(jm+1-ig) + + ! Original data at center of the cell + REAL*8, INTENT(IN) :: q1(im,jm) + + ! Target cell's southern edge sin(lat2) + REAL*8, INTENT(IN) :: sin2(jn+1-ig) +! +! !OUTPUT PARAMETERS: +! + ! Mapped data at the target resolution + REAL*8, INTENT(OUT) :: q2(im,jn) +! +! !REMARKS: +! +! sin1 (1) = -1 must be south pole; sin1(jm+1)=1 must be N pole. +! +! sin1(1) < sin1(2) < sin1(3) < ... < sin1(jm) < sin1(jm+1) +! sin2(1) < sin2(2) < sin2(3) < ... < sin2(jn) < sin2(jn+1)! +! +! !AUTHOR: +! Developer: Prasad Kasibhatla +! March 6, 2012 +! +! !REVISION HISTORY +! 06 Mar 2012 - P. Kasibhatla - Initial version +! 27 Aug 2012 - R. Yantosca - Added parallel DO loops +! 27 Aug 2012 - R. Yantosca - Change REAL*4 variables to REAL*8 to better +! ensure numerical stability +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: i, j0, m, mm, j + REAL*8 :: dy1(jm) + REAL*8 :: dy +!------------------------------------------------------------------------------ +! Prior to 8/27/12: +! Change REAL*4 to REAL*8, to eliminate numerical noise (bmy, 8/27/12) +! REAL*4 :: qsum, sum +!------------------------------------------------------------------------------ + REAL*8 :: qsum, sum + + ! YMAP begins here! + do j=1,jm-ig + dy1(j) = sin1(j+1) - sin1(j) + enddo + + !=============================================================== + ! Area preserving mapping + !=============================================================== + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( I, J0, J, M, QSUM, MM, DY ) + do 1000 i=1,im + j0 = 1 + do 555 j=1,jn-ig + do 100 m=j0,jm-ig + + !========================================================= + ! locate the southern edge: sin2(i) + !========================================================= + if(sin2(j) .ge. sin1(m) .and. sin2(j) .le. sin1(m+1)) then + + if(sin2(j+1) .le. sin1(m+1)) then + + ! entire new cell is within the original cell + q2(i,j)=q1(i,m) + j0 = m + goto 555 + else + + ! South most fractional area + qsum=(sin1(m+1)-sin2(j))*q1(i,m) + + do mm=m+1,jm-ig + + ! locate the northern edge: sin2(j+1) + if(sin2(j+1) .gt. sin1(mm+1) ) then + + ! Whole layer + qsum = qsum + dy1(mm)*q1(i,mm) + else + + ! North most fractional area + dy = sin2(j+1)-sin1(mm) + qsum=qsum+dy*q1(i,mm) + j0 = mm + goto 123 + endif + enddo + goto 123 + endif + endif +100 continue +123 q2(i,j) = qsum / ( sin2(j+1) - sin2(j) ) +555 continue +1000 continue + !$OMP END PARALLEL DO + + !=================================================================== + ! Final processing for poles + !=================================================================== + if ( ig .eq. 0 .and. iv .eq. 0 ) then + +!------------------------------------------------------------------------------ +! Prior to 8/27/12: +! Change REAL*4 to REAL*8, to eliminate numerical noise (bmy, 8/27/12) +! ! South pole +! sum = 0. +! do i=1,im +! sum = sum + q2(i,1) +! enddo +! +! sum = sum / float(im) +! do i=1,im +! q2(i,1) = sum +! enddo +! +! ! North pole: +! sum = 0. +! do i=1,im +! sum = sum + q2(i,jn) +! enddo +! +! sum = sum / float(im) +! do i=1,im +! q2(i,jn) = sum +! enddo +!------------------------------------------------------------------------------ + ! South pole + sum = 0.d0 + do i=1,im + sum = sum + q2(i,1) + enddo + + sum = sum / DBLE( im ) + do i=1,im + q2(i,1) = sum + enddo + + ! North pole: + sum = 0.d0 + do i=1,im + sum = sum + q2(i,jn) + enddo + + sum = sum / DBLE( im ) + do i=1,im + q2(i,jn) = sum + enddo + + endif + + END SUBROUTINE YMAP +!EOC +!------------------------------------------------------------------------------ +! Prasad Kasibhatla - Duke University ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: xmap +! +! !DESCRIPTION: Routine to perform area preserving mapping in E-W from an +! arbitrary resolution to another. +! Periodic domain will be assumed, i.e., the eastern wall bounding cell +! im is lon1(im+1) = lon1(1); Note the equal sign is true geographysically. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE xmap(im, jm, lon1, q1, in, lon2, q2) +! +! !INPUT PARAMETERS: +! + ! Original E-W dimension + INTEGER, INTENT(IN) :: im + + ! Target E-W dimension + INTEGER, INTENT(IN) :: in + + ! Original N-S dimension + INTEGER, INTENT(IN) :: jm + + ! Original western edge of the cell + REAL*8, INTENT(IN) :: lon1(im+1) + + ! Original data at center of the cell + REAL*8, INTENT(IN) :: q1(im,jm) + + ! Target cell's western edge + REAL*8, INTENT(IN) :: lon2(in+1) +! +! !OUTPUT PARAMETERS: +! + ! Mapped data at the target resolution + REAL*8, INTENT(OUT) :: q2(in,jm) +! +! !REMARKS: +! lon1(1) < lon1(2) < lon1(3) < ... < lon1(im) < lon1(im+1) +! lon2(1) < lon2(2) < lon2(3) < ... < lon2(in) < lon2(in+1) +! +! !AUTHOR: +! Developer: Prasad Kasibhatla +! March 6, 2012 +! +! !REVISION HISTORY +! 06 Mar 2012 - P. Kasibhatla - Initial version +! 27 Aug 2012 - R. Yantosca - Added parallel DO loops +! 27 Aug 2012 - R. Yantosca - Change REAL*4 variables to REAL*8 to better +! ensure numerical stability +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: i1, i2, i, i0, m, mm, j + REAL*8 :: qtmp(-im:im+im) + REAL*8 :: x1(-im:im+im+1) + REAL*8 :: dx1(-im:im+im) + REAL*8 :: dx +!------------------------------------------------------------------------------ +! Prior to 8/27/12: +! Change REAL*4 to REAL*8, to eliminate numerical noise (bmy, 8/27/12) +! REAL*4 :: qsum +!------------------------------------------------------------------------------ + REAL*8 :: qsum + LOGICAL :: found + + ! XMAP begins here! + do i=1,im+1 + x1(i) = lon1(i) + enddo + + do i=1,im + dx1(i) = x1(i+1) - x1(i) + enddo + + !=================================================================== + ! check to see if ghosting is necessary + ! Western edge: + !=================================================================== + found = .false. + i1 = 1 + do while ( .not. found ) + if( lon2(1) .ge. x1(i1) ) then + found = .true. + else + i1 = i1 - 1 + if (i1 .lt. -im) then + write(6,*) 'failed in xmap western edge ' + stop + else + x1(i1) = x1(i1+1) - dx1(im+i1) + dx1(i1) = dx1(im+i1) + endif + endif + enddo + + !=================================================================== + ! Eastern edge: + !=================================================================== + found = .false. + i2 = im+1 + do while ( .not. found ) + if( lon2(in+1) .le. x1(i2) ) then + found = .true. + else + i2 = i2 + 1 + if (i2 .gt. 2*im) then + write(6,*) 'failed in xmap eastern edge' + stop + else + dx1(i2-1) = dx1(i2-1-im) + x1(i2) = x1(i2-1) + dx1(i2-1) + endif + endif + enddo + + !$OMP PARALLEL DO & + !$OMP DEFAULT( SHARED ) & + !$OMP PRIVATE( J, QTMP, I, I0, M, QSUM, MM, DX ) + do 1000 j=1,jm + + !================================================================= + ! Area preserving mapping + !================================================================ + + qtmp(0)=q1(im,j) + do i=1,im + qtmp(i)=q1(i,j) + enddo + qtmp(im+1)=q1(1,j) + + ! check to see if ghosting is necessary + ! Western edge + if ( i1 .le. 0 ) then + do i=i1,0 + qtmp(i) = qtmp(im+i) + enddo + endif + + ! Eastern edge: + if ( i2 .gt. im+1 ) then + do i=im+1,i2-1 + qtmp(i) = qtmp(i-im) + enddo + endif + + i0 = i1 + + do 555 i=1,in + do 100 m=i0,i2-1 + + !============================================================= + ! locate the western edge: lon2(i) + !============================================================= + if(lon2(i) .ge. x1(m) .and. lon2(i) .le. x1(m+1)) then + + if(lon2(i+1) .le. x1(m+1)) then + + ! entire new grid is within the original grid + q2(i,j)=qtmp(m) + i0 = m + goto 555 + else + + ! Left most fractional area + qsum=(x1(m+1)-lon2(i))*qtmp(m) + do mm=m+1,i2-1 + + ! locate the eastern edge: lon2(i+1) + if(lon2(i+1) .gt. x1(mm+1) ) then + + ! Whole layer + qsum = qsum + dx1(mm)*qtmp(mm) + + else + ! Right most fractional area + dx = lon2(i+1)-x1(mm) + qsum=qsum+dx*qtmp(mm) + i0 = mm + goto 123 + endif + enddo + goto 123 + endif + endif +100 continue +123 q2(i,j) = qsum / ( lon2(i+1) - lon2(i) ) +555 continue +1000 continue + !$OMP END PARALLEL DO + + END SUBROUTINE xmap +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: read_input_grid +! +! !DESCRIPTION: Routine to read variables and attributes from a netCDF +! file. This routine was automatically generated by the Perl script +! NcdfUtilities/perl/ncCodeRead. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE READ_INPUT_GRID( IM, JM, fileName, lon_edges, lat_sines ) +! +! !USES: +! + ! Modules for netCDF read + USE m_netcdf_io_open + USE m_netcdf_io_get_dimlen + USE m_netcdf_io_read + USE m_netcdf_io_readattr + USE m_netcdf_io_close + + IMPLICIT NONE + +# include "netcdf.inc" +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: IM ! # of longitudes + INTEGER, INTENT(IN) :: JM ! # of latitudes + CHARACTER(LEN=*), INTENT(IN) :: fileName ! File w/ grid info +! +! !OUTPUT PARAMETERS: +! + REAL*8, INTENT(OUT) :: lon_edges(IM+1) ! Lon edges [degrees] + REAL*8, INTENT(OUT) :: lat_sines(JM+1) ! SIN( latitude edges ) +! +! !REMARKS: +! Created with the ncCodeRead script of the NcdfUtilities package, +! with subsequent hand-editing. +! +! !REVISION HISTORY: +! 23 Aug 2012 - R. Yantosca - Initial version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: fId ! netCDF file ID + + ! Arrays + INTEGER :: st1d(1), ct1d(1) ! netCDF start & count + + !====================================================================== + ! Read data from file + !====================================================================== + + ! Open file for reading + CALL Ncop_Rd( fId, TRIM( fileName ) ) + + ! Read lon_edges from file + st1d = (/ 1 /) + ct1d = (/ IM+1 /) + CALL NcRd( lon_edges, fId, "lon_edges", st1d, ct1d ) + + ! Read lat_sines from file + st1d = (/ 1 /) + ct1d = (/ JM+1 /) + CALL NcRd( lat_sines, fId, "lat_sines", st1d, ct1d ) + + ! Close netCDF file + CALL NcCl( fId ) + + END SUBROUTINE READ_INPUT_GRID +!EOC +END MODULE REGRID_A2A_MOD diff --git a/code/retro_mod.f b/code/retro_mod.f new file mode 100644 index 0000000..fda0e59 --- /dev/null +++ b/code/retro_mod.f @@ -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 diff --git a/code/ruralbox.f b/code/ruralbox.f new file mode 100644 index 0000000..f671d7e --- /dev/null +++ b/code/ruralbox.f @@ -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 diff --git a/code/scale_anthro_mod.f b/code/scale_anthro_mod.f new file mode 100644 index 0000000..b5b5b40 --- /dev/null +++ b/code/scale_anthro_mod.f @@ -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 + + diff --git a/code/schem.f b/code/schem.f new file mode 100644 index 0000000..ea17c05 --- /dev/null +++ b/code/schem.f @@ -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 diff --git a/code/seasalt_mod.f b/code/seasalt_mod.f new file mode 100644 index 0000000..5018bb1 --- /dev/null +++ b/code/seasalt_mod.f @@ -0,0 +1,1454 @@ +! $Id: seasalt_mod.f,v 1.2 2010/03/09 15:03:46 daven Exp $ + MODULE SEASALT_MOD +! +!****************************************************************************** +! Module SEASALT_MOD contains arrays and routines for performing either a +! coupled chemistry/aerosol run or an offline seasalt aerosol simulation. +! Original code taken from Mian Chin's GOCART model and modified accordingly. +! (bec, rjp, bmy, 6/22/00, 7/18/08) +! +! Seasalt aerosol species: (1) Accumulation mode (usually 0.1 - 0.5 um) +! (2) Coarse mode (usually 0.5 - 10.0 um) +! +! NOTE: You can change the bin sizes for accumulation mode and coarse +! mode seasalt in the "input.geos" file in v7-yy-zz and higher. +! +! Module Variables: +! ============================================================================ +! (1 ) DRYSALA (INTEGER) : Drydep index for accumulation mode sea salt +! (2 ) DRYSALC (INTEGER) : Drydep index for coarse mode sea salt +! (3 ) NSALT (INTEGER) : Number of sea salt tracers +! (4 ) IDDEP (INTEGER) : Drydep index array for sea salt tracers +! (5 ) REDGE (REAL*8 ) : Array for edges of seasalt radius bins +! (6 ) RMID (REAL*8 ) : Array for centers of seasalt radius bins +! (7 ) SRC (REAL*8 ) : Array for baseline seasalt emission/bin [kg/m2] +! (7 ) SRC_N (REAL*8 ) : Array for baseline seasalt emission/bin [#/m2] +! (8 ) SS_DEN (REAL*8 ) : Sea salt density [kg/m3] +! (9 ) ALK_EMIS (REAL*8 ) : Array for alkalinity [kg] +! (10) N_DENS (REAL*8 ) : Number density of seasalt emissions [#/m3] +! (11) SALT_V (REAL*8) : Log-normal volum size distribution for sea salt +! +! Module Routines: +! ============================================================================ +! (1 ) CHEMSEASALT : Driver routine for sea salt loss processes +! (2 ) WET SETTLING : Routine which performs wet settling of sea salt +! (3 ) DRY_DEPOSITION : Routine which performs dry deposition of sea salt +! (4 ) EMISSSEASALT : Driver routine for sea salt emissions +! (5 ) SRCSALT : Updates surface mixing ratio for sea salt +! (6 ) GET_ALK : Gets the alkalinity of seasalt emissions +! (6 ) INIT_SEASALT : Allocates all module arrays +! (7 ) CLEANUP_SEASALT : Deallocates all module arrays +! +! GEOS-CHEM modules referenced by "seasalt_mod.f": +! ============================================================================ +! (1 ) dao_mod.f : Module w/ arrays for GMAO met fields +! (2 ) diag_mod.f : Module w/ GEOS-CHEM diagnostic arrays +! (3 ) drydep_mod.f : Module w/ GEOS-CHEM drydep routines +! (4 ) error_mod.f : Module w/ I/O error and NaN check routines +! (5 ) grid_mod.f : Module w/ horizontal grid information +! (6 ) logical_mod.f : Module w/ GEOS-CHEM logical switches +! (7 ) pbl_mix_mod.f : Module w/ routines for PBL height & mixing +! (8 ) pressure_mod.f : Module w/ routines to compute P(I,J,L) +! (9 ) time_mod.f : Module w/ routines to compute date & time +! (10) tracer_mod.f : Module w/ GEOS-CHEM tracer array STT etc. +! (11) tracerid_mod.f : Module w/ pointers to tracers & emissions +! +! References: +! ============================================================================ +! (1 ) Chin, M., P. Ginoux, S. Kinne, B. Holben, B. Duncan, R. Martin, +! J. Logan, A. Higurashi, and T. Nakajima, "Tropospheric aerosol +! optical thickness from the GOCART model and comparisons with +! satellite and sunphotometers measurements", J. Atmos Sci., 2001. +! (2 ) Gong, S., L. Barrie, and J.-P. Blanchet, "Modeling sea-salt +! aerosols in the atmosphere. 1. Model development", J. Geophys. Res., +! v. 102, 3805-3818, 1997. +! +! NOTES: +! (1 ) Now references "logical_mod.f" and "tracer_mod.f". Comment out +! SS_SIZE, this has been replaced by SALA_REDGE_um and SALC_REDGE_um +! from "tracer_mod.f". Increased NR_MAX to 200. (bmy, 7/20/04) +! (2 ) Added error check in EMISSSEASALT (bmy, 1/20/05) +! (3 ) Now references "pbl_mix_mod.f" (bmy, 2/22/05) +! (4 ) Added routine GET_ALK to account for alkalinity. (bec, bmy, 4/13/05) +! (5 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +! (6 ) Now only call dry deposition routine if LDRYD=T (bec, bmy, 5/23/06) +! (7 ) Remove unused variables from GET_ALK. Also fixed variable declaration +! bug in WET_SETTLING. (bec, bmy, 9/5/06) +! (8 ) Extra error check for low RH in WET_SETTLING (phs, 6/11/08) +! (9 ) Bug fix to remove a double-substitution in GET_ALK (bec, bmy, 7/18/08) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "seasalt_mod.f" + !================================================================= + + ! Make everyting PRIVATE ... + PRIVATE + + ! ... except these variables (jaegle 5/11/11) + PUBLIC :: SALT_V + PUBLIC :: DMID + + ! ... except these routines + PUBLIC :: CHEMSEASALT + PUBLIC :: EMISSSEASALT + PUBLIC :: CLEANUP_SEASALT + PUBLIC :: GET_ALK + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Scalars + INTEGER, PARAMETER :: NSALT = 2 + INTEGER, PARAMETER :: NR_MAX = 200 + INTEGER :: DRYSALA, DRYSALC + + ! Arrays + INTEGER :: IDDEP(NSALT) + REAL*8, ALLOCATABLE :: REDGE(:,:) + REAL*8, ALLOCATABLE :: RMID(:,:) + REAL*8, ALLOCATABLE :: SRC(:,:) + REAL*8, ALLOCATABLE :: SRC_N(:,:) + REAL*8, ALLOCATABLE :: ALK_EMIS(:,:,:,:) + REAL*8, ALLOCATABLE :: N_DENS(:,:,:,:) + ! Add SALT_V and DMID (jaegle 5/11/11) + REAL*8, ALLOCATABLE :: SALT_V(:) + REAL*8, ALLOCATABLE :: DMID(:) + REAL*8 :: SS_DEN(NSALT) = (/ 2200.d0, 2200.d0 /) + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHEMSEASALT +! +!****************************************************************************** +! Subroutine CHEMSEASALT is the interface between the GEOS-CHEM main program +! and the seasalt chemistry routines that mostly calculates seasalt dry +! deposition (rjp, bmy, 1/24/02, 5/23/06) +! +! NOTES: +! (1 ) Now reference STT from "tracer_mod.f". Now references LPRT from +! "logical_mod.f" (bmy, 7/20/04) +! (2 ) Now only call DRY_DEPOSITION if LDRYD=T (bec, bmy, 5/23/06) +!****************************************************************************** +! + ! References to F90 modules + USE DRYDEP_MOD, ONLY : DEPNAME, NUMDEP + USE ERROR_MOD, ONLY : DEBUG_MSG + USE LOGICAL_MOD, ONLY : LPRT, LDRYD + USE TRACER_MOD, ONLY : STT + USE TRACERID_MOD, ONLY : IDTSALA, IDTSALC + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: N + + !================================================================= + ! CHEMSEASALT begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + + ! Initialize (if necessary) + CALL INIT_SEASALT + + ! Find drydep species in DEPSAV + DO N = 1, NUMDEP + SELECT CASE ( TRIM( DEPNAME(N) ) ) + CASE ( 'SALA' ) + DRYSALA = N + CASE ( 'SALC' ) + DRYSALC = N + CASE DEFAULT + ! Nothing + END SELECT + ENDDO + + ! Store in IDDEP array + IDDEP(1) = DRYSALA + IDDEP(2) = DRYSALC + + ! Reset first-time flag + FIRST = .FALSE. + ENDIF + + !================================================================= + ! Maybe someday we should merge these two separate calculations + ! into one (rjp, 4/3/04) + !================================================================= + + !------------------- + ! Accumulation mode + !------------------- + CALL WET_SETTLING( STT(:,:,:,IDTSALA), 1 ) + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSEASALT: WET_SET, Accum' ) + + IF ( LDRYD ) THEN + ! If LNLPBL (non local PBL mixing) is turned on, do sea salt + ! dry deposition in vdiff as for all the other aerosols (jaegle 5/11/11) + !IF ( LDRYD .AND. .NOT. LNLPBL ) THEN ! This is not yet supported for adjoint code + CALL DRY_DEPOSITION( STT(:,:,:,IDTSALA), 1 ) + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSEASALT: DRY_DEP, Accum' ) + ENDIF + + !------------------- + ! Coarse mode + !------------------- + CALL WET_SETTLING( STT(:,:,:,IDTSALC), 2 ) + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSEASALT: WET_SET, Coarse' ) + + IF ( LDRYD ) THEN + ! If LNLPBL (non local PBL mixing) is turned on, do sea salt + ! dry deposition in vdiff as for all the other aerosols (jaegle 5/11/11) + !IF ( LDRYD .AND. .NOT. LNLPBL ) THEN ! This is not yet supported for adjoint code + CALL DRY_DEPOSITION( STT(:,:,:,IDTSALC), 2 ) + IF ( LPRT ) CALL DEBUG_MSG( '### CHEMSEASALT: DRY_DEP, Coarse') + ENDIF + + ! Return to calling program + END SUBROUTINE CHEMSEASALT + +!------------------------------------------------------------------------------ + + SUBROUTINE WET_SETTLING( TC, N ) +! +!****************************************************************************** +! Subroutine WET_SETTLING performs wet settling of sea salt. +! (bec, rjp, bmy, 4/20/04, 6/11/08) +! +! Arguments as Input: +! ============================================================================ +! (1 ) TC (REAL*8 ) : Sea salt tracer [kg] +! (2 ) N (INTEGER) : N=1 is accum mode; N=2 is coarse mode +! +! Arguments as Output: +! ============================================================================ +! (1 ) TC (REAL*8 ) : Contains modified tracer +! +! NOTES: +! (1 ) Now references SALA_REDGE_um and SALC_REDGE_um from "tracer_mod.f" +! (bmy, 7/20/04) +! (2 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +! (3 ) Bug fix: DTCHEM has to be REAL*8, not integer. (bmy, 9/7/06) +! (4 ) Now limit relative humidity to [tiny(real*8),0.99] range for DLOG +! argument (phs, 5/1/08) +! (5 ) Update sea salt density calculation using Tang et al. (1997) (bec, jaegle 5/11/11) +! (6 ) Update hygroscopic growth for sea salt using Lewis and Schwartz (2006) and and density +! calculation based on Tang et al. (1997) (bec, jaegle 5/11/11) +! (7 ) Itegrate settling velocity over entire size distribution (jaegle 5/11/11) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : T, BXHEIGHT, RH + USE DIAG_MOD, ONLY : AD44 + USE DRYDEP_MOD, ONLY : DEPSAV + USE PRESSURE_MOD, ONLY : GET_PCENTER + USE TRACER_MOD, ONLY : SALA_REDGE_um, SALC_REDGE_um, XNUMOL + USE TRACERID_MOD, ONLY : IDTSALA, IDTSALC + USE TIME_MOD, ONLY : GET_TS_CHEM + USE GRID_MOD, ONLY : GET_AREA_CM2 + ! add (jaegle 5/11/11) + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! g0 +# include "CMN_DIAG" ! ND44 + + ! Argumetns + INTEGER, INTENT(IN) :: N + REAL*8, INTENT(INOUT) :: TC(IIPAR,JJPAR,LLPAR) + + ! Local variables + INTEGER :: I, J, L + REAL*8 :: DELZ, DELZ1, REFF, DEN + REAL*8 :: P, DP, PDP, TEMP + REAL*8 :: CONST, SLIP, VISC, FAC1 + REAL*8 :: FAC2, FLUX, AREA_CM2, RHB + ! replace RCM with RUM (radis in micron) jaegle 5/11/11 + REAL*8 :: RUM, RWET, RATIO_R, RHO + REAL*8 :: TOT1, TOT2, DTCHEM + REAL*8 :: VTS(LLPAR) + REAL*8 :: TC0(LLPAR) + ! New variables (jaegle 5/11/11) + REAL*8 :: SW + REAL*8 :: R0, R1, NR, DEDGE, SALT_MASS + REAL*8 :: SALT_MASS_TOTAL, VTS_WEIGHT, DMIDW + REAL*8 :: WTP, RHO1 + INTEGER :: ID + LOGICAL, SAVE :: FIRST = .TRUE. + + ! Parameters + REAL*8, PARAMETER :: C1 = 0.7674d0 + REAL*8, PARAMETER :: C2 = 3.079d0 + REAL*8, PARAMETER :: C3 = 2.573d-11 + REAL*8, PARAMETER :: C4 = -1.424d0 + ! Parameters for polynomial coefficients to derive seawater + ! density. From Tang et al. (1997) (jaegle 5/11/11) + REAL*8, PARAMETER :: A1 = 7.93d-3 + REAL*8, PARAMETER :: A2 = -4.28d-5 + REAL*8, PARAMETER :: A3 = 2.52d-6 + REAL*8, PARAMETER :: A4 = -2.35d-8 + ! increment of radius for integration of settling velocity (um) + REAL*8, PARAMETER :: DR = 5.d-2 + ! parameter for convergence + REAL*8, PARAMETER :: EPSI = 1.0D-4 + ! parameters for assumed size distribution of acc and coarse mode + ! sea salt aerosols (jaegle 5/11/11) + ! geometric dry mean diameters (microns) + REAL*8, PARAMETER :: RG_A = 0.085d0 + REAL*8, PARAMETER :: RG_C = 0.4d0 + ! sigma of the size distribution + REAL*8, PARAMETER :: SIG_A = 1.5d0 + REAL*8, PARAMETER :: SIG_C = 1.8d0 + + + !================================================================= + ! WET_SETTLING begins here! + !================================================================= + + ! Chemistry timestep [s] + DTCHEM = GET_TS_CHEM() * 60d0 + + ! Sea salt density [kg/m3] + DEN = SS_DEN( N ) + + ! Seasalt effective radius (i.e. midpt of radius bin) [m] + SELECT CASE ( N ) + + ! Accum mode + ! add R0 and R1 = edges if the sea salt size bins (jaegle 5/11/11) + CASE( 1 ) + REFF = 0.5d-6 * ( SALA_REDGE_um(1) + SALA_REDGE_um(2) ) + R0 = SALA_REDGE_um(1) + R1 = SALA_REDGE_um(2) + + ! Coarse mode + CASE( 2 ) + REFF = 0.5d-6 * ( SALC_REDGE_um(1) + SALC_REDGE_um(2) ) + R0 = SALC_REDGE_um(1) + R1 = SALC_REDGE_um(2) + + END SELECT + + ! Number of dry radius size bins between lowest radius (accumulation + ! mode) and largest radii (coarse mode) (jaegle 5/11/11) + + NR = INT( ( ( SALC_REDGE_um(2) - SALA_REDGE_um(1) ) / DR ) + & + 0.5d0 ) + + ! Error check + IF ( NR > NR_MAX ) THEN + CALL ERROR_STOP( 'Too many bins!', 'SRCSALT (seasalt_mod.f)') + ENDIF + + !================================================================= + ! Define the volume size distribution of sea-salt. This only has + ! to be done once. We assume that sea-salt is the combination of a coarse mode + ! and accumulation model log-normal distribution functions (jaegle 5/11/11) + !================================================================= + IF ( FIRST) THEN + + ! Lower edge of 0th bin + DEDGE=SALA_REDGE_um(1) * 2d0 + + ! Loop over diameters + DO ID = 1, NR + ! Diameter of mid-point in microns + DMID(ID) = DEDGE + ( DR ) + + ! Calculate the dry volume size distribution as the sum of two log-normal + ! size distributions. The parameters for the size distribution are + ! based on Reid et al. and Quinn et al. + ! The scaling factors 13. and 0.8 for acc and coarse mode aerosols are + ! chosen to obtain a realistic distribution + ! SALT_V (D) = dV/dln(D) [um3] + SALT_V(ID) = PI / 6d0* (DMID(ID)**3) * ( + & 13d0*exp(-0.5*( LOG(DMID(ID))-LOG(RG_A*2d0) )**2d0/ + & LOG(SIG_A)**2d0 ) + & /( sqrt(2d0 * PI) * LOG(SIG_A) ) + + & 0.8d0*exp(-0.5*( LOG(DMID(ID))-LOG(RG_C*2d0) )**2d0/ + & LOG(SIG_C)**2d0) + & /( sqrt(2d0 * PI) * LOG(SIG_C) ) ) + ! update the next edge + DEDGE = DEDGE + DR*2d0 + ENDDO + + ! Reset after the first time + IF ( FIRST ) FIRST = .FALSE. + ENDIF + + + ! Sea salt radius [cm] + !RCM = REFF * 100d0 + ! The radius used in the Gerber formulation for hygroscopic growth + ! of sea salt should be in microns (RUM) instead of cm (RCM). Replace RCM + ! with RUM (jaegle 5/11/11) + !RUM = REFF * 1d6 + + ! Exponential factors + !FAC1 = C1 * ( RCM**C2 ) + !FAC2 = C3 * ( RCM**C4 ) + ! Replace with RUM (jaegle 5/11/11) + !FAC1 = C1 * ( RUM**C2 ) + !FAC2 = C3 * ( RUM**C4 ) + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, VTS, P, TEMP, RHB, RWET ) +!$OMP+PRIVATE( RATIO_R, RHO, DP, PDP, CONST, SLIP, VISC, TC0 ) +!$OMP+PRIVATE( DELZ, DELZ1, TOT1, TOT2, AREA_CM2, FLUX ) +!$OMP+PRIVATE( SW, ID, SALT_MASS_TOTAL, VTS_WEIGHT ) !jaegle 5/11/11 +!$OMP+PRIVATE( DMIDW, RHO1, WTP, SALT_MASS ) !jaegle 5/11/11 +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Initialize + DO L = 1, LLPAR + VTS(L) = 0d0 + ENDDO + + ! Loop over levels + DO L = 1, LLPAR + + ! Pressure at center of the level [kPa] + P = GET_PCENTER(I,J,L) * 0.1d0 + + ! Temperature [K] + TEMP = T(I,J,L) + + ! Cap RH at 0.99 + RHB = MIN( 0.99d0, RH(I,J,L) * 1d-2 ) + + ! Safety check (phs, 5/1/08) + RHB = MAX( TINY(RHB), RHB ) + + ! Aerosol growth with relative humidity in radius [m] + ! (Gerber, 1985) + !RWET = 0.01d0*(FAC1/(FAC2-DLOG(RHB))+RCM**3.d0)**0.33d0 + ! Fix bugs in the Gerber formula: a log10 (instead of ln) should be used and the + ! dry radius should be expressed in micrometers (instead of cm) also add more significant + ! digits to the exponent (should be 1/3) (jaegle 5/11/11) + !RWET = 1d-6*(FAC1/(FAC2-LOG10(RHB))+RUM**3.d0)**0.33333d0 + + ! Use equation 5 in Lewis and Schwartz (2006) for sea salt growth (bec, jaegle 5/11/11) + RWET = REFF * (4.d0 / 3.7d0) * + & ( (2.d0 - RHB)/(1.d0 - RHB) )**(1.d0/3.d0) + + + ! Ratio dry over wet radii at the cubic power + RATIO_R = ( REFF / RWET )**3.d0 + + ! Density of the wet aerosol (kg/m3) + RHO = RATIO_R * DEN + ( 1.d0 - RATIO_R ) * 1000.d0 + + ! Above density calculation is chemically unsound because it ignores chemical solvation. + ! Iteratively solve Tang et al., 1997 equation 5 to calculate density of wet aerosol (kg/m3) + ! (bec, jaegle 5/11/11) + RATIO_R = ( REFF / RWET ) + ! Assume an initial density of 1000 kg/m3 + RHO = 1000.D0 + RHO1 = 0.d0 !initialize (bec, 6/21/10) + DO WHILE ( ABS( RHO1-RHO ) .gt. EPSI ) + ! First calculate weight percent of aerosol (kg_RH=0.8/kg_wet) + WTP = 100.d0 * DEN/RHO * RATIO_R**3.d0 + ! Then calculate density of wet aerosol using equation 5 + ! in Tang et al., 1997 [kg/m3] + RHO1 = ( 0.9971d0 + (A1 * WTP) + (A2 * WTP**2.d0) + + $ (A3 * WTP**3.d0) + (A4 * WTP**4.d0) ) * 1000.d0 + ! Now calculate new weight percent using above density calculation + WTP = 100.d0 * DEN/RHO1 * RATIO_R**3.d0 + ! Now recalculate new wet density [kg/m3] + RHO = ( 0.9971d0 + (A1 * WTP) + (A2 * WTP**2.d0) + + $ (A3 * WTP**3.d0) + (A4 * WTP**4.d0) ) * 1000.d0 + ENDDO + + ! Dp = particle diameter [um] + DP = 2.d0 * RWET * 1.d6 + + ! PdP = P * dP [hPa * um] + PDp = P * Dp + + ! Constant + CONST = 2.d0 * RHO * RWET**2 * g0 / 9.d0 + + !=========================================================== + ! NOTE: Slip correction factor calculations following + ! Seinfeld, pp464 which is thought to be more accurate + ! but more computation required. (rjp, 1/24/02) + ! + ! # air molecule number density + ! num = P * 1d3 * 6.023d23 / (8.314 * Temp) + ! + ! # gas mean free path + ! lamda = 1.d6/( 1.41421 * num * 3.141592 * (3.7d-10)**2 ) + ! + ! # Slip correction + ! Slip = 1. + 2. * lamda * (1.257 + 0.4 * exp( -1.1 * Dp + ! & / (2. * lamda))) / Dp + ! + ! NOTE: Eq) 3.22 pp 50 in Hinds (Aerosol Technology) + ! which produces slip correction factore with small error + ! compared to the above with less computation. + !=========================================================== + + ! Slip correction factor (as function of P*dp) + Slip = 1.d0+(15.60d0 + 7.0d0 * EXP(-0.059d0 * PDp)) / PDp + + ! Viscosity [Pa*s] of air as a function of temperature + VISC = 1.458d-6 * (Temp)**(1.5d0) / ( Temp + 110.4d0 ) + + ! Settling velocity [m/s] + VTS(L) = CONST * Slip / VISC + + ! This settling velocity is for the mid-point of the size bin. + ! In the following we derive scaling factors to take into account + ! the strong dependence on radius of the settling velocity and the + ! mass size distribution: + ! VTS_WEIGHTED = total( M(k) x VTS(k)) / total( M(k) ) + ! The settling velocity is a function of the radius squared (see definition + ! of CONST above) + ! so VTS(k) = VTS * (RMID(k)/RWET)^2 + ! (jaegle 5/11/11) + + SALT_MASS_TOTAL = 0d0 + VTS_WEIGHT = 0d0 + DO ID = 1, NR + ! Calculate mass of wet aerosol (Dw = wet diameter, D = dry diamter): + ! dM/dlnDw = dV/dlnDw * RHO, we assume that the density of sea-salt + ! doesn't change much over the size range. + ! and + ! dV/dlnDw = dV/dlnD * dlnD/dlnDw = dV/dlnD * Dw/D = dV/dlnD * Rwet/Rdry + ! Further convert to dM/dDw = dM/dln(Dw) * dln(Dw)/Dw = dM/dln(Dw)/Dw + ! Overall = dM/dDw = dV/dlnD * Rwet/Rdry * RHO /Rw + ! + IF (DMID(ID) .ge. R0*2d0 .and. DMID(ID) .le. R1*2d0 ) THEN + DMIDW = DMID(ID) * RWET/REFF ! wet radius [um] + SALT_MASS = SALT_V(ID) * RWET/REFF * RHO / (DMIDW*0.5d0) + VTS_WEIGHT = VTS_WEIGHT + + & SALT_MASS * VTS(L) * (DMIDW/(RWET*1d6*2d0) )**2d0 * + & (2d0 * DR * RWET/REFF) + SALT_MASS_TOTAL=SALT_MASS_TOTAL+SALT_MASS * + & (2d0 * DR * RWET/REFF) + ENDIF + + ENDDO + ! Calculate the weighted settling velocity: + VTS(L) = VTS_WEIGHT/SALT_MASS_TOTAL + ENDDO + + ! Method is to solve bidiagonal matrix which is + ! implicit and first order accurate in z (rjp, 1/24/02) + + ! Save initial tracer concentration in column + DO L = 1, LLPAR + TC0(L) = TC(I,J,L) + ENDDO + + ! We know the boundary condition at the model top + L = LLTROP + DELZ = BXHEIGHT(I,J,L) + + TC(I,J,L) = TC(I,J,L) / ( 1.d0 + DTCHEM * VTS(L) / DELZ ) + + DO L = LLTROP-1, 1, -1 + DELZ = BXHEIGHT(I,J,L) + DELZ1 = BXHEIGHT(I,J,L+1) + TC(I,J,L) = 1.d0 / ( 1.d0 + DTCHEM * VTS(L) / DELZ ) + & * ( TC(I,J,L) + DTCHEM * VTS(L+1) / DELZ1 + & * TC(I,J,L+1) ) + ENDDO + + !============================================================== + ! ND44 diagnostic: sea salt loss [molec/cm2/s] + !============================================================== + IF ( ND44 > 0 ) THEN + + ! Initialize + TOT1 = 0d0 + TOT2 = 0d0 + + ! Compute column totals of TCO(:) and TC(I,J,:,N) + DO L = 1, LLPAR + TOT1 = TOT1 + TC0(L) + TOT2 = TOT2 + TC(I,J,L) + ENDDO + + ! Surface area [cm2] + AREA_CM2 = GET_AREA_CM2( J ) + + ! Convert sea salt flux from [kg/s] to [molec/cm2/s] + FLUX = ( TOT1 - TOT2 ) / DTCHEM + FLUX = FLUX * XNUMOL(IDTSALA) / AREA_CM2 + + ! Store in AD44 array + AD44(I,J,IDDEP(N),1) = AD44(I,J,IDDEP(N),1) + FLUX + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE WET_SETTLING + +!------------------------------------------------------------------------------ + + SUBROUTINE DRY_DEPOSITION( TC, N ) +! +!****************************************************************************** +! Subroutine DRY_DEPOSITION computes the loss of sea salt by dry deposition +! at the surface, using an implicit method. (bec, rjp, bmy, 4/20/04) +! +! Arguments as Input: +! ============================================================================ +! (1 ) TC (REAL*8 ) : Sea salt tracer [kg] +! (2 ) N (INTEGER) : N=1 is accum mode; N=2 is coarse mode +! +! Arguments as Output: +! ============================================================================ +! (1 ) TC (REAL*8 ) : Contains modified tracer +! +! NOTES: +! (1 ) Now references XNUMOL from "tracer_mod.f" (bmy, 10/25/05) +! (2 ) Update to calculate the drydep throughout the entire PBL instead of just +! at the surface. This is more in line with what is done in dry_dep.f. This +! is only used if LNLPBL is turned off (or for GEOS-4 and prior met fields). +! (jaegle 5/11/11) +!****************************************************************************** +! + ! References to F90 modules + USE DIAG_MOD, ONLY : AD44 + USE DRYDEP_MOD, ONLY : DEPSAV + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTSALA, IDTSALC + USE TIME_MOD, ONLY : GET_MONTH, GET_TS_CHEM + USE GRID_MOD, ONLY : GET_AREA_CM2 + ! Add PBL variables (jaegle 5/5/11) + USE PBL_MIX_MOD, ONLY : GET_FRAC_UNDER_PBLTOP, GET_PBL_MAX_L + + +# include "CMN_SIZE" ! Size parameters +# include "CMN_GCTM" ! g0 +# include "CMN_DIAG" ! ND44 + + ! Arguments + INTEGER, INTENT(IN) :: N + REAL*8, INTENT(INOUT) :: TC(IIPAR,JJPAR,LLPAR) + + ! Local variables + INTEGER :: I, J, L, DTCHEM + REAL*8 :: OLD, NEW, G, REFF + REAL*8 :: DIAM, U_TS0, REYNOL, ALPHA + REAL*8 :: BETA, GAMMA, DENS, FLUX + REAL*8 :: AREA_CM2, TOT1, TOT2 + REAL*8 :: ND44_TMP(IIPAR,JJPAR,LLPAR) + ! New variables for applying dry dep thoughout the PBL (jaegle 5/11/11) + INTEGER :: PBL_MAX + REAL*8 :: F_UNDER_TOP, FREQ + + ! Parameters + REAL*8, PARAMETER :: RHOA = 1.25d-3 + + !================================================================= + ! DRY_DEPOSITION begins here! + !================================================================= + + ! Chemistry timestep [s] + DTCHEM = GET_TS_CHEM() * 60d0 + + ! Maximum extent of the PBL [model layers] (jaegle 5/11/11) + PBL_MAX = GET_PBL_MAX_L() + + ! Zero temporary array for drydep diagnostic + IF ( ND44 > 0 ) ND44_TMP = 0d0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, AREA_CM2, OLD, NEW, FLUX ) +!$OMP+PRIVATE( L, F_UNDER_TOP , FREQ ) ! (jaegle 5/11/11) +!$OMP+SCHEDULE( DYNAMIC ) + + ! Loop over levels under PBL + DO L = 1, PBL_MAX + + ! Loop over latitudes + DO J = 1, JJPAR + + ! Grid box surface area [cm2] + AREA_CM2 = GET_AREA_CM2( J ) + + ! Loop over longitudes + DO I = 1, IIPAR + + ! Fraction of box (I,J,L) under PBL top [unitless] + F_UNDER_TOP = GET_FRAC_UNDER_PBLTOP( I, J, L ) + + ! Only apply drydep to boxes w/in the PBL + IF ( F_UNDER_TOP > 0d0 ) THEN + + ! Sea salt dry deposition frequency [1/s] accounting + ! for fraction of each grid box located beneath the PBL top + FREQ = DEPSAV(I,J,IDDEP(N)) * F_UNDER_TOP + ! Only apply drydep loss if FREQ is nonzero + IF ( FREQ > 0d0 ) THEN + ! Old tracer concentration [kg] + OLD = TC(I,J,L) + + ! New tracer concentration [kg] + NEW = OLD * EXP( -FREQ * DTCHEM ) + + + ! Old tracer concentration [kg] + !OLD = TC(I,J,1) + + ! New tracer concentration [kg] + !NEW = OLD * EXP( -DEPSAV(I,J,IDDEP(N)) * DTCHEM ) + + !=========================================================== + ! ND44 diagnostic: sea salt drydep loss [molec/cm2/s] + !=========================================================== + IF ( ND44 > 0 ) THEN + + ! Convert drydep loss from [kg/s] to [molec/cm2/s] + FLUX = ( OLD - NEW ) / DTCHEM + FLUX = FLUX * XNUMOL(IDTSALA) / AREA_CM2 + + ! Store in AD44 + !AD44(I,J,IDDEP(N),1) = AD44(I,J,IDDEP(N),1) + FLUX + ND44_TMP(I,J,L) = ND44_TMP(I,J,L) + FLUX + ENDIF + + ! Update tracer array + TC(I,J,L) = NEW + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !==================================================================== + ! ND44 diagnostic: save into AD44 array, summing in the vertical + !==================================================================== + IF ( ND44 > 0 ) THEN +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + AD44(I,J,IDDEP(N),1) = SUM( ND44_TMP(I,J,:) ) + ENDDO + ENDDO +!$OMP END PARALLEL DO + ENDIF + + ! Return to calling program + END SUBROUTINE DRY_DEPOSITION + +!------------------------------------------------------------------------------ + + SUBROUTINE EMISSSEASALT +! +!****************************************************************************** +! Subroutine EMISSSEASALT is the interface between the GEOS-CHEM model +! and the SEASALT emissions routines in "seasalt_mod.f". +! (bec, rjp, bmy, 3/24/03, 2/22/05) +! +! NOTES: +! (1 ) Now references LPRT from "logical_mod.f" and STT from "tracer_mod.f". +! (bmy, 7/20/04) +! (2 ) Now make sure IDTSALA, IDTSALC are nonzero before calling SRCSALT. +! (bmy, 1/26/05) +! (3 ) Remove reference to header file "CMN" (bmy, 2/22/05) +! (4 ) Now call INIT_SEASALT on the first timestep. Also initialize ALK_EMIS +! and N_DENS on each timestep. (bec, bmy, 4/13/05) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : DEBUG_MSG + USE LOGICAL_MOD, ONLY : LPRT + USE TRACER_MOD, ONLY : STT + USE TRACERID_MOD, ONLY : IDTSALA, IDTSALC + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, L, N + + !================================================================= + ! EMISSSEASALT begins here! + !================================================================= + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### in EMISSEASALT' ) + + ! Allocate all module arrays (bec, bmy, 4/13/05) + IF ( FIRST ) THEN + CALL INIT_SEASALT + FIRST = .FALSE. + ENDIF + + ! Initialize for each timestep (bec, bmy, 4/13/05) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N ) + DO N = 1, NSALT + DO L = 1, LLTROP + DO J = 1, JJPAR + DO I = 1, IIPAR + ALK_EMIS(I,J,L,N) = 0d0 + N_DENS(I,J,L,N) = 0d0 + ENDDO + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Accumulation mode emissions + IF ( IDTSALA > 0 ) THEN + CALL SRCSALT( STT(:,:,:,IDTSALA), 1 ) + IF ( LPRT ) CALL DEBUG_MSG( '### EMISSEASALT: Accum' ) + ENDIF + + ! Coarse mode emissions + IF ( IDTSALC > 0 ) THEN + CALL SRCSALT( STT(:,:,:,IDTSALC), 2 ) + IF ( LPRT ) CALL DEBUG_MSG( '### EMISSEASALT: Coarse' ) + ENDIF + + ! Return to calling program + END SUBROUTINE EMISSSEASALT + +!----------------------------------------------------------------------------- + + SUBROUTINE SRCSALT( TC, N ) +! +!****************************************************************************** +! The new SRCSALT is based on the sea salt source function of Gong (2003) with +! the empirical sea surface temperature (SST) dependence of Jaegle et al. (2011). This +! SST dependence was derived based on comparisons to cruise observations of +! coarse mode sea salt mass concentrations. +! +! Contact: Lyatt Jaegle (jaegle@uw.edu) +! +! Old: +!! Subroutine SRCSALT updates the surface mixing ratio of dry sea salt +!! aerosols for NSALT size bins. The generation of sea salt aerosols +!! has been parameterized following Monahan et al. [1986] parameterization +!! as described by Gong et al. [1997]. (bec, rjp, bmy, 4/20/04, 11/23/09) +! +!! Contact: Becky Alexander (bec@io.harvard.edu) or +!! Rokjin Park (rjp@io.harvard.edu) +! +! Arguments as Input: +! ============================================================================ +! (1 ) TC (REAL*8 ) : Sea salt tracer array [v/v] +! (2 ) N (INTEGER) : N=1 denotes accumulation mode; N=2 denotes coarse mode +! +! Arguments as Output: +! ============================================================================ +! (1 ) TC (REAL*8 ) : Contains modified sea salt concentration [v/v] +! +! References: +! ============================================================================ +! (1 ) Chin, M., P. Ginoux, S. Kinne, B. Holben, B. Duncan, R. Martin, +! J. Logan, A. Higurashi, and T. Nakajima, "Tropospheric aerosol +! optical thickness from the GOCART model and comparisons with +! satellite and sunphotometers measurements", J. Atmos Sci., 2001. +! (2 ) Gong, S., L. Barrie, and J.-P. Blanchet, "Modeling sea-salt +! aerosols in the atmosphere. 1. Model development", J. Geophys. Res., +! v. 102, 3805-3818, 1997. +! (3 ) Gong, S. L., "A parameterization of sea-salt aerosol source function +! for sub- and super-micron particles", Global Biogeochem. Cy., 17(4), +! 1097, doi:10.1029/2003GB002079, 2003. +! (4 ) Jaegle, L., P.K. Quinn, T.S. Bates, B. Alexander, J.-T. Lin, "Global +! distribution of sea salt aerosols: New constraints from in situ and +! remote sensing observations", Atmos. Chem. Phys., 11, 3137-3157, +! doi:10.5194/acp-11-3137-2011. +! +! NOTES: +! (1 ) Now references SALA_REDGE_um and SALC_REDGE_um from "tracer_mod.f" +! (bmy, 7/20/04) +! (2 ) Now references GET_FRAC_OF_PBL and GET_PBL_TOP_L from "pbl_mix_mod.f". +! Removed reference to header file CMN. Removed reference to +! "pressure_mod.f". (bmy, 2/22/05) +! (3 ) Now also compute alkalinity and number density of seasalt emissions. +! (bec, bmy, 4/13/05) +! (4 ) Now references XNUMOL & XNUMOLAIR from "tracer_mod.f" (bmy, 10/25/05) +! (5 ) The source function is for wet aerosol radius (RH=80%, with a radius +! twice the size of dry aerosols) so BETHA should be set to 2 +! instead of 1. Also now use LOG10 instead of LOG in the expressions +! for the seasalt base source, since we need the logarithm to the base +! 10. (jaegle, bec, bmy, 11/23/09) +! (6 ) Update to use the Gong (2003) source function (jaegle 5/11/11) +! (7 ) Apply an empirical sea surface temperature dependence to Gong (2003) (jaegle 5/11/11) +!****************************************************************************** +! + ! References to F90 modules + USE DAO_MOD, ONLY : PBL, AD, IS_WATER, AIRVOL + ! Add TSKIN (jaegle 5/11/11) + USE DAO_MOD, ONLY : TSKIN ! jaegle + USE DIAG_MOD, ONLY : AD08 + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE GRID_MOD, ONLY : GET_AREA_M2 + USE PBL_MIX_MOD, ONLY : GET_FRAC_OF_PBL, GET_PBL_TOP_L + USE TIME_MOD, ONLY : GET_TS_EMIS + USE TRACER_MOD, ONLY : SALA_REDGE_um, SALC_REDGE_um, XNUMOL + +# include "CMN_SIZE" ! Size parameters +# include "CMN_DIAG" ! ND44, ND08 +# include "CMN_GCTM" ! PI + + ! Arguments + INTEGER, INTENT(IN) :: N + REAL*8, INTENT(INOUT) :: TC(IIPAR,JJPAR,LLPAR) + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, L + INTEGER :: R, NR, NTOP + REAL*8 :: W10M, DTEMIS, R0 + REAL*8 :: R1, CONST, CONST_N + REAL*8 :: FEMIS, A_M2 + REAL*8 :: SALT(IIPAR,JJPAR) + REAL*8 :: SALT_N(IIPAR,JJPAR) + ! New variables (jaegle 5/11/11) + REAL*8 :: A, B, SST, SCALE + + ! Increment of radius for Emission integration (um) + REAL*8, PARAMETER :: DR = 5.d-2 + REAL*8, PARAMETER :: BETHA = 2.d0 + + ! External functions + REAL*8, EXTERNAL :: SFCWINDSQR + + !================================================================= + ! SRCSALT begins here! + !================================================================= + + ! Emission timestep [s] + DTEMIS = GET_TS_EMIS() * 60d0 + + ! no longer used (jaegle 5/11/11) + ! Constant [volume * time * other stuff??] + !CONST = 4d0/3d0 * PI * DR * DTEMIS * 1.d-18 * 1.373d0 + + !CONST_N = DTEMIS * DR * 1.373d0 + ! Constant for converting from [#/m2/s/um] to [#/m2] + CONST_N = DTEMIS * (DR * BETHA) + + ! Lower and upper limit of size bin N [um] + ! Note that these are dry size bins. In order to + ! get wet (RH=80%) sizes, we need to multiply by + ! BETHA. + SELECT CASE( N ) + + ! Accum mode + CASE( 1 ) + R0 = SALA_REDGE_um(1) + R1 = SALA_REDGE_um(2) + + ! Coarse mode + CASE( 2 ) + R0 = SALC_REDGE_um(1) + R1 = SALC_REDGE_um(2) + + END SELECT + + ! Number of radius size bins + NR = INT( ( ( R1 - R0 ) / DR ) + 0.5d0 ) + + ! Error check + IF ( NR > NR_MAX ) THEN + CALL ERROR_STOP( 'Too many bins!', 'SRCSALT (seasalt_mod.f)' ) + ENDIF + + ! Initialize source +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO J = 1, JJPAR + DO I = 1, IIPAR + SALT(I,J) = 0d0 + SALT_N(I,J) = 0d0 + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Define edges and midpoints of each incrmental radius bin + ! This only has to be done once per sea salt type + !================================================================= + IF ( FIRST ) THEN + + ! Lower edge of 0th bin + REDGE(0,N) = R0 + + ! Loop over the # of radius bins + DO R = 1, NR + + ! Midpoint of IRth bin + RMID(R,N) = REDGE(R-1,N) + ( DR / 2d0 ) + + ! Upper edge of IRth bin + REDGE(R,N) = REDGE(R-1,N) + DR + + + ! Sea salt base source [#/m2]. Note that the Gong formulation + ! is for r80 (radius at 80% RH), so we need to multiply RMID + ! by the scaling factor BETHA=2. + A = 4.7*(1.+30.*(BETHA*RMID(R,N))) + & **(-0.017*(BETHA*RMID(R,N))**(-1.44)) + B = (0.433d0-LOG10(BETHA*RMID(R,N))) / 0.433d0 + SRC_N(R,N) = CONST_N * 1.373 * (1.d0/(BETHA*RMID(R,N))**(A)) + & * (1.d0+0.057d0*(BETHA*RMID(R,N))**3.45d0) + & * 10d0**(1.607d0*EXP(-(B**2))) + + ! Sea salt base source [kg/m2]: multiply the number of particles + ! by the dry volume multiplied by the dry density of sea-salt. + SRC(R,N) = SRC_N(R,N) * 4d0/3d0 * PI * 1.d-18 + & * SS_DEN( N ) * (RMID(R,N))**3 + + + !----------------------------------------------------------- + ! IMPORTANT NOTE! + ! + ! In mathematics, "LOG" means "log10". + ! In Fortran, "LOG" means "ln" (and LOG10 is "log10"). + ! + ! The following equations require log to the base 10, so + ! we need to use the Fortran function LOG10 instead of LOG. + ! (jaegle, bmy, 11/23/09) + !----------------------------------------------------------- + +! ! Old Monahan et al. (1986) formulation +! ! Sea salt base source [kg/m2] +! CONST_N = DTEMIS * (DR * BETHA) +! SRC(R,N) = CONST * SS_DEN( N ) +! & * ( 1.d0 + 0.057d0*( BETHA * RMID(R,N) )**1.05d0 ) +! & * 10d0**( 1.19d0* +! & EXP(-((0.38d0-LOG10(BETHA*RMID(R,N)))/0.65d0)**2)) +! & / BETHA**2 + +! ! Sea salt base source [#/m2] (bec, bmy, 4/13/05) +! SRC_N(R,N) = CONST_N * (1.d0/RMID(R,N)**3) +! & * (1.d0+0.057d0*(BETHA*RMID(R,N))**1.05d0) +! & * 10d0**(1.19d0*EXP(-((0.38d0-LOG10(BETHA*RMID(R,N))) +! & /0.65d0)**2))/ BETHA**2 + +!### Debug +!### WRITE( 6, 100 ) R,REDGE(R-1,N),RMID(R,N),REDGE(R,N),SRC(R,N) +!### 100 FORMAT( 'IR, R0, RMID, R1: ', i3, 3f11.4,2x,es13.6 ) + ENDDO + + ! Reset only after N=NSALT + IF ( FIRST .and. N == NSALT ) FIRST = .FALSE. + ENDIF + + !================================================================= + ! Emission is integrated over a given size range for each bin + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, R, A_M2, W10M ) +!$OMP+PRIVATE( SST , SCALE ) !(jaegle 5/11/11) +!$OMP+SCHEDULE( DYNAMIC ) + + ! Loop over latitudes + DO J = 1, JJPAR + + ! Grid box surface area [m2] + A_M2 = GET_AREA_M2( J ) + + ! Loop over longitudes + DO I = 1, IIPAR + + ! Test if this is a water box + IF ( IS_WATER(I,J) ) THEN + + ! Wind speed at 10 m altitude [m/s] + W10M = SQRT( SFCWINDSQR(I,J) ) + + ! Sea surface temperature in Celcius (jaegle 5/11/11) + SST = TSKIN(I,J) - 273.15d0 + ! Limit SST to 0-30C range + SST = MAX( SST , 0d0 ) ! limit to 0C + SST = MIN( SST , 30d0 ) ! limit to 30C + ! Empirical SST scaling factor (jaegle 5/11/11) + SCALE = 0.329d0 + 0.0904d0*SST - + & 0.00717d0*SST**2d0 + 0.000207d0*SST**3d0 + + ! Reset to using original Gong (2003) emissions (jaegle 6/30/11) + !SCALE = 1.0d0 + +! The source function calculated with GEOS-4 2x2.5 wind speeds is too high compared to GEOS-5 +! at the same resolution. The 10m winds in GEOS-4 are too rapid. To correct this, apply a global +! scaling factor of 0.72 (jaegle 5/11/11) +#if defined( GEOS_4 ) + SCALE = SCALE * 0.72d0 +#endif + + ! Loop over size bins + DO R = 1, NR + + ! Update seasalt source into SALT [kg] + SALT(I,J) = SALT(I,J) + + & ( SCALE * SRC(R,N) * A_M2 * W10M**3.41d0 ) + + ! Update seasalt source into SALT_N [#] + ! (bec, bmy, 4/13/05) + SALT_N(I,J) = SALT_N(I,J) + + & ( SCALE * SRC_N(R,N) * A_M2 * W10M**3.41d0 ) + + ENDDO + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !================================================================= + ! Now partition seasalt emissions through boundary layer + !================================================================= +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, NTOP, L, FEMIS ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Layer in which the PBL top occurs + NTOP = CEILING( GET_PBL_TOP_L( I, J ) ) + + ! Loop thru the boundary layer + DO L = 1, NTOP + + ! Fraction of the PBL spanned by box (I,J,L) [unitless] + FEMIS = GET_FRAC_OF_PBL( I, J, L ) + + ! Add seasalt emissions into box (I,J,L) [kg] + TC(I,J,L) = TC(I,J,L) + ( FEMIS * SALT(I,J) ) + + ! Alkalinity [kg] (bec, bmy, 4/13/05) + ALK_EMIS(I,J,L,N) = SALT(I,J) + + ! Number density [#/m3] (bec, bmy, 4/13/05) + N_DENS(I,J,L,N) = SALT_N(I,J) / AIRVOL(I,J,L) + + ENDDO + + ! ND08 diagnostic: sea salt emissions [kg] + IF ( ND08 > 0 ) THEN + AD08(I,J,N) = AD08(I,J,N) + SALT(I,J) + ENDIF + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE SRCSALT + +!------------------------------------------------------------------------------ + + SUBROUTINE GET_ALK( I, J, L, ALK1, ALK2, Kt1, Kt2, Kt1N, Kt2N ) +! +!****************************************************************************** +! Function GET_ALK returns the seasalt alkalinity emitted at each timestep to +! sulfate_mod.f for chemistry on seasalt aerosols. +! (bec, 12/7/04, 9/5/06) +! +! Arguments as Input: +! ============================================================================ +! +! NOTES: +! (1 ) Becky Alexander says we can remove AREA1, AREA2 (bec, bmy, 9/5/06) +! (2 ) Bug fix to remove a double-substitution. Replace code lines for +! TERM{123}A, TERM{123}B, TERM{123}AN, TERM{123}BN. (bec, bmy, 7/18/08) +! (3 ) Updated hygroscopic growth parameters (bec, bmy, 11/23/09) +!****************************************************************************** +! + USE DAO_MOD, ONLY : AD, RH + USE ERROR_MOD, ONLY : IT_IS_NAN + USE TRACER_MOD, ONLY : SALA_REDGE_um, SALC_REDGE_um + + ! Arguments + INTEGER, INTENT(IN) :: I, J, L + + ! Return value + REAL*8, INTENT(OUT) :: ALK1, ALK2 ! [kg] + REAL*8, INTENT(OUT) :: Kt1, Kt2, Kt1N, Kt2N ! [s-1] + + REAL*8, PARAMETER :: PI = 3.14159265 + REAL*8 :: N1, N2, Kt + REAL*8 :: HGF, ALK + REAL*8 :: RAD1, RAD2, RAD3 + REAL*8 :: term1a, term2a, term3a + REAL*8 :: term1b, term2b, term3b + REAL*8 :: term1aN, term2aN, term3aN + REAL*8 :: term1bN, term2bN, term3bN + REAL*8 :: const1, const2, const1N, const2N + REAL*8 :: a1, a2, b1, b2, a1N, a2N, b1N, b2N + REAL*8, PARAMETER :: MINDAT = 1.d-20 + INTEGER :: IRH + REAL*8, PARAMETER :: gamma_SO2 = 0.11d0 !from Worsnop et al. (1989) + REAL*8, PARAMETER :: gamma_HNO3 = 0.2d0 !from JPL [2001] + REAL*8, PARAMETER :: Dg = 0.2d0 !gas phase diffusion coeff. [cm2/s] + REAL*8, PARAMETER :: v = 3.0d4 !cm/s + + LOGICAL, SAVE :: FIRST = .TRUE. + + !================================================================= + ! GET_ALK begins here! + !================================================================= + + ! Zero variables + ALK1 = 0.D0 + ALK2 = 0.D0 + KT1 = 0.D0 + KT2 = 0.D0 + KT1N = 0.D0 + KT2N = 0.D0 + N1 = 0.D0 + N2 = 0.D0 + + ! [kg] use this when not transporting alk + ALK1 = ALK_EMIS(I,J,L,1) + ALK2 = ALK_EMIS(I,J,L,2) + + !----------------------------------------------------------------------- + ! NOTE: If you want to transport alkalinity then uncomment this section + ! (bec, bmy, 4/13/05) + ! + !! alkalinity [v/v] to [kg] use this when transporting alk + !! or using Liao et al [2004] assumption of a continuous supply of + ! alkalinity based on Laskin et al. [2003] + !ALK1 = STT(I,J,L,IDTSALA) * AD(I,J,L)/TCVV(IDTSALA) + !ALK2 = STT(I,J,L,IDTSALC) * AD(I,J,L)/TCVV(IDTSALC) + !----------------------------------------------------------------------- + + ! Conversion from [m-3] --> [cm-3] + N1 = N_DENS(I,J,L,1) * 1.d-6 + N2 = N_DENS(I,J,L,2) * 1.d-6 + + ALK = ALK1 + ALK2 + + ! If there is any alkalinity ... + IF ( ALK > MINDAT ) THEN + + ! set humidity index IRH as a percent + IRH = RH(I,J,L) + IRH = MAX( 1, IRH ) + IRH = MIN( 99, IRH ) + + !-------------------------------------------------------------------- + ! Prior to 11/23/09: + ! These hygroscopic growth factors are incorrect (bec, bmy, 11/23/09) + !! hygroscopic growth factor for sea-salt from Chin et al. (2002) + !IF ( IRH < 100 ) HGF = 2.2d0 + !IF ( IRH < 99 ) HGF = 1.9d0 + !IF ( IRH < 95 ) HGF = 1.8d0 + !IF ( IRH < 90 ) HGF = 1.6d0 + !IF ( IRH < 80 ) HGF = 1.5d0 + !IF ( IRH < 70 ) HGF = 1.4d0 + !IF ( IRH < 50 ) HGF = 1.0d0 + !-------------------------------------------------------------------- + + ! Hygroscopic growth factor for sea-salt from Chin et al. (2002) + ! Updated (bec, bmy, 11/23/09) + IF ( IRH < 100 ) HGF = 4.8d0 + IF ( IRH < 99 ) HGF = 2.9d0 + IF ( IRH < 95 ) HGF = 2.4d0 + IF ( IRH < 90 ) HGF = 2.0d0 + IF ( IRH < 80 ) HGF = 1.8d0 + IF ( IRH < 70 ) HGF = 1.6d0 + IF ( IRH < 50 ) HGF = 1.0d0 + + ! radius of sea-salt aerosol size bins [cm] accounting for + ! hygroscopic growth + RAD1 = SALA_REDGE_um(1) * HGF * 1.d-4 + RAD2 = SALA_REDGE_um(2) * HGF * 1.d-4 + RAD3 = SALC_REDGE_um(2) * HGF * 1.d-4 + + !---------------------------------- + ! SO2 uptake onto fine particles + !---------------------------------- + + ! calculate gas-to-particle rate constant for uptake of + ! SO2 onto fine sea-salt aerosols [Jacob, 2000] analytical solution + CONST1 = 4.D0/(V*GAMMA_SO2) + A1 = (RAD1/DG)+CONST1 + B1 = (RAD2/DG)+CONST1 + TERM1A = ((B1**2)/2.0d0) - ((A1**2)/2.0d0) + TERM2A = 2.D0*CONST1*(B1-A1) + TERM3A = (CONST1**2)*LOG(B1/A1) + KT1 = 4.D0*PI*N1*(DG**3)*(TERM1A - TERM2A + TERM3A) + + !---------------------------------- + ! SO2 uptake onto coarse particles + !---------------------------------- + + ! calculate gas-to-particle rate constant for uptake of + ! SO2 onto coarse sea-salt aerosols [Jacob, 2000] analytical solution + CONST2 = 4.D0/(V*GAMMA_SO2) + A2 = (RAD2/DG)+CONST2 + B2 = (RAD3/DG)+CONST2 + TERM1B = ((B2**2)/2.0d0) - ((A2**2)/2.0d0) + TERM2B = 2.D0*CONST2*(B2-A2) + TERM3B = (CONST2**2)*LOG(B2/A2) + KT2 = 4.D0*PI*N2*(DG**3)*(TERM1B - TERM2B + TERM3B) + KT = KT1 + KT2 + + !---------------------------------- + ! HNO3 uptake onto fine particles + !---------------------------------- + + ! calculate gas-to-particle rate constant for uptake of + ! HNO3 onto fine sea-salt aerosols [Jacob, 2000] analytical solution + CONST1N = 4.D0/(V*GAMMA_HNO3) + A1N = (RAD1/DG)+CONST1N + B1N = (RAD2/DG)+CONST1N + TERM1AN = ((B1N**2)/2.0d0) - ((A1N**2)/2.0d0) + TERM2AN = 2.D0*CONST1N*(B1N-A1N) + TERM3AN = (CONST1N**2)*LOG(B1N/A1N) + KT1N = 4.D0*PI*N1*(DG**3)*(TERM1AN - TERM2AN + TERM3AN) + + !---------------------------------- + ! HNO3 uptake onto coarse particles + !---------------------------------- + + ! calculate gas-to-particle rate constant for uptake of + ! HNO3 onto coarse sea-salt aerosols [Jacob, 2000] analytical solution + CONST2N = 4.D0/(V*GAMMA_HNO3) + A2N = (RAD2/DG)+CONST2N + B2N = (RAD3/DG)+CONST2N + TERM1BN = ((B2N**2)/2.0d0) - ((A2N**2)/2.0d0) + TERM2BN = 2.D0*CONST2N*(B2N-A2N) + TERM3BN = (CONST2N**2)*LOG(B2N/A2N) + KT2N = 4.D0*PI*N2*(DG**3)*(TERM1BN - TERM2BN + TERM3BN) + + + ELSE + + ! If no alkalinity, set everything to zero + KT1 = 0.D0 + KT1N = 0.D0 + KT2 = 0.D0 + KT2N = 0.D0 + + ENDIF + + ! Return to calling program + END SUBROUTINE GET_ALK + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_SEASALT +! +!****************************************************************************** +! Subroutine INIT_SEASALT initializes and zeroes all module arrays +! (bmy, 4/26/04, 4/13/05) +! +! NOTES: +! (1 ) Now exit if we have allocated arrays before. Now also allocate +! ALK_EMIS & N_DENS. Now reference CMN_SIZE. (bec, bmy, 4/13/05) +! (2 ) Added SALT_V and DMID (jaegle 5/11/11) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" + + ! Local variables + LOGICAL, SAVE :: IS_INIT = .FALSE. + INTEGER :: AS + + !================================================================= + ! INIT_SEASALT begins here! + !================================================================= + + ! Return if we have already allocated arrays + IF ( IS_INIT ) RETURN + + ! Allocate arrays + ALLOCATE( REDGE( 0:NR_MAX, NSALT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'REDGE' ) + REDGE = 0d0 + + ALLOCATE( RMID( NR_MAX, NSALT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'RMID' ) + RMID = 0d0 + + ALLOCATE( SRC( NR_MAX, NSALT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SRC' ) + SRC = 0d0 + + ALLOCATE( SRC_N( NR_MAX, NSALT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SRC_N' ) + SRC_N = 0d0 + + ALLOCATE( ALK_EMIS( IIPAR, JJPAR, LLTROP, NSALT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ALK_EMIS' ) + ALK_EMIS = 0d0 + + ALLOCATE( N_DENS( IIPAR, JJPAR, LLTROP, NSALT ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'N_DENS' ) + N_DENS = 0d0 + + ALLOCATE( SALT_V( NR_MAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SALT_V' ) + SALT_V = 0d0 + + ALLOCATE( DMID( NR_MAX ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'DMID' ) + DMID = 0d0 + + ! Reset IS_INIT + IS_INIT = .TRUE. + + ! Return to calling program + END SUBROUTINE INIT_SEASALT + +!---------------------------------------------------------------------------- + + SUBROUTINE CLEANUP_SEASALT +! +!****************************************************************************** +! Subroutine INIT_SEASALT deallocates all module arrays +! (bmy, 4/26/04, 4/13/05) +! +! NOTES: +! (1 ) Now deallocates ALK_EMIS, N_DENS, SRC_N (bec, bmy, 4/13/05) +! (2 ) Deallocated SALT_V and DMID (jaegle 5/11/11) +!****************************************************************************** +! + !================================================================= + ! CLEANUP_SEASALT begins here! + !================================================================= + IF ( ALLOCATED( REDGE ) ) DEALLOCATE( REDGE ) + IF ( ALLOCATED( RMID ) ) DEALLOCATE( RMID ) + IF ( ALLOCATED( SRC ) ) DEALLOCATE( SRC ) + IF ( ALLOCATED( SRC_N ) ) DEALLOCATE( SRC_N ) + IF ( ALLOCATED( ALK_EMIS ) ) DEALLOCATE( ALK_EMIS ) + IF ( ALLOCATED( N_DENS ) ) DEALLOCATE( N_DENS ) + IF ( ALLOCATED( SALT_V ) ) DEALLOCATE( SALT_V ) + IF ( ALLOCATED( DMID ) ) DEALLOCATE( DMID ) + + ! Return to calling program + END SUBROUTINE CLEANUP_SEASALT + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE SEASALT_MOD diff --git a/code/set_aer.f b/code/set_aer.f new file mode 100644 index 0000000..cc020c1 --- /dev/null +++ b/code/set_aer.f @@ -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 diff --git a/code/setbase.f b/code/setbase.f new file mode 100644 index 0000000..4d6a628 --- /dev/null +++ b/code/setbase.f @@ -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 diff --git a/code/setemdep.f b/code/setemdep.f new file mode 100644 index 0000000..0a82a4f --- /dev/null +++ b/code/setemdep.f @@ -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 diff --git a/code/setmodel.f b/code/setmodel.f new file mode 100644 index 0000000..a13ea0a --- /dev/null +++ b/code/setmodel.f @@ -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 diff --git a/code/sfcwindsqr.f b/code/sfcwindsqr.f new file mode 100644 index 0000000..f53ee85 --- /dev/null +++ b/code/sfcwindsqr.f @@ -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 diff --git a/code/smvgear.f b/code/smvgear.f new file mode 100644 index 0000000..0378b14 --- /dev/null +++ b/code/smvgear.f @@ -0,0 +1,1752 @@ +! $Id: smvgear.f,v 1.1 2009/06/09 21:51:52 daven Exp $ + SUBROUTINE SMVGEAR +! +!****************************************************************************** +! Subroutine SMVGEAR solves ODE's for chemical reactions using a GEAR-type +! method. (M. Jacobson 1997; bdf, bmy, 5/12/03, 11/1/07) +! +! NOTES: +! (1 ) For GEOS-CHEM we had to remove IXSAVE, IYSAVE, and IZSAVE from +! "comode.h" and to declare these allocatable in "comode_mod.f". This +! allows us to only allocate these if we are doing a fullchem run. Now +! also references IT_IS_NAN and GEOS_CHEM_STOP from "error_mod.f". +! Now force double-precision with "D" exponent. Now prevent ND65 +! "fake" prodloss families from being counted towards the SMVGEAR +! convergence criteria. (ljm, bdf, bmy, 4/18/03) +! (2 ) Removed ITS_NOT_A_ND65_FAMILY -- this has now been converted from +! a function to a lookup-table in "comode.h". This should execute much +! faster, particularly on Linux. Comment out counter variable +! NUM_TIMESTEPS, you can get the same info w/ a profiling run. +! Cosmetic changes. (bmy, 7/9/03) +! (3 ) Declare NSTEPS, KLOOP, IABOVK as local variables since they are only +! ever used w/in "smvgear.f" Also reference ERRMX2 from "comode_mod.f" +! (4 ) Now declare DELY, ERRHOLD, YABST, as local variables, since these are +! used only w/in this routine and nowhere else --- also removed these +! from /DKBLOOP/ and /DKBLOOP5/ in "comode.h". (bmy, 7/28/03) +! (5 ) Increase max allowable iteration count to 99999 (mje, bmy, 9/15/03) +! (6 ) Added trap for negative CNEW values if iteration passes both local and +! global error tests. If negative values are found, go back to CNEW +! values at the end of the previous successful march, and try again +! with smaller timestep. Now stop at the end of the code if negative +! values are encountered in CNEW. Do not reset negative CNEW values +! to zero. (tmf, 11/1/07) +!****************************************************************************** +! + ! References to F90 modules + USE COMODE_MOD, ONLY : ERRMX2, IXSAVE, IYSAVE, IZSAVE + USE ERROR_MOD, ONLY : IT_IS_NAN, GEOS_CHEM_STOP + + IMPLICIT NONE + +# include "CMN_SIZE" +# include "comode.h" +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 ********************************************************************* +C ********************************************************************* +C +C SSSSSSS M M V V GGGGGGG EEEEEEE A RRRRRRR +C S MM MM V V G E A A R R +C SSSSSSS M M M M V V G GGGG EEEEEEE A A RRRRRRR +C S M M M V V G G E AAAAAAA R R +C SSSSSSS M M V GGGGGGG EEEEEEE A A R R +C +C ********************************************************************* +C VERSION: SMVGEAR II +C LAST UPDATE: AUGUST, 1997 +C ********************************************************************* +C +C ********************************************************************* +C * SMVGEAR IS A GEAR-TYPE INTEGRATOR THAT SOLVES FIRST-ORDER ORDIN- * +C * ARY DIFFERENTIAL EQUATIONS WITH INITIAL VALUE BOUNDARY CONDITIONS.* +C * SMVGEAR DIFFERS FROM AN ORIGINAL GEAR CODE IN THAT IT USES SPARSE * +C * MATRIX AND VECTORIZATION TECHNIQUES TO IMPROVE SPEED. MUCH * +C * OF THE SPEED UP IN THIS PROGRAM IS DUE TO SPARSE MATRIX * +C * TECHNIQUES AND VECTORIZATION. * +C * * +C * THIS VERSION INCLUDES RE-ORDERING OF GRID-CELLS PRIOR TO EACH * +C * TIME-INTERVAL. THE PURPOSE OF THE REORDERING IS TO GROUP CELLS * +C * WITH STIFF EQUATIONS TOGETHER AND THOSE WITH NON-STIFF EQUATIONS * +C * THIS REORDERING CAN SAVE SIGNIFCANT COMPUTER TIME * +C * (E.G. SPEED THE CODE BY A FACTOR OF TWO OR MORE), DEPENDING ON * +C * THE VARIATION IN STIFFNESS THROUGHOUT THE GRID-DOMAIN. WHEN THE * +C * STIFFNESS IS THE SAME THROUGHOUT THE GRID-DOMAIN (E.G. IF ALL * +C * CONCENTRATIONS AND RATES ARE THE SAME), THEN RE-ORDERING IS * +C * UNNECESSARY AND WILL NOT SPEED SOLUTIONS. * +C * * +C * THIS VERSION INCLUDES A VARIABLE ABSOLUTE ERROR TOLERANCE. * +C * THE ABSOLUTE TOLERANCE IS RECALCULATED EVERY FEW GEAR TIME STEPS. * +C * * +C * THIS VERSION CONTAINS DIFFERENT SETS OF CHEMISTRY FOR * +C * DIFFERENT REGIONS OF THE ATMOSPHERE. THUS, URBAN, FREE TROP- * +C * OSPHERIC, AND STRATOSPHERIC CHEMISTRY CAN BE SOLVED DURING THE * +C * SAME MODEL RUN. * +C * * +C * REFERENCES: * +C * ----------- * +C * * +C * JACOBSON M. Z. (1998) FUNDAMENTALS OF ATMOSPHERIC MODELING. * +C * CAMBRIDGE UNIVERSITY PRESS, NEW YORK. * +C * * +C * JACOBSON M. Z. (1998) IMPROVEMENT OF SMVGEAR II ON VECTOR AND * +C * SCALAR MACHINES THROUGH ABSOLUTE ERROR TOLERANCE CONTROL. * +C * ATMOS. ENVIRON. 32, 791 - 796 * +C * * +C * JACOBSON M. Z. (1995) COMPUTATION OF GLOBAL PHOTOCHEMISTRY * +C * WITH SMVGEAR II. ATMOS. ENVIRON., 29A, 2541 - 2546 * +C * * +C * JACOBSON M. Z. (1994) DEVELOPING, COUPLING, AND APPLYING A GAS, * +C * AEROSOL, TRANSPORT, AND RADIATION MODEL TO STUDYING URBAN * +C * AND REGIONAL AIR POLLUTION. Ph. D. THESIS, UNIVERSITY OF * +C * CALIFORNIA, LOS ANGELES. * +C * * +C * JACOBSON M. Z. AND TURCO R. P. (1994) SMVGEAR: A SPARSE- * +C * MATRIX, VECTORIZED GEAR CODE FOR ATMOSPHERIC MODELS. * +C * ATMOS. ENVIRON. 28A, 273 - 284. * +C * * +C * HOW TO CALL SUBROUTINE: * +C * ---------------------- * +C * CALL SMVGEAR FROM PHYSPROC FOR GAS CHEM W/ NCS = 1..NCSGAS * +C * * +C ********************************************************************* +C * * +C * THE ORIGINS OF THE GEAR INTEGRATOR USED IN SMVGEAR ARE FOUND IN * +C * * +C * GEAR C. W. (1971) NUMERICAL INITIAL VALUE PROBLEMS IN ORDINARY * +C * DIFFERENTIAL EQUATIONS. PRENTICE-HALL, NJ, PP. 158-166. * +C * * +C ********************************************************************* +C * * +C * FINALLY, IN SUBROUTINE SMVGEAR.F, THE FOLLOWING IDEAS ORIGINATED * +C * FROM LSODES, THE LIVERMORE SOLVER FOR ORDINARY DIFFERENTIAL * +C * WITH SPARSE MATRICES (HINDMARSH A. C. AND SHERMAN A. H.): * +C * * +C * (A) PREDICTING THE FIRST TIME-STEP; * +C * (B) DETERMINING CORRECTOR CONVERGENCE DIFFERENTLY THAN IN * +C * GEAR'S ORIGINAL CODE (GOC) * +C * (C) DETERMINING ERROR DIFFERENTLY THAN IN GOC * +C * (D) SUMMING UP THE PASCAL MATRIX DIFFERENTLY THAN IN GOC * +C * * +C * REFERENCES FOR THE 1987 LSODES VERSION INCLUDE: * +C * * +C * SHERMAN A. H. AND HINDMARSH A. C. (1980) GEARS: A PACKAGE FOR * +C * THE SOLUTION OF SPARSE, STIFF ORDINARY DIFFERENTIAL EQUATIONS. * +C * LAWRENCE LIVERMORE LABORATORY REPORT UCRL-84102. * +C * * +C * HINDMARSH A. C. (1983) ODEPACK, A SYSTEMATIZED COLLECTION OF * +C * ODE SOLVERS. IN SCIENTIFIC COMPUTING, R.S. STEPLEMAN ET AL., * +C * EDS., NORTH-HOLLAND, AMSTERDAM, PP. 55 - 74. * +C * * +C ********************************************************************* +C +C ********************************************************************* +C *************** HERE ARE SOME PARAMETER DEFINITIONS ***************** +C ********************************************************************* +C +C ABST2 = 1. / TIMEINTERVAL**2 (SEC-2) (SET IN READER.F) +C ASN1 = THE VALUE OF ASET(NQQ,1) +C CEST = STORES VALUE OF DTLOS WHEN IDOUB = 1 +C CHOLD = 1 / (RELTOL * CNEW + ABTOL). MULTIPLY +C CHOLD BY LOCAL ERRORS IN DIFFERENT ERROR TESTS. +C CNEW = STORES CONCENTRATION (Y [ESTIMATED]) +C CONC = AN ARRAY OF LENGTH ISCHAN * (MAXORD+1) THAT CARRIES THE +C DERIVATIVES OF CNEW, SCALED BY DELT**J/FACTORIAL(J), +C WHERE J IS THE J-TH DERIVATIVE. J VARIES FROM 1 TO NQQ, +C WHICH IS THE CURRENT ORDER OF THE METHOD. +C E.G. CONC(JSPC,2) STORES DELT * Y' (ESTIMATED) +C DELT = CURRENT TIME-STEP (S) LENGTH DURING A TIME-INTERVAL +C DRATE = PARAMETER WHICH USED TO DETERMINE WHETHER CONVERGENCE +C HAS OCCURRED +C DTLOS = AN ARRAY OF LENGTH ISCHAN, USED FOR THE ACCUMULATED +C CORRECTIONS. ON A SUCCESSFUL RETURN, DTLOS(KLOOP,I) CONTAINS +C THE ESTIMATED ONE-STEP LOCAL ERROR IN CNEW. +C EDWN = PERTST**2 * ORDER FOR ONE ORDER LOWER THAN CURRENT ORDER +C ENQQ = PERTST**2 * ORDER FOR CURRENT ORDER +C ERRMAX = RELATIVE ERROR TOLERANCE (SEE CHOLD). SET IN m.dat. +C EPS SHOULD BE < 1.0. FOR SPEEDY AND RELIABLE RESULTS, +C 10**-3 IS REASONABLE. FOR MANY DECIMAL PLACES OF ACCURACY, +C DECREASE EPS. +C EUP = PERTST**2 * ORDER FOR ONE ORDER HIGHER THAN CURRENT ORDER +C FRACDEC = FRACTION THE TIME-STEP IS DECREASED IF CONVERGENCE TEST FAILS +C GLOSS = VALUE OF FIRST DERIVATIVES ON OUTPUT FROM SUBFUN. +C = RIGHT-SIDE OF EQUATION ON INPUT TO BACKSUB.F +C = ERROR TERM (SOLUTION FROM BACKSUB.F) ON OUTPUT FROM BACKSUB +C HMAX = THE MAXIMUM ALLOWABLE VALUE OF DELT +C HMIN = THE MINIMUM ALLOWABLE VALUE OF DELT +C HRMAX = MAXIMUM RELATIVE CHANGE IN DELT*ASET(1) BEFORE PDERIV IS CALLED. +C HRATIO = RELATIVE CHANGE IN DELT * ASET(1) EACH CHANGE IN STEP OR ORDER +C WHEN ABS(HRATIO-1) > HRMAX, RESET JEVAL = 1 TO CALL PDERIV +C IABOVK = NUMBER OF SPECIES WHOSE CONCENTRATIONS ARE LARGER THAN YABST +C IDOUB = RECORDS THE NUMBER OF STEPS SINCE THE LAST CHANGE IN STEP SIZE +C OR ORDER. IT MUST BE AT LEAST KSTEP = NQQ+1 BEFORE DOUBLING IS +C ALLOWED. +C IFAIL = NUMBER OF TIMES THE CORRECTOR FAILED TO CONVERGE WHILE THE +C JACOBIAN WAS OLD (PDERIV NOT CALLED DURING THE LAST TEST) +C IFSUCCESS = IDENTIFIES WHETHER STEP IS SUCCESSFUL (=1) OR NOT (=0) +C IFSUN = IDENTIFIES WHETHER SUN IS UP (=1) OR DOWN (=2) +C ISCHAN = THE NUMBER OF FIRST-ORDER EQUATIONS TO SOLVE = # OF SPECIES = +C ORDER OF ORIGINAL MATRIX. ISCHAN HAS A DIFFERENT VALUE +C FOR DAY AND NIGHT AND FOR GAS- CHEMISTRY. +C ISREORD = 1: CALC INITIAL STIFFNESS BEFORE RUNNING CODE TO REORDER CELLS +C IN THIS CASE, USE PHOTORATES FOR END OF TIME-INTERVAL +C = 0: DO NORMAL CALCULATIONS +C JEVAL = 1 --> CALL PDERIV THE NEXT TIME THROUGH THE CORRECTOR STEPS. +C = 0 --> LAST STEP WAS SUCCESSFUL AND DO NOT NEED TO CALL PDERIV +C = -1 --> PDERIV JUST CALLED, AND DO NOT NEED TO CALL AGAIN +C UNTIL JEVAL SWITCHED TO 1. +C JRESTAR = COUNTS NUMBER OF TIMES SMVGEAR STARTS OVER AT ORDER 1 +C BECAUSE OF EXCESSIVE FAILURES. +C LFAIL = NUMBER OF TIMES THE ACCUMULATED ERROR TEST FAILED +C KSTEP = NQQ + 1 +C KTLOOP = NUMBER OF GRID-CELLS IN A GRID-BLOCK +C MAXORD = THE MAXIMUM ALLOWABLE ORDER OF THE INTEGRATION METHOD +C MBETWEEN = THE MAXIMUM ALLOWABLE NUMBER OF STEPS BETWEEN CALLS TO PDERIV +C MSTEP = THE MAXIMUM ALLOWABLE NUMBER OF CORRECTOR ITERATIONS +C NCS = 1..NCSGAS FOR GAS CHEMISTRY +C NCSP = NCS FOR DAYTIME GAS CHEM +C = NCS + ICS FOR NIGHTTIME GAS CHEM +C NFAIL = NUMBER OF TIMES CORRECTER FAILS TO CONVERGE AFTER PDERIV +C WAS JUST CALLED +C NPDERIV = TOTAL NUMBER OF TIMES THAT MATRIX IS EVALUATED (PDERIV) +C NPDTOT = NUMBER OF CALLS TO PDERIV ROUTINE, OVER ALL TIME +C NSFTOT = NUMBER OF CALLS TO SUBFUN ROUTINE, OVER ALL TIME +C NSLP = THE LAST TIME-STEP NUMBER DURING WHICH PDERIV WAS CALLED +C NSTTOT = TOTAL NUMBER OF SUCCESSFUL TIME-STEPS, OVER ALL TIME +C NSUBFUN = TOTAL NUMBER OF TIMES SUBFUN IS CALLED +C NSTEPS = TOTAL NUMBER OF SUCCESSFUL TIME-STEPS TAKEN +C NQQ = ORDER OF THE INTEGRATION METHOD. IT VARIES BETWEEN 1 AND MAXORD. +C NQQISC = NQQ * ISCHAN +C NQQOLD = VALUE OF NQQ DURING LAST TIME-STEP +C ORDER = FLOATING POINT VALUE OF ISCHAN, THE ORDER OF NUMBER OF ODES. +C PDERIV = NAME OF ROUTINE TO EVALUATE THE JACOBIAN MATRIX (J) +C AND P = I - DELT * ASET(1) * J +C PERTS2 = COEFFICIENTS USED IN SELECTING THE STEP AND ORDER (SEE +C JSPARSE.F) NOTE THAT PERTS2 = ORIGINAL PERTST**2 +C RDELMAX = THE MAXIMUM FACTOR BY WHICH DELT CAN BE INCREASED IN A SINGLE +C STEP. AS IN LSODES, SET IT TO 1E4 INITIALLY TO COMPENSATE +C FOR THE SMALL INITIAL DELT, BUT THEN SET IT TO 10 AFTER +C SUCCESSFUL STEPS AND 2 AFTER UNSUCCESSFUL STEPS +C RDELT = FACTOR (TIME-STEP RATIO) BY WHICH WE INCREASE OR DECREASE DELT +C RDELTDN = TIME-STEP RATIO AT ONE ORDER LOWER THAN CURRENT ORDER +C RDELTSM = TIME-STEP RATIO AT CURRENT ORDER +C RDELTUP = TIME-STEP RATIO AT ONE ORDER HIGHER THAN CURRENT ORDER +C RMSRAT = RATIO OF CURRENT TO PREVIOUS RMS SCALED ERROR. IF THIS +C RATIO DECREASES, THEN CONVERGENCE IS OCCURING. +C SUBFUN = NAME OF ROUTINE TO SOLVE FIRST DERIVATIVES. +C = EVALUATES DERIVATIVES IN THE SPECIAL FORM F = Y'(EST) +C = F(X,Y,ESTIMATED), WHERE F IS THE RIGHT HAND SIDE OF THE +C DIFFERENTIAL EQUATION. +C TINTERVAL = TOTAL SECONDS IN A TIME-INTERVAL +C TIMREMAIN = REMAINING TIME IN AN INTERVAL +C TOLD = STORES THE LAST VALUE OF XELAPS IN CASE THE CURRENT STEP FAILS +C XELAPS = ELAPSED TIME IN AN INTERVAL (S) +C ABTOL = ABSOLUTE ERROR TOLERANCE +C IF ABTOL IS TOO SMALL, THEN INTEGRATION WILL TAKE TOO LONG. +C IF ABTOL TOO LARGE, CONVERGENCE WILL BE TOO EASY AND ERRORS +C WILL ACCUMULATE, THE TIME-STEP MAY BE CUT TOO SMALL, AND +C THE INTEGRATION MAY STOP (DELT < HMIN OR FLOATING POINT +C EXCEPTION IN DECOMP.F). +C TYPICAL GAS-PHASE VALUES OF ABSTOL ARE 10**3 CM-3 +C TYPICAL AQ -PHASE VALUES OF ABSTOL ARE 10**-13 TO 10**-15 M L-1 +C YFAC = 1.0 ORIGINIALLY, BUT IS DECREASED IF EXCESSIVE FAILURES OCCUR +C IN ORDER TO REDUCE ABSOLUTE ERROR TOLERANCE +C ********************************************************************* +C + INTEGER JFAIL,ISCHAN1,IABOVE,KLOOP,IDOUB,JRESTAR,JNEW,IFSUCCESS + INTEGER K,JSPC,K1,K2,K3,K4,K5,NQQOLD,JEVAL,JS1,NQQISC + INTEGER LLOOPA,LLOOPB,JLOOP,MLOOP,M1,M2,JOLD,I1,J,I,J1,J2,J3,J4 + INTEGER J5,L3,JB,JG1,KSTEPISC,NQISC,I2,NSLP,KSTEP + + REAL*8 NYLOWDEC,ORDER,HRMAX,YFAC,ERRINIT,RELTOL1,RELTOL2,RELTOL3 + REAL*8 ABTOLER1,ABTOLER2,HRATIO,ASN1,RDELMAX,CNW,CNEWYLOW,ERRYMAX + REAL*8 RMSTOP,DELT1,ENQQ,EUP,EDWN,CONP3,CONP2,CONP1,HMTIM,RDELTA + REAL*8 CONC3J3,CONC4J4,CONC10J5,CONC5J5,DRATE,RMSERRP,DER2MAX + REAL*8 RMSRAT,DCON,RDELTUP,ASNQQJ,DER3MAX,RDELTSM,DER1MAX,RDELTDN + REAL*8 CONSMULT + + !==================================== + ! Additional variable declarations + !==================================== + + ! Add counter + INTEGER :: ICOUNT, NK + + !----------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic (ljm, bmy, 5/9/03) + INTEGER :: NNOFAM + !----------------------------------------------------------------- + + ! ljm stop 700 trouble + INTEGER :: IJSAVE, JSPCSAVE(KTLOOP) + INTEGER :: IX, IY, IZ, JJ, JJJ, KSAVE, COUNTER + REAL*8 :: SPECMAX + + ! Maximum iteration count for SMVGEAR (bmy, 4/11/03) + INTEGER, PARAMETER :: MAX_ITERATIONS = 99999 + + ! Variables from "comode.h" which are only ever used in "smvgear.f" + ! Remove them from "comode.h" and the THREADPRIVATE declarations + ! (bmy, 7/28/03) + INTEGER :: NSTEPS + INTEGER :: KGRP(KBLOOP,5), IABOVK(KBLOOP) + REAL*8 :: DELY(KBLOOP), ERRHOLD(KBLOOP) + REAL*8 :: YABST(KBLOOP) + + !----------------------------------------------------------------------- + ! %%%%% MODIFICATION TO PREVENT NEGATIVE CNEW (tmf, 11/1/07) %%%%% + ! INEG = flag for identifying negative values in CNEW + ! If IDTFORCE==1, then use DTFORCE as timestep instead of DELT + ! CPREVM stores CNEW at the end of the previous successful march + INTEGER :: INEG, IDTFORCE + REAL*8 :: DTFORCE + REAL*8 :: CPREVM( KBLOOP, MXGSAER ) + !----------------------------------------------------------------------- + + !================================================================= + ! SMVGEAR begins here! + !================================================================= + COUNTER = 0 + ICOUNT = 0 + NSUBFUN = 0 + NPDERIV = 0 + NSTEPS = 0 + IFAIL = 0 + JFAIL = 0 + LFAIL = 0 + NFAIL = 0 + NYLOWDEC = 0 + TINTERVAL = TIMEINTV(NCS) + ISCHAN = ISCHANG( NCS) + ISCHAN1 = ISCHAN - 1 + + !----------------------------------------------------------------------- + ! %%%%% MODIFICATION TO PREVENT NEGATIVE CNEW (tmf, 11/1/07) %%%%% + ! Initialize + IDTFORCE = 0 + DTFORCE = 0.d0 + !----------------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic, in order to prevent + ! ND65 prod/loss families from being counted towards the + ! SMVGEAR convergence criteria. (ljm, bmy, 5/9/03) + NNOFAM = ISCHAN - NFAMILIES + ORDER = REAL( NNOFAM ) + !----------------------------------------------------------------------- +C + IABOVE = ORDER * 0.4d0 +C + DO 115 KLOOP = 1, KTLOOP + IABOVK(KLOOP) = IABOVE + 115 CONTINUE +C + HRMAX = 0.3d0 + HMAX = HMAXUSE( NCSP) + YFAC = 1.0d0 + ERRINIT = MIN(ERRMAX(NCS),1.0D-03) +C +C ********************************************************************* +C START TIME INTERVAL OR RE-ENTER AFTER TOTAL FAILURE +C ********************************************************************* +C + ! EXPLANATORY NOTE: Internal timestep loop begins here (tmf, 11/1/07) + 120 IDOUB = 2 + NSLP = MBETWEEN + JRESTAR = 0 + DELT = 0.d0 + XELAPS = 0.d0 + XELAPLAST = -1.d0 + TOLD = 0.d0 + TIMREMAIN = TINTERVAL + RELTOL1 = YFAC / ERRINIT + RELTOL2 = YFAC / ERRMAX(NCS) + RELTOL3 = 1.d0 / ERRMAX(NCS) + ABTOLER1 = ABTOL(6,NCS) * RELTOL1 + ABTOLER2 = ABTOL(6,NCS) * RELTOL2 +C +C ********************************************************************* +C INITIALIZE CONCENTRATION ARRAY +C ********************************************************************* +C CORIG = ORIGINAL CONCENTRATIONS, WHICH DO NOT CHANGE IN SMVGEAR +C CNEW = FINAL CONCENTRATIONS, CALCULATED IN SMVGEAR +C CPREVM = VALUE OF CNEW AT END OF LAST SUCCESSFUL MARCH +C + + DO 129 JNEW = 1, ISCHAN + DO 127 KLOOP = 1, KTLOOP + CNEW( KLOOP,JNEW) = CORIG(KLOOP,JNEW) + !--------------------------------------------------------------------- + ! %%%%% MODIFICATION TO PREVENT NEGATIVE CNEW (tmf, 11/1/07) %%%%% + ! Initialize CPREVM with CORIG before 1st internal march + CPREVM( KLOOP,JNEW) = CORIG(KLOOP,JNEW) + !--------------------------------------------------------------------- + 127 CONTINUE + 129 CONTINUE + +C +C ********************************************************************* +C RE-ENTER HERE IF TOTAL FAILURE OR IF RESTARTING WITH NEW CELL BLOCK +C ********************************************************************* +C + 140 HRATIO = 0.d0 + ASN1 = 1.d0 + IFSUCCESS = 1 + RDELMAX = 1.0d+04 + +C ********************************************************************* +C INITIALIZE PHOTRATES +C ********************************************************************* +C + ! Called for photorates with no active loss terms (bdf, 4/18/03) + IF (IFSUN.EQ.1) CALL UPDATE +C +C ********************************************************************* +C INITIALIZE FIRST DERIVATIVE FOR CHEMISTRY +C ********************************************************************* +C + CALL SUBFUN + + +C +C ********************************************************************* +C DETERMINE INITIAL ABSOLUTE ERROR TOLERANCE +C ********************************************************************* +C IABOVK = NUMBER OF SPECIES WHOSE CONCENTRATIONS ARE LARGER THAN YABST +C ISREORD = 1: CALC INITIAL STIFFNESS BEFORE RUNNING CODE TO REORDER CELLS +C IN THIS CASE, USE PHOTORATES FOR END OF TIME-INTERVAL +C = 2: DO NORMAL CALCULATIONS +C KGRP = COUNTS NUMBER OF CONCENTRATIONS ABOVE ABTOL(I), I = 1.. +C YABST = ABSOLUTE ERROR TOLERANCE (MOLEC. CM-3 FOR GASES) +C ABTOL = PRE-DEFINED ABSOLUTE ERROR TOLERANCES +C + DO 142 KLOOP = 1, KTLOOP + ERRHOLD(KLOOP) = 0.d0 + 142 CONTINUE +C + ! EXPLANATORY NOTE: + ! We don't reorder: IFREORD=0 in mglob.dat, (tmf, 11/1/07) + IF (ISREORD.NE.1) THEN +C + DO 134 K = 1, 5 + DO 132 KLOOP = 1, KTLOOP + KGRP(KLOOP,K) = 0 + 132 CONTINUE + 134 CONTINUE +C + DO 136 JSPC = 1, ISCHAN + !--------------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic. This prevents ND65 + ! prod/loss species from being counted towards the convergence + ! criteria for the SMVGEAR solver (ljm, bmy, 5/9/03) + IF ( ITS_NOT_A_ND65_FAMILY(JSPC) ) THEN + DO 135 KLOOP = 1, KTLOOP + CNW = CNEW(KLOOP,JSPC) + IF (CNW.GT.ABTOL(1,NCS)) THEN + KGRP(KLOOP,1) = KGRP(KLOOP,1) + 1 + ELSEIF (CNW.GT.ABTOL(2,NCS)) THEN + KGRP(KLOOP,2) = KGRP(KLOOP,2) + 1 + ELSEIF (CNW.GT.ABTOL(3,NCS)) THEN + KGRP(KLOOP,3) = KGRP(KLOOP,3) + 1 + ELSEIF (CNW.GT.ABTOL(4,NCS)) THEN + KGRP(KLOOP,4) = KGRP(KLOOP,4) + 1 + ELSEIF (CNW.GT.ABTOL(5,NCS)) THEN + KGRP(KLOOP,5) = KGRP(KLOOP,5) + 1 + ENDIF + 135 CONTINUE + ENDIF + !--------------------------------------------------------------------- + 136 CONTINUE + +C + + DO 137 KLOOP = 1, KTLOOP + K1 = KGRP(KLOOP,1) + K2 = KGRP(KLOOP,2) + K1 + K3 = KGRP(KLOOP,3) + K2 + K4 = KGRP(KLOOP,4) + K3 + K5 = KGRP(KLOOP,5) + K4 + IF (K1.GT.IABOVK(KLOOP)) THEN + YABST(KLOOP) = ABTOL(1,NCS) + ELSEIF (K2.GT.IABOVK(KLOOP)) THEN + YABST(KLOOP) = ABTOL(2,NCS) + ELSEIF (K3.GT.IABOVK(KLOOP)) THEN + YABST(KLOOP) = ABTOL(3,NCS) + ELSEIF (K4.GT.IABOVK(KLOOP)) THEN + YABST(KLOOP) = ABTOL(4,NCS) + ELSEIF (K5.GT.IABOVK(KLOOP)) THEN + YABST(KLOOP) = ABTOL(5,NCS) + ELSE + YABST(KLOOP) = ABTOL(6,NCS) + ENDIF + 137 CONTINUE +C + DO 139 JSPC = 1, ISCHAN + !-------------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic. This prevents ND65 + ! prod/loss species from being counted towards the convergence + ! criteria for the SMVGEAR solver (ljm, bmy, 5/9/03) + IF ( ITS_NOT_A_ND65_FAMILY(JSPC) ) THEN + DO 138 KLOOP = 1, KTLOOP + CNEWYLOW = CNEW(KLOOP,JSPC) + YABST(KLOOP) *RELTOL1 + ERRYMAX = GLOSS(KLOOP,JSPC) / CNEWYLOW + ERRHOLD(KLOOP) = ERRHOLD(KLOOP) + ERRYMAX * ERRYMAX + 138 CONTINUE + ENDIF + !-------------------------------------------------------------------- + 139 CONTINUE + +C + ELSE + +! EXPLANATORY NOTE: This is not used (tmf, 11/1/07) +C +C ********************************************************************* +C USE LOWEST ABSOLUTE ERROR TOLERANCE WHEN REORDERING +C IF REORDERING, SET ERRMX2 THEN RETURN TO PHYSPROC.F +C ********************************************************************* +C ABTOLER1 = YFAC * ABTOL(6,NCS) / MIN(ERRMAX,1.0E-03) +C + DO 144 JSPC = 1, ISCHAN + !-------------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic. This prevents ND65 + ! prod/loss species from being counted towards the convergence + ! criteria for the SMVGEAR solver (ljm, bmy, 5/9/03) + IF ( ITS_NOT_A_ND65_FAMILY(JSPC) ) THEN + DO 143 KLOOP = 1, KTLOOP + ERRYMAX = GLOSS(KLOOP,JSPC)/ + & (CNEW(KLOOP,JSPC)+ABTOLER1) + ERRHOLD(KLOOP) = ERRHOLD(KLOOP) + ERRYMAX * ERRYMAX + 143 CONTINUE + ENDIF + !-------------------------------------------------------------------- + 144 CONTINUE +C + IF (ISREORD.EQ.1) THEN + DO 150 KLOOP = 1, KTLOOP + ERRMX2(JLOOPLO+KLOOP) = ERRHOLD(KLOOP) + 150 CONTINUE +C + RETURN + ENDIF + ENDIF + +! EXPLANATORY NOTE (tmf, 11/1/07) +! This is the end of the ISREORDER condition. + +C +C ********************************************************************* +C CALCULATE INITIAL TIME STEP SIZE (S) +C ********************************************************************* +C SQRT(ERRHOLD / [ERRINIT * ORDER]) = RMSNORM OF ERROR SCALED TO ERRINIT +C * CNEW + ABTOL/RELTOL +C + RMSTOP = 0.d0 +C + DO 151 KLOOP = 1, KTLOOP + IF (ERRHOLD(KLOOP).GT.RMSTOP) RMSTOP = ERRHOLD(KLOOP) + 151 CONTINUE +C + DELT1 = SQRT(ERRINIT / (ABST2(NCS) + RMSTOP / ORDER)) + + !----------------------------------------------------------------------- + ! %%%%% MODIFICATION TO PREVENT NEGATIVE CNEW (tmf, 11/1/07) %%%%% + ! + ! If IDTFORCE==0 then compute DELT w/ the original method + ! If IDTFORCE==1 then manually set DELT to DTFORCE + IF ( IDTFORCE == 0 ) THEN + DELT = MAX( MIN( DELT1, TIMREMAIN, HMAX ), HMIN ) + ELSE + DELT = DTFORCE + ENDIF + + ! Reset IDTFORCE for next internal timestep march + IDTFORCE = 0 + !----------------------------------------------------------------------- +C +C ********************************************************************* +C SET INITIAL ORDER TO 1 +C ********************************************************************* +C + NQQOLD = 0 + NQQ = 1 + JEVAL = 1 + RDELT = 1.0d0 + +C +C ********************************************************************* +C * STORE INITIAL CONCENTRATION AND FIRST DERIVATIVES x TIME-STEP * +C ********************************************************************* +C + DO 155 JSPC = 1, ISCHAN + JS1 = ISCHAN + JSPC + DO 154 KLOOP = 1, KTLOOP + CONC(KLOOP,JSPC) = CNEW(KLOOP,JSPC) + CONC(KLOOP,JS1) = DELT * GLOSS(KLOOP,JSPC) + 154 CONTINUE + 155 CONTINUE + +C +C ********************************************************************* +C ** UPDATE COEFFICIENTS OF THE ORDER. NQQ IS THE ORDER. ASET AND ** +C ** PERTS2 ARE DEFINED IN SUBROUTINE KSPARSE. NOTE THAT PERTS2 ** +C ** IS THE ORIGINAL PERTST**2 ** +C ********************************************************************* +C + + 170 IF (NQQ.NE.NQQOLD) THEN + NQQOLD = NQQ + KSTEP = NQQ + 1 + HRATIO = HRATIO * ASET(NQQ,1) / ASN1 + ASN1 = ASET(NQQ,1) + ENQQ = PERTS2(NQQ,1) * ORDER + EUP = PERTS2(NQQ,2) * ORDER + EDWN = PERTS2(NQQ,3) * ORDER + CONP3 = 1.4d0 / ( EUP**ENQQ3(NQQ)) + CONP2 = 1.2d0 / (ENQQ**ENQQ2(NQQ)) + CONP1 = 1.3d0 / (EDWN**ENQQ1(NQQ)) + NQQISC = NQQ * ISCHAN + ENDIF + counter=counter+1 + +C +C ********************************************************************* +C LIMIT SIZE OF RDELT, THEN RECALCULATE NEW TIME STEP AND UPDATE +C HRATIO. USE HRATIO TO DETERMINE WHETHER PDERIV SHOULD BE CALLED AGAIN +C ********************************************************************* +C + HMTIM = MIN(HMAX,TIMREMAIN) + RDELT = MIN(RDELT,RDELMAX,HMTIM/DELT) + DELT = DELT * RDELT + HRATIO = HRATIO * RDELT + XELAPS = XELAPS + DELT + + +C + IF (ABS(HRATIO-1.0).GT.HRMAX.OR.NSTEPS.GE.NSLP) JEVAL = 1 +C +C ********************************************************************* +C IF TIME STEP < HMIN, TIGHTEN ABSOLOUTE ERROR TOLERANCE AND +C RESTART INTEGRATION AT BEGINNING OF TIME INTERVAL +C ********************************************************************* +C + IF (DELT.LT.HMIN) THEN + WRITE(6,233)DELT,KBLK,KTLOOP,NCS,TIME,TIMREMAIN,YFAC,ERRMAX(NCS) + NYLOWDEC = NYLOWDEC + 1 + YFAC = YFAC * 0.01d0 +C + IF (NYLOWDEC.EQ.10) THEN + LLOOPA = 1 + LLOOPB = KTLOOP + WRITE(6,234) +C + DO 177 KLOOP = 1, KTLOOP + JLOOP = JREORDER(JLOOPLO+KLOOP) + K = (JLOOP - 1) / NLOOP + 1 + MLOOP = JLOOP - (K - 1) * NLOOP + M1 = (MLOOP - 1) / NLONG + 1 + M2 = MLOOP - (M1 - 1) * NLONG + WRITE(6,685) M1, M2, K, ERRHOLD(KLOOP) + 177 CONTINUE +C + DO 178 JNEW = 1, ISCHAN + JOLD = INEWOLD(JNEW,NCS) + WRITE(6,690) JNEW, NCS, NAMENCS(JOLD,NCS),CORIG(LLOOPA,JNEW), + 1 CORIG(LLOOPB,JNEW) + 178 CONTINUE + + ! Stop run w/ error msg + CALL GEOS_CHEM_STOP + ENDIF +C + GOTO 120 + ENDIF + +C +C ********************************************************************* +C * IF THE DELT IS DIFFERENT THAN DURING THE LAST STEP (IF RDELT NE * +C * 1), THEN SCALE THE DERIVATIVES * +C ********************************************************************* +C + IF (RDELT.NE.1.0) THEN + RDELTA = 1.0d0 + I1 = 1 + DO 184 J = 2, KSTEP + RDELTA = RDELTA * RDELT + I1 = I1 + ISCHAN + DO 182 I = I1, I1 + ISCHAN1 + DO 180 KLOOP = 1, KTLOOP + CONC(KLOOP,I) = CONC(KLOOP,I) * RDELTA + 180 CONTINUE + 182 CONTINUE + 184 CONTINUE + ENDIF +C +C ********************************************************************* +C * UPDATE PHOTO RATES BECAUSE THE TIME CHANGED. * +C * NOTE THAT A TIME CHANGE COULD CORRESPOND TO EITHER A SUCCESSFUL * +C * OR FAILED STEP * +C ********************************************************************* +C + ! Called for photorates with no active loss terms (bdf, 4/18/03) + IF (IFSUN.EQ.1.AND.XELAPS.NE.XELAPLAST) CALL UPDATE +C +C ********************************************************************* +C * IF THE LAST STEP WAS SUCCESSFUL, RESET RDELMAX = 10 AND UPDATE * +C * THE CHOLD ARRAY WITH CURRENT VALUES OF CNEW. * +C ********************************************************************* +C + IF (IFSUCCESS.EQ.1) THEN + RDELMAX = 10.d0 +C +C ********************************************************************* +C DETERMINE NEW ABSOLUTE ERROR TOLERANCE +C ********************************************************************* +C KGRP = COUNTS NUMBER OF CONCENTRATIONS ABOVE ABTOL(I), I = 1.. +C YABST = ABSOLUTE ERROR TOLERANCE (MOLEC. CM-3 FOR GASES) +C ABTOL = PRE-DEFINED ABSOLUTE ERROR TOLERANCES +C +C EXPLANATORY NOTES (tmf, 11/1/07) +C (1) If the previous step is successful, then redetermine +C the absolute error tolerance every on 3rd step. +C ********************************************************************* +C + IF (MOD(NSTEPS,3).EQ.2) THEN + DO 203 K = 1, 5 + DO 201 KLOOP = 1, KTLOOP + KGRP(KLOOP,K) = 0 + 201 CONTINUE + 203 CONTINUE +C + DO 207 JSPC = 1, ISCHAN + !-------------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic. This prevents ND65 + ! prod/loss species from being counted towards the convergence + ! criteria for the SMVGEAR solver (ljm, bmy, 5/9/03) + IF ( ITS_NOT_A_ND65_FAMILY(JSPC) ) THEN + DO 205 KLOOP = 1, KTLOOP + CNW = CNEW(KLOOP,JSPC) + IF (CNW.GT.ABTOL(1,NCS)) THEN + KGRP(KLOOP,1) = KGRP(KLOOP,1) + 1 + ELSEIF (CNW.GT.ABTOL(2,NCS)) THEN + KGRP(KLOOP,2) = KGRP(KLOOP,2) + 1 + ELSEIF (CNW.GT.ABTOL(3,NCS)) THEN + KGRP(KLOOP,3) = KGRP(KLOOP,3) + 1 + ELSEIF (CNW.GT.ABTOL(4,NCS)) THEN + KGRP(KLOOP,4) = KGRP(KLOOP,4) + 1 + ELSEIF (CNW.GT.ABTOL(5,NCS)) THEN + KGRP(KLOOP,5) = KGRP(KLOOP,5) + 1 + ENDIF + 205 CONTINUE + ENDIF + !-------------------------------------------------------------------- + 207 CONTINUE +C + DO 209 KLOOP = 1, KTLOOP + K1 = KGRP(KLOOP,1) + K2 = KGRP(KLOOP,2) + K1 + K3 = KGRP(KLOOP,3) + K2 + K4 = KGRP(KLOOP,4) + K3 + K5 = KGRP(KLOOP,5) + K4 + IF (K1.GT.IABOVK(KLOOP)) THEN + YABST(KLOOP) = ABTOL(1,NCS) + ELSEIF (K2.GT.IABOVK(KLOOP)) THEN + YABST(KLOOP) = ABTOL(2,NCS) + ELSEIF (K3.GT.IABOVK(KLOOP)) THEN + YABST(KLOOP) = ABTOL(3,NCS) + ELSEIF (K4.GT.IABOVK(KLOOP)) THEN + YABST(KLOOP) = ABTOL(4,NCS) + ELSEIF (K5.GT.IABOVK(KLOOP)) THEN + YABST(KLOOP) = ABTOL(5,NCS) + ELSE + YABST(KLOOP) = ABTOL(6,NCS) + ENDIF + 209 CONTINUE + ENDIF +C +C EXPLANATORY NOTES: (tmf, 11/1/07) +C (1) What is CHOLD? +C CHOLD = 1./( (Relative tolerance) * N + (Absolute tolerance * Yfac) ) + DO 213 JSPC = 1, ISCHAN + !--------------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic. This prevents ND65 + ! prod/loss species from being counted towards the convergence + ! criteria for the SMVGEAR solver (ljm, bmy, 5/9/03) + IF ( ITS_NOT_A_ND65_FAMILY(JSPC) ) THEN + DO 211 KLOOP = 1, KTLOOP + CHOLD(KLOOP,JSPC) = RELTOL3 / (MAX(CNEW(KLOOP,JSPC),0.D0) + 1 + YABST(KLOOP) * RELTOL2) + 211 CONTINUE + ENDIF + !--------------------------------------------------------------------- + 213 CONTINUE +C + ENDIF + +C ENDIF IFSUCCESS.EQ.1 +C +C ********************************************************************* +C * COMPUTE THE PREDICTED CONCENTRATION AND DERIVATIVES BY MULTIPLY- * +C * ING PREVIOUS VALUES BY THE PASCAL TRIANGLE MATRIX. * +C ********************************************************************* +C THIS SET OF OPERATIONS IS EQUIVALENT TO THE REVERSE OF LOOP 419. +C THE EXPANSION OF THE PASCAL TRIANGLE MATRIX WAS CALCULATED BY B. SCHWARTZ. +C THE FIRST DERIVATIVE MULTIPLIED BY THE TIME STEP IS THE SUM +C OF TERMS ADDED TO CONC(KLOOP,I) +C + IF (NQQ.EQ.1) THEN + DO 236 I = 1, ISCHAN + J = I + ISCHAN + DO 235 KLOOP = 1, KTLOOP + CONC(KLOOP,I) = CONC(KLOOP,I) + CONC(KLOOP,J) + 235 CONTINUE + 236 CONTINUE +C + ELSEIF (NQQ.EQ.2) THEN +C + DO 238 I = 1, ISCHAN + J1 = I + ISCHAN + J2 = J1 + ISCHAN + DO 237 KLOOP = 1, KTLOOP + CONC(KLOOP, I) = CONC(KLOOP, I) + CONC(KLOOP,J1) + 1 + CONC(KLOOP,J2) + CONC(KLOOP,J1) = CONC(KLOOP,J1) + CONC(KLOOP,J2) * 2.d0 + 237 CONTINUE + 238 CONTINUE +C + ELSEIF (NQQ.EQ.3) THEN +C + DO 240 I = 1, ISCHAN + J1 = I + ISCHAN + J2 = J1 + ISCHAN + J3 = J2 + ISCHAN + DO 239 KLOOP = 1, KTLOOP + CONC3J3 = CONC(KLOOP,J3) * 3.d0 + CONC(KLOOP, I) = CONC(KLOOP, I) + CONC(KLOOP,J1) + 1 + CONC(KLOOP,J2) + CONC(KLOOP,J3) + CONC(KLOOP,J1) = CONC(KLOOP,J1) + CONC(KLOOP,J2)*2.d0 + CONC3J3 + CONC(KLOOP,J2) = CONC(KLOOP,J2) + CONC3J3 + 239 CONTINUE + 240 CONTINUE +C + ELSEIF (NQQ.EQ.4) THEN +C + DO 242 I = 1, ISCHAN + J1 = I + ISCHAN + J2 = J1 + ISCHAN + J3 = J2 + ISCHAN + J4 = J3 + ISCHAN + DO 241 KLOOP = 1, KTLOOP + CONC3J3 = CONC(KLOOP,J3) * 3.d0 + CONC4J4 = CONC(KLOOP,J4) * 4.d0 + CONC(KLOOP, I) = CONC(KLOOP, I) + CONC(KLOOP,J1) + 1 + CONC(KLOOP,J2) + CONC(KLOOP,J3) + 2 + CONC(KLOOP,J4) + CONC(KLOOP,J1) = CONC(KLOOP,J1) + CONC(KLOOP,J2)*2.d0 + CONC3J3 + 1 + CONC4J4 + CONC(KLOOP,J2) = CONC(KLOOP,J2) + CONC3J3 + CONC(KLOOP,J4)*6.d0 + CONC(KLOOP,J3) = CONC(KLOOP,J3) + CONC4J4 + 241 CONTINUE + 242 CONTINUE +C + ELSEIF (NQQ.EQ.5) THEN +C + DO 244 I = 1, ISCHAN + J1 = I + ISCHAN + J2 = J1 + ISCHAN + J3 = J2 + ISCHAN + J4 = J3 + ISCHAN + J5 = J4 + ISCHAN + DO 243 KLOOP = 1, KTLOOP + CONC3J3 = CONC(KLOOP,J3) * 3.d0 + CONC4J4 = CONC(KLOOP,J4) * 4.d0 + CONC5J5 = CONC(KLOOP,J5) * 5.d0 + CONC10J5 = CONC5J5 + CONC5J5 + CONC(KLOOP, I) = CONC(KLOOP, I) + CONC(KLOOP,J1) + 1 + CONC(KLOOP,J2) + CONC(KLOOP,J3) + 2 + CONC(KLOOP,J4) + CONC(KLOOP,J5) + CONC(KLOOP,J1) = CONC(KLOOP,J1) + CONC(KLOOP,J2)*2.d0 + CONC3J3 + 1 + CONC4J4 + CONC5J5 + CONC(KLOOP,J2) = CONC(KLOOP,J2) + CONC3J3 + CONC(KLOOP,J4)*6.d0 + 1 + CONC10J5 + CONC(KLOOP,J3) = CONC(KLOOP,J3) + CONC4J4 + CONC10J5 + CONC(KLOOP,J4) = CONC(KLOOP,J4) + CONC5J5 + 243 CONTINUE + 244 CONTINUE + ENDIF + +C +C ********************************************************************* +C ************************** CORRECTION LOOP ************************** +C * TAKE UP TO 3 CORRECTOR ITERATIONS. TEST CONVERGENCE BY REQUIRING * +C * THAT CHANGES BE LESS THAN THE RMS NORM WEIGHTED BY CHOLD. * +C * ACCUMULATE THE CORRECTION IN THE ARRAY DTLOS(). IT EQUALS THE * +C * THE J-TH DERIVATIVE OF CONC() MULTIPLIED BY DELT**KSTEP / * +C * (FACTORIAL(KSTEP-1)*ASET(KSTEP)); THUS, IT IS PROPORTIONAL TO THE * +C * ACTUAL ERRORS TO THE LOWEST POWER OF DELT PRESENT (DELT**KSTEP) * +C ********************************************************************* +C + 220 L3 = 0 + DO 232 JSPC = 1, ISCHAN + DO 230 KLOOP = 1, KTLOOP + CNEW(KLOOP,JSPC) = CONC(KLOOP,JSPC) + DTLOS(KLOOP,JSPC) = 0.d0 + 230 CONTINUE + 232 CONTINUE + +C +C ********************************************************************* +C * IF JEVAL = 1, RE-EVALUATE PREDICTOR MATRIX P = I - H * ASET(1) *J * +C * BEFORE STARTING THE CORRECTOR ITERATION. AFTER CALLING PDERIV, * +C * SET JEVAL = -1 TO PREVENT RECALLING PDERIV UNLESS NECESSARY LATER.* +C * CALL DECOMP TO DECOMPOSE THE MATRIX * +C ********************************************************************* +C + IF (JEVAL.EQ.1) THEN + R1DELT = -ASN1 * DELT +C + CALL PDERIV +C + CALL DECOMP + JEVAL = -1 + HRATIO = 1.0d0 + NSLP = NSTEPS + MBETWEEN + DRATE = 0.7d0 + + ENDIF + +C +C ********************************************************************* +C * EVALUATE THE FIRST DERIVATIVE USING CORRECTED VALUES OF CNEW * +C ********************************************************************* +C + 270 CALL SUBFUN + +C +C ********************************************************************* +C * IN THE CASE OF THE CHORD METHOD, COMPUTE ERROR (GLOSS) FROM THE * +C * CORRECTED CALCULATION OF THE FIRST DERIVATIVE * +C * * +C * EXPLANATORY NOTES (tmf, 11/1/07) * +C * (1) GLOSS now changes from 1st derivative to error here * +C * (2) GLOSS is now the B matrix in Px = B * +C * (Equation 3 in Jacobson & Turco 1994) * +C * (3) DTLOS is the accumulation of deltaN (x array in Px = B) * +C ********************************************************************* +C + DO 362 JSPC = 1, ISCHAN + J = JSPC + ISCHAN + DO 360 KLOOP = 1, KTLOOP + GLOSS(KLOOP,JSPC) = DELT * GLOSS(KLOOP,JSPC) + 1 - (CONC(KLOOP,J) + DTLOS(KLOOP,JSPC)) + 360 CONTINUE + 362 CONTINUE + + +C +C ********************************************************************* +C * SOLVE THE LINEAR SYSTEM OF EQUATIONS WITH THE CORRECTOR ERROR. * +C * BACKSUB.F SOLVES BACKSUBSTITUTION OVER MATRIX OF PARTIAL DERIVS. * +C * * +C * EXPLANATORY NOTES (tmf, 11/1/07) * +C * (1) BACKSUB solves Px = B. * +C * (2) GLOSS is now the solution B array. * +C ********************************************************************* +C + CALL BACKSUB +C +C ********************************************************************* +C * SUM-UP THE ACCUMULATED ERROR, CORRECT THE CONCENTRATION WITH THE * +C * ERROR, AND BEGIN TO CALCULATE THE RMSNORM OF THE ERROR RELATIVE * +C * TO CHOLD. * +C * * +C * EXPLANATORY NOTES (tmf, 11/1/07) * +C * In loops 366..368 and 370..372 we do the following: * +C * (1) Calculate local error * +C * (2) Update DTLOS = accumulation of delta N * +C * (3) Update CNEW = concentration array * +C ********************************************************************* +C + DO 365 KLOOP = 1, KTLOOP + DELY(KLOOP) = 0.d0 + 365 CONTINUE +C + specmax = 0.0d0 + IF (ASN1.EQ.1.0) THEN + DO 368 I = 1, ISCHAN + DO 366 KLOOP = 1, KTLOOP + DTLOS(KLOOP,I) = DTLOS(KLOOP,I) + GLOSS(KLOOP,I) + CNEW(KLOOP,I) = CONC(KLOOP,I) + DTLOS(KLOOP,I) + !--------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic. This prevents + ! ND65 prod/loss species from being counted towards the + ! convergence criteria for SMVGEAR (ljm, bmy, 5/9/03) + IF ( ITS_NOT_A_ND65_FAMILY(I) ) THEN + ERRYMAX = GLOSS(KLOOP,I) * CHOLD(KLOOP,I) + DELY(KLOOP) = DELY(KLOOP) + ERRYMAX * ERRYMAX + ENDIF + !--------------------------------------------------------------- + 366 CONTINUE + 368 CONTINUE + ELSE + DO 372 I = 1, ISCHAN + DO 370 KLOOP = 1, KTLOOP + DTLOS(KLOOP,I) = DTLOS(KLOOP,I) + GLOSS(KLOOP,I) + CNEW(KLOOP,I) = CONC(KLOOP,I) + ASN1 * DTLOS(KLOOP,I) + !--------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic. This prevents + ! ND65 prod/loss species from being counted towards the + ! convergence criteria for SMVGEAR (ljm, bmy, 5/9/03) + IF ( ITS_NOT_A_ND65_FAMILY(I) ) THEN + ERRYMAX = GLOSS(KLOOP,I) * CHOLD(KLOOP,I) + DELY(KLOOP) = DELY(KLOOP) + ERRYMAX * ERRYMAX + ENDIF + !--------------------------------------------------------------- + 370 CONTINUE + 372 CONTINUE + ENDIF + + +C +C ********************************************************************* +C * SET THE PREVIOUS RMS ERROR AND CALCULATE THE NEW RMS ERROR. * +C * IF DCON < 1, THEN SUFFICIENT CONVERGENCE HAS OCCURRED. OTHERWISE, * +C * IF THE RATIO OF THE CURRENT TO PREVIOUS RMSERR IS DECREASING, * +C * ITERATE MORE. IF IT IS NOT, THEN THE CONVERGENCE TEST FAILED * +C * * +C * EXPLANATORY NOTES (tmf, 11/1/07) * +C * (1) ORDER is the # of species, excluding ND65 families * +C * (2) RMSRAT = (local error this march) / (local error last march) * +C ********************************************************************* +C + RMSERRP = RMSERR + DER2MAX = 0.d0 +C + ksave=0d0 + DO 427 KLOOP = 1, KTLOOP + !----------------------------------------------------------------------- + ! %%%%% MODIFICATION TO PREVENT NEGATIVE CNEW (tmf, 11/1/07) %%%%% + ! Put STOP 700 debug variables into IF statement + !IF (DELY(KLOOP).GT.DER2MAX) DER2MAX = DELY(KLOOP) + !----------------------------------------------------------------------- + IF (DELY(KLOOP).GT.DER2MAX) THEN + DER2MAX = DELY(KLOOP) + ijsave=jlooplo+kloop + ksave=kloop + ENDIF + 427 CONTINUE +C + RMSERR = SQRT(DER2MAX / ORDER) +C + L3 = L3 + 1 +C + IF (L3.GT.1) THEN + RMSRAT = RMSERR / RMSERRP + DRATE = MAX(0.2d0 * DRATE, RMSRAT) + ENDIF +C + DCON = RMSERR * MIN(CONPST(NQQ),CONP15(NQQ)*DRATE) +C +C ********************************************************************* +C IF CONVERGENCE OCCURS, GO ON TO CHECK ACCUMULATED ERROR +C ********************************************************************* +C + + + ! EXPLANATORY NOTE (tmf, 11/1/07) + ! This is where we check for local error convergence + IF (DCON .LE. 1.0) THEN + + ! EXPLANATORY NOTE (tmf, 11/1/07) + ! Go on to check global error + GOTO 390 +C +C ********************************************************************* +C IF NONCONVERGENCE AFTER ONE STEP, RE-EVALUATE FIRST DERIVATIVE WITH +C NEW VALUES OF CNEW +C ********************************************************************* +C +C ELSEIF (L3.LT.MSTEP.AND.(L3.EQ.1.OR.RMSRAT.LE.0.9)) THEN + ELSEIF (L3.EQ.1) THEN + + GOTO 270 +C +C ********************************************************************* +C * THE CORRECTOR ITERATION FAILED TO CONVERGE * +C * IF THE JACOBIAN MATRIX IS MORE THAN ONE STEP OLD, UPDATE THE * +C * JACOBIAN AND TRY CONVERGENCE AGAIN. IF THE JACOBIAN IS CURRENT, * +C * THEN REDUCE THE TIME-STEP, RE-SET THE ACCUMULATED DERIVATIVES TO * +C * THEIR VALUES BEFORE THE FAILED STEP, AND RETRY WITH THE SMALLER * +C * STEP. * +C ********************************************************************* +C + + ELSEIF (JEVAL .EQ. 0) THEN + + ! EXPLANATORY NOTE (tmf, 11/1/07) + ! If Jacobian is old, reevaluate Jacobian with + ! CNEW = CNEW_old + dt*GLOSS(CNEW_old), + ! and reset L3 = 0. + IFAIL = IFAIL + 1 + JEVAL = 1 + + GOTO 220 + ENDIF + +C + 399 NFAIL = NFAIL + 1 + RDELMAX = 2.0d0 + JEVAL = 1 + IFSUCCESS = 0 + XELAPS = TOLD + RDELT = FRACDEC +C +C ********************************************************************* +C SUBTRACT OFF DERIVATIVES PREVIOUSLY ADDED +C ********************************************************************* +C THIS SET OF OPERATIONS IS EQUIVALENT TO LOOP 419. +C + ! EXPLANATORY NOTE (tmf, 11/1/07) + ! The local error is still not converging + IF (NQQ.EQ.1) THEN + DO 376 I = 1, ISCHAN + J = I + ISCHAN + DO 375 KLOOP = 1, KTLOOP + CONC(KLOOP,I) = CONC(KLOOP,I) - CONC(KLOOP,J) + 375 CONTINUE + 376 CONTINUE +C + ELSEIF (NQQ.EQ.2) THEN +C + DO 378 I = 1, ISCHAN + J1 = I + ISCHAN + J2 = J1 + ISCHAN + DO 377 KLOOP = 1, KTLOOP + CONC(KLOOP, I) = CONC(KLOOP, I) - CONC(KLOOP,J1)-CONC(KLOOP,J2) + CONC(KLOOP,J1) = CONC(KLOOP,J1) - CONC(KLOOP,J2) * 2.d0 + 377 CONTINUE + 378 CONTINUE +C + ELSEIF (NQQ.EQ.3) THEN + DO 380 I = 1, ISCHAN + J1 = I + ISCHAN + J2 = J1 + ISCHAN + J3 = J2 + ISCHAN + DO 379 KLOOP = 1, KTLOOP + CONC3J3 = CONC(KLOOP,J3) * 3.d0 + CONC(KLOOP, I) = CONC(KLOOP, I) - CONC(KLOOP,J1) + 1 - CONC(KLOOP,J2) - CONC(KLOOP,J3) + CONC(KLOOP,J1) = CONC(KLOOP,J1) - CONC(KLOOP,J2)*2.d0 - CONC3J3 + CONC(KLOOP,J2) = CONC(KLOOP,J2) - CONC3J3 + 379 CONTINUE + 380 CONTINUE +C + ELSEIF (NQQ.EQ.4) THEN +C + DO 382 I = 1, ISCHAN + J1 = I + ISCHAN + J2 = J1 + ISCHAN + J3 = J2 + ISCHAN + J4 = J3 + ISCHAN + DO 381 KLOOP = 1, KTLOOP + CONC3J3 = CONC(KLOOP,J3) * 3.d0 + CONC4J4 = CONC(KLOOP,J4) * 4.d0 + CONC(KLOOP, I) = CONC(KLOOP, I) - CONC(KLOOP,J1) + 1 - CONC(KLOOP,J2) - CONC(KLOOP,J3) + 2 - CONC(KLOOP,J4) + CONC(KLOOP,J1) = CONC(KLOOP,J1) - CONC(KLOOP,J2)*2.d0 - CONC3J3 + 1 - CONC4J4 + CONC(KLOOP,J2) = CONC(KLOOP,J2) - CONC3J3 - CONC(KLOOP,J4)*6.d0 + CONC(KLOOP,J3) = CONC(KLOOP,J3) - CONC4J4 + 381 CONTINUE + 382 CONTINUE +C + ELSEIF (NQQ.EQ.5) THEN +C + DO 384 I = 1, ISCHAN + J1 = I + ISCHAN + J2 = J1 + ISCHAN + J3 = J2 + ISCHAN + J4 = J3 + ISCHAN + J5 = J4 + ISCHAN + DO 383 KLOOP = 1, KTLOOP + CONC3J3 = CONC(KLOOP,J3) * 3.d0 + CONC4J4 = CONC(KLOOP,J4) * 4.d0 + CONC5J5 = CONC(KLOOP,J5) * 5.d0 + CONC10J5 = CONC5J5 + CONC5J5 + CONC(KLOOP, I) = CONC(KLOOP, I) - CONC(KLOOP,J1) - + 1 CONC(KLOOP,J2) - CONC(KLOOP,J3) - + 2 CONC(KLOOP,J4) - CONC(KLOOP,J5) + CONC(KLOOP,J1) = CONC(KLOOP,J1) - CONC(KLOOP,J2)*2.d0 - CONC3J3 + 1 - CONC4J4 - CONC5J5 + CONC(KLOOP,J2) = CONC(KLOOP,J2) - CONC3J3 - CONC(KLOOP,J4)*6.d0 + 2 - CONC10J5 + CONC(KLOOP,J3) = CONC(KLOOP,J3) - CONC4J4 - CONC10J5 + CONC(KLOOP,J4) = CONC(KLOOP,J4) - CONC5J5 + 383 CONTINUE + 384 CONTINUE + ENDIF + + GOTO 170 +C +C ********************************************************************* +C * THE CORRECTOR ITERATION CONVERGED * +C * SET JEVAL = 0 SO THAT IT DOES NOT NEED TO BE CALLED THE NEXT STEP * +C * IF ALL ELSE GOES WELL. NEXT, TEST THE ACCUMULATED ERROR FROM THE * +C * CONVERGENCE PROCESS, ABOVE * +C ********************************************************************* +C + 390 JEVAL = 0 +C + IF (L3.GT.1) THEN + DO 395 KLOOP = 1, KTLOOP + DELY(KLOOP) = 0.d0 + 395 CONTINUE +C + DO 402 JSPC = 1, ISCHAN + !--------------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic. This prevents ND65 + ! prod/loss species from being counted towards the convergence + ! criteria for the SMVGEAR solver (ljm, bmy, 5/9/03) + IF ( ITS_NOT_A_ND65_FAMILY(JSPC) ) THEN + DO 400 KLOOP = 1, KTLOOP + ERRYMAX = DTLOS(KLOOP,JSPC) * CHOLD(KLOOP,JSPC) + DELY(KLOOP) = DELY(KLOOP) + ERRYMAX * ERRYMAX + 400 CONTINUE + ENDIF + !--------------------------------------------------------------------- + 402 CONTINUE +C + DER2MAX = 0.d0 +C + DO 405 KLOOP = 1, KTLOOP + IF (DELY(KLOOP).GT.DER2MAX) DER2MAX = DELY(KLOOP) + 405 CONTINUE + ENDIF +C +C ********************************************************************* +C * THE ACCUMULATED ERROR TEST FAILED * +C * IN ALL CASES, RE-SET THE DERIVATIVES TO THEIR VALUES BEFORE THE * +C * LAST TIME-STEP. NEXT * +C * * +C * (A) RE-ESTIMATE A TIME-STEP AT THE SAME OR ONE LOWER ORDER AND * +C * RETRY THE STEP. * +C * (B) IF THE FIRST ATTEMPTS FAIL, RETRY THE STEP AT FRACDEC x * +C * THE PRIOR STEP * +C * (C) IF THIS FAILS, RE-SET THE ORDER TO 1 AND GO BACK TO THE * +C * BEGINNING, AT ORDER = 1, BECAUSE ERRORS OF THE WRONG ORDER * +C * HAVE ACCUMULATED * +C ********************************************************************* +C + ! EXPLANATORY NOTE (tmf, 11/1/07) + ! Check if global error is tolerable + IF (DER2MAX.GT.ENQQ) THEN + + XELAPS = TOLD + LFAIL = LFAIL + 1 + JFAIL = JFAIL + 1 +C + I1 = NQQISC + 1 + DO 419 JB = 1, NQQ + I1 = I1 - ISCHAN + DO 417 I = I1, NQQISC + J = I + ISCHAN + DO 415 KLOOP = 1, KTLOOP + CONC(KLOOP,I) = CONC(KLOOP,I) - CONC(KLOOP,J) + 415 CONTINUE + 417 CONTINUE + 419 CONTINUE +C + RDELMAX = 2.0d0 + IF (JFAIL.LE.6) THEN + IFSUCCESS = 0 + RDELTUP = 0.0d0 + + GOTO 540 + + ELSEIF (JFAIL.LE.20) THEN + IFSUCCESS = 0 + RDELT = FRACDEC + + GOTO 170 + + ELSE + DELT = DELT * 0.1d0 + RDELT = 1. + JFAIL = 0 + JRESTAR = JRESTAR + 1 + IDOUB = 5 +C + DO 432 JSPC = 1, ISCHAN + DO 430 KLOOP = 1, KTLOOP + CNEW(KLOOP,JSPC) = CONC(KLOOP,JSPC) + 430 CONTINUE + 432 CONTINUE +C + WRITE(6,670) DELT, XELAPS + !print*, 'kblk = ', kblk !gcc + IF (JRESTAR.EQ.100) THEN + WRITE(6,680) + CALL GEOS_CHEM_STOP + ENDIF +C + GOTO 140 + ENDIF ! end of JFAIL condition +C + ELSE + +C +C ********************************************************************* +C * ALL SUCCESSFUL STEPS COME THROUGH HERE * +C * * +C * AFTER A SUCCESSFUL STEP, UPDATE THE CONCENTRATION AND ALL DERIV- * +C * ATIVES, RESET TOLD, SET IFSUCCESS = 1, INCREMENT NSTEPS, AND * +C * RESET JFAIL = 0. * +C ********************************************************************* +C +!----------------------------------------------------------------------------- +! %%%%% MODIFICATION TO PREVENT NEGATIVE CNEW (tmf, 11/1/07) %%%%% +! +! Even if both local and global error tests are passed, if any of the values +! in the CNEW array are less than zero, start over with a smaller time step, +! and re-evaluate the Jacobian (i.e. GOTO 140). +! + ! Initialize counter + 820 INEG = 0 + + ! Count the # of negatives in CNEW + DO JSPC = 1, ISCHAN + DO KLOOP = 1, KTLOOP + IF ( ITS_NOT_A_ND65_FAMILY(JSPC) ) THEN + IF ( CNEW(KLOOP,JSPC) < 0.d0 ) INEG = INEG + 1 + ENDIF + ENDDO + ENDDO + + ! If there are negatives in CNEW then ... + IF ( INEG > 0 ) THEN + + ! ... Set CNEW to CPREVM. CPREVM stores the values that were in + ! in the CNEW array at the end of the previous successful march. + DO JSPC = 1, ISCHAN + DO KLOOP = 1, KTLOOP + CNEW(KLOOP,JSPC) = CPREVM(KLOOP,JSPC) + ENDDO + ENDDO + + ! ... Then reset the various time & tolerance variables + XELAPS = TOLD + JEVAL = 1 + IFSUCCESS = 0 + DTFORCE = DELT * FRACDEC + IDTFORCE = 1 + RDELT = 1.d0 + JFAIL = 0 + JRESTAR = JRESTAR + 1 + IDOUB = 5 + L3 = 0 + + ! ... Then try another march + GOTO 140 + + ENDIF +!------------------------------------------------------------------------------ + + JFAIL = 0 + IFSUCCESS = 1 + NSTEPS = NSTEPS + 1 + TOLD = XELAPS +C +C ********************************************************************* +C + I1 = 1 + DO 474 J = 2, KSTEP + I1 = I1 + ISCHAN + ASNQQJ = ASET(NQQ,J) + DO 472 JSPC = 1, ISCHAN + I = JSPC + I1 - 1 + DO 470 KLOOP = 1, KTLOOP + CONC(KLOOP,I) = CONC(KLOOP,I) + ASNQQJ * DTLOS(KLOOP,JSPC) + 470 CONTINUE + 472 CONTINUE + 474 CONTINUE +C + IF (ASN1.EQ.1.0) THEN + DO 473 JSPC = 1, ISCHAN + DO 471 KLOOP = 1, KTLOOP + CONC( KLOOP,JSPC) = CONC( KLOOP,JSPC) + DTLOS(KLOOP,JSPC) + 471 CONTINUE + 473 CONTINUE + ELSE + DO 477 JSPC = 1, ISCHAN + DO 475 KLOOP = 1, KTLOOP + CONC( KLOOP,JSPC) = CONC( KLOOP,JSPC) + ASN1*DTLOS(KLOOP,JSPC) + 475 CONTINUE + 477 CONTINUE + ENDIF +C +C ********************************************************************* +C EXIT SMVGEAR IF A TIME INTERVAL HAS BEEN COMPLETED +C ********************************************************************* +C + TIMREMAIN = TINTERVAL - XELAPS + + IF (TIMREMAIN.LE.1.0d-06) GOTO 650 + + ! Increment counter of internal timesteps + ICOUNT = ICOUNT + 1 + + ! STOP 700 error -- nonconvergence after many tries + IF ( DELT < HMIN .or. ICOUNT > MAX_ITERATIONS ) THEN + + WRITE( 6, '(/,a)' ) 'SMVGEAR ERROR -- nonconvergence!' + WRITE( 6, '( a)' ) '---------------------------------' + + ! Write DELT and HMIN + WRITE( 6, 231 ) DELT, HMIN + 231 FORMAT( 'DELT = ', ES10.3, ' HMIN = ', ES10.3 ) + + ! List all kinetic and photo reactions + WRITE( 6, '(/,a)' ) 'Kinetic and Photolysis Reactions:' + WRITE( 6, '( a)' ) '---------------------------------' + + DO NK = 1, NALLRAT(NCS) + WRITE( 6, 248 ) NK, RRATE(KSAVE,NK),TRATE(KSAVE,NK) + 248 FORMAT( 'Rxn #:', i5, ' RRATE = ', es13.6 , + x ' TRATE = ', es13.6 ) + ENDDO + + ! List various SMVGEAR parameters + WRITE( 6, * ) 'RDELT = ', RDELT + WRITE( 6, * ) 'TIMREMAIN = ', TIMREMAIN + WRITE( 6, * ) 'HMAX = ', HMAX + WRITE( 6, * ) 'RDELMAX = ', RDELMAX + WRITE( 6, * ) 'HRATIO = ', HRATIO + + ! Write offending grid box + IX = IXSAVE(IJSAVE) + IY = IYSAVE(IJSAVE) + IZ = IZSAVE(IJSAVE) + WRITE( 6, * ) 'TROUBLE BOX = ', IX, IY, IZ + + ! Nonconvergence after too many iterations + IF ( ICOUNT > MAX_ITERATIONS ) THEN + WRITE( 6, * ) 'ICOUNT = ', ICOUNT + WRITE( 6, * ) 'Too many iterations!' + ENDIF + + ! Stop w/ error msg + WRITE( 6, '(/,a)' ) 'STOP 700 in smvgear.f' + CALL GEOS_CHEM_STOP + ENDIF +C +C ********************************************************************* +C * IDOUB COUNTS THE NUMBER OF SUCCESSFUL STEPS BEFORE RE-TESTING THE * +C * STEP-SIZE AND ORDER * +C * * +C * IF IDOUB > 1, DECREASE IDOUB AND GO ON TO THE NEXT TIME-STEP WITH * +C * THE CURRENT STEP-SIZE AND ORDER. * +C * IF IDOUB = 1, STORE THE VALUE OF THE ERROR (DTLOS) FOR THE TIME- * +C * STEP PREDICTION, WHICH WILL OCCUR WHEN IDOUB = 0, * +C * BUT GO ON TO THE NEXT STEP WITH THE CURRENT STEP- * +C * SIZE AND ORDER. * +C * IF IDOUB = 0, TEST THE TIME-STEP AND ORDER FOR A CHANGE. * +C ********************************************************************* +C + IF (IDOUB.GT.1) THEN + IDOUB = IDOUB - 1 + IF (IDOUB.EQ.1) THEN + DO 527 JSPC = 1, ISCHAN, 2 + JG1 = JSPC + 1 + DO 525 KLOOP = 1, KTLOOP + CEST(KLOOP,JSPC) = DTLOS(KLOOP,JSPC) + CEST(KLOOP,JG1) = DTLOS(KLOOP,JG1) + 525 CONTINUE + 527 CONTINUE + ENDIF + RDELT = 1.0d0 + + !--------------------------------------------------------------------- + ! %%%%% MODIFICATION TO PREVENT NEGATIVE CNEW (tmf, 11/1/07) %%%%% + ! + ! Store successful CNEW in CPREVM. CPREVM will be used in a future + ! march to re-initialize the CNEW array if negatives are found. + ! + DO JSPC = 1, ISCHAN + DO KLOOP = 1, KTLOOP + CPREVM(KLOOP,JSPC) = CNEW(KLOOP,JSPC) + ENDDO + ENDDO + !--------------------------------------------------------------------- + + GOTO 170 + ENDIF +C + ENDIF +C ENDIF DER2MAX.GT.ENQQ +C +C ********************************************************************* +C * TEST WHETHER TO CHANGE THE STEP-SIZE AND ORDER * +C * DETERMINE THE TIME-STEP AT (A) ONE ORDER LOWER THAN, (B) THE SAME * +C * ORDER AS, AND (C) ONE ORDER HIGHER THAN THE CURRENT ORDER. IN THE * +C * CASE OF MULTIPLE GRID-CELLS IN A GRID-BLOCK, FIND THE MINIMUM * +C * STEP-SIZE AMONG ALL THE CELLS FOR EACH OF THE ORDERS. THEN, IN * +C * ALL CASES, CHOOSE THE LONGEST TIME-STEP AMONG THE THREE STEPS * +C * PAIRED WITH ORDERS, AND CHOOSE THE ORDER ALLOWING THIS LONGEST * +C * STEP. * +C ********************************************************************* +C +C ********************************************************************* +C * ESTIMATE THE TIME-STEP RATIO (RDELTUP) AT ONE ORDER HIGHER THAN * +C * THE CURRENT ORDER. IF NQQ >= MAXORD, THEN WE DO NOT ALLOW THE * +C * ORDER TO INCREASE. * +C ********************************************************************* +C + IF (NQQ.LT.MAXORD) THEN + DO 542 KLOOP = 1, KTLOOP + DELY(KLOOP) = 0.d0 + 542 CONTINUE +C + DO 545 JSPC = 1, ISCHAN + !--------------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic. This prevents ND65 + ! prod/loss species from being counted towards the convergence + ! criteria for the SMVGEAR solver (ljm, bmy, 5/9/03) + IF ( ITS_NOT_A_ND65_FAMILY(JSPC) ) THEN + DO 544 KLOOP = 1, KTLOOP + ERRYMAX = (DTLOS(KLOOP,JSPC) - CEST(KLOOP,JSPC)) * + 1 CHOLD(KLOOP,JSPC) + DELY(KLOOP) = DELY(KLOOP) + ERRYMAX * ERRYMAX + if (errymax .gt. specmax) then + errymax = specmax + jspcsave(kloop) = i + endif + 544 CONTINUE + ENDIF + !--------------------------------------------------------------------- + 545 CONTINUE +C + DER3MAX = 0.d0 +C + DO 546 KLOOP = 1, KTLOOP + IF (DELY(KLOOP).GT.DER3MAX) DER3MAX = DELY(KLOOP) + 546 CONTINUE +C + RDELTUP = 1.0d0 / (CONP3*DER3MAX**ENQQ3(NQQ)+1.4d-6) + ELSE + RDELTUP = 0.0d0 + ENDIF +C +C ********************************************************************* +C * ESTIMATE THE TIME-STEP RATIO (RDELTSM) AT THE CURRENT ORDER * +C * WE CALCULATED DER2MAX DURING THE ERROR TESTS EARLIER * +C ********************************************************************* +C + 540 RDELTSM = 1.0d0 / (CONP2*DER2MAX**ENQQ2(NQQ)+1.2d-6) +C +C ********************************************************************* +C * ESTIMATE THE TIME-STEP RATIO (RDELTDN) AT ONE ORDER LOWER THAN * +C * THE CURRENT ORDER. IF NQQ = 1, THEN WE CANNOT TEST A LOWER ORDER. * +C ********************************************************************* +C + IF (NQQ.GT.1) THEN + DO 552 KLOOP = 1, KTLOOP + DELY(KLOOP) = 0.d0 + 552 CONTINUE +C + KSTEPISC = (KSTEP - 1) * ISCHAN + DO 555 JSPC = 1, ISCHAN + !--------------------------------------------------------------------- + ! Added for the ND65 prod/loss diagnostic. This prevents ND65 + ! prod/loss species from being counted towards the convergence + ! criteria for the SMVGEAR solver (ljm, bmy, 5/9/03) + IF ( ITS_NOT_A_ND65_FAMILY(JSPC) ) THEN + I = JSPC + KSTEPISC + DO 554 KLOOP = 1, KTLOOP + ERRYMAX = CONC(KLOOP,I) * CHOLD(KLOOP,JSPC) + DELY(KLOOP) = DELY(KLOOP) + ERRYMAX * ERRYMAX + 554 CONTINUE + ENDIF + !--------------------------------------------------------------------- + 555 CONTINUE +C + DER1MAX = 0.d0 +C + DO 556 KLOOP = 1, KTLOOP + IF (DELY(KLOOP).GT.DER1MAX) DER1MAX = DELY(KLOOP) + 556 CONTINUE + + RDELTDN = 1.0d0 / (CONP1*DER1MAX**ENQQ1(NQQ)+1.3d-6) +C + ELSE + RDELTDN = 0.d0 + ENDIF +C +C ********************************************************************* +C * FIND THE LARGEST OF THE PREDICTED TIME-STEPS RATIOS OF EACH ORDER * +C ********************************************************************* +C + RDELT = MAX(RDELTUP,RDELTSM,RDELTDN) +C +C ********************************************************************* +C * IF THE LAST STEP WAS SUCCESSFUL AND RDELT IS SMALL, KEEP THE * +C * CURRENT STEP AND ORDER AND ALLOW THREE SUCCESSFUL STEPS BEFORE * +C * RE-CHECKING THE TIME-STEP AND ORDER. * +C ********************************************************************* +C + IF (RDELT.LT.1.1.AND.IFSUCCESS.EQ.1) THEN + IDOUB = 3 + GOTO 170 +C +C ********************************************************************* +C * IF THE MAXIMUM TIME-STEP RATIO IS THAT OF ONE ORDER LOWER THAN * +C * THE CURRENT ORDER, DECREASE THE ORDER. DO NOT MINIMIZE RDELT * +C * TO =< 1 WHEN IFSUCCESS = 0 SINCE THIS IS LESS EFFICIENT. * +C ********************************************************************* +C + ELSEIF (RDELT.EQ.RDELTDN) THEN + NQQ = NQQ - 1 + +C +C ********************************************************************* +C * IF THE MAXIMUM TIME-STEP RATIO IS THAT OF ONE ORDER HIGHER THAN * +C * THE CURRENT ORDER, INCREASE THE ORDER AND ADD A DERIVATIVE TERM * +C * FOR THE HIGHER ORDER. * +C ********************************************************************* +C + ELSEIF (RDELT.EQ.RDELTUP) THEN + CONSMULT = ASET(NQQ,KSTEP) / FLOAT(KSTEP) + NQQ = KSTEP + NQISC = NQQ * ISCHAN + DO 602 JSPC = 1, ISCHAN, 2 + JG1 = JSPC + 1 + I1 = JSPC + NQISC + I2 = JG1 + NQISC + DO 600 KLOOP = 1, KTLOOP + CONC(KLOOP,I1) = DTLOS(KLOOP,JSPC) * CONSMULT + CONC(KLOOP,I2) = DTLOS(KLOOP,JG1) * CONSMULT + 600 CONTINUE + 602 CONTINUE + + + ENDIF +C +C ********************************************************************* +C * IF THE LAST TWO STEPS HAVE FAILED, RE-SET IDOUB TO THE CURRENT * +C * ORDER + 1. DO NOT MINIMIZE RDELT IF JFAIL.GE.2 SINCE TESTS SHOW * +C * THAT THIS MERELY LEADS TO ADDITIONAL COMPUTATIONS. * +C ********************************************************************* +C + IDOUB = NQQ + 1 +C + + GOTO 170 +C +C ********************************************************************* +C * UPDATE COUNTERS * +C ********************************************************************* +C + 650 NSFTOT = NSFTOT + NSUBFUN + NPDTOT = NPDTOT + NPDERIV + NSTTOT = NSTTOT + NSTEPS + IFAILTOT = IFAILTOT + IFAIL + NFAILTOT = NFAILTOT + NFAIL + LFAILTOT = LFAILTOT + LFAIL + +C +C ********************************************************************* +C * SET FINAL CONCENTRATION FOR RUN AND UPDATE COUNTERS * +C ********************************************************************* +C + DO JSPC = 1, ISCHAN + DO KLOOP = 1, KTLOOP + + ! Stop with an error message if NaN's are encountered + ! (bmy, pip, 4/27/00) + IF ( IT_IS_NAN( CNEW(KLOOP,JSPC) ) ) THEN + DO NK = 1, NALLRAT(NCS) + WRITE( 6, 249 ) NK, RRATE(KLOOP,NK),TRATE(KLOOP,NK),KLOOP + 249 FORMAT( 'Rxn #:', i5, ' RRATE = ', es13.6 , + x ' TRATE = ', es13.6, 'KLOOP = ', I6 ) + ENDDO + write(6,*) 'sum of rrate = ',sum(rrate) + PRINT*, 'SMVGEAR: CNEW is NaN!' + PRINT*, 'Species index : ', JSPC + PRINT*, 'Species NAME : ', NAMEGAS(JSPC) + + PRINT*, 'Grid Box : ', IXSAVE(KLOOP+JLOOPLO), + & IYSAVE(KLOOP+JLOOPLO), IZSAVE(KLOOP+JLOOPLO) + PRINT*, 'STOP AT END OF smvgear.f!' + + ! Stop the run and deallocate all arrays + CALL GEOS_CHEM_STOP + ENDIF + +!------------------------------------------------------------------------------ +! %%%%% MODIFICATION TO PREVENT NEGATIVE CNEW (tmf, 11/1/07) %%%%% +! +! The previous code would reset negative CNEW to a small positive #. We don't +! want to do that anymore. If any negative CNEW values exist at the end of +! an internal march, we reset the timestep and re-evaluate the Jacobian. +! (see at CONTINUE statement 820). +! +! However, if any negative values in CNEW still exist at this point, we will +! stop the run and print out debug information. + + + IF ( ITS_NOT_A_ND65_FAMILY(JSPC) ) THEN + + IF ( CNEW(KLOOP,JSPC) .LT. 0d0 ) THEN + DO NK = 1, NALLRAT(NCS) + WRITE( 6, 249 ) NK, RRATE(KSAVE,NK),TRATE(KSAVE,NK) + 250 FORMAT( 'Rxn #:', i5, ' RRATE = ', es13.6 , + x ' TRATE = ', es13.6 ) + ENDDO + write(6,*) 'sum of rrate = ',sum(rrate) + PRINT*, 'SMVGEAR: CNEW is negative!' + PRINT*, 'Species index : ', JSPC, 'CNEW =', CNEW(KLOOP,JSPC) + PRINT*, 'Grid Box : ', IXSAVE(KLOOP+JLOOPLO), + & IYSAVE(KLOOP+JLOOPLO), IZSAVE(KLOOP+JLOOPLO) + PRINT*, 'STOP in smvgear.f!' + + ! Stop the run and deallocate all arrays + CALL GEOS_CHEM_STOP + ENDIF + + ENDIF + + ! Comment this line out, we don't want to reset CNEW anymore + !! Reset negatives to a very small positive number + !CNEW(KLOOP,JSPC) = MAX(CNEW(KLOOP,JSPC),SMAL2) + +!------------------------------------------------------------------------------ + + ENDDO + ENDDO + + +C +C +C ********************************************************************* +C FORMATS +C ********************************************************************* +C + 233 FORMAT('SMVGEAR: DELT= ',1PE8.2,' TOO LOW DEC YFAC. KBLK, ', + 1 'KTLOOP, NCS, TIME, TIMREMAIN, YFAC, ', + 2 'EPS = ',/3(1X,I4),2X,4(1PE9.3,1X)) + 234 FORMAT('SMVGEAR: TOO MANY DECREASES OF YFAC ') + 670 FORMAT('DELT DEC TO =',E13.5,'; TIME ',E13.5,' BECAUSE ', + 1 'EXCESSIVE ERRORS') + 680 FORMAT('SMVGEAR: STOP BECAUSE OF EXCESSIVE ERRORS.') + 685 FORMAT('M1,M2,K,ERR = ',3(I4),2X,1PE10.4) + 690 FORMAT('CONC WHEN STOP = ',2(I4,1X),A14,2(1X,1PE10.2)) +C +C ********************************************************************* +C *************** END OF SUBROUTINE SMVGEAR ******************* +C ********************************************************************* +C + RETURN + END SUBROUTINE SMVGEAR diff --git a/code/soilbase.f b/code/soilbase.f new file mode 100644 index 0000000..4b46b81 --- /dev/null +++ b/code/soilbase.f @@ -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 diff --git a/code/soilcrf.f b/code/soilcrf.f new file mode 100644 index 0000000..8137b58 --- /dev/null +++ b/code/soilcrf.f @@ -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 diff --git a/code/soiltemp.f b/code/soiltemp.f new file mode 100644 index 0000000..5dce386 --- /dev/null +++ b/code/soiltemp.f @@ -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 diff --git a/code/soiltype.f b/code/soiltype.f new file mode 100644 index 0000000..c348cff --- /dev/null +++ b/code/soiltype.f @@ -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 diff --git a/code/streets_anthro_mod.f b/code/streets_anthro_mod.f new file mode 100644 index 0000000..46e8e3f --- /dev/null +++ b/code/streets_anthro_mod.f @@ -0,0 +1,3043 @@ +! $Id: streets_anthro_mod.f,v 1.3 2012/05/09 22:31:56 nicolas Exp $ + MODULE STREETS_ANTHRO_MOD +! +!****************************************************************************** +! Module STREETS_ANTHRO_MOD contains variables and routines to read the +! David Streets et al Asian anthropogenic emissions for NOx and CO. +! (yxw, bmy, 8/16/06, 3/11/09) +! +! Module Variables: +! ============================================================================ +! (1 ) A_CM2 (REAL*8 ) : Array for grid box surface area [cm2] +! (2 ) MASK_CHINA_1x1 (INTEGER) : Mask for the China region at 1x1 +! (2 ) MASK_CHINA (REAL*8) : Mask for the China region (for 2001 CO) +! (3 ) MASK_SE_ASIA (REAL*8) : Mask for the SE Asia region (for 2000 emiss) +! (4 ) NOx (REAL*8) : Streets anthro NOx emissions [kg/yr] +! (5 ) CO (REAL*8) : Streets anthro CO emissions [kg/yr] +! (6 ) SO2 (REAL*8) : Streets anthro SO2 emissions [kg/yr] +! (7 ) NH3 (REAL*8) : Streets anthro NH3 emissions [kg/yr] +! (8 ) CO2 (REAL*8) : Streets anthro CO2 emissions [kg/yr] +! (9 ) CH4 (REAL*8) : Streets anthro CH4 emissions [kg/yr] +! (10) following VOC in [atoms C/yr] or [molec/yr]: ACET, ALD2, ALK4, C2H6, +! C3H8, CH2O, ISOP, MEK, PRPE +! +! Module Routines: +! ============================================================================ +! (1 ) GET_CHINA_MASK : Gets the China mask value at (I,J) +! (2 ) GET_SE_ASIA_MASK : Gets the SE Asia mask value at (I,J) +! (3 ) GET_STREETS_ANTHRO : Gets emissions at (I,J) for emissions species +! (4 ) EMISS_STREETS_ANTHRO : Reads Streets' emissions from disk +! (5 ) STREETS_SCALE_FUTURE : Applies IPCC future scale factors to emissions +! (6 ) READ_STREETS_MASKS : Reads mask info from disk +! (7 ) INIT_STREETS_ANTHRO : Allocates and zeroes module arrays +! (8 ) CLEANUP_STREETS_ANTHRO : Dealocates module arrays +! +! GEOS-Chem modules referenced by "streets_anthro_mod.f" +! ============================================================================ +! (1 ) bpch2_mod.f : Module w/ routines for binary punch file I/O +! (2 ) directory_mod.f : Module w/ GEOS-Chem data & met field dirs +! (3 ) error_mod.f : Module w/ I/O error and NaN check routines +! (4 ) future_emissions_mod.f : Module w/ routines for IPCC future emissions +! (5 ) grid_mod.f : Module w/ horizontal grid information +! (6 ) logical_mod.f : Module w/ GEOS-Chem logical switches +! (7 ) regrid_1x1_mod.f : Module w/ routines to regrid 1x1 data +! (8 ) time_mod.f : Module w/ routines for computing time & date +! (9 ) tracerid_mod.f : Module w/ pointers to tracers & emissions +! +! References: +! ============================================================================ +! (1 ) Streets, D.G, Q. Zhang, L. Wang, K. He, J. Hao, Y. Wu, Y. Tang, +! and G.C. Carmichael, "Revisiting China's CO emissions after the +! Transport and Chemical Evolution over the Pacific (TRACE-P) mission: +! Synthesis of inventories, atmospheric modeling, and observations", +! J. Geophys. Res, 111, D14306, doi:10.1029/2006JD007118, 2006. +! (2 ) Streets, D.G., T.C. Bond, G.R. Carmichael, S.D. Fernandes, Q. Fu, +! Z. Klimont, S.M. Nelson, N.Y. Tsai, M.Q. Wang, J-H. Woo, and +! K.F. Yarber, "An inventory of gaseous and primary aerosol emissions +! in Asia in the year 2000", J. Geophys. Res, 108, D21, +! doi:10.1029/2002JD003093, 2003. +! (3) Zhang, Q., Streets, D. G., Carmichael, G., He, K., Huo, H., +! Kannari, A., Klimont, Z., Park, I., Reddy, S., Chen, D., Duan, L., +! Lei, Y., Wang, L. and Yao, Z.: Asian emissions in 2006 for the +! NASA INTEX-B mission, manuscript submitted to Atmospheric +! Chemistry & Physics Discussions, 2009 + +! +! NOTES: +! (1 ) Modification: Now use 2001 CO over China, and 2000 CO over countries +! other than China in the larger SE Asia region. (yxw, bmy, 9/5/06) +! (2 ) Modifications for 0.5 x 0.667 nested grids (yxw, dan, bmy, 11/6/08) +! (3 ) 2006 and 2020 inventories are now available. But species emitted +! differ (phs, 3/7/08): +! 2000/2001 = NOx, CO, SO2, NH3, CO2, CH4 +! 2006/2020 = NOx, CO, SO2, all VOC +! (4 ) Now scale emissions using int'annual scale factors (amv, 08/24/07) +! (5 ) Implemented monthly variations (phs, 4/12/08) +! (6 ) Bug fix: call READ_STREETS_05x0666 in routine +! EMISS_STREETS_ANTHRO_05x0666 (ccc, 3/11/09) +!****************************************************************************** +! + IMPLICIT NONE + + !================================================================= + ! MODULE PRIVATE DECLARATIONS -- keep certain internal variables + ! and routines from being seen outside "streets_anthro_mod.f" + !================================================================= + + ! Make everything PRIVATE ... + PRIVATE + + ! ... except these routines + PUBLIC :: CLEANUP_STREETS_ANTHRO + PUBLIC :: EMISS_STREETS_ANTHRO + PUBLIC :: EMISS_STREETS_ANTHRO_05x0666 + PUBLIC :: EMISS_STREETS_ANTHRO_025x03125 ! (lzh,02/01/2015) + PUBLIC :: GET_CHINA_MASK + PUBLIC :: GET_SE_ASIA_MASK + PUBLIC :: GET_STREETS_ANTHRO + + !================================================================= + ! MODULE VARIABLES + !================================================================= + + ! Arrays + INTEGER, ALLOCATABLE :: MASK_CHINA_1x1(:,:) + INTEGER, ALLOCATABLE :: MASK_CHINA_05x0666(:,:) + REAL*8, ALLOCATABLE :: A_CM2(:) + REAL*8, ALLOCATABLE :: MASK_CHINA(:,:) + REAL*8, ALLOCATABLE :: MASK_SE_ASIA(:,:) + REAL*8, ALLOCATABLE :: NOx(:,:) + REAL*8, ALLOCATABLE :: CO(:,:) + REAL*8, ALLOCATABLE :: SO2(:,:) + REAL*8, ALLOCATABLE :: NH3(:,:) + REAL*8, ALLOCATABLE :: CO2(:,:) + REAL*8, ALLOCATABLE :: CH4(:,:) + + ! added VOC for 2006 inventory (phs, 3/7/08) + ! Note ISOP is not used in GEOS-Chem but it is available for 2006. + REAL*8, ALLOCATABLE :: ALK4(:,:) + REAL*8, ALLOCATABLE :: ACET(:,:) + REAL*8, ALLOCATABLE :: MEK(:,:) + REAL*8, ALLOCATABLE :: PRPE(:,:) + REAL*8, ALLOCATABLE :: C2H6(:,:) + REAL*8, ALLOCATABLE :: C3H8(:,:) + REAL*8, ALLOCATABLE :: CH2O(:,:) + REAL*8, ALLOCATABLE :: ALD2(:,:) + + ! flag to denote if emission base year is 2006 + LOGICAL IS_2006 + + ! month + INTEGER MONTH + + + ! Parameters + REAL*8, PARAMETER :: SEC_IN_YEAR = 86400d0 * 365.25d0 + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS + +!------------------------------------------------------------------------------ + + FUNCTION GET_CHINA_MASK( I, J ) RESULT( THISMASK ) +! +!****************************************************************************** +! Function GET_STREETS_MASK returns the value of the China mask for the David +! Streets et al emissions at grid box (I,J). MASK=1 if (I,J) is China, or +! MASK=0 otherwise. (bmy, 8/16/06) +! +! NOTE: The China Mask is used with the 2001 CO emissions. +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : GEOS-Chem longitude index +! (2 ) J (INTEGER) : GEOS-Chem latitude index +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J + + ! Local variables + REAL*8 :: THISMASK + + !================================================================= + ! GET_CHINA_MASK begins here! + !================================================================= + THISMASK = MASK_CHINA(I,J) + + ! Return to calling program + END FUNCTION GET_CHINA_MASK + +!------------------------------------------------------------------------------ + + FUNCTION GET_SE_ASIA_MASK( I, J ) RESULT( THISMASK ) +! +!****************************************************************************** +! Function GET_SE_ASIA_MASK returns the value of the China mask for the David +! Streets et al emissions at grid box (I,J). MASK=1 if (I,J) is China, or +! MASK=0 otherwise. (bmy, 8/16/06) +! +! NOTE: The SE Asia Mask is used with the 2000 emissions for +! NOx, CO, CO2, SO2, NH3, and CH4. +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : GEOS-Chem longitude index +! (2 ) J (INTEGER) : GEOS-Chem latitude index +! +! NOTES: +!****************************************************************************** +! + ! Arguments + INTEGER, INTENT(IN) :: I, J + + ! Local variables + REAL*8 :: THISMASK + + !================================================================= + ! GET_SE_ASIA_MASK begins here! + !================================================================= + THISMASK = MASK_SE_ASIA(I,J) + + ! Return to calling program + END FUNCTION GET_SE_ASIA_MASK + +!------------------------------------------------------------------------------ + + FUNCTION GET_STREETS_ANTHRO( I, J, N, + & MOLEC_CM2_S, KG_S ) RESULT( VALUE ) +! +!****************************************************************************** +! Function GET_STREETS_ANTHRO returns the David Streets et al emission for +! GEOS-Chem grid box (I,J) and tracer N. Emissions can be returned in +! units of [kg/s] or [molec/cm2/s]. (bmy, 8/16/06) +! +! Arguments as Input: +! ============================================================================ +! (1 ) I (INTEGER) : GEOS-Chem longitude index +! (2 ) J (INTEGER) : GEOS-Chem latitude index +! (3 ) N (INTEGER) : GEOS-Chem tracer number +! (4 ) MOLEC_CM2_S (LOGICAL) : OPTIONAL -- return emissions in [molec/cm2/s] +! (5 ) KG_S (LOGICAL) : OPTIONAL -- return emissions in [kg/s] +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM + USE TRACER_MOD, ONLY : ITS_A_CO2_SIM + USE TRACER_MOD, ONLY : XNUMOL + USE TRACERID_MOD, ONLY : IDTNOx, IDTCO, IDTSO2, IDTNH3 + USE TRACERID_MOD, ONLY : IDTACET, IDTALK4, IDTC2H6 + USE TRACERID_MOD, ONLY : IDTCH2O, IDTMEK, IDTALD2 + USE TRACERID_MOD, ONLY : IDTPRPE, IDTC3H8 + + ! Arguments + INTEGER, INTENT(IN) :: I, J, N + LOGICAL, INTENT(IN), OPTIONAL :: MOLEC_CM2_S + LOGICAL, INTENT(IN), OPTIONAL :: KG_S + + ! Local variables + LOGICAL :: DO_KGS, DO_MCS, IS_NMVOC + REAL*8 :: VALUE + + !================================================================= + ! GET_STREETS_ANTHRO begins here! + !================================================================= + + ! Initialize + DO_KGS = .FALSE. + DO_MCS = .FALSE. + IS_NMVOC = .TRUE. + + ! 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 + + ! Test for simulation type + IF ( ITS_A_CH4_SIM() ) THEN + + !------------------- + ! CH4 simulation + !------------------- + VALUE = CH4(I,J) + + ELSE IF ( ITS_A_CO2_SIM() ) THEN + + !------------------- + ! CO2 simulation + !------------------- + VALUE = CO2(I,J) + + ELSE + + !------------------- + ! Other simulations + !------------------- + IF ( N == IDTNOx ) THEN + + ! NOx [kg/yr] + VALUE = NOx(I,J) + + IS_NMVOC =.FALSE. !PHS + + ELSE IF ( N == IDTCO ) THEN + + ! CO [kg/yr] + VALUE = CO(I,J) + + IS_NMVOC =.FALSE. !PHS + + ELSE IF ( N == IDTSO2 ) THEN + + ! SO2 [kg/yr] + VALUE = SO2(I,J) + + IS_NMVOC =.FALSE. !PHS + + ELSE IF ( N == IDTNH3 ) THEN + + ! NH3 [kg/yr] + VALUE = NH3(I,J) + + IS_NMVOC =.FALSE. !PHS (bug fix, 3/2/09) + + !========= start VOC modifications (phs, 3/7/08) + ELSE IF ( N == IDTALK4 ) THEN + + ! SO2 [kg/yr] + VALUE = ALK4(I,J) + + ELSE IF ( N == IDTALD2 ) THEN + + ! SO2 [kg/yr] + VALUE = ALD2(I,J) + + ELSE IF ( N == IDTPRPE ) THEN + + ! SO2 [kg/yr] + VALUE = PRPE(I,J) + + ELSE IF ( N == IDTC3H8 ) THEN + + ! SO2 [kg/yr] + VALUE = C3H8(I,J) + + ELSE IF ( N == IDTC2H6 ) THEN + + ! SO2 [kg/yr] + VALUE = C2H6(I,J) + + ELSE IF ( N == IDTMEK ) THEN + + ! SO2 [kg/yr] + VALUE = MEK(I,J) + + ELSE IF ( N == IDTACET ) THEN + + ! SO2 [kg/yr] + VALUE = ACET(I,J) + + ELSE IF ( N == IDTCH2O ) THEN + + ! SO2 [kg/yr] + VALUE = CH2O(I,J) + + !========= end VOC modifications ================ + ELSE + + ! Otherwise return a negative value to indicate + ! that there are no STREETS emissions for tracer N + VALUE = -1d0 + RETURN + + ENDIF + + ENDIF + + ! Check if some species are missing + IF ( VALUE .LT. 0D0 ) RETURN + + + !------------------------------ + ! Convert units (if necessary) + !------------------------------ + IF ( DO_KGS ) THEN + + IF ( IS_NMVOC ) THEN + ! Convert from [atom C/yr] to [kg/s] or from [molec/yr] + ! to [kg/s] + VALUE = VALUE / ( XNUMOL(N) * SEC_IN_YEAR ) + ELSE + ! Convert from [kg/yr] to [kg/s] + VALUE = VALUE / SEC_IN_YEAR + ENDIF + + ELSE IF ( DO_MCS ) THEN + + IF ( IS_NMVOC ) THEN + ! Convert from [atom C/yr] to [atom C/cm2/s] or + ! from [molec/yr] to [molec/cm2/s] + VALUE = VALUE / ( A_CM2(J) * SEC_IN_YEAR ) + ELSE + ! Convert from [kg/yr] to [molec/cm2/s] + VALUE = VALUE * XNUMOL(N) / ( A_CM2(J) * SEC_IN_YEAR ) + ENDIF + + ENDIF + + ! Return to calling program + END FUNCTION GET_STREETS_ANTHRO + +!------------------------------------------------------------------------------ + + SUBROUTINE EMISS_STREETS_ANTHRO +! +!****************************************************************************** +! Subroutine EMISS_STREETS_ANTHRO reads the David Streets et al emission +! fields at 1x1 resolution and regrids them to the current model resolution. +! (bmy, 8/16/06, 9/5/06) +! +! NOTES: +! (1 ) Overwrite 2000 SE Asia CO with 2001 CO over China (bmy, 9/5/06) +! (2 ) Now can use 2000(2001 for CO over CHINA), or 2006, or 2020 inventory +! (phs,3/07/08) +! (3 ) Added int'annual scale factors (amv, 08/24/07) +! (4 ) Now accounts for FSCALYR and monthly variation (phs, 3/17/08) +! (5 ) Now NH3 2000 is used for all simulation years (phs, 2/27/09) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE LOGICAL_MOD, ONLY : LFUTURE + USE TRACER_MOD, ONLY : ITS_A_CO2_SIM, ITS_A_CH4_SIM + USE TIME_MOD, ONLY : GET_YEAR, GET_MONTH + USE SCALE_ANTHRO_MOD, ONLY : GET_ANNUAL_SCALAR + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! FSCALYR + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: BASE_YEAR, SIM_YEAR + CHARACTER(LEN=255) :: FILENAME, STREETS_DIR, + $ STREETS_DIR_2000 + + ! to loop over the sources + INTEGER, PARAMETER :: NSRCE = 10 + INTEGER :: NSOURCE, NTSOURCE1, NTSOURCE2 + CHARACTER(LEN=3) :: SOURCES(NSRCE) !! + REAL*8 :: ONOFF(NSRCE) !! To switch off/on each sources + REAL*8 :: SCALE2020(NSRCE) !! To scale 2006 to 2020 + + ! to hold data and scale factors + REAL*4 :: SCALFAC( IIPAR, JJPAR ) + REAL*8 :: TEMP( IIPAR, JJPAR ) + + ! TAUs + REAL*8 :: TAU2000, TAU2004, TAU2006 + REAL*8 :: TAUMONTH_2001, TAUMONTH_2004, TAU + + !================================================================= + ! EMISS_STREETS_ANTHRO begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + CALL INIT_STREETS_ANTHRO + FIRST = .FALSE. + ELSE + NOx = 0D0 + CO = 0D0 + SO2 = 0D0 + ALK4 = 0D0 + ACET = 0D0 + MEK = 0D0 + PRPE = 0D0 + C2H6 = 0D0 + C3H8 = 0D0 + CH2O = 0D0 + ALD2 = 0D0 + ENDIF + + ! TAU0 values for 2000, 2004 and 2006 + TAU2000 = GET_TAU0( 1, 1, 2000 ) + TAU2004 = GET_TAU0( 1, 1, 2004 ) + TAU2006 = GET_TAU0( 1, 1, 2006 ) + + MONTH = GET_MONTH() + TAUMONTH_2001 = GET_TAU0( MONTH, 1, 2001 ) + TAUMONTH_2004 = GET_TAU0( MONTH, 1, 2004 ) + + !------------------------------------------------------------------------- + ! Base Year & Yearly Scale Factors used + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! %%% To simulate 2020 : % + ! %%% you set BASE_YEAR = 2020 (hardwired, see below) % + ! %%% % + ! %%% To simulate 2006 and after, the program sets: % + ! %%% BASE_YEAR = 2006 for all species, except NH3 % + ! %%% BASE_YEAR = 2000 for NH3 % + ! %%% % + ! %%% To simulate 2005 and before, it sets: % + ! %%% BASE_YEAR = 2004 for NOx % + ! %%% BASE_YEAR = 2001 for CO in China % + ! %%% BASE_YEAR = 2000 for CO outside China, NH3, SO2, CH4 & CO2 % + ! %%% & VOC are not emitted - % + ! %%% % + ! %%% & YEARLY SCALE FACTOR are applied to get 1985-2005 estimates % + ! %%% of NOx, CO, SO2 if BASE_YEAR in 2000-4 % + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !------------------------------------------------------------------------- + + ! select emissions year + IF ( FSCALYR < 0 ) THEN + SIM_YEAR = GET_YEAR() + ELSE + SIM_YEAR = FSCALYR + ENDIF + + ! Pickup BASE_YEAR according to SIMulation YEAR + IF ( SIM_YEAR >= 2006 ) THEN + BASE_YEAR = 2006 + ELSE + BASE_YEAR = 2000 + ENDIF + + ! set module flag + IS_2006 = ( BASE_YEAR == 2006 ) + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! %%%% To simulate 2020 estimate, uncomment following two lines %%%% + !BASE_YEAR = 2020 + !IS_2006 = .TRUE. + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! define data directory and number of sources + STREETS_DIR_2000 = TRIM( DATA_DIR_1x1 ) // 'Streets_200607/' + + IF ( IS_2006 ) THEN + NTSOURCE1 = 4 + NTSOURCE2 = 10 + STREETS_DIR = TRIM( DATA_DIR_1x1 ) // 'Streets_200812/' + ELSE + NTSOURCE1 = 1 + NTSOURCE2 = 2 + STREETS_DIR = TRIM( DATA_DIR_1x1 ) // 'Streets_200607/' + ENDIF + + + !----------------------------------------------------------------- + ! SOURCES = String array to identify emissions sources for 2006 + ! inventory. They correspond to : + ! + ! Industry, Power, Residential, Transport for NOx/CO/SO2 + ! + ! Domestic Biofuel, Domestic Fossil Fuel, Domestic Non-Combustion, + ! Industry, Power Plants, and Transportation for NMVOC + ! + ! ONOFF = their orresponding switch + ! ### MODIFY ONLY ONOFF FOR SENSITIVITY STUDIES ## + !----------------------------------------------------------------- + SOURCES = (/ 'ind', 'pow', 'res', 'tra', ! for NOx/CO/SO2 + & 'dob', 'dof', 'dop', 'ind', 'pow', 'tra' /) ! for VOC + + ONOFF = (/ 1D0, 1D0, 1D0, 1D0, + & 1D0, 1D0, 1D0, 1D0, 1D0, 1D0 /) + + ! Corresponding scaling to get 2020 from 2006 + ! Note : first line only for NOx (no change in CO/SO2) + IF ( BASE_YEAR == 2020 ) THEN + SCALE2020 = (/ 2.36D0, 1.33D0, 1.02D0, 2.5D0, + & 1.02D0, 1.02D0, 1.02D0, 2.36D0, 1.33D0, 2.5D0 /) + ELSE + SCALE2020 = (/ 1D0, 1D0, 1D0, 1D0, + & 1D0, 1D0, 1D0, 1D0, 1D0, 1D0 /) + ENDIF + + + !----------------------------------------------------------------- + ! Test for simulation type + !----------------------------------------------------------------- + IF ( ITS_A_CH4_SIM() ) THEN + + !-------------------------- + ! Read CH4 and regrid + ! (CH4 simulations only) + !-------------------------- + + ! File name + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_CH4_FF_2000.generic.1x1' + + BASE_YEAR = 2000 + + ! Read data + CALL READ_STREETS( FILENAME, 'CH4-EMIS', 1, TAU2000, CH4, + & IS_MASS=1 ) + + ELSE IF ( ITS_A_CO2_SIM() ) THEN + + !-------------------------- + ! Read CO2 and regrid + ! (CO2 simulations only) + !-------------------------- + + ! File name + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_CO2_FF_2000.generic.1x1' + + BASE_YEAR = 2000 + + ! Read data + CALL READ_STREETS( FILENAME, 'CO2-SRCE', 1, TAU2000, CO2, + $ IS_MASS=1 ) + + ELSE + + !-------------------------------------------------------------- + ! Other simulations + !-------------------------------------------------------------- + + !-------------------------- + ! Read NOx and regrid + !-------------------------- + DO NSOURCE = 1, NTSOURCE1 + + ! File name + IF ( IS_2006 ) THEN + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_NOx_'// + & SOURCES( NSOURCE ) // '_2006.generic.1x1' + + TAU = TAU2006 + ELSE + +!--- prior to 7/1/09 (has only Chinese data) +! +! FILENAME = TRIM( STREETS_DIR ) // +! & 'Streets_NOx_FF_2004_monthly.generic.1x1' +! +! TAU = TAUMONTH_2004 +! + + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_NOx_FF_2000.generic.1x1' + + TAU = TAU2000 + + ENDIF + + ! Read data + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 1, TAU, TEMP, + & IS_MASS=1 ) + + NOX = NOX + TEMP * ONOFF( NSOURCE ) * SCALE2020( NSOURCE ) + + ENDDO + + + !-------------------------- + ! Scale NOx + !-------------------------- + +!----- prior to 7/1/09 (phs) +! IF ( IS_2006 ) THEN +! +! ! Monthly Variability for 2006 Base Year. Variability has +! ! been obtained from 2004 data (phs, 12/2/08) +! FILENAME = TRIM( STREETS_DIR ) // +! & 'Streets_2004_NOx_MonthFctr_total.generic.1x1' +! +! CALL READ_STREETS( FILENAME, 'RATIO-2D', 71, +! $ TAUMONTH_2004, TEMP, 'unitless' ) +! +! NOX = NOX * TEMP +! +! +! ELSE +! +! ! Annual scalar factor for NOx 2004 (amv, phs, 3/10/08) +! CALL GET_ANNUAL_SCALAR( 71, 2004, SIM_YEAR, SCALFAC ) +! +! NOX = NOX * SCALFAC +! +! ENDIF + + ! Annual scalar factor (phs, 3/10/08) + !-------------------------- + IF ( BASE_YEAR == 2000 ) THEN + + CALL GET_ANNUAL_SCALAR( 71, 2000, SIM_YEAR, SCALFAC ) + + NOX = NOX * SCALFAC + ENDIF + + ! Seasonal Variation for NOx + !-------------------------- + ! Monthly Variability for any year. Variability has + ! been obtained from 2004 1x1 data, for two cases: + ! FF seasonality for 2000, and TOTAL (BF+FF) for 2006 + ! inventories (phs, 12/2/08) + + IF ( IS_2006 ) THEN + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_2004_NOx_MonthFctr_total.generic.1x1' + + ELSE + + ! redefine the entire path here + FILENAME = TRIM( DATA_DIR_1x1 ) // 'Streets_200812/' + & // 'Streets_2004_NOx_MonthFctr_FF.generic.1x1' + + ENDIF + + CALL READ_STREETS( FILENAME, 'RATIO-2D', 71, + $ TAUMONTH_2004, TEMP, IS_MASS=0 ) + + NOX = NOX * TEMP + + !-------------------------- + ! Read CO and scale CO + !-------------------------- + + ! Base year = 2006 + IF ( IS_2006 ) THEN + + DO NSOURCE = 1, NTSOURCE1 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_CO_'// + & SOURCES( NSOURCE ) // '_2006.generic.1x1' + + ! Read data + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 4, + $ TAU2006, TEMP, IS_MASS=1 ) + + ! No scaling for 2006-2020 + CO = CO + TEMP * ONOFF( NSOURCE ) + + ENDDO + + ! Monthly Variability for 2006 Base Year. Variability has + ! been obtained from 2001 data, and thus affects only China + ! (phs, 12/2/08) + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_2001_CO_MonthFctr_total.generic.1x1' + + CALL READ_STREETS( FILENAME, 'RATIO-2D', 72, + $ TAUMONTH_2001, TEMP, IS_MASS=0 ) + + CO = CO * TEMP + + ! Base year = 2000 (2001 for China) + ELSE + + !-- PART 1 -- File name for 2000 CO over SE Asia + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_CO_FF_2000.generic.1x1' + + ! Read data + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 4, TAU2000, CO, + & IS_MASS=1 ) + + ! Annual scalar factor (amv, phs, 3/10/08) + CALL GET_ANNUAL_SCALAR( 72, 2000, SIM_YEAR, SCALFAC ) + CO = CO * SCALFAC + + + + !-- PART 2 -- File name for 2001 CO over China only + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_CO_FF_2001_monthly.generic.1x1' + + ! Read data + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 4, + $ TAUMONTH_2001, TEMP, IS_MASS=1) + + ! Annual scalar factor (amv, phs, 3/10/08) + CALL GET_ANNUAL_SCALAR( 72, 2001, SIM_YEAR, SCALFAC ) + TEMP = TEMP * SCALFAC + + + !-- PART 3 -- Replace SE Asia CO for 2000 with China CO for 2001 + WHERE ( MASK_CHINA > 0 ) CO = TEMP + + ! switch and scale + CO = CO * ONOFF( 1 ) + + ENDIF + + + !-------------------------- + ! Read SO2 and regrid + !-------------------------- + DO NSOURCE = 1, NTSOURCE1 + + ! File name + IF ( BASE_YEAR == 2000 ) THEN + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_SO2_FF_2000.generic.1x1' + + TAU = TAU2000 + + ELSE + FILENAME = TRIM( STREETS_DIR ) // 'Streets_SO2_'// + & SOURCES( NSOURCE ) // '_2006.generic.1x1' + + TAU = TAU2006 + + ENDIF + + ! Read data + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 26, TAU, TEMP, + & IS_MASS=1 ) + + SO2 = SO2 + TEMP * ONOFF( NSOURCE ) + + ENDDO + + ! Annual scalar factor (amv, phs, 3/10/08) + IF ( .NOT. IS_2006 ) THEN + CALL GET_ANNUAL_SCALAR( 73, 2000, SIM_YEAR, SCALFAC ) + SO2 = SO2 * SCALFAC + ENDIF + + + !--------------------------------------------- + ! Read NH3 only available for base year 2000 + !--------------------------------------------- +! IF ( IS_2006 ) THEN +! +! NH3 = -1D0 +! +! ELSE + + ! File name + FILENAME = TRIM( STREETS_DIR_2000 ) // + & 'Streets_NH3_FF_2000.generic.1x1' + + ! Old file has NH3 as tracer #30 + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 30, TAU2000, NH3, + & IS_MASS=1 ) + + ! switch and scale + NH3 = NH3 * ONOFF( 1 ) + +! ENDIF + + + !--------------------------------------------- + ! Read VOC only if base year is 2006 + !--------------------------------------------- + IF ( IS_2006 ) THEN + + TAU = TAU2006 + + !-------------------------- + ! Read ACET and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_ACET_'// + & SOURCES( NSOURCE ) // '_2006.generic.1x1' + + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 9, TAU, TEMP, + & IS_MASS=1 ) + + ACET = ACET + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + !-------------------------- + ! Read C2H6 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_C2H6_'// + & SOURCES( NSOURCE ) // '_2006.generic.1x1' + + ! Read data [atom C/yr] + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 21, TAU, TEMP, + & IS_MASS=1 ) + + C2H6 = C2H6 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + !-------------------------- + ! Read CH2O and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_CH2O_'// + & SOURCES( NSOURCE ) // '_2006.generic.1x1' + + ! Read data [atom C/yr] + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 20, TAU, TEMP, + & IS_MASS=0 ) + + CH2O = CH2O + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + !-------------------------- + ! Read C3H8 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_C3H8_'// + & SOURCES( NSOURCE ) // '_2006.generic.1x1' + + ! Read data [atom C/yr] + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 19, TAU, TEMP, + & IS_MASS=1 ) + + C3H8 = C3H8 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + !-------------------------- + ! Read PRPE and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_PRPE_'// + & SOURCES( NSOURCE ) // '_2006.generic.1x1' + + ! Read data [atom C/yr] + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 18, TAU, TEMP, + & IS_MASS=1 ) + + PRPE = PRPE + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + !-------------------------- + ! Read ALD2 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_ALD2_'// + & SOURCES( NSOURCE ) // '_2006.generic.1x1' + + ! Read data [atom C/yr] + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 11, TAU, TEMP, + & IS_MASS=1 ) + + ALD2 = ALD2 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + + !-------------------------- + ! Read MEK and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_MEK_'// + & SOURCES( NSOURCE ) // '_2006.generic.1x1' + + ! Read data [atom C/yr] + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 10, TAU, TEMP, + & IS_MASS=1 ) + + MEK = MEK + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + !-------------------------- + ! Read ALK4 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_ALK4_'// + & SOURCES( NSOURCE ) // '_2006.generic.1x1' + + ! Read data [atom C/yr] + CALL READ_STREETS( FILENAME, 'ANTHSRCE', 5, TAU, TEMP, + & IS_MASS=1 ) + + ALK4 = ALK4 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + ELSE + + ! Set VOC to -1 + ALK4 = -1D0 + ACET = -1D0 + MEK = -1D0 + PRPE = -1D0 + C2H6 = -1D0 + C3H8 = -1D0 + CH2O = -1D0 + ALD2 = -1D0 + + + ENDIF ! end VOCs + + ENDIF ! end other simulations + + + !-------------------------- + ! Compute future emissions + !-------------------------- + IF ( LFUTURE ) THEN + CALL STREETS_SCALE_FUTURE + ENDIF + + !-------------------------- + ! Print emission totals + !-------------------------- + CALL TOTAL_ANTHRO_Tg( SIM_YEAR, BASE_YEAR ) + + ! Return to calling program + END SUBROUTINE EMISS_STREETS_ANTHRO + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_STREETS( FILENAME, CATEGORY, TRACERN, TAU, ARR, + $ IS_MASS ) +! +!****************************************************************************** +! Subroutine READ_STREETS reads data from one STREETS data file +! from disk, at GENERIC 1x1 resolution and regrids them to the +! current model resolution. (phs, 3/7/08) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Name of anthro or biomass file to read +! (2 ) CATEGORY (CHARACTER) : Category name +! (3 ) TRACERN (INTEGER ) : Tracer number +! +! Arguments as Input/Output: +! ============================================================================ +! (2 ) ARR (REAL*8 ) : Array to hold emissions +! +! NOTES: +! (1) UNIT argument in DO_REGRID_... is 'kg/yr' for VOCs +! because 'atom C/yr' and 'molec/yr' are not recognized. The result is +! still correct. +! (2) Now inlcude seasonal scaling of NH3 emissions (jaf, 3/2/11) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1, DO_REGRID_G2G_1x1 + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE REGRID_1x1_MOD, ONLY : DO_REGRID_1x1 + USE REGRID_1x1_MOD, ONLY : DO_REGRID_G2G_1x1 + USE TIME_MOD, ONLY : GET_MONTH + USE TRACERID_MOD, ONLY : IDTNH3 + + ! (lzh,02/01/2015) update regridding + USE REGRID_A2A_MOD, ONLY : DO_REGRID_A2A + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: FILENAME, CATEGORY + INTEGER, INTENT(IN) :: TRACERN + REAL*8, INTENT(INOUT) :: ARR(IIPAR,JJPAR) + REAL*8, INTENT(IN) :: TAU + INTEGER, INTENT(IN) :: IS_MASS ! For MAP_A2A regrid + + ! Local variables + REAL*4 :: ARRAY(I1x1,J1x1-1,1) + !REAL*8 :: GEN_1x1(I1x1,J1x1-1) + REAL*8, TARGET :: GEN_1x1(I1x1,J1x1-1) !(lzh) + REAL*8 :: GEOS_1x1(I1x1,J1x1,1) + + ! (lzh, 02/01/2015) + CHARACTER(LEN=255) :: LLFILENAME + REAL*8, POINTER :: INGRID(:,:) => NULL() + + ! Variables for seasonal scaling of NH3 (jaf, 3/2/11) + REAL*4 :: SCALAR_1x1(I1x1,J1x1-1,1) + REAL*8 :: TAU1995 + INTEGER :: RATIOID + CHARACTER(LEN=250):: FILENAME_S + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - EMISS_STREETS_ANTHRO: Reading ', a ) + + ARR = 0d0 + ARRAY = 0. + + ! Read data + CALL READ_BPCH2( FILENAME, CATEGORY, TRACERN, + & TAU, I1x1, J1x1-1, + & 1, ARRAY, QUIET=.TRUE. ) + !================================================================= + ! Apply seasonal variation to NH3 based on seasonality from + ! Lex Bouwman. Follow methodology in emep_mod.f (jaf, 3/2/11) + !================================================================= + + ! Get TAU value for 1995, since the data is timestamped w/ this + TAU1995 = GET_TAU0( GET_MONTH(), 1, 1995 ) + +! (lzh, 06/23/2014) disable NH3 seasonality +c$$$ ! For NH3 only ... +c$$$ IF ( TRACERN == 30 ) THEN +c$$$ +c$$$ ! File name containing scaling factors +c$$$ FILENAME_S = TRIM( DATA_DIR_1x1 ) // +c$$$ & 'Streets_200607/NH3-Streets-SeasonalScalar.generic.1x1' +c$$$ +c$$$ ! Tracer number for scale factor data +c$$$ RATIOID = 74 +c$$$ +c$$$ ! Echo info +c$$$ WRITE( 6, 101 ) TRIM( FILENAME_S ) +c$$$101 FORMAT( ' - READ_STREETS: Reading ', a ) +c$$$ +c$$$ ! Read scaling factors +c$$$ CALL READ_BPCH2( FILENAME_S, 'RATIO-2D', RATIOID, +c$$$ & TAU1995, I1x1, J1x1-1, +c$$$ & 1, SCALAR_1x1, QUIET=.TRUE. ) +c$$$ +c$$$ ! Apply seasonal scalar to NH3 emissions +c$$$ ARRAY(:,:,1) = ARRAY(:,:,1) * SCALAR_1x1(:,:,1) +c$$$ +c$$$ ENDIF + + ! Cast to REAL*8 before regridding + GEN_1x1(:,:) = ARRAY(:,:,1) + + ! Regrid from GENERIC 1x1 --> GEOS 1x1 +! CALL DO_REGRID_G2G_1x1( THISUNIT, GEN_1x1, GEOS_1x1(:,:,1) ) + + ! Regrid from GEOS 1x1 --> current model resolution +! CALL DO_REGRID_1x1( THISUNIT, GEOS_1x1, ARR ) + + ! (lzh,02/01/2015) + ! File with lat/lon edges for regridding + LLFILENAME = TRIM( DATA_DIR_1x1) // + & 'MAP_A2A_Regrid_201203/MAP_A2A_latlon_generic1x1.nc' + + ! Regrid from GENERIC 1x1 --> current model resolution + INGRID => GEN_1x1 + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1-1, + & INGRID, ARR, IS_MASS, + & netCDF=.TRUE. ) + + ! Free pointer + NULLIFY( INGRID ) + + END SUBROUTINE READ_STREETS + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_STREETS_05x0666( FILENAME, CATEGORY, TRACERN, + $ TAU, ARR ) +! +!****************************************************************************** +! Subroutine READ_STREETS_05x0666 reads data from one STREETS data file +! from disk, at 05x0666 resolution and cut them to the CHINA nested +! window. (phs, 12/2/08) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Name of anthro or biomass file to read +! (2 ) CATEGORY (CHARACTER) : Category name +! (3 ) TRACERN (INTEGER ) : Tracer number +! +! Arguments as Input/Output: +! ============================================================================ +! (2 ) ARR (REAL*8 ) : Array to hold emissions +! +! NOTES: +! (1) UNIT argument in DO_REGRID_... is 'kg/yr' for VOCs +! because 'atom C/yr' and 'molec/yr' are not recognized. The result is +! still correct. +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE REGRID_1x1_MOD, ONLY : DO_REGRID_05X0666 + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: FILENAME, CATEGORY + INTEGER, INTENT(IN) :: TRACERN + REAL*8, INTENT(INOUT) :: ARR(IIPAR,JJPAR) + REAL*8, INTENT(IN) :: TAU + + ! Local variables + REAL*4 :: ARRAY(I05x0666,J05x0666,1) + REAL*8 :: GEOS_05x0666(I05x0666,J05x0666,1) + + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - EMISS_STREETS_ANTHRO: Reading ', a ) + + ! Read data + CALL READ_BPCH2( FILENAME, CATEGORY, TRACERN, + & TAU, I05x0666, J05x0666, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 before regridding + GEOS_05x0666(:,:,1) = ARRAY(:,:,1) + + ! Cut to China nested simulation window + CALL DO_REGRID_05x0666( 1,'kg/yr', GEOS_05x0666, ARR ) + + + END SUBROUTINE READ_STREETS_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE EMISS_STREETS_ANTHRO_05x0666 +! +!****************************************************************************** +! Subroutine EMISS_STREETS_ANTHRO_05x0666 reads the David Streets et al +! emission fields at 0.5 x 0.666 resolution and regrids them to the current +! nested-grid model resolution. (yxw, dan, bmy, 11/6/08) +! +! NOTES: +! (1 ) For now, disable the monthly CO emissions and just read the +! same emissions as we do for the global simulations. Update +! emissions in a future release. (bmy, 11/6/08) +! (2) Now read 2006 inventory (including VOCs) if needed. Apply monthly +! variations for NOx +! (3) Bug fixe : we call only read_streets_05x0666. (ccc, 3/11/09) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE LOGICAL_MOD, ONLY : LFUTURE + USE TRACER_MOD, ONLY : ITS_A_CO2_SIM, ITS_A_CH4_SIM + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE TIME_MOD, ONLY : GET_MONTH, GET_YEAR + USE TRACER_MOD, ONLY : XNUMOL +! USE SCALE_ANTHRO_MOD, ONLY : GET_ANNUAL_SCALAR_05x0666 + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! FSCALYR + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: BASE_YEAR, SIM_YEAR + CHARACTER(LEN=255) :: FILENAME, STREETS_DIR + + ! to loop over the sources + INTEGER, PARAMETER :: NSRCE = 10 + INTEGER :: NSOURCE, NTSOURCE1, NTSOURCE2 + CHARACTER(LEN=3) :: SOURCES(NSRCE) !! + REAL*8 :: ONOFF(NSRCE) !! To switch off/on each sources + REAL*8 :: SCALE2020(NSRCE) !! To scale 2006 to 2020 + + ! to hold temporary data and scale factors + REAL*4 :: SCALFAC( IIPAR, JJPAR ) + REAL*8 :: TEMP( IIPAR, JJPAR ) + + ! TAUs + REAL*8 :: TAU2000, TAU2004, TAU2006 + REAL*8 :: TAUMONTH_2001, TAUMONTH_2004, TAU + + + !================================================================= + ! EMISS_STREETS_ANTHRO begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + CALL INIT_STREETS_ANTHRO + FIRST = .FALSE. + ELSE + NOx = 0D0 + CO = 0D0 + SO2 = 0D0 + ALK4 = 0D0 + ACET = 0D0 + MEK = 0D0 + PRPE = 0D0 + C2H6 = 0D0 + C3H8 = 0D0 + CH2O = 0D0 + ALD2 = 0D0 + ENDIF + + ! TAU0 values for 2000, 2004 and 2006 + TAU2000 = GET_TAU0( 1, 1, 2000 ) + TAU2004 = GET_TAU0( 1, 1, 2004 ) + TAU2006 = GET_TAU0( 1, 1, 2006 ) + + MONTH = GET_MONTH() + TAUMONTH_2001 = GET_TAU0( MONTH, 1, 2001 ) + TAUMONTH_2004 = GET_TAU0( MONTH, 1, 2004 ) + + !------------------------------------------------------------------------- + ! Base Year & Yearly Scale Factors + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! %%% To simulate 2020 : % + ! %%% you must set BASE_YEAR = 2020 (hardwired, see below) % + ! %%% % + ! %%% To simulate 2006 and after, we use: % + ! %%% BASE_YEAR = 2006 for all species. NH3 is not emitted % + ! %%% % + ! %%% To simulate 2005 and before, we use: % + ! %%% BASE_YEAR = 2001 for CO in China % + ! %%% BASE_YEAR = 2000 for CO outside China, NOx, SO2, CH4, & CO2 % + ! %%% & VOC are not emitted - % + ! %%% % + ! %%% YEARLY SCALE FACTOR (**** NOT AVAILABLE YET ****) % + ! %%% to be applied to get 1985-2005 estimates % + ! %%% of NOx, CO and SO2 if BASE_YEAR is 2000/1 % + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !------------------------------------------------------------------------- + + ! select emissions year + IF ( FSCALYR < 0 ) THEN + SIM_YEAR = GET_YEAR() + ELSE + SIM_YEAR = FSCALYR + ENDIF + + ! Pickup BASE_YEAR according to SIMulation YEAR + IF ( SIM_YEAR >= 2006 ) THEN + IS_2006 = .TRUE. + BASE_YEAR = 2006 + ELSE + BASE_YEAR = 2000 + ENDIF + + ! %%%% To simulate 2020 estimate, uncomment following line %%%% + !BASE_YEAR = 2020 + !IS_2006 = .TRUE. + + ! define data directory and number of sources + IF ( IS_2006 ) THEN + NTSOURCE1 = 4 + NTSOURCE2 = 10 + STREETS_DIR = TRIM( DATA_DIR ) // 'Streets_200812/' + ELSE + NTSOURCE1 = 1 + NTSOURCE2 = 2 + STREETS_DIR = TRIM( DATA_DIR ) // 'Streets_200607/' + ENDIF + + + !----------------------------------------------------------------- + ! SOURCES = String array to identify emissions sources for 2006 + ! inventory. They correspond to : + ! + ! Industry, Power, Residential, Transport for NOx/CO/SO2 + ! + ! Domestic Biofuel, Domestic Fossil Fuel, Domestic Non-Combustion, + ! Industry, Power Plants, and Transportation for NMVOC + ! + ! ONOFF = their orresponding switch + ! ### MODIFY ONLY ONOFF FOR SENSITIVITY STUDIES ## + !----------------------------------------------------------------- + SOURCES = (/ 'ind', 'pow', 'res', 'tra', ! for NOx/CO/SO2 + & 'dob', 'dof', 'dop', 'ind', 'pow', 'tra' /) ! for VOC + + ONOFF = (/ 1D0, 1D0, 1D0, 1D0, + & 1D0, 1D0, 1D0, 1D0, 1D0, 1D0 /) + + ! Corresponding scaling to get 2020 from 2006 + ! Note : first line only for NOx (no change in CO/SO2) + IF ( BASE_YEAR == 2020 ) THEN + SCALE2020 = (/ 2.36D0, 1.33D0, 1.02D0, 2.5D0, + & 1.02D0, 1.02D0, 1.02D0, 2.36D0, 1.33D0, 2.5D0 /) + ELSE + SCALE2020 = (/ 1D0, 1D0, 1D0, 1D0, + & 1D0, 1D0, 1D0, 1D0, 1D0, 1D0 /) + ENDIF + + + !----------------------------------------------------------------- + ! Test for simulation type + !----------------------------------------------------------------- + IF ( ITS_A_CH4_SIM() ) THEN + + !-------------------------- + ! Read CH4 and regrid + ! (CH4 simulations only) + !-------------------------- + + ! File name for 2000 CO over SE Asia + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_CH4_FF_2000.geos5.05x0666' + + BASE_YEAR = 2000 + + ! Read data + CALL READ_STREETS_05x0666( FILENAME, 'CH4-EMIS', 1, + $ TAU2000, CH4 ) + + + ELSE IF ( ITS_A_CO2_SIM() ) THEN + + !-------------------------- + ! Read CO2 and regrid + ! (CH2 simulations only) + !-------------------------- + + ! File name for 2000 CO over SE Asia + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_CO2_FF_2000.geos5.05x0666' + + BASE_YEAR = 2000 + + ! Read data + CALL READ_STREETS_05x0666( FILENAME, 'CO2-SRCE', 1, + $ TAU2000, CO2 ) + + ELSE + + !-------------------------------------------------------------- + ! Other simulations + !-------------------------------------------------------------- + + !-------------------------- + ! Read NOx + !-------------------------- + DO NSOURCE = 1, NTSOURCE1 + + ! File name + IF ( BASE_YEAR == 2000 ) THEN + + ! File name for 2000 CO over SE Asia + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_NOx_FF_2000.geos5.05x0666' + + TAU = TAU2000 + + ELSE + + ! File name for 2000 NOx over SE Asia + FILENAME = TRIM( STREETS_DIR ) // 'Streets_NOx_'// + & SOURCES( NSOURCE ) // '_2006.geos5.05x0666' + + TAU = TAU2006 + + ENDIF + + ! Read data + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 1, + $ TAU, TEMP ) + + NOX = NOX + TEMP * ONOFF( NSOURCE ) * SCALE2020( NSOURCE ) + + ENDDO + +!------------------------------------------------------------------------ +! Not available yet +! ! Annual scalar factor (phs, 3/10/08) +! IF ( BASE_YEAR == 2000 ) THEN +! CALL GET_ANNUAL_SCALAR_05x0666( 71, 2000, +! & SIM_YEAR, SCALFAC ) +! NOX = NOX * SCALFAC +! ENDIF +!------------------------------------------------------------------------ + !-------------------------- + ! Seasonal Variation for NOx + !-------------------------- + + ! Monthly Variability for any year. Variability has + ! been obtained from 2004 1x1 data, for two cases: + ! FF seasonality for 2000, and TOTAL (BF+FF) for 2006 + ! inventories (phs, 12/2/08) + + IF ( IS_2006 ) THEN + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_2004_NOx_MonthFctr_total.geos5.05x0666' + + ELSE + + ! we need to redefine the entire path here + !----------------------------------------- + FILENAME = TRIM( DATA_DIR ) // 'Streets_200812/' + & // 'Streets_2004_NOx_MonthFctr_FF.geos5.05x0666' + + ENDIF + + CALL READ_STREETS_05x0666( FILENAME, 'RATIO-2D', + $ 71, TAUMONTH_2004, TEMP ) + + NOX = NOX * TEMP + + + !-------------------------- + ! Read CO 2006 (SE Asia) + !-------------------------- + IF ( IS_2006 ) THEN + + DO NSOURCE = 1, NTSOURCE1 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_CO_'// + & SOURCES( NSOURCE ) // '_2006.geos5.05x0666' + + ! Read data + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 4, + $ TAU2006, TEMP ) + + ! No scaling for 2006-2020 + CO = CO + TEMP * ONOFF( NSOURCE ) + + ENDDO + + ! Monthly Variability for 2006 BF+FF. Variability has + ! been obtained from 2001 05x0666 data, and like those + ! those data, only China features variability (phs, 12/2/08) + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_2001_CO_MonthFctr_total.geos5.05x0666' + + CALL READ_STREETS_05x0666( FILENAME, 'RATIO-2D', 72, + $ TAUMONTH_2001, TEMP ) + + CO = CO * TEMP + + !------------------------------ + ! Read CO 2000 (2001 for China) + !----------------------------- + ELSE + + !-- PART 1 -- File name for 2000 CO over SE Asia + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_CO_FF_2000.geos5.05x0666' + + ! Read data + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 4, + $ TAU2000, CO ) + +!------------------------------------------------------------------------ +! Not available yet +! CALL GET_ANNUAL_SCALAR_05x0666( 72, 2000, +! & SIM_YEAR, SCALFAC ) +! CO = CO * SCALFAC +!------------------------------------------------------------------------ + + + !-- PART 2 -- File name for 2001 CO over China only + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_2001CO_monthly_ff.geos5.05x0666' + + ! Read data + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 4, + $ TAUMONTH_2001, TEMP ) + +!------------------------------------------------------------------------ +! Not available yet +! CALL GET_ANNUAL_SCALAR_05x0666( 72, 2001, +! & SIM_YEAR, SCALFAC ) +! TEMP = TEMP * SCALFAC +!------------------------------------------------------------------------ + + + !-- PART 3 -- Replace SE Asia CO for 2000 with China CO for 2001 + + WHERE ( MASK_CHINA > 0 ) CO = TEMP + + + ENDIF + + + + !-------------------------- + ! Read SO2 and regrid + !-------------------------- + + DO NSOURCE = 1, NTSOURCE1 + + ! File name + IF ( BASE_YEAR == 2000 ) THEN + + ! File name for 2000 SO2 over SE Asia + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_SO2_FF_2000.geos5.05x0666' + + TAU = TAU2000 + + ELSE + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_SO2_'// + & SOURCES( NSOURCE ) // '_2006.geos5.05x0666' + + TAU = TAU2006 + + ENDIF + + ! Read data + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 26, + $ TAU, TEMP ) + + SO2 = SO2 + TEMP * ONOFF( NSOURCE ) + + ENDDO + +!------------------------------------------------------------------------ +! Not available yet +! ! Annual scalar factor (amv, phs, 3/10/08) +! IF ( .NOT. IS_2006 ) THEN +! CALL GET_ANNUAL_SCALAR_05x0666( 73, 2000, +! $ SIM_YEAR, SCALFAC ) +! SO2 = SO2 * SCALFAC +! ENDIF +!------------------------------------------------------------------------ + + + + !--------------------------------------------- + ! Read NH3 only if base year is 2000 + !--------------------------------------------- + IF ( IS_2006 ) THEN + + NH3 = -1D0 + + ELSE + + ! File name + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_NH3_FF_2000.geos5.05x0666' + + ! Old file has NH3 as tracer #30 + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 30, + $ TAU2000, NH3 ) + + ! switch and scale + NH3 = NH3 * ONOFF( 1 ) + + ENDIF + + + + !--------------------------------------------- + ! Read VOC only if base year is 2006 + !--------------------------------------------- + IF ( IS_2006 ) THEN + + TAU = TAU2006 + + !-------------------------- + ! Read ACET and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_ACET_'// + & SOURCES( NSOURCE ) // '_2006.geos5.05x0666' + + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 9, + & TAU, TEMP ) + + ACET = ACET + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + !-------------------------- + ! Read C2H6 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_C2H6_'// + & SOURCES( NSOURCE ) // '_2006.geos5.05x0666' + + ! Read data [atom C/yr] + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 21, + & TAU, TEMP ) + + C2H6 = C2H6 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + !-------------------------- + ! Read CH2O and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_CH2O_'// + & SOURCES( NSOURCE ) // '_2006.geos5.05x0666' + + ! Read data [atom C/yr] + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 20, + & TAU, TEMP ) + + CH2O = CH2O + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + !-------------------------- + ! Read C3H8 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_C3H8_'// + & SOURCES( NSOURCE ) // '_2006.geos5.05x0666' + + ! Read data [atom C/yr] + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 19, + & TAU, TEMP ) + + C3H8 = C3H8 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + !-------------------------- + ! Read PRPE and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_PRPE_'// + & SOURCES( NSOURCE ) // '_2006.geos5.05x0666' + + ! Read data [atom C/yr] + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 18, + & TAU, TEMP ) + + PRPE = PRPE + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + !-------------------------- + ! Read ALD2 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_ALD2_'// + & SOURCES( NSOURCE ) // '_2006.geos5.05x0666' + + ! Read data [atom C/yr] + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 11, + & TAU, TEMP ) + + ALD2 = ALD2 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + + !-------------------------- + ! Read MEK and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_MEK_'// + & SOURCES( NSOURCE ) // '_2006.geos5.05x0666' + + ! Read data [atom C/yr] + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 10, + & TAU, TEMP ) + + MEK = MEK + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + !-------------------------- + ! Read ALK4 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_ALK4_'// + & SOURCES( NSOURCE ) // '_2006.geos5.05x0666' + + ! Read data [atom C/yr] + CALL READ_STREETS_05x0666( FILENAME, 'ANTHSRCE', 5, + & TAU, TEMP ) + + ALK4 = ALK4 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + ELSE + + ! Set VOC to -1 + ALK4 = -1D0 + ACET = -1D0 + MEK = -1D0 + PRPE = -1D0 + C2H6 = -1D0 + C3H8 = -1D0 + CH2O = -1D0 + ALD2 = -1D0 + + + ENDIF ! end VOCs + + ENDIF ! end other simulations + + +!------------------------------------------------------------------------ +! Not available yet +! !-------------------------- +! ! Compute future emissions +! !-------------------------- +! IF ( LFUTURE ) THEN +! CALL STREETS_SCALE_FUTURE +! ENDIF +!------------------------------------------------------------------------ + + !-------------------------- + ! Print emission totals + !-------------------------- + CALL TOTAL_ANTHRO_Tg( SIM_YEAR, BASE_YEAR ) + + END SUBROUTINE EMISS_STREETS_ANTHRO_05x0666 + +!----------------------------------------------------------------------------- +!===== (lzh, 04/25/2014) ===== +!------------------------------------------------------------------------------ + + SUBROUTINE READ_STREETS_025x03125( FILENAME, CATEGORY, TRACERN, + $ TAU, ARR ) +! +!****************************************************************************** +! Subroutine READ_STREETS_025x03125 reads data from one STREETS data file +! from disk, at 025x03125 resolution and cut them to the CHINA nested +! window. (phs, 12/2/08) +! +! Arguments as Input: +! ============================================================================ +! (1 ) FILENAME (CHARACTER) : Name of anthro or biomass file to read +! (2 ) CATEGORY (CHARACTER) : Category name +! (3 ) TRACERN (INTEGER ) : Tracer number +! +! Arguments as Input/Output: +! ============================================================================ +! (2 ) ARR (REAL*8 ) : Array to hold emissions +! +! NOTES: +! (1) UNIT argument in DO_REGRID_... is 'kg/yr' for VOCs +! because 'atom C/yr' and 'molec/yr' are not recognized. The result is +! still correct. +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE REGRID_1x1_MOD, ONLY : DO_REGRID_025X03125 + +# include "CMN_SIZE" ! Size parameters + + ! Arguments + CHARACTER(LEN=*), INTENT(IN) :: FILENAME, CATEGORY + INTEGER, INTENT(IN) :: TRACERN + REAL*8, INTENT(INOUT) :: ARR(IIPAR,JJPAR) + REAL*8, INTENT(IN) :: TAU + + ! Local variables + REAL*4 :: ARRAY(I025x031,J025x031,1) + REAL*8 :: GEOS_025x03125(I025x031,J025x031,1) + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - EMISS_STREETS_ANTHRO: Reading ', a ) + + ! Read data + CALL READ_BPCH2( FILENAME, CATEGORY, TRACERN, + & TAU, I025x031, J025x031, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 before regridding + GEOS_025x03125(:,:,1) = ARRAY(:,:,1) + + ! Cut to China nested simulation window + CALL DO_REGRID_025x03125( 1,'kg/yr', GEOS_025x03125, ARR ) + + END SUBROUTINE READ_STREETS_025x03125 + +!------------------------------------------------------------------------------ + + SUBROUTINE EMISS_STREETS_ANTHRO_025x03125 +! +!****************************************************************************** +! Subroutine EMISS_STREETS_ANTHRO_05x0666 reads the David Streets et al +! emission fields at 0.5 x 0.666 resolution and regrids them to the current +! nested-grid model resolution. (yxw, dan, bmy, 11/6/08) +! +! NOTES: +! (1 ) For now, disable the monthly CO emissions and just read the +! same emissions as we do for the global simulations. Update +! emissions in a future release. (bmy, 11/6/08) +! (2) Now read 2006 inventory (including VOCs) if needed. Apply monthly +! variations for NOx +! (3) Bug fixe : we call only read_streets_05x0666. (ccc, 3/11/09) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE LOGICAL_MOD, ONLY : LFUTURE + USE TRACER_MOD, ONLY : ITS_A_CO2_SIM, ITS_A_CH4_SIM + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE TIME_MOD, ONLY : GET_MONTH, GET_YEAR + USE TRACER_MOD, ONLY : XNUMOL + +# include "CMN_SIZE" ! Size parameters +# include "CMN_O3" ! FSCALYR + + ! Local variables + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: BASE_YEAR, SIM_YEAR + CHARACTER(LEN=255) :: FILENAME, STREETS_DIR + + ! to loop over the sources + INTEGER, PARAMETER :: NSRCE = 10 + INTEGER :: NSOURCE, NTSOURCE1, NTSOURCE2 + CHARACTER(LEN=3) :: SOURCES(NSRCE) !! + REAL*8 :: ONOFF(NSRCE) !! To switch off/on each sources + REAL*8 :: SCALE2020(NSRCE) !! To scale 2006 to 2020 + + ! to hold temporary data and scale factors + REAL*4 :: SCALFAC( IIPAR, JJPAR ) + REAL*8 :: TEMP( IIPAR, JJPAR ) + + ! TAUs + REAL*8 :: TAU2000, TAU2004, TAU2006 + REAL*8 :: TAUMONTH_2001, TAUMONTH_2004, TAU + + !================================================================= + ! EMISS_STREETS_ANTHRO begins here! + !================================================================= + + ! First-time initialization + IF ( FIRST ) THEN + CALL INIT_STREETS_ANTHRO + FIRST = .FALSE. + ELSE + NOx = 0D0 + CO = 0D0 + SO2 = 0D0 + ALK4 = 0D0 + ACET = 0D0 + MEK = 0D0 + PRPE = 0D0 + C2H6 = 0D0 + C3H8 = 0D0 + CH2O = 0D0 + ALD2 = 0D0 + + ! (lzh, 09/15/2014) + NH3 = 0D0 + ENDIF + + ! TAU0 values for 2000, 2004 and 2006 + TAU2000 = GET_TAU0( 1, 1, 2000 ) + TAU2004 = GET_TAU0( 1, 1, 2004 ) + TAU2006 = GET_TAU0( 1, 1, 2006 ) + + MONTH = GET_MONTH() + TAUMONTH_2001 = GET_TAU0( MONTH, 1, 2001 ) + TAUMONTH_2004 = GET_TAU0( MONTH, 1, 2004 ) + + !------------------------------------------------------------------------- + ! Base Year & Yearly Scale Factors + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! %%% To simulate 2020 : % + ! %%% you must set BASE_YEAR = 2020 (hardwired, see below) % + ! %%% % + ! %%% To simulate 2006 and after, we use: % + ! %%% BASE_YEAR = 2006 for all species. NH3 is not emitted % + ! %%% % + ! %%% To simulate 2005 and before, we use: % + ! %%% BASE_YEAR = 2001 for CO in China % + ! %%% BASE_YEAR = 2000 for CO outside China, NOx, SO2, CH4, & CO2 % + ! %%% & VOC are not emitted - % + ! %%% % + ! %%% YEARLY SCALE FACTOR (**** NOT AVAILABLE YET ****) % + ! %%% to be applied to get 1985-2005 estimates % + ! %%% of NOx, CO and SO2 if BASE_YEAR is 2000/1 % + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !------------------------------------------------------------------------- + + ! select emissions year + IF ( FSCALYR < 0 ) THEN + SIM_YEAR = GET_YEAR() + ELSE + SIM_YEAR = FSCALYR + ENDIF + + ! Pickup BASE_YEAR according to SIMulation YEAR + IF ( SIM_YEAR >= 2006 ) THEN + IS_2006 = .TRUE. + BASE_YEAR = 2006 + ELSE + BASE_YEAR = 2000 + ENDIF + + ! %%%% To simulate 2020 estimate, uncomment following line %%%% + !BASE_YEAR = 2020 + !IS_2006 = .TRUE. + + ! define data directory and number of sources + IF ( IS_2006 ) THEN + NTSOURCE1 = 4 + NTSOURCE2 = 10 + STREETS_DIR = TRIM( DATA_DIR ) // 'Streets_200812/' + ELSE + NTSOURCE1 = 1 + NTSOURCE2 = 2 + STREETS_DIR = TRIM( DATA_DIR ) // 'Streets_200607/' + ENDIF + + !----------------------------------------------------------------- + ! SOURCES = String array to identify emissions sources for 2006 + ! inventory. They correspond to : + ! + ! Industry, Power, Residential, Transport for NOx/CO/SO2 + ! + ! Domestic Biofuel, Domestic Fossil Fuel, Domestic Non-Combustion, + ! Industry, Power Plants, and Transportation for NMVOC + ! + ! ONOFF = their orresponding switch + ! ### MODIFY ONLY ONOFF FOR SENSITIVITY STUDIES ## + !----------------------------------------------------------------- + SOURCES = (/ 'ind', 'pow', 'res', 'tra', ! for NOx/CO/SO2 + & 'dob', 'dof', 'dop', 'ind', 'pow', 'tra' /) ! for VOC + + ONOFF = (/ 1D0, 1D0, 1D0, 1D0, + & 1D0, 1D0, 1D0, 1D0, 1D0, 1D0 /) + + ! Corresponding scaling to get 2020 from 2006 + ! Note : first line only for NOx (no change in CO/SO2) + IF ( BASE_YEAR == 2020 ) THEN + SCALE2020 = (/ 2.36D0, 1.33D0, 1.02D0, 2.5D0, + & 1.02D0, 1.02D0, 1.02D0, 2.36D0, 1.33D0, 2.5D0 /) + ELSE + SCALE2020 = (/ 1D0, 1D0, 1D0, 1D0, + & 1D0, 1D0, 1D0, 1D0, 1D0, 1D0 /) + ENDIF + + !----------------------------------------------------------------- + ! Test for simulation type + !----------------------------------------------------------------- + IF ( ITS_A_CH4_SIM() ) THEN + + !-------------------------- + ! Read CH4 and regrid + ! (CH4 simulations only) + !-------------------------- + + ! File name for 2000 CO over SE Asia + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_CH4_FF_2000.geos5.025x03125' + + BASE_YEAR = 2000 + + ! Read data + CALL READ_STREETS_025x03125( FILENAME, 'CH4-EMIS', 1, + $ TAU2000, CH4 ) + + + ELSE IF ( ITS_A_CO2_SIM() ) THEN + + !-------------------------- + ! Read CO2 and regrid + ! (CH2 simulations only) + !-------------------------- + + ! File name for 2000 CO over SE Asia + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_CO2_FF_2000.geos5.025x03125' + + BASE_YEAR = 2000 + + ! Read data + CALL READ_STREETS_025x03125( FILENAME, 'CO2-SRCE', 1, + $ TAU2000, CO2 ) + + ELSE + + !-------------------------------------------------------------- + ! Other simulations + !-------------------------------------------------------------- + + !-------------------------- + ! Read NOx + !-------------------------- + DO NSOURCE = 1, NTSOURCE1 + + ! File name + IF ( BASE_YEAR == 2000 ) THEN + + ! File name for 2000 CO over SE Asia + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_NOx_FF_2000.geos5.025x03125' + + TAU = TAU2000 + + ELSE + + ! File name for 2000 NOx over SE Asia + FILENAME = TRIM( STREETS_DIR ) // 'Streets_NOx_'// + & SOURCES( NSOURCE ) // '_2006.geos5.025x03125' + + TAU = TAU2006 + + ENDIF + + ! Read data + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 1, + $ TAU, TEMP ) + + NOX = NOX + TEMP * ONOFF( NSOURCE ) * SCALE2020( NSOURCE ) + + ENDDO + +!------------------------------------------------------------------------ +! Not available yet +! ! Annual scalar factor (phs, 3/10/08) +! IF ( BASE_YEAR == 2000 ) THEN +! CALL GET_ANNUAL_SCALAR_05x0666( 71, 2000, +! & SIM_YEAR, SCALFAC ) +! NOX = NOX * SCALFAC +! ENDIF +!------------------------------------------------------------------------ +c$$$ !-------------------------- +c$$$ ! Seasonal Variation for NOx +c$$$ !-------------------------- +c$$$ +c$$$ ! Monthly Variability for any year. Variability has +c$$$ ! been obtained from 2004 1x1 data, for two cases: +c$$$ ! FF seasonality for 2000, and TOTAL (BF+FF) for 2006 +c$$$ ! inventories (phs, 12/2/08) +c$$$ +c$$$ IF ( IS_2006 ) THEN +c$$$ FILENAME = TRIM( STREETS_DIR ) // +c$$$ & 'Streets_2004_NOx_MonthFctr_total.geos5.05x0666' +c$$$ +c$$$ ELSE +c$$$ +c$$$ ! we need to redefine the entire path here +c$$$ !----------------------------------------- +c$$$ FILENAME = TRIM( DATA_DIR ) // 'Streets_200812/' +c$$$ & // 'Streets_2004_NOx_MonthFctr_FF.geos5.05x0666' +c$$$ +c$$$ ENDIF +c$$$ +c$$$ CALL READ_STREETS_05x0666( FILENAME, 'RATIO-2D', +c$$$ $ 71, TAUMONTH_2004, TEMP ) +c$$$ +c$$$ NOX = NOX * TEMP + + !-------------------------- + ! Read CO 2006 (SE Asia) + !-------------------------- + IF ( IS_2006 ) THEN + + DO NSOURCE = 1, NTSOURCE1 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_CO_'// + & SOURCES( NSOURCE ) // '_2006.geos5.025x03125' + + ! Read data + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 4, + $ TAU2006, TEMP ) + + ! No scaling for 2006-2020 + CO = CO + TEMP * ONOFF( NSOURCE ) + + ENDDO + + ! Monthly Variability for 2006 BF+FF. Variability has + ! been obtained from 2001 05x0666 data, and like those + ! those data, only China features variability (phs, 12/2/08) + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_2001_CO_MonthFctr_total.geos5.025x03125' + + CALL READ_STREETS_025x03125( FILENAME, 'RATIO-2D', 72, + $ TAUMONTH_2001, TEMP ) + + CO = CO * TEMP + + !------------------------------ + ! Read CO 2000 (2001 for China) + !----------------------------- + ELSE + + !-- PART 1 -- File name for 2000 CO over SE Asia + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_CO_FF_2000.geos5.025x03125' + + ! Read data + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 4, + $ TAU2000, CO ) + +!------------------------------------------------------------------------ +! Not available yet +! CALL GET_ANNUAL_SCALAR_05x0666( 72, 2000, +! & SIM_YEAR, SCALFAC ) +! CO = CO * SCALFAC +!------------------------------------------------------------------------ + + + !-- PART 2 -- File name for 2001 CO over China only + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_2001CO_monthly_ff.geos5.025x03125' + + ! Read data + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 4, + $ TAUMONTH_2001, TEMP ) + +!------------------------------------------------------------------------ +! Not available yet +! CALL GET_ANNUAL_SCALAR_05x0666( 72, 2001, +! & SIM_YEAR, SCALFAC ) +! TEMP = TEMP * SCALFAC +!------------------------------------------------------------------------ + + + !-- PART 3 -- Replace SE Asia CO for 2000 with China CO for 2001 + + WHERE ( MASK_CHINA > 0 ) CO = TEMP + + + ENDIF + + !-------------------------- + ! Read SO2 and regrid + !-------------------------- + + DO NSOURCE = 1, NTSOURCE1 + + ! File name + IF ( BASE_YEAR == 2000 ) THEN + + ! File name for 2000 SO2 over SE Asia + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_SO2_FF_2000.geos5.025x03125' + + TAU = TAU2000 + + ELSE + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_SO2_'// + & SOURCES( NSOURCE ) // '_2006.geos5.025x03125' + + TAU = TAU2006 + + ENDIF + + ! Read data + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 26, + $ TAU, TEMP ) + + SO2 = SO2 + TEMP * ONOFF( NSOURCE ) + + ENDDO + +!------------------------------------------------------------------------ +! Not available yet +! ! Annual scalar factor (amv, phs, 3/10/08) +! IF ( .NOT. IS_2006 ) THEN +! CALL GET_ANNUAL_SCALAR_05x0666( 73, 2000, +! $ SIM_YEAR, SCALFAC ) +! SO2 = SO2 * SCALFAC +! ENDIF +!------------------------------------------------------------------------ + + !--------------------------------------------- + ! Read NH3 only if base year is 2000 + !--------------------------------------------- + IF ( IS_2006 ) THEN + + NH3 = -1D0 + + ELSE + + ! File name + FILENAME = TRIM( STREETS_DIR ) // + & 'Streets_NH3_FF_2000.geos5.025x03125' + + ! Old file has NH3 as tracer #30 + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 30, + $ TAU2000, NH3 ) + + ! switch and scale + NH3 = NH3 * ONOFF( 1 ) + + ENDIF + + !--------------------------------------------- + ! Read VOC only if base year is 2006 + !--------------------------------------------- + IF ( IS_2006 ) THEN + + TAU = TAU2006 + + !-------------------------- + ! Read ACET and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_ACET_'// + & SOURCES( NSOURCE ) // '_2006.geos5.025x03125' + + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 9, + & TAU, TEMP ) + + ACET = ACET + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + !-------------------------- + ! Read C2H6 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_C2H6_'// + & SOURCES( NSOURCE ) // '_2006.geos5.025x03125' + + ! Read data [atom C/yr] + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 21, + & TAU, TEMP ) + + C2H6 = C2H6 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + !-------------------------- + ! Read CH2O and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_CH2O_'// + & SOURCES( NSOURCE ) // '_2006.geos5.025x03125' + + ! Read data [atom C/yr] + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 20, + & TAU, TEMP ) + + CH2O = CH2O + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + !-------------------------- + ! Read C3H8 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_C3H8_'// + & SOURCES( NSOURCE ) // '_2006.geos5.025x03125' + + ! Read data [atom C/yr] + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 19, + & TAU, TEMP ) + + C3H8 = C3H8 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + !-------------------------- + ! Read PRPE and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_PRPE_'// + & SOURCES( NSOURCE ) // '_2006.geos5.025x03125' + + ! Read data [atom C/yr] + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 18, + & TAU, TEMP ) + + PRPE = PRPE + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + !-------------------------- + ! Read ALD2 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_ALD2_'// + & SOURCES( NSOURCE ) // '_2006.geos5.025x03125' + + ! Read data [atom C/yr] + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 11, + & TAU, TEMP ) + + ALD2 = ALD2 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + !-------------------------- + ! Read MEK and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_MEK_'// + & SOURCES( NSOURCE ) // '_2006.geos5.025x03125' + + ! Read data [atom C/yr] + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 10, + & TAU, TEMP ) + + MEK = MEK + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + + !-------------------------- + ! Read ALK4 and regrid + !-------------------------- + DO NSOURCE = NTSOURCE1 + 1, NTSOURCE2 + + FILENAME = TRIM( STREETS_DIR ) // 'Streets_ALK4_'// + & SOURCES( NSOURCE ) // '_2006.geos5.025x03125' + + ! Read data [atom C/yr] + CALL READ_STREETS_025x03125( FILENAME, 'ANTHSRCE', 5, + & TAU, TEMP ) + + ALK4 = ALK4 + TEMP * ONOFF( NSOURCE ) + & * SCALE2020( NSOURCE ) + ENDDO + + ELSE + + ! Set VOC to -1 + ALK4 = -1D0 + ACET = -1D0 + MEK = -1D0 + PRPE = -1D0 + C2H6 = -1D0 + C3H8 = -1D0 + CH2O = -1D0 + ALD2 = -1D0 + + + ENDIF ! end VOCs + + ENDIF ! end other simulations + + +!------------------------------------------------------------------------ +! Not available yet +! !-------------------------- +! ! Compute future emissions +! !-------------------------- +! IF ( LFUTURE ) THEN +! CALL STREETS_SCALE_FUTURE +! ENDIF +!------------------------------------------------------------------------ + + !-------------------------- + ! Print emission totals + !-------------------------- + CALL TOTAL_ANTHRO_Tg( SIM_YEAR, BASE_YEAR ) + + END SUBROUTINE EMISS_STREETS_ANTHRO_025x03125 + +!----------------------------------------------------------------------------- + + SUBROUTINE STREETS_SCALE_FUTURE +! +!****************************************************************************** +! Subroutine STREETS_SCALE_FUTURE applies the IPCC future scale factors to +! the David Streets' anthropogenic emissions. (swu, bmy, 8/16/06) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_COff + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NH3an + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_NOxff + USE FUTURE_EMISSIONS_MOD, ONLY : GET_FUTURE_SCALE_SO2ff + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: I, J + + !================================================================= + ! STREETS_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/yr] + NOx(I,J) = NOx(I,J) * GET_FUTURE_SCALE_NOxff( I, J ) + + ! Future CO [kg CO /yr] + CO(I,J) = CO(I,J) * GET_FUTURE_SCALE_COff( I, J ) + + ! Future SO2 [kg SO2/yr] + SO2(I,J) = SO2(I,J) * GET_FUTURE_SCALE_SO2ff( I, J ) + + ! Future SO2 [kg SO2/yr] + NH3(I,J) = NH3(I,J) * GET_FUTURE_SCALE_NH3an( I, J ) + + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Return to calling program + END SUBROUTINE STREETS_SCALE_FUTURE + +!------------------------------------------------------------------------------ + + SUBROUTINE TOTAL_ANTHRO_TG ( YEAR, BASE_YEAR ) +! +!****************************************************************************** +! Subroutine TOTAL_ANTHRO_TG prints the totals for the anthropogenic +! emissions of NOx and CO. (bmy, 8/16/06) +! +! NOTES: +! (1 ) Now both simulation and base years are input. Output totals in +! Tg/month instead of Tg/yr, except for CO2 and CH4 offline +! simulations (phs, 12/9/08) +! (2 ) Updated information output. Account for NH3 2000 used for all +! simulation years (phs, 2/27/09) +!****************************************************************************** +! + ! References to F90 modules + USE TRACER_MOD, ONLY : ITS_A_CH4_SIM, ITS_A_CO2_SIM + +# include "CMN_SIZE" ! Size parameters + + ! argument + INTEGER, INTENT(IN) :: YEAR, BASE_YEAR + + ! Local variables + INTEGER :: I, J + REAL*8 :: T_NOX, T_CO, T_SO2 + REAL*8 :: T_NH3, T_CH4, T_CO2 + REAL*8 :: T_ACET, T_ALD2, T_ALK4, T_C2H6 + REAL*8 :: T_C3H8, T_CH2O, T_MEK, T_PRPE + REAL*8 :: AFACTOR + + CHARACTER(LEN=3) :: UNIT + + !================================================================= + ! TOTAL_ANTHRO_TG begins here! + !================================================================= + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, 100 ) BASE_YEAR + 100 FORMAT( 'M O N T H L Y S T R E E T S A S I A N', + $ ' E M I S S I O N S', /, 'Scaled from base year : ', i4) + + + ! Test for simulation type + IF ( ITS_A_CH4_SIM() ) THEN + + !----------------------- + ! CH4 simulation + !----------------------- + + ! Total CH4 [Tg CH4] + T_CH4 = SUM( CH4 ) * 1d-9 + + ! Print totals + WRITE( 6, 120 ) 'CH4 ', 2000, T_NOx, ' CH4' + + ELSE IF ( ITS_A_CO2_SIM() ) THEN + + !----------------------- + ! CO2 simulation + !----------------------- + + ! Total CO2 [Tg CO2] + T_CH4 = SUM( CO2 ) * 1d-9 + + ! Print totals + WRITE( 6, 120 ) 'CO2 ', 2000, T_NOx, ' CO2' + + ELSE + + !----------------------- + ! Other simulations + !----------------------- +#if !defined( GRID05x0666 ) + IF ( .NOT. IS_2006 ) THEN + WRITE( 6, * ) 'NOTES: ' + WRITE( 6, * ) '(1) Base year for NOx : 2004' + WRITE( 6, * ) '(2) Annual scale factors applied to' // + $ ' NOx, CO & SO2' + WRITE( 6, * ) '(3) Monthly variations applied to NOx & CO' + ELSE + WRITE( 6, * ) 'NOTES: ' + WRITE( 6, * ) '(1) Include ANTH and BIOFUEL' + WRITE( 6, * ) '(2) Base year for NH3 : 2000' + WRITE( 6, * ) '(3) Monthly variations applied to NOx & CO' + ENDIF +#endif + + ! Total NOx [Tg N] + T_NOX = SUM( NOx ) * 1d-9 * ( 14d0 / ( 12d0 * 46d0 ) ) + + ! Total CO [Tg CO] + T_CO = SUM( CO ) * 1d-9 / 12d0 + + ! Total SO2 [Tg S] + T_SO2 = SUM( SO2 ) * 1d-9 * ( 32d0 / ( 12d0 * 64d0 ) ) + + ! Total NH3 [Tg NH3] + T_NH3 = SUM( NH3 ) * 1d-9 / 12d0 + + IF ( IS_2006 ) THEN + + AFACTOR = 12d-12 / 6.0225d23 ! for C atom, units=Tg/yr + + AFACTOR = AFACTOR / 12d0 ! convert from Tg/yr to Tg/month + + T_ACET = SUM(ACET) * AFACTOR + T_ALD2 = SUM(ALD2) * AFACTOR + T_ALK4 = SUM(ALK4) * AFACTOR + T_C2H6 = SUM(C2H6) * AFACTOR + T_C3H8 = SUM(C3H8) * AFACTOR + T_CH2O = SUM(CH2O) * 30d-12 / (6.0225d23 * 12d0) + T_MEK = SUM(MEK) * AFACTOR + T_PRPE = SUM(PRPE) * AFACTOR + +!-- prior 2/27/09 +! ELSE +! +! ! Total NH3 [Tg NH3] +! T_NH3 = SUM( NH3 ) * 1d-9 / 12d0 + + ENDIF + + + ! Print totals in [kg/month] + WRITE( 6, 110 ) 'NOx ', YEAR, MONTH, T_NOx, '[Tg N ]' + WRITE( 6, 110 ) 'CO ', YEAR, MONTH, T_CO, '[Tg CO ]' + WRITE( 6, 110 ) 'SO2 ', YEAR, MONTH, T_SO2, '[Tg S ]' + WRITE( 6, 110 ) 'NH3 ', YEAR, MONTH, T_NH3, '[Tg NH3 ]' + + IF ( IS_2006 ) THEN + + WRITE( 6, 110 ) 'ALK4 ', YEAR, MONTH, T_ALK4, '[Tg C ]' + WRITE( 6, 110 ) 'ACET ', YEAR, MONTH, T_ACET, '[Tg C ]' + WRITE( 6, 110 ) 'MEK ', YEAR, MONTH, T_MEK, '[Tg C ]' + WRITE( 6, 110 ) 'PRPE ', YEAR, MONTH, T_PRPE, '[Tg C ]' + WRITE( 6, 110 ) 'C3H8 ', YEAR, MONTH, T_C3H8, '[Tg C ]' + WRITE( 6, 110 ) 'CH2O ', YEAR, MONTH, T_CH2O, '[Tg Ch2O]' + WRITE( 6, 110 ) 'C2H6 ', YEAR, MONTH, T_C2H6, '[Tg C ]' + WRITE( 6, 110 ) 'ALD2 ', YEAR, MONTH, T_ALD2, '[Tg C ]' + +!-- prior 2/27/09 +! ELSE +! +! WRITE( 6, 110 ) 'NH3 ', YEAR, MONTH, T_NH3, '[Tg NH3 ]' + + ENDIF + + ENDIF + + + ! Format statement + 110 FORMAT( 'David Streets anthro ', a5, 'for year ', i4, + $ ' and month ', i2.2 ,': ', f11.4, 1x, a9 ) + + 120 FORMAT( 'David Streets anthro ', a5, 'for year ', i4, + $ ': ', f11.4, 1x, a9 ) + + ! Fancy output + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + + ! Return to calling program + END SUBROUTINE TOTAL_ANTHRO_Tg + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_STREETS_MASKS +! +!****************************************************************************** +! Subroutine READ_STREETS_MASKS reads and regrids the China and SE Asia masks +! that define the David Streets' emission regions (bmy, 8/16/06, 9/5/06) +! +! NOTES: +! (1 ) Now also save 1x1 CHINA MASK for use in other routines. (bmy, 9/5/06) +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 + USE REGRID_1x1_MOD, ONLY : DO_REGRID_G2G_1x1, DO_REGRID_1x1 + + ! (lzh,02/01/2015) update regridding + USE REGRID_A2A_MOD, ONLY : DO_REGRID_A2A + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + REAL*4 :: ARRAY(I1x1,J1x1-1,1) + REAL*8 :: GEN_1x1(I1x1,J1x1-1) + REAL*8 :: GEOS_1x1(I1x1,J1x1,1) + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=255) :: LLFILENAME !(lzh,02/01/2015) + + !================================================================= + ! READ_STREETS_MASKS begins here! + !================================================================= + + !------------------------------------ + ! China Mask (for 2001 CO emisisons) + !------------------------------------ + + ! File name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'Streets_200607/China_mask.generic.1x1' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_STREETS_MASKS: Reading ', a ) + + ! Read data [unitless] + CALL READ_BPCH2( FILENAME, 'LANDMAP', 2, + & 0d0, I1x1, J1x1-1, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 before regridding + GEN_1x1(:,:) = ARRAY(:,:,1) + + ! Save the 1x1 China mask for future use + MASK_CHINA_1x1(:,:) = GEN_1x1(:,:) + + ! Regrid from GENERIC 1x1 GRID to GEOS 1x1 GRID +! CALL DO_REGRID_G2G_1x1( 'unitless', GEN_1x1, GEOS_1x1(:,:,1) ) + + ! Regrid from GEOS 1x1 GRID to current model resolution +! CALL DO_REGRID_1x1( 'unitless', GEOS_1x1, MASK_CHINA ) + + ! (lzh,02/01/2015) + ! File with lat/lon edges for regridding + LLFILENAME = TRIM( DATA_DIR_1x1) // + & 'MAP_A2A_Regrid_201203/MAP_A2A_latlon_generic1x1.nc' + + ! Regrid from GENERIC 1x1 to current model resolution + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1-1, + & GEN_1x1, MASK_CHINA, IS_MASS=0, + & netCDF=.TRUE. ) + WHERE( MASK_CHINA > 0d0 ) MASK_CHINA = 1d0 + + !------------------------------------ + ! SE Asia Mask (for 2000 emissions) + !------------------------------------ + + ! File name + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'Streets_200607/SE_Asia_mask.generic.1x1' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Read data [unitless] + CALL READ_BPCH2( FILENAME, 'LANDMAP', 2, + & 0d0, I1x1, J1x1-1, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 before regridding + GEN_1x1(:,:) = ARRAY(:,:,1) + + ! Regrid from GENERIC 1x1 GRID to GEOS 1x1 GRID +! CALL DO_REGRID_G2G_1x1( 'unitless', GEN_1x1, GEOS_1x1(:,:,1) ) + + ! Regrid from GEOS 1x1 GRID to current model resolution +! CALL DO_REGRID_1x1( 'unitless', GEOS_1x1, MASK_SE_ASIA ) + + ! (lzh,02/01/2015) + ! Regrid from GENERIC 1x1 GRID to current model resolution + CALL DO_REGRID_A2A( LLFILENAME, I1x1, J1x1-1, + & GEN_1x1, MASK_SE_ASIA, IS_MASS=0, + & netCDF=.TRUE. ) + WHERE( MASK_SE_ASIA > 0d0 ) MASK_SE_ASIA = 1d0 + + ! Return to calling program + END SUBROUTINE READ_STREETS_MASKS + +!------------------------------------------------------------------------------ + + SUBROUTINE READ_STREETS_MASKS_05x0666 +! +!****************************************************************************** +! Subroutine READ_STREETS_MASKS reads and regrids the China and SE Asia +! masks that define the David Streets' emission regions. Specially modified +! for the GEOS-5 0.5 x 0.666 nested grid simulations. +! (yxw, dan, bmy, 11/6/08) +! +! NOTES: +!****************************************************************************** +! + ! References to F90 modules + USE BPCH2_MOD, ONLY : READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE REGRID_1x1_MOD, ONLY : DO_REGRID_05x0666 + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + REAL*4 :: ARRAY(I05x0666,J05x0666,1) + REAL*8 :: GEOS_05x0666(I05x0666,J05x0666,1) + CHARACTER(LEN=255) :: FILENAME + + !================================================================= + ! READ_STREETS_MASKS begins here! + !================================================================= + + ! Zero arrays + ARRAY = 0d0 + GEOS_05x0666 = 0d0 + + !------------------------------------ + ! China Mask (for 2001 CO emisisons) + !------------------------------------ + + ! File name + FILENAME = TRIM( DATA_DIR ) // + & 'Streets_200607/China_mask.geos5.05x0666' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - READ_STREETS_MASKS: Reading ', a ) + + ! Read data [unitless] + CALL READ_BPCH2( FILENAME, 'LANDMAP', 2, + & 0d0, I05x0666, J05x0666, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 before regridding + + + GEOS_05x0666(:,:,1) = ARRAY(:,:,1) + + ! Save the 1x1 China mask for future use + MASK_CHINA_05x0666(:,:) = GEOS_05x0666(:,:,1) + + ! Regrid from GENERIC 1x1 GRID to GEOS 1x1 GRID + CALL DO_REGRID_05x0666( 1, 'unitless', GEOS_05x0666, MASK_CHINA ) + + !------------------------------------ + ! SE Asia Mask (for 2000 emissions) + !------------------------------------ + + ! File name + FILENAME = TRIM( DATA_DIR ) // + & 'Streets_200607/SE_Asia_mask.geos5.05x0666' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + + ! Read data [unitless] + CALL READ_BPCH2( FILENAME, 'LANDMAP', 2, + & 0d0, I05x0666, J05x0666, + & 1, ARRAY, QUIET=.TRUE. ) + + ! Cast to REAL*8 before regridding + GEOS_05x0666(:,:,1) = ARRAY(:,:,1) + + ! Regrid from GENERIC 1x1 GRID to GEOS 1x1 GRID + CALL DO_REGRID_05x0666( 1, 'unitless', GEOS_05x0666, MASK_SE_ASIA) + + ! Return to calling program + END SUBROUTINE READ_STREETS_MASKS_05x0666 + +!------------------------------------------------------------------------------ + + SUBROUTINE INIT_STREETS_ANTHRO +! +!****************************************************************************** +! Subroutine INIT_STREETS_ANTHRO allocates and zeroes all module arrays. +! (bmy, 8/16/06, 11/6/08) +! +! NOTES: +! (1 ) Now allocate MASK_CHINA_1x1 (bmy, 9/5/06) +! (2 ) Now calls READ_STREETS_MASKS_05x0666 for the GEOS-5 0.5 x 0.666 +! nested-grid simulations (yxw, dan, bmy, 11/6/08) +!****************************************************************************** +! + ! References to F90 modules + USE ERROR_MOD, ONLY : ALLOC_ERR + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE LOGICAL_MOD, ONLY : LSTREETS + +# include "CMN_SIZE" ! Size parameters + + ! Local variables + INTEGER :: AS, J + + !================================================================= + ! INIT_STREETS begins here! + !================================================================= + + ! Return if LSTREETS is false + IF ( .not. LSTREETS ) 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 + + ALLOCATE( NH3( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NH3' ) + NH3 = 0d0 + + ALLOCATE( CO2( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CO2' ) + CO2 = 0d0 + + ALLOCATE( CH4( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CH4' ) + CH4 = 0d0 + + ! Now allocate VOCs (phs, 3/7/08) + ALLOCATE( ACET( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ACET' ) + ACET = 0d0 + + + ALLOCATE( ALD2( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ALD2' ) + ALD2 = 0d0 + + + ALLOCATE( C2H6( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'C2H6' ) + C2H6 = 0d0 + + + ALLOCATE( C3H8( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'C3H8' ) + C3H8 = 0d0 + + + ALLOCATE( PRPE( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PRPE' ) + PRPE = 0d0 + + + ALLOCATE( ALK4( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ALK4' ) + ALK4 = 0d0 + + + ALLOCATE( CH2O( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'CH2O' ) + CH2O = 0d0 + + + ALLOCATE( MEK( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MEK' ) + MEK = 0d0 + ! -- end VOCs + + !--------------------------------------------------- + ! 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 + + !--------------------------------------------------- + ! Read & Regrid masks for Streets' emissions + !--------------------------------------------------- + + ALLOCATE( MASK_CHINA_1x1( I1x1, J1x1-1 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASK_CHINA_1x1' ) + MASK_CHINA_1x1 = 0 + + ALLOCATE( MASK_CHINA_05x0666( I05x0666, J05x0666 ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASK_CHINA_05x0666' ) + MASK_CHINA_05x0666 = 0 + + ALLOCATE( MASK_CHINA( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASK_CHINA' ) + MASK_CHINA = 0d0 + + ALLOCATE( MASK_SE_ASIA( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MASK_SE_ASIA' ) + MASK_SE_ASIA = 0d0 + + ! Read China & SE Asia masks from disk +#if defined( GRID05x0666 ) + CALL READ_STREETS_MASKS_05x0666 ! GEOS-5 nested grids +#else + CALL READ_STREETS_MASKS ! Global simulations +#endif + + ! Return to calling program + END SUBROUTINE INIT_STREETS_ANTHRO + +!------------------------------------------------------------------------------ + + SUBROUTINE CLEANUP_STREETS_ANTHRO +! +!****************************************************************************** +! Subroutine CLEANUP_STREETS deallocates all module arrays +! (bmy, 8/16/06, 9/5/06) +! +! NOTES: +! (1 ) Now deallocate MASK_CHINA_1x1 (bmy, 9/5/06) +!****************************************************************************** +! + !================================================================= + ! CLEANUP_STREETS begins here! + !================================================================= + IF ( ALLOCATED( A_CM2 ) ) DEALLOCATE( A_CM2 ) + IF ( ALLOCATED( MASK_CHINA_1x1 ) ) DEALLOCATE( MASK_CHINA_1x1 ) + IF ( ALLOCATED( MASK_CHINA_05x0666 ) ) + & DEALLOCATE( MASK_CHINA_05x0666 ) !(dan) + IF ( ALLOCATED( MASK_CHINA ) ) DEALLOCATE( MASK_CHINA ) + IF ( ALLOCATED( MASK_SE_ASIA ) ) DEALLOCATE( MASK_SE_ASIA ) + IF ( ALLOCATED( NOx ) ) DEALLOCATE( NOx ) + IF ( ALLOCATED( CO ) ) DEALLOCATE( CO ) + IF ( ALLOCATED( SO2 ) ) DEALLOCATE( SO2 ) + IF ( ALLOCATED( NH3 ) ) DEALLOCATE( NH3 ) + IF ( ALLOCATED( CH4 ) ) DEALLOCATE( CH4 ) + IF ( ALLOCATED( CO2 ) ) DEALLOCATE( CO2 ) + + ! Now deallocate VOCs (phs, 3/7/08) + IF ( ALLOCATED( C3H8 ) ) DEALLOCATE( C3H8 ) + IF ( ALLOCATED( C2H6 ) ) DEALLOCATE( C2H6 ) + IF ( ALLOCATED( ALK4 ) ) DEALLOCATE( ALK4 ) + IF ( ALLOCATED( ALD2 ) ) DEALLOCATE( ALD2 ) + IF ( ALLOCATED( PRPE ) ) DEALLOCATE( PRPE ) + IF ( ALLOCATED( MEK ) ) DEALLOCATE( MEK ) + IF ( ALLOCATED( CH2O ) ) DEALLOCATE( CH2O ) + IF ( ALLOCATED( ACET ) ) DEALLOCATE( ACET ) + + ! Return to calling program + END SUBROUTINE CLEANUP_STREETS_ANTHRO + +!------------------------------------------------------------------------------ + + ! End of module + END MODULE STREETS_ANTHRO_MOD diff --git a/code/subfun.f b/code/subfun.f new file mode 100644 index 0000000..69d6861 --- /dev/null +++ b/code/subfun.f @@ -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 diff --git a/code/sunparam.f b/code/sunparam.f new file mode 100644 index 0000000..3aaf43c --- /dev/null +++ b/code/sunparam.f @@ -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