!------------------------------------------------------------------------------ ! Caltech Department of Chemical Engineering / Seinfeld Group ! !------------------------------------------------------------------------------ !BOP ! ! !MODULE: isoropiaii_adj_mod ! ! !DESCRIPTION: Module ISOROPIAII_ADJ\_MOD contains the routines that provide ! the interface between ISORROPIA II and GEOS-Chem. !\\ !\\ ! The actual ANISORROPIA code which performs Na-SO4-NH3-NO3-Cl ! aerosol thermodynamic equilibrium is in \texttt{isoropiaIIcode_adj.f}. !\\ !\\ ! !INTERFACE: ! MODULE ISOROPIAII_ADJ_MOD ! ! !USES: ! IMPLICIT NONE PRIVATE ! ! !PUBLIC MEMBER FUNCTIONS: ! PUBLIC :: CLEANUP_ISOROPIAII PUBLIC :: DO_ISOROPIAII PUBLIC :: DO_ISOROPIAII_ADJ PUBLIC :: GET_GNO3 PUBLIC :: GET_ISRINFO ! ! !PRIVATE MEMBER FUNCTIONS: ! PRIVATE :: GET_HNO3 PRIVATE :: INIT_ISOROPIAII PRIVATE :: SAFELOG10 PRIVATE :: SET_HNO3 ! ! !REMARKS: ! Original Author: ! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, ! *** GEORGIA INSTITUTE OF TECHNOLOGY ! *** WRITTEN BY ATHANASIOS NENES ! *** UPDATED BY CHRISTOS FOUNTOUKIS ! . ! Original v1.3 isoropia implementation into GEOS-Chem by ! Becky Alexander and Bob Yantosca (bec, bmy, 4/12/05, 11/2/05) ! . ! For Ca,K,Mg = 0, ISOROPIA II performs exactly like ISOROPIAv1.7 ! Ca, K, Mg, Na from dust is not currently considered ! . ! To implement ISOROPIA II into GEOS-Chem: ! * cleanup_isoropiaII needs to be called from cleanup.f ! * DO_ISOROPIA needs to be replaced with DO_ISOROPIAII in chemistry_mod.f ! * Change ISOROPIA to ISOROPIAII in sulfate_mod.f ! * add isoropiaII_mod.f, isoropiaIIcode.f, and irspia.inc to Makefile ! . ! ISOROPIA II implementation notes by Havala O.T. Pye: ! (1) The original isoropia code from T.Nenes is left as unmodified as ! possible. Original isoropia code can be found in isoropiaIIcode.f ! and common blocks can be found in isrpia.inc. For future upgrades ! to isoropia, replace isrpia.inc and isoropiaIIcode.f with the new ! version of isoropia and modify the call to ISOROPIA in this module. ! Please let the original author know of any changes made to ISOROPIA. ! (2) As of Nov 2007, routines using non-zero Ca, K, and Mg do not always ! conserve mass. Ca, K, and Mg are set to zero. ! . ! NOTE: ISORROPIA is Greek for "equilibrium", in case you were wondering. ! ! ANISORROPIA implementation in GEOS-Chem adjoint by ! Shannon Capps (slc, 8/22/2011) ! (1) As of Aug 2011, only Na-SO4-NH3-NO3-Cl routines have an adjoint. ! (2) Adjoint calculations require online activity coefficient calculation ! unlike the default configuration in GEOS-Chem that uses look up tables. ! Reference: doi:10.5194/acp-12-527-2012 ! ! !REVISION HISTORY: ! 06 Jul 2007 - H. O. T. Pye - Initial version ! 29 Jan 2010 - R. Yantosca - Added ProTeX headers ! 21 Apr 2010 - R. Yantosca - Bug fix in DO_ISOROPIAII for offline aerosol ! 22 Aug 2011 - S. Capps - ANISORROPIA implementation ! ! *** VERY IMPORTANT PORTING WARNING (slc.1.2012) *** ! ANISORROPIA code is optimized for adjoint frameworks and will not ! perform commensurately with publicly released ISORROPIAII code. ! ! Please visit http://nenes.eas.gatech.edu/ISORROPIA for current ! releases of ISORROPIAII for forward modeling. ! !EOP !------------------------------------------------------------------------------ !BOC ! Array for offline HNO3 (for relaxation of M.M.) REAL*8, ALLOCATABLE :: HNO3_sav(:,:,:) ! Array for offline use in sulfate_mod (SEASALT_CHEM) REAL*8, ALLOCATABLE :: GAS_HNO3(:,:,:) ! AEROPH: Save information related to aerosol pH (hotp 8/11/09) REAL*8, ALLOCATABLE :: PH_SAV(:,:,:) REAL*8, ALLOCATABLE :: HPLUS_SAV(:,:,:) REAL*8, ALLOCATABLE :: WATER_SAV(:,:,:) REAL*8, ALLOCATABLE :: SULRAT_SAV(:,:,:) REAL*8, ALLOCATABLE :: NARAT_SAV(:,:,:) REAL*8, ALLOCATABLE :: ACIDPUR_SAV(:,:,:) CONTAINS !EOC !------------------------------------------------------------------------------ ! Caltech Department of Chemical Engineering / Seinfeld Group ! !------------------------------------------------------------------------------ !BOP ! ! !IROUTINE: do_isoropiaii ! ! !DESCRIPTION: Subroutine DO\_ISOROPIAII is the interface between the ! GEOS-Chem model and the aerosol thermodynamical equilibrium routine ! ISORROPIA II. !\\ !\\ ! !INTERFACE: ! SUBROUTINE DO_ISOROPIAII ! ! !USES: ! USE CHECKPT_MOD, ONLY : ANISO_IN USE DAO_MOD, ONLY : AIRVOL, RH, T USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP USE ERROR_MOD, ONLY : SAFE_DIV USE GLOBAL_HNO3_MOD, ONLY : GET_GLOBAL_HNO3 USE LOGICAL_MOD, ONLY : LPRT USE TIME_MOD, ONLY : GET_MONTH, ITS_A_NEW_MONTH USE TRACER_MOD USE TRACERID_MOD, ONLY : IDTHNO3, IDTNIT, IDTNH4, IDTNH3 USE TRACERID_MOD, ONLY : IDTSALA, IDTSO4 USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT ! USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD USE LOGICAL_ADJ_MOD, ONLY : LADJ # include "CMN_SIZE" ! Size parameters ! ! !REMARKS: ! Original isoropia v1.3 implmentation: (rjp, bec, bmy, 12/17/01, 8/22/05) ! ! !REVISION HISTORY: ! 24 Aug 2007 - H. O. T. Pye - Initial version, in ISORROPIA II ! 18 Dec 2009 - H. O. T. Pye - Added division checks ! 29 Jan 2010 - R. Yantosca - Added ProTeX headers ! 21 Apr 2010 - E. Sofen - Prevent out-of-bounds errors for offline ! aerosol simulations where HNO3 is undefined ! 23 Jul 2010 - R. Yantosca - Bug fix: corrected typo in ND42 diag section ! 22 Aug 2011 - S. Capps - ANISORROPIA implementation !EOP !------------------------------------------------------------------------------ !BOC ! ! !DEFINED PARAMETERS: ! ! Array dimensions INTEGER, PARAMETER :: NOTHERA = 9 INTEGER, PARAMETER :: NCTRLA = 2 INTEGER, PARAMETER :: NCOMPA = 8 INTEGER, PARAMETER :: NIONSA = 10 INTEGER, PARAMETER :: NGASAQA = 3 INTEGER, PARAMETER :: NSLDSA = 19 ! Concentration lower limit [mole/m3] REAL*8, PARAMETER :: CONMIN = 1.0d-30 ! ! !LOCAL VARIABLES: ! LOGICAL, SAVE :: FIRST = .TRUE. INTEGER :: I, J, L, N REAL*8 :: ANO3, GNO3, RHI, TEMPI REAL*8 :: TCA, TMG, TK, HNO3_DEN REAL*8 :: TNA, TCL, TNH3, TNH4 REAL*8 :: TNIT, TNO3, TSO4, VOL REAL*8 :: AERLIQ(NIONSA+NGASAQA+2) REAL*8 :: AERSLD(NSLDSA) REAL*8 :: GAS(NGASAQA) REAL*8 :: OTHER(NOTHERA) REAL*8 :: WI(NCOMPA) REAL*8 :: WT(NCOMPA) REAL*8 :: CNTRL(NCTRLA) CHARACTER(LEN=255) :: X CHARACTER(LEN=15) :: SCASI ! Flag and integer indicative of ANISORROPIA internal error system LOGICAL :: TRUSTISO !Temporary variables to check if division is safe REAL*8 :: NUM_SAV, DEN_SAV ! AEROPH: Temporary variable for pH (hotp 8/11/09) REAL*8 :: HPLUSTEMP ! debug variables INTEGER :: Itemp, Jtemp, Ltemp INTEGER :: ISOERRCOUNT,ISOCALLCOUNT INTEGER :: NERR, NERR22, NERR33, NERR44, NERR100 INTEGER :: NERR101, NERR102, NERR103, NERR104 INTEGER :: NERR50, NERROTHER, COTHER INTEGER :: CA, CB, CC, CD, CE, CF, CG, CH, CI, CJ LOGICAL, SAVE :: FIRSTCHECK = .TRUE. !================================================================= ! DO_ISOROPIAII begins here! !================================================================= ! Location string X = 'DO_ISOROPIAII (isoropiaII_mod.f)' WRITE(6,*) X ! First-time initialization IF ( FIRST ) THEN ! Make sure certain tracers are defined IF ( IDTSO4 == 0 ) CALL ERROR_STOP( 'IDTSO4 is undefined!', X) IF ( IDTNH3 == 0 ) CALL ERROR_STOP( 'IDTNH3 is undefined!', X) IF ( IDTNH4 == 0 ) CALL ERROR_STOP( 'IDTNH4 is undefined!', X) IF ( IDTNIT == 0 ) CALL ERROR_STOP( 'IDTNIT is undefined!', X) IF ( IDTSALA == 0 ) CALL ERROR_STOP( 'IDTSALA is undefined!',X) ! Initialize arrays CALL INIT_ISOROPIAII !WRITE(*,*) 'Successfully finished INIT_ISOROPIAII' ! Reset first-time flag FIRST = .FALSE. ! Reset error counting flag ISOERRCOUNT = 0 ENDIF !================================================================= ! Check to see if we have to read in monthly mean HNO3 !================================================================= IF ( IDTHNO3 == 0 ) THEN IF ( ITS_A_FULLCHEM_SIM() ) THEN ! Coupled simulation: stop w/ error since we need HNO3 CALL ERROR_STOP( 'IDTHNO3 is not defined!', X ) ELSE IF ( ITS_AN_AEROSOL_SIM() ) THEN ! Offline simulation: read monthly mean HNO3 IF ( ITS_A_NEW_MONTH() ) THEN CALL GET_GLOBAL_HNO3( GET_MONTH() ) ENDIF ! Initialize for each timestep (bec, bmy, 4/15/05) GAS_HNO3 = 0d0 ELSE ! Otherwise stop w/ error CALL ERROR_STOP( 'Invalid simulation type!', X ) ENDIF ENDIF ! AEROPH: Initialize arrays all the way up to LLPAR for ! aeroph. Arrays go up to LLPAR due to ND42 use (hotp 8/11/09) PH_SAV = 0d0 HPLUS_SAV = 0d0 WATER_SAV = 0d0 SULRAT_SAV = 0d0 NARAT_SAV = 0d0 ACIDPUR_SAV = 0d0 ! Initialize the error distribution flags NERR22 = 0 NERR33 = 0 NERR44 = 0 NERR100 = 0 NERR101 = 0 NERR102 = 0 NERR103 = 0 NERR104 = 0 NERROTHER = 0 ISOCALLCOUNT = 0 ISOERRCOUNT = 0 CA = 0 CB = 0 CC = 0 CD = 0 CE = 0 CF = 0 CG = 0 CH = 0 CI = 0 CJ = 0 COTHER = 0 IF ( LADJ ) THEN ! adj_group ANISO_IN(:,:,:,1:14) = 0.d0 ENDIF !WRITE(*,*) 'ANISO_IN: ',ANISO_IN(1,1,1,:) !================================================================= ! Loop over grid boxes and call ISOROPIA (see comments in the ! ISOROPIA routine ISOROPIAIICODE.f which describes ! the input/output args) !================================================================= ! AEROPH: add HPLUSTEMP as private (hotp 8/11/09) !$OMP PARALLEL DO !$OMP+DEFAULT( SHARED ) !$OMP+PRIVATE( I, J, L, N, WI, WT, GAS, TEMPI ) !$OMP+PRIVATE( RHI, VOL, TSO4, TNH3, TNA, TCL, ANO3, GNO3 ) !$OMP+PRIVATE( TCA, TMG, TK, CNTRL, SCASI, TRUSTISO ) !$OMP+PRIVATE( TNO3, AERLIQ, AERSLD, OTHER, TNH4, TNIT, NERR ) !$OMP+PRIVATE( HPLUSTEMP, NUM_SAV, DEN_SAV, HNO3_DEN ) !$OMP+SCHEDULE( DYNAMIC ) DO L = 1, LLTROP DO J = 1, JJPAR DO I = 1, IIPAR ! Skip strat boxes IF ( ITS_IN_THE_STRAT( I, J, L ) ) CYCLE ! Initialize WI, WT DO N = 1, NCOMPA WI(N) = 0d0 WT(N) = 0d0 ENDDO ! Initialize GAS DO N = 1, NGASAQA GAS(N) = 0d0 ENDDO ! Temperature [K] TEMPI = T(I,J,L) ! Relative humidity [unitless] RHI = RH(I,J,L) * 1.d-2 ! Force RH in the range 0.01 - 0.98 RHI = MAX( 0.01d0, RHI ) RHI = MIN( 0.98d0, RHI ) ! Volume of grid box [m3] VOL = AIRVOL(I,J,L) !--------------------------------- ! Compute quantities for ISOROPIA !--------------------------------- ! Total SO4 [mole/m3] ! Convert from kg to mole/m3 air TSO4 = STT(I,J,L,IDTSO4) * 1.d3 / ( 96.d0 * VOL ) ! Total NH3 [mole/m3] ! Convert from kg to mole/m3 air TNH3 = STT(I,J,L,IDTNH4) * 1.d3 / ( 18.d0 * VOL ) + & STT(I,J,L,IDTNH3) * 1.d3 / ( 17.d0 * VOL ) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%% NOTE: The error-trap statement above will halt execution if IDTSALA is !%%% undefined. Therefore this IF statement is superfluous. Comment out !%%% for clarity. (hotp, bmy, 2/1/10) !%%% !%%% IF ( IDTSALA > 0 ) THEN ! Total Na+ (30.61% by weight of seasalt) [mole/m3] TNA = STT(I,J,L,IDTSALA) * 0.3061d0 * 1.d3 / & ( 22.99d0 * VOL ) ! Total Cl- (55.04% by weight of seasalt) [mole/m3] TCL = STT(I,J,L,IDTSALA) * 0.5504d0 * 1.d3 / & ( 35.45d0 * VOL ) !============================================================================== !=== NOTE: As of 11/2007, ISORROPIAII does not conserve mass when Ca,K,Mg are !=== non-zero. If you would like to consider Ca, K, Mg from seasalt and dust, !=== isoropiaIIcode.f ISRP4F routines must be debugged. (hotp, bmy, 2/1/10) !=== !=== ! Total Ca2+ (1.16% by weight of seasalt) [mole/m3] !=== TCA = STT(I,J,L,IDTSALA) * 0.0116d0 * 1.d3 / !=== & ( 40.08d0 * VOL ) !=== !=== ! Total K+ (1.1% by weight of seasalt) [mole/m3] !=== TK = STT(I,J,L,IDTSALA) * 0.0110d0 * 1.d3 / !=== & ( 39.102d0 * VOL ) !=== !=== ! Total Mg+ (3.69% by weight of seasalt) [mole/m3] !=== TMG = STT(I,J,L,IDTSALA) * 0.0369d0 * 1.d3 / !=== & ( 24.312d0 * VOL ) ! Set Ca, K, Mg to zero for time being (hotp, bmy, 2/1/10) TCA = 0d0 TK = 0d0 TMG = 0d0 !============================================================================== !%%% ELSE !%%% !%%% ! no seasalt, set to zero !%%% TNA = 0.d0 !%%% TCL = 0.d0 !%%% TCA = 0.d0 !%%% TK = 0.d0 !%%% TMG = 0.d0 !%%% !%%% ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! Compute gas-phase NO3 IF ( IDTHNO3 > 0 ) THEN !--------------------- ! COUPLED SIMULATION !--------------------- ! Compute gas-phase HNO3 [mole/m3] from HNO3 tracer GNO3 = STT(I,J,L,IDTHNO3) GNO3 = MAX( GNO3 * 1.d3 / ( 63.d0 * VOL ), CONMIN ) ! Aerosol-phase NO3 [mole/m3] ANO3 = STT(I,J,L,IDTNIT) * 1.d3 / ( 62.d0 * VOL ) ! Total NO3 [mole/m3] TNO3 = GNO3 + ANO3 ELSE !--------------------- ! OFFLINE SIMULATION !--------------------- ! Convert total inorganic NO3 from [ug/m3] to [mole/m3]. ! GET_HNO3, lets HNO3 conc's evolve, but relaxes to ! monthly mean values every 3h. TNO3 = GET_HNO3( I,J,L ) * 1.d-6 / 63.d0 ENDIF !--------------------------------- ! Call ISOROPIAII !--------------------------------- ! set type of ISOROPIA call ! Forward problem, do not change this value ! 0d0 represents forward problem CNTRL(1) = 0.0d0 ! Metastable for now ! 1d0 represents metastable problem CNTRL(2) = 1.0d0 ! Insert concentrations [mole/m3] into WI & prevent underflow WI(1) = MAX( TNA, CONMIN ) WI(2) = MAX( TSO4, CONMIN ) WI(3) = MAX( TNH3, CONMIN ) WI(4) = MAX( TNO3, CONMIN ) WI(5) = MAX( TCL, CONMIN ) WI(6) = MAX( TCA, CONMIN ) WI(7) = MAX( TK, CONMIN ) WI(8) = MAX( TMG, CONMIN ) IF ( LPRINTFD & .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN WRITE(6,*) 'Forward, CELL(',I,',',J,',',L,')',WI(1:5) WRITE(6,*) 'Temp',TEMPI, ' RHI',RHI ENDIF ! Perform aerosol thermodynamic equilibrium ! ISOROPIAII can be found in isoropiaIIcode_adj.f ! inputs are WI, RHI, TEMPI, CNTRL ! adj_group: call special version for adjoint (slc.09.2011) IF ( .not. LADJ ) THEN CALL ISOROPIAII (WI, RHI, TEMPI, CNTRL, & WT, GAS, AERLIQ, AERSLD, & SCASI, OTHER, TRUSTISO,NERR) ELSE ! Checkpoint ANISORROPIA input ANISO_IN(I,J,L,1:8) = WI(:) ANISO_IN(I,J,L,9) = RHI ANISO_IN(I,J,L,10) = TEMPI CALL ISOROPIAII (WI, RHI, TEMPI, CNTRL, & WT, GAS, AERLIQ, AERSLD, & SCASI, OTHER, TRUSTISO,NERR) ! Debug ANISO checkpoint IF ( LPRINTFD & .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN WRITE(6,*) ' After ISOROPIAII ', I, J, L ! (slc.10.2011) debug - output of ISORROPIA WRITE(6,*) 'GAS ',GAS(:) WRITE(6,*) 'AERLIQ: 3,5,6,7 ',AERLIQ(3), & AERLIQ(5),AERLIQ(6),AERLIQ(7) WRITE(6,*) 'TRUSTISO ',TRUSTISO ENDIF ENDIF ! Checkpointing for adjoint !--------------------------------- ! Save back into tracer array !--------------------------------- ! Convert ISOROPIA output from [mole/m3] to [kg] TSO4 = MAX( 96.d-3 * VOL * WT(2), CONMIN ) TNH3 = MAX( 17.d-3 * VOL * GAS(1), CONMIN ) ! (slc.9.2011) - for adjoint to work without WT_ADJ ! TNH4 = MAX( 18.d-3 * VOL * ( WT(3) - GAS(1) ), CONMIN ) ! TNIT = MAX( 62.d-3 * VOL * ( WT(4) - GAS(2) ), CONMIN ) TNH4 = MAX( 18.d-3 * VOL * AERLIQ(3), CONMIN ) TNIT = MAX( 62.d-3 * VOL * AERLIQ(7), CONMIN ) !------------------------------------ ! Check as to whether error occurred. !------------------------------------ IF ( TRUSTISO ) THEN ! Save tracers back into STT array [kg] ! no longer save TSO4 back into STT. SO4 is all aerosol phase ! (hotp 11/7/07) ! STT(I,J,L,IDTSO4) = TSO4 STT(I,J,L,IDTNH3) = TNH3 STT(I,J,L,IDTNH4) = TNH4 STT(I,J,L,IDTNIT) = TNIT ! slc.debug IF ( LADJ ) THEN ! adj_group IF ( 17.d-3 * VOL * GAS(1) < CONMIN ) THEN !WRITE(*,*) 'CONMIN > NH3', GAS(1) !WRITE(*,*) 'CELL:(',I,',',J,',',L,')' ANISO_IN(I,J,L,11) = 0.d0 ELSE ANISO_IN(I,J,L,11) = 1.d0 ENDIF IF ( 18.d-3 * VOL * AERLIQ(3) < CONMIN ) THEN !WRITE(*,*) 'CONMIN > NH4', AERLIQ(3) !WRITE(*,*) 'CELL:(',I,',',J,',',L,')' ANISO_IN(I,J,L,12) = 0.d0 ELSE ANISO_IN(I,J,L,12) = 1.d0 ENDIF IF ( 62.d-3 * VOL * AERLIQ(7) < CONMIN ) THEN !WRITE(*,*) 'CONMIN > NIT', AERLIQ(7) !WRITE(*,*) 'CELL:(',I,',',J,',',L,')' ANISO_IN(I,J,L,13) = 0.d0 ELSE ANISO_IN(I,J,L,13) = 1.d0 ENDIF IF ( 96.d-3 * VOL * WT(2) < CONMIN ) THEN !WRITE(*,*) 'CONMIN > SUL', WT(2) !WRITE(*,*) 'CELL:(',I,',',J,',',L,')' ANISO_IN(I,J,L,15) = 0.d0 ELSE ANISO_IN(I,J,L,15) = 1.d0 ENDIF ENDIF ELSE ! Echo location of NAN (probably leave this commented out ! unless you are getting lots of ADJ_NAN warnings !WRITE(6,*) 'Can't trust ANISO at I,J,L,N = ',I,J,L,N IF ( LADJ ) THEN ! adj_group ANISO_IN(I,J,L,11:15) = 0.d0 ENDIF !WRITE(*,*) 'ANISO_IN when TRUSTISO = .F.', !& ANISO_IN(I,J,L,11:14) !!$OMP CRITICAL ! Show TRUSTISO flag so that a warning is echoed to screen TRUSTISO = .FALSE. !!$OMP END CRITICAL ! Count number of errors and total calls ISOERRCOUNT = ISOERRCOUNT + 1 SELECT CASE (NERR) CASE (22) NERR22 = NERR22 + 1 CASE (33) NERR33 = NERR33 + 1 CASE (50) NERR50 = NERR50 + 1 CASE (100) NERR100 = NERR100 + 1 CASE (101) NERR101 = NERR101 + 1 CASE (102) NERR102 = NERR102 + 1 CASE (103) NERR103 = NERR103 + 1 CASE (104) NERR104 = NERR104 + 1 CASE DEFAULT NERROTHER = NERROTHER + 1 END SELECT ! Do not replace original value !STT(I,J,L,IDTNH3) = STT(I,J,L,IDTNH3) !STT(I,J,L,IDTNH4) = STT(I,J,L,IDTNH4) ENDIF ! slc.debug ISOCALLCOUNT = ISOCALLCOUNT + 1 SELECT CASE (SCASI) CASE("A2") CA = CA + 1 CASE("B4") CB = CB + 1 CASE("C2") CC = CC + 1 CASE("D3") CD = CD + 1 CASE("E4") CE = CE + 1 CASE("F2") CF = CF + 1 CASE("G5") CG = CG + 1 CASE("H6") CH = CH + 1 CASE("I6") CI = CI + 1 CASE("J3") CJ = CJ + 1 CASE DEFAULT COTHER = COTHER + 1 END SELECT ! Special handling for HNO3 [kg] IF ( IDTHNO3 > 0 ) THEN !--------------------- ! COUPLED SIMULATION !--------------------- !------------------------------------ ! Check as to whether error occurred. !------------------------------------ IF ( TRUSTISO ) THEN ! HNO3 [mole/m3] is in GAS(2); convert & store in STT [kg] STT(I,J,L,IDTHNO3) = MAX( 63.d-3 * VOL * GAS(2), CONMIN ) ! slc.debug IF ( LADJ ) THEN ! adj_group IF ( 63.d-3 * VOL * GAS(2) < CONMIN ) THEN !WRITE(*,*) 'CONMIN > HNO3', STT(I,J,L,IDTHNO3) ANISO_IN(I,J,L,14) = 0.d0 ELSE ANISO_IN(I,J,L,14) = 1.d0 ENDIF ENDIF ! Save for use in DEN_SAV expression below (sofen, 4/21/10) HNO3_DEN = STT(I,J,L,IDTHNO3) ENDIF ELSE !--------------------------------- ! Check for trustworthiness. !--------------------------------- IF ( TRUSTISO ) THEN !--------------------- ! OFFLINE SIMULATION: !--------------------- ! Convert total inorganic nitrate from [mole/m3] to [ug/m3] ! and save for next time ! WT(4) is in [mole/m3] -- unit conv is necessary! CALL SET_HNO3( I, J, L, 63.d6 * WT(4) ) ! Save for use in sulfate_mod (SEASALT_CHEM) for offline ! aerosol simulations (bec, 4/15/05) GAS_HNO3(I,J,L) = GAS(2) ! Save for use in DEN_SAV expression below (sofen, 4/21/10) HNO3_DEN = GAS(2) * VOL * 63d-3 !--------------------------------- ! Check for trustworthiness. !--------------------------------- !IF ( .NOT. TRUSTISO ) THEN ! STT(I,J,L,IDTHNO3) = STT(I,J,L,IDTHNO3) ! STT(I,J,L,IDTNIT) = STT(I,J,L,IDTNIT) ENDIF ENDIF !--------------------------------- ! Check for trustworthiness. !--------------------------------- ! IF ( TRUSTISO ) THEN ! ! !------------------------- ! ! ND42 diagnostic arrays ! !------------------------- ! ! ! AEROPH: get pH related info to SAV arrays (hotp 8/11/09) ! ! HPLUSTEMP is H+ in mol/L water, AERLIQ1 is H, AERLIQ8 is H2O ! ! in mol/m3 air --> convert to mol/L water ! IF ( AERLIQ(8) < 1d-32 ) THEN ! ! Aerosol is dry so HPLUSTEMP and PH_SAV are undefined ! ! We force HPLUSTEMP to 1d20 and PH_SAV to -999d0. ! ! (hotp, ccc, 12/18/09) ! HPLUSTEMP = 1d20 ! !------------------------------------------------------------- ! ! Prior to 7/23/10: ! ! Bug fix: this should be PH_SAV(I,J,L) (sofen, bmy, 7/12/10) ! !PH_SAV = -999d0 ! !------------------------------------------------------------- ! PH_SAV(I,J,L) = -999d0 ! ELSE ! HPLUSTEMP = AERLIQ(1) / AERLIQ(8) * 1d3/18d0 ! ! ! Use SAFELOG10 to prevent NAN ! PH_SAV(I,J,L) = -1d0 * SAFELOG10( HPLUSTEMP ) ! ENDIF ! ! ! Additional Info ! HPLUS_SAV(I,J,L) = AERLIQ(1) ! WATER_SAV(I,J,L) = AERLIQ(8) ! SULRAT_SAV(I,J,L) = OTHER(2) ! NARAT_SAV(I,J,L) = OTHER(4) ! ! NUM_SAV = ( STT(I,J,L,IDTNH3) /17d0 + ! & STT(I,J,L,IDTNH4) /18d0 + ! & STT(I,J,L,IDTSALA)*0.3061d0/23.0d0 ) ! ! DEN_SAV = ( STT(I,J,L,IDTSO4) / 96d0 * 2d0 + ! & STT(I,J,L,IDTNIT) / 62d0 + ! & HNO3_DEN / 63d0 + ! & STT(I,J,L,IDTSALA) * 0.55d0 / 35.45d0 ) ! ! ! Value if DEN_SAV and NUM_SAV too small. ! ACIDPUR_SAV(I,J,L) = SAFE_DIV(NUM_SAV, DEN_SAV, ! & 0d0, ! & 999d0) ! ! ENDIF ENDDO ENDDO ENDDO !$OMP END PARALLEL DO !WRITE(*,*) 'Finished with OMP loop in ISOII' !slc.debug !### Debug IF ( LPRT ) CALL DEBUG_MSG( '### ISOROPIAII: a AERO_THERMO' ) ! WRITE(6,*) 'ISO calls: ',ISOCALLCOUNT ! WRITE(6,*) 'ISO error occurrences: ',ISOERRCOUNT ! WRITE(6,*) 'Specific error codes: ' ! WRITE(6,*) 'Error 22: ',NERR22 ! WRITE(6,*) 'Error 33: ',NERR33 ! WRITE(6,*) 'Error 44: ',NERR44 ! WRITE(6,*) 'Error 100: ',NERR100 ! WRITE(6,*) 'Error 101: ',NERR101 ! WRITE(6,*) 'Error 102: ',NERR102 ! WRITE(6,*) 'Error 103: ',NERR103 ! WRITE(6,*) 'Error 104: ',NERR104 ! WRITE(6,*) 'Error Other: ', NERROTHER ! ! WRITE(6,*) '____________ Case Distribution ____________' ! WRITE(6,*) 'A: ',CA ! WRITE(6,*) 'B: ',CB ! WRITE(6,*) 'C: ',CC ! WRITE(6,*) 'D: ',CD ! WRITE(6,*) 'E: ',CE ! WRITE(6,*) 'F: ',CF ! WRITE(6,*) 'G: ',CG ! WRITE(6,*) 'H: ',CH ! WRITE(6,*) 'I: ',CI ! WRITE(6,*) 'J: ',CJ ! WRITE(6,*) 'Other: ', COTHER ! ! Return to calling program END SUBROUTINE DO_ISOROPIAII !EOC !------------------------------------------------------------------------------ !BOP ! ! !IROUTINE: do_isoropiaii_adj ! ! !DESCRIPTION: Subroutine DO\_ISOROPIAII_ADJ is the interface between the ! GEOS-Chem model and the adjoint of the aerosol thermodynamical ! equilibrium routine ISORROPIA II. !\\ !\\ ! !INTERFACE: ! SUBROUTINE DO_ISOROPIAII_ADJ ! ! !USES: ! USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ USE CHECKPT_MOD, ONLY : ANISO_IN USE DAO_MOD, ONLY : AIRVOL, RH, T USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP USE ERROR_MOD, ONLY : SAFE_DIV, IT_IS_NAN USE GLOBAL_HNO3_MOD, ONLY : GET_GLOBAL_HNO3 USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD USE LOGICAL_MOD, ONLY : LPRT USE TIME_MOD, ONLY : GET_MONTH, ITS_A_NEW_MONTH USE TRACER_MOD USE TRACERID_MOD, ONLY : IDTHNO3, IDTNIT, IDTNH4, IDTNH3 USE TRACERID_MOD, ONLY : IDTSALA, IDTSO4 USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT # include "CMN_SIZE" ! Size parameters ! ! !REMARKS: ! Original isoropia v1.3 implementation: (rjp, bec, bmy, 12/17/01, 8/22/05) ! ! !REVISION HISTORY: ! 30 Aug 2011 - S. Capps - Interface ANISORROPIA with adjoint !EOP !------------------------------------------------------------------------------ !BOC ! ! !DEFINED PARAMETERS: ! ! Array dimensions INTEGER, PARAMETER :: NOTHERA = 9 INTEGER, PARAMETER :: NCTRLA = 2 INTEGER, PARAMETER :: NCOMPA = 8 INTEGER, PARAMETER :: NIONSA = 10 INTEGER, PARAMETER :: NGASAQA = 3 INTEGER, PARAMETER :: NSLDSA = 19 ! Concentration lower limit [mole/m3] REAL*8, PARAMETER :: CONMIN = 1.0d-30 ! Adjoint parameters INTEGER, PARAMETER :: MAX_ALLOWED_NAN = 10 INTEGER, PARAMETER :: MAX_ALLOWED_EXPLD = 10 REAL*8, PARAMETER :: MAX_ALLOWED_INCREASE = 10.0D10 ! ! !LOCAL VARIABLES: ! LOGICAL, SAVE :: FIRSTADJ = .TRUE. INTEGER :: I, J, L, N REAL*8 :: ANO3, GNO3, RHI, TEMPI REAL*8 :: TCA, TMG, TK, HNO3_DEN REAL*8 :: TNA, TCL, TNH3, TNH4 REAL*8 :: TNIT, TNO3, TSO4, VOL REAL*8 :: AERLIQ(NIONSA+NGASAQA+2) REAL*8 :: AERSLD(NSLDSA) REAL*8 :: GAS(NGASAQA) REAL*8 :: OTHER(NOTHERA) REAL*8 :: WI(NCOMPA) REAL*8 :: WT(NCOMPA) REAL*8 :: CNTRL(NCTRLA) CHARACTER(LEN=255) :: X CHARACTER(LEN=15) :: SCASI LOGICAL :: TRUSTISO ! Adjoint variables LOGICAL :: ADJ_NAN = .FALSE. INTEGER :: ADJ_NAN_COUNT, ADJ_EXPLD_COUNT REAL*8 :: WT_ADJ(NCOMPA) REAL*8 :: WI_ADJ(NCOMPA) REAL*8 :: GAS_ADJ(NGASAQA) REAL*8 :: AERLIQ_ADJ(NIONSA+NGASAQA+2) REAL*8 :: TNH3_ADJ, TNH4_ADJ, TNO3_ADJ REAL*8 :: TSO4_ADJ, TNIT_ADJ, HNO3_ADJ REAL*8 :: TCA_ADJ, TMG_ADJ, TK_ADJ REAL*8 :: TNA_ADJ, TCL_ADJ REAL*8 :: ANO3_ADJ, GNO3_ADJ REAL*8 :: MAX_ADJ_TMP ! Temp max value used for error checking !Temporary variables to check if division is safe REAL*8 :: NUM_SAV, DEN_SAV ! AEROPH: Temporary variable for pH (hotp 8/11/09) REAL*8 :: HPLUSTEMP ! debug variables INTEGER :: Itemp, Jtemp, Ltemp INTEGER :: ANISOERRCOUNT, ANISOCALLCOUNT INTEGER :: NERR, NERR22, NERR33, NERR44, NERR100 INTEGER :: NERR101, NERR102, NERR103, NERR104 INTEGER :: NERR50, NERROTHER, COTHER INTEGER :: CA, CB, CC, CD, CE, CF, CG, CH, CI, CJ LOGICAL, SAVE :: FIRSTCHECK = .TRUE. !================================================================= ! DO_ISOROPIAII_ADJ begins here! !================================================================= WRITE(6,*) 'Inside DO_ISOROPIAII_ADJ' ! Location string X = 'DO_ISOROPIAII_ADJ (isoropiaII_adj_mod.f)' ! First-time initialization IF ( FIRSTADJ ) THEN ! Make sure certain tracers are defined IF ( IDTSO4 == 0 ) CALL ERROR_STOP( 'IDTSO4 is undefined!', X) IF ( IDTNH3 == 0 ) CALL ERROR_STOP( 'IDTNH3 is undefined!', X) IF ( IDTNH4 == 0 ) CALL ERROR_STOP( 'IDTNH4 is undefined!', X) IF ( IDTNIT == 0 ) CALL ERROR_STOP( 'IDTNIT is undefined!', X) IF ( IDTSALA == 0 ) CALL ERROR_STOP( 'IDTSALA is undefined!',X) ! debug - slc.1.2012 !! Initialize ADJ_NAN_COUNT !ADJ_NAN_COUNT = 0 !ADJ_EXPLD_COUNT = 0 ! Reset first-time flag FIRSTADJ = .FALSE. ! Initialize error count flag ANISOERRCOUNT = 0 ENDIF ! Save maximum adjoint for error checking later MAX_ADJ_TMP = MAXVAL( ABS(STT_ADJ) ) ! debug - slc.1.2012 !WRITE(*,*) 'Successfully initialized' !================================================================= ! Check to see if we have to read in monthly mean HNO3 !================================================================= IF ( IDTHNO3 == 0 ) THEN IF ( ITS_A_FULLCHEM_SIM() ) THEN ! Coupled simulation: stop w/ error since we need HNO3 CALL ERROR_STOP( 'IDTHNO3 is not defined!', X ) ELSE IF ( ITS_AN_AEROSOL_SIM() ) THEN ! Offline simulation: read monthly mean HNO3 IF ( ITS_A_NEW_MONTH() ) THEN CALL GET_GLOBAL_HNO3( GET_MONTH() ) ENDIF ! Initialize for each timestep (bec, bmy, 4/15/05) GAS_HNO3 = 0d0 ELSE ! Otherwise stop w/ error CALL ERROR_STOP( 'Invalid simulation type!', X ) ENDIF ENDIF ! debug - slc.1.2012 !WRITE(*,*) 'Successfully checked HNO3' ! AEROPH: Initialize arrays all the way up to LLPAR for ! aeroph. Arrays go up to LLPAR due to ND42 use (hotp 8/11/09) PH_SAV = 0d0 HPLUS_SAV = 0d0 WATER_SAV = 0d0 SULRAT_SAV = 0d0 NARAT_SAV = 0d0 ACIDPUR_SAV = 0d0 ! Initialize the error distribution flags NERR22 = 0 NERR33 = 0 NERR44 = 0 NERR100 = 0 NERR101 = 0 NERR102 = 0 NERR103 = 0 NERR104 = 0 NERROTHER = 0 ANISOCALLCOUNT = 0 ANISOERRCOUNT = 0 CA = 0 CB = 0 CC = 0 CD = 0 CE = 0 CF = 0 CG = 0 CH = 0 CI = 0 CJ = 0 COTHER = 0 !================================================================= ! Loop over grid boxes and call ISOROPIA (see comments in the ! ISOROPIA routine ISOROPIAIICODE.f which describes ! the input/output args) !================================================================= ! AEROPH: add HPLUSTEMP as private (hotp 8/11/09) !$OMP PARALLEL DO !$OMP+DEFAULT( SHARED ) !$OMP+PRIVATE( I, J, L, N, WI, WT, GAS, TEMPI ) !$OMP+PRIVATE( RHI, VOL, TSO4, TNH3, TNA, TCL, ANO3, GNO3 ) !$OMP+PRIVATE( TCA, TMG, TK, CNTRL, SCASI, TRUSTISO ) !$OMP+PRIVATE( TNO3, AERLIQ, AERSLD, OTHER, TNH4, TNIT, NERR ) !$OMP+PRIVATE( HPLUSTEMP, NUM_SAV, DEN_SAV, HNO3_DEN ) !$OMP+PRIVATE( WI_ADJ, WT_ADJ, GAS_ADJ, AERLIQ_ADJ, TSO4_ADJ ) !$OMP+PRIVATE( TMG_ADJ, TK_ADJ, TCA_ADJ, TCL_ADJ, TNO3_ADJ, TNH3_ADJ ) !$OMP+PRIVATE( TNA_ADJ, GNO3_ADJ, ANO3_ADJ ) !$OMP+SCHEDULE( DYNAMIC ) DO L = 1, LLTROP DO J = 1, JJPAR DO I = 1, IIPAR ! Skip strat boxes IF ( ITS_IN_THE_STRAT( I, J, L ) ) CYCLE ! BEGIN RECALCULATION OF FORWARD VALUES --> ! Initialize WI, WT WI(:) = 0.d0 WT(:) = 0.d0 ! Initialize adjoint variables WI_ADJ, WT_ADJ, GAS_ADJ, AERLIQ_ADJ WI_ADJ(:) = 0d0 WT_ADJ(:) = 0d0 GAS_ADJ(:) = 0d0 AERLIQ_ADJ(:) = 0d0 ! Initialize GAS GAS(:) = 0.d0 ! Volume of grid box [m3] VOL = AIRVOL(I,J,L) ! ! Compute gas-phase NO3 ! IF ( IDTHNO3 > 0 ) THEN ! ! !--------------------- ! ! COUPLED SIMULATION ! !--------------------- ! ! Compute gas-phase HNO3 [mole/m3] from HNO3 tracer ! GNO3 = STT(I,J,L,IDTHNO3) ! GNO3 = MAX( GNO3 * 1.d3 / ( 63.d0 * VOL ), CONMIN ) ! ! Aerosol-phase NO3 [mole/m3] ! ANO3 = STT(I,J,L,IDTNIT) * 1.d3 / ( 62.d0 * VOL ) ! ! Total NO3 [mole/m3] ! TNO3 = GNO3 + ANO3 ! ELSE ! !--------------------- ! ! OFFLINE SIMULATION - no adjoint for this type of run ! !--------------------- ! ! Convert total inorganic NO3 from [ug/m3] to [mole/m3]. ! ! GET_HNO3, lets HNO3 conc's evolve, but relaxes to ! ! monthly mean values every 3h. ! TNO3 = GET_HNO3( I,J,L ) * 1.d-6 / 63.d0 ! ENDIF !--------------------------------- ! Call ANISORROPIA !--------------------------------- ! set type of ANISORROPIA call ! Forward problem, do not change this value ! 0d0 represents forward problem CNTRL(1) = 0.0d0 ! Metastable for now ! 1d0 represents metastable problem CNTRL(2) = 1.0d0 ! From checkpointed files, gather input values (slc.09.27.2011) ! Load IN from ANISO_IN WI(:) = ANISO_IN(I,J,L,1:8) ! Load parameters from ANISO_IN RHI = ANISO_IN(I,J,L,9) TEMPI = ANISO_IN(I,J,L,10) !WRITE(*,*) 'ISO_ADJ, ANISO_IN: ',ANISO_IN(I,J,L,:) !WRITE(*,*) 'STT_ADJ(IDTNIT): ', STT_ADJ(I,J,L,IDTNIT) !WRITE(*,*) 'STT_ADJ(IDTHNO3): ', STT_ADJ(I,J,L,IDTHNO3) !WRITE(*,*) 'STT_ADJ(IDTSO4): ', STT_ADJ(I,J,L,IDTSO4) !WRITE(*,*) 'STT_ADJ(IDTNH4): ', STT_ADJ(I,J,L,IDTNH4) !WRITE(*,*) 'STT_ADJ(IDTNH3): ', STT_ADJ(I,J,L,IDTNH3) !<--- END LOADING OF FORWARD VALUES !---> BEGIN ADJOINT CALCULATION ! adj code IF ( IDTHNO3 > 0 ) THEN ! IF ( TRUSTISO ) THEN ! not defined ! ! fwd code: ! STT(I,J,L,IDTHNO3) = MAX( 63.d-3 * VOL * GAS(2), CONMIN ) ! adj code: IF ( ANISO_IN(I,J,L,14) .GT. 0.d0 ) THEN GAS_ADJ(2) = STT_ADJ(I,J,L,IDTHNO3) * 63.d-3 * VOL ELSE GAS_ADJ(2) = 0.d0 ENDIF ! ENDIF ELSE CALL ERROR_STOP('adj not supported for offline', X ) ENDIF !IF ( TRUSTISO ) THEN ! not defined ! ! fwd code: !STT(I,J,L,IDTSO4) = TSO4 - not in forward, but adding for ! adjoint forcing only - slc.4.2013 !STT(I,J,L,IDTNH3) = TNH3 !STT(I,J,L,IDTNH4) = TNH4 !STT(I,J,L,IDTNIT) = TNIT ! adj code: IF ( ANISO_IN(I,J,L,15) .GT. 0.d0 ) THEN TSO4_ADJ = STT_ADJ(I,J,L,IDTSO4) ELSE TSO4_ADJ = 0.d0 ENDIF IF ( ANISO_IN(I,J,L,13) .GT. 0.d0 ) THEN TNIT_ADJ = STT_ADJ(I,J,L,IDTNIT) ELSE TNIT_ADJ = 0.d0 ENDIF IF ( ANISO_IN(I,J,L,11) .GT. 0.d0 ) THEN TNH3_ADJ = STT_ADJ(I,J,L,IDTNH3) ELSE TNH3_ADJ = 0.d0 ENDIF IF ( ANISO_IN(I,J,L,12) .GT. 0.d0 ) THEN TNH4_ADJ = STT_ADJ(I,J,L,IDTNH4) ELSE TNH4_ADJ = 0.d0 ENDIF ! Debug ANISO checkpoint !IF ( LPRINTFD !& .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN ! IF ( ( ABS(STT_ADJ(I,J,L,IDTNH4)) .GT. 1d10) .OR. !& ( ABS(STT_ADJ(I,J,L,IDTNH3)) .GT. 1d10) .OR. !& ( ABS(STT_ADJ(I,J,L,IDTHNO3)) .GT. 1d10) .OR. !& ( ABS(STT_ADJ(I,J,L,IDTNIT)) .GT. 1d10) .OR. !& ( ABS(STT_ADJ(I,J,L,IDTSO4)) .GT. 1d10) ) THEN ! print*, ' Before ISOROPIAII_ADJ ', I, J, L ! print*, ' STT_ADJ(NIT) ', STT_ADJ(I,J,L,IDTNIT) ! print*, ' STT_ADJ(HNO3) ', STT_ADJ(I,J,L,IDTHNO3) ! print*, ' STT_ADJ(NH4) ', STT_ADJ(I,J,L,IDTNH4) ! print*, ' STT_ADJ(NH3) ', STT_ADJ(I,J,L,IDTNH3) ! print*, ' STT_ADJ(SO4) ', STT_ADJ(I,J,L,IDTSO4) ! ENDIF !ENDIF ! fwd code: !TSO4 = MAX( 96.d-3 * VOL * WT(2), CONMIN ) !TNH3 = MAX( 17.d-3 * VOL * GAS(1), CONMIN ) ! Changing for use of the adjoint without WT_ADJ ! !TNH4 = MAX( 18.d-3 * VOL * ( WT(3) - GAS(1) ), CONMIN ) ! !TNIT = MAX( 62.d-3 * VOL * ( WT(4) - GAS(2) ), CONMIN ) !TNH4 = MAX( 18.d-3 * VOL * AERLIQ(3), CONMIN ) !TNIT = MAX( 62.d-3 * VOL * AERLIQ(7), CONMIN ) ! adj code (note that we don't overwrite GAS_ADJ(2), ! which has already been assigned a value: AERLIQ_ADJ(5) = 96.d-3 * VOL * TSO4_ADJ ! SO4 AERLIQ_ADJ(6) = 97.d-3 * VOL * TSO4_ADJ ! HSO4 AERLIQ_ADJ(7) = 62.d-3 * VOL * TNIT_ADJ AERLIQ_ADJ(3) = 18.d-3 * VOL * TNH4_ADJ GAS_ADJ(1) = 17.d-3 * VOL * TNH3_ADJ ! Changes implemented above (slc.4.2013) !!! Always zero because the TSO4_ADJ = nothing !!! WT_ADJ(2) = 96.d-3 * VOL * TSO4_ADJ !IF ( LPRINTFD !& .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN !WRITE(*,*) 'Adjoint, CELL(',I,',',J,',',L,')',WI(1:5) !WRITE(*,*) 'Temp ',TEMPI ,' RH ', RHI !WRITE(*,*) '------------------------' !WRITE(*,*) 'adjoint forcing vectors ' !WRITE(*,*) 'NH4 force', AERLIQ_ADJ(3) !WRITE(*,*) 'NIT force', AERLIQ_ADJ(7) !WRITE(*,*) 'NH3 force', GAS_ADJ(1) !WRITE(*,*) 'HNO3 force', GAS_ADJ(2) !ENDIF ! Perform aerosol thermodynamic equilibrium ! ISOROPIAII_ADJ can be found in ISOROPIAIICODE_ADJ.f ! inputs are WI, RHI, TEMPI, CNTRL, ADJ_GAS, ADJ_AERLIQ CALL ISOROPIAII_ADJ(WI, WI_ADJ, RHI, TEMPI, CNTRL, & WT, GAS, GAS_ADJ, AERLIQ, AERLIQ_ADJ, & AERSLD, SCASI, OTHER, TRUSTISO,NERR) IF ( TRUSTISO ) THEN ! no ISOROPIAII_ADJ errors ! fwd code: !WI(1) = MAX( TNA, CONMIN ) !WI(2) = MAX( TSO4, CONMIN ) !WI(3) = MAX( TNH3, CONMIN ) !WI(4) = MAX( TNO3, CONMIN ) !WI(5) = MAX( TCL, CONMIN ) !WI(6) = MAX( TCA, CONMIN ) !WI(7) = MAX( TK, CONMIN ) !WI(8) = MAX( TMG, CONMIN ) ! adj code (not sure if need all these, but include anyways to be complete): ! Modification for testing ANISO with no seasalt or dust ! adjoint - slc.4.2012 TMG_ADJ = 0.d0 ! WI_ADJ(8) TK_ADJ = 0.d0 ! WI_ADJ(7) TCA_ADJ = 0.d0 ! WI_ADJ(6) TCL_ADJ = 0.d0 ! WI_ADJ(5) TNO3_ADJ = WI_ADJ(4) TNH3_ADJ = WI_ADJ(3) TSO4_ADJ = WI_ADJ(2) TNA_ADJ = 0.d0 ! WI_ADJ(1) - end of changes - slc.4.2012 IF ( LPRINTFD & .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN WRITE(*,*) 'Adjoint execution, WI_ADJ' WRITE(*,*) 'SO4: ',WI_ADJ(2) WRITE(*,*) 'NH4: ',WI_ADJ(3) WRITE(*,*) 'NIT: ',WI_ADJ(4) ENDIF IF ( IDTHNO3 > 0 ) THEN ! fwd code: !TNO3 = GNO3 + ANO3 ! adj code: GNO3_ADJ = TNO3_ADJ ANO3_ADJ = TNO3_ADJ ! fwd code: !ANO3 = STT(I,J,L,IDTNIT) * 1.d3 / ( 62.d0 * VOL ) ! adj code: STT_ADJ(I,J,L,IDTNIT) = ANO3_ADJ * 1.d3 / ( 62.d0 * VOL ) ! fwd code: !GNO3 = STT(I,J,L,IDTHNO3) !GNO3 = MAX( GNO3 * 1.d3 / ( 63.d0 * VOL ), CONMIN ) GNO3_ADJ = GNO3_ADJ * 1.d3 / ( 63.d0 * VOL) STT_ADJ(I,J,L,IDTHNO3) = GNO3_ADJ ELSE CALL ERROR_STOP('adj not supported for offline', X ) ENDIF ! fwd code: !TCA = 0d0 !TK = 0d0 !TMG = 0d0 ! adj code: TCA_ADJ = 0d0 TK_ADJ = 0d0 TMG_ADJ = 0d0 ! Keep commented until seasalt adjoint is developed. ! (slc.1.2012) ! fwd code: !TCL = STT(I,J,L,IDTSALA) * 0.5504d0 * 1.d3 / ! ( 35.45d0 * VOL ) ! adj code (would add this once we have SALA ADJ: !STT_ADJ(I,J,L,IDTSALA) = TCL_ADJ * 0.5504d0 * 1.d3 / ! ( 35.45d0 * VOL ) ! fwd code: !TNA = STT(I,J,L,IDTSALA) * 0.3061d0 * 1.d3 / ! ( 22.99d0 * VOL ) ! adj code !STT_ADJ(I,J,L,IDTSALA) = TNA_ADJ * 0.3061d0 * 1.d3 / ! ( 22.99d0 * VOL ) TNA_ADJ = 0d0 TCL_ADJ = 0d0 !STT_ADJ(I,J,L,IDTDST1) = 0.d0 + STT_ADJ(I,J,L,IDTDST1) !TCA_ADJ !STT_ADJ(I,J,L,IDTDST2) = 0.d0 + STT_ADJ(I,J,L,IDTDST2) !TK_ADJ !STT_ADJ(I,J,L,IDTDST3) = 0.d0 + STT_ADJ(I,J,L,IDTDST3) !TMG_ADJ !STT_ADJ(I,J,L,IDTDST4) = 0.d0 + STT_ADJ(I,J,L,IDTDST4) !TNA_ADJ !STT_ADJ(I,J,L,IDTSALA) = 0.d0 + STT_ADJ(I,J,L,IDTSALA) !TCL_ADJ !STT_ADJ(I,J,L,IDTSALC) = 0.d0 + STT_ADJ(I,J,L,IDTSALC) !TCL_ADJ ! fwd code: !TNH3 = STT(I,J,L,IDTNH4) * 1.d3 / ( 18.d0 * VOL ) + ! STT(I,J,L,IDTNH3) * 1.d3 / ( 17.d0 * VOL ) STT_ADJ(I,J,L,IDTNH4) = TNH3_ADJ * 1.d3 / ( 18.d0 * VOL ) STT_ADJ(I,J,L,IDTNH3) = TNH3_ADJ * 1.d3 / ( 17.d0 * VOL ) ! fwd code: !TSO4 = STT(I,J,L,IDTSO4) * 1.d3 / ( 96.d0 * VOL ) ! adj code: STT_ADJ(I,J,L,IDTSO4) = TSO4_ADJ * 1.d3 / ( 96.d0 * VOL ) IF ( LPRINTFD & .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN WRITE(*,*) 'After ANISORROPIA, STT_ADJ' WRITE(*,*) 'SO4 ',STT_ADJ(I,J,L,IDTSO4) WRITE(*,*) 'NH4 ',STT_ADJ(I,J,L,IDTNH4) WRITE(*,*) 'NH3 ',STT_ADJ(I,J,L,IDTNH3) WRITE(*,*) 'HNO3',STT_ADJ(I,J,L,IDTHNO3) WRITE(*,*) 'NIT ',STT_ADJ(I,J,L,IDTNIT) !PAUSE ENDIF ELSE ! Count the number of error flags & calls to reverse ANISOERRCOUNT = ANISOERRCOUNT + 1 SELECT CASE (NERR) CASE (22) NERR22 = NERR22 + 1 CASE (33) NERR33 = NERR33 + 1 CASE (50) NERR50 = NERR50 + 1 CASE (100) NERR100 = NERR100 + 1 CASE (101) NERR101 = NERR101 + 1 CASE (102) NERR102 = NERR102 + 1 CASE (103) NERR103 = NERR103 + 1 CASE (104) NERR104 = NERR104 + 1 CASE DEFAULT NERROTHER = NERROTHER + 1 END SELECT ENDIF ! no ISOROPIAII_ADJ errors ! debug - slc.1.2012 ANISOCALLCOUNT = ANISOCALLCOUNT + 1 SELECT CASE (SCASI) CASE("A2") CA = CA + 1 CASE("B4") CB = CB + 1 CASE("C2") CC = CC + 1 CASE("D3") CD = CD + 1 CASE("E4") CE = CE + 1 CASE("F2") CF = CF + 1 CASE("G5") CG = CG + 1 CASE("H6") CH = CH + 1 CASE("I6") CI = CI + 1 CASE("J3") CJ = CJ + 1 CASE DEFAULT COTHER = COTHER + 1 END SELECT ! fwd code: !DO N = 1, NCOMPA ! WI(N) = 0d0 ! WT(N) = 0d0 !ENDDO ! adj code (reset values for safety) WI_ADJ(:) = 0d0 WT_ADJ(:) = 0d0 GAS_ADJ(:) = 0d0 AERLIQ_ADJ(:) = 0d0 !<--- END ADJOINT CALCULATION ENDDO ENDDO ENDDO !$OMP END PARALLEL DO ! More error checking: warn of exploding adjoit values, except ! the first jump up from zero (MAX_ADJ_TMP = 0 first few times) IF ( MAXVAL(ABS(STT_ADJ)) > (MAX_ADJ_TMP * MAX_ALLOWED_INCREASE) & .AND. ( MAX_ADJ_TMP > 0d0 ) ) THEN WRITE(6,*)' *** - WARNING: EXPLODING adjoints in ADJ_AEROSOL' WRITE(6,*)' *** - MAX(ADJ_STT) before = ',MAX_ADJ_TMP WRITE(6,*)' *** - MAX(ADJ_STT) after = ',MAXVAL(ABS(STT_ADJ)) ADJ_EXPLD_COUNT = ADJ_EXPLD_COUNT + 1 IF (ADJ_EXPLD_COUNT > MAX_ALLOWED_EXPLD ) & CALL ERROR_STOP('Too many exploding adjoints', & 'ADJ_AEROSOL, adjoint_mod.f') ENDIF !### Debug IF ( LPRT ) CALL DEBUG_MSG( '### ISOROPIAII_ADJ: AERO_THERMO_ADJ') ! WRITE(6,*) 'ANISO calls: ',ANISOCALLCOUNT ! WRITE(6,*) 'ANISO error occurrences: ',ANISOERRCOUNT ! WRITE(6,*) 'Specific error codes: ' ! WRITE(6,*) 'Error 22: ',NERR22 ! WRITE(6,*) 'Error 33: ',NERR33 ! WRITE(6,*) 'Error 44: ',NERR44 ! WRITE(6,*) 'Error 100: ',NERR100 ! WRITE(6,*) 'Error 101: ',NERR101 ! WRITE(6,*) 'Error 102: ',NERR102 ! WRITE(6,*) 'Error 103: ',NERR103 ! WRITE(6,*) 'Error 104: ',NERR104 ! WRITE(6,*) 'Error Other: ', NERROTHER ! ! WRITE(6,*) '____________ Case Distribution ____________' ! WRITE(6,*) 'A: ',CA ! WRITE(6,*) 'B: ',CB ! WRITE(6,*) 'C: ',CC ! WRITE(6,*) 'D: ',CD ! WRITE(6,*) 'E: ',CE ! WRITE(6,*) 'F: ',CF ! WRITE(6,*) 'G: ',CG ! WRITE(6,*) 'H: ',CH ! WRITE(6,*) 'I: ',CI ! WRITE(6,*) 'J: ',CJ ! WRITE(6,*) 'Other: ', COTHER ! Return to calling program END SUBROUTINE DO_ISOROPIAII_ADJ !EOC !------------------------------------------------------------------------------ ! Caltech Department of Chemical Engineering / Seinfeld Group ! !------------------------------------------------------------------------------ !BOP ! ! !IROUTINE: safelog10 ! ! !DESCRIPTION: Calculates the LOG (base 10) of a number X. Returns a minimum ! value if X is too small, in order to avoid NaN or Infinity problems. !\\ !\\ ! !INTERFACE: ! FUNCTION SAFELOG10( X ) RESULT ( SAFLOG ) ! ! !INPUT PARAMETERS: ! REAL*8, INTENT(IN) :: X ! Argument for LOG10 function ! ! !RETURN VALUE: ! REAL*8 :: SAFLOG ! LOG10 output -- ! ! !REVISION HISTORY: ! 11 Aug 2009 - H. O. T. Pye - Initial version, in ISORROPIA II ! 29 Jan 2010 - R. Yantosca - Added ProTeX headers !EOP !------------------------------------------------------------------------------ !BOC IF ( X <= 1d-20 ) THEN SAFLOG = -1d0*20d0 ! if X<0, make pH 20 ELSE SAFLOG = LOG10(X) ENDIF END FUNCTION SAFELOG10 !EOC !------------------------------------------------------------------------------ ! Caltech Department of Chemical Engineering / Seinfeld Group ! !------------------------------------------------------------------------------ !BOP ! ! !IROUTINE: get_isrinfo ! ! !DESCRIPTION: Subroutine GET\_ISRINFO returns information related to ! aerosol pH. !\\ !\\ ! !INTERFACE: ! FUNCTION GET_ISRINFO( I, J, L, N ) RESULT ( RETURNVALUE ) ! ! !INPUT PARAMETERS: ! INTEGER, INTENT(IN) :: I ! GEOS-Chem longitude index INTEGER, INTENT(IN) :: J ! GEOS-Chem latitude index INTEGER, INTENT(IN) :: L ! GEOS-Chem level index INTEGER, INTENT(IN) :: N ! Flag for which information is desired ! ! !RETURN VALUE: ! REAL*8 :: RETURNVALUE ! ! !REVISION HISTORY: ! 11 Aug 2009 - H. O. T. Pye - Initial version ! 29 Jan 2010 - R. Yantosca - Added ProTeX headers !EOP !------------------------------------------------------------------------------ !BOC IF ( N == 1 ) THEN RETURNVALUE = PH_SAV( I, J, L ) ELSEIF ( N == 2 ) THEN RETURNVALUE = HPLUS_SAV( I, J, L ) ELSEIF ( N == 3 ) THEN RETURNVALUE = WATER_SAV( I, J, L ) ELSEIF ( N == 4 ) THEN RETURNVALUE = SULRAT_SAV( I, J, L ) ELSEIF ( N == 5 ) THEN RETURNVALUE = NARAT_SAV( I, J, L ) ELSEIF ( N == 6 ) THEN RETURNVALUE = ACIDPUR_SAV( I, J, L ) ELSE ! return large value to indicate problem RETURNVALUE = 99999d0 !FP_ISOP WRITE(*,*) 'VALUE NOT DEFINED IN GET_ISRINFO' ENDIF END FUNCTION GET_ISRINFO !EOC !------------------------------------------------------------------------------ ! Caltech Department of Chemical Engineering / Seinfeld Group ! !------------------------------------------------------------------------------ !BOP ! ! !IROUTINE: get_hno3 ! ! !DESCRIPTION: Subroutine GET\_HNO3 allows the HNO3 concentrations to evolve ! with time, but relaxes back to the monthly mean concentrations every 3 ! hours. !\\ !\\ ! !INTERFACE: ! FUNCTION GET_HNO3( I, J, L ) RESULT ( HNO3_UGM3 ) ! ! !USES: ! USE GLOBAL_HNO3_MOD, ONLY : GET_HNO3_UGM3 USE TIME_MOD, ONLY : GET_ELAPSED_MIN ! ! !INPUT PARAMETERS: ! INTEGER, INTENT(IN) :: I ! GEOS-Chem longitude index INTEGER, INTENT(IN) :: J ! GEOS-Chem latitude index INTEGER, INTENT(IN) :: L ! GEOS-Chem level index ! ! !REVISION HISTORY: ! 16 Dec 2002 - R. Yantosca - Initial version, in ISORROPIA I ! 24 Mar 2003 - R. Yantosca - Now use function GET_ELAPSED_MIN() from the ! new "time_mod.f" to get the elapsed minutes ! since the start of run. ! 06 Jul 2007 - H. O. T. Pye - Initial version, in ISORROPIA II ! 29 Jan 2010 - R. Yantosca - Added ProTeX headers !EOP !------------------------------------------------------------------------------ !BOC ! ! !LOCAL VARIABLES: ! REAL*8 :: HNO3_UGM3 !================================================================= ! GET_HNO3 begins here! !================================================================= ! Relax to monthly mean HNO3 concentrations every 3 hours ! Otherwise just return the concentration in HNO3_sav IF ( MOD( GET_ELAPSED_MIN(), 180 ) == 0 ) THEN HNO3_UGM3 = GET_HNO3_UGM3( I, J, L ) ELSE HNO3_UGM3 = HNO3_sav(I,J,L) ENDIF ! Return to calling program END FUNCTION GET_HNO3 !EOC !------------------------------------------------------------------------------ ! Caltech Department of Chemical Engineering / Seinfeld Group ! !------------------------------------------------------------------------------ !BOP ! ! !IROUTINE: set_hno3 ! ! !DESCRIPTION: Subroutine SET\_HNO3 stores the modified HNO3 value back ! into the HNO3\_sav array for the next timestep. !\\ !\\ ! !INTERFACE: ! SUBROUTINE SET_HNO3( I, J, L, HNO3_UGM3 ) ! ! !INPUT PARAMETERS: ! INTEGER, INTENT(IN) :: I ! GEOS-Chem longitude index INTEGER, INTENT(IN) :: J ! GEOS-Chem longitude index INTEGER, INTENT(IN) :: L ! GEOS-Chem longitude index REAL*8, INTENT(IN) :: HNO3_UGM3 ! HNO3 concentration [ug/m3] ! ! !REVISION HISTORY: ! 16 Dec 2002 - R. Yantosca - Initial version, in ISORROPIA I ! 06 Jul 2007 - H. O. T. Pye - Initial version, in ISORROPIA II ! 29 Jan 2010 - R. Yantosca - Added ProTeX headers !EOP !------------------------------------------------------------------------------ !BOC HNO3_sav(I,J,L) = HNO3_UGM3 END SUBROUTINE SET_HNO3 !EOC !------------------------------------------------------------------------------ ! Caltech Department of Chemical Engineering / Seinfeld Group ! !------------------------------------------------------------------------------ !BOP ! ! !IROUTINE: get_gno3 ! ! !DESCRIPTION: Function GET\_GNO3 returns the gas-phase HNO3 [v/v] for ! calculation of sea-salt chemistry in sulfate\_mod (SEASALT\_CHEM). !\\ !\\ ! !INTERFACE: ! SUBROUTINE GET_GNO3( I, J, L, HNO3_kg ) ! ! !USES: ! USE DAO_MOD, ONLY : AIRVOL, AD ! ! !INPUT PARAMETERS: ! INTEGER, INTENT(IN) :: I ! GEOS-Chem longitude index INTEGER, INTENT(IN) :: J ! GEOS-Chem latitude index INTEGER, INTENT(IN) :: L ! GEOS-Chem level index ! ! !OUTPUT PARAMETERS: ! REAL*8, INTENT(OUT) :: HNO3_kg ! Gas-phase HNO3 [kg] ! ! !REVISION HISTORY: ! 15 Apr 2005 - B. Alexander - Initial version, in ISORROPIA I ! 06 Jul 2007 - H. O. T. Pye - Initial version, in ISORROPIA II ! 29 Jan 2010 - R. Yantosca - Added ProTeX headers !EOP !------------------------------------------------------------------------------ !BOC ! Zero variables HNO3_kg = 0.D0 ! convert from [mole/m3] to [kg] HNO3_kg = GAS_HNO3(I,J,L) * 63.d-3 * AIRVOL(I,J,L) ! Return to calling program END SUBROUTINE GET_GNO3 !EOC !------------------------------------------------------------------------------ ! Caltech Department of Chemical Engineering / Seinfeld Group ! !------------------------------------------------------------------------------ !BOP ! ! !IROUTINE: init_isoropiaII ! ! !DESCRIPTION: Subroutine INIT\_ISOROPIAII initializes all module arrays. !\\ !\\ ! !INTERFACE: ! SUBROUTINE INIT_ISOROPIAII ! ! !USES: ! USE ERROR_MOD, ONLY : ALLOC_ERR # include "CMN_SIZE" ! Size parameters ! ! !REVISION HISTORY: ! 06 Jul 2007 - H. O. T. Pye - Initial version ! 29 Jan 2010 - R. Yantosca - Added ProTeX headers !EOP !------------------------------------------------------------------------------ !BOC ! ! !LOCAL VARIABLES: ! INTEGER :: AS !================================================================= ! INIT_ISOROPIAII begins here! !================================================================= WRITE(*,*) 'INIT_ISOROPIAII' ALLOCATE( HNO3_sav( IIPAR, JJPAR, LLTROP ) , STAT=AS ) IF ( AS /= 0 ) CALL ALLOC_ERR( 'HNO3_sav' ) HNO3_sav = 0d0 ALLOCATE( GAS_HNO3( IIPAR, JJPAR, LLTROP ) , STAT=AS ) IF ( AS /= 0 ) CALL ALLOC_ERR( 'GAS_HNO3' ) GAS_HNO3 = 0d0 ! AEROPH: diagnostic info (hotp 8/11/09) ! Allocate up to LLPAR, but zero above LLTROP ALLOCATE( PH_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) IF ( AS /= 0 ) CALL ALLOC_ERR( 'PH_SAV' ) PH_SAV = 0d0 ALLOCATE( HPLUS_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) IF ( AS /= 0 ) CALL ALLOC_ERR( 'HPLUS_SAV' ) HPLUS_SAV = 0d0 ALLOCATE( WATER_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) IF ( AS /= 0 ) CALL ALLOC_ERR( 'WATER_SAV' ) WATER_SAV = 0d0 ALLOCATE( SULRAT_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) IF ( AS /= 0 ) CALL ALLOC_ERR( 'SULRAT_SAV' ) SULRAT_SAV = 0d0 ALLOCATE( NARAT_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) IF ( AS /= 0 ) CALL ALLOC_ERR( 'NARAT_SAV' ) NARAT_SAV = 0d0 ALLOCATE( ACIDPUR_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) IF ( AS /= 0 ) CALL ALLOC_ERR( 'ACIDPUR_SAV' ) ACIDPUR_SAV = 0d0 ! Return to calling program END SUBROUTINE INIT_ISOROPIAII !EOC !------------------------------------------------------------------------------ ! Caltech Department of Chemical Engineering / Seinfeld Group ! !------------------------------------------------------------------------------ !BOP ! ! !IROUTINE: cleanup_isoropiaII ! ! !DESCRIPTION: Subroutine CLEANUP\_ISOROPIAII deallocates all module arrays. !\\ !\\ ! !INTERFACE: ! SUBROUTINE CLEANUP_ISOROPIAII ! ! !REVISION HISTORY: ! 06 Jul 2007 - H. O. T. Pye - Initial version ! 29 Jan 2010 - R. Yantosca - Added ProTeX headers !EOP !------------------------------------------------------------------------------ !BOC IF ( ALLOCATED( HNO3_sav ) ) DEALLOCATE( HNO3_sav ) IF ( ALLOCATED( GAS_HNO3 ) ) DEALLOCATE( GAS_HNO3 ) ! AEROPH: Deallocate arrays for pH (hotp 8/11/09) IF ( ALLOCATED( PH_SAV ) ) DEALLOCATE( PH_SAV ) IF ( ALLOCATED( HPLUS_SAV ) ) DEALLOCATE( HPLUS_SAV ) IF ( ALLOCATED( WATER_SAV ) ) DEALLOCATE( WATER_SAV ) IF ( ALLOCATED( SULRAT_SAV ) ) DEALLOCATE( SULRAT_SAV ) IF ( ALLOCATED( NARAT_SAV ) ) DEALLOCATE( NARAT_SAV ) IF ( ALLOCATED( ACIDPUR_SAV ) ) DEALLOCATE( ACIDPUR_SAV) END SUBROUTINE CLEANUP_ISOROPIAII !EOC END MODULE ISOROPIAII_ADJ_MOD