32409 lines
1.0 MiB
32409 lines
1.0 MiB
!
|
|
! NOTES:
|
|
! (1 ) Removed references to reverse problem code since GEOS-Chem
|
|
! will only need forward problem solution (hotp 8/1/07)
|
|
! (2 ) Explicitly declared some variables and made some common blocks
|
|
! THREADPRIVATE (hotp 8/2/07)
|
|
! (3 ) Removed DATA structure in CALCACT4 for parallelization
|
|
! (hotp 8/23/07)
|
|
! (4 ) Removed DELT and A2 print statement (hotp 8/30/07)
|
|
! (5 ) Removed SETPARM routine because it's not called (hotp 8/30/07)
|
|
! (6 ) Changed NADJ from 0 to 1 to force mass balance (hotp 11/7/07)
|
|
! (7 ) Stop code if ISRP4F is called due to mass balance
|
|
! issues (hotp 11/7/07)
|
|
! (8 ) If you wish to calculated act coeff online, check that DATA
|
|
! statements in KMFUL are not problematic for parallelization
|
|
! (9 ) Changed 1d-10 in ISRP3F to TINY for mass balance (hotp
|
|
! 11/14/07)
|
|
! (10 ) Added fix for negative H+ in CALCHS4 (hotp 8/25/09)
|
|
! search for 'PHFIX' to see where the fix was applied
|
|
! fix must be activated to use
|
|
! 23 Aug 2011 - S. Capps - ANISORROPIA implementation
|
|
! - only metastable routines included
|
|
! - online activity coefficient calculation only
|
|
! - removed auxiliary reverse problem routines
|
|
!
|
|
! *** 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.
|
|
!
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ISOROPIAII
|
|
C *** THIS SUBROUTINE IS THE MASTER ROUTINE FOR THE ISORROPIA
|
|
C THERMODYNAMIC EQUILIBRIUM AEROSOL MODEL (VERSION 1.1 and above)
|
|
C
|
|
C ======================== ARGUMENTS / USAGE ===========================
|
|
C
|
|
C INPUT:
|
|
C 1. [WI]
|
|
C REAL*8 :: array of length [8].
|
|
C Concentrations, expressed in moles/m3. Depending on the type of
|
|
C problem solved (specified in CNTRL(1)), WI contains either
|
|
C GAS+AEROSOL or AEROSOL only concentratios.
|
|
C WI(1) - sodium
|
|
C WI(2) - sulfate
|
|
C WI(3) - ammonium
|
|
C WI(4) - nitrate
|
|
C WI(5) - chloride
|
|
C WI(6) - calcium
|
|
C WI(7) - potassium
|
|
C WI(8) - magnesium
|
|
C
|
|
C 2. [RHI]
|
|
C REAL*8 :: variable.
|
|
C Ambient relative humidity expressed on a (0,1) scale.
|
|
C
|
|
C 3. [TEMPI]
|
|
C REAL*8 :: variable.
|
|
C Ambient temperature expressed in Kelvins.
|
|
C
|
|
C 4. [CNTRL]
|
|
C REAL*8 :: array of length [2].
|
|
C Parameters that control the type of problem solved.
|
|
C
|
|
C CNTRL(1): Defines the type of problem solved.
|
|
C 0 - Forward problem is solved. In this case, array WI contains
|
|
C GAS and AEROSOL concentrations together.
|
|
C 1 - Reverse problem is solved. In this case, array WI contains
|
|
C AEROSOL concentrations only.
|
|
C
|
|
C CNTRL(2): Defines the state of the aerosol
|
|
C 0 - The aerosol can have both solid+liquid phases (deliquescent)
|
|
C 1 - The aerosol is in only liquid state (metastable aerosol)
|
|
C
|
|
C OUTPUT:
|
|
C 1. [WT]
|
|
C REAL*8 :: array of length [8].
|
|
C Total concentrations (GAS+AEROSOL) of species, expressed in moles/m3.
|
|
C If the forward probelm is solved (CNTRL(1)=0), array WT is
|
|
C identical to array WI.
|
|
C WT(1) - total sodium
|
|
C WT(2) - total sulfate
|
|
C WT(3) - total ammonium
|
|
C WT(4) - total nitrate
|
|
C WT(5) - total chloride
|
|
C WT(6) - total calcium
|
|
C WT(7) - total potassium
|
|
C WT(8) - total magnesium
|
|
C
|
|
C 2. [GAS]
|
|
C REAL*8 :: array of length [03].
|
|
C Gaseous species concentrations, expressed in moles/m3.
|
|
C GAS(1) - NH3
|
|
C GAS(2) - HNO3
|
|
C GAS(3) - HCl
|
|
C
|
|
C 3. [AERLIQ]
|
|
C REAL*8 :: array of length [15].
|
|
C Liquid aerosol species concentrations, expressed in moles/m3.
|
|
C AERLIQ(01) - H+(aq)
|
|
C AERLIQ(02) - Na+(aq)
|
|
C AERLIQ(03) - NH4+(aq)
|
|
C AERLIQ(04) - Cl-(aq)
|
|
C AERLIQ(05) - SO4--(aq)
|
|
C AERLIQ(06) - HSO4-(aq)
|
|
C AERLIQ(07) - NO3-(aq)
|
|
C AERLIQ(08) - H2O
|
|
C AERLIQ(09) - NH3(aq) (undissociated)
|
|
C AERLIQ(10) - HNCl(aq) (undissociated)
|
|
C AERLIQ(11) - HNO3(aq) (undissociated)
|
|
C AERLIQ(12) - OH-(aq)
|
|
C AERLIQ(13) - Ca2+(aq)
|
|
C AERLIQ(14) - K+(aq)
|
|
C AERLIQ(15) - Mg2+(aq)
|
|
C
|
|
C 4. [AERSLD]
|
|
C REAL*8 :: array of length [19].
|
|
C Solid aerosol species concentrations, expressed in moles/m3.
|
|
C AERSLD(01) - NaNO3(s)
|
|
C AERSLD(02) - NH4NO3(s)
|
|
C AERSLD(03) - NaCl(s)
|
|
C AERSLD(04) - NH4Cl(s)
|
|
C AERSLD(05) - Na2SO4(s)
|
|
C AERSLD(06) - (NH4)2SO4(s)
|
|
C AERSLD(07) - NaHSO4(s)
|
|
C AERSLD(08) - NH4HSO4(s)
|
|
C AERSLD(09) - (NH4)4H(SO4)2(s)
|
|
C AERSLD(10) - CaSO4(s)
|
|
C AERSLD(11) - Ca(NO3)2(s)
|
|
C AERSLD(12) - CaCl2(s)
|
|
C AERSLD(13) - K2SO4(s)
|
|
C AERSLD(14) - KHSO4(s)
|
|
C AERSLD(15) - KNO3(s)
|
|
C AERSLD(16) - KCl(s)
|
|
C AERSLD(17) - MgSO4(s)
|
|
C AERSLD(18) - Mg(NO3)2(s)
|
|
C AERSLD(19) - MgCl2(s)
|
|
C
|
|
C 5. [SCASI]
|
|
C CHARACTER*15 variable.
|
|
C Returns the subcase which the input corresponds to.
|
|
C
|
|
C 6. [OTHER]
|
|
C REAL*8 :: array of length [9].
|
|
C Returns solution information.
|
|
C
|
|
C OTHER(1): Shows if aerosol water exists.
|
|
C 0 - Aerosol is WET
|
|
C 1 - Aerosol is DRY
|
|
C
|
|
C OTHER(2): Aerosol Sulfate ratio, defined as (in moles/m3) :
|
|
C (total ammonia + total Na) / (total sulfate)
|
|
C
|
|
C OTHER(3): Sulfate ratio based on aerosol properties that defines
|
|
C a sulfate poor system:
|
|
C (aerosol ammonia + aerosol Na) / (aerosol sulfate)
|
|
C
|
|
C OTHER(4): Aerosol sodium ratio, defined as (in moles/m3) :
|
|
C (total Na) / (total sulfate)
|
|
C
|
|
C OTHER(5): Ionic strength of the aqueous aerosol (if it exists).
|
|
C
|
|
C OTHER(6): Total number of calls to the activity coefficient
|
|
C calculation subroutine.
|
|
C
|
|
C OTHER(7): Sulfate ratio with crustal species, defined as (in moles/m3) :
|
|
C (total ammonia + total crustal species + total Na) / (total sulfate)
|
|
C
|
|
C OTHER(8): Crustal species + sodium ratio, defined as (in moles/m3) :
|
|
C (total crustal species + total Na) / (total sulfate)
|
|
C
|
|
C OTHER(9): Crustal species ratio, defined as (in moles/m3) :
|
|
C (total crustal species) / (total sulfate)
|
|
C
|
|
C 7. [TRUSTISO]
|
|
C LOGICAL variable.
|
|
C Returns internal error information.
|
|
C
|
|
C TRUE - no error occurred
|
|
C FALSE - error occurred
|
|
C
|
|
C 8. [NERR]
|
|
C INTEGER variable.
|
|
C Returns specific internal error information.
|
|
C
|
|
C Zero if no error occurred; otherwise, code of first error produced.
|
|
C - see subroutine ERRSTAT for classification of error codes.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISOROPIAII (WI, RHI, TEMPI, CNTRL,
|
|
& WT, GAS, AERLIQ, AERSLD, SCASI, OTHER,
|
|
& TRUSTISO,NERR)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
INTEGER, PARAMETER :: NCTRL = 2
|
|
INTEGER, PARAMETER :: NOTHER = 9
|
|
CHARACTER(LEN=15) :: SCASI
|
|
REAL*8 :: CNTRL, AERSLD, OTHER
|
|
LOGICAL :: TRUSTISO
|
|
REAL*8 :: WI, RHI, TEMPI, WT, GAS, AERLIQ
|
|
DIMENSION WI(NCOMP), WT(NCOMP), GAS(NGASAQ), AERSLD(NSLDS),
|
|
& AERLIQ(NIONS+NGASAQ+2), CNTRL(NCTRL), OTHER(NOTHER)
|
|
INTEGER :: ERRSTKI(25), NERR
|
|
CHARACTER(LEN=40) :: ERRMSGI(25)
|
|
C
|
|
C *** PROBLEM TYPE (0=FORWARD, 1=REVERSE) ******************************
|
|
C
|
|
IPROB = NINT(CNTRL(1))
|
|
C
|
|
C *** AEROSOL STATE (0=SOLID+LIQUID, 1=METASTABLE) **********************
|
|
C
|
|
METSTBL = NINT(CNTRL(2))
|
|
C
|
|
C *** SOLVE FORWARD PROBLEM ********************************************
|
|
C
|
|
50 IF (IPROB == 0) THEN
|
|
IF ((WI(1)+WI(2)+WI(3)+WI(4)+WI(5)) <= TINY) THEN ! Everything=0
|
|
!WRITE(*,*) 'Only calling INIT1'
|
|
CALL INIT1 (WI, RHI, TEMPI)
|
|
ELSE IF ((WI(1)+WI(4)+WI(5)) <= TINY) THEN ! Na,Cl,NO3=0
|
|
!WRITE(*,*) 'Calling ISRP1F'
|
|
CALL ISRP1F (WI, RHI, TEMPI)
|
|
ELSE IF ((WI(1)+WI(5)) <= TINY) THEN ! Na,Cl=0
|
|
!WRITE(*,*) 'Calling ISRP2F'
|
|
CALL ISRP2F (WI, RHI, TEMPI)
|
|
ELSE
|
|
!WRITE(*,*) 'Calling ISRP3F'
|
|
CALL ISRP3F (WI, RHI, TEMPI)
|
|
ENDIF
|
|
C
|
|
C *** SOLVE REVERSE PROBLEM *********************************************
|
|
C
|
|
C ELSE
|
|
C IF ((WI(1)+WI(2)+WI(3)+WI(4)+WI(5)) <= TINY) THEN ! Everything=0
|
|
CC CALL INIT1 (WI, RHI, TEMPI)
|
|
C ELSE IF ((WI(1)+WI(4)+WI(5)) <= TINY) THEN ! Na,Cl,NO3=0
|
|
C CALL ISRP1R (WI, RHI, TEMPI)
|
|
C ELSE IF ((WI(1)+WI(5)) <= TINY) THEN ! Na,Cl=0
|
|
C CALL ISRP2R (WI, RHI, TEMPI)
|
|
C ELSE
|
|
C CALL ISRP3R (WI, RHI, TEMPI)
|
|
C ENDIF
|
|
ENDIF
|
|
C
|
|
C *** ADJUST MASS BALANCE ***********************************************
|
|
C
|
|
IF (NADJ == 1) CALL ADJUST (WI)
|
|
ccC
|
|
ccC *** IF METASTABLE AND NO WATER - RESOLVE AS NORMAL ********************
|
|
ccC
|
|
cc IF (WATER <= TINY .AND. METSTBL == 1) THEN
|
|
cc METSTBL = 0
|
|
cc GOTO 50
|
|
cc ENDIF
|
|
C
|
|
C *** SAVE RESULTS TO ARRAYS (units = mole/m3) ****************************
|
|
C
|
|
GAS(1) = GNH3 ! Gaseous aerosol species
|
|
GAS(2) = GHNO3
|
|
GAS(3) = GHCL
|
|
C
|
|
DO I=1,7 ! Liquid aerosol species
|
|
AERLIQ(I) = MOLAL(I)
|
|
ENDDO
|
|
DO I=1,NGASAQ
|
|
AERLIQ(7+1+I) = GASAQ(I)
|
|
ENDDO
|
|
AERLIQ(7+1) = WATER*1.0D3/18.0D0
|
|
AERLIQ(7+NGASAQ+2) = COH
|
|
C
|
|
DO I=8,10 ! Liquid aerosol species
|
|
AERLIQ(I+5) = MOLAL(I)
|
|
ENDDO
|
|
C
|
|
AERSLD(1) = CNANO3 ! Solid aerosol species
|
|
AERSLD(2) = CNH4NO3
|
|
AERSLD(3) = CNACL
|
|
AERSLD(4) = CNH4CL
|
|
AERSLD(5) = CNA2SO4
|
|
AERSLD(6) = CNH42S4
|
|
AERSLD(7) = CNAHSO4
|
|
AERSLD(8) = CNH4HS4
|
|
AERSLD(9) = CLC
|
|
AERSLD(10) = CCASO4
|
|
AERSLD(11) = CCANO32
|
|
AERSLD(12) = CCACL2
|
|
AERSLD(13) = CK2SO4
|
|
AERSLD(14) = CKHSO4
|
|
AERSLD(15) = CKNO3
|
|
AERSLD(16) = CKCL
|
|
AERSLD(17) = CMGSO4
|
|
AERSLD(18) = CMGNO32
|
|
AERSLD(19) = CMGCL2
|
|
C
|
|
IF(WATER <= TINY) THEN ! Dry flag
|
|
OTHER(1) = 1.d0
|
|
ELSE
|
|
OTHER(1) = 0.d0
|
|
ENDIF
|
|
C
|
|
OTHER(2) = SULRAT ! Other stuff
|
|
OTHER(3) = SULRATW
|
|
OTHER(4) = SODRAT
|
|
OTHER(5) = IONIC
|
|
OTHER(6) = ICLACT
|
|
OTHER(7) = SO4RAT
|
|
OTHER(8) = CRNARAT
|
|
OTHER(9) = CRRAT
|
|
C
|
|
SCASI = SCASE
|
|
C
|
|
WT(1) = WI(1) ! Total gas+aerosol phase
|
|
WT(2) = WI(2)
|
|
WT(3) = WI(3)
|
|
WT(4) = WI(4)
|
|
WT(5) = WI(5)
|
|
WT(6) = WI(6)
|
|
WT(7) = WI(7)
|
|
WT(8) = WI(8)
|
|
|
|
! For reverse mode only (slc.8.2012)
|
|
!IF (IPROB > 0 .AND. WATER > TINY) THEN
|
|
! WT(3) = WT(3) + GNH3
|
|
! WT(4) = WT(4) + GHNO3
|
|
! WT(5) = WT(5) + GHCL
|
|
!ENDIF
|
|
|
|
NERR = 0
|
|
C
|
|
C slc.debug
|
|
C
|
|
C WRITE(*,*) '============= ANISORROPIA Debug =============='
|
|
C WRITE(*,*) 'Inside ISORROPIA Forward'
|
|
C WRITE(*,*) 'WI: ',WI
|
|
C WRITE(*,*) 'RHI: ',RHI, ' TEMPI: ',TEMPI
|
|
C WRITE(*,*) 'GAS: ',GAS
|
|
C WRITE(*,*) 'AERLIQ: ',AERLIQ(1:7)
|
|
C WRITE(*,*) AERLIQ(8:13)
|
|
C WRITE(*,*) '=============================================='
|
|
C WRITE(*,*) 'SCASE: ',SCASE
|
|
C WRITE(*,*) 'TRUSTISO ',TRUSTISO
|
|
C WRITE(*,*) '=============================================='
|
|
C
|
|
C *** Check for errors ****************************************************
|
|
C
|
|
TRUSTISO = .TRUE.
|
|
!WRITE(*,*) 'ISO, TRUSTISO: ',TRUSTISO,', RH: ',RHI,', T: ',TEMPI
|
|
CALL ISERRINF (ERRSTKI, ERRMSGI, NOFER, STKOFL) ! Obtain error stack
|
|
C IF (NOFER > 0) TRUSTISO = .FALSE. ! Errors found
|
|
IF (NOFER > 0) THEN
|
|
|
|
TRUSTISO = .FALSE. ! Errors found
|
|
NERR = ERRSTKI(1)
|
|
|
|
C WRITE(*,*) 'Forward: TRUSTISO = F', ERRSTKI(1)
|
|
C WRITE(6,*) 'Err Msg',ERRMSGI(1)
|
|
C WRITE(6,*) '# of errors ', NOFER
|
|
ENDIF
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE ISOROPIA ******************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ANISORROPIA CODE
|
|
C *** SUBROUTINE ISOROPIA_B
|
|
C *** THIS SUBROUTINE IS THE MASTER ROUTINE FOR THE ADJOINT OF ISORROPIA
|
|
C THERMODYNAMIC EQUILIBRIUM AEROSOL MODEL (VERSION 1.1 and above)
|
|
C
|
|
C ANISORROPIA ROUTINE. (slc.8.2011)
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISOROPIAII_ADJ(WI, WPB, RHI, TEMPI, CNTRL,
|
|
& WT, GAS, GASb, AERLIQ, AERLIQb, AERSLD,
|
|
& SCASI, OTHER, TRUSTISO, NERR)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
INTEGER, PARAMETER :: NCTRL = 2
|
|
INTEGER, PARAMETER :: NOTHER = 9
|
|
CHARACTER(LEN=15) :: SCASI
|
|
LOGICAL :: TRUSTISO
|
|
REAL*8 :: wp(ncomp), aerliq, gas
|
|
REAL*8 :: wpb(ncomp)
|
|
REAL*8 :: WTORIG, GASORIG, AERLIQORIG
|
|
REAL*8 :: wi, RHI
|
|
REAL*8 :: gasb(ngasaq), aerliqb(nions+ngasaq+2)
|
|
INTEGER :: ERRSTKI(25), NERR
|
|
CHARACTER(LEN=40) :: ERRMSGI(25)
|
|
DIMENSION WI(NCOMP), WT(NCOMP), GAS(NGASAQ), AERSLD(NSLDS),
|
|
& AERLIQ(NIONS+NGASAQ+2), CNTRL(NCTRL), OTHER(NOTHER)
|
|
C
|
|
C slc.debug
|
|
C
|
|
C WRITE(*,*) '============= ANISORROPIA Debug =============='
|
|
C WRITE(*,*) 'Inside ANISORROPIA'
|
|
C WRITE(*,*) 'WI: ',WI
|
|
C WRITE(*,*) 'RHI: ',RHI, ' TEMPI: ',TEMPI
|
|
C WRITE(*,*) '=============================================='
|
|
C WRITE(*,*) 'gas_b: ',gasb
|
|
C WRITE(*,*) 'aerliq_b: ',aerliqb(1:7)
|
|
C WRITE(*,*) aerliqb(8:13)
|
|
C WRITE(*,*) '=============================================='
|
|
C
|
|
C *** PROBLEM TYPE (0=FORWARD, 1=REVERSE) ******************************
|
|
C
|
|
IPROB = NINT(CNTRL(1))
|
|
C
|
|
C *** AEROSOL STATE (0=SOLID+LIQUID, 1=METASTABLE) **********************
|
|
C
|
|
METSTBL = NINT(CNTRL(2))
|
|
C
|
|
C *** SOLVE FORWARD PROBLEM ********************************************
|
|
C
|
|
IF (WI(1)+WI(2)+WI(3)+WI(4)+WI(5) <= TINY) THEN ! Everything=0
|
|
CALL INIT1 (WI,RHI,TEMPI)
|
|
ELSE IF (WI(1)+WI(4)+WI(5) <= TINY) THEN ! Na,Cl,NO3=0
|
|
C CALL ISRP1F (WI, RHI, TEMPI)
|
|
C
|
|
C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK **************************
|
|
C
|
|
CALL INIT1 (WI, RHI, TEMPI)
|
|
C WP = W
|
|
C
|
|
C *** CALCULATE SULFATE RATIO TO SEND TO APPROPRIATE CALC ***************
|
|
C
|
|
SULRAT = W(3)/W(2)
|
|
C
|
|
C *** FIND CALCULATION REGIME FROM (SULRAT,RH) **************************
|
|
C
|
|
IF (2.0 <= SULRAT) THEN
|
|
SCASE = 'A2'
|
|
CALL ISRP1FA_AB(wpb, gasb, aerliqb)
|
|
ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN
|
|
SCASE = 'B4'
|
|
CALL CALCB4_BB(wpb, gasb, aerliqb)
|
|
ELSEIF (SULRAT < 1.0) THEN
|
|
SCASE = 'C2'
|
|
CALL CALCC2_CB(wpb, gasb, aerliqb)
|
|
ELSE
|
|
RETURN
|
|
ENDIF
|
|
!RETURN
|
|
ELSE IF (WI(1)+WI(5) <= TINY) THEN ! Na,Cl=0
|
|
C
|
|
C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK **************************
|
|
C
|
|
CALL INIT2 (WI, RHI, TEMPI)
|
|
C
|
|
C *** CALCULATE SULFATE RATIO TO SEND TO APPROPRIATE CALC ***************
|
|
C
|
|
SULRAT = W(3)/W(2)
|
|
C
|
|
C *** FIND CALCULATION REGIME FROM (SULRAT,RH) **************************
|
|
C
|
|
IF (2.0 <= SULRAT) THEN
|
|
SCASE = 'D3'
|
|
CALL CALCD3_B(wpb, gasb, aerliqb)
|
|
ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN
|
|
SCASE = 'E4'
|
|
CALL CALCB4E_EB(wpb, gasb, aerliqb)
|
|
ELSEIF (SULRAT < 1.0) THEN
|
|
SCASE = 'F2'
|
|
CALL CALCC2F_FB(wpb, gasb, aerliqb)
|
|
ELSE
|
|
RETURN
|
|
ENDIF
|
|
!RETURN
|
|
C
|
|
ELSE IF (WI(1)+WI(5) > TINY) THEN ! Na,Cl>0
|
|
C
|
|
C *** SULFATE POOR ; SODIUM POOR
|
|
C
|
|
REST = 2.D0*WI(2) + WI(4) + WI(5)
|
|
IF (WI(1) > REST) THEN ! NA > 2*SO4+CL+NO3 ?
|
|
WI(1) = (ONE-1D-6)*REST ! Adjust Na amount
|
|
CALL PUSHERR (0050, 'ISRP3F') ! Warning error: Na adjusted
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE SULFATE & SODIUM RATIOS *********************************
|
|
C
|
|
SULRAT = (WI(1)+WI(3))/WI(2)
|
|
SODRAT = WI(1)/WI(2)
|
|
C
|
|
IF (2.0 <= SULRAT .AND. SODRAT < 2.0) THEN
|
|
C
|
|
C *** ADJUST FOR TOO LITTLE AMMONIUM AND CHLORIDE ***********************
|
|
C
|
|
WI(3) = MAX (WI(3), 1.D-10) ! NH4+ : 1e-4 umoles/m3
|
|
WI(5) = MAX (WI(5), 1.D-10) ! Cl- : 1e-4 umoles/m3
|
|
C
|
|
C *** ADJUST FOR TOO LITTLE SODIUM, SULFATE AND NITRATE COMBINED ********
|
|
C
|
|
IF (WI(1)+WI(2)+WI(4) <= 1d-10) THEN
|
|
WI(1) = 1.D-10 ! Na+ : 1e-4 umoles/m3
|
|
WI(2) = 1.D-10 ! SO4- : 1e-4 umoles/m3
|
|
ENDIF
|
|
C
|
|
C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK **************************
|
|
C
|
|
CALL ISOINIT3 (WI, RHI, TEMPI)
|
|
C
|
|
C *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE *********
|
|
C
|
|
REST = 2.D0*W(2) + W(4) + W(5)
|
|
IF (W(1) > REST) THEN ! NA > 2*SO4+CL+NO3 ?
|
|
W(1) = (ONE-1D-6)*REST ! Adjust Na amount
|
|
CALL PUSHERR (0050, 'ISRP3F') ! Warning error: Na adjusted
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE SULFATE & SODIUM RATIOS *********************************
|
|
C
|
|
SULRAT = (W(1)+W(3))/W(2)
|
|
SODRAT = W(1)/W(2)
|
|
C
|
|
C *** FIND CALCULATION REGIME FROM (SULRAT,RH) **************************
|
|
SCASE = 'G5'
|
|
CALL CALCG5_B(wpb, gasb, aerliqb) ! Only liquid (metastable)
|
|
C
|
|
ELSEIF (SULRAT >= 2.0 .AND. SODRAT >= 2.0) THEN
|
|
C
|
|
C *** ADJUST FOR TOO LITTLE AMMONIUM AND CHLORIDE ***********************
|
|
C
|
|
WI(3) = MAX (WI(3), 1.D-10) ! NH4+ : 1e-4 umoles/m3
|
|
WI(5) = MAX (WI(5), 1.D-10) ! Cl- : 1e-4 umoles/m3
|
|
C
|
|
C *** ADJUST FOR TOO LITTLE SODIUM, SULFATE AND NITRATE COMBINED ********
|
|
C
|
|
IF (WI(1)+WI(2)+WI(4) <= 1d-10) THEN
|
|
WI(1) = 1.D-10 ! Na+ : 1e-4 umoles/m3
|
|
WI(2) = 1.D-10 ! SO4- : 1e-4 umoles/m3
|
|
ENDIF
|
|
C
|
|
C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK **************************
|
|
C
|
|
CALL ISOINIT3 (WI, RHI, TEMPI)
|
|
C
|
|
C *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE *********
|
|
C
|
|
REST = 2.D0*W(2) + W(4) + W(5)
|
|
IF (W(1) > REST) THEN ! NA > 2*SO4+CL+NO3 ?
|
|
W(1) = (ONE-1D-6)*REST ! Adjust Na amount
|
|
CALL PUSHERR (0050, 'ISRP3F') ! Warning error: Na adjusted
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE SULFATE & SODIUM RATIOS *********************************
|
|
C
|
|
SULRAT = (W(1)+W(3))/W(2)
|
|
SODRAT = W(1)/W(2)
|
|
C
|
|
SCASE = 'H6'
|
|
CALL CALCH6_B(wpb, gasb, aerliqb) ! Only liquid (metastable)
|
|
ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN
|
|
CALL ISOINIT3 (WI, RHI, TEMPI)
|
|
SCASE = 'I6'
|
|
CALL ISRP3F_IB(wpb, gasb, aerliqb, rhi, tempi) ! Only liquid (metastable)
|
|
ELSEIF (SULRAT < 1.0) THEN
|
|
CALL ISOINIT3 (WI, RHI, TEMPI)
|
|
SCASE = 'J3'
|
|
CALL ISRP3F_JB(wpb, gasb, aerliqb, rhi, tempi) ! Only liquid (metastable)
|
|
ENDIF
|
|
ENDIF
|
|
C
|
|
C *** SOLVE REVERSE PROBLEM *********************************************
|
|
C
|
|
C ELSE
|
|
C
|
|
C *** Reverse routines not yet treated **********************************
|
|
C
|
|
C IF (WI(1)+WI(2)+WI(3)+WI(4)+WI(5) <= TINY) THEN ! Everything=0
|
|
C CALL INIT1 (WI, RHI, TEMPI)
|
|
C ELSE IF (WI(1)+WI(4)+WI(5) <= TINY) THEN ! Na,Cl,NO3=0
|
|
C CALL ISRP1R (WI, RHI, TEMPI)
|
|
C ELSE IF (WI(1)+WI(5) <= TINY) THEN ! Na,Cl=0
|
|
C CALL ISRP2R (WI, RHI, TEMPI)
|
|
C ELSE
|
|
C CALL ISRP3R (WI, RHI, TEMPI)
|
|
C ENDIF
|
|
C ENDIF
|
|
C RETURN
|
|
C
|
|
C *** ADJUST MASS BALANCE ***********************************************
|
|
C
|
|
IF (NADJ == 1) CALL ADJUST (WI)
|
|
ccC
|
|
ccC *** IF METASTABLE AND NO WATER - RESOLVE AS NORMAL ********************
|
|
ccC
|
|
cc IF (WATER <= TINY .AND. METSTBL == 1) THEN
|
|
cc METSTBL = 0
|
|
cc GOTO 50
|
|
cc ENDIF
|
|
C
|
|
C *** SAVE RESULTS TO ARRAYS (units = MICROGRAMS/m3) ****************************
|
|
C
|
|
C
|
|
GAS(1) = GNH3 ! Gaseous aerosol species
|
|
GAS(2) = GHNO3
|
|
GAS(3) = GHCL
|
|
C
|
|
DO I=1,7 ! Liquid aerosol species
|
|
AERLIQ(I) = MOLAL(I)
|
|
ENDDO
|
|
DO I=1,NGASAQ
|
|
AERLIQ(7+1+I) = GASAQ(I)
|
|
ENDDO
|
|
AERLIQ(7+1) = WATER*1.0D3/18.0D0
|
|
AERLIQ(7+NGASAQ+2) = COH
|
|
C
|
|
DO I=8,10 ! Liquid aerosol species
|
|
AERLIQ(I+5) = MOLAL(I)
|
|
ENDDO
|
|
C
|
|
AERSLD(1) = CNANO3 ! Solid aerosol species
|
|
AERSLD(2) = CNH4NO3
|
|
AERSLD(3) = CNACL
|
|
AERSLD(4) = CNH4CL
|
|
AERSLD(5) = CNA2SO4
|
|
AERSLD(6) = CNH42S4
|
|
AERSLD(7) = CNAHSO4
|
|
AERSLD(8) = CNH4HS4
|
|
AERSLD(9) = CLC
|
|
AERSLD(10) = CCASO4
|
|
AERSLD(11) = CCANO32
|
|
AERSLD(12) = CCACL2
|
|
AERSLD(13) = CK2SO4
|
|
AERSLD(14) = CKHSO4
|
|
AERSLD(15) = CKNO3
|
|
AERSLD(16) = CKCL
|
|
AERSLD(17) = CMGSO4
|
|
AERSLD(18) = CMGNO32
|
|
AERSLD(19) = CMGCL2
|
|
C
|
|
IF(WATER <= TINY) THEN ! Dry flag
|
|
OTHER(1) = 1.d0
|
|
ELSE
|
|
OTHER(1) = 0.d0
|
|
ENDIF
|
|
C
|
|
OTHER(2) = SULRAT ! Other stuff
|
|
OTHER(3) = SULRATW
|
|
OTHER(4) = SODRAT
|
|
OTHER(5) = IONIC
|
|
OTHER(6) = ICLACT
|
|
OTHER(7) = SO4RAT
|
|
OTHER(8) = CRNARAT
|
|
OTHER(9) = CRRAT
|
|
C
|
|
SCASI = SCASE
|
|
C
|
|
C slc.debug
|
|
C
|
|
C WRITE(*,*) '=============================================='
|
|
C WRITE(*,*) 'GAS: ',GAS
|
|
C WRITE(*,*) 'AERLIQ: ',AERLIQ(1:7)
|
|
C WRITE(*,*) AERLIQ(8:13)
|
|
C WRITE(*,*) 'wp_b: ',wpb
|
|
C WRITE(*,*) 'SCASE: ',SCASE
|
|
C WRITE(*,*) 'TRUSTISO ',TRUSTISO
|
|
C WRITE(*,*) '=============================================='
|
|
C
|
|
! For reverse mode only (slc.8.2012)
|
|
!IF (IPROB > 0 .AND. WATER > TINY) THEN
|
|
! WT(3) = WT(3) + GNH3
|
|
! WT(4) = WT(4) + GHNO3
|
|
! WT(5) = WT(5) + GHCL
|
|
!ENDIF
|
|
C
|
|
C *** Check for errors ****************************************************
|
|
C
|
|
TRUSTISO = .TRUE.
|
|
CALL ISERRINF (ERRSTKI, ERRMSGI, NOFER, STKOFL) ! Obtain error stack
|
|
IF (NOFER > 0) THEN
|
|
|
|
TRUSTISO = .FALSE. ! Errors found
|
|
NERR = ERRSTKI(1)
|
|
|
|
C WRITE(*,*) 'Forward: TRUSTISO = F', ERRSTKI(1)
|
|
C WRITE(6,*) 'Err Msg',ERRMSGI(1)
|
|
C WRITE(6,*) '# of errors ', NOFER
|
|
ENDIF
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE ISOROPIA ******************************************
|
|
C
|
|
END
|
|
C
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE SETPARM
|
|
C *** THIS SUBROUTINE REDEFINES THE SOLUTION PARAMETERS OF ISORROPIA
|
|
C
|
|
C ======================== ARGUMENTS / USAGE ===========================
|
|
C
|
|
C *** NOTE: IF NEGATIVE VALUES ARE GIVEN FOR A PARAMETER, IT IS
|
|
C IGNORED AND THE CURRENT VALUE IS USED INSTEAD.
|
|
C
|
|
C INPUT:
|
|
C 1. [WFTYPI]
|
|
C INTEGER variable.
|
|
C Defines the type of weighting algorithm for the solution in Mutual
|
|
C Deliquescence Regions (MDR's):
|
|
C 0 - MDR's are assumed dry. This is equivalent to the approach
|
|
C used by SEQUILIB.
|
|
C 1 - The solution is assumed "half" dry and "half" wet throughout
|
|
C the MDR.
|
|
C 2 - The solution is a relative-humidity weighted mean of the
|
|
C dry and wet solutions (as defined in Nenes et al., 1998)
|
|
C
|
|
C 2. [IACALCI]
|
|
C INTEGER variable.
|
|
C Method of activity coefficient calculation:
|
|
C 0 - Calculate coefficients during runtime
|
|
C 1 - Use precalculated tables
|
|
C
|
|
C 3. [EPSI]
|
|
C DOUBLE PRECITION variable.
|
|
C Defines the convergence criterion for all iterative processes
|
|
C in ISORROPIA, except those for activity coefficient calculations
|
|
C (EPSACTI controls that).
|
|
C
|
|
C 4. [MAXITI]
|
|
C INTEGER variable.
|
|
C Defines the maximum number of iterations for all iterative
|
|
C processes in ISORROPIA, except for activity coefficient calculations
|
|
C (NSWEEPI controls that).
|
|
C
|
|
C 5. [NSWEEPI]
|
|
C INTEGER variable.
|
|
C Defines the maximum number of iterations for activity coefficient
|
|
C calculations.
|
|
C
|
|
C 6. [EPSACTI]
|
|
C REAL*8 :: variable.
|
|
C Defines the convergence criterion for activity coefficient
|
|
C calculations.
|
|
C
|
|
C 7. [NDIV]
|
|
C INTEGER variable.
|
|
C Defines the number of subdivisions needed for the initial root
|
|
C tracking for the bisection method. Usually this parameter should
|
|
C not be altered, but is included for completeness.
|
|
C
|
|
C 8. [NADJ]
|
|
C INTEGER variable.
|
|
C Forces the solution obtained to satisfy total mass balance
|
|
C to machine precision
|
|
C 0 - No adjustment done (default)
|
|
C 1 - Do adjustment
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
! SUBROUTINE SETPARM (WFTYPI, IACALCI, EPSI, MAXITI, NSWEEPI,
|
|
! & EPSACTI, NDIVI, NADJI)
|
|
! INCLUDE 'isrpia_adj.inc'
|
|
! REAL*8 :: EPSI, EPSACTI
|
|
! INTEGER :: WFTYPI
|
|
!C
|
|
!C *** SETUP SOLUTION PARAMETERS *****************************************
|
|
!C
|
|
! IF (WFTYPI >= 0) WFTYP = WFTYPI
|
|
! IF (IACALCI >= 0) IACALC = IACALCI
|
|
! IF (EPSI >= ZERO) EPS = EPSI
|
|
! IF (MAXITI > 0) MAXIT = MAXITI
|
|
! IF (NSWEEPI > 0) NSWEEP = NSWEEPI
|
|
! IF (EPSACTI >= ZERO) EPSACT = EPSACTI
|
|
! IF (NDIVI > 0) NDIV = NDIVI
|
|
! IF (NADJI >= 0) NADJ = NADJI
|
|
!C
|
|
!C *** END OF SUBROUTINE SETPARM *****************************************
|
|
!C
|
|
! RETURN
|
|
! END
|
|
!
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE GETPARM
|
|
C *** THIS SUBROUTINE OBTAINS THE CURRENT VAULES OF THE SOLUTION
|
|
C PARAMETERS OF ISORROPIA
|
|
C
|
|
C ======================== ARGUMENTS / USAGE ===========================
|
|
C
|
|
C *** THE PARAMETERS ARE THOSE OF SUBROUTINE SETPARM
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE GETPARM (WFTYPI, IACALCI, EPSI, MAXITI, NSWEEPI,
|
|
& EPSACTI, NDIVI, NADJI)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
INTEGER WFTYPI
|
|
C
|
|
C *** GET SOLUTION PARAMETERS *******************************************
|
|
C
|
|
WFTYPI = WFTYP
|
|
IACALCI = IACALC
|
|
EPSI = EPS
|
|
MAXITI = MAXIT
|
|
NSWEEPI = NSWEEP
|
|
EPSACTI = EPSACT
|
|
NDIVI = NDIV
|
|
NADJI = NADJ
|
|
C
|
|
C *** END OF SUBROUTINE GETPARM *****************************************
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** BLOCK DATA BLKISO
|
|
C *** THIS SUBROUTINE PROVIDES INITIAL (DEFAULT) VALUES TO PROGRAM
|
|
C PARAMETERS VIA DATA STATEMENTS
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C *** ZSR RELATIONSHIP PARAMETERS MODIFIED BY DOUGLAS WALDRON
|
|
C *** OCTOBER 2003
|
|
C *** BASED ON AIM MODEL III (http://mae.ucdavis.edu/wexler/aim)
|
|
C
|
|
C=======================================================================
|
|
C
|
|
BLOCK DATA BLKISO
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
C *** DEFAULT VALUES *************************************************
|
|
C
|
|
C DATA TEMP/298.0/, R/82.0567D-6/, RH/0.9D0/, EPS/1D-10/,
|
|
C & MAXIT/100/, TINY/1D-20/, GREAT/1D10/, ZERO/0.0D0/,
|
|
C & ONE/1.0D0/,NSWEEP/10/, TINY2/1D-11/, NDIV/5/
|
|
|
|
C ! EPS = 1d-10 instead of 1d-6 !slc.8.2011!
|
|
C ! Increase the stringency of convergence criteria
|
|
C
|
|
C ! NSWEEP = 10 instead of 4
|
|
C ! Increase number of iterations possible to attain convergence
|
|
|
|
C
|
|
C DATA MOLAL/NIONS*0.0D0/, MOLALR/NPAIR*0.0D0/, GAMA/NPAIR*0.1D0/,
|
|
C & GAMOU/NPAIR*1D10/, GAMIN/NPAIR*1D10/, CALAIN/.TRUE./,
|
|
C & CALAOU/.TRUE./, EPSACT/1D-10/, ICLACT/0/,
|
|
C & IACALC/0/, NADJ/0/, WFTYP/2/
|
|
|
|
C ! EPSACT = 1d-10 instead of 5d-2 !slc.8.2011!
|
|
C ! Increase precision of activity coefficient calculation
|
|
C
|
|
C ! NADJ = 0 instead of 1
|
|
C ! No mass conservation routines have an adjoint
|
|
C
|
|
C ! IACALC = 0 instead of 1
|
|
C ! Online activity coefficient calculation required
|
|
|
|
C
|
|
C DATA ERRSTK/NERRMX*0/, ERRMSG/NERRMX*' '/, NOFER/0/,
|
|
C & STKOFL/.FALSE./
|
|
C
|
|
C DATA IPROB/0/, METSTBL/0/
|
|
C
|
|
C DATA VERSION /'2.0 (03/19/07)'/
|
|
C
|
|
C *** OTHER PARAMETERS ***********************************************
|
|
C
|
|
C DATA SMW/58.5,142.,85.0,132.,80.0,53.5,98.0,98.0,115.,63.0,
|
|
C & 36.5,120.,247./
|
|
C & IMW/ 1.0,23.0,18.0,35.5,96.0,97.0,63.0/,
|
|
C & WMW/23.0,98.0,17.0,63.0,36.5/
|
|
C
|
|
C REAL*8 :: ZZ(NPAIR) = (/ 1,2,1,2,1,1,2,1,1,1,1,1,2,4,2,2,2,
|
|
C & 1,1,1,4,2,2 /)
|
|
C REAL*8 :: Z(NIONS) = (/ 1.0D0, 1.0D0, 1.0D0, 1.0D0, 2.0D0,
|
|
C & 1.0D0, 1.0D0, 2.0D0, 1.0D0, 2.0D0 /)
|
|
C
|
|
C *** ZSR RELATIONSHIP PARAMETERS **************************************
|
|
C
|
|
C awas= ammonium sulfate
|
|
C
|
|
DATA AWAS/10*187.72,
|
|
& 158.13,134.41,115.37,100.10, 87.86, 78.00, 70.00, 63.45, 58.02,
|
|
& 53.46,
|
|
& 49.59, 46.26, 43.37, 40.84, 38.59, 36.59, 34.79, 33.16, 31.67,
|
|
& 30.31,
|
|
& 29.07, 27.91, 26.84, 25.84, 24.91, 24.03, 23.21, 22.44, 21.70,
|
|
& 21.01,
|
|
& 20.34, 19.71, 19.11, 18.54, 17.99, 17.46, 16.95, 16.46, 15.99,
|
|
& 15.54,
|
|
& 15.10, 14.67, 14.26, 13.86, 13.47, 13.09, 12.72, 12.36, 12.01,
|
|
& 11.67,
|
|
& 11.33, 11.00, 10.68, 10.37, 10.06, 9.75, 9.45, 9.15, 8.86,
|
|
& 8.57,
|
|
& 8.29, 8.01, 7.73, 7.45, 7.18, 6.91, 6.64, 6.37, 6.10,
|
|
& 5.83,
|
|
& 5.56, 5.29, 5.02, 4.74, 4.47, 4.19, 3.91, 3.63, 3.34,
|
|
& 3.05,
|
|
& 2.75, 2.45, 2.14, 1.83, 1.51, 1.19, 0.87, 0.56, 0.26,
|
|
& 0.1/
|
|
C
|
|
C awsn= sodium nitrate
|
|
C
|
|
DATA AWSN/10*394.54,
|
|
& 338.91,293.01,254.73,222.61,195.56,172.76,153.53,137.32,123.65,
|
|
& 112.08,
|
|
& 102.26, 93.88, 86.68, 80.45, 75.02, 70.24, 66.02, 62.26, 58.89,
|
|
& 55.85,
|
|
& 53.09, 50.57, 48.26, 46.14, 44.17, 42.35, 40.65, 39.06, 37.57,
|
|
& 36.17,
|
|
& 34.85, 33.60, 32.42, 31.29, 30.22, 29.20, 28.22, 27.28, 26.39,
|
|
& 25.52,
|
|
& 24.69, 23.89, 23.12, 22.37, 21.65, 20.94, 20.26, 19.60, 18.96,
|
|
& 18.33,
|
|
& 17.72, 17.12, 16.53, 15.96, 15.40, 14.85, 14.31, 13.78, 13.26,
|
|
& 12.75,
|
|
& 12.25, 11.75, 11.26, 10.77, 10.29, 9.82, 9.35, 8.88, 8.42,
|
|
& 7.97,
|
|
& 7.52, 7.07, 6.62, 6.18, 5.75, 5.32, 4.89, 4.47, 4.05,
|
|
& 3.64,
|
|
& 3.24, 2.84, 2.45, 2.07, 1.70, 1.34, 0.99, 0.65, 0.31,
|
|
& 0.1/
|
|
C
|
|
C awsc= sodium chloride
|
|
C
|
|
DATA AWSC/10*28.16,
|
|
& 27.17, 26.27, 25.45, 24.69, 23.98, 23.33, 22.72, 22.14, 21.59,
|
|
& 21.08,
|
|
& 20.58, 20.12, 19.67, 19.24, 18.82, 18.43, 18.04, 17.67, 17.32,
|
|
& 16.97,
|
|
& 16.63, 16.31, 15.99, 15.68, 15.38, 15.08, 14.79, 14.51, 14.24,
|
|
& 13.97,
|
|
& 13.70, 13.44, 13.18, 12.93, 12.68, 12.44, 12.20, 11.96, 11.73,
|
|
& 11.50,
|
|
& 11.27, 11.05, 10.82, 10.60, 10.38, 10.16, 9.95, 9.74, 9.52,
|
|
& 9.31,
|
|
& 9.10, 8.89, 8.69, 8.48, 8.27, 8.07, 7.86, 7.65, 7.45,
|
|
& 7.24,
|
|
& 7.04, 6.83, 6.62, 6.42, 6.21, 6.00, 5.79, 5.58, 5.36,
|
|
& 5.15,
|
|
& 4.93, 4.71, 4.48, 4.26, 4.03, 3.80, 3.56, 3.32, 3.07,
|
|
& 2.82,
|
|
& 2.57, 2.30, 2.04, 1.76, 1.48, 1.20, 0.91, 0.61, 0.30,
|
|
& 0.1/
|
|
C
|
|
C awac= ammonium chloride
|
|
C
|
|
DATA AWAC/10*1209.00,
|
|
& 1067.60,949.27,848.62,761.82,686.04,619.16,559.55,505.92,457.25,
|
|
& 412.69,
|
|
& 371.55,333.21,297.13,262.81,229.78,197.59,165.98,135.49,108.57,
|
|
& 88.29,
|
|
& 74.40, 64.75, 57.69, 52.25, 47.90, 44.30, 41.27, 38.65, 36.36,
|
|
& 34.34,
|
|
& 32.52, 30.88, 29.39, 28.02, 26.76, 25.60, 24.51, 23.50, 22.55,
|
|
& 21.65,
|
|
& 20.80, 20.00, 19.24, 18.52, 17.83, 17.17, 16.54, 15.93, 15.35,
|
|
& 14.79,
|
|
& 14.25, 13.73, 13.22, 12.73, 12.26, 11.80, 11.35, 10.92, 10.49,
|
|
& 10.08,
|
|
& 9.67, 9.28, 8.89, 8.51, 8.14, 7.77, 7.42, 7.06, 6.72,
|
|
& 6.37,
|
|
& 6.03, 5.70, 5.37, 5.05, 4.72, 4.40, 4.08, 3.77, 3.45,
|
|
& 3.14,
|
|
& 2.82, 2.51, 2.20, 1.89, 1.57, 1.26, 0.94, 0.62, 0.31,
|
|
& 0.1/
|
|
C
|
|
C awss= sodium sulfate
|
|
C
|
|
DATA AWSS/10*24.10,
|
|
& 23.17, 22.34, 21.58, 20.90, 20.27, 19.69, 19.15, 18.64, 18.17,
|
|
& 17.72,
|
|
& 17.30, 16.90, 16.52, 16.16, 15.81, 15.48, 15.16, 14.85, 14.55,
|
|
& 14.27,
|
|
& 13.99, 13.73, 13.47, 13.21, 12.97, 12.73, 12.50, 12.27, 12.05,
|
|
& 11.84,
|
|
& 11.62, 11.42, 11.21, 11.01, 10.82, 10.63, 10.44, 10.25, 10.07,
|
|
& 9.89,
|
|
& 9.71, 9.53, 9.36, 9.19, 9.02, 8.85, 8.68, 8.51, 8.35,
|
|
& 8.19,
|
|
& 8.02, 7.86, 7.70, 7.54, 7.38, 7.22, 7.06, 6.90, 6.74,
|
|
& 6.58,
|
|
& 6.42, 6.26, 6.10, 5.94, 5.78, 5.61, 5.45, 5.28, 5.11,
|
|
& 4.93,
|
|
& 4.76, 4.58, 4.39, 4.20, 4.01, 3.81, 3.60, 3.39, 3.16,
|
|
& 2.93,
|
|
& 2.68, 2.41, 2.13, 1.83, 1.52, 1.19, 0.86, 0.54, 0.25,
|
|
& 0.1/
|
|
C
|
|
C awab= ammonium bisulfate
|
|
C
|
|
DATA AWAB/10*312.84,
|
|
& 271.43,237.19,208.52,184.28,163.64,145.97,130.79,117.72,106.42,
|
|
& 96.64,
|
|
& 88.16, 80.77, 74.33, 68.67, 63.70, 59.30, 55.39, 51.89, 48.76,
|
|
& 45.93,
|
|
& 43.38, 41.05, 38.92, 36.97, 35.18, 33.52, 31.98, 30.55, 29.22,
|
|
& 27.98,
|
|
& 26.81, 25.71, 24.67, 23.70, 22.77, 21.90, 21.06, 20.27, 19.52,
|
|
& 18.80,
|
|
& 18.11, 17.45, 16.82, 16.21, 15.63, 15.07, 14.53, 14.01, 13.51,
|
|
& 13.02,
|
|
& 12.56, 12.10, 11.66, 11.24, 10.82, 10.42, 10.04, 9.66, 9.29,
|
|
& 8.93,
|
|
& 8.58, 8.24, 7.91, 7.58, 7.26, 6.95, 6.65, 6.35, 6.05,
|
|
& 5.76,
|
|
& 5.48, 5.20, 4.92, 4.64, 4.37, 4.09, 3.82, 3.54, 3.27,
|
|
& 2.99,
|
|
& 2.70, 2.42, 2.12, 1.83, 1.52, 1.22, 0.90, 0.59, 0.28,
|
|
& 0.1/
|
|
C
|
|
C awsa= sulfuric acid
|
|
C
|
|
DATA AWSA/34.00, 33.56, 29.22, 26.55, 24.61, 23.11, 21.89, 20.87,
|
|
& 19.99, 18.45,
|
|
& 17.83, 17.26, 16.73, 16.25, 15.80, 15.38, 14.98, 14.61, 14.26,
|
|
& 13.93,
|
|
& 13.61, 13.30, 13.01, 12.73, 12.47, 12.21, 11.96, 11.72, 11.49,
|
|
& 11.26,
|
|
& 11.04, 10.83, 10.62, 10.42, 10.23, 10.03, 9.85, 9.67, 9.49,
|
|
& 9.31,
|
|
& 9.14, 8.97, 8.81, 8.65, 8.49, 8.33, 8.18, 8.02, 7.87,
|
|
& 7.73,
|
|
& 7.58, 7.44, 7.29, 7.15, 7.01, 6.88, 6.74, 6.61, 6.47,
|
|
& 6.34,
|
|
& 6.21, 6.07, 5.94, 5.81, 5.68, 5.55, 5.43, 5.30, 5.17,
|
|
& 5.04,
|
|
& 4.91, 4.78, 4.65, 4.52, 4.39, 4.26, 4.13, 4.00, 3.86,
|
|
& 3.73,
|
|
& 3.59, 3.45, 3.31, 3.17, 3.02, 2.87, 2.71, 2.56, 2.39,
|
|
& 2.22,
|
|
& 2.05, 1.87, 1.68, 1.48, 1.27, 1.04, 0.80, 0.55, 0.28,
|
|
& 0.1/
|
|
C
|
|
C awlc= (NH4)3H(SO4)2
|
|
C
|
|
DATA AWLC/10*125.37,
|
|
& 110.10, 97.50, 86.98, 78.08, 70.49, 63.97, 58.33, 53.43, 49.14,
|
|
& 45.36,
|
|
& 42.03, 39.07, 36.44, 34.08, 31.97, 30.06, 28.33, 26.76, 25.32,
|
|
& 24.01,
|
|
& 22.81, 21.70, 20.67, 19.71, 18.83, 18.00, 17.23, 16.50, 15.82,
|
|
& 15.18,
|
|
& 14.58, 14.01, 13.46, 12.95, 12.46, 11.99, 11.55, 11.13, 10.72,
|
|
& 10.33,
|
|
& 9.96, 9.60, 9.26, 8.93, 8.61, 8.30, 8.00, 7.72, 7.44,
|
|
& 7.17,
|
|
& 6.91, 6.66, 6.42, 6.19, 5.96, 5.74, 5.52, 5.31, 5.11,
|
|
& 4.91,
|
|
& 4.71, 4.53, 4.34, 4.16, 3.99, 3.81, 3.64, 3.48, 3.31,
|
|
& 3.15,
|
|
& 2.99, 2.84, 2.68, 2.53, 2.37, 2.22, 2.06, 1.91, 1.75,
|
|
& 1.60,
|
|
& 1.44, 1.28, 1.12, 0.95, 0.79, 0.62, 0.45, 0.29, 0.14,
|
|
& 0.1/
|
|
C
|
|
C awan= ammonium nitrate
|
|
C
|
|
DATA AWAN/10*960.19,
|
|
& 853.15,763.85,688.20,623.27,566.92,517.54,473.91,435.06,400.26,
|
|
& 368.89,
|
|
& 340.48,314.63,291.01,269.36,249.46,231.11,214.17,198.50,184.00,
|
|
& 170.58,
|
|
& 158.15,146.66,136.04,126.25,117.24,108.97,101.39, 94.45, 88.11,
|
|
& 82.33,
|
|
& 77.06, 72.25, 67.85, 63.84, 60.16, 56.78, 53.68, 50.81, 48.17,
|
|
& 45.71,
|
|
& 43.43, 41.31, 39.32, 37.46, 35.71, 34.06, 32.50, 31.03, 29.63,
|
|
& 28.30,
|
|
& 27.03, 25.82, 24.67, 23.56, 22.49, 21.47, 20.48, 19.53, 18.61,
|
|
& 17.72,
|
|
& 16.86, 16.02, 15.20, 14.41, 13.64, 12.89, 12.15, 11.43, 10.73,
|
|
& 10.05,
|
|
& 9.38, 8.73, 8.09, 7.47, 6.86, 6.27, 5.70, 5.15, 4.61,
|
|
& 4.09,
|
|
& 3.60, 3.12, 2.66, 2.23, 1.81, 1.41, 1.03, 0.67, 0.32,
|
|
& 0.1/
|
|
C
|
|
C awsb= sodium bisulfate
|
|
C
|
|
DATA AWSB/10*55.99,
|
|
& 53.79, 51.81, 49.99, 48.31, 46.75, 45.28, 43.91, 42.62, 41.39,
|
|
& 40.22,
|
|
& 39.10, 38.02, 36.99, 36.00, 35.04, 34.11, 33.21, 32.34, 31.49,
|
|
& 30.65,
|
|
& 29.84, 29.04, 28.27, 27.50, 26.75, 26.01, 25.29, 24.57, 23.87,
|
|
& 23.17,
|
|
& 22.49, 21.81, 21.15, 20.49, 19.84, 19.21, 18.58, 17.97, 17.37,
|
|
& 16.77,
|
|
& 16.19, 15.63, 15.08, 14.54, 14.01, 13.51, 13.01, 12.53, 12.07,
|
|
& 11.62,
|
|
& 11.19, 10.77, 10.36, 9.97, 9.59, 9.23, 8.87, 8.53, 8.20,
|
|
& 7.88,
|
|
& 7.57, 7.27, 6.97, 6.69, 6.41, 6.14, 5.88, 5.62, 5.36,
|
|
& 5.11,
|
|
& 4.87, 4.63, 4.39, 4.15, 3.92, 3.68, 3.45, 3.21, 2.98,
|
|
& 2.74,
|
|
& 2.49, 2.24, 1.98, 1.72, 1.44, 1.16, 0.87, 0.57, 0.28,
|
|
& 0.1/
|
|
C
|
|
C awpc= potassium chloride
|
|
C
|
|
DATA AWPC/172.62, 165.75, 159.10, 152.67, 146.46, 140.45, 134.64,
|
|
& 129.03, 123.61, 118.38, 113.34, 108.48, 103.79, 99.27,
|
|
& 94.93, 90.74, 86.71, 82.84, 79.11, 75.53, 72.09, 68.79,
|
|
& 65.63, 62.59, 59.68, 56.90, 54.23, 51.68, 49.24, 46.91,
|
|
& 44.68, 42.56, 40.53, 38.60, 36.76, 35.00, 33.33, 31.75,
|
|
& 30.24, 28.81, 27.45, 26.16, 24.94, 23.78, 22.68, 21.64,
|
|
& 20.66, 19.74, 18.86, 18.03, 17.25, 16.51, 15.82, 15.16,
|
|
& 14.54, 13.96, 13.41, 12.89, 12.40, 11.94, 11.50, 11.08,
|
|
& 10.69, 10.32, 9.96, 9.62, 9.30, 8.99, 8.69, 8.40, 8.12,
|
|
& 7.85, 7.59, 7.33, 7.08, 6.83, 6.58, 6.33, 6.08, 5.84,
|
|
& 5.59, 5.34, 5.09, 4.83, 4.57, 4.31, 4.04, 3.76, 3.48,
|
|
& 3.19, 2.90, 2.60, 2.29, 1.98, 1.66, 1.33, 0.99, 0.65,
|
|
& 0.30, 0.1/
|
|
C
|
|
C awps= potassium sulfate
|
|
C
|
|
DATA AWPS/1014.82, 969.72, 926.16, 884.11, 843.54, 804.41, 766.68,
|
|
& 730.32, 695.30, 661.58, 629.14, 597.93, 567.92, 539.09,
|
|
& 511.41, 484.83, 459.34, 434.89, 411.47, 389.04, 367.58,
|
|
& 347.05, 327.43, 308.69, 290.80, 273.73, 257.47, 241.98,
|
|
& 227.24, 213.22, 199.90, 187.26, 175.27, 163.91, 153.15,
|
|
& 142.97, 133.36, 124.28, 115.73, 107.66, 100.08, 92.95,
|
|
& 86.26, 79.99, 74.12, 68.63, 63.50, 58.73, 54.27, 50.14,
|
|
& 46.30, 42.74, 39.44, 36.40, 33.59, 31.00, 28.63, 26.45,
|
|
& 24.45, 22.62, 20.95, 19.43, 18.05, 16.79, 15.64, 14.61,
|
|
& 13.66, 12.81, 12.03, 11.33, 10.68, 10.09, 9.55, 9.06,
|
|
& 8.60, 8.17, 7.76, 7.38, 7.02, 6.66, 6.32, 5.98, 5.65,
|
|
& 5.31, 4.98, 4.64, 4.31, 3.96, 3.62, 3.27, 2.92, 2.57,
|
|
& 2.22, 1.87, 1.53, 1.20, 0.87, 0.57, 0.28, 0.1/
|
|
C
|
|
C awpn= potassium nitrate
|
|
C
|
|
DATA AWPN/44*1000.00, 953.05, 881.09, 813.39,
|
|
& 749.78, 690.09, 634.14, 581.77, 532.83, 487.16, 444.61,
|
|
& 405.02, 368.26, 334.18, 302.64, 273.51, 246.67, 221.97,
|
|
& 199.31, 178.56, 159.60, 142.33, 126.63, 112.40, 99.54,
|
|
& 87.96, 77.55, 68.24, 59.92, 52.53, 45.98, 40.2, 35.11,
|
|
& 30.65, 26.75, 23.35, 20.40, 17.85, 15.63, 13.72, 12.06,
|
|
& 10.61, 9.35, 8.24, 7.25, 6.37, 5.56, 4.82, 4.12, 3.47,
|
|
& 2.86, 2.28, 1.74, 1.24, 0.79, 0.40, 0.1/
|
|
C
|
|
C awpb= potassium bisulfate
|
|
C
|
|
DATA AWPB/10*55.99,
|
|
& 53.79, 51.81, 49.99, 48.31, 46.75, 45.28, 43.91, 42.62, 41.39,
|
|
& 40.22,
|
|
& 39.10, 38.02, 36.99, 36.00, 35.04, 34.11, 33.21, 32.34, 31.49,
|
|
& 30.65,
|
|
& 29.84, 29.04, 28.27, 27.50, 26.75, 26.01, 25.29, 24.57, 23.87,
|
|
& 23.17,
|
|
& 22.49, 21.81, 21.15, 20.49, 19.84, 19.21, 18.58, 17.97, 17.37,
|
|
& 16.77,
|
|
& 16.19, 15.63, 15.08, 14.54, 14.01, 13.51, 13.01, 12.53, 12.07,
|
|
& 11.62,
|
|
& 11.19, 10.77, 10.36, 9.97, 9.59, 9.23, 8.87, 8.53, 8.20,
|
|
& 7.88,
|
|
& 7.57, 7.27, 6.97, 6.69, 6.41, 6.14, 5.88, 5.62, 5.36,
|
|
& 5.11,
|
|
& 4.87, 4.63, 4.39, 4.15, 3.92, 3.68, 3.45, 3.21, 2.98,
|
|
& 2.74,
|
|
& 2.49, 2.24, 1.98, 1.72, 1.44, 1.16, 0.87, 0.57, 0.28,
|
|
& 0.1/
|
|
C
|
|
C awcc= calcium chloride
|
|
C
|
|
DATA AWCC/19.9, 19.0, 18.15, 17.35, 16.6, 15.89, 15.22, 14.58,
|
|
& 13.99, 13.43, 12.90, 12.41, 11.94, 11.50, 11.09, 10.7,
|
|
& 10.34, 9.99, 9.67, 9.37, 9.09, 8.83, 8.57, 8.34, 8.12,
|
|
& 7.91, 7.71, 7.53, 7.35, 7.19, 7.03, 6.88, 6.74, 6.6,
|
|
& 6.47, 6.35, 6.23, 6.12, 6.01, 5.90, 5.80, 5.70, 5.61,
|
|
& 5.51, 5.42, 5.33, 5.24, 5.16, 5.07, 4.99, 4.91, 4.82,
|
|
& 4.74, 4.66, 4.58, 4.50, 4.42, 4.34, 4.26, 4.19, 4.11,
|
|
& 4.03, 3.95, 3.87, 3.79, 3.72, 3.64, 3.56, 3.48, 3.41,
|
|
& 3.33, 3.25, 3.17, 3.09, 3.01, 2.93, 2.85, 2.76, 2.68,
|
|
& 2.59, 2.50, 2.41, 2.32, 2.23, 2.13, 2.03, 1.93, 1.82,
|
|
& 1.71, 1.59, 1.47, 1.35, 1.22, 1.07, 0.93, 0.77, 0.61,
|
|
& 0.44, 0.25, 0.1/
|
|
C
|
|
C awcn= calcium nitrate
|
|
C
|
|
DATA AWCN/32.89, 31.46, 30.12, 28.84, 27.64, 26.51, 25.44, 24.44,
|
|
& 23.49, 22.59, 21.75, 20.96, 20.22, 19.51, 18.85, 18.23,
|
|
& 17.64, 17.09, 16.56, 16.07, 15.61, 15.17, 14.75, 14.36,
|
|
& 13.99, 13.63, 13.3, 12.98, 12.68, 12.39, 12.11, 11.84,
|
|
& 11.59, 11.35, 11.11, 10.88, 10.66, 10.45, 10.24, 10.04,
|
|
& 9.84, 9.65, 9.46, 9.28, 9.1, 8.92, 8.74, 8.57, 8.4,
|
|
& 8.23, 8.06, 7.9, 7.73, 7.57, 7.41, 7.25, 7.1,6.94, 6.79,
|
|
& 6.63, 6.48, 6.33, 6.18, 6.03, 5.89, 5.74, 5.60, 5.46,
|
|
& 5.32, 5.17, 5.04, 4.9, 4.76, 4.62, 4.49, 4.35, 4.22,
|
|
& 4.08, 3.94, 3.80, 3.66, 3.52, 3.38, 3.23, 3.08, 2.93,
|
|
& 2.77, 2.60, 2.43, 2.25, 2.07, 1.87, 1.67, 1.45, 1.22,
|
|
& 0.97, 0.72, 0.44, 0.14, 0.1/
|
|
C
|
|
C awmc= magnesium chloride
|
|
C
|
|
DATA AWMC/11.24, 10.99, 10.74, 10.5, 10.26, 10.03, 9.81, 9.59,
|
|
& 9.38, 9.18, 8.98, 8.79, 8.60, 8.42, 8.25, 8.07, 7.91,
|
|
& 7.75, 7.59, 7.44, 7.29, 7.15, 7.01, 6.88, 6.75, 6.62,
|
|
& 6.5, 6.38, 6.27, 6.16, 6.05, 5.94, 5.85, 5.75, 5.65,
|
|
& 5.56, 5.47, 5.38, 5.30, 5.22, 5.14, 5.06, 4.98, 4.91,
|
|
& 4.84, 4.77, 4.7, 4.63, 4.57, 4.5, 4.44, 4.37, 4.31,
|
|
& 4.25, 4.19, 4.13, 4.07, 4.01, 3.95, 3.89, 3.83, 3.77,
|
|
& 3.71, 3.65, 3.58, 3.52, 3.46, 3.39, 3.33, 3.26, 3.19,
|
|
& 3.12, 3.05, 2.98, 2.9, 2.82, 2.75, 2.67, 2.58, 2.49,
|
|
& 2.41, 2.32, 2.22, 2.13, 2.03, 1.92, 1.82, 1.71, 1.60,
|
|
& 1.48, 1.36, 1.24, 1.11, 0.98, 0.84, 0.70, 0.56, 0.41,
|
|
& 0.25, 0.1/
|
|
C
|
|
C awmn= magnesium nitrate
|
|
C
|
|
DATA AWMN/12.00, 11.84, 11.68, 11.52, 11.36, 11.2, 11.04, 10.88,
|
|
& 10.72, 10.56, 10.40, 10.25, 10.09, 9.93, 9.78, 9.63,
|
|
& 9.47, 9.32, 9.17, 9.02, 8.87, 8.72, 8.58, 8.43, 8.29,
|
|
& 8.15, 8.01, 7.87, 7.73, 7.59, 7.46, 7.33, 7.2, 7.07,
|
|
& 6.94, 6.82, 6.69, 6.57, 6.45, 6.33, 6.21, 6.01, 5.98,
|
|
& 5.87, 5.76, 5.65, 5.55, 5.44, 5.34, 5.24, 5.14, 5.04,
|
|
& 4.94, 4.84, 4.75, 4.66, 4.56, 4.47, 4.38, 4.29, 4.21,
|
|
& 4.12, 4.03, 3.95, 3.86, 3.78, 3.69, 3.61, 3.53, 3.45,
|
|
& 3.36, 3.28, 3.19, 3.11, 3.03, 2.94, 2.85, 2.76, 2.67,
|
|
& 2.58, 2.49, 2.39, 2.3, 2.2, 2.1, 1.99, 1.88, 1.77, 1.66,
|
|
& 1.54, 1.42, 1.29, 1.16, 1.02, 0.88, 0.73, 0.58, 0.42,
|
|
& 0.25, 0.1/
|
|
C
|
|
C awmn= magnesium sulfate
|
|
C
|
|
DATA AWMS/0.93, 2.5, 3.94, 5.25, 6.45, 7.54, 8.52, 9.40, 10.19,
|
|
& 10.89, 11.50, 12.04, 12.51, 12.90, 13.23, 13.50, 13.72,
|
|
& 13.88, 13.99, 14.07, 14.1, 14.09, 14.05, 13.98, 13.88,
|
|
& 13.75, 13.6, 13.43, 13.25, 13.05, 12.83, 12.61, 12.37,
|
|
& 12.13, 11.88, 11.63, 11.37, 11.12, 10.86, 10.60, 10.35,
|
|
& 10.09, 9.85, 9.6, 9.36, 9.13, 8.9, 8.68, 8.47, 8.26,
|
|
& 8.07, 7.87, 7.69, 7.52, 7.35, 7.19, 7.03, 6.89, 6.75,
|
|
& 6.62, 6.49, 6.37, 6.26, 6.15, 6.04, 5.94, 5.84, 5.75,
|
|
& 5.65, 5.56, 5.47, 5.38, 5.29, 5.20, 5.11, 5.01, 4.92,
|
|
& 4.82, 4.71, 4.60, 4.49, 4.36, 4.24, 4.10, 3.96, 3.81,
|
|
& 3.65, 3.48, 3.30, 3.11, 2.92, 2.71, 2.49, 2.26, 2.02,
|
|
& 1.76, 1.50, 1.22, 0.94, 0.64/
|
|
C
|
|
C *** END OF BLOCK DATA SUBPROGRAM *************************************
|
|
C
|
|
END
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE INIT1
|
|
C *** THIS SUBROUTINE INITIALIZES ALL GLOBAL VARIABLES FOR AMMONIUM
|
|
C SULFATE AEROSOL SYSTEMS (SUBROUTINE ISRP1)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE INIT1 (WI, RHI, TEMPI)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: WI, RHI, TEMPI
|
|
DIMENSION WI(NCOMP)
|
|
REAL*8 :: IC,GII,GI0,XX
|
|
REAL*8, PARAMETER :: LN10 = 2.30258509299404568402D0
|
|
C
|
|
C *** SAVE INPUT VARIABLES IN COMMON BLOCK ******************************
|
|
C
|
|
IF (IPROB == 0) THEN ! FORWARD CALCULATION
|
|
DO I=1,NCOMP
|
|
C W(I) = (WI(I), TINY)
|
|
IF (TINY > (WI(I))) THEN
|
|
W(I) = TINY
|
|
ELSE
|
|
W(I) = WI(I)
|
|
ENDIF
|
|
C WB(I) = 0.d0
|
|
ENDDO
|
|
ELSE
|
|
DO I=1,NCOMP ! REVERSE CALCULATION
|
|
C WAER(I) = MAX(WI(I), TINY)
|
|
IF (TINY > (WI(I))) THEN
|
|
WAER(I) = TINY
|
|
ELSE
|
|
WAER(I) = WI(I)
|
|
ENDIF
|
|
W(I) = ZERO
|
|
ENDDO
|
|
ENDIF
|
|
RH = RHI
|
|
TEMP = TEMPI
|
|
C
|
|
C *** CALCULATE EQUILIBRIUM CONSTANTS ***********************************
|
|
C
|
|
XK1 = 1.015d-2 ! HSO4(aq) <==> H(aq) + SO4(aq)
|
|
XK21 = 57.639d0 ! NH3(g) <==> NH3(aq)
|
|
XK22 = 1.805d-5 ! NH3(aq) <==> NH4(aq) + OH(aq)
|
|
XK7 = 1.817d0 ! (NH4)2SO4(s) <==> 2*NH4(aq) + SO4(aq)
|
|
XK12 = 1.382d2 ! NH4HSO4(s) <==> NH4(aq) + HSO4(aq)
|
|
XK13 = 29.268d0 ! (NH4)3H(SO4)2(s) <==> 3*NH4(aq) + HSO4(aq) + SO4(aq)
|
|
XKW = 1.010d-14 ! H2O <==> H(aq) + OH(aq)
|
|
C
|
|
IF (INT(TEMP) /= 298) THEN ! FOR T != 298K or 298.15K
|
|
T0 = 298.15d0
|
|
T0T = T0/TEMP
|
|
COEF= 1.d0+LOG(T0T)-T0T
|
|
XK1 = XK1 *EXP( 8.85d0*(T0T-1.d0) + 25.140d0*COEF)
|
|
XK21= XK21*EXP( 13.79d0*(T0T-1.d0) - 5.393d0*COEF)
|
|
XK22= XK22*EXP( -1.50d0*(T0T-1.d0) + 26.920d0*COEF)
|
|
XK7 = XK7 *EXP( -2.65d0*(T0T-1.d0) + 38.570d0*COEF)
|
|
XK12= XK12*EXP( -2.87d0*(T0T-1.d0) + 15.830d0*COEF)
|
|
XK13= XK13*EXP( -5.19d0*(T0T-1.d0) + 54.400d0*COEF)
|
|
XKW = XKW *EXP(-22.52d0*(T0T-1.d0) + 26.920d0*COEF)
|
|
ENDIF
|
|
XK2 = XK21*XK22
|
|
C
|
|
C *** CALCULATE DELIQUESCENCE RELATIVE HUMIDITIES (UNICOMPONENT) ********
|
|
C
|
|
DRH2SO4 = 0.0000D0
|
|
DRNH42S4 = 0.7997D0
|
|
DRNH4HS4 = 0.4000D0
|
|
DRLC = 0.6900D0
|
|
IF (INT(TEMP) /= 298) THEN
|
|
T0 = 298.15d0
|
|
TCF = 1.d0/TEMP - 1.d0/T0
|
|
DRNH42S4 = DRNH42S4*EXP( 80.d0*TCF)
|
|
DRNH4HS4 = DRNH4HS4*EXP(384.d0*TCF)
|
|
DRLC = DRLC *EXP(186.d0*TCF)
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE MUTUAL DELIQUESCENCE RELATIVE HUMIDITIES ****************
|
|
C
|
|
DRMLCAB = 0.3780D0 ! (NH4)3H(SO4)2 & NH4HSO4
|
|
DRMLCAS = 0.6900D0 ! (NH4)3H(SO4)2 & (NH4)2SO4
|
|
CCC IF (INT(TEMP) /= 298) THEN ! For the time being.
|
|
CCC T0 = 298.15d0
|
|
CCC TCF = 1.0/TEMP - 1.0/T0
|
|
CCC DRMLCAB = DRMLCAB*EXP(507.506*TCF)
|
|
CCC DRMLCAS = DRMLCAS*EXP(133.865*TCF)
|
|
CCC ENDIF
|
|
C
|
|
C *** LIQUID PHASE ******************************************************
|
|
C
|
|
CHNO3 = ZERO
|
|
CHCL = ZERO
|
|
CH2SO4 = ZERO
|
|
COH = ZERO
|
|
WATER = TINY
|
|
C
|
|
DO I=1,NPAIR
|
|
MOLALR(I)=ZERO
|
|
GAMA(I) =0.1d0
|
|
GAMIN(I) =GREAT
|
|
GAMOU(I) =GREAT
|
|
M0(I) =1.d5
|
|
ENDDO
|
|
C
|
|
DO I=1,NPAIR
|
|
GAMA(I) = 0.1d0
|
|
ENDDO
|
|
C
|
|
DO I=1,NIONS
|
|
C MOLALB(I) = 0.d0
|
|
MOLAL(I)=ZERO
|
|
ENDDO
|
|
COH = ZERO
|
|
C
|
|
DO I=1,NGASAQ
|
|
GASAQ(I)=ZERO
|
|
ENDDO
|
|
C
|
|
C *** SOLID PHASE *******************************************************
|
|
C
|
|
CNH42S4= ZERO
|
|
CNH4HS4= ZERO
|
|
CNACL = ZERO
|
|
CNA2SO4= ZERO
|
|
CNANO3 = ZERO
|
|
CNH4NO3= ZERO
|
|
CNH4CL = ZERO
|
|
CNAHSO4= ZERO
|
|
CLC = ZERO
|
|
CCASO4 = ZERO
|
|
CCANO32= ZERO
|
|
CCACL2 = ZERO
|
|
CK2SO4 = ZERO
|
|
CKHSO4 = ZERO
|
|
CKNO3 = ZERO
|
|
CKCL = ZERO
|
|
CMGSO4 = ZERO
|
|
CMGNO32= ZERO
|
|
CMGCL2 = ZERO
|
|
C
|
|
C *** GAS PHASE *********************************************************
|
|
C
|
|
GNH3 = ZERO
|
|
GHNO3 = ZERO
|
|
GHCL = ZERO
|
|
C
|
|
C *** CALCULATE ZSR PARAMETERS ******************************************
|
|
C
|
|
IRH = MIN (INT(RH*NZSR+0.5d0),NZSR) ! Position in ZSR arrays
|
|
IRH = MAX (IRH, 1)
|
|
C
|
|
C M0(01) = AWSC(IRH) ! NACl
|
|
C IF (M0(01) < 100.0) THEN
|
|
C IC = M0(01)
|
|
C CALL KMTAB(IC,298.0, GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(01) = M0(01)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
C M0(02) = AWSS(IRH) ! (NA)2SO4
|
|
C IF (M0(02) < 100.0) THEN
|
|
C IC = 3.0*M0(02)
|
|
C CALL KMTAB(IC,298.0, XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(02) = M0(02)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
C M0(03) = AWSN(IRH) ! NANO3
|
|
C IF (M0(03) < 100.0) THEN
|
|
C IC = M0(03)
|
|
C CALL KMTAB(IC,298.0, XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(03) = M0(03)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(04) = AWAS(IRH) ! (NH4)2SO4
|
|
C IF (M0(04) < 100.0) THEN
|
|
C IC = 3.0*M0(04)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(04) = M0(04)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
C M0(05) = AWAN(IRH) ! NH4NO3
|
|
C IF (M0(05) < 100.0) THEN
|
|
C IC = M0(05)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(05) = M0(05)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
C M0(06) = AWAC(IRH) ! NH4CL
|
|
C IF (M0(06) < 100.0) THEN
|
|
C IC = M0(06)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX)
|
|
C M0(06) = M0(06)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(07) = AWSA(IRH) ! 2H-SO4
|
|
C IF (M0(07) < 100.0) THEN
|
|
C IC = 3.0*M0(07)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX)
|
|
C M0(07) = M0(07)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(08) = AWSA(IRH) ! H-HSO4
|
|
CCC IF (M0(08) < 100.0) THEN ! These are redundant, because M0(8) is not used
|
|
CCC IC = M0(08)
|
|
CCC CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX)
|
|
CCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX)
|
|
CCCCCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX)
|
|
CCC M0(08) = M0(08)*EXP(LN10*(GI0-GII))
|
|
CCC ENDIF
|
|
C
|
|
M0(09) = AWAB(IRH) ! NH4HSO4
|
|
C IF (M0(09) < 100.0) THEN
|
|
C IC = M0(09)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX)
|
|
C M0(09) = M0(09)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
C M0(12) = AWSB(IRH) ! NAHSO4
|
|
C IF (M0(12) < 100.0) THEN
|
|
C IC = M0(12)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GI0)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GII)
|
|
C M0(12) = M0(12)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(13) = AWLC(IRH) ! (NH4)3H(SO4)2
|
|
C IF (M0(13) < 100.0) THEN
|
|
C IC = 4.0*M0(13)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX)
|
|
C G130 = 0.2*(3.0*GI0+2.0*GII)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX)
|
|
C G13I = 0.2*(3.0*GI0+2.0*GII)
|
|
C M0(13) = M0(13)*EXP(LN10*SNGL(G130-G13I))
|
|
C ENDIF
|
|
C
|
|
C *** OTHER INITIALIZATIONS *********************************************
|
|
C
|
|
ICLACT = 0
|
|
CALAOU = .TRUE.
|
|
CALAIN = .TRUE.
|
|
FRST = .TRUE.
|
|
SCASE = 'XX'
|
|
SULRATW = 2.D0
|
|
SODRAT = ZERO
|
|
CRNARAT = ZERO
|
|
CRRAT = ZERO
|
|
NOFER = 0
|
|
STKOFL =.FALSE.
|
|
DO I=1,NERRMX
|
|
ERRSTK(I) =-999
|
|
ERRMSG(I) = 'MESSAGE N/A'
|
|
ENDDO
|
|
C
|
|
C *** END OF SUBROUTINE INIT1 *******************************************
|
|
C
|
|
END
|
|
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE INIT2
|
|
C *** THIS SUBROUTINE INITIALIZES ALL GLOBAL VARIABLES FOR AMMONIUM,
|
|
C NITRATE, SULFATE AEROSOL SYSTEMS (SUBROUTINE ISRP2)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE INIT2 (WI, RHI, TEMPI)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: WI, RHI, TEMPI
|
|
DIMENSION WI(NCOMP)
|
|
LOGICAL FLAGNP
|
|
REAL*8 :: IC,GII,GI0,XX
|
|
REAL*8, PARAMETER :: LN10 = 2.30258509299404568402D0
|
|
C
|
|
C *** SAVE INPUT VARIABLES IN COMMON BLOCK ******************************
|
|
C
|
|
! IF (IPROB == 0) THEN ! FORWARD CALCULATION
|
|
DO I=1,NCOMP
|
|
C W(I) = (WI(I), TINY)
|
|
IF (TINY > (WI(I))) THEN
|
|
W(I) = ZERO! TINY
|
|
ELSE
|
|
W(I) = WI(I)
|
|
ENDIF
|
|
C WB(I) = ZERO
|
|
ENDDO
|
|
! ELSE
|
|
! DO I=1,NCOMP ! REVERSE CALCULATION
|
|
C WAER(I) = MAX(WI(I), TINY)
|
|
! IF (TINY > (WI(I))) THEN
|
|
! WAER(I) = TINY
|
|
! ELSE
|
|
! WAER(I) = WI(I)
|
|
! ENDIF
|
|
! W(I) = ZERO
|
|
! ENDDO
|
|
! ENDIF
|
|
RH = RHI
|
|
TEMP = TEMPI
|
|
C
|
|
C *** CALCULATE EQUILIBRIUM CONSTANTS ***********************************
|
|
C
|
|
XK1 = 1.015d-2 ! HSO4(aq) <==> H(aq) + SO4(aq)
|
|
XK21 = 57.639d0 ! NH3(g) <==> NH3(aq)
|
|
XK22 = 1.805d-5 ! NH3(aq) <==> NH4(aq) + OH(aq)
|
|
XK4 = 2.511d6 ! HNO3(g) <==> H(aq) + NO3(aq) ! ISORR
|
|
CCC XK4 = 3.638e6 ! HNO3(g) <==> H(aq) + NO3(aq) ! SEQUIL
|
|
XK41 = 2.100d5 ! HNO3(g) <==> HNO3(aq)
|
|
XK7 = 1.817d0 ! (NH4)2SO4(s) <==> 2*NH4(aq) + SO4(aq)
|
|
XK10 = 5.746d-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! ISORR
|
|
CCC XK10 = 2.985e-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! SEQUIL
|
|
XK12 = 1.382d2 ! NH4HSO4(s) <==> NH4(aq) + HSO4(aq)
|
|
XK13 = 29.268d0 ! (NH4)3H(SO4)2(s) <==> 3*NH4(aq) + HSO4(aq) + SO4(aq)
|
|
XKW = 1.010d-14 ! H2O <==> H(aq) + OH(aq)
|
|
C
|
|
IF (INT(TEMP) /= 298) THEN ! FOR T != 298K or 298.15K
|
|
T0 = 298.15D0
|
|
T0T = T0/TEMP
|
|
COEF= 1.0+LOG(T0T)-T0T
|
|
XK1 = XK1 *EXP( 8.85d0*(T0T-1.d0) + 25.140d0*COEF)
|
|
XK21= XK21*EXP( 13.79d0*(T0T-1.d0) - 5.393d0*COEF)
|
|
XK22= XK22*EXP( -1.50d0*(T0T-1.d0) + 26.920d0*COEF)
|
|
XK4 = XK4 *EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF) !ISORR
|
|
CCC XK4 = XK4 *EXP( 29.47d0*(T0T-1.d0) + 16.840d0*COEF) ! SEQUIL
|
|
XK41= XK41*EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF)
|
|
XK7 = XK7 *EXP( -2.65d0*(T0T-1.d0) + 38.570d0*COEF)
|
|
XK10= XK10*EXP(-74.38d0*(T0T-1.d0) + 6.120d0*COEF) ! ISORR
|
|
CCC XK10= XK10*EXP(-75.11d0*(T0T-1.d0) + 13.460d0*COEF) ! SEQUIL
|
|
XK12= XK12*EXP( -2.87d0*(T0T-1.d0) + 15.830d0*COEF)
|
|
XK13= XK13*EXP( -5.19d0*(T0T-1.d0) + 54.400d0*COEF)
|
|
XKW = XKW *EXP(-22.52d0*(T0T-1.d0) + 26.920d0*COEF)
|
|
ENDIF
|
|
XK2 = XK21*XK22
|
|
XK42 = XK4/XK41
|
|
C
|
|
C *** CALCULATE DELIQUESCENCE RELATIVE HUMIDITIES (UNICOMPONENT) ********
|
|
C
|
|
DRH2SO4 = ZERO
|
|
DRNH42S4 = 0.7997D0
|
|
DRNH4HS4 = 0.4000D0
|
|
DRNH4NO3 = 0.6183D0
|
|
DRLC = 0.6900D0
|
|
IF (INT(TEMP) /= 298) THEN
|
|
T0 = 298.15D0
|
|
TCF = 1.0d0/TEMP - 1.0d0/T0
|
|
DRNH4NO3 = DRNH4NO3*EXP(852.d0*TCF)
|
|
DRNH42S4 = DRNH42S4*EXP( 80.d0*TCF)
|
|
DRNH4HS4 = DRNH4HS4*EXP(384.d0*TCF)
|
|
DRLC = DRLC *EXP(186.d0*TCF)
|
|
DRNH4NO3 = MIN ((DRNH4NO3),(DRNH42S4)) ! ADJUST FOR DRH CROSSOVER AT T<271K
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE MUTUAL DELIQUESCENCE RELATIVE HUMIDITIES ****************
|
|
C
|
|
DRMLCAB = 0.3780D0 ! (NH4)3H(SO4)2 & NH4HSO4
|
|
DRMLCAS = 0.6900D0 ! (NH4)3H(SO4)2 & (NH4)2SO4
|
|
DRMASAN = 0.6000D0 ! (NH4)2SO4 & NH4NO3
|
|
CCC IF (INT(TEMP) /= 298) THEN ! For the time being
|
|
CCC T0 = 298.15d0
|
|
CCC TCF = 1.0/TEMP - 1.0/T0
|
|
CCC DRMLCAB = DRMLCAB*EXP( 507.506*TCF)
|
|
CCC DRMLCAS = DRMLCAS*EXP( 133.865*TCF)
|
|
CCC DRMASAN = DRMASAN*EXP(1269.068*TCF)
|
|
CCC ENDIF
|
|
C
|
|
C *** LIQUID PHASE ******************************************************
|
|
C
|
|
CHNO3 = ZERO
|
|
CHCL = ZERO
|
|
CH2SO4 = ZERO
|
|
COH = ZERO
|
|
WATER = TINY
|
|
C
|
|
DO I=1,NPAIR
|
|
MOLALR(I)=ZERO
|
|
GAMA(I) = 0.1D0
|
|
GAMIN(I) = 1.D10 ! GREAT
|
|
GAMOU(I) = 1.D10 !GREAT
|
|
M0(I) = 1d5
|
|
ENDDO
|
|
C
|
|
DO I=1,NPAIR
|
|
GAMA(I) = 0.1d0
|
|
ENDDO
|
|
C
|
|
DO I=1,NIONS
|
|
MOLAL(I)=ZERO
|
|
ENDDO
|
|
COH = ZERO
|
|
C
|
|
DO I=1,NGASAQ
|
|
GASAQ(I)=ZERO
|
|
ENDDO
|
|
C
|
|
C *** SOLID PHASE ******************************************************
|
|
C
|
|
CNH42S4= ZERO
|
|
CNH4HS4= ZERO
|
|
CNACL = ZERO
|
|
CNA2SO4= ZERO
|
|
CNANO3 = ZERO
|
|
CNH4NO3= ZERO
|
|
CNH4CL = ZERO
|
|
CNAHSO4= ZERO
|
|
CLC = ZERO
|
|
CCASO4 = ZERO
|
|
CCANO32= ZERO
|
|
CCACL2 = ZERO
|
|
CK2SO4 = ZERO
|
|
CKHSO4 = ZERO
|
|
CKNO3 = ZERO
|
|
CKCL = ZERO
|
|
CMGSO4 = ZERO
|
|
CMGNO32= ZERO
|
|
CMGCL2 = ZERO
|
|
C
|
|
C *** GAS PHASE *********************************************************
|
|
C
|
|
GNH3 = ZERO
|
|
GHNO3 = ZERO
|
|
GHCL = ZERO
|
|
C
|
|
C *** CALCULATE ZSR PARAMETERS ******************************************
|
|
C
|
|
IRH = MIN (INT(RH*NZSR+0.5d0),NZSR) ! Position in ZSR arrays
|
|
IRH = MAX (IRH, 1)
|
|
C
|
|
C M0(01) = AWSC(IRH) ! NACl
|
|
C IF (M0(01) < 100.0) THEN
|
|
C IC = M0(01)
|
|
C CALL KMTAB(IC,298.0, GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(01) = M0(01)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
C M0(02) = AWSS(IRH) ! (NA)2SO4
|
|
C IF (M0(02) < 100.0) THEN
|
|
C IC = 3.0*M0(02)
|
|
C CALL KMTAB(IC,298.0, XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(02) = M0(02)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
C M0(03) = AWSN(IRH) ! NANO3
|
|
C IF (M0(03) < 100.0) THEN
|
|
C IC = M0(03)
|
|
C CALL KMTAB(IC,298.0, XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(03) = M0(03)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(04) = AWAS(IRH) ! (NH4)2SO4
|
|
C IF (M0(04) < 100.0) THEN
|
|
C IC = 3.0*M0(04)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(04) = M0(04)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(05) = AWAN(IRH) ! NH4NO3
|
|
C IF (M0(05) < 100.0) THEN
|
|
C IC = M0(05)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(05) = M0(05)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
C M0(06) = AWAC(IRH) ! NH4CL
|
|
C IF (M0(06) < 100.0) THEN
|
|
C IC = M0(06)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX)
|
|
C M0(06) = M0(06)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(07) = AWSA(IRH) ! 2H-SO4
|
|
C IF (M0(07) < 100.0) THEN
|
|
C IC = 3.0*M0(07)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX)
|
|
C M0(07) = M0(07)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(08) = AWSA(IRH) ! H-HSO4
|
|
CCC IF (M0(08) < 100.0) THEN ! These are redundant, because M0(8) is not used
|
|
CCC IC = M0(08)
|
|
CCC CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX)
|
|
CCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX)
|
|
CCCCCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX)
|
|
CCC M0(08) = M0(08)*EXP(LN10*(GI0-GII))
|
|
CCC ENDIF
|
|
C
|
|
M0(09) = AWAB(IRH) ! NH4HSO4
|
|
C IF (M0(09) < 100.0) THEN
|
|
C IC = M0(09)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX)
|
|
C M0(09) = M0(09)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
C M0(12) = AWSB(IRH) ! NAHSO4
|
|
C IF (M0(12) < 100.0) THEN
|
|
C IC = M0(12)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GI0)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GII)
|
|
C M0(12) = M0(12)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(13) = AWLC(IRH) ! (NH4)3H(SO4)2
|
|
C IF (M0(13) < 100.0) THEN
|
|
C IC = 4.0*M0(13)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX)
|
|
C G130 = 0.2*(3.0*GI0+2.0*GII)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX)
|
|
C G13I = 0.2*(3.0*GI0+2.0*GII)
|
|
C M0(13) = M0(13)*EXP(LN10*SNGL(G130-G13I))
|
|
C ENDIF
|
|
C
|
|
C *** OTHER INITIALIZATIONS *********************************************
|
|
C
|
|
ICLACT = 0
|
|
CALAOU = .TRUE.
|
|
CALAIN = .TRUE.
|
|
FRST = .TRUE.
|
|
FLAGNP = .FALSE.
|
|
NONPHYS = .FALSE.
|
|
SCASE = 'XX'
|
|
SULRATW = 2.D0
|
|
SODRAT = ZERO
|
|
CRNARAT = ZERO
|
|
CRRAT = ZERO
|
|
NOFER = 0
|
|
STKOFL =.FALSE.
|
|
DO I=1,NERRMX
|
|
ERRSTK(I) =-999
|
|
ERRMSG(I) = 'MESSAGE N/A'
|
|
ENDDO
|
|
C
|
|
C *** END OF SUBROUTINE INIT2 *******************************************
|
|
C
|
|
END
|
|
|
|
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ISOINIT3
|
|
C *** THIS SUBROUTINE INITIALIZES ALL GLOBAL VARIABLES FOR AMMONIUM,
|
|
C SODIUM, CHLORIDE, NITRATE, SULFATE AEROSOL SYSTEMS (SUBROUTINE
|
|
C ISRP3)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISOINIT3 (WI, RHI, TEMPI)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: WI(NCOMP), RHI, TEMPI
|
|
REAL*8 :: IC,GII,GI0,XX
|
|
REAL*8, PARAMETER :: LN10 = 2.30258509299404568402D0
|
|
C
|
|
C *** SAVE INPUT VARIABLES IN COMMON BLOCK ******************************
|
|
C
|
|
! IF (IPROB == 0) THEN ! FORWARD CALCULATION
|
|
DO I=1,NCOMP
|
|
C W(I) = (WI(I), TINY)
|
|
IF (TINY > (WI(I))) THEN
|
|
W(I) = TINY
|
|
ELSE
|
|
W(I) = WI(I)
|
|
ENDIF
|
|
ENDDO
|
|
! ELSE
|
|
! DO I=1,NCOMP ! REVERSE CALCULATION
|
|
C WAER(I) = MAX(WI(I), TINY)
|
|
! IF (TINY > (WI(I))) THEN
|
|
! WAER(I) = TINY
|
|
! ELSE
|
|
! WAER(I) = WI(I)
|
|
! ENDIF
|
|
! W(I) = ZERO
|
|
! ENDDO
|
|
! ENDIF
|
|
RH = RHI
|
|
TEMP = TEMPI
|
|
C
|
|
C *** CALCULATE EQUILIBRIUM CONSTANTS ***********************************
|
|
C
|
|
XK1 = 1.015D-2 ! HSO4(aq) <==> H(aq) + SO4(aq)
|
|
XK21 = 57.639D0 ! NH3(g) <==> NH3(aq)
|
|
XK22 = 1.805D-5 ! NH3(aq) <==> NH4(aq) + OH(aq)
|
|
XK3 = 1.971D6 ! HCL(g) <==> H(aq) + CL(aq)
|
|
XK31 = 2.500d3 ! HCL(g) <==> HCL(aq)
|
|
XK4 = 2.511d6 ! HNO3(g) <==> H(aq) + NO3(aq) ! ISORR
|
|
CCC XK4 = 3.638e6 ! HNO3(g) <==> H(aq) + NO3(aq) ! SEQUIL
|
|
XK41 = 2.100d5 ! HNO3(g) <==> HNO3(aq)
|
|
XK5 = 0.4799D0 ! NA2SO4(s) <==> 2*NA(aq) + SO4(aq)
|
|
XK6 = 1.086D-16 ! NH4CL(s) <==> NH3(g) + HCL(g)
|
|
XK7 = 1.817D0 ! (NH4)2SO4(s) <==> 2*NH4(aq) + SO4(aq)
|
|
XK8 = 37.661D0 ! NACL(s) <==> NA(aq) + CL(aq)
|
|
XK10 = 5.746D-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! ISORR
|
|
CCC XK10 = 2.985e-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! SEQUIL
|
|
XK11 = 2.413D4 ! NAHSO4(s) <==> NA(aq) + HSO4(aq)
|
|
XK12 = 1.382D2 ! NH4HSO4(s) <==> NH4(aq) + HSO4(aq)
|
|
XK13 = 29.268D0 ! (NH4)3H(SO4)2(s) <==> 3*NH4(aq) + HSO4(aq) + SO4(aq)
|
|
XK14 = 22.05D0 ! NH4CL(s) <==> NH4(aq) + CL(aq)
|
|
XKW = 1.010D-14 ! H2O <==> H(aq) + OH(aq)
|
|
XK9 = 11.977D0 ! NANO3(s) <==> NA(aq) + NO3(aq)
|
|
C
|
|
IF (INT(TEMP) /= 298) THEN ! FOR T != 298K or 298.15K
|
|
T0 = 298.15D0
|
|
T0T = T0/TEMP
|
|
COEF= 1.d0+LOG(T0T)-T0T
|
|
XK1 = XK1 *EXP( 8.85d0*(T0T-1.d0) + 25.140d0*COEF)
|
|
XK21= XK21*EXP( 13.79d0*(T0T-1.d0) - 5.393d0*COEF)
|
|
XK22= XK22*EXP( -1.50d0*(T0T-1.d0) + 26.920d0*COEF)
|
|
XK3 = XK3 *EXP( 30.20d0*(T0T-1.d0) + 19.910d0*COEF)
|
|
XK31= XK31*EXP( 30.20d0*(T0T-1.d0) + 19.910d0*COEF)
|
|
XK4 = XK4 *EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF) !ISORR
|
|
CCC XK4 = XK4 *EXP( 29.47*(T0T-1.d0) + 16.840d0*COEF) ! SEQUIL
|
|
XK41= XK41*EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF)
|
|
XK5 = XK5 *EXP( 0.98d0*(T0T-1.d0) + 39.500d0*COEF)
|
|
XK6 = XK6 *EXP(-71.00d0*(T0T-1.d0) + 2.400d0*COEF)
|
|
XK7 = XK7 *EXP( -2.65d0*(T0T-1.d0) + 38.570d0*COEF)
|
|
XK8 = XK8 *EXP( -1.56d0*(T0T-1.d0) + 16.900d0*COEF)
|
|
XK9 = XK9 *EXP( -8.22d0*(T0T-1.d0) + 16.010d0*COEF)
|
|
XK10= XK10*EXP(-74.38d0*(T0T-1.d0) + 6.120d0*COEF) ! ISORR
|
|
CCC XK10= XK10*EXP(-75.11*(T0T-1.d0) + 13.460d0*COEF) ! SEQUIL
|
|
XK11= XK11*EXP( 0.79d0*(T0T-1.d0) + 14.746d0*COEF)
|
|
XK12= XK12*EXP( -2.87d0*(T0T-1.d0) + 15.830d0*COEF)
|
|
XK13= XK13*EXP( -5.19d0*(T0T-1.d0) + 54.400d0*COEF)
|
|
XK14= XK14*EXP( 24.55d0*(T0T-1.d0) + 16.900d0*COEF)
|
|
XKW = XKW *EXP(-22.52d0*(T0T-1.d0) + 26.920d0*COEF)
|
|
ENDIF
|
|
XK2 = XK21*XK22
|
|
XK42 = XK4/XK41
|
|
XK32 = XK3/XK31
|
|
C
|
|
C *** CALCULATE DELIQUESCENCE RELATIVE HUMIDITIES (UNICOMPONENT) ********
|
|
C
|
|
DRH2SO4 = ZERO
|
|
DRNH42S4 = 0.7997D0
|
|
DRNH4HS4 = 0.4000D0
|
|
DRLC = 0.6900D0
|
|
DRNACL = 0.7528D0
|
|
DRNANO3 = 0.7379D0
|
|
DRNH4CL = 0.7710D0
|
|
DRNH4NO3 = 0.6183D0
|
|
DRNA2SO4 = 0.9300D0
|
|
DRNAHSO4 = 0.5200D0
|
|
IF (INT(TEMP) /= 298) THEN
|
|
T0 = 298.15D0
|
|
TCF = 1.d0/TEMP - 1.d0/T0
|
|
DRNACL = DRNACL *EXP( 25.d0*TCF)
|
|
DRNANO3 = DRNANO3 *EXP(304.d0*TCF)
|
|
DRNA2SO4 = DRNA2SO4*EXP( 80.d0*TCF)
|
|
DRNH4NO3 = DRNH4NO3*EXP(852.d0*TCF)
|
|
DRNH42S4 = DRNH42S4*EXP( 80.d0*TCF)
|
|
DRNH4HS4 = DRNH4HS4*EXP(384.d0*TCF)
|
|
DRLC = DRLC *EXP(186.d0*TCF)
|
|
DRNH4CL = DRNH4Cl *EXP(239.d0*TCF)
|
|
DRNAHSO4 = DRNAHSO4*EXP(-45.d0*TCF)
|
|
C
|
|
C *** ADJUST FOR DRH "CROSSOVER" AT LOW TEMPERATURES
|
|
C
|
|
C DRNH4NO3 = MIN (DRNH4NO3, DRNH4CL, DRNH42S4, DRNANO3, DRNACL) slc.1.2011 due to TAPENADE's FORTRAN parser
|
|
DRNH42S4 = MIN (DRNH42S4, DRNANO3, DRNACL) ! slc.1.2011 due to TAPENADE's FORTRAN parser
|
|
DRNH4NO3 = MIN (DRNH4NO3, DRNH4CL, DRNH42S4) ! slc.1.2011 due to TAPENADE's FORTRAN parser
|
|
DRNANO3 = MIN (DRNANO3, DRNACL)
|
|
DRNH4CL = MIN (DRNH4Cl, DRNH42S4)
|
|
C
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE MUTUAL DELIQUESCENCE RELATIVE HUMIDITIES ****************
|
|
C
|
|
DRMLCAB = 0.378D0 ! (NH4)3H(SO4)2 & NH4HSO4
|
|
DRMLCAS = 0.690D0 ! (NH4)3H(SO4)2 & (NH4)2SO4
|
|
DRMASAN = 0.600D0 ! (NH4)2SO4 & NH4NO3
|
|
DRMG1 = 0.460D0 ! (NH4)2SO4, NH4NO3, NA2SO4, NH4CL
|
|
DRMG2 = 0.691D0 ! (NH4)2SO4, NA2SO4, NH4CL
|
|
DRMG3 = 0.697D0 ! (NH4)2SO4, NA2SO4
|
|
DRMH1 = 0.240D0 ! NA2SO4, NANO3, NACL, NH4NO3, NH4CL
|
|
DRMH2 = 0.596D0 ! NA2SO4, NANO3, NACL, NH4CL
|
|
DRMI1 = 0.240D0 ! LC, NAHSO4, NH4HSO4, NA2SO4, (NH4)2SO4
|
|
DRMI2 = 0.363D0 ! LC, NAHSO4, NA2SO4, (NH4)2SO4 - NO DATA -
|
|
DRMI3 = 0.610D0 ! LC, NA2SO4, (NH4)2SO4
|
|
DRMQ1 = 0.494D0 ! (NH4)2SO4, NH4NO3, NA2SO4
|
|
DRMR1 = 0.663D0 ! NA2SO4, NANO3, NACL
|
|
DRMR2 = 0.735D0 ! NA2SO4, NACL
|
|
DRMR3 = 0.673D0 ! NANO3, NACL
|
|
DRMR4 = 0.694D0 ! NA2SO4, NACL, NH4CL
|
|
DRMR5 = 0.731D0 ! NA2SO4, NH4CL
|
|
DRMR6 = 0.596D0 ! NA2SO4, NANO3, NH4CL
|
|
DRMR7 = 0.380D0 ! NA2SO4, NANO3, NACL, NH4NO3
|
|
DRMR8 = 0.380D0 ! NA2SO4, NACL, NH4NO3
|
|
DRMR9 = 0.494D0 ! NA2SO4, NH4NO3
|
|
DRMR10 = 0.476D0 ! NA2SO4, NANO3, NH4NO3
|
|
DRMR11 = 0.340D0 ! NA2SO4, NACL, NH4NO3, NH4CL
|
|
DRMR12 = 0.460D0 ! NA2SO4, NH4NO3, NH4CL
|
|
DRMR13 = 0.438D0 ! NA2SO4, NANO3, NH4NO3, NH4CL
|
|
CCC IF (INT(TEMP) /= 298) THEN
|
|
CCC T0 = 298.15d0
|
|
CCC TCF = 1.0/TEMP - 1.0/T0
|
|
CCC DRMLCAB = DRMLCAB*EXP( 507.506*TCF)
|
|
CCC DRMLCAS = DRMLCAS*EXP( 133.865*TCF)
|
|
CCC DRMASAN = DRMASAN*EXP(1269.068*TCF)
|
|
CCC DRMG1 = DRMG1 *EXP( 572.207*TCF)
|
|
CCC DRMG2 = DRMG2 *EXP( 58.166*TCF)
|
|
CCC DRMG3 = DRMG3 *EXP( 22.253*TCF)
|
|
CCC DRMH1 = DRMH1 *EXP(2116.542*TCF)
|
|
CCC DRMH2 = DRMH2 *EXP( 650.549*TCF)
|
|
CCC DRMI1 = DRMI1 *EXP( 565.743*TCF)
|
|
CCC DRMI2 = DRMI2 *EXP( 91.745*TCF)
|
|
CCC DRMI3 = DRMI3 *EXP( 161.272*TCF)
|
|
CCC DRMQ1 = DRMQ1 *EXP(1616.621*TCF)
|
|
CCC DRMR1 = DRMR1 *EXP( 292.564*TCF)
|
|
CCC DRMR2 = DRMR2 *EXP( 14.587*TCF)
|
|
CCC DRMR3 = DRMR3 *EXP( 307.907*TCF)
|
|
CCC DRMR4 = DRMR4 *EXP( 97.605*TCF)
|
|
CCC DRMR5 = DRMR5 *EXP( 98.523*TCF)
|
|
CCC DRMR6 = DRMR6 *EXP( 465.500*TCF)
|
|
CCC DRMR7 = DRMR7 *EXP( 324.425*TCF)
|
|
CCC DRMR8 = DRMR8 *EXP(2660.184*TCF)
|
|
CCC DRMR9 = DRMR9 *EXP(1617.178*TCF)
|
|
CCC DRMR10 = DRMR10 *EXP(1745.226*TCF)
|
|
CCC DRMR11 = DRMR11 *EXP(3691.328*TCF)
|
|
CCC DRMR12 = DRMR12 *EXP(1836.842*TCF)
|
|
CCC DRMR13 = DRMR13 *EXP(1967.938*TCF)
|
|
CCC ENDIF
|
|
C
|
|
C *** LIQUID PHASE ******************************************************
|
|
C
|
|
CHNO3 = ZERO
|
|
CHCL = ZERO
|
|
CH2SO4 = ZERO
|
|
COH = ZERO
|
|
WATER = TINY
|
|
C
|
|
DO I=1,NPAIR
|
|
MOLALR(I)=ZERO
|
|
C MOLALRB(I) = ZERO
|
|
GAMA(I) =0.1d0
|
|
GAMIN(I) =GREAT
|
|
GAMOU(I) =GREAT
|
|
M0(I) =1d5
|
|
ENDDO
|
|
C
|
|
DO I=1,NPAIR
|
|
GAMA(I) = 0.1d0
|
|
ENDDO
|
|
C
|
|
DO I=1,NIONS
|
|
MOLAL(I)=ZERO
|
|
ENDDO
|
|
COH = ZERO
|
|
C
|
|
DO I=1,NGASAQ
|
|
GASAQ(I)=ZERO
|
|
ENDDO
|
|
C
|
|
C *** SOLID PHASE *******************************************************
|
|
C
|
|
CNH42S4= ZERO
|
|
CNH4HS4= ZERO
|
|
CNACL = ZERO
|
|
CNA2SO4= ZERO
|
|
CNANO3 = ZERO
|
|
CNH4NO3= ZERO
|
|
CNH4CL = ZERO
|
|
CNAHSO4= ZERO
|
|
CLC = ZERO
|
|
CCASO4 = ZERO
|
|
CCANO32= ZERO
|
|
CCACL2 = ZERO
|
|
CK2SO4 = ZERO
|
|
CKHSO4 = ZERO
|
|
CKNO3 = ZERO
|
|
CKCL = ZERO
|
|
CMGSO4 = ZERO
|
|
CMGNO32= ZERO
|
|
CMGCL2 = ZERO
|
|
C
|
|
C *** GAS PHASE *********************************************************
|
|
C
|
|
GNH3 = ZERO
|
|
GHNO3 = ZERO
|
|
GHCL = ZERO
|
|
C
|
|
C *** CALCULATE ZSR PARAMETERS ******************************************
|
|
C
|
|
IRH = MIN (INT(RH*NZSR+0.5d0),NZSR) ! Position in ZSR arrays
|
|
IRH = MAX (IRH, 1)
|
|
C
|
|
M0(01) = AWSC(IRH) ! NACl
|
|
C IF (M0(01) < 100.0) THEN
|
|
C IC = M0(01)
|
|
C CALL KMTAB(IC,298.0, GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(01) = M0(01)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(02) = AWSS(IRH) ! (NA)2SO4
|
|
C IF (M0(02) < 100.0) THEN
|
|
C IC = 3.0*M0(02)
|
|
C CALL KMTAB(IC,298.0, XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(02) = M0(02)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(03) = AWSN(IRH) ! NANO3
|
|
C IF (M0(03) < 100.0) THEN
|
|
C IC = M0(03)
|
|
C CALL KMTAB(IC,298.0, XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(03) = M0(03)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(04) = AWAS(IRH) ! (NH4)2SO4
|
|
C IF (M0(04) < 100.0) THEN
|
|
C IC = 3.0*M0(04)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(04) = M0(04)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(05) = AWAN(IRH) ! NH4NO3
|
|
C IF (M0(05) < 100.0) THEN
|
|
C IC = M0(05)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(05) = M0(05)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(06) = AWAC(IRH) ! NH4CL
|
|
C IF (M0(06) < 100.0) THEN
|
|
C IC = M0(06)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX)
|
|
C M0(06) = M0(06)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(07) = AWSA(IRH) ! 2H-SO4
|
|
C IF (M0(07) < 100.0) THEN
|
|
C IC = 3.0*M0(07)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX)
|
|
C M0(07) = M0(07)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(08) = AWSA(IRH) ! H-HSO4
|
|
CCC IF (M0(08) < 100.0) THEN ! These are redundant, because M0(8) is not used
|
|
CCC IC = M0(08)
|
|
CCC CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX)
|
|
CCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX)
|
|
CCCCCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX)
|
|
CCC M0(08) = M0(08)*EXP(LN10*(GI0-GII))
|
|
CCC ENDIF
|
|
C
|
|
M0(09) = AWAB(IRH) ! NH4HSO4
|
|
C IF (M0(09) < 100.0) THEN
|
|
C IC = M0(09)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX)
|
|
C M0(09) = M0(09)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(12) = AWSB(IRH) ! NAHSO4
|
|
C IF (M0(12) < 100.0) THEN
|
|
C IC = M0(12)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GI0)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GII)
|
|
C M0(12) = M0(12)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(13) = AWLC(IRH) ! (NH4)3H(SO4)2
|
|
C IF (M0(13) < 100.0) THEN
|
|
C IC = 4.0*M0(13)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX)
|
|
C G130 = 0.2*(3.0*GI0+2.0*GII)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX)
|
|
C G13I = 0.2*(3.0*GI0+2.0*GII)
|
|
C M0(13) = M0(13)*EXP(LN10*SNGL(G130-G13I))
|
|
C ENDIF
|
|
C
|
|
C *** OTHER INITIALIZATIONS *********************************************
|
|
C
|
|
ICLACT = 0
|
|
CALAOU = .TRUE.
|
|
CALAIN = .TRUE.
|
|
FRST = .TRUE.
|
|
SCASE = 'XX'
|
|
SULRATW = 2.D0
|
|
CRNARAT = ZERO
|
|
CRRAT = ZERO
|
|
NOFER = 0
|
|
STKOFL =.FALSE.
|
|
DO I=1,NERRMX
|
|
ERRSTK(I) =-999
|
|
ERRMSG(I) = 'MESSAGE N/A'
|
|
ENDDO
|
|
C
|
|
C *** END OF SUBROUTINE ISOINIT3 *******************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE II
|
|
C *** SUBROUTINE INIT4
|
|
C *** THIS SUBROUTINE INITIALIZES ALL GLOBAL VARIABLES FOR AMMONIUM,
|
|
C SODIUM, CHLORIDE, NITRATE, SULFATE, CALCIUM, POTASSIUM, MAGNESIUM
|
|
C AEROSOL SYSTEMS (SUBROUTINE ISRP4)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS AND ATHANASIOS NENES
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE INIT4 (WI, RHI, TEMPI)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: WI(NCOMP), RHI, TEMPI
|
|
REAL*8 :: IC,GII,GI0,XX
|
|
REAL*8, PARAMETER :: LN10 = 2.30258509299404568402D0
|
|
C
|
|
C *** SAVE INPUT VARIABLES IN COMMON BLOCK ******************************
|
|
C
|
|
! IF (IPROB == 0) THEN ! FORWARD CALCULATION
|
|
DO I=1,NCOMP
|
|
W(I) = MAX(WI(I), TINY)
|
|
ENDDO
|
|
! ELSE
|
|
! DO I=1,NCOMP ! REVERSE CALCULATION
|
|
! WAER(I) = MAX(WI(I), TINY)
|
|
! W(I) = ZERO
|
|
! ENDDO
|
|
! ENDIF
|
|
RH = RHI
|
|
TEMP = TEMPI
|
|
C
|
|
C *** CALCULATE EQUILIBRIUM CONSTANTS ***********************************
|
|
C
|
|
XK1 = 1.015D-2 ! HSO4(aq) <==> H(aq) + SO4(aq)
|
|
XK21 = 57.639D0 ! NH3(g) <==> NH3(aq)
|
|
XK22 = 1.805D-5 ! NH3(aq) <==> NH4(aq) + OH(aq)
|
|
XK3 = 1.971D6 ! HCL(g) <==> H(aq) + CL(aq)
|
|
XK31 = 2.500d3 ! HCL(g) <==> HCL(aq)
|
|
XK4 = 2.511d6 ! HNO3(g) <==> H(aq) + NO3(aq) ! ISORR
|
|
C XK4 = 3.638d6 ! HNO3(g) <==> H(aq) + NO3(aq) ! SEQUIL
|
|
XK41 = 2.100d5 ! HNO3(g) <==> HNO3(aq)
|
|
XK5 = 0.4799D0 ! NA2SO4(s) <==> 2*NA(aq) + SO4(aq)
|
|
XK6 = 1.086D-16 ! NH4CL(s) <==> NH3(g) + HCL(g)
|
|
XK7 = 1.817D0 ! (NH4)2SO4(s) <==> 2*NH4(aq) + SO4(aq)
|
|
XK8 = 37.661D0 ! NACL(s) <==> NA(aq) + CL(aq)
|
|
C XK10 = 5.746D-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! ISORR
|
|
XK10 = 4.199D-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! (Mozurkewich, 1993)
|
|
C XK10 = 2.985d-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! SEQUIL
|
|
XK11 = 2.413D4 ! NAHSO4(s) <==> NA(aq) + HSO4(aq)
|
|
XK12 = 1.382D2 ! NH4HSO4(s) <==> NH4(aq) + HSO4(aq)
|
|
XK13 = 29.268D0 ! (NH4)3H(SO4)2(s) <==> 3*NH4(aq) + HSO4(aq) + SO4(aq)
|
|
XK14 = 22.05D0 ! NH4CL(s) <==> NH4(aq) + CL(aq)
|
|
XKW = 1.010D-14 ! H2O <==> H(aq) + OH(aq)
|
|
XK9 = 11.977D0 ! NANO3(s) <==> NA(aq) + NO3(aq)
|
|
CCC
|
|
XK15 = 6.067D5 ! CA(NO3)2(s) <==> CA(aq) + 2NO3(aq)
|
|
XK16 = 7.974D11 ! CACL2(s) <==> CA(aq) + 2CL(aq)
|
|
XK17 = 1.569D-2 ! K2SO4(s) <==> 2K(aq) + SO4(aq)
|
|
XK18 = 24.016d0 ! KHSO4(s) <==> K(aq) + HSO4(aq)
|
|
XK19 = 0.872d0 ! KNO3(s) <==> K(aq) + NO3(aq)
|
|
XK20 = 8.680d0 ! KCL(s) <==> K(aq) + CL(aq)
|
|
XK23 = 1.079D5 ! MGS04(s) <==> MG(aq) + SO4(aq)
|
|
XK24 = 2.507D15 ! MG(NO3)2(s) <==> MG(aq) + 2NO3(aq)
|
|
XK25 = 9.557D21 ! MGCL2(s) <==> MG(aq) + 2CL(aq)
|
|
C XK26 = 4.299D-7 ! CO2(aq) + H2O <==> HCO3(aq) + H(aq)
|
|
C XK27 = 4.678D-11 ! HCO3(aq) <==> CO3(aq) + H(aq)
|
|
|
|
C
|
|
IF (INT(TEMP) .NE. 298) THEN ! FOR T != 298K or 298.15K
|
|
T0 = 298.15D0
|
|
T0T = T0/TEMP
|
|
COEF= 1.d0+LOG(T0T)-T0T
|
|
XK1 = XK1 *EXP( 8.85d0*(T0T-1.d0) + 25.140d0*COEF)
|
|
XK21= XK21*EXP( 13.79d0*(T0T-1.d0) - 5.393d0*COEF)
|
|
XK22= XK22*EXP( -1.50d0*(T0T-1.d0) + 26.920d0*COEF)
|
|
XK3 = XK3 *EXP( 30.20d0*(T0T-1.d0) + 19.910d0*COEF)
|
|
XK31= XK31*EXP( 30.20d0*(T0T-1.d0) + 19.910d0*COEF)
|
|
XK4 = XK4 *EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF) !ISORR
|
|
C XK4 = XK4 *EXP( 29.47d0*(T0T-1.d0) + 16.840d0*COEF) ! SEQUIL
|
|
XK41= XK41*EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF)
|
|
XK5 = XK5 *EXP( 0.98d0*(T0T-1.d0) + 39.500d0*COEF)
|
|
XK6 = XK6 *EXP(-71.00d0*(T0T-1.d0) + 2.400d0*COEF)
|
|
XK7 = XK7 *EXP( -2.65d0*(T0T-1.d0) + 38.570d0*COEF)
|
|
XK8 = XK8 *EXP( -1.56d0*(T0T-1.d0) + 16.900d0*COEF)
|
|
XK9 = XK9 *EXP( -8.22d0*(T0T-1.d0) + 16.010d0*COEF)
|
|
C XK10= XK10*EXP(-74.38d0*(T0T-1.d0) + 6.120d0*COEF) ! ISORR
|
|
XK10= XK10*EXP(-74.7351d0*(T0T-1.d0) + 6.025d0*COEF) ! (Mozurkewich, 1993)
|
|
C XK10= XK10*EXP(-75.11d0*(T0T-1.d0) + 13.460d0*COEF) ! SEQUIL
|
|
XK11= XK11*EXP( 0.79d0*(T0T-1.d0) + 14.746d0*COEF)
|
|
XK12= XK12*EXP( -2.87d0*(T0T-1.d0) + 15.830d0*COEF)
|
|
XK13= XK13*EXP( -5.19d0*(T0T-1.d0) + 54.400d0*COEF)
|
|
XK14= XK14*EXP( 24.55d0*(T0T-1.d0) + 16.900d0*COEF)
|
|
XKW = XKW *EXP(-22.52d0*(T0T-1.d0) + 26.920d0*COEF)
|
|
CCC
|
|
C XK15= XK15 *EXP( .0d0*(T0T-1.d0) + .0d0*COEF)
|
|
C XK16= XK16 *EXP( .0d0*(T0T-1.d0) + .0d0*COEF)
|
|
XK17= XK17 *EXP(-9.585d0*(T0T-1.d0) + 45.81d0*COEF)
|
|
XK18= XK18 *EXP(-8.423d0*(T0T-1.d0) + 17.96d0*COEF)
|
|
XK19= XK19 *EXP(-14.08d0*(T0T-1.d0) + 19.39d0*COEF)
|
|
XK20= XK20 *EXP(-6.902d0*(T0T-1.d0) + 19.95d0*COEF)
|
|
C XK23= XK23 *EXP( .0d0*(T0T-1.d0) + .0d0*COEF)
|
|
C XK24= XK24 *EXP( .0d0*(T0T-1.d0) + .0d0*COEF)
|
|
C XK25= XK25 *EXP( .0d0*(T0T-1.d0) + .0d0*COEF)
|
|
C XK26= XK26 *EXP(-3.0821d0*(T0T-1.d0) + 31.8139*COEF)
|
|
C XK27= XK27 *EXP(-5.9908d0*(T0T-1.d0) + 38.844*COEF)
|
|
|
|
ENDIF
|
|
XK2 = XK21*XK22
|
|
XK42 = XK4/XK41
|
|
XK32 = XK3/XK31
|
|
C
|
|
C *** CALCULATE DELIQUESCENCE RELATIVE HUMIDITIES (UNICOMPONENT) ********
|
|
C
|
|
DRH2SO4 = ZERO
|
|
DRNH42S4 = 0.7997D0
|
|
DRNH4HS4 = 0.4000D0
|
|
DRLC = 0.6900D0
|
|
DRNACL = 0.7528D0
|
|
DRNANO3 = 0.7379D0
|
|
DRNH4CL = 0.7710D0
|
|
DRNH4NO3 = 0.6183D0
|
|
DRNA2SO4 = 0.9300D0
|
|
DRNAHSO4 = 0.5200D0
|
|
DRCANO32 = 0.4906D0
|
|
DRCACL2 = 0.2830D0
|
|
DRK2SO4 = 0.9750D0
|
|
DRKHSO4 = 0.8600D0
|
|
DRKNO3 = 0.9248D0
|
|
DRKCL = 0.8426D0
|
|
DRMGSO4 = 0.8613D0
|
|
DRMGNO32 = 0.5400D0
|
|
DRMGCL2 = 0.3284D0
|
|
IF (INT(TEMP) .NE. 298) THEN
|
|
T0 = 298.15D0
|
|
TCF = 1.d0/TEMP - 1.d0/T0
|
|
DRNACL = DRNACL *EXP( 25.d0*TCF)
|
|
DRNANO3 = DRNANO3 *EXP(304.d0*TCF)
|
|
DRNA2SO4 = DRNA2SO4*EXP( 80.d0*TCF)
|
|
DRNH4NO3 = DRNH4NO3*EXP(852.d0*TCF)
|
|
DRNH42S4 = DRNH42S4*EXP( 80.d0*TCF)
|
|
DRNH4HS4 = DRNH4HS4*EXP(384.d0*TCF)
|
|
DRLC = DRLC *EXP(186.d0*TCF)
|
|
DRNH4CL = DRNH4Cl *EXP(239.d0*TCF)
|
|
DRNAHSO4 = DRNAHSO4*EXP(-45.d0*TCF)
|
|
C DRCANO32 = DRCANO32*EXP(-430.5d0*TCF)
|
|
DRCANO32 = DRCANO32*EXP(509.4d0*TCF) ! KELLY & WEXLER (2005) FOR CANO32.4H20
|
|
C DRCACL2 = DRCACL2 *EXP(-1121.d0*TCF)
|
|
DRCACL2 = DRCACL2 *EXP(551.1d0*TCF) ! KELLY & WEXLER (2005) FOR CACL2.6H20
|
|
DRK2SO4 = DRK2SO4 *EXP(35.6d0*TCF)
|
|
C DRKHSO4 = DRKHSO4 *EXP( 0.d0*TCF)
|
|
C DRKNO3 = DRKNO3 *EXP( 0.d0*TCF)
|
|
DRKCL = DRKCL *EXP(159.d0*TCF)
|
|
DRMGSO4 = DRMGSO4 *EXP(-714.45d0*TCF)
|
|
DRMGNO32 = DRMGNO32*EXP(230.2d0*TCF) ! KELLY & WEXLER (2005) FOR MGNO32.6H20
|
|
C DRMGCL2 = DRMGCL2 *EXP(-1860.d0*TCF)
|
|
DRMGCL2 = DRMGCL2 *EXP(42.23d0*TCF) ! KELLY & WEXLER (2005) FOR MGCL2.6H20
|
|
C
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE MUTUAL DELIQUESCENCE RELATIVE HUMIDITIES ****************
|
|
C
|
|
DRMLCAB = 0.378D0 ! (NH4)3H(SO4)2 & NH4HSO4
|
|
DRMLCAS = 0.690D0 ! (NH4)3H(SO4)2 & (NH4)2SO4
|
|
DRMASAN = 0.600D0 ! (NH4)2SO4 & NH4NO3
|
|
DRMG1 = 0.460D0 ! (NH4)2SO4, NH4NO3, NA2SO4, NH4CL
|
|
DRMG2 = 0.691D0 ! (NH4)2SO4, NA2SO4, NH4CL
|
|
DRMG3 = 0.697D0 ! (NH4)2SO4, NA2SO4
|
|
DRMH1 = 0.240D0 ! NA2SO4, NANO3, NACL, NH4NO3, NH4CL
|
|
DRMH2 = 0.596D0 ! NA2SO4, NANO3, NACL, NH4CL
|
|
DRMI1 = 0.240D0 ! LC, NAHSO4, NH4HSO4, NA2SO4, (NH4)2SO4
|
|
DRMI2 = 0.363D0 ! LC, NAHSO4, NA2SO4, (NH4)2SO4 - NO DATA -
|
|
DRMI3 = 0.610D0 ! LC, NA2SO4, (NH4)2SO4
|
|
DRMQ1 = 0.494D0 ! (NH4)2SO4, NH4NO3, NA2SO4
|
|
DRMR1 = 0.663D0 ! NA2SO4, NANO3, NACL
|
|
DRMR2 = 0.735D0 ! NA2SO4, NACL
|
|
DRMR3 = 0.673D0 ! NANO3, NACL
|
|
DRMR4 = 0.694D0 ! NA2SO4, NACL, NH4CL
|
|
DRMR5 = 0.731D0 ! NA2SO4, NH4CL
|
|
DRMR6 = 0.596D0 ! NA2SO4, NANO3, NH4CL
|
|
DRMR7 = 0.380D0 ! NA2SO4, NANO3, NACL, NH4NO3
|
|
DRMR8 = 0.380D0 ! NA2SO4, NACL, NH4NO3
|
|
DRMR9 = 0.494D0 ! NA2SO4, NH4NO3
|
|
DRMR10 = 0.476D0 ! NA2SO4, NANO3, NH4NO3
|
|
DRMR11 = 0.340D0 ! NA2SO4, NACL, NH4NO3, NH4CL
|
|
DRMR12 = 0.460D0 ! NA2SO4, NH4NO3, NH4CL
|
|
DRMR13 = 0.438D0 ! NA2SO4, NANO3, NH4NO3, NH4CL
|
|
C
|
|
DRMO1 = 0.460D0 ! (NH4)2SO4, NH4NO3, NH4Cl, NA2SO4, K2SO4, MGSO4
|
|
DRMO2 = 0.691D0 ! (NH4)2SO4, NH4Cl, NA2SO4, K2SO4, MGSO4
|
|
DRMO3 = 0.697D0 ! (NH4)2SO4, NA2SO4, K2SO4, MGSO4
|
|
DRML1 = 0.240D0 ! K2SO4, MGSO4, KHSO4, NH4HSO4, NAHSO4, (NH4)2SO4, NA2SO4, LC
|
|
DRML2 = 0.363D0 ! K2SO4, MGSO4, KHSO4, NAHSO4, (NH4)2SO4, NA2SO4, LC
|
|
DRML3 = 0.610D0 ! K2SO4, MGSO4, KHSO4, (NH4)2SO4, NA2SO4, LC
|
|
DRMM1 = 0.240D0 ! K2SO4, NA2SO4, MGSO4, NH4CL, NACL, NANO3, NH4NO3
|
|
DRMM2 = 0.596D0 ! K2SO4, NA2SO4, MGSO4, NH4CL, NACL, NANO3
|
|
DRMP1 = 0.200D0 ! CA(NO3)2, CACL2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL
|
|
DRMP2 = 0.240D0 ! CA(NO3)2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL
|
|
DRMP3 = 0.240D0 ! CA(NO3)2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL
|
|
DRMP4 = 0.240D0 ! K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL
|
|
DRMP5 = 0.240D0 ! K2SO4, KNO3, KCL, MGSO4, NANO3, NACL, NH4NO3, NH4CL
|
|
CC
|
|
DRMV1 = 0.494D0 ! (NH4)2SO4, NH4NO3, NA2SO4, K2SO4, MGSO4
|
|
CC
|
|
CC
|
|
C DRMO1 = 0.1D0 ! (NH4)2SO4, NH4NO3, NH4Cl, NA2SO4, K2SO4, MGSO4
|
|
C DRMO2 = 0.1D0 ! (NH4)2SO4, NH4Cl, NA2SO4, K2SO4, MGSO4
|
|
C DRMO3 = 0.1D0 ! (NH4)2SO4, NA2SO4, K2SO4, MGSO4
|
|
C DRML1 = 0.1D0 ! K2SO4, MGSO4, KHSO4, NH4HSO4, NAHSO4, (NH4)2SO4, NA2SO4, LC
|
|
C DRML2 = 0.1D0 ! K2SO4, MGSO4, KHSO4, NAHSO4, (NH4)2SO4, NA2SO4, LC
|
|
C DRML3 = 0.1D0 ! K2SO4, MGSO4, KHSO4, (NH4)2SO4, NA2SO4, LC
|
|
C DRMM1 = 0.1D0 ! K2SO4, NA2SO4, MGSO4, NH4CL, NACL, NANO3, NH4NO3
|
|
C DRMM2 = 0.1D0 ! K2SO4, NA2SO4, MGSO4, NH4CL, NACL, NANO3
|
|
C DRMP1 = 0.1D0 ! CA(NO3)2, CACL2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL
|
|
C DRMP2 = 0.1D0 ! CA(NO3)2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL
|
|
C DRMP3 = 0.1D0 ! CA(NO3)2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL
|
|
C DRMP4 = 0.1D0 ! K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL
|
|
C DRMP5 = 0.1D0 ! K2SO4, KNO3, KCL, MGSO4, NANO3, NACL, NH4NO3, NH4CL
|
|
CC
|
|
C DRMV1 = 0.1D0 ! (NH4)2SO4, NH4NO3, NA2SO4, K2SO4, MGSO4
|
|
C
|
|
CCC IF (INT(TEMP) .NE. 298) THEN
|
|
CCC T0 = 298.15d0
|
|
CCC TCF = 1.0/TEMP - 1.0/T0
|
|
CCC DRMLCAB = DRMLCAB*EXP( 507.506*TCF)
|
|
CCC DRMLCAS = DRMLCAS*EXP( 133.865*TCF)
|
|
CCC DRMASAN = DRMASAN*EXP(1269.068*TCF)
|
|
CCC DRMG1 = DRMG1 *EXP( 572.207*TCF)
|
|
CCC DRMG2 = DRMG2 *EXP( 58.166*TCF)
|
|
CCC DRMG3 = DRMG3 *EXP( 22.253*TCF)
|
|
CCC DRMH1 = DRMH1 *EXP(2116.542*TCF)
|
|
CCC DRMH2 = DRMH2 *EXP( 650.549*TCF)
|
|
CCC DRMI1 = DRMI1 *EXP( 565.743*TCF)
|
|
CCC DRMI2 = DRMI2 *EXP( 91.745*TCF)
|
|
CCC DRMI3 = DRMI3 *EXP( 161.272*TCF)
|
|
CCC DRMQ1 = DRMQ1 *EXP(1616.621*TCF)
|
|
CCC DRMR1 = DRMR1 *EXP( 292.564*TCF)
|
|
CCC DRMR2 = DRMR2 *EXP( 14.587*TCF)
|
|
CCC DRMR3 = DRMR3 *EXP( 307.907*TCF)
|
|
CCC DRMR4 = DRMR4 *EXP( 97.605*TCF)
|
|
CCC DRMR5 = DRMR5 *EXP( 98.523*TCF)
|
|
CCC DRMR6 = DRMR6 *EXP( 465.500*TCF)
|
|
CCC DRMR7 = DRMR7 *EXP( 324.425*TCF)
|
|
CCC DRMR8 = DRMR8 *EXP(2660.184*TCF)
|
|
CCC DRMR9 = DRMR9 *EXP(1617.178*TCF)
|
|
CCC DRMR10 = DRMR10 *EXP(1745.226*TCF)
|
|
CCC DRMR11 = DRMR11 *EXP(3691.328*TCF)
|
|
CCC DRMR12 = DRMR12 *EXP(1836.842*TCF)
|
|
CCC DRMR13 = DRMR13 *EXP(1967.938*TCF)
|
|
CCC ENDIF
|
|
C
|
|
C *** LIQUID PHASE ******************************************************
|
|
C
|
|
CHNO3 = ZERO
|
|
CHCL = ZERO
|
|
CH2SO4 = ZERO
|
|
COH = ZERO
|
|
WATER = TINY
|
|
C
|
|
DO I=1,NPAIR
|
|
MOLALR(I)=ZERO
|
|
GAMA(I) =0.1d0
|
|
GAMIN(I) =GREAT
|
|
GAMOU(I) =GREAT
|
|
M0(I) =1d5
|
|
ENDDO
|
|
C
|
|
DO I=1,NPAIR
|
|
GAMA(I) = 0.1d0
|
|
ENDDO
|
|
C
|
|
DO I=1,NIONS
|
|
MOLAL(I)=ZERO
|
|
ENDDO
|
|
COH = ZERO
|
|
C
|
|
DO I=1,NGASAQ
|
|
GASAQ(I)=ZERO
|
|
ENDDO
|
|
C
|
|
C *** SOLID PHASE *******************************************************
|
|
C
|
|
CNH42S4= ZERO
|
|
CNH4HS4= ZERO
|
|
CNACL = ZERO
|
|
CNA2SO4= ZERO
|
|
CNANO3 = ZERO
|
|
CNH4NO3= ZERO
|
|
CNH4CL = ZERO
|
|
CNAHSO4= ZERO
|
|
CLC = ZERO
|
|
CCASO4 = ZERO
|
|
CCANO32= ZERO
|
|
CCACL2 = ZERO
|
|
CK2SO4 = ZERO
|
|
CKHSO4 = ZERO
|
|
CKNO3 = ZERO
|
|
CKCL = ZERO
|
|
CMGSO4 = ZERO
|
|
CMGNO32= ZERO
|
|
CMGCL2 = ZERO
|
|
C
|
|
C *** GAS PHASE *********************************************************
|
|
C
|
|
GNH3 = ZERO
|
|
GHNO3 = ZERO
|
|
GHCL = ZERO
|
|
C
|
|
C *** CALCULATE ZSR PARAMETERS ******************************************
|
|
C
|
|
IRH = MIN (INT(RH*NZSR+0.5d0),NZSR) ! Position in ZSR arrays
|
|
IRH = MAX (IRH, 1)
|
|
C
|
|
M0(01) = AWSC(IRH) ! NACl
|
|
C IF (M0(01) < 100.0) THEN
|
|
C IC = M0(01)
|
|
C CALL KMTAB(IC,298.0, GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(01) = M0(01)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(02) = AWSS(IRH) ! (NA)2SO4
|
|
C IF (M0(02) < 100.0) THEN
|
|
C IC = 3.0*M0(02)
|
|
C CALL KMTAB(IC,298.0, XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(02) = M0(02)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(03) = AWSN(IRH) ! NANO3
|
|
C IF (M0(03) < 100.0) THEN
|
|
C IC = M0(03)
|
|
C CALL KMTAB(IC,298.0, XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(03) = M0(03)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(04) = AWAS(IRH) ! (NH4)2SO4
|
|
C IF (M0(04) < 100.0) THEN
|
|
C IC = 3.0*M0(04)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(04) = M0(04)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(05) = AWAN(IRH) ! NH4NO3
|
|
C IF (M0(05) < 100.0) THEN
|
|
C IC = M0(05)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(05) = M0(05)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(06) = AWAC(IRH) ! NH4CL
|
|
C IF (M0(06) < 100.0) THEN
|
|
C IC = M0(06)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(06) = M0(06)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(07) = AWSA(IRH) ! 2H-SO4
|
|
C IF (M0(07) < 100.0) THEN
|
|
C IC = 3.0*M0(07)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(07) = M0(07)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(08) = AWSA(IRH) ! H-HSO4
|
|
CCC IF (M0(08) < 100.0) THEN ! These are redundant, because M0(8) is not used
|
|
CCC IC = M0(08)
|
|
CCC CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX)
|
|
CCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX)
|
|
CCCCCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX)
|
|
CCC M0(08) = M0(08)*EXP(LN10*(GI0-GII))
|
|
CCC ENDIF
|
|
C
|
|
M0(09) = AWAB(IRH) ! NH4HSO4
|
|
C IF (M0(09) < 100.0) THEN
|
|
C IC = M0(09)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(09) = M0(09)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(12) = AWSB(IRH) ! NAHSO4
|
|
C IF (M0(12) < 100.0) THEN
|
|
C IC = M0(12)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GI0,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GII,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(12) = M0(12)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(13) = AWLC(IRH) ! (NH4)3H(SO4)2
|
|
C IF (M0(13) < 100.0) THEN
|
|
C IC = 4.0*M0(13)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C G130 = 0.2*(3.0*GI0+2.0*GII)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C G13I = 0.2*(3.0*GI0+2.0*GII)
|
|
C M0(13) = M0(13)*EXP(LN10*SNGL(G130-G13I))
|
|
C ENDIF
|
|
C
|
|
M0(15) = AWCN(IRH) ! CA(NO3)2
|
|
C IF (M0(15) < 100.0) THEN
|
|
C IC = M0(15)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & GI0,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & GII,XX,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(15) = M0(15)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
CC
|
|
M0(16) = AWCC(IRH) ! CACl2
|
|
C IF (M0(16) < 100.0) THEN
|
|
C IC = M0(16)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,GI0,XX,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,GII,XX,XX,XX,XX,XX,XX,XX)
|
|
C M0(16) = M0(16)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(17) = AWPS(IRH) ! K2SO4
|
|
C IF (M0(17) < 100.0) THEN
|
|
C IC = M0(17)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,GI0,XX,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,GII,XX,XX,XX,XX,XX,XX)
|
|
C M0(17) = M0(17)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(18) = AWPB(IRH) ! KHSO4
|
|
C IF (M0(18) < 100.0) THEN
|
|
C IC = M0(18)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,GI0,XX,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,GII,XX,XX,XX,XX,XX)
|
|
C M0(18) = M0(18)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(19) = AWPN(IRH) ! KNO3
|
|
C IF (M0(19) < 100.0) THEN
|
|
C IC = M0(19)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,GI0,XX,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,GII,XX,XX,XX,XX)
|
|
C M0(19) = M0(19)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(20) = AWPC(IRH) ! KCl
|
|
C IF (M0(20) < 100.0) THEN
|
|
C IC = M0(20)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,GI0,XX,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,GII,XX,XX,XX)
|
|
C M0(20) = M0(20)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(21) = AWMS(IRH) ! MGSO4
|
|
C IF (M0(21) < 100.0) THEN
|
|
C IC = M0(21)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,GI0,XX,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,GII,XX,XX)
|
|
C M0(21) = M0(21)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(22) = AWMN(IRH) ! MG(NO3)2
|
|
C IF (M0(22) < 100.0) THEN
|
|
C IC = M0(22)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,GI0,XX)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,GII,XX)
|
|
C M0(22) = M0(22)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
M0(23) = AWMC(IRH) ! MGCL2
|
|
C IF (M0(23) < 100.0) THEN
|
|
C IC = M0(23)
|
|
C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,GI0)
|
|
C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,
|
|
C & XX,XX,XX,XX,XX,XX,XX,XX,GII)
|
|
C M0(23) = M0(23)*EXP(LN10*(GI0-GII))
|
|
C ENDIF
|
|
C
|
|
C *** OTHER INITIALIZATIONS *********************************************
|
|
C
|
|
ICLACT = 0
|
|
CALAOU = .TRUE.
|
|
CALAIN = .TRUE.
|
|
FRST = .TRUE.
|
|
SCASE = '??'
|
|
SULRATW = 2.D0
|
|
SO4RAT = 2.D0
|
|
CRNARAT = 2.D0
|
|
CRRAT = 2.D0
|
|
NOFER = 0
|
|
STKOFL =.FALSE.
|
|
DO I=1,NERRMX
|
|
ERRSTK(I) =-999
|
|
ERRMSG(I) = 'MESSAGE N/A'
|
|
ENDDO
|
|
C
|
|
C *** END OF SUBROUTINE INIT4 *******************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ADJUST
|
|
C *** ADJUSTS FOR MASS BALANCE BETWEEN VOLATILE SPECIES AND SULFATE
|
|
C FIRST CALCULATE THE EXCESS OF EACH PRECURSOR, AND IF IT EXISTS, THEN
|
|
C ADJUST SEQUENTIALY AEROSOL PHASE SPECIES WHICH CONTAIN THE EXCESS
|
|
C PRECURSOR.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ADJUST (WI)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: WI(*)
|
|
C
|
|
C *** FOR AMMONIUM *****************************************************
|
|
C
|
|
IF (IPROB == 0) THEN ! Calculate excess (solution - input)
|
|
EXNH4 = GNH3 + MOLAL(3) + CNH4CL + CNH4NO3 + CNH4HS4
|
|
& + 2D0*CNH42S4 + 3D0*CLC
|
|
& -WI(3)
|
|
ELSE
|
|
EXNH4 = MOLAL(3) + CNH4CL + CNH4NO3 + CNH4HS4 + 2D0*CNH42S4
|
|
& + 3D0*CLC
|
|
& -WI(3)
|
|
|
|
ENDIF
|
|
EXNH4 = MAX(EXNH4,ZERO)
|
|
IF ((EXNH4) < TINY) GOTO 20 ! No excess NH4, go to next precursor
|
|
C
|
|
IF ((MOLAL(3)) > (EXNH4)) THEN ! Adjust aqueous phase NH4
|
|
MOLAL(3) = MOLAL(3) - EXNH4
|
|
GOTO 20
|
|
ELSE
|
|
EXNH4 = EXNH4 - MOLAL(3)
|
|
MOLAL(3) = ZERO
|
|
ENDIF
|
|
C
|
|
IF ((CNH4CL) > (EXNH4)) THEN ! Adjust NH4Cl(s)
|
|
CNH4CL = CNH4CL - EXNH4 ! more solid than excess
|
|
GHCL = GHCL + EXNH4 ! evaporate Cl to gas phase
|
|
GOTO 20
|
|
ELSE ! less solid than excess
|
|
GHCL = GHCL + CNH4CL ! evaporate into gas phase
|
|
EXNH4 = EXNH4 - CNH4CL ! reduce excess
|
|
CNH4CL = ZERO ! zero salt concentration
|
|
ENDIF
|
|
C
|
|
IF ((CNH4NO3) > (EXNH4)) THEN ! Adjust NH4NO3(s)
|
|
CNH4NO3 = CNH4NO3- EXNH4 ! more solid than excess
|
|
GHNO3 = GHNO3 + EXNH4 ! evaporate NO3 to gas phase
|
|
GOTO 20
|
|
ELSE ! less solid than excess
|
|
GHNO3 = GHNO3 + CNH4NO3! evaporate into gas phase
|
|
EXNH4 = EXNH4 - CNH4NO3! reduce excess
|
|
CNH4NO3 = ZERO ! zero salt concentration
|
|
ENDIF
|
|
C
|
|
IF ((CLC) > 3d0*(EXNH4)) THEN ! Adjust (NH4)3H(SO4)2(s)
|
|
CLC = CLC - EXNH4/3d0 ! more solid than excess
|
|
GOTO 20
|
|
ELSE ! less solid than excess
|
|
EXNH4 = EXNH4 - 3d0*CLC ! reduce excess
|
|
CLC = ZERO ! zero salt concentration
|
|
ENDIF
|
|
C
|
|
IF ((CNH4HS4) > (EXNH4)) THEN ! Adjust NH4HSO4(s)
|
|
CNH4HS4 = CNH4HS4- EXNH4 ! more solid than excess
|
|
GOTO 20
|
|
ELSE ! less solid than excess
|
|
EXNH4 = EXNH4 - CNH4HS4! reduce excess
|
|
CNH4HS4 = ZERO ! zero salt concentration
|
|
ENDIF
|
|
C
|
|
IF ((CNH42S4) > (EXNH4)) THEN ! Adjust (NH4)2SO4(s)
|
|
CNH42S4 = CNH42S4- EXNH4 ! more solid than excess
|
|
GOTO 20
|
|
ELSE ! less solid than excess
|
|
EXNH4 = EXNH4 - CNH42S4! reduce excess
|
|
CNH42S4 = ZERO ! zero salt concentration
|
|
ENDIF
|
|
C
|
|
C *** FOR NITRATE ******************************************************
|
|
C
|
|
20 IF (IPROB == 0) THEN ! Calculate excess (solution - input)
|
|
EXNO3 = GHNO3 + MOLAL(7) + CNH4NO3
|
|
& -WI(4)
|
|
ELSE
|
|
EXNO3 = MOLAL(7) + CNH4NO3
|
|
& -WI(4)
|
|
ENDIF
|
|
EXNO3 = MAX(EXNO3,ZERO)
|
|
IF ((EXNO3) < TINY) GOTO 30 ! No excess NO3, go to next precursor
|
|
C
|
|
IF ((MOLAL(7)) > (EXNO3)) THEN ! Adjust aqueous phase NO3
|
|
MOLAL(7) = MOLAL(7) - EXNO3
|
|
GOTO 30
|
|
ELSE
|
|
EXNO3 = EXNO3 - MOLAL(7)
|
|
MOLAL(7) = ZERO
|
|
ENDIF
|
|
C
|
|
IF ((CNH4NO3) > (EXNO3)) THEN ! Adjust NH4NO3(s)
|
|
CNH4NO3 = CNH4NO3- EXNO3 ! more solid than excess
|
|
GNH3 = GNH3 + EXNO3 ! evaporate NO3 to gas phase
|
|
GOTO 30
|
|
ELSE ! less solid than excess
|
|
GNH3 = GNH3 + CNH4NO3! evaporate into gas phase
|
|
EXNO3 = EXNO3 - CNH4NO3! reduce excess
|
|
CNH4NO3 = ZERO ! zero salt concentration
|
|
ENDIF
|
|
C
|
|
C *** FOR CHLORIDE *****************************************************
|
|
C
|
|
30 IF (IPROB == 0) THEN ! Calculate excess (solution - input)
|
|
EXCl = GHCL + MOLAL(4) + CNH4CL
|
|
& -WI(5)
|
|
ELSE
|
|
EXCl = MOLAL(4) + CNH4CL
|
|
& -WI(5)
|
|
ENDIF
|
|
EXCl = MAX(EXCl,ZERO)
|
|
IF ((EXCl) < TINY) GOTO 40 ! No excess Cl, go to next precursor
|
|
C
|
|
IF ((MOLAL(4)) > (EXCL)) THEN ! Adjust aqueous phase Cl
|
|
MOLAL(4) = MOLAL(4) - EXCL
|
|
GOTO 40
|
|
ELSE
|
|
EXCL = EXCL - MOLAL(4)
|
|
MOLAL(4) = ZERO
|
|
ENDIF
|
|
C
|
|
IF ((CNH4CL) > (EXCL)) THEN ! Adjust NH4Cl(s)
|
|
CNH4CL = CNH4CL - EXCL ! more solid than excess
|
|
GHCL = GHCL + EXCL ! evaporate Cl to gas phase
|
|
GOTO 40
|
|
ELSE ! less solid than excess
|
|
GHCL = GHCL + CNH4CL ! evaporate into gas phase
|
|
EXCL = EXCL - CNH4CL ! reduce excess
|
|
CNH4CL = ZERO ! zero salt concentration
|
|
ENDIF
|
|
C
|
|
C *** FOR SULFATE ******************************************************
|
|
C
|
|
40 EXS4 = MOLAL(5) + MOLAL(6) + 2.d0*CLC + CNH42S4 + CNH4HS4 +
|
|
& CNA2SO4 + CNAHSO4 - WI(2)
|
|
EXS4 = MAX(EXS4,ZERO) ! Calculate excess (solution - input)
|
|
IF ((EXS4) < TINY) GOTO 50 ! No excess SO4, return
|
|
C
|
|
IF ((MOLAL(6)) > (EXS4)) THEN ! Adjust aqueous phase HSO4
|
|
MOLAL(6) = MOLAL(6) - EXS4
|
|
GOTO 50
|
|
ELSE
|
|
EXS4 = EXS4 - MOLAL(6)
|
|
MOLAL(6) = ZERO
|
|
ENDIF
|
|
C
|
|
IF ((MOLAL(5)) > (EXS4)) THEN ! Adjust aqueous phase SO4
|
|
MOLAL(5) = MOLAL(5) - EXS4
|
|
GOTO 50
|
|
ELSE
|
|
EXS4 = EXS4 - MOLAL(5)
|
|
MOLAL(5) = ZERO
|
|
ENDIF
|
|
C
|
|
IF ((CLC) > 2d0*(EXS4)) THEN ! Adjust (NH4)3H(SO4)2(s)
|
|
CLC = CLC - EXS4/2d0 ! more solid than excess
|
|
GNH3 = GNH3 +1.5d0*EXS4! evaporate NH3 to gas phase
|
|
GOTO 50
|
|
ELSE ! less solid than excess
|
|
GNH3 = GNH3 + 1.5d0*CLC! evaporate NH3 to gas phase
|
|
EXS4 = EXS4 - 2d0*CLC ! reduce excess
|
|
CLC = ZERO ! zero salt concentration
|
|
ENDIF
|
|
C
|
|
IF ((CNH4HS4) > (EXS4)) THEN ! Adjust NH4HSO4(s)
|
|
CNH4HS4 = CNH4HS4 - EXS4 ! more solid than excess
|
|
GNH3 = GNH3 + EXS4 ! evaporate NH3 to gas phase
|
|
GOTO 50
|
|
ELSE ! less solid than excess
|
|
GNH3 = GNH3 + CNH4HS4 ! evaporate NH3 to gas phase
|
|
EXS4 = EXS4 - CNH4HS4 ! reduce excess
|
|
CNH4HS4 = ZERO ! zero salt concentration
|
|
ENDIF
|
|
C
|
|
IF ((CNH42S4) > (EXS4)) THEN ! Adjust (NH4)2SO4(s)
|
|
CNH42S4 = CNH42S4- EXS4 ! more solid than excess
|
|
GNH3 = GNH3 + 2.d0*EXS4! evaporate NH3 to gas phase
|
|
GOTO 50
|
|
ELSE ! less solid than excess
|
|
GNH3 = GNH3+2.d0*CNH42S4 ! evaporate NH3 to gas phase
|
|
EXS4 = EXS4 - CNH42S4 ! reduce excess
|
|
CNH42S4 = ZERO ! zero salt concentration
|
|
ENDIF
|
|
C
|
|
C *** RETURN **********************************************************
|
|
C
|
|
50 RETURN
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** FUNCTION GETASR
|
|
C *** CALCULATES THE LIMITING NH4+/SO4 RATIO OF A SULFATE POOR SYSTEM
|
|
C (i.e. SULFATE RATIO = 2.0) FOR GIVEN SO4 LEVEL AND RH
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
REAL*8 FUNCTION GETASR (SO4I, RHI)
|
|
IMPLICIT NONE
|
|
INTEGER, PARAMETER :: NSO4S = 14
|
|
INTEGER, PARAMETER :: NRHS = 20
|
|
INTEGER, PARAMETER :: NASRD = NSO4S*NRHS
|
|
REAL*8 :: WF, ASRAT, ASSO4
|
|
COMMON /ASRC/ ASRAT(NASRD), ASSO4(NSO4S)
|
|
!$OMP THREADPRIVATE( /ASRC/ )
|
|
REAL*8 :: SO4I, RHI, RAT
|
|
INTEGER :: IA1, A1, INDS, INDR, INDSL, INDSH, IPOSL, IPOSH
|
|
CCC
|
|
CCC *** SOLVE USING FULL COMPUTATIONS, NOT LOOK-UP TABLES **************
|
|
CCC
|
|
CCC W(2) = WAER(2)
|
|
CCC W(3) = WAER(2)*2.0001D0
|
|
CCC CALL CALCA2
|
|
CCC SULRATW = MOLAL(3)/WAER(2)
|
|
CCC CALL INIT1 (WI, RHI, TEMPI) ! Re-initialize COMMON BLOCK
|
|
C
|
|
C *** CALCULATE INDICES ************************************************
|
|
C
|
|
RAT = SO4I/1.D-9
|
|
A1 = INT(LOG10(RAT)) ! Magnitude of RAT
|
|
IA1 = INT(RAT/2.5d0/10.d0**A1)
|
|
C
|
|
INDS = INT(4.d0*A1 + MIN(IA1,4))
|
|
INDS = MIN(MAX(0, INDS), NSO4S-1) + 1 ! SO4 component of IPOS
|
|
C
|
|
INDR = INT(99.d0-RHI*100.d0) + 1
|
|
INDR = MIN(MAX(1, INDR), NRHS) ! RH component of IPOS
|
|
C
|
|
C *** GET VALUE AND RETURN *********************************************
|
|
C
|
|
INDSL = INDS
|
|
INDSH = MIN(INDSL+1, NSO4S)
|
|
IPOSL = (INDSL-1)*NRHS + INDR ! Low position in array
|
|
IPOSH = (INDSH-1)*NRHS + INDR ! High position in array
|
|
C
|
|
WF = (SO4I-ASSO4(INDSL))/(ASSO4(INDSH)-ASSO4(INDSL) + 1.D-7)
|
|
WF = MIN(MAX((WF), 0.d0), 1.d0)
|
|
! IF ((WF) < 0.D0) THEN
|
|
! WF = 0.d0
|
|
! ELSEIF ((WF) > 1.D0) THEN
|
|
! WF = 1.d0
|
|
! ENDIF
|
|
C
|
|
GETASR = WF*ASRAT(IPOSH) + (1.D0-WF)*ASRAT(IPOSL)
|
|
C
|
|
C *** END OF FUNCTION GETASR *******************************************
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** BLOCK DATA AERSR
|
|
C *** CONTAINS DATA FOR AEROSOL SULFATE RATIO ARRAY NEEDED IN FUNCTION
|
|
C GETASR
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
BLOCK DATA AERSR
|
|
INTEGER, PARAMETER :: NSO4S = 14
|
|
INTEGER, PARAMETER :: NRHS = 20
|
|
INTEGER, PARAMETER :: NASRD = NSO4S*NRHS
|
|
COMMON /ASRC/ ASRAT(NASRD), ASSO4(NSO4S)
|
|
C
|
|
DATA ASSO4/1.0D-9, 2.5D-9, 5.0D-9, 7.5D-9, 1.0D-8,
|
|
& 2.5D-8, 5.0D-8, 7.5D-8, 1.0D-7, 2.5D-7,
|
|
& 5.0D-7, 7.5D-7, 1.0D-6, 5.0D-6/
|
|
C
|
|
DATA (ASRAT(I), I=1,100)/
|
|
& 1.020464, 0.9998130, 0.9960167, 0.9984423, 1.004004,
|
|
& 1.010885, 1.018356, 1.026726, 1.034268, 1.043846,
|
|
& 1.052933, 1.062230, 1.062213, 1.080050, 1.088350,
|
|
& 1.096603, 1.104289, 1.111745, 1.094662, 1.121594,
|
|
& 1.268909, 1.242444, 1.233815, 1.232088, 1.234020,
|
|
& 1.238068, 1.243455, 1.250636, 1.258734, 1.267543,
|
|
& 1.276948, 1.286642, 1.293337, 1.305592, 1.314726,
|
|
& 1.323463, 1.333258, 1.343604, 1.344793, 1.355571,
|
|
& 1.431463, 1.405204, 1.395791, 1.393190, 1.394403,
|
|
& 1.398107, 1.403811, 1.411744, 1.420560, 1.429990,
|
|
& 1.439742, 1.449507, 1.458986, 1.468403, 1.477394,
|
|
& 1.487373, 1.495385, 1.503854, 1.512281, 1.520394,
|
|
& 1.514464, 1.489699, 1.480686, 1.478187, 1.479446,
|
|
& 1.483310, 1.489316, 1.497517, 1.506501, 1.515816,
|
|
& 1.524724, 1.533950, 1.542758, 1.551730, 1.559587,
|
|
& 1.568343, 1.575610, 1.583140, 1.590440, 1.596481,
|
|
& 1.567743, 1.544426, 1.535928, 1.533645, 1.535016,
|
|
& 1.539003, 1.545124, 1.553283, 1.561886, 1.570530,
|
|
& 1.579234, 1.587813, 1.595956, 1.603901, 1.611349,
|
|
& 1.618833, 1.625819, 1.632543, 1.639032, 1.645276/
|
|
|
|
DATA (ASRAT(I), I=101,200)/
|
|
& 1.707390, 1.689553, 1.683198, 1.681810, 1.683490,
|
|
& 1.687477, 1.693148, 1.700084, 1.706917, 1.713507,
|
|
& 1.719952, 1.726190, 1.731985, 1.737544, 1.742673,
|
|
& 1.747756, 1.752431, 1.756890, 1.761141, 1.765190,
|
|
& 1.785657, 1.771851, 1.767063, 1.766229, 1.767901,
|
|
& 1.771455, 1.776223, 1.781769, 1.787065, 1.792081,
|
|
& 1.796922, 1.801561, 1.805832, 1.809896, 1.813622,
|
|
& 1.817292, 1.820651, 1.823841, 1.826871, 1.829745,
|
|
& 1.822215, 1.810497, 1.806496, 1.805898, 1.807480,
|
|
& 1.810684, 1.814860, 1.819613, 1.824093, 1.828306,
|
|
& 1.832352, 1.836209, 1.839748, 1.843105, 1.846175,
|
|
& 1.849192, 1.851948, 1.854574, 1.857038, 1.859387,
|
|
& 1.844588, 1.834208, 1.830701, 1.830233, 1.831727,
|
|
& 1.834665, 1.838429, 1.842658, 1.846615, 1.850321,
|
|
& 1.853869, 1.857243, 1.860332, 1.863257, 1.865928,
|
|
& 1.868550, 1.870942, 1.873208, 1.875355, 1.877389,
|
|
& 1.899556, 1.892637, 1.890367, 1.890165, 1.891317,
|
|
& 1.893436, 1.896036, 1.898872, 1.901485, 1.903908,
|
|
& 1.906212, 1.908391, 1.910375, 1.912248, 1.913952,
|
|
& 1.915621, 1.917140, 1.918576, 1.919934, 1.921220/
|
|
|
|
DATA (ASRAT(I), I=201,280)/
|
|
& 1.928264, 1.923245, 1.921625, 1.921523, 1.922421,
|
|
& 1.924016, 1.925931, 1.927991, 1.929875, 1.931614,
|
|
& 1.933262, 1.934816, 1.936229, 1.937560, 1.938769,
|
|
& 1.939951, 1.941026, 1.942042, 1.943003, 1.943911,
|
|
& 1.941205, 1.937060, 1.935734, 1.935666, 1.936430,
|
|
& 1.937769, 1.939359, 1.941061, 1.942612, 1.944041,
|
|
& 1.945393, 1.946666, 1.947823, 1.948911, 1.949900,
|
|
& 1.950866, 1.951744, 1.952574, 1.953358, 1.954099,
|
|
& 1.948985, 1.945372, 1.944221, 1.944171, 1.944850,
|
|
& 1.946027, 1.947419, 1.948902, 1.950251, 1.951494,
|
|
& 1.952668, 1.953773, 1.954776, 1.955719, 1.956576,
|
|
& 1.957413, 1.958174, 1.958892, 1.959571, 1.960213,
|
|
& 1.977193, 1.975540, 1.975023, 1.975015, 1.975346,
|
|
& 1.975903, 1.976547, 1.977225, 1.977838, 1.978401,
|
|
& 1.978930, 1.979428, 1.979879, 1.980302, 1.980686,
|
|
& 1.981060, 1.981401, 1.981722, 1.982025, 1.982312/
|
|
C
|
|
C *** END OF BLOCK DATA AERSR ******************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCHA
|
|
C *** CALCULATES CHLORIDES SPECIATION
|
|
C
|
|
C HYDROCHLORIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES,
|
|
C AND DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE
|
|
C HYDROCHLORIC ACID DISSOLVED IS CALCULATED FROM THE
|
|
C HCL(G) <-> (H+) + (CL-)
|
|
C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCHA
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: KAPA, X, DELT, ALFA, DIAK
|
|
CC CHARACTER(LEN=40) errinf
|
|
C
|
|
C *** CALCULATE HCL DISSOLUTION *****************************************
|
|
C
|
|
X = W(5)
|
|
DELT = 0.0d0
|
|
IF ((WATER) > TINY) THEN
|
|
KAPA = MOLAL(1)
|
|
ALFA = XK3*R*TEMP*(WATER/GAMA(11))**2.D0
|
|
DIAK = SQRT( (KAPA+ALFA)**2.D0 + 4.D0*ALFA*X)
|
|
DELT = 0.5D0*(-(KAPA+ALFA) + DIAK)
|
|
CC IF (DELT/KAPA > 0.1d0) THEN
|
|
CC WRITE (ERRINF,'(1PE10.3)') DELT/KAPA*100.0
|
|
CC CALL PUSHERR (0033, ERRINF)
|
|
CC ENDIF
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE HCL SPECIATION IN THE GAS PHASE *************************
|
|
C
|
|
GHCL = MAX(X-DELT, 0.0d0) ! GAS HCL
|
|
C
|
|
C *** CALCULATE HCL SPECIATION IN THE LIQUID PHASE **********************
|
|
C
|
|
MOLAL(4) = DELT ! CL-
|
|
MOLAL(1) = MOLAL(1) + DELT ! H+
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCHA ******************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNA
|
|
C *** CALCULATES NITRATES SPECIATION
|
|
C
|
|
C NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT
|
|
C DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC
|
|
C ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> (H+) + (NO3-)
|
|
C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNA
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: ALFA, DELT, KAPA, DIAK
|
|
CC CHARACTER(LEN=40) errinf
|
|
C
|
|
C *** CALCULATE HNO3 DISSOLUTION ****************************************
|
|
C
|
|
X = W(4)
|
|
DELT = 0.0d0
|
|
IF ((WATER) > TINY) THEN
|
|
KAPA = MOLAL(1)
|
|
ALFA = XK4*R*TEMP*(WATER/GAMA(10))**2.D0
|
|
DIAK = SQRT( (KAPA+ALFA)**2.D0 + 4.d0*ALFA*X)
|
|
DELT = 0.5d0*(-(KAPA+ALFA) + DIAK)
|
|
CC IF (DELT/KAPA > 0.1d0) THEN
|
|
CC WRITE (ERRINF,'(1PE10.3)') DELT/KAPA*100.0
|
|
CC CALL PUSHERR (0019, ERRINF) ! WARNING ERROR: NO SOLUTION
|
|
CC ENDIF
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE HNO3 SPECIATION IN THE GAS PHASE ************************
|
|
C
|
|
GHNO3 = MAX(X-DELT, 0.0d0) ! GAS HNO3
|
|
C
|
|
C *** CALCULATE HNO3 SPECIATION IN THE LIQUID PHASE *********************
|
|
C
|
|
MOLAL(7) = DELT ! NO3-
|
|
MOLAL(1) = MOLAL(1) + DELT ! H+
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCNA ******************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNH3
|
|
C *** CALCULATES AMMONIA IN GAS PHASE
|
|
C
|
|
C AMMONIA IN THE GAS PHASE IS ASSUMED A MINOR SPECIES, THAT
|
|
C DOES NOT SIGNIFICANTLY PERTURB THE AEROSOL EQUILIBRIUM.
|
|
C AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l)
|
|
C EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION.
|
|
C
|
|
C THIS IS THE VERSION USED BY THE DIRECT PROBLEM
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNH3
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: BB, CC, DIAK, PSI
|
|
C
|
|
C *** IS THERE A LIQUID PHASE? ******************************************
|
|
C
|
|
IF ((WATER) <= TINY) RETURN
|
|
C
|
|
C *** CALCULATE NH3 SUBLIMATION *****************************************
|
|
C
|
|
A1 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0
|
|
CHI1 = MOLAL(3)
|
|
CHI2 = MOLAL(1)
|
|
C
|
|
BB =(CHI2 + ONE/A1) ! a=1; b!=1; c!=1
|
|
CC =-CHI1/A1
|
|
DIAK = SQRT(BB*BB - 4.D0*CC) ! Always > 0
|
|
PSI = 0.5d0*(-BB + DIAK) ! One positive root
|
|
PSI = MAX(MIN(PSI,CHI1), TINY) ! Constrict in acceptible range
|
|
C
|
|
C *** CALCULATE NH3 SPECIATION IN THE GAS PHASE *************************
|
|
C
|
|
GNH3 = PSI ! GAS HNO3
|
|
C
|
|
C *** CALCULATE NH3 AFFECT IN THE LIQUID PHASE **************************
|
|
C
|
|
MOLAL(3) = CHI1 - PSI ! NH4+
|
|
MOLAL(1) = CHI2 + PSI ! H+
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCNH3 *****************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNHA
|
|
C
|
|
C THIS SUBROUTINE CALCULATES THE DISSOLUTION OF HCL, HNO3 AT
|
|
C THE PRESENCE OF (H,SO4). HCL, HNO3 ARE CONSIDERED MINOR SPECIES,
|
|
C THAT DO NOT SIGNIFICANTLY AFFECT THE EQUILIBRIUM POINT.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNHA
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: M1, M2, M3, DELCL, DELNO, OMEGA
|
|
CHARACTER(LEN=40) errinf
|
|
C
|
|
C *** SPECIAL CASE; WATER=ZERO ******************************************
|
|
C
|
|
IF ((WATER) <= TINY) THEN
|
|
c wz
|
|
GOTO 55
|
|
C
|
|
C *** SPECIAL CASE; HCL=HNO3=ZERO ***************************************
|
|
C
|
|
ELSEIF ((W(5)) <= TINY .AND. (W(4)) <= TINY) THEN
|
|
GOTO 60
|
|
C
|
|
C *** SPECIAL CASE; HCL=ZERO ********************************************
|
|
C
|
|
ELSE IF ((W(5)) <= TINY) THEN
|
|
CALL CALCNA ! CALL HNO3 DISSOLUTION ROUTINE
|
|
GOTO 60
|
|
C
|
|
C *** SPECIAL CASE; HNO3=ZERO *******************************************
|
|
C
|
|
ELSE IF ((W(4)) <= TINY) THEN
|
|
CALL CALCHA ! CALL HCL DISSOLUTION ROUTINE
|
|
GOTO 60
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE EQUILIBRIUM CONSTANTS ***********************************
|
|
C
|
|
A3 = XK4*R*TEMP*(WATER/GAMA(10))**2.D0 ! HNO3
|
|
A4 = XK3*R*TEMP*(WATER/GAMA(11))**2.D0 ! HCL
|
|
C
|
|
C *** CALCULATE CUBIC EQUATION COEFFICIENTS *****************************
|
|
C
|
|
DELCL = ZERO
|
|
DELNO = ZERO
|
|
C
|
|
OMEGA = MOLAL(1) ! H+
|
|
CHI3 = W(4) ! HNO3
|
|
CHI4 = W(5) ! HCL
|
|
C
|
|
C1 = A3*CHI3
|
|
C2 = A4*CHI4
|
|
C3 = A3 - A4
|
|
C
|
|
M1 = (C1 + C2 + (OMEGA+A4)*C3)/C3
|
|
M2 = ((OMEGA+A4)*C2 - A4*C3*CHI4)/C3
|
|
M3 =-A4*C2*CHI4/C3
|
|
C
|
|
C *** CALCULATE ROOTS ***************************************************
|
|
C
|
|
CALL POLY3 (M1, M2, M3, DELCL, ISLV) ! HCL DISSOLUTION
|
|
|
|
IF (ISLV /= 0) THEN
|
|
DELCL = TINY ! TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT
|
|
C
|
|
C * Commenting this error since the tiny assumption was shown to be
|
|
C * reliable by A.Nenes.
|
|
C
|
|
C WRITE (ERRINF,'(1PE10.1)') TINY
|
|
C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
DELCL = MIN(DELCL, CHI4)
|
|
C
|
|
DELNO = C1*DELCL/(C2 + C3*DELCL)
|
|
DELNO = MIN(DELNO, CHI3)
|
|
C
|
|
IF ((DELCL) < ZERO .OR. (DELNO) < ZERO .OR.
|
|
& (DELCL) > (CHI4) .OR. (DELNO) > (CHI3)) THEN
|
|
DELCL = TINY ! TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT
|
|
DELNO = TINY
|
|
C
|
|
C * Commenting this error since the tiny assumption was shown to be
|
|
C * reliable by A.Nenes.
|
|
C
|
|
C WRITE (ERRINF,'(1PE10.1)') TINY
|
|
C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
CCC
|
|
CCC *** COMPARE DELTA TO TOTAL H+ ; ESTIMATE EFFECT TO HSO4 ***************
|
|
CCC
|
|
CC IF ((DELCL+DELNO)/MOLAL(1) > 0.1d0) THEN
|
|
CC WRITE (ERRINF,'(1PE10.3)') (DELCL+DELNO)/MOLAL(1)*100.0
|
|
CC CALL PUSHERR (0021, ERRINF)
|
|
CC ENDIF
|
|
C
|
|
C *** EFFECT ON LIQUID PHASE ********************************************
|
|
C
|
|
50 MOLAL(1) = MOLAL(1) + (DELNO+DELCL) ! H+ CHANGE
|
|
MOLAL(4) = MOLAL(4) + DELCL ! CL- CHANGE
|
|
MOLAL(7) = MOLAL(7) + DELNO ! NO3- CHANGE
|
|
C
|
|
C *** EFFECT ON GAS PHASE ***********************************************
|
|
C
|
|
55 GHCL = MAX((W(5) - MOLAL(4)), TINY)
|
|
GHNO3 = MAX((W(4) - MOLAL(7)), TINY)
|
|
C
|
|
60 RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCNHA *****************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCAMAQ
|
|
C *** THIS SUBROUTINE CALCULATES THE NH3(aq) GENERATED FROM (H,NH4+).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCAMAQ (NH4I, OHI, DELT)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: NH4I, OHI, OM1, OM2, BB, CC, DD, DEL1, DEL2
|
|
CC CHARACTER(LEN=40) errinf
|
|
C
|
|
C *** EQUILIBRIUM CONSTANTS
|
|
C
|
|
A22 = XK22/XKW/WATER*(GAMA(8)/GAMA(9))**2.D0 ! GAMA(NH3) ASSUMED 1
|
|
AKW = XKW *RH*WATER*WATER
|
|
C
|
|
C *** FIND ROOT
|
|
C
|
|
OM1 = NH4I
|
|
OM2 = OHI
|
|
BB =-(OM1+OM2+A22*AKW)
|
|
CC = OM1*OM2
|
|
DD = SQRT(BB*BB-4.D0*CC)
|
|
|
|
DEL1 = 0.5D0*(-BB - DD)
|
|
DEL2 = 0.5D0*(-BB + DD)
|
|
C
|
|
C *** GET APPROPRIATE ROOT.
|
|
C
|
|
IF ((DEL1) < ZERO) THEN
|
|
IF ((DEL2) > (NH4I) .OR. (DEL2) > (OHI)) THEN
|
|
DELT = ZERO
|
|
ELSE
|
|
DELT = DEL2
|
|
ENDIF
|
|
ELSE
|
|
DELT = DEL1
|
|
ENDIF
|
|
CC
|
|
CC *** COMPARE DELTA TO TOTAL NH4+ ; ESTIMATE EFFECT *********************
|
|
CC
|
|
CC IF (DELTA/HYD > 0.1d0) THEN
|
|
CC WRITE (ERRINF,'(1PE10.3)') DELTA/HYD*100.0
|
|
CC CALL PUSHERR (0020, ERRINF)
|
|
CC ENDIF
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCAMAQ ****************************************
|
|
C
|
|
END
|
|
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCAMAQ2
|
|
C
|
|
C THIS SUBROUTINE CALCULATES THE NH3(aq) GENERATED FROM (H,NH4+).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCAMAQ2 (GGNH3, NH4I, OHI, NH3AQ)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: NH4I, NH3AQ, ALF1, ALF2, BB, CC, DEL, OHI
|
|
C
|
|
C *** EQUILIBRIUM CONSTANTS
|
|
C
|
|
A22 = XK22/XKW/WATER*(GAMA(8)/GAMA(9))**2.d0 ! GAMA(NH3) ASSUMED 1
|
|
AKW = XKW *RH*WATER*WATER
|
|
C
|
|
C *** FIND ROOT
|
|
C
|
|
ALF1 = NH4I - GGNH3
|
|
ALF2 = GGNH3
|
|
BB = ALF1 + A22*AKW
|
|
CC =-A22*AKW*ALF2
|
|
DEL = 0.5D0*(-BB + SQRT(BB*BB-4.D0*CC))
|
|
C
|
|
C *** ADJUST CONCENTRATIONS
|
|
C
|
|
NH4I = ALF1 + DEL
|
|
OHI = DEL
|
|
IF ((OHI) <= TINY) OHI = SQRT(AKW) ! If solution is neutral.
|
|
NH3AQ = ALF2 - DEL
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCAMAQ2 ****************************************
|
|
C
|
|
END
|
|
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCCLAQ
|
|
C
|
|
C THIS SUBROUTINE CALCULATES THE HCL(aq) GENERATED FROM (H+,CL-).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCCLAQ (CLI, HI, DELT)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: CLI, HI, OM1, OM2, BB, CC, DD, DELT
|
|
C
|
|
C *** EQUILIBRIUM CONSTANTS
|
|
C
|
|
A32 = XK32*WATER/(GAMA(11))**2.D0 ! GAMA(HCL) ASSUMED 1
|
|
C
|
|
C *** FIND ROOT
|
|
C
|
|
OM1 = CLI
|
|
OM2 = HI
|
|
BB =-(OM1+OM2+A32)
|
|
CC = OM1*OM2
|
|
DD = SQRT(BB*BB-4.D0*CC)
|
|
|
|
DEL1 = 0.5D0*(-BB - DD)
|
|
DEL2 = 0.5D0*(-BB + DD)
|
|
C
|
|
C *** GET APPROPRIATE ROOT.
|
|
C
|
|
IF ((DEL1) < ZERO) THEN
|
|
IF ((DEL2) < ZERO .OR. (DEL2) > (CLI) .OR.
|
|
+ (DEL2) > (HI)) THEN
|
|
DELT = ZERO
|
|
ELSE
|
|
DELT = DEL2
|
|
ENDIF
|
|
ELSE
|
|
DELT = DEL1
|
|
ENDIF
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCCLAQ ****************************************
|
|
C
|
|
END
|
|
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCCLAQ2
|
|
C
|
|
C THIS SUBROUTINE CALCULATES THE HCL(aq) GENERATED FROM (H+,CL-).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCCLAQ2 (GGCL, CLI, HI, CLAQ)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: GGCL, CLI, HI, CLAQ, ALF1, ALF2, DEL1
|
|
C
|
|
C *** EQUILIBRIUM CONSTANTS
|
|
C
|
|
A32 = XK32*WATER/(GAMA(11))**2.D0 ! GAMA(HCL) ASSUMED 1
|
|
AKW = XKW *RH*WATER*WATER
|
|
C
|
|
C *** FIND ROOT
|
|
C
|
|
ALF1 = CLI - GGCL
|
|
ALF2 = GGCL
|
|
COEF = (ALF1+A32)
|
|
DEL1 = 0.5d0*(-COEF + SQRT(COEF*COEF+4.D0*A32*ALF2))
|
|
C
|
|
C *** CORRECT CONCENTRATIONS
|
|
C
|
|
CLI = ALF1 + DEL1
|
|
HI = DEL1
|
|
IF ((HI) <= TINY) HI = SQRT(AKW) ! If solution is neutral.
|
|
CLAQ = ALF2 - DEL1
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCCLAQ2 ****************************************
|
|
C
|
|
END
|
|
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNIAQ
|
|
C
|
|
C THIS SUBROUTINE CALCULATES THE HNO3(aq) GENERATED FROM (H,NO3-).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNIAQ (NO3I, HI, DELT)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: NO3I, HI, DELT
|
|
REAL*8 :: OM1, OM2, BB, CC, DD, DEL1, DEL2
|
|
C
|
|
C *** EQUILIBRIUM CONSTANTS
|
|
C
|
|
A42 = XK42*WATER/(GAMA(10))**2.D0 ! GAMA(HNO3) ASSUMED 1
|
|
C
|
|
C *** FIND ROOT
|
|
C
|
|
OM1 = NO3I
|
|
OM2 = HI
|
|
BB =-(OM1+OM2+A42)
|
|
CC = OM1*OM2
|
|
DD = SQRT(BB*BB-4.D0*CC)
|
|
|
|
DEL1 = 0.5D0*(-BB - DD)
|
|
DEL2 = 0.5D0*(-BB + DD)
|
|
C
|
|
C *** GET APPROPRIATE ROOT.
|
|
C
|
|
IF ((DEL1) < ZERO .OR. (DEL1) > (HI) .OR.
|
|
& (DEL1) > (NO3I)) THEN
|
|
DELT = ZERO
|
|
ELSE
|
|
DELT = DEL1
|
|
RETURN
|
|
ENDIF
|
|
C
|
|
IF ((DEL2) < ZERO .OR. (DEL2) > (NO3I) .OR.
|
|
& (DEL2) > (HI)) THEN
|
|
DELT = ZERO
|
|
ELSE
|
|
DELT = DEL2
|
|
ENDIF
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCNIAQ ****************************************
|
|
C
|
|
END
|
|
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNIAQ2
|
|
C
|
|
C THIS SUBROUTINE CALCULATES THE UNDISSOCIATED HNO3(aq)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: GGNO3, NO3I, HI, NO3AQ
|
|
REAL*8 :: OM1, OM2, BB, CC, DD, ALF1, ALF2, ALF3, DEL1
|
|
C
|
|
C *** EQUILIBRIUM CONSTANTS
|
|
C
|
|
A42 = XK42*WATER/(GAMA(10))**2.d0 ! GAMA(HNO3) ASSUMED 1
|
|
AKW = XKW *RH*WATER*WATER
|
|
C
|
|
C *** FIND ROOT
|
|
C
|
|
ALF1 = NO3I - GGNO3
|
|
ALF2 = GGNO3
|
|
ALF3 = HI
|
|
C
|
|
BB = ALF3 + ALF1 + A42
|
|
CC = ALF3*ALF1 - A42*ALF2
|
|
DEL1 = 0.5d0*(-BB + SQRT(BB*BB-4.D0*CC))
|
|
C
|
|
C *** CORRECT CONCENTRATIONS
|
|
C
|
|
NO3I = ALF1 + DEL1
|
|
HI = ALF3 + DEL1
|
|
IF ((HI) <= TINY) HI = SQRT(AKW) ! If solution is neutral.
|
|
NO3AQ = ALF2 - DEL1
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCNIAQ2 ****************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCMR
|
|
C *** THIS SUBROUTINE CALCULATES:
|
|
C 1. ION PAIR CONCENTRATIONS (FROM [MOLAR] ARRAY)
|
|
C 2. WATER CONTENT OF LIQUID AEROSOL PHASE (FROM ZSR CORRELATION)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCMR
|
|
INCLUDE 'isrpia_adj.inc'
|
|
|
|
CHARACTER SC*1
|
|
REAL*8 :: HSO4I, SO4I, AML5, TOTS4, FRNO3, FRCL, FRNH4
|
|
C
|
|
C *** CALCULATE ION PAIR CONCENTRATIONS ACCORDING TO SPECIFIC CASE ****
|
|
C
|
|
SC =SCASE(1:1) ! SULRAT & SODRAT case
|
|
C
|
|
C *** NH4-SO4 SYSTEM ; SULFATE POOR CASE
|
|
C
|
|
IF (SC == 'A') THEN
|
|
MOLALR(4) = MOLAL(5)+MOLAL(6) ! (NH4)2SO4 - CORRECT FOR SO4 TO HSO4
|
|
C
|
|
C *** NH4-SO4 SYSTEM ; SULFATE RICH CASE ; NO FREE ACID
|
|
C
|
|
ELSE IF (SC == 'B') THEN
|
|
SO4I = MOLAL(5)-MOLAL(1) ! CORRECT FOR HSO4 DISSOCIATION
|
|
HSO4I = MOLAL(6)+MOLAL(1)
|
|
IF ((SO4I) < (HSO4I)) THEN
|
|
MOLALR(13) = SO4I ! [LC] = [SO4]
|
|
MOLALR(9) = MAX(HSO4I-SO4I, ZERO) ! NH4HSO4
|
|
ELSE
|
|
MOLALR(13) = HSO4I ! [LC] = [HSO4]
|
|
MOLALR(4) = MAX(SO4I-HSO4I, ZERO) ! (NH4)2SO4
|
|
ENDIF
|
|
C
|
|
C *** NH4-SO4 SYSTEM ; SULFATE RICH CASE ; FREE ACID
|
|
C
|
|
ELSE IF (SC == 'C') THEN
|
|
MOLALR(9) = MOLAL(3) ! NH4HSO4
|
|
MOLALR(7) = MAX(W(2)-W(3), ZERO) ! H2SO4
|
|
C
|
|
C *** NH4-SO4-NO3 SYSTEM ; SULFATE POOR CASE
|
|
C
|
|
ELSE IF (SC == 'D') THEN
|
|
MOLALR(4) = MOLAL(5) + MOLAL(6) ! (NH4)2SO4
|
|
AML5 = MOLAL(3)-2.D0*MOLALR(4) ! "free" NH4
|
|
MOLALR(5) = MAX(MIN(AML5,MOLAL(7)), ZERO)! NH4NO3 = MIN("free", NO3)
|
|
C
|
|
C *** NH4-SO4-NO3 SYSTEM ; SULFATE RICH CASE ; NO FREE ACID
|
|
C
|
|
ELSE IF (SC == 'E') THEN
|
|
SO4I = MAX(MOLAL(5)-MOLAL(1),ZERO) ! FROM HSO4 DISSOCIATION
|
|
HSO4I = MOLAL(6)+MOLAL(1)
|
|
IF ((SO4I) < (HSO4I)) THEN
|
|
MOLALR(13) = SO4I ! [LC] = [SO4]
|
|
MOLALR(9) = MAX(HSO4I-SO4I, ZERO) ! NH4HSO4
|
|
ELSE
|
|
MOLALR(13) = HSO4I ! [LC] = [HSO4]
|
|
MOLALR(4) = MAX(SO4I-HSO4I, ZERO) ! (NH4)2SO4
|
|
ENDIF
|
|
C
|
|
C *** NH4-SO4-NO3 SYSTEM ; SULFATE RICH CASE ; FREE ACID
|
|
C
|
|
ELSE IF (SC == 'F') THEN
|
|
MOLALR(9) = MOLAL(3) ! NH4HSO4
|
|
MOLALR(7) = MAX(MOLAL(5)+MOLAL(6)-MOLAL(3),ZERO) ! H2SO4
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM POOR CASE
|
|
C
|
|
ELSE IF (SC == 'G') THEN
|
|
MOLALR(2) = 0.5D0*MOLAL(2) ! NA2SO4
|
|
TOTS4 = MOLAL(5)+MOLAL(6) ! Total SO4
|
|
MOLALR(4) = MAX(TOTS4 - MOLALR(2), ZERO) ! (NH4)2SO4
|
|
FRNH4 = MAX(MOLAL(3) - 2.D0*MOLALR(4), ZERO)
|
|
MOLALR(5) = MIN(MOLAL(7),FRNH4) ! NH4NO3
|
|
FRNH4 = MAX(FRNH4 - MOLALR(5), ZERO)
|
|
MOLALR(6) = MIN(MOLAL(4), FRNH4) ! NH4CL
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM RICH CASE
|
|
C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/
|
|
C
|
|
ELSE IF (SC == 'H') THEN
|
|
MOLALR(1) = PSI7 ! NACL
|
|
MOLALR(2) = PSI1 ! NA2SO4
|
|
MOLALR(3) = PSI8 ! NANO3
|
|
MOLALR(4) = ZERO ! (NH4)2SO4
|
|
FRNO3 = MAX(MOLAL(7) - MOLALR(3), ZERO) ! "FREE" NO3
|
|
FRCL = MAX(MOLAL(4) - MOLALR(1), ZERO) ! "FREE" CL
|
|
MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3
|
|
FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3
|
|
MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE RICH CASE ; NO FREE ACID
|
|
C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/
|
|
C
|
|
ELSE IF (SC == 'I') THEN
|
|
MOLALR(04) = PSI5 ! (NH4)2SO4
|
|
MOLALR(02) = PSI4 ! NA2SO4
|
|
MOLALR(09) = PSI1 ! NH4HSO4
|
|
MOLALR(12) = PSI3 ! NAHSO4
|
|
MOLALR(13) = PSI2 ! LC
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE RICH CASE ; FREE ACID
|
|
C
|
|
ELSE IF (SC == 'J') THEN
|
|
MOLALR(09) = MOLAL(3) ! NH4HSO4
|
|
MOLALR(12) = MOLAL(2) ! NAHSO4
|
|
MOLALR(07) = MOLAL(5)+MOLAL(6)-MOLAL(3)-MOLAL(2) ! H2SO4
|
|
MOLALR(07) = MAX(MOLALR(07),ZERO)
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL-CA-K-MG SYSTEM ; SULFATE POOR ; CR+NA POOR CASE
|
|
C
|
|
ELSE IF (SC.EQ.'O') THEN
|
|
MOLALR(2) = 0.5D0*MOLAL(2) ! NA2SO4
|
|
TOTS4 = MOLAL(5)+MOLAL(6) ! Total SO4
|
|
MOLALR(17)= 0.5D0*MOLAL(9) ! K2SO4
|
|
MOLALR(21)= MOLAL(10) ! MGSO4
|
|
MOLALR(4) = MAX(TOTS4 - MOLALR(2) - MOLALR(17)
|
|
& - MOLALR(21), ZERO) ! (NH4)2SO4
|
|
FRNH4 = MAX(MOLAL(3) - 2.D0*MOLALR(4), ZERO)
|
|
MOLALR(5) = MIN(MOLAL(7),FRNH4) ! NH4NO3
|
|
FRNH4 = MAX(FRNH4 - MOLALR(5), ZERO)
|
|
MOLALR(6) = MIN(MOLAL(4), FRNH4) ! NH4CL
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL-CA-K-MG SYSTEM ; SULFATE POOR ; CR+NA RICH; CR POOR CASE
|
|
C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/
|
|
C
|
|
ELSE IF (SC.EQ.'M') THEN
|
|
MOLALR(1) = PSI7 ! NACL
|
|
MOLALR(2) = PSI1 ! NA2SO4
|
|
MOLALR(3) = PSI8 ! NANO3
|
|
MOLALR(4) = ZERO ! (NH4)2SO4
|
|
FRNO3 = MAX(MOLAL(7) - MOLALR(3), ZERO) ! "FREE" NO3
|
|
FRCL = MAX(MOLAL(4) - MOLALR(1), ZERO) ! "FREE" CL
|
|
MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3
|
|
FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3
|
|
MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL
|
|
MOLALR(17)= PSI9 ! K2SO4
|
|
MOLALR(21)= PSI10 ! MGSO4
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL-CA-K-MG SYSTEM ; SULFATE POOR ; CR+NA RICH; CR RICH CASE
|
|
C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/
|
|
C
|
|
ELSE IF (SC.EQ.'P') THEN
|
|
MOLALR(1) = PSI7 ! NACL
|
|
MOLALR(3) = PSI8 ! NANO3
|
|
MOLALR(15)= PSI12 ! CANO32
|
|
MOLALR(16)= PSI17 ! CACL2
|
|
MOLALR(19)= PSI13 ! KNO3
|
|
MOLALR(20)= PSI14 ! KCL
|
|
MOLALR(22)= PSI15 ! MGNO32
|
|
MOLALR(23)= PSI16 ! MGCL2
|
|
FRNO3 = MAX(MOLAL(7)-MOLALR(3)-2.D0*MOLALR(15)
|
|
& -MOLALR(19)-2.D0*MOLALR(22), ZERO) ! "FREE" NO3
|
|
FRCL = MAX(MOLAL(4)-MOLALR(1)-2.D0*MOLALR(16)
|
|
& -MOLALR(20)-2.D0*MOLALR(23), ZERO) ! "FREE" CL
|
|
MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3
|
|
FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3
|
|
MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL
|
|
MOLALR(17)= PSI9 ! K2SO4
|
|
MOLALR(21)= PSI10 ! MGSO4
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL-CA-K-MG SYSTEM ; SULFATE RICH CASE ; NO FREE ACID
|
|
C
|
|
ELSE IF (SC.EQ.'L') THEN
|
|
MOLALR(04) = PSI5 ! (NH4)2SO4
|
|
MOLALR(02) = PSI4 ! NA2SO4
|
|
MOLALR(09) = PSI1 ! NH4HSO4
|
|
MOLALR(12) = PSI3 ! NAHSO4
|
|
MOLALR(13) = PSI2 ! LC
|
|
MOLALR(17) = PSI6 ! K2SO4
|
|
MOLALR(21) = PSI7 ! MGSO4
|
|
MOLALR(18) = PSI8 ! KHSO4
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL-CA-K-MG SYSTEM ; SULFATE SUPER RICH CASE ; FREE ACID
|
|
C
|
|
ELSE IF (SC.EQ.'K') THEN
|
|
MOLALR(09) = MOLAL(3) ! NH4HSO4
|
|
MOLALR(12) = MOLAL(2) ! NAHSO4
|
|
MOLALR(14) = MOLAL(8) ! CASO4
|
|
MOLALR(18) = MOLAL(9) ! KHSO4
|
|
MOLALR(07) = MOLAL(5)+MOLAL(6)-MOLAL(3)
|
|
& -MOLAL(2)-MOLAL(8)-MOLAL(9) ! H2SO4
|
|
MOLALR(07) = MAX(MOLALR(07),ZERO)
|
|
C
|
|
C ======= REVERSE PROBLEMS ===========================================
|
|
C
|
|
C *** NH4-SO4-NO3 SYSTEM ; SULFATE POOR CASE
|
|
C
|
|
ELSE IF (SC == 'N') THEN
|
|
MOLALR(4) = MOLAL(5) + MOLAL(6) ! (NH4)2SO4
|
|
AML5 = WAER(3)-2.D0*MOLALR(4) ! "free" NH4
|
|
MOLALR(5) = MAX(MIN(AML5,WAER(4)), ZERO) ! NH4NO3 = MIN("free", NO3)
|
|
C
|
|
C *** NH4-SO4-NO3-NA-CL SYSTEM ; SULFATE POOR, SODIUM POOR CASE
|
|
C
|
|
ELSE IF (SC == 'Q') THEN
|
|
MOLALR(2) = PSI1 ! NA2SO4
|
|
MOLALR(4) = PSI6 ! (NH4)2SO4
|
|
MOLALR(5) = PSI5 ! NH4NO3
|
|
MOLALR(6) = PSI4 ! NH4CL
|
|
C
|
|
C *** NH4-SO4-NO3-NA-CL SYSTEM ; SULFATE POOR, SODIUM RICH CASE
|
|
C
|
|
ELSE IF (SC == 'R') THEN
|
|
MOLALR(1) = PSI3 ! NACL
|
|
MOLALR(2) = PSI1 ! NA2SO4
|
|
MOLALR(3) = PSI2 ! NANO3
|
|
MOLALR(4) = ZERO ! (NH4)2SO4
|
|
MOLALR(5) = PSI5 ! NH4NO3
|
|
MOLALR(6) = PSI4 ! NH4CL
|
|
C
|
|
C *** NH4-SO4-NO3-NA-CL-CA-K-MG SYSTEM ; SULFATE POOR, CRUSTAL&SODIUM POOR CASE
|
|
C
|
|
ELSE IF (SC.EQ.'V') THEN
|
|
MOLALR(2) = PSI1 ! NA2SO4
|
|
MOLALR(4) = PSI6 ! (NH4)2SO4
|
|
MOLALR(5) = PSI5 ! NH4NO3
|
|
MOLALR(6) = PSI4 ! NH4CL
|
|
MOLALR(17)= PSI7 ! K2SO4
|
|
MOLALR(21)= PSI8 ! MGSO4
|
|
C
|
|
C *** NH4-SO4-NO3-NA-CL-CA-K-MG SYSTEM ; SULFATE POOR, CRUSTAL&SODIUM RICH, CRUSTAL POOR CASE
|
|
C
|
|
ELSE IF (SC.EQ.'U') THEN
|
|
MOLALR(1) = PSI3 ! NACL
|
|
MOLALR(2) = PSI1 ! NA2SO4
|
|
MOLALR(3) = PSI2 ! NANO3
|
|
MOLALR(5) = PSI5 ! NH4NO3
|
|
MOLALR(6) = PSI4 ! NH4CL
|
|
MOLALR(17)= PSI7 ! K2SO4
|
|
MOLALR(21)= PSI8 ! MGSO4
|
|
C
|
|
C *** NH4-SO4-NO3-NA-CL-CA-K-MG SYSTEM ; SULFATE POOR, CRUSTAL&SODIUM RICH, CRUSTAL RICH CASE
|
|
C
|
|
ELSE IF (SC.EQ.'W') THEN
|
|
MOLALR(1) = PSI7 ! NACL
|
|
MOLALR(3) = PSI8 ! NANO3
|
|
MOLALR(5) = PSI6 ! NH4NO3
|
|
MOLALR(6) = PSI5 ! NH4CL
|
|
MOLALR(15)= PSI12 ! CANO32
|
|
MOLALR(16)= PSI17 ! CACL2
|
|
MOLALR(17)= PSI9 ! K2SO4
|
|
MOLALR(19)= PSI13 ! KNO3
|
|
MOLALR(20)= PSI14 ! KCL
|
|
MOLALR(21)= PSI10 ! MGSO4
|
|
MOLALR(22)= PSI15 ! MGNO32
|
|
MOLALR(23)= PSI16 ! MGCL2
|
|
C
|
|
C *** UNKNOWN CASE
|
|
C
|
|
ELSE
|
|
CALL PUSHERR (1001, ' ') ! FATAL ERROR: CASE NOT SUPPORTED
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
WATER = ZERO
|
|
DO I=1,NPAIR
|
|
WATER = WATER + MOLALR(I)/M0(I)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCMR ******************************************
|
|
C
|
|
END
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCMDRH
|
|
C
|
|
C THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL
|
|
C DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED
|
|
C SOLUTIONS ; THE 'DRY' SOLUTION (SUBROUTINE DRYCASE) AND THE
|
|
C 'SATURATED LIQUID' SOLUTION (SUBROUTINE LIQCASE).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCMDRH (RHI, RHDRY, RHLIQ, DRYCASE, LIQCASE)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
EXTERNAL DRYCASE, LIQCASE
|
|
C
|
|
C *** FIND WEIGHT FACTOR **********************************************
|
|
C
|
|
IF (WFTYP.EQ.0) THEN
|
|
WF = ONE
|
|
ELSEIF (WFTYP.EQ.1) THEN
|
|
WF = 0.5D0
|
|
ELSE
|
|
WF = (RHLIQ-RHI)/(RHLIQ-RHDRY)
|
|
ENDIF
|
|
ONEMWF = ONE - WF
|
|
C
|
|
C *** FIND FIRST SECTION ; DRY ONE ************************************
|
|
C
|
|
CALL DRYCASE
|
|
IF (ABS(ONEMWF).LE.1D-5) GOTO 200 ! DRY AEROSOL
|
|
C
|
|
CNH42SO = CNH42S4 ! FIRST (DRY) SOLUTION
|
|
CNH4HSO = CNH4HS4
|
|
CLCO = CLC
|
|
CNH4N3O = CNH4NO3
|
|
CNH4CLO = CNH4CL
|
|
CNA2SO = CNA2SO4
|
|
CNAHSO = CNAHSO4
|
|
CNANO = CNANO3
|
|
CNACLO = CNACL
|
|
GNH3O = GNH3
|
|
GHNO3O = GHNO3
|
|
GHCLO = GHCL
|
|
C
|
|
C *** FIND SECOND SECTION ; DRY & LIQUID ******************************
|
|
C
|
|
CNH42S4 = ZERO
|
|
CNH4HS4 = ZERO
|
|
CLC = ZERO
|
|
CNH4NO3 = ZERO
|
|
CNH4CL = ZERO
|
|
CNA2SO4 = ZERO
|
|
CNAHSO4 = ZERO
|
|
CNANO3 = ZERO
|
|
CNACL = ZERO
|
|
GNH3 = ZERO
|
|
GHNO3 = ZERO
|
|
GHCL = ZERO
|
|
CALL LIQCASE ! SECOND (LIQUID) SOLUTION
|
|
C
|
|
C *** ADJUST THINGS FOR THE CASE THAT THE LIQUID SUB PREDICTS DRY AEROSOL
|
|
C
|
|
IF (WATER.LE.TINY) THEN
|
|
DO 100 I=1,NIONS
|
|
MOLAL(I)= ZERO ! Aqueous phase
|
|
100 CONTINUE
|
|
WATER = ZERO
|
|
C
|
|
CNH42S4 = CNH42SO ! Solid phase
|
|
CNA2SO4 = CNA2SO
|
|
CNAHSO4 = CNAHSO
|
|
CNH4HS4 = CNH4HSO
|
|
CLC = CLCO
|
|
CNH4NO3 = CNH4N3O
|
|
CNANO3 = CNANO
|
|
CNACL = CNACLO
|
|
CNH4CL = CNH4CLO
|
|
C
|
|
GNH3 = GNH3O ! Gas phase
|
|
GHNO3 = GHNO3O
|
|
GHCL = GHCLO
|
|
C
|
|
GOTO 200
|
|
ENDIF
|
|
C
|
|
C *** FIND SALT DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS.
|
|
C
|
|
DAMSUL = CNH42SO - CNH42S4
|
|
DSOSUL = CNA2SO - CNA2SO4
|
|
DAMBIS = CNH4HSO - CNH4HS4
|
|
DSOBIS = CNAHSO - CNAHSO4
|
|
DLC = CLCO - CLC
|
|
DAMNIT = CNH4N3O - CNH4NO3
|
|
DAMCHL = CNH4CLO - CNH4CL
|
|
DSONIT = CNANO - CNANO3
|
|
DSOCHL = CNACLO - CNACL
|
|
C
|
|
C *** FIND GAS DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS.
|
|
C
|
|
DAMG = GNH3O - GNH3
|
|
DHAG = GHCLO - GHCL
|
|
DNAG = GHNO3O - GHNO3
|
|
C
|
|
C *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS.
|
|
C
|
|
C LIQUID
|
|
C
|
|
MOLAL(1)= ONEMWF*MOLAL(1) ! H+
|
|
MOLAL(2)= ONEMWF*(2.D0*DSOSUL + DSOBIS + DSONIT + DSOCHL) ! NA+
|
|
MOLAL(3)= ONEMWF*(2.D0*DAMSUL + DAMG + DAMBIS + DAMCHL +
|
|
& 3.D0*DLC + DAMNIT ) ! NH4+
|
|
MOLAL(4)= ONEMWF*( DAMCHL + DSOCHL + DHAG) ! CL-
|
|
MOLAL(5)= ONEMWF*( DAMSUL + DSOSUL + DLC - MOLAL(6)) ! SO4-- !VB 17 Sept 2001
|
|
MOLAL(6)= ONEMWF*( MOLAL(6) + DSOBIS + DAMBIS + DLC) ! HSO4-
|
|
MOLAL(7)= ONEMWF*( DAMNIT + DSONIT + DNAG) ! NO3-
|
|
WATER = ONEMWF*WATER
|
|
C
|
|
C SOLID
|
|
C
|
|
CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4
|
|
CNA2SO4 = WF*CNA2SO + ONEMWF*CNA2SO4
|
|
CNAHSO4 = WF*CNAHSO + ONEMWF*CNAHSO4
|
|
CNH4HS4 = WF*CNH4HSO + ONEMWF*CNH4HS4
|
|
CLC = WF*CLCO + ONEMWF*CLC
|
|
CNH4NO3 = WF*CNH4N3O + ONEMWF*CNH4NO3
|
|
CNANO3 = WF*CNANO + ONEMWF*CNANO3
|
|
CNACL = WF*CNACLO + ONEMWF*CNACL
|
|
CNH4CL = WF*CNH4CLO + ONEMWF*CNH4CL
|
|
C
|
|
C GAS
|
|
C
|
|
GNH3 = WF*GNH3O + ONEMWF*GNH3
|
|
GHNO3 = WF*GHNO3O + ONEMWF*GHNO3
|
|
GHCL = WF*GHCLO + ONEMWF*GHCL
|
|
C
|
|
C *** RETURN POINT
|
|
C
|
|
200 RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCMDRH ****************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE II
|
|
C *** SUBROUTINE CALCMDRH2
|
|
C
|
|
C THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL
|
|
C DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED
|
|
C SOLUTIONS ; THE 'DRY' SOLUTION (SUBROUTINE DRYCASE) AND THE
|
|
C 'SATURATED LIQUID' SOLUTION (SUBROUTINE LIQCASE).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCMDRH2 (RHI, RHDRY, RHLIQ, DRYCASE, LIQCASE)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
EXTERNAL DRYCASE, LIQCASE
|
|
C
|
|
C *** FIND WEIGHT FACTOR **********************************************
|
|
C
|
|
IF (WFTYP.EQ.0) THEN
|
|
WF = ONE
|
|
ELSEIF (WFTYP.EQ.1) THEN
|
|
WF = 0.5D0
|
|
ELSE
|
|
WF = (RHLIQ-RHI)/(RHLIQ-RHDRY)
|
|
ENDIF
|
|
ONEMWF = ONE - WF
|
|
C
|
|
C *** FIND FIRST SECTION ; DRY ONE ************************************
|
|
C
|
|
CALL DRYCASE
|
|
IF (ABS(ONEMWF).LE.1D-5) GOTO 200 ! DRY AEROSOL
|
|
C
|
|
CNH42SO = CNH42S4 ! FIRST (DRY) SOLUTION
|
|
CNH4HSO = CNH4HS4
|
|
CLCO = CLC
|
|
CNH4N3O = CNH4NO3
|
|
CNH4CLO = CNH4CL
|
|
CNA2SO = CNA2SO4
|
|
CNAHSO = CNAHSO4
|
|
CNANO = CNANO3
|
|
CNACLO = CNACL
|
|
GNH3O = GNH3
|
|
GHNO3O = GHNO3
|
|
GHCLO = GHCL
|
|
C
|
|
CCASO = CCASO4
|
|
CK2SO = CK2SO4
|
|
CMGSO = CMGSO4
|
|
CKHSO = CKHSO4
|
|
CCAN32O = CCANO32
|
|
CCAC2L = CCACL2
|
|
CKN3O = CKNO3
|
|
CKCLO = CKCL
|
|
CMGN32O = CMGNO32
|
|
CMGC2L = CMGCL2
|
|
C
|
|
C *** FIND SECOND SECTION ; DRY & LIQUID ******************************
|
|
C
|
|
CNH42S4 = ZERO
|
|
CNH4HS4 = ZERO
|
|
CLC = ZERO
|
|
CNH4NO3 = ZERO
|
|
CNH4CL = ZERO
|
|
CNA2SO4 = ZERO
|
|
CNAHSO4 = ZERO
|
|
CNANO3 = ZERO
|
|
CNACL = ZERO
|
|
GNH3 = ZERO
|
|
GHNO3 = ZERO
|
|
GHCL = ZERO
|
|
C
|
|
CCASO4 = ZERO
|
|
CK2SO4 = ZERO
|
|
CMGSO4 = ZERO
|
|
CKHSO4 = ZERO
|
|
CCANO32 = ZERO
|
|
CCACL2 = ZERO
|
|
CKNO3 = ZERO
|
|
CKCL = ZERO
|
|
CMGNO32 = ZERO
|
|
CMGCL2 = ZERO
|
|
C
|
|
CALL LIQCASE ! SECOND (LIQUID) SOLUTION
|
|
C
|
|
C *** ADJUST THINGS FOR THE CASE THAT THE LIQUID SUB PREDICTS DRY AEROSOL
|
|
C
|
|
IF (WATER.LE.TINY) THEN
|
|
DO 100 I=1,NIONS
|
|
MOLAL(I)= ZERO ! Aqueous phase
|
|
100 CONTINUE
|
|
WATER = ZERO
|
|
C
|
|
CNH42S4 = CNH42SO ! Solid phase
|
|
CNA2SO4 = CNA2SO
|
|
CNAHSO4 = CNAHSO
|
|
CNH4HS4 = CNH4HSO
|
|
CLC = CLCO
|
|
CNH4NO3 = CNH4N3O
|
|
CNANO3 = CNANO
|
|
CNACL = CNACLO
|
|
CNH4CL = CNH4CLO
|
|
C
|
|
GNH3 = GNH3O ! Gas phase
|
|
GHNO3 = GHNO3O
|
|
GHCL = GHCLO
|
|
C
|
|
CCASO4 = CCASO
|
|
CK2SO4 = CK2SO
|
|
CMGSO4 = CMGSO
|
|
CKHSO4 = CKHSO
|
|
CCANO32 = CCAN32O
|
|
CCACL2 = CCAC2L
|
|
CKNO3 = CKN3O
|
|
CKCL = CKCLO
|
|
CMGNO32 = CMGN32O
|
|
CMGCL2 = CMGC2L
|
|
C
|
|
GOTO 200
|
|
ENDIF
|
|
C
|
|
C *** FIND SALT DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS.
|
|
C
|
|
DAMSUL = CNH42SO - CNH42S4
|
|
DSOSUL = CNA2SO - CNA2SO4
|
|
DAMBIS = CNH4HSO - CNH4HS4
|
|
DSOBIS = CNAHSO - CNAHSO4
|
|
DLC = CLCO - CLC
|
|
DAMNIT = CNH4N3O - CNH4NO3
|
|
DAMCHL = CNH4CLO - CNH4CL
|
|
DSONIT = CNANO - CNANO3
|
|
DSOCHL = CNACLO - CNACL
|
|
C
|
|
DCASUL = CCASO - CCASO4
|
|
DPOSUL = CK2SO - CK2SO4
|
|
DMGSUL = CMGSO - CMGSO4
|
|
DPOBIS = CKHSO - CKHSO4
|
|
DCANIT = CCAN32O - CCANO32
|
|
DCACHL = CCAC2L - CCACL2
|
|
DPONIT = CKN3O - CKNO3
|
|
DPOCHL = CKCLO - CKCL
|
|
DMGNIT = CMGN32O - CMGNO32
|
|
DMGCHL = CMGC2L - CMGCL2
|
|
C
|
|
C *** FIND GAS DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS.
|
|
C
|
|
DAMG = GNH3O - GNH3
|
|
DHAG = GHCLO - GHCL
|
|
DNAG = GHNO3O - GHNO3
|
|
C
|
|
C *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS.
|
|
C
|
|
C LIQUID
|
|
C
|
|
MOLAL(1) = ONEMWF*MOLAL(1) ! H+
|
|
MOLAL(2) = ONEMWF*(2.D0*DSOSUL + DSOBIS + DSONIT + DSOCHL) ! NA+
|
|
MOLAL(3) = ONEMWF*(2.D0*DAMSUL + DAMG + DAMBIS + DAMCHL +
|
|
& 3.D0*DLC + DAMNIT ) ! NH4+
|
|
MOLAL(4) = ONEMWF*(DAMCHL + DSOCHL + DHAG + 2.D0*DCACHL +
|
|
& 2.D0*DMGCHL + DPOCHL) ! CL-
|
|
MOLAL(5) = ONEMWF*(DAMSUL + DSOSUL + DLC - MOLAL(6)
|
|
& +DCASUL + DPOSUL + DMGSUL) ! SO4-- !VB 17 Sept 2001
|
|
MOLAL(6) = ONEMWF*(MOLAL(6) + DSOBIS + DAMBIS + DLC + DPOBIS) ! HSO4-
|
|
MOLAL(7) = ONEMWF*(DAMNIT + DSONIT + DNAG + 2.D0*DCANIT
|
|
& + 2.D0*DMGNIT + DPONIT) ! NO3-
|
|
MOLAL(8) = ONEMWF*(DCASUL + DCANIT + DCACHL) ! CA2+
|
|
MOLAL(9) = ONEMWF*(2.D0*DPOSUL + DPONIT + DPOCHL + DPOBIS) ! K+
|
|
MOLAL(10)= ONEMWF*(DMGSUL + DMGNIT + DMGCHL) ! MG2+
|
|
WATER = ONEMWF*WATER
|
|
C
|
|
C SOLID
|
|
C
|
|
CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4
|
|
CNA2SO4 = WF*CNA2SO + ONEMWF*CNA2SO4
|
|
CNAHSO4 = WF*CNAHSO + ONEMWF*CNAHSO4
|
|
CNH4HS4 = WF*CNH4HSO + ONEMWF*CNH4HS4
|
|
CLC = WF*CLCO + ONEMWF*CLC
|
|
CNH4NO3 = WF*CNH4N3O + ONEMWF*CNH4NO3
|
|
CNANO3 = WF*CNANO + ONEMWF*CNANO3
|
|
CNACL = WF*CNACLO + ONEMWF*CNACL
|
|
CNH4CL = WF*CNH4CLO + ONEMWF*CNH4CL
|
|
C
|
|
CCASO4 = WF*CCASO + ONEMWF*CCASO4
|
|
CK2SO4 = WF*CK2SO + ONEMWF*CK2SO4
|
|
CMGSO4 = WF*CMGSO + ONEMWF*CMGSO4
|
|
CKHSO4 = WF*CKHSO + ONEMWF*CKHSO4
|
|
CCANO32 = WF*CCAN32O + ONEMWF*CCANO32
|
|
CCACL2 = WF*CCAC2L + ONEMWF*CCACL2
|
|
CMGNO32 = WF*CMGN32O + ONEMWF*CMGNO32
|
|
CMGCL2 = WF*CMGC2L + ONEMWF*CMGCL2
|
|
CKCL = WF*CKCLO + ONEMWF*CKCL
|
|
C
|
|
C GAS
|
|
C
|
|
GNH3 = WF*GNH3O + ONEMWF*GNH3
|
|
GHNO3 = WF*GHNO3O + ONEMWF*GHNO3
|
|
GHCL = WF*GHCLO + ONEMWF*GHCL
|
|
C
|
|
C *** RETURN POINT
|
|
C
|
|
200 RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCMDRH2 ****************************************
|
|
C
|
|
END
|
|
C
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCMDRP
|
|
C
|
|
C THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL
|
|
C DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED
|
|
C SOLUTIONS ; THE 'DRY' SOLUTION (SUBROUTINE DRYCASE) AND THE
|
|
C 'SATURATED LIQUID' SOLUTION (SUBROUTINE LIQCASE). (REVERSE PROBLEM)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCMDRP (RHI, RHDRY, RHLIQ, DRYCASE, LIQCASE)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
EXTERNAL DRYCASE, LIQCASE
|
|
C
|
|
C *** FIND WEIGHT FACTOR **********************************************
|
|
C
|
|
IF (WFTYP.EQ.0) THEN
|
|
WF = ONE
|
|
ELSEIF (WFTYP.EQ.1) THEN
|
|
WF = 0.5D0
|
|
ELSE
|
|
WF = (RHLIQ-RHI)/(RHLIQ-RHDRY)
|
|
ENDIF
|
|
ONEMWF = ONE - WF
|
|
C
|
|
C *** FIND FIRST SECTION ; DRY ONE ************************************
|
|
C
|
|
CALL DRYCASE
|
|
IF (ABS(ONEMWF).LE.1D-5) GOTO 200 ! DRY AEROSOL
|
|
C
|
|
CNH42SO = CNH42S4 ! FIRST (DRY) SOLUTION
|
|
CNH4HSO = CNH4HS4
|
|
CLCO = CLC
|
|
CNH4N3O = CNH4NO3
|
|
CNH4CLO = CNH4CL
|
|
CNA2SO = CNA2SO4
|
|
CNAHSO = CNAHSO4
|
|
CNANO = CNANO3
|
|
CNACLO = CNACL
|
|
C
|
|
C *** FIND SECOND SECTION ; DRY & LIQUID ******************************
|
|
C
|
|
CNH42S4 = ZERO
|
|
CNH4HS4 = ZERO
|
|
CLC = ZERO
|
|
CNH4NO3 = ZERO
|
|
CNH4CL = ZERO
|
|
CNA2SO4 = ZERO
|
|
CNAHSO4 = ZERO
|
|
CNANO3 = ZERO
|
|
CNACL = ZERO
|
|
GNH3 = ZERO
|
|
GHNO3 = ZERO
|
|
GHCL = ZERO
|
|
CALL LIQCASE ! SECOND (LIQUID) SOLUTION
|
|
C
|
|
C *** ADJUST THINGS FOR THE CASE THAT THE LIQUID SUB PREDICTS DRY AEROSOL
|
|
C
|
|
IF (WATER.LE.TINY) THEN
|
|
WATER = ZERO
|
|
DO 100 I=1,NIONS
|
|
MOLAL(I)= ZERO
|
|
100 CONTINUE
|
|
CALL DRYCASE
|
|
GOTO 200
|
|
ENDIF
|
|
C
|
|
C *** FIND SALT DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS.
|
|
C
|
|
DAMBIS = CNH4HSO - CNH4HS4
|
|
DSOBIS = CNAHSO - CNAHSO4
|
|
DLC = CLCO - CLC
|
|
C
|
|
C *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS.
|
|
C
|
|
C *** SOLID
|
|
C
|
|
CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4
|
|
CNA2SO4 = WF*CNA2SO + ONEMWF*CNA2SO4
|
|
CNAHSO4 = WF*CNAHSO + ONEMWF*CNAHSO4
|
|
CNH4HS4 = WF*CNH4HSO + ONEMWF*CNH4HS4
|
|
CLC = WF*CLCO + ONEMWF*CLC
|
|
CNH4NO3 = WF*CNH4N3O + ONEMWF*CNH4NO3
|
|
CNANO3 = WF*CNANO + ONEMWF*CNANO3
|
|
CNACL = WF*CNACLO + ONEMWF*CNACL
|
|
CNH4CL = WF*CNH4CLO + ONEMWF*CNH4CL
|
|
C
|
|
C *** LIQUID
|
|
C
|
|
WATER = ONEMWF*WATER
|
|
C
|
|
MOLAL(2)= WAER(1) - 2.D0*CNA2SO4 - CNAHSO4 - CNANO3 -
|
|
& CNACL ! NA+
|
|
MOLAL(3)= WAER(3) - 2.D0*CNH42S4 - CNH4HS4 - CNH4CL -
|
|
& 3.D0*CLC - CNH4NO3 ! NH4+
|
|
MOLAL(4)= WAER(5) - CNACL - CNH4CL ! CL-
|
|
MOLAL(7)= WAER(4) - CNANO3 - CNH4NO3 ! NO3-
|
|
MOLAL(6)= ONEMWF*(MOLAL(6) + DSOBIS + DAMBIS + DLC) ! HSO4-
|
|
MOLAL(5)= WAER(2) - MOLAL(6) - CLC - CNH42S4 - CNA2SO4 ! SO4--
|
|
C
|
|
A8 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.
|
|
IF (MOLAL(5).LE.TINY) THEN
|
|
HIEQ = SQRT(XKW *RH*WATER*WATER) ! Neutral solution
|
|
ELSE
|
|
HIEQ = A8*MOLAL(6)/MOLAL(5)
|
|
ENDIF
|
|
HIEN = MOLAL(4) + MOLAL(7) + MOLAL(6) + 2.D0*MOLAL(5) -
|
|
& MOLAL(2) - MOLAL(3)
|
|
MOLAL(1)= MAX (HIEQ, HIEN) ! H+
|
|
C
|
|
C *** GAS (ACTIVITY COEFS FROM LIQUID SOLUTION)
|
|
C
|
|
A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+
|
|
A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3-
|
|
A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL-
|
|
C
|
|
GNH3 = MOLAL(3)/MAX(MOLAL(1),TINY)/A2
|
|
GHNO3 = MOLAL(1)*MOLAL(7)/A3
|
|
GHCL = MOLAL(1)*MOLAL(4)/A4
|
|
C
|
|
200 RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCMDRP ****************************************
|
|
C
|
|
END
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCMDRPII
|
|
C
|
|
C THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL
|
|
C DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED
|
|
C SOLUTIONS ; THE 'DRY' SOLUTION (SUBROUTINE DRYCASE) AND THE
|
|
C 'SATURATED LIQUID' SOLUTION (SUBROUTINE LIQCASE). (REVERSE PROBLEM)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCMDRPII (RHI, RHDRY, RHLIQ, DRYCASE, LIQCASE)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
EXTERNAL DRYCASE, LIQCASE
|
|
C
|
|
C *** FIND WEIGHT FACTOR **********************************************
|
|
C
|
|
IF (WFTYP.EQ.0) THEN
|
|
WF = ONE
|
|
ELSEIF (WFTYP.EQ.1) THEN
|
|
WF = 0.5D0
|
|
ELSE
|
|
WF = (RHLIQ-RHI)/(RHLIQ-RHDRY)
|
|
ENDIF
|
|
ONEMWF = ONE - WF
|
|
C
|
|
C *** FIND FIRST SECTION ; DRY ONE ************************************
|
|
C
|
|
CALL DRYCASE
|
|
IF (ABS(ONEMWF).LE.1D-5) GOTO 200 ! DRY AEROSOL
|
|
C
|
|
CNH42SO = CNH42S4 ! FIRST (DRY) SOLUTION
|
|
CNH4HSO = CNH4HS4
|
|
CLCO = CLC
|
|
CNH4N3O = CNH4NO3
|
|
CNH4CLO = CNH4CL
|
|
CNA2SO = CNA2SO4
|
|
CNAHSO = CNAHSO4
|
|
CNANO = CNANO3
|
|
CNACLO = CNACL
|
|
C
|
|
CCASO = CCASO4
|
|
CK2SO = CK2SO4
|
|
CMGSO = CMGSO4
|
|
CKHSO = CKHSO4
|
|
CCAN32O = CCANO32
|
|
CCAC2L = CCACL2
|
|
CKN3O = CKNO3
|
|
CKCLO = CKCL
|
|
CMGN32O = CMGNO32
|
|
CMGC2L = CMGCL2
|
|
C
|
|
C *** FIND SECOND SECTION ; DRY & LIQUID ******************************
|
|
C
|
|
CNH42S4 = ZERO
|
|
CNH4HS4 = ZERO
|
|
CLC = ZERO
|
|
CNH4NO3 = ZERO
|
|
CNH4CL = ZERO
|
|
CNA2SO4 = ZERO
|
|
CNAHSO4 = ZERO
|
|
CNANO3 = ZERO
|
|
CNACL = ZERO
|
|
GNH3 = ZERO
|
|
GHNO3 = ZERO
|
|
GHCL = ZERO
|
|
C
|
|
CCASO4 = ZERO
|
|
CK2SO4 = ZERO
|
|
CMGSO4 = ZERO
|
|
CKHSO4 = ZERO
|
|
CCANO32 = ZERO
|
|
CCACL2 = ZERO
|
|
CKNO3 = ZERO
|
|
CKCL = ZERO
|
|
CMGNO32 = ZERO
|
|
CMGCL2 = ZERO
|
|
C
|
|
CALL LIQCASE ! SECOND (LIQUID) SOLUTION
|
|
C
|
|
C *** ADJUST THINGS FOR THE CASE THAT THE LIQUID SUB PREDICTS DRY AEROSOL
|
|
C
|
|
IF (WATER.LE.TINY) THEN
|
|
WATER = ZERO
|
|
DO 100 I=1,NIONS
|
|
MOLAL(I)= ZERO
|
|
100 CONTINUE
|
|
CALL DRYCASE
|
|
GOTO 200
|
|
ENDIF
|
|
C
|
|
C *** FIND SALT DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS.
|
|
C
|
|
DAMBIS = CNH4HSO - CNH4HS4
|
|
DSOBIS = CNAHSO - CNAHSO4
|
|
DLC = CLCO - CLC
|
|
DPOBIS = CKHSO - CKHSO4
|
|
C
|
|
C *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS.
|
|
C
|
|
C *** SOLID
|
|
C
|
|
CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4
|
|
CNA2SO4 = WF*CNA2SO + ONEMWF*CNA2SO4
|
|
CNAHSO4 = WF*CNAHSO + ONEMWF*CNAHSO4
|
|
CNH4HS4 = WF*CNH4HSO + ONEMWF*CNH4HS4
|
|
CLC = WF*CLCO + ONEMWF*CLC
|
|
CNH4NO3 = WF*CNH4N3O + ONEMWF*CNH4NO3
|
|
CNANO3 = WF*CNANO + ONEMWF*CNANO3
|
|
CNACL = WF*CNACLO + ONEMWF*CNACL
|
|
CNH4CL = WF*CNH4CLO + ONEMWF*CNH4CL
|
|
C
|
|
CCASO4 = WF*CCASO + ONEMWF*CCASO4
|
|
CK2SO4 = WF*CK2SO + ONEMWF*CK2SO4
|
|
CMGSO4 = WF*CMGSO + ONEMWF*CMGSO4
|
|
CKHSO4 = WF*CKHSO + ONEMWF*CKHSO4
|
|
CCANO32 = WF*CCAN32O + ONEMWF*CCANO32
|
|
CCACL2 = WF*CCAC2L + ONEMWF*CCACL2
|
|
CMGNO32 = WF*CMGN32O + ONEMWF*CMGNO32
|
|
CMGCL2 = WF*CMGC2L + ONEMWF*CMGCL2
|
|
CKCL = WF*CKCLO + ONEMWF*CKCL
|
|
C
|
|
C *** LIQUID
|
|
C
|
|
WATER = ONEMWF*WATER
|
|
C
|
|
MOLAL(2)= WAER(1) - 2.D0*CNA2SO4 - CNAHSO4 - CNANO3 -
|
|
& CNACL ! NA+
|
|
MOLAL(3)= WAER(3) - 2.D0*CNH42S4 - CNH4HS4 - CNH4CL -
|
|
& 3.D0*CLC - CNH4NO3 ! NH4+
|
|
MOLAL(4)= WAER(5) - CNACL - CNH4CL - 2.D0*CCACL2 -
|
|
& 2.D0*CMGCL2 - CKCL ! CL-
|
|
MOLAL(7)= WAER(4) - CNANO3 - CNH4NO3 - CKNO3
|
|
& - 2.D0*CCANO32 - 2.D0*CMGNO32 ! NO3-
|
|
MOLAL(6)= ONEMWF*(MOLAL(6) + DSOBIS + DAMBIS + DLC + DPOBIS) ! HSO4-
|
|
MOLAL(5)= WAER(2) - MOLAL(6) - CLC - CNH42S4 - CNA2SO4
|
|
& - CCASO4 - CK2SO4 - CMGSO4 ! SO4--
|
|
MOLAL(8)= WAER(6) - CCASO4 - CCANO32 - CCACL2 ! CA++
|
|
MOLAL(9)= WAER(7) - 2.D0*CK2SO4 - CKNO3 - CKCL - CKHSO4 ! K+
|
|
MOLAL(10)=WAER(8) - CMGSO4 - CMGNO32 - CMGCL2 ! MG++
|
|
C
|
|
A8 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.
|
|
IF (MOLAL(5).LE.TINY) THEN
|
|
HIEQ = SQRT(XKW *RH*WATER*WATER) ! Neutral solution
|
|
ELSE
|
|
HIEQ = A8*MOLAL(6)/MOLAL(5)
|
|
ENDIF
|
|
HIEN = MOLAL(4) + MOLAL(7) + MOLAL(6) + 2.D0*MOLAL(5) -
|
|
& MOLAL(2) - MOLAL(3)
|
|
MOLAL(1)= MAX (HIEQ, HIEN) ! H+
|
|
C
|
|
C *** GAS (ACTIVITY COEFS FROM LIQUID SOLUTION)
|
|
C
|
|
A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+
|
|
A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3-
|
|
A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL-
|
|
C
|
|
GNH3 = MOLAL(3)/MAX(MOLAL(1),TINY)/A2
|
|
GHNO3 = MOLAL(1)*MOLAL(7)/A3
|
|
GHCL = MOLAL(1)*MOLAL(4)/A4
|
|
C
|
|
200 RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCMDRPII **************************************
|
|
C
|
|
END
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCHS4
|
|
C *** THIS SUBROUTINE CALCULATES THE HSO4 GENERATED FROM (H,SO4).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCHS4 (HI, SO4I, HSO4I, DELTA)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: HI, SO4I, HSO4I, DELTA, BB, CC, DD, SQDD, DELTA1,
|
|
& DELTA2
|
|
CC CHARACTER(LEN=40) errinf
|
|
C
|
|
C *** IF TOO LITTLE WATER, DONT SOLVE
|
|
C
|
|
IF ((WATER) <= 1d1*TINY) THEN
|
|
DELTA = ZERO
|
|
RETURN
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE HSO4 SPECIATION *****************************************
|
|
C
|
|
A8 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.d0
|
|
C
|
|
BB =-(HI + SO4I + A8)
|
|
CC = HI*SO4I - HSO4I*A8
|
|
DD = BB*BB - 4.D0*CC
|
|
C
|
|
IF ((DD) >= ZERO) THEN
|
|
SQDD = SQRT(DD)
|
|
DELTA1 = 0.5d0*(-BB + SQDD)
|
|
DELTA2 = 0.5d0*(-BB - SQDD)
|
|
IF ((HSO4I) <= TINY) THEN
|
|
DELTA = DELTA2
|
|
ELSEIF( (HI*SO4I) >= (A8*HSO4I) ) THEN
|
|
DELTA = DELTA2
|
|
ELSEIF( (HI*SO4I) < (A8*HSO4I) ) THEN
|
|
DELTA = DELTA1
|
|
ELSE
|
|
DELTA = ZERO
|
|
ENDIF
|
|
ELSE
|
|
DELTA = ZERO
|
|
ENDIF
|
|
|
|
! PHFIX applied by Havala (just a quick fix, not a final solution)
|
|
! make sure H+ is positive (hotp 8/19/09)
|
|
! Negative H+ was due to subtracting two similar, small numbers
|
|
! for a set of test conditions examined
|
|
!IF ( DELTA > HI ) DELTA = HI - 1d-30
|
|
|
|
CCC
|
|
CCC *** COMPARE DELTA TO TOTAL H+ ; ESTIMATE EFFECT OF HSO4 ***************
|
|
CCC
|
|
CC HYD = MAX(HI, MOLAL(1))
|
|
CC IF (HYD > TINY) THEN
|
|
CC IF (DELTA/HYD > 0.1d0) THEN
|
|
CC WRITE (ERRINF,'(1PE10.3)') DELTA/HYD*100.0
|
|
CC CALL PUSHERR (0020, ERRINF)
|
|
CC ENDIF
|
|
CC ENDIF
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCHS4 *****************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCPH
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCPH (GG, HI, OHI)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: CN, GG, HI, OHI, BB, CC, DD
|
|
C
|
|
AKW = XKW *RH*WATER*WATER
|
|
CN = SQRT(AKW)
|
|
C
|
|
C *** GG = (negative charge) - (positive charge)
|
|
C
|
|
IF ((GG) > TINY) THEN ! H+ in excess
|
|
BB =-GG
|
|
CC =-AKW
|
|
DD = BB*BB - 4.D0*CC
|
|
HI = MAX(0.5D0*(-BB + SQRT(DD)),CN)
|
|
OHI= AKW/HI
|
|
ELSE ! OH- in excess
|
|
BB = GG
|
|
CC =-AKW
|
|
DD = BB*BB - 4.D0*CC
|
|
OHI= MAX(0.5D0*(-BB + SQRT(DD)),CN)
|
|
HI = AKW/OHI
|
|
ENDIF
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCPH ******************************************
|
|
C
|
|
END
|
|
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE RSTGAM
|
|
C *** RESETS ACTIVITY COEFFICIENT ARRAYS TO DEFAULT VALUE OF 0.1
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE RSTGAM
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
DO I=1, NPAIR
|
|
GAMA(I) = 0.1D0
|
|
ENDDO
|
|
C
|
|
C *** END OF SUBROUTINE RSTGAM ******************************************
|
|
C
|
|
RETURN
|
|
END
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE RSTGAMP
|
|
C *** RESETS ACTIVITY COEFFICIENT ARRAYS TO DEFAULT VALUE OF 0.1 IF
|
|
C *** GREATER THAN THE THRESHOLD VALUE.
|
|
C
|
|
C ANISORROPIA ROUTINE. (slc.8.2011)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE RSTGAMP
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: GMAX, GTHRESH
|
|
INTEGER I
|
|
C
|
|
GTHRESH = 100.D0
|
|
GMAX = 0.1D0
|
|
DO I=1, NPAIR
|
|
GMAX = MAX(GMAX,GAMA(I))
|
|
ENDDO
|
|
IF ((GMAX) > (GTHRESH)) THEN
|
|
DO I = 1,NPAIR
|
|
GAMA(I) = 1.D-1
|
|
GAMIN(I) = GREAT
|
|
GAMOU(I) = GREAT
|
|
ENDDO
|
|
CALAOU = .TRUE.
|
|
FRST = .TRUE.
|
|
ENDIF
|
|
C
|
|
END SUBROUTINE RSTGAMP
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE II
|
|
C *** SUBROUTINE CALCACT4
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM-CALCIUM-POTASSIUM-MAGNESIUM
|
|
C AEROSOL SYSTEM. THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL4).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C SUBROUTINE CALCACT4
|
|
C INCLUDE 'isrpia_adj.inc'
|
|
CC
|
|
C REAL EX10
|
|
C REAL G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(6),F2A(4),F2B(4)
|
|
C REAL*8 :: MPL, XIJ, YJI
|
|
C
|
|
C ! hotp removed for parallelization (8/23/07), integer declared
|
|
C !DATA G0/24*0D0/
|
|
C INTEGER I,J
|
|
C
|
|
CC
|
|
C GA(I,J)= (F1(I)/Z(I) + F2A(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H
|
|
C GB(I,J)= (F1(I)/Z(I+4) + F2B(J)/Z(J+3)) / (Z(I+4)+Z(J+3)) - H
|
|
C
|
|
C ! initialize G0 array here (hotp 8/23/07)
|
|
C DO J = 1, 4
|
|
C DO I = 1, 6
|
|
C G0(I,J) = 0.0
|
|
C ENDDO
|
|
C ENDDO
|
|
CC
|
|
CC *** SAVE ACTIVITIES IN OLD ARRAY *************************************
|
|
CC
|
|
C IF (FRST) THEN ! Outer loop
|
|
C DO 10 I=1,NPAIR
|
|
C GAMOU(I) = GAMA(I)
|
|
C10 CONTINUE
|
|
C ENDIF
|
|
CC
|
|
C DO 20 I=1,NPAIR ! Inner loop
|
|
C GAMIN(I) = GAMA(I)
|
|
C20 CONTINUE
|
|
CC
|
|
CC *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
CC
|
|
C IONIC=0.0
|
|
C DO 30 I=1,NIONS
|
|
C IONIC=IONIC + MOLAL(I)*Z(I)*Z(I)
|
|
C30 CONTINUE
|
|
C IONIC = MAX(MIN(0.5*IONIC/WATER,100.d0), TINY)
|
|
CC
|
|
CC *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
CC
|
|
CC G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
CC G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
CC
|
|
C IF (IACALC.EQ.0) THEN ! K.M.; FULL
|
|
C CALL KMFUL4 (IONIC, SNGL(TEMP),G0(2,1),G0(2,2),G0(2,4),
|
|
C & G0(3,2),G0(3,4),G0(3,1),G0(1,2),G0(1,3),G0(3,3),
|
|
C & G0(1,4),G0(1,1),G0(2,3),G0(4,4),G0(4,1),G0(5,2),
|
|
C & G0(5,3),G0(5,4),G0(5,1),G0(6,2),G0(6,4),G0(6,1))
|
|
C ELSE ! K.M.; TABULATED
|
|
C CALL KMTAB (IONIC, SNGL(TEMP),G0(2,1),G0(2,2),G0(2,4),
|
|
C & G0(3,2),G0(3,4),G0(3,1),G0(1,2),G0(1,3),G0(3,3),
|
|
C & G0(1,4),G0(1,1),G0(2,3),G0(4,4),G0(4,1),G0(5,2),
|
|
C & G0(5,3),G0(5,4),G0(5,1),G0(6,2),G0(6,4),G0(6,1))
|
|
C ENDIF
|
|
CC
|
|
CC *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
CC
|
|
C AGAMA = 0.511*(298.0/TEMP)**1.5 ! Debye Huckel const. at T
|
|
C SION = SQRT(IONIC)
|
|
C H = AGAMA*SION/(1+SION)
|
|
CC
|
|
C DO 100 I=1,4
|
|
C F1(I)=0.0
|
|
C F2A(I)=0.0
|
|
C F2B(I)=0.0
|
|
C100 CONTINUE
|
|
C F1(5)=0.0
|
|
C F1(6)=0.0
|
|
CC
|
|
C DO 110 I=1,3
|
|
C ZPL = Z(I)
|
|
C MPL = MOLAL(I)/WATER
|
|
C DO 110 J=1,4
|
|
C ZMI = Z(J+3)
|
|
C CH = 0.25*(ZPL+ZMI)*(ZPL+ZMI)/IONIC
|
|
C XIJ = CH*MPL
|
|
C YJI = CH*MOLAL(J+3)/WATER
|
|
C F1(I) = F1(I) + SNGL(YJI*(G0(I,J) + ZPL*ZMI*H))
|
|
C F2A(J) = F2A(J) + SNGL(XIJ*(G0(I,J) + ZPL*ZMI*H))
|
|
C110 CONTINUE
|
|
CC
|
|
C DO 330 I=4,6
|
|
C ZPL = Z(I+4)
|
|
C MPL = MOLAL(I+4)/WATER
|
|
C DO 330 J=1,4
|
|
C ZMI = Z(J+3)
|
|
C IF (J.EQ.3) THEN
|
|
C IF (I.EQ.4 .OR. I.EQ.6) THEN
|
|
C GO TO 330
|
|
C ENDIF
|
|
C ENDIF
|
|
C CH = 0.25*(ZPL+ZMI)*(ZPL+ZMI)/IONIC
|
|
C XIJ = CH*MPL
|
|
C YJI = CH*MOLAL(J+3)/WATER
|
|
C F1(I) = F1(I) + SNGL(YJI*(G0(I,J) + ZPL*ZMI*H))
|
|
C F2B(J) = F2B(J) + SNGL(XIJ*(G0(I,J) + ZPL*ZMI*H))
|
|
C330 CONTINUE
|
|
C
|
|
CC
|
|
CC *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
CC
|
|
C GAMA(01) = GA(2,1)*ZZ(01) ! NACL
|
|
C GAMA(02) = GA(2,2)*ZZ(02) ! NA2SO4
|
|
C GAMA(03) = GA(2,4)*ZZ(03) ! NANO3
|
|
C GAMA(04) = GA(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C GAMA(05) = GA(3,4)*ZZ(05) ! NH4NO3
|
|
C GAMA(06) = GA(3,1)*ZZ(06) ! NH4CL
|
|
C GAMA(07) = GA(1,2)*ZZ(07) ! 2H-SO4
|
|
C GAMA(08) = GA(1,3)*ZZ(08) ! H-HSO4
|
|
C GAMA(09) = GA(3,3)*ZZ(09) ! NH4HSO4
|
|
C GAMA(10) = GA(1,4)*ZZ(10) ! HNO3
|
|
C GAMA(11) = GA(1,1)*ZZ(11) ! HCL
|
|
C GAMA(12) = GA(2,3)*ZZ(12) ! NAHSO4
|
|
C GAMA(13) = 0.20*(3.0*GAMA(04)+2.0*GAMA(09)) ! LC ; SCAPE
|
|
CCC GAMA(13) = 0.50*(GAMA(04)+GAMA(09)) ! LC ; SEQUILIB
|
|
CCC GAMA(13) = 0.25*(3.0*GAMA(04)+GAMA(07)) ! LC ; AIM
|
|
C GAMA(14) = 0.0d0 ! CASO4
|
|
C GAMA(15) = GB(4,4)*ZZ(15) ! CA(NO3)2
|
|
C GAMA(16) = GB(4,1)*ZZ(16) ! CACL2
|
|
C GAMA(17) = GB(5,2)*ZZ(17) ! K2SO4
|
|
C GAMA(18) = GB(5,3)*ZZ(18) ! KHSO4
|
|
C GAMA(19) = GB(5,4)*ZZ(19) ! KNO3
|
|
C GAMA(20) = GB(5,1)*ZZ(20) ! KCL
|
|
C GAMA(21) = GB(6,2)*ZZ(21) ! MGSO4
|
|
C GAMA(22) = GB(6,4)*ZZ(22) ! MG(NO3)2
|
|
C GAMA(23) = GB(6,1)*ZZ(23) ! MGCL2
|
|
CC
|
|
CC *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
CC
|
|
C DO 200 I=1,NPAIR
|
|
C GAMA(I)=MAX(-5.0d0, MIN(GAMA(I),5.0d0) ) ! F77 LIBRARY ROUTINE
|
|
C GAMA(I)=10.0**GAMA(I)
|
|
CCC GAMA(I)=EX10(SNGL(GAMA(I)), 5.0) ! CUTOFF SET TO [-5,5]
|
|
C 200 CONTINUE
|
|
CC
|
|
CC *** SETUP ACTIVITY CALCULATION FLAGS ********************************
|
|
CC
|
|
CC OUTER CALCULATION LOOP ; ONLY IF FRST=.TRUE.
|
|
CC
|
|
C IF (FRST) THEN
|
|
C ERROU = ZERO ! CONVERGENCE CRITERION
|
|
C DO 210 I=1,NPAIR
|
|
C ERROU=MAX(ERROU, ABS((GAMOU(I)-GAMA(I))/GAMOU(I)))
|
|
C210 CONTINUE
|
|
C CALAOU = ERROU .GE. EPSACT ! SETUP FLAGS
|
|
C FRST =.FALSE.
|
|
C ENDIF
|
|
CC
|
|
CC INNER CALCULATION LOOP ; ALWAYS
|
|
CC
|
|
C ERRIN = ZERO ! CONVERGENCE CRITERION
|
|
C DO 220 I=1,NPAIR
|
|
C ERRIN = MAX (ERRIN, ABS((GAMIN(I)-GAMA(I))/GAMIN(I)))
|
|
C220 CONTINUE
|
|
C CALAIN = ERRIN .GE. EPSACT
|
|
CC
|
|
C ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter
|
|
CC
|
|
CC *** END OF SUBROUTINE ACTIVITY ****************************************
|
|
CC
|
|
C RETURN
|
|
C END
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(3),F2(4)
|
|
REAL*8 :: MPL, XIJ, YJI, CHECK
|
|
CHARACTER(LEN=40) :: errinf
|
|
C
|
|
C
|
|
C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H
|
|
C
|
|
C *** SAVE ACTIVITIES IN OLD ARRAY *************************************
|
|
C
|
|
IF (FRST) THEN ! Outer loop
|
|
GAMOU = GAMA
|
|
ENDIF
|
|
C
|
|
GAMIN = GAMA
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
IONIC=0.D0
|
|
DO I=1,7
|
|
IONIC=IONIC + MOLAL(I)*Z(I)*Z(I)
|
|
ENDDO
|
|
CHECK = 0.5d0*IONIC/WATER
|
|
IF (CHECK > 200.d0) THEN
|
|
C WRITE(*,*) 'Threshold exceeded in CALCACT: WATER',water,'IONIc'
|
|
C & ,IONIC
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')'
|
|
CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD
|
|
ELSEIF (CHECK < TINY) THEN
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')'
|
|
CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD
|
|
ENDIF
|
|
IONIC = MAX(MIN(0.5D0*IONIC/WATER,200.d0), TINY)
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3 (IONIC, TEMP,G01,G02,G03,
|
|
& G04,G05,G06,G07,G08,G09,
|
|
& G10,G11,G12)
|
|
C
|
|
G0(1,1)=G11
|
|
G0(1,2)=G07
|
|
G0(1,3)=G08
|
|
G0(1,4)=G10
|
|
G0(2,1)=G01
|
|
G0(2,2)=G02
|
|
G0(2,3)=G12
|
|
G0(2,4)=G03
|
|
G0(3,1)=G06
|
|
G0(3,2)=G04
|
|
G0(3,3)=G09
|
|
G0(3,4)=G05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
AGAMA = 0.511D0*(298.D0/TEMP)**1.5D0 ! Debye Huckel const. at T
|
|
SION = SQRT(IONIC)
|
|
H = AGAMA*SION/(1.D0+SION)
|
|
|
|
C
|
|
DO I=1,3
|
|
F1(I)=0.D0
|
|
F2(I)=0.D0
|
|
ENDDO
|
|
F2(4)=0.D0
|
|
C
|
|
DO I=1,3
|
|
ZPL = Z(I)
|
|
MPL = MOLAL(I)/WATER
|
|
DO J=1,4
|
|
ZMI = Z(J+3)
|
|
CH = 0.25D0*(ZPL+ZMI)*(ZPL+ZMI)/IONIC
|
|
XIJ = CH*MPL
|
|
YJI = CH*MOLAL(J+3)/WATER
|
|
F1(I) = F1(I) + (YJI*(G0(I,J) + ZPL*ZMI*H))
|
|
F2(J) = F2(J) + (XIJ*(G0(I,J) + ZPL*ZMI*H))
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
GAMA(01) = ((F1(2)/Z(2) + F2(1)/Z(4)) / (Z(2)+Z(4)) - H)*ZZ(01) ! NACL
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
GAMA(02) = ((F1(2)/Z(2) + F2(2)/Z(5)) / (Z(2)+Z(5)) - H)*ZZ(02) ! NA2SO4
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
GAMA(03) = ((F1(2)/Z(2) + F2(4)/Z(7)) / (Z(2)+Z(7)) - H)*ZZ(03) ! NANO3
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
GAMA(04) = ((F1(3)/Z(3) + F2(2)/Z(5)) / (Z(3)+Z(5)) - H)*ZZ(04) ! (NH4)2SO4
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
GAMA(05) = ((F1(3)/Z(3) + F2(4)/Z(7)) / (Z(3)+Z(7)) - H)*ZZ(05) ! NH4NO3
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
GAMA(06) = ((F1(3)/Z(3) + F2(1)/Z(4)) / (Z(3)+Z(4)) - H)*ZZ(06) ! NH4CL
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
GAMA(07) = ((F1(1)/Z(1) + F2(2)/Z(5)) / (Z(1)+Z(5)) - H)*ZZ(07) ! 2H-SO4
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
GAMA(08) = ((F1(1)/Z(1) + F2(3)/Z(6)) / (Z(1)+Z(6)) - H)*ZZ(08) ! H-HSO4
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
GAMA(09) = ((F1(3)/Z(3) + F2(3)/Z(6)) / (Z(3)+Z(6)) - H)*ZZ(09) ! NH4HSO4
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
GAMA(10) = ((F1(1)/Z(1) + F2(4)/Z(7)) / (Z(1)+Z(7)) - H)*ZZ(10) ! HNO3
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
GAMA(11) = ((F1(1)/Z(1) + F2(1)/Z(4)) / (Z(1)+Z(4)) - H)*ZZ(11) ! HCL
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
GAMA(12) = ((F1(2)/Z(2) + F2(3)/Z(6)) / (Z(2)+Z(6)) - H)*ZZ(12) ! NAHSO4
|
|
GAMA(13) = 0.2D0*(3.D0*GAMA(04)+2.D0*GAMA(09)) ! LC ; SCAPE
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO I=1,13
|
|
GAMA(I)=MAX(MIN(GAMA(I),5.0d0), -5.0d0) ! F77 LIBRARY ROUTINE
|
|
GAMA(I)=10.D0**GAMA(I)
|
|
ENDDO
|
|
C
|
|
C *** SETUP ACTIVITY CALCULATION FLAGS *********************************
|
|
C
|
|
C OUTER CALCULATION LOOP ; ONLY IF FRST=.TRUE.
|
|
C
|
|
IF (FRST) THEN
|
|
ERROU = ZERO ! CONVERGENCE CRITERION
|
|
DO I=1,13
|
|
ERROU=MAX(ERROU, ((GAMOU(I)-GAMA(I))/GAMOU(I)))
|
|
ENDDO
|
|
CALAOU = (ERROU) >= (EPSACT) ! SETUP FLAGS
|
|
FRST =.FALSE.
|
|
ENDIF
|
|
C
|
|
C INNER CALCULATION LOOP ; ALWAYS
|
|
C
|
|
ERRIN = ZERO ! CONVERGENCE CRITERION
|
|
DO I=1,13
|
|
ERRIN = MAX(ERRIN, ABS((GAMIN(I)-GAMA(I))/GAMIN(I)))
|
|
ENDDO
|
|
CALAIN = (ERRIN) >= (EPSACT)
|
|
C
|
|
ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter
|
|
C
|
|
C *** END OF SUBROUTINE ACTIVITY ****************************************
|
|
C
|
|
RETURN
|
|
END
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3P
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C ANISORROPIA ROUTINE. (slc.8.2011)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3P
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(3),F2(4)
|
|
REAL*8 :: MPL, XIJ, YJI, CHECK
|
|
CHARACTER(LEN=40) errinf
|
|
C
|
|
C
|
|
C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
IONIC=0.D0
|
|
DO I=1,7
|
|
IONIC=IONIC + MOLAL(I)*Z(I)*Z(I)
|
|
ENDDO
|
|
CHECK = 0.5d0*IONIC/WATER
|
|
IF (CHECK > 200.d0) THEN
|
|
C WRITE(*,*) 'Threshold exceeded in CALCACT: WATER',water,'IONIc'
|
|
C & ,IONIC
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')'
|
|
CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD
|
|
ELSEIF (CHECK < TINY) THEN
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')'
|
|
CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD
|
|
ENDIF
|
|
IONIC = MAX(MIN(0.5D0*IONIC/WATER,200.d0), TINY)
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3 (IONIC, TEMP,G01,G02,G03,
|
|
& G04,G05,G06,G07,G08,G09,
|
|
& G10,G11,G12)
|
|
C
|
|
G0(1,1)=G11
|
|
G0(1,2)=G07
|
|
G0(1,3)=G08
|
|
G0(1,4)=G10
|
|
G0(2,1)=G01
|
|
G0(2,2)=G02
|
|
G0(2,3)=G12
|
|
G0(2,4)=G03
|
|
G0(3,1)=G06
|
|
G0(3,2)=G04
|
|
G0(3,3)=G09
|
|
G0(3,4)=G05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
AGAMA = 0.511D0*(298.D0/TEMP)**1.5D0 ! Debye Huckel const. at T
|
|
SION = SQRT(IONIC)
|
|
H = AGAMA*SION/(1.D0+SION)
|
|
C
|
|
DO I=1,3
|
|
F1(I)=0.D0
|
|
F2(I)=0.D0
|
|
ENDDO
|
|
F2(4)=0.D0
|
|
C
|
|
DO I=1,3
|
|
ZPL = Z(I)
|
|
MPL = MOLAL(I)/WATER
|
|
DO J=1,4
|
|
ZMI = Z(J+3)
|
|
CH = 0.25D0*(ZPL+ZMI)*(ZPL+ZMI)/IONIC
|
|
XIJ = CH*MPL
|
|
YJI = CH*MOLAL(J+3)/WATER
|
|
F1(I) = F1(I) + (YJI*(G0(I,J) + ZPL*ZMI*H))
|
|
F2(J) = F2(J) + (XIJ*(G0(I,J) + ZPL*ZMI*H))
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
GAMA(01) = ((F1(2)/Z(2) + F2(1)/Z(4)) / (Z(2)+Z(4)) - H)*ZZ(01) ! NACL
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
GAMA(02) = ((F1(2)/Z(2) + F2(2)/Z(5)) / (Z(2)+Z(5)) - H)*ZZ(02) ! NA2SO4
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
GAMA(03) = ((F1(2)/Z(2) + F2(4)/Z(7)) / (Z(2)+Z(7)) - H)*ZZ(03) ! NANO3
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
GAMA(04) = ((F1(3)/Z(3) + F2(2)/Z(5)) / (Z(3)+Z(5)) - H)*ZZ(04) ! (NH4)2SO4
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
GAMA(05) = ((F1(3)/Z(3) + F2(4)/Z(7)) / (Z(3)+Z(7)) - H)*ZZ(05) ! NH4NO3
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
GAMA(06) = ((F1(3)/Z(3) + F2(1)/Z(4)) / (Z(3)+Z(4)) - H)*ZZ(06) ! NH4CL
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
GAMA(07) = ((F1(1)/Z(1) + F2(2)/Z(5)) / (Z(1)+Z(5)) - H)*ZZ(07) ! 2H-SO4
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
GAMA(08) = ((F1(1)/Z(1) + F2(3)/Z(6)) / (Z(1)+Z(6)) - H)*ZZ(08) ! H-HSO4
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
GAMA(09) = ((F1(3)/Z(3) + F2(3)/Z(6)) / (Z(3)+Z(6)) - H)*ZZ(09) ! NH4HSO4
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
GAMA(10) = ((F1(1)/Z(1) + F2(4)/Z(7)) / (Z(1)+Z(7)) - H)*ZZ(10) ! HNO3
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
GAMA(11) = ((F1(1)/Z(1) + F2(1)/Z(4)) / (Z(1)+Z(4)) - H)*ZZ(11) ! HCL
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
GAMA(12) = ((F1(2)/Z(2) + F2(3)/Z(6)) / (Z(2)+Z(6)) - H)*ZZ(12) ! NAHSO4
|
|
GAMA(13) = 0.2D0*(3.D0*GAMA(04)+2.D0*GAMA(09)) ! LC ; SCAPE
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO I=1,13
|
|
GAMA(I)=MAX(MIN(GAMA(I),5.0d0), -5.0d0) ! F77 LIBRARY ROUTINE
|
|
GAMA(I)=10.D0**GAMA(I)
|
|
ENDDO
|
|
C
|
|
ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter
|
|
C
|
|
C *** END OF SUBROUTINE ACTIVITY ****************************************
|
|
C
|
|
RETURN
|
|
END
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3F
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3F
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(3),F2(4)
|
|
REAL*8 :: MPL, XIJ, YJI, CHECK
|
|
CHARACTER(LEN=40) errinf
|
|
C
|
|
C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
IONIC=0.D0
|
|
DO I=1,7
|
|
IONIC=IONIC + MOLAL(I)*Z(I)*Z(I)
|
|
ENDDO
|
|
CHECK = 0.5d0*IONIC/WATER
|
|
IF (CHECK .GT. 200.d0) THEN
|
|
C WRITE(*,*) 'Threshold exceeded in CALCACT: WATER',water,'IONIc'
|
|
C & ,IONIC
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')'
|
|
C * slc.debug
|
|
C WRITE(*,*) '102,ACT3F,',CHECK
|
|
C WRITE(*,*) 'Water: ',WATER ,', IONIC: ',IONIC
|
|
C WRITE(*,*) 'W: ',W
|
|
C WRITE(*,*) 'RH: ',RH, ', TEMP:',TEMP
|
|
CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD
|
|
ELSEIF (CHECK .LT. TINY) THEN
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')'
|
|
C * slc.debug
|
|
C WRITE(*,*) '102,ACT3F,',CHECK
|
|
C WRITE(*,*) 'Water: ',WATER ,', IONIC: ',IONIC
|
|
C WRITE(*,*) 'W: ',W
|
|
C WRITE(*,*) 'RH: ',RH, ', TEMP:',TEMP
|
|
CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD
|
|
ENDIF
|
|
IONIC = MAX(MIN(0.5D0*IONIC/WATER,200.d0), TINY)
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3 (IONIC, TEMP,G01,G02,G03,
|
|
& G04,G05,G06,G07,G08,G09,
|
|
& G10,G11,G12)
|
|
C
|
|
G0(1,1)=G11
|
|
G0(1,2)=G07
|
|
G0(1,3)=G08
|
|
G0(1,4)=G10
|
|
G0(2,1)=G01
|
|
G0(2,2)=G02
|
|
G0(2,3)=G12
|
|
G0(2,4)=G03
|
|
G0(3,1)=G06
|
|
G0(3,2)=G04
|
|
G0(3,3)=G09
|
|
G0(3,4)=G05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
AGAMA = 0.511D0*(298.D0/TEMP)**1.5D0 ! Debye Huckel const. at T
|
|
SION = SQRT(IONIC)
|
|
H = AGAMA*SION/(1.D0+SION)
|
|
C
|
|
DO I=1,3
|
|
F1(I)=0.D0
|
|
F2(I)=0.D0
|
|
ENDDO
|
|
F2(4)=0.D0
|
|
C
|
|
DO I=1,3
|
|
ZPL = Z(I)
|
|
MPL = MOLAL(I)/WATER
|
|
DO J=1,4
|
|
ZMI = Z(J+3)
|
|
CH = 0.25D0*(ZPL+ZMI)*(ZPL+ZMI)/IONIC
|
|
XIJ = CH*MPL
|
|
YJI = CH*MOLAL(J+3)/WATER
|
|
F1(I) = F1(I) + (YJI*(G0(I,J) + ZPL*ZMI*H))
|
|
F2(J) = F2(J) + (XIJ*(G0(I,J) + ZPL*ZMI*H))
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
GAMA(01) = ((F1(2)/Z(2) + F2(1)/Z(4)) / (Z(2)+Z(4)) - H)*ZZ(01) ! NACL
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
GAMA(02) = ((F1(2)/Z(2) + F2(2)/Z(5)) / (Z(2)+Z(5)) - H)*ZZ(02) ! NA2SO4
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
GAMA(03) = ((F1(2)/Z(2) + F2(4)/Z(7)) / (Z(2)+Z(7)) - H)*ZZ(03) ! NANO3
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
GAMA(04) = ((F1(3)/Z(3) + F2(2)/Z(5)) / (Z(3)+Z(5)) - H)*ZZ(04) ! (NH4)2SO4
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
GAMA(05) = ((F1(3)/Z(3) + F2(4)/Z(7)) / (Z(3)+Z(7)) - H)*ZZ(05) ! NH4NO3
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
GAMA(06) = ((F1(3)/Z(3) + F2(1)/Z(4)) / (Z(3)+Z(4)) - H)*ZZ(06) ! NH4CL
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
GAMA(07) = ((F1(1)/Z(1) + F2(2)/Z(5)) / (Z(1)+Z(5)) - H)*ZZ(07) ! 2H-SO4
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
GAMA(08) = ((F1(1)/Z(1) + F2(3)/Z(6)) / (Z(1)+Z(6)) - H)*ZZ(08) ! H-HSO4
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
GAMA(09) = ((F1(3)/Z(3) + F2(3)/Z(6)) / (Z(3)+Z(6)) - H)*ZZ(09) ! NH4HSO4
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
GAMA(10) = ((F1(1)/Z(1) + F2(4)/Z(7)) / (Z(1)+Z(7)) - H)*ZZ(10) ! HNO3
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
GAMA(11) = ((F1(1)/Z(1) + F2(1)/Z(4)) / (Z(1)+Z(4)) - H)*ZZ(11) ! HCL
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
GAMA(12) = ((F1(2)/Z(2) + F2(3)/Z(6)) / (Z(2)+Z(6)) - H)*ZZ(12) ! NAHSO4
|
|
GAMA(13) = 0.2D0*(3.D0*GAMA(04)+2.D0*GAMA(09)) ! LC ; SCAPE
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO I=1,13
|
|
GAMA(I)=MAX(MIN(GAMA(I),5.0d0), -5.0d0) ! F77 LIBRARY ROUTINE
|
|
GAMA(I)=10.D0**GAMA(I)
|
|
ENDDO
|
|
C
|
|
ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter
|
|
C
|
|
C *** END OF SUBROUTINE ACTIVITY ****************************************
|
|
C
|
|
RETURN
|
|
END
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT2
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL2).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C SUBROUTINE CALCACT2
|
|
C INCLUDE 'isrpia_adj.inc'
|
|
CC
|
|
C REAL*8 :: G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(3),F2(4)
|
|
C REAL*8 :: MPL, XIJ, YJI
|
|
CC
|
|
C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H
|
|
CC
|
|
CC *** SAVE ACTIVITIES IN OLD ARRAY *************************************
|
|
CC
|
|
C IF (FRST) THEN ! Outer loop
|
|
C DO I=7,10
|
|
C GAMOU(I) = GAMA(I)
|
|
C ENDDO
|
|
C GAMOU(4) = GAMA(4)
|
|
C GAMOU(5) = GAMA(5)
|
|
C GAMOU(13) = GAMA(13)
|
|
C ENDIF
|
|
CC
|
|
C DO I=7,10 ! Inner loop
|
|
C GAMIN(I) = GAMA(I)
|
|
C ENDDO
|
|
C GAMIN(4) = GAMA(4)
|
|
C GAMIN(5) = GAMA(5)
|
|
C GAMIN(13) = GAMA(13)
|
|
CC
|
|
CC *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
CC
|
|
C IONIC=0.D0
|
|
C MOLAL(2) = ZERO
|
|
C MOLAL(4) = ZERO
|
|
C DO I=1,7
|
|
C IONIC=IONIC + MOLAL(I)*Z(I)*Z(I)
|
|
C ENDDO
|
|
C IONIC = MAX(MIN(0.5D0*IONIC/WATER,100.d0), TINY)
|
|
CC
|
|
CC *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
CC
|
|
CC G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
CC G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
CC
|
|
C CALL KMFUL2 (IONIC,TEMP,G0(3,2),G0(3,4),G0(1,2),
|
|
C & G0(1,3),G0(3,3),G0(1,4))
|
|
CC
|
|
CC *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
CC
|
|
C AGAMA = 0.511D0*(298.D0/TEMP)**1.5D0 ! Debye Huckel const. at T
|
|
C SION = SQRT(IONIC)
|
|
C H = AGAMA*SION/(1.D0+SION)
|
|
CC
|
|
C DO I=1,3
|
|
C F1(I)=0.D0
|
|
C F2(I)=0.D0
|
|
C ENDDO
|
|
C F2(4)=0.D0
|
|
CC
|
|
C DO I=1,3,2
|
|
C ZPL = Z(I)
|
|
C MPL = MOLAL(I)/WATER
|
|
C DO J=2,4
|
|
C ZMI = Z(J+3)
|
|
C CH = 0.25D0*(ZPL+ZMI)*(ZPL+ZMI)/IONIC
|
|
C XIJ = CH*MPL
|
|
C YJI = CH*MOLAL(J+3)/WATER
|
|
C F1(I) = F1(I) + (YJI*(G0(I,J) + ZPL*ZMI*H))
|
|
C F2(J) = F2(J) + (XIJ*(G0(I,J) + ZPL*ZMI*H))
|
|
C ENDDO
|
|
C ENDDO
|
|
CC
|
|
CC *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
CC
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C GAMA(13) = 0.2D0*(3.D0*GAMA(04)+2.D0*GAMA(09)) ! LC ; SCAPE
|
|
CC
|
|
CC *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
CC
|
|
C DO I=7,10
|
|
C GAMA(I)=MAX(-5.0d0, MIN(GAMA(I),5.0d0) ) ! F77 LIBRARY ROUTINE
|
|
C GAMA(I)=10.D0**GAMA(I)
|
|
C ENDDO
|
|
CC
|
|
C GAMA(4)=MAX(-5.0d0, MIN(GAMA(4),5.0d0) ) ! F77 LIBRARY ROUTINE
|
|
C GAMA(4)=10.D0**GAMA(4)
|
|
CC
|
|
C GAMA(5)=MAX(-5.0d0, MIN(GAMA(5),5.0d0) ) ! F77 LIBRARY ROUTINE
|
|
C GAMA(5)=10.D0**GAMA(5)
|
|
CC
|
|
C GAMA(13)=MAX(-5.0d0, MIN(GAMA(13),5.0d0) ) ! F77 LIBRARY ROUTINE
|
|
C GAMA(13)=10.D0**GAMA(13)
|
|
CC
|
|
CC *** SETUP ACTIVITY CALCULATION FLAGS *********************************
|
|
CC
|
|
CC OUTER CALCULATION LOOP ; ONLY IF FRST=.TRUE.
|
|
CC
|
|
C IF (FRST) THEN
|
|
C ERROU = ZERO ! CONVERGENCE CRITERION
|
|
C DO I=7,10
|
|
C ERROU=MAX(ERROU, ABS((GAMOU(I)-GAMA(I))/GAMOU(I)))
|
|
C ENDDO
|
|
C ERROU=MAX(ERROU, ABS((GAMOU(4)-GAMA(4))/GAMOU(4)))
|
|
C ERROU=MAX(ERROU, ABS((GAMOU(5)-GAMA(5))/GAMOU(5)))
|
|
C ERROU=MAX(ERROU, ABS((GAMOU(13)-GAMA(13))/GAMOU(13)))
|
|
CC
|
|
C CALAOU = ERROU >= EPSACT ! SETUP FLAGS
|
|
C FRST =.FALSE.
|
|
C ENDIF
|
|
CC
|
|
CC INNER CALCULATION LOOP ; ALWAYS
|
|
CC
|
|
C ERRIN = ZERO ! CONVERGENCE CRITERION
|
|
C DO I=7,10
|
|
C ERRIN = MAX (ERRIN, ABS((GAMIN(I)-GAMA(I))/GAMIN(I)))
|
|
C ENDDO
|
|
C ERRIN = MAX (ERRIN, ABS((GAMIN(4)-GAMA(4))/GAMIN(4)))
|
|
C ERRIN = MAX (ERRIN, ABS((GAMIN(5)-GAMA(5))/GAMIN(5)))
|
|
C ERRIN = MAX (ERRIN, ABS((GAMIN(13)-GAMA(13))/GAMIN(13)))
|
|
C CALAIN = ERRIN >= EPSACT
|
|
CC
|
|
C ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter
|
|
CC
|
|
CC *** END OF SUBROUTINE ACTIVITY ****************************************
|
|
CC
|
|
C RETURN
|
|
C END
|
|
CC
|
|
CC=======================================================================
|
|
CC
|
|
CC *** ISORROPIA CODE
|
|
CC *** SUBROUTINE CALCACT1
|
|
CC *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
CC METHOD FOR AN AMMONIUM-SULFATE AEROSOL SYSTEM.
|
|
CC THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
CC KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL1).
|
|
CC
|
|
CC *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
CC *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
CC
|
|
CC *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
CC
|
|
CC=======================================================================
|
|
CC
|
|
C SUBROUTINE CALCACT1
|
|
C INCLUDE 'isrpia_adj.inc'
|
|
CC
|
|
C REAL*8 :: G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(3),F2(4)
|
|
C REAL*8 :: MPL, XIJ, YJI
|
|
CC
|
|
C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H
|
|
CC
|
|
CC *** SAVE ACTIVITIES IN OLD ARRAY *************************************
|
|
CC
|
|
C IF (FRST) THEN ! Outer loop
|
|
C DO I=7,9
|
|
C GAMOU(I) = GAMA(I)
|
|
C ENDDO
|
|
C GAMOU(4) = GAMA(4)
|
|
C GAMOU(13) = GAMA(13)
|
|
C ENDIF
|
|
CC
|
|
C DO I=7,9 ! Inner loop
|
|
C GAMIN(I) = GAMA(I)
|
|
C ENDDO
|
|
C GAMIN(4) = GAMA(4)
|
|
C GAMIN(13) = GAMA(13)
|
|
CC
|
|
CC *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
CC
|
|
C IONIC=0.D0
|
|
C MOLAL(2) = ZERO
|
|
C MOLAL(4) = ZERO
|
|
C MOLAL(7) = ZERO
|
|
C DO I=1,7
|
|
C IONIC=IONIC + MOLAL(I)*Z(I)*Z(I)
|
|
C ENDDO
|
|
C IONIC = MAX(MIN(0.5D0*IONIC/WATER,100.d0), TINY)
|
|
CC
|
|
CC *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
CC
|
|
CC G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
CC G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
CC
|
|
C CALL KMFUL1 (IONIC,TEMP,G0(3,2),G0(1,2),
|
|
C & G0(1,3))
|
|
CC
|
|
CC *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
CC
|
|
C AGAMA = 0.511D0*(298.D0/TEMP)**1.5D0 ! Debye Huckel const. at T
|
|
C SION = SQRT(IONIC)
|
|
C H = AGAMA*SION/(1.D0+SION)
|
|
CC
|
|
C DO I=1,3
|
|
C F1(I)=0.D0
|
|
C F2(I)=0.D0
|
|
C ENDDO
|
|
C F2(4)=0.D0
|
|
CC
|
|
C DO I=1,3,2
|
|
C ZPL = Z(I)
|
|
C MPL = MOLAL(I)/WATER
|
|
C DO J=2,3
|
|
C ZMI = Z(J+3)
|
|
C CH = 0.25D0*(ZPL+ZMI)*(ZPL+ZMI)/IONIC
|
|
C XIJ = CH*MPL
|
|
C YJI = CH*MOLAL(J+3)/WATER
|
|
C F1(I) = F1(I) + (YJI*(G0(I,J) + ZPL*ZMI*H))
|
|
C F2(J) = F2(J) + (XIJ*(G0(I,J) + ZPL*ZMI*H))
|
|
C ENDDO
|
|
C ENDDO
|
|
CC
|
|
CC *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
CC
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C GAMA(09) = 0.5D0*(GAMA(04)+GAMA(07)) ! NH4HSO4 ; AIM (Wexler & Seinfeld, 1991)
|
|
C GAMA(13) = 0.20D0*(3.D0*GAMA(04)+2.D0*GAMA(09)) ! LC ; SCAPE
|
|
CC
|
|
CC *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
CC
|
|
C DO I=7,9
|
|
C GAMA(I)=MAX(-5.0d0, MIN(GAMA(I),5.0d0) ) ! F77 LIBRARY ROUTINE
|
|
C GAMA(I)=10.D0**GAMA(I)
|
|
C ENDDO
|
|
CC
|
|
C GAMA(4)=MAX(-5.0d0, MIN(GAMA(4),5.0d0) ) ! F77 LIBRARY ROUTINE
|
|
C GAMA(4)=10.D0**GAMA(4)
|
|
CC
|
|
C GAMA(13)=MAX(-5.0d0, MIN(GAMA(13),5.0d0) ) ! F77 LIBRARY ROUTINE
|
|
C GAMA(13)=10.D0**GAMA(13)
|
|
CC
|
|
CC *** SETUP ACTIVITY CALCULATION FLAGS *********************************
|
|
CC
|
|
CC OUTER CALCULATION LOOP ; ONLY IF FRST=.TRUE.
|
|
CC
|
|
C IF (FRST) THEN
|
|
C ERROU = ZERO ! CONVERGENCE CRITERION
|
|
C DO I=7,9
|
|
C ERROU=MAX(ERROU, ABS((GAMOU(I)-GAMA(I))/GAMOU(I)))
|
|
C ENDDO
|
|
C ERROU=MAX(ERROU, ABS((GAMOU(4)-GAMA(4))/GAMOU(4)))
|
|
C ERROU=MAX(ERROU, ABS((GAMOU(13)-GAMA(13))/GAMOU(13)))
|
|
CC
|
|
C CALAOU = ERROU >= EPSACT ! SETUP FLAGS
|
|
C FRST =.FALSE.
|
|
C ENDIF
|
|
CC
|
|
CC INNER CALCULATION LOOP ; ALWAYS
|
|
CC
|
|
C ERRIN = ZERO ! CONVERGENCE CRITERION
|
|
C DO I=7,9
|
|
C ERRIN = MAX (ERRIN, ABS((GAMIN(I)-GAMA(I))/GAMIN(I)))
|
|
C ENDDO
|
|
C ERRIN = MAX (ERRIN, ABS((GAMIN(4)-GAMA(4))/GAMIN(4)))
|
|
C ERRIN = MAX (ERRIN, ABS((GAMIN(13)-GAMA(13))/GAMIN(13)))
|
|
C CALAIN = ERRIN >= EPSACT
|
|
CC
|
|
C ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter
|
|
CC
|
|
CC *** END OF SUBROUTINE ACTIVITY ****************************************
|
|
CC
|
|
C RETURN
|
|
C END
|
|
CC
|
|
CC=======================================================================
|
|
CC
|
|
CC *** ISORROPIA CODE
|
|
CC *** SUBROUTINE RSTGAM
|
|
CC *** RESETS ACTIVITY COEFFICIENT ARRAYS TO DEFAULT VALUE OF 0.1
|
|
CC
|
|
CC *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
CC *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
CC *** WRITTEN BY ATHANASIOS NENES
|
|
CC *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
CC
|
|
CC=======================================================================
|
|
CC
|
|
C SUBROUTINE RSTGAM
|
|
C INCLUDE 'isrpia_adj.inc'
|
|
CC
|
|
C DO I=1, NPAIR
|
|
C GAMA(I) = 0.1D0
|
|
C ENDDO
|
|
CC
|
|
CC *** END OF SUBROUTINE RSTGAM ******************************************
|
|
CC
|
|
C RETURN
|
|
C END
|
|
CC
|
|
CC=======================================================================
|
|
CC
|
|
CC *** ISORROPIA CODE II
|
|
CC *** SUBROUTINE KMFUL4
|
|
CC *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
CC FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM-CALCIUM-POTASSIUM-MAGNESIUM
|
|
CC AEROSOL SYSTEM.
|
|
CC
|
|
CC *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
CC *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
CC
|
|
CC *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
CC
|
|
CC=======================================================================
|
|
CC
|
|
C SUBROUTINE KMFUL4 (IONIC,TEMP,G01,G02,G03,G04,G05,G06,G07,G08,G09,
|
|
C & G10,G11,G12,G15,G16,G17,G18,G19,G20,
|
|
C & G21,G22,G23)
|
|
C IMPLICIT NONE
|
|
C REAL*8 :: IONIC, TEMP, SION, TI, TC, CF1, CF2
|
|
C REAL*8 :: G01,G02,G03,G04,G05,G06,G07,G08,G09,
|
|
C & G10,G11,G12,G15,G16,G17,G18,G19,G20,G21,G22,G23
|
|
C REAL*8 :: Q1, Q2, Q3, Q4, Q5, Q6, Q7, Q8, Q10, Q11,
|
|
C & Q15, Q16, Q17, Q19, Q20, Q21, Q22, Q23
|
|
C REAL*8 :: Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11,Z15,Z16,
|
|
C & Z17,Z19,Z20,Z21,Z22,Z23
|
|
C DATA Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11,Z15,Z16,Z17,Z19,Z20,
|
|
C & Z21,Z22,Z23/1.D0,2.D0,1.D0,2.D0,1.D0,1.D0,2.D0,1.D0,1.D0,
|
|
C & 1.D0,2.D0,2.D0,2.D0,1.D0,1.D0,4.D0,2.D0,2.D0/
|
|
CC
|
|
C SION = SQRT(IONIC)
|
|
CC
|
|
CC *** Coefficients at 25 oC
|
|
CC
|
|
C Q1 = 2.230D0
|
|
C Q2 = -0.19D0
|
|
C Q3 = -0.39D0
|
|
C Q4 = -0.25D0
|
|
C Q5 = -1.15D0
|
|
C Q6 = 0.820D0
|
|
C Q7 = -.100D0
|
|
C Q8 = 8.000D0
|
|
C Q10 = 2.600D0
|
|
C Q11 = 6.000D0
|
|
C Q15 = 0.930D0
|
|
C Q16 = 2.400D0
|
|
C Q17 = -0.25D0
|
|
C Q19 = -2.33D0
|
|
C Q20 = 0.920D0
|
|
C Q21 = 0.150D0
|
|
C Q22 = 2.320D0
|
|
C Q23 = 2.900D0
|
|
CC
|
|
C CALL MKBI(Q1 , IONIC, SION, Z01, G01)
|
|
C CALL MKBI(Q2 , IONIC, SION, Z02, G02)
|
|
C CALL MKBI(Q3 , IONIC, SION, Z03, G03)
|
|
C CALL MKBI(Q4 , IONIC, SION, Z04, G04)
|
|
C CALL MKBI(Q5 , IONIC, SION, Z05, G05)
|
|
C CALL MKBI(Q6 , IONIC, SION, Z06, G06)
|
|
C CALL MKBI(Q7 , IONIC, SION, Z07, G07)
|
|
C CALL MKBI(Q8 , IONIC, SION, Z08, G08)
|
|
C CALL MKBI(Q10, IONIC, SION, Z10, G10)
|
|
C CALL MKBI(Q11, IONIC, SION, Z11, G11)
|
|
C CALL MKBI(Q15, IONIC, SION, Z15, G15)
|
|
C CALL MKBI(Q16, IONIC, SION, Z16, G16)
|
|
C CALL MKBI(Q17, IONIC, SION, Z17, G17)
|
|
C CALL MKBI(Q19, IONIC, SION, Z19, G19)
|
|
C CALL MKBI(Q20, IONIC, SION, Z20, G20)
|
|
C CALL MKBI(Q21, IONIC, SION, Z21, G21)
|
|
C CALL MKBI(Q22, IONIC, SION, Z22, G22)
|
|
C CALL MKBI(Q23, IONIC, SION, Z23, G23)
|
|
CC
|
|
CC *** Correct for T other than 298 K
|
|
CC
|
|
C TI = TEMP-273.D0
|
|
C TC = TI-25.D0
|
|
C IF (ABS(TC) > 1.D0) THEN
|
|
C CF1 = 1.125D0-0.005D0*TI
|
|
C CF2 = (0.125D0-0.005D0*TI)*
|
|
C & (0.039D0*IONIC**0.92D0-0.41D0*SION/(1.D0+SION))
|
|
C G01 = CF1*G01 - CF2*Z01
|
|
C G02 = CF1*G02 - CF2*Z02
|
|
C G03 = CF1*G03 - CF2*Z03
|
|
C G04 = CF1*G04 - CF2*Z04
|
|
C G05 = CF1*G05 - CF2*Z05
|
|
C G06 = CF1*G06 - CF2*Z06
|
|
C G07 = CF1*G07 - CF2*Z07
|
|
C G08 = CF1*G08 - CF2*Z08
|
|
C G10 = CF1*G10 - CF2*Z10
|
|
C G11 = CF1*G11 - CF2*Z11
|
|
C G15 = CF1*G15 - CF2*Z15
|
|
C G16 = CF1*G16 - CF2*Z16
|
|
C G17 = CF1*G17 - CF2*Z17
|
|
C G19 = CF1*G19 - CF2*Z19
|
|
C G20 = CF1*G20 - CF2*Z20
|
|
C G21 = CF1*G21 - CF2*Z21
|
|
C G22 = CF1*G22 - CF2*Z22
|
|
C G23 = CF1*G23 - CF2*Z23
|
|
C
|
|
C ENDIF
|
|
CC
|
|
C G09 = G06 + G08 - G11
|
|
C G12 = G01 + G08 - G11
|
|
C G18 = G08 + G20 - G11
|
|
CC
|
|
CC *** Return point ; End of subroutine
|
|
CC
|
|
C RETURN
|
|
C END
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3 (IONIC,TEMP,G01,G02,G03,G04,G05,G06,G07,G08,G09,
|
|
& G10,G11,G12)
|
|
IMPLICIT NONE
|
|
REAL*8 :: IONIC, TEMP, SION, TI, TC, CF1, CF2
|
|
REAL*8 :: G01,G02,G03,G04,G05,G06,G07,G08,G09,
|
|
& G10,G11,G12
|
|
REAL*8 :: Q1, Q2, Q3, Q4, Q5, Q6, Q7, Q8, Q10, Q11
|
|
REAL*8 :: Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11
|
|
DATA Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11
|
|
& /1.d0, 2.d0, 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
SION = SQRT(IONIC)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
Q1 = 2.230D0
|
|
Q2 = -0.19D0
|
|
Q3 = -0.39D0
|
|
Q4 = -0.25D0
|
|
Q5 = -1.15D0
|
|
Q6 = 0.820D0
|
|
Q7 = -.100D0
|
|
Q8 = 8.000D0
|
|
Q10 = 2.600D0
|
|
Q11 = 6.000D0
|
|
C
|
|
CALL MKBI(Q1 , IONIC, SION, Z01, G01)
|
|
CALL MKBI(Q2 , IONIC, SION, Z02, G02)
|
|
CALL MKBI(Q3 , IONIC, SION, Z03, G03)
|
|
CALL MKBI(Q4 , IONIC, SION, Z04, G04)
|
|
CALL MKBI(Q5 , IONIC, SION, Z05, G05)
|
|
CALL MKBI(Q6 , IONIC, SION, Z06, G06)
|
|
CALL MKBI(Q7 , IONIC, SION, Z07, G07)
|
|
CALL MKBI(Q8 , IONIC, SION, Z08, G08)
|
|
CALL MKBI(Q10, IONIC, SION, Z10, G10)
|
|
CALL MKBI(Q11, IONIC, SION, Z11, G11)
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
TI = TEMP-273.D0
|
|
TC = TI-25.D0
|
|
IF (ABS(TC) > 1.D0) THEN
|
|
CF1 = 1.125D0-0.005D0*TI
|
|
CF2 = (0.125D0-0.005D0*TI)*(0.039D0*IONIC**0.92D0-
|
|
& 0.41D0*SION/(1.D0+SION))
|
|
G01 = CF1*G01 - CF2*Z01
|
|
G02 = CF1*G02 - CF2*Z02
|
|
G03 = CF1*G03 - CF2*Z03
|
|
G04 = CF1*G04 - CF2*Z04
|
|
G05 = CF1*G05 - CF2*Z05
|
|
G06 = CF1*G06 - CF2*Z06
|
|
G07 = CF1*G07 - CF2*Z07
|
|
G08 = CF1*G08 - CF2*Z08
|
|
G10 = CF1*G10 - CF2*Z10
|
|
G11 = CF1*G11 - CF2*Z11
|
|
ENDIF
|
|
C
|
|
G09 = G06 + G08 - G11
|
|
G12 = G01 + G08 - G11
|
|
C
|
|
C *** Return point ; End of subroutine
|
|
C
|
|
RETURN
|
|
END
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL2
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C SUBROUTINE KMFUL2 (IONIC,TEMP,G04,G05,G07,G08,G09,G10)
|
|
C IMPLICIT NONE
|
|
C REAL*8 :: IONIC, TEMP, SION, TI, TC, CF1, CF2
|
|
C REAL*8 :: G01,G02,G03,G04,G05,G06,G07,G08,G09,
|
|
C & G10,G11,G12
|
|
C REAL*8 :: Q4, Q5, Q7, Q8, Q10
|
|
C REAL*8 :: Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11
|
|
C DATA Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11
|
|
C & /1.d0, 2.d0, 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
CC
|
|
C SION = SQRT(IONIC)
|
|
CC
|
|
CC *** Coefficients at 25 oC
|
|
CC
|
|
C Q4 = -0.25D0
|
|
C Q5 = -1.15D0
|
|
C Q7 = -.100D0
|
|
C Q8 = 8.000D0
|
|
C Q10 = 2.600D0
|
|
CC
|
|
C CALL MKBI(Q4 , IONIC, SION, Z04, G04)
|
|
C CALL MKBI(Q5 , IONIC, SION, Z05, G05)
|
|
C CALL MKBI(Q7 , IONIC, SION, Z07, G07)
|
|
C CALL MKBI(Q8 , IONIC, SION, Z08, G08)
|
|
C CALL MKBI(Q10, IONIC, SION, Z10, G10)
|
|
CC
|
|
CC *** Correct for T other than 298 K
|
|
CC
|
|
C TI = TEMP-273.D0
|
|
C TC = TI-25.D0
|
|
C IF (ABSIRE(TC) > 1.D0) THEN
|
|
C CF1 = 1.125D0-0.005D0*TI
|
|
C CF2 = (0.125D0-0.005D0*TI)*(0.039D0*IONIC**0.92D0-
|
|
C & 0.41D0*SION/(1.D0+SION))
|
|
C G04 = CF1*G04 - CF2*Z04
|
|
C G05 = CF1*G05 - CF2*Z05
|
|
C G07 = CF1*G07 - CF2*Z07
|
|
C G08 = CF1*G08 - CF2*Z08
|
|
C G10 = CF1*G10 - CF2*Z10
|
|
C ENDIF
|
|
CC
|
|
C G09 = G05 + G08 - G10
|
|
CC
|
|
CC *** Return point ; End of subroutine
|
|
CC
|
|
C RETURN
|
|
C END
|
|
CC=======================================================================
|
|
CC
|
|
CC *** ISORROPIA CODE
|
|
CC *** SUBROUTINE KMFUL1
|
|
CC *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
CC FOR AN AMMONIUM-SULFATE AEROSOL SYSTEM.
|
|
CC
|
|
CC *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
CC *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
CC
|
|
CC *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
CC
|
|
CC=======================================================================
|
|
CC
|
|
C SUBROUTINE KMFUL1 (IONIC,TEMP,G04,G07,G08)
|
|
C IMPLICIT NONE
|
|
C REAL*8 :: IONIC, TEMP, SION, TI, TC, CF1, CF2
|
|
C REAL*8 :: G01,G02,G03,G04,G05,G06,G07,G08,G09,
|
|
C & G10,G11,G12
|
|
C REAL*8 :: Q4, Q7, Q8
|
|
C REAL*8 :: Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11
|
|
C DATA Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11
|
|
C & /1.d0, 2.d0, 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
CC
|
|
C SION = SQRT(IONIC)
|
|
CC
|
|
CC *** Coefficients at 25 oC
|
|
CC
|
|
C Q4 = -0.25D0
|
|
C Q7 = -.100D0
|
|
C Q8 = 8.000D0
|
|
CC
|
|
C CALL MKBI(Q4 , IONIC, SION, Z04, G04)
|
|
C CALL MKBI(Q7 , IONIC, SION, Z07, G07)
|
|
C CALL MKBI(Q8 , IONIC, SION, Z08, G08)
|
|
CC
|
|
CC *** Correct for T other than 298 K
|
|
CC
|
|
C TI = TEMP-273.D0
|
|
C TC = TI-25.D0
|
|
C IF (ABSIRE(TC) > 1.D0) THEN
|
|
C CF1 = 1.125D0-0.005D0*TI
|
|
C CF2 = (0.125D0-0.005D0*TI)*(0.039D0*IONIC**0.92D0-
|
|
C & 0.41D0*SION/(1.D0+SION))
|
|
C G04 = CF1*G04 - CF2*Z04
|
|
C G07 = CF1*G07 - CF2*Z07
|
|
C G08 = CF1*G08 - CF2*Z08
|
|
C ENDIF
|
|
CC
|
|
CC *** Return point ; End of subroutine
|
|
CC
|
|
C RETURN
|
|
C END
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI(Q,IONIC,SION,ZIP,BI)
|
|
C
|
|
IMPLICIT NONE
|
|
REAL*8 :: Q, IONIC, SION, ZIP, BI
|
|
REAL*8 :: B, C, XX
|
|
C
|
|
B=.75D0-.065D0*Q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
C=1.d0+.055D0*Q*EXP(-.023D0*IONIC*IONIC*IONIC)
|
|
XX=-0.5107D0*SION/(1.D0+C*SION)
|
|
BI=(1.D0+B*(1.D0+.1D0*IONIC)**Q-B)
|
|
BI=ZIP*LOG10(BI) + ZIP*XX
|
|
C
|
|
RETURN
|
|
END
|
|
C
|
|
CC*************************************************************************
|
|
CC
|
|
CC TOOLBOX LIBRARY v.1.0 (May 1995)
|
|
CC
|
|
CC Program unit : SUBROUTINE CHRBLN
|
|
CC Purpose : Position of last non-blank character in a string
|
|
CC Author : Athanasios Nenes
|
|
CC
|
|
CC ======================= ARGUMENTS / USAGE =============================
|
|
CC
|
|
CC STR is the CHARACTER variable containing the string examined
|
|
CC IBLK is a INTEGER variable containing the position of last non
|
|
CC blank character. If string is all spaces (ie ' '), then
|
|
CC the value returned is 1.
|
|
CC
|
|
CC EXAMPLE:
|
|
CC STR = 'TEST1.DAT '
|
|
CC CALL CHRBLN (STR, IBLK)
|
|
CC
|
|
CC after execution of this code segment, "IBLK" has the value "9", which
|
|
CC is the position of the last non-blank character of "STR".
|
|
CC
|
|
CC***********************************************************************
|
|
CC
|
|
SUBROUTINE CHRBLN (STR, IBLK)
|
|
CC
|
|
CC***********************************************************************
|
|
CHARACTER*(*) STR
|
|
C
|
|
IBLK = 1 ! Substring pointer (default=1)
|
|
ILEN = LEN(STR) ! Length of string
|
|
DO 10 i=ILEN,1,-1
|
|
IF (STR(i:i) /= ' ' .AND. STR(i:i) /= CHAR(0)) THEN
|
|
IBLK = i
|
|
RETURN
|
|
ENDIF
|
|
10 CONTINUE
|
|
RETURN
|
|
C
|
|
END
|
|
|
|
|
|
CC*************************************************************************
|
|
CC
|
|
CC TOOLBOX LIBRARY v.1.0 (May 1995)
|
|
CC
|
|
CC Program unit : SUBROUTINE SHFTRGHT
|
|
CC Purpose : RIGHT-JUSTIFICATION FUNCTION ON A STRING
|
|
CC Author : Athanasios Nenes
|
|
CC
|
|
CC ======================= ARGUMENTS / USAGE =============================
|
|
CC
|
|
CC STRING is the CHARACTER variable with the string to be justified
|
|
CC
|
|
CC EXAMPLE:
|
|
CC STRING = 'AAAA '
|
|
CC CALL SHFTRGHT (STRING)
|
|
CC
|
|
CC after execution of this code segment, STRING contains the value
|
|
CC ' AAAA'.
|
|
CC
|
|
CC*************************************************************************
|
|
CC
|
|
SUBROUTINE SHFTRGHT (CHR)
|
|
CC
|
|
CC***********************************************************************
|
|
CHARACTER CHR*(*)
|
|
C
|
|
I1 = LEN(CHR) ! Total length of string
|
|
CALL CHRBLN(CHR,I2) ! Position of last non-blank character
|
|
IF (I2 == I1) RETURN
|
|
C
|
|
DO 10 I=I2,1,-1 ! Shift characters
|
|
CHR(I1+I-I2:I1+I-I2) = CHR(I:I)
|
|
CHR(I:I) = ' '
|
|
10 CONTINUE
|
|
RETURN
|
|
C
|
|
END
|
|
|
|
|
|
|
|
|
|
CC*************************************************************************
|
|
CC
|
|
CC TOOLBOX LIBRARY v.1.0 (May 1995)
|
|
CC
|
|
CC Program unit : SUBROUTINE RPLSTR
|
|
CC Purpose : REPLACE CHARACTERS OCCURING IN A STRING
|
|
CC Author : Athanasios Nenes
|
|
CC
|
|
CC ======================= ARGUMENTS / USAGE =============================
|
|
CC
|
|
CC STRING is the CHARACTER variable with the string to be edited
|
|
CC OLD is the old character which is to be replaced
|
|
CC NEW is the new character which OLD is to be replaced with
|
|
CC IERR is 0 if everything went well, is 1 if 'NEW' contains 'OLD'.
|
|
CC In this case, this is invalid, and no change is done.
|
|
CC
|
|
CC EXAMPLE:
|
|
CC STRING = 'AAAA'
|
|
CC OLD = 'A'
|
|
CC NEW = 'B'
|
|
CC CALL RPLSTR (STRING, OLD, NEW)
|
|
CC
|
|
CC after execution of this code segment, STRING contains the value
|
|
CC 'BBBB'.
|
|
CC
|
|
CC*************************************************************************
|
|
CC
|
|
SUBROUTINE RPLSTR (STRING, OLD, NEW, IERR)
|
|
CC
|
|
CC***********************************************************************
|
|
CHARACTER STRING*(*), OLD*(*), NEW*(*)
|
|
C
|
|
C *** INITIALIZE ********************************************************
|
|
C
|
|
ILO = LEN(OLD)
|
|
C
|
|
C *** CHECK AND SEE IF 'NEW' CONTAINS 'OLD', WHICH CANNOT ***************
|
|
C
|
|
IP = INDEX(NEW,OLD)
|
|
IF (IP /= 0) THEN
|
|
IERR = 1
|
|
RETURN
|
|
ELSE
|
|
IERR = 0
|
|
ENDIF
|
|
C
|
|
C *** PROCEED WITH REPLACING *******************************************
|
|
C
|
|
10 IP = INDEX(STRING,OLD) ! SEE IF 'OLD' EXISTS IN 'STRING'
|
|
IF (IP == 0) RETURN ! 'OLD' DOES NOT EXIST ; RETURN
|
|
STRING(IP:IP+ILO-1) = NEW ! REPLACE SUBSTRING 'OLD' WITH 'NEW'
|
|
GOTO 10 ! GO FOR NEW OCCURANCE OF 'OLD'
|
|
C
|
|
END
|
|
|
|
|
|
CC*************************************************************************
|
|
CC
|
|
CC TOOLBOX LIBRARY v.1.0 (May 1995)
|
|
CC
|
|
CC Program unit : SUBROUTINE INPTD
|
|
CC Purpose : Prompts user for a value (DOUBLE). A default value
|
|
CC is provided, so if user presses <Enter>, the default
|
|
CC is used.
|
|
CC Author : Athanasios Nenes
|
|
CC
|
|
CC ======================= ARGUMENTS / USAGE =============================
|
|
CC
|
|
CC VAR is the REAL*8 :: variable which value is to be saved
|
|
CC DEF is a REAL*8 :: variable, with the default value of VAR.
|
|
CC PROMPT is a CHARACTER varible containing the prompt string.
|
|
CC PRFMT is a CHARACTER variable containing the FORMAT specifier
|
|
CC for the default value DEF.
|
|
CC IERR is an INTEGER error flag, and has the values:
|
|
CC 0 - No error detected.
|
|
CC 1 - Invalid FORMAT and/or Invalid default value.
|
|
CC 2 - Bad value specified by user
|
|
CC
|
|
CC EXAMPLE:
|
|
CC CALL INPTD (VAR, 1.0D0, 'Give value for A ', '*', Ierr)
|
|
CC
|
|
CC after execution of this code segment, the user is prompted for the
|
|
CC value of variable VAR. If <Enter> is pressed (ie no value is specified)
|
|
CC then 1.0 is assigned to VAR. The default value is displayed in free-
|
|
CC format. The error status is specified by variable Ierr
|
|
CC
|
|
CC***********************************************************************
|
|
CC
|
|
SUBROUTINE INPTD (VAR, DEF, PROMPT, PRFMT, IERR)
|
|
CC
|
|
CC***********************************************************************
|
|
CHARACTER PROMPT*(*), PRFMT*(*), BUFFER*128
|
|
REAL*8 :: DEF, VAR
|
|
INTEGER IERR
|
|
C
|
|
IERR = 0
|
|
C
|
|
C *** WRITE DEFAULT VALUE TO WORK BUFFER *******************************
|
|
C
|
|
WRITE (BUFFER, FMT=PRFMT, ERR=10) DEF
|
|
CALL CHRBLN (BUFFER, IEND)
|
|
C
|
|
C *** PROMPT USER FOR INPUT AND READ IT ********************************
|
|
C
|
|
C WRITE (*,*) PROMPT,' [',BUFFER(1:IEND),']: '
|
|
C READ (*, '(A)', ERR=20, END=20) BUFFER
|
|
CALL CHRBLN (BUFFER,IEND)
|
|
C
|
|
C *** READ DATA OR SET DEFAULT ? ****************************************
|
|
C
|
|
IF (IEND == 1 .AND. BUFFER(1:1) == ' ') THEN
|
|
VAR = DEF
|
|
ELSE
|
|
READ (BUFFER, *, ERR=20, END=20) VAR
|
|
ENDIF
|
|
C
|
|
C *** RETURN POINT ******************************************************
|
|
C
|
|
30 RETURN
|
|
C
|
|
C *** ERROR HANDLER *****************************************************
|
|
C
|
|
10 IERR = 1 ! Bad FORMAT and/or bad default value
|
|
GOTO 30
|
|
C
|
|
20 IERR = 2 ! Bad number given by user
|
|
GOTO 30
|
|
C
|
|
END
|
|
|
|
|
|
CC*************************************************************************
|
|
CC
|
|
CC TOOLBOX LIBRARY v.1.0 (May 1995)
|
|
CC
|
|
CC Program unit : SUBROUTINE Pushend
|
|
CC Purpose : Positions the pointer of a sequential file at its end
|
|
CC Simulates the ACCESS='APPEND' clause of a F77L OPEN
|
|
CC statement with Standard Fortran commands.
|
|
CC
|
|
CC ======================= ARGUMENTS / USAGE =============================
|
|
CC
|
|
CC Iunit is a INTEGER variable, the file unit which the file is
|
|
CC connected to.
|
|
CC
|
|
CC EXAMPLE:
|
|
CC CALL PUSHEND (10)
|
|
CC
|
|
CC after execution of this code segment, the pointer of unit 10 is
|
|
CC pushed to its end.
|
|
CC
|
|
CC***********************************************************************
|
|
CC
|
|
SUBROUTINE Pushend (Iunit)
|
|
CC
|
|
CC***********************************************************************
|
|
C
|
|
LOGICAL OPNED
|
|
C
|
|
C *** INQUIRE IF Iunit CONNECTED TO FILE ********************************
|
|
C
|
|
INQUIRE (UNIT=Iunit, OPENED=OPNED)
|
|
IF (.NOT.OPNED) GOTO 25
|
|
C
|
|
C *** Iunit CONNECTED, PUSH POINTER TO END ******************************
|
|
C
|
|
10 READ (Iunit,'()', ERR=20, END=20)
|
|
GOTO 10
|
|
C
|
|
C *** RETURN POINT ******************************************************
|
|
C
|
|
20 BACKSPACE (Iunit)
|
|
25 RETURN
|
|
END
|
|
|
|
|
|
|
|
CC*************************************************************************
|
|
CC
|
|
CC TOOLBOX LIBRARY v.1.0 (May 1995)
|
|
CC
|
|
CC Program unit : SUBROUTINE APPENDEXT
|
|
CC Purpose : Fix extension in file name string
|
|
CC
|
|
CC ======================= ARGUMENTS / USAGE =============================
|
|
CC
|
|
CC Filename is the CHARACTER variable with the file name
|
|
CC Defext is the CHARACTER variable with extension (including '.',
|
|
CC ex. '.DAT')
|
|
CC Overwrite is a LOGICAL value, .TRUE. overwrites any existing extension
|
|
CC in "Filename" with "Defext", .FALSE. puts "Defext" only if
|
|
CC there is no extension in "Filename".
|
|
CC
|
|
CC EXAMPLE:
|
|
CC FILENAME1 = 'TEST.DAT'
|
|
CC FILENAME2 = 'TEST.DAT'
|
|
CC CALL APPENDEXT (FILENAME1, '.TXT', .FALSE.)
|
|
CC CALL APPENDEXT (FILENAME2, '.TXT', .TRUE. )
|
|
CC
|
|
CC after execution of this code segment, "FILENAME1" has the value
|
|
CC 'TEST.DAT', while "FILENAME2" has the value 'TEST.TXT'
|
|
CC
|
|
CC***********************************************************************
|
|
CC
|
|
SUBROUTINE Appendext (Filename, Defext, Overwrite)
|
|
CC
|
|
CC***********************************************************************
|
|
CHARACTER*(*) Filename, Defext
|
|
LOGICAL Overwrite
|
|
C
|
|
CALL CHRBLN (Filename, Iend)
|
|
IF (Filename(1:1) == ' ' .AND. Iend == 1) RETURN ! Filename empty
|
|
Idot = INDEX (Filename, '.') ! Append extension ?
|
|
IF (Idot == 0) Filename = Filename(1:Iend)//Defext
|
|
IF (Overwrite .AND. Idot /= 0)
|
|
& Filename = Filename(:Idot-1)//Defext
|
|
RETURN
|
|
END
|
|
|
|
|
|
|
|
C SUBROUTINE TEST_QTCRT(degree,a,z)
|
|
C !-----------------------------------------------------------------------
|
|
C ! Test program written to be compatible with ELF90 by
|
|
C ! Alan Miller
|
|
C ! amiller @ bigpond.net.au
|
|
C ! WWW-page: http://users.bigpond.net.au/amiller
|
|
C ! Latest revision - 27 February 1997
|
|
C !-----------------------------------------------------------------------
|
|
C USE constants_NSWC
|
|
C IMPLICIT NONE
|
|
C
|
|
C INTEGER :: degree, i
|
|
C REAL (dp) :: a(0:4)
|
|
C COMPLEX (dp) :: z(4)
|
|
C
|
|
C INTERFACE
|
|
C SUBROUTINE qdcrt (a, z)
|
|
C USE constants_NSWC
|
|
C IMPLICIT NONE
|
|
C REAL (dp), INTENT(IN) :: a(:)
|
|
C COMPLEX (dp), INTENT(OUT) :: z(:)
|
|
C END SUBROUTINE qdcrt
|
|
C
|
|
C SUBROUTINE cbcrt (a, z)
|
|
C USE constants_NSWC
|
|
C IMPLICIT NONE
|
|
C REAL (dp), INTENT(IN) :: a(:)
|
|
C COMPLEX (dp), INTENT(OUT) :: z(:)
|
|
C END SUBROUTINE cbcrt
|
|
C
|
|
C SUBROUTINE qtcrt (a, z)
|
|
C USE constants_NSWC
|
|
C IMPLICIT NONE
|
|
C REAL (dp), INTENT(IN) :: a(:)
|
|
C COMPLEX (dp), INTENT(OUT) :: z(:)
|
|
C END SUBROUTINE qtcrt
|
|
C END INTERFACE
|
|
C
|
|
C WRITE(*, *) 'Solve quadratic, cubic, quartic eq. w/REAL coeffs'
|
|
C WRITE(*, *)
|
|
C
|
|
CC DO
|
|
C WRITE(*, *)'Enter 2, 3, 4 for quadratic, cubic or quartic eqn.:'
|
|
CC READ(*, *) degree
|
|
C SELECT CASE (degree)
|
|
C CASE (2)
|
|
C WRITE(*, *)'Enter a(0), a(1) then a(2): '
|
|
C WRITE(*, *) a(0), a(1), a(2)
|
|
C CALL qdcrt(a, z)
|
|
C WRITE(*, '(a, 2(/2g20.12))') ' Rts: REAL PART IMAG PART',
|
|
C & (DBLE(z(i)), AIMAG(z(i)), i=1,2)
|
|
C CASE (3)
|
|
C WRITE(*, *)'Enter a(0), a(1), a(2) then a(3): '
|
|
C WRITE(*, *) a(0), a(1), a(2), a(3)
|
|
C CALL cbcrt(a, z)
|
|
C WRITE(*, '(a, 3(/2g20.12))') ' Rts: REAL PART IMAG PART',
|
|
C & (DBLE(z(i)), AIMAG(z(i)), i=1,3)
|
|
C CASE (4)
|
|
C WRITE(*, *)'Enter a(0), a(1), a(2), a(3) then a(4): '
|
|
C WRITE(*, *) a(0), a(1), a(2), a(3), a(4)
|
|
C CALL qtcrt(a, z)
|
|
C WRITE(*, '(a, 4(/2g20.12))') ' Rts: REAL PART IMAG PART',
|
|
C & (DBLE(z(i)), AIMAG(z(i)), i=1,4)
|
|
C CASE DEFAULT
|
|
C WRITE(*, *)'*** Try again! ***'
|
|
C WRITE(*, *)'Use Ctrl-C to exit the program'
|
|
C END SELECT
|
|
CC END DO
|
|
C
|
|
C RETURN
|
|
C END SUBROUTINE TEST_QTCRT
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE POLY3
|
|
C *** FINDS THE REAL ROOTS OF THE THIRD ORDER ALGEBRAIC EQUATION:
|
|
C X**3 + A1*X**2 + A2*X + A3 = 0.0
|
|
C THE EQUATION IS SOLVED ANALYTICALLY.
|
|
C
|
|
C PARAMETERS A1, A2, A3 ARE SPECIFIED BY THE USER. THE MINIMUM
|
|
C NONEGATIVE ROOT IS RETURNED IN VARIABLE 'ROOT'. IF NO ROOT IS
|
|
C FOUND (WHICH IS GREATER THAN ZERO), ROOT HAS THE VALUE 1D30.
|
|
C AND THE FLAG ISLV HAS A VALUE GREATER THAN ZERO.
|
|
C
|
|
C SOLUTION FORMULA IS FOUND IN PAGE 32 OF:
|
|
C MATHEMATICAL HANDBOOK OF FORMULAS AND TABLES
|
|
C SCHAUM'S OUTLINE SERIES
|
|
C MURRAY SPIEGER, McGRAW-HILL, NEW YORK, 1968
|
|
C (GREEK TRANSLATION: BY SOTIRIOS PERSIDES, ESPI, ATHENS, 1976)
|
|
C
|
|
C A SPECIAL CASE IS CONSIDERED SEPERATELY ; WHEN A3 = 0, THEN
|
|
C ONE ROOT IS X=0.0, AND THE OTHER TWO FROM THE SOLUTION OF THE
|
|
C QUADRATIC EQUATION X**2 + A1*X + A2 = 0.0
|
|
C THIS SPECIAL CASE IS CONSIDERED BECAUSE THE ANALYTICAL FORMULA
|
|
C DOES NOT YIELD ACCURATE RESULTS (DUE TO NUMERICAL ROUNDOFF ERRORS)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE POLY3 (A1, A2, A3, ROOT, ISLV)
|
|
C
|
|
IMPLICIT NONE
|
|
REAL*8, PARAMETER :: EXPON=1.D0/3.D0
|
|
REAL*8, PARAMETER :: ZERO=0.D0
|
|
REAL*8, PARAMETER :: THET1=120.D0/180.D0
|
|
REAL*8, PARAMETER :: THET2=240.D0/180.D0
|
|
REAL*8, PARAMETER :: PI=3.1415926535897932D0
|
|
REAL*8, PARAMETER :: EPS=1.D-50
|
|
|
|
REAL*8 :: x(3), a1, a2, a3, root
|
|
INTEGER :: ix, i, islv
|
|
REAL*8 :: d, q, u, s, t
|
|
REAL*8 :: sqd
|
|
REAL*8 :: thet
|
|
REAL*8 :: coef
|
|
REAL*8 :: ssig, tsig
|
|
C
|
|
C *** SPECIAL CASE : QUADRATIC*X EQUATION *****************************
|
|
C
|
|
IF (ABS(A3) <= EPS) THEN
|
|
ISLV = 1
|
|
IX = 1
|
|
X(1) = ZERO
|
|
D = A1*A1-4.D0*A2
|
|
IF ((D) >= ZERO) THEN
|
|
IX = 3
|
|
SQD = SQRT(D)
|
|
X(2) = 0.5*(-A1+SQD)
|
|
X(3) = 0.5*(-A1-SQD)
|
|
ELSE
|
|
C WRITE(*,*) 'No solution being determined'
|
|
PAUSE
|
|
ENDIF
|
|
ELSE
|
|
C
|
|
C *** NORMAL CASE : CUBIC EQUATION ************************************
|
|
C
|
|
C DEFINE PARAMETERS Q, U, S, T, D
|
|
C
|
|
ISLV= 1
|
|
Q = (3.D0*A2 - A1*A1)/9.D0
|
|
U = (9.D0*A1*A2 - 27.D0*A3 - 2.D0*A1*A1*A1)/54.D0
|
|
D = Q*Q*Q + U*U
|
|
C
|
|
C *** CALCULATE ROOTS *************************************************
|
|
C
|
|
C D < 0, THREE REAL ROOTS
|
|
C
|
|
IF ((D) < -EPS) THEN ! D < -EPS : D < ZERO
|
|
IX = 3
|
|
THET = EXPON*ACOS(U/SQRT(-Q*Q*Q))
|
|
COEF = 2.D0*SQRT(-Q)
|
|
X(1) = COEF*COS(THET) - EXPON*A1
|
|
X(2) = COEF*COS(THET + THET1*PI) - EXPON*A1
|
|
X(3) = COEF*COS(THET + THET2*PI) - EXPON*A1
|
|
C
|
|
C D = 0, THREE REAL (ONE DOUBLE) ROOTS
|
|
C
|
|
ELSE IF ((D) <= EPS) THEN ! -EPS <= D <= EPS : D = ZERO
|
|
IX = 2
|
|
SSIG = SIGN (1.D0, U)
|
|
S = SSIG*(ABS(U))**EXPON
|
|
X(1) = 2.D0*S - EXPON*A1
|
|
X(2) = -S - EXPON*A1
|
|
C
|
|
C D > 0, ONE REAL ROOT
|
|
C
|
|
ELSE ! D > EPS : D > ZERO
|
|
IX = 1
|
|
SQD = SQRT(D)
|
|
SSIG = SIGN (1.D0, U+SQD) ! TRANSFER SIGN TO SSIG
|
|
TSIG = SIGN (1.D0, U-SQD)
|
|
S = SSIG*(ABS(U+SQD))**EXPON ! EXPONENTIATE ABS()
|
|
T = TSIG*(ABS(U-SQD))**EXPON
|
|
X(1) = S + T - EXPON*A1
|
|
ENDIF
|
|
ENDIF
|
|
C
|
|
C *** SELECT APPROPRIATE ROOT *****************************************
|
|
C
|
|
ROOT = 1.D30
|
|
DO I=1,IX
|
|
IF ((X(I)) > ZERO) THEN
|
|
ROOT = MIN(ROOT, X(I))
|
|
ISLV = 0
|
|
ENDIF
|
|
ENDDO
|
|
C
|
|
C *** END OF SUBROUTINE POLY3 *****************************************
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** FUNCTION EX10
|
|
C *** 10^X FUNCTION ; ALTERNATE OF LIBRARY ROUTINE ; USED BECAUSE IT IS
|
|
C MUCH FASTER BUT WITHOUT GREAT LOSS IN ACCURACY. ,
|
|
C MAXIMUM ERROR IS 2%, EXECUTION TIME IS 42% OF THE LIBRARY ROUTINE
|
|
C (ON A 80286/80287 MACHINE, using Lahey FORTRAN 77 v.3.0).
|
|
C
|
|
C EXPONENT RANGE IS BETWEEN -K AND K (K IS THE REAL ARGUMENT 'K')
|
|
C MAX VALUE FOR K: 9.999
|
|
C IF X < -K, X IS SET TO -K, IF X > K, X IS SET TO K
|
|
C
|
|
C THE EXPONENT IS CALCULATED BY THE PRODUCT ADEC*AINT, WHERE ADEC
|
|
C IS THE MANTISSA AND AINT IS THE MAGNITUDE (EXPONENT). BOTH
|
|
C MANTISSA AND MAGNITUDE ARE PRE-CALCULATED AND STORED IN LOOKUP
|
|
C TABLES ; THIS LEADS TO THE INCREASED SPEED.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
FUNCTION EX10(X,K)
|
|
REAL X, EX10, Y, AINT10, ADEC10, K
|
|
INTEGER K1, K2
|
|
COMMON /EXPNC/ AINT10(20), ADEC10(200)
|
|
C
|
|
C *** LIMIT X TO [-K, K] RANGE *****************************************
|
|
C
|
|
Y = MAX(-K, MIN(X,K)) ! MIN: -9.999, MAX: 9.999
|
|
C
|
|
C *** GET INTEGER AND DECIMAL PART *************************************
|
|
C
|
|
K1 = INT(Y)
|
|
K2 = INT(100*(Y-K1))
|
|
C
|
|
C *** CALCULATE EXP FUNCTION *******************************************
|
|
C
|
|
EX10 = AINT10(K1+10)*ADEC10(K2+100)
|
|
C
|
|
C *** END OF EXP FUNCTION **********************************************
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** BLOCK DATA EXPON
|
|
C *** CONTAINS DATA FOR EXPONENT ARRAYS NEEDED IN FUNCTION EXP10
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
BLOCK DATA EXPONb
|
|
C
|
|
C *** Common block definition
|
|
C
|
|
REAL*8 :: AINT10, ADEC10
|
|
COMMON /EXPNC/ AINT10(20), ADEC10(200)
|
|
C
|
|
C *** Integer part
|
|
C
|
|
DATA AINT10/
|
|
& 0.1000E-08, 0.1000E-07, 0.1000E-06, 0.1000E-05, 0.1000E-04,
|
|
& 0.1000E-03, 0.1000E-02, 0.1000E-01, 0.1000E+00, 0.1000E+01,
|
|
& 0.1000E+02, 0.1000E+03, 0.1000E+04, 0.1000E+05, 0.1000E+06,
|
|
& 0.1000E+07, 0.1000E+08, 0.1000E+09, 0.1000E+10, 0.1000E+11
|
|
& /
|
|
C
|
|
C *** decimal part
|
|
C
|
|
DATA (ADEC10(I),I=1,100)/
|
|
& 0.1023E+00, 0.1047E+00, 0.1072E+00, 0.1096E+00, 0.1122E+00,
|
|
& 0.1148E+00, 0.1175E+00, 0.1202E+00, 0.1230E+00, 0.1259E+00,
|
|
& 0.1288E+00, 0.1318E+00, 0.1349E+00, 0.1380E+00, 0.1413E+00,
|
|
& 0.1445E+00, 0.1479E+00, 0.1514E+00, 0.1549E+00, 0.1585E+00,
|
|
& 0.1622E+00, 0.1660E+00, 0.1698E+00, 0.1738E+00, 0.1778E+00,
|
|
& 0.1820E+00, 0.1862E+00, 0.1905E+00, 0.1950E+00, 0.1995E+00,
|
|
& 0.2042E+00, 0.2089E+00, 0.2138E+00, 0.2188E+00, 0.2239E+00,
|
|
& 0.2291E+00, 0.2344E+00, 0.2399E+00, 0.2455E+00, 0.2512E+00,
|
|
& 0.2570E+00, 0.2630E+00, 0.2692E+00, 0.2754E+00, 0.2818E+00,
|
|
& 0.2884E+00, 0.2951E+00, 0.3020E+00, 0.3090E+00, 0.3162E+00,
|
|
& 0.3236E+00, 0.3311E+00, 0.3388E+00, 0.3467E+00, 0.3548E+00,
|
|
& 0.3631E+00, 0.3715E+00, 0.3802E+00, 0.3890E+00, 0.3981E+00,
|
|
& 0.4074E+00, 0.4169E+00, 0.4266E+00, 0.4365E+00, 0.4467E+00,
|
|
& 0.4571E+00, 0.4677E+00, 0.4786E+00, 0.4898E+00, 0.5012E+00,
|
|
& 0.5129E+00, 0.5248E+00, 0.5370E+00, 0.5495E+00, 0.5623E+00,
|
|
& 0.5754E+00, 0.5888E+00, 0.6026E+00, 0.6166E+00, 0.6310E+00,
|
|
& 0.6457E+00, 0.6607E+00, 0.6761E+00, 0.6918E+00, 0.7079E+00,
|
|
& 0.7244E+00, 0.7413E+00, 0.7586E+00, 0.7762E+00, 0.7943E+00,
|
|
& 0.8128E+00, 0.8318E+00, 0.8511E+00, 0.8710E+00, 0.8913E+00,
|
|
& 0.9120E+00, 0.9333E+00, 0.9550E+00, 0.9772E+00, 0.1000E+01/
|
|
|
|
DATA (ADEC10(I),I=101,200)/
|
|
& 0.1023E+01, 0.1047E+01, 0.1072E+01, 0.1096E+01, 0.1122E+01,
|
|
& 0.1148E+01, 0.1175E+01, 0.1202E+01, 0.1230E+01, 0.1259E+01,
|
|
& 0.1288E+01, 0.1318E+01, 0.1349E+01, 0.1380E+01, 0.1413E+01,
|
|
& 0.1445E+01, 0.1479E+01, 0.1514E+01, 0.1549E+01, 0.1585E+01,
|
|
& 0.1622E+01, 0.1660E+01, 0.1698E+01, 0.1738E+01, 0.1778E+01,
|
|
& 0.1820E+01, 0.1862E+01, 0.1905E+01, 0.1950E+01, 0.1995E+01,
|
|
& 0.2042E+01, 0.2089E+01, 0.2138E+01, 0.2188E+01, 0.2239E+01,
|
|
& 0.2291E+01, 0.2344E+01, 0.2399E+01, 0.2455E+01, 0.2512E+01,
|
|
& 0.2570E+01, 0.2630E+01, 0.2692E+01, 0.2754E+01, 0.2818E+01,
|
|
& 0.2884E+01, 0.2951E+01, 0.3020E+01, 0.3090E+01, 0.3162E+01,
|
|
& 0.3236E+01, 0.3311E+01, 0.3388E+01, 0.3467E+01, 0.3548E+01,
|
|
& 0.3631E+01, 0.3715E+01, 0.3802E+01, 0.3890E+01, 0.3981E+01,
|
|
& 0.4074E+01, 0.4169E+01, 0.4266E+01, 0.4365E+01, 0.4467E+01,
|
|
& 0.4571E+01, 0.4677E+01, 0.4786E+01, 0.4898E+01, 0.5012E+01,
|
|
& 0.5129E+01, 0.5248E+01, 0.5370E+01, 0.5495E+01, 0.5623E+01,
|
|
& 0.5754E+01, 0.5888E+01, 0.6026E+01, 0.6166E+01, 0.6310E+01,
|
|
& 0.6457E+01, 0.6607E+01, 0.6761E+01, 0.6918E+01, 0.7079E+01,
|
|
& 0.7244E+01, 0.7413E+01, 0.7586E+01, 0.7762E+01, 0.7943E+01,
|
|
& 0.8128E+01, 0.8318E+01, 0.8511E+01, 0.8710E+01, 0.8913E+01,
|
|
& 0.9120E+01, 0.9333E+01, 0.9550E+01, 0.9772E+01, 0.1000E+02
|
|
& /
|
|
C
|
|
C *** END OF BLOCK DATA EXPON ******************************************
|
|
C
|
|
END
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE PUSHERR
|
|
C *** THIS SUBROUTINE SAVES AN ERROR MESSAGE IN THE ERROR STACK
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE PUSHERR (IERR,ERRINF)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
CHARACTER(LEN=*) :: ERRINF
|
|
C
|
|
C *** SAVE ERROR CODE IF THERE IS ANY SPACE ***************************
|
|
C
|
|
C WRITE(*,*) 'Calling Error, IERR: ',IERR,ERRINF
|
|
C PAUSE
|
|
IF (NOFER < NERRMX) THEN
|
|
NOFER = NOFER + 1
|
|
ERRSTK(NOFER) = IERR
|
|
ERRMSG(NOFER) = ERRINF
|
|
STKOFL =.FALSE.
|
|
ELSE
|
|
STKOFL =.TRUE. ! STACK OVERFLOW
|
|
ENDIF
|
|
C
|
|
C *** END OF SUBROUTINE PUSHERR ****************************************
|
|
C
|
|
END
|
|
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ISERRINF
|
|
C *** THIS SUBROUTINE OBTAINS A COPY OF THE ERROR STACK (& MESSAGES)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISERRINF (ERRSTKI, ERRMSGI, NOFERI, STKOFLI)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
CHARACTER(LEN=40) :: ERRMSGI(NERRMX)
|
|
INTEGER :: ERRSTKI(NERRMX)
|
|
LOGICAL :: STKOFLI
|
|
C
|
|
C *** OBTAIN WHOLE ERROR STACK ****************************************
|
|
C
|
|
DO I=1,NOFER ! Error messages & codes
|
|
ERRSTKI(I) = ERRSTK(I)
|
|
ERRMSGI(I) = ERRMSG(I)
|
|
ENDDO
|
|
C
|
|
STKOFLI = STKOFL
|
|
NOFERI = NOFER
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE ISERRINF ***************************************
|
|
C
|
|
END
|
|
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ERRSTAT
|
|
C *** THIS SUBROUTINE REPORTS ERROR MESSAGES TO UNIT 'IO'
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ERRSTAT (IO,IERR,ERRINF)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
CHARACTER(LEN=4) :: CER
|
|
CHARACTER(LEN=29) :: NCIS = 'NO CONVERGENCE IN SUBROUTINE '
|
|
CHARACTER(LEN=27) :: NCIF = 'NO CONVERGENCE IN FUNCTION '
|
|
CHARACTER(LEN=26) :: NSIS = 'NO SOLUTION IN SUBROUTINE '
|
|
CHARACTER(LEN=24) :: NSIF = 'NO SOLUTION IN FUNCTION '
|
|
CHARACTER(*) :: ERRINF
|
|
C
|
|
C *** WRITE ERROR IN CHARACTER *****************************************
|
|
C
|
|
C WRITE (*,'(I4)') IERR
|
|
WRITE (CER,'(I4)') IERR
|
|
CALL RPLSTR (CER, ' ', '0',IOK) ! REPLACE BLANKS WITH ZEROS
|
|
CALL CHRBLN (ERRINF, IEND) ! LAST POSITION OF ERRINF CHAR
|
|
C
|
|
C *** WRITE ERROR TYPE (FATAL, WARNING ) *******************************
|
|
C
|
|
IF (IERR == 0) THEN
|
|
WRITE (IO,1000) 'NO ERRORS DETECTED '
|
|
GOTO 10
|
|
C
|
|
ELSE IF (IERR < 0) THEN
|
|
WRITE (IO,1000) 'ERROR STACK EXHAUSTED '
|
|
GOTO 10
|
|
C
|
|
ELSE IF (IERR > 1000) THEN
|
|
WRITE (IO,1100) 'FATAL',CER
|
|
C
|
|
ELSE
|
|
WRITE (IO,1100) 'WARNING',CER
|
|
ENDIF
|
|
C
|
|
C *** WRITE ERROR MESSAGE **********************************************
|
|
C
|
|
C FATAL MESSAGES
|
|
C
|
|
IF (IERR == 1001) THEN
|
|
CALL CHRBLN (SCASE, IEND)
|
|
WRITE (IO,1000) 'CASE NOT SUPPORTED IN CALCMR ['//SCASE(1:IEND)
|
|
& //']'
|
|
C
|
|
ELSEIF (IERR == 1002) THEN
|
|
CALL CHRBLN (SCASE, IEND)
|
|
WRITE (IO,1000) 'CASE NOT SUPPORTED ['//SCASE(1:IEND)//']'
|
|
C
|
|
C WARNING MESSAGES
|
|
C
|
|
ELSEIF (IERR == 0001) THEN
|
|
WRITE (IO,1000) NSIS,ERRINF
|
|
C
|
|
ELSEIF (IERR == 0002) THEN
|
|
WRITE (IO,1000) NCIS,ERRINF
|
|
C
|
|
ELSEIF (IERR == 0003) THEN
|
|
WRITE (IO,1000) NSIF,ERRINF
|
|
C
|
|
ELSEIF (IERR == 0004) THEN
|
|
WRITE (IO,1000) NCIF,ERRINF
|
|
C
|
|
ELSE IF (IERR == 0019) THEN
|
|
WRITE (IO,1000) 'HNO3(aq) AFFECTS H+, WHICH '//
|
|
& 'MIGHT AFFECT SO4/HSO4 RATIO'
|
|
WRITE (IO,1000) 'DIRECT INCREASE IN H+ [',ERRINF(1:IEND),'] %'
|
|
C
|
|
ELSE IF (IERR == 0020) THEN
|
|
IF ((W(4)) > TINY .AND. (W(5)) > TINY) THEN
|
|
WRITE (IO,1000) 'HSO4-SO4 EQUILIBRIUM MIGHT AFFECT HNO3,'
|
|
& //'HCL DISSOLUTION'
|
|
ELSE
|
|
WRITE (IO,1000) 'HSO4-SO4 EQUILIBRIUM MIGHT AFFECT NH3 '
|
|
& //'DISSOLUTION'
|
|
ENDIF
|
|
WRITE (IO,1000) 'DIRECT DECREASE IN H+ [',ERRINF(1:IEND),'] %'
|
|
C
|
|
ELSE IF (IERR == 0021) THEN
|
|
WRITE (IO,1000) 'HNO3(aq),HCL(aq) AFFECT H+, WHICH '//
|
|
& 'MIGHT AFFECT SO4/HSO4 RATIO'
|
|
WRITE (IO,1000) 'DIRECT INCREASE IN H+ [',ERRINF(1:IEND),'] %'
|
|
C
|
|
ELSE IF (IERR == 0022) THEN
|
|
WRITE (IO,1000) 'HCL(g) EQUILIBRIUM YIELDS NONPHYSICAL '//
|
|
& 'DISSOLUTION'
|
|
WRITE (IO,1000) 'A TINY AMOUNT [',ERRINF(1:IEND),'] IS '//
|
|
& 'ASSUMED TO BE DISSOLVED'
|
|
C
|
|
ELSEIF (IERR == 0033) THEN
|
|
WRITE (IO,1000) 'HCL(aq) AFFECTS H+, WHICH '//
|
|
& 'MIGHT AFFECT SO4/HSO4 RATIO'
|
|
WRITE (IO,1000) 'DIRECT INCREASE IN H+ [',ERRINF(1:IEND),'] %'
|
|
C
|
|
ELSEIF (IERR == 0050) THEN
|
|
WRITE (IO,1000) 'TOO MUCH SODIUM GIVEN AS INPUT.'
|
|
WRITE (IO,1000) 'REDUCED TO COMPLETELY NEUTRALIZE SO4,Cl,NO3.'
|
|
WRITE (IO,1000) 'EXCESS SODIUM IS IGNORED.'
|
|
C
|
|
ELSEIF (IERR == 0100) THEN
|
|
C WRITE(*,*) 'Executing PUSHERR 100'
|
|
WRITE (IO,1000) 'CONVERGENCE TO VALUE OTHER THAN 0 '
|
|
WRITE (IO,1000) 'FUNCTION AND VALUE: ',ERRINF(1:IEND),'.'
|
|
C
|
|
ELSEIF (IERR == 0101) THEN
|
|
C WRITE(*,*) 'Executing PUSHERR 101'
|
|
WRITE (IO,1000) 'CONVERGENCE AT INITIAL VALUE.'
|
|
WRITE (IO,1000) 'FUNCTION AND VALUE: ',ERRINF(1:IEND),'.'
|
|
C
|
|
ELSEIF (IERR == 0102) THEN
|
|
C WRITE(*,*) 'Executing PUSHERR 102'
|
|
WRITE (IO,1000) 'EXCEEDED THE THRESHOLD VALUE FOR IONIC.'
|
|
WRITE (IO,1000) 'FUNCTION AND VALUE: ',ERRINF(1:IEND),'.'
|
|
C
|
|
ELSEIF (IERR == 0103) THEN
|
|
C WRITE(*,*) 'Executing PUSHERR 103'
|
|
WRITE (IO,1000) 'VERY SMALL VALUE FOR TEST VARIABLE.'
|
|
WRITE (IO,1000) 'FUNCTION AND VALUE: ',ERRINF(1:IEND),'.'
|
|
C
|
|
ELSEIF (IERR == 0104) THEN
|
|
C WRITE(*,*) 'Executing PUSHERR 104'
|
|
WRITE (IO,1000) 'NEWTON METHOD NOT CONVERGING.'
|
|
WRITE (IO,1000) 'FUNCTION AND Y1-Y2 DIFF: ',ERRINF(1:IEND),'.'
|
|
C
|
|
ELSE
|
|
WRITE (IO,1000) 'NO DIAGNOSTIC MESSAGE AVAILABLE'
|
|
ENDIF
|
|
C
|
|
10 RETURN
|
|
C
|
|
C *** FORMAT STATEMENTS *************************************
|
|
C
|
|
1000 FORMAT (1X,A:A:A:A:A)
|
|
1100 FORMAT (1X,A,' ERROR [',A4,']:')
|
|
C
|
|
C *** END OF SUBROUTINE ERRSTAT *****************************
|
|
C
|
|
END
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ISORINF
|
|
C *** THIS SUBROUTINE PROVIDES INFORMATION ABOUT ISORROPIA
|
|
C
|
|
C ======================== ARGUMENTS / USAGE ===========================
|
|
C
|
|
C OUTPUT:
|
|
C 1. [VERSI]
|
|
C CHARACTER*15 variable.
|
|
C Contains version-date information of ISORROPIA
|
|
C
|
|
C 2. [NCMP]
|
|
C INTEGER variable.
|
|
C The number of components needed in input array WI
|
|
C (or, the number of major species accounted for by ISORROPIA)
|
|
C
|
|
C 3. [NION]
|
|
C INTEGER variable
|
|
C The number of ions considered in the aqueous phase
|
|
C
|
|
C 4. [NAQGAS]
|
|
C INTEGER variable
|
|
C The number of undissociated species found in aqueous aerosol
|
|
C phase
|
|
C
|
|
C 5. [NSOL]
|
|
C INTEGER variable
|
|
C The number of solids considered in the solid aerosol phase
|
|
C
|
|
C 6. [NERR]
|
|
C INTEGER variable
|
|
C The size of the error stack (maximum number of errors that can
|
|
C be stored before the stack exhausts).
|
|
C
|
|
C 7. [TIN]
|
|
C REAL*8 :: variable
|
|
C The value used for a very small number.
|
|
C
|
|
C 8. [GRT]
|
|
C REAL*8 :: variable
|
|
C The value used for a very large number.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISORINF (VERSI, NCMP, NION, NAQGAS, NSOL, NERR, TIN,
|
|
& GRT)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: TIN, GRT
|
|
CHARACTER VERSI*(*)
|
|
C
|
|
C *** ASSIGN INFO *******************************************************
|
|
C
|
|
VERSI = VERSION
|
|
NCMP = NCOMP
|
|
NION = NIONS
|
|
NAQGAS = NGASAQ
|
|
NSOL = NSLDS
|
|
NERR = NERRMX
|
|
TIN = TINY
|
|
GRT = GREAT
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE ISORINF *******************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ISRP1F
|
|
C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF
|
|
C AN AMMONIUM-SULFATE AEROSOL SYSTEM.
|
|
C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY
|
|
C THE AMBIENT RELATIVE HUMIDITY.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISRP1F (WI, RHI, TEMPI)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: WI(NCOMP), RHI, TEMPI
|
|
REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2)
|
|
REAL*8 :: DC
|
|
C
|
|
C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK **************************
|
|
C
|
|
CALL INIT1 (WI, RHI, TEMPI)
|
|
C
|
|
C *** CALCULATE SULFATE RATIO *******************************************
|
|
C
|
|
SULRAT = (W(3))/(W(2))
|
|
C
|
|
C *** FIND CALCULATION REGIME FROM (SULRAT,RH) **************************
|
|
C
|
|
C *** SULFATE POOR
|
|
C
|
|
IF (2.0 <= SULRAT) THEN
|
|
C WP = W
|
|
!WRITE(*,*) 'Calling ISRP1FA, WI: ',WI
|
|
CALL ISRP1FA ! Wrapper for TAPENADE to process correctly
|
|
C DC = W(3) - 2.001D0*W(2) ! For numerical stability
|
|
C W(3) = W(3) + MAX(-DC, ZERO)
|
|
CC
|
|
CC IF(METSTBL == 1) THEN
|
|
C SCASE = 'A2'
|
|
C CALL CALCA2 ! Only liquid (metastable)
|
|
C ELSE
|
|
C
|
|
C IF (RH < DRNH42S4) THEN
|
|
C SCASE = 'A1'
|
|
C CALL CALCA1 ! NH42SO4 ; case A1
|
|
CC
|
|
C ELSEIF (DRNH42S4 <= RH) THEN
|
|
C SCASE = 'A2'
|
|
C CALL CALCA2 ! Only liquid ; case A2
|
|
C ENDIF
|
|
C ENDIF
|
|
C
|
|
C *** SULFATE RICH (NO ACID)
|
|
C
|
|
ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN
|
|
C
|
|
C IF(METSTBL == 1) THEN
|
|
!WRITE(*,*) 'Calling CALCB4, WI: ',WI
|
|
SCASE = 'B4'
|
|
C WP = W
|
|
CALL CALCB4 ! Only liquid (metastable)
|
|
C ELSE
|
|
CC
|
|
C IF (RH < DRNH4HS4) THEN
|
|
C SCASE = 'B1'
|
|
C CALL CALCB1 ! NH4HSO4,LC,NH42SO4 ; case B1
|
|
CC
|
|
C ELSEIF (DRNH4HS4 <= RH .AND. RH < DRLC) THEN
|
|
C SCASE = 'B2'
|
|
C CALL CALCB2 ! LC,NH42S4 ; case B2
|
|
CC
|
|
C ELSEIF (DRLC <= RH .AND. RH < DRNH42S4) THEN
|
|
C SCASE = 'B3'
|
|
C CALL CALCB3 ! NH42S4 ; case B3
|
|
CC
|
|
C ELSEIF (DRNH42S4 <= RH) THEN
|
|
C SCASE = 'B4'
|
|
C CALL CALCB4 ! Only liquid ; case B4
|
|
C ENDIF
|
|
C ENDIF
|
|
CALL CALCACT3F ! Checking for IONIC too high
|
|
CALL CALCNH3
|
|
C
|
|
C *** SULFATE RICH (FREE ACID)
|
|
C
|
|
ELSEIF (SULRAT < 1.0) THEN
|
|
C
|
|
C IF(METSTBL == 1) THEN
|
|
!WRITE(*,*) 'Calling CALCC2, WI: ',WI
|
|
SCASE = 'C2'
|
|
CALL CALCC2 ! Only liquid (metastable)
|
|
C ELSE
|
|
CC
|
|
C IF (RH < DRNH4HS4) THEN
|
|
C SCASE = 'C1'
|
|
C CALL CALCC1 ! NH4HSO4 ; case C1
|
|
CC
|
|
C ELSEIF (DRNH4HS4 <= RH) THEN
|
|
C SCASE = 'C2'
|
|
C CALL CALCC2 ! Only liquid ; case C2
|
|
CC
|
|
C ENDIF
|
|
C ENDIF
|
|
CALL CALCACT3F ! Checking for IONIC too high
|
|
CALL CALCNH3
|
|
ENDIF
|
|
C
|
|
C *** RETURN POINT
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE ISRP1F *****************************************
|
|
C
|
|
END
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ISRP1F
|
|
C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF
|
|
C AN AMMONIUM-SULFATE AEROSOL SYSTEM.
|
|
C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY
|
|
C THE AMBIENT RELATIVE HUMIDITY.
|
|
C
|
|
C ANISORROPIA ROUTINE. (slc.8.2011)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISRP1FA
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: WI(NCOMP), RHI, TEMPI
|
|
REAL*8 :: WP(NCOMP), MOLALP(NIONS)
|
|
REAL*8 :: DC, GAS(3), AERLIQ(NIONS+NGASAQ+2)
|
|
|
|
C W = WP
|
|
|
|
DC = W(3) - 2.001D0*W(2) ! For numerical stability
|
|
W(3) = W(3) + MAX(-DC, ZERO)
|
|
C
|
|
SCASE = 'A2'
|
|
CALL CALCA2 ! Only liquid (metastable)
|
|
|
|
C GAS(1) = GNH3 ! Gaseous aerosol species
|
|
C GAS(2) = GHNO3
|
|
C GAS(3) = GHCL
|
|
CC
|
|
C DO I=1,NIONS ! Liquid aerosol species
|
|
C AERLIQ(I) = MOLAL(I)
|
|
C ENDDO
|
|
C
|
|
C *** RETURN POINT
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE ISRP1F *****************************************
|
|
C
|
|
END
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ISRP2F
|
|
C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF
|
|
C AN AMMONIUM-SULFATE-NITRATE AEROSOL SYSTEM.
|
|
C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY
|
|
C THE AMBIENT RELATIVE HUMIDITY.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISRP2F (WI, RHI, TEMPI)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: WI(NCOMP), RHI, TEMPI
|
|
REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2)
|
|
C
|
|
C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK **************************
|
|
C
|
|
CALL INIT2 (WI, RHI, TEMPI)
|
|
!WRITE(*,*) 'ISRP2F, SULRAT: ',SULRAT
|
|
C
|
|
C *** CALCULATE SULFATE RATIO *******************************************
|
|
C
|
|
SULRAT = (W(3))/(W(2))
|
|
C
|
|
C *** FIND CALCULATION REGIME FROM (SULRAT,RH) **************************
|
|
C
|
|
C *** SULFATE POOR
|
|
C
|
|
IF (2.0 <= SULRAT) THEN
|
|
C
|
|
C IF(METSTBL == 1) THEN
|
|
!WRITE(*,*) 'ISRP2F, SCASE: ',SCASE
|
|
SCASE = 'D3'
|
|
CALL CALCD3 ! Only liquid (metastable)
|
|
C ENDIF
|
|
C
|
|
C *** SULFATE RICH (NO ACID)
|
|
C FOR SOLVING THIS CASE, NITRIC ACID IS ASSUMED A MINOR SPECIES,
|
|
C THAT DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM.
|
|
C SUBROUTINES CALCB? ARE CALLED, AND THEN THE NITRIC ACID IS DISSOLVED
|
|
C FROM THE HNO3(G) -> (H+) + (NO3-) EQUILIBRIUM.
|
|
C
|
|
ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN
|
|
C
|
|
C IF(METSTBL == 1) THEN
|
|
C WP = W
|
|
!WRITE(*,*) 'ISRP2F, SCASE: ',SCASE
|
|
SCASE = 'E4'
|
|
CALL CALCB4E ! Only liquid (metastable)
|
|
SCASE = 'E4'
|
|
C ENDIF
|
|
C
|
|
CALL CALCACT3F ! Checking for IONIC too high
|
|
CALL CALCNA ! HNO3(g) DISSOLUTION
|
|
C
|
|
C *** SULFATE RICH (FREE ACID)
|
|
C FOR SOLVING THIS CASE, NITRIC ACID IS ASSUMED A MINOR SPECIES,
|
|
C THAT DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM
|
|
C SUBROUTINE CALCC? IS CALLED, AND THEN THE NITRIC ACID IS DISSOLVED
|
|
C FROM THE HNO3(G) -> (H+) + (NO3-) EQUILIBRIUM.
|
|
C
|
|
ELSEIF (SULRAT < 1.0) THEN
|
|
C
|
|
C IF(METSTBL == 1) THEN
|
|
C WP = W
|
|
!WRITE(*,*) 'ISRP2F, SCASE: ',SCASE
|
|
SCASE = 'F2'
|
|
CALL CALCC2F ! Only liquid (metastable)
|
|
SCASE = 'F2'
|
|
C ENDIF
|
|
C
|
|
CALL CALCACT3F ! Checking for IONIC too high
|
|
CALL CALCNA ! HNO3(g) DISSOLUTION
|
|
ENDIF
|
|
C
|
|
C *** RETURN POINT
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE ISRP2F *****************************************
|
|
C
|
|
END
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ISRP3F
|
|
C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF
|
|
C AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE & SODIUM
|
|
C RATIOS AND BY THE AMBIENT RELATIVE HUMIDITY.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISRP3F (WI, RHI, TEMPI)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: WI(NCOMP), RHI, TEMPI
|
|
REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2)
|
|
C
|
|
C *** ADJUST FOR TOO LITTLE AMMONIUM AND CHLORIDE ***********************
|
|
C
|
|
! To have better conservation of mass, change to TINY
|
|
! (hotp 11/14/07)
|
|
!WI(3) = MAX (WI(3), 1.D-10) ! NH4+ : 1e-4 umoles/m3
|
|
!WI(5) = MAX (WI(5), 1.D-10) ! Cl- : 1e-4 umoles/m3
|
|
WI(3) = MAX (WI(3), TINY) ! NH4+ : 1e-4 umoles/m3
|
|
WI(5) = MAX (WI(5), TINY) ! Cl- : 1e-4 umoles/m3
|
|
C
|
|
C *** ADJUST FOR TOO LITTLE SODIUM, SULFATE AND NITRATE COMBINED ********
|
|
C
|
|
! To have better conservation of mass, change to TINY
|
|
! (hotp 11/14/07)
|
|
!IF (WI(1)+WI(2)+WI(4) .LE. 1d-10) THEN
|
|
! WI(1) = 1.D-10 ! Na+ : 1e-4 umoles/m3
|
|
! WI(2) = 1.D-10 ! SO4- : 1e-4 umoles/m3
|
|
!ENDIF
|
|
IF (WI(1)+WI(2)+WI(4) .LE. TINY) THEN
|
|
WI(1) = TINY ! Na+ : 1e-4 umoles/m3
|
|
WI(2) = TINY ! SO4- : 1e-4 umoles/m3
|
|
ENDIF
|
|
C
|
|
C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK **************************
|
|
C
|
|
CALL ISOINIT3 (WI, RHI, TEMPI)
|
|
C
|
|
C *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE *********
|
|
C
|
|
REST = 2.D0*W(2) + W(4) + W(5)
|
|
IF (W(1) > REST) THEN ! NA > 2*SO4+CL+NO3 ?
|
|
W(1) = (ONE-1D-6)*REST ! Adjust Na amount
|
|
CALL PUSHERR (0050, 'ISRP3F') ! Warning error: Na adjusted
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE SULFATE & SODIUM RATIOS *********************************
|
|
C
|
|
SULRAT = (W(1)+W(3))/W(2)
|
|
SODRAT = W(1)/W(2)
|
|
C
|
|
C *** FIND CALCULATION REGIME FROM (SULRAT,RH) **************************
|
|
|
|
C *** SULFATE POOR ; SODIUM POOR
|
|
C
|
|
IF (2.0 <= SULRAT .AND. SODRAT < 2.0) THEN
|
|
C
|
|
C IF(METSTBL == 1) THEN
|
|
!WRITE(*,*) 'Calling CALCG5, WI: ',WI
|
|
SCASE = 'G5'
|
|
CALL CALCG5 ! Only liquid (metastable)
|
|
C ENDIF
|
|
C
|
|
C *** SULFATE POOR ; SODIUM RICH
|
|
C
|
|
ELSE IF (SULRAT >= 2.0 .AND. SODRAT >= 2.0) THEN
|
|
C
|
|
C IF(METSTBL == 1) THEN
|
|
!WRITE(*,*) 'Calling CALCH6, WI: ',WI
|
|
SCASE = 'H6'
|
|
CALL CALCH6 ! Only liquid (metastable)
|
|
C ENDIF
|
|
C
|
|
C *** SULFATE RICH (NO ACID)
|
|
C
|
|
ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN
|
|
C
|
|
C IF(METSTBL == 1) THEN
|
|
!WRITE(*,*) 'Calling CALCI6, WI: ',WI
|
|
SCASE = 'I6'
|
|
CALL CALCI6 ! Only liquid (metastable)
|
|
C ENDIF
|
|
C
|
|
CALL CALCNHA ! MINOR SPECIES: HNO3, HCl
|
|
CALL CALCACT3F ! Checking for IONIC too high
|
|
CALL CALCNH3 ! NH3
|
|
C
|
|
C *** SULFATE RICH (FREE ACID)
|
|
C
|
|
ELSEIF (SULRAT < 1.0) THEN
|
|
C
|
|
C IF(METSTBL == 1) THEN
|
|
!WRITE(*,*) 'Calling CALCJ3, WI: ',WI
|
|
SCASE = 'J3'
|
|
CALL CALCJ3 ! Only liquid (metastable)
|
|
C ENDIF
|
|
C
|
|
CALL CALCNHA ! MINOR SPECIES: HNO3, HCl
|
|
CALL CALCACT3F ! Checking for IONIC too high
|
|
CALL CALCNH3 ! NH3
|
|
ENDIF
|
|
C
|
|
C *** RETURN POINT
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE ISRP3F *****************************************
|
|
C
|
|
END
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE II
|
|
C *** SUBROUTINE ISRP4F
|
|
C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF
|
|
C AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM-CALCIUM-POTASSIUM-MAGNESIUM
|
|
C AEROSOL SYSTEM.
|
|
C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE & SODIUM
|
|
C RATIOS AND BY THE AMBIENT RELATIVE HUMIDITY.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS AND ATHANASIOS NENES
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C SUBROUTINE ISRP4F (WI, RHI, TEMPI)
|
|
C INCLUDE 'isrpia_adj.inc'
|
|
C DIMENSION WI(NCOMP)
|
|
C REAL*8 :: NAFRI, NO3FRI
|
|
CC
|
|
CC *** ADJUST FOR TOO LITTLE AMMONIUM AND CHLORIDE ***********************
|
|
CC
|
|
CC WI(3) = MAX (WI(3), 1.D-10) ! NH4+ : 1e-4 umoles/m3
|
|
CC WI(5) = MAX (WI(5), 1.D-10) ! Cl- : 1e-4 umoles/m3
|
|
CC
|
|
CC *** ADJUST FOR TOO LITTLE SODIUM, SULFATE AND NITRATE COMBINED ********
|
|
CC
|
|
CC IF (WI(1)+WI(2)+WI(4) .LE. 1d-10) THEN
|
|
CC WI(1) = 1.D-10 ! Na+ : 1e-4 umoles/m3
|
|
CC WI(2) = 1.D-10 ! SO4- : 1e-4 umoles/m3
|
|
CC ENDIF
|
|
CC
|
|
CC *** INITIALIZE ALL VARIABLES IN COMMON BLOCK **************************
|
|
CC
|
|
C CALL INIT4 (WI, RHI, TEMPI)
|
|
CC
|
|
CC *** CHECK IF TOO MUCH SODIUM+CRUSTALS ; ADJUST AND ISSUE ERROR MESSAGE
|
|
CC
|
|
C REST = 2.D0*W(2) + W(4) + W(5)
|
|
CC
|
|
C IF (W(1)+W(6)+W(7)+W(8).GT.REST) THEN
|
|
CC
|
|
C CCASO4I = MIN (W(2),W(6))
|
|
C FRSO4I = MAX (W(2) - CCASO4I, ZERO)
|
|
C CAFRI = MAX (W(6) - CCASO4I, ZERO)
|
|
C CCANO32I = MIN (CAFRI, 0.5D0*W(4))
|
|
C CAFRI = MAX (CAFRI - CCANO32I, ZERO)
|
|
C NO3FRI = MAX (W(4) - 2.D0*CCANO32I, ZERO)
|
|
C CCACL2I = MIN (CAFRI, 0.5D0*W(5))
|
|
C CLFRI = MAX (W(5) - 2.D0*CCACL2I, ZERO)
|
|
C REST1 = 2.D0*FRSO4I + NO3FRI + CLFRI
|
|
CC
|
|
C CNA2SO4I = MIN (FRSO4I, 0.5D0*W(1))
|
|
C FRSO4I = MAX (FRSO4I - CNA2SO4I, ZERO)
|
|
C NAFRI = MAX (W(1) - 2.D0*CNA2SO4I, ZERO)
|
|
C CNACLI = MIN (NAFRI, CLFRI)
|
|
C NAFRI = MAX (NAFRI - CNACLI, ZERO)
|
|
C CLFRI = MAX (CLFRI - CNACLI, ZERO)
|
|
C CNANO3I = MIN (NAFRI, NO3FRI)
|
|
C NO3FR = MAX (NO3FRI - CNANO3I, ZERO)
|
|
C REST2 = 2.D0*FRSO4I + NO3FRI + CLFRI
|
|
CC
|
|
C CMGSO4I = MIN (FRSO4I, W(8))
|
|
C FRMGI = MAX (W(8) - CMGSO4I, ZERO)
|
|
C FRSO4I = MAX (FRSO4I - CMGSO4I, ZERO)
|
|
C CMGNO32I = MIN (FRMGI, 0.5D0*NO3FRI)
|
|
C FRMGI = MAX (FRMGI - CMGNO32I, ZERO)
|
|
C NO3FRI = MAX (NO3FRI - 2.D0*CMGNO32I, ZERO)
|
|
C CMGCL2I = MIN (FRMGI, 0.5D0*CLFRI)
|
|
C CLFRI = MAX (CLFRI - 2.D0*CMGCL2I, ZERO)
|
|
C REST3 = 2.D0*FRSO4I + NO3FRI + CLFRI
|
|
CC
|
|
C IF (W(6).GT.REST) THEN ! Ca > 2*SO4+CL+NO3 ?
|
|
C W(6) = (ONE-1D-6)*REST ! Adjust Ca amount
|
|
C W(1)= ZERO ! Adjust Na amount
|
|
C W(7)= ZERO ! Adjust K amount
|
|
C W(8)= ZERO ! Adjust Mg amount
|
|
C CALL PUSHERR (0051, 'ISRP4F') ! Warning error: Ca, Na, K, Mg in excess
|
|
CC
|
|
C ELSE IF (W(1).GT.REST1) THEN ! Na > 2*FRSO4+FRCL+FRNO3 ?
|
|
C W(1) = (ONE-1D-6)*REST1 ! Adjust Na amount
|
|
C W(7)= ZERO ! Adjust K amount
|
|
C W(8)= ZERO ! Adjust Mg amount
|
|
C CALL PUSHERR (0052, 'ISRP4F') ! Warning error: Na, K, Mg in excess
|
|
CC
|
|
C ELSE IF (W(8).GT.REST2) THEN ! Mg > 2*FRSO4+FRCL+FRNO3 ?
|
|
C W(8) = (ONE-1D-6)*REST2 ! Adjust Mg amount
|
|
C W(7)= ZERO ! Adjust K amount
|
|
C CALL PUSHERR (0053, 'ISRP4F') ! Warning error: K, Mg in excess
|
|
CC
|
|
C ELSE IF (W(7).GT.REST3) THEN ! K > 2*FRSO4+FRCL+FRNO3 ?
|
|
C W(7) = (ONE-1D-6)*REST3 ! Adjust K amount
|
|
C CALL PUSHERR (0054, 'ISRP4F') ! Warning error: K in excess
|
|
C ENDIF
|
|
C ENDIF
|
|
CC
|
|
CC *** CALCULATE RATIOS *************************************************
|
|
CC
|
|
C SO4RAT = (W(1)+W(3)+W(6)+W(7)+W(8))/W(2)
|
|
C CRNARAT = (W(1)+W(6)+W(7)+W(8))/W(2)
|
|
C CRRAT = (W(6)+W(7)+W(8))/W(2)
|
|
CC
|
|
CC *** FIND CALCULATION REGIME FROM (SO4RAT, CRNARAT, CRRAT, RRH) ********
|
|
CC
|
|
CC *** SULFATE POOR: Rso4>2; (DUST + SODIUM) POOR: R(Cr+Na)<2
|
|
CC
|
|
C IF (2.0.LE.SO4RAT .AND. CRNARAT.LT.2.0) THEN
|
|
CC
|
|
C IF(METSTBL.EQ.1) THEN
|
|
C SCASE = 'O7'
|
|
C CALL CALCO7 ! Only liquid (metastable)
|
|
C ELSE
|
|
CC
|
|
C IF (RH.LT.DRNH4NO3) THEN
|
|
C SCASE = 'O1'
|
|
C CALL CALCO1 ! CaSO4, NH4NO3, NH4CL, (NH4)2SO4, MGSO4, NA2SO4, K2SO4
|
|
CC
|
|
C ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNH4CL) THEN
|
|
C SCASE = 'O2'
|
|
C CALL CALCO2 ! CaSO4, NH4CL, (NH4)2SO4, MGSO4, NA2SO4, K2SO4
|
|
CC
|
|
C ELSEIF (DRNH4CL.LE.RH .AND. RH.LT.DRNH42S4) THEN
|
|
C SCASE = 'O3'
|
|
C CALL CALCO3 ! CaSO4, (NH4)2SO4, MGSO4, NA2SO4, K2SO4
|
|
CC
|
|
C ELSEIF (DRNH42S4.LE.RH .AND. RH.LT.DRMGSO4) THEN
|
|
C SCASE = 'O4'
|
|
C CALL CALCO4 ! CaSO4, MGSO4, NA2SO4, K2SO4
|
|
CC
|
|
C ELSEIF (DRMGSO4.LE.RH .AND. RH.LT.DRNA2SO4) THEN
|
|
C SCASE = 'O5'
|
|
C CALL CALCO5 ! CaSO4, NA2SO4, K2SO4
|
|
CC
|
|
C ELSEIF (DRNA2SO4.LE.RH .AND. RH.LT.DRK2SO4) THEN
|
|
C SCASE = 'O6'
|
|
C CALL CALCO6 ! CaSO4, K2SO4
|
|
CC
|
|
C ELSEIF (DRK2SO4.LE.RH) THEN
|
|
C SCASE = 'O7'
|
|
C CALL CALCO7 ! CaSO4
|
|
C ENDIF
|
|
C ENDIF
|
|
CC
|
|
CC *** SULFATE POOR: Rso4>2; (DUST + SODIUM) RICH: R(Cr+Na)>2; DUST POOR: Rcr<2.
|
|
CC
|
|
C ELSEIF (SO4RAT.GE.2.0 .AND. CRNARAT.GE.2.0) THEN
|
|
CC
|
|
C IF (CRRAT.LE.2.0) THEN
|
|
CC
|
|
C IF(METSTBL.EQ.1) THEN
|
|
C SCASE = 'M8'
|
|
C CALL CALCM8 ! Only liquid (metastable)
|
|
C ELSE
|
|
CC
|
|
C IF (RH.LT.DRNH4NO3) THEN
|
|
C SCASE = 'M1'
|
|
C CALL CALCM1 ! CaSO4, NH4NO3, NH4CL, MGSO4, NA2SO4, K2SO4, NACL, NANO3
|
|
CC
|
|
C ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNANO3) THEN
|
|
C SCASE = 'M2'
|
|
C CALL CALCM2 ! CaSO4, NH4CL, MGSO4, NA2SO4, K2SO4, NACL, NANO3
|
|
CC
|
|
C ELSEIF (DRNANO3.LE.RH .AND. RH.LT.DRNACL) THEN
|
|
C SCASE = 'M3'
|
|
C CALL CALCM3 ! CaSO4, NH4CL, MGSO4, NA2SO4, K2SO4, NACL
|
|
CC
|
|
C ELSEIF (DRNACL.LE.RH .AND. RH.LT.DRNH4Cl) THEN
|
|
C SCASE = 'M4'
|
|
C CALL CALCM4 ! CaSO4, NH4CL, MGSO4, NA2SO4, K2SO4
|
|
CC
|
|
C ELSEIF (DRNH4Cl.LE.RH .AND. RH.LT.DRMGSO4) THEN
|
|
C SCASE = 'M5'
|
|
C CALL CALCM5 ! CaSO4, MGSO4, NA2SO4, K2SO4
|
|
CC
|
|
C ELSEIF (DRMGSO4.LE.RH .AND. RH.LT.DRNA2SO4) THEN
|
|
C SCASE = 'M6'
|
|
C CALL CALCM6 ! CaSO4, NA2SO4, K2SO4
|
|
CC
|
|
C ELSEIF (DRNA2SO4.LE.RH .AND. RH.LT.DRK2SO4) THEN
|
|
C SCASE = 'M7'
|
|
C CALL CALCM7 ! CaSO4, K2SO4
|
|
CC
|
|
C ELSEIF (DRK2SO4.LE.RH) THEN
|
|
C SCASE = 'M8'
|
|
C CALL CALCM8 ! CaSO4
|
|
C ENDIF
|
|
C ENDIF
|
|
CC CALL CALCHCO3
|
|
CC
|
|
CC *** SULFATE POOR: Rso4>2; (DUST + SODIUM) RICH: R(Cr+Na)>2; DUST POOR: Rcr<2.
|
|
CC
|
|
C ELSEIF (CRRAT.GT.2.0) THEN
|
|
CC
|
|
C IF(METSTBL.EQ.1) THEN
|
|
C SCASE = 'P13'
|
|
C CALL CALCP13 ! Only liquid (metastable)
|
|
C ELSE
|
|
CC
|
|
C IF (RH.LT.DRCACL2) THEN
|
|
C SCASE = 'P1'
|
|
C CALL CALCP1 ! CaSO4, CA(NO3)2, CACL2, K2SO4, KNO3, KCL, MGSO4,
|
|
CC ! MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL
|
|
CC
|
|
C ELSEIF (DRCACL2.LE.RH .AND. RH.LT.DRMGCL2) THEN
|
|
C SCASE = 'P2'
|
|
C CALL CALCP2 ! CaSO4, CA(NO3)2, K2SO4, KNO3, KCL, MGSO4,
|
|
CC ! MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL
|
|
CC
|
|
C ELSEIF (DRMGCL2.LE.RH .AND. RH.LT.DRCANO32) THEN
|
|
C SCASE = 'P3'
|
|
C CALL CALCP3 ! CaSO4, CA(NO3)2, K2SO4, KNO3, KCL, MGSO4,
|
|
CC ! MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL
|
|
CC
|
|
C ELSEIF (DRCANO32.LE.RH .AND. RH.LT.DRMGNO32) THEN
|
|
C SCASE = 'P4'
|
|
C CALL CALCP4 ! CaSO4, K2SO4, KNO3, KCL, MGSO4,
|
|
CC ! MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL
|
|
CC
|
|
C ELSEIF (DRMGNO32.LE.RH .AND. RH.LT.DRNH4NO3) THEN
|
|
C SCASE = 'P5'
|
|
C CALL CALCP5 ! CaSO4, K2SO4, KNO3, KCL, MGSO4,
|
|
CC ! NANO3, NACL, NH4NO3, NH4CL
|
|
CC
|
|
C ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNANO3) THEN
|
|
C SCASE = 'P6'
|
|
C CALL CALCP6 ! CaSO4, K2SO4, KNO3, KCL, MGSO4, NANO3, NACL, NH4CL
|
|
CC
|
|
C ELSEIF (DRNANO3.LE.RH .AND. RH.LT.DRNACL) THEN
|
|
C SCASE = 'P7'
|
|
C CALL CALCP7 ! CaSO4, K2SO4, KNO3, KCL, MGSO4, NACL, NH4CL
|
|
CC
|
|
C ELSEIF (DRNACL.LE.RH .AND. RH.LT.DRNH4CL) THEN
|
|
C SCASE = 'P8'
|
|
C CALL CALCP8 ! CaSO4, K2SO4, KNO3, KCL, MGSO4, NH4CL
|
|
CC
|
|
C ELSEIF (DRNH4CL.LE.RH .AND. RH.LT.DRKCL) THEN
|
|
C SCASE = 'P9'
|
|
C CALL CALCP9 ! CaSO4, K2SO4, KNO3, KCL, MGSO4
|
|
CC
|
|
C ELSEIF (DRKCL.LE.RH .AND. RH.LT.DRMGSO4) THEN
|
|
C SCASE = 'P10'
|
|
C CALL CALCP10 ! CaSO4, K2SO4, KNO3, MGSO4
|
|
CC
|
|
C ELSEIF (DRMGSO4.LE.RH .AND. RH.LT.DRKNO3) THEN
|
|
C SCASE = 'P11'
|
|
C CALL CALCP11 ! CaSO4, K2SO4, KNO3
|
|
CC
|
|
C ELSEIF (DRKNO3.LE.RH .AND. RH.LT.DRK2SO4) THEN
|
|
C SCASE = 'P12'
|
|
C CALL CALCP12 ! CaSO4, K2SO4
|
|
CC
|
|
C ELSEIF (DRK2SO4.LE.RH) THEN
|
|
C SCASE = 'P13'
|
|
C CALL CALCP13 ! CaSO4
|
|
C ENDIF
|
|
C ENDIF
|
|
CC CALL CALCHCO3
|
|
C ENDIF
|
|
CC
|
|
CC *** SULFATE RICH (NO ACID): 1<Rso4<2;
|
|
CC
|
|
C ELSEIF (1.0.LE.SO4RAT .AND. SO4RAT.LT.2.0) THEN
|
|
CC
|
|
C IF(METSTBL.EQ.1) THEN
|
|
C SCASE = 'L9'
|
|
C CALL CALCL9 ! Only liquid (metastable)
|
|
C ELSE
|
|
CC
|
|
C IF (RH.LT.DRNH4HS4) THEN
|
|
C SCASE = 'L1'
|
|
C CALL CALCL1 ! CASO4,K2SO4,MGSO4,KHSO4,NA2SO4,(NH4)2SO4,NAHSO4,NH4HSO4,LC
|
|
CC
|
|
C ELSEIF (DRNH4HS4.LE.RH .AND. RH.LT.DRNAHSO4) THEN
|
|
C SCASE = 'L2'
|
|
C CALL CALCL2 ! CASO4,K2SO4,MGSO4,KHSO4,NA2SO4,(NH4)2SO4,NAHSO4,LC
|
|
CC
|
|
C ELSEIF (DRNAHSO4.LE.RH .AND. RH.LT.DRLC) THEN
|
|
C SCASE = 'L3'
|
|
C CALL CALCL3 ! CASO4,K2SO4,MGSO4,KHSO4,NA2SO4,(NH4)2SO4,LC
|
|
CC
|
|
C ELSEIF (DRLC.LE.RH .AND. RH.LT.DRNH42S4) THEN
|
|
C SCASE = 'L4'
|
|
C CALL CALCL4 ! CASO4,K2SO4,MGSO4,KHSO4,NA2SO4,(NH4)2SO4
|
|
CC
|
|
C ELSEIF (DRNH42S4.LE.RH .AND. RH.LT.DRKHSO4) THEN
|
|
C SCASE = 'L5'
|
|
C CALL CALCL5 ! CASO4,K2SO4,MGSO4,KHSO4,NA2SO4
|
|
CC
|
|
C ELSEIF (DRKHSO4.LE.RH .AND. RH.LT.DRMGSO4) THEN
|
|
C SCASE = 'L6'
|
|
C CALL CALCL6 ! CASO4,K2SO4,MGSO4,NA2SO4
|
|
CC
|
|
C ELSEIF (DRMGSO4.LE.RH .AND. RH.LT.DRNA2SO4) THEN
|
|
C SCASE = 'L7'
|
|
C CALL CALCL7 ! CASO4,K2SO4,NA2SO4
|
|
CC
|
|
C ELSEIF (DRNA2SO4.LE.RH .AND. RH.LT.DRK2SO4) THEN
|
|
C SCASE = 'L8'
|
|
C CALL CALCL8 ! CASO4,K2SO4
|
|
CC
|
|
C ELSEIF (DRK2SO4.LE.RH) THEN
|
|
C SCASE = 'L9'
|
|
C CALL CALCL9 ! CaSO4
|
|
C ENDIF
|
|
C ENDIF
|
|
CC
|
|
C CALL CALCNHA ! MINOR SPECIES: HNO3, HCl
|
|
C CALL CALCNH3 ! NH3
|
|
CC
|
|
CC *** SULFATE SUPER RICH (FREE ACID): Rso4<1;
|
|
CC
|
|
C ELSEIF (SO4RAT.LT.1.0) THEN
|
|
CC
|
|
C IF(METSTBL.EQ.1) THEN
|
|
C SCASE = 'K4'
|
|
C CALL CALCK4 ! Only liquid (metastable)
|
|
C ELSE
|
|
CC
|
|
C IF (RH.LT.DRNH4HS4) THEN ! RH < 0.4
|
|
C SCASE = 'K1'
|
|
C CALL CALCK1 ! NH4HSO4,NAHSO4,KHSO4,CASO4
|
|
CC
|
|
C ELSEIF (DRNH4HS4.LE.RH .AND. RH.LT.DRNAHSO4) THEN
|
|
C SCASE = 'K2'
|
|
C CALL CALCK2 ! NAHSO4,KHSO4,CASO4
|
|
CC
|
|
C ELSEIF (DRNAHSO4.LE.RH .AND. RH.LT.DRKHSO4) THEN
|
|
C SCASE = 'K3'
|
|
C CALL CALCK3 ! KHSO4,CASO4 0.52 < RH < 0.86
|
|
CC
|
|
C ELSEIF (DRKHSO4.LE.RH) THEN
|
|
C SCASE = 'K4'
|
|
C CALL CALCK4 ! CASO4
|
|
C ENDIF
|
|
C ENDIF
|
|
CC
|
|
C CALL CALCNHA ! MINOR SPECIES: HNO3, HCl
|
|
C CALL CALCNH3 ! NH3
|
|
CC
|
|
C ENDIF
|
|
CC
|
|
C RETURN
|
|
C END
|
|
CC
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCA2
|
|
C *** CASE A2
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0)
|
|
C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE
|
|
C
|
|
C FOR CALCULATIONS, AN ITERATIVE ALGORITHM REDUCES X TO THE ROOT,
|
|
C THE AMOUNT OF HYDROGEN IONS (H+) FOUND IN THE LIQUID PHASE.
|
|
C FOR EACH ESTIMATION OF H+, FUNCTION FUNCB2A CALCULATES THE
|
|
C CONCENTRATION OF IONS FROM THE NH3(GAS) - NH4+(LIQ) EQUILIBRIUM.
|
|
C ELECTRONEUTRALITY IS USED AS THE OBJECTIVE FUNCTION.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCA2
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: DELTA
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
CALAOU =.TRUE. ! Outer loop activity calculation flag
|
|
C UCONLO = TINY ! Low limit: No excess NH3 dissolves
|
|
C UCONHI = W(3) - 2.0D0*W(2) ! High limit: All NH3 remaining in gas dissolves
|
|
C
|
|
C *** CALCULATE WATER CONTENT *****************************************
|
|
C
|
|
MOLAL(5) = W(2)
|
|
MOLAL(6) = ZERO
|
|
C
|
|
C CALL CALCMR
|
|
C
|
|
MOLALR(4) = MOLAL(5)+MOLAL(6) ! (NH4)2SO4 - CORRECT FOR SO4 TO HSO4
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
WATER = ZERO
|
|
DO I=1,NPAIR
|
|
WATER = WATER + MOLALR(I)/M0(I)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C
|
|
C *** CREATE ITERATION FOR ACTIVITY COEFFICIENTS
|
|
C
|
|
CALL FUNCA2P
|
|
C
|
|
IF ((MOLAL(1)) > TINY) THEN
|
|
CALL CALCHS4 (MOLAL(1), MOLAL(5), ZERO, DELTA)
|
|
MOLAL(1) = MOLAL(1) - DELTA ! H+ EFFECT
|
|
MOLAL(5) = MOLAL(5) - DELTA ! SO4 EFFECT
|
|
MOLAL(6) = DELTA ! HSO4 EFFECT
|
|
ENDIF
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCA2H ****************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** FUNCTION FUNCA2P
|
|
C *** CASE A2
|
|
C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE A2 ;
|
|
C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCA2P.
|
|
C
|
|
C CREATED FOR ANISORROPIA. (slc.5.2010)
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCA2P
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: LAMDA, DISC, SQDR, THRSHHI, THRSHLO
|
|
REAL*8 :: NCON, QCON, UCON, UCONOLD
|
|
REAL*8 :: W2, W3
|
|
LOGICAL TST, TST2
|
|
INTEGER I
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
TST = .TRUE.
|
|
TST2 = .TRUE.
|
|
FRST = .TRUE.
|
|
CALAIN = .TRUE.
|
|
W2 = W(2) ! INITIAL AMOUNT OF (NH4)2SO4 IN SOLUTION
|
|
W3 = W(3)
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
I=1
|
|
UCON = 0.D0
|
|
DO WHILE ((I <= 14).AND. TST .AND. TST2)
|
|
UCONOLD = UCON
|
|
A2 = XK2*R*TEMP/XKW*(GAMA(8)/GAMA(9))**2.
|
|
C
|
|
AA = -A2
|
|
BB = A2*W3 - 2.D0*A2*W2 + 1.d0
|
|
CC = 2.d0*W2
|
|
DISC = BB*BB - 4.D0*AA*CC
|
|
SQDR = SQRT(DISC)
|
|
C
|
|
RT1 = (-BB + SQDR)/2.D0/AA
|
|
RT2 = (-BB - SQDR)/2.D0/AA
|
|
C
|
|
IF ((RT1) < ZERO .AND. (RT2) >= ZERO) THEN
|
|
UCON = RT1
|
|
ELSEIF ((RT2) < ZERO .AND. (RT1) >= ZERO) THEN
|
|
UCON = RT2
|
|
ELSE
|
|
TST2 = .FALSE.
|
|
ENDIF
|
|
C
|
|
QCON = -UCON
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
MOLAL (1) = QCON ! HI
|
|
C MOLAL (3) = MAX(W(3)/(ONE/A2/OMEGI + ONE), 2.*MOLAL(5)) ! NH4I
|
|
C MOLAL (3) = MAX(2.D0*W2 + UCON, TINY) ! NH4I
|
|
IF (TINY > (2.D0*W2 + UCON)) THEN
|
|
MOLAL(3) = TINY
|
|
ELSE
|
|
MOLAL(3) = 2.D0*W2 + UCON
|
|
ENDIF
|
|
MOLAL (5) = W2 ! SO4I
|
|
MOLAL (6) = ZERO ! HSO4I
|
|
C GNH3 = MAX(W(3)-MOLAL(3), TINY) ! NH3GI
|
|
IF (TINY > (W(3)-MOLAL(3))) THEN
|
|
GNH3 = TINY
|
|
ELSE
|
|
GNH3 = W(3)-MOLAL(3)
|
|
ENDIF
|
|
COH = XKW/QCON ! OHI
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
THRSHLO = UCONOLD - UCONOLD*1.0D-15
|
|
THRSHHI = UCONOLD + UCONOLD*1.0D-15
|
|
IF (((UCON).LE.(THRSHLO)).AND.
|
|
& ((UCON).GE.(THRSHHI))) THEN
|
|
TST = .FALSE.
|
|
CALL CALCACT3F
|
|
ELSE
|
|
TST = .TRUE.
|
|
CALL CALCACT3P
|
|
ENDIF
|
|
I = I + 1
|
|
|
|
ENDDO ! Iterative solution to the A2 system
|
|
C
|
|
C *** END OF FUNCTION FUNCA2 ********************************************
|
|
C
|
|
END SUBROUTINE FUNCA2P
|
|
C
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCB4
|
|
C *** CASE B4
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0)
|
|
C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE
|
|
C
|
|
C FOR CALCULATIONS, A BISECTION IS PERFORMED WITH RESPECT TO H+.
|
|
C THE OBJECTIVE FUNCTION IS THE DIFFERENCE BETWEEN THE ESTIMATED H+
|
|
C AND THAT CALCULATED FROM ELECTRONEUTRALITY.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCB4
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: X,Y, SO4I, HSO4I, BB, CC, DD
|
|
REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2)
|
|
INTEGER :: I
|
|
C
|
|
C *** SOLVE EQUATIONS **************************************************
|
|
C
|
|
FRST = .TRUE.
|
|
CALAIN = .TRUE.
|
|
CALAOU = .TRUE.
|
|
C
|
|
C *** CALCULATE WATER CONTENT ******************************************
|
|
C
|
|
C CALL CALCB1A ! GET DRY SALT CONTENT, AND USE FOR WATER.
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
X = 2.d0*W(2)-W(3) ! Equivalent NH4HSO4
|
|
Y = W(3)-W(2) ! Equivalent (NH4)2SO4
|
|
C
|
|
C *** CALCULATE COMPOSITION *******************************************
|
|
C
|
|
IF ((X) <= (Y)) THEN ! LC is the MIN(x,y)
|
|
CLC = 2.D0*W(2)-W(3) !X ! NH4HSO4 >= (NH4)2S04
|
|
CNH4HS4 = ZERO
|
|
CNH42S4 = 2.D0*W(3) - 3.D0*W(2) !Y-X
|
|
ELSE
|
|
CLC = W(3)-W(2) !Y ! NH4HSO4 < (NH4)2S04
|
|
CNH4HS4 = 3.D0*W(2) - 2.D0*W(3) !X-Y
|
|
CNH42S4 = ZERO
|
|
ENDIF
|
|
C
|
|
MOLALR(13) = CLC
|
|
MOLALR(9) = CNH4HS4
|
|
MOLALR(4) = CNH42S4
|
|
CLC = ZERO
|
|
CNH4HS4 = ZERO
|
|
CNH42S4 = ZERO
|
|
WATER = MOLALR(13)/M0(13)+MOLALR(9)/M0(9)+MOLALR(4)/M0(4)
|
|
C
|
|
MOLAL(3) = W(3) ! NH4I
|
|
C
|
|
I = 1
|
|
DO WHILE ((I <= NSWEEP).AND.(CALAIN))
|
|
|
|
AK1 = XK1*((GAMA(8)/GAMA(7))**2.)*(WATER/GAMA(7))
|
|
BET = W(2)
|
|
GAM = MOLAL(3)
|
|
C
|
|
BB = BET + AK1 - GAM
|
|
CC =-AK1*BET
|
|
DD = BB*BB - 4.D0*CC
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
MOLAL (5) = MAX(MIN(0.5d0*(-BB + SQRT(DD)), W(2)),TINY) ! SO4I
|
|
MOLAL (6) = MAX(MIN(W(2)-MOLAL(5), W(2)), TINY) ! HSO4I
|
|
MOLAL (1) = MAX(MIN(AK1*MOLAL(6)/MOLAL(5), W(2)), TINY) ! HI
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
SO4I = MOLAL(5)-MOLAL(1) ! CORRECT FOR HSO4 DISSOCIATION
|
|
HSO4I = MOLAL(6)+MOLAL(1)
|
|
IF ((SO4I) < (HSO4I)) THEN
|
|
MOLALR(13) = SO4I ! [LC] = [SO4]
|
|
MOLALR(9) = MAX(HSO4I-SO4I, ZERO) ! NH4HSO4
|
|
ELSE
|
|
MOLALR(13) = HSO4I ! [LC] = [HSO4]
|
|
MOLALR(4) = MAX(SO4I-HSO4I, ZERO) ! (NH4)2SO4
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
WATER = ZERO
|
|
DO J=1,NPAIR
|
|
WATER = WATER + MOLALR(J)/M0(J)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
I = I + 1
|
|
CALL CALCACT3
|
|
|
|
ENDDO ! Iterative loop for convergence of B4 aerosol system
|
|
|
|
IF (CALAIN .AND. (I > (NSWEEP+1))) THEN
|
|
CALL PUSHERR (0001, 'CALCB4') ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
C
|
|
C *** END OF SUBROUTINE CALCB4 ******************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCB4E
|
|
C *** CASE E4
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0)
|
|
C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE
|
|
C
|
|
C FOR CALCULATIONS, A BISECTION IS PERFORMED WITH RESPECT TO H+.
|
|
C THE OBJECTIVE FUNCTION IS THE DIFFERENCE BETWEEN THE ESTIMATED H+
|
|
C AND THAT CALCULATED FROM ELECTRONEUTRALITY.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCB4E
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: X,Y, SO4I, HSO4I, BB, CC, DD
|
|
REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2)
|
|
INTEGER :: I
|
|
C
|
|
C *** SOLVE EQUATIONS **************************************************
|
|
C
|
|
FRST = .TRUE.
|
|
CALAIN = .TRUE.
|
|
CALAOU = .TRUE.
|
|
C
|
|
C *** CALCULATE WATER CONTENT ******************************************
|
|
C
|
|
C CALL CALCB1A ! GET DRY SALT CONTENT, AND USE FOR WATER.
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
X = 2.d0*W(2)-W(3) ! Equivalent NH4HSO4
|
|
Y = W(3)-W(2) ! Equivalent (NH4)2SO4
|
|
C
|
|
C *** CALCULATE COMPOSITION *******************************************
|
|
C
|
|
IF ((X) <= (Y)) THEN ! LC is the MIN(x,y)
|
|
CLC = 2.d0*W(2)-W(3) !X ! NH4HSO4 >= (NH4)2S04
|
|
CNH4HS4 = ZERO
|
|
CNH42S4 = 2.d0*W(3)-3.d0*W(2) !Y-X
|
|
ELSE
|
|
CLC = W(3)-W(2) !Y ! NH4HSO4 < (NH4)2S04
|
|
CNH4HS4 = 3.d0*W(2)-2.d0*W(3) !X-Y
|
|
CNH42S4 = ZERO
|
|
ENDIF
|
|
C
|
|
MOLALR(13) = CLC
|
|
MOLALR(9) = CNH4HS4
|
|
MOLALR(4) = CNH42S4
|
|
CLC = ZERO
|
|
CNH4HS4 = ZERO
|
|
CNH42S4 = ZERO
|
|
WATER = MOLALR(13)/M0(13)+MOLALR(9)/M0(9)+MOLALR(4)/M0(4)
|
|
C
|
|
MOLAL(3) = W(3) ! NH4I
|
|
C
|
|
I = 1
|
|
|
|
DO WHILE ((I <= NSWEEP).AND.(CALAIN))
|
|
AK1 = XK1*((GAMA(8)/GAMA(7))**2.d0)*(WATER/GAMA(7))
|
|
BET = W(2)
|
|
GAM = MOLAL(3)
|
|
C
|
|
BB = BET + AK1 - GAM
|
|
CC =-AK1*BET
|
|
DD = BB*BB - 4.D0*CC
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
MOLAL (5) = MAX(MIN(0.5d0*(-BB + SQRT(DD)), W(2)),TINY) ! SO4I
|
|
MOLAL (6) = MAX(MIN(W(2)-MOLAL(5), W(2)), TINY) ! HSO4I
|
|
MOLAL (1) = MAX(MIN(AK1*MOLAL(6)/MOLAL(5), W(2)), TINY) ! HI
|
|
C
|
|
SO4I = MOLAL(5)-MOLAL(1) ! CORRECT FOR HSO4 DISSOCIATION as from B4
|
|
C SO4I = MAX(MOLAL(5)-MOLAL(1),ZERO) ! FROM HSO4 DISSOCIATION
|
|
HSO4I = MOLAL(6)+MOLAL(1)
|
|
IF ((SO4I) < (HSO4I)) THEN
|
|
MOLALR(13) = SO4I ! [LC] = [SO4]
|
|
MOLALR(9) = MAX(HSO4I-SO4I, ZERO) ! NH4HSO4
|
|
ELSE
|
|
MOLALR(13) = HSO4I ! [LC] = [HSO4]
|
|
MOLALR(4) = MAX(SO4I-HSO4I, ZERO) ! (NH4)2SO4
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
WATER = ZERO
|
|
DO J=1,NPAIR
|
|
WATER = WATER + MOLALR(J)/M0(J)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
I = I + 1
|
|
CALL CALCACT3
|
|
|
|
ENDDO ! Iterative loop for E4 aerosol system solution
|
|
|
|
IF (CALAIN .AND. (I > (NSWEEP+1))) THEN
|
|
CALL PUSHERR (0001, 'CALCB4E') ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
C
|
|
C *** END OF SUBROUTINE CALCB4E *****************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCC2
|
|
C *** CASE C2
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0)
|
|
C 2. THERE IS ONLY A LIQUID PHASE
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCC2
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: LAMDA, KAPA, PSI, PARM
|
|
REAL*8 :: BB, CC
|
|
REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2)
|
|
INTEGER :: I
|
|
C
|
|
CALAOU =.TRUE. ! Outer loop activity calculation flag
|
|
FRST =.TRUE.
|
|
CALAIN =.TRUE.
|
|
C
|
|
C *** SOLVE EQUATIONS **************************************************
|
|
C
|
|
LAMDA = W(3) ! NH4HSO4 INITIALLY IN SOLUTION
|
|
PSI = W(2)-W(3) ! H2SO4 IN SOLUTION
|
|
I = 1
|
|
|
|
DO WHILE ((I <= NSWEEP).AND.(CALAIN))
|
|
|
|
PARM = WATER*XK1/GAMA(7)*(GAMA(8)/GAMA(7))**2.
|
|
BB = PSI+PARM
|
|
CC =-PARM*(LAMDA+PSI)
|
|
KAPA = 0.5d0*(-BB+SQRT(BB*BB-4.0*CC))
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
MOLAL(1) = PSI+KAPA ! HI
|
|
MOLAL(3) = LAMDA ! NH4I
|
|
MOLAL(5) = KAPA ! SO4I
|
|
MOLAL(6) = MAX(LAMDA+PSI-KAPA, TINY) ! HSO4I
|
|
CH2SO4 = MAX(MOLAL(5)+MOLAL(6)-MOLAL(3), ZERO) ! Free H2SO4
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
MOLALR(9) = MOLAL(3) ! NH4HSO4 *** As in ISORROPIA 1.7
|
|
MOLALR(7) = MAX(W(2)-W(3), ZERO) ! H2SO4
|
|
WATER = ZERO
|
|
DO J=1,NPAIR
|
|
WATER = WATER + MOLALR(J)/M0(J)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
I = I + 1
|
|
CALL CALCACT3
|
|
|
|
ENDDO ! Iterative loop for C2 aerosol system
|
|
|
|
IF (CALAIN .AND. (I > (NSWEEP+1))) THEN
|
|
CALL PUSHERR (0001, 'CALCC2') ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
C
|
|
C *** END OF SUBROUTINE CALCC2 *****************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCC2F
|
|
C *** CASE F2
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0)
|
|
C 2. THERE IS ONLY A LIQUID PHASE
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCC2F
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: LAMDA, KAPA, PSI, PARM
|
|
REAL*8 :: BB, CC
|
|
REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2)
|
|
INTEGER :: I
|
|
C
|
|
CALAOU =.TRUE. ! Outer loop activity calculation flag
|
|
FRST =.TRUE.
|
|
CALAIN =.TRUE.
|
|
C
|
|
C *** SOLVE EQUATIONS **************************************************
|
|
C
|
|
LAMDA = W(3) ! NH4HSO4 INITIALLY IN SOLUTION
|
|
PSI = W(2)-W(3) ! H2SO4 IN SOLUTION
|
|
I = 1
|
|
DO WHILE ((I <= NSWEEP).AND.(CALAIN))
|
|
|
|
PARM = WATER*XK1/GAMA(7)*(GAMA(8)/GAMA(7))**2.d0
|
|
BB = PSI+PARM
|
|
CC =-PARM*(LAMDA+PSI)
|
|
KAPA = 0.5d0*(-BB+SQRT(BB*BB-4.d0*CC))
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
MOLAL(1) = PSI+KAPA ! HI
|
|
MOLAL(3) = LAMDA ! NH4I
|
|
MOLAL(5) = KAPA ! SO4I
|
|
MOLAL(6) = MAX(LAMDA+PSI-KAPA, TINY) ! HSO4I
|
|
CH2SO4 = MAX(MOLAL(5)+MOLAL(6)-MOLAL(3), ZERO) ! Free H2SO4
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C slc.1.2011 - calling CALCMR for case F rather than C
|
|
C
|
|
MOLALR(9) = MOLAL(3) ! NH4HSO4 - slc.1.2011 - from ISORROPIA 1.7
|
|
MOLALR(7) = MAX(MOLAL(5)+MOLAL(6)-MOLAL(3),ZERO) ! H2SO4
|
|
WATER = ZERO
|
|
DO J=1,NPAIR
|
|
WATER = WATER + MOLALR(J)/M0(J)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
I = I + 1
|
|
CALL CALCACT3
|
|
|
|
ENDDO ! Iterative loop for F2 aerosol system
|
|
|
|
IF (CALAIN .AND. (I > (NSWEEP+1))) THEN
|
|
CALL PUSHERR (0001, 'CALCC2F') ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
C
|
|
C *** END OF SUBROUTINE CALCC2F ****************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCD3
|
|
C *** CASE D3
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0)
|
|
C 2. THERE IS OLNY A LIQUID PHASE
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCD3
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
INTEGER :: NDIVOLD
|
|
LOGICAL :: CHNDIVF, BISECT, EARLY, REX, LDIFFX
|
|
REAL*8 :: X1, X2, Y1, Y2, X3, Y3, YF, YLO
|
|
REAL*8 :: THRSH, DIFF, TSTSIGN, PSI4LO, PSI4HI, P4
|
|
REAL*8 :: DIFFX, DIFFXQ
|
|
REAL*8 :: FEPS
|
|
LOGICAL :: TST1, TST2, TST
|
|
CHARACTER(LEN=40) :: ERRINF
|
|
INTEGER :: ERRSTKI(25), J, CHECKIT
|
|
LOGICAL :: DEXS, IEXS, EOF
|
|
CHARACTER(LEN=40) :: ERRMSGI(25)
|
|
REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2)
|
|
C
|
|
C *** FIND DRY COMPOSITION **********************************************
|
|
C
|
|
FEPS = 1.d-5
|
|
REX = .FALSE.
|
|
CALL CALCD1AL
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
CHI1 = CNH4NO3 ! Save from CALCD1 run
|
|
CHI2 = CNH42S4
|
|
CHI3 = GHNO3
|
|
CHI4 = GNH3
|
|
C
|
|
PSI1 = CNH4NO3 ! ASSIGN INITIAL PSI's
|
|
PSI2 = CHI2
|
|
PSI3 = ZERO
|
|
PSI4 = ZERO
|
|
C
|
|
MOLAL(5) = PSI2 ! slc.7.2010 - include dissolved sulfate in initial water calc
|
|
MOLAL(6) = ZERO
|
|
MOLAL(3) = PSI1
|
|
MOLAL(7) = PSI1
|
|
CALL CALCMR ! Initial water
|
|
C
|
|
CALAOU = .TRUE. ! Outer loop activity calculation flag
|
|
TST1 = .TRUE.
|
|
TST2 = .TRUE.
|
|
CHECKIT = 1
|
|
PSI4LO = TINY ! Low limit
|
|
PSI4HI = CHI4 ! High limit
|
|
C
|
|
C *** INITIAL VALUES FOR BISECTION ************************************
|
|
C
|
|
60 X1 = PSI4LO
|
|
CALL RSTGAMP
|
|
CALL FUNCD3 (X1, Y1)
|
|
IF (ABS(Y1) <= (EPS)) THEN
|
|
X3 = X1
|
|
GOTO 50
|
|
ENDIF
|
|
YLO = Y1 ! Save Y-value at HI position
|
|
C
|
|
C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO **********************
|
|
C
|
|
DX = (PSI4HI-PSI4LO)/FLOAT(NDIV)
|
|
X2 = X1
|
|
Y2 = Y1
|
|
I = 1
|
|
DO WHILE ((I <= NDIV) .AND. TST1)
|
|
X1 = X2
|
|
Y1 = Y2
|
|
X2 = X1+DX
|
|
CALL FUNCD3 (X2, Y2)
|
|
C IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2) < ZERO) THEN
|
|
IF (((Y1) < ZERO) .AND. ((Y2) > ZERO)) THEN
|
|
TST1 = .FALSE.! (Y1*Y2 < ZERO)
|
|
ENDIF
|
|
I = I + 1
|
|
ENDDO
|
|
IF (.NOT.TST1) GOTO 20
|
|
C
|
|
C *** NO SUBDIVISION WITH SOLUTION FOUND
|
|
C
|
|
YHI= Y1 ! Save Y-value at Hi position
|
|
IF (ABS(Y2) < EPS) THEN ! X2 IS A SOLUTION
|
|
X3 = X2
|
|
Y3 = Y2
|
|
GOTO 50
|
|
C
|
|
C *** { YLO, YHI } < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NH3
|
|
C Physically I dont know when this might happen, but I have put this
|
|
C branch in for completeness. I assume there is no solution; all NO3 goes to the
|
|
C gas phase.
|
|
C
|
|
ELSE IF ((YLO) < ZERO .AND. (YHI) < ZERO) THEN
|
|
P4 = TINY ! PSI4LO ! CHI4
|
|
CALL RSTGAMP
|
|
CALL FUNCD3(P4, Y3)
|
|
X3 = P4
|
|
GOTO 50
|
|
C
|
|
C *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NH3
|
|
C This happens when Sul.Rat. = 2.0, so some NH4+ from sulfate evaporates
|
|
C and goes to the gas phase ; so I redefine the LO and HI limits of PSI4
|
|
C and proceed again with root tracking.
|
|
C
|
|
ELSE IF ((YLO) > ZERO .AND. (YHI) > ZERO) THEN
|
|
PSI4HI = PSI4LO
|
|
PSI4LO = PSI4LO - 0.1*(PSI1+PSI2) ! No solution; some NH3 evaporates
|
|
IF ((PSI4LO) < (-1.D0*(PSI1+PSI2))) THEN
|
|
C WRITE(*,*) 'Error'
|
|
CALL PUSHERR (0001, 'CALCD3') ! WARNING ERROR: NO SOLUTION
|
|
RETURN
|
|
ELSE
|
|
MOLAL(5) = PSI2 ! so4 included in water calc
|
|
MOLAL(6) = ZERO
|
|
MOLAL(3) = PSI1
|
|
MOLAL(7) = PSI1
|
|
CALL CALCMR ! Initial water
|
|
C WRITE(*,*) 'Re-executing'
|
|
IF ( CHECKIT .LT. 15 ) THEN
|
|
REX = .TRUE.
|
|
CHECKIT = CHECKIT + 1
|
|
GOTO 60 ! Redo root tracking
|
|
ELSE
|
|
CALL PUSHERR (0002, 'CALCD3') ! WARNING ERROR: NO CONVERGENCE
|
|
GOTO 50
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
C
|
|
C *** PERFORM BISECTION ***********************************************
|
|
C
|
|
20 I = 1
|
|
TST2 = .TRUE.
|
|
Y3 = Y2
|
|
DO WHILE ((I <= MAXIT) .AND. TST2)
|
|
X3 = 0.5*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCD3 (X3,Y3)
|
|
IF (SIGN(1.d0,(Y1))*SIGN(1.d0,(Y3)) <= ZERO) THEN ! (Y1*Y3 <= ZERO)
|
|
Y2 = Y3
|
|
X2 = X3
|
|
ELSE
|
|
Y1 = Y3
|
|
X1 = X3
|
|
ENDIF
|
|
IF ((ABS(X2-X1) <= EPS*ABS(X1)) .AND.
|
|
& (ABS(Y3) < FEPS)) THEN
|
|
TST2 = .FALSE.
|
|
ENDIF
|
|
C WRITE(*, '(A,E12.5,A,E12.5)') 'In loop: X3',(X3),'Y3',(Y3)
|
|
I = I + 1
|
|
ENDDO
|
|
|
|
IF ((I > MAXIT+1) .AND. TST2) THEN
|
|
CALL PUSHERR (0002, 'CALCD3') ! WARNING ERROR: NO CONVERGENCE
|
|
ENDIF
|
|
C
|
|
C *** CONVERGED ; RETURN **********************************************
|
|
C
|
|
X3 = 0.5*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCD3 (X3, Y3)
|
|
C
|
|
50 CONTINUE
|
|
C IF (ABS(Y3) > FEPS) THEN
|
|
C WRITE(ERRINF, '(A,E12.5,A)') 'CALCD3 (',(Y3),')'
|
|
C CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE
|
|
C RETURN
|
|
C ENDIF
|
|
C
|
|
CALL FUNCD3P(X3,YF) ! Execute Newton-Raphson for adjoint
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCD3 ******************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCD3
|
|
C *** CASE D3
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0)
|
|
C 2. THERE IS OLNY A LIQUID PHASE
|
|
C
|
|
C CREATED FOR ANISORROPIA. (slc.8.2010)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCD3_B(wpb, gasb, aerliqb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
INTEGER :: NDIVOLD
|
|
LOGICAL :: CHNDIVF, BISECT, EARLY, REX, LDIFFX
|
|
REAL*8 :: X1, X2, Y1, Y2, X3, Y3, YF, YLO
|
|
REAL*8 :: THRSH, DIFF, TSTSIGN, PSI4LO, PSI4HI, P4
|
|
REAL*8 :: DIFFX, DIFFXQ
|
|
REAL*8 :: FEPS
|
|
LOGICAL :: TST1, TST2, TST
|
|
CHARACTER(LEN=40) :: ERRINF
|
|
INTEGER :: ERRSTKI(25), J, CHECKIT
|
|
LOGICAL :: DEXS, IEXS, EOF
|
|
CHARACTER(LEN=40) :: ERRMSGI(25)
|
|
REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2)
|
|
REAL*8 :: WPB(NCOMP), GASB(3), AERLIQB(NIONS+NGASAQ+2)
|
|
REAL*8 :: WPDB(NCOMP), GASDB(3), AERLIQDB(NIONS+NGASAQ+2)
|
|
C
|
|
C *** FIND DRY COMPOSITION **********************************************
|
|
C
|
|
!WRITE(*,*) 'CALCD3, NDIV: ',NDIV
|
|
FEPS = 1d-5
|
|
REX = .FALSE.
|
|
CALL CALCD1AL
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
CHI1 = CNH4NO3 ! Save from CALCD1 run
|
|
CHI2 = CNH42S4
|
|
CHI3 = GHNO3
|
|
CHI4 = GNH3
|
|
C
|
|
PSI1 = CNH4NO3 ! ASSIGN INITIAL PSI's
|
|
PSI2 = CHI2
|
|
PSI3 = ZERO
|
|
PSI4 = ZERO
|
|
C
|
|
MOLAL(5) = PSI2 ! sc.7.2010 - include dissolved sulfate in initial water calc
|
|
MOLAL(6) = ZERO
|
|
MOLAL(3) = PSI1
|
|
MOLAL(7) = PSI1
|
|
CALL CALCMR ! Initial water
|
|
C
|
|
CALAOU = .TRUE. ! Outer loop activity calculation flag
|
|
TST1 = .TRUE.
|
|
TST2 = .TRUE.
|
|
CHECKIT = 1
|
|
PSI4LO = TINY ! Low limit
|
|
PSI4HI = CHI4 ! High limit
|
|
C
|
|
C *** INITIAL VALUES FOR BISECTION ************************************
|
|
C
|
|
60 X1 = PSI4LO
|
|
CALL RSTGAMP
|
|
CALL FUNCD3 (X1, Y1)
|
|
IF (ABS(Y1) <= (EPS)) THEN
|
|
X3 = X1
|
|
GOTO 50
|
|
ENDIF
|
|
YLO = Y1 ! Save Y-value at HI position
|
|
C
|
|
C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO **********************
|
|
C
|
|
DX = (PSI4HI-PSI4LO)/FLOAT(NDIV)
|
|
X2 = X1
|
|
Y2 = Y1
|
|
I = 1
|
|
DO WHILE ((I <= NDIV) .AND. TST1)
|
|
X1 = X2
|
|
Y1 = Y2
|
|
X2 = X1+DX
|
|
CALL FUNCD3 (X2, Y2)
|
|
C IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2) < ZERO) THEN
|
|
IF (((Y1) < ZERO) .AND. ((Y2) > ZERO)) THEN
|
|
TST1 = .FALSE.! (Y1*Y2 < ZERO)
|
|
ENDIF
|
|
I = I + 1
|
|
ENDDO
|
|
IF (.NOT.TST1) GOTO 20
|
|
C
|
|
C *** NO SUBDIVISION WITH SOLUTION FOUND
|
|
C
|
|
YHI= Y1 ! Save Y-value at Hi position
|
|
IF (ABS(Y2) < EPS) THEN ! X2 IS A SOLUTION
|
|
X3 = X2
|
|
Y3 = Y2
|
|
GOTO 50
|
|
C
|
|
C *** { YLO, YHI } < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NH3
|
|
C Physically I dont know when this might happen, but I have put this
|
|
C branch in for completeness. I assume there is no solution; all NO3 goes to the
|
|
C gas phase.
|
|
C
|
|
ELSE IF ((YLO) < ZERO .AND. (YHI) < ZERO) THEN
|
|
P4 = TINY ! PSI4LO ! CHI4
|
|
CALL RSTGAMP
|
|
CALL FUNCD3(P4, Y3)
|
|
X3 = P4
|
|
GOTO 50
|
|
C
|
|
C *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NH3
|
|
C This happens when Sul.Rat. = 2.0, so some NH4+ from sulfate evaporates
|
|
C and goes to the gas phase ; so I redefine the LO and HI limits of PSI4
|
|
C and proceed again with root tracking.
|
|
C
|
|
ELSE IF ((YLO) > ZERO .AND. (YHI) > ZERO) THEN
|
|
PSI4HI = PSI4LO
|
|
PSI4LO = PSI4LO - 0.1*(PSI1+PSI2) ! No solution; some NH3 evaporates
|
|
IF ((PSI4LO) < (-1.D0*(PSI1+PSI2))) THEN
|
|
C WRITE(*,*) 'Error'
|
|
CALL PUSHERR (0001, 'CALCD3') ! WARNING ERROR: NO SOLUTION
|
|
RETURN
|
|
ELSE
|
|
MOLAL(5) = PSI2 ! so4 included in water calc
|
|
MOLAL(6) = ZERO
|
|
MOLAL(3) = PSI1
|
|
MOLAL(7) = PSI1
|
|
CALL CALCMR ! Initial water
|
|
IF ( CHECKIT .LT. 15 ) THEN
|
|
REX = .TRUE.
|
|
CHECKIT = CHECKIT + 1
|
|
GOTO 60 ! Redo root tracking
|
|
ELSE
|
|
CALL PUSHERR (0002, 'CALCD3') ! WARNING ERROR: NO CONVERGENCE
|
|
GOTO 50
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
C
|
|
C *** PERFORM BISECTION ***********************************************
|
|
C
|
|
20 I = 1
|
|
TST2 = .TRUE.
|
|
Y3 = Y2
|
|
DO WHILE ((I <= MAXIT) .AND. TST2)
|
|
X3 = 0.5d0*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCD3 (X3,Y3)
|
|
IF (SIGN(1.d0,(Y1))*SIGN(1.d0,(Y3)) <= ZERO) THEN ! (Y1*Y3 <= ZERO)
|
|
Y2 = Y3
|
|
X2 = X3
|
|
ELSE
|
|
Y1 = Y3
|
|
X1 = X3
|
|
ENDIF
|
|
IF ((ABS(X2-X1) <= EPS*ABS(X1)) .AND.
|
|
+ (ABS(Y3) < FEPS)) THEN
|
|
TST2 = .FALSE.
|
|
ENDIF
|
|
I = I + 1
|
|
ENDDO
|
|
|
|
IF ((I > MAXIT+1) .AND. TST2) THEN
|
|
CALL PUSHERR (0002, 'CALCD3') ! WARNING ERROR: NO CONVERGENCE
|
|
ENDIF
|
|
C
|
|
C *** CONVERGED ; RETURN **********************************************
|
|
C
|
|
X3 = 0.5*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCD3 (X3, Y3)
|
|
C
|
|
50 CONTINUE
|
|
C IF (ABS(Y3) > FEPS) THEN
|
|
C WRITE(ERRINF, '(A,E12.5,A)') 'CALCD3 (',(Y3),')'
|
|
C CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE
|
|
C RETURN
|
|
C ENDIF
|
|
C
|
|
CALL FUNCD3P_DB(x3, y1, wpdb, gasb, aerliqb)
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCD3 ******************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** FUNCTION FUNCD3
|
|
C *** CASE D3
|
|
C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ;
|
|
C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3.
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCD3(P4, FD3)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
LOGICAL :: TST
|
|
REAL*8 :: GMAX, GTHRESH, P4, FD3, BB, DENM
|
|
INTEGER :: I
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
FRST = .TRUE.
|
|
CALAIN = .TRUE.
|
|
TST = .TRUE.
|
|
PSI4 = P4
|
|
I = 1
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
DO WHILE ((I <= NSWEEP) .AND. TST)
|
|
C
|
|
IF (I > 1) CALL CALCACT3
|
|
C
|
|
A2 = XK7*(WATER/GAMA(4))**3.0
|
|
A3 = XK4*R*TEMP*(WATER/GAMA(10))**2.0
|
|
A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0
|
|
A7 = XKW *RH*WATER*WATER
|
|
C
|
|
PSI3 = A3*A4*CHI3*(CHI4-PSI4) - PSI1*(2.D0*PSI2+PSI1+PSI4)
|
|
PSI3 = PSI3/(A3*A4*(CHI4-PSI4) + 2.D0*PSI2+PSI1+PSI4)
|
|
PSI3 = MIN(MAX(PSI3, ZERO), CHI3)
|
|
C
|
|
BB = PSI4 - PSI3
|
|
|
|
DENM = BB+SQRT(BB*BB + 4.d0*A7)
|
|
IF ((DENM) <= TINY) THEN ! Avoid overflow when HI->0
|
|
ABB = ABS(BB)
|
|
DENM = BB + ABB + 2.0*A7/ABB - (2.0*A7*A7)/ABB**3.0 ! Taylor expansion of SQRT
|
|
ENDIF
|
|
AHI = 2.0*A7/DENM
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
MOLAL (1) = AHI ! HI
|
|
MOLAL (3) = PSI1 + PSI4 + 2.D0*PSI2 ! NH4I
|
|
MOLAL (5) = PSI2 ! SO4I
|
|
MOLAL (6) = ZERO ! HSO4I
|
|
MOLAL (7) = PSI3 + PSI1 ! NO3I
|
|
CNH42S4 = CHI2 - PSI2 ! Solid (NH4)2SO4
|
|
CNH4NO3 = ZERO ! Solid NH4NO3
|
|
GHNO3 = CHI3 - PSI3 ! Gas HNO3
|
|
GNH3 = CHI4 - PSI4 ! Gas NH3
|
|
CALL CALCMR ! Water content
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN
|
|
TST = .TRUE.
|
|
ELSE
|
|
TST = .FALSE.
|
|
ENDIF
|
|
I = I+1
|
|
ENDDO
|
|
C
|
|
C *** CALCULATE OBJECTIVE FUNCTION ************************************
|
|
C
|
|
CCC FUNCD3= NH4I/HI/MAXCOMP(GNH3,TINY)/A4 - ONE
|
|
FD3= MOLAL(3)/MOLAL(1)/MAX(GNH3,TINY)/A4 - ONE
|
|
|
|
RETURN
|
|
C
|
|
C *** END OF FUNCTION FUNCD3 ********************************************
|
|
C
|
|
END
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** FUNCTION FUNCD3P
|
|
C *** CASE D3
|
|
C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ;
|
|
C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3.
|
|
C
|
|
C CREATED FOR ANISORROPIA. (slc.8.2010)
|
|
C NEWTON-RAPHSON SOLUTION ABOUT THE ROOT.
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCD3P (P4, Y1)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
|
|
REAL*8 :: P4, Y1, PARM, X
|
|
REAL*8 :: X1, X2, XT, Y1D, Y2, XTD
|
|
REAL*8 :: OMPS, DIAK, DELTA
|
|
CHARACTER(LEN=40) :: ERRINF
|
|
INTEGER :: ERRSTKI(25)
|
|
LOGICAL :: DEXS, IEXS, EOF
|
|
REAL*8 :: OM, PS, ZE, FEPS
|
|
CHARACTER(LEN=40) :: ERRMSGI(25)
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
FEPS = 1.D-5
|
|
PARM = XK10/(R*TEMP)/(R*TEMP)
|
|
C
|
|
C *** CALCULATE NH4NO3 THAT VOLATIZES *********************************
|
|
C
|
|
CNH42S4 = W(2)
|
|
X = MIN(W(3)-2.d0*W(2), W(4))
|
|
IF ((X) > ZERO) THEN
|
|
IF (((W(3) - 2.0*W(2))) < (W(4))) THEN
|
|
PS = ZERO
|
|
OM = W(4) - W(3) + 2.0*W(2)
|
|
IF ((OM) < TINY) THEN
|
|
OM = ZERO
|
|
ENDIF
|
|
ELSE
|
|
PS = W(3) - W(4) - 2.0*W(2)
|
|
IF ((PS) < TINY) THEN
|
|
PS = ZERO
|
|
ENDIF
|
|
OM = ZERO
|
|
ENDIF
|
|
ELSE
|
|
X = ZERO
|
|
PS = MAX(W(3) - 2.d0*W(2), ZERO)
|
|
IF ((PS) < TINY) THEN
|
|
PS = ZERO
|
|
ENDIF
|
|
OM = W(4)
|
|
ENDIF
|
|
C
|
|
OMPS = OM+PS
|
|
DIAK = SQRT(OMPS*OMPS + 4.0*PARM) ! DIAKRINOUSA
|
|
ZE = MIN(X, 0.5*(-OMPS + DIAK)) ! THETIKI RIZA
|
|
C
|
|
C *** SPECIATION *******************************************************
|
|
C
|
|
CNH4NO3 = X - ZE ! Solid NH4NO3
|
|
GNH3 = PS + ZE ! Gas NH3
|
|
GHNO3 = OM + ZE ! Gas HNO3
|
|
C
|
|
CHI1 = CNH4NO3 ! Save from CALCD1 run
|
|
CHI2 = CNH42S4
|
|
CHI3 = GHNO3
|
|
CHI4 = GNH3
|
|
C
|
|
PSI1 = CNH4NO3 ! ASSIGN INITIAL PSI's
|
|
PSI2 = CHI2
|
|
PSI3 = ZERO
|
|
PSI4 = P4
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
C
|
|
C *** NEWTON-RAPHSON DETERMINATION OF ROOT **********************
|
|
C
|
|
XT = PSI4
|
|
XTD = 1.D0
|
|
|
|
CALL FUNCD3B_DNRD(XT, XTD, Y1, Y1D)
|
|
X2 = XT - (Y1/(Y1D*1.d0))
|
|
CALL FUNCD3B(X2,Y2)
|
|
|
|
IF (abs(Y2) > 10.d0*FEPS) THEN
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCD3 (',(Y2),')'
|
|
CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE
|
|
RETURN
|
|
ENDIF
|
|
C
|
|
IF ((MOLAL(1)) > TINY .AND. (MOLAL(5)) > TINY) THEN
|
|
CALL CALCHS4 (MOLAL(1), MOLAL(5), ZERO, DELTA)
|
|
MOLAL(1) = MOLAL(1) - DELTA ! H+ EFFECT
|
|
MOLAL(5) = MOLAL(5) - DELTA ! SO4 EFFECT
|
|
MOLAL(6) = DELTA ! HSO4 EFFECT
|
|
ENDIF
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF FUNCTION FUNCD3P *******************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** FUNCTION FUNCD3
|
|
C *** CASE D3
|
|
C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ;
|
|
C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3.
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCD3B (P4,FD3B)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
|
|
REAL*8 :: WP(NCOMP), MOLALP(NIONS)
|
|
REAL*8 :: P4, BB, DENM, AHI, AML5, FD3B
|
|
CHARACTER(LEN=40) :: ERRINF
|
|
INTEGER :: ERRSTKI(25), K, J
|
|
LOGICAL :: DEXS, IEXS, EOF
|
|
CHARACTER(LEN=40) :: ERRMSGI(25)
|
|
LOGICAL :: TST
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
PSI4 = P4
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
DO I = 1,3
|
|
C
|
|
A2 = XK7*(WATER/GAMA(4))**3.0
|
|
A3 = XK4*R*TEMP*(WATER/GAMA(10))**2.0
|
|
A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0
|
|
A7 = XKW *RH*WATER*WATER
|
|
C
|
|
PSI3 = A3*A4*CHI3*(CHI4-PSI4) - PSI1*(2.D0*PSI2+PSI1+PSI4)
|
|
PSI3 = PSI3/(A3*A4*(CHI4-PSI4) + 2.D0*PSI2+PSI1+PSI4)
|
|
PSI3 = MIN(MAX(PSI3, ZERO), CHI3)
|
|
C
|
|
BB = PSI4 - PSI3
|
|
DENM = BB+SQRT(BB*BB + 4.d0*A7)
|
|
IF ((DENM) <= TINY) THEN ! Avoid overflow when HI->0
|
|
ABB = ABS(BB)
|
|
DENM = BB + ABB + 2.d0*A7/ABB - (2.d0*A7*A7)/ABB**3.d0 ! Taylor expansion of SQRT
|
|
ENDIF
|
|
AHI = 2.d0*A7/DENM
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
MOLAL (1) = AHI ! HI
|
|
MOLAL (3) = PSI1 + PSI4 + 2.D0*PSI2 ! NH4I
|
|
MOLAL (5) = PSI2 ! SO4I
|
|
MOLAL (6) = ZERO ! HSO4I
|
|
MOLAL (7) = PSI3 + PSI1 ! NO3I
|
|
CNH42S4 = CHI2 - PSI2 ! Solid (NH4)2SO4
|
|
CNH4NO3 = ZERO ! Solid NH4NO3
|
|
GHNO3 = CHI3 - PSI3 ! Gas HNO3
|
|
GNH3 = CHI4 - PSI4 ! Gas NH3
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
MOLALR(4) = MOLAL(5) + MOLAL(6) ! (NH4)2SO4
|
|
AML5 = MOLAL(3)-2.D0*MOLALR(4) ! "free" NH4
|
|
MOLALR(5) = MAX(MIN(AML5,MOLAL(7)), ZERO) ! NH4NO3 = MIN("free", NO3)
|
|
C
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
WATER = ZERO
|
|
DO J=1,NPAIR
|
|
WATER = WATER + MOLALR(J)/M0(J)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C
|
|
CALL CALCACT3F
|
|
ENDDO
|
|
C
|
|
C *** CALCULATE OBJECTIVE FUNCTION ************************************
|
|
C
|
|
CCC FUNCD3= NH4I/HI/MAX(GNH3,TINY)/A4 - ONE
|
|
FD3B = MOLAL(3)/MOLAL(1)/MAX(GNH3,TINY)/A4 - ONE
|
|
RETURN
|
|
C
|
|
C *** END OF FUNCTION FUNCD3P *******************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCD1A
|
|
C *** CASE D1 ; SUBCASE 1
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0)
|
|
C 2. SOLID AEROSOL ONLY
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4NO3
|
|
C
|
|
C THE SOLID (NH4)2SO4 IS CALCULATED FROM THE SULFATES, WHILE NH4NO3
|
|
C IS CALCULATED FROM NH3-HNO3 EQUILIBRIUM. 'ZE' IS THE AMOUNT OF
|
|
C NH4NO3 THAT VOLATIZES WHEN ALL POSSILBE NH4NO3 IS INITIALLY IN
|
|
C THE SOLID PHASE.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCD1A
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: PARM, PS, OM, OMPS, DIAK, ZE, X
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
PARM = XK10/(R*TEMP)/(R*TEMP)
|
|
C
|
|
C *** CALCULATE NH4NO3 THAT VOLATIZES *********************************
|
|
C
|
|
CNH42S4 = W(2)
|
|
X = MAX(MIN(W(3)-2.d0*CNH42S4, W(4)), ZERO) ! MAX NH4NO3
|
|
PS = MAX(W(3) - X - 2.d0*CNH42S4, ZERO)
|
|
OM = MAX(W(4) - X, ZERO)
|
|
C
|
|
OMPS = OM+PS
|
|
DIAK = SQRT(OMPS*OMPS + 4.0*PARM) ! DIAKRINOUSA
|
|
ZE = MIN(X, 0.5*(-OMPS + DIAK)) ! THETIKI RIZA
|
|
C
|
|
C *** SPECIATION *******************************************************
|
|
C
|
|
CNH4NO3 = X - ZE ! Solid NH4NO3
|
|
GNH3 = PS + ZE ! Gas NH3
|
|
GHNO3 = OM + ZE ! Gas HNO3
|
|
C
|
|
C PAUSE
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCD1A *****************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCD1AL
|
|
C *** CASE D1 ; SUBCASE 1
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0)
|
|
C 2. SOLID AEROSOL ONLY
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4NO3
|
|
C
|
|
C THE SOLID (NH4)2SO4 IS CALCULATED FROM THE SULFATES, WHILE NH4NO3
|
|
C IS CALCULATED FROM NH3-HNO3 EQUILIBRIUM. 'ZE' IS THE AMOUNT OF
|
|
C NH4NO3 THAT VOLATIZES WHEN ALL POSSILBE NH4NO3 IS INITIALLY IN
|
|
C THE SOLID PHASE.
|
|
C
|
|
C CREATED FOR ANISORROPIA. (slc.8.2010)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCD1AL
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: PARM, PS, OM, OMPS, DIAK, ZE, X
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
PARM = XK10/(R*TEMP)/(R*TEMP)
|
|
C
|
|
C *** CALCULATE NH4NO3 THAT VOLATIZES *********************************
|
|
C
|
|
CNH42S4 = W(2)
|
|
X = MIN(W(3)-2.d0*W(2), W(4))
|
|
IF ((X) > ZERO) THEN
|
|
IF ((W(3) - 2.d0*W(2)) < (W(4))) THEN
|
|
PS = ZERO
|
|
OM = W(4) - W(3) + 2.d0*W(2)
|
|
IF ((OM) < TINY) THEN
|
|
OM = ZERO
|
|
ENDIF
|
|
ELSE
|
|
PS = W(3) - W(4) - 2.d0*W(2)
|
|
IF ((PS) < TINY) THEN
|
|
PS = ZERO
|
|
ENDIF
|
|
OM = ZERO
|
|
ENDIF
|
|
ELSE
|
|
X = ZERO
|
|
PS = MAX(W(3) - 2.d0*W(2), ZERO)
|
|
IF ((PS) < TINY) THEN
|
|
PS = ZERO
|
|
ENDIF
|
|
OM = W(4)
|
|
ENDIF
|
|
C
|
|
OMPS = OM+PS
|
|
DIAK = SQRT(OMPS*OMPS + 4.d0*PARM) ! DIAKRINOUSA
|
|
ZE = MIN(X, 0.5d0*(-OMPS + DIAK)) ! THETIKI RIZA
|
|
C
|
|
C *** SPECIATION *******************************************************
|
|
C
|
|
CNH4NO3 = X - ZE ! Solid NH4NO3
|
|
GNH3 = PS + ZE ! Gas NH3
|
|
GHNO3 = OM + ZE ! Gas HNO3
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCD1A *****************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCG5
|
|
C *** CASE G5
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCG5
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
LOGICAL :: TST1, TST2
|
|
INTEGER :: I
|
|
CHARACTER(LEN=40) :: ERRINF
|
|
INTEGER :: ERRSTKI(25)
|
|
CHARACTER(LEN=40) :: ERRMSGI(25)
|
|
REAL*8 :: AERLIQ(NIONS+NGASAQ+2), GAS(3)
|
|
REAL*8 :: WP(NCOMP)
|
|
REAL*8 :: LAMDA, FEPS
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
FEPS = 1.D-5
|
|
CALAOU = .TRUE.
|
|
CHI1 = 0.5d0*W(1)
|
|
CHI2 = MAX (W(2)-0.5d0*W(1), ZERO)
|
|
CHI3 = ZERO
|
|
CHI4 = MAX (W(3)-2.D0*CHI2, ZERO)
|
|
CHI5 = W(4)
|
|
CHI6 = W(5)
|
|
C
|
|
PSI1 = CHI1
|
|
PSI2 = CHI2
|
|
PSI6LO = TINY
|
|
PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4)
|
|
C
|
|
WATER = CHI2/M0(4) + CHI1/M0(2)
|
|
C
|
|
C *** INITIAL VALUES FOR BISECTION ************************************
|
|
C
|
|
X1 = PSI6LO
|
|
CALL FUNCG5A (X1, Y1)
|
|
IF (CHI6 <= TINY) THEN
|
|
X3 = X1
|
|
Y3 = Y1
|
|
GOTO 50
|
|
ENDIF
|
|
ccc IF (ABS(Y1) <= EPS .OR. CHI6 <= TINY) GOTO 50
|
|
ccc IF (WATER <= TINY) RETURN ! No water
|
|
C
|
|
C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO **********************
|
|
C
|
|
DX = (PSI6HI-PSI6LO)/FLOAT(NDIV)
|
|
X2 = X1
|
|
Y2 = Y1
|
|
I = 1
|
|
TST1 = .TRUE.
|
|
|
|
DO WHILE ((I <= NDIV) .AND. TST1)
|
|
X1 = X2
|
|
Y1 = Y2
|
|
X2 = X1+DX
|
|
CALL FUNCG5A (X2, Y2)
|
|
IF ((Y1 < ZERO) .AND. (Y2 > ZERO)) THEN
|
|
TST1 = .FALSE.! (Y1*Y2 < ZERO)
|
|
ENDIF
|
|
I = I+1
|
|
ENDDO
|
|
C
|
|
C *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2)<EPS SOLUTION IS ASSUMED
|
|
C
|
|
IF ((ABS(Y2) > EPS).AND.TST1.AND.(I > NDIV+1)) THEN
|
|
CALL RSTGAMP
|
|
CALL FUNCG5A (PSI6LO, Y3)
|
|
X3 = PSI6LO
|
|
CALL PUSHERR (0002, 'CALCG5') ! WARNING ERROR: NO CONVERGENCE
|
|
GOTO 50
|
|
ENDIF
|
|
C
|
|
C *** PERFORM BISECTION ***********************************************
|
|
C
|
|
I = 1
|
|
TST2 = .TRUE.
|
|
DO WHILE ((I <= MAXIT).AND.TST2)
|
|
X3 = 0.5*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCG5A (X3, Y3)
|
|
IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) <= ZERO) THEN ! (Y1*Y3 <= ZERO)
|
|
Y2 = Y3
|
|
X2 = X3
|
|
ELSE
|
|
Y1 = Y3
|
|
X1 = X3
|
|
ENDIF
|
|
IF (ABS(X2-X1) <= EPS*X1 .AND. (ABS(Y3) < FEPS)) THEN
|
|
TST2 = .FALSE. !GOTO 40
|
|
ENDIF
|
|
I = I+1
|
|
ENDDO
|
|
IF ((I > (MAXIT+1)) .AND. TST2) THEN
|
|
CALL PUSHERR (0002, 'CALCG5') ! WARNING ERROR: NO CONVERGENCE
|
|
ENDIF
|
|
C
|
|
C *** CONVERGED ; RETURN **********************************************
|
|
C
|
|
X3 = 0.5*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCG5A (X3, Y3)
|
|
C
|
|
C *** CALCULATE HSO4 SPECIATION AND RETURN *******************************
|
|
C
|
|
50 CONTINUE
|
|
|
|
C *** Execute differentiable Newtons function once ***********************
|
|
|
|
! * slc.11.2011 - commenting since error does not prevent call of FUNCG5AP_GB
|
|
!
|
|
! IF (ABS(Y3) > FEPS) THEN
|
|
! WRITE(ERRINF, '(A,E12.5,A)') 'CALCG5 (',Y3,')'
|
|
! CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE
|
|
! WRITE(*,*) 'CALCG5 - Err 104: ',Y3
|
|
! ENDIF
|
|
C
|
|
CALL FUNCG5AP(X3)
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCG5 *******************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCG5
|
|
C *** CASE G5
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCG5_B(wpb, gasb, aerliqb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
LOGICAL :: TST1, TST2
|
|
INTEGER :: I
|
|
CHARACTER(LEN=40) :: ERRINF
|
|
INTEGER :: ERRSTKI(25)
|
|
CHARACTER(LEN=40) :: ERRMSGI(25)
|
|
REAL*8 :: AERLIQ(NIONS+NGASAQ+2), GAS(3), WP(NCOMP)
|
|
REAL*8 :: LAMDA, wpb(ncomp)
|
|
REAL*8 :: gasb(ngasaq), aerliqb(nions+ngasaq+2)
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
FEPS = 1.d-5
|
|
CALAOU = .TRUE.
|
|
CHI1 = 0.5d0*W(1)
|
|
CHI2 = MAX (W(2)-0.5d0*W(1), ZERO)
|
|
CHI3 = ZERO
|
|
CHI4 = MAX (W(3)-2.D0*CHI2, ZERO)
|
|
CHI5 = W(4)
|
|
CHI6 = W(5)
|
|
C
|
|
PSI1 = CHI1
|
|
PSI2 = CHI2
|
|
PSI6LO = TINY
|
|
PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4)
|
|
C
|
|
WATER = CHI2/M0(4) + CHI1/M0(2)
|
|
C
|
|
C *** INITIAL VALUES FOR BISECTION ************************************
|
|
C
|
|
X1 = PSI6LO
|
|
CALL FUNCG5A (X1, Y1)
|
|
IF (CHI6 <= TINY) THEN
|
|
X3 = X1
|
|
Y3 = Y1
|
|
GOTO 50
|
|
ENDIF
|
|
ccc IF (ABS(Y1) <= EPS .OR. CHI6 <= TINY) GOTO 50
|
|
ccc IF (WATER <= TINY) RETURN ! No water
|
|
C
|
|
C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO **********************
|
|
C
|
|
DX = (PSI6HI-PSI6LO)/FLOAT(NDIV)
|
|
X2 = X1
|
|
Y2 = Y1
|
|
I = 1
|
|
TST1 = .TRUE.
|
|
|
|
DO WHILE ((I <= NDIV) .AND. TST1)
|
|
X1 = X2
|
|
Y1 = Y2
|
|
X2 = X1+DX
|
|
CALL FUNCG5A (X2, Y2)
|
|
IF ((Y1 < ZERO) .AND. (Y2 > ZERO)) THEN
|
|
TST1 = .FALSE.! (Y1*Y2 < ZERO)
|
|
ENDIF
|
|
I = I+1
|
|
ENDDO
|
|
C
|
|
C *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2)<EPS SOLUTION IS ASSUMED
|
|
C
|
|
IF ((ABS(Y2) > EPS).AND.TST1.AND.(I > NDIV+1)) THEN
|
|
CALL RSTGAMP
|
|
CALL FUNCG5A (PSI6LO, Y3)
|
|
X3 = PSI6LO
|
|
CALL PUSHERR (0002, 'CALCG5') ! WARNING ERROR: NO CONVERGENCE
|
|
GOTO 50
|
|
ENDIF
|
|
C
|
|
C *** PERFORM BISECTION ***********************************************
|
|
C
|
|
I = 1
|
|
TST2 = .TRUE.
|
|
FEPS = 1.D-5
|
|
DO WHILE ((I <= MAXIT).AND.TST2)
|
|
X3 = 0.5d0*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCG5A (X3, Y3)
|
|
IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) <= ZERO) THEN ! (Y1*Y3 <= ZERO)
|
|
Y2 = Y3
|
|
X2 = X3
|
|
ELSE
|
|
Y1 = Y3
|
|
X1 = X3
|
|
ENDIF
|
|
IF (ABS(X2-X1) <= EPS*X1 .AND. (ABS(Y3) < FEPS)) THEN
|
|
TST2 = .FALSE. !GOTO 40
|
|
ENDIF
|
|
I = I+1
|
|
ENDDO
|
|
|
|
IF ((I > (MAXIT+1)) .AND. TST2) THEN
|
|
CALL PUSHERR (0002, 'CALCG5') ! WARNING ERROR: NO CONVERGENCE
|
|
ENDIF
|
|
C
|
|
C *** CONVERGED ; RETURN **********************************************
|
|
C
|
|
X3 = 0.5d0*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCG5A (X3, Y3)
|
|
C
|
|
C *** CALCULATE HSO4 SPECIATION AND RETURN *******************************
|
|
C
|
|
50 CONTINUE
|
|
|
|
C *** Execute differentiable Newton's function once ***********************
|
|
|
|
! * slc.11.2011 - commenting since error does not prevent call of FUNCG5AP_GB
|
|
!
|
|
! IF (ABS(Y3) > FEPS) THEN
|
|
! WRITE(ERRINF, '(A,E12.5,A)') 'CALCG5 (',Y3,')'
|
|
! CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE
|
|
! WRITE(*,*) 'W: ',W
|
|
! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP
|
|
! WRITE(*,*) 'CALCG5_B, before NR - Err 104: ',Y3
|
|
! ENDIF
|
|
C
|
|
CALL FUNCG5AP_GB(x3, wpb, gasb, aerliqb)
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCG5 *******************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCG5A
|
|
C *** CASE G5
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCG5A (X, FG5A)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
LOGICAL :: TST
|
|
INTEGER :: SO4FLG
|
|
REAL*8 :: LAMDA, FG5A
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
PSI6 = X
|
|
I = 1
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
TST = .TRUE.
|
|
DO WHILE ((I <= NSWEEP).AND. TST)
|
|
C
|
|
A1 = XK5 *(WATER/GAMA(2))**3.0
|
|
A2 = XK7 *(WATER/GAMA(4))**3.0
|
|
A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0
|
|
A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0
|
|
A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0
|
|
AKK = A4*A6
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
IF (CHI5 >= TINY) THEN
|
|
PSI5 = PSI6*CHI5/(A6/A5*(CHI6-PSI6) + PSI6)
|
|
ELSE
|
|
PSI5 = TINY
|
|
ENDIF
|
|
C
|
|
CCC IF(CHI4 > TINY) THEN
|
|
IF(W(2) > TINY) THEN ! Accounts for NH3 evaporation
|
|
BB =-(CHI4 + PSI6 + PSI5 + 1.d0/A4)
|
|
CC = CHI4*(PSI5+PSI6) - 2.d0*PSI2/A4
|
|
DD = MAX(BB*BB-4.d0*CC,ZERO) ! Patch proposed by Uma Shankar, 19/11/01
|
|
PSI4 =0.5d0*(-BB - SQRT(DD))
|
|
ELSE
|
|
PSI4 = TINY
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
MOLAL (2) = W(1) ! NAI
|
|
C MOLAL (3) = 2.0*PSI2 + PSI4 ! NH4I
|
|
MOLAL (4) = PSI6 ! CLI
|
|
IF (W(2)-0.5d0*W(1) > ZERO) THEN
|
|
MOLAL(3) = 2.d0*W(2) - W(1) + PSI4
|
|
MOLAL(5) = W(2) ! SO4I
|
|
ELSE
|
|
MOLAL(3) = PSI4
|
|
MOLAL(5) = 0.5d0*W(1) ! SO4I
|
|
ENDIF
|
|
MOLAL (6) = ZERO
|
|
MOLAL (7) = PSI5 ! NO3I
|
|
C
|
|
C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3)
|
|
SMIN = PSI5 + PSI6 - PSI4
|
|
CALL CALCPH (SMIN, HI, OHI)
|
|
MOLAL (1) = HI
|
|
C
|
|
GNH3 = MAX(CHI4 - PSI4, TINY) ! Gas NH3
|
|
GHNO3 = MAX(CHI5 - PSI5, TINY) ! Gas HNO3
|
|
GHCL = MAX(CHI6 - PSI6, TINY) ! Gas HCl
|
|
C
|
|
CNH42S4 = ZERO ! Solid (NH4)2SO4
|
|
CNH4NO3 = ZERO ! Solid NH4NO3
|
|
CNH4CL = ZERO ! Solid NH4Cl
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C WRITE(*,*) 'MOLAL ',MOLAL
|
|
MOLALR(2) = 0.5d0*W(1) ! NA2SO4
|
|
IF ((W(2)-0.5d0*W(1)) > ZERO) THEN
|
|
TOTS4 = W(2) ! Total SO4
|
|
MOLALR(4) = W(2)-0.5d0*W(1) ! (NH4)2SO4
|
|
FRNH4 = MAX(PSI4, ZERO)
|
|
ELSE
|
|
TOTS4 = 0.5d0*W(1) ! Total SO4
|
|
MOLALR(4) = ZERO ! (NH4)2SO4
|
|
FRNH4 = MAX(2.d0*W(2)-W(1) + PSI4, ZERO)
|
|
ENDIF
|
|
IF ((PSI5) < (FRNH4)) THEN
|
|
MOLALR(5) = PSI5
|
|
FRNH4 = MAX(FRNH4 - PSI5, ZERO)
|
|
ELSE
|
|
MOLALR(5) = FRNH4
|
|
FRNH4 = ZERO
|
|
ENDIF
|
|
MOLALR(6) = MIN(PSI6, FRNH4) ! NH4CL
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
WATER = ZERO
|
|
DO J=1,NPAIR
|
|
WATER = WATER + MOLALR(J)/M0(J)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C WRITE(*,*) 'After CALCMR: WATER ',WATER
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN
|
|
TST = .TRUE.
|
|
ELSE
|
|
TST = .FALSE.
|
|
ENDIF
|
|
CALL CALCACT3
|
|
I = I + 1
|
|
C
|
|
ENDDO
|
|
C
|
|
C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP ***************************
|
|
C
|
|
20 FG5A = MOLAL(1)*MOLAL(4)/GHCL/A6 - ONE
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF FUNCTION FUNCG5A *******************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCG5AB
|
|
C *** CASE G5
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCG5AB (X, FG5AB)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
LOGICAL :: TST
|
|
INTEGER :: SO4FLG
|
|
REAL*8 :: LAMDA, FG5AB
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
PSI6 = X
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
C WRITE(*,*) 'NSWEEP ',NSWEEP,'WATER',WATER
|
|
DO I = 1,2
|
|
C
|
|
A1 = XK5 *(WATER/GAMA(2))**3.0
|
|
A2 = XK7 *(WATER/GAMA(4))**3.0
|
|
A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0
|
|
A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0
|
|
A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0
|
|
AKK = A4*A6
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
IF (CHI5 >= TINY) THEN
|
|
PSI5 = PSI6*CHI5/(A6/A5*(CHI6-PSI6) + PSI6)
|
|
ELSE
|
|
PSI5 = TINY
|
|
ENDIF
|
|
C
|
|
CCC IF(CHI4 > TINY) THEN
|
|
IF(W(2) > TINY) THEN ! Accounts for NH3 evaporation
|
|
BB = -(CHI4 + PSI6 + PSI5 + 1.d0/A4)
|
|
CC = CHI4*(PSI5+PSI6) - 2.d0*PSI2/A4
|
|
DD = MAX(BB*BB-4.d0*CC,ZERO) ! Patch proposed by Uma Shankar, 19/11/01
|
|
PSI4 = 0.5d0*(-BB - SQRT(DD))
|
|
ELSE
|
|
PSI4 = TINY
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
MOLAL (2) = W(1) ! NAI
|
|
MOLAL (4) = PSI6 ! CLI
|
|
IF (W(2)-0.5d0*W(1) > ZERO) THEN
|
|
MOLAL(3) = 2.d0*W(2) - W(1) + PSI4
|
|
MOLAL(5) = W(2) ! SO4I
|
|
ELSE
|
|
MOLAL(3) = PSI4
|
|
MOLAL(5) = 0.5d0*W(1) ! SO4I
|
|
ENDIF
|
|
MOLAL (6) = ZERO
|
|
MOLAL (7) = PSI5 ! NO3I
|
|
C
|
|
C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3)
|
|
SMIN = PSI5 + PSI6 - PSI4
|
|
CALL CALCPH (SMIN, HI, OHI)
|
|
MOLAL (1) = HI
|
|
C
|
|
GNH3 = MAX(CHI4 - PSI4, TINY) ! Gas NH3
|
|
GHNO3 = MAX(CHI5 - PSI5, TINY) ! Gas HNO3
|
|
GHCL = MAX(CHI6 - PSI6, TINY) ! Gas HCl
|
|
C
|
|
CNH42S4 = ZERO ! Solid (NH4)2SO4
|
|
CNH4NO3 = ZERO ! Solid NH4NO3
|
|
CNH4CL = ZERO ! Solid NH4Cl
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
MOLALR(2) = 0.5*W(1) ! NA2SO4
|
|
IF (W(2)-0.5d0*W(1) > ZERO) THEN
|
|
TOTS4 = W(2) ! Total SO4
|
|
MOLALR(4) = W(2)-0.5d0*W(1) ! (NH4)2SO4
|
|
FRNH4 = MAX(PSI4, ZERO)
|
|
ELSE
|
|
TOTS4 = 0.5d0*W(1) ! Total SO4
|
|
MOLALR(4) = ZERO ! (NH4)2SO4
|
|
FRNH4 = MAX(2.d0*W(2)-W(1) + PSI4, ZERO)
|
|
ENDIF
|
|
IF (PSI5 < FRNH4) THEN
|
|
MOLALR(5) = PSI5
|
|
FRNH4 = MAX(FRNH4 - PSI5, ZERO)
|
|
ELSE
|
|
MOLALR(5) = FRNH4
|
|
FRNH4 = ZERO
|
|
ENDIF
|
|
MOLALR(6) = MIN(PSI6, FRNH4) ! NH4CL
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
WATER = ZERO
|
|
DO J=1,NPAIR
|
|
WATER = WATER + MOLALR(J)/M0(J)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3F
|
|
ENDDO
|
|
C
|
|
C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP ***************************
|
|
C
|
|
20 FG5AB = MOLAL(1)*MOLAL(4)/GHCL/A6 - ONE
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF FUNCTION FUNCG5A *******************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCG5A
|
|
C *** CASE G5
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C CREATED FOR ANISORROPIA. (slc.5.2011)
|
|
C NEWTON-RAPHSON SOLUTION ABOUT THE ROOT.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCG5AP (X1)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
LOGICAL :: TST
|
|
CHARACTER(LEN=40) :: ERRINF
|
|
REAL*8 :: LAMDA, FEPS
|
|
REAL*8 :: WP(5), X1
|
|
REAL*8 :: AERLIQ(NIONS+NGASAQ+2), GAS(3)
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
FEPS = 1.d-5
|
|
CHI1 = 0.5d0*W(1)
|
|
CHI2 = MAX (W(2)-0.5d0*W(1), ZERO)
|
|
CHI3 = ZERO
|
|
CHI4 = MAX (W(3)-2.D0*CHI2, ZERO)
|
|
CHI5 = W(4)
|
|
CHI6 = W(5)
|
|
C
|
|
PSI1 = CHI1
|
|
PSI2 = CHI2
|
|
I = 1
|
|
PSI6 = X1
|
|
FRST = .TRUE.
|
|
CALAIN = .TRUE.
|
|
TST = .TRUE.
|
|
C
|
|
C *** NEWTON-RAPHSON DETERMINATION OF ROOT **********************
|
|
C
|
|
XT = X1
|
|
XTD = 1.D0
|
|
CCCC$AD NOCHECKPOINT
|
|
CALL FUNCG5AB_GNRD(XT, XTD, Y1, Y1D)
|
|
X2 = XT - (Y1/(Y1D*1.d0))
|
|
CALL FUNCG5AB(X2,Y2)
|
|
IF (abs(Y2) > 10.d0*FEPS) THEN
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCG5 (',(Y2),')'
|
|
CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE
|
|
! WRITE(*,*) 'W: ',W
|
|
! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP
|
|
! WRITE(*,*) 'FUNCG5AP, after NR - Err 104: ',Y2
|
|
RETURN
|
|
ENDIF
|
|
C
|
|
IF (MOLAL(1) > TINY .AND. MOLAL(5) > TINY) THEN
|
|
CALL CALCHS4 (MOLAL(1), MOLAL(5), ZERO, DELTA)
|
|
MOLAL(1) = MOLAL(1) - DELTA ! H+ EFFECT
|
|
MOLAL(5) = MOLAL(5) - DELTA ! SO4 EFFECT
|
|
MOLAL(6) = DELTA ! HSO4 EFFECT
|
|
ENDIF
|
|
C
|
|
C *** END OF FUNCTION FUNCG5A *******************************************
|
|
C
|
|
END
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCH6
|
|
C *** CASE H6
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCH6
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
LOGICAL :: TST1, TST2, TST
|
|
REAL*8 :: FEPS, WP(ncomp), AERLIQ(NIONS+NGASAQ+2)
|
|
REAL*8 :: GAS(3)
|
|
CHARACTER(LEN=40) :: ERRINF
|
|
INTEGER :: ERRSTKI(25)
|
|
CHARACTER(LEN=40) :: ERRMSGI(25)
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
CALAOU = .TRUE.
|
|
TST1 = .TRUE.
|
|
TST2 = .TRUE.
|
|
CHI1 = W(2) ! CNA2SO4
|
|
CHI2 = ZERO ! CNH42S4
|
|
CHI3 = ZERO ! CNH4CL
|
|
FRNA = MAX (W(1)-2.D0*W(2), ZERO)
|
|
CHI8 = MIN (FRNA, W(4)) ! CNANO3
|
|
CHI4 = W(3) ! NH3(g)
|
|
IF (FRNA < W(4)) THEN
|
|
CHI5 = MAX(W(4)-FRNA, ZERO)
|
|
CHI7 = MIN(ZERO,W(5))
|
|
CHI6 = MAX(W(5),ZERO)
|
|
ELSE
|
|
CHI5 = ZERO
|
|
IF (MAX(FRNA-W(4),ZERO) < W(5)) THEN
|
|
CHI7 = MAX(FRNA-W(4),ZERO)
|
|
CHI6 = MAX(W(5)-CHI7,ZERO)
|
|
ELSE
|
|
CHI7 = W(5)
|
|
CHI6 = ZERO
|
|
ENDIF
|
|
ENDIF
|
|
C
|
|
PSI6LO = TINY
|
|
PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4)
|
|
C
|
|
C *** INITIAL VALUES FOR BISECTION ************************************
|
|
C
|
|
X1 = PSI6LO
|
|
CALL FUNCH6A (X1, Y1)
|
|
IF (ABS(Y1) <= EPS .OR. CHI6 <= TINY) THEN
|
|
X3 = X1
|
|
Y3 = Y1
|
|
GOTO 50
|
|
ENDIF
|
|
C
|
|
C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO **********************
|
|
C
|
|
I = 1
|
|
X2 = X1
|
|
Y2 = Y1
|
|
DX = (PSI6HI-PSI6LO)/FLOAT(NDIV)
|
|
DO WHILE ((I <= NDIV) .AND. TST1)
|
|
X1 = X2
|
|
Y2 = Y2
|
|
X2 = X1+DX
|
|
CALL FUNCH6A (X2, Y2)
|
|
IF ((Y1 < ZERO) .AND. (Y2 > ZERO)) THEN
|
|
TST1 = .FALSE.! (Y1*Y2 < ZERO)
|
|
ENDIF
|
|
I = I+1
|
|
ENDDO
|
|
C
|
|
C *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2)<EPS SOLUTION IS ASSUMED
|
|
C
|
|
IF ((ABS(Y2) > EPS).AND.TST1.AND.(I > NDIV+1)) THEN
|
|
CALL RSTGAMP
|
|
CALL FUNCH6A (PSI6LO, Y3)
|
|
X3 = PSI6LO
|
|
CALL PUSHERR (0002, 'CALCH6') ! WARNING ERROR: NO CONVERGENCE
|
|
GOTO 50
|
|
ENDIF
|
|
C
|
|
C *** PERFORM BISECTION ***********************************************
|
|
C
|
|
I = 1
|
|
TST2 = .TRUE.
|
|
FEPS = 1.D-5
|
|
DO WHILE ((I <= MAXIT) .AND. TST2)
|
|
X3 = 0.5*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCH6A (X3, Y3)
|
|
IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) <= ZERO) THEN ! (Y1*Y3 <= ZERO)
|
|
Y2 = Y3
|
|
X2 = X3
|
|
ELSE
|
|
Y1 = Y3
|
|
X1 = X3
|
|
ENDIF
|
|
IF ((ABS(X2-X1) <= EPS*X1) .AND. (ABS(Y3) < FEPS)) THEN
|
|
TST2 = .FALSE.
|
|
ENDIF
|
|
I = I+1
|
|
ENDDO
|
|
IF ((I > (MAXIT+1)) .AND. TST2) THEN
|
|
CALL PUSHERR (0002, 'CALCH6') ! WARNING ERROR: NO CONVERGENCE
|
|
ENDIF
|
|
C
|
|
C *** CONVERGED ; RETURN **********************************************
|
|
C
|
|
X3 = 0.5d0*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCH6A (X3, Y3)
|
|
C
|
|
C *** CALCULATE HSO4 SPECIATION AND RETURN *******************************
|
|
C
|
|
50 CONTINUE
|
|
C
|
|
CALL FUNCH6AP(X3)
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCH6 ******************************************
|
|
C
|
|
END
|
|
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCH6_B
|
|
C *** CASE H6
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C CREATED FOR ANISORROPIA. (slc.5.2011)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCH6_B(wpb, gasb, aerliqb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
LOGICAL :: TST1, TST2, TST
|
|
REAL*8 :: FEPS, AERLIQ(NIONS+NGASAQ+2)
|
|
REAL*8 :: GAS(3), wpb(ncomp)
|
|
CHARACTER(LEN=40) :: ERRINF
|
|
INTEGER :: ERRSTKI(25), npflag
|
|
CHARACTER(LEN=40) :: ERRMSGI(25)
|
|
REAL*8 :: gasb(3), aerliqb(NIONS+NGASAQ+2)
|
|
C
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
FEPS = 1.D-5
|
|
CALAOU = .TRUE.
|
|
TST1 = .TRUE.
|
|
TST2 = .TRUE.
|
|
CHI1 = W(2) ! CNA2SO4
|
|
CHI2 = ZERO ! CNH42S4
|
|
CHI3 = ZERO ! CNH4CL
|
|
FRNA = MAX (W(1)-2.D0*W(2), ZERO)
|
|
CHI8 = MIN (FRNA, W(4)) ! CNANO3
|
|
CHI4 = W(3) ! NH3(g)
|
|
IF (FRNA < W(4)) THEN
|
|
CHI5 = MAX(W(4)-FRNA, ZERO)
|
|
CHI7 = MIN(ZERO,W(5))
|
|
CHI6 = MAX(W(5),ZERO)
|
|
ELSE
|
|
CHI5 = ZERO
|
|
IF (MAX(FRNA-W(4),ZERO) < W(5)) THEN
|
|
CHI7 = MAX(FRNA-W(4),ZERO)
|
|
CHI6 = MAX(W(5)-CHI7,ZERO)
|
|
ELSE
|
|
CHI7 = W(5)
|
|
CHI6 = ZERO
|
|
ENDIF
|
|
ENDIF
|
|
C
|
|
PSI6LO = TINY
|
|
PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4)
|
|
C
|
|
C *** INITIAL VALUES FOR BISECTION ************************************
|
|
C
|
|
X1 = PSI6LO
|
|
CALL FUNCH6A (X1, Y1)
|
|
IF (ABS(Y1) <= EPS .OR. CHI6 <= TINY) THEN
|
|
X3 = X1
|
|
Y3 = Y1
|
|
GOTO 50
|
|
ENDIF
|
|
C
|
|
C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO **********************
|
|
C
|
|
I = 1
|
|
X2 = X1
|
|
Y2 = Y1
|
|
DX = (PSI6HI-PSI6LO)/FLOAT(NDIV)
|
|
DO WHILE ((I <= NDIV) .AND. TST1)
|
|
X1 = X2
|
|
Y2 = Y2
|
|
X2 = X1+DX
|
|
CALL FUNCH6A (X2, Y2)
|
|
IF ((Y1 < ZERO) .AND. (Y2 > ZERO)) THEN
|
|
TST1 = .FALSE.! (Y1*Y2 < ZERO)
|
|
ENDIF
|
|
I = I+1
|
|
ENDDO
|
|
C
|
|
C *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2)<EPS SOLUTION IS ASSUMED
|
|
C
|
|
IF ((ABS(Y2) > EPS).AND.TST1.AND.(I > NDIV+1)) THEN
|
|
CALL RSTGAMP
|
|
CALL FUNCH6A (PSI6LO, Y3)
|
|
X3 = PSI6LO
|
|
CALL PUSHERR (0002, 'CALCH6') ! WARNING ERROR: NO CONVERGENCE
|
|
GOTO 50
|
|
ENDIF
|
|
C
|
|
C *** PERFORM BISECTION ***********************************************
|
|
C
|
|
I = 1
|
|
TST2 = .TRUE.
|
|
DO WHILE ((I <= MAXIT) .AND. TST2)
|
|
X3 = 0.5d0*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCH6A (X3, Y3)
|
|
IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) <= ZERO) THEN ! (Y1*Y3 <= ZERO)
|
|
Y2 = Y3
|
|
X2 = X3
|
|
ELSE
|
|
Y1 = Y3
|
|
X1 = X3
|
|
ENDIF
|
|
IF ((ABS(X2-X1) <= EPS*X1) .AND. (ABS(Y3) < FEPS)) THEN
|
|
TST2 = .FALSE.
|
|
ENDIF
|
|
I = I+1
|
|
ENDDO
|
|
IF ((I > (MAXIT+1)) .AND. TST2) THEN
|
|
CALL PUSHERR (0002, 'CALCH6') ! WARNING ERROR: NO CONVERGENCE
|
|
ENDIF
|
|
C
|
|
C *** CONVERGED ; RETURN **********************************************
|
|
C
|
|
X3 = 0.5d0*(X1+X2)
|
|
CALL RSTGAMP
|
|
CALL FUNCH6A (X3, Y3)
|
|
C
|
|
C *** CALCULATE HSO4 SPECIATION AND RETURN *******************************
|
|
C
|
|
50 CONTINUE
|
|
|
|
! * slc.11.2011 - commenting since error does not prevent call of FUNCG5AP_GB
|
|
!
|
|
! IF (ABS(Y3) > FEPS) THEN
|
|
! WRITE(ERRINF, '(A,E12.5,A)') 'CALCH6 (',Y3,')'
|
|
! CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE
|
|
! WRITE(*,*) 'W: ',W
|
|
! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP
|
|
! WRITE(*,*) 'CALCH6_B, before NR - Err 104: ',Y3
|
|
! ENDIF
|
|
C
|
|
CALL FUNCH6AP_HB(x3, wpb, gasb, aerliqb)
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCH6 ******************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCH6A
|
|
C *** CASE H6
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCH6A (X, FH6A)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
LOGICAL :: TST
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
I = 1
|
|
PSI6 = X
|
|
PSI1 = CHI1
|
|
PSI2 = ZERO
|
|
PSI3 = ZERO
|
|
PSI7 = CHI7
|
|
PSI8 = CHI8
|
|
FRST = .TRUE.
|
|
CALAIN = .TRUE.
|
|
TST = .TRUE.
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
DO WHILE ((I <= NSWEEP) .AND. TST)
|
|
C
|
|
A1 = XK5 *(WATER/GAMA(2))**3.0
|
|
A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0
|
|
A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0
|
|
A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0
|
|
A7 = XK8 *(WATER/GAMA(1))**2.0
|
|
A8 = XK9 *(WATER/GAMA(3))**2.0
|
|
A9 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
PSI5 = CHI5*(PSI6+PSI7) - A6/A5*PSI8*(CHI6-PSI6-PSI3)
|
|
PSI5 = PSI5/(A6/A5*(CHI6-PSI6-PSI3) + PSI6 + PSI7)
|
|
PSI5 = MAX(PSI5, TINY)
|
|
C
|
|
IF (W(3) > TINY .AND. WATER > TINY) THEN ! First try 3rd order soln
|
|
BB = -(CHI4 + PSI6 + PSI5 + 1.d0/A4)
|
|
CC = CHI4*(PSI5+PSI6)
|
|
DD = BB*BB-4.d0*CC
|
|
PSI4 = 0.5d0*(-BB - SQRT(DD))
|
|
PSI4 = MIN(PSI4,CHI4)
|
|
ELSE
|
|
PSI4 = TINY
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
MOLAL (2) = PSI8 + PSI7 + 2.D0*PSI1 ! NAI
|
|
MOLAL (3) = PSI4 ! NH4I
|
|
MOLAL (4) = PSI6 + PSI7 ! CLI
|
|
MOLAL (5) = PSI2 + PSI1 ! SO4I
|
|
MOLAL (6) = ZERO ! HSO4I
|
|
MOLAL (7) = PSI5 + PSI8 ! NO3I
|
|
C
|
|
C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3)
|
|
SMIN = 2.d0*PSI2 + PSI5 + PSI6 - PSI4
|
|
CALL CALCPH (SMIN, HI, OHI)
|
|
MOLAL (1) = HI
|
|
C
|
|
GNH3 = MAX(CHI4 - PSI4, TINY)
|
|
GHNO3 = MAX(CHI5 - PSI5, TINY)
|
|
GHCL = MAX(CHI6 - PSI6, TINY)
|
|
C
|
|
CNH42S4 = ZERO
|
|
CNH4NO3 = ZERO
|
|
CNACL = MAX(CHI7 - PSI7, ZERO)
|
|
CNANO3 = MAX(CHI8 - PSI8, ZERO)
|
|
CNA2SO4 = MAX(CHI1 - PSI1, ZERO)
|
|
C
|
|
CALL CALCMR ! Water content
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN
|
|
TST = .TRUE.
|
|
ELSE
|
|
TST = .FALSE.
|
|
ENDIF
|
|
CALL CALCACT3
|
|
I = I + 1
|
|
ENDDO
|
|
C
|
|
C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP ***************************
|
|
C
|
|
FH6A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF FUNCTION FUNCH6A *******************************************
|
|
C
|
|
END
|
|
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCH6AP
|
|
C *** CASE H6
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C CREATED FOR ANISORROPIA. (slc.5.2011)
|
|
C NEWTON-RAPHSON SOLUTION ABOUT THE ROOT.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCH6AP (X1)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
CHARACTER(LEN=40) :: ERRINF
|
|
REAL*8 :: AERLIQ(NIONS+NGASAQ+2), GAS(3), FEPS
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
FEPS = 1.d-5
|
|
CHI1 = W(2) ! CNA2SO4
|
|
CHI2 = ZERO ! CNH42S4
|
|
CHI3 = ZERO ! CNH4CL
|
|
FRNA = MAX (W(1)-2.D0*W(2), ZERO)
|
|
CHI8 = MIN (FRNA, W(4)) ! CNANO3
|
|
CHI4 = W(3) ! NH3(g)
|
|
IF (FRNA < W(4)) THEN
|
|
CHI5 = MAX(W(4)-FRNA, ZERO)
|
|
CHI7 = MIN(ZERO,W(5))
|
|
CHI6 = MAX(W(5),ZERO)
|
|
ELSE
|
|
CHI5 = ZERO
|
|
IF (MAX(FRNA-W(4),ZERO) < W(5)) THEN
|
|
CHI7 = MAX(FRNA-W(4),ZERO)
|
|
CHI6 = MAX(W(5)-CHI7,ZERO)
|
|
ELSE
|
|
CHI7 = W(5)
|
|
CHI6 = ZERO
|
|
ENDIF
|
|
ENDIF
|
|
C
|
|
PSI1 = CHI1
|
|
PSI2 = ZERO
|
|
PSI3 = ZERO
|
|
PSI7 = CHI7
|
|
PSI8 = CHI8
|
|
PSI6 = X1
|
|
C
|
|
C *** NEWTON-RAPHSON DETERMINATION OF ROOT **********************
|
|
C
|
|
XT = X1
|
|
XTD = 1.D0
|
|
CALL FUNCH6AB_HNRD(XT, XTD, Y1, Y1D)
|
|
X2 = XT - (Y1/(Y1D*1.d0))
|
|
CALL FUNCH6AB(X2,Y2)
|
|
IF (abs(Y2) > 10.d0*FEPS) THEN
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCH6 (',(Y2),')'
|
|
CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE
|
|
! WRITE(*,*) 'W: ',W
|
|
! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP
|
|
! WRITE(*,*) 'CALCH6AP, after NR - Err 104: ',Y2
|
|
RETURN
|
|
ENDIF
|
|
C
|
|
IF (MOLAL(1) > TINY .AND. MOLAL(5) > TINY) THEN
|
|
CALL CALCHS4 (MOLAL(1), MOLAL(5), ZERO, DELTA)
|
|
MOLAL(1) = MOLAL(1) - DELTA ! H+ EFFECT
|
|
MOLAL(5) = MOLAL(5) - DELTA ! SO4 EFFECT
|
|
MOLAL(6) = DELTA ! HSO4 EFFECT
|
|
ENDIF
|
|
C
|
|
C *** END OF FUNCTION FUNCH6A *******************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCH6AB
|
|
C *** CASE H6
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C CREATED FOR ANISORROPIA. (slc.5.2011)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCH6AB (X, FH6AB)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
INTEGER :: J
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
PSI6 = X
|
|
PSI1 = CHI1
|
|
PSI2 = ZERO
|
|
PSI3 = ZERO
|
|
PSI7 = CHI7
|
|
PSI8 = CHI8
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
DO I = 1,2
|
|
C
|
|
A1 = XK5 *(WATER/GAMA(2))**3.0
|
|
A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0
|
|
A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0
|
|
A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0
|
|
A7 = XK8 *(WATER/GAMA(1))**2.0
|
|
A8 = XK9 *(WATER/GAMA(3))**2.0
|
|
A9 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.0
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
PSI5 = CHI5*(PSI6+PSI7) - A6/A5*PSI8*(CHI6-PSI6-PSI3)
|
|
PSI5 = PSI5/(A6/A5*(CHI6-PSI6-PSI3) + PSI6 + PSI7)
|
|
PSI5 = MAX(PSI5, TINY)
|
|
C
|
|
IF (W(3) > TINY .AND. WATER > TINY) THEN ! First try 3rd order soln
|
|
BB = -(CHI4 + PSI6 + PSI5 + 1.d0/A4)
|
|
CC = CHI4*(PSI5+PSI6)
|
|
DD = BB*BB-4.d0*CC
|
|
PSI4 = 0.5d0*(-BB - SQRT(DD))
|
|
PSI4 = MIN(PSI4,CHI4)
|
|
ELSE
|
|
PSI4 = TINY
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
MOLAL (2) = PSI8 + PSI7 + 2.D0*PSI1 ! NAI
|
|
MOLAL (3) = PSI4 ! NH4I
|
|
MOLAL (4) = PSI6 + PSI7 ! CLI
|
|
MOLAL (5) = PSI2 + PSI1 ! SO4I
|
|
MOLAL (6) = ZERO ! HSO4I
|
|
MOLAL (7) = PSI5 + PSI8 ! NO3I
|
|
C
|
|
C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3)
|
|
SMIN = 2.d0*PSI2 + PSI5 + PSI6 - PSI4
|
|
CALL CALCPH (SMIN, HI, OHI)
|
|
MOLAL (1) = HI
|
|
C
|
|
GNH3 = MAX(CHI4 - PSI4, TINY)
|
|
GHNO3 = MAX(CHI5 - PSI5, TINY)
|
|
GHCL = MAX(CHI6 - PSI6, TINY)
|
|
C
|
|
CNH42S4 = ZERO
|
|
CNH4NO3 = ZERO
|
|
CNACL = MAX(CHI7 - PSI7, ZERO)
|
|
CNANO3 = MAX(CHI8 - PSI8, ZERO)
|
|
CNA2SO4 = MAX(CHI1 - PSI1, ZERO)
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM RICH CASE
|
|
C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/
|
|
C
|
|
MOLALR(1) = PSI7 ! NACL
|
|
MOLALR(2) = PSI1 ! NA2SO4
|
|
MOLALR(3) = PSI8 ! NANO3
|
|
MOLALR(4) = ZERO ! (NH4)2SO4
|
|
C FRNO3 = MAX(MOLAL(7) - MOLALR(3), ZERO) ! "FREE" NO3
|
|
FRNO3 = MAX(PSI5, ZERO)
|
|
C FRCL = MAX(MOLAL(4) - MOLALR(1), ZERO) ! "FREE" CL
|
|
FRCL = MAX(PSI6, ZERO)
|
|
C MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3
|
|
C FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3
|
|
C MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL
|
|
IF (PSI4 < FRNO3) THEN
|
|
MOLALR(5) = PSI4
|
|
FRNH4 = ZERO
|
|
MOLALR(6) = MIN(FRCL, ZERO)
|
|
ELSE
|
|
MOLALR(5) = FRNO3
|
|
FRNH4 = MAX(PSI4-FRNO3,ZERO)
|
|
MOLALR(6) = MIN(FRCL, FRNH4)
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
WATER = ZERO
|
|
DO J=1,NPAIR
|
|
WATER = WATER + MOLALR(J)/M0(J)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3F
|
|
ENDDO
|
|
C
|
|
C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP ***************************
|
|
C
|
|
FH6AB = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE
|
|
C
|
|
RETURN
|
|
C
|
|
C *** END OF FUNCTION FUNCH6A *******************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCI6
|
|
C *** CASE I6
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0)
|
|
C 2. SOLID & LIQUID AEROSOL POSSIBLE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCI6
|
|
INCLUDE 'isrpia_adj.inc'
|
|
REAL*8 :: AERLIQ(NIONS+NGASAQ+2), GAS(3)
|
|
C
|
|
C *** FIND DRY COMPOSITION **********************************************
|
|
C
|
|
C CALL CALCI1A
|
|
C
|
|
C *** CALCULATE NON VOLATILE SOLIDS ***********************************
|
|
C
|
|
CNA2SO4 = 0.5D0*W(1)
|
|
CNH4HS4 = ZERO
|
|
CNAHSO4 = ZERO
|
|
CNH42S4 = ZERO
|
|
FRSO4 = MAX(W(2)-CNA2SO4, ZERO)
|
|
C
|
|
CLC = MIN(W(3)/3.D0, FRSO4/2.D0)
|
|
FRSO4 = MAX(FRSO4-2.D0*CLC, ZERO)
|
|
FRNH4 = MAX(W(3)-3.D0*CLC, ZERO)
|
|
C
|
|
IF (FRSO4 <= TINY) THEN
|
|
CLC = MAX(CLC - FRNH4, ZERO)
|
|
CNH42S4 = 2.D0*FRNH4
|
|
|
|
ELSEIF (FRNH4 <= TINY) THEN
|
|
CNH4HS4 = 3.D0*MIN(FRSO4, CLC)
|
|
CLC = MAX(CLC-FRSO4, ZERO)
|
|
IF (CNA2SO4 > TINY) THEN
|
|
FRSO4 = MAX(FRSO4-CNH4HS4/3.D0, ZERO)
|
|
CNAHSO4 = 2.D0*FRSO4
|
|
CNA2SO4 = MAX(CNA2SO4-FRSO4, ZERO)
|
|
ENDIF
|
|
ENDIF
|
|
C
|
|
C *** CALCULATE GAS SPECIES *********************************************
|
|
C
|
|
GHNO3 = W(4)
|
|
GHCL = W(5)
|
|
GNH3 = ZERO
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
CHI1 = CNH4HS4 ! Save from CALCI1 run
|
|
CHI2 = CLC
|
|
CHI3 = CNAHSO4
|
|
CHI4 = CNA2SO4
|
|
CHI5 = CNH42S4
|
|
C
|
|
PSI1 = CNH4HS4 ! ASSIGN INITIAL PSI's
|
|
PSI2 = CLC
|
|
PSI3 = CNAHSO4
|
|
PSI4 = CNA2SO4
|
|
PSI5 = CNH42S4
|
|
C
|
|
CALAOU = .TRUE. ! Outer loop activity calculation flag
|
|
FRST = .TRUE.
|
|
CALAIN = .TRUE.
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
J = 1
|
|
DO WHILE ((J <= NSWEEP).AND.(CALAIN))
|
|
C
|
|
A6 = XK1 *WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.d0
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
BB = PSI2 + PSI4 + PSI5 + A6 ! PSI6
|
|
CC = -A6*(PSI2 + PSI3 + PSI1)
|
|
DD = BB*BB - 4.D0*CC
|
|
PSI6 = 0.5D0*(-BB + SQRT(DD))
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
MOLAL (1) = PSI6 ! HI
|
|
MOLAL (2) = 2.D0*PSI4 + PSI3 ! NAI
|
|
MOLAL (3) = 3.D0*PSI2 + 2.D0*PSI5 + PSI1 ! NH4I
|
|
MOLAL (5) = PSI2 + PSI4 + PSI5 + PSI6 ! SO4I
|
|
MOLAL (6) = PSI2 + PSI3 + PSI1 - PSI6 ! HSO4I
|
|
CLC = ZERO
|
|
CNAHSO4 = ZERO
|
|
CNA2SO4 = CHI4 - PSI4
|
|
CNH42S4 = ZERO
|
|
CNH4HS4 = ZERO
|
|
|
|
MOLALR(04) = PSI5 ! (NH4)2SO4
|
|
MOLALR(02) = PSI4 ! NA2SO4
|
|
MOLALR(09) = PSI1 ! NH4HSO4
|
|
MOLALR(12) = PSI3 ! NAHSO4
|
|
MOLALR(13) = PSI2 ! LC
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
WATER = ZERO
|
|
DO I=1,NPAIR
|
|
WATER = WATER + MOLALR(I)/M0(I)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3
|
|
J = J+1
|
|
ENDDO
|
|
|
|
IF (CALAIN .AND. (J > (NSWEEP+1))) THEN
|
|
CALL PUSHERR (0001, 'CALCI6') ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
C
|
|
20 RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCI6 *****************************************
|
|
C
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCJ3
|
|
C *** CASE J3
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0)
|
|
C 2. THERE IS ONLY A LIQUID PHASE
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCJ3
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
INTEGER :: J
|
|
REAL*8 :: LAMDA, KAPA
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
CALAOU = .TRUE. ! Outer loop activity calculation flag
|
|
FRST = .TRUE.
|
|
CALAIN = .TRUE.
|
|
C
|
|
LAMDA = MAX(W(2) - W(3) - W(1), TINY) ! FREE H2SO4
|
|
CHI1 = W(1) ! NA TOTAL as NaHSO4
|
|
CHI2 = W(3) ! NH4 TOTAL as NH4HSO4
|
|
PSI1 = CHI1
|
|
PSI2 = CHI2 ! ALL NH4HSO4 DELIQUESCED
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
J = 1
|
|
DO WHILE ((J <= NSWEEP).AND.(CALAIN))
|
|
C
|
|
A3 = XK1 *WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.0
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
BB = A3+LAMDA ! KAPA
|
|
CC =-A3*(LAMDA + PSI1 + PSI2)
|
|
DD = BB*BB-4.D0*CC
|
|
KAPA = 0.5D0*(-BB+SQRT(DD))
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
MOLAL (1) = LAMDA + KAPA ! HI
|
|
MOLAL (2) = PSI1 ! NAI
|
|
MOLAL (3) = PSI2 ! NH4I
|
|
MOLAL (4) = ZERO ! CLI
|
|
MOLAL (5) = KAPA ! SO4I
|
|
MOLAL (6) = LAMDA + PSI1 + PSI2 - KAPA ! HSO4I
|
|
MOLAL (7) = ZERO ! NO3I
|
|
C
|
|
CNAHSO4 = ZERO
|
|
CNH4HS4 = ZERO
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
MOLALR(09) = MOLAL(3) ! NH4HSO4
|
|
MOLALR(12) = MOLAL(2) ! NAHSO4
|
|
MOLALR(07) = MOLAL(5)+MOLAL(6)-MOLAL(3)-MOLAL(2) ! H2SO4
|
|
MOLALR(07) = MAX(MOLALR(07),ZERO)
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
WATER = ZERO
|
|
DO I=1,NPAIR
|
|
WATER = WATER + MOLALR(I)/M0(I)
|
|
ENDDO
|
|
WATER = MAX(WATER, TINY)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3
|
|
J = J+1
|
|
ENDDO
|
|
|
|
IF (CALAIN .AND. (J > (NSWEEP+1))) THEN
|
|
CALL PUSHERR (0001, 'CALCJ3') ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
C
|
|
50 RETURN
|
|
C
|
|
C *** END OF SUBROUTINE CALCJ3 ******************************************
|
|
C
|
|
END
|
|
|
|
|
|
C
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of isrp1fa in reverse (adjoint) mode:
|
|
C gradient of useful results: aerliq gas
|
|
C with respect to varying inputs: wp aerliq gas
|
|
C RW status of diff variables: wp:out aerliq:in-out gas:in-out
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ISRP1F_AB
|
|
C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FOREWARD PROBLEM OF
|
|
C AN AMMONIUM-SULFATE AEROSOL SYSTEM.
|
|
C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY
|
|
C THE AMBIENT RELATIVE HUMIDITY.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISRP1FA_AB(wpab, gasab, aerliqab)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
|
|
REAL*8 :: wpab(ncomp)
|
|
REAL*8 :: dc, gas(3), aerliq(nions+ngasaq+2)
|
|
REAL*8 :: dcab, gasab(3), aerliqab(nions+ngasaq+2)
|
|
INTEGER :: i, npflag, ncase
|
|
INTEGER :: branch
|
|
INTRINSIC MAX
|
|
REAL*8 :: max1ab
|
|
INTEGER :: ii1
|
|
REAL*8 :: max1
|
|
C
|
|
C For numerical stability
|
|
dc = w(3) - 2.001d0*w(2)
|
|
IF (-dc .LT. zero) THEN
|
|
max1 = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
max1 = -dc
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
w(3) = w(3) + max1
|
|
C
|
|
C Only liquid (metastable)
|
|
C Gaseous aerosol species
|
|
DO ii1=1,nions
|
|
molalab(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=nions,1,-1
|
|
molalab(i) = molalab(i) + aerliqab(i)
|
|
ENDDO
|
|
aerliqab = 0.D0
|
|
gasab(3) = 0.D0
|
|
gasab(2) = 0.D0
|
|
gnh3ab = gasab(1)
|
|
gasab(1) = 0.D0
|
|
CALL CALCA2_AB()
|
|
max1ab = wab(3)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch .EQ. 0) THEN
|
|
dcab = 0.D0
|
|
ELSE
|
|
dcab = -max1ab
|
|
END IF
|
|
wab(3) = wab(3) + dcab
|
|
wab(2) = wab(2) - 2.001d0*dcab
|
|
wpab = wab
|
|
C
|
|
END
|
|
|
|
C Differentiation of calca2 in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gnh3
|
|
C with respect to varying inputs: w
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCA2
|
|
C *** CASE A2
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0)
|
|
C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE
|
|
C
|
|
C FOR CALCULATIONS, A !!!!!BISECTION IS PERFORMED TOWARDS X, THE
|
|
C AMOUNT OF HYDROGEN IONS (H+) FOUND IN THE LIQUID PHASE.
|
|
C FOR EACH ESTIMATION OF H+, FUNCTION FUNCB2A CALCULATES THE
|
|
C CONCENTRATION OF IONS FROM THE NH3(GAS) - NH4+(LIQ) EQUILIBRIUM.
|
|
C ELECTRONEUTRALITY IS USED AS THE OBJECTIVE FUNCTION.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCA2_AB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: delta
|
|
REAL*8 :: deltaab
|
|
INTEGER :: i
|
|
INTEGER :: ii1
|
|
INTEGER :: branch
|
|
INTRINSIC :: MAX
|
|
REAL*8 :: molalrab(npair)
|
|
C
|
|
C *** CALCULATE WATER CONTENT *****************************************
|
|
C
|
|
molal(5) = w(2)
|
|
molal(6) = zero
|
|
C
|
|
C CALL CALCMR
|
|
C
|
|
C (NH4)2SO4 - CORRECT FOR SO4 TO HSO4
|
|
molalr(4) = molal(5) + molal(6)
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
DO i=1,npair
|
|
water = water + molalr(i)/m0(i)
|
|
ENDDO
|
|
IF (water .LT. tiny) THEN
|
|
water = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
CALL PUSHINTEGER4(iclact)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
C
|
|
C *** CREATE ITERATION FOR ACTIVITY COEFFICIENTS
|
|
C
|
|
CALL FUNCA2P()
|
|
C
|
|
IF (molal(1) .GT. tiny) THEN
|
|
deltaab = molalab(6)
|
|
molalab(6) = 0.D0
|
|
deltaab = deltaab - molalab(1) - molalab(5)
|
|
CALL CALCHS4_AB(molal(1), molalab(1), molal(5), molalab(5), zero
|
|
+ , delta, deltaab)
|
|
ELSE
|
|
DO ii1=1,npair
|
|
gamaab(ii1) = 0.D0
|
|
ENDDO
|
|
waterab = 0.D0
|
|
END IF
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPINTEGER4(iclact)
|
|
CALL FUNCA2P_AB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch .EQ. 0) waterab = 0.D0
|
|
DO ii1=1,npair
|
|
molalrab(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=npair,1,-1
|
|
molalrab(i) = molalrab(i) + waterab/m0(i)
|
|
ENDDO
|
|
molalab(5) = molalab(5) + molalrab(4)
|
|
molalab(6) = 0.D0
|
|
wab(2) = wab(2) + molalab(5)
|
|
END
|
|
|
|
C Differentiation of funca2p in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water gnh3
|
|
C with respect to varying inputs: w molal water
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** FUNCTION FUNCA2P
|
|
C *** CASE A2
|
|
C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE A2 ;
|
|
C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCA2P.
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCA2P_AB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: lamda, disc, sqdr, thrshhi, thrshlo
|
|
REAL*8 :: discab, sqdrab
|
|
REAL*8 :: ncon, qcon, ucon, uconold
|
|
REAL*8 :: qconab, uconab
|
|
REAL*8 :: w2, w3
|
|
REAL*8 :: w2ab, w3ab
|
|
LOGICAL tst, tst2
|
|
INTEGER :: i
|
|
REAL*8 :: aa
|
|
REAL*8 :: aaab
|
|
REAL*8 :: bb
|
|
REAL*8 :: bbab
|
|
REAL*8 :: cc
|
|
REAL*8 :: ccab
|
|
REAL*8 :: rt1
|
|
REAL*8 :: rt1ab
|
|
REAL*8 :: rt2
|
|
REAL*8 :: rt2ab
|
|
INTEGER :: branch
|
|
INTEGER :: ad_count
|
|
INTEGER :: i0
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp1ab0
|
|
REAL*8 :: temp0ab
|
|
REAL*8 :: temp1ab
|
|
INTEGER :: ii1
|
|
INTRINSIC :: SQRT
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
tst = .true.
|
|
tst2 = .true.
|
|
C INITIAL AMOUNT OF (NH4)2SO4 IN SOLUTION
|
|
w2 = w(2)
|
|
w3 = w(3)
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
i = 1
|
|
ucon = 0.d0
|
|
ad_count = 0
|
|
DO WHILE (i .LE. 14 .AND. tst .AND. tst2)
|
|
C DO I=1,14 !NSWEEP
|
|
uconold = ucon
|
|
CALL PUSHREAL8(a2)
|
|
a2 = xk2*r*temp/xkw*(gama(8)/gama(9))**2.
|
|
CALL PUSHREAL8(aa)
|
|
C
|
|
aa = -a2
|
|
CALL PUSHREAL8(bb)
|
|
bb = a2*w3 - 2.d0*a2*w2 + 1
|
|
cc = 2.d0*w2
|
|
disc = bb*bb - 4.d0*aa*cc
|
|
CALL PUSHREAL8(sqdr)
|
|
sqdr = SQRT(disc)
|
|
C
|
|
rt1 = (-bb+sqdr)/2.d0/aa
|
|
rt2 = (-bb-sqdr)/2.d0/aa
|
|
C WRITE(*,*) 'ROOTS', RT1, RT2
|
|
C
|
|
IF (rt1 .LT. zero .AND. rt2 .GE. zero) THEN
|
|
ucon = rt1
|
|
CALL PUSHCONTROL2B(0)
|
|
ELSE IF (rt2 .LT. zero .AND. rt1 .GE. zero) THEN
|
|
ucon = rt2
|
|
CALL PUSHCONTROL2B(1)
|
|
ELSE
|
|
tst2 = .false.
|
|
CALL PUSHCONTROL2B(2)
|
|
END IF
|
|
C
|
|
qcon = -ucon
|
|
CALL PUSHREAL8(molal(1))
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
C HI
|
|
molal(1) = qcon
|
|
C MOLAL (3) = MAX(W(3)/(ONE/A2/OMEGI + ONE), 2.*MOLAL(5)) ! NH4I
|
|
C MOLAL (3) = MAX(2.D0*W2 + UCON, TINY) ! NH4I
|
|
IF (tiny .GT. 2.d0*w2 + ucon) THEN
|
|
CALL PUSHREAL8(molal(3))
|
|
molal(3) = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(molal(3))
|
|
molal(3) = 2.d0*w2 + ucon
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8(molal(5))
|
|
C SO4I
|
|
molal(5) = w2
|
|
CALL PUSHREAL8(molal(6))
|
|
C HSO4I
|
|
molal(6) = zero
|
|
C GNH3 = MAX(W(3)-MOLAL(3), TINY) ! NH3GI
|
|
IF (tiny .GT. w(3) - molal(3)) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C OHI
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3P()
|
|
thrshlo = uconold - uconold*1.0d-15
|
|
thrshhi = uconold + uconold*1.0d-15
|
|
IF (ucon .LE. thrshlo .AND. ucon .GE. thrshhi) THEN
|
|
tst = .false.
|
|
ELSE
|
|
tst = .true.
|
|
END IF
|
|
C CALL CALCACT
|
|
C ELSE
|
|
C GOTO 20
|
|
C ENDIF
|
|
i = i + 1
|
|
ad_count = ad_count + 1
|
|
ENDDO
|
|
DO ii1=1,ncomp
|
|
wab(ii1) = 0.D0
|
|
ENDDO
|
|
uconab = 0.D0
|
|
w2ab = 0.D0
|
|
w3ab = 0.D0
|
|
DO i0=1,ad_count
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3P_AB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch .NE. 0) THEN
|
|
wab(3) = wab(3) + gnh3ab
|
|
molalab(3) = molalab(3) - gnh3ab
|
|
END IF
|
|
CALL POPREAL8(molal(6))
|
|
molalab(6) = 0.D0
|
|
CALL POPREAL8(molal(5))
|
|
w2ab = w2ab + molalab(5)
|
|
molalab(5) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch .EQ. 0) THEN
|
|
CALL POPREAL8(molal(3))
|
|
molalab(3) = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(molal(3))
|
|
w2ab = w2ab + 2.d0*molalab(3)
|
|
uconab = uconab + molalab(3)
|
|
molalab(3) = 0.D0
|
|
END IF
|
|
CALL POPREAL8(molal(1))
|
|
qconab = molalab(1)
|
|
molalab(1) = 0.D0
|
|
uconab = uconab - qconab
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch .EQ. 0) THEN
|
|
rt1ab = uconab
|
|
rt2ab = 0.D0
|
|
uconab = 0.D0
|
|
ELSE
|
|
IF (branch .EQ. 1) THEN
|
|
rt2ab = uconab
|
|
uconab = 0.D0
|
|
ELSE
|
|
rt2ab = 0.D0
|
|
END IF
|
|
rt1ab = 0.D0
|
|
END IF
|
|
temp1ab0 = rt1ab/(2.d0*aa)
|
|
temp1ab = rt2ab/(2.d0*aa)
|
|
sqdrab = temp1ab0 - temp1ab
|
|
cc = 2.d0*w2
|
|
disc = bb*bb - 4.d0*aa*cc
|
|
IF (disc .EQ. 0.0) THEN
|
|
discab = 0.0
|
|
ELSE
|
|
discab = sqdrab/(2.0*SQRT(disc))
|
|
END IF
|
|
bbab = 2*bb*discab - temp1ab0 - temp1ab
|
|
aaab = -((sqdr-bb)*temp1ab0/aa) - 4.d0*cc*discab - (-bb-sqdr)*
|
|
+ temp1ab/aa
|
|
CALL POPREAL8(sqdr)
|
|
ccab = -(4.d0*aa*discab)
|
|
w2ab = w2ab + 2.d0*ccab - 2.d0*a2*bbab
|
|
CALL POPREAL8(bb)
|
|
a2ab = (w3-2.d0*w2)*bbab - aaab
|
|
w3ab = w3ab + a2*bbab
|
|
CALL POPREAL8(aa)
|
|
CALL POPREAL8(a2)
|
|
temp0 = gama(8)/gama(9)
|
|
temp0ab = 2.*temp0*xk2*r*temp*a2ab/(xkw*gama(9))
|
|
gamaab(8) = gamaab(8) + temp0ab
|
|
gamaab(9) = gamaab(9) - temp0*temp0ab
|
|
gnh3ab = 0.D0
|
|
ENDDO
|
|
wab(3) = wab(3) + w3ab
|
|
wab(2) = wab(2) + w2ab
|
|
END
|
|
|
|
C Differentiation of calchs4 in reverse (adjoint) mode:
|
|
C gradient of useful results: hi so4i delta
|
|
C with respect to varying inputs: gama water hi so4i
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCHS4
|
|
C *** THIS SUBROUTINE CALCULATES THE HSO4 GENERATED FROM (H,SO4).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCHS4_AB(hi, hiab, so4i, so4iab, hso4i, delta,
|
|
+ deltaab)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: hi, so4i, hso4i, delta, bb, cc, dd, sqdd, delta1
|
|
+ , delta2
|
|
REAL*8 :: hiab, so4iab, deltaab, bbab, ccab, ddab, sqddab,
|
|
+ delta1ab, delta2ab
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0ab
|
|
REAL*8 :: temp1ab
|
|
INTEGER :: ii1
|
|
INTRINSIC :: SQRT
|
|
C
|
|
C *** IF TOO LITTLE WATER, DONT SOLVE
|
|
C
|
|
IF (water .LE. 1d1*tiny) THEN
|
|
DO ii1=1,npair
|
|
gamaab(ii1) = 0.D0
|
|
ENDDO
|
|
waterab = 0.D0
|
|
ELSE
|
|
C
|
|
C *** CALCULATE HSO4 SPECIATION *****************************************
|
|
C
|
|
a8 = xk1*water/gama(7)*(gama(8)/gama(7))**2.
|
|
C
|
|
bb = -(hi+so4i+a8)
|
|
cc = hi*so4i - hso4i*a8
|
|
dd = bb*bb - 4.d0*cc
|
|
C
|
|
IF (dd .GE. zero) THEN
|
|
IF (hso4i .LE. tiny) THEN
|
|
delta2ab = deltaab
|
|
delta1ab = 0.D0
|
|
ELSE IF (hi*so4i .GE. a8*hso4i) THEN
|
|
delta2ab = deltaab
|
|
delta1ab = 0.D0
|
|
ELSE
|
|
IF (hi*so4i .LT. a8*hso4i) THEN
|
|
delta1ab = deltaab
|
|
ELSE
|
|
delta1ab = 0.D0
|
|
END IF
|
|
delta2ab = 0.D0
|
|
END IF
|
|
bbab = -(0.5*delta1ab) - 0.5*delta2ab
|
|
sqddab = 0.5*delta1ab - 0.5*delta2ab
|
|
IF (dd .EQ. 0.0) THEN
|
|
ddab = 0.0
|
|
ELSE
|
|
ddab = sqddab/(2.0*SQRT(dd))
|
|
END IF
|
|
ELSE
|
|
ddab = 0.D0
|
|
bbab = 0.D0
|
|
END IF
|
|
bbab = bbab + 2*bb*ddab
|
|
ccab = -(4.d0*ddab)
|
|
hiab = hiab + so4i*ccab - bbab
|
|
so4iab = so4iab + hi*ccab - bbab
|
|
a8ab = -bbab - hso4i*ccab
|
|
DO ii1=1,npair
|
|
gamaab(ii1) = 0.D0
|
|
ENDDO
|
|
temp0 = water/gama(7)
|
|
temp1 = gama(8)/gama(7)
|
|
temp1ab = 2.*temp1*temp0*xk1*a8ab/gama(7)
|
|
temp0ab = temp1**2.*xk1*a8ab/gama(7)
|
|
gamaab(8) = gamaab(8) + temp1ab
|
|
gamaab(7) = gamaab(7) - temp0*temp0ab - temp1*temp1ab
|
|
waterab = temp0ab
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of calcact3p in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3P_AB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0ab(6, 4), sionab, hab, chab, f1ab(3), f2ab(4)
|
|
REAL*8 :: mpl, xij, yji, ionicab
|
|
REAL*8 :: mplab, xijab, yjiab
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01ab
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02ab
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03ab
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04ab
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05ab
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06ab
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07ab
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08ab
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09ab
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10ab
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11ab
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12ab
|
|
INTEGER :: j
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0ab0
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2ab
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: temp0ab
|
|
INTRINSIC MIN
|
|
REAL*8 :: x1ab
|
|
REAL*8 :: temp0ab13
|
|
REAL*8 :: temp0ab12
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
REAL*8 :: temp0ab11
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp0ab9
|
|
REAL*8 :: temp0ab10
|
|
REAL*8 :: temp0ab8
|
|
REAL*8 :: temp0ab7
|
|
REAL*8 :: temp0ab6
|
|
REAL*8 :: temp0ab5
|
|
REAL*8 :: temp0ab4
|
|
REAL*8 :: temp0ab3
|
|
REAL*8 :: temp0ab2
|
|
REAL*8 :: temp0ab1
|
|
C
|
|
C
|
|
C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
DO i=1,7
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water .GT. 200.d0) THEN
|
|
x1 = 200.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 .LT. tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08,
|
|
+ g09, g10, g11, g12)
|
|
C
|
|
g0(1, 1) = g11
|
|
g0(1, 2) = g07
|
|
g0(1, 3) = g08
|
|
g0(1, 4) = g10
|
|
g0(2, 1) = g01
|
|
g0(2, 2) = g02
|
|
g0(2, 3) = g12
|
|
g0(2, 4) = g03
|
|
g0(3, 1) = g06
|
|
g0(3, 2) = g04
|
|
g0(3, 3) = g09
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
sion = SQRT(ionic)
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
yji = ch*molal(j+3)/water
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gama(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gama(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gama(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gama(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gama(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gama(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gama(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gama(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gama(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gama(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gama(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gama(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gama(13))
|
|
C LC ; SCAPE
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) .GT. 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
ELSE
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 .LT. -5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
gamaab(i) = 10.d0**gama(i)*LOG(10.d0)*gamaab(i)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch .EQ. 0) THEN
|
|
gamaab(i) = 0.D0
|
|
x2ab = 0.D0
|
|
ELSE
|
|
x2ab = gamaab(i)
|
|
gamaab(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch .NE. 0) gamaab(i) = gamaab(i) + x2ab
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamaab(4) = gamaab(4) + 0.2d0*3.d0*gamaab(13)
|
|
gamaab(9) = gamaab(9) + 0.2d0*2.d0*gamaab(13)
|
|
gamaab(13) = 0.D0
|
|
DO ii1=1,3
|
|
f1ab(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2ab(ii1) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp0ab2 = zz(12)*gamaab(12)/(z(2)+z(6))
|
|
f1ab(2) = f1ab(2) + temp0ab2/z(2)
|
|
f2ab(3) = f2ab(3) + temp0ab2/z(6)
|
|
hab = -(zz(12)*gamaab(12))
|
|
gamaab(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp0ab3 = zz(11)*gamaab(11)/(z(1)+z(4))
|
|
f2ab(1) = f2ab(1) + temp0ab3/z(4)
|
|
hab = hab - zz(11)*gamaab(11)
|
|
gamaab(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp0ab4 = zz(10)*gamaab(10)/(z(1)+z(7))
|
|
f1ab(1) = f1ab(1) + temp0ab4/z(1) + temp0ab3/z(1)
|
|
f2ab(4) = f2ab(4) + temp0ab4/z(7)
|
|
hab = hab - zz(10)*gamaab(10)
|
|
gamaab(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp0ab5 = zz(9)*gamaab(9)/(z(3)+z(6))
|
|
f1ab(3) = f1ab(3) + temp0ab5/z(3)
|
|
hab = hab - zz(9)*gamaab(9)
|
|
gamaab(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp0ab6 = zz(8)*gamaab(8)/(z(1)+z(6))
|
|
f2ab(3) = f2ab(3) + temp0ab6/z(6) + temp0ab5/z(6)
|
|
hab = hab - zz(8)*gamaab(8)
|
|
gamaab(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp0ab7 = zz(7)*gamaab(7)/(z(1)+z(5))
|
|
f1ab(1) = f1ab(1) + temp0ab7/z(1) + temp0ab6/z(1)
|
|
f2ab(2) = f2ab(2) + temp0ab7/z(5)
|
|
hab = hab - zz(7)*gamaab(7)
|
|
gamaab(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp0ab8 = zz(6)*gamaab(6)/(z(3)+z(4))
|
|
f2ab(1) = f2ab(1) + temp0ab8/z(4)
|
|
hab = hab - zz(6)*gamaab(6)
|
|
gamaab(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp0ab9 = zz(5)*gamaab(5)/(z(3)+z(7))
|
|
f2ab(4) = f2ab(4) + temp0ab9/z(7)
|
|
hab = hab - zz(5)*gamaab(5)
|
|
gamaab(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp0ab10 = zz(4)*gamaab(4)/(z(3)+z(5))
|
|
f1ab(3) = f1ab(3) + temp0ab9/z(3) + temp0ab10/z(3) + temp0ab8/z(3)
|
|
f2ab(2) = f2ab(2) + temp0ab10/z(5)
|
|
hab = hab - zz(4)*gamaab(4)
|
|
gamaab(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp0ab11 = zz(3)*gamaab(3)/(z(2)+z(7))
|
|
f2ab(4) = f2ab(4) + temp0ab11/z(7)
|
|
hab = hab - zz(3)*gamaab(3)
|
|
gamaab(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp0ab12 = zz(2)*gamaab(2)/(z(2)+z(5))
|
|
f2ab(2) = f2ab(2) + temp0ab12/z(5)
|
|
hab = hab - zz(2)*gamaab(2)
|
|
gamaab(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp0ab13 = zz(1)*gamaab(1)/(z(2)+z(4))
|
|
f1ab(2) = f1ab(2) + temp0ab12/z(2) + temp0ab13/z(2) + temp0ab11/z(
|
|
+ 2)
|
|
f2ab(1) = f2ab(1) + temp0ab13/z(4)
|
|
hab = hab - zz(1)*gamaab(1)
|
|
gamaab(1) = 0.D0
|
|
ionicab = 0.D0
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0ab(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mplab = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijab = (g0(i, j)+zpl*zmi*h)*f2ab(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0ab(i, j) = g0ab(i, j) + yji*f1ab(i) + xij*f2ab(j)
|
|
hab = hab + yji*zpl*zmi*f1ab(i) + xij*zpl*zmi*f2ab(j)
|
|
yjiab = (g0(i, j)+zpl*zmi*h)*f1ab(i)
|
|
temp0ab1 = molal(j+3)*yjiab/water
|
|
molalab(j+3) = molalab(j+3) + ch*yjiab/water
|
|
chab = mpl*xijab + temp0ab1
|
|
waterab = waterab - ch*temp0ab1/water
|
|
mplab = mplab + ch*xijab
|
|
ionicab = ionicab - (zpl+zmi)**2*0.25d0*chab/ionic**2
|
|
ENDDO
|
|
CALL POPREAL8(mpl)
|
|
molalab(i) = molalab(i) + mplab/water
|
|
waterab = waterab - molal(i)*mplab/water**2
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp0ab0 = agama*hab/(sion+1.d0)
|
|
sionab = (1.D0-sion/(sion+1.d0))*temp0ab0
|
|
IF (.NOT.ionic .EQ. 0.0) ionicab = ionicab + sionab/(2.0*SQRT(
|
|
+ ionic))
|
|
g05ab = g0ab(3, 4)
|
|
g0ab(3, 4) = 0.D0
|
|
g09ab = g0ab(3, 3)
|
|
g0ab(3, 3) = 0.D0
|
|
g04ab = g0ab(3, 2)
|
|
g0ab(3, 2) = 0.D0
|
|
g06ab = g0ab(3, 1)
|
|
g0ab(3, 1) = 0.D0
|
|
g03ab = g0ab(2, 4)
|
|
g0ab(2, 4) = 0.D0
|
|
g12ab = g0ab(2, 3)
|
|
g0ab(2, 3) = 0.D0
|
|
g02ab = g0ab(2, 2)
|
|
g0ab(2, 2) = 0.D0
|
|
g01ab = g0ab(2, 1)
|
|
g0ab(2, 1) = 0.D0
|
|
g10ab = g0ab(1, 4)
|
|
g0ab(1, 4) = 0.D0
|
|
g08ab = g0ab(1, 3)
|
|
g0ab(1, 3) = 0.D0
|
|
g07ab = g0ab(1, 2)
|
|
g0ab(1, 2) = 0.D0
|
|
g11ab = g0ab(1, 1)
|
|
CALL KMFUL3_AB(ionic, ionicab, temp, g01, g01ab, g02, g02ab, g03,
|
|
+ g03ab, g04, g04ab, g05, g05ab, g06, g06ab, g07,
|
|
+ g07ab, g08, g08ab, g09, g09ab, g10, g10ab, g11,
|
|
+ g11ab, g12, g12ab)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch .EQ. 0) THEN
|
|
CALL POPREAL8(ionic)
|
|
x1ab = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1ab = ionicab
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch .EQ. 0) THEN
|
|
ionicab = 0.D0
|
|
ELSE
|
|
temp0ab = 0.5d0*x1ab/water
|
|
ionicab = temp0ab
|
|
waterab = waterab - ionic*temp0ab/water
|
|
END IF
|
|
DO i=7,1,-1
|
|
molalab(i) = molalab(i) + z(i)**2*ionicab
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of kmful3 in reverse (adjoint) mode:
|
|
C gradient of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12 ionic
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_AB(ionic, ionicab, temp, g01, g01ab, g02, g02ab
|
|
+ , g03, g03ab, g04, g04ab, g05, g05ab, g06,
|
|
+ g06ab, g07, g07ab, g08, g08ab, g09, g09ab,
|
|
+ g10, g10ab, g11, g11ab, g12, g12ab)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionicab, sionab, cf2ab
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01ab, g02ab, g03ab, g04ab, g05ab, g06ab, g07ab,
|
|
+ g08ab, g09ab, g10ab, g11ab, g12ab
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0ab0
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp0ab
|
|
REAL*8 :: abs1
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc .GE. 0.) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 .GT. 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01ab = g01ab + g12ab
|
|
g08ab = g08ab + g09ab + g12ab
|
|
g11ab = g11ab - g09ab - g12ab
|
|
g06ab = g06ab + g09ab
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch .EQ. 0) THEN
|
|
cf2ab = -(z10*g10ab) - z07*g07ab - z05*g05ab - z03*g03ab - z01*
|
|
+ g01ab - z02*g02ab - z04*g04ab - z06*g06ab - z08*g08ab - z11*
|
|
+ g11ab
|
|
g11ab = cf1*g11ab
|
|
g10ab = cf1*g10ab
|
|
g08ab = cf1*g08ab
|
|
g07ab = cf1*g07ab
|
|
g06ab = cf1*g06ab
|
|
g05ab = cf1*g05ab
|
|
g04ab = cf1*g04ab
|
|
g03ab = cf1*g03ab
|
|
g02ab = cf1*g02ab
|
|
g01ab = cf1*g01ab
|
|
temp0ab = (0.125d0-ti*0.005d0)*cf2ab
|
|
temp0ab0 = -(0.41d0*temp0ab/(sion+1.d0))
|
|
ionicab = ionicab + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0ab
|
|
sionab = (1.D0-sion/(sion+1.d0))*temp0ab0
|
|
ELSE
|
|
sionab = 0.D0
|
|
END IF
|
|
CALL MKBI_AB(q11, ionic, ionicab, sion, sionab, z11, g11, g11ab)
|
|
CALL MKBI_AB(q10, ionic, ionicab, sion, sionab, z10, g10, g10ab)
|
|
CALL MKBI_AB(q8, ionic, ionicab, sion, sionab, z08, g08, g08ab)
|
|
CALL MKBI_AB(q7, ionic, ionicab, sion, sionab, z07, g07, g07ab)
|
|
CALL MKBI_AB(q6, ionic, ionicab, sion, sionab, z06, g06, g06ab)
|
|
CALL MKBI_AB(q5, ionic, ionicab, sion, sionab, z05, g05, g05ab)
|
|
CALL MKBI_AB(q4, ionic, ionicab, sion, sionab, z04, g04, g04ab)
|
|
CALL MKBI_AB(q3, ionic, ionicab, sion, sionab, z03, g03, g03ab)
|
|
CALL MKBI_AB(q2, ionic, ionicab, sion, sionab, z02, g02, g02ab)
|
|
CALL MKBI_AB(q1, ionic, ionicab, sion, sionab, z01, g01, g01ab)
|
|
IF (.NOT.ionic .EQ. 0.0) ionicab = ionicab + sionab/(2.0*SQRT(
|
|
+ ionic))
|
|
END
|
|
|
|
C Differentiation of mkbi in reverse (adjoint) mode:
|
|
C gradient of useful results: sion bi ionic
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_AB(q, ionic, ionicab, sion, sionab, zip, bi, biab)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionicab, sionab, biab
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: cab, xxab
|
|
REAL*8 :: tempab
|
|
INTRINSIC EXP
|
|
REAL*8 :: tempab0
|
|
INTRINSIC LOG10
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC.LT.6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic))
|
|
bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b
|
|
C
|
|
xxab = zip*biab
|
|
biab = zip*biab/(bi*LOG(10.0))
|
|
tempab = -(0.5107d0*xxab/(c*sion+1.d0))
|
|
tempab0 = -(sion*tempab/(c*sion+1.d0))
|
|
sionab = sionab + c*tempab0 + tempab
|
|
cab = sion*tempab0
|
|
IF (.1d0*ionic + 1.d0 .LE. 0.0 .AND. (q .EQ. 0.0 .OR. q .NE. INT(q
|
|
+ ))) THEN
|
|
ionicab = ionicab - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*
|
|
+ ionic**2*cab
|
|
ELSE
|
|
ionicab = ionicab + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*biab -
|
|
+ .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cab
|
|
END IF
|
|
END
|
|
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of calcb4 in reverse (adjoint) mode:
|
|
C gradient of useful results: aerliq gas
|
|
C with respect to varying inputs: wp aerliq gas
|
|
C RW status of diff variables: wp:out aerliq:in-out gas:in-out
|
|
C
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCB4
|
|
C *** CASE B4
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0)
|
|
C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE
|
|
C
|
|
C FOR CALCULATIONS, A BISECTION IS PERFORMED WITH RESPECT TO H+.
|
|
C THE OBJECTIVE FUNCTION IS THE DIFFERENCE BETWEEN THE ESTIMATED H+
|
|
C AND THAT CALCULATED FROM ELECTRONEUTRALITY.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCB4_BB(wpbb, gasbb, aerliqbb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
|
|
REAL*8 :: x, y, so4i, hso4i, bb, cc, dd
|
|
REAL*8 :: so4ibb, hso4ibb, bbbb, ccbb, ddbb
|
|
REAL*8 :: gas(3), AERLIQ(NIONS+NGASAQ+2)
|
|
REAL*8 :: wpbb(ncomp), gasbb(3), aerliqbb(NIONS+NGASAQ+2)
|
|
REAL*8 :: wbb(ncomp)
|
|
INTEGER :: i
|
|
REAL*8 :: ak1
|
|
REAL*8 :: ak1bb
|
|
REAL*8 :: bet
|
|
REAL*8 :: betbb
|
|
REAL*8 :: gam
|
|
REAL*8 :: gambb
|
|
INTEGER :: j
|
|
INTEGER :: branch
|
|
INTEGER :: ad_count
|
|
INTEGER :: i0
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0bb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x4
|
|
REAL*8 :: x3
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x3bb
|
|
REAL*8 :: temp1bb
|
|
REAL*8 :: x1bb
|
|
REAL*8 :: x4bb
|
|
INTRINSIC MIN
|
|
REAL*8 :: temp2bb
|
|
INTEGER :: ii1, npflag, ncase
|
|
INTRINSIC SQRT
|
|
REAL*8 :: x2bb
|
|
REAL*8 :: molalrbb(npair)
|
|
C
|
|
C *** SOLVE EQUATIONS **************************************************
|
|
C
|
|
frst = .true.
|
|
calain = .true.
|
|
C
|
|
C *** CALCULATE WATER CONTENT ******************************************
|
|
C
|
|
C
|
|
C CALL CALCB1A ! GET DRY SALT CONTENT, AND USE FOR WATER.
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
C Equivalent NH4HSO4
|
|
x = 2.d0*w(2) - w(3)
|
|
C Equivalent (NH4)2SO4
|
|
y = w(3) - w(2)
|
|
C
|
|
C *** CALCULATE COMPOSITION *******************************************
|
|
C
|
|
IF (x <= y) THEN
|
|
C LC is the MIN(x,y)
|
|
CX ! NH4HSO4 >= (NH4)2S04
|
|
clc = 2.d0*w(2) - w(3)
|
|
cnh4hs4 = zero
|
|
CY-X
|
|
cnh42s4 = 2.d0*w(3) - 3.d0*w(2)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CY ! NH4HSO4 < (NH4)2S04
|
|
clc = w(3) - w(2)
|
|
CX-Y
|
|
cnh4hs4 = 3.d0*w(2) - 2.d0*w(3)
|
|
cnh42s4 = zero
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
molalr(13) = clc
|
|
molalr(9) = cnh4hs4
|
|
molalr(4) = cnh42s4
|
|
water = molalr(13)/m0(13) + molalr(9)/m0(9) + molalr(4)/m0(4)
|
|
C
|
|
C NH4I
|
|
molal(3) = w(3)
|
|
C
|
|
i = 1
|
|
ad_count = 0
|
|
C NSWEEP = 50
|
|
DO WHILE (i <= nsweep .AND. calain)
|
|
CALL PUSHREAL8(ak1)
|
|
C IF (I > 1) CALL CALCACT3
|
|
ak1 = xk1*(gama(8)/gama(7))**2.*(water/gama(7))
|
|
bet = w(2)
|
|
gam = molal(3)
|
|
CALL PUSHREAL8(bb)
|
|
C
|
|
bb = bet + ak1 - gam
|
|
cc = -(ak1*bet)
|
|
dd = bb*bb - 4.d0*cc
|
|
x4 = 0.5*(-bb+SQRT(dd))
|
|
IF (x4 > w(2)) THEN
|
|
x1 = w(2)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = x4
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(molal(5))
|
|
molal(5) = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(molal(5))
|
|
molal(5) = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (w(2) - molal(5) > w(2)) THEN
|
|
x2 = w(2)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x2 = w(2) - molal(5)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < tiny) THEN
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = x2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (ak1*molal(6)/molal(5) > w(2)) THEN
|
|
x3 = w(2)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x3 = ak1*molal(6)/molal(5)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x3 < tiny) THEN
|
|
CALL PUSHREAL8(molal(1))
|
|
molal(1) = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(molal(1))
|
|
molal(1) = x3
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C CORRECT FOR HSO4 DISSOCIATION
|
|
so4i = molal(5) - molal(1)
|
|
hso4i = molal(6) + molal(1)
|
|
IF (so4i < hso4i) THEN
|
|
C [LC] = [SO4]
|
|
molalr(13) = so4i
|
|
IF (hso4i - so4i < zero) THEN
|
|
molalr(9) = zero
|
|
CALL PUSHCONTROL2B(1)
|
|
ELSE
|
|
molalr(9) = hso4i - so4i
|
|
CALL PUSHCONTROL2B(0)
|
|
END IF
|
|
ELSE
|
|
C [LC] = [HSO4]
|
|
molalr(13) = hso4i
|
|
IF (so4i - hso4i < zero) THEN
|
|
molalr(4) = zero
|
|
CALL PUSHCONTROL2B(3)
|
|
ELSE
|
|
molalr(4) = so4i - hso4i
|
|
CALL PUSHCONTROL2B(2)
|
|
END IF
|
|
END IF
|
|
CALL PUSHREAL8(water)
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
DO j=1,npair
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
C IF (.NOT.CALAIN) GOTO 30
|
|
i = i + 1
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C*** slc.11.2009 moved to beginning of loop
|
|
CALL CALCACT3()
|
|
ad_count = ad_count + 1
|
|
ENDDO
|
|
IF (CALAIN .AND. (I > (NSWEEP+1))) THEN
|
|
CALL PUSHERR (0001, 'CALCB4') ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
CALL PUSHINTEGER4(ad_count)
|
|
DO ii1=1,nions
|
|
molalbb(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=nions,1,-1
|
|
molalbb(i) = molalbb(i) + aerliqbb(i)
|
|
ENDDO
|
|
aerliqbb = 0.D0
|
|
gasbb(3) = 0.D0
|
|
gasbb(2) = 0.D0
|
|
gnh3bb = gasbb(1)
|
|
gasbb(1) = 0.D0
|
|
CALL CALCNH3_BB()
|
|
DO ii1=1,ncomp
|
|
wbb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
molalrbb(ii1) = 0.D0
|
|
ENDDO
|
|
waterbb = 0.D0
|
|
CALL POPINTEGER4(ad_count)
|
|
DO i0=1,ad_count
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3_BB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) waterbb = 0.D0
|
|
DO j=npair,1,-1
|
|
molalrbb(j) = molalrbb(j) + waterbb/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(water)
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch < 2) THEN
|
|
IF (branch == 0) THEN
|
|
hso4ibb = molalrbb(9)
|
|
so4ibb = -molalrbb(9)
|
|
molalrbb(9) = 0.D0
|
|
ELSE
|
|
molalrbb(9) = 0.D0
|
|
hso4ibb = 0.D0
|
|
so4ibb = 0.D0
|
|
END IF
|
|
so4ibb = so4ibb + molalrbb(13)
|
|
molalrbb(13) = 0.D0
|
|
ELSE
|
|
IF (branch == 2) THEN
|
|
so4ibb = molalrbb(4)
|
|
hso4ibb = -molalrbb(4)
|
|
molalrbb(4) = 0.D0
|
|
ELSE
|
|
molalrbb(4) = 0.D0
|
|
hso4ibb = 0.D0
|
|
so4ibb = 0.D0
|
|
END IF
|
|
hso4ibb = hso4ibb + molalrbb(13)
|
|
molalrbb(13) = 0.D0
|
|
END IF
|
|
molalbb(6) = molalbb(6) + hso4ibb
|
|
molalbb(1) = molalbb(1) + hso4ibb
|
|
molalbb(5) = molalbb(5) + so4ibb
|
|
molalbb(1) = molalbb(1) - so4ibb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(molal(1))
|
|
molalbb(1) = 0.D0
|
|
x3bb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(molal(1))
|
|
x3bb = molalbb(1)
|
|
molalbb(1) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
wbb(2) = wbb(2) + x3bb
|
|
ak1 = xk1*(gama(8)/gama(7))**2.*(water/gama(7))
|
|
ak1bb = 0.D0
|
|
ELSE
|
|
temp2bb = x3bb/molal(5)
|
|
ak1bb = molal(6)*temp2bb
|
|
molalbb(6) = molalbb(6) + ak1*temp2bb
|
|
molalbb(5) = molalbb(5) - ak1*molal(6)*temp2bb/molal(5)
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(molal(6))
|
|
molalbb(6) = 0.D0
|
|
x2bb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(molal(6))
|
|
x2bb = molalbb(6)
|
|
molalbb(6) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
wbb(2) = wbb(2) + x2bb
|
|
ELSE
|
|
wbb(2) = wbb(2) + x2bb
|
|
molalbb(5) = molalbb(5) - x2bb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(molal(5))
|
|
molalbb(5) = 0.D0
|
|
x1bb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(molal(5))
|
|
x1bb = molalbb(5)
|
|
molalbb(5) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
wbb(2) = wbb(2) + x1bb
|
|
x4bb = 0.D0
|
|
ELSE
|
|
x4bb = x1bb
|
|
END IF
|
|
bet = w(2)
|
|
gam = molal(3)
|
|
bb = bet + ak1 - gam
|
|
cc = -(ak1*bet)
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (dd == 0.0) THEN
|
|
ddbb = 0.0
|
|
ELSE
|
|
ddbb = 0.5*x4bb/(2.0*SQRT(dd))
|
|
END IF
|
|
bbbb = 2*bb*ddbb - 0.5*x4bb
|
|
ccbb = -(4.d0*ddbb)
|
|
ak1bb = ak1bb + bbbb - bet*ccbb
|
|
betbb = bbbb - ak1*ccbb
|
|
CALL POPREAL8(bb)
|
|
gambb = -bbbb
|
|
molalbb(3) = molalbb(3) + gambb
|
|
wbb(2) = wbb(2) + betbb
|
|
CALL POPREAL8(ak1)
|
|
temp0 = water/gama(7)
|
|
temp1 = gama(8)/gama(7)
|
|
temp1bb = 2.*temp1*temp0*xk1*ak1bb/gama(7)
|
|
temp0bb = temp1**2.*xk1*ak1bb/gama(7)
|
|
gamabb(8) = gamabb(8) + temp1bb
|
|
gamabb(7) = gamabb(7) - temp0*temp0bb - temp1*temp1bb
|
|
waterbb = temp0bb
|
|
ENDDO
|
|
wbb(3) = wbb(3) + molalbb(3)
|
|
molalrbb(13) = molalrbb(13) + waterbb/m0(13)
|
|
molalrbb(9) = molalrbb(9) + waterbb/m0(9)
|
|
molalrbb(4) = molalrbb(4) + waterbb/m0(4)
|
|
cnh42s4bb = molalrbb(4)
|
|
molalrbb(4) = 0.D0
|
|
cnh4hs4bb = molalrbb(9)
|
|
molalrbb(9) = 0.D0
|
|
clcbb = molalrbb(13)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
wbb(3) = wbb(3) + 2.d0*cnh42s4bb
|
|
wbb(2) = wbb(2) + 2.d0*clcbb - 3.d0*cnh42s4bb
|
|
wbb(3) = wbb(3) - clcbb
|
|
ELSE
|
|
wbb(2) = wbb(2) + 3.d0*cnh4hs4bb
|
|
wbb(3) = wbb(3) + clcbb - 2.d0*cnh4hs4bb
|
|
wbb(2) = wbb(2) - clcbb
|
|
END IF
|
|
wpbb = wbb
|
|
|
|
END
|
|
C
|
|
C Differentiation of calcnh3 in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gnh3
|
|
C with respect to varying inputs: molal gama
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNH3
|
|
C *** CALCULATES AMMONIA IN GAS PHASE
|
|
C
|
|
C AMMONIA IN THE GAS PHASE IS ASSUMED A MINOR SPECIES, THAT
|
|
C DOES NOT SIGNIFICANTLY PERTURB THE AEROSOL EQUILIBRIUM.
|
|
C AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l)
|
|
C EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION.
|
|
C
|
|
C THIS IS THE VERSION USED BY THE DIRECT PROBLEM
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNH3_BB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
|
|
REAL*8 :: a1bb
|
|
REAL*8 :: chi1bb
|
|
REAL*8 :: chi2bb
|
|
C
|
|
REAL*8 :: bb, cc, diak, psi
|
|
REAL*8 :: bbbb, ccbb, diakbb, psibb
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0bb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x1
|
|
REAL*8 :: temp1bb
|
|
REAL*8 :: x1bb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** IS THERE A LIQUID PHASE? ******************************************
|
|
C
|
|
IF (water <= tiny) THEN
|
|
DO ii1=1,npair
|
|
gamabb(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
C
|
|
C *** CALCULATE NH3 SUBLIMATION *****************************************
|
|
C
|
|
a1 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
chi1 = molal(3)
|
|
chi2 = molal(1)
|
|
C
|
|
C a=1; b!=1; c!=1
|
|
bb = chi2 + one/a1
|
|
cc = -(chi1/a1)
|
|
C Always > 0
|
|
diak = SQRT(bb*bb - 4.d0*cc)
|
|
C One positive root
|
|
psi = 0.5*(-bb+diak)
|
|
IF (psi > chi1) THEN
|
|
x1 = chi1
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = psi
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
chi2bb = molalbb(1)
|
|
psibb = molalbb(1)
|
|
molalbb(1) = 0.D0
|
|
chi1bb = molalbb(3)
|
|
psibb = psibb + gnh3bb - molalbb(3)
|
|
molalbb(3) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
x1bb = 0.D0
|
|
ELSE
|
|
x1bb = psibb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
chi1bb = chi1bb + x1bb
|
|
psibb = 0.D0
|
|
ELSE
|
|
psibb = x1bb
|
|
END IF
|
|
diakbb = 0.5*psibb
|
|
IF (bb**2 - 4.d0*cc == 0.0) THEN
|
|
temp1bb = 0.0
|
|
ELSE
|
|
temp1bb = diakbb/(2.0*SQRT(bb**2-4.d0*cc))
|
|
END IF
|
|
bbbb = 2*bb*temp1bb - 0.5*psibb
|
|
ccbb = -(4.d0*temp1bb)
|
|
chi1bb = chi1bb - ccbb/a1
|
|
a1bb = chi1*ccbb/a1**2 - one*bbbb/a1**2
|
|
chi2bb = chi2bb + bbbb
|
|
molalbb(1) = molalbb(1) + chi2bb
|
|
molalbb(3) = molalbb(3) + chi1bb
|
|
DO ii1=1,npair
|
|
gamabb(ii1) = 0.D0
|
|
ENDDO
|
|
temp0 = gama(10)/gama(5)
|
|
temp0bb = 2.0*temp0*xk2*r*temp*a1bb/(xkw*gama(5))
|
|
gamabb(10) = gamabb(10) + temp0bb
|
|
gamabb(5) = gamabb(5) - temp0*temp0bb
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of calcact3 in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3_BB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2(4)
|
|
REAL*8 :: g0bb(6, 4), sionbb, hbb, chbb, f1bb(3), f2bb(4)
|
|
REAL*8 :: mpl, xij, yji, ionicbb
|
|
REAL*8 :: mplbb, xijbb, yjibb
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01bb
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02bb
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03bb
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04bb
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05bb
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06bb
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07bb
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08bb
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09bb
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10bb
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11bb
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12bb
|
|
INTEGER :: j
|
|
REAL*8 :: errou
|
|
REAL*8 :: errin
|
|
C
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0bb10
|
|
REAL*8 :: temp0bb
|
|
INTRINSIC MAX
|
|
INTRINSIC ABS
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: temp0bb9
|
|
REAL*8 :: temp0bb8
|
|
REAL*8 :: temp0bb7
|
|
REAL*8 :: temp0bb6
|
|
REAL*8 :: temp0bb5
|
|
REAL*8 :: temp0bb4
|
|
REAL*8 :: temp0bb3
|
|
REAL*8 :: temp0bb2
|
|
REAL*8 :: temp0bb1
|
|
REAL*8 :: temp0bb0
|
|
REAL*8 :: x1bb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: x2bb
|
|
REAL*8 :: temp0bb13
|
|
REAL*8 :: temp0bb12
|
|
REAL*8 :: y1
|
|
REAL*8 :: temp0bb11
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
DO i=1,7
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08,
|
|
+ g09, g10, g11, g12)
|
|
C
|
|
g0(1, 1) = g11
|
|
g0(1, 2) = g07
|
|
g0(1, 3) = g08
|
|
g0(1, 4) = g10
|
|
g0(2, 1) = g01
|
|
g0(2, 2) = g02
|
|
g0(2, 3) = g12
|
|
g0(2, 4) = g03
|
|
g0(3, 1) = g06
|
|
g0(3, 2) = g04
|
|
g0(3, 3) = g09
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
sion = SQRT(ionic)
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
yji = ch*molal(j+3)/water
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gama(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gama(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gama(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gama(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gama(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gama(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gama(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gama(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gama(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gama(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gama(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gama(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gama(13))
|
|
C LC ; SCAPE
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
ELSE
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
gamabb(i) = 10.d0**gama(i)*LOG(10.d0)*gamabb(i)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
gamabb(i) = 0.D0
|
|
x2bb = 0.D0
|
|
ELSE
|
|
x2bb = gamabb(i)
|
|
gamabb(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) gamabb(i) = gamabb(i) + x2bb
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamabb(4) = gamabb(4) + 0.2d0*3.d0*gamabb(13)
|
|
gamabb(9) = gamabb(9) + 0.2d0*2.d0*gamabb(13)
|
|
gamabb(13) = 0.D0
|
|
DO ii1=1,3
|
|
f1bb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2bb(ii1) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp0bb2 = zz(12)*gamabb(12)/(z(2)+z(6))
|
|
f1bb(2) = f1bb(2) + temp0bb2/z(2)
|
|
f2bb(3) = f2bb(3) + temp0bb2/z(6)
|
|
hbb = -(zz(12)*gamabb(12))
|
|
gamabb(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp0bb3 = zz(11)*gamabb(11)/(z(1)+z(4))
|
|
f2bb(1) = f2bb(1) + temp0bb3/z(4)
|
|
hbb = hbb - zz(11)*gamabb(11)
|
|
gamabb(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp0bb4 = zz(10)*gamabb(10)/(z(1)+z(7))
|
|
f1bb(1) = f1bb(1) + temp0bb4/z(1) + temp0bb3/z(1)
|
|
f2bb(4) = f2bb(4) + temp0bb4/z(7)
|
|
hbb = hbb - zz(10)*gamabb(10)
|
|
gamabb(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp0bb5 = zz(9)*gamabb(9)/(z(3)+z(6))
|
|
f1bb(3) = f1bb(3) + temp0bb5/z(3)
|
|
hbb = hbb - zz(9)*gamabb(9)
|
|
gamabb(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp0bb6 = zz(8)*gamabb(8)/(z(1)+z(6))
|
|
f2bb(3) = f2bb(3) + temp0bb6/z(6) + temp0bb5/z(6)
|
|
hbb = hbb - zz(8)*gamabb(8)
|
|
gamabb(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp0bb7 = zz(7)*gamabb(7)/(z(1)+z(5))
|
|
f1bb(1) = f1bb(1) + temp0bb7/z(1) + temp0bb6/z(1)
|
|
f2bb(2) = f2bb(2) + temp0bb7/z(5)
|
|
hbb = hbb - zz(7)*gamabb(7)
|
|
gamabb(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp0bb8 = zz(6)*gamabb(6)/(z(3)+z(4))
|
|
f2bb(1) = f2bb(1) + temp0bb8/z(4)
|
|
hbb = hbb - zz(6)*gamabb(6)
|
|
gamabb(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp0bb9 = zz(5)*gamabb(5)/(z(3)+z(7))
|
|
f2bb(4) = f2bb(4) + temp0bb9/z(7)
|
|
hbb = hbb - zz(5)*gamabb(5)
|
|
gamabb(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp0bb10 = zz(4)*gamabb(4)/(z(3)+z(5))
|
|
f1bb(3) = f1bb(3) + temp0bb9/z(3) + temp0bb10/z(3) + temp0bb8/z(3)
|
|
f2bb(2) = f2bb(2) + temp0bb10/z(5)
|
|
hbb = hbb - zz(4)*gamabb(4)
|
|
gamabb(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp0bb11 = zz(3)*gamabb(3)/(z(2)+z(7))
|
|
f2bb(4) = f2bb(4) + temp0bb11/z(7)
|
|
hbb = hbb - zz(3)*gamabb(3)
|
|
gamabb(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp0bb12 = zz(2)*gamabb(2)/(z(2)+z(5))
|
|
f2bb(2) = f2bb(2) + temp0bb12/z(5)
|
|
hbb = hbb - zz(2)*gamabb(2)
|
|
gamabb(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp0bb13 = zz(1)*gamabb(1)/(z(2)+z(4))
|
|
f1bb(2) = f1bb(2) + temp0bb12/z(2) + temp0bb13/z(2) + temp0bb11/z(
|
|
+ 2)
|
|
f2bb(1) = f2bb(1) + temp0bb13/z(4)
|
|
hbb = hbb - zz(1)*gamabb(1)
|
|
gamabb(1) = 0.D0
|
|
ionicbb = 0.D0
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0bb(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mplbb = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijbb = (g0(i, j)+zpl*zmi*h)*f2bb(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0bb(i, j) = g0bb(i, j) + yji*f1bb(i) + xij*f2bb(j)
|
|
hbb = hbb + yji*zpl*zmi*f1bb(i) + xij*zpl*zmi*f2bb(j)
|
|
yjibb = (g0(i, j)+zpl*zmi*h)*f1bb(i)
|
|
temp0bb1 = molal(j+3)*yjibb/water
|
|
molalbb(j+3) = molalbb(j+3) + ch*yjibb/water
|
|
chbb = mpl*xijbb + temp0bb1
|
|
waterbb = waterbb - ch*temp0bb1/water
|
|
mplbb = mplbb + ch*xijbb
|
|
ionicbb = ionicbb - (zpl+zmi)**2*0.25d0*chbb/ionic**2
|
|
ENDDO
|
|
CALL POPREAL8(mpl)
|
|
molalbb(i) = molalbb(i) + mplbb/water
|
|
waterbb = waterbb - molal(i)*mplbb/water**2
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp0bb0 = agama*hbb/(sion+1.d0)
|
|
sionbb = (1.D0-sion/(sion+1.d0))*temp0bb0
|
|
IF (.NOT.ionic == 0.0) ionicbb = ionicbb + sionbb/(2.0*SQRT(
|
|
+ ionic))
|
|
g05bb = g0bb(3, 4)
|
|
g0bb(3, 4) = 0.D0
|
|
g09bb = g0bb(3, 3)
|
|
g0bb(3, 3) = 0.D0
|
|
g04bb = g0bb(3, 2)
|
|
g0bb(3, 2) = 0.D0
|
|
g06bb = g0bb(3, 1)
|
|
g0bb(3, 1) = 0.D0
|
|
g03bb = g0bb(2, 4)
|
|
g0bb(2, 4) = 0.D0
|
|
g12bb = g0bb(2, 3)
|
|
g0bb(2, 3) = 0.D0
|
|
g02bb = g0bb(2, 2)
|
|
g0bb(2, 2) = 0.D0
|
|
g01bb = g0bb(2, 1)
|
|
g0bb(2, 1) = 0.D0
|
|
g10bb = g0bb(1, 4)
|
|
g0bb(1, 4) = 0.D0
|
|
g08bb = g0bb(1, 3)
|
|
g0bb(1, 3) = 0.D0
|
|
g07bb = g0bb(1, 2)
|
|
g0bb(1, 2) = 0.D0
|
|
g11bb = g0bb(1, 1)
|
|
CALL KMFUL3_BB(ionic, ionicbb, temp, g01, g01bb, g02, g02bb, g03,
|
|
+ g03bb, g04, g04bb, g05, g05bb, g06, g06bb, g07,
|
|
+ g07bb, g08, g08bb, g09, g09bb, g10, g10bb, g11,
|
|
+ g11bb, g12, g12bb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionic)
|
|
x1bb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1bb = ionicbb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ionicbb = 0.D0
|
|
ELSE
|
|
temp0bb = 0.5d0*x1bb/water
|
|
ionicbb = temp0bb
|
|
waterbb = waterbb - ionic*temp0bb/water
|
|
END IF
|
|
DO i=7,1,-1
|
|
molalbb(i) = molalbb(i) + z(i)**2*ionicbb
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of kmful3 in reverse (adjoint) mode:
|
|
C gradient of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12 ionic
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_BB(ionic, ionicbb, temp, g01, g01bb, g02, g02bb
|
|
+ , g03, g03bb, g04, g04bb, g05, g05bb, g06,
|
|
+ g06bb, g07, g07bb, g08, g08bb, g09, g09bb,
|
|
+ g10, g10bb, g11, g11bb, g12, g12bb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionicbb, sionbb, cf2bb
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01bb, g02bb, g03bb, g04bb, g05bb, g06bb, g07bb,
|
|
+ g08bb, g09bb, g10bb, g11bb, g12bb
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0bb
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp0bb0
|
|
REAL*8 :: abs1
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01bb = g01bb + g12bb
|
|
g08bb = g08bb + g09bb + g12bb
|
|
g11bb = g11bb - g09bb - g12bb
|
|
g06bb = g06bb + g09bb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2bb = -(z10*g10bb) - z07*g07bb - z05*g05bb - z03*g03bb - z01*
|
|
+ g01bb - z02*g02bb - z04*g04bb - z06*g06bb - z08*g08bb - z11*
|
|
+ g11bb
|
|
g11bb = cf1*g11bb
|
|
g10bb = cf1*g10bb
|
|
g08bb = cf1*g08bb
|
|
g07bb = cf1*g07bb
|
|
g06bb = cf1*g06bb
|
|
g05bb = cf1*g05bb
|
|
g04bb = cf1*g04bb
|
|
g03bb = cf1*g03bb
|
|
g02bb = cf1*g02bb
|
|
g01bb = cf1*g01bb
|
|
temp0bb = (0.125d0-ti*0.005d0)*cf2bb
|
|
temp0bb0 = -(0.41d0*temp0bb/(sion+1.d0))
|
|
ionicbb = ionicbb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0bb
|
|
sionbb = (1.D0-sion/(sion+1.d0))*temp0bb0
|
|
ELSE
|
|
sionbb = 0.D0
|
|
END IF
|
|
CALL MKBI_BB(q11, ionic, ionicbb, sion, sionbb, z11, g11, g11bb)
|
|
CALL MKBI_BB(q10, ionic, ionicbb, sion, sionbb, z10, g10, g10bb)
|
|
CALL MKBI_BB(q8, ionic, ionicbb, sion, sionbb, z08, g08, g08bb)
|
|
CALL MKBI_BB(q7, ionic, ionicbb, sion, sionbb, z07, g07, g07bb)
|
|
CALL MKBI_BB(q6, ionic, ionicbb, sion, sionbb, z06, g06, g06bb)
|
|
CALL MKBI_BB(q5, ionic, ionicbb, sion, sionbb, z05, g05, g05bb)
|
|
CALL MKBI_BB(q4, ionic, ionicbb, sion, sionbb, z04, g04, g04bb)
|
|
CALL MKBI_BB(q3, ionic, ionicbb, sion, sionbb, z03, g03, g03bb)
|
|
CALL MKBI_BB(q2, ionic, ionicbb, sion, sionbb, z02, g02, g02bb)
|
|
CALL MKBI_BB(q1, ionic, ionicbb, sion, sionbb, z01, g01, g01bb)
|
|
IF (.NOT.ionic == 0.0) ionicbb = ionicbb + sionbb/(2.0*SQRT(
|
|
+ ionic))
|
|
END
|
|
|
|
C Differentiation of mkbi in reverse (adjoint) mode:
|
|
C gradient of useful results: sion bi ionic
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_BB(q, ionic, ionicbb, sion, sionbb, zip, bi, bibb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionicbb, sionbb, bibb
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: cbb, xxbb
|
|
INTRINSIC EXP
|
|
REAL*8 :: tempbb0
|
|
REAL*8 :: tempbb
|
|
INTRINSIC LOG10
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic))
|
|
bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b
|
|
C
|
|
xxbb = zip*bibb
|
|
bibb = zip*bibb/(bi*LOG(10.0))
|
|
tempbb = -(0.5107d0*xxbb/(c*sion+1.d0))
|
|
tempbb0 = -(sion*tempbb/(c*sion+1.d0))
|
|
sionbb = sionbb + c*tempbb0 + tempbb
|
|
cbb = sion*tempbb0
|
|
IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q
|
|
+ ))) THEN
|
|
ionicbb = ionicbb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*
|
|
+ ionic**2*cbb
|
|
ELSE
|
|
ionicbb = ionicbb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bibb -
|
|
+ .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cbb
|
|
END IF
|
|
END
|
|
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of calcc2 in reverse (adjoint) mode:
|
|
C gradient of useful results: aerliq gas
|
|
C with respect to varying inputs: wp aerliq gas
|
|
C RW status of diff variables: wp:out aerliq:in-out gas:in-out
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCC2
|
|
C *** CASE C2
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0)
|
|
C 2. THERE IS ONLY A LIQUID PHASE
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCC2_CB(wpcb, gascb, aerliqcb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: lamda, kapa, psi, parm
|
|
REAL*8 :: lamdacb, kapacb, psicb, parmcb
|
|
REAL*8 :: bb, cc
|
|
REAL*8 :: bbcb, cccb
|
|
REAL*8 :: molalrcb(npair)
|
|
REAL*8 :: gas(3), AERLIQ(NIONS+NGASAQ+2)
|
|
REAL*8 :: wcb(ncomp)
|
|
REAL*8 :: wpcb(ncomp), gascb(3), aerliqcb(NIONS+NGASAQ+2)
|
|
INTEGER :: i
|
|
INTEGER :: j
|
|
INTEGER :: branch
|
|
INTEGER :: ad_count
|
|
INTEGER :: i0
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp1cb
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp2cb
|
|
REAL*8 :: temp0cb
|
|
INTEGER :: ii1, npflag, ncase
|
|
INTRINSIC SQRT
|
|
C
|
|
C Outer loop activity calculation flag
|
|
frst = .true.
|
|
calain = .true.
|
|
C
|
|
C *** SOLVE EQUATIONS **************************************************
|
|
C
|
|
C NH4HSO4 INITIALLY IN SOLUTION
|
|
lamda = w(3)
|
|
C H2SO4 IN SOLUTION
|
|
psi = w(2) - w(3)
|
|
i = 1
|
|
ad_count = 0
|
|
C NSWEEP = 50
|
|
DO WHILE (i <= nsweep .AND. calain)
|
|
C IF (I > 1) CALL CALCACT3
|
|
parm = water*xk1/gama(7)*(gama(8)/gama(7))**2.
|
|
bb = psi + parm
|
|
cc = -(parm*(lamda+psi))
|
|
kapa = 0.5*(-bb+SQRT(bb*bb-4.0*cc))
|
|
CALL PUSHREAL8(molal(1))
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
C HI
|
|
molal(1) = psi + kapa
|
|
CALL PUSHREAL8(molal(3))
|
|
C NH4I
|
|
molal(3) = lamda
|
|
CALL PUSHREAL8(molal(5))
|
|
C SO4I
|
|
molal(5) = kapa
|
|
IF (lamda + psi - kapa < tiny) THEN
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = lamda + psi - kapa
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C MOLALR(9) = MOLAL(3) ! NH4HSO4 *** As in ISORROPIA 1.7
|
|
C NH4HSO4
|
|
molalr(4) = molal(3)
|
|
IF (w(2) - w(3) < zero) THEN
|
|
molalr(7) = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
molalr(7) = w(2) - w(3)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8(water)
|
|
water = zero
|
|
DO j=1,npair
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
C IF (.NOT.CALAIN) GOTO 30
|
|
i = i + 1
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C*** slc.11.2009 moved to beginning of loop
|
|
CALL CALCACT3()
|
|
ad_count = ad_count + 1
|
|
ENDDO
|
|
IF (CALAIN .AND. (I > (NSWEEP+1))) THEN
|
|
CALL PUSHERR (0001, 'CALCC2') ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
CALL PUSHINTEGER4(ad_count)
|
|
DO ii1=1,nions
|
|
molalcb(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=nions,1,-1
|
|
molalcb(i) = molalcb(i) + aerliqcb(i)
|
|
ENDDO
|
|
aerliqcb = 0.D0
|
|
gascb(3) = 0.D0
|
|
gascb(2) = 0.D0
|
|
gnh3cb = gascb(1)
|
|
gascb(1) = 0.D0
|
|
CALL CALCNH3_CB()
|
|
DO ii1=1,ncomp
|
|
wcb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
molalrcb(ii1) = 0.D0
|
|
ENDDO
|
|
watercb = 0.D0
|
|
psicb = 0.D0
|
|
lamdacb = 0.D0
|
|
CALL POPINTEGER4(ad_count)
|
|
DO i0=1,ad_count
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3_CB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) watercb = 0.D0
|
|
DO j=npair,1,-1
|
|
molalrcb(j) = molalrcb(j) + watercb/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(water)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
molalrcb(7) = 0.D0
|
|
ELSE
|
|
wcb(2) = wcb(2) + molalrcb(7)
|
|
wcb(3) = wcb(3) - molalrcb(7)
|
|
molalrcb(7) = 0.D0
|
|
END IF
|
|
molalcb(3) = molalcb(3) + molalrcb(4)
|
|
molalrcb(4) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(molal(6))
|
|
molalcb(6) = 0.D0
|
|
kapacb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(molal(6))
|
|
lamdacb = lamdacb + molalcb(6)
|
|
psicb = psicb + molalcb(6)
|
|
kapacb = -molalcb(6)
|
|
molalcb(6) = 0.D0
|
|
END IF
|
|
CALL POPREAL8(molal(5))
|
|
kapacb = kapacb + molalcb(5)
|
|
molalcb(5) = 0.D0
|
|
CALL POPREAL8(molal(3))
|
|
lamdacb = lamdacb + molalcb(3)
|
|
molalcb(3) = 0.D0
|
|
CALL POPREAL8(molal(1))
|
|
kapacb = kapacb + molalcb(1)
|
|
parm = water*xk1/gama(7)*(gama(8)/gama(7))**2.
|
|
bb = psi + parm
|
|
cc = -(parm*(lamda+psi))
|
|
IF (bb**2 - 4.0*cc == 0.0) THEN
|
|
temp2cb = 0.0
|
|
ELSE
|
|
temp2cb = 0.5*kapacb/(2.0*SQRT(bb**2-4.0*cc))
|
|
END IF
|
|
bbcb = 2*bb*temp2cb - 0.5*kapacb
|
|
cccb = -(4.0*temp2cb)
|
|
psicb = psicb + bbcb - parm*cccb + molalcb(1)
|
|
molalcb(1) = 0.D0
|
|
parmcb = bbcb - (lamda+psi)*cccb
|
|
lamdacb = lamdacb - parm*cccb
|
|
temp0 = water/gama(7)
|
|
temp1 = gama(8)/gama(7)
|
|
temp1cb = 2.*temp1*temp0*xk1*parmcb/gama(7)
|
|
temp0cb = temp1**2.*xk1*parmcb/gama(7)
|
|
gamacb(8) = gamacb(8) + temp1cb
|
|
gamacb(7) = gamacb(7) - temp0*temp0cb - temp1*temp1cb
|
|
watercb = temp0cb
|
|
ENDDO
|
|
wcb(2) = wcb(2) + psicb
|
|
wcb(3) = wcb(3) + lamdacb - psicb
|
|
wpcb = wcb
|
|
C
|
|
END
|
|
C
|
|
C
|
|
C Differentiation of calcnh3 in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gnh3
|
|
C with respect to varying inputs: molal gama
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNH3
|
|
C *** CALCULATES AMMONIA IN GAS PHASE
|
|
C
|
|
C AMMONIA IN THE GAS PHASE IS ASSUMED A MINOR SPECIES, THAT
|
|
C DOES NOT SIGNIFICANTLY PERTURB THE AEROSOL EQUILIBRIUM.
|
|
C AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l)
|
|
C EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION.
|
|
C
|
|
C THIS IS THE VERSION USED BY THE DIRECT PROBLEM
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNH3_CB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
!
|
|
REAL*8 :: a1cb
|
|
REAL*8 :: chi1cb
|
|
REAL*8 :: chi2cb
|
|
REAL*8 :: bb, cc, diak, psi
|
|
REAL*8 :: bbcb, cccb, diakcb, psicb
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp1cb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x1cb
|
|
REAL*8 :: x1
|
|
REAL*8 :: temp0cb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** IS THERE A LIQUID PHASE? ******************************************
|
|
C
|
|
IF (water <= tiny) THEN
|
|
DO ii1=1,npair
|
|
gamacb(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
C
|
|
C *** CALCULATE NH3 SUBLIMATION *****************************************
|
|
C
|
|
a1 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
chi1 = molal(3)
|
|
chi2 = molal(1)
|
|
C
|
|
C a=1; b!=1; c!=1
|
|
bb = chi2 + one/a1
|
|
cc = -(chi1/a1)
|
|
C Always > 0
|
|
diak = SQRT(bb*bb - 4.d0*cc)
|
|
C One positive root
|
|
psi = 0.5*(-bb+diak)
|
|
IF (psi > chi1) THEN
|
|
x1 = chi1
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = psi
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
chi2cb = molalcb(1)
|
|
psicb = molalcb(1)
|
|
molalcb(1) = 0.D0
|
|
chi1cb = molalcb(3)
|
|
psicb = psicb + gnh3cb - molalcb(3)
|
|
molalcb(3) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
x1cb = 0.D0
|
|
ELSE
|
|
x1cb = psicb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
chi1cb = chi1cb + x1cb
|
|
psicb = 0.D0
|
|
ELSE
|
|
psicb = x1cb
|
|
END IF
|
|
diakcb = 0.5*psicb
|
|
IF (bb**2 - 4.d0*cc == 0.0) THEN
|
|
temp1cb = 0.0
|
|
ELSE
|
|
temp1cb = diakcb/(2.0*SQRT(bb**2-4.d0*cc))
|
|
END IF
|
|
bbcb = 2*bb*temp1cb - 0.5*psicb
|
|
cccb = -(4.d0*temp1cb)
|
|
chi1cb = chi1cb - cccb/a1
|
|
a1cb = chi1*cccb/a1**2 - one*bbcb/a1**2
|
|
chi2cb = chi2cb + bbcb
|
|
molalcb(1) = molalcb(1) + chi2cb
|
|
molalcb(3) = molalcb(3) + chi1cb
|
|
DO ii1=1,npair
|
|
gamacb(ii1) = 0.D0
|
|
ENDDO
|
|
temp0 = gama(10)/gama(5)
|
|
temp0cb = 2.0*temp0*xk2*r*temp*a1cb/(xkw*gama(5))
|
|
gamacb(10) = gamacb(10) + temp0cb
|
|
gamacb(5) = gamacb(5) - temp0*temp0cb
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of calcact3 in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3_CB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0cb(6, 4), sioncb, hcb, chcb, f1cb(3), f2cb(4)
|
|
REAL*8 :: mpl, xij, yji, ioniccb
|
|
REAL*8 :: mplcb, xijcb, yjicb
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01cb
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02cb
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03cb
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04cb
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05cb
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06cb
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07cb
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08cb
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09cb
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10cb
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11cb
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12cb
|
|
INTEGER :: j
|
|
REAL*8 :: errou
|
|
REAL*8 :: errin
|
|
C
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0cb13
|
|
REAL*8 :: temp0cb12
|
|
REAL*8 :: temp0cb11
|
|
REAL*8 :: temp0cb10
|
|
INTRINSIC MAX
|
|
REAL*8 :: x1cb
|
|
INTRINSIC ABS
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x2cb
|
|
REAL*8 :: temp0cb9
|
|
REAL*8 :: temp0cb8
|
|
REAL*8 :: temp0cb7
|
|
REAL*8 :: temp0cb6
|
|
REAL*8 :: temp0cb5
|
|
REAL*8 :: temp0cb4
|
|
REAL*8 :: temp0cb3
|
|
REAL*8 :: temp0cb
|
|
REAL*8 :: temp0cb2
|
|
REAL*8 :: temp0cb1
|
|
REAL*8 :: temp0cb0
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: y1
|
|
C
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
DO i=1,7
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08,
|
|
+ g09, g10, g11, g12)
|
|
C
|
|
g0(1, 1) = g11
|
|
g0(1, 2) = g07
|
|
g0(1, 3) = g08
|
|
g0(1, 4) = g10
|
|
g0(2, 1) = g01
|
|
g0(2, 2) = g02
|
|
g0(2, 3) = g12
|
|
g0(2, 4) = g03
|
|
g0(3, 1) = g06
|
|
g0(3, 2) = g04
|
|
g0(3, 3) = g09
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
sion = SQRT(ionic)
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
yji = ch*molal(j+3)/water
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gama(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gama(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gama(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gama(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gama(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gama(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gama(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gama(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gama(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gama(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gama(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gama(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gama(13))
|
|
C LC ; SCAPE
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
ELSE
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
gamacb(i) = 10.d0**gama(i)*LOG(10.d0)*gamacb(i)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
gamacb(i) = 0.D0
|
|
x2cb = 0.D0
|
|
ELSE
|
|
x2cb = gamacb(i)
|
|
gamacb(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) gamacb(i) = gamacb(i) + x2cb
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamacb(4) = gamacb(4) + 0.2d0*3.d0*gamacb(13)
|
|
gamacb(9) = gamacb(9) + 0.2d0*2.d0*gamacb(13)
|
|
gamacb(13) = 0.D0
|
|
DO ii1=1,3
|
|
f1cb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2cb(ii1) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp0cb2 = zz(12)*gamacb(12)/(z(2)+z(6))
|
|
f1cb(2) = f1cb(2) + temp0cb2/z(2)
|
|
f2cb(3) = f2cb(3) + temp0cb2/z(6)
|
|
hcb = -(zz(12)*gamacb(12))
|
|
gamacb(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp0cb3 = zz(11)*gamacb(11)/(z(1)+z(4))
|
|
f2cb(1) = f2cb(1) + temp0cb3/z(4)
|
|
hcb = hcb - zz(11)*gamacb(11)
|
|
gamacb(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp0cb4 = zz(10)*gamacb(10)/(z(1)+z(7))
|
|
f1cb(1) = f1cb(1) + temp0cb4/z(1) + temp0cb3/z(1)
|
|
f2cb(4) = f2cb(4) + temp0cb4/z(7)
|
|
hcb = hcb - zz(10)*gamacb(10)
|
|
gamacb(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp0cb5 = zz(9)*gamacb(9)/(z(3)+z(6))
|
|
f1cb(3) = f1cb(3) + temp0cb5/z(3)
|
|
hcb = hcb - zz(9)*gamacb(9)
|
|
gamacb(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp0cb6 = zz(8)*gamacb(8)/(z(1)+z(6))
|
|
f2cb(3) = f2cb(3) + temp0cb6/z(6) + temp0cb5/z(6)
|
|
hcb = hcb - zz(8)*gamacb(8)
|
|
gamacb(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp0cb7 = zz(7)*gamacb(7)/(z(1)+z(5))
|
|
f1cb(1) = f1cb(1) + temp0cb7/z(1) + temp0cb6/z(1)
|
|
f2cb(2) = f2cb(2) + temp0cb7/z(5)
|
|
hcb = hcb - zz(7)*gamacb(7)
|
|
gamacb(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp0cb8 = zz(6)*gamacb(6)/(z(3)+z(4))
|
|
f2cb(1) = f2cb(1) + temp0cb8/z(4)
|
|
hcb = hcb - zz(6)*gamacb(6)
|
|
gamacb(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp0cb9 = zz(5)*gamacb(5)/(z(3)+z(7))
|
|
f2cb(4) = f2cb(4) + temp0cb9/z(7)
|
|
hcb = hcb - zz(5)*gamacb(5)
|
|
gamacb(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp0cb10 = zz(4)*gamacb(4)/(z(3)+z(5))
|
|
f1cb(3) = f1cb(3) + temp0cb9/z(3) + temp0cb10/z(3) + temp0cb8/z(3)
|
|
f2cb(2) = f2cb(2) + temp0cb10/z(5)
|
|
hcb = hcb - zz(4)*gamacb(4)
|
|
gamacb(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp0cb11 = zz(3)*gamacb(3)/(z(2)+z(7))
|
|
f2cb(4) = f2cb(4) + temp0cb11/z(7)
|
|
hcb = hcb - zz(3)*gamacb(3)
|
|
gamacb(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp0cb12 = zz(2)*gamacb(2)/(z(2)+z(5))
|
|
f2cb(2) = f2cb(2) + temp0cb12/z(5)
|
|
hcb = hcb - zz(2)*gamacb(2)
|
|
gamacb(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp0cb13 = zz(1)*gamacb(1)/(z(2)+z(4))
|
|
f1cb(2) = f1cb(2) + temp0cb12/z(2) + temp0cb13/z(2) + temp0cb11/z(
|
|
+ 2)
|
|
f2cb(1) = f2cb(1) + temp0cb13/z(4)
|
|
hcb = hcb - zz(1)*gamacb(1)
|
|
gamacb(1) = 0.D0
|
|
ioniccb = 0.D0
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0cb(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mplcb = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijcb = (g0(i, j)+zpl*zmi*h)*f2cb(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0cb(i, j) = g0cb(i, j) + yji*f1cb(i) + xij*f2cb(j)
|
|
hcb = hcb + yji*zpl*zmi*f1cb(i) + xij*zpl*zmi*f2cb(j)
|
|
yjicb = (g0(i, j)+zpl*zmi*h)*f1cb(i)
|
|
temp0cb1 = molal(j+3)*yjicb/water
|
|
molalcb(j+3) = molalcb(j+3) + ch*yjicb/water
|
|
chcb = mpl*xijcb + temp0cb1
|
|
watercb = watercb - ch*temp0cb1/water
|
|
mplcb = mplcb + ch*xijcb
|
|
ioniccb = ioniccb - (zpl+zmi)**2*0.25d0*chcb/ionic**2
|
|
ENDDO
|
|
CALL POPREAL8(mpl)
|
|
molalcb(i) = molalcb(i) + mplcb/water
|
|
watercb = watercb - molal(i)*mplcb/water**2
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp0cb0 = agama*hcb/(sion+1.d0)
|
|
sioncb = (1.D0-sion/(sion+1.d0))*temp0cb0
|
|
IF (.NOT.ionic == 0.0) ioniccb = ioniccb + sioncb/(2.0*SQRT(
|
|
+ ionic))
|
|
g05cb = g0cb(3, 4)
|
|
g0cb(3, 4) = 0.D0
|
|
g09cb = g0cb(3, 3)
|
|
g0cb(3, 3) = 0.D0
|
|
g04cb = g0cb(3, 2)
|
|
g0cb(3, 2) = 0.D0
|
|
g06cb = g0cb(3, 1)
|
|
g0cb(3, 1) = 0.D0
|
|
g03cb = g0cb(2, 4)
|
|
g0cb(2, 4) = 0.D0
|
|
g12cb = g0cb(2, 3)
|
|
g0cb(2, 3) = 0.D0
|
|
g02cb = g0cb(2, 2)
|
|
g0cb(2, 2) = 0.D0
|
|
g01cb = g0cb(2, 1)
|
|
g0cb(2, 1) = 0.D0
|
|
g10cb = g0cb(1, 4)
|
|
g0cb(1, 4) = 0.D0
|
|
g08cb = g0cb(1, 3)
|
|
g0cb(1, 3) = 0.D0
|
|
g07cb = g0cb(1, 2)
|
|
g0cb(1, 2) = 0.D0
|
|
g11cb = g0cb(1, 1)
|
|
CALL KMFUL3_CB(ionic, ioniccb, temp, g01, g01cb, g02, g02cb, g03,
|
|
+ g03cb, g04, g04cb, g05, g05cb, g06, g06cb, g07,
|
|
+ g07cb, g08, g08cb, g09, g09cb, g10, g10cb, g11,
|
|
+ g11cb, g12, g12cb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionic)
|
|
x1cb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1cb = ioniccb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ioniccb = 0.D0
|
|
ELSE
|
|
temp0cb = 0.5d0*x1cb/water
|
|
ioniccb = temp0cb
|
|
watercb = watercb - ionic*temp0cb/water
|
|
END IF
|
|
DO i=7,1,-1
|
|
molalcb(i) = molalcb(i) + z(i)**2*ioniccb
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of kmful3 in reverse (adjoint) mode:
|
|
C gradient of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12 ionic
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_CB(ionic, ioniccb, temp, g01, g01cb, g02, g02cb
|
|
+ , g03, g03cb, g04, g04cb, g05, g05cb, g06,
|
|
+ g06cb, g07, g07cb, g08, g08cb, g09, g09cb,
|
|
+ g10, g10cb, g11, g11cb, g12, g12cb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ioniccb, sioncb, cf2cb
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01cb, g02cb, g03cb, g04cb, g05cb, g06cb, g07cb,
|
|
+ g08cb, g09cb, g10cb, g11cb, g12cb
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTEGER :: branch
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp0cb
|
|
REAL*8 :: temp0cb0
|
|
REAL*8 :: abs1
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01cb = g01cb + g12cb
|
|
g08cb = g08cb + g09cb + g12cb
|
|
g11cb = g11cb - g09cb - g12cb
|
|
g06cb = g06cb + g09cb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2cb = -(z10*g10cb) - z07*g07cb - z05*g05cb - z03*g03cb - z01*
|
|
+ g01cb - z02*g02cb - z04*g04cb - z06*g06cb - z08*g08cb - z11*
|
|
+ g11cb
|
|
g11cb = cf1*g11cb
|
|
g10cb = cf1*g10cb
|
|
g08cb = cf1*g08cb
|
|
g07cb = cf1*g07cb
|
|
g06cb = cf1*g06cb
|
|
g05cb = cf1*g05cb
|
|
g04cb = cf1*g04cb
|
|
g03cb = cf1*g03cb
|
|
g02cb = cf1*g02cb
|
|
g01cb = cf1*g01cb
|
|
temp0cb = (0.125d0-ti*0.005d0)*cf2cb
|
|
temp0cb0 = -(0.41d0*temp0cb/(sion+1.d0))
|
|
ioniccb = ioniccb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0cb
|
|
sioncb = (1.D0-sion/(sion+1.d0))*temp0cb0
|
|
ELSE
|
|
sioncb = 0.D0
|
|
END IF
|
|
CALL MKBI_CB(q11, ionic, ioniccb, sion, sioncb, z11, g11, g11cb)
|
|
CALL MKBI_CB(q10, ionic, ioniccb, sion, sioncb, z10, g10, g10cb)
|
|
CALL MKBI_CB(q8, ionic, ioniccb, sion, sioncb, z08, g08, g08cb)
|
|
CALL MKBI_CB(q7, ionic, ioniccb, sion, sioncb, z07, g07, g07cb)
|
|
CALL MKBI_CB(q6, ionic, ioniccb, sion, sioncb, z06, g06, g06cb)
|
|
CALL MKBI_CB(q5, ionic, ioniccb, sion, sioncb, z05, g05, g05cb)
|
|
CALL MKBI_CB(q4, ionic, ioniccb, sion, sioncb, z04, g04, g04cb)
|
|
CALL MKBI_CB(q3, ionic, ioniccb, sion, sioncb, z03, g03, g03cb)
|
|
CALL MKBI_CB(q2, ionic, ioniccb, sion, sioncb, z02, g02, g02cb)
|
|
CALL MKBI_CB(q1, ionic, ioniccb, sion, sioncb, z01, g01, g01cb)
|
|
IF (.NOT.ionic == 0.0) ioniccb = ioniccb + sioncb/(2.0*SQRT(
|
|
+ ionic))
|
|
END
|
|
|
|
C Differentiation of mkbi in reverse (adjoint) mode:
|
|
C gradient of useful results: sion bi ionic
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_CB(q, ionic, ioniccb, sion, sioncb, zip, bi, bicb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ioniccb, sioncb, bicb
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: ccb, xxcb
|
|
INTRINSIC EXP
|
|
REAL*8 :: tempcb
|
|
REAL*8 :: tempcb0
|
|
INTRINSIC LOG10
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic))
|
|
bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b
|
|
C
|
|
xxcb = zip*bicb
|
|
bicb = zip*bicb/(bi*LOG(10.0))
|
|
tempcb = -(0.5107d0*xxcb/(c*sion+1.d0))
|
|
tempcb0 = -(sion*tempcb/(c*sion+1.d0))
|
|
sioncb = sioncb + c*tempcb0 + tempcb
|
|
ccb = sion*tempcb0
|
|
IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q
|
|
+ ))) THEN
|
|
ioniccb = ioniccb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*
|
|
+ ionic**2*ccb
|
|
ELSE
|
|
ioniccb = ioniccb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bicb -
|
|
+ .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*ccb
|
|
END IF
|
|
END
|
|
|
|
C
|
|
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of funcd3p in reverse (adjoint) mode:
|
|
C gradient of useful results: aerliq gas
|
|
C with respect to varying inputs: wp aerliq gas
|
|
C RW status of diff variables: wp:out aerliq:in-out gas:in-out
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** FUNCTION FUNCD3P
|
|
C *** CASE D3
|
|
C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ;
|
|
C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3.
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCD3P_DB(p4, y1, wpdb, gasdb, aerliqdb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: chi2db
|
|
C
|
|
REAL*8 :: gas(3), AERLIQ(NIONS+NGASAQ+2)
|
|
REAL*8 :: wpdb(ncomp),gasdb(3)
|
|
REAL*8 :: aerliqdb(NIONS+NGASAQ+2)
|
|
REAL*8 :: wdb(ncomp)
|
|
REAL*8 :: p4, y1, parm, x
|
|
REAL*8 :: y1db, xdb
|
|
REAL*8 :: x1, x2, xt, y1d, y2, xtd
|
|
REAL*8 :: x2db, y1ddb
|
|
REAL*8 :: ps, om, omps, diak, ze, delta
|
|
REAL*8 :: psdb, omdb, ompsdb, diakdb, zedb, deltadb
|
|
CHARACTER(LEN=40) :: errinf
|
|
INTEGER :: errstki(25)
|
|
LOGICAL :: dexs, iexs, eof
|
|
REAL*8 :: absire, feps
|
|
CHARACTER(LEN=40) :: errmsgi(25)
|
|
INTEGER :: i
|
|
INTEGER :: branch, npflag, ncase
|
|
INTRINSIC MAX
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs1
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
C WRITE(*,*) 'Within FUNCD3P_DB'
|
|
feps = 1.d-5
|
|
parm = xk10/(r*temp)/(r*temp)
|
|
C
|
|
C *** CALCULATE NH4NO3 THAT VOLATIZES *********************************
|
|
C
|
|
cnh42s4 = w(2)
|
|
IF (w(3) - 2.d0*w(2) > w(4)) THEN
|
|
x = w(4)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x = w(3) - 2.d0*w(2)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x > zero) THEN
|
|
IF (w(3) - 2.0*w(2) < w(4)) THEN
|
|
ps = zero
|
|
om = w(4) - w(3) + 2.0*w(2)
|
|
IF (om < tiny) THEN
|
|
om = zero
|
|
CALL PUSHCONTROL3B(4)
|
|
ELSE
|
|
CALL PUSHCONTROL3B(3)
|
|
END IF
|
|
ELSE
|
|
ps = w(3) - w(4) - 2.0*w(2)
|
|
IF (ps < tiny) THEN
|
|
ps = zero
|
|
CALL PUSHCONTROL3B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL3B(2)
|
|
END IF
|
|
om = zero
|
|
END IF
|
|
ELSE
|
|
x = zero
|
|
IF (w(3) - 2.d0*w(2) < zero) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ps = zero
|
|
ELSE
|
|
ps = w(3) - 2.d0*w(2)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (ps < tiny) THEN
|
|
ps = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
om = w(4)
|
|
CALL PUSHCONTROL3B(0)
|
|
END IF
|
|
C
|
|
omps = om + ps
|
|
C DIAKRINOUSA
|
|
diak = SQRT(omps*omps + 4.0*parm)
|
|
IF (x > 0.5*(-omps+diak)) THEN
|
|
ze = 0.5*(-omps+diak)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
ze = x
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** SPECIATION *******************************************************
|
|
C
|
|
C Solid NH4NO3
|
|
cnh4no3 = x - ze
|
|
C Gas NH3
|
|
gnh3 = ps + ze
|
|
C Gas HNO3
|
|
ghno3 = om + ze
|
|
C
|
|
C Save from CALCD1 run
|
|
chi2 = cnh42s4
|
|
chi3 = ghno3
|
|
chi4 = gnh3
|
|
C
|
|
C ASSIGN INITIAL PSI's
|
|
psi1 = cnh4no3
|
|
psi2 = chi2
|
|
psi4 = p4
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
C
|
|
C *** NEWTON-RAPHSON DETERMINATION OF ROOT **********************
|
|
C
|
|
C WRITE(*,*) 'Before FUNCD3B_DNRD, xt: ',PSI4
|
|
xt = psi4
|
|
xtd = 1.d0
|
|
CALL PUSHREAL8ARRAY(gamadnrd, npair)
|
|
CALL PUSHREAL8ARRAY(molaldnrd, nions)
|
|
CALL PUSHINTEGER4(iclact)
|
|
CALL PUSHREAL8(water)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
CALL PUSHREAL8ARRAY(molalr, npair)
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
C WRITE(*,*) 'PSI4 ',PSI4
|
|
C CALL FUNCD3B(XT,Y1)
|
|
CALL FUNCD3B_DNRD(xt, xtd, y1, y1d)
|
|
x2 = xt - y1/(y1d*1.d0)
|
|
CALL PUSHINTEGER4(iclact)
|
|
CALL PUSHREAL8(water)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
CALL PUSHREAL8ARRAY(molalr, npair)
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
CALL FUNCD3B(x2, y2)
|
|
C WRITE(*,*) 'x2 ', x2, ' y2 ',y2
|
|
IF (y2 >= 0.) THEN
|
|
abs1 = y2
|
|
ELSE
|
|
abs1 = -y2
|
|
END IF
|
|
IF (abs1 > 10.d0*feps) THEN
|
|
C WRITE(*,*) 'abs1 > feps', abs1
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCD3 (',(abs1),')'
|
|
CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE
|
|
DO ii1=1,nions
|
|
molaldb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
gamadb(ii1) = 0.D0
|
|
ENDDO
|
|
waterdb = 0.D0
|
|
gnh3db = 0.D0
|
|
ghno3db = 0.D0
|
|
ELSE
|
|
C WRITE(*,*) '********** Testing Newton in CVM *******************'
|
|
C WRITE(*,*) 'XT ',XT
|
|
C WRITE(*,*) 'Y1 ', Y1
|
|
C WRITE(*,*) 'Y1D ', Y1D
|
|
C WRITE(*,*) 'X2 ',X2
|
|
C WRITE(*,*) 'Y2 ',Y2
|
|
C WRITE(*,*) '******** End of testing Newton in CVM ***************'
|
|
C
|
|
IF (molal(1) > tiny .AND. molal(5) > tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
DO ii1=1,nions
|
|
molaldb(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=nions,1,-1
|
|
molaldb(i) = molaldb(i) + aerliqdb(i)
|
|
ENDDO
|
|
aerliqdb = 0.D0
|
|
C WRITE(*,*) 'molaldb',molaldb
|
|
gasdb(3) = 0.D0
|
|
ghno3db = gasdb(2)
|
|
gasdb(2) = 0.D0
|
|
gnh3db = gasdb(1)
|
|
gasdb(1) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
deltadb = molaldb(6)
|
|
molaldb(6) = 0.D0
|
|
deltadb = deltadb - molaldb(1) - molaldb(5)
|
|
CALL CALCHS4_DB(molal(1), molaldb(1), molal(5), molaldb(5),
|
|
+ zero, delta, deltadb)
|
|
ELSE
|
|
DO ii1=1,npair
|
|
gamadb(ii1) = 0.D0
|
|
ENDDO
|
|
waterdb = 0.D0
|
|
END IF
|
|
END IF
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL POPREAL8ARRAY(molalr, npair)
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPREAL8(water)
|
|
CALL POPINTEGER4(iclact)
|
|
CALL FUNCD3B_DB(x2, x2db, y2)
|
|
y1db = -(x2db/y1d)
|
|
y1ddb = y1*x2db/y1d**2
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL POPREAL8ARRAY(molalr, npair)
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPREAL8(water)
|
|
CALL POPINTEGER4(iclact)
|
|
CALL POPREAL8ARRAY(molaldnrd, nions)
|
|
CALL POPREAL8ARRAY(gamadnrd, npair)
|
|
CALL FUNCD3B_DNRD_DB(xt, xtd, y1, y1db, y1d, y1ddb)
|
|
chi2db = psi2db
|
|
cnh4no3db = psi1db
|
|
gnh3db = gnh3db + chi4db
|
|
ghno3db = ghno3db + chi3db
|
|
cnh42s4db = chi2db
|
|
omdb = ghno3db
|
|
zedb = gnh3db - cnh4no3db + ghno3db
|
|
psdb = gnh3db
|
|
xdb = cnh4no3db
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
diakdb = 0.5*zedb
|
|
ompsdb = -(0.5*zedb)
|
|
ELSE
|
|
xdb = xdb + zedb
|
|
diakdb = 0.D0
|
|
ompsdb = 0.D0
|
|
END IF
|
|
IF (.NOT.parm*4.0 + omps**2 == 0.0) ompsdb = ompsdb + 2*omps*
|
|
+ diakdb/(2.0*SQRT(parm*4.0+omps**2))
|
|
omdb = omdb + ompsdb
|
|
psdb = psdb + ompsdb
|
|
CALL POPCONTROL3B(branch)
|
|
IF (branch < 2) THEN
|
|
IF (branch == 0) THEN
|
|
DO ii1=1,ncomp
|
|
wdb(ii1) = 0.D0
|
|
ENDDO
|
|
wdb(4) = wdb(4) + omdb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) psdb = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
wdb(3) = wdb(3) + psdb
|
|
wdb(2) = wdb(2) - 2.d0*psdb
|
|
END IF
|
|
xdb = 0.D0
|
|
GOTO 100
|
|
ELSE
|
|
psdb = 0.D0
|
|
END IF
|
|
ELSE IF (branch /= 2) THEN
|
|
IF (branch /= 3) omdb = 0.D0
|
|
DO ii1=1,ncomp
|
|
wdb(ii1) = 0.D0
|
|
ENDDO
|
|
wdb(4) = wdb(4) + omdb
|
|
wdb(3) = wdb(3) - omdb
|
|
wdb(2) = wdb(2) + 2.0*omdb
|
|
GOTO 100
|
|
END IF
|
|
DO ii1=1,ncomp
|
|
wdb(ii1) = 0.D0
|
|
ENDDO
|
|
wdb(3) = wdb(3) + psdb
|
|
wdb(4) = wdb(4) - psdb
|
|
wdb(2) = wdb(2) - 2.0*psdb
|
|
100 CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
wdb(4) = wdb(4) + xdb
|
|
ELSE
|
|
wdb(3) = wdb(3) + xdb
|
|
wdb(2) = wdb(2) - 2.d0*xdb
|
|
END IF
|
|
wdb(2) = wdb(2) + cnh42s4db
|
|
wpdb = wdb
|
|
END
|
|
|
|
C Differentiation of funcd3b in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water gnh3 ghno3
|
|
C with respect to varying inputs: molal molalr gama water gnh3
|
|
C ghno3 chi3 chi4 psi1 psi2 p4
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** FUNCTION FUNCD3
|
|
C *** CASE D3
|
|
C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ;
|
|
C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3.
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCD3B_DB(p4, p4db, fd3b)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: psi3db
|
|
REAL*8 :: psi4db
|
|
REAL*8 :: a3db
|
|
REAL*8 :: a4db
|
|
REAL*8 :: a7db
|
|
C
|
|
REAL*8 :: p4, bb, denm, ahi, aml5, fd3b
|
|
REAL*8 :: p4db, bbdb, denmdb, ahidb, aml5db
|
|
CHARACTER(LEN=40) :: errinf
|
|
INTEGER :: errstki(25), k, j
|
|
LOGICAL :: dexs, iexs, eof
|
|
CHARACTER(LEN=40) :: errmsgi(25)
|
|
LOGICAL :: tst
|
|
INTEGER :: i
|
|
REAL*8 :: abb
|
|
REAL*8 :: abbdb
|
|
INTEGER :: branch
|
|
REAL*8 :: temp3
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp4db
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp2db
|
|
INTRINSIC ABS
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x2db
|
|
REAL*8 :: temp2db3
|
|
REAL*8 :: temp2db2
|
|
REAL*8 :: temp2db1
|
|
REAL*8 :: temp2db0
|
|
REAL*8 :: temp3db0
|
|
REAL*8 :: temp0db
|
|
REAL*8 :: temp4db0
|
|
REAL*8 :: temp3db
|
|
REAL*8 :: temp1db
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: x1db
|
|
REAL*8 :: max1
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
psi4 = p4
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
DO i=1,3
|
|
C
|
|
a3 = xk4*r*temp*(water/gama(10))**2.0
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
CALL PUSHREAL8(a7)
|
|
a7 = xkw*rh*water*water
|
|
C
|
|
psi3 = a3*a4*chi3*(chi4-psi4) - psi1*(2.d0*psi2+psi1+psi4)
|
|
CALL PUSHREAL8(psi3)
|
|
psi3 = psi3/(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4)
|
|
IF (psi3 < zero) THEN
|
|
x1 = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = psi3
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 > chi3) THEN
|
|
psi3 = chi3
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
psi3 = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8(bb)
|
|
C
|
|
bb = psi4 - psi3
|
|
CALL PUSHREAL8(denm)
|
|
denm = bb + SQRT(bb*bb + 4.d0*a7)
|
|
IF (denm <= tiny) THEN
|
|
IF (bb >= 0.) THEN
|
|
CALL PUSHREAL8(abb)
|
|
abb = bb
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(abb)
|
|
abb = -bb
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C Taylor expansion of SQRT
|
|
denm = bb + abb + 2.0*a7/abb - 2.0*a7*a7/abb**3.0
|
|
C WRITE(*,*) 'TS approx. of DENM: ',DENM
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
ahi = 2.0*a7/denm
|
|
CALL PUSHREAL8(molal(1))
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
C HI
|
|
molal(1) = ahi
|
|
CALL PUSHREAL8(molal(3))
|
|
C NH4I
|
|
molal(3) = psi1 + psi4 + 2.d0*psi2
|
|
CALL PUSHREAL8(molal(5))
|
|
C SO4I
|
|
molal(5) = psi2
|
|
CALL PUSHREAL8(molal(6))
|
|
C HSO4I
|
|
molal(6) = zero
|
|
CALL PUSHREAL8(molal(7))
|
|
C NO3I
|
|
molal(7) = psi3 + psi1
|
|
C Solid (NH4)2SO4
|
|
C Solid NH4NO3
|
|
C Gas HNO3
|
|
C Gas NH3
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C (NH4)2SO4
|
|
molalr(4) = molal(5) + molal(6)
|
|
C "free" NH4
|
|
aml5 = molal(3) - 2.d0*molalr(4)
|
|
IF (aml5 > molal(7)) THEN
|
|
x2 = molal(7)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x2 = aml5
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < zero) THEN
|
|
molalr(5) = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
molalr(5) = x2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8(water)
|
|
C
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
DO j=1,npair
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C
|
|
CALL CALCACT3P()
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
molalrdb(ii1) = 0.D0
|
|
ENDDO
|
|
chi3db = 0.D0
|
|
chi4db = 0.D0
|
|
psi1db = 0.D0
|
|
psi2db = 0.D0
|
|
psi4db = 0.D0
|
|
DO i=3,1,-1
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3P_DB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) waterdb = 0.D0
|
|
DO j=npair,1,-1
|
|
molalrdb(j) = molalrdb(j) + waterdb/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(water)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
molalrdb(5) = 0.D0
|
|
x2db = 0.D0
|
|
ELSE
|
|
x2db = molalrdb(5)
|
|
molalrdb(5) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
molaldb(7) = molaldb(7) + x2db
|
|
aml5db = 0.D0
|
|
ELSE
|
|
aml5db = x2db
|
|
END IF
|
|
molaldb(3) = molaldb(3) + aml5db
|
|
molalrdb(4) = molalrdb(4) - 2.d0*aml5db
|
|
molaldb(5) = molaldb(5) + molalrdb(4)
|
|
molaldb(6) = molaldb(6) + molalrdb(4)
|
|
molalrdb(4) = 0.D0
|
|
chi4db = chi4db + gnh3db
|
|
chi3db = chi3db + ghno3db
|
|
psi3db = molaldb(7) - ghno3db
|
|
CALL POPREAL8(molal(7))
|
|
psi1db = psi1db + molaldb(7)
|
|
molaldb(7) = 0.D0
|
|
CALL POPREAL8(molal(6))
|
|
molaldb(6) = 0.D0
|
|
CALL POPREAL8(molal(5))
|
|
psi2db = psi2db + molaldb(5)
|
|
molaldb(5) = 0.D0
|
|
psi4db = psi4db + molaldb(3) - gnh3db
|
|
CALL POPREAL8(molal(3))
|
|
psi1db = psi1db + molaldb(3)
|
|
psi2db = psi2db + 2.d0*molaldb(3)
|
|
molaldb(3) = 0.D0
|
|
CALL POPREAL8(molal(1))
|
|
ahidb = molaldb(1)
|
|
molaldb(1) = 0.D0
|
|
temp4db0 = 2.0*ahidb/denm
|
|
a7db = temp4db0
|
|
denmdb = -(a7*temp4db0/denm)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
bbdb = 0.D0
|
|
ELSE
|
|
temp4db = 2.0*denmdb/abb
|
|
temp3 = abb**3.0
|
|
temp3db0 = -(2.0*denmdb/temp3)
|
|
bbdb = denmdb
|
|
abbdb = denmdb - a7*temp4db/abb - a7**2*3.0*abb**2.0*temp3db0/
|
|
+ temp3
|
|
a7db = a7db + 2*a7*temp3db0 + temp4db
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(abb)
|
|
bbdb = bbdb + abbdb
|
|
ELSE
|
|
CALL POPREAL8(abb)
|
|
bbdb = bbdb - abbdb
|
|
END IF
|
|
denmdb = 0.D0
|
|
END IF
|
|
CALL POPREAL8(denm)
|
|
IF (bb**2 + 4.d0*a7 == 0.0) THEN
|
|
temp3db = 0.0
|
|
ELSE
|
|
temp3db = denmdb/(2.0*SQRT(bb**2+4.d0*a7))
|
|
END IF
|
|
bbdb = bbdb + 2*bb*temp3db + denmdb
|
|
a7db = a7db + 4.d0*temp3db
|
|
CALL POPREAL8(bb)
|
|
psi4db = psi4db + bbdb
|
|
psi3db = psi3db - bbdb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
chi3db = chi3db + psi3db
|
|
x1db = 0.D0
|
|
ELSE
|
|
x1db = psi3db
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
psi3db = 0.D0
|
|
ELSE
|
|
psi3db = x1db
|
|
END IF
|
|
a3 = xk4*r*temp*(water/gama(10))**2.0
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
CALL POPREAL8(psi3)
|
|
temp2 = a3*a4*(chi4-psi4) + 2.d0*psi2 + psi1 + psi4
|
|
temp2db = -(psi3*psi3db/temp2**2)
|
|
temp2db0 = a3*a4*temp2db
|
|
psi3db = psi3db/temp2
|
|
temp2db1 = chi3*(chi4-psi4)*psi3db
|
|
a3db = a4*temp2db1 + (chi4-psi4)*a4*temp2db
|
|
a4db = a3*temp2db1 + (chi4-psi4)*a3*temp2db
|
|
temp2db2 = a3*a4*psi3db
|
|
chi4db = chi4db + chi3*temp2db2 + temp2db0
|
|
temp2db3 = -(psi1*psi3db)
|
|
psi4db = psi4db + temp2db3 - chi3*temp2db2 + temp2db - temp2db0
|
|
psi2db = psi2db + 2.d0*temp2db3 + 2.d0*temp2db
|
|
psi1db = psi1db + temp2db3 - (2.d0*psi2+psi1+psi4)*psi3db +
|
|
+ temp2db
|
|
chi3db = chi3db + (chi4-psi4)*temp2db2
|
|
CALL POPREAL8(a7)
|
|
temp1 = gama(10)/gama(5)
|
|
temp1db = 2.0*temp1*xk2*r*temp*a4db/(xkw*gama(5))
|
|
gamadb(10) = gamadb(10) + temp1db
|
|
gamadb(5) = gamadb(5) - temp1*temp1db
|
|
temp0 = water/gama(10)
|
|
temp0db = 2.0*temp0*xk4*r*temp*a3db/gama(10)
|
|
waterdb = temp0db + xkw*rh*2*water*a7db
|
|
gamadb(10) = gamadb(10) - temp0*temp0db
|
|
gnh3db = 0.D0
|
|
ghno3db = 0.D0
|
|
ENDDO
|
|
p4db = psi4db
|
|
END
|
|
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCHS4
|
|
C *** THIS SUBROUTINE CALCULATES THE HSO4 GENERATED FROM (H,SO4).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCHS4_DB(hi, hidb, so4i, so4idb, hso4i, delta,
|
|
+ deltadb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: a8db
|
|
C
|
|
REAL*8 :: hi, so4i, hso4i, delta, bb, cc, dd, sqdd, delta1
|
|
+ , delta2
|
|
REAL*8 :: hidb, so4idb, deltadb, bbdb, ccdb, dddb, sqdddb,
|
|
+ delta1db, delta2db
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0db
|
|
REAL*8 :: temp1db
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** IF TOO LITTLE WATER, DONT SOLVE
|
|
C
|
|
IF (water <= 1d1*tiny) THEN
|
|
DO ii1=1,npair
|
|
gamadb(ii1) = 0.D0
|
|
ENDDO
|
|
waterdb = 0.D0
|
|
ELSE
|
|
C
|
|
C *** CALCULATE HSO4 SPECIATION *****************************************
|
|
C
|
|
a8 = xk1*water/gama(7)*(gama(8)/gama(7))**2.
|
|
C
|
|
bb = -(hi+so4i+a8)
|
|
cc = hi*so4i - hso4i*a8
|
|
dd = bb*bb - 4.d0*cc
|
|
C
|
|
IF (dd >= zero) THEN
|
|
IF (hso4i <= tiny) THEN
|
|
delta2db = deltadb
|
|
delta1db = 0.D0
|
|
ELSE IF (hi*so4i >= a8*hso4i) THEN
|
|
delta2db = deltadb
|
|
delta1db = 0.D0
|
|
ELSE
|
|
IF (hi*so4i < a8*hso4i) THEN
|
|
delta1db = deltadb
|
|
ELSE
|
|
delta1db = 0.D0
|
|
END IF
|
|
delta2db = 0.D0
|
|
END IF
|
|
bbdb = -(0.5*delta1db) - 0.5*delta2db
|
|
sqdddb = 0.5*delta1db - 0.5*delta2db
|
|
IF (dd == 0.0) THEN
|
|
dddb = 0.0
|
|
ELSE
|
|
dddb = sqdddb/(2.0*SQRT(dd))
|
|
END IF
|
|
ELSE
|
|
dddb = 0.D0
|
|
bbdb = 0.D0
|
|
END IF
|
|
bbdb = bbdb + 2*bb*dddb
|
|
ccdb = -(4.d0*dddb)
|
|
hidb = hidb + so4i*ccdb - bbdb
|
|
so4idb = so4idb + hi*ccdb - bbdb
|
|
a8db = -bbdb - hso4i*ccdb
|
|
DO ii1=1,npair
|
|
gamadb(ii1) = 0.D0
|
|
ENDDO
|
|
temp0 = water/gama(7)
|
|
temp1 = gama(8)/gama(7)
|
|
temp1db = 2.*temp1*temp0*xk1*a8db/gama(7)
|
|
temp0db = temp1**2.*xk1*a8db/gama(7)
|
|
gamadb(8) = gamadb(8) + temp1db
|
|
gamadb(7) = gamadb(7) - temp0*temp0db - temp1*temp1db
|
|
waterdb = temp0db
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of calcact3p in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3P_DB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0db(6, 4), siondb, hdb, chdb, f1db(3), f2db(4)
|
|
REAL*8 :: mpl, xij, yji, ionicdb
|
|
REAL*8 :: mpldb, xijdb, yjidb
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01db
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02db
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03db
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04db
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05db
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06db
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07db
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08db
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09db
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10db
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11db
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12db
|
|
INTEGER :: j
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0db9
|
|
REAL*8 :: temp0db8
|
|
REAL*8 :: temp0db7
|
|
REAL*8 :: temp0db6
|
|
REAL*8 :: temp0db5
|
|
REAL*8 :: temp0db4
|
|
REAL*8 :: temp0db3
|
|
REAL*8 :: temp0db2
|
|
REAL*8 :: temp0db13
|
|
REAL*8 :: temp0db1
|
|
REAL*8 :: temp0db12
|
|
REAL*8 :: temp0db0
|
|
REAL*8 :: temp0db11
|
|
REAL*8 :: temp0db10
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x2db
|
|
REAL*8 :: temp0db
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: x1db
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
DO i=1,7
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08,
|
|
+ g09, g10, g11, g12)
|
|
C
|
|
g0(1, 1) = g11
|
|
g0(1, 2) = g07
|
|
g0(1, 3) = g08
|
|
g0(1, 4) = g10
|
|
g0(2, 1) = g01
|
|
g0(2, 2) = g02
|
|
g0(2, 3) = g12
|
|
g0(2, 4) = g03
|
|
g0(3, 1) = g06
|
|
g0(3, 2) = g04
|
|
g0(3, 3) = g09
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
sion = SQRT(ionic)
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
yji = ch*molal(j+3)/water
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gama(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gama(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gama(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gama(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gama(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gama(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gama(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gama(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gama(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gama(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gama(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gama(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gama(13))
|
|
C LC ; SCAPE
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
ELSE
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
gamadb(i) = 10.d0**gama(i)*LOG(10.d0)*gamadb(i)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
gamadb(i) = 0.D0
|
|
x2db = 0.D0
|
|
ELSE
|
|
x2db = gamadb(i)
|
|
gamadb(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) gamadb(i) = gamadb(i) + x2db
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamadb(4) = gamadb(4) + 0.2d0*3.d0*gamadb(13)
|
|
gamadb(9) = gamadb(9) + 0.2d0*2.d0*gamadb(13)
|
|
gamadb(13) = 0.D0
|
|
DO ii1=1,3
|
|
f1db(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2db(ii1) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp0db2 = zz(12)*gamadb(12)/(z(2)+z(6))
|
|
f1db(2) = f1db(2) + temp0db2/z(2)
|
|
f2db(3) = f2db(3) + temp0db2/z(6)
|
|
hdb = -(zz(12)*gamadb(12))
|
|
gamadb(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp0db3 = zz(11)*gamadb(11)/(z(1)+z(4))
|
|
f2db(1) = f2db(1) + temp0db3/z(4)
|
|
hdb = hdb - zz(11)*gamadb(11)
|
|
gamadb(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp0db4 = zz(10)*gamadb(10)/(z(1)+z(7))
|
|
f1db(1) = f1db(1) + temp0db4/z(1) + temp0db3/z(1)
|
|
f2db(4) = f2db(4) + temp0db4/z(7)
|
|
hdb = hdb - zz(10)*gamadb(10)
|
|
gamadb(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp0db5 = zz(9)*gamadb(9)/(z(3)+z(6))
|
|
f1db(3) = f1db(3) + temp0db5/z(3)
|
|
hdb = hdb - zz(9)*gamadb(9)
|
|
gamadb(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp0db6 = zz(8)*gamadb(8)/(z(1)+z(6))
|
|
f2db(3) = f2db(3) + temp0db6/z(6) + temp0db5/z(6)
|
|
hdb = hdb - zz(8)*gamadb(8)
|
|
gamadb(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp0db7 = zz(7)*gamadb(7)/(z(1)+z(5))
|
|
f1db(1) = f1db(1) + temp0db7/z(1) + temp0db6/z(1)
|
|
f2db(2) = f2db(2) + temp0db7/z(5)
|
|
hdb = hdb - zz(7)*gamadb(7)
|
|
gamadb(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp0db8 = zz(6)*gamadb(6)/(z(3)+z(4))
|
|
f2db(1) = f2db(1) + temp0db8/z(4)
|
|
hdb = hdb - zz(6)*gamadb(6)
|
|
gamadb(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp0db9 = zz(5)*gamadb(5)/(z(3)+z(7))
|
|
f2db(4) = f2db(4) + temp0db9/z(7)
|
|
hdb = hdb - zz(5)*gamadb(5)
|
|
gamadb(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp0db10 = zz(4)*gamadb(4)/(z(3)+z(5))
|
|
f1db(3) = f1db(3) + temp0db9/z(3) + temp0db10/z(3) + temp0db8/z(3)
|
|
f2db(2) = f2db(2) + temp0db10/z(5)
|
|
hdb = hdb - zz(4)*gamadb(4)
|
|
gamadb(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp0db11 = zz(3)*gamadb(3)/(z(2)+z(7))
|
|
f2db(4) = f2db(4) + temp0db11/z(7)
|
|
hdb = hdb - zz(3)*gamadb(3)
|
|
gamadb(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp0db12 = zz(2)*gamadb(2)/(z(2)+z(5))
|
|
f2db(2) = f2db(2) + temp0db12/z(5)
|
|
hdb = hdb - zz(2)*gamadb(2)
|
|
gamadb(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp0db13 = zz(1)*gamadb(1)/(z(2)+z(4))
|
|
f1db(2) = f1db(2) + temp0db12/z(2) + temp0db13/z(2) + temp0db11/z(
|
|
+ 2)
|
|
f2db(1) = f2db(1) + temp0db13/z(4)
|
|
hdb = hdb - zz(1)*gamadb(1)
|
|
gamadb(1) = 0.D0
|
|
ionicdb = 0.D0
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0db(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mpldb = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijdb = (g0(i, j)+zpl*zmi*h)*f2db(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0db(i, j) = g0db(i, j) + yji*f1db(i) + xij*f2db(j)
|
|
hdb = hdb + yji*zpl*zmi*f1db(i) + xij*zpl*zmi*f2db(j)
|
|
yjidb = (g0(i, j)+zpl*zmi*h)*f1db(i)
|
|
temp0db1 = molal(j+3)*yjidb/water
|
|
molaldb(j+3) = molaldb(j+3) + ch*yjidb/water
|
|
chdb = mpl*xijdb + temp0db1
|
|
waterdb = waterdb - ch*temp0db1/water
|
|
mpldb = mpldb + ch*xijdb
|
|
ionicdb = ionicdb - (zpl+zmi)**2*0.25d0*chdb/ionic**2
|
|
ENDDO
|
|
CALL POPREAL8(mpl)
|
|
molaldb(i) = molaldb(i) + mpldb/water
|
|
waterdb = waterdb - molal(i)*mpldb/water**2
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp0db0 = agama*hdb/(sion+1.d0)
|
|
siondb = (1.D0-sion/(sion+1.d0))*temp0db0
|
|
IF (.NOT.ionic == 0.0) ionicdb = ionicdb + siondb/(2.0*SQRT(
|
|
+ ionic))
|
|
g05db = g0db(3, 4)
|
|
g0db(3, 4) = 0.D0
|
|
g09db = g0db(3, 3)
|
|
g0db(3, 3) = 0.D0
|
|
g04db = g0db(3, 2)
|
|
g0db(3, 2) = 0.D0
|
|
g06db = g0db(3, 1)
|
|
g0db(3, 1) = 0.D0
|
|
g03db = g0db(2, 4)
|
|
g0db(2, 4) = 0.D0
|
|
g12db = g0db(2, 3)
|
|
g0db(2, 3) = 0.D0
|
|
g02db = g0db(2, 2)
|
|
g0db(2, 2) = 0.D0
|
|
g01db = g0db(2, 1)
|
|
g0db(2, 1) = 0.D0
|
|
g10db = g0db(1, 4)
|
|
g0db(1, 4) = 0.D0
|
|
g08db = g0db(1, 3)
|
|
g0db(1, 3) = 0.D0
|
|
g07db = g0db(1, 2)
|
|
g0db(1, 2) = 0.D0
|
|
g11db = g0db(1, 1)
|
|
CALL KMFUL3_DB(ionic, ionicdb, temp, g01, g01db, g02, g02db, g03,
|
|
+ g03db, g04, g04db, g05, g05db, g06, g06db, g07,
|
|
+ g07db, g08, g08db, g09, g09db, g10, g10db, g11,
|
|
+ g11db, g12, g12db)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionic)
|
|
x1db = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1db = ionicdb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ionicdb = 0.D0
|
|
ELSE
|
|
temp0db = 0.5d0*x1db/water
|
|
ionicdb = temp0db
|
|
waterdb = waterdb - ionic*temp0db/water
|
|
END IF
|
|
DO i=7,1,-1
|
|
molaldb(i) = molaldb(i) + z(i)**2*ionicdb
|
|
ENDDO
|
|
END
|
|
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_DB(ionic, ionicdb, temp, g01, g01db, g02, g02db
|
|
+ , g03, g03db, g04, g04db, g05, g05db, g06,
|
|
+ g06db, g07, g07db, g08, g08db, g09, g09db,
|
|
+ g10, g10db, g11, g11db, g12, g12db)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionicdb, siondb, cf2db
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01db, g02db, g03db, g04db, g05db, g06db, g07db,
|
|
+ g08db, g09db, g10db, g11db, g12db
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0db0
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp0db
|
|
REAL*8 :: abs1
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01db = g01db + g12db
|
|
g08db = g08db + g09db + g12db
|
|
g11db = g11db - g09db - g12db
|
|
g06db = g06db + g09db
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2db = -(z10*g10db) - z07*g07db - z05*g05db - z03*g03db - z01*
|
|
+ g01db - z02*g02db - z04*g04db - z06*g06db - z08*g08db - z11*
|
|
+ g11db
|
|
g11db = cf1*g11db
|
|
g10db = cf1*g10db
|
|
g08db = cf1*g08db
|
|
g07db = cf1*g07db
|
|
g06db = cf1*g06db
|
|
g05db = cf1*g05db
|
|
g04db = cf1*g04db
|
|
g03db = cf1*g03db
|
|
g02db = cf1*g02db
|
|
g01db = cf1*g01db
|
|
temp0db = (0.125d0-ti*0.005d0)*cf2db
|
|
temp0db0 = -(0.41d0*temp0db/(sion+1.d0))
|
|
ionicdb = ionicdb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0db
|
|
siondb = (1.D0-sion/(sion+1.d0))*temp0db0
|
|
ELSE
|
|
siondb = 0.D0
|
|
END IF
|
|
CALL MKBI_DB(q11, ionic, ionicdb, sion, siondb, z11, g11, g11db)
|
|
CALL MKBI_DB(q10, ionic, ionicdb, sion, siondb, z10, g10, g10db)
|
|
CALL MKBI_DB(q8, ionic, ionicdb, sion, siondb, z08, g08, g08db)
|
|
CALL MKBI_DB(q7, ionic, ionicdb, sion, siondb, z07, g07, g07db)
|
|
CALL MKBI_DB(q6, ionic, ionicdb, sion, siondb, z06, g06, g06db)
|
|
CALL MKBI_DB(q5, ionic, ionicdb, sion, siondb, z05, g05, g05db)
|
|
CALL MKBI_DB(q4, ionic, ionicdb, sion, siondb, z04, g04, g04db)
|
|
CALL MKBI_DB(q3, ionic, ionicdb, sion, siondb, z03, g03, g03db)
|
|
CALL MKBI_DB(q2, ionic, ionicdb, sion, siondb, z02, g02, g02db)
|
|
CALL MKBI_DB(q1, ionic, ionicdb, sion, siondb, z01, g01, g01db)
|
|
IF (.NOT.ionic == 0.0) ionicdb = ionicdb + siondb/(2.0*SQRT(
|
|
+ ionic))
|
|
END
|
|
|
|
C Differentiation of mkbi in reverse (adjoint) mode:
|
|
C gradient of useful results: sion bi ionic
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_DB(q, ionic, ionicdb, sion, siondb, zip, bi, bidb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionicdb, siondb, bidb
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: cdb, xxdb
|
|
INTRINSIC EXP
|
|
REAL*8 :: tempdb
|
|
INTRINSIC LOG10
|
|
REAL*8 :: tempdb0
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic))
|
|
bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b
|
|
C
|
|
xxdb = zip*bidb
|
|
bidb = zip*bidb/(bi*LOG(10.0))
|
|
tempdb = -(0.5107d0*xxdb/(c*sion+1.d0))
|
|
tempdb0 = -(sion*tempdb/(c*sion+1.d0))
|
|
siondb = siondb + c*tempdb0 + tempdb
|
|
cdb = sion*tempdb0
|
|
IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q
|
|
+ ))) THEN
|
|
ionicdb = ionicdb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*
|
|
+ ionic**2*cdb
|
|
ELSE
|
|
ionicdb = ionicdb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bidb -
|
|
+ .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cdb
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of funcd3b_dnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: molal molalr gama water gnh3
|
|
C ghno3 chi3 chi4 psi1 psi2 fd3bdnrd fd3b
|
|
C with respect to varying inputs: gnh3 ghno3 chi3 chi4 psi1 psi2
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of funcd3b in forward (tangent) mode:
|
|
C variations of useful results: fd3b
|
|
C with respect to varying inputs: p4
|
|
C RW status of diff variables: p4:in fd3b:out
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** FUNCTION FUNCD3
|
|
C *** CASE D3
|
|
C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ;
|
|
C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3.
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCD3B_DNRD_DB(p4, p4dnrd, fd3b, fd3bdb, fd3bdnrd,
|
|
+ fd3bdnrddb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: psi3db
|
|
REAL*8 :: psi3dnrd
|
|
REAL*8 :: psi3dnrddb
|
|
REAL*8 :: psi4dnrd
|
|
REAL*8 :: a3db
|
|
REAL*8 :: a3dnrd
|
|
REAL*8 :: a3dnrddb
|
|
REAL*8 :: a4db
|
|
REAL*8 :: a4dnrd
|
|
REAL*8 :: a4dnrddb
|
|
REAL*8 :: a7db
|
|
REAL*8 :: a7dnrd
|
|
REAL*8 :: a7dnrddb
|
|
|
|
REAL*8 :: p4, bb, denm, ahi, aml5, fd3b
|
|
REAL*8 :: bbdb, denmdb, ahidb, aml5db, fd3bdb
|
|
REAL*8 :: p4dnrd, bbdnrd, denmdnrd, ahidnrd, aml5dnrd,
|
|
+ fd3bdnrd
|
|
REAL*8 :: bbdnrddb, denmdnrddb, ahidnrddb, aml5dnrddb,
|
|
+ fd3bdnrddb
|
|
REAL*8 :: molalrdnrd(npair), molalrdnrddb(npair)
|
|
CHARACTER(LEN=40) errinf
|
|
INTEGER :: errstki(25), k, j
|
|
LOGICAL :: dexs, iexs, eof
|
|
CHARACTER(LEN=40) errmsgi(25)
|
|
LOGICAL tst
|
|
INTEGER :: i
|
|
REAL*8 :: abb
|
|
REAL*8 :: abbdb
|
|
REAL*8 :: abbdnrd
|
|
REAL*8 :: abbdnrddb
|
|
REAL*8 :: arg1
|
|
REAL*8 :: arg1db
|
|
REAL*8 :: arg1dnrd
|
|
REAL*8 :: arg1dnrddb
|
|
REAL*8 :: result1
|
|
REAL*8 :: result1db
|
|
REAL*8 :: result1dnrd
|
|
REAL*8 :: result1dnrddb
|
|
REAL*8 :: x1dnrd
|
|
REAL*8 :: x1dnrddb
|
|
INTRINSIC MAX
|
|
INTRINSIC ABS
|
|
REAL*8 :: x2
|
|
REAL*8 :: x2db
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1db
|
|
REAL*8 :: max1dnrd
|
|
REAL*8 :: x2dnrd
|
|
REAL*8 :: x2dnrddb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: max1
|
|
REAL*8 :: max1db
|
|
INTEGER :: branch
|
|
REAL*8 :: temp3
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp4db
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp27
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp26
|
|
REAL*8 :: temp25
|
|
REAL*8 :: temp24
|
|
REAL*8 :: temp23
|
|
REAL*8 :: temp22
|
|
REAL*8 :: temp21
|
|
REAL*8 :: temp20
|
|
REAL*8 :: temp23db
|
|
REAL*8 :: temp0db1
|
|
REAL*8 :: temp0db0
|
|
REAL*8 :: temp7db
|
|
REAL*8 :: temp16db
|
|
REAL*8 :: temp2db
|
|
REAL*8 :: temp11db
|
|
REAL*8 :: temp27db0
|
|
REAL*8 :: temp19
|
|
REAL*8 :: temp18
|
|
REAL*8 :: temp17
|
|
REAL*8 :: temp16
|
|
REAL*8 :: temp21db
|
|
REAL*8 :: temp15
|
|
REAL*8 :: temp14
|
|
REAL*8 :: temp13
|
|
REAL*8 :: temp19db
|
|
REAL*8 :: temp12
|
|
REAL*8 :: temp11
|
|
REAL*8 :: temp10
|
|
REAL*8 :: temp5db
|
|
REAL*8 :: temp14db
|
|
REAL*8 :: temp3db0
|
|
REAL*8 :: temp0db
|
|
REAL*8 :: temp17db0
|
|
REAL*8 :: temp24db
|
|
REAL*8 :: temp8db
|
|
REAL*8 :: temp18db2
|
|
REAL*8 :: temp17db
|
|
REAL*8 :: temp18db1
|
|
REAL*8 :: temp18db0
|
|
REAL*8 :: temp5db0
|
|
REAL*8 :: temp3db
|
|
REAL*8 :: temp12db
|
|
REAL*8 :: temp27db
|
|
REAL*8 :: temp6db2
|
|
REAL*8 :: temp6db1
|
|
REAL*8 :: temp6db0
|
|
INTEGER :: ii10
|
|
REAL*8 :: temp22db
|
|
REAL*8 :: temp6db
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp1db
|
|
REAL*8 :: temp10db
|
|
REAL*8 :: temp10db0
|
|
REAL*8 :: temp9
|
|
REAL*8 :: temp8
|
|
REAL*8 :: temp20db
|
|
REAL*8 :: temp7
|
|
REAL*8 :: temp9db
|
|
REAL*8 :: temp6
|
|
REAL*8 :: temp5
|
|
REAL*8 :: temp18db
|
|
REAL*8 :: temp4
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
psi4dnrd = p4dnrd
|
|
psi4 = p4
|
|
DO ii1=1,nions
|
|
molaldnrd(ii1) = 0.d0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
molalrdnrd(ii1) = 0.d0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
gamadnrd(ii1) = 0.d0
|
|
ENDDO
|
|
waterdnrd = 0.d0
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(a3dnrd)
|
|
C
|
|
a3dnrd = xk4*r*temp*2.0*water*(waterdnrd*gama(10)-water*gamadnrd
|
|
+ (10))/gama(10)**3
|
|
a3 = xk4*r*temp*(water/gama(10))**2.0
|
|
CALL PUSHREAL8(a4dnrd)
|
|
a4dnrd = xk2*r*temp*2.0*gama(10)*(gamadnrd(10)*gama(5)-gama(10)*
|
|
+ gamadnrd(5))/(xkw*gama(5)**3)
|
|
CALL PUSHREAL8(a4)
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
CALL PUSHREAL8(a7dnrd)
|
|
a7dnrd = xkw*rh*(waterdnrd*water+water*waterdnrd)
|
|
CALL PUSHREAL8(a7)
|
|
a7 = xkw*rh*water*water
|
|
C
|
|
psi3dnrd = chi3*((a3dnrd*a4+a3*a4dnrd)*(chi4-psi4)-a3*a4*
|
|
+ psi4dnrd) - psi1*psi4dnrd
|
|
psi3 = a3*a4*chi3*(chi4-psi4) - psi1*(2.d0*psi2+psi1+psi4)
|
|
CALL PUSHREAL8(psi3dnrd)
|
|
psi3dnrd = (psi3dnrd*(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4)-
|
|
+ psi3*((a3dnrd*a4+a3*a4dnrd)*(chi4-psi4)-a3*a4*psi4dnrd+
|
|
+ psi4dnrd))/(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4)**2
|
|
CALL PUSHREAL8(psi3)
|
|
psi3 = psi3/(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4)
|
|
IF (psi3 < zero) THEN
|
|
x1 = zero
|
|
x1dnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1dnrd = psi3dnrd
|
|
x1 = psi3
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 > chi3) THEN
|
|
psi3 = chi3
|
|
psi3dnrd = 0.d0
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
psi3dnrd = x1dnrd
|
|
psi3 = x1
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
CALL PUSHREAL8(bbdnrd)
|
|
C
|
|
bbdnrd = psi4dnrd - psi3dnrd
|
|
CALL PUSHREAL8(bb)
|
|
bb = psi4 - psi3
|
|
arg1dnrd = bbdnrd*bb + bb*bbdnrd + 4.d0*a7dnrd
|
|
arg1 = bb*bb + 4.d0*a7
|
|
IF (arg1 >= 0.) THEN
|
|
abs1 = arg1
|
|
ELSE
|
|
abs1 = -arg1
|
|
END IF
|
|
IF (abs1 < tiny) THEN
|
|
result1dnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
result1dnrd = arg1dnrd/(2.0*SQRT(arg1))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
result1 = SQRT(arg1)
|
|
CALL PUSHREAL8(denmdnrd)
|
|
denmdnrd = bbdnrd + result1dnrd
|
|
CALL PUSHREAL8(denm)
|
|
denm = bb + result1
|
|
IF (denm <= tiny) THEN
|
|
IF (bb >= 0.d0) THEN
|
|
CALL PUSHREAL8(abbdnrd)
|
|
abbdnrd = bbdnrd
|
|
CALL PUSHREAL8(abb)
|
|
abb = bb
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(abbdnrd)
|
|
abbdnrd = -bbdnrd
|
|
CALL PUSHREAL8(abb)
|
|
abb = -bb
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C Taylor expansion of SQRT
|
|
denmdnrd = bbdnrd + abbdnrd + (2.0*a7dnrd*abb-2.0*a7*abbdnrd)/
|
|
+ abb**2 - (2.0*(a7dnrd*a7+a7*a7dnrd)*abb**3.0-2.0*a7**2*3.0*
|
|
+ abb**2.0*abbdnrd)/(abb**3.0)**2
|
|
denm = bb + abb + 2.0*a7/abb - 2.0*a7*a7/abb**3.0
|
|
C WRITE(*,*) 'TS approx. of DENM: ',DENM
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ahidnrd = (2.d0*a7dnrd*denm-2.d0*a7*denmdnrd)/denm**2
|
|
ahi = 2.d0*a7/denm
|
|
CALL PUSHREAL8(molaldnrd(1))
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
C HI
|
|
molaldnrd(1) = ahidnrd
|
|
CALL PUSHREAL8(molal(1))
|
|
molal(1) = ahi
|
|
CALL PUSHREAL8(molaldnrd(3))
|
|
C NH4I
|
|
molaldnrd(3) = psi4dnrd
|
|
CALL PUSHREAL8(molal(3))
|
|
molal(3) = psi1 + psi4 + 2.d0*psi2
|
|
CALL PUSHREAL8(molaldnrd(5))
|
|
C SO4I
|
|
molaldnrd(5) = 0.d0
|
|
CALL PUSHREAL8(molal(5))
|
|
molal(5) = psi2
|
|
CALL PUSHREAL8(molaldnrd(6))
|
|
C HSO4I
|
|
molaldnrd(6) = 0.d0
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = zero
|
|
CALL PUSHREAL8(molaldnrd(7))
|
|
C NO3I
|
|
molaldnrd(7) = psi3dnrd
|
|
CALL PUSHREAL8(molal(7))
|
|
molal(7) = psi3 + psi1
|
|
C Solid (NH4)2SO4
|
|
C Solid NH4NO3
|
|
C Gas HNO3
|
|
C Gas NH3
|
|
gnh3dnrd = -psi4dnrd
|
|
gnh3 = chi4 - psi4
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C (NH4)2SO4
|
|
molalrdnrd(4) = molaldnrd(5) + molaldnrd(6)
|
|
molalr(4) = molal(5) + molal(6)
|
|
C "free" NH4
|
|
aml5dnrd = molaldnrd(3) - 2.d0*molalrdnrd(4)
|
|
aml5 = molal(3) - 2.d0*molalr(4)
|
|
IF (aml5 > molal(7)) THEN
|
|
x2dnrd = molaldnrd(7)
|
|
x2 = molal(7)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x2dnrd = aml5dnrd
|
|
x2 = aml5
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < zero) THEN
|
|
molalrdnrd(5) = 0.d0
|
|
molalr(5) = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
molalrdnrd(5) = x2dnrd
|
|
molalr(5) = x2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8(water)
|
|
C
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
CALL PUSHREAL8(waterdnrd)
|
|
waterdnrd = 0.d0
|
|
DO j=1,npair
|
|
waterdnrd = waterdnrd + molalrdnrd(j)/m0(j)
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
waterdnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
CALL PUSHREAL8ARRAY(gamadnrd, npair)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C
|
|
CALL CALCACT3P_DNRD()
|
|
ENDDO
|
|
IF (gnh3 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
max1 = tiny
|
|
max1dnrd = 0.d0
|
|
ELSE
|
|
max1dnrd = gnh3dnrd
|
|
max1 = gnh3
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
temp27db0 = fd3bdnrddb/a4**2
|
|
temp26 = max1**2
|
|
temp20 = a4/temp26
|
|
temp21db = temp20*temp27db0
|
|
temp25 = molal(1)**2
|
|
temp23 = max1/temp25
|
|
temp24db = temp23*temp21db
|
|
temp24 = molaldnrd(3)*molal(1) - molal(3)*molaldnrd(1)
|
|
temp23db = temp24*temp21db/temp25
|
|
temp22 = molal(3)/molal(1)
|
|
temp22db = -(max1dnrd*temp21db/molal(1))
|
|
temp21 = temp24*temp23 - max1dnrd*temp22
|
|
temp20db = temp21*temp27db0/temp26
|
|
temp18 = molal(1)*max1
|
|
temp19db = -(temp27db0/temp18)
|
|
temp19 = molal(3)*a4dnrd/temp18
|
|
temp18db2 = -(temp19*temp19db)
|
|
temp27 = molal(1)*max1*a4
|
|
temp27db = -(molal(3)*fd3bdb/temp27**2)
|
|
molaldb(3) = molaldb(3) + fd3bdb/temp27
|
|
molaldb(1) = molaldb(1) + molaldnrd(3)*temp24db - temp23*2*molal(1
|
|
+ )*temp23db - temp22*temp22db + max1*temp18db2 + max1*a4*temp27db
|
|
max1db = temp23db - temp20*2*max1*temp20db + molal(1)*temp18db2 +
|
|
+ molal(1)*a4*temp27db
|
|
a4db = temp20db - (temp21*temp20-temp19)*2*temp27db0/a4 + molal(1)
|
|
+ *max1*temp27db
|
|
DO ii10=1,nions
|
|
molaldnrddb(ii10) = 0.D0
|
|
ENDDO
|
|
molaldnrddb(3) = molaldnrddb(3) + molal(1)*temp24db
|
|
molaldb(3) = molaldb(3) + a4dnrd*temp19db + temp22db - molaldnrd(1
|
|
+ )*temp24db
|
|
molaldnrddb(1) = molaldnrddb(1) - molal(3)*temp24db
|
|
a4dnrddb = molal(3)*temp19db
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) gnh3db = gnh3db + max1db
|
|
DO ii10=1,npair
|
|
gamadnrddb(ii10) = 0.D0
|
|
ENDDO
|
|
waterdnrddb = 0.D0
|
|
DO ii10=1,npair
|
|
molalrdnrddb(ii10) = 0.D0
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPREAL8ARRAY(gamadnrd, npair)
|
|
CALL CALCACT3P_DNRD_DB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
waterdb = 0.D0
|
|
waterdnrddb = 0.D0
|
|
END IF
|
|
DO j=npair,1,-1
|
|
molalrdb(j) = molalrdb(j) + waterdb/m0(j)
|
|
molalrdnrddb(j) = molalrdnrddb(j) + waterdnrddb/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(waterdnrd)
|
|
CALL POPREAL8(water)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
molalrdb(5) = 0.D0
|
|
molalrdnrddb(5) = 0.D0
|
|
x2dnrddb = 0.D0
|
|
x2db = 0.D0
|
|
ELSE
|
|
x2db = molalrdb(5)
|
|
molalrdb(5) = 0.D0
|
|
x2dnrddb = molalrdnrddb(5)
|
|
molalrdnrddb(5) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
molaldb(7) = molaldb(7) + x2db
|
|
molaldnrddb(7) = molaldnrddb(7) + x2dnrddb
|
|
aml5dnrddb = 0.D0
|
|
aml5db = 0.D0
|
|
ELSE
|
|
aml5db = x2db
|
|
aml5dnrddb = x2dnrddb
|
|
END IF
|
|
molaldb(3) = molaldb(3) + aml5db
|
|
molalrdb(4) = molalrdb(4) - 2.d0*aml5db
|
|
molaldnrddb(3) = molaldnrddb(3) + aml5dnrddb
|
|
molalrdnrddb(4) = molalrdnrddb(4) - 2.d0*aml5dnrddb
|
|
molaldb(5) = molaldb(5) + molalrdb(4)
|
|
molaldb(6) = molaldb(6) + molalrdb(4)
|
|
molalrdb(4) = 0.D0
|
|
molaldnrddb(5) = molaldnrddb(5) + molalrdnrddb(4)
|
|
molaldnrddb(6) = molaldnrddb(6) + molalrdnrddb(4)
|
|
molalrdnrddb(4) = 0.D0
|
|
chi4db = chi4db + gnh3db
|
|
chi3db = chi3db + ghno3db
|
|
psi3db = molaldb(7) - ghno3db
|
|
CALL POPREAL8(molal(7))
|
|
psi1db = psi1db + molaldb(7)
|
|
molaldb(7) = 0.D0
|
|
CALL POPREAL8(molaldnrd(7))
|
|
psi3dnrddb = molaldnrddb(7)
|
|
molaldnrddb(7) = 0.D0
|
|
CALL POPREAL8(molal(6))
|
|
molaldb(6) = 0.D0
|
|
CALL POPREAL8(molaldnrd(6))
|
|
molaldnrddb(6) = 0.D0
|
|
CALL POPREAL8(molal(5))
|
|
psi2db = psi2db + molaldb(5)
|
|
molaldb(5) = 0.D0
|
|
CALL POPREAL8(molaldnrd(5))
|
|
molaldnrddb(5) = 0.D0
|
|
CALL POPREAL8(molal(3))
|
|
psi1db = psi1db + molaldb(3)
|
|
psi2db = psi2db + 2.d0*molaldb(3)
|
|
molaldb(3) = 0.D0
|
|
CALL POPREAL8(molaldnrd(3))
|
|
molaldnrddb(3) = 0.D0
|
|
CALL POPREAL8(molal(1))
|
|
ahidb = molaldb(1)
|
|
molaldb(1) = 0.D0
|
|
CALL POPREAL8(molaldnrd(1))
|
|
ahidnrddb = molaldnrddb(1)
|
|
molaldnrddb(1) = 0.D0
|
|
temp18db0 = 2.d0*ahidb/denm
|
|
temp18db1 = ahidnrddb/denm**2
|
|
a7db = temp18db0 - 2.d0*denmdnrd*temp18db1
|
|
denmdb = (2.d0*a7dnrd-(2.d0*(a7dnrd*denm)-2.d0*(a7*denmdnrd))*2/
|
|
+ denm)*temp18db1 - a7*temp18db0/denm
|
|
a7dnrddb = 2.d0*denm*temp18db1
|
|
denmdnrddb = -(2.d0*a7*temp18db1)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
temp16 = abb**3.0
|
|
temp16db = -(denmdnrddb/temp16**2)
|
|
temp15 = abb**3.0
|
|
temp14 = a7dnrd*a7 + a7*a7dnrd
|
|
temp14db = 2.0*temp15*temp16db
|
|
temp13 = abb**2.0
|
|
temp12 = a7**2*abbdnrd
|
|
temp12db = -(3.0*2.0*temp16db)
|
|
temp17db0 = denmdnrddb/abb**2
|
|
temp18db = 2.0*denmdb/abb
|
|
temp17 = abb**3.0
|
|
temp17db = -(2.0*denmdb/temp17)
|
|
bbdb = denmdb
|
|
abbdb = (2.0*a7dnrd-(2.0*(a7dnrd*abb)-2.0*(a7*abbdnrd))*2/abb)
|
|
+ *temp17db0 + (temp14*2.0*3.0*abb**2.0-2*(2.0*(temp14*temp15)
|
|
+ -3.0*2.0*(temp12*temp13))*3.0*abb**2.0/temp16)*temp16db +
|
|
+ temp12*2.0*abb*temp12db - a7**2*3.0*abb**2.0*temp17db/temp17
|
|
+ - a7*temp18db/abb + denmdb
|
|
a7db = a7db + 2*a7dnrd*temp14db - 2.0*abbdnrd*temp17db0 +
|
|
+ abbdnrd*temp13*2*a7*temp12db + 2*a7*temp17db + temp18db
|
|
bbdnrddb = denmdnrddb
|
|
abbdnrddb = temp13*a7**2*temp12db - 2.0*a7*temp17db0 +
|
|
+ denmdnrddb
|
|
a7dnrddb = a7dnrddb + 2*a7*temp14db + 2.0*abb*temp17db0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(abb)
|
|
bbdb = bbdb + abbdb
|
|
CALL POPREAL8(abbdnrd)
|
|
bbdnrddb = bbdnrddb + abbdnrddb
|
|
ELSE
|
|
CALL POPREAL8(abb)
|
|
bbdb = bbdb - abbdb
|
|
CALL POPREAL8(abbdnrd)
|
|
bbdnrddb = bbdnrddb - abbdnrddb
|
|
END IF
|
|
denmdnrddb = 0.D0
|
|
denmdb = 0.D0
|
|
ELSE
|
|
bbdnrddb = 0.D0
|
|
bbdb = 0.D0
|
|
END IF
|
|
CALL POPREAL8(denm)
|
|
bbdb = bbdb + denmdb
|
|
result1db = denmdb
|
|
CALL POPREAL8(denmdnrd)
|
|
bbdnrddb = bbdnrddb + denmdnrddb
|
|
result1dnrddb = denmdnrddb
|
|
arg1 = bb*bb + 4.d0*a7
|
|
IF (arg1 == 0.0) THEN
|
|
arg1db = 0.0
|
|
ELSE
|
|
arg1db = result1db/(2.0*SQRT(arg1))
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
arg1dnrddb = 0.D0
|
|
ELSE
|
|
arg1dnrd = bbdnrd*bb + bb*bbdnrd + 4.d0*a7dnrd
|
|
temp11 = SQRT(arg1)
|
|
temp11db = result1dnrddb/(2.0*temp11)
|
|
arg1dnrddb = temp11db
|
|
IF (.NOT.arg1 == 0.0) arg1db = arg1db - arg1dnrd*temp11db/(
|
|
+ 2.0*temp11**2)
|
|
END IF
|
|
bbdb = bbdb + 2*bbdnrd*arg1dnrddb + 2*bb*arg1db
|
|
a7db = a7db + 4.d0*arg1db
|
|
bbdnrddb = bbdnrddb + 2*bb*arg1dnrddb
|
|
a7dnrddb = a7dnrddb + 4.d0*arg1dnrddb
|
|
CALL POPREAL8(bb)
|
|
psi3db = psi3db - bbdb
|
|
CALL POPREAL8(bbdnrd)
|
|
psi3dnrddb = psi3dnrddb - bbdnrddb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
x1db = psi3db
|
|
x1dnrddb = psi3dnrddb
|
|
ELSE
|
|
chi3db = chi3db + psi3db
|
|
x1db = 0.D0
|
|
x1dnrddb = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
psi3db = 0.D0
|
|
psi3dnrddb = 0.D0
|
|
ELSE
|
|
psi3db = x1db
|
|
psi3dnrddb = x1dnrddb
|
|
END IF
|
|
a3 = xk4*r*temp*(water/gama(10))**2.0
|
|
CALL POPREAL8(psi3)
|
|
temp10 = psi4 + a3*a4*(chi4-psi4) + 2.d0*psi2 + psi1
|
|
temp10db = -(psi3*psi3db/temp10**2)
|
|
CALL POPREAL8(psi3dnrd)
|
|
temp6 = psi4 + a3*a4*(chi4-psi4) + 2.d0*psi2 + psi1
|
|
temp10db0 = psi3dnrddb/temp6**2
|
|
temp9 = psi4 + a3*a4*(chi4-psi4) + 2.d0*psi2 + psi1
|
|
temp9db = psi3dnrd*temp10db0
|
|
temp7 = a3dnrd*a4 + a3*a4dnrd
|
|
temp8 = psi4dnrd + temp7*(chi4-psi4) - psi4dnrd*a3*a4
|
|
psi3db = psi3db/temp10 - temp8*temp10db0
|
|
temp8db = -(psi3*temp10db0)
|
|
temp7db = (chi4-psi4)*temp8db
|
|
temp6db = -((psi3dnrd*temp9-psi3*temp8)*2*temp10db0/temp6)
|
|
psi2db = psi2db + 2.d0*temp9db + 2.d0*temp6db - psi1*2.d0*psi3db
|
|
+ + 2.d0*temp10db
|
|
psi3dnrddb = temp9*temp10db0
|
|
psi1db = psi1db + temp9db + temp6db - psi4dnrd*psi3dnrddb + ((-2
|
|
+ )*psi1-psi4-2.d0*psi2)*psi3db + temp10db
|
|
temp6db1 = chi3*(chi4-psi4)*psi3db
|
|
temp6db2 = a3*a4*psi3db
|
|
temp5 = a3dnrd*a4 + a3*a4dnrd
|
|
chi3db = chi3db + (temp5*(chi4-psi4)-psi4dnrd*(a3*a4))*
|
|
+ psi3dnrddb + (chi4-psi4)*temp6db2
|
|
temp6db0 = chi3*psi3dnrddb
|
|
chi4db = chi4db + a3*a4*temp9db + temp7*temp8db + a3*a4*temp6db
|
|
+ + temp5*temp6db0 + chi3*temp6db2 + a3*a4*temp10db
|
|
temp5db = (chi4-psi4)*temp6db0
|
|
a3db = (chi4-psi4)*a4*temp9db + a4dnrd*temp7db - psi4dnrd*a4*
|
|
+ temp8db + (chi4-psi4)*a4*temp6db + a4dnrd*temp5db - psi4dnrd*
|
|
+ a4*temp6db0 + a4*temp6db1 + (chi4-psi4)*a4*temp10db
|
|
a4db = a4db + (chi4-psi4)*a3*temp9db + a3dnrd*temp7db - psi4dnrd
|
|
+ *a3*temp8db + (chi4-psi4)*a3*temp6db + a3dnrd*temp5db -
|
|
+ psi4dnrd*a3*temp6db0 + a3*temp6db1 + (chi4-psi4)*a3*temp10db
|
|
a3dnrddb = a4*temp5db + a4*temp7db
|
|
a4dnrddb = a4dnrddb + a3*temp5db + a3*temp7db
|
|
CALL POPREAL8(a7)
|
|
CALL POPREAL8(a7dnrd)
|
|
temp5db0 = xkw*rh*a7dnrddb
|
|
CALL POPREAL8(a4)
|
|
temp4 = gama(10)/gama(5)
|
|
temp4db = 2.0*temp4*xk2*r*temp*a4db/(xkw*gama(5))
|
|
gamadb(10) = gamadb(10) + temp4db
|
|
CALL POPREAL8(a4dnrd)
|
|
temp3 = xkw*gama(5)**3
|
|
temp2 = gama(10)/temp3
|
|
temp3db0 = xk2*2.0*r*temp*a4dnrddb
|
|
temp3db = temp2*temp3db0
|
|
temp2db = (gamadnrd(10)*gama(5)-gama(10)*gamadnrd(5))*temp3db0/
|
|
+ temp3
|
|
gamadb(5) = gamadb(5) + gamadnrd(10)*temp3db - xkw*temp2*3*gama(
|
|
+ 5)**2*temp2db - temp4*temp4db
|
|
gamadnrddb(10) = gamadnrddb(10) + gama(5)*temp3db
|
|
gamadnrddb(5) = gamadnrddb(5) - gama(10)*temp3db
|
|
temp1 = water/gama(10)
|
|
temp1db = 2.0*temp1*xk4*r*temp*a3db/gama(10)
|
|
CALL POPREAL8(a3dnrd)
|
|
temp0 = gama(10)**3
|
|
temp0db1 = xk4*2.0*r*temp*a3dnrddb
|
|
temp0db = water*temp0db1/temp0
|
|
waterdnrddb = gama(10)*temp0db + 2*water*temp5db0
|
|
temp0db0 = (waterdnrd*gama(10)-water*gamadnrd(10))*temp0db1/
|
|
+ temp0
|
|
waterdb = 2*waterdnrd*temp5db0 - gamadnrd(10)*temp0db + temp0db0
|
|
+ + temp1db + xkw*rh*2*water*a7db
|
|
gamadb(10) = gamadb(10) + waterdnrd*temp0db - water*3*gama(10)**
|
|
+ 2*temp0db0/temp0 - temp1*temp1db + temp2db - gamadnrd(5)*
|
|
+ temp3db
|
|
gamadnrddb(10) = gamadnrddb(10) - water*temp0db
|
|
gnh3db = 0.D0
|
|
ghno3db = 0.D0
|
|
a4db = 0.D0
|
|
a4dnrddb = 0.D0
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of calcact3p_dnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water molaldnrd
|
|
C gamadnrd waterdnrd
|
|
C with respect to varying inputs: molal gama water molaldnrd
|
|
C gamadnrd waterdnrd
|
|
C
|
|
C Differentiation of calcact3p in forward (tangent) mode:
|
|
C variations of useful results: gama
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3P_DNRD_DB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0db(6, 4), siondb, hdb, chdb, f1db(3), f2db(4)
|
|
REAL*8 :: g0dnrd(6, 4), siondnrd, hdnrd, chdnrd, f1dnrd(3)
|
|
+ , f2dnrd(4)
|
|
REAL*8 :: g0dnrddb(6, 4), siondnrddb, hdnrddb, chdnrddb,
|
|
+ f1dnrddb(3), f2dnrddb(4)
|
|
REAL*8 :: mpl, xij, yji
|
|
REAL*8 :: mpldb, xijdb, yjidb, ionicdnrddb
|
|
REAL*8 :: mpldnrd, xijdnrd, yjidnrd, ionicdb
|
|
REAL*8 :: mpldnrddb, xijdnrddb, yjidnrddb, ionicdnrd
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01db
|
|
REAL*8 :: g01dnrd
|
|
REAL*8 :: g01dnrddb
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02db
|
|
REAL*8 :: g02dnrd
|
|
REAL*8 :: g02dnrddb
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03db
|
|
REAL*8 :: g03dnrd
|
|
REAL*8 :: g03dnrddb
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04db
|
|
REAL*8 :: g04dnrd
|
|
REAL*8 :: g04dnrddb
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05db
|
|
REAL*8 :: g05dnrd
|
|
REAL*8 :: g05dnrddb
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06db
|
|
REAL*8 :: g06dnrd
|
|
REAL*8 :: g06dnrddb
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07db
|
|
REAL*8 :: g07dnrd
|
|
REAL*8 :: g07dnrddb
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08db
|
|
REAL*8 :: g08dnrd
|
|
REAL*8 :: g08dnrddb
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09db
|
|
REAL*8 :: g09dnrd
|
|
REAL*8 :: g09dnrddb
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10db
|
|
REAL*8 :: g10dnrd
|
|
REAL*8 :: g10dnrddb
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11db
|
|
REAL*8 :: g11dnrd
|
|
REAL*8 :: g11dnrddb
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12db
|
|
REAL*8 :: g12dnrd
|
|
REAL*8 :: g12dnrddb
|
|
INTEGER :: j
|
|
REAL*8 :: x1dnrd
|
|
REAL*8 :: x1dnrddb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x2db
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1db
|
|
REAL*8 :: x2dnrd
|
|
REAL*8 :: x2dnrddb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
INTEGER :: branch
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0db1
|
|
REAL*8 :: temp0db0
|
|
REAL*8 :: temp1db4
|
|
REAL*8 :: temp2db
|
|
REAL*8 :: temp1db3
|
|
REAL*8 :: temp1db2
|
|
REAL*8 :: temp1db1
|
|
REAL*8 :: temp1db0
|
|
REAL*8 :: temp2db9
|
|
REAL*8 :: temp2db8
|
|
REAL*8 :: temp2db7
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp2db6
|
|
REAL*8 :: temp2db5
|
|
REAL*8 :: temp2db4
|
|
REAL*8 :: temp2db3
|
|
REAL*8 :: temp2db2
|
|
REAL*8 :: temp2db1
|
|
REAL*8 :: temp2db0
|
|
REAL*8 :: temp2db25
|
|
REAL*8 :: temp2db24
|
|
INTEGER :: ii20
|
|
REAL*8 :: temp2db23
|
|
REAL*8 :: temp2db22
|
|
REAL*8 :: temp2db21
|
|
REAL*8 :: temp0db
|
|
REAL*8 :: temp2db20
|
|
INTRINSIC LOG
|
|
REAL*8 :: temp2db19
|
|
REAL*8 :: temp2db18
|
|
REAL*8 :: temp2db17
|
|
REAL*8 :: temp2db16
|
|
REAL*8 :: temp2db15
|
|
INTEGER :: ii10
|
|
REAL*8 :: temp2db14
|
|
REAL*8 :: temp2db13
|
|
REAL*8 :: temp2db12
|
|
REAL*8 :: temp2db11
|
|
REAL*8 :: temp2db10
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp1db
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
ionicdnrd = 0.d0
|
|
DO i=1,7
|
|
ionicdnrd = ionicdnrd + z(i)**2*molaldnrd(i)
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
x1dnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1dnrd = (0.5d0*ionicdnrd*water-0.5d0*ionic*waterdnrd)/water**2
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHREAL8(ionicdnrd)
|
|
ionicdnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionicdnrd)
|
|
ionicdnrd = x1dnrd
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3_DNRD(ionic, ionicdnrd, temp, g01, g01dnrd, g02,
|
|
+ g02dnrd, g03, g03dnrd, g04, g04dnrd, g05, g05dnrd
|
|
+ , g06, g06dnrd, g07, g07dnrd, g08, g08dnrd, g09,
|
|
+ g09dnrd, g10, g10dnrd, g11, g11dnrd, g12, g12dnrd
|
|
+ )
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0dnrd(ii2, ii1) = 0.d0
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
g0dnrd(1, 1) = g11dnrd
|
|
g0(1, 1) = g11
|
|
g0dnrd(1, 2) = g07dnrd
|
|
g0(1, 2) = g07
|
|
g0dnrd(1, 3) = g08dnrd
|
|
g0(1, 3) = g08
|
|
g0dnrd(1, 4) = g10dnrd
|
|
g0(1, 4) = g10
|
|
g0dnrd(2, 1) = g01dnrd
|
|
g0(2, 1) = g01
|
|
g0dnrd(2, 2) = g02dnrd
|
|
g0(2, 2) = g02
|
|
g0dnrd(2, 3) = g12dnrd
|
|
g0(2, 3) = g12
|
|
g0dnrd(2, 4) = g03dnrd
|
|
g0(2, 4) = g03
|
|
g0dnrd(3, 1) = g06dnrd
|
|
g0(3, 1) = g06
|
|
g0dnrd(3, 2) = g04dnrd
|
|
g0(3, 2) = g04
|
|
g0dnrd(3, 3) = g09dnrd
|
|
g0(3, 3) = g09
|
|
g0dnrd(3, 4) = g05dnrd
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
IF (ionic >= 0.) THEN
|
|
abs1 = ionic
|
|
ELSE
|
|
abs1 = -ionic
|
|
END IF
|
|
IF (abs1 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
siondnrd = 0.d0
|
|
ELSE
|
|
siondnrd = ionicdnrd/(2.0*SQRT(ionic))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
hdnrd = (agama*siondnrd*(1.d0+sion)-agama*sion*siondnrd)/(1.d0+
|
|
+ sion)**2
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
DO ii1=1,3
|
|
f1dnrd(ii1) = 0.d0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2dnrd(ii1) = 0.d0
|
|
ENDDO
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mpldnrd)
|
|
mpldnrd = (molaldnrd(i)*water-molal(i)*waterdnrd)/water**2
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
chdnrd = -(0.25d0*(zpl+zmi)**2*ionicdnrd/ionic**2)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xijdnrd = chdnrd*mpl + ch*mpldnrd
|
|
xij = ch*mpl
|
|
CALL PUSHREAL8(yjidnrd)
|
|
yjidnrd = ((chdnrd*molal(j+3)+ch*molaldnrd(j+3))*water-ch*
|
|
+ molal(j+3)*waterdnrd)/water**2
|
|
yji = ch*molal(j+3)/water
|
|
f1dnrd(i) = f1dnrd(i) + yjidnrd*(g0(i, j)+zpl*zmi*h) + yji*(
|
|
+ g0dnrd(i, j)+zpl*zmi*hdnrd)
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2dnrd(j) = f2dnrd(j) + xijdnrd*(g0(i, j)+zpl*zmi*h) + xij*(
|
|
+ g0dnrd(i, j)+zpl*zmi*hdnrd)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gamadnrd(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gamadnrd(1) = zz(1)*((f1dnrd(2)/z(2)+f2dnrd(1)/z(4))/(z(2)+z(4))-
|
|
+ hdnrd)
|
|
CALL PUSHREAL8(gama(1))
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gamadnrd(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gamadnrd(2) = zz(2)*((f1dnrd(2)/z(2)+f2dnrd(2)/z(5))/(z(2)+z(5))-
|
|
+ hdnrd)
|
|
CALL PUSHREAL8(gama(2))
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gamadnrd(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gamadnrd(3) = zz(3)*((f1dnrd(2)/z(2)+f2dnrd(4)/z(7))/(z(2)+z(7))-
|
|
+ hdnrd)
|
|
CALL PUSHREAL8(gama(3))
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gamadnrd(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gamadnrd(4) = zz(4)*((f1dnrd(3)/z(3)+f2dnrd(2)/z(5))/(z(3)+z(5))-
|
|
+ hdnrd)
|
|
CALL PUSHREAL8(gama(4))
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gamadnrd(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gamadnrd(5) = zz(5)*((f1dnrd(3)/z(3)+f2dnrd(4)/z(7))/(z(3)+z(7))-
|
|
+ hdnrd)
|
|
CALL PUSHREAL8(gama(5))
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gamadnrd(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gamadnrd(6) = zz(6)*((f1dnrd(3)/z(3)+f2dnrd(1)/z(4))/(z(3)+z(4))-
|
|
+ hdnrd)
|
|
CALL PUSHREAL8(gama(6))
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gamadnrd(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gamadnrd(7) = zz(7)*((f1dnrd(1)/z(1)+f2dnrd(2)/z(5))/(z(1)+z(5))-
|
|
+ hdnrd)
|
|
CALL PUSHREAL8(gama(7))
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gamadnrd(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gamadnrd(8) = zz(8)*((f1dnrd(1)/z(1)+f2dnrd(3)/z(6))/(z(1)+z(6))-
|
|
+ hdnrd)
|
|
CALL PUSHREAL8(gama(8))
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gamadnrd(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gamadnrd(9) = zz(9)*((f1dnrd(3)/z(3)+f2dnrd(3)/z(6))/(z(3)+z(6))-
|
|
+ hdnrd)
|
|
CALL PUSHREAL8(gama(9))
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gamadnrd(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gamadnrd(10) = zz(10)*((f1dnrd(1)/z(1)+f2dnrd(4)/z(7))/(z(1)+z(7))
|
|
+ -hdnrd)
|
|
CALL PUSHREAL8(gama(10))
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gamadnrd(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gamadnrd(11) = zz(11)*((f1dnrd(1)/z(1)+f2dnrd(1)/z(4))/(z(1)+z(4))
|
|
+ -hdnrd)
|
|
CALL PUSHREAL8(gama(11))
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gamadnrd(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gamadnrd(12) = zz(12)*((f1dnrd(2)/z(2)+f2dnrd(3)/z(6))/(z(2)+z(6))
|
|
+ -hdnrd)
|
|
CALL PUSHREAL8(gama(12))
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gamadnrd(13))
|
|
C LC ; SCAPE
|
|
gamadnrd(13) = 0.2d0*(3.d0*gamadnrd(4)+2.d0*gamadnrd(9))
|
|
CALL PUSHREAL8(gama(13))
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
x2dnrd = 0.d0
|
|
ELSE
|
|
x2dnrd = gamadnrd(i)
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHREAL8(gamadnrd(i))
|
|
gamadnrd(i) = 0.d0
|
|
CALL PUSHREAL8(gama(i))
|
|
gama(i) = -5.0d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(gamadnrd(i))
|
|
gamadnrd(i) = x2dnrd
|
|
CALL PUSHREAL8(gama(i))
|
|
gama(i) = x2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
temp2db25 = LOG(10.d0)*gamadnrddb(i)
|
|
temp2 = 10.d0**gama(i)
|
|
gamadb(i) = gamadnrd(i)*temp2*LOG(10.d0)*temp2db25 + 10.d0**gama
|
|
+ (i)*LOG(10.d0)*gamadb(i)
|
|
gamadnrddb(i) = temp2*temp2db25
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(gama(i))
|
|
gamadb(i) = 0.D0
|
|
CALL POPREAL8(gamadnrd(i))
|
|
gamadnrddb(i) = 0.D0
|
|
x2dnrddb = 0.D0
|
|
x2db = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(gama(i))
|
|
x2db = gamadb(i)
|
|
gamadb(i) = 0.D0
|
|
CALL POPREAL8(gamadnrd(i))
|
|
x2dnrddb = gamadnrddb(i)
|
|
gamadnrddb(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
gamadb(i) = gamadb(i) + x2db
|
|
gamadnrddb(i) = gamadnrddb(i) + x2dnrddb
|
|
END IF
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamadb(4) = gamadb(4) + 0.2d0*3.d0*gamadb(13)
|
|
gamadb(9) = gamadb(9) + 0.2d0*2.d0*gamadb(13)
|
|
gamadb(13) = 0.D0
|
|
CALL POPREAL8(gamadnrd(13))
|
|
gamadnrddb(4) = gamadnrddb(4) + 0.2d0*3.d0*gamadnrddb(13)
|
|
gamadnrddb(9) = gamadnrddb(9) + 0.2d0*2.d0*gamadnrddb(13)
|
|
gamadnrddb(13) = 0.D0
|
|
DO ii10=1,3
|
|
f1db(ii10) = 0.D0
|
|
ENDDO
|
|
DO ii10=1,4
|
|
f2db(ii10) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp2db1 = zz(12)*gamadb(12)/(z(2)+z(6))
|
|
f1db(2) = f1db(2) + temp2db1/z(2)
|
|
f2db(3) = f2db(3) + temp2db1/z(6)
|
|
hdb = -(zz(12)*gamadb(12))
|
|
gamadb(12) = 0.D0
|
|
DO ii10=1,4
|
|
f2dnrddb(ii10) = 0.D0
|
|
ENDDO
|
|
DO ii10=1,3
|
|
f1dnrddb(ii10) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gamadnrd(12))
|
|
temp2db2 = zz(12)*gamadnrddb(12)/(z(2)+z(6))
|
|
f1dnrddb(2) = f1dnrddb(2) + temp2db2/z(2)
|
|
f2dnrddb(3) = f2dnrddb(3) + temp2db2/z(6)
|
|
hdnrddb = -(zz(12)*gamadnrddb(12))
|
|
gamadnrddb(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp2db3 = zz(11)*gamadb(11)/(z(1)+z(4))
|
|
f2db(1) = f2db(1) + temp2db3/z(4)
|
|
hdb = hdb - zz(11)*gamadb(11)
|
|
gamadb(11) = 0.D0
|
|
CALL POPREAL8(gamadnrd(11))
|
|
temp2db5 = zz(11)*gamadnrddb(11)/(z(1)+z(4))
|
|
f2dnrddb(1) = f2dnrddb(1) + temp2db5/z(4)
|
|
hdnrddb = hdnrddb - zz(11)*gamadnrddb(11)
|
|
gamadnrddb(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp2db4 = zz(10)*gamadb(10)/(z(1)+z(7))
|
|
f1db(1) = f1db(1) + temp2db4/z(1) + temp2db3/z(1)
|
|
f2db(4) = f2db(4) + temp2db4/z(7)
|
|
hdb = hdb - zz(10)*gamadb(10)
|
|
gamadb(10) = 0.D0
|
|
CALL POPREAL8(gamadnrd(10))
|
|
temp2db6 = zz(10)*gamadnrddb(10)/(z(1)+z(7))
|
|
f1dnrddb(1) = f1dnrddb(1) + temp2db6/z(1) + temp2db5/z(1)
|
|
f2dnrddb(4) = f2dnrddb(4) + temp2db6/z(7)
|
|
hdnrddb = hdnrddb - zz(10)*gamadnrddb(10)
|
|
gamadnrddb(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp2db7 = zz(9)*gamadb(9)/(z(3)+z(6))
|
|
f1db(3) = f1db(3) + temp2db7/z(3)
|
|
hdb = hdb - zz(9)*gamadb(9)
|
|
gamadb(9) = 0.D0
|
|
CALL POPREAL8(gamadnrd(9))
|
|
temp2db9 = zz(9)*gamadnrddb(9)/(z(3)+z(6))
|
|
f1dnrddb(3) = f1dnrddb(3) + temp2db9/z(3)
|
|
hdnrddb = hdnrddb - zz(9)*gamadnrddb(9)
|
|
gamadnrddb(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp2db8 = zz(8)*gamadb(8)/(z(1)+z(6))
|
|
f2db(3) = f2db(3) + temp2db8/z(6) + temp2db7/z(6)
|
|
hdb = hdb - zz(8)*gamadb(8)
|
|
gamadb(8) = 0.D0
|
|
CALL POPREAL8(gamadnrd(8))
|
|
temp2db10 = zz(8)*gamadnrddb(8)/(z(1)+z(6))
|
|
f2dnrddb(3) = f2dnrddb(3) + temp2db10/z(6) + temp2db9/z(6)
|
|
hdnrddb = hdnrddb - zz(8)*gamadnrddb(8)
|
|
gamadnrddb(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp2db11 = zz(7)*gamadb(7)/(z(1)+z(5))
|
|
f1db(1) = f1db(1) + temp2db11/z(1) + temp2db8/z(1)
|
|
f2db(2) = f2db(2) + temp2db11/z(5)
|
|
hdb = hdb - zz(7)*gamadb(7)
|
|
gamadb(7) = 0.D0
|
|
CALL POPREAL8(gamadnrd(7))
|
|
temp2db12 = zz(7)*gamadnrddb(7)/(z(1)+z(5))
|
|
f1dnrddb(1) = f1dnrddb(1) + temp2db12/z(1) + temp2db10/z(1)
|
|
f2dnrddb(2) = f2dnrddb(2) + temp2db12/z(5)
|
|
hdnrddb = hdnrddb - zz(7)*gamadnrddb(7)
|
|
gamadnrddb(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp2db13 = zz(6)*gamadb(6)/(z(3)+z(4))
|
|
f2db(1) = f2db(1) + temp2db13/z(4)
|
|
hdb = hdb - zz(6)*gamadb(6)
|
|
gamadb(6) = 0.D0
|
|
CALL POPREAL8(gamadnrd(6))
|
|
temp2db16 = zz(6)*gamadnrddb(6)/(z(3)+z(4))
|
|
f2dnrddb(1) = f2dnrddb(1) + temp2db16/z(4)
|
|
hdnrddb = hdnrddb - zz(6)*gamadnrddb(6)
|
|
gamadnrddb(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp2db14 = zz(5)*gamadb(5)/(z(3)+z(7))
|
|
f2db(4) = f2db(4) + temp2db14/z(7)
|
|
hdb = hdb - zz(5)*gamadb(5)
|
|
gamadb(5) = 0.D0
|
|
CALL POPREAL8(gamadnrd(5))
|
|
temp2db17 = zz(5)*gamadnrddb(5)/(z(3)+z(7))
|
|
f2dnrddb(4) = f2dnrddb(4) + temp2db17/z(7)
|
|
hdnrddb = hdnrddb - zz(5)*gamadnrddb(5)
|
|
gamadnrddb(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp2db15 = zz(4)*gamadb(4)/(z(3)+z(5))
|
|
f1db(3) = f1db(3) + temp2db14/z(3) + temp2db15/z(3) + temp2db13/z(
|
|
+ 3)
|
|
f2db(2) = f2db(2) + temp2db15/z(5)
|
|
hdb = hdb - zz(4)*gamadb(4)
|
|
gamadb(4) = 0.D0
|
|
CALL POPREAL8(gamadnrd(4))
|
|
temp2db18 = zz(4)*gamadnrddb(4)/(z(3)+z(5))
|
|
f1dnrddb(3) = f1dnrddb(3) + temp2db17/z(3) + temp2db18/z(3) +
|
|
+ temp2db16/z(3)
|
|
f2dnrddb(2) = f2dnrddb(2) + temp2db18/z(5)
|
|
hdnrddb = hdnrddb - zz(4)*gamadnrddb(4)
|
|
gamadnrddb(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp2db19 = zz(3)*gamadb(3)/(z(2)+z(7))
|
|
f2db(4) = f2db(4) + temp2db19/z(7)
|
|
hdb = hdb - zz(3)*gamadb(3)
|
|
gamadb(3) = 0.D0
|
|
CALL POPREAL8(gamadnrd(3))
|
|
temp2db22 = zz(3)*gamadnrddb(3)/(z(2)+z(7))
|
|
f2dnrddb(4) = f2dnrddb(4) + temp2db22/z(7)
|
|
hdnrddb = hdnrddb - zz(3)*gamadnrddb(3)
|
|
gamadnrddb(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp2db20 = zz(2)*gamadb(2)/(z(2)+z(5))
|
|
f2db(2) = f2db(2) + temp2db20/z(5)
|
|
hdb = hdb - zz(2)*gamadb(2)
|
|
gamadb(2) = 0.D0
|
|
CALL POPREAL8(gamadnrd(2))
|
|
temp2db23 = zz(2)*gamadnrddb(2)/(z(2)+z(5))
|
|
f2dnrddb(2) = f2dnrddb(2) + temp2db23/z(5)
|
|
hdnrddb = hdnrddb - zz(2)*gamadnrddb(2)
|
|
gamadnrddb(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp2db21 = zz(1)*gamadb(1)/(z(2)+z(4))
|
|
f1db(2) = f1db(2) + temp2db20/z(2) + temp2db21/z(2) + temp2db19/z(
|
|
+ 2)
|
|
f2db(1) = f2db(1) + temp2db21/z(4)
|
|
hdb = hdb - zz(1)*gamadb(1)
|
|
gamadb(1) = 0.D0
|
|
CALL POPREAL8(gamadnrd(1))
|
|
temp2db24 = zz(1)*gamadnrddb(1)/(z(2)+z(4))
|
|
f1dnrddb(2) = f1dnrddb(2) + temp2db23/z(2) + temp2db24/z(2) +
|
|
+ temp2db22/z(2)
|
|
f2dnrddb(1) = f2dnrddb(1) + temp2db24/z(4)
|
|
hdnrddb = hdnrddb - zz(1)*gamadnrddb(1)
|
|
gamadnrddb(1) = 0.D0
|
|
ionicdb = 0.D0
|
|
DO ii10=1,4
|
|
DO ii20=1,6
|
|
g0dnrddb(ii20, ii10) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO ii10=1,4
|
|
DO ii20=1,6
|
|
g0db(ii20, ii10) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
ionicdnrddb = 0.D0
|
|
DO i=3,1,-1
|
|
mpldb = 0.D0
|
|
mpldnrddb = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijdb = (g0dnrd(i, j)+zpl*zmi*hdnrd)*f2dnrddb(j) + (g0(i, j)+
|
|
+ zpl*zmi*h)*f2db(j)
|
|
chdnrd = -(0.25d0*(zpl+zmi)**2*ionicdnrd/ionic**2)
|
|
xijdnrd = chdnrd*mpl + ch*mpldnrd
|
|
xijdnrddb = (g0(i, j)+zpl*zmi*h)*f2dnrddb(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0db(i, j) = g0db(i, j) + xijdnrd*f2dnrddb(j) + yjidnrd*
|
|
+ f1dnrddb(i) + yji*f1db(i) + xij*f2db(j)
|
|
hdb = hdb + xijdnrd*zpl*zmi*f2dnrddb(j) + yjidnrd*zpl*zmi*
|
|
+ f1dnrddb(i) + yji*zpl*zmi*f1db(i) + xij*zpl*zmi*f2db(j)
|
|
g0dnrddb(i, j) = g0dnrddb(i, j) + yji*f1dnrddb(i) + xij*
|
|
+ f2dnrddb(j)
|
|
hdnrddb = hdnrddb + yji*zpl*zmi*f1dnrddb(i) + xij*zpl*zmi*
|
|
+ f2dnrddb(j)
|
|
yjidb = (g0dnrd(i, j)+zpl*zmi*hdnrd)*f1dnrddb(i) + (g0(i, j)+
|
|
+ zpl*zmi*h)*f1db(i)
|
|
yjidnrddb = (g0(i, j)+zpl*zmi*h)*f1dnrddb(i)
|
|
temp2db = molal(j+3)*yjidb/water
|
|
CALL POPREAL8(yjidnrd)
|
|
temp2db0 = yjidnrddb/water**2
|
|
temp1db2 = water*temp2db0
|
|
molaldb(j+3) = molaldb(j+3) + chdnrd*temp1db2 - ch*waterdnrd*
|
|
+ temp2db0 + ch*yjidb/water
|
|
temp1 = chdnrd*molal(j+3) + ch*molaldnrd(j+3)
|
|
waterdb = waterdb + (temp1-(temp1*water-molal(j+3)*(ch*
|
|
+ waterdnrd))*2/water)*temp2db0 - ch*temp2db/water
|
|
temp1db3 = -(molal(j+3)*temp2db0)
|
|
chdb = molaldnrd(j+3)*temp1db2 + waterdnrd*temp1db3 + mpldnrd*
|
|
+ xijdnrddb + mpl*xijdb + temp2db
|
|
chdnrddb = mpl*xijdnrddb + molal(j+3)*temp1db2
|
|
molaldnrddb(j+3) = molaldnrddb(j+3) + ch*temp1db2
|
|
waterdnrddb = waterdnrddb + ch*temp1db3
|
|
mpldb = mpldb + chdnrd*xijdnrddb + ch*xijdb
|
|
mpldnrddb = mpldnrddb + ch*xijdnrddb
|
|
temp1db4 = -((zpl+zmi)**2*0.25d0*chdnrddb/ionic**2)
|
|
ionicdb = ionicdb - ionicdnrd*2*temp1db4/ionic - (zpl+zmi)**2*
|
|
+ 0.25d0*chdb/ionic**2
|
|
ionicdnrddb = ionicdnrddb + temp1db4
|
|
ENDDO
|
|
temp1db1 = mpldnrddb/water**2
|
|
CALL POPREAL8(mpl)
|
|
molaldb(i) = molaldb(i) + mpldb/water - waterdnrd*temp1db1
|
|
waterdb = waterdb + (molaldnrd(i)-(molaldnrd(i)*water-molal(i)*
|
|
+ waterdnrd)*2/water)*temp1db1 - molal(i)*mpldb/water**2
|
|
CALL POPREAL8(mpldnrd)
|
|
molaldnrddb(i) = molaldnrddb(i) + water*temp1db1
|
|
waterdnrddb = waterdnrddb - molal(i)*temp1db1
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp1db0 = hdnrddb/(sion+1.d0)**2
|
|
temp1db = agama*hdb/(sion+1.d0)
|
|
siondb = (1.D0-sion/(sion+1.d0))*temp1db - (agama*(siondnrd*(sion+
|
|
+ 1.d0))-agama*(sion*siondnrd))*2*temp1db0/(sion+1.d0)
|
|
siondnrddb = (agama*(sion+1.d0)-agama*sion)*temp1db0
|
|
IF (.NOT.ionic == 0.0) ionicdb = ionicdb + siondb/(2.0*SQRT(
|
|
+ ionic))
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp0 = SQRT(ionic)
|
|
temp0db1 = siondnrddb/(2.0*temp0)
|
|
ionicdnrddb = ionicdnrddb + temp0db1
|
|
IF (.NOT.ionic == 0.0) ionicdb = ionicdb - ionicdnrd*temp0db1/
|
|
+ (2.0*temp0**2)
|
|
END IF
|
|
g05db = g0db(3, 4)
|
|
g0db(3, 4) = 0.D0
|
|
g05dnrddb = g0dnrddb(3, 4)
|
|
g0dnrddb(3, 4) = 0.D0
|
|
g09db = g0db(3, 3)
|
|
g0db(3, 3) = 0.D0
|
|
g09dnrddb = g0dnrddb(3, 3)
|
|
g0dnrddb(3, 3) = 0.D0
|
|
g04db = g0db(3, 2)
|
|
g0db(3, 2) = 0.D0
|
|
g04dnrddb = g0dnrddb(3, 2)
|
|
g0dnrddb(3, 2) = 0.D0
|
|
g06db = g0db(3, 1)
|
|
g0db(3, 1) = 0.D0
|
|
g06dnrddb = g0dnrddb(3, 1)
|
|
g0dnrddb(3, 1) = 0.D0
|
|
g03db = g0db(2, 4)
|
|
g0db(2, 4) = 0.D0
|
|
g03dnrddb = g0dnrddb(2, 4)
|
|
g0dnrddb(2, 4) = 0.D0
|
|
g12db = g0db(2, 3)
|
|
g0db(2, 3) = 0.D0
|
|
g12dnrddb = g0dnrddb(2, 3)
|
|
g0dnrddb(2, 3) = 0.D0
|
|
g02db = g0db(2, 2)
|
|
g0db(2, 2) = 0.D0
|
|
g02dnrddb = g0dnrddb(2, 2)
|
|
g0dnrddb(2, 2) = 0.D0
|
|
g01db = g0db(2, 1)
|
|
g0db(2, 1) = 0.D0
|
|
g01dnrddb = g0dnrddb(2, 1)
|
|
g0dnrddb(2, 1) = 0.D0
|
|
g10db = g0db(1, 4)
|
|
g0db(1, 4) = 0.D0
|
|
g10dnrddb = g0dnrddb(1, 4)
|
|
g0dnrddb(1, 4) = 0.D0
|
|
g08db = g0db(1, 3)
|
|
g0db(1, 3) = 0.D0
|
|
g08dnrddb = g0dnrddb(1, 3)
|
|
g0dnrddb(1, 3) = 0.D0
|
|
g07db = g0db(1, 2)
|
|
g0db(1, 2) = 0.D0
|
|
g07dnrddb = g0dnrddb(1, 2)
|
|
g0dnrddb(1, 2) = 0.D0
|
|
g11db = g0db(1, 1)
|
|
g11dnrddb = g0dnrddb(1, 1)
|
|
CALL KMFUL3_DNRD_DB(ionic, ionicdb, ionicdnrd, ionicdnrddb, temp,
|
|
+ g01, g01db, g01dnrd, g01dnrddb, g02, g02db,
|
|
+ g02dnrd, g02dnrddb, g03, g03db, g03dnrd,
|
|
+ g03dnrddb, g04, g04db, g04dnrd, g04dnrddb, g05
|
|
+ , g05db, g05dnrd, g05dnrddb, g06, g06db,
|
|
+ g06dnrd, g06dnrddb, g07, g07db, g07dnrd,
|
|
+ g07dnrddb, g08, g08db, g08dnrd, g08dnrddb, g09
|
|
+ , g09db, g09dnrd, g09dnrddb, g10, g10db,
|
|
+ g10dnrd, g10dnrddb, g11, g11db, g11dnrd,
|
|
+ g11dnrddb, g12, g12db, g12dnrd, g12dnrddb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionicdnrd)
|
|
CALL POPREAL8(ionic)
|
|
x1db = 0.D0
|
|
x1dnrddb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1db = ionicdb
|
|
CALL POPREAL8(ionicdnrd)
|
|
x1dnrddb = ionicdnrddb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ionicdb = 0.D0
|
|
ionicdnrddb = 0.D0
|
|
ELSE
|
|
temp0db0 = x1dnrddb/water**2
|
|
temp0db = 0.5d0*x1db/water
|
|
ionicdb = temp0db - 0.5d0*waterdnrd*temp0db0
|
|
waterdb = waterdb + (0.5d0*ionicdnrd-(0.5d0*(ionicdnrd*water)-
|
|
+ 0.5d0*(ionic*waterdnrd))*2/water)*temp0db0 - ionic*temp0db/
|
|
+ water
|
|
ionicdnrddb = 0.5d0*water*temp0db0
|
|
waterdnrddb = waterdnrddb - 0.5d0*ionic*temp0db0
|
|
END IF
|
|
DO i=7,1,-1
|
|
molaldb(i) = molaldb(i) + z(i)**2*ionicdb
|
|
molaldnrddb(i) = molaldnrddb(i) + z(i)**2*ionicdnrddb
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of kmful3_dnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: g11dnrd g04dnrd g09dnrd g01
|
|
C g02 g03 g04 g12dnrd g05 g06 g07 g08 g09 g05dnrd
|
|
C g10 g11 g12 g01dnrd ionicdnrd g06dnrd ionic g02dnrd
|
|
C g07dnrd g10dnrd g03dnrd g08dnrd
|
|
C with respect to varying inputs: ionicdnrd ionic
|
|
C
|
|
C Differentiation of kmful3 in forward (tangent) mode:
|
|
C variations of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_DNRD_DB(ionic, ionicdb, ionicdnrd, ionicdnrddb,
|
|
+ temp, g01, g01db, g01dnrd, g01dnrddb,
|
|
+ g02, g02db, g02dnrd, g02dnrddb, g03,
|
|
+ g03db, g03dnrd, g03dnrddb, g04, g04db,
|
|
+ g04dnrd, g04dnrddb, g05, g05db, g05dnrd
|
|
+ , g05dnrddb, g06, g06db, g06dnrd,
|
|
+ g06dnrddb, g07, g07db, g07dnrd,
|
|
+ g07dnrddb, g08, g08db, g08dnrd,
|
|
+ g08dnrddb, g09, g09db, g09dnrd,
|
|
+ g09dnrddb, g10, g10db, g10dnrd,
|
|
+ g10dnrddb, g11, g11db, g11dnrd,
|
|
+ g11dnrddb, g12, g12db, g12dnrd,
|
|
+ g12dnrddb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionicdb, siondb, cf2db
|
|
REAL*8 :: ionicdnrd, siondnrd, cf2dnrd
|
|
REAL*8 :: ionicdnrddb, siondnrddb, cf2dnrddb
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01db, g02db, g03db, g04db, g05db, g06db, g07db,
|
|
+ g08db, g09db, g10db, g11db, g12db
|
|
REAL*8 :: g01dnrd, g02dnrd, g03dnrd, g04dnrd, g05dnrd,
|
|
+ g06dnrd, g07dnrd, g08dnrd, g09dnrd, g10dnrd,
|
|
+ g11dnrd, g12dnrd
|
|
REAL*8 :: g01dnrddb, g02dnrddb, g03dnrddb, g04dnrddb,
|
|
+ g05dnrddb, g06dnrddb, g07dnrddb, g08dnrddb,
|
|
+ g09dnrddb, g10dnrddb, g11dnrddb, g12dnrddb
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: tiny
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp1db3
|
|
REAL*8 :: temp1db2
|
|
REAL*8 :: temp1db1
|
|
REAL*8 :: temp1db0
|
|
REAL*8 :: temp0db
|
|
REAL*8 :: abs2
|
|
REAL*8 :: temp1db
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
tiny = 1.d-20
|
|
IF (ionic >= 0.) THEN
|
|
abs2 = ionic
|
|
ELSE
|
|
abs2 = -ionic
|
|
END IF
|
|
C
|
|
IF (abs2 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
siondnrd = 0.d0
|
|
ELSE
|
|
siondnrd = ionicdnrd/(2.0*SQRT(ionic))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.d0) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01db = g01db + g12db
|
|
g08db = g08db + g09db + g12db
|
|
g11db = g11db - g09db - g12db
|
|
g01dnrddb = g01dnrddb + g12dnrddb
|
|
g08dnrddb = g08dnrddb + g09dnrddb + g12dnrddb
|
|
g11dnrddb = g11dnrddb - g09dnrddb - g12dnrddb
|
|
g06db = g06db + g09db
|
|
g06dnrddb = g06dnrddb + g09dnrddb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2db = -(z10*g10db) - z07*g07db - z05*g05db - z03*g03db - z01*
|
|
+ g01db - z02*g02db - z04*g04db - z06*g06db - z08*g08db - z11*
|
|
+ g11db
|
|
g11db = cf1*g11db
|
|
cf2dnrddb = -(z10*g10dnrddb) - z07*g07dnrddb - z05*g05dnrddb -
|
|
+ z03*g03dnrddb - z01*g01dnrddb - z02*g02dnrddb - z04*g04dnrddb
|
|
+ - z06*g06dnrddb - z08*g08dnrddb - z11*g11dnrddb
|
|
g11dnrddb = cf1*g11dnrddb
|
|
g10db = cf1*g10db
|
|
g10dnrddb = cf1*g10dnrddb
|
|
g08db = cf1*g08db
|
|
g08dnrddb = cf1*g08dnrddb
|
|
g07db = cf1*g07db
|
|
g07dnrddb = cf1*g07dnrddb
|
|
g06db = cf1*g06db
|
|
g06dnrddb = cf1*g06dnrddb
|
|
g05db = cf1*g05db
|
|
g05dnrddb = cf1*g05dnrddb
|
|
g04db = cf1*g04db
|
|
g04dnrddb = cf1*g04dnrddb
|
|
g03db = cf1*g03db
|
|
g03dnrddb = cf1*g03dnrddb
|
|
g02db = cf1*g02db
|
|
g02dnrddb = cf1*g02dnrddb
|
|
g01db = cf1*g01db
|
|
g01dnrddb = cf1*g01dnrddb
|
|
temp1db = (0.125d0-ti*0.005d0)*cf2db
|
|
temp1db0 = -(0.41d0*temp1db/(sion+1.d0))
|
|
temp1db3 = (0.125d0-ti*0.005d0)*cf2dnrddb
|
|
temp1db1 = 0.92d0*0.039d0*temp1db3
|
|
ionicdb = ionicdb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp1db -
|
|
+ ionicdnrd*0.8d0*ionic**(-1.8D0)*temp1db1
|
|
temp1db2 = -(temp1db3/(sion+1.d0)**2)
|
|
siondb = (1.D0-sion/(sion+1.d0))*temp1db0 - (0.41d0*(siondnrd*(
|
|
+ sion+1.d0))-0.41d0*(sion*siondnrd))*2*temp1db2/(sion+1.d0)
|
|
ionicdnrddb = ionicdnrddb + ionic**(-0.8d0)*temp1db1
|
|
siondnrddb = (0.41d0*(sion+1.d0)-0.41d0*sion)*temp1db2
|
|
ELSE
|
|
siondnrddb = 0.D0
|
|
siondb = 0.D0
|
|
END IF
|
|
CALL MKBI_DNRD_DB(q11, ionic, ionicdb, ionicdnrd, ionicdnrddb,
|
|
+ sion, siondb, siondnrd, siondnrddb, z11, g11,
|
|
+ g11db, g11dnrd, g11dnrddb)
|
|
CALL MKBI_DNRD_DB(q10, ionic, ionicdb, ionicdnrd, ionicdnrddb,
|
|
+ sion, siondb, siondnrd, siondnrddb, z10, g10,
|
|
+ g10db, g10dnrd, g10dnrddb)
|
|
CALL MKBI_DNRD_DB(q8, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion
|
|
+ , siondb, siondnrd, siondnrddb, z08, g08, g08db
|
|
+ , g08dnrd, g08dnrddb)
|
|
CALL MKBI_DNRD_DB(q7, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion
|
|
+ , siondb, siondnrd, siondnrddb, z07, g07, g07db
|
|
+ , g07dnrd, g07dnrddb)
|
|
CALL MKBI_DNRD_DB(q6, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion
|
|
+ , siondb, siondnrd, siondnrddb, z06, g06, g06db
|
|
+ , g06dnrd, g06dnrddb)
|
|
CALL MKBI_DNRD_DB(q5, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion
|
|
+ , siondb, siondnrd, siondnrddb, z05, g05, g05db
|
|
+ , g05dnrd, g05dnrddb)
|
|
CALL MKBI_DNRD_DB(q4, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion
|
|
+ , siondb, siondnrd, siondnrddb, z04, g04, g04db
|
|
+ , g04dnrd, g04dnrddb)
|
|
CALL MKBI_DNRD_DB(q3, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion
|
|
+ , siondb, siondnrd, siondnrddb, z03, g03, g03db
|
|
+ , g03dnrd, g03dnrddb)
|
|
CALL MKBI_DNRD_DB(q2, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion
|
|
+ , siondb, siondnrd, siondnrddb, z02, g02, g02db
|
|
+ , g02dnrd, g02dnrddb)
|
|
CALL MKBI_DNRD_DB(q1, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion
|
|
+ , siondb, siondnrd, siondnrddb, z01, g01, g01db
|
|
+ , g01dnrd, g01dnrddb)
|
|
IF (.NOT.ionic == 0.0) ionicdb = ionicdb + siondb/(2.0*SQRT(
|
|
+ ionic))
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp0 = SQRT(ionic)
|
|
temp0db = siondnrddb/(2.0*temp0)
|
|
ionicdnrddb = ionicdnrddb + temp0db
|
|
IF (.NOT.ionic == 0.0) ionicdb = ionicdb - ionicdnrd*temp0db/(
|
|
+ 2.0*temp0**2)
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of mkbi_dnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: siondnrd sion bi bidnrd ionicdnrd
|
|
C ionic
|
|
C with respect to varying inputs: siondnrd sion ionicdnrd ionic
|
|
C
|
|
C Differentiation of mkbi in forward (tangent) mode:
|
|
C variations of useful results: bi
|
|
C with respect to varying inputs: sion ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_DNRD_DB(q, ionic, ionicdb, ionicdnrd, ionicdnrddb
|
|
+ , sion, siondb, siondnrd, siondnrddb, zip
|
|
+ , bi, bidb, bidnrd, bidnrddb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionicdb, siondb, bidb
|
|
REAL*8 :: ionicdnrd, siondnrd, bidnrd
|
|
REAL*8 :: ionicdnrddb, siondnrddb, bidnrddb
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: cdb, xxdb
|
|
REAL*8 :: cdnrd, xxdnrd
|
|
REAL*8 :: cdnrddb, xxdnrddb
|
|
REAL*8 :: arg1
|
|
REAL*8 :: arg1db
|
|
REAL*8 :: arg1dnrd
|
|
REAL*8 :: arg1dnrddb
|
|
REAL*8 :: pwx1
|
|
REAL*8 :: pwx1db
|
|
REAL*8 :: pwx1dnrd
|
|
REAL*8 :: pwx1dnrddb
|
|
REAL*8 :: pwr1
|
|
REAL*8 :: pwr1db
|
|
REAL*8 :: pwr1dnrd
|
|
REAL*8 :: pwr1dnrddb
|
|
INTRINSIC EXP
|
|
INTRINSIC LOG10
|
|
REAL*8 :: tiny
|
|
INTEGER :: branch
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: tempdb
|
|
REAL*8 :: temp1db3
|
|
REAL*8 :: temp1db2
|
|
REAL*8 :: temp1db1
|
|
REAL*8 :: temp1db0
|
|
INTRINSIC ABS
|
|
REAL*8 :: x1
|
|
REAL*8 :: temp0db
|
|
INTRINSIC LOG
|
|
INTRINSIC INT
|
|
REAL*8 :: abs3
|
|
REAL*8 :: abs2
|
|
REAL*8 :: abs1
|
|
REAL*8 :: tempdb2
|
|
REAL*8 :: temp1db
|
|
REAL*8 :: tempdb1
|
|
REAL*8 :: tempdb0
|
|
REAL*8 :: temp
|
|
tiny = 1.d-20
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
arg1dnrd = -(.023d0*((ionicdnrd*ionic+ionic*ionicdnrd)*ionic+ionic
|
|
+ **2*ionicdnrd))
|
|
arg1 = -(.023d0*ionic*ionic*ionic)
|
|
cdnrd = .055d0*q*arg1dnrd*EXP(arg1)
|
|
c = 1. + .055d0*q*EXP(arg1)
|
|
pwx1dnrd = .1d0*ionicdnrd
|
|
pwx1 = 1.d0 + .1d0*ionic
|
|
x1 = q - INT(q)
|
|
IF (x1 >= 0.) THEN
|
|
abs1 = x1
|
|
ELSE
|
|
abs1 = -x1
|
|
END IF
|
|
IF (pwx1 .GT. 0.d0 .OR. (pwx1 .LT. 0.d0 .AND. abs1 .LT. tiny))
|
|
+THEN
|
|
pwr1dnrd = q*pwx1**(q-1)*pwx1dnrd
|
|
CALL PUSHCONTROL2B(0)
|
|
ELSE
|
|
IF (pwx1 .GE. 0.) THEN
|
|
abs2 = pwx1
|
|
ELSE
|
|
abs2 = -pwx1
|
|
END IF
|
|
IF (q - 1.d0 .GE. 0.) THEN
|
|
abs3 = q - 1.d0
|
|
ELSE
|
|
abs3 = -(q-1.d0)
|
|
END IF
|
|
IF (abs2 .LT. tiny .AND. abs3 .LT. tiny) THEN
|
|
pwr1dnrd = pwx1dnrd
|
|
CALL PUSHCONTROL2B(1)
|
|
ELSE
|
|
pwr1dnrd = 0.0
|
|
CALL PUSHCONTROL2B(2)
|
|
END IF
|
|
END IF
|
|
pwr1 = pwx1**q
|
|
bidnrd = b*pwr1dnrd
|
|
bi = 1.d0 + b*pwr1 - b
|
|
C
|
|
temp1 = LOG(10.d0)
|
|
temp1db3 = zip*bidnrddb/(temp1*bi)
|
|
xxdb = zip*bidb
|
|
bidb = zip*bidb/(bi*LOG(10.0)) - bidnrd*temp1db3/bi
|
|
xxdnrddb = zip*bidnrddb
|
|
bidnrddb = temp1db3
|
|
pwr1db = b*bidb
|
|
pwr1dnrddb = b*bidnrddb
|
|
IF (pwx1 .LE. 0.0 .AND. (q .EQ. 0.0 .OR. q .NE. INT(q))) THEN
|
|
pwx1db = 0.0
|
|
ELSE
|
|
pwx1db = q*pwx1**(q-1)*pwr1db
|
|
END IF
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch .EQ. 0) THEN
|
|
IF (.NOT.(pwx1 .LE. 0.0 .AND. (q - 1 .EQ. 0.0 .OR. q - 1 .NE.
|
|
+ INT(q - 1)))) pwx1db = pwx1db + pwx1dnrd*q*(q-1)*pwx1**(q-2)
|
|
+ *pwr1dnrddb
|
|
pwx1dnrddb = q*pwx1**(q-1)*pwr1dnrddb
|
|
ELSE IF (branch .EQ. 1) THEN
|
|
pwx1dnrddb = pwr1dnrddb
|
|
ELSE
|
|
pwx1dnrddb = 0.D0
|
|
END IF
|
|
temp = c*sion + 1.d0
|
|
temp1db2 = -(xxdnrddb/temp**2)
|
|
temp1db1 = 0.5107d0*siondnrd*temp1db2
|
|
temp0 = cdnrd*sion + c*siondnrd
|
|
temp0db = -(0.5107d0*sion*temp1db2)
|
|
tempdb1 = -((0.5107d0*(siondnrd*(c*sion+1.d0))-0.5107d0*(sion*
|
|
+ temp0))*2*temp1db2/temp)
|
|
temp1db = -(0.5107d0*xxdb/(c*sion+1.d0))
|
|
temp1db0 = -(sion*temp1db/(c*sion+1.d0))
|
|
cdb = sion*temp1db1 + siondnrd*temp0db + sion*tempdb1 + sion*
|
|
+ temp1db0
|
|
cdnrddb = sion*temp0db
|
|
tempdb2 = q*.055d0*cdnrddb
|
|
arg1db = arg1dnrd*EXP(arg1)*tempdb2 + q*.055d0*EXP(arg1)*cdb
|
|
arg1dnrddb = EXP(arg1)*tempdb2
|
|
tempdb = -(.023d0*arg1dnrddb)
|
|
tempdb0 = ionic*tempdb
|
|
ionicdb = ionicdb + (ionicdnrd*2*ionic+ionicdnrd*ionic+ionic*
|
|
+ ionicdnrd)*tempdb - .023d0*3*ionic**2*arg1db + 2*ionicdnrd*
|
|
+ tempdb0 + .1d0*pwx1db
|
|
ionicdnrddb = ionicdnrddb + 2*ionic*tempdb0 + ionic**2*tempdb +
|
|
+ .1d0*pwx1dnrddb
|
|
siondb = siondb + c*temp1db1 - 0.5107d0*temp0*temp1db2 + cdnrd*
|
|
+ temp0db + c*tempdb1 + c*temp1db0 + temp1db
|
|
siondnrddb = siondnrddb + c*temp0db + 0.5107d0*(c*sion+1.d0)*
|
|
+ temp1db2
|
|
END
|
|
C
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of funcd3b in forward (tangent) mode:
|
|
C variations of useful results: fd3b
|
|
C with respect to varying inputs: p4
|
|
C RW status of diff variables: p4:in fd3b:out
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** FUNCTION FUNCD3
|
|
C *** CASE D3
|
|
C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ;
|
|
C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3.
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCD3B_DNRD(p4, p4dnrd, fd3b, fd3bdnrd)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: psi3dnrd
|
|
REAL*8 :: psi4dnrd
|
|
REAL*8 :: a3dnrd
|
|
REAL*8 :: a4dnrd
|
|
REAL*8 :: a7dnrd
|
|
REAL*8 :: p4, bb, denm, ahi, aml5, fd3b
|
|
REAL*8 :: p4dnrd, bbdnrd, denmdnrd, ahidnrd, aml5dnrd,
|
|
+ fd3bdnrd
|
|
CHARACTER(LEN=40) errinf
|
|
INTEGER :: errstki(25), k, j
|
|
LOGICAL dexs, iexs, eof
|
|
CHARACTER(LEN=40) errmsgi(25)
|
|
LOGICAL tst
|
|
INTEGER :: i
|
|
REAL*8 :: molalrdnrd(npair)
|
|
REAL*8 :: abb
|
|
REAL*8 :: abbdnrd
|
|
REAL*8 :: arg1
|
|
REAL*8 :: arg1dnrd
|
|
REAL*8 :: result1
|
|
REAL*8 :: result1dnrd
|
|
REAL*8 :: x1dnrd
|
|
INTRINSIC MAX
|
|
INTRINSIC ABS
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: max1dnrd
|
|
REAL*8 :: x2dnrd
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: max1
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
C WRITE(*,*) 'Within FUNCD3B_DNRD: ',p4,p4dnrd
|
|
psi4dnrd = p4dnrd
|
|
psi4 = p4
|
|
DO ii1=1,nions
|
|
molaldnrd(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
molalrdnrd(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
gamadnrd(ii1) = 0.D0
|
|
ENDDO
|
|
waterdnrd = 0.D0
|
|
gnh3dnrd = 0.D0
|
|
a4dnrd = 0.D0
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
DO i=1,3
|
|
C
|
|
a2 = xk7*(water/gama(4))**3.0
|
|
a3dnrd = xk4*r*temp*2.0*water*(waterdnrd*gama(10)-water*gamadnrd
|
|
+ (10))/gama(10)**3
|
|
a3 = xk4*r*temp*(water/gama(10))**2.0
|
|
a4dnrd = xk2*r*temp*2.0*gama(10)*(gamadnrd(10)*gama(5)-gama(10)*
|
|
+ gamadnrd(5))/(xkw*gama(5)**3)
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
a7dnrd = xkw*rh*(waterdnrd*water+water*waterdnrd)
|
|
a7 = xkw*rh*water*water
|
|
C
|
|
psi3dnrd = chi3*((a3dnrd*a4+a3*a4dnrd)*(chi4-psi4)-a3*a4*
|
|
+ psi4dnrd) - psi1*psi4dnrd
|
|
psi3 = a3*a4*chi3*(chi4-psi4) - psi1*(2.d0*psi2+psi1+psi4)
|
|
psi3dnrd = (psi3dnrd*(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4)-
|
|
+ psi3*((a3dnrd*a4+a3*a4dnrd)*(chi4-psi4)-a3*a4*psi4dnrd+
|
|
+ psi4dnrd))/(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4)**2
|
|
psi3 = psi3/(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4)
|
|
IF (psi3 < zero) THEN
|
|
x1 = zero
|
|
x1dnrd = 0.D0
|
|
ELSE
|
|
x1dnrd = psi3dnrd
|
|
x1 = psi3
|
|
END IF
|
|
IF (x1 > chi3) THEN
|
|
psi3 = chi3
|
|
psi3dnrd = 0.D0
|
|
ELSE
|
|
psi3dnrd = x1dnrd
|
|
psi3 = x1
|
|
END IF
|
|
C
|
|
bbdnrd = psi4dnrd - psi3dnrd
|
|
bb = psi4 - psi3
|
|
arg1dnrd = bbdnrd*bb + bb*bbdnrd + 4.d0*a7dnrd
|
|
arg1 = bb*bb + 4.d0*a7
|
|
IF (abs(arg1) < tiny) THEN
|
|
result1dnrd = 0.D0
|
|
ELSE
|
|
result1dnrd = arg1dnrd/(2.0*SQRT(arg1))
|
|
END IF
|
|
result1 = SQRT(arg1)
|
|
denmdnrd = bbdnrd + result1dnrd
|
|
denm = bb + result1
|
|
IF (denm <= tiny) THEN
|
|
IF (bb >= 0.D0) THEN
|
|
abbdnrd = bbdnrd
|
|
abb = bb
|
|
ELSE
|
|
abbdnrd = -bbdnrd
|
|
abb = -bb
|
|
END IF
|
|
C Taylor expansion of SQRT
|
|
denmdnrd = bbdnrd + abbdnrd + (2.0*a7dnrd*abb-2.0*a7*abbdnrd)/
|
|
+ abb**2 - (2.0*(a7dnrd*a7+a7*a7dnrd)*abb**3.0-2.0*a7**2*3.0*
|
|
+ abb**2.0*abbdnrd)/(abb**3.0)**2
|
|
denm = bb + abb + 2.0*a7/abb - 2.0*a7*a7/abb**3.0
|
|
C WRITE(*,*) 'TS approx. of DENM: ',DENM
|
|
END IF
|
|
ahidnrd = (2.D0*a7dnrd*denm-2.D0*a7*denmdnrd)/denm**2
|
|
ahi = 2.D0*a7/denm
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
C HI
|
|
molaldnrd(1) = ahidnrd
|
|
molal(1) = ahi
|
|
C NH4I
|
|
molaldnrd(3) = psi4dnrd
|
|
molal(3) = psi1 + psi4 + 2.d0*psi2
|
|
C SO4I
|
|
molaldnrd(5) = 0.D0
|
|
molal(5) = psi2
|
|
C HSO4I
|
|
molaldnrd(6) = 0.D0
|
|
molal(6) = zero
|
|
C NO3I
|
|
molaldnrd(7) = psi3dnrd
|
|
molal(7) = psi3 + psi1
|
|
C Solid (NH4)2SO4
|
|
cnh42s4 = chi2 - psi2
|
|
C Solid NH4NO3
|
|
cnh4no3 = zero
|
|
C Gas HNO3
|
|
ghno3 = chi3 - psi3
|
|
C Gas NH3
|
|
gnh3dnrd = -psi4dnrd
|
|
gnh3 = chi4 - psi4
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C (NH4)2SO4
|
|
molalrdnrd(4) = molaldnrd(5) + molaldnrd(6)
|
|
molalr(4) = molal(5) + molal(6)
|
|
C "free" NH4
|
|
aml5dnrd = molaldnrd(3) - 2.d0*molalrdnrd(4)
|
|
aml5 = molal(3) - 2.d0*molalr(4)
|
|
IF (aml5 > molal(7)) THEN
|
|
x2dnrd = molaldnrd(7)
|
|
x2 = molal(7)
|
|
ELSE
|
|
x2dnrd = aml5dnrd
|
|
x2 = aml5
|
|
END IF
|
|
IF (x2 < zero) THEN
|
|
molalrdnrd(5) = 0.D0
|
|
molalr(5) = zero
|
|
ELSE
|
|
molalrdnrd(5) = x2dnrd
|
|
molalr(5) = x2
|
|
END IF
|
|
C
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
waterdnrd = 0.D0
|
|
DO j=1,npair
|
|
waterdnrd = waterdnrd + molalrdnrd(j)/m0(j)
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
waterdnrd = 0.D0
|
|
ELSE
|
|
water = water
|
|
END IF
|
|
C
|
|
CALL CALCACT3P_DNRD()
|
|
ENDDO
|
|
IF (gnh3 < tiny) THEN
|
|
max1 = tiny
|
|
max1dnrd = 0.D0
|
|
ELSE
|
|
max1dnrd = gnh3dnrd
|
|
max1 = gnh3
|
|
END IF
|
|
C
|
|
C *** CALCULATE OBJECTIVE FUNCTION ************************************
|
|
C
|
|
CCC FUNCD3= NH4I/HI/MAXCOMP(GNH3,TINY)/A4 - ONE
|
|
fd3bdnrd = (((molaldnrd(3)*molal(1)-molal(3)*molaldnrd(1))*max1/
|
|
+ molal(1)**2-molal(3)*max1dnrd/molal(1))*a4/max1**2-molal(3)*
|
|
+ a4dnrd/(molal(1)*max1))/a4**2
|
|
fd3b = molal(3)/molal(1)/max1/a4 - one
|
|
RETURN
|
|
END
|
|
C
|
|
C Differentiation of calcact3p in forward (tangent) mode:
|
|
C variations of useful results: gama
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3P_DNRD()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0dnrd(6, 4), siondnrd, hdnrd, chdnrd, f1dnrd(3)
|
|
+ , f2dnrd(4)
|
|
REAL*8 :: mpl, xij, yji, ionicdnrd
|
|
REAL*8 :: mpldnrd, xijdnrd, yjidnrd
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01dnrd
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02dnrd
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03dnrd
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04dnrd
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05dnrd
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06dnrd
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07dnrd
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08dnrd
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09dnrd
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10dnrd
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11dnrd
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12dnrd
|
|
INTEGER :: j
|
|
REAL*8 :: x1dnrd
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x2dnrd
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
ionicdnrd = 0.D0
|
|
DO i=1,7
|
|
ionicdnrd = ionicdnrd + z(i)**2*molaldnrd(i)
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
x1dnrd = 0.D0
|
|
ELSE
|
|
x1dnrd = (0.5d0*ionicdnrd*water-0.5d0*ionic*waterdnrd)/water**2
|
|
x1 = 0.5d0*ionic/water
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
ionic = tiny
|
|
ionicdnrd = 0.D0
|
|
ELSE
|
|
ionicdnrd = x1dnrd
|
|
ionic = x1
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3_DNRD(ionic, ionicdnrd, temp, g01, g01dnrd, g02,
|
|
+ g02dnrd, g03, g03dnrd, g04, g04dnrd, g05, g05dnrd
|
|
+ , g06, g06dnrd, g07, g07dnrd, g08, g08dnrd, g09,
|
|
+ g09dnrd, g10, g10dnrd, g11, g11dnrd, g12, g12dnrd
|
|
+ )
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0dnrd(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
g0dnrd(1, 1) = g11dnrd
|
|
g0(1, 1) = g11
|
|
g0dnrd(1, 2) = g07dnrd
|
|
g0(1, 2) = g07
|
|
g0dnrd(1, 3) = g08dnrd
|
|
g0(1, 3) = g08
|
|
g0dnrd(1, 4) = g10dnrd
|
|
g0(1, 4) = g10
|
|
g0dnrd(2, 1) = g01dnrd
|
|
g0(2, 1) = g01
|
|
g0dnrd(2, 2) = g02dnrd
|
|
g0(2, 2) = g02
|
|
g0dnrd(2, 3) = g12dnrd
|
|
g0(2, 3) = g12
|
|
g0dnrd(2, 4) = g03dnrd
|
|
g0(2, 4) = g03
|
|
g0dnrd(3, 1) = g06dnrd
|
|
g0(3, 1) = g06
|
|
g0dnrd(3, 2) = g04dnrd
|
|
g0(3, 2) = g04
|
|
g0dnrd(3, 3) = g09dnrd
|
|
g0(3, 3) = g09
|
|
g0dnrd(3, 4) = g05dnrd
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
IF (abs(ionic) < tiny) THEN
|
|
siondnrd = 0.D0
|
|
ELSE
|
|
siondnrd = ionicdnrd/(2.0*SQRT(ionic))
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
hdnrd = (agama*siondnrd*(1.d0+sion)-agama*sion*siondnrd)/(1.d0+
|
|
+ sion)**2
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1dnrd(i) = 0.D0
|
|
f1(i) = 0.d0
|
|
f2dnrd(i) = 0.D0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2dnrd(4) = 0.D0
|
|
f2(4) = 0.d0
|
|
DO ii1=1,3
|
|
f1dnrd(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2dnrd(ii1) = 0.D0
|
|
ENDDO
|
|
C
|
|
DO i=1,3
|
|
zpl = z(i)
|
|
mpldnrd = (molaldnrd(i)*water-molal(i)*waterdnrd)/water**2
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
chdnrd = -(0.25d0*(zpl+zmi)**2*ionicdnrd/ionic**2)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xijdnrd = chdnrd*mpl + ch*mpldnrd
|
|
xij = ch*mpl
|
|
yjidnrd = ((chdnrd*molal(j+3)+ch*molaldnrd(j+3))*water-ch*
|
|
+ molal(j+3)*waterdnrd)/water**2
|
|
yji = ch*molal(j+3)/water
|
|
f1dnrd(i) = f1dnrd(i) + yjidnrd*(g0(i, j)+zpl*zmi*h) + yji*(
|
|
+ g0dnrd(i, j)+zpl*zmi*hdnrd)
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2dnrd(j) = f2dnrd(j) + xijdnrd*(g0(i, j)+zpl*zmi*h) + xij*(
|
|
+ g0dnrd(i, j)+zpl*zmi*hdnrd)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gamadnrd(1) = zz(1)*((f1dnrd(2)/z(2)+f2dnrd(1)/z(4))/(z(2)+z(4))-
|
|
+ hdnrd)
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gamadnrd(2) = zz(2)*((f1dnrd(2)/z(2)+f2dnrd(2)/z(5))/(z(2)+z(5))-
|
|
+ hdnrd)
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gamadnrd(3) = zz(3)*((f1dnrd(2)/z(2)+f2dnrd(4)/z(7))/(z(2)+z(7))-
|
|
+ hdnrd)
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gamadnrd(4) = zz(4)*((f1dnrd(3)/z(3)+f2dnrd(2)/z(5))/(z(3)+z(5))-
|
|
+ hdnrd)
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gamadnrd(5) = zz(5)*((f1dnrd(3)/z(3)+f2dnrd(4)/z(7))/(z(3)+z(7))-
|
|
+ hdnrd)
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gamadnrd(6) = zz(6)*((f1dnrd(3)/z(3)+f2dnrd(1)/z(4))/(z(3)+z(4))-
|
|
+ hdnrd)
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gamadnrd(7) = zz(7)*((f1dnrd(1)/z(1)+f2dnrd(2)/z(5))/(z(1)+z(5))-
|
|
+ hdnrd)
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gamadnrd(8) = zz(8)*((f1dnrd(1)/z(1)+f2dnrd(3)/z(6))/(z(1)+z(6))-
|
|
+ hdnrd)
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gamadnrd(9) = zz(9)*((f1dnrd(3)/z(3)+f2dnrd(3)/z(6))/(z(3)+z(6))-
|
|
+ hdnrd)
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gamadnrd(10) = zz(10)*((f1dnrd(1)/z(1)+f2dnrd(4)/z(7))/(z(1)+z(7))
|
|
+ -hdnrd)
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gamadnrd(11) = zz(11)*((f1dnrd(1)/z(1)+f2dnrd(1)/z(4))/(z(1)+z(4))
|
|
+ -hdnrd)
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gamadnrd(12) = zz(12)*((f1dnrd(2)/z(2)+f2dnrd(3)/z(6))/(z(2)+z(6))
|
|
+ -hdnrd)
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
C LC ; SCAPE
|
|
gamadnrd(13) = 0.2d0*(3.d0*gamadnrd(4)+2.d0*gamadnrd(9))
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
x2 = 5.0d0
|
|
x2dnrd = 0.D0
|
|
ELSE
|
|
x2dnrd = gamadnrd(i)
|
|
x2 = gama(i)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
gamadnrd(i) = 0.D0
|
|
gama(i) = -5.0d0
|
|
ELSE
|
|
gamadnrd(i) = x2dnrd
|
|
gama(i) = x2
|
|
END IF
|
|
gamadnrd(i) = 10.d0**gama(i)*LOG(10.d0)*gamadnrd(i)
|
|
gama(i) = 10.d0**gama(i)
|
|
ENDDO
|
|
C
|
|
C Increment ACTIVITY call counter
|
|
iclact = iclact + 1
|
|
C
|
|
C *** END OF SUBROUTINE ACTIVITY ****************************************
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C Differentiation of kmful3 in forward (tangent) mode:
|
|
C variations of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_DNRD(ionic, ionicdnrd, temp, g01, g01dnrd, g02,
|
|
+ g02dnrd, g03, g03dnrd, g04, g04dnrd, g05,
|
|
+ g05dnrd, g06, g06dnrd, g07, g07dnrd, g08,
|
|
+ g08dnrd, g09, g09dnrd, g10, g10dnrd, g11,
|
|
+ g11dnrd, g12, g12dnrd)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionicdnrd, siondnrd, cf2dnrd
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01dnrd, g02dnrd, g03dnrd, g04dnrd, g05dnrd,
|
|
+ g06dnrd, g07dnrd, g08dnrd, g09dnrd, g10dnrd,
|
|
+ g11dnrd, g12dnrd
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs1
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
REAL*8 :: tiny
|
|
tiny = 1.d-20
|
|
C
|
|
IF (abs(ionic) < tiny) THEN
|
|
siondnrd = 0.D0
|
|
ELSE
|
|
siondnrd = ionicdnrd/(2.0*SQRT(ionic))
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
CALL MKBI_DNRD(q1, ionic, ionicdnrd, sion, siondnrd, z01, g01,
|
|
+ g01dnrd)
|
|
CALL MKBI_DNRD(q2, ionic, ionicdnrd, sion, siondnrd, z02, g02,
|
|
+ g02dnrd)
|
|
CALL MKBI_DNRD(q3, ionic, ionicdnrd, sion, siondnrd, z03, g03,
|
|
+ g03dnrd)
|
|
CALL MKBI_DNRD(q4, ionic, ionicdnrd, sion, siondnrd, z04, g04,
|
|
+ g04dnrd)
|
|
CALL MKBI_DNRD(q5, ionic, ionicdnrd, sion, siondnrd, z05, g05,
|
|
+ g05dnrd)
|
|
CALL MKBI_DNRD(q6, ionic, ionicdnrd, sion, siondnrd, z06, g06,
|
|
+ g06dnrd)
|
|
CALL MKBI_DNRD(q7, ionic, ionicdnrd, sion, siondnrd, z07, g07,
|
|
+ g07dnrd)
|
|
CALL MKBI_DNRD(q8, ionic, ionicdnrd, sion, siondnrd, z08, g08,
|
|
+ g08dnrd)
|
|
CALL MKBI_DNRD(q10, ionic, ionicdnrd, sion, siondnrd, z10, g10,
|
|
+ g10dnrd)
|
|
CALL MKBI_DNRD(q11, ionic, ionicdnrd, sion, siondnrd, z11, g11,
|
|
+ g11dnrd)
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.D0) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
cf2dnrd = (0.125d0-0.005d0*ti)*(0.039d0*0.92d0*ionic**(-0.8D0)*
|
|
+ ionicdnrd-(0.41d0*siondnrd*(1.d0+sion)-0.41d0*sion*siondnrd)/(
|
|
+ 1.d0+sion)**2)
|
|
cf2 = (0.125d0-0.005d0*ti)*(0.039d0*ionic**0.92d0-0.41d0*sion/(
|
|
+ 1.d0+sion))
|
|
g01dnrd = cf1*g01dnrd - z01*cf2dnrd
|
|
g01 = cf1*g01 - cf2*z01
|
|
g02dnrd = cf1*g02dnrd - z02*cf2dnrd
|
|
g02 = cf1*g02 - cf2*z02
|
|
g03dnrd = cf1*g03dnrd - z03*cf2dnrd
|
|
g03 = cf1*g03 - cf2*z03
|
|
g04dnrd = cf1*g04dnrd - z04*cf2dnrd
|
|
g04 = cf1*g04 - cf2*z04
|
|
g05dnrd = cf1*g05dnrd - z05*cf2dnrd
|
|
g05 = cf1*g05 - cf2*z05
|
|
g06dnrd = cf1*g06dnrd - z06*cf2dnrd
|
|
g06 = cf1*g06 - cf2*z06
|
|
g07dnrd = cf1*g07dnrd - z07*cf2dnrd
|
|
g07 = cf1*g07 - cf2*z07
|
|
g08dnrd = cf1*g08dnrd - z08*cf2dnrd
|
|
g08 = cf1*g08 - cf2*z08
|
|
g10dnrd = cf1*g10dnrd - z10*cf2dnrd
|
|
g10 = cf1*g10 - cf2*z10
|
|
g11dnrd = cf1*g11dnrd - z11*cf2dnrd
|
|
g11 = cf1*g11 - cf2*z11
|
|
END IF
|
|
C
|
|
g09dnrd = g06dnrd + g08dnrd - g11dnrd
|
|
g09 = g06 + g08 - g11
|
|
g12dnrd = g01dnrd + g08dnrd - g11dnrd
|
|
g12 = g01 + g08 - g11
|
|
C
|
|
C *** Return point ; End of subroutine
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C Differentiation of mkbi in forward (tangent) mode:
|
|
C variations of useful results: bi
|
|
C with respect to varying inputs: sion ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_DNRD(q, ionic, ionicdnrd, sion, siondnrd, zip, bi
|
|
+ , bidnrd)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionicdnrd, siondnrd, bidnrd
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: cdnrd, xxdnrd
|
|
REAL*8 :: arg1
|
|
REAL*8 :: arg1dnrd
|
|
REAL*8 :: pwx1
|
|
REAL*8 :: pwx1dnrd
|
|
REAL*8 :: pwr1
|
|
REAL*8 :: pwr1dnrd
|
|
INTRINSIC EXP
|
|
INTRINSIC LOG10
|
|
REAL*8 :: tiny
|
|
tiny = 1.d-20
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
arg1dnrd = -(.023d0*((ionicdnrd*ionic+ionic*ionicdnrd)*ionic+ionic
|
|
+ **2*ionicdnrd))
|
|
arg1 = -(.023d0*ionic*ionic*ionic)
|
|
cdnrd = .055d0*q*arg1dnrd*EXP(arg1)
|
|
c = 1. + .055d0*q*EXP(arg1)
|
|
xxdnrd = -((0.5107d0*siondnrd*(1.d0+c*sion)-0.5107d0*sion*(cdnrd*
|
|
+ sion+c*siondnrd))/(1.d0+c*sion)**2)
|
|
xx = -(0.5107d0*sion/(1.d0+c*sion))
|
|
pwx1dnrd = .1d0*ionicdnrd
|
|
pwx1 = 1.d0 + .1d0*ionic
|
|
IF (pwx1 > 0.d0 .OR. (pwx1 < 0.d0 .AND.
|
|
& abs(q-INT(q)) < tiny)) THEN
|
|
pwr1dnrd = q*pwx1**(q-1)*pwx1dnrd
|
|
ELSE IF (abs(pwx1) < tiny .AND. abs(q-1.D0) < tiny) THEN
|
|
pwr1dnrd = pwx1dnrd
|
|
ELSE
|
|
pwr1dnrd = 0.0
|
|
END IF
|
|
pwr1 = pwx1**q
|
|
bidnrd = b*pwr1dnrd
|
|
bi = 1.d0 + b*pwr1 - b
|
|
bidnrd = zip*bidnrd/(bi*LOG(10.D0)) + zip*xxdnrd
|
|
bi = zip*LOG10(bi) + zip*xx
|
|
RETURN
|
|
END
|
|
|
|
C
|
|
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of calcb4e in reverse (adjoint) mode:
|
|
C gradient of useful results: aerliq gas
|
|
C with respect to varying inputs: wp aerliq gas
|
|
C RW status of diff variables: wp:out aerliq:in-out gas:in-out
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCB4E
|
|
C *** CASE B4
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0)
|
|
C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE
|
|
C
|
|
C FOR CALCULATIONS, A BISECTION IS PERFORMED WITH RESPECT TO H+.
|
|
C THE OBJECTIVE FUNCTION IS THE DIFFERENCE BETWEEN THE ESTIMATED H+
|
|
C AND THAT CALCULATED FROM ELECTRONEUTRALITY.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCB4E_EB(wpeb, gaseb, aerliqeb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: molalreb(npair)
|
|
REAL*8 :: x, y, so4i, hso4i, bb, cc, dd
|
|
REAL*8 :: so4ieb, hso4ieb, bbeb, cceb, ddeb
|
|
REAL*8 :: gas(3), AERLIQ(NIONS+NGASAQ+2)
|
|
REAL*8 :: wpeb(ncomp), gaseb(3), aerliqeb(NIONS+NGASAQ+2)
|
|
INTEGER :: i
|
|
REAL*8 :: ak1
|
|
REAL*8 :: ak1eb
|
|
REAL*8 :: bet
|
|
REAL*8 :: beteb
|
|
REAL*8 :: gam
|
|
REAL*8 :: gameb
|
|
INTEGER :: j
|
|
INTEGER :: branch
|
|
INTEGER :: ad_count
|
|
INTEGER :: i0
|
|
REAL*8 :: x2eb
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0eb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x4
|
|
REAL*8 :: x3
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x3eb
|
|
REAL*8 :: temp1eb
|
|
REAL*8 :: x1eb
|
|
REAL*8 :: x4eb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1, npflag, ncase
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp2eb
|
|
C
|
|
C *** SOLVE EQUATIONS **************************************************
|
|
C
|
|
frst = .true.
|
|
calain = .true.
|
|
C
|
|
C *** CALCULATE WATER CONTENT ******************************************
|
|
C
|
|
C
|
|
C CALL CALCB1A ! GET DRY SALT CONTENT, AND USE FOR WATER.
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
C Equivalent NH4HSO4
|
|
x = 2.d0*w(2) - w(3)
|
|
C Equivalent (NH4)2SO4
|
|
y = w(3) - w(2)
|
|
C
|
|
C *** CALCULATE COMPOSITION *******************************************
|
|
C
|
|
IF (x <= y) THEN
|
|
C LC is the MIN(x,y)
|
|
C CLC = X ! NH4HSO4 >= (NH4)2S04
|
|
clc = 2.d0*w(2) - w(3)
|
|
cnh4hs4 = zero
|
|
C CNH42S4 = Y-X
|
|
cnh42s4 = 2.d0*w(3) - 3.d0*w(2)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
C CLC = Y ! NH4HSO4 < (NH4)2S04
|
|
clc = w(3) - w(2)
|
|
C CNH4HS4 = X-Y
|
|
cnh4hs4 = 3.d0*w(2) - 2.d0*w(3)
|
|
cnh42s4 = zero
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
molalr(13) = clc
|
|
molalr(9) = cnh4hs4
|
|
molalr(4) = cnh42s4
|
|
water = molalr(13)/m0(13) + molalr(9)/m0(9) + molalr(4)/m0(4)
|
|
C
|
|
C NH4I
|
|
molal(3) = w(3)
|
|
C
|
|
i = 1
|
|
ad_count = 0
|
|
C NSWEEP = 50
|
|
DO WHILE (i <= nsweep .AND. calain)
|
|
CALL PUSHREAL8(ak1)
|
|
C IF (I > 1) CALL CALCACT3
|
|
ak1 = xk1*(gama(8)/gama(7))**2.*(water/gama(7))
|
|
bet = w(2)
|
|
gam = molal(3)
|
|
CALL PUSHREAL8(bb)
|
|
C
|
|
bb = bet + ak1 - gam
|
|
cc = -(ak1*bet)
|
|
dd = bb*bb - 4.d0*cc
|
|
x4 = 0.5d0*(-bb+SQRT(dd))
|
|
IF (x4 > w(2)) THEN
|
|
x1 = w(2)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = x4
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(molal(5))
|
|
molal(5) = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(molal(5))
|
|
molal(5) = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (w(2) - molal(5) > w(2)) THEN
|
|
x2 = w(2)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x2 = w(2) - molal(5)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < tiny) THEN
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = x2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (ak1*molal(6)/molal(5) > w(2)) THEN
|
|
x3 = w(2)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x3 = ak1*molal(6)/molal(5)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x3 < tiny) THEN
|
|
CALL PUSHREAL8(molal(1))
|
|
molal(1) = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(molal(1))
|
|
molal(1) = x3
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C WRITE(*,*) 'MOLAL(5, 6) ', MOLAL(5), MOLAL(6)
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C slc.1.2011 - calling CALCMR for case E rather than B
|
|
C
|
|
C CORRECT FOR HSO4 DISSOCIATION as from B4
|
|
so4i = molal(5) - molal(1)
|
|
C SO4I = MAX(MOLAL(5)-MOLAL(1),ZERO) ! FROM HSO4 DISSOCIATION
|
|
hso4i = molal(6) + molal(1)
|
|
IF (so4i < hso4i) THEN
|
|
C [LC] = [SO4]
|
|
molalr(13) = so4i
|
|
IF (hso4i - so4i < zero) THEN
|
|
molalr(9) = zero
|
|
CALL PUSHCONTROL2B(1)
|
|
ELSE
|
|
molalr(9) = hso4i - so4i
|
|
CALL PUSHCONTROL2B(0)
|
|
END IF
|
|
ELSE
|
|
C [LC] = [HSO4]
|
|
molalr(13) = hso4i
|
|
IF (so4i - hso4i < zero) THEN
|
|
molalr(4) = zero
|
|
CALL PUSHCONTROL2B(3)
|
|
ELSE
|
|
molalr(4) = so4i - hso4i
|
|
CALL PUSHCONTROL2B(2)
|
|
END IF
|
|
END IF
|
|
CALL PUSHREAL8(water)
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
DO j=1,npair
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
C IF (.NOT.CALAIN) GOTO 30
|
|
i = i + 1
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C*** slc.11.2009 moved to beginning of loop
|
|
CALL CALCACT3()
|
|
ad_count = ad_count + 1
|
|
ENDDO
|
|
IF (CALAIN .AND. (I > (NSWEEP+1))) THEN
|
|
CALL PUSHERR (0001, 'CALCB4E') ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
CALL PUSHINTEGER4(ad_count)
|
|
DO ii1=1,nions
|
|
molaleb(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=nions,1,-1
|
|
molaleb(i) = molaleb(i) + aerliqeb(i)
|
|
ENDDO
|
|
aerliqeb = 0.D0
|
|
gaseb(3) = 0.D0
|
|
ghno3eb = gaseb(2)
|
|
gaseb(2) = 0.D0
|
|
gaseb(1) = 0.D0
|
|
CALL CALCNA_EB()
|
|
DO ii1=1,npair
|
|
molalreb(ii1) = 0.D0
|
|
ENDDO
|
|
CALL POPINTEGER4(ad_count)
|
|
DO i0=1,ad_count
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3_EB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) watereb = 0.D0
|
|
DO j=npair,1,-1
|
|
molalreb(j) = molalreb(j) + watereb/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(water)
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch < 2) THEN
|
|
IF (branch == 0) THEN
|
|
hso4ieb = molalreb(9)
|
|
so4ieb = -molalreb(9)
|
|
molalreb(9) = 0.D0
|
|
ELSE
|
|
molalreb(9) = 0.D0
|
|
hso4ieb = 0.D0
|
|
so4ieb = 0.D0
|
|
END IF
|
|
so4ieb = so4ieb + molalreb(13)
|
|
molalreb(13) = 0.D0
|
|
ELSE
|
|
IF (branch == 2) THEN
|
|
so4ieb = molalreb(4)
|
|
hso4ieb = -molalreb(4)
|
|
molalreb(4) = 0.D0
|
|
ELSE
|
|
molalreb(4) = 0.D0
|
|
hso4ieb = 0.D0
|
|
so4ieb = 0.D0
|
|
END IF
|
|
hso4ieb = hso4ieb + molalreb(13)
|
|
molalreb(13) = 0.D0
|
|
END IF
|
|
molaleb(6) = molaleb(6) + hso4ieb
|
|
molaleb(1) = molaleb(1) + hso4ieb
|
|
molaleb(5) = molaleb(5) + so4ieb
|
|
molaleb(1) = molaleb(1) - so4ieb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(molal(1))
|
|
molaleb(1) = 0.D0
|
|
x3eb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(molal(1))
|
|
x3eb = molaleb(1)
|
|
molaleb(1) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
web(2) = web(2) + x3eb
|
|
ak1 = xk1*(gama(8)/gama(7))**2.*(water/gama(7))
|
|
ak1eb = 0.D0
|
|
ELSE
|
|
temp2eb = x3eb/molal(5)
|
|
ak1eb = molal(6)*temp2eb
|
|
molaleb(6) = molaleb(6) + ak1*temp2eb
|
|
molaleb(5) = molaleb(5) - ak1*molal(6)*temp2eb/molal(5)
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(molal(6))
|
|
molaleb(6) = 0.D0
|
|
x2eb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(molal(6))
|
|
x2eb = molaleb(6)
|
|
molaleb(6) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
web(2) = web(2) + x2eb
|
|
ELSE
|
|
web(2) = web(2) + x2eb
|
|
molaleb(5) = molaleb(5) - x2eb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(molal(5))
|
|
molaleb(5) = 0.D0
|
|
x1eb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(molal(5))
|
|
x1eb = molaleb(5)
|
|
molaleb(5) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
web(2) = web(2) + x1eb
|
|
x4eb = 0.D0
|
|
ELSE
|
|
x4eb = x1eb
|
|
END IF
|
|
bet = w(2)
|
|
gam = molal(3)
|
|
bb = bet + ak1 - gam
|
|
cc = -(ak1*bet)
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (dd == 0.0) THEN
|
|
ddeb = 0.0
|
|
ELSE
|
|
ddeb = 0.5d0*x4eb/(2.0*SQRT(dd))
|
|
END IF
|
|
bbeb = 2*bb*ddeb - 0.5d0*x4eb
|
|
cceb = -(4.d0*ddeb)
|
|
ak1eb = ak1eb + bbeb - bet*cceb
|
|
beteb = bbeb - ak1*cceb
|
|
CALL POPREAL8(bb)
|
|
gameb = -bbeb
|
|
molaleb(3) = molaleb(3) + gameb
|
|
web(2) = web(2) + beteb
|
|
CALL POPREAL8(ak1)
|
|
temp0 = water/gama(7)
|
|
temp1 = gama(8)/gama(7)
|
|
temp1eb = 2.*temp1*temp0*xk1*ak1eb/gama(7)
|
|
temp0eb = temp1**2.*xk1*ak1eb/gama(7)
|
|
gamaeb(8) = gamaeb(8) + temp1eb
|
|
gamaeb(7) = gamaeb(7) - temp0*temp0eb - temp1*temp1eb
|
|
watereb = temp0eb
|
|
ENDDO
|
|
web(3) = web(3) + molaleb(3)
|
|
molalreb(13) = molalreb(13) + watereb/m0(13)
|
|
molalreb(9) = molalreb(9) + watereb/m0(9)
|
|
molalreb(4) = molalreb(4) + watereb/m0(4)
|
|
cnh42s4eb = molalreb(4)
|
|
molalreb(4) = 0.D0
|
|
cnh4hs4eb = molalreb(9)
|
|
molalreb(9) = 0.D0
|
|
clceb = molalreb(13)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
web(3) = web(3) + 2*cnh42s4eb
|
|
web(2) = web(2) + 2*clceb - 3*cnh42s4eb
|
|
web(3) = web(3) - clceb
|
|
ELSE
|
|
web(2) = web(2) + 3*cnh4hs4eb
|
|
web(3) = web(3) + clceb - 2*cnh4hs4eb
|
|
web(2) = web(2) - clceb
|
|
END IF
|
|
wpeb = web
|
|
!WRITE(*,*) 'E4, wpeb: ',wpeb
|
|
|
|
END
|
|
|
|
C Differentiation of calcna in reverse (adjoint) mode:
|
|
C gradient of useful results: molal ghno3
|
|
C with respect to varying inputs: w molal gama water
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNA
|
|
C *** CALCULATES NITRATES SPECIATION
|
|
C
|
|
C NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT
|
|
C DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC
|
|
C ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> (H+) + (NO3-)
|
|
C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNA_EB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: alfa, delt, kapa, diak
|
|
REAL*8 :: alfaeb, delteb, kapaeb, diakeb
|
|
REAL*8 :: x
|
|
REAL*8 :: xeb
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0eb
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp1eb
|
|
REAL*8 :: temp1eb1
|
|
REAL*8 :: temp1eb0
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** CALCULATE HNO3 DISSOLUTION ****************************************
|
|
C
|
|
x = w(4)
|
|
delt = 0.0d0
|
|
IF (water > tiny) THEN
|
|
kapa = molal(1)
|
|
alfa = xk4*r*temp*(water/gama(10))**2.0
|
|
diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x)
|
|
delt = 0.5*(-(kapa+alfa)+diak)
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
IF (x - delt < 0.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
delteb = molaleb(7) + molaleb(1)
|
|
molaleb(7) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
xeb = 0.D0
|
|
ELSE
|
|
xeb = ghno3eb
|
|
delteb = delteb - ghno3eb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
DO ii1=1,npair
|
|
gamaeb(ii1) = 0.D0
|
|
ENDDO
|
|
watereb = 0.D0
|
|
ELSE
|
|
temp1eb = 0.5*delteb
|
|
diakeb = temp1eb
|
|
IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN
|
|
temp1eb1 = 0.0
|
|
ELSE
|
|
temp1eb1 = diakeb/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x)))
|
|
END IF
|
|
temp1eb0 = 2.0*(kapa+alfa)*temp1eb1
|
|
alfaeb = temp1eb0 + 4.0*x*temp1eb1 - temp1eb
|
|
kapaeb = temp1eb0 - temp1eb
|
|
xeb = xeb + 4.0*alfa*temp1eb1
|
|
DO ii1=1,npair
|
|
gamaeb(ii1) = 0.D0
|
|
ENDDO
|
|
temp0 = water/gama(10)
|
|
temp0eb = 2.0*temp0*xk4*r*temp*alfaeb/gama(10)
|
|
watereb = temp0eb
|
|
gamaeb(10) = gamaeb(10) - temp0*temp0eb
|
|
molaleb(1) = molaleb(1) + kapaeb
|
|
END IF
|
|
DO ii1=1,ncomp
|
|
web(ii1) = 0.D0
|
|
ENDDO
|
|
web(4) = web(4) + xeb
|
|
END
|
|
|
|
C Differentiation of calcact3 in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3_EB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0eb(6, 4), sioneb, heb, cheb, f1eb(3), f2eb(4)
|
|
REAL*8 :: mpl, xij, yji
|
|
REAL*8 :: mpleb, xijeb, yjieb, ioniceb
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01eb
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02eb
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03eb
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04eb
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05eb
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06eb
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07eb
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08eb
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09eb
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10eb
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11eb
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12eb
|
|
INTEGER :: j
|
|
REAL*8 :: errou
|
|
REAL*8 :: errin
|
|
C
|
|
C
|
|
C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H
|
|
C
|
|
C *** SAVE ACTIVITIES IN OLD ARRAY *************************************
|
|
C
|
|
INTEGER :: branch
|
|
REAL*8 :: x2eb
|
|
REAL*8 :: temp0eb
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp0eb13
|
|
REAL*8 :: temp0eb12
|
|
REAL*8 :: temp0eb11
|
|
REAL*8 :: temp0eb10
|
|
INTRINSIC ABS
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: temp0eb9
|
|
REAL*8 :: temp0eb8
|
|
REAL*8 :: temp0eb7
|
|
REAL*8 :: temp0eb6
|
|
REAL*8 :: temp0eb5
|
|
REAL*8 :: temp0eb4
|
|
REAL*8 :: temp0eb3
|
|
REAL*8 :: temp0eb2
|
|
REAL*8 :: temp0eb1
|
|
REAL*8 :: temp0eb0
|
|
REAL*8 :: x1eb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: y1
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
DO i=1,7
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08,
|
|
+ g09, g10, g11, g12)
|
|
C
|
|
g0(1, 1) = g11
|
|
g0(1, 2) = g07
|
|
g0(1, 3) = g08
|
|
g0(1, 4) = g10
|
|
g0(2, 1) = g01
|
|
g0(2, 2) = g02
|
|
g0(2, 3) = g12
|
|
g0(2, 4) = g03
|
|
g0(3, 1) = g06
|
|
g0(3, 2) = g04
|
|
g0(3, 3) = g09
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
sion = SQRT(ionic)
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
yji = ch*molal(j+3)/water
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gama(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gama(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gama(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gama(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gama(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gama(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gama(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gama(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gama(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gama(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gama(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gama(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gama(13))
|
|
C LC ; SCAPE
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
ELSE
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
gamaeb(i) = 10.d0**gama(i)*LOG(10.d0)*gamaeb(i)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
gamaeb(i) = 0.D0
|
|
x2eb = 0.D0
|
|
ELSE
|
|
x2eb = gamaeb(i)
|
|
gamaeb(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) gamaeb(i) = gamaeb(i) + x2eb
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamaeb(4) = gamaeb(4) + 0.2d0*3.d0*gamaeb(13)
|
|
gamaeb(9) = gamaeb(9) + 0.2d0*2.d0*gamaeb(13)
|
|
gamaeb(13) = 0.D0
|
|
DO ii1=1,3
|
|
f1eb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2eb(ii1) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp0eb2 = zz(12)*gamaeb(12)/(z(2)+z(6))
|
|
f1eb(2) = f1eb(2) + temp0eb2/z(2)
|
|
f2eb(3) = f2eb(3) + temp0eb2/z(6)
|
|
heb = -(zz(12)*gamaeb(12))
|
|
gamaeb(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp0eb3 = zz(11)*gamaeb(11)/(z(1)+z(4))
|
|
f2eb(1) = f2eb(1) + temp0eb3/z(4)
|
|
heb = heb - zz(11)*gamaeb(11)
|
|
gamaeb(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp0eb4 = zz(10)*gamaeb(10)/(z(1)+z(7))
|
|
f1eb(1) = f1eb(1) + temp0eb4/z(1) + temp0eb3/z(1)
|
|
f2eb(4) = f2eb(4) + temp0eb4/z(7)
|
|
heb = heb - zz(10)*gamaeb(10)
|
|
gamaeb(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp0eb5 = zz(9)*gamaeb(9)/(z(3)+z(6))
|
|
f1eb(3) = f1eb(3) + temp0eb5/z(3)
|
|
heb = heb - zz(9)*gamaeb(9)
|
|
gamaeb(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp0eb6 = zz(8)*gamaeb(8)/(z(1)+z(6))
|
|
f2eb(3) = f2eb(3) + temp0eb6/z(6) + temp0eb5/z(6)
|
|
heb = heb - zz(8)*gamaeb(8)
|
|
gamaeb(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp0eb7 = zz(7)*gamaeb(7)/(z(1)+z(5))
|
|
f1eb(1) = f1eb(1) + temp0eb7/z(1) + temp0eb6/z(1)
|
|
f2eb(2) = f2eb(2) + temp0eb7/z(5)
|
|
heb = heb - zz(7)*gamaeb(7)
|
|
gamaeb(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp0eb8 = zz(6)*gamaeb(6)/(z(3)+z(4))
|
|
f2eb(1) = f2eb(1) + temp0eb8/z(4)
|
|
heb = heb - zz(6)*gamaeb(6)
|
|
gamaeb(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp0eb9 = zz(5)*gamaeb(5)/(z(3)+z(7))
|
|
f2eb(4) = f2eb(4) + temp0eb9/z(7)
|
|
heb = heb - zz(5)*gamaeb(5)
|
|
gamaeb(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp0eb10 = zz(4)*gamaeb(4)/(z(3)+z(5))
|
|
f1eb(3) = f1eb(3) + temp0eb9/z(3) + temp0eb10/z(3) + temp0eb8/z(3)
|
|
f2eb(2) = f2eb(2) + temp0eb10/z(5)
|
|
heb = heb - zz(4)*gamaeb(4)
|
|
gamaeb(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp0eb11 = zz(3)*gamaeb(3)/(z(2)+z(7))
|
|
f2eb(4) = f2eb(4) + temp0eb11/z(7)
|
|
heb = heb - zz(3)*gamaeb(3)
|
|
gamaeb(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp0eb12 = zz(2)*gamaeb(2)/(z(2)+z(5))
|
|
f2eb(2) = f2eb(2) + temp0eb12/z(5)
|
|
heb = heb - zz(2)*gamaeb(2)
|
|
gamaeb(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp0eb13 = zz(1)*gamaeb(1)/(z(2)+z(4))
|
|
f1eb(2) = f1eb(2) + temp0eb12/z(2) + temp0eb13/z(2) + temp0eb11/z(
|
|
+ 2)
|
|
f2eb(1) = f2eb(1) + temp0eb13/z(4)
|
|
heb = heb - zz(1)*gamaeb(1)
|
|
gamaeb(1) = 0.D0
|
|
ioniceb = 0.D0
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0eb(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mpleb = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijeb = (g0(i, j)+zpl*zmi*h)*f2eb(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0eb(i, j) = g0eb(i, j) + yji*f1eb(i) + xij*f2eb(j)
|
|
heb = heb + yji*zpl*zmi*f1eb(i) + xij*zpl*zmi*f2eb(j)
|
|
yjieb = (g0(i, j)+zpl*zmi*h)*f1eb(i)
|
|
temp0eb1 = molal(j+3)*yjieb/water
|
|
molaleb(j+3) = molaleb(j+3) + ch*yjieb/water
|
|
cheb = mpl*xijeb + temp0eb1
|
|
watereb = watereb - ch*temp0eb1/water
|
|
mpleb = mpleb + ch*xijeb
|
|
ioniceb = ioniceb - (zpl+zmi)**2*0.25d0*cheb/ionic**2
|
|
ENDDO
|
|
CALL POPREAL8(mpl)
|
|
molaleb(i) = molaleb(i) + mpleb/water
|
|
watereb = watereb - molal(i)*mpleb/water**2
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp0eb0 = agama*heb/(sion+1.d0)
|
|
sioneb = (1.D0-sion/(sion+1.d0))*temp0eb0
|
|
IF (.NOT.ionic == 0.0) ioniceb = ioniceb + sioneb/(2.0*SQRT(
|
|
+ ionic))
|
|
g05eb = g0eb(3, 4)
|
|
g0eb(3, 4) = 0.D0
|
|
g09eb = g0eb(3, 3)
|
|
g0eb(3, 3) = 0.D0
|
|
g04eb = g0eb(3, 2)
|
|
g0eb(3, 2) = 0.D0
|
|
g06eb = g0eb(3, 1)
|
|
g0eb(3, 1) = 0.D0
|
|
g03eb = g0eb(2, 4)
|
|
g0eb(2, 4) = 0.D0
|
|
g12eb = g0eb(2, 3)
|
|
g0eb(2, 3) = 0.D0
|
|
g02eb = g0eb(2, 2)
|
|
g0eb(2, 2) = 0.D0
|
|
g01eb = g0eb(2, 1)
|
|
g0eb(2, 1) = 0.D0
|
|
g10eb = g0eb(1, 4)
|
|
g0eb(1, 4) = 0.D0
|
|
g08eb = g0eb(1, 3)
|
|
g0eb(1, 3) = 0.D0
|
|
g07eb = g0eb(1, 2)
|
|
g0eb(1, 2) = 0.D0
|
|
g11eb = g0eb(1, 1)
|
|
CALL KMFUL3_EB(ionic, ioniceb, temp, g01, g01eb, g02, g02eb, g03,
|
|
+ g03eb, g04, g04eb, g05, g05eb, g06, g06eb, g07,
|
|
+ g07eb, g08, g08eb, g09, g09eb, g10, g10eb, g11,
|
|
+ g11eb, g12, g12eb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionic)
|
|
x1eb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1eb = ioniceb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ioniceb = 0.D0
|
|
ELSE
|
|
temp0eb = 0.5d0*x1eb/water
|
|
ioniceb = temp0eb
|
|
watereb = watereb - ionic*temp0eb/water
|
|
END IF
|
|
DO i=7,1,-1
|
|
molaleb(i) = molaleb(i) + z(i)**2*ioniceb
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of kmful3 in reverse (adjoint) mode:
|
|
C gradient of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12 ionic
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_EB(ionic, ioniceb, temp, g01, g01eb, g02, g02eb
|
|
+ , g03, g03eb, g04, g04eb, g05, g05eb, g06,
|
|
+ g06eb, g07, g07eb, g08, g08eb, g09, g09eb,
|
|
+ g10, g10eb, g11, g11eb, g12, g12eb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ioniceb, sioneb, cf2eb
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01eb, g02eb, g03eb, g04eb, g05eb, g06eb, g07eb,
|
|
+ g08eb, g09eb, g10eb, g11eb, g12eb
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0eb
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp0eb0
|
|
REAL*8 :: abs1
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01eb = g01eb + g12eb
|
|
g08eb = g08eb + g09eb + g12eb
|
|
g11eb = g11eb - g09eb - g12eb
|
|
g06eb = g06eb + g09eb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2eb = -(z10*g10eb) - z07*g07eb - z05*g05eb - z03*g03eb - z01*
|
|
+ g01eb - z02*g02eb - z04*g04eb - z06*g06eb - z08*g08eb - z11*
|
|
+ g11eb
|
|
g11eb = cf1*g11eb
|
|
g10eb = cf1*g10eb
|
|
g08eb = cf1*g08eb
|
|
g07eb = cf1*g07eb
|
|
g06eb = cf1*g06eb
|
|
g05eb = cf1*g05eb
|
|
g04eb = cf1*g04eb
|
|
g03eb = cf1*g03eb
|
|
g02eb = cf1*g02eb
|
|
g01eb = cf1*g01eb
|
|
temp0eb = (0.125d0-ti*0.005d0)*cf2eb
|
|
temp0eb0 = -(0.41d0*temp0eb/(sion+1.d0))
|
|
ioniceb = ioniceb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0eb
|
|
sioneb = (1.D0-sion/(sion+1.d0))*temp0eb0
|
|
ELSE
|
|
sioneb = 0.D0
|
|
END IF
|
|
CALL MKBI_EB(q11, ionic, ioniceb, sion, sioneb, z11, g11, g11eb)
|
|
CALL MKBI_EB(q10, ionic, ioniceb, sion, sioneb, z10, g10, g10eb)
|
|
CALL MKBI_EB(q8, ionic, ioniceb, sion, sioneb, z08, g08, g08eb)
|
|
CALL MKBI_EB(q7, ionic, ioniceb, sion, sioneb, z07, g07, g07eb)
|
|
CALL MKBI_EB(q6, ionic, ioniceb, sion, sioneb, z06, g06, g06eb)
|
|
CALL MKBI_EB(q5, ionic, ioniceb, sion, sioneb, z05, g05, g05eb)
|
|
CALL MKBI_EB(q4, ionic, ioniceb, sion, sioneb, z04, g04, g04eb)
|
|
CALL MKBI_EB(q3, ionic, ioniceb, sion, sioneb, z03, g03, g03eb)
|
|
CALL MKBI_EB(q2, ionic, ioniceb, sion, sioneb, z02, g02, g02eb)
|
|
CALL MKBI_EB(q1, ionic, ioniceb, sion, sioneb, z01, g01, g01eb)
|
|
IF (.NOT.ionic == 0.0) ioniceb = ioniceb + sioneb/(2.0*SQRT(
|
|
+ ionic))
|
|
END
|
|
|
|
C Differentiation of mkbi in reverse (adjoint) mode:
|
|
C gradient of useful results: sion bi ionic
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_EB(q, ionic, ioniceb, sion, sioneb, zip, bi, bieb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ioniceb, sioneb, bieb
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: ceb, xxeb
|
|
INTRINSIC EXP
|
|
REAL*8 :: tempeb0
|
|
REAL*8 :: tempeb
|
|
INTRINSIC LOG10
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic))
|
|
bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b
|
|
C
|
|
xxeb = zip*bieb
|
|
bieb = zip*bieb/(bi*LOG(10.0))
|
|
tempeb = -(0.5107d0*xxeb/(c*sion+1.d0))
|
|
tempeb0 = -(sion*tempeb/(c*sion+1.d0))
|
|
sioneb = sioneb + c*tempeb0 + tempeb
|
|
ceb = sion*tempeb0
|
|
IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q
|
|
+ ))) THEN
|
|
ioniceb = ioniceb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*
|
|
+ ionic**2*ceb
|
|
ELSE
|
|
ioniceb = ioniceb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bieb -
|
|
+ .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*ceb
|
|
END IF
|
|
END
|
|
|
|
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of calcc2f in reverse (adjoint) mode:
|
|
C gradient of useful results: aerliq gas
|
|
C with respect to varying inputs: wp aerliq gas
|
|
C RW status of diff variables: wp:out aerliq:in-out gas:in-out
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCC2
|
|
C *** CASE C2
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0)
|
|
C 2. THERE IS ONLY A LIQUID PHASE
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCC2F_FB(wpfb, gasfb, aerliqfb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: molalrfb(npair)
|
|
REAL*8 :: lamda, kapa, psi, parm
|
|
REAL*8 :: lamdafb, kapafb, psifb, parmfb
|
|
REAL*8 :: bb, cc
|
|
REAL*8 :: bbfb, ccfb
|
|
REAL*8 :: gas(3), AERLIQ(NIONS+NGASAQ+2)
|
|
REAL*8 :: wpfb(ncomp), gasfb(3), aerliqfb(NIONS+NGASAQ+2)
|
|
INTEGER :: i
|
|
INTEGER :: j
|
|
INTEGER :: branch
|
|
INTEGER :: ad_count
|
|
INTEGER :: i0
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp1fb
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp2fb
|
|
REAL*8 :: temp0fb
|
|
INTEGER :: ii1, npflag, ncase
|
|
INTRINSIC SQRT
|
|
|
|
!WRITE(*,*) 'F5, gasfb: ',gasfb
|
|
!WRITE(*,*) 'F5, aerliqfb: ',aerliqfb
|
|
C
|
|
C Outer loop activity calculation flag
|
|
frst = .true.
|
|
calain = .true.
|
|
C
|
|
C *** SOLVE EQUATIONS **************************************************
|
|
C
|
|
C NH4HSO4 INITIALLY IN SOLUTION
|
|
lamda = w(3)
|
|
C H2SO4 IN SOLUTION
|
|
psi = w(2) - w(3)
|
|
i = 1
|
|
ad_count = 0
|
|
C NSWEEP = 50
|
|
DO WHILE (i <= nsweep .AND. calain)
|
|
C IF (I > 1) CALL CALCACT3
|
|
parm = water*xk1/gama(7)*(gama(8)/gama(7))**2.
|
|
bb = psi + parm
|
|
cc = -(parm*(lamda+psi))
|
|
kapa = 0.5*(-bb+SQRT(bb*bb-4.0*cc))
|
|
CALL PUSHREAL8(molal(1))
|
|
C
|
|
C *** SPECIATION & WATER CONTENT ***************************************
|
|
C
|
|
C HI
|
|
molal(1) = psi + kapa
|
|
CALL PUSHREAL8(molal(3))
|
|
C NH4I
|
|
molal(3) = lamda
|
|
CALL PUSHREAL8(molal(5))
|
|
C SO4I
|
|
molal(5) = kapa
|
|
IF (lamda + psi - kapa < tiny) THEN
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = lamda + psi - kapa
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C slc.1.2011 - calling CALCMR for case F rather than C
|
|
C
|
|
C NH4HSO4 ! slc.1.2011 - different than ISORROPIA 1.7
|
|
molalr(4) = molal(3)
|
|
IF (molal(5) + molal(6) - molal(3) < zero) THEN
|
|
molalr(7) = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
molalr(7) = molal(5) + molal(6) - molal(3)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8(water)
|
|
water = zero
|
|
DO j=1,npair
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
C WRITE(*,*) 'Iteration: i', I
|
|
C WRITE(*,*) 'MOLAL ',MOLAL(1), MOLAL(3), MoLAL(5), MOLAL(6)
|
|
C WRITE(*,*) 'MOLALR ', (MOLALR(7)), (MOLALR(4))
|
|
C WRITE(*,*) 'M0 ',(M0(7)), (M0(4))
|
|
C WRITE(*,*) 'GAMA ', (GAMA)
|
|
C WRITE(*,*) 'water', water
|
|
C PAUSE
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
C IF (.NOT.CALAIN) GOTO 30
|
|
i = i + 1
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C*** slc.11.2009 moved to beginning of loop
|
|
CALL CALCACT3()
|
|
ad_count = ad_count + 1
|
|
ENDDO
|
|
IF (CALAIN .AND. (I > (NSWEEP+1))) THEN
|
|
CALL PUSHERR (0001, 'CALCC2F') ! WARNING ERROR: NO SOLUTION
|
|
ENDIF
|
|
CALL PUSHINTEGER4(ad_count)
|
|
DO ii1=1,nions
|
|
molalfb(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=nions,1,-1
|
|
molalfb(i) = molalfb(i) + aerliqfb(i)
|
|
ENDDO
|
|
aerliqfb = 0.D0
|
|
gasfb(3) = 0.D0
|
|
ghno3fb = gasfb(2)
|
|
gasfb(2) = 0.D0
|
|
gasfb(1) = 0.D0
|
|
CALL CALCNA_FB()
|
|
DO ii1=1,npair
|
|
molalrfb(ii1) = 0.D0
|
|
ENDDO
|
|
psifb = 0.D0
|
|
lamdafb = 0.D0
|
|
CALL POPINTEGER4(ad_count)
|
|
DO i0=1,ad_count
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3_FB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) waterfb = 0.D0
|
|
DO j=npair,1,-1
|
|
molalrfb(j) = molalrfb(j) + waterfb/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(water)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
molalrfb(7) = 0.D0
|
|
ELSE
|
|
molalfb(5) = molalfb(5) + molalrfb(7)
|
|
molalfb(6) = molalfb(6) + molalrfb(7)
|
|
molalfb(3) = molalfb(3) - molalrfb(7)
|
|
molalrfb(7) = 0.D0
|
|
END IF
|
|
molalfb(3) = molalfb(3) + molalrfb(4)
|
|
molalrfb(4) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(molal(6))
|
|
molalfb(6) = 0.D0
|
|
kapafb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(molal(6))
|
|
lamdafb = lamdafb + molalfb(6)
|
|
psifb = psifb + molalfb(6)
|
|
kapafb = -molalfb(6)
|
|
molalfb(6) = 0.D0
|
|
END IF
|
|
CALL POPREAL8(molal(5))
|
|
kapafb = kapafb + molalfb(5)
|
|
molalfb(5) = 0.D0
|
|
CALL POPREAL8(molal(3))
|
|
lamdafb = lamdafb + molalfb(3)
|
|
molalfb(3) = 0.D0
|
|
CALL POPREAL8(molal(1))
|
|
kapafb = kapafb + molalfb(1)
|
|
parm = water*xk1/gama(7)*(gama(8)/gama(7))**2.
|
|
bb = psi + parm
|
|
cc = -(parm*(lamda+psi))
|
|
IF (bb**2 - 4.0*cc == 0.0) THEN
|
|
temp2fb = 0.0
|
|
ELSE
|
|
temp2fb = 0.5*kapafb/(2.0*SQRT(bb**2-4.0*cc))
|
|
END IF
|
|
bbfb = 2*bb*temp2fb - 0.5*kapafb
|
|
ccfb = -(4.0*temp2fb)
|
|
psifb = psifb + bbfb - parm*ccfb + molalfb(1)
|
|
molalfb(1) = 0.D0
|
|
parmfb = bbfb - (lamda+psi)*ccfb
|
|
lamdafb = lamdafb - parm*ccfb
|
|
temp0 = water/gama(7)
|
|
temp1 = gama(8)/gama(7)
|
|
temp1fb = 2.*temp1*temp0*xk1*parmfb/gama(7)
|
|
temp0fb = temp1**2.*xk1*parmfb/gama(7)
|
|
gamafb(8) = gamafb(8) + temp1fb
|
|
gamafb(7) = gamafb(7) - temp0*temp0fb - temp1*temp1fb
|
|
waterfb = temp0fb
|
|
ENDDO
|
|
wfb(2) = wfb(2) + psifb
|
|
wfb(3) = wfb(3) + lamdafb - psifb
|
|
C
|
|
wpfb = wfb
|
|
!WRITE(*,*) 'F5, wpfb: ',wpfb
|
|
C
|
|
END
|
|
|
|
C Differentiation of calcna in reverse (adjoint) mode:
|
|
C gradient of useful results: molal ghno3
|
|
C with respect to varying inputs: w molal gama water
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNA
|
|
C *** CALCULATES NITRATES SPECIATION
|
|
C
|
|
C NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT
|
|
C DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC
|
|
C ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> (H+) + (NO3-)
|
|
C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNA_FB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: alfa, delt, kapa, diak
|
|
REAL*8 :: alfafb, deltfb, kapafb, diakfb
|
|
REAL*8 :: x
|
|
REAL*8 :: xfb
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp1fb1
|
|
REAL*8 :: temp1fb0
|
|
REAL*8 :: temp1fb
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp0fb
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** CALCULATE HNO3 DISSOLUTION ****************************************
|
|
C
|
|
x = w(4)
|
|
delt = 0.0d0
|
|
IF (water > tiny) THEN
|
|
kapa = molal(1)
|
|
alfa = xk4*r*temp*(water/gama(10))**2.0
|
|
diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x)
|
|
delt = 0.5*(-(kapa+alfa)+diak)
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
IF (x - delt < 0.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
deltfb = molalfb(7) + molalfb(1)
|
|
molalfb(7) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
xfb = 0.D0
|
|
ELSE
|
|
xfb = ghno3fb
|
|
deltfb = deltfb - ghno3fb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
DO ii1=1,npair
|
|
gamafb(ii1) = 0.D0
|
|
ENDDO
|
|
waterfb = 0.D0
|
|
ELSE
|
|
temp1fb = 0.5*deltfb
|
|
diakfb = temp1fb
|
|
IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN
|
|
temp1fb1 = 0.0
|
|
ELSE
|
|
temp1fb1 = diakfb/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x)))
|
|
END IF
|
|
temp1fb0 = 2.0*(kapa+alfa)*temp1fb1
|
|
alfafb = temp1fb0 + 4.0*x*temp1fb1 - temp1fb
|
|
kapafb = temp1fb0 - temp1fb
|
|
xfb = xfb + 4.0*alfa*temp1fb1
|
|
DO ii1=1,npair
|
|
gamafb(ii1) = 0.D0
|
|
ENDDO
|
|
temp0 = water/gama(10)
|
|
temp0fb = 2.0*temp0*xk4*r*temp*alfafb/gama(10)
|
|
waterfb = temp0fb
|
|
gamafb(10) = gamafb(10) - temp0*temp0fb
|
|
molalfb(1) = molalfb(1) + kapafb
|
|
END IF
|
|
DO ii1=1,ncomp
|
|
wfb(ii1) = 0.D0
|
|
ENDDO
|
|
wfb(4) = wfb(4) + xfb
|
|
END
|
|
|
|
C Differentiation of calcact3 in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3_FB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0fb(6, 4), sionfb, hfb, chfb, f1fb(3), f2fb(4)
|
|
REAL*8 :: mpl, xij, yji
|
|
REAL*8 :: mplfb, xijfb, yjifb, ionicfb
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01fb
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02fb
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03fb
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04fb
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05fb
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06fb
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07fb
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08fb
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09fb
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10fb
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11fb
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12fb
|
|
INTEGER :: j
|
|
REAL*8 :: errou
|
|
REAL*8 :: errin
|
|
C
|
|
INTEGER :: branch
|
|
INTRINSIC MAX
|
|
INTRINSIC ABS
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1fb
|
|
REAL*8 :: temp0fb13
|
|
REAL*8 :: temp0fb12
|
|
REAL*8 :: temp0fb11
|
|
REAL*8 :: temp0fb10
|
|
REAL*8 :: x2fb
|
|
REAL*8 :: temp0fb
|
|
INTRINSIC MIN
|
|
REAL*8 :: temp0fb9
|
|
REAL*8 :: temp0fb8
|
|
REAL*8 :: temp0fb7
|
|
REAL*8 :: temp0fb6
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
REAL*8 :: temp0fb5
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp0fb4
|
|
REAL*8 :: temp0fb3
|
|
REAL*8 :: temp0fb2
|
|
REAL*8 :: temp0fb1
|
|
REAL*8 :: temp0fb0
|
|
REAL*8 :: y1
|
|
C
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
DO i=1,7
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08,
|
|
+ g09, g10, g11, g12)
|
|
C
|
|
g0(1, 1) = g11
|
|
g0(1, 2) = g07
|
|
g0(1, 3) = g08
|
|
g0(1, 4) = g10
|
|
g0(2, 1) = g01
|
|
g0(2, 2) = g02
|
|
g0(2, 3) = g12
|
|
g0(2, 4) = g03
|
|
g0(3, 1) = g06
|
|
g0(3, 2) = g04
|
|
g0(3, 3) = g09
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
sion = SQRT(ionic)
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
yji = ch*molal(j+3)/water
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gama(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gama(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gama(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gama(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gama(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gama(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gama(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gama(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gama(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gama(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gama(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gama(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gama(13))
|
|
C LC ; SCAPE
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
ELSE
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
gamafb(i) = 10.d0**gama(i)*LOG(10.d0)*gamafb(i)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
gamafb(i) = 0.D0
|
|
x2fb = 0.D0
|
|
ELSE
|
|
x2fb = gamafb(i)
|
|
gamafb(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) gamafb(i) = gamafb(i) + x2fb
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamafb(4) = gamafb(4) + 0.2d0*3.d0*gamafb(13)
|
|
gamafb(9) = gamafb(9) + 0.2d0*2.d0*gamafb(13)
|
|
gamafb(13) = 0.D0
|
|
DO ii1=1,3
|
|
f1fb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2fb(ii1) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp0fb2 = zz(12)*gamafb(12)/(z(2)+z(6))
|
|
f1fb(2) = f1fb(2) + temp0fb2/z(2)
|
|
f2fb(3) = f2fb(3) + temp0fb2/z(6)
|
|
hfb = -(zz(12)*gamafb(12))
|
|
gamafb(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp0fb3 = zz(11)*gamafb(11)/(z(1)+z(4))
|
|
f2fb(1) = f2fb(1) + temp0fb3/z(4)
|
|
hfb = hfb - zz(11)*gamafb(11)
|
|
gamafb(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp0fb4 = zz(10)*gamafb(10)/(z(1)+z(7))
|
|
f1fb(1) = f1fb(1) + temp0fb4/z(1) + temp0fb3/z(1)
|
|
f2fb(4) = f2fb(4) + temp0fb4/z(7)
|
|
hfb = hfb - zz(10)*gamafb(10)
|
|
gamafb(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp0fb5 = zz(9)*gamafb(9)/(z(3)+z(6))
|
|
f1fb(3) = f1fb(3) + temp0fb5/z(3)
|
|
hfb = hfb - zz(9)*gamafb(9)
|
|
gamafb(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp0fb6 = zz(8)*gamafb(8)/(z(1)+z(6))
|
|
f2fb(3) = f2fb(3) + temp0fb6/z(6) + temp0fb5/z(6)
|
|
hfb = hfb - zz(8)*gamafb(8)
|
|
gamafb(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp0fb7 = zz(7)*gamafb(7)/(z(1)+z(5))
|
|
f1fb(1) = f1fb(1) + temp0fb7/z(1) + temp0fb6/z(1)
|
|
f2fb(2) = f2fb(2) + temp0fb7/z(5)
|
|
hfb = hfb - zz(7)*gamafb(7)
|
|
gamafb(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp0fb8 = zz(6)*gamafb(6)/(z(3)+z(4))
|
|
f2fb(1) = f2fb(1) + temp0fb8/z(4)
|
|
hfb = hfb - zz(6)*gamafb(6)
|
|
gamafb(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp0fb9 = zz(5)*gamafb(5)/(z(3)+z(7))
|
|
f2fb(4) = f2fb(4) + temp0fb9/z(7)
|
|
hfb = hfb - zz(5)*gamafb(5)
|
|
gamafb(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp0fb10 = zz(4)*gamafb(4)/(z(3)+z(5))
|
|
f1fb(3) = f1fb(3) + temp0fb9/z(3) + temp0fb10/z(3) + temp0fb8/z(3)
|
|
f2fb(2) = f2fb(2) + temp0fb10/z(5)
|
|
hfb = hfb - zz(4)*gamafb(4)
|
|
gamafb(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp0fb11 = zz(3)*gamafb(3)/(z(2)+z(7))
|
|
f2fb(4) = f2fb(4) + temp0fb11/z(7)
|
|
hfb = hfb - zz(3)*gamafb(3)
|
|
gamafb(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp0fb12 = zz(2)*gamafb(2)/(z(2)+z(5))
|
|
f2fb(2) = f2fb(2) + temp0fb12/z(5)
|
|
hfb = hfb - zz(2)*gamafb(2)
|
|
gamafb(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp0fb13 = zz(1)*gamafb(1)/(z(2)+z(4))
|
|
f1fb(2) = f1fb(2) + temp0fb12/z(2) + temp0fb13/z(2) + temp0fb11/z(
|
|
+ 2)
|
|
f2fb(1) = f2fb(1) + temp0fb13/z(4)
|
|
hfb = hfb - zz(1)*gamafb(1)
|
|
gamafb(1) = 0.D0
|
|
ionicfb = 0.D0
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0fb(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mplfb = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijfb = (g0(i, j)+zpl*zmi*h)*f2fb(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0fb(i, j) = g0fb(i, j) + yji*f1fb(i) + xij*f2fb(j)
|
|
hfb = hfb + yji*zpl*zmi*f1fb(i) + xij*zpl*zmi*f2fb(j)
|
|
yjifb = (g0(i, j)+zpl*zmi*h)*f1fb(i)
|
|
temp0fb1 = molal(j+3)*yjifb/water
|
|
molalfb(j+3) = molalfb(j+3) + ch*yjifb/water
|
|
chfb = mpl*xijfb + temp0fb1
|
|
waterfb = waterfb - ch*temp0fb1/water
|
|
mplfb = mplfb + ch*xijfb
|
|
ionicfb = ionicfb - (zpl+zmi)**2*0.25d0*chfb/ionic**2
|
|
ENDDO
|
|
CALL POPREAL8(mpl)
|
|
molalfb(i) = molalfb(i) + mplfb/water
|
|
waterfb = waterfb - molal(i)*mplfb/water**2
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp0fb0 = agama*hfb/(sion+1.d0)
|
|
sionfb = (1.D0-sion/(sion+1.d0))*temp0fb0
|
|
IF (.NOT.ionic == 0.0) ionicfb = ionicfb + sionfb/(2.0*SQRT(
|
|
+ ionic))
|
|
g05fb = g0fb(3, 4)
|
|
g0fb(3, 4) = 0.D0
|
|
g09fb = g0fb(3, 3)
|
|
g0fb(3, 3) = 0.D0
|
|
g04fb = g0fb(3, 2)
|
|
g0fb(3, 2) = 0.D0
|
|
g06fb = g0fb(3, 1)
|
|
g0fb(3, 1) = 0.D0
|
|
g03fb = g0fb(2, 4)
|
|
g0fb(2, 4) = 0.D0
|
|
g12fb = g0fb(2, 3)
|
|
g0fb(2, 3) = 0.D0
|
|
g02fb = g0fb(2, 2)
|
|
g0fb(2, 2) = 0.D0
|
|
g01fb = g0fb(2, 1)
|
|
g0fb(2, 1) = 0.D0
|
|
g10fb = g0fb(1, 4)
|
|
g0fb(1, 4) = 0.D0
|
|
g08fb = g0fb(1, 3)
|
|
g0fb(1, 3) = 0.D0
|
|
g07fb = g0fb(1, 2)
|
|
g0fb(1, 2) = 0.D0
|
|
g11fb = g0fb(1, 1)
|
|
CALL KMFUL3_FB(ionic, ionicfb, temp, g01, g01fb, g02, g02fb, g03,
|
|
+ g03fb, g04, g04fb, g05, g05fb, g06, g06fb, g07,
|
|
+ g07fb, g08, g08fb, g09, g09fb, g10, g10fb, g11,
|
|
+ g11fb, g12, g12fb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionic)
|
|
x1fb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1fb = ionicfb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ionicfb = 0.D0
|
|
ELSE
|
|
temp0fb = 0.5d0*x1fb/water
|
|
ionicfb = temp0fb
|
|
waterfb = waterfb - ionic*temp0fb/water
|
|
END IF
|
|
DO i=7,1,-1
|
|
molalfb(i) = molalfb(i) + z(i)**2*ionicfb
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of kmful3 in reverse (adjoint) mode:
|
|
C gradient of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12 ionic
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_FB(ionic, ionicfb, temp, g01, g01fb, g02, g02fb
|
|
+ , g03, g03fb, g04, g04fb, g05, g05fb, g06,
|
|
+ g06fb, g07, g07fb, g08, g08fb, g09, g09fb,
|
|
+ g10, g10fb, g11, g11fb, g12, g12fb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionicfb, sionfb, cf2fb
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01fb, g02fb, g03fb, g04fb, g05fb, g06fb, g07fb,
|
|
+ g08fb, g09fb, g10fb, g11fb, g12fb
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTEGER :: branch
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp0fb
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp0fb0
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01fb = g01fb + g12fb
|
|
g08fb = g08fb + g09fb + g12fb
|
|
g11fb = g11fb - g09fb - g12fb
|
|
g06fb = g06fb + g09fb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2fb = -(z10*g10fb) - z07*g07fb - z05*g05fb - z03*g03fb - z01*
|
|
+ g01fb - z02*g02fb - z04*g04fb - z06*g06fb - z08*g08fb - z11*
|
|
+ g11fb
|
|
g11fb = cf1*g11fb
|
|
g10fb = cf1*g10fb
|
|
g08fb = cf1*g08fb
|
|
g07fb = cf1*g07fb
|
|
g06fb = cf1*g06fb
|
|
g05fb = cf1*g05fb
|
|
g04fb = cf1*g04fb
|
|
g03fb = cf1*g03fb
|
|
g02fb = cf1*g02fb
|
|
g01fb = cf1*g01fb
|
|
temp0fb = (0.125d0-ti*0.005d0)*cf2fb
|
|
temp0fb0 = -(0.41d0*temp0fb/(sion+1.d0))
|
|
ionicfb = ionicfb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0fb
|
|
sionfb = (1.D0-sion/(sion+1.d0))*temp0fb0
|
|
ELSE
|
|
sionfb = 0.D0
|
|
END IF
|
|
CALL MKBI_FB(q11, ionic, ionicfb, sion, sionfb, z11, g11, g11fb)
|
|
CALL MKBI_FB(q10, ionic, ionicfb, sion, sionfb, z10, g10, g10fb)
|
|
CALL MKBI_FB(q8, ionic, ionicfb, sion, sionfb, z08, g08, g08fb)
|
|
CALL MKBI_FB(q7, ionic, ionicfb, sion, sionfb, z07, g07, g07fb)
|
|
CALL MKBI_FB(q6, ionic, ionicfb, sion, sionfb, z06, g06, g06fb)
|
|
CALL MKBI_FB(q5, ionic, ionicfb, sion, sionfb, z05, g05, g05fb)
|
|
CALL MKBI_FB(q4, ionic, ionicfb, sion, sionfb, z04, g04, g04fb)
|
|
CALL MKBI_FB(q3, ionic, ionicfb, sion, sionfb, z03, g03, g03fb)
|
|
CALL MKBI_FB(q2, ionic, ionicfb, sion, sionfb, z02, g02, g02fb)
|
|
CALL MKBI_FB(q1, ionic, ionicfb, sion, sionfb, z01, g01, g01fb)
|
|
IF (.NOT.ionic == 0.0) ionicfb = ionicfb + sionfb/(2.0*SQRT(
|
|
+ ionic))
|
|
END
|
|
|
|
C Differentiation of mkbi in reverse (adjoint) mode:
|
|
C gradient of useful results: sion bi ionic
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_FB(q, ionic, ionicfb, sion, sionfb, zip, bi, bifb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionicfb, sionfb, bifb
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: cfb, xxfb
|
|
INTRINSIC EXP
|
|
REAL*8 :: tempfb
|
|
REAL*8 :: tempfb0
|
|
INTRINSIC LOG10
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic))
|
|
bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b
|
|
C
|
|
xxfb = zip*bifb
|
|
bifb = zip*bifb/(bi*LOG(10.0))
|
|
tempfb = -(0.5107d0*xxfb/(c*sion+1.d0))
|
|
tempfb0 = -(sion*tempfb/(c*sion+1.d0))
|
|
sionfb = sionfb + c*tempfb0 + tempfb
|
|
cfb = sion*tempfb0
|
|
IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q
|
|
+ ))) THEN
|
|
ionicfb = ionicfb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*
|
|
+ ionic**2*cfb
|
|
ELSE
|
|
ionicfb = ionicfb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bifb -
|
|
+ .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cfb
|
|
END IF
|
|
END
|
|
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of funcg5ap in reverse (adjoint) mode:
|
|
C gradient of useful results: aerliq gas
|
|
C with respect to varying inputs: wp aerliq gas
|
|
C RW status of diff variables: wp:out aerliq:in-out gas:in-out
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCG5A
|
|
C *** CASE G5
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCG5AP_GB(x1, wpgb, gasgb, aerliqgb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
LOGICAL :: tst
|
|
REAL*8 :: lamda
|
|
REAL*8 :: x1
|
|
REAL*8 :: wpgb(ncomp)
|
|
REAL*8 :: AERLIQ(NIONS+NGASAQ+2), gas(3)
|
|
REAL*8 :: aerliqgb(NIONS+NGASAQ+2), gasgb(3)
|
|
CHARACTER(LEN=40) :: ERRINF
|
|
INTEGER :: errstki(25)
|
|
CHARACTER(LEN=40) :: errmsgi(25)
|
|
REAL*8 :: feps
|
|
INTEGER :: i
|
|
REAL*8 :: xt
|
|
REAL*8 :: xtd
|
|
REAL*8 :: y1
|
|
REAL*8 :: y1gb
|
|
REAL*8 :: y1d
|
|
REAL*8 :: y1dgb
|
|
REAL*8 :: x2
|
|
REAL*8 :: x2gb
|
|
REAL*8 :: y2
|
|
REAL*8 :: delta
|
|
REAL*8 :: deltagb
|
|
INTEGER :: branch
|
|
INTRINSIC MAX
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs1
|
|
INTEGER :: ii1
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
feps = 1.d-5
|
|
IF (w(2) - 0.5d0*w(1) < zero) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
chi2 = zero
|
|
ELSE
|
|
chi2 = w(2) - 0.5d0*w(1)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (w(3) - 2.d0*chi2 < zero) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
chi4 = zero
|
|
ELSE
|
|
chi4 = w(3) - 2.d0*chi2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
chi5 = w(4)
|
|
chi6 = w(5)
|
|
C
|
|
psi2 = chi2
|
|
C
|
|
C *** NEWTON-RAPHSON DETERMINATION OF ROOT **********************
|
|
C
|
|
xt = x1
|
|
xtd = 1.d0
|
|
CALL PUSHREAL8ARRAY(gamagnrd, npair)
|
|
CALL PUSHREAL8ARRAY(molalgnrd, nions)
|
|
CALL PUSHINTEGER4(iclact)
|
|
CALL PUSHREAL8(water)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
CALL PUSHREAL8ARRAY(molalr, npair)
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
CCCC$AD NOCHECKPOINT
|
|
CALL FUNCG5AB_GNRD(xt, xtd, y1, y1d)
|
|
x2 = xt - y1/(y1d*1.d0)
|
|
CALL PUSHINTEGER4(iclact)
|
|
CALL PUSHREAL8(water)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
CALL PUSHREAL8ARRAY(molalr, npair)
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
CALL FUNCG5AB(x2, y2)
|
|
C WRITE(*,*) 'x2 ',x2,' y2 ',y2
|
|
IF (y2 >= 0.) THEN
|
|
abs1 = y2
|
|
ELSE
|
|
abs1 = -y2
|
|
END IF
|
|
C CALL FUNCG5AB(XT,Y2)
|
|
C
|
|
IF (abs1 > 10.d0*feps) THEN
|
|
DO ii1=1,nions
|
|
molalgb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
gamagb(ii1) = 0.D0
|
|
ENDDO
|
|
watergb = 0.D0
|
|
gnh3gb = 0.D0
|
|
ghno3gb = 0.D0
|
|
ghclgb = 0.D0
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCG5 (',(abs1),')'
|
|
CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE
|
|
! WRITE(*,*) 'W: ',W
|
|
! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP
|
|
! WRITE(*,*) 'FUNCG5AP_GB, after NR - Err 104: ',abs1
|
|
! RETURN
|
|
ELSE
|
|
C
|
|
IF (molal(1) > tiny .AND. molal(5) > tiny) THEN
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
ghclgb = gasgb(3)
|
|
gasgb(3) = 0.D0
|
|
ghno3gb = gasgb(2)
|
|
gasgb(2) = 0.D0
|
|
gnh3gb = gasgb(1)
|
|
gasgb(1) = 0.D0
|
|
aerliqgb(nions+ngasaq+2) = 0.D0
|
|
watergb = 1.0d3*aerliqgb(nions+1)/18.0d0
|
|
aerliqgb(nions+1) = 0.D0
|
|
DO i=ngasaq,1,-1
|
|
aerliqgb(nions+1+i) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,nions
|
|
molalgb(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=nions,1,-1
|
|
molalgb(i) = molalgb(i) + aerliqgb(i)
|
|
aerliqgb(i) = 0.D0
|
|
ENDDO
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
DO ii1=1,npair
|
|
gamagb(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
deltagb = molalgb(6)
|
|
molalgb(6) = 0.D0
|
|
deltagb = deltagb - molalgb(1) - molalgb(5)
|
|
CALL CALCHS4_GB(molal(1), molalgb(1), molal(5), molalgb(5),
|
|
+ zero, delta, deltagb)
|
|
END IF
|
|
END IF
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL POPREAL8ARRAY(molalr, npair)
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPREAL8(water)
|
|
CALL POPINTEGER4(iclact)
|
|
CALL FUNCG5AB_GB(x2, x2gb, y2)
|
|
y1gb = -(x2gb/y1d)
|
|
y1dgb = y1*x2gb/y1d**2
|
|
C WRITE(*,*) 'y1gb ',y1gb,'y1dgb ',y1dgb
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL POPREAL8ARRAY(molalr, npair)
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPREAL8(water)
|
|
CALL POPINTEGER4(iclact)
|
|
CALL POPREAL8ARRAY(molalgnrd, nions)
|
|
CALL POPREAL8ARRAY(gamagnrd, npair)
|
|
CALL FUNCG5AB_GNRD_GB(xt, xtd, y1, y1gb, y1d, y1dgb)
|
|
chi2gb = psi2gb
|
|
wgb(5) = wgb(5) + chi6gb
|
|
wgb(4) = wgb(4) + chi5gb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
wgb(3) = wgb(3) + chi4gb
|
|
chi2gb = chi2gb - 2.d0*chi4gb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
wgb(2) = wgb(2) + chi2gb
|
|
wgb(1) = wgb(1) - 0.5d0*chi2gb
|
|
END IF
|
|
DO ii1=1,5
|
|
wpgb(ii1) = 0.D0
|
|
ENDDO
|
|
wpgb = wgb
|
|
C PAUSE
|
|
END
|
|
|
|
C Differentiation of funcg5ab in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water gnh3 ghno3
|
|
C ghcl
|
|
C with respect to varying inputs: w molal molalr gama water gnh3
|
|
C ghno3 ghcl chi4 chi5 chi6 psi2 x
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCG5A
|
|
C *** CASE G5
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCG5AB_GB(x, xgb, fg5ab)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: psi4gb
|
|
REAL*8 :: psi5gb
|
|
REAL*8 :: psi6gb
|
|
REAL*8 :: a4gb
|
|
REAL*8 :: a5gb
|
|
REAL*8 :: a6gb
|
|
C
|
|
LOGICAL tst
|
|
INTEGER :: so4flg
|
|
REAL*8 :: lamda, fg5ab
|
|
INTEGER :: i
|
|
REAL*8 :: akk
|
|
REAL*8 :: bb
|
|
REAL*8 :: bbgb
|
|
REAL*8 :: cc
|
|
REAL*8 :: ccgb
|
|
REAL*8 :: dd
|
|
REAL*8 :: ddgb
|
|
REAL*8 :: smin
|
|
REAL*8 :: smingb
|
|
REAL*8 :: hi
|
|
REAL*8 :: higb
|
|
REAL*8 :: ohi
|
|
REAL*8 :: tots4
|
|
REAL*8 :: frnh4
|
|
REAL*8 :: frnh4gb
|
|
INTEGER :: j
|
|
INTEGER :: branch
|
|
REAL*8 :: x
|
|
REAL*8 :: xgb
|
|
REAL*8 :: temp3
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp4gb
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp2gb
|
|
REAL*8 :: temp5gb
|
|
REAL*8 :: temp0gb
|
|
REAL*8 :: temp3gb
|
|
REAL*8 :: temp5gb0
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp1gb
|
|
REAL*8 :: temp4
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
psi6 = x
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
C WRITE(*,*) 'NSWEEP ',NSWEEP,'WATER',WATER
|
|
DO i=1,2
|
|
C
|
|
C IF (I > 1) CALL CALCACT3P
|
|
C WRITE(*,*) 'GAMA ', GAMA
|
|
C
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
a5 = xk4*r*temp*(water/gama(10))**2.0
|
|
a6 = xk3*r*temp*(water/gama(11))**2.0
|
|
C WRITE(*,*) 'a6/a5', a6/a5
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
IF (chi5 >= tiny) THEN
|
|
CALL PUSHREAL8(psi5)
|
|
psi5 = psi6*chi5/(a6/a5*(chi6-psi6)+psi6)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(psi5)
|
|
psi5 = tiny
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
CCC IF(CHI4 > TINY) THEN
|
|
IF (w(2) > tiny) THEN
|
|
CALL PUSHREAL8(bb)
|
|
C Accounts for NH3 evaporation
|
|
bb = -(chi4+psi6+psi5+1.d0/a4)
|
|
cc = chi4*(psi5+psi6) - 2.d0*psi2/a4
|
|
IF (bb*bb - 4.d0*cc < zero) THEN
|
|
CALL PUSHREAL8(dd)
|
|
dd = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(dd)
|
|
dd = bb*bb - 4.d0*cc
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
psi4 = 0.5d0*(-bb-SQRT(dd))
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
psi4 = tiny
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8(molal(2))
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
C NAI
|
|
molal(2) = w(1)
|
|
CALL PUSHREAL8(molal(4))
|
|
C MOLAL (3) = 2.0*PSI2 + PSI4 ! NH4I
|
|
C CLI
|
|
molal(4) = psi6
|
|
IF (w(2) - 0.5d0*w(1) > zero) THEN
|
|
CALL PUSHREAL8(molal(3))
|
|
molal(3) = 2.d0*w(2) - w(1) + psi4
|
|
CALL PUSHREAL8(molal(5))
|
|
C SO4I
|
|
molal(5) = w(2)
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHREAL8(molal(3))
|
|
molal(3) = psi4
|
|
CALL PUSHREAL8(molal(5))
|
|
C SO4I
|
|
molal(5) = 0.5d0*w(1)
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = zero
|
|
CALL PUSHREAL8(molal(7))
|
|
C NO3I
|
|
molal(7) = psi5
|
|
CALL PUSHREAL8(smin)
|
|
C
|
|
C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3)
|
|
smin = psi5 + psi6 - psi4
|
|
CALL CALCPH(smin, hi, ohi)
|
|
CALL PUSHREAL8(molal(1))
|
|
molal(1) = hi
|
|
IF (chi4 - psi4 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (chi5 - psi5 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (chi6 - psi6 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C Solid (NH4)2SO4
|
|
C Solid NH4NO3
|
|
C Solid NH4Cl
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C WRITE(*,*) 'MOLAL ',MOLAL
|
|
C NA2SO4
|
|
molalr(2) = 0.5*w(1)
|
|
IF (w(2) - 0.5d0*w(1) > zero) THEN
|
|
C Total SO4
|
|
C (NH4)2SO4
|
|
molalr(4) = w(2) - 0.5d0*w(1)
|
|
IF (psi4 < zero) THEN
|
|
frnh4 = zero
|
|
CALL PUSHCONTROL2B(1)
|
|
ELSE
|
|
frnh4 = psi4
|
|
CALL PUSHCONTROL2B(0)
|
|
END IF
|
|
ELSE
|
|
C Total SO4
|
|
C (NH4)2SO4
|
|
molalr(4) = zero
|
|
IF (2.d0*w(2) - w(1) + psi4 < zero) THEN
|
|
frnh4 = zero
|
|
CALL PUSHCONTROL2B(3)
|
|
ELSE
|
|
frnh4 = 2.d0*w(2) - w(1) + psi4
|
|
CALL PUSHCONTROL2B(2)
|
|
END IF
|
|
END IF
|
|
IF (psi5 < frnh4) THEN
|
|
molalr(5) = psi5
|
|
IF (frnh4 - psi5 < zero) THEN
|
|
frnh4 = zero
|
|
CALL PUSHCONTROL2B(2)
|
|
ELSE
|
|
frnh4 = frnh4 - psi5
|
|
CALL PUSHCONTROL2B(1)
|
|
END IF
|
|
ELSE
|
|
molalr(5) = frnh4
|
|
frnh4 = zero
|
|
CALL PUSHCONTROL2B(0)
|
|
END IF
|
|
IF (psi6 > frnh4) THEN
|
|
molalr(6) = frnh4
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
molalr(6) = psi6
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8(water)
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
DO j=1,npair
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C WRITE(*,*) 'After CALCMR_AB: WATER ',WATER
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3P()
|
|
ENDDO
|
|
DO ii1=1,ncomp
|
|
wgb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
molalrgb(ii1) = 0.D0
|
|
ENDDO
|
|
chi4gb = 0.D0
|
|
chi5gb = 0.D0
|
|
chi6gb = 0.D0
|
|
psi2gb = 0.D0
|
|
psi6gb = 0.D0
|
|
DO i=2,1,-1
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3P_GB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) watergb = 0.D0
|
|
DO j=npair,1,-1
|
|
molalrgb(j) = molalrgb(j) + watergb/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(water)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
frnh4gb = molalrgb(6)
|
|
molalrgb(6) = 0.D0
|
|
ELSE
|
|
psi6gb = psi6gb + molalrgb(6)
|
|
molalrgb(6) = 0.D0
|
|
frnh4gb = 0.D0
|
|
END IF
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch == 0) THEN
|
|
frnh4gb = molalrgb(5)
|
|
molalrgb(5) = 0.D0
|
|
psi5gb = 0.D0
|
|
ELSE
|
|
IF (branch == 1) THEN
|
|
psi5gb = -frnh4gb
|
|
ELSE
|
|
psi5gb = 0.D0
|
|
frnh4gb = 0.D0
|
|
END IF
|
|
psi5gb = psi5gb + molalrgb(5)
|
|
molalrgb(5) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch < 2) THEN
|
|
IF (branch == 0) THEN
|
|
psi4gb = frnh4gb
|
|
ELSE
|
|
psi4gb = 0.D0
|
|
END IF
|
|
wgb(2) = wgb(2) + molalrgb(4)
|
|
wgb(1) = wgb(1) - 0.5d0*molalrgb(4)
|
|
molalrgb(4) = 0.D0
|
|
ELSE
|
|
IF (branch == 2) THEN
|
|
wgb(2) = wgb(2) + 2.d0*frnh4gb
|
|
wgb(1) = wgb(1) - frnh4gb
|
|
psi4gb = frnh4gb
|
|
ELSE
|
|
psi4gb = 0.D0
|
|
END IF
|
|
molalrgb(4) = 0.D0
|
|
END IF
|
|
wgb(1) = wgb(1) + 0.5*molalrgb(2)
|
|
molalrgb(2) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
chi6gb = chi6gb + ghclgb
|
|
psi6gb = psi6gb - ghclgb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
chi5gb = chi5gb + ghno3gb
|
|
psi5gb = psi5gb - ghno3gb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
chi4gb = chi4gb + gnh3gb
|
|
psi4gb = psi4gb - gnh3gb
|
|
END IF
|
|
CALL POPREAL8(molal(1))
|
|
higb = molalgb(1)
|
|
molalgb(1) = 0.D0
|
|
CALL CALCPH_GB(smin, smingb, hi, higb, ohi)
|
|
CALL POPREAL8(smin)
|
|
psi5gb = psi5gb + molalgb(7) + smingb
|
|
psi6gb = psi6gb + smingb
|
|
psi4gb = psi4gb - smingb
|
|
CALL POPREAL8(molal(7))
|
|
molalgb(7) = 0.D0
|
|
CALL POPREAL8(molal(6))
|
|
molalgb(6) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(molal(5))
|
|
wgb(1) = wgb(1) + 0.5d0*molalgb(5)
|
|
molalgb(5) = 0.D0
|
|
CALL POPREAL8(molal(3))
|
|
psi4gb = psi4gb + molalgb(3)
|
|
molalgb(3) = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(molal(5))
|
|
wgb(2) = wgb(2) + molalgb(5)
|
|
molalgb(5) = 0.D0
|
|
CALL POPREAL8(molal(3))
|
|
wgb(2) = wgb(2) + 2.d0*molalgb(3)
|
|
wgb(1) = wgb(1) - molalgb(3)
|
|
psi4gb = psi4gb + molalgb(3)
|
|
molalgb(3) = 0.D0
|
|
END IF
|
|
CALL POPREAL8(molal(4))
|
|
psi6gb = psi6gb + molalgb(4)
|
|
molalgb(4) = 0.D0
|
|
CALL POPREAL8(molal(2))
|
|
wgb(1) = wgb(1) + molalgb(2)
|
|
molalgb(2) = 0.D0
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
bbgb = -(0.5d0*psi4gb)
|
|
IF (dd == 0.0) THEN
|
|
ddgb = 0.0
|
|
ELSE
|
|
ddgb = -(0.5d0*psi4gb/(2.0*SQRT(dd)))
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(dd)
|
|
ccgb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(dd)
|
|
bbgb = bbgb + 2*bb*ddgb
|
|
ccgb = -(4.d0*ddgb)
|
|
END IF
|
|
temp5gb0 = -(2.d0*ccgb/a4)
|
|
chi4gb = chi4gb + (psi5+psi6)*ccgb - bbgb
|
|
psi5gb = psi5gb + chi4*ccgb - bbgb
|
|
psi6gb = psi6gb + chi4*ccgb - bbgb
|
|
psi2gb = psi2gb + temp5gb0
|
|
a4gb = bbgb/a4**2 - psi2*temp5gb0/a4
|
|
CALL POPREAL8(bb)
|
|
ELSE
|
|
a4gb = 0.D0
|
|
END IF
|
|
a5 = xk4*r*temp*(water/gama(10))**2.0
|
|
a6 = xk3*r*temp*(water/gama(11))**2.0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(psi5)
|
|
temp3 = a6/a5
|
|
temp4 = (chi6-psi6)*temp3 + psi6
|
|
temp5gb = psi5gb/temp4
|
|
temp4gb = -(psi6*chi5*temp5gb/temp4)
|
|
temp3gb = (chi6-psi6)*temp4gb/a5
|
|
psi6gb = psi6gb + (1.D0-temp3)*temp4gb + chi5*temp5gb
|
|
chi5gb = chi5gb + psi6*temp5gb
|
|
chi6gb = chi6gb + temp3*temp4gb
|
|
a6gb = temp3gb
|
|
a5gb = -(temp3*temp3gb)
|
|
ELSE
|
|
CALL POPREAL8(psi5)
|
|
a5gb = 0.D0
|
|
a6gb = 0.D0
|
|
END IF
|
|
temp0 = gama(10)/gama(5)
|
|
temp0gb = 2.0*temp0*xk2*r*temp*a4gb/(xkw*gama(5))
|
|
temp1 = water/gama(10)
|
|
temp1gb = 2.0*temp1*xk4*r*temp*a5gb/gama(10)
|
|
temp2 = water/gama(11)
|
|
temp2gb = 2.0*temp2*xk3*r*temp*a6gb/gama(11)
|
|
watergb = watergb + temp1gb + temp2gb
|
|
gamagb(11) = gamagb(11) - temp2*temp2gb
|
|
gamagb(10) = gamagb(10) + temp0gb - temp1*temp1gb
|
|
gamagb(5) = gamagb(5) - temp0*temp0gb
|
|
gnh3gb = 0.D0
|
|
ghno3gb = 0.D0
|
|
ghclgb = 0.D0
|
|
ENDDO
|
|
xgb = psi6gb
|
|
END
|
|
|
|
C
|
|
C Differentiation of calchs4 in reverse (adjoint) mode:
|
|
C gradient of useful results: water hi so4i delta
|
|
C with respect to varying inputs: gama water hi so4i
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCHS4
|
|
C *** THIS SUBROUTINE CALCULATES THE HSO4 GENERATED FROM (H,SO4).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCHS4_GB(hi, higb, so4i, so4igb, hso4i, delta,
|
|
+ deltagb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: a8gb
|
|
REAL*8 :: hi, so4i, hso4i, delta, bb, cc, dd, sqdd, delta1
|
|
+ , delta2
|
|
REAL*8 :: higb, so4igb, deltagb, bbgb, ccgb, ddgb, sqddgb,
|
|
+ delta1gb, delta2gb
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0gb
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp1gb
|
|
C
|
|
C *** IF TOO LITTLE WATER, DONT SOLVE
|
|
C
|
|
IF (water <= 1d1*tiny) THEN
|
|
DO ii1=1,npair
|
|
gamagb(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
C
|
|
C *** CALCULATE HSO4 SPECIATION *****************************************
|
|
C
|
|
a8 = xk1*water/gama(7)*(gama(8)/gama(7))**2.
|
|
C
|
|
bb = -(hi+so4i+a8)
|
|
cc = hi*so4i - hso4i*a8
|
|
dd = bb*bb - 4.d0*cc
|
|
C
|
|
IF (dd >= zero) THEN
|
|
IF (hso4i <= tiny) THEN
|
|
delta2gb = deltagb
|
|
delta1gb = 0.D0
|
|
ELSE IF (hi*so4i >= a8*hso4i) THEN
|
|
delta2gb = deltagb
|
|
delta1gb = 0.D0
|
|
ELSE
|
|
IF (hi*so4i < a8*hso4i) THEN
|
|
delta1gb = deltagb
|
|
ELSE
|
|
delta1gb = 0.D0
|
|
END IF
|
|
delta2gb = 0.D0
|
|
END IF
|
|
bbgb = -(0.5*delta1gb) - 0.5*delta2gb
|
|
sqddgb = 0.5*delta1gb - 0.5*delta2gb
|
|
IF (dd == 0.0) THEN
|
|
ddgb = 0.0
|
|
ELSE
|
|
ddgb = sqddgb/(2.0*SQRT(dd))
|
|
END IF
|
|
ELSE
|
|
ddgb = 0.D0
|
|
bbgb = 0.D0
|
|
END IF
|
|
bbgb = bbgb + 2*bb*ddgb
|
|
ccgb = -(4.d0*ddgb)
|
|
higb = higb + so4i*ccgb - bbgb
|
|
so4igb = so4igb + hi*ccgb - bbgb
|
|
a8gb = -bbgb - hso4i*ccgb
|
|
DO ii1=1,npair
|
|
gamagb(ii1) = 0.D0
|
|
ENDDO
|
|
temp0 = water/gama(7)
|
|
temp1 = gama(8)/gama(7)
|
|
temp1gb = 2.*temp1*temp0*xk1*a8gb/gama(7)
|
|
temp0gb = temp1**2.*xk1*a8gb/gama(7)
|
|
gamagb(8) = gamagb(8) + temp1gb
|
|
gamagb(7) = gamagb(7) - temp0*temp0gb - temp1*temp1gb
|
|
watergb = watergb + temp0gb
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of calcph in reverse (adjoint) mode:
|
|
C gradient of useful results: hi
|
|
C with respect to varying inputs: water gg
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCPH
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCPH_GB(gg, gggb, hi, higb, ohi)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: cn, gg, hi, ohi, bb, cc, dd
|
|
REAL*8 :: cngb, gggb, higb, ohigb, bbgb, ccgb, ddgb
|
|
REAL*8 :: akw
|
|
REAL*8 :: akwgb
|
|
INTEGER :: branch
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x2gb
|
|
INTRINSIC SQRT
|
|
REAL*8 :: x1gb
|
|
C
|
|
akw = xkw*rh*water*water
|
|
cn = SQRT(akw)
|
|
C
|
|
C *** GG = (negative charge) - (positive charge)
|
|
C
|
|
IF (gg > tiny) THEN
|
|
C H+ in excess
|
|
bb = -gg
|
|
cc = -akw
|
|
dd = bb*bb - 4.d0*cc
|
|
x1 = 0.5d0*(-bb+SQRT(dd))
|
|
IF (x1 < cn) THEN
|
|
cngb = higb
|
|
x1gb = 0.D0
|
|
ELSE
|
|
x1gb = higb
|
|
cngb = 0.D0
|
|
END IF
|
|
IF (dd == 0.0) THEN
|
|
ddgb = 0.0
|
|
ELSE
|
|
ddgb = 0.5d0*x1gb/(2.0*SQRT(dd))
|
|
END IF
|
|
bbgb = 2*bb*ddgb - 0.5d0*x1gb
|
|
ccgb = -(4.d0*ddgb)
|
|
akwgb = -ccgb
|
|
gggb = -bbgb
|
|
ELSE
|
|
C OH- in excess
|
|
bb = gg
|
|
cc = -akw
|
|
dd = bb*bb - 4.d0*cc
|
|
x2 = 0.5d0*(-bb+SQRT(dd))
|
|
IF (x2 < cn) THEN
|
|
ohi = cn
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
ohi = x2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
akwgb = higb/ohi
|
|
ohigb = -(akw*higb/ohi**2)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cngb = ohigb
|
|
x2gb = 0.D0
|
|
ELSE
|
|
x2gb = ohigb
|
|
cngb = 0.D0
|
|
END IF
|
|
IF (dd == 0.0) THEN
|
|
ddgb = 0.0
|
|
ELSE
|
|
ddgb = 0.5d0*x2gb/(2.0*SQRT(dd))
|
|
END IF
|
|
bbgb = 2*bb*ddgb - 0.5d0*x2gb
|
|
ccgb = -(4.d0*ddgb)
|
|
akwgb = akwgb - ccgb
|
|
gggb = bbgb
|
|
END IF
|
|
IF (.NOT.akw == 0.0) akwgb = akwgb + cngb/(2.0*SQRT(akw))
|
|
watergb = xkw*rh*2*water*akwgb
|
|
END
|
|
|
|
C Differentiation of calcact3p in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3P_GB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0gb(6, 4), siongb, hgb, chgb, f1gb(3), f2gb(4)
|
|
REAL*8 :: mpl, xij, yji
|
|
REAL*8 :: mplgb, xijgb, yjigb, ionicgb
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01gb
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02gb
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03gb
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04gb
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05gb
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06gb
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07gb
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08gb
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09gb
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10gb
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11gb
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12gb
|
|
INTEGER :: j
|
|
INTEGER :: branch
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp0gb9
|
|
REAL*8 :: temp0gb8
|
|
REAL*8 :: temp0gb7
|
|
REAL*8 :: temp0gb6
|
|
REAL*8 :: x2
|
|
REAL*8 :: temp0gb5
|
|
REAL*8 :: x1
|
|
REAL*8 :: temp0gb4
|
|
REAL*8 :: temp0gb3
|
|
REAL*8 :: temp0gb2
|
|
REAL*8 :: temp0gb1
|
|
REAL*8 :: temp0gb0
|
|
REAL*8 :: x2gb
|
|
REAL*8 :: temp0gb13
|
|
REAL*8 :: temp0gb12
|
|
REAL*8 :: temp0gb11
|
|
REAL*8 :: temp0gb10
|
|
REAL*8 :: temp0gb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: x1gb
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
DO i=1,7
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08,
|
|
+ g09, g10, g11, g12)
|
|
C
|
|
g0(1, 1) = g11
|
|
g0(1, 2) = g07
|
|
g0(1, 3) = g08
|
|
g0(1, 4) = g10
|
|
g0(2, 1) = g01
|
|
g0(2, 2) = g02
|
|
g0(2, 3) = g12
|
|
g0(2, 4) = g03
|
|
g0(3, 1) = g06
|
|
g0(3, 2) = g04
|
|
g0(3, 3) = g09
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
sion = SQRT(ionic)
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
yji = ch*molal(j+3)/water
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gama(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gama(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gama(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gama(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gama(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gama(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gama(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gama(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gama(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gama(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gama(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gama(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gama(13))
|
|
C LC ; SCAPE
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
ELSE
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
gamagb(i) = 10.d0**gama(i)*LOG(10.d0)*gamagb(i)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
gamagb(i) = 0.D0
|
|
x2gb = 0.D0
|
|
ELSE
|
|
x2gb = gamagb(i)
|
|
gamagb(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) gamagb(i) = gamagb(i) + x2gb
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamagb(4) = gamagb(4) + 0.2d0*3.d0*gamagb(13)
|
|
gamagb(9) = gamagb(9) + 0.2d0*2.d0*gamagb(13)
|
|
gamagb(13) = 0.D0
|
|
DO ii1=1,3
|
|
f1gb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2gb(ii1) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp0gb2 = zz(12)*gamagb(12)/(z(2)+z(6))
|
|
f1gb(2) = f1gb(2) + temp0gb2/z(2)
|
|
f2gb(3) = f2gb(3) + temp0gb2/z(6)
|
|
hgb = -(zz(12)*gamagb(12))
|
|
gamagb(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp0gb3 = zz(11)*gamagb(11)/(z(1)+z(4))
|
|
f2gb(1) = f2gb(1) + temp0gb3/z(4)
|
|
hgb = hgb - zz(11)*gamagb(11)
|
|
gamagb(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp0gb4 = zz(10)*gamagb(10)/(z(1)+z(7))
|
|
f1gb(1) = f1gb(1) + temp0gb4/z(1) + temp0gb3/z(1)
|
|
f2gb(4) = f2gb(4) + temp0gb4/z(7)
|
|
hgb = hgb - zz(10)*gamagb(10)
|
|
gamagb(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp0gb5 = zz(9)*gamagb(9)/(z(3)+z(6))
|
|
f1gb(3) = f1gb(3) + temp0gb5/z(3)
|
|
hgb = hgb - zz(9)*gamagb(9)
|
|
gamagb(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp0gb6 = zz(8)*gamagb(8)/(z(1)+z(6))
|
|
f2gb(3) = f2gb(3) + temp0gb6/z(6) + temp0gb5/z(6)
|
|
hgb = hgb - zz(8)*gamagb(8)
|
|
gamagb(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp0gb7 = zz(7)*gamagb(7)/(z(1)+z(5))
|
|
f1gb(1) = f1gb(1) + temp0gb7/z(1) + temp0gb6/z(1)
|
|
f2gb(2) = f2gb(2) + temp0gb7/z(5)
|
|
hgb = hgb - zz(7)*gamagb(7)
|
|
gamagb(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp0gb8 = zz(6)*gamagb(6)/(z(3)+z(4))
|
|
f2gb(1) = f2gb(1) + temp0gb8/z(4)
|
|
hgb = hgb - zz(6)*gamagb(6)
|
|
gamagb(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp0gb9 = zz(5)*gamagb(5)/(z(3)+z(7))
|
|
f2gb(4) = f2gb(4) + temp0gb9/z(7)
|
|
hgb = hgb - zz(5)*gamagb(5)
|
|
gamagb(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp0gb10 = zz(4)*gamagb(4)/(z(3)+z(5))
|
|
f1gb(3) = f1gb(3) + temp0gb9/z(3) + temp0gb10/z(3) + temp0gb8/z(3)
|
|
f2gb(2) = f2gb(2) + temp0gb10/z(5)
|
|
hgb = hgb - zz(4)*gamagb(4)
|
|
gamagb(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp0gb11 = zz(3)*gamagb(3)/(z(2)+z(7))
|
|
f2gb(4) = f2gb(4) + temp0gb11/z(7)
|
|
hgb = hgb - zz(3)*gamagb(3)
|
|
gamagb(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp0gb12 = zz(2)*gamagb(2)/(z(2)+z(5))
|
|
f2gb(2) = f2gb(2) + temp0gb12/z(5)
|
|
hgb = hgb - zz(2)*gamagb(2)
|
|
gamagb(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp0gb13 = zz(1)*gamagb(1)/(z(2)+z(4))
|
|
f1gb(2) = f1gb(2) + temp0gb12/z(2) + temp0gb13/z(2) + temp0gb11/z(
|
|
+ 2)
|
|
f2gb(1) = f2gb(1) + temp0gb13/z(4)
|
|
hgb = hgb - zz(1)*gamagb(1)
|
|
gamagb(1) = 0.D0
|
|
ionicgb = 0.D0
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0gb(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mplgb = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijgb = (g0(i, j)+zpl*zmi*h)*f2gb(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0gb(i, j) = g0gb(i, j) + yji*f1gb(i) + xij*f2gb(j)
|
|
hgb = hgb + yji*zpl*zmi*f1gb(i) + xij*zpl*zmi*f2gb(j)
|
|
yjigb = (g0(i, j)+zpl*zmi*h)*f1gb(i)
|
|
temp0gb1 = molal(j+3)*yjigb/water
|
|
molalgb(j+3) = molalgb(j+3) + ch*yjigb/water
|
|
chgb = mpl*xijgb + temp0gb1
|
|
watergb = watergb - ch*temp0gb1/water
|
|
mplgb = mplgb + ch*xijgb
|
|
ionicgb = ionicgb - (zpl+zmi)**2*0.25d0*chgb/ionic**2
|
|
ENDDO
|
|
CALL POPREAL8(mpl)
|
|
molalgb(i) = molalgb(i) + mplgb/water
|
|
watergb = watergb - molal(i)*mplgb/water**2
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp0gb0 = agama*hgb/(sion+1.d0)
|
|
siongb = (1.D0-sion/(sion+1.d0))*temp0gb0
|
|
IF (.NOT.ionic == 0.0) ionicgb = ionicgb + siongb/(2.0*SQRT(
|
|
+ ionic))
|
|
g05gb = g0gb(3, 4)
|
|
g0gb(3, 4) = 0.D0
|
|
g09gb = g0gb(3, 3)
|
|
g0gb(3, 3) = 0.D0
|
|
g04gb = g0gb(3, 2)
|
|
g0gb(3, 2) = 0.D0
|
|
g06gb = g0gb(3, 1)
|
|
g0gb(3, 1) = 0.D0
|
|
g03gb = g0gb(2, 4)
|
|
g0gb(2, 4) = 0.D0
|
|
g12gb = g0gb(2, 3)
|
|
g0gb(2, 3) = 0.D0
|
|
g02gb = g0gb(2, 2)
|
|
g0gb(2, 2) = 0.D0
|
|
g01gb = g0gb(2, 1)
|
|
g0gb(2, 1) = 0.D0
|
|
g10gb = g0gb(1, 4)
|
|
g0gb(1, 4) = 0.D0
|
|
g08gb = g0gb(1, 3)
|
|
g0gb(1, 3) = 0.D0
|
|
g07gb = g0gb(1, 2)
|
|
g0gb(1, 2) = 0.D0
|
|
g11gb = g0gb(1, 1)
|
|
CALL KMFUL3_GB(ionic, ionicgb, temp, g01, g01gb, g02, g02gb, g03,
|
|
+ g03gb, g04, g04gb, g05, g05gb, g06, g06gb, g07,
|
|
+ g07gb, g08, g08gb, g09, g09gb, g10, g10gb, g11,
|
|
+ g11gb, g12, g12gb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionic)
|
|
x1gb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1gb = ionicgb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ionicgb = 0.D0
|
|
ELSE
|
|
temp0gb = 0.5d0*x1gb/water
|
|
ionicgb = temp0gb
|
|
watergb = watergb - ionic*temp0gb/water
|
|
END IF
|
|
DO i=7,1,-1
|
|
molalgb(i) = molalgb(i) + z(i)**2*ionicgb
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of kmful3 in reverse (adjoint) mode:
|
|
C gradient of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12 ionic
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_GB(ionic, ionicgb, temp, g01, g01gb, g02, g02gb
|
|
+ , g03, g03gb, g04, g04gb, g05, g05gb, g06,
|
|
+ g06gb, g07, g07gb, g08, g08gb, g09, g09gb,
|
|
+ g10, g10gb, g11, g11gb, g12, g12gb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionicgb, siongb, cf2gb
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01gb, g02gb, g03gb, g04gb, g05gb, g06gb, g07gb,
|
|
+ g08gb, g09gb, g10gb, g11gb, g12gb
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTEGER :: branch
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp0gb0
|
|
REAL*8 :: temp0gb
|
|
REAL*8 :: abs1
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01gb = g01gb + g12gb
|
|
g08gb = g08gb + g09gb + g12gb
|
|
g11gb = g11gb - g09gb - g12gb
|
|
g06gb = g06gb + g09gb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2gb = -(z10*g10gb) - z07*g07gb - z05*g05gb - z03*g03gb - z01*
|
|
+ g01gb - z02*g02gb - z04*g04gb - z06*g06gb - z08*g08gb - z11*
|
|
+ g11gb
|
|
g11gb = cf1*g11gb
|
|
g10gb = cf1*g10gb
|
|
g08gb = cf1*g08gb
|
|
g07gb = cf1*g07gb
|
|
g06gb = cf1*g06gb
|
|
g05gb = cf1*g05gb
|
|
g04gb = cf1*g04gb
|
|
g03gb = cf1*g03gb
|
|
g02gb = cf1*g02gb
|
|
g01gb = cf1*g01gb
|
|
temp0gb = (0.125d0-ti*0.005d0)*cf2gb
|
|
temp0gb0 = -(0.41d0*temp0gb/(sion+1.d0))
|
|
ionicgb = ionicgb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0gb
|
|
siongb = (1.D0-sion/(sion+1.d0))*temp0gb0
|
|
ELSE
|
|
siongb = 0.D0
|
|
END IF
|
|
CALL MKBI_GB(q11, ionic, ionicgb, sion, siongb, z11, g11, g11gb)
|
|
CALL MKBI_GB(q10, ionic, ionicgb, sion, siongb, z10, g10, g10gb)
|
|
CALL MKBI_GB(q8, ionic, ionicgb, sion, siongb, z08, g08, g08gb)
|
|
CALL MKBI_GB(q7, ionic, ionicgb, sion, siongb, z07, g07, g07gb)
|
|
CALL MKBI_GB(q6, ionic, ionicgb, sion, siongb, z06, g06, g06gb)
|
|
CALL MKBI_GB(q5, ionic, ionicgb, sion, siongb, z05, g05, g05gb)
|
|
CALL MKBI_GB(q4, ionic, ionicgb, sion, siongb, z04, g04, g04gb)
|
|
CALL MKBI_GB(q3, ionic, ionicgb, sion, siongb, z03, g03, g03gb)
|
|
CALL MKBI_GB(q2, ionic, ionicgb, sion, siongb, z02, g02, g02gb)
|
|
CALL MKBI_GB(q1, ionic, ionicgb, sion, siongb, z01, g01, g01gb)
|
|
IF (.NOT.ionic == 0.0) ionicgb = ionicgb + siongb/(2.0*SQRT(
|
|
+ ionic))
|
|
END
|
|
|
|
C Differentiation of mkbi in reverse (adjoint) mode:
|
|
C gradient of useful results: sion bi ionic
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_GB(q, ionic, ionicgb, sion, siongb, zip, bi, bigb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionicgb, siongb, bigb
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: cgb, xxgb
|
|
REAL*8 :: tempgb0
|
|
INTRINSIC EXP
|
|
REAL*8 :: tempgb
|
|
INTRINSIC LOG10
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic))
|
|
bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b
|
|
C
|
|
xxgb = zip*bigb
|
|
bigb = zip*bigb/(bi*LOG(10.0))
|
|
tempgb = -(0.5107d0*xxgb/(c*sion+1.d0))
|
|
tempgb0 = -(sion*tempgb/(c*sion+1.d0))
|
|
siongb = siongb + c*tempgb0 + tempgb
|
|
cgb = sion*tempgb0
|
|
IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q
|
|
+ ))) THEN
|
|
ionicgb = ionicgb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*
|
|
+ ionic**2*cgb
|
|
ELSE
|
|
ionicgb = ionicgb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bigb -
|
|
+ .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cgb
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of funcg5ab_gnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: w molal molalr gama water gnh3
|
|
C ghno3 ghcl chi4 chi5 chi6 psi2 fg5abgnrd fg5ab
|
|
C with respect to varying inputs: w chi4 chi5 chi6 psi2
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of funcg5ab in forward (tangent) mode:
|
|
C variations of useful results: fg5ab
|
|
C with respect to varying inputs: x
|
|
C RW status of diff variables: x:in fg5ab:out
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCG5A
|
|
C *** CASE G5
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCG5AB_GNRD_GB(x, xgnrd, fg5ab, fg5abgb, fg5abgnrd,
|
|
+ fg5abgnrdgb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: psi4gnrd
|
|
REAL*8 :: psi4gnrdgb
|
|
REAL*8 :: psi5gb
|
|
REAL*8 :: psi5gnrd
|
|
REAL*8 :: psi5gnrdgb
|
|
REAL*8 :: psi6gnrd
|
|
REAL*8 :: a4gb
|
|
REAL*8 :: a4gnrd
|
|
REAL*8 :: a4gnrdgb
|
|
REAL*8 :: a5gb
|
|
REAL*8 :: a5gnrd
|
|
REAL*8 :: a5gnrdgb
|
|
REAL*8 :: a6gb
|
|
REAL*8 :: a6gnrd
|
|
REAL*8 :: a6gnrdgb
|
|
C
|
|
REAL*8 :: molalrgnrd(npair), molalrgnrdgb(npair)
|
|
LOGICAL tst
|
|
INTEGER :: so4flg
|
|
REAL*8 :: lamda, fg5ab
|
|
REAL*8 :: fg5abgb
|
|
REAL*8 :: fg5abgnrd
|
|
REAL*8 :: fg5abgnrdgb
|
|
INTEGER :: i
|
|
REAL*8 :: akk
|
|
REAL*8 :: bb
|
|
REAL*8 :: bbgb
|
|
REAL*8 :: bbgnrd
|
|
REAL*8 :: bbgnrdgb
|
|
REAL*8 :: cc
|
|
REAL*8 :: ccgb
|
|
REAL*8 :: ccgnrd
|
|
REAL*8 :: ccgnrdgb
|
|
REAL*8 :: dd
|
|
REAL*8 :: ddgb
|
|
REAL*8 :: ddgnrd
|
|
REAL*8 :: ddgnrdgb
|
|
REAL*8 :: smin
|
|
REAL*8 :: smingb
|
|
REAL*8 :: smingnrd
|
|
REAL*8 :: smingnrdgb
|
|
REAL*8 :: hi
|
|
REAL*8 :: higb
|
|
REAL*8 :: hignrd
|
|
REAL*8 :: hignrdgb
|
|
REAL*8 :: ohi
|
|
REAL*8 :: tots4
|
|
REAL*8 :: frnh4
|
|
REAL*8 :: frnh4gb
|
|
REAL*8 :: frnh4gnrd
|
|
REAL*8 :: frnh4gnrdgb
|
|
INTEGER :: j
|
|
REAL*8 :: result1
|
|
REAL*8 :: result1gb
|
|
REAL*8 :: result1gnrd
|
|
REAL*8 :: result1gnrdgb
|
|
REAL*8 :: x
|
|
REAL*8 :: xgnrd
|
|
INTRINSIC MAX
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
INTEGER :: branch
|
|
REAL*8 :: temp3
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp20gb
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp9gb
|
|
REAL*8 :: temp18gb
|
|
REAL*8 :: temp22
|
|
REAL*8 :: temp4gb
|
|
REAL*8 :: temp21
|
|
REAL*8 :: temp20
|
|
REAL*8 :: temp13gb
|
|
REAL*8 :: temp23gb1
|
|
REAL*8 :: temp23gb0
|
|
REAL*8 :: temp9gb0
|
|
REAL*8 :: temp23gb
|
|
REAL*8 :: temp7gb
|
|
REAL*8 :: temp16gb
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp2gb
|
|
REAL*8 :: temp19
|
|
REAL*8 :: temp11gb
|
|
REAL*8 :: temp18
|
|
REAL*8 :: temp17
|
|
REAL*8 :: temp16
|
|
REAL*8 :: temp15
|
|
REAL*8 :: temp14
|
|
REAL*8 :: temp13
|
|
REAL*8 :: temp12
|
|
REAL*8 :: temp11
|
|
REAL*8 :: temp10
|
|
REAL*8 :: temp21gb
|
|
REAL*8 :: temp1gb0
|
|
REAL*8 :: temp19gb
|
|
REAL*8 :: temp5gb
|
|
REAL*8 :: temp14gb
|
|
REAL*8 :: temp15gb0
|
|
REAL*8 :: temp0gb
|
|
REAL*8 :: temp3gb1
|
|
REAL*8 :: temp3gb0
|
|
REAL*8 :: temp8gb
|
|
REAL*8 :: temp17gb3
|
|
REAL*8 :: temp17gb
|
|
REAL*8 :: temp17gb2
|
|
REAL*8 :: temp17gb1
|
|
REAL*8 :: temp17gb0
|
|
REAL*8 :: temp3gb
|
|
INTEGER :: ii10
|
|
REAL*8 :: temp5gb1
|
|
REAL*8 :: temp5gb0
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp6gb
|
|
REAL*8 :: temp15gb
|
|
REAL*8 :: temp1gb
|
|
REAL*8 :: temp10gb
|
|
REAL*8 :: temp9
|
|
REAL*8 :: temp8
|
|
REAL*8 :: temp7
|
|
REAL*8 :: temp6
|
|
REAL*8 :: temp5
|
|
REAL*8 :: temp4
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
psi6gnrd = xgnrd
|
|
psi6 = x
|
|
DO ii1=1,nions
|
|
molalgnrd(ii1) = 0.d0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
molalrgnrd(ii1) = 0.d0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
gamagnrd(ii1) = 0.d0
|
|
ENDDO
|
|
watergnrd = 0.d0
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
C WRITE(*,*) 'NSWEEP ',NSWEEP,'WATER',WATER
|
|
DO i=1,2
|
|
CALL PUSHREAL8(a4gnrd)
|
|
C
|
|
C IF (I > 1) CALL CALCACT3P
|
|
C WRITE(*,*) 'GAMA ', GAMA
|
|
C
|
|
a4gnrd = xk2*r*temp*2.0*gama(10)*(gamagnrd(10)*gama(5)-gama(10)*
|
|
+ gamagnrd(5))/(xkw*gama(5)**3)
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
CALL PUSHREAL8(a5gnrd)
|
|
a5gnrd = xk4*r*temp*2.0*water*(watergnrd*gama(10)-water*gamagnrd
|
|
+ (10))/gama(10)**3
|
|
a5 = xk4*r*temp*(water/gama(10))**2.0
|
|
CALL PUSHREAL8(a6gnrd)
|
|
a6gnrd = xk3*r*temp*2.0*water*(watergnrd*gama(11)-water*gamagnrd
|
|
+ (11))/gama(11)**3
|
|
CALL PUSHREAL8(a6)
|
|
a6 = xk3*r*temp*(water/gama(11))**2.0
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
IF (chi5 >= tiny) THEN
|
|
CALL PUSHREAL8(psi5gnrd)
|
|
psi5gnrd = (chi5*psi6gnrd*(a6/a5*(chi6-psi6)+psi6)-psi6*chi5*(
|
|
+ (a6gnrd*a5-a6*a5gnrd)*(chi6-psi6)/a5**2-a6*psi6gnrd/a5+
|
|
+ psi6gnrd))/(a6/a5*(chi6-psi6)+psi6)**2
|
|
CALL PUSHREAL8(psi5)
|
|
psi5 = psi6*chi5/(a6/a5*(chi6-psi6)+psi6)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(psi5)
|
|
psi5 = tiny
|
|
CALL PUSHREAL8(psi5gnrd)
|
|
psi5gnrd = 0.d0
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
CCC IF(CHI4 > TINY) THEN
|
|
IF (w(2) > tiny) THEN
|
|
CALL PUSHREAL8(bbgnrd)
|
|
C Accounts for NH3 evaporation
|
|
bbgnrd = -(psi6gnrd+psi5gnrd-a4gnrd/a4**2)
|
|
CALL PUSHREAL8(bb)
|
|
bb = -(chi4+psi6+psi5+1.d0/a4)
|
|
ccgnrd = chi4*(psi5gnrd+psi6gnrd) + 2.d0*psi2*a4gnrd/a4**2
|
|
cc = chi4*(psi5+psi6) - 2.d0*psi2/a4
|
|
IF (bb*bb - 4.d0*cc < zero) THEN
|
|
CALL PUSHREAL8(dd)
|
|
dd = zero
|
|
CALL PUSHREAL8(ddgnrd)
|
|
ddgnrd = 0.d0
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHREAL8(ddgnrd)
|
|
ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd
|
|
CALL PUSHREAL8(dd)
|
|
dd = bb*bb - 4.d0*cc
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
IF (dd >= 0.) THEN
|
|
abs1 = dd
|
|
ELSE
|
|
abs1 = -dd
|
|
END IF
|
|
IF (abs1 < tiny) THEN
|
|
result1gnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
result1gnrd = ddgnrd/(2.0*SQRT(dd))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
psi4gnrd = 0.5d0*(-bbgnrd-result1gnrd)
|
|
psi4 = 0.5d0*(-bb-result1)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
psi4 = tiny
|
|
psi4gnrd = 0.d0
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8(molalgnrd(2))
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
C NAI
|
|
molalgnrd(2) = 0.d0
|
|
CALL PUSHREAL8(molal(2))
|
|
molal(2) = w(1)
|
|
CALL PUSHREAL8(molalgnrd(4))
|
|
C MOLAL (3) = 2.0*PSI2 + PSI4 ! NH4I
|
|
C CLI
|
|
molalgnrd(4) = psi6gnrd
|
|
CALL PUSHREAL8(molal(4))
|
|
molal(4) = psi6
|
|
IF (w(2) - 0.5d0*w(1) > zero) THEN
|
|
CALL PUSHREAL8(molalgnrd(3))
|
|
molalgnrd(3) = psi4gnrd
|
|
CALL PUSHREAL8(molal(3))
|
|
molal(3) = 2.d0*w(2) - w(1) + psi4
|
|
CALL PUSHREAL8(molalgnrd(5))
|
|
C SO4I
|
|
molalgnrd(5) = 0.d0
|
|
CALL PUSHREAL8(molal(5))
|
|
molal(5) = w(2)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(molalgnrd(3))
|
|
molalgnrd(3) = psi4gnrd
|
|
CALL PUSHREAL8(molal(3))
|
|
molal(3) = psi4
|
|
CALL PUSHREAL8(molalgnrd(5))
|
|
C SO4I
|
|
molalgnrd(5) = 0.d0
|
|
CALL PUSHREAL8(molal(5))
|
|
molal(5) = 0.5d0*w(1)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8(molalgnrd(6))
|
|
molalgnrd(6) = 0.d0
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = zero
|
|
CALL PUSHREAL8(molalgnrd(7))
|
|
C NO3I
|
|
molalgnrd(7) = psi5gnrd
|
|
CALL PUSHREAL8(molal(7))
|
|
molal(7) = psi5
|
|
CALL PUSHREAL8(smingnrd)
|
|
C
|
|
C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3)
|
|
smingnrd = psi5gnrd + psi6gnrd - psi4gnrd
|
|
CALL PUSHREAL8(smin)
|
|
smin = psi5 + psi6 - psi4
|
|
CALL CALCPH_GNRD(smin, smingnrd, hi, hignrd, ohi)
|
|
CALL PUSHREAL8(molalgnrd(1))
|
|
molalgnrd(1) = hignrd
|
|
CALL PUSHREAL8(molal(1))
|
|
molal(1) = hi
|
|
IF (chi4 - psi4 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (chi5 - psi5 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (chi6 - psi6 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ghcl = tiny
|
|
ghclgnrd = 0.d0
|
|
ELSE
|
|
ghclgnrd = -psi6gnrd
|
|
ghcl = chi6 - psi6
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C Solid (NH4)2SO4
|
|
C Solid NH4NO3
|
|
C Solid NH4Cl
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C WRITE(*,*) 'MOLAL ',MOLAL
|
|
C NA2SO4
|
|
molalrgnrd(2) = 0.d0
|
|
molalr(2) = 0.5*w(1)
|
|
IF (w(2) - 0.5d0*w(1) > zero) THEN
|
|
C Total SO4
|
|
C (NH4)2SO4
|
|
molalrgnrd(4) = 0.d0
|
|
molalr(4) = w(2) - 0.5d0*w(1)
|
|
IF (psi4 < zero) THEN
|
|
frnh4 = zero
|
|
frnh4gnrd = 0.d0
|
|
CALL PUSHCONTROL2B(0)
|
|
ELSE
|
|
frnh4gnrd = psi4gnrd
|
|
frnh4 = psi4
|
|
CALL PUSHCONTROL2B(1)
|
|
END IF
|
|
ELSE
|
|
C Total SO4
|
|
C (NH4)2SO4
|
|
molalrgnrd(4) = 0.d0
|
|
molalr(4) = zero
|
|
IF (2.d0*w(2) - w(1) + psi4 < zero) THEN
|
|
frnh4 = zero
|
|
frnh4gnrd = 0.d0
|
|
CALL PUSHCONTROL2B(2)
|
|
ELSE
|
|
frnh4gnrd = psi4gnrd
|
|
frnh4 = 2.d0*w(2) - w(1) + psi4
|
|
CALL PUSHCONTROL2B(3)
|
|
END IF
|
|
END IF
|
|
IF (psi5 < frnh4) THEN
|
|
molalrgnrd(5) = psi5gnrd
|
|
molalr(5) = psi5
|
|
IF (frnh4 - psi5 < zero) THEN
|
|
frnh4 = zero
|
|
frnh4gnrd = 0.d0
|
|
CALL PUSHCONTROL2B(0)
|
|
ELSE
|
|
frnh4gnrd = frnh4gnrd - psi5gnrd
|
|
frnh4 = frnh4 - psi5
|
|
CALL PUSHCONTROL2B(1)
|
|
END IF
|
|
ELSE
|
|
molalrgnrd(5) = frnh4gnrd
|
|
molalr(5) = frnh4
|
|
frnh4 = zero
|
|
frnh4gnrd = 0.d0
|
|
CALL PUSHCONTROL2B(2)
|
|
END IF
|
|
IF (psi6 > frnh4) THEN
|
|
molalrgnrd(6) = frnh4gnrd
|
|
molalr(6) = frnh4
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHREAL8(water)
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
CALL PUSHREAL8(watergnrd)
|
|
watergnrd = 0.d0
|
|
DO j=1,npair
|
|
watergnrd = watergnrd + molalrgnrd(j)/m0(j)
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
watergnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
CALL PUSHREAL8ARRAY(gamagnrd, npair)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C WRITE(*,*) 'After CALCMR: WATER ',WATER
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3P_GNRD()
|
|
ENDDO
|
|
temp23gb1 = fg5abgnrdgb/a6**2
|
|
temp22 = ghcl**2
|
|
temp19 = a6/temp22
|
|
temp20gb = temp19*temp23gb1
|
|
temp21gb = ghcl*temp20gb
|
|
temp21 = molalgnrd(1)*molal(4) + molal(1)*molalgnrd(4)
|
|
temp20 = temp21*ghcl - ghclgnrd*molal(1)*molal(4)
|
|
temp19gb = temp20*temp23gb1/temp22
|
|
temp18 = a6gnrd/ghcl
|
|
temp18gb = -(molal(1)*molal(4)*temp23gb1/ghcl)
|
|
temp23gb = fg5abgb/(ghcl*a6)
|
|
temp23gb0 = -(molal(1)*molal(4)*temp23gb/(ghcl*a6))
|
|
molalgb(1) = molalgb(1) + molal(4)*temp23gb
|
|
molalgb(4) = molalgb(4) + molalgnrd(1)*temp21gb - ghclgnrd*molal(1
|
|
+ )*temp20gb - temp18*molal(1)*temp23gb1 + molal(1)*temp23gb
|
|
ghclgb = ghclgb + temp21*temp20gb - temp19*2*ghcl*temp19gb -
|
|
+ temp18*temp18gb + a6*temp23gb0
|
|
a6gb = temp19gb - (temp20*temp19-molal(1)*molal(4)*temp18)*2*
|
|
+ temp23gb1/a6 + ghcl*temp23gb0
|
|
DO ii10=1,nions
|
|
molalgnrdgb(ii10) = 0.D0
|
|
ENDDO
|
|
molalgnrdgb(1) = molalgnrdgb(1) + molal(4)*temp21gb
|
|
molalgb(1) = molalgb(1) + molalgnrd(4)*temp21gb - ghclgnrd*molal(4
|
|
+ )*temp20gb - temp18*molal(4)*temp23gb1
|
|
molalgnrdgb(4) = molalgnrdgb(4) + molal(1)*temp21gb
|
|
a6gnrdgb = temp18gb
|
|
DO ii10=1,npair
|
|
gamagnrdgb(ii10) = 0.D0
|
|
ENDDO
|
|
watergnrdgb = 0.D0
|
|
DO ii10=1,npair
|
|
molalrgnrdgb(ii10) = 0.D0
|
|
ENDDO
|
|
DO i=2,1,-1
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPREAL8ARRAY(gamagnrd, npair)
|
|
CALL CALCACT3P_GNRD_GB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
watergb = 0.D0
|
|
watergnrdgb = 0.D0
|
|
END IF
|
|
DO j=npair,1,-1
|
|
molalrgb(j) = molalrgb(j) + watergb/m0(j)
|
|
molalrgnrdgb(j) = molalrgnrdgb(j) + watergnrdgb/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(watergnrd)
|
|
CALL POPREAL8(water)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
frnh4gb = molalrgb(6)
|
|
molalrgb(6) = 0.D0
|
|
frnh4gnrdgb = molalrgnrdgb(6)
|
|
molalrgnrdgb(6) = 0.D0
|
|
ELSE
|
|
molalrgb(6) = 0.D0
|
|
molalrgnrdgb(6) = 0.D0
|
|
frnh4gb = 0.D0
|
|
frnh4gnrdgb = 0.D0
|
|
END IF
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch == 0) THEN
|
|
psi5gb = 0.D0
|
|
psi5gnrdgb = 0.D0
|
|
frnh4gb = 0.D0
|
|
frnh4gnrdgb = 0.D0
|
|
ELSE IF (branch == 1) THEN
|
|
psi5gb = -frnh4gb
|
|
psi5gnrdgb = -frnh4gnrdgb
|
|
ELSE
|
|
frnh4gb = molalrgb(5)
|
|
molalrgb(5) = 0.D0
|
|
frnh4gnrdgb = molalrgnrdgb(5)
|
|
molalrgnrdgb(5) = 0.D0
|
|
psi5gb = 0.D0
|
|
psi5gnrdgb = 0.D0
|
|
GOTO 100
|
|
END IF
|
|
psi5gb = psi5gb + molalrgb(5)
|
|
molalrgb(5) = 0.D0
|
|
psi5gnrdgb = psi5gnrdgb + molalrgnrdgb(5)
|
|
molalrgnrdgb(5) = 0.D0
|
|
100 CALL POPCONTROL2B(branch)
|
|
IF (branch < 2) THEN
|
|
IF (branch == 0) THEN
|
|
psi4gb = 0.D0
|
|
psi4gnrdgb = 0.D0
|
|
ELSE
|
|
psi4gb = frnh4gb
|
|
psi4gnrdgb = frnh4gnrdgb
|
|
END IF
|
|
wgb(2) = wgb(2) + molalrgb(4)
|
|
wgb(1) = wgb(1) - 0.5d0*molalrgb(4)
|
|
molalrgb(4) = 0.D0
|
|
molalrgnrdgb(4) = 0.D0
|
|
ELSE
|
|
IF (branch == 2) THEN
|
|
psi4gb = 0.D0
|
|
psi4gnrdgb = 0.D0
|
|
ELSE
|
|
wgb(2) = wgb(2) + 2.d0*frnh4gb
|
|
wgb(1) = wgb(1) - frnh4gb
|
|
psi4gb = frnh4gb
|
|
psi4gnrdgb = frnh4gnrdgb
|
|
END IF
|
|
molalrgb(4) = 0.D0
|
|
molalrgnrdgb(4) = 0.D0
|
|
END IF
|
|
wgb(1) = wgb(1) + 0.5*molalrgb(2)
|
|
molalrgb(2) = 0.D0
|
|
molalrgnrdgb(2) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) chi6gb = chi6gb + ghclgb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
chi5gb = chi5gb + ghno3gb
|
|
psi5gb = psi5gb - ghno3gb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
chi4gb = chi4gb + gnh3gb
|
|
psi4gb = psi4gb - gnh3gb
|
|
END IF
|
|
CALL POPREAL8(molal(1))
|
|
higb = molalgb(1)
|
|
molalgb(1) = 0.D0
|
|
CALL POPREAL8(molalgnrd(1))
|
|
hignrdgb = molalgnrdgb(1)
|
|
molalgnrdgb(1) = 0.D0
|
|
CALL CALCPH_GNRD_GB(smin, smingb, smingnrd, smingnrdgb, hi, higb
|
|
+ , hignrd, hignrdgb, ohi)
|
|
CALL POPREAL8(smin)
|
|
psi5gb = psi5gb + molalgb(7) + smingb
|
|
psi4gb = psi4gb - smingb
|
|
CALL POPREAL8(smingnrd)
|
|
psi5gnrdgb = psi5gnrdgb + molalgnrdgb(7) + smingnrdgb
|
|
psi4gnrdgb = psi4gnrdgb - smingnrdgb
|
|
CALL POPREAL8(molal(7))
|
|
molalgb(7) = 0.D0
|
|
CALL POPREAL8(molalgnrd(7))
|
|
molalgnrdgb(7) = 0.D0
|
|
CALL POPREAL8(molal(6))
|
|
molalgb(6) = 0.D0
|
|
CALL POPREAL8(molalgnrd(6))
|
|
molalgnrdgb(6) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(molal(5))
|
|
wgb(2) = wgb(2) + molalgb(5)
|
|
molalgb(5) = 0.D0
|
|
CALL POPREAL8(molalgnrd(5))
|
|
molalgnrdgb(5) = 0.D0
|
|
CALL POPREAL8(molal(3))
|
|
wgb(2) = wgb(2) + 2.d0*molalgb(3)
|
|
wgb(1) = wgb(1) - molalgb(3)
|
|
psi4gb = psi4gb + molalgb(3)
|
|
molalgb(3) = 0.D0
|
|
CALL POPREAL8(molalgnrd(3))
|
|
psi4gnrdgb = psi4gnrdgb + molalgnrdgb(3)
|
|
molalgnrdgb(3) = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(molal(5))
|
|
wgb(1) = wgb(1) + 0.5d0*molalgb(5)
|
|
molalgb(5) = 0.D0
|
|
CALL POPREAL8(molalgnrd(5))
|
|
molalgnrdgb(5) = 0.D0
|
|
CALL POPREAL8(molal(3))
|
|
psi4gb = psi4gb + molalgb(3)
|
|
molalgb(3) = 0.D0
|
|
CALL POPREAL8(molalgnrd(3))
|
|
psi4gnrdgb = psi4gnrdgb + molalgnrdgb(3)
|
|
molalgnrdgb(3) = 0.D0
|
|
END IF
|
|
CALL POPREAL8(molal(4))
|
|
molalgb(4) = 0.D0
|
|
CALL POPREAL8(molalgnrd(4))
|
|
molalgnrdgb(4) = 0.D0
|
|
CALL POPREAL8(molal(2))
|
|
wgb(1) = wgb(1) + molalgb(2)
|
|
molalgb(2) = 0.D0
|
|
CALL POPREAL8(molalgnrd(2))
|
|
molalgnrdgb(2) = 0.D0
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
bbgb = -(0.5d0*psi4gb)
|
|
result1gb = -(0.5d0*psi4gb)
|
|
bbgnrdgb = -(0.5d0*psi4gnrdgb)
|
|
result1gnrdgb = -(0.5d0*psi4gnrdgb)
|
|
IF (dd == 0.0) THEN
|
|
ddgb = 0.0
|
|
ELSE
|
|
ddgb = result1gb/(2.0*SQRT(dd))
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ddgnrdgb = 0.D0
|
|
ELSE
|
|
temp17 = SQRT(dd)
|
|
temp17gb3 = result1gnrdgb/(2.0*temp17)
|
|
ddgnrdgb = temp17gb3
|
|
IF (.NOT.dd == 0.0) ddgb = ddgb - ddgnrd*temp17gb3/(2.0*
|
|
+ temp17**2)
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(dd)
|
|
bbgb = bbgb + 2*bbgnrd*ddgnrdgb + 2*bb*ddgb
|
|
ccgb = -(4.d0*ddgb)
|
|
CALL POPREAL8(ddgnrd)
|
|
bbgnrdgb = bbgnrdgb + 2*bb*ddgnrdgb
|
|
ccgnrdgb = -(4.d0*ddgnrdgb)
|
|
ELSE
|
|
CALL POPREAL8(ddgnrd)
|
|
CALL POPREAL8(dd)
|
|
ccgnrdgb = 0.D0
|
|
ccgb = 0.D0
|
|
END IF
|
|
temp17gb2 = bbgnrdgb/a4**2
|
|
temp17gb1 = 2.d0*ccgnrdgb/a4**2
|
|
temp17gb0 = -(2.d0*ccgb/a4)
|
|
chi4gb = chi4gb + (psi6gnrd+psi5gnrd)*ccgnrdgb - bbgb + (psi6+
|
|
+ psi5)*ccgb
|
|
psi5gb = psi5gb + chi4*ccgb - bbgb
|
|
psi2gb = psi2gb + a4gnrd*temp17gb1 + temp17gb0
|
|
a4gb = bbgb/a4**2 - a4gnrd*2*temp17gb2/a4 - psi2*a4gnrd*2*
|
|
+ temp17gb1/a4 - psi2*temp17gb0/a4
|
|
psi5gnrdgb = psi5gnrdgb + chi4*ccgnrdgb - bbgnrdgb
|
|
a4gnrdgb = temp17gb2 + psi2*temp17gb1
|
|
CALL POPREAL8(bb)
|
|
CALL POPREAL8(bbgnrd)
|
|
ELSE
|
|
a4gb = 0.D0
|
|
a4gnrdgb = 0.D0
|
|
END IF
|
|
a5 = xk4*r*temp*(water/gama(10))**2.0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
temp7 = a6/a5
|
|
temp8 = psi6 + (chi6-psi6)*temp7
|
|
temp15gb0 = psi5gnrdgb/temp8**2
|
|
temp13 = a6/a5
|
|
temp14 = psi6 + (chi6-psi6)*temp13
|
|
temp14gb = psi6gnrd*temp15gb0
|
|
temp13gb = (chi6-psi6)*chi5*temp14gb/a5
|
|
temp12 = a5**2
|
|
temp9 = (chi6-psi6)/temp12
|
|
temp10 = a6gnrd*a5 - a6*a5gnrd
|
|
temp11 = psi6gnrd + temp10*temp9 - psi6gnrd*a6/a5
|
|
temp11gb = -(psi6*chi5*temp15gb0)
|
|
temp10gb = temp9*temp11gb
|
|
temp9gb = temp10*temp11gb/temp12
|
|
temp9gb0 = -(psi6gnrd*temp11gb/a5)
|
|
temp8gb = -((psi6gnrd*(chi5*temp14)-psi6*(chi5*temp11))*2*
|
|
+ temp15gb0/temp8)
|
|
temp7gb = (chi6-psi6)*temp8gb/a5
|
|
CALL POPREAL8(psi5)
|
|
temp15 = a6/a5
|
|
temp16 = psi6 + (chi6-psi6)*temp15
|
|
temp17gb = psi6*psi5gb/temp16
|
|
temp16gb = -(chi5*temp17gb/temp16)
|
|
temp15gb = (chi6-psi6)*temp16gb/a5
|
|
chi5gb = chi5gb + temp14*temp14gb - psi6*temp11*temp15gb0 +
|
|
+ temp17gb
|
|
chi6gb = chi6gb + chi5*temp13*temp14gb + temp9gb + temp7*
|
|
+ temp8gb + temp15*temp16gb
|
|
a6gb = a6gb + temp13gb - a5gnrd*temp10gb + temp9gb0 + temp7gb
|
|
+ + temp15gb
|
|
a5gb = a6gnrd*temp10gb - temp13*temp13gb - temp9*2*a5*temp9gb
|
|
+ - a6*temp9gb0/a5 - temp7*temp7gb - temp15*temp15gb
|
|
CALL POPREAL8(psi5gnrd)
|
|
a6gnrdgb = a6gnrdgb + a5*temp10gb
|
|
a5gnrdgb = -(a6*temp10gb)
|
|
ELSE
|
|
CALL POPREAL8(psi5gnrd)
|
|
CALL POPREAL8(psi5)
|
|
a5gb = 0.D0
|
|
a5gnrdgb = 0.D0
|
|
END IF
|
|
temp1 = xkw*gama(5)**3
|
|
temp0 = gama(10)/temp1
|
|
temp1gb0 = xk2*2.0*r*temp*a4gnrdgb
|
|
temp1gb = temp0*temp1gb0
|
|
temp0gb = (gamagnrd(10)*gama(5)-gama(10)*gamagnrd(5))*temp1gb0/
|
|
+ temp1
|
|
temp2 = gama(10)/gama(5)
|
|
temp2gb = 2.0*temp2*xk2*r*temp*a4gb/(xkw*gama(5))
|
|
temp3 = gama(10)**3
|
|
temp3gb1 = xk4*2.0*r*temp*a5gnrdgb
|
|
temp3gb = water*temp3gb1/temp3
|
|
temp3gb0 = (watergnrd*gama(10)-water*gamagnrd(10))*temp3gb1/
|
|
+ temp3
|
|
temp4 = water/gama(10)
|
|
temp4gb = 2.0*temp4*xk4*r*temp*a5gb/gama(10)
|
|
temp5 = gama(11)**3
|
|
temp5gb1 = xk3*2.0*r*temp*a6gnrdgb
|
|
temp5gb = water*temp5gb1/temp5
|
|
temp5gb0 = (watergnrd*gama(11)-water*gamagnrd(11))*temp5gb1/
|
|
+ temp5
|
|
CALL POPREAL8(a6)
|
|
temp6 = water/gama(11)
|
|
temp6gb = 2.0*temp6*xk3*r*temp*a6gb/gama(11)
|
|
watergb = watergb + temp5gb0 - gamagnrd(11)*temp5gb - gamagnrd(
|
|
+ 10)*temp3gb + temp3gb0 + temp4gb + temp6gb
|
|
gamagb(11) = gamagb(11) + watergnrd*temp5gb - water*3*gama(11)**
|
|
+ 2*temp5gb0/temp5 - temp6*temp6gb
|
|
CALL POPREAL8(a6gnrd)
|
|
watergnrdgb = watergnrdgb + gama(10)*temp3gb + gama(11)*temp5gb
|
|
gamagnrdgb(11) = gamagnrdgb(11) - water*temp5gb
|
|
gamagb(10) = gamagb(10) + watergnrd*temp3gb - water*3*gama(10)**
|
|
+ 2*temp3gb0/temp3 + temp2gb - temp4*temp4gb
|
|
CALL POPREAL8(a5gnrd)
|
|
gamagnrdgb(10) = gamagnrdgb(10) + gama(5)*temp1gb - water*
|
|
+ temp3gb
|
|
gamagb(5) = gamagb(5) + gamagnrd(10)*temp1gb - xkw*temp0*3*gama(
|
|
+ 5)**2*temp0gb - temp2*temp2gb
|
|
CALL POPREAL8(a4gnrd)
|
|
gamagb(10) = gamagb(10) + temp0gb - gamagnrd(5)*temp1gb
|
|
gamagnrdgb(5) = gamagnrdgb(5) - gama(10)*temp1gb
|
|
gnh3gb = 0.D0
|
|
ghno3gb = 0.D0
|
|
ghclgb = 0.D0
|
|
a6gb = 0.D0
|
|
a6gnrdgb = 0.D0
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of calcph_gnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: hi hignrd
|
|
C with respect to varying inputs: water watergnrd gggnrd gg
|
|
C
|
|
C Differentiation of calcph in forward (tangent) mode:
|
|
C variations of useful results: hi
|
|
C with respect to varying inputs: water gg
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCPH
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCPH_GNRD_GB(gg, gggb, gggnrd, gggnrdgb, hi, higb,
|
|
+ hignrd, hignrdgb, ohi)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: cn, gg, hi, ohi, bb, cc, dd
|
|
REAL*8 :: cngb, gggb, higb, ohigb, bbgb, ccgb, ddgb
|
|
REAL*8 :: cngnrd, gggnrd, hignrd, ohignrd, bbgnrd, ccgnrd,
|
|
+ ddgnrd
|
|
REAL*8 :: cngnrdgb, gggnrdgb, hignrdgb, ohignrdgb, bbgnrdgb
|
|
+ , ccgnrdgb, ddgnrdgb
|
|
REAL*8 :: akw
|
|
REAL*8 :: akwgb
|
|
REAL*8 :: akwgnrd
|
|
REAL*8 :: akwgnrdgb
|
|
REAL*8 :: result1
|
|
REAL*8 :: result1gb
|
|
REAL*8 :: result1gnrd
|
|
REAL*8 :: result1gnrdgb
|
|
REAL*8 :: x2gnrd
|
|
REAL*8 :: x2gnrdgb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x2gb
|
|
REAL*8 :: x1gnrd
|
|
REAL*8 :: x1gnrdgb
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1gb
|
|
INTRINSIC SQRT
|
|
INTEGER :: branch
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp2gb
|
|
REAL*8 :: temp0gb0
|
|
REAL*8 :: temp0gb
|
|
REAL*8 :: temp3gb
|
|
REAL*8 :: abs3
|
|
REAL*8 :: abs2
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp1gb
|
|
C
|
|
akwgnrd = xkw*rh*(watergnrd*water+water*watergnrd)
|
|
akw = xkw*rh*water*water
|
|
IF (akw >= 0.) THEN
|
|
abs1 = akw
|
|
ELSE
|
|
abs1 = -akw
|
|
END IF
|
|
IF (abs1 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
cngnrd = 0.d0
|
|
ELSE
|
|
cngnrd = akwgnrd/(2.0*SQRT(akw))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
cn = SQRT(akw)
|
|
C
|
|
C *** GG = (negative charge) - (positive charge)
|
|
C
|
|
IF (gg > tiny) THEN
|
|
C H+ in excess
|
|
bbgnrd = -gggnrd
|
|
bb = -gg
|
|
ccgnrd = -akwgnrd
|
|
cc = -akw
|
|
ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (dd >= 0.) THEN
|
|
abs2 = dd
|
|
ELSE
|
|
abs2 = -dd
|
|
END IF
|
|
IF (abs2 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
x1 = 0.5d0*(-bb+result1)
|
|
IF (x1 < cn) THEN
|
|
cngb = higb
|
|
cngnrdgb = hignrdgb
|
|
x1gb = 0.D0
|
|
x1gnrdgb = 0.D0
|
|
ELSE
|
|
x1gb = higb
|
|
x1gnrdgb = hignrdgb
|
|
cngb = 0.D0
|
|
cngnrdgb = 0.D0
|
|
END IF
|
|
result1gb = 0.5d0*x1gb
|
|
bbgb = -(0.5d0*x1gb)
|
|
result1gnrdgb = 0.5d0*x1gnrdgb
|
|
bbgnrdgb = -(0.5d0*x1gnrdgb)
|
|
IF (dd == 0.0) THEN
|
|
ddgb = 0.0
|
|
ELSE
|
|
ddgb = result1gb/(2.0*SQRT(dd))
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ddgnrdgb = 0.D0
|
|
ELSE
|
|
temp1 = SQRT(dd)
|
|
temp1gb = result1gnrdgb/(2.0*temp1)
|
|
ddgnrdgb = temp1gb
|
|
IF (.NOT.dd == 0.0) ddgb = ddgb - ddgnrd*temp1gb/(2.0*temp1
|
|
+ **2)
|
|
END IF
|
|
bbgb = bbgb + 2*bbgnrd*ddgnrdgb + 2*bb*ddgb
|
|
ccgb = -(4.d0*ddgb)
|
|
bbgnrdgb = bbgnrdgb + 2*bb*ddgnrdgb
|
|
ccgnrdgb = -(4.d0*ddgnrdgb)
|
|
akwgb = -ccgb
|
|
akwgnrdgb = -ccgnrdgb
|
|
gggb = -bbgb
|
|
gggnrdgb = -bbgnrdgb
|
|
ELSE
|
|
C OH- in excess
|
|
bbgnrd = gggnrd
|
|
bb = gg
|
|
ccgnrd = -akwgnrd
|
|
cc = -akw
|
|
ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (dd >= 0.) THEN
|
|
abs3 = dd
|
|
ELSE
|
|
abs3 = -dd
|
|
END IF
|
|
IF (abs3 < tiny) THEN
|
|
result1gnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
result1gnrd = ddgnrd/(2.0*SQRT(dd))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
x2gnrd = 0.5d0*(result1gnrd-bbgnrd)
|
|
x2 = 0.5d0*(-bb+result1)
|
|
IF (x2 < cn) THEN
|
|
ohignrd = cngnrd
|
|
ohi = cn
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
ohignrd = x2gnrd
|
|
ohi = x2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
temp3gb = hignrdgb/ohi**2
|
|
akwgb = higb/ohi - ohignrd*temp3gb
|
|
ohigb = (akwgnrd-(akwgnrd*ohi-akw*ohignrd)*2/ohi)*temp3gb - akw*
|
|
+ higb/ohi**2
|
|
akwgnrdgb = ohi*temp3gb
|
|
ohignrdgb = -(akw*temp3gb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cngb = ohigb
|
|
cngnrdgb = ohignrdgb
|
|
x2gb = 0.D0
|
|
x2gnrdgb = 0.D0
|
|
ELSE
|
|
x2gb = ohigb
|
|
x2gnrdgb = ohignrdgb
|
|
cngb = 0.D0
|
|
cngnrdgb = 0.D0
|
|
END IF
|
|
result1gb = 0.5d0*x2gb
|
|
bbgb = -(0.5d0*x2gb)
|
|
result1gnrdgb = 0.5d0*x2gnrdgb
|
|
bbgnrdgb = -(0.5d0*x2gnrdgb)
|
|
IF (dd == 0.0) THEN
|
|
ddgb = 0.0
|
|
ELSE
|
|
ddgb = result1gb/(2.0*SQRT(dd))
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ddgnrdgb = 0.D0
|
|
ELSE
|
|
temp2 = SQRT(dd)
|
|
temp2gb = result1gnrdgb/(2.0*temp2)
|
|
ddgnrdgb = temp2gb
|
|
IF (.NOT.dd == 0.0) ddgb = ddgb - ddgnrd*temp2gb/(2.0*temp2
|
|
+ **2)
|
|
END IF
|
|
bbgb = bbgb + 2*bbgnrd*ddgnrdgb + 2*bb*ddgb
|
|
ccgb = -(4.d0*ddgb)
|
|
bbgnrdgb = bbgnrdgb + 2*bb*ddgnrdgb
|
|
ccgnrdgb = -(4.d0*ddgnrdgb)
|
|
akwgb = akwgb - ccgb
|
|
akwgnrdgb = akwgnrdgb - ccgnrdgb
|
|
gggb = bbgb
|
|
gggnrdgb = bbgnrdgb
|
|
END IF
|
|
IF (.NOT.akw == 0.0) akwgb = akwgb + cngb/(2.0*SQRT(akw))
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp0 = SQRT(akw)
|
|
temp0gb0 = cngnrdgb/(2.0*temp0)
|
|
akwgnrdgb = akwgnrdgb + temp0gb0
|
|
IF (.NOT.akw == 0.0) akwgb = akwgb - akwgnrd*temp0gb0/(2.0*
|
|
+ temp0**2)
|
|
END IF
|
|
temp0gb = xkw*rh*akwgnrdgb
|
|
watergb = 2*watergnrd*temp0gb + xkw*rh*2*water*akwgb
|
|
watergnrdgb = 2*water*temp0gb
|
|
END
|
|
|
|
C Differentiation of calcact3p_gnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water molalgnrd
|
|
C gamagnrd watergnrd
|
|
C with respect to varying inputs: molal gama water molalgnrd
|
|
C gamagnrd watergnrd
|
|
C
|
|
C Differentiation of calcact3p in forward (tangent) mode:
|
|
C variations of useful results: gama
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3P_GNRD_GB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0gb(6, 4), siongb, hgb, chgb, f1gb(3), f2gb(4)
|
|
REAL*8 :: g0gnrd(6, 4), siongnrd, hgnrd, chgnrd, f1gnrd(3)
|
|
+ , f2gnrd(4)
|
|
REAL*8 :: g0gnrdgb(6, 4), siongnrdgb, hgnrdgb, chgnrdgb,
|
|
+ f1gnrdgb(3), f2gnrdgb(4)
|
|
REAL*8 :: mpl, xij, yji
|
|
REAL*8 :: mplgb, xijgb, yjigb
|
|
REAL*8 :: mplgnrd, xijgnrd, yjignrd
|
|
REAL*8 :: mplgnrdgb, xijgnrdgb, yjignrdgb
|
|
REAL*8 :: ionicgb, ionicgnrd, ionicgnrdgb
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01gb
|
|
REAL*8 :: g01gnrd
|
|
REAL*8 :: g01gnrdgb
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02gb
|
|
REAL*8 :: g02gnrd
|
|
REAL*8 :: g02gnrdgb
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03gb
|
|
REAL*8 :: g03gnrd
|
|
REAL*8 :: g03gnrdgb
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04gb
|
|
REAL*8 :: g04gnrd
|
|
REAL*8 :: g04gnrdgb
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05gb
|
|
REAL*8 :: g05gnrd
|
|
REAL*8 :: g05gnrdgb
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06gb
|
|
REAL*8 :: g06gnrd
|
|
REAL*8 :: g06gnrdgb
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07gb
|
|
REAL*8 :: g07gnrd
|
|
REAL*8 :: g07gnrdgb
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08gb
|
|
REAL*8 :: g08gnrd
|
|
REAL*8 :: g08gnrdgb
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09gb
|
|
REAL*8 :: g09gnrd
|
|
REAL*8 :: g09gnrdgb
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10gb
|
|
REAL*8 :: g10gnrd
|
|
REAL*8 :: g10gnrdgb
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11gb
|
|
REAL*8 :: g11gnrd
|
|
REAL*8 :: g11gnrdgb
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12gb
|
|
REAL*8 :: g12gnrd
|
|
REAL*8 :: g12gnrdgb
|
|
INTEGER :: j
|
|
REAL*8 :: x2gnrd
|
|
REAL*8 :: x2gnrdgb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x2gb
|
|
REAL*8 :: x1gnrd
|
|
REAL*8 :: x1gnrdgb
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1gb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
INTEGER :: branch
|
|
REAL*8 :: temp2gb13
|
|
REAL*8 :: temp2gb12
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp2gb11
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp2gb10
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp2gb
|
|
REAL*8 :: temp0gb1
|
|
REAL*8 :: temp0gb0
|
|
REAL*8 :: temp1gb4
|
|
REAL*8 :: temp1gb3
|
|
REAL*8 :: temp1gb2
|
|
INTEGER :: ii20
|
|
REAL*8 :: temp1gb1
|
|
REAL*8 :: temp1gb0
|
|
REAL*8 :: temp2gb9
|
|
REAL*8 :: temp2gb8
|
|
REAL*8 :: temp2gb7
|
|
REAL*8 :: temp2gb6
|
|
REAL*8 :: temp2gb5
|
|
REAL*8 :: temp2gb4
|
|
REAL*8 :: temp2gb3
|
|
REAL*8 :: temp2gb2
|
|
REAL*8 :: temp2gb1
|
|
REAL*8 :: temp0gb
|
|
REAL*8 :: temp2gb0
|
|
INTRINSIC LOG
|
|
REAL*8 :: temp2gb25
|
|
REAL*8 :: temp2gb24
|
|
REAL*8 :: temp2gb23
|
|
REAL*8 :: temp2gb22
|
|
REAL*8 :: temp2gb21
|
|
INTEGER :: ii10
|
|
REAL*8 :: temp2gb20
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp1gb
|
|
REAL*8 :: temp2gb19
|
|
REAL*8 :: temp2gb18
|
|
REAL*8 :: temp2gb17
|
|
REAL*8 :: temp2gb16
|
|
REAL*8 :: temp2gb15
|
|
REAL*8 :: temp2gb14
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
ionicgnrd = 0.d0
|
|
DO i=1,7
|
|
ionicgnrd = ionicgnrd + z(i)**2*molalgnrd(i)
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
x1gnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1gnrd = (0.5d0*ionicgnrd*water-0.5d0*ionic*watergnrd)/water**2
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHREAL8(ionicgnrd)
|
|
ionicgnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionicgnrd)
|
|
ionicgnrd = x1gnrd
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3_GNRD(ionic, ionicgnrd, temp, g01, g01gnrd, g02,
|
|
+ g02gnrd, g03, g03gnrd, g04, g04gnrd, g05, g05gnrd
|
|
+ , g06, g06gnrd, g07, g07gnrd, g08, g08gnrd, g09,
|
|
+ g09gnrd, g10, g10gnrd, g11, g11gnrd, g12, g12gnrd
|
|
+ )
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0gnrd(ii2, ii1) = 0.d0
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
g0gnrd(1, 1) = g11gnrd
|
|
g0(1, 1) = g11
|
|
g0gnrd(1, 2) = g07gnrd
|
|
g0(1, 2) = g07
|
|
g0gnrd(1, 3) = g08gnrd
|
|
g0(1, 3) = g08
|
|
g0gnrd(1, 4) = g10gnrd
|
|
g0(1, 4) = g10
|
|
g0gnrd(2, 1) = g01gnrd
|
|
g0(2, 1) = g01
|
|
g0gnrd(2, 2) = g02gnrd
|
|
g0(2, 2) = g02
|
|
g0gnrd(2, 3) = g12gnrd
|
|
g0(2, 3) = g12
|
|
g0gnrd(2, 4) = g03gnrd
|
|
g0(2, 4) = g03
|
|
g0gnrd(3, 1) = g06gnrd
|
|
g0(3, 1) = g06
|
|
g0gnrd(3, 2) = g04gnrd
|
|
g0(3, 2) = g04
|
|
g0gnrd(3, 3) = g09gnrd
|
|
g0(3, 3) = g09
|
|
g0gnrd(3, 4) = g05gnrd
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
IF (ionic >= 0.) THEN
|
|
abs1 = ionic
|
|
ELSE
|
|
abs1 = -ionic
|
|
END IF
|
|
IF (abs1 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
siongnrd = 0.d0
|
|
ELSE
|
|
siongnrd = ionicgnrd/(2.0*SQRT(ionic))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
hgnrd = (agama*siongnrd*(1.d0+sion)-agama*sion*siongnrd)/(1.d0+
|
|
+ sion)**2
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
DO ii1=1,3
|
|
f1gnrd(ii1) = 0.d0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2gnrd(ii1) = 0.d0
|
|
ENDDO
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mplgnrd)
|
|
mplgnrd = (molalgnrd(i)*water-molal(i)*watergnrd)/water**2
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
chgnrd = -(0.25d0*(zpl+zmi)**2*ionicgnrd/ionic**2)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xijgnrd = chgnrd*mpl + ch*mplgnrd
|
|
xij = ch*mpl
|
|
CALL PUSHREAL8(yjignrd)
|
|
yjignrd = ((chgnrd*molal(j+3)+ch*molalgnrd(j+3))*water-ch*
|
|
+ molal(j+3)*watergnrd)/water**2
|
|
yji = ch*molal(j+3)/water
|
|
f1gnrd(i) = f1gnrd(i) + yjignrd*(g0(i, j)+zpl*zmi*h) + yji*(
|
|
+ g0gnrd(i, j)+zpl*zmi*hgnrd)
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2gnrd(j) = f2gnrd(j) + xijgnrd*(g0(i, j)+zpl*zmi*h) + xij*(
|
|
+ g0gnrd(i, j)+zpl*zmi*hgnrd)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gamagnrd(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gamagnrd(1) = zz(1)*((f1gnrd(2)/z(2)+f2gnrd(1)/z(4))/(z(2)+z(4))-
|
|
+ hgnrd)
|
|
CALL PUSHREAL8(gama(1))
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gamagnrd(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gamagnrd(2) = zz(2)*((f1gnrd(2)/z(2)+f2gnrd(2)/z(5))/(z(2)+z(5))-
|
|
+ hgnrd)
|
|
CALL PUSHREAL8(gama(2))
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gamagnrd(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gamagnrd(3) = zz(3)*((f1gnrd(2)/z(2)+f2gnrd(4)/z(7))/(z(2)+z(7))-
|
|
+ hgnrd)
|
|
CALL PUSHREAL8(gama(3))
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gamagnrd(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gamagnrd(4) = zz(4)*((f1gnrd(3)/z(3)+f2gnrd(2)/z(5))/(z(3)+z(5))-
|
|
+ hgnrd)
|
|
CALL PUSHREAL8(gama(4))
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gamagnrd(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gamagnrd(5) = zz(5)*((f1gnrd(3)/z(3)+f2gnrd(4)/z(7))/(z(3)+z(7))-
|
|
+ hgnrd)
|
|
CALL PUSHREAL8(gama(5))
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gamagnrd(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gamagnrd(6) = zz(6)*((f1gnrd(3)/z(3)+f2gnrd(1)/z(4))/(z(3)+z(4))-
|
|
+ hgnrd)
|
|
CALL PUSHREAL8(gama(6))
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gamagnrd(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gamagnrd(7) = zz(7)*((f1gnrd(1)/z(1)+f2gnrd(2)/z(5))/(z(1)+z(5))-
|
|
+ hgnrd)
|
|
CALL PUSHREAL8(gama(7))
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gamagnrd(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gamagnrd(8) = zz(8)*((f1gnrd(1)/z(1)+f2gnrd(3)/z(6))/(z(1)+z(6))-
|
|
+ hgnrd)
|
|
CALL PUSHREAL8(gama(8))
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gamagnrd(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gamagnrd(9) = zz(9)*((f1gnrd(3)/z(3)+f2gnrd(3)/z(6))/(z(3)+z(6))-
|
|
+ hgnrd)
|
|
CALL PUSHREAL8(gama(9))
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gamagnrd(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gamagnrd(10) = zz(10)*((f1gnrd(1)/z(1)+f2gnrd(4)/z(7))/(z(1)+z(7))
|
|
+ -hgnrd)
|
|
CALL PUSHREAL8(gama(10))
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gamagnrd(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gamagnrd(11) = zz(11)*((f1gnrd(1)/z(1)+f2gnrd(1)/z(4))/(z(1)+z(4))
|
|
+ -hgnrd)
|
|
CALL PUSHREAL8(gama(11))
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gamagnrd(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gamagnrd(12) = zz(12)*((f1gnrd(2)/z(2)+f2gnrd(3)/z(6))/(z(2)+z(6))
|
|
+ -hgnrd)
|
|
CALL PUSHREAL8(gama(12))
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gamagnrd(13))
|
|
C LC ; SCAPE
|
|
gamagnrd(13) = 0.2d0*(3.d0*gamagnrd(4)+2.d0*gamagnrd(9))
|
|
CALL PUSHREAL8(gama(13))
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
x2gnrd = 0.d0
|
|
ELSE
|
|
x2gnrd = gamagnrd(i)
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHREAL8(gamagnrd(i))
|
|
gamagnrd(i) = 0.d0
|
|
CALL PUSHREAL8(gama(i))
|
|
gama(i) = -5.0d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(gamagnrd(i))
|
|
gamagnrd(i) = x2gnrd
|
|
CALL PUSHREAL8(gama(i))
|
|
gama(i) = x2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
temp2gb25 = LOG(10.d0)*gamagnrdgb(i)
|
|
temp2 = 10.d0**gama(i)
|
|
gamagb(i) = gamagnrd(i)*temp2*LOG(10.d0)*temp2gb25 + 10.d0**gama
|
|
+ (i)*LOG(10.d0)*gamagb(i)
|
|
gamagnrdgb(i) = temp2*temp2gb25
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(gama(i))
|
|
gamagb(i) = 0.D0
|
|
CALL POPREAL8(gamagnrd(i))
|
|
gamagnrdgb(i) = 0.D0
|
|
x2gb = 0.D0
|
|
x2gnrdgb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(gama(i))
|
|
x2gb = gamagb(i)
|
|
gamagb(i) = 0.D0
|
|
CALL POPREAL8(gamagnrd(i))
|
|
x2gnrdgb = gamagnrdgb(i)
|
|
gamagnrdgb(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
gamagb(i) = gamagb(i) + x2gb
|
|
gamagnrdgb(i) = gamagnrdgb(i) + x2gnrdgb
|
|
END IF
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamagb(4) = gamagb(4) + 0.2d0*3.d0*gamagb(13)
|
|
gamagb(9) = gamagb(9) + 0.2d0*2.d0*gamagb(13)
|
|
gamagb(13) = 0.D0
|
|
CALL POPREAL8(gamagnrd(13))
|
|
gamagnrdgb(4) = gamagnrdgb(4) + 0.2d0*3.d0*gamagnrdgb(13)
|
|
gamagnrdgb(9) = gamagnrdgb(9) + 0.2d0*2.d0*gamagnrdgb(13)
|
|
gamagnrdgb(13) = 0.D0
|
|
DO ii10=1,3
|
|
f1gb(ii10) = 0.D0
|
|
ENDDO
|
|
DO ii10=1,4
|
|
f2gb(ii10) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp2gb1 = zz(12)*gamagb(12)/(z(2)+z(6))
|
|
f1gb(2) = f1gb(2) + temp2gb1/z(2)
|
|
f2gb(3) = f2gb(3) + temp2gb1/z(6)
|
|
hgb = -(zz(12)*gamagb(12))
|
|
gamagb(12) = 0.D0
|
|
DO ii10=1,3
|
|
f1gnrdgb(ii10) = 0.D0
|
|
ENDDO
|
|
DO ii10=1,4
|
|
f2gnrdgb(ii10) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gamagnrd(12))
|
|
temp2gb2 = zz(12)*gamagnrdgb(12)/(z(2)+z(6))
|
|
f1gnrdgb(2) = f1gnrdgb(2) + temp2gb2/z(2)
|
|
f2gnrdgb(3) = f2gnrdgb(3) + temp2gb2/z(6)
|
|
hgnrdgb = -(zz(12)*gamagnrdgb(12))
|
|
gamagnrdgb(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp2gb3 = zz(11)*gamagb(11)/(z(1)+z(4))
|
|
f2gb(1) = f2gb(1) + temp2gb3/z(4)
|
|
hgb = hgb - zz(11)*gamagb(11)
|
|
gamagb(11) = 0.D0
|
|
CALL POPREAL8(gamagnrd(11))
|
|
temp2gb5 = zz(11)*gamagnrdgb(11)/(z(1)+z(4))
|
|
f2gnrdgb(1) = f2gnrdgb(1) + temp2gb5/z(4)
|
|
hgnrdgb = hgnrdgb - zz(11)*gamagnrdgb(11)
|
|
gamagnrdgb(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp2gb4 = zz(10)*gamagb(10)/(z(1)+z(7))
|
|
f1gb(1) = f1gb(1) + temp2gb4/z(1) + temp2gb3/z(1)
|
|
f2gb(4) = f2gb(4) + temp2gb4/z(7)
|
|
hgb = hgb - zz(10)*gamagb(10)
|
|
gamagb(10) = 0.D0
|
|
CALL POPREAL8(gamagnrd(10))
|
|
temp2gb6 = zz(10)*gamagnrdgb(10)/(z(1)+z(7))
|
|
f1gnrdgb(1) = f1gnrdgb(1) + temp2gb6/z(1) + temp2gb5/z(1)
|
|
f2gnrdgb(4) = f2gnrdgb(4) + temp2gb6/z(7)
|
|
hgnrdgb = hgnrdgb - zz(10)*gamagnrdgb(10)
|
|
gamagnrdgb(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp2gb7 = zz(9)*gamagb(9)/(z(3)+z(6))
|
|
f1gb(3) = f1gb(3) + temp2gb7/z(3)
|
|
hgb = hgb - zz(9)*gamagb(9)
|
|
gamagb(9) = 0.D0
|
|
CALL POPREAL8(gamagnrd(9))
|
|
temp2gb9 = zz(9)*gamagnrdgb(9)/(z(3)+z(6))
|
|
f1gnrdgb(3) = f1gnrdgb(3) + temp2gb9/z(3)
|
|
hgnrdgb = hgnrdgb - zz(9)*gamagnrdgb(9)
|
|
gamagnrdgb(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp2gb8 = zz(8)*gamagb(8)/(z(1)+z(6))
|
|
f2gb(3) = f2gb(3) + temp2gb8/z(6) + temp2gb7/z(6)
|
|
hgb = hgb - zz(8)*gamagb(8)
|
|
gamagb(8) = 0.D0
|
|
CALL POPREAL8(gamagnrd(8))
|
|
temp2gb10 = zz(8)*gamagnrdgb(8)/(z(1)+z(6))
|
|
f2gnrdgb(3) = f2gnrdgb(3) + temp2gb10/z(6) + temp2gb9/z(6)
|
|
hgnrdgb = hgnrdgb - zz(8)*gamagnrdgb(8)
|
|
gamagnrdgb(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp2gb11 = zz(7)*gamagb(7)/(z(1)+z(5))
|
|
f1gb(1) = f1gb(1) + temp2gb11/z(1) + temp2gb8/z(1)
|
|
f2gb(2) = f2gb(2) + temp2gb11/z(5)
|
|
hgb = hgb - zz(7)*gamagb(7)
|
|
gamagb(7) = 0.D0
|
|
CALL POPREAL8(gamagnrd(7))
|
|
temp2gb12 = zz(7)*gamagnrdgb(7)/(z(1)+z(5))
|
|
f1gnrdgb(1) = f1gnrdgb(1) + temp2gb12/z(1) + temp2gb10/z(1)
|
|
f2gnrdgb(2) = f2gnrdgb(2) + temp2gb12/z(5)
|
|
hgnrdgb = hgnrdgb - zz(7)*gamagnrdgb(7)
|
|
gamagnrdgb(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp2gb13 = zz(6)*gamagb(6)/(z(3)+z(4))
|
|
f2gb(1) = f2gb(1) + temp2gb13/z(4)
|
|
hgb = hgb - zz(6)*gamagb(6)
|
|
gamagb(6) = 0.D0
|
|
CALL POPREAL8(gamagnrd(6))
|
|
temp2gb16 = zz(6)*gamagnrdgb(6)/(z(3)+z(4))
|
|
f2gnrdgb(1) = f2gnrdgb(1) + temp2gb16/z(4)
|
|
hgnrdgb = hgnrdgb - zz(6)*gamagnrdgb(6)
|
|
gamagnrdgb(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp2gb14 = zz(5)*gamagb(5)/(z(3)+z(7))
|
|
f2gb(4) = f2gb(4) + temp2gb14/z(7)
|
|
hgb = hgb - zz(5)*gamagb(5)
|
|
gamagb(5) = 0.D0
|
|
CALL POPREAL8(gamagnrd(5))
|
|
temp2gb17 = zz(5)*gamagnrdgb(5)/(z(3)+z(7))
|
|
f2gnrdgb(4) = f2gnrdgb(4) + temp2gb17/z(7)
|
|
hgnrdgb = hgnrdgb - zz(5)*gamagnrdgb(5)
|
|
gamagnrdgb(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp2gb15 = zz(4)*gamagb(4)/(z(3)+z(5))
|
|
f1gb(3) = f1gb(3) + temp2gb14/z(3) + temp2gb15/z(3) + temp2gb13/z(
|
|
+ 3)
|
|
f2gb(2) = f2gb(2) + temp2gb15/z(5)
|
|
hgb = hgb - zz(4)*gamagb(4)
|
|
gamagb(4) = 0.D0
|
|
CALL POPREAL8(gamagnrd(4))
|
|
temp2gb18 = zz(4)*gamagnrdgb(4)/(z(3)+z(5))
|
|
f1gnrdgb(3) = f1gnrdgb(3) + temp2gb17/z(3) + temp2gb18/z(3) +
|
|
+ temp2gb16/z(3)
|
|
f2gnrdgb(2) = f2gnrdgb(2) + temp2gb18/z(5)
|
|
hgnrdgb = hgnrdgb - zz(4)*gamagnrdgb(4)
|
|
gamagnrdgb(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp2gb19 = zz(3)*gamagb(3)/(z(2)+z(7))
|
|
f2gb(4) = f2gb(4) + temp2gb19/z(7)
|
|
hgb = hgb - zz(3)*gamagb(3)
|
|
gamagb(3) = 0.D0
|
|
CALL POPREAL8(gamagnrd(3))
|
|
temp2gb22 = zz(3)*gamagnrdgb(3)/(z(2)+z(7))
|
|
f2gnrdgb(4) = f2gnrdgb(4) + temp2gb22/z(7)
|
|
hgnrdgb = hgnrdgb - zz(3)*gamagnrdgb(3)
|
|
gamagnrdgb(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp2gb20 = zz(2)*gamagb(2)/(z(2)+z(5))
|
|
f2gb(2) = f2gb(2) + temp2gb20/z(5)
|
|
hgb = hgb - zz(2)*gamagb(2)
|
|
gamagb(2) = 0.D0
|
|
CALL POPREAL8(gamagnrd(2))
|
|
temp2gb23 = zz(2)*gamagnrdgb(2)/(z(2)+z(5))
|
|
f2gnrdgb(2) = f2gnrdgb(2) + temp2gb23/z(5)
|
|
hgnrdgb = hgnrdgb - zz(2)*gamagnrdgb(2)
|
|
gamagnrdgb(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp2gb21 = zz(1)*gamagb(1)/(z(2)+z(4))
|
|
f1gb(2) = f1gb(2) + temp2gb20/z(2) + temp2gb21/z(2) + temp2gb19/z(
|
|
+ 2)
|
|
f2gb(1) = f2gb(1) + temp2gb21/z(4)
|
|
hgb = hgb - zz(1)*gamagb(1)
|
|
gamagb(1) = 0.D0
|
|
CALL POPREAL8(gamagnrd(1))
|
|
temp2gb24 = zz(1)*gamagnrdgb(1)/(z(2)+z(4))
|
|
f1gnrdgb(2) = f1gnrdgb(2) + temp2gb23/z(2) + temp2gb24/z(2) +
|
|
+ temp2gb22/z(2)
|
|
f2gnrdgb(1) = f2gnrdgb(1) + temp2gb24/z(4)
|
|
hgnrdgb = hgnrdgb - zz(1)*gamagnrdgb(1)
|
|
gamagnrdgb(1) = 0.D0
|
|
ionicgb = 0.D0
|
|
ionicgnrdgb = 0.D0
|
|
DO ii10=1,4
|
|
DO ii20=1,6
|
|
g0gb(ii20, ii10) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO ii10=1,4
|
|
DO ii20=1,6
|
|
g0gnrdgb(ii20, ii10) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mplgnrdgb = 0.D0
|
|
mplgb = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijgb = (g0gnrd(i, j)+zpl*zmi*hgnrd)*f2gnrdgb(j) + (g0(i, j)+
|
|
+ zpl*zmi*h)*f2gb(j)
|
|
chgnrd = -(0.25d0*(zpl+zmi)**2*ionicgnrd/ionic**2)
|
|
xijgnrd = chgnrd*mpl + ch*mplgnrd
|
|
xijgnrdgb = (g0(i, j)+zpl*zmi*h)*f2gnrdgb(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0gb(i, j) = g0gb(i, j) + xijgnrd*f2gnrdgb(j) + yjignrd*
|
|
+ f1gnrdgb(i) + yji*f1gb(i) + xij*f2gb(j)
|
|
hgb = hgb + xijgnrd*zpl*zmi*f2gnrdgb(j) + yjignrd*zpl*zmi*
|
|
+ f1gnrdgb(i) + yji*zpl*zmi*f1gb(i) + xij*zpl*zmi*f2gb(j)
|
|
g0gnrdgb(i, j) = g0gnrdgb(i, j) + yji*f1gnrdgb(i) + xij*
|
|
+ f2gnrdgb(j)
|
|
hgnrdgb = hgnrdgb + yji*zpl*zmi*f1gnrdgb(i) + xij*zpl*zmi*
|
|
+ f2gnrdgb(j)
|
|
yjigb = (g0gnrd(i, j)+zpl*zmi*hgnrd)*f1gnrdgb(i) + (g0(i, j)+
|
|
+ zpl*zmi*h)*f1gb(i)
|
|
yjignrdgb = (g0(i, j)+zpl*zmi*h)*f1gnrdgb(i)
|
|
temp2gb = molal(j+3)*yjigb/water
|
|
CALL POPREAL8(yjignrd)
|
|
temp2gb0 = yjignrdgb/water**2
|
|
temp1gb2 = water*temp2gb0
|
|
molalgb(j+3) = molalgb(j+3) + chgnrd*temp1gb2 - ch*watergnrd*
|
|
+ temp2gb0 + ch*yjigb/water
|
|
temp1 = chgnrd*molal(j+3) + ch*molalgnrd(j+3)
|
|
watergb = watergb + (temp1-(temp1*water-molal(j+3)*(ch*
|
|
+ watergnrd))*2/water)*temp2gb0 - ch*temp2gb/water
|
|
temp1gb3 = -(molal(j+3)*temp2gb0)
|
|
chgb = molalgnrd(j+3)*temp1gb2 + watergnrd*temp1gb3 + mplgnrd*
|
|
+ xijgnrdgb + mpl*xijgb + temp2gb
|
|
chgnrdgb = mpl*xijgnrdgb + molal(j+3)*temp1gb2
|
|
molalgnrdgb(j+3) = molalgnrdgb(j+3) + ch*temp1gb2
|
|
watergnrdgb = watergnrdgb + ch*temp1gb3
|
|
mplgb = mplgb + chgnrd*xijgnrdgb + ch*xijgb
|
|
mplgnrdgb = mplgnrdgb + ch*xijgnrdgb
|
|
temp1gb4 = -((zpl+zmi)**2*0.25d0*chgnrdgb/ionic**2)
|
|
ionicgb = ionicgb - ionicgnrd*2*temp1gb4/ionic - (zpl+zmi)**2*
|
|
+ 0.25d0*chgb/ionic**2
|
|
ionicgnrdgb = ionicgnrdgb + temp1gb4
|
|
ENDDO
|
|
temp1gb1 = mplgnrdgb/water**2
|
|
CALL POPREAL8(mpl)
|
|
molalgb(i) = molalgb(i) + mplgb/water - watergnrd*temp1gb1
|
|
watergb = watergb + (molalgnrd(i)-(molalgnrd(i)*water-molal(i)*
|
|
+ watergnrd)*2/water)*temp1gb1 - molal(i)*mplgb/water**2
|
|
CALL POPREAL8(mplgnrd)
|
|
molalgnrdgb(i) = molalgnrdgb(i) + water*temp1gb1
|
|
watergnrdgb = watergnrdgb - molal(i)*temp1gb1
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp1gb0 = hgnrdgb/(sion+1.d0)**2
|
|
temp1gb = agama*hgb/(sion+1.d0)
|
|
siongb = (1.D0-sion/(sion+1.d0))*temp1gb - (agama*(siongnrd*(sion+
|
|
+ 1.d0))-agama*(sion*siongnrd))*2*temp1gb0/(sion+1.d0)
|
|
siongnrdgb = (agama*(sion+1.d0)-agama*sion)*temp1gb0
|
|
IF (.NOT.ionic == 0.0) ionicgb = ionicgb + siongb/(2.0*SQRT(
|
|
+ ionic))
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp0 = SQRT(ionic)
|
|
temp0gb1 = siongnrdgb/(2.0*temp0)
|
|
ionicgnrdgb = ionicgnrdgb + temp0gb1
|
|
IF (.NOT.ionic == 0.0) ionicgb = ionicgb - ionicgnrd*temp0gb1/
|
|
+ (2.0*temp0**2)
|
|
END IF
|
|
g05gb = g0gb(3, 4)
|
|
g0gb(3, 4) = 0.D0
|
|
g05gnrdgb = g0gnrdgb(3, 4)
|
|
g0gnrdgb(3, 4) = 0.D0
|
|
g09gb = g0gb(3, 3)
|
|
g0gb(3, 3) = 0.D0
|
|
g09gnrdgb = g0gnrdgb(3, 3)
|
|
g0gnrdgb(3, 3) = 0.D0
|
|
g04gb = g0gb(3, 2)
|
|
g0gb(3, 2) = 0.D0
|
|
g04gnrdgb = g0gnrdgb(3, 2)
|
|
g0gnrdgb(3, 2) = 0.D0
|
|
g06gb = g0gb(3, 1)
|
|
g0gb(3, 1) = 0.D0
|
|
g06gnrdgb = g0gnrdgb(3, 1)
|
|
g0gnrdgb(3, 1) = 0.D0
|
|
g03gb = g0gb(2, 4)
|
|
g0gb(2, 4) = 0.D0
|
|
g03gnrdgb = g0gnrdgb(2, 4)
|
|
g0gnrdgb(2, 4) = 0.D0
|
|
g12gb = g0gb(2, 3)
|
|
g0gb(2, 3) = 0.D0
|
|
g12gnrdgb = g0gnrdgb(2, 3)
|
|
g0gnrdgb(2, 3) = 0.D0
|
|
g02gb = g0gb(2, 2)
|
|
g0gb(2, 2) = 0.D0
|
|
g02gnrdgb = g0gnrdgb(2, 2)
|
|
g0gnrdgb(2, 2) = 0.D0
|
|
g01gb = g0gb(2, 1)
|
|
g0gb(2, 1) = 0.D0
|
|
g01gnrdgb = g0gnrdgb(2, 1)
|
|
g0gnrdgb(2, 1) = 0.D0
|
|
g10gb = g0gb(1, 4)
|
|
g0gb(1, 4) = 0.D0
|
|
g10gnrdgb = g0gnrdgb(1, 4)
|
|
g0gnrdgb(1, 4) = 0.D0
|
|
g08gb = g0gb(1, 3)
|
|
g0gb(1, 3) = 0.D0
|
|
g08gnrdgb = g0gnrdgb(1, 3)
|
|
g0gnrdgb(1, 3) = 0.D0
|
|
g07gb = g0gb(1, 2)
|
|
g0gb(1, 2) = 0.D0
|
|
g07gnrdgb = g0gnrdgb(1, 2)
|
|
g0gnrdgb(1, 2) = 0.D0
|
|
g11gb = g0gb(1, 1)
|
|
g11gnrdgb = g0gnrdgb(1, 1)
|
|
CALL KMFUL3_GNRD_GB(ionic, ionicgb, ionicgnrd, ionicgnrdgb, temp,
|
|
+ g01, g01gb, g01gnrd, g01gnrdgb, g02, g02gb,
|
|
+ g02gnrd, g02gnrdgb, g03, g03gb, g03gnrd,
|
|
+ g03gnrdgb, g04, g04gb, g04gnrd, g04gnrdgb, g05
|
|
+ , g05gb, g05gnrd, g05gnrdgb, g06, g06gb,
|
|
+ g06gnrd, g06gnrdgb, g07, g07gb, g07gnrd,
|
|
+ g07gnrdgb, g08, g08gb, g08gnrd, g08gnrdgb, g09
|
|
+ , g09gb, g09gnrd, g09gnrdgb, g10, g10gb,
|
|
+ g10gnrd, g10gnrdgb, g11, g11gb, g11gnrd,
|
|
+ g11gnrdgb, g12, g12gb, g12gnrd, g12gnrdgb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionicgnrd)
|
|
CALL POPREAL8(ionic)
|
|
x1gb = 0.D0
|
|
x1gnrdgb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1gb = ionicgb
|
|
CALL POPREAL8(ionicgnrd)
|
|
x1gnrdgb = ionicgnrdgb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ionicgb = 0.D0
|
|
ionicgnrdgb = 0.D0
|
|
ELSE
|
|
temp0gb0 = x1gnrdgb/water**2
|
|
temp0gb = 0.5d0*x1gb/water
|
|
ionicgb = temp0gb - 0.5d0*watergnrd*temp0gb0
|
|
watergb = watergb + (0.5d0*ionicgnrd-(0.5d0*(ionicgnrd*water)-
|
|
+ 0.5d0*(ionic*watergnrd))*2/water)*temp0gb0 - ionic*temp0gb/
|
|
+ water
|
|
ionicgnrdgb = 0.5d0*water*temp0gb0
|
|
watergnrdgb = watergnrdgb - 0.5d0*ionic*temp0gb0
|
|
END IF
|
|
DO i=7,1,-1
|
|
molalgb(i) = molalgb(i) + z(i)**2*ionicgb
|
|
molalgnrdgb(i) = molalgnrdgb(i) + z(i)**2*ionicgnrdgb
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of kmful3_gnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: g05gnrd g01 g02 g03 g04 g05
|
|
C g06 g01gnrd g07 g08 ionicgnrd g09 g06gnrd g02gnrd
|
|
C g10 g11 g07gnrd g12 g10gnrd g03gnrd ionic g08gnrd
|
|
C g11gnrd g04gnrd g09gnrd g12gnrd
|
|
C with respect to varying inputs: ionicgnrd ionic
|
|
C
|
|
C Differentiation of kmful3 in forward (tangent) mode:
|
|
C variations of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_GNRD_GB(ionic, ionicgb, ionicgnrd, ionicgnrdgb,
|
|
+ temp, g01, g01gb, g01gnrd, g01gnrdgb,
|
|
+ g02, g02gb, g02gnrd, g02gnrdgb, g03,
|
|
+ g03gb, g03gnrd, g03gnrdgb, g04, g04gb,
|
|
+ g04gnrd, g04gnrdgb, g05, g05gb, g05gnrd
|
|
+ , g05gnrdgb, g06, g06gb, g06gnrd,
|
|
+ g06gnrdgb, g07, g07gb, g07gnrd,
|
|
+ g07gnrdgb, g08, g08gb, g08gnrd,
|
|
+ g08gnrdgb, g09, g09gb, g09gnrd,
|
|
+ g09gnrdgb, g10, g10gb, g10gnrd,
|
|
+ g10gnrdgb, g11, g11gb, g11gnrd,
|
|
+ g11gnrdgb, g12, g12gb, g12gnrd,
|
|
+ g12gnrdgb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionicgb, siongb, cf2gb
|
|
REAL*8 :: ionicgnrd, siongnrd, cf2gnrd
|
|
REAL*8 :: ionicgnrdgb, siongnrdgb, cf2gnrdgb
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01gb, g02gb, g03gb, g04gb, g05gb, g06gb, g07gb,
|
|
+ g08gb, g09gb, g10gb, g11gb, g12gb
|
|
REAL*8 :: g01gnrd, g02gnrd, g03gnrd, g04gnrd, g05gnrd,
|
|
+ g06gnrd, g07gnrd, g08gnrd, g09gnrd, g10gnrd,
|
|
+ g11gnrd, g12gnrd
|
|
REAL*8 :: g01gnrdgb, g02gnrdgb, g03gnrdgb, g04gnrdgb,
|
|
+ g05gnrdgb, g06gnrdgb, g07gnrdgb, g08gnrdgb,
|
|
+ g09gnrdgb, g10gnrdgb, g11gnrdgb, g12gnrdgb
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs1, tiny
|
|
INTRINSIC SQRT
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp1gb3
|
|
REAL*8 :: temp1gb2
|
|
REAL*8 :: temp1gb1
|
|
REAL*8 :: temp1gb0
|
|
REAL*8 :: temp0gb
|
|
REAL*8 :: abs2
|
|
REAL*8 :: temp1gb
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
tiny = 1.d-20
|
|
IF (ionic >= 0.) THEN
|
|
abs2 = ionic
|
|
ELSE
|
|
abs2 = -ionic
|
|
END IF
|
|
IF (abs2 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
siongnrd = 0.d0
|
|
ELSE
|
|
siongnrd = ionicgnrd/(2.0*SQRT(ionic))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.d0) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01gb = g01gb + g12gb
|
|
g08gb = g08gb + g09gb + g12gb
|
|
g11gb = g11gb - g09gb - g12gb
|
|
g01gnrdgb = g01gnrdgb + g12gnrdgb
|
|
g08gnrdgb = g08gnrdgb + g09gnrdgb + g12gnrdgb
|
|
g11gnrdgb = g11gnrdgb - g09gnrdgb - g12gnrdgb
|
|
g06gb = g06gb + g09gb
|
|
g06gnrdgb = g06gnrdgb + g09gnrdgb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2gb = -(z10*g10gb) - z07*g07gb - z05*g05gb - z03*g03gb - z01*
|
|
+ g01gb - z02*g02gb - z04*g04gb - z06*g06gb - z08*g08gb - z11*
|
|
+ g11gb
|
|
g11gb = cf1*g11gb
|
|
cf2gnrdgb = -(z10*g10gnrdgb) - z07*g07gnrdgb - z05*g05gnrdgb -
|
|
+ z03*g03gnrdgb - z01*g01gnrdgb - z02*g02gnrdgb - z04*g04gnrdgb
|
|
+ - z06*g06gnrdgb - z08*g08gnrdgb - z11*g11gnrdgb
|
|
g11gnrdgb = cf1*g11gnrdgb
|
|
g10gb = cf1*g10gb
|
|
g10gnrdgb = cf1*g10gnrdgb
|
|
g08gb = cf1*g08gb
|
|
g08gnrdgb = cf1*g08gnrdgb
|
|
g07gb = cf1*g07gb
|
|
g07gnrdgb = cf1*g07gnrdgb
|
|
g06gb = cf1*g06gb
|
|
g06gnrdgb = cf1*g06gnrdgb
|
|
g05gb = cf1*g05gb
|
|
g05gnrdgb = cf1*g05gnrdgb
|
|
g04gb = cf1*g04gb
|
|
g04gnrdgb = cf1*g04gnrdgb
|
|
g03gb = cf1*g03gb
|
|
g03gnrdgb = cf1*g03gnrdgb
|
|
g02gb = cf1*g02gb
|
|
g02gnrdgb = cf1*g02gnrdgb
|
|
g01gb = cf1*g01gb
|
|
g01gnrdgb = cf1*g01gnrdgb
|
|
temp1gb = (0.125d0-ti*0.005d0)*cf2gb
|
|
temp1gb0 = -(0.41d0*temp1gb/(sion+1.d0))
|
|
temp1gb3 = (0.125d0-ti*0.005d0)*cf2gnrdgb
|
|
temp1gb1 = 0.92d0*0.039d0*temp1gb3
|
|
ionicgb = ionicgb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp1gb -
|
|
+ ionicgnrd*0.8d0*ionic**(-1.8D0)*temp1gb1
|
|
temp1gb2 = -(temp1gb3/(sion+1.d0)**2)
|
|
siongb = (1.D0-sion/(sion+1.d0))*temp1gb0 - (0.41d0*(siongnrd*(
|
|
+ sion+1.d0))-0.41d0*(sion*siongnrd))*2*temp1gb2/(sion+1.d0)
|
|
ionicgnrdgb = ionicgnrdgb + ionic**(-0.8d0)*temp1gb1
|
|
siongnrdgb = (0.41d0*(sion+1.d0)-0.41d0*sion)*temp1gb2
|
|
ELSE
|
|
siongb = 0.D0
|
|
siongnrdgb = 0.D0
|
|
END IF
|
|
CALL MKBI_GNRD_GB(q11, ionic, ionicgb, ionicgnrd, ionicgnrdgb,
|
|
+ sion, siongb, siongnrd, siongnrdgb, z11, g11,
|
|
+ g11gb, g11gnrd, g11gnrdgb)
|
|
CALL MKBI_GNRD_GB(q10, ionic, ionicgb, ionicgnrd, ionicgnrdgb,
|
|
+ sion, siongb, siongnrd, siongnrdgb, z10, g10,
|
|
+ g10gb, g10gnrd, g10gnrdgb)
|
|
CALL MKBI_GNRD_GB(q8, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion
|
|
+ , siongb, siongnrd, siongnrdgb, z08, g08, g08gb
|
|
+ , g08gnrd, g08gnrdgb)
|
|
CALL MKBI_GNRD_GB(q7, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion
|
|
+ , siongb, siongnrd, siongnrdgb, z07, g07, g07gb
|
|
+ , g07gnrd, g07gnrdgb)
|
|
CALL MKBI_GNRD_GB(q6, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion
|
|
+ , siongb, siongnrd, siongnrdgb, z06, g06, g06gb
|
|
+ , g06gnrd, g06gnrdgb)
|
|
CALL MKBI_GNRD_GB(q5, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion
|
|
+ , siongb, siongnrd, siongnrdgb, z05, g05, g05gb
|
|
+ , g05gnrd, g05gnrdgb)
|
|
CALL MKBI_GNRD_GB(q4, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion
|
|
+ , siongb, siongnrd, siongnrdgb, z04, g04, g04gb
|
|
+ , g04gnrd, g04gnrdgb)
|
|
CALL MKBI_GNRD_GB(q3, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion
|
|
+ , siongb, siongnrd, siongnrdgb, z03, g03, g03gb
|
|
+ , g03gnrd, g03gnrdgb)
|
|
CALL MKBI_GNRD_GB(q2, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion
|
|
+ , siongb, siongnrd, siongnrdgb, z02, g02, g02gb
|
|
+ , g02gnrd, g02gnrdgb)
|
|
CALL MKBI_GNRD_GB(q1, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion
|
|
+ , siongb, siongnrd, siongnrdgb, z01, g01, g01gb
|
|
+ , g01gnrd, g01gnrdgb)
|
|
IF (.NOT.ionic == 0.0) ionicgb = ionicgb + siongb/(2.0*SQRT(
|
|
+ ionic))
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp0 = SQRT(ionic)
|
|
temp0gb = siongnrdgb/(2.0*temp0)
|
|
ionicgnrdgb = ionicgnrdgb + temp0gb
|
|
IF (.NOT.ionic == 0.0) ionicgb = ionicgb - ionicgnrd*temp0gb/(
|
|
+ 2.0*temp0**2)
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of mkbi_gnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: sion bignrd ionicgnrd bi ionic
|
|
C siongnrd
|
|
C with respect to varying inputs: sion ionicgnrd ionic siongnrd
|
|
C
|
|
C Differentiation of mkbi in forward (tangent) mode:
|
|
C variations of useful results: bi
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_GNRD_GB(q, ionic, ionicgb, ionicgnrd, ionicgnrdgb
|
|
+ , sion, siongb, siongnrd, siongnrdgb, zip
|
|
+ , bi, bigb, bignrd, bignrdgb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionicgb, siongb, bigb
|
|
REAL*8 :: ionicgnrd, siongnrd, bignrd
|
|
REAL*8 :: ionicgnrdgb, siongnrdgb, bignrdgb
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: cgb, xxgb
|
|
REAL*8 :: cgnrd, xxgnrd
|
|
REAL*8 :: cgnrdgb, xxgnrdgb
|
|
REAL*8 :: arg1
|
|
REAL*8 :: arg1gb
|
|
REAL*8 :: arg1gnrd
|
|
REAL*8 :: arg1gnrdgb
|
|
REAL*8 :: pwx1
|
|
REAL*8 :: pwx1gb
|
|
REAL*8 :: pwx1gnrd
|
|
REAL*8 :: pwx1gnrdgb
|
|
REAL*8 :: pwr1
|
|
REAL*8 :: pwr1gb
|
|
REAL*8 :: pwr1gnrd, tiny
|
|
REAL*8 :: pwr1gnrdgb
|
|
INTRINSIC EXP
|
|
INTRINSIC LOG10
|
|
INTEGER :: branch
|
|
REAL*8 :: tempgb2
|
|
REAL*8 :: tempgb1
|
|
REAL*8 :: tempgb0
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: tempgb
|
|
INTRINSIC ABS
|
|
REAL*8 :: x1
|
|
REAL*8 :: temp1gb3
|
|
REAL*8 :: temp1gb2
|
|
REAL*8 :: temp1gb1
|
|
REAL*8 :: temp1gb0
|
|
REAL*8 :: temp0gb
|
|
INTRINSIC LOG
|
|
INTRINSIC INT
|
|
REAL*8 :: abs3
|
|
REAL*8 :: abs2
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp
|
|
REAL*8 :: temp1gb
|
|
tiny = 1.d-20
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
arg1gnrd = -(.023d0*((ionicgnrd*ionic+ionic*ionicgnrd)*ionic+ionic
|
|
+ **2*ionicgnrd))
|
|
arg1 = -(.023d0*ionic*ionic*ionic)
|
|
cgnrd = .055d0*q*arg1gnrd*EXP(arg1)
|
|
c = 1. + .055d0*q*EXP(arg1)
|
|
pwx1gnrd = .1d0*ionicgnrd
|
|
pwx1 = 1.d0 + .1d0*ionic
|
|
x1 = q - INT(q)
|
|
IF (x1 >= 0.) THEN
|
|
abs1 = x1
|
|
ELSE
|
|
abs1 = -x1
|
|
END IF
|
|
IF (pwx1 > 0.d0 .OR. (pwx1 < 0.d0 .AND. abs1 < tiny))
|
|
+THEN
|
|
pwr1gnrd = q*pwx1**(q-1)*pwx1gnrd
|
|
CALL PUSHCONTROL2B(0)
|
|
ELSE
|
|
IF (pwx1 >= 0.) THEN
|
|
abs2 = pwx1
|
|
ELSE
|
|
abs2 = -pwx1
|
|
END IF
|
|
IF (q - 1.d0 >= 0.) THEN
|
|
abs3 = q - 1.d0
|
|
ELSE
|
|
abs3 = -(q-1.d0)
|
|
END IF
|
|
IF (abs2 < tiny .AND. abs3 < tiny) THEN
|
|
pwr1gnrd = pwx1gnrd
|
|
CALL PUSHCONTROL2B(1)
|
|
ELSE
|
|
pwr1gnrd = 0.0
|
|
CALL PUSHCONTROL2B(2)
|
|
END IF
|
|
END IF
|
|
pwr1 = pwx1**q
|
|
bignrd = b*pwr1gnrd
|
|
bi = 1.d0 + b*pwr1 - b
|
|
C
|
|
temp1 = LOG(10.d0)
|
|
temp1gb3 = zip*bignrdgb/(temp1*bi)
|
|
xxgb = zip*bigb
|
|
bigb = zip*bigb/(bi*LOG(10.0)) - bignrd*temp1gb3/bi
|
|
xxgnrdgb = zip*bignrdgb
|
|
bignrdgb = temp1gb3
|
|
pwr1gb = b*bigb
|
|
pwr1gnrdgb = b*bignrdgb
|
|
IF (pwx1 <= 0.d0 .AND. (q == 0.d0 .OR. q /= INT(q))) THEN
|
|
pwx1gb = 0.d0
|
|
ELSE
|
|
pwx1gb = q*pwx1**(q-1.d0)*pwr1gb
|
|
END IF
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch == 0) THEN
|
|
IF (.NOT.(pwx1 <= 0.d0 .AND. (q - 1.d0 == 0.d0 .OR.
|
|
+ q - 1.d0 /= INT(q - 1.d0)))) pwx1gb = pwx1gb +
|
|
+ pwx1gnrd*q*(q-1)*pwx1**(q-2)*pwr1gnrdgb
|
|
pwx1gnrdgb = q*pwx1**(q-1)*pwr1gnrdgb
|
|
ELSE IF (branch == 1) THEN
|
|
pwx1gnrdgb = pwr1gnrdgb
|
|
ELSE
|
|
pwx1gnrdgb = 0.D0
|
|
END IF
|
|
temp = c*sion + 1.d0
|
|
temp1gb2 = -(xxgnrdgb/temp**2)
|
|
temp1gb1 = 0.5107d0*siongnrd*temp1gb2
|
|
temp0 = cgnrd*sion + c*siongnrd
|
|
temp0gb = -(0.5107d0*sion*temp1gb2)
|
|
tempgb1 = -((0.5107d0*(siongnrd*(c*sion+1.d0))-0.5107d0*(sion*
|
|
+ temp0))*2*temp1gb2/temp)
|
|
temp1gb = -(0.5107d0*xxgb/(c*sion+1.d0))
|
|
temp1gb0 = -(sion*temp1gb/(c*sion+1.d0))
|
|
cgb = sion*temp1gb1 + siongnrd*temp0gb + sion*tempgb1 + sion*
|
|
+ temp1gb0
|
|
cgnrdgb = sion*temp0gb
|
|
tempgb2 = q*.055d0*cgnrdgb
|
|
arg1gb = arg1gnrd*EXP(arg1)*tempgb2 + q*.055d0*EXP(arg1)*cgb
|
|
arg1gnrdgb = EXP(arg1)*tempgb2
|
|
tempgb = -(.023d0*arg1gnrdgb)
|
|
tempgb0 = ionic*tempgb
|
|
ionicgb = ionicgb + (ionicgnrd*2*ionic+ionicgnrd*ionic+ionic*
|
|
+ ionicgnrd)*tempgb - .023d0*3*ionic**2*arg1gb + 2*ionicgnrd*
|
|
+ tempgb0 + .1d0*pwx1gb
|
|
ionicgnrdgb = ionicgnrdgb + 2*ionic*tempgb0 + ionic**2*tempgb +
|
|
+ .1d0*pwx1gnrdgb
|
|
siongb = siongb + c*temp1gb1 - 0.5107d0*temp0*temp1gb2 + cgnrd*
|
|
+ temp0gb + c*tempgb1 + c*temp1gb0 + temp1gb
|
|
siongnrdgb = siongnrdgb + c*temp0gb + 0.5107d0*(c*sion+1.d0)*
|
|
+ temp1gb2
|
|
END
|
|
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of funcg5ab in forward (tangent) mode:
|
|
C variations of useful results: fg5ab
|
|
C with respect to varying inputs: x
|
|
C RW status of diff variables: x:in fg5ab:out
|
|
C
|
|
C
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCG5A
|
|
C *** CASE G5
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCG5AB_GNRD(x, xgnrd, fg5ab, fg5abgnrd)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: psi4gnrd
|
|
REAL*8 :: psi5gnrd
|
|
REAL*8 :: psi6gnrd
|
|
REAL*8 :: a4gnrd
|
|
REAL*8 :: a5gnrd
|
|
REAL*8 :: a6gnrd
|
|
C
|
|
LOGICAL tst
|
|
REAL*8 :: molalrgnrd(npair)
|
|
INTEGER :: so4flg
|
|
REAL*8 :: lamda, fg5a
|
|
INTEGER :: i
|
|
REAL*8 :: akk
|
|
REAL*8 :: bb
|
|
REAL*8 :: bbgnrd
|
|
REAL*8 :: cc
|
|
REAL*8 :: ccgnrd
|
|
REAL*8 :: dd
|
|
REAL*8 :: ddgnrd
|
|
REAL*8 :: smin
|
|
REAL*8 :: smingnrd
|
|
REAL*8 :: hi
|
|
REAL*8 :: hignrd
|
|
REAL*8 :: ohi
|
|
INTEGER :: j
|
|
REAL*8 :: result1
|
|
REAL*8 :: result1gnrd
|
|
REAL*8 :: x
|
|
REAL*8 :: xgnrd
|
|
REAL*8 :: fg5ab
|
|
REAL*8 :: fg5abgnrd
|
|
INTRINSIC MAX
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs9
|
|
REAL*8 :: abs8
|
|
REAL*8 :: abs7
|
|
REAL*8 :: abs6
|
|
REAL*8 :: abs5
|
|
REAL*8 :: abs4
|
|
REAL*8 :: abs3
|
|
REAL*8 :: abs2
|
|
REAL*8 :: abs1
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
psi6gnrd = xgnrd
|
|
psi6 = x
|
|
DO ii1=1,nions
|
|
molalgnrd(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
molalrgnrd(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
gamagnrd(ii1) = 0.D0
|
|
ENDDO
|
|
watergnrd = 0.D0
|
|
ghclgnrd = 0.D0
|
|
a6gnrd = 0.D0
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
C WRITE(*,*) 'NSWEEP ',NSWEEP,'WATER',WATER
|
|
DO i=1,2
|
|
C
|
|
a1 = xk5*(water/gama(2))**3.0
|
|
a2 = xk7*(water/gama(4))**3.0
|
|
a4gnrd = xk2*r*temp*2.0*gama(10)*(gamagnrd(10)*gama(5)-gama(10)*
|
|
+ gamagnrd(5))/(xkw*gama(5)**3)
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
a5gnrd = xk4*r*temp*2.0*water*(watergnrd*gama(10)-water*gamagnrd
|
|
+ (10))/gama(10)**3
|
|
a5 = xk4*r*temp*(water/gama(10))**2.0
|
|
a6gnrd = xk3*r*temp*2.0*water*(watergnrd*gama(11)-water*gamagnrd
|
|
+ (11))/gama(11)**3
|
|
a6 = xk3*r*temp*(water/gama(11))**2.0
|
|
akk = a4*a6
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
IF (chi5 >= tiny) THEN
|
|
psi5gnrd = (chi5*psi6gnrd*(a6/a5*(chi6-psi6)+psi6)-psi6*chi5*(
|
|
+ (a6gnrd*a5-a6*a5gnrd)*(chi6-psi6)/a5**2-a6*psi6gnrd/a5+
|
|
+ psi6gnrd))/(a6/a5*(chi6-psi6)+psi6)**2
|
|
psi5 = psi6*chi5/(a6/a5*(chi6-psi6)+psi6)
|
|
ELSE
|
|
psi5 = tiny
|
|
psi5gnrd = 0.D0
|
|
END IF
|
|
C
|
|
CCC IF(CHI4 > TINY) THEN
|
|
IF (w(2) > tiny) THEN
|
|
C Accounts for NH3 evaporation
|
|
bbgnrd = -(psi6gnrd+psi5gnrd-a4gnrd/a4**2)
|
|
bb = -(chi4+psi6+psi5+1.d0/a4)
|
|
ccgnrd = chi4*(psi5gnrd+psi6gnrd) + 2.d0*psi2*a4gnrd/a4**2
|
|
cc = chi4*(psi5+psi6) - 2.d0*psi2/a4
|
|
IF (bb*bb - 4.d0*cc < zero) THEN
|
|
dd = zero
|
|
ddgnrd = 0.D0
|
|
ELSE
|
|
ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd
|
|
dd = bb*bb - 4.d0*cc
|
|
END IF
|
|
IF (abs(dd) < tiny) THEN
|
|
result1gnrd = 0.D0
|
|
ELSE
|
|
result1gnrd = ddgnrd/(2.0*SQRT(dd))
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
psi4gnrd = 0.5d0*(-bbgnrd-result1gnrd)
|
|
psi4 = 0.5d0*(-bb-result1)
|
|
ELSE
|
|
psi4 = tiny
|
|
psi4gnrd = 0.D0
|
|
END IF
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
C NAI
|
|
molalgnrd(2) = 0.D0
|
|
molal(2) = w(1)
|
|
C MOLAL (3) = 2.0*PSI2 + PSI4 ! NH4I
|
|
C CLI
|
|
molalgnrd(4) = psi6gnrd
|
|
molal(4) = psi6
|
|
IF (w(2) - 0.5d0*w(1) > zero) THEN
|
|
molalgnrd(3) = psi4gnrd
|
|
molal(3) = 2.d0*w(2) - w(1) + psi4
|
|
C SO4I
|
|
molalgnrd(5) = 0.D0
|
|
molal(5) = w(2)
|
|
ELSE
|
|
molalgnrd(3) = psi4gnrd
|
|
molal(3) = psi4
|
|
C SO4I
|
|
molalgnrd(5) = 0.D0
|
|
molal(5) = 0.5d0*w(1)
|
|
END IF
|
|
molalgnrd(6) = 0.D0
|
|
molal(6) = zero
|
|
C NO3I
|
|
molalgnrd(7) = psi5gnrd
|
|
molal(7) = psi5
|
|
C
|
|
C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3)
|
|
smingnrd = psi5gnrd + psi6gnrd - psi4gnrd
|
|
smin = psi5 + psi6 - psi4
|
|
CALL CALCPH_GNRD(smin, smingnrd, hi, hignrd, ohi)
|
|
molalgnrd(1) = hignrd
|
|
molal(1) = hi
|
|
IF (chi4 - psi4 < tiny) THEN
|
|
gnh3 = tiny
|
|
ELSE
|
|
gnh3 = chi4 - psi4
|
|
END IF
|
|
IF (chi5 - psi5 < tiny) THEN
|
|
ghno3 = tiny
|
|
ELSE
|
|
ghno3 = chi5 - psi5
|
|
END IF
|
|
IF (chi6 - psi6 < tiny) THEN
|
|
ghcl = tiny
|
|
ghclgnrd = 0.D0
|
|
ELSE
|
|
ghclgnrd = -psi6gnrd
|
|
ghcl = chi6 - psi6
|
|
END IF
|
|
C
|
|
C Solid (NH4)2SO4
|
|
cnh42s4 = zero
|
|
C Solid NH4NO3
|
|
cnh4no3 = zero
|
|
C Solid NH4Cl
|
|
cnh4cl = zero
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C WRITE(*,*) 'MOLAL ',MOLAL
|
|
C NA2SO4
|
|
molalrgnrd(2) = 0.D0
|
|
molalr(2) = 0.5d0*w(1)
|
|
IF (w(2) - 0.5d0*w(1) >= 0.) THEN
|
|
abs1 = w(2) - 0.5d0*w(1)
|
|
ELSE
|
|
abs1 = -(w(2)-0.5d0*w(1))
|
|
END IF
|
|
IF (abs1 > tiny) THEN
|
|
C WRITE(*,*) 'W(2) - 0.5D0W(1) > ZERO'
|
|
molalrgnrd(4) = 0.D0
|
|
molalr(4) = w(2) - 0.5d0*w(1)
|
|
IF (psi4 >= 0.) THEN
|
|
abs2 = psi4
|
|
ELSE
|
|
abs2 = -psi4
|
|
END IF
|
|
IF (abs2 > tiny) THEN
|
|
C FRNH4,2 = PSI4
|
|
IF (psi5 < psi4) THEN
|
|
C
|
|
molalrgnrd(5) = psi5gnrd
|
|
molalr(5) = psi5
|
|
IF (psi4 - psi5 >= 0.) THEN
|
|
abs3 = psi4 - psi5
|
|
ELSE
|
|
abs3 = -(psi4-psi5)
|
|
END IF
|
|
IF (abs3 > tiny) THEN
|
|
IF (psi6 > psi4 - psi5) THEN
|
|
molalrgnrd(6) = psi4gnrd - psi5gnrd
|
|
molalr(6) = psi4 - psi5
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
ELSE IF (psi6 > zero) THEN
|
|
molalrgnrd(6) = 0.D0
|
|
molalr(6) = zero
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
ELSE
|
|
C FRNH4,2 = ZERO
|
|
molalrgnrd(5) = psi4gnrd
|
|
molalr(5) = psi4
|
|
IF (psi6 > zero) THEN
|
|
molalrgnrd(6) = 0.D0
|
|
molalr(6) = zero
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
END IF
|
|
ELSE
|
|
IF (psi5 >= 0.) THEN
|
|
abs4 = psi5
|
|
ELSE
|
|
abs4 = -psi5
|
|
END IF
|
|
C WRITE(*,*) 'MOLALR(4,5,6)',MOLALR(4),MOLALR(5),MOLALR(6)
|
|
C PAUSE
|
|
IF (abs4 < tiny) THEN
|
|
molalrgnrd(5) = psi5gnrd
|
|
molalr(5) = psi5
|
|
IF (-psi5 >= 0.) THEN
|
|
abs5 = -psi5
|
|
ELSE
|
|
abs5 = psi5
|
|
END IF
|
|
IF (abs5 > tiny) THEN
|
|
IF (psi6 > -psi5) THEN
|
|
molalrgnrd(6) = -psi5gnrd
|
|
molalr(6) = -psi5
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
ELSE IF (psi6 > zero) THEN
|
|
molalrgnrd(6) = 0.D0
|
|
molalr(6) = zero
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
ELSE
|
|
molalrgnrd(5) = 0.D0
|
|
molalr(5) = zero
|
|
IF (psi6 > zero) THEN
|
|
molalrgnrd(6) = 0.D0
|
|
molalr(6) = zero
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
END IF
|
|
END IF
|
|
ELSE
|
|
C W(2) - 0.5D0W(1) < ZERO
|
|
C WRITE(*,*) 'W(2) - 0.5D0W(1) < ZERO'
|
|
molalrgnrd(4) = 0.D0
|
|
molalr(4) = zero
|
|
IF (2.d0*psi2 + psi4 >= 0.) THEN
|
|
abs6 = 2.d0*psi2 + psi4
|
|
ELSE
|
|
abs6 = -(2.d0*psi2+psi4)
|
|
END IF
|
|
IF (abs6 > tiny) THEN
|
|
IF (psi5 < 2.d0*w(2) - w(1) + psi4) THEN
|
|
molalrgnrd(5) = psi5gnrd
|
|
molalr(5) = psi5
|
|
IF (2.d0*w(2) - w(1) + psi4 - psi5 >= 0.) THEN
|
|
abs7 = 2.d0*w(2) - w(1) + psi4 - psi5
|
|
ELSE
|
|
abs7 = -(2.d0*w(2)-w(1)+psi4-psi5)
|
|
END IF
|
|
IF (abs7 > tiny) THEN
|
|
IF (psi6 > 2.d0*w(2) - w(1) + psi4 - psi5) THEN
|
|
molalrgnrd(6) = psi4gnrd - psi5gnrd
|
|
molalr(6) = 2.d0*w(2) - w(1) + psi4 - psi5
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
ELSE IF (psi6 > zero) THEN
|
|
molalrgnrd(6) = 0.D0
|
|
molalr(6) = zero
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
ELSE
|
|
molalrgnrd(5) = psi4gnrd
|
|
molalr(5) = 2.d0*w(2) - w(1) + psi4
|
|
IF (psi6 > zero) THEN
|
|
molalrgnrd(6) = 0.D0
|
|
molalr(6) = zero
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
END IF
|
|
ELSE
|
|
IF (psi5 >= 0.) THEN
|
|
abs8 = psi5
|
|
ELSE
|
|
abs8 = -psi5
|
|
END IF
|
|
IF (abs8 < tiny) THEN
|
|
molalrgnrd(5) = psi5gnrd
|
|
molalr(5) = psi5
|
|
IF (-psi5 >= 0.) THEN
|
|
abs9 = -psi5
|
|
ELSE
|
|
abs9 = psi5
|
|
END IF
|
|
IF (abs9 < tiny) THEN
|
|
IF (psi6 > -psi5) THEN
|
|
molalrgnrd(6) = -psi5gnrd
|
|
molalr(6) = -psi5
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
ELSE IF (psi6 > zero) THEN
|
|
molalrgnrd(6) = 0.D0
|
|
molalr(6) = zero
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
ELSE
|
|
molalrgnrd(5) = 0.D0
|
|
molalr(5) = zero
|
|
IF (psi6 > zero) THEN
|
|
molalrgnrd(6) = 0.D0
|
|
molalr(6) = zero
|
|
ELSE
|
|
molalrgnrd(6) = psi6gnrd
|
|
molalr(6) = psi6
|
|
END IF
|
|
END IF
|
|
END IF
|
|
END IF
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
watergnrd = 0.D0
|
|
DO j=1,npair
|
|
watergnrd = watergnrd + molalrgnrd(j)/m0(j)
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
watergnrd = 0.D0
|
|
ELSE
|
|
water = water
|
|
END IF
|
|
C WRITE(*,*) 'After CALCMR: WATER ',WATER
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3P_GNRD()
|
|
ENDDO
|
|
C
|
|
C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP ***************************
|
|
C
|
|
fg5abgnrd = (((molalgnrd(1)*molal(4)+molal(1)*molalgnrd(4))*ghcl-
|
|
+ molal(1)*molal(4)*ghclgnrd)*a6/ghcl**2-molal(1)*molal(4)*a6gnrd/
|
|
+ ghcl)/a6**2
|
|
fg5ab = molal(1)*molal(4)/ghcl/a6 - one
|
|
CCC FUNCG5A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C
|
|
C Differentiation of calcph in forward (tangent) mode:
|
|
C variations of useful results: hi
|
|
C with respect to varying inputs: water gg
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCPH
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCPH_GNRD(gg, gggnrd, hi, hignrd, ohi)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: cn, gg, hi, ohi, bb, cc, dd
|
|
REAL*8 :: cngnrd, gggnrd, hignrd, ohignrd, bbgnrd, ccgnrd,
|
|
+ ddgnrd
|
|
REAL*8 :: akw
|
|
REAL*8 :: akwgnrd
|
|
REAL*8 :: result1
|
|
REAL*8 :: result1gnrd
|
|
REAL*8 :: x2gnrd
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1gnrd
|
|
REAL*8 :: x1
|
|
INTRINSIC SQRT
|
|
C
|
|
akwgnrd = xkw*rh*(watergnrd*water+water*watergnrd)
|
|
akw = xkw*rh*water*water
|
|
IF (abs(akw) < tiny) THEN
|
|
cngnrd = 0.D0
|
|
ELSE
|
|
cngnrd = akwgnrd/(2.0*SQRT(akw))
|
|
END IF
|
|
cn = SQRT(akw)
|
|
C
|
|
C *** GG = (negative charge) - (positive charge)
|
|
C
|
|
IF (gg > tiny) THEN
|
|
C H+ in excess
|
|
bbgnrd = -gggnrd
|
|
bb = -gg
|
|
ccgnrd = -akwgnrd
|
|
cc = -akw
|
|
ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (abs(dd) < tiny) THEN
|
|
result1gnrd = 0.D0
|
|
ELSE
|
|
result1gnrd = ddgnrd/(2.0*SQRT(dd))
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
x1gnrd = 0.5d0*(result1gnrd-bbgnrd)
|
|
x1 = 0.5d0*(-bb+result1)
|
|
IF (x1 < cn) THEN
|
|
hignrd = cngnrd
|
|
hi = cn
|
|
ELSE
|
|
hignrd = x1gnrd
|
|
hi = x1
|
|
END IF
|
|
ohi = akw/hi
|
|
ELSE
|
|
C OH- in excess
|
|
bbgnrd = gggnrd
|
|
bb = gg
|
|
ccgnrd = -akwgnrd
|
|
cc = -akw
|
|
ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (ABS(dd) < tiny) THEN
|
|
result1gnrd = 0.D0
|
|
ELSE
|
|
result1gnrd = ddgnrd/(2.0*SQRT(dd))
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
x2gnrd = 0.5d0*(result1gnrd-bbgnrd)
|
|
x2 = 0.5d0*(-bb+result1)
|
|
IF (x2 < cn) THEN
|
|
ohignrd = cngnrd
|
|
ohi = cn
|
|
ELSE
|
|
ohignrd = x2gnrd
|
|
ohi = x2
|
|
END IF
|
|
hignrd = (akwgnrd*ohi-akw*ohignrd)/ohi**2
|
|
hi = akw/ohi
|
|
END IF
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C Differentiation of calcact3p in forward (tangent) mode:
|
|
C variations of useful results: gama
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3P_GNRD()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0gnrd(6, 4), siongnrd, hgnrd, chgnrd, f1gnrd(3)
|
|
+ , f2gnrd(4)
|
|
REAL*8 :: mpl, xij, yji
|
|
REAL*8 :: mplgnrd, xijgnrd, yjignrd, ionicgnrd
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01gnrd
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02gnrd
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03gnrd
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04gnrd
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05gnrd
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06gnrd
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07gnrd
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08gnrd
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09gnrd
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10gnrd
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11gnrd
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12gnrd
|
|
INTEGER :: j
|
|
REAL*8 :: x2gnrd
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1gnrd
|
|
REAL*8 :: x1
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
ionicgnrd = 0.D0
|
|
DO i=1,7
|
|
ionicgnrd = ionicgnrd + z(i)**2*molalgnrd(i)
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
x1gnrd = 0.D0
|
|
ELSE
|
|
x1gnrd = (0.5d0*ionicgnrd*water-0.5d0*ionic*watergnrd)/water**2
|
|
x1 = 0.5d0*ionic/water
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
ionic = tiny
|
|
ionicgnrd = 0.D0
|
|
ELSE
|
|
ionicgnrd = x1gnrd
|
|
ionic = x1
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3_GNRD(ionic, ionicgnrd, temp, g01, g01gnrd, g02,
|
|
+ g02gnrd, g03, g03gnrd, g04, g04gnrd, g05, g05gnrd
|
|
+ , g06, g06gnrd, g07, g07gnrd, g08, g08gnrd, g09,
|
|
+ g09gnrd, g10, g10gnrd, g11, g11gnrd, g12, g12gnrd
|
|
+ )
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0gnrd(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
g0gnrd(1, 1) = g11gnrd
|
|
g0(1, 1) = g11
|
|
g0gnrd(1, 2) = g07gnrd
|
|
g0(1, 2) = g07
|
|
g0gnrd(1, 3) = g08gnrd
|
|
g0(1, 3) = g08
|
|
g0gnrd(1, 4) = g10gnrd
|
|
g0(1, 4) = g10
|
|
g0gnrd(2, 1) = g01gnrd
|
|
g0(2, 1) = g01
|
|
g0gnrd(2, 2) = g02gnrd
|
|
g0(2, 2) = g02
|
|
g0gnrd(2, 3) = g12gnrd
|
|
g0(2, 3) = g12
|
|
g0gnrd(2, 4) = g03gnrd
|
|
g0(2, 4) = g03
|
|
g0gnrd(3, 1) = g06gnrd
|
|
g0(3, 1) = g06
|
|
g0gnrd(3, 2) = g04gnrd
|
|
g0(3, 2) = g04
|
|
g0gnrd(3, 3) = g09gnrd
|
|
g0(3, 3) = g09
|
|
g0gnrd(3, 4) = g05gnrd
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
IF (abs(ionic) < tiny) THEN
|
|
siongnrd = 0.D0
|
|
ELSE
|
|
siongnrd = ionicgnrd/(2.0*SQRT(ionic))
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
hgnrd = (agama*siongnrd*(1.d0+sion)-agama*sion*siongnrd)/(1.d0+
|
|
+ sion)**2
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1gnrd(i) = 0.D0
|
|
f1(i) = 0.d0
|
|
f2gnrd(i) = 0.D0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2gnrd(4) = 0.D0
|
|
f2(4) = 0.d0
|
|
DO ii1=1,3
|
|
f1gnrd(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2gnrd(ii1) = 0.D0
|
|
ENDDO
|
|
C
|
|
DO i=1,3
|
|
zpl = z(i)
|
|
mplgnrd = (molalgnrd(i)*water-molal(i)*watergnrd)/water**2
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
chgnrd = -(0.25d0*(zpl+zmi)**2*ionicgnrd/ionic**2)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xijgnrd = chgnrd*mpl + ch*mplgnrd
|
|
xij = ch*mpl
|
|
yjignrd = ((chgnrd*molal(j+3)+ch*molalgnrd(j+3))*water-ch*
|
|
+ molal(j+3)*watergnrd)/water**2
|
|
yji = ch*molal(j+3)/water
|
|
f1gnrd(i) = f1gnrd(i) + yjignrd*(g0(i, j)+zpl*zmi*h) + yji*(
|
|
+ g0gnrd(i, j)+zpl*zmi*hgnrd)
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2gnrd(j) = f2gnrd(j) + xijgnrd*(g0(i, j)+zpl*zmi*h) + xij*(
|
|
+ g0gnrd(i, j)+zpl*zmi*hgnrd)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gamagnrd(1) = zz(1)*((f1gnrd(2)/z(2)+f2gnrd(1)/z(4))/(z(2)+z(4))-
|
|
+ hgnrd)
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gamagnrd(2) = zz(2)*((f1gnrd(2)/z(2)+f2gnrd(2)/z(5))/(z(2)+z(5))-
|
|
+ hgnrd)
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gamagnrd(3) = zz(3)*((f1gnrd(2)/z(2)+f2gnrd(4)/z(7))/(z(2)+z(7))-
|
|
+ hgnrd)
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gamagnrd(4) = zz(4)*((f1gnrd(3)/z(3)+f2gnrd(2)/z(5))/(z(3)+z(5))-
|
|
+ hgnrd)
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gamagnrd(5) = zz(5)*((f1gnrd(3)/z(3)+f2gnrd(4)/z(7))/(z(3)+z(7))-
|
|
+ hgnrd)
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gamagnrd(6) = zz(6)*((f1gnrd(3)/z(3)+f2gnrd(1)/z(4))/(z(3)+z(4))-
|
|
+ hgnrd)
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gamagnrd(7) = zz(7)*((f1gnrd(1)/z(1)+f2gnrd(2)/z(5))/(z(1)+z(5))-
|
|
+ hgnrd)
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gamagnrd(8) = zz(8)*((f1gnrd(1)/z(1)+f2gnrd(3)/z(6))/(z(1)+z(6))-
|
|
+ hgnrd)
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gamagnrd(9) = zz(9)*((f1gnrd(3)/z(3)+f2gnrd(3)/z(6))/(z(3)+z(6))-
|
|
+ hgnrd)
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gamagnrd(10) = zz(10)*((f1gnrd(1)/z(1)+f2gnrd(4)/z(7))/(z(1)+z(7))
|
|
+ -hgnrd)
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gamagnrd(11) = zz(11)*((f1gnrd(1)/z(1)+f2gnrd(1)/z(4))/(z(1)+z(4))
|
|
+ -hgnrd)
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gamagnrd(12) = zz(12)*((f1gnrd(2)/z(2)+f2gnrd(3)/z(6))/(z(2)+z(6))
|
|
+ -hgnrd)
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
C LC ; SCAPE
|
|
gamagnrd(13) = 0.2d0*(3.d0*gamagnrd(4)+2.d0*gamagnrd(9))
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
x2 = 5.0d0
|
|
x2gnrd = 0.D0
|
|
ELSE
|
|
x2gnrd = gamagnrd(i)
|
|
x2 = gama(i)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
gamagnrd(i) = 0.D0
|
|
gama(i) = -5.0d0
|
|
ELSE
|
|
gamagnrd(i) = x2gnrd
|
|
gama(i) = x2
|
|
END IF
|
|
gamagnrd(i) = 10.d0**gama(i)*LOG(10.d0)*gamagnrd(i)
|
|
gama(i) = 10.d0**gama(i)
|
|
ENDDO
|
|
C
|
|
C Increment ACTIVITY call counter
|
|
iclact = iclact + 1
|
|
C
|
|
C *** END OF SUBROUTINE ACTIVITY ****************************************
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C Differentiation of kmful3 in forward (tangent) mode:
|
|
C variations of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_GNRD(ionic, ionicgnrd, temp, g01, g01gnrd, g02,
|
|
+ g02gnrd, g03, g03gnrd, g04, g04gnrd, g05,
|
|
+ g05gnrd, g06, g06gnrd, g07, g07gnrd, g08,
|
|
+ g08gnrd, g09, g09gnrd, g10, g10gnrd, g11,
|
|
+ g11gnrd, g12, g12gnrd)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionicgnrd, siongnrd, cf2gnrd
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01gnrd, g02gnrd, g03gnrd, g04gnrd, g05gnrd,
|
|
+ g06gnrd, g07gnrd, g08gnrd, g09gnrd, g10gnrd,
|
|
+ g11gnrd, g12gnrd
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs1, tiny
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
tiny = 1.d-20
|
|
C
|
|
IF (abs(ionic) < tiny) THEN
|
|
siongnrd = 0.D0
|
|
ELSE
|
|
siongnrd = ionicgnrd/(2.0*SQRT(ionic))
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
CALL MKBI_GNRD(q1, ionic, ionicgnrd, sion, siongnrd, z01, g01,
|
|
+ g01gnrd)
|
|
CALL MKBI_GNRD(q2, ionic, ionicgnrd, sion, siongnrd, z02, g02,
|
|
+ g02gnrd)
|
|
CALL MKBI_GNRD(q3, ionic, ionicgnrd, sion, siongnrd, z03, g03,
|
|
+ g03gnrd)
|
|
CALL MKBI_GNRD(q4, ionic, ionicgnrd, sion, siongnrd, z04, g04,
|
|
+ g04gnrd)
|
|
CALL MKBI_GNRD(q5, ionic, ionicgnrd, sion, siongnrd, z05, g05,
|
|
+ g05gnrd)
|
|
CALL MKBI_GNRD(q6, ionic, ionicgnrd, sion, siongnrd, z06, g06,
|
|
+ g06gnrd)
|
|
CALL MKBI_GNRD(q7, ionic, ionicgnrd, sion, siongnrd, z07, g07,
|
|
+ g07gnrd)
|
|
CALL MKBI_GNRD(q8, ionic, ionicgnrd, sion, siongnrd, z08, g08,
|
|
+ g08gnrd)
|
|
CALL MKBI_GNRD(q10, ionic, ionicgnrd, sion, siongnrd, z10, g10,
|
|
+ g10gnrd)
|
|
CALL MKBI_GNRD(q11, ionic, ionicgnrd, sion, siongnrd, z11, g11,
|
|
+ g11gnrd)
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.d0) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
cf2gnrd = (0.125d0-0.005d0*ti)*(0.039d0*0.92d0*ionic**(-0.8D0)*
|
|
+ ionicgnrd-(0.41d0*siongnrd*(1.d0+sion)-0.41d0*sion*siongnrd)/(
|
|
+ 1.d0+sion)**2)
|
|
cf2 = (0.125d0-0.005d0*ti)*(0.039d0*ionic**0.92d0-0.41d0*sion/(
|
|
+ 1.d0+sion))
|
|
g01gnrd = cf1*g01gnrd - z01*cf2gnrd
|
|
g01 = cf1*g01 - cf2*z01
|
|
g02gnrd = cf1*g02gnrd - z02*cf2gnrd
|
|
g02 = cf1*g02 - cf2*z02
|
|
g03gnrd = cf1*g03gnrd - z03*cf2gnrd
|
|
g03 = cf1*g03 - cf2*z03
|
|
g04gnrd = cf1*g04gnrd - z04*cf2gnrd
|
|
g04 = cf1*g04 - cf2*z04
|
|
g05gnrd = cf1*g05gnrd - z05*cf2gnrd
|
|
g05 = cf1*g05 - cf2*z05
|
|
g06gnrd = cf1*g06gnrd - z06*cf2gnrd
|
|
g06 = cf1*g06 - cf2*z06
|
|
g07gnrd = cf1*g07gnrd - z07*cf2gnrd
|
|
g07 = cf1*g07 - cf2*z07
|
|
g08gnrd = cf1*g08gnrd - z08*cf2gnrd
|
|
g08 = cf1*g08 - cf2*z08
|
|
g10gnrd = cf1*g10gnrd - z10*cf2gnrd
|
|
g10 = cf1*g10 - cf2*z10
|
|
g11gnrd = cf1*g11gnrd - z11*cf2gnrd
|
|
g11 = cf1*g11 - cf2*z11
|
|
END IF
|
|
C
|
|
g09gnrd = g06gnrd + g08gnrd - g11gnrd
|
|
g09 = g06 + g08 - g11
|
|
g12gnrd = g01gnrd + g08gnrd - g11gnrd
|
|
g12 = g01 + g08 - g11
|
|
C
|
|
C *** Return point ; End of subroutine
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C Differentiation of mkbi in forward (tangent) mode:
|
|
C variations of useful results: bi
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_GNRD(q, ionic, ionicgnrd, sion, siongnrd, zip, bi
|
|
+ , bignrd)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionicgnrd, siongnrd, bignrd
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: cgnrd, xxgnrd
|
|
REAL*8 :: arg1
|
|
REAL*8 :: arg1gnrd
|
|
REAL*8 :: pwx1
|
|
REAL*8 :: pwx1gnrd
|
|
REAL*8 :: pwr1
|
|
REAL*8 :: pwr1gnrd, tiny
|
|
INTRINSIC EXP
|
|
INTRINSIC LOG10
|
|
tiny = 1.d-20
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
arg1gnrd = -(.023d0*((ionicgnrd*ionic+ionic*ionicgnrd)*ionic+ionic
|
|
+ **2*ionicgnrd))
|
|
arg1 = -(.023d0*ionic*ionic*ionic)
|
|
cgnrd = .055d0*q*arg1gnrd*EXP(arg1)
|
|
c = 1. + .055d0*q*EXP(arg1)
|
|
xxgnrd = -((0.5107d0*siongnrd*(1.d0+c*sion)-0.5107d0*sion*(cgnrd*
|
|
+ sion+c*siongnrd))/(1.d0+c*sion)**2)
|
|
xx = -(0.5107d0*sion/(1.d0+c*sion))
|
|
pwx1gnrd = .1d0*ionicgnrd
|
|
pwx1 = 1.d0 + .1d0*ionic
|
|
IF (pwx1 > 0.d0 .OR. (pwx1 < 0.d0
|
|
& .AND. (q-INT(q)) < tiny)) THEN
|
|
pwr1gnrd = q*pwx1**(q-1)*pwx1gnrd
|
|
ELSE IF (abs(pwx1) < TINY .AND. abs(q-1.d0) < tiny) THEN
|
|
pwr1gnrd = pwx1gnrd
|
|
ELSE
|
|
pwr1gnrd = 0.d0
|
|
END IF
|
|
pwr1 = pwx1**q
|
|
bignrd = b*pwr1gnrd
|
|
bi = 1.d0 + b*pwr1 - b
|
|
bignrd = zip*bignrd/(bi*LOG(10.d0)) + zip*xxgnrd
|
|
bi = zip*LOG10(bi) + zip*xx
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C
|
|
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of funch6ap in reverse (adjoint) mode:
|
|
C gradient of useful results: aerliq gas
|
|
C with respect to varying inputs: wp aerliq gas
|
|
C RW status of diff variables: wp:out aerliq:in-out gas:in-out
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCH6AB
|
|
C *** CASE H6
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCH6AP_HB(x1, wphb, gashb, aerliqhb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: aerliq(NIONS+NGASAQ+2), gas(3)
|
|
REAL*8 :: aerliqhb(NIONS+NGASAQ+2), gashb(3), wphb(ncomp)
|
|
REAL*8 :: whb(ncomp)
|
|
CHARACTER(LEN=40) ERRINF
|
|
INTEGER :: errstki(25)
|
|
CHARACTER(LEN=40) errmsgi(25)
|
|
REAL*8 :: feps
|
|
REAL*8 :: frna
|
|
REAL*8 :: frnahb
|
|
REAL*8 :: xt
|
|
REAL*8 :: xtd
|
|
REAL*8 :: y1
|
|
REAL*8 :: y1hb
|
|
REAL*8 :: y1d
|
|
REAL*8 :: y1dhb
|
|
REAL*8 :: x2
|
|
REAL*8 :: x2hb
|
|
REAL*8 :: y2
|
|
REAL*8 :: delta
|
|
REAL*8 :: deltahb
|
|
INTEGER :: i
|
|
INTEGER :: branch
|
|
REAL*8 :: x1
|
|
INTRINSIC MAX
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs1
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
REAL*8 :: max1
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
feps = 1.d-5
|
|
C CNA2SO4
|
|
chi1 = w(2)
|
|
C CNH42S4
|
|
C CNH4CL
|
|
IF (w(1) - 2.d0*w(2) < zero) THEN
|
|
!WRITE(*,*) 'First in H6, PUSHCONTROL1B: 0, before'
|
|
CALL PUSHCONTROL1B(0)
|
|
!WRITE(*,*) 'First in H6, PUSHCONTROL1B: 0, after'
|
|
frna = zero
|
|
ELSE
|
|
frna = w(1) - 2.d0*w(2)
|
|
!WRITE(*,*) 'First in H6, PUSHCONTROL1B: 0, before'
|
|
CALL PUSHCONTROL1B(1)
|
|
!WRITE(*,*) 'First in H6, PUSHCONTROL1B: 0, after'
|
|
END IF
|
|
IF (frna > w(4)) THEN
|
|
chi8 = w(4)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
chi8 = frna
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C NH3(g)
|
|
chi4 = w(3)
|
|
C CHI5 = MAX (W(4)-CHI8, ZERO) ! HNO3(g)
|
|
C CHI7 = MIN (MAX(FRNA-CHI8, ZERO), W(5)) ! CNACL
|
|
C CHI6 = MAX (W(5)-CHI7, ZERO) ! HCL(g)
|
|
IF (frna < w(4)) THEN
|
|
IF (w(4) - frna < zero) THEN
|
|
chi5 = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
chi5 = w(4) - frna
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (zero > w(5)) THEN
|
|
chi7 = w(5)
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
chi7 = zero
|
|
END IF
|
|
IF (w(5) < zero) THEN
|
|
chi6 = zero
|
|
CALL PUSHCONTROL3B(2)
|
|
ELSE
|
|
chi6 = w(5)
|
|
CALL PUSHCONTROL3B(1)
|
|
END IF
|
|
ELSE
|
|
chi5 = zero
|
|
IF (frna - w(4) < zero) THEN
|
|
max1 = zero
|
|
ELSE
|
|
max1 = frna - w(4)
|
|
END IF
|
|
IF (max1 < w(5)) THEN
|
|
IF (frna - w(4) < zero) THEN
|
|
chi7 = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
chi7 = frna - w(4)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (w(5) - chi7 < zero) THEN
|
|
chi6 = zero
|
|
CALL PUSHCONTROL3B(4)
|
|
ELSE
|
|
chi6 = w(5) - chi7
|
|
CALL PUSHCONTROL3B(3)
|
|
END IF
|
|
ELSE
|
|
chi7 = w(5)
|
|
chi6 = zero
|
|
CALL PUSHCONTROL3B(0)
|
|
END IF
|
|
END IF
|
|
C
|
|
C
|
|
C *** NEWTON-RAPHSON DETERMINATION OF ROOT **********************
|
|
C
|
|
xt = x1
|
|
xtd = 1.d0
|
|
CALL PUSHREAL8ARRAY(gamahnrd, npair)
|
|
CALL PUSHREAL8ARRAY(molalhnrd, nions)
|
|
CALL PUSHINTEGER4(iclact)
|
|
CALL PUSHREAL8(water)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
CALL PUSHREAL8ARRAY(molalr, npair)
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
CALL FUNCH6AB_HNRD(xt, xtd, y1, y1d)
|
|
x2 = xt - y1/(y1d*1.d0)
|
|
CALL PUSHINTEGER4(iclact)
|
|
CALL PUSHREAL8(water)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
CALL PUSHREAL8ARRAY(molalr, npair)
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
CALL FUNCH6AB(x2, y2)
|
|
IF (y2 >= 0.) THEN
|
|
abs1 = y2
|
|
ELSE
|
|
abs1 = -y2
|
|
END IF
|
|
C
|
|
IF (abs1 > 10.d0*feps) THEN
|
|
DO ii1=1,nions
|
|
molalhb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
gamahb(ii1) = 0.D0
|
|
ENDDO
|
|
waterhb = 0.D0
|
|
gnh3hb = 0.D0
|
|
ghno3hb = 0.D0
|
|
ghclhb = 0.D0
|
|
WRITE(ERRINF, '(A,E12.5,A)') 'CALCH6 (',(abs1),')'
|
|
CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE
|
|
! WRITE(*,*) 'W: ',W
|
|
! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP
|
|
! WRITE(*,*) 'FUNCH6AP_HB, after NR - Err 104: ',abs1
|
|
! RETURN
|
|
ELSE
|
|
C
|
|
C CALL FUNCH6AB(XT,Y2)
|
|
C
|
|
IF (molal(1) > tiny .AND. molal(5) > tiny) THEN
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
ghclhb = gashb(3)
|
|
gashb(3) = 0.D0
|
|
ghno3hb = gashb(2)
|
|
gashb(2) = 0.D0
|
|
gnh3hb = gashb(1)
|
|
gashb(1) = 0.D0
|
|
aerliqhb(nions+ngasaq+2) = 0.D0
|
|
waterhb = 1.0d3*aerliqhb(nions+1)/18.0d0
|
|
aerliqhb(nions+1) = 0.D0
|
|
DO i=ngasaq,1,-1
|
|
aerliqhb(nions+1+i) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,nions
|
|
molalhb(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=nions,1,-1
|
|
molalhb(i) = molalhb(i) + aerliqhb(i)
|
|
aerliqhb(i) = 0.D0
|
|
ENDDO
|
|
!WRITE(*,*) 'First in H6, POPCONTROL1B: 0, before'
|
|
CALL POPCONTROL1B(branch)
|
|
!WRITE(*,*) 'First in H6, POPCONTROL1B: 0, after'
|
|
IF (branch == 0) THEN
|
|
DO ii1=1,npair
|
|
gamahb(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
deltahb = molalhb(6)
|
|
molalhb(6) = 0.D0
|
|
deltahb = deltahb - molalhb(1) - molalhb(5)
|
|
CALL CALCHS4_HB(molal(1), molalhb(1), molal(5), molalhb(5),
|
|
+ zero, delta, deltahb)
|
|
END IF
|
|
END IF
|
|
!WRITE(*,*) 'First in H6, POPREAL8ARRAY, before'
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
!WRITE(*,*) 'First in H6, POPREAL8ARRAY, after'
|
|
CALL POPREAL8ARRAY(molalr, npair)
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPREAL8(water)
|
|
CALL POPINTEGER4(iclact)
|
|
CALL FUNCH6AB_HB(x2, x2hb, y2)
|
|
y1hb = -(x2hb/y1d)
|
|
y1dhb = y1*x2hb/y1d**2
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL POPREAL8ARRAY(molalr, npair)
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPREAL8(water)
|
|
CALL POPINTEGER4(iclact)
|
|
CALL POPREAL8ARRAY(molalhnrd, nions)
|
|
CALL POPREAL8ARRAY(gamahnrd, npair)
|
|
CALL FUNCH6AB_HNRD_HB(xt, xtd, y1, y1hb, y1d, y1dhb)
|
|
CALL POPCONTROL3B(branch)
|
|
IF (branch < 2) THEN
|
|
IF (branch == 0) THEN
|
|
DO ii1=1,ncomp
|
|
whb(ii1) = 0.D0
|
|
ENDDO
|
|
whb(5) = whb(5) + chi7hb
|
|
frnahb = 0.D0
|
|
GOTO 100
|
|
ELSE
|
|
DO ii1=1,ncomp
|
|
whb(ii1) = 0.D0
|
|
ENDDO
|
|
whb(5) = whb(5) + chi6hb
|
|
END IF
|
|
ELSE IF (branch == 2) THEN
|
|
DO ii1=1,ncomp
|
|
whb(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
IF (branch == 3) THEN
|
|
DO ii1=1,ncomp
|
|
whb(ii1) = 0.D0
|
|
ENDDO
|
|
whb(5) = whb(5) + chi6hb
|
|
chi7hb = chi7hb - chi6hb
|
|
ELSE
|
|
DO ii1=1,ncomp
|
|
whb(ii1) = 0.D0
|
|
ENDDO
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
frnahb = 0.D0
|
|
ELSE
|
|
frnahb = chi7hb
|
|
whb(4) = whb(4) - chi7hb
|
|
END IF
|
|
GOTO 100
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) whb(5) = whb(5) + chi7hb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
frnahb = 0.D0
|
|
ELSE
|
|
whb(4) = whb(4) + chi5hb
|
|
frnahb = -chi5hb
|
|
END IF
|
|
100 whb(3) = whb(3) + chi4hb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
whb(4) = whb(4) + chi8hb
|
|
ELSE
|
|
frnahb = frnahb + chi8hb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
whb(1) = whb(1) + frnahb
|
|
whb(2) = whb(2) - 2.d0*frnahb
|
|
END IF
|
|
whb(2) = whb(2) + chi1hb
|
|
DO ii1=1,5
|
|
wphb(ii1) = 0.D0
|
|
ENDDO
|
|
wphb = whb
|
|
END
|
|
|
|
C Differentiation of funch6ab in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water gnh3 ghno3
|
|
C ghcl
|
|
C with respect to varying inputs: molal molalr gama water gnh3
|
|
C ghno3 ghcl chi1 chi4 chi5 chi6 chi7 chi8 x
|
|
C
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCH6AB
|
|
C *** CASE H6
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCH6AB_HB(x, xhb, fh6ab)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: psi1hb
|
|
REAL*8 :: psi4hb
|
|
REAL*8 :: psi5hb
|
|
REAL*8 :: psi6hb
|
|
REAL*8 :: psi7hb
|
|
REAL*8 :: psi8hb
|
|
REAL*8 :: a4hb
|
|
REAL*8 :: a5hb
|
|
REAL*8 :: a6hb
|
|
C
|
|
INTEGER :: j
|
|
INTEGER :: i
|
|
REAL*8 :: bb
|
|
REAL*8 :: bbhb
|
|
REAL*8 :: cc
|
|
REAL*8 :: cchb
|
|
REAL*8 :: dd
|
|
REAL*8 :: ddhb
|
|
REAL*8 :: smin
|
|
REAL*8 :: sminhb
|
|
REAL*8 :: hi
|
|
REAL*8 :: hihb
|
|
REAL*8 :: ohi
|
|
REAL*8 :: frno3
|
|
REAL*8 :: frno3hb
|
|
REAL*8 :: frcl
|
|
REAL*8 :: frclhb
|
|
REAL*8 :: frnh4
|
|
REAL*8 :: frnh4hb
|
|
INTEGER :: branch
|
|
REAL*8 :: fh6ab
|
|
REAL*8 :: x
|
|
REAL*8 :: xhb
|
|
REAL*8 :: temp3
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp5hb
|
|
REAL*8 :: temp0hb
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp3hb
|
|
REAL*8 :: temp1hb
|
|
REAL*8 :: temp4hb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp5
|
|
REAL*8 :: temp4
|
|
REAL*8 :: temp2hb
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
psi6 = x
|
|
psi1 = chi1
|
|
psi2 = zero
|
|
psi3 = zero
|
|
psi7 = chi7
|
|
psi8 = chi8
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
DO i=1,2
|
|
C
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
a5 = xk4*r*temp*(water/gama(10))**2.0
|
|
a6 = xk3*r*temp*(water/gama(11))**2.0
|
|
CALL PUSHREAL8(psi5)
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
psi5 = chi5*(psi6+psi7) - a6/a5*psi8*(chi6-psi6-psi3)
|
|
CALL PUSHREAL8(psi5)
|
|
psi5 = psi5/(a6/a5*(chi6-psi6-psi3)+psi6+psi7)
|
|
IF (psi5 < tiny) THEN
|
|
psi5 = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
psi5 = psi5
|
|
END IF
|
|
C
|
|
IF (w(3) > tiny .AND. water > tiny) THEN
|
|
CALL PUSHREAL8(bb)
|
|
C First try 3rd order soln
|
|
bb = -(chi4+psi6+psi5+1.d0/a4)
|
|
cc = chi4*(psi5+psi6)
|
|
dd = bb*bb - 4.d0*cc
|
|
psi4 = 0.5d0*(-bb-SQRT(dd))
|
|
IF (psi4 > chi4) THEN
|
|
psi4 = chi4
|
|
CALL PUSHCONTROL2B(2)
|
|
ELSE
|
|
CALL PUSHCONTROL2B(1)
|
|
psi4 = psi4
|
|
END IF
|
|
ELSE
|
|
psi4 = tiny
|
|
CALL PUSHCONTROL2B(0)
|
|
END IF
|
|
CALL PUSHREAL8(molal(2))
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
C NAI
|
|
molal(2) = psi8 + psi7 + 2.d0*psi1
|
|
CALL PUSHREAL8(molal(3))
|
|
C NH4I
|
|
molal(3) = psi4
|
|
CALL PUSHREAL8(molal(4))
|
|
C CLI
|
|
molal(4) = psi6 + psi7
|
|
CALL PUSHREAL8(molal(5))
|
|
C SO4I
|
|
molal(5) = psi2 + psi1
|
|
CALL PUSHREAL8(molal(6))
|
|
C HSO4I
|
|
molal(6) = zero
|
|
CALL PUSHREAL8(molal(7))
|
|
C NO3I
|
|
molal(7) = psi5 + psi8
|
|
CALL PUSHREAL8(smin)
|
|
C
|
|
C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3)
|
|
smin = 2.d0*psi2 + psi5 + psi6 - psi4
|
|
CALL CALCPH(smin, hi, ohi)
|
|
CALL PUSHREAL8(molal(1))
|
|
molal(1) = hi
|
|
IF (chi4 - psi4 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (chi5 - psi5 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (chi6 - psi6 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM RICH CASE
|
|
C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/
|
|
C
|
|
C NACL
|
|
molalr(1) = psi7
|
|
C NA2SO4
|
|
molalr(2) = psi1
|
|
C NANO3
|
|
molalr(3) = psi8
|
|
C (NH4)2SO4
|
|
molalr(4) = zero
|
|
IF (psi5 < zero) THEN
|
|
frno3 = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
frno3 = psi5
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (psi6 < zero) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
frcl = zero
|
|
ELSE
|
|
frcl = psi6
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3
|
|
C FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3
|
|
C MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL
|
|
IF (psi4 < frno3) THEN
|
|
molalr(5) = psi4
|
|
IF (frcl > zero) THEN
|
|
molalr(6) = zero
|
|
CALL PUSHCONTROL2B(1)
|
|
ELSE
|
|
molalr(6) = frcl
|
|
CALL PUSHCONTROL2B(0)
|
|
END IF
|
|
ELSE
|
|
molalr(5) = frno3
|
|
IF (psi4 - frno3 < zero) THEN
|
|
frnh4 = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
frnh4 = psi4 - frno3
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (frcl > frnh4) THEN
|
|
molalr(6) = frnh4
|
|
CALL PUSHCONTROL2B(3)
|
|
ELSE
|
|
molalr(6) = frcl
|
|
CALL PUSHCONTROL2B(2)
|
|
END IF
|
|
END IF
|
|
CALL PUSHREAL8(water)
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
DO j=1,npair
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3P()
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
molalrhb(ii1) = 0.D0
|
|
ENDDO
|
|
chi4hb = 0.D0
|
|
chi5hb = 0.D0
|
|
chi6hb = 0.D0
|
|
psi1hb = 0.D0
|
|
psi6hb = 0.D0
|
|
psi7hb = 0.D0
|
|
psi8hb = 0.D0
|
|
DO i=2,1,-1
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3P_HB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) waterhb = 0.D0
|
|
DO j=npair,1,-1
|
|
molalrhb(j) = molalrhb(j) + waterhb/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(water)
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch < 2) THEN
|
|
IF (branch == 0) THEN
|
|
frclhb = molalrhb(6)
|
|
molalrhb(6) = 0.D0
|
|
ELSE
|
|
molalrhb(6) = 0.D0
|
|
frclhb = 0.D0
|
|
END IF
|
|
psi4hb = molalrhb(5)
|
|
molalrhb(5) = 0.D0
|
|
frno3hb = 0.D0
|
|
ELSE
|
|
IF (branch == 2) THEN
|
|
frclhb = molalrhb(6)
|
|
molalrhb(6) = 0.D0
|
|
frnh4hb = 0.D0
|
|
ELSE
|
|
frnh4hb = molalrhb(6)
|
|
molalrhb(6) = 0.D0
|
|
frclhb = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
psi4hb = 0.D0
|
|
frno3hb = 0.D0
|
|
ELSE
|
|
psi4hb = frnh4hb
|
|
frno3hb = -frnh4hb
|
|
END IF
|
|
frno3hb = frno3hb + molalrhb(5)
|
|
molalrhb(5) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) psi6hb = psi6hb + frclhb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
psi5hb = 0.D0
|
|
ELSE
|
|
psi5hb = frno3hb
|
|
END IF
|
|
molalrhb(4) = 0.D0
|
|
psi8hb = psi8hb + molalrhb(3)
|
|
molalrhb(3) = 0.D0
|
|
psi1hb = psi1hb + molalrhb(2)
|
|
molalrhb(2) = 0.D0
|
|
psi7hb = psi7hb + molalrhb(1)
|
|
molalrhb(1) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
chi6hb = chi6hb + ghclhb
|
|
psi6hb = psi6hb - ghclhb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
chi5hb = chi5hb + ghno3hb
|
|
psi5hb = psi5hb - ghno3hb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
chi4hb = chi4hb + gnh3hb
|
|
psi4hb = psi4hb - gnh3hb
|
|
END IF
|
|
CALL POPREAL8(molal(1))
|
|
hihb = molalhb(1)
|
|
molalhb(1) = 0.D0
|
|
CALL CALCPH_HB(smin, sminhb, hi, hihb, ohi)
|
|
CALL POPREAL8(smin)
|
|
psi5hb = psi5hb + molalhb(7) + sminhb
|
|
CALL POPREAL8(molal(7))
|
|
psi8hb = psi8hb + molalhb(7)
|
|
molalhb(7) = 0.D0
|
|
CALL POPREAL8(molal(6))
|
|
molalhb(6) = 0.D0
|
|
CALL POPREAL8(molal(5))
|
|
psi1hb = psi1hb + molalhb(5)
|
|
molalhb(5) = 0.D0
|
|
psi6hb = psi6hb + molalhb(4) + sminhb
|
|
CALL POPREAL8(molal(4))
|
|
psi7hb = psi7hb + molalhb(4)
|
|
molalhb(4) = 0.D0
|
|
psi4hb = psi4hb + molalhb(3) - sminhb
|
|
CALL POPREAL8(molal(3))
|
|
molalhb(3) = 0.D0
|
|
CALL POPREAL8(molal(2))
|
|
psi8hb = psi8hb + molalhb(2)
|
|
psi7hb = psi7hb + molalhb(2)
|
|
psi1hb = psi1hb + 2.d0*molalhb(2)
|
|
molalhb(2) = 0.D0
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch == 0) THEN
|
|
a4hb = 0.D0
|
|
ELSE
|
|
IF (branch /= 1) THEN
|
|
chi4hb = chi4hb + psi4hb
|
|
psi4hb = 0.D0
|
|
END IF
|
|
cc = chi4*(psi5+psi6)
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (dd == 0.0) THEN
|
|
ddhb = 0.0
|
|
ELSE
|
|
ddhb = -(0.5d0*psi4hb/(2.0*SQRT(dd)))
|
|
END IF
|
|
bbhb = 2*bb*ddhb - 0.5d0*psi4hb
|
|
cchb = -(4.d0*ddhb)
|
|
chi4hb = chi4hb + (psi5+psi6)*cchb - bbhb
|
|
psi5hb = psi5hb + chi4*cchb - bbhb
|
|
psi6hb = psi6hb + chi4*cchb - bbhb
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
CALL POPREAL8(bb)
|
|
a4hb = bbhb/a4**2
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) psi5hb = 0.D0
|
|
temp0 = gama(10)/gama(5)
|
|
temp0hb = 2.0*temp0*xk2*r*temp*a4hb/(xkw*gama(5))
|
|
a5 = xk4*r*temp*(water/gama(10))**2.0
|
|
a6 = xk3*r*temp*(water/gama(11))**2.0
|
|
CALL POPREAL8(psi5)
|
|
temp4 = a6/a5
|
|
temp5 = (chi6-psi3-psi6)*temp4 + psi6 + psi7
|
|
temp5hb = -(psi5*psi5hb/temp5**2)
|
|
temp4hb = (chi6-psi3-psi6)*temp5hb/a5
|
|
psi5hb = psi5hb/temp5
|
|
psi7hb = psi7hb + chi5*psi5hb + temp5hb
|
|
CALL POPREAL8(psi5)
|
|
temp3 = (chi6-psi3-psi6)/a5
|
|
a6hb = temp4hb - temp3*psi8*psi5hb
|
|
temp3hb = -(a6*psi8*psi5hb/a5)
|
|
chi6hb = chi6hb + temp3hb + temp4*temp5hb
|
|
psi6hb = psi6hb + chi5*psi5hb - temp3hb + (1.D0-temp4)*temp5hb
|
|
a5hb = -(temp3*temp3hb) - temp4*temp4hb
|
|
chi5hb = chi5hb + (psi6+psi7)*psi5hb
|
|
psi8hb = psi8hb - temp3*a6*psi5hb
|
|
temp2 = water/gama(11)
|
|
temp2hb = 2.0*temp2*xk3*r*temp*a6hb/gama(11)
|
|
gamahb(11) = gamahb(11) - temp2*temp2hb
|
|
temp1 = water/gama(10)
|
|
temp1hb = 2.0*temp1*xk4*r*temp*a5hb/gama(10)
|
|
waterhb = waterhb + temp1hb + temp2hb
|
|
gamahb(10) = gamahb(10) + temp0hb - temp1*temp1hb
|
|
gamahb(5) = gamahb(5) - temp0*temp0hb
|
|
gnh3hb = 0.D0
|
|
ghno3hb = 0.D0
|
|
ghclhb = 0.D0
|
|
ENDDO
|
|
chi8hb = psi8hb
|
|
chi7hb = psi7hb
|
|
chi1hb = psi1hb
|
|
xhb = psi6hb
|
|
END
|
|
|
|
C
|
|
C Differentiation of calchs4 in reverse (adjoint) mode:
|
|
C gradient of useful results: water hi so4i delta
|
|
C with respect to varying inputs: gama water hi so4i
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCHS4
|
|
C *** THIS SUBROUTINE CALCULATES THE HSO4 GENERATED FROM (H,SO4).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCHS4_HB(hi, hihb, so4i, so4ihb, hso4i, delta,
|
|
+ deltahb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: a8hb
|
|
REAL*8 :: hi, so4i, hso4i, delta, bb, cc, dd, sqdd, delta1
|
|
+ , delta2
|
|
REAL*8 :: hihb, so4ihb, deltahb, bbhb, cchb, ddhb, sqddhb,
|
|
+ delta1hb, delta2hb
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0hb
|
|
REAL*8 :: temp1hb
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** IF TOO LITTLE WATER, DONT SOLVE
|
|
C
|
|
IF (water <= 1d1*tiny) THEN
|
|
DO ii1=1,npair
|
|
gamahb(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
C
|
|
C *** CALCULATE HSO4 SPECIATION *****************************************
|
|
C
|
|
a8 = xk1*water/gama(7)*(gama(8)/gama(7))**2.
|
|
C
|
|
bb = -(hi+so4i+a8)
|
|
cc = hi*so4i - hso4i*a8
|
|
dd = bb*bb - 4.d0*cc
|
|
C
|
|
IF (dd >= zero) THEN
|
|
IF (hso4i <= tiny) THEN
|
|
delta2hb = deltahb
|
|
delta1hb = 0.D0
|
|
ELSE IF (hi*so4i >= a8*hso4i) THEN
|
|
delta2hb = deltahb
|
|
delta1hb = 0.D0
|
|
ELSE
|
|
IF (hi*so4i < a8*hso4i) THEN
|
|
delta1hb = deltahb
|
|
ELSE
|
|
delta1hb = 0.D0
|
|
END IF
|
|
delta2hb = 0.D0
|
|
END IF
|
|
bbhb = -(0.5*delta1hb) - 0.5*delta2hb
|
|
sqddhb = 0.5*delta1hb - 0.5*delta2hb
|
|
IF (dd == 0.0) THEN
|
|
ddhb = 0.0
|
|
ELSE
|
|
ddhb = sqddhb/(2.0*SQRT(dd))
|
|
END IF
|
|
ELSE
|
|
ddhb = 0.D0
|
|
bbhb = 0.D0
|
|
END IF
|
|
bbhb = bbhb + 2*bb*ddhb
|
|
cchb = -(4.d0*ddhb)
|
|
hihb = hihb + so4i*cchb - bbhb
|
|
so4ihb = so4ihb + hi*cchb - bbhb
|
|
a8hb = -bbhb - hso4i*cchb
|
|
DO ii1=1,npair
|
|
gamahb(ii1) = 0.D0
|
|
ENDDO
|
|
temp0 = water/gama(7)
|
|
temp1 = gama(8)/gama(7)
|
|
temp1hb = 2.*temp1*temp0*xk1*a8hb/gama(7)
|
|
temp0hb = temp1**2.*xk1*a8hb/gama(7)
|
|
gamahb(8) = gamahb(8) + temp1hb
|
|
gamahb(7) = gamahb(7) - temp0*temp0hb - temp1*temp1hb
|
|
waterhb = waterhb + temp0hb
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of calcph in reverse (adjoint) mode:
|
|
C gradient of useful results: hi
|
|
C with respect to varying inputs: water gg
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCPH
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCPH_HB(gg, gghb, hi, hihb, ohi)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: cn, gg, hi, ohi, bb, cc, dd
|
|
REAL*8 :: cnhb, gghb, hihb, ohihb, bbhb, cchb, ddhb
|
|
REAL*8 :: akw
|
|
REAL*8 :: akwhb
|
|
INTEGER :: branch
|
|
REAL*8 :: x2hb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1hb
|
|
INTRINSIC SQRT
|
|
C
|
|
akw = xkw*rh*water*water
|
|
cn = SQRT(akw)
|
|
C
|
|
C *** GG = (negative charge) - (positive charge)
|
|
C
|
|
IF (gg > tiny) THEN
|
|
C H+ in excess
|
|
bb = -gg
|
|
cc = -akw
|
|
dd = bb*bb - 4.d0*cc
|
|
x1 = 0.5d0*(-bb+SQRT(dd))
|
|
IF (x1 < cn) THEN
|
|
cnhb = hihb
|
|
x1hb = 0.D0
|
|
ELSE
|
|
x1hb = hihb
|
|
cnhb = 0.D0
|
|
END IF
|
|
IF (dd == 0.0) THEN
|
|
ddhb = 0.0
|
|
ELSE
|
|
ddhb = 0.5d0*x1hb/(2.0*SQRT(dd))
|
|
END IF
|
|
bbhb = 2*bb*ddhb - 0.5d0*x1hb
|
|
cchb = -(4.d0*ddhb)
|
|
akwhb = -cchb
|
|
gghb = -bbhb
|
|
ELSE
|
|
C OH- in excess
|
|
bb = gg
|
|
cc = -akw
|
|
dd = bb*bb - 4.d0*cc
|
|
x2 = 0.5d0*(-bb+SQRT(dd))
|
|
IF (x2 < cn) THEN
|
|
ohi = cn
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
ohi = x2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
akwhb = hihb/ohi
|
|
ohihb = -(akw*hihb/ohi**2)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cnhb = ohihb
|
|
x2hb = 0.D0
|
|
ELSE
|
|
x2hb = ohihb
|
|
cnhb = 0.D0
|
|
END IF
|
|
IF (dd == 0.0) THEN
|
|
ddhb = 0.0
|
|
ELSE
|
|
ddhb = 0.5d0*x2hb/(2.0*SQRT(dd))
|
|
END IF
|
|
bbhb = 2*bb*ddhb - 0.5d0*x2hb
|
|
cchb = -(4.d0*ddhb)
|
|
akwhb = akwhb - cchb
|
|
gghb = bbhb
|
|
END IF
|
|
IF (.NOT.akw == 0.0) akwhb = akwhb + cnhb/(2.0*SQRT(akw))
|
|
waterhb = xkw*rh*2*water*akwhb
|
|
END
|
|
|
|
C Differentiation of calcact3p in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3P_HB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0hb(6, 4), sionhb, hhb, chhb, f1hb(3), f2hb(4)
|
|
REAL*8 :: mpl, xij, yji
|
|
REAL*8 :: mplhb, xijhb, yjihb, ionichb
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01hb
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02hb
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03hb
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04hb
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05hb
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06hb
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07hb
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08hb
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09hb
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10hb
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11hb
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12hb
|
|
INTEGER :: j
|
|
INTEGER :: branch
|
|
REAL*8 :: x2hb
|
|
REAL*8 :: temp0hb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: temp0hb13
|
|
REAL*8 :: temp0hb12
|
|
REAL*8 :: temp0hb11
|
|
REAL*8 :: temp0hb10
|
|
REAL*8 :: temp0hb9
|
|
REAL*8 :: temp0hb8
|
|
REAL*8 :: temp0hb7
|
|
REAL*8 :: temp0hb6
|
|
REAL*8 :: x1hb
|
|
REAL*8 :: temp0hb5
|
|
REAL*8 :: temp0hb4
|
|
REAL*8 :: temp0hb3
|
|
REAL*8 :: temp0hb2
|
|
REAL*8 :: temp0hb1
|
|
REAL*8 :: temp0hb0
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
DO i=1,7
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08,
|
|
+ g09, g10, g11, g12)
|
|
C
|
|
g0(1, 1) = g11
|
|
g0(1, 2) = g07
|
|
g0(1, 3) = g08
|
|
g0(1, 4) = g10
|
|
g0(2, 1) = g01
|
|
g0(2, 2) = g02
|
|
g0(2, 3) = g12
|
|
g0(2, 4) = g03
|
|
g0(3, 1) = g06
|
|
g0(3, 2) = g04
|
|
g0(3, 3) = g09
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
sion = SQRT(ionic)
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
yji = ch*molal(j+3)/water
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gama(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gama(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gama(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gama(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gama(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gama(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gama(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gama(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gama(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gama(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gama(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gama(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gama(13))
|
|
C LC ; SCAPE
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
ELSE
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
gamahb(i) = 10.d0**gama(i)*LOG(10.d0)*gamahb(i)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
gamahb(i) = 0.D0
|
|
x2hb = 0.D0
|
|
ELSE
|
|
x2hb = gamahb(i)
|
|
gamahb(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) gamahb(i) = gamahb(i) + x2hb
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamahb(4) = gamahb(4) + 0.2d0*3.d0*gamahb(13)
|
|
gamahb(9) = gamahb(9) + 0.2d0*2.d0*gamahb(13)
|
|
gamahb(13) = 0.D0
|
|
DO ii1=1,3
|
|
f1hb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2hb(ii1) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp0hb2 = zz(12)*gamahb(12)/(z(2)+z(6))
|
|
f1hb(2) = f1hb(2) + temp0hb2/z(2)
|
|
f2hb(3) = f2hb(3) + temp0hb2/z(6)
|
|
hhb = -(zz(12)*gamahb(12))
|
|
gamahb(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp0hb3 = zz(11)*gamahb(11)/(z(1)+z(4))
|
|
f2hb(1) = f2hb(1) + temp0hb3/z(4)
|
|
hhb = hhb - zz(11)*gamahb(11)
|
|
gamahb(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp0hb4 = zz(10)*gamahb(10)/(z(1)+z(7))
|
|
f1hb(1) = f1hb(1) + temp0hb4/z(1) + temp0hb3/z(1)
|
|
f2hb(4) = f2hb(4) + temp0hb4/z(7)
|
|
hhb = hhb - zz(10)*gamahb(10)
|
|
gamahb(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp0hb5 = zz(9)*gamahb(9)/(z(3)+z(6))
|
|
f1hb(3) = f1hb(3) + temp0hb5/z(3)
|
|
hhb = hhb - zz(9)*gamahb(9)
|
|
gamahb(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp0hb6 = zz(8)*gamahb(8)/(z(1)+z(6))
|
|
f2hb(3) = f2hb(3) + temp0hb6/z(6) + temp0hb5/z(6)
|
|
hhb = hhb - zz(8)*gamahb(8)
|
|
gamahb(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp0hb7 = zz(7)*gamahb(7)/(z(1)+z(5))
|
|
f1hb(1) = f1hb(1) + temp0hb7/z(1) + temp0hb6/z(1)
|
|
f2hb(2) = f2hb(2) + temp0hb7/z(5)
|
|
hhb = hhb - zz(7)*gamahb(7)
|
|
gamahb(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp0hb8 = zz(6)*gamahb(6)/(z(3)+z(4))
|
|
f2hb(1) = f2hb(1) + temp0hb8/z(4)
|
|
hhb = hhb - zz(6)*gamahb(6)
|
|
gamahb(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp0hb9 = zz(5)*gamahb(5)/(z(3)+z(7))
|
|
f2hb(4) = f2hb(4) + temp0hb9/z(7)
|
|
hhb = hhb - zz(5)*gamahb(5)
|
|
gamahb(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp0hb10 = zz(4)*gamahb(4)/(z(3)+z(5))
|
|
f1hb(3) = f1hb(3) + temp0hb9/z(3) + temp0hb10/z(3) + temp0hb8/z(3)
|
|
f2hb(2) = f2hb(2) + temp0hb10/z(5)
|
|
hhb = hhb - zz(4)*gamahb(4)
|
|
gamahb(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp0hb11 = zz(3)*gamahb(3)/(z(2)+z(7))
|
|
f2hb(4) = f2hb(4) + temp0hb11/z(7)
|
|
hhb = hhb - zz(3)*gamahb(3)
|
|
gamahb(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp0hb12 = zz(2)*gamahb(2)/(z(2)+z(5))
|
|
f2hb(2) = f2hb(2) + temp0hb12/z(5)
|
|
hhb = hhb - zz(2)*gamahb(2)
|
|
gamahb(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp0hb13 = zz(1)*gamahb(1)/(z(2)+z(4))
|
|
f1hb(2) = f1hb(2) + temp0hb12/z(2) + temp0hb13/z(2) + temp0hb11/z(
|
|
+ 2)
|
|
f2hb(1) = f2hb(1) + temp0hb13/z(4)
|
|
hhb = hhb - zz(1)*gamahb(1)
|
|
gamahb(1) = 0.D0
|
|
ionichb = 0.D0
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0hb(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mplhb = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijhb = (g0(i, j)+zpl*zmi*h)*f2hb(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0hb(i, j) = g0hb(i, j) + yji*f1hb(i) + xij*f2hb(j)
|
|
hhb = hhb + yji*zpl*zmi*f1hb(i) + xij*zpl*zmi*f2hb(j)
|
|
yjihb = (g0(i, j)+zpl*zmi*h)*f1hb(i)
|
|
temp0hb1 = molal(j+3)*yjihb/water
|
|
molalhb(j+3) = molalhb(j+3) + ch*yjihb/water
|
|
chhb = mpl*xijhb + temp0hb1
|
|
waterhb = waterhb - ch*temp0hb1/water
|
|
mplhb = mplhb + ch*xijhb
|
|
ionichb = ionichb - (zpl+zmi)**2*0.25d0*chhb/ionic**2
|
|
ENDDO
|
|
CALL POPREAL8(mpl)
|
|
molalhb(i) = molalhb(i) + mplhb/water
|
|
waterhb = waterhb - molal(i)*mplhb/water**2
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp0hb0 = agama*hhb/(sion+1.d0)
|
|
sionhb = (1.D0-sion/(sion+1.d0))*temp0hb0
|
|
IF (.NOT.ionic == 0.0) ionichb = ionichb + sionhb/(2.0*SQRT(
|
|
+ ionic))
|
|
g05hb = g0hb(3, 4)
|
|
g0hb(3, 4) = 0.D0
|
|
g09hb = g0hb(3, 3)
|
|
g0hb(3, 3) = 0.D0
|
|
g04hb = g0hb(3, 2)
|
|
g0hb(3, 2) = 0.D0
|
|
g06hb = g0hb(3, 1)
|
|
g0hb(3, 1) = 0.D0
|
|
g03hb = g0hb(2, 4)
|
|
g0hb(2, 4) = 0.D0
|
|
g12hb = g0hb(2, 3)
|
|
g0hb(2, 3) = 0.D0
|
|
g02hb = g0hb(2, 2)
|
|
g0hb(2, 2) = 0.D0
|
|
g01hb = g0hb(2, 1)
|
|
g0hb(2, 1) = 0.D0
|
|
g10hb = g0hb(1, 4)
|
|
g0hb(1, 4) = 0.D0
|
|
g08hb = g0hb(1, 3)
|
|
g0hb(1, 3) = 0.D0
|
|
g07hb = g0hb(1, 2)
|
|
g0hb(1, 2) = 0.D0
|
|
g11hb = g0hb(1, 1)
|
|
CALL KMFUL3_HB(ionic, ionichb, temp, g01, g01hb, g02, g02hb, g03,
|
|
+ g03hb, g04, g04hb, g05, g05hb, g06, g06hb, g07,
|
|
+ g07hb, g08, g08hb, g09, g09hb, g10, g10hb, g11,
|
|
+ g11hb, g12, g12hb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionic)
|
|
x1hb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1hb = ionichb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ionichb = 0.D0
|
|
ELSE
|
|
temp0hb = 0.5d0*x1hb/water
|
|
ionichb = temp0hb
|
|
waterhb = waterhb - ionic*temp0hb/water
|
|
END IF
|
|
DO i=7,1,-1
|
|
molalhb(i) = molalhb(i) + z(i)**2*ionichb
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of kmful3 in reverse (adjoint) mode:
|
|
C gradient of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12 ionic
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_HB(ionic, ionichb, temp, g01, g01hb, g02, g02hb
|
|
+ , g03, g03hb, g04, g04hb, g05, g05hb, g06,
|
|
+ g06hb, g07, g07hb, g08, g08hb, g09, g09hb,
|
|
+ g10, g10hb, g11, g11hb, g12, g12hb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionichb, sionhb, cf2hb
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01hb, g02hb, g03hb, g04hb, g05hb, g06hb, g07hb,
|
|
+ g08hb, g09hb, g10hb, g11hb, g12hb
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0hb
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp0hb0
|
|
REAL*8 :: abs1
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01hb = g01hb + g12hb
|
|
g08hb = g08hb + g09hb + g12hb
|
|
g11hb = g11hb - g09hb - g12hb
|
|
g06hb = g06hb + g09hb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2hb = -(z10*g10hb) - z07*g07hb - z05*g05hb - z03*g03hb - z01*
|
|
+ g01hb - z02*g02hb - z04*g04hb - z06*g06hb - z08*g08hb - z11*
|
|
+ g11hb
|
|
g11hb = cf1*g11hb
|
|
g10hb = cf1*g10hb
|
|
g08hb = cf1*g08hb
|
|
g07hb = cf1*g07hb
|
|
g06hb = cf1*g06hb
|
|
g05hb = cf1*g05hb
|
|
g04hb = cf1*g04hb
|
|
g03hb = cf1*g03hb
|
|
g02hb = cf1*g02hb
|
|
g01hb = cf1*g01hb
|
|
temp0hb = (0.125d0-ti*0.005d0)*cf2hb
|
|
temp0hb0 = -(0.41d0*temp0hb/(sion+1.d0))
|
|
ionichb = ionichb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0hb
|
|
sionhb = (1.D0-sion/(sion+1.d0))*temp0hb0
|
|
ELSE
|
|
sionhb = 0.D0
|
|
END IF
|
|
CALL MKBI_HB(q11, ionic, ionichb, sion, sionhb, z11, g11, g11hb)
|
|
CALL MKBI_HB(q10, ionic, ionichb, sion, sionhb, z10, g10, g10hb)
|
|
CALL MKBI_HB(q8, ionic, ionichb, sion, sionhb, z08, g08, g08hb)
|
|
CALL MKBI_HB(q7, ionic, ionichb, sion, sionhb, z07, g07, g07hb)
|
|
CALL MKBI_HB(q6, ionic, ionichb, sion, sionhb, z06, g06, g06hb)
|
|
CALL MKBI_HB(q5, ionic, ionichb, sion, sionhb, z05, g05, g05hb)
|
|
CALL MKBI_HB(q4, ionic, ionichb, sion, sionhb, z04, g04, g04hb)
|
|
CALL MKBI_HB(q3, ionic, ionichb, sion, sionhb, z03, g03, g03hb)
|
|
CALL MKBI_HB(q2, ionic, ionichb, sion, sionhb, z02, g02, g02hb)
|
|
CALL MKBI_HB(q1, ionic, ionichb, sion, sionhb, z01, g01, g01hb)
|
|
IF (.NOT.ionic == 0.0) ionichb = ionichb + sionhb/(2.0*SQRT(
|
|
+ ionic))
|
|
END
|
|
|
|
C Differentiation of mkbi in reverse (adjoint) mode:
|
|
C gradient of useful results: sion bi ionic
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_HB(q, ionic, ionichb, sion, sionhb, zip, bi, bihb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionichb, sionhb, bihb
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: chb, xxhb
|
|
INTRINSIC EXP
|
|
REAL*8 :: temphb0
|
|
INTRINSIC LOG10
|
|
REAL*8 :: temphb
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic))
|
|
bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b
|
|
C
|
|
xxhb = zip*bihb
|
|
bihb = zip*bihb/(bi*LOG(10.0))
|
|
temphb = -(0.5107d0*xxhb/(c*sion+1.d0))
|
|
temphb0 = -(sion*temphb/(c*sion+1.d0))
|
|
sionhb = sionhb + c*temphb0 + temphb
|
|
chb = sion*temphb0
|
|
IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q
|
|
+ ))) THEN
|
|
ionichb = ionichb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*
|
|
+ ionic**2*chb
|
|
ELSE
|
|
ionichb = ionichb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bihb -
|
|
+ .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*chb
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of funch6ab_hnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: molal molalr gama water gnh3
|
|
C ghno3 ghcl chi1 chi4 chi5 chi6 chi7 chi8 fh6ab
|
|
C fh6abhnrd
|
|
C with respect to varying inputs: chi1 chi4 chi5 chi6 chi7 chi8
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of funch6ab in forward (tangent) mode:
|
|
C variations of useful results: fh6ab
|
|
C with respect to varying inputs: x
|
|
C RW status of diff variables: fh6ab:out x:in
|
|
C
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCH6AB
|
|
C *** CASE H6
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCH6AB_HNRD_HB(x, xhnrd, fh6ab, fh6abhb, fh6abhnrd,
|
|
+ fh6abhnrdhb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: psi1hb
|
|
REAL*8 :: psi4hb
|
|
REAL*8 :: psi4hnrd
|
|
REAL*8 :: psi4hnrdhb
|
|
REAL*8 :: psi5hb
|
|
REAL*8 :: psi5hnrd
|
|
REAL*8 :: psi5hnrdhb
|
|
REAL*8 :: psi6hnrd
|
|
REAL*8 :: psi7hb
|
|
REAL*8 :: psi8hb
|
|
REAL*8 :: a4hb
|
|
REAL*8 :: a4hnrd
|
|
REAL*8 :: a4hnrdhb
|
|
REAL*8 :: a5hb
|
|
REAL*8 :: a5hnrd
|
|
REAL*8 :: a5hnrdhb
|
|
REAL*8 :: a6hb
|
|
REAL*8 :: a6hnrd
|
|
REAL*8 :: a6hnrdhb
|
|
C
|
|
INTEGER :: j
|
|
INTEGER :: i
|
|
REAL*8 :: bb
|
|
REAL*8 :: bbhb
|
|
REAL*8 :: bbhnrd
|
|
REAL*8 :: bbhnrdhb
|
|
REAL*8 :: cc
|
|
REAL*8 :: cchb
|
|
REAL*8 :: cchnrd
|
|
REAL*8 :: cchnrdhb
|
|
REAL*8 :: dd
|
|
REAL*8 :: ddhb
|
|
REAL*8 :: ddhnrd
|
|
REAL*8 :: ddhnrdhb
|
|
REAL*8 :: smin
|
|
REAL*8 :: sminhb
|
|
REAL*8 :: sminhnrd
|
|
REAL*8 :: sminhnrdhb
|
|
REAL*8 :: hi
|
|
REAL*8 :: hihb
|
|
REAL*8 :: hihnrd
|
|
REAL*8 :: hihnrdhb
|
|
REAL*8 :: ohi
|
|
REAL*8 :: frno3
|
|
REAL*8 :: frno3hb
|
|
REAL*8 :: frno3hnrd
|
|
REAL*8 :: frno3hnrdhb
|
|
REAL*8 :: frcl
|
|
REAL*8 :: frclhnrd
|
|
REAL*8 :: frnh4
|
|
REAL*8 :: frnh4hb
|
|
REAL*8 :: frnh4hnrd
|
|
REAL*8 :: frnh4hnrdhb
|
|
REAL*8 :: result1
|
|
REAL*8 :: result1hb
|
|
REAL*8 :: result1hnrd
|
|
REAL*8 :: result1hnrdhb
|
|
REAL*8 :: fh6ab
|
|
REAL*8 :: fh6abhb
|
|
REAL*8 :: fh6abhnrd
|
|
REAL*8 :: fh6abhnrdhb
|
|
REAL*8 :: x
|
|
REAL*8 :: xhnrd, molalrhnrd(npair), molalrhnrdhb(npair)
|
|
INTRINSIC MAX
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
INTEGER :: branch
|
|
REAL*8 :: temp3
|
|
REAL*8 :: temp3hb0
|
|
REAL*8 :: temp29
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp11hb
|
|
REAL*8 :: temp28
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp27
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp26
|
|
REAL*8 :: temp25
|
|
REAL*8 :: temp24
|
|
REAL*8 :: temp26hb
|
|
REAL*8 :: temp23
|
|
REAL*8 :: temp22
|
|
REAL*8 :: temp21
|
|
REAL*8 :: temp20
|
|
REAL*8 :: temp21hb
|
|
REAL*8 :: temp19hb
|
|
REAL*8 :: temp5hb
|
|
REAL*8 :: temp5hb1
|
|
REAL*8 :: temp14hb
|
|
REAL*8 :: temp5hb0
|
|
REAL*8 :: temp31hb
|
|
REAL*8 :: temp0hb
|
|
REAL*8 :: temp29hb
|
|
REAL*8 :: temp19hb0
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp19
|
|
REAL*8 :: temp39hb
|
|
REAL*8 :: temp18
|
|
REAL*8 :: temp21hb0
|
|
REAL*8 :: temp17
|
|
REAL*8 :: temp8hb
|
|
REAL*8 :: temp16
|
|
REAL*8 :: temp15
|
|
REAL*8 :: temp17hb
|
|
REAL*8 :: temp14
|
|
REAL*8 :: temp7hb0
|
|
REAL*8 :: temp34hb
|
|
REAL*8 :: temp13
|
|
REAL*8 :: temp12
|
|
REAL*8 :: temp3hb
|
|
REAL*8 :: temp11
|
|
REAL*8 :: temp10
|
|
REAL*8 :: temp12hb
|
|
REAL*8 :: temp27hb
|
|
REAL*8 :: temp22hb
|
|
REAL*8 :: temp6hb
|
|
REAL*8 :: temp15hb
|
|
REAL*8 :: temp32hb
|
|
REAL*8 :: temp1hb
|
|
REAL*8 :: temp10hb
|
|
REAL*8 :: temp25hb
|
|
REAL*8 :: temp39
|
|
REAL*8 :: temp38
|
|
REAL*8 :: temp20hb
|
|
REAL*8 :: temp13hb0
|
|
REAL*8 :: temp37
|
|
REAL*8 :: temp9hb
|
|
REAL*8 :: temp36
|
|
INTEGER :: ii10
|
|
REAL*8 :: temp35
|
|
REAL*8 :: temp18hb
|
|
REAL*8 :: temp34
|
|
REAL*8 :: temp38hb0
|
|
REAL*8 :: temp33
|
|
REAL*8 :: temp32
|
|
REAL*8 :: temp4hb
|
|
REAL*8 :: temp31
|
|
REAL*8 :: temp30
|
|
REAL*8 :: temp13hb
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp30hb
|
|
REAL*8 :: temp1hb0
|
|
REAL*8 :: temp28hb
|
|
REAL*8 :: temp23hb
|
|
REAL*8 :: temp40hb
|
|
REAL*8 :: temp38hb
|
|
REAL*8 :: temp9
|
|
REAL*8 :: temp7hb
|
|
REAL*8 :: temp8
|
|
REAL*8 :: temp7
|
|
REAL*8 :: temp6
|
|
REAL*8 :: temp33hb
|
|
REAL*8 :: temp5
|
|
REAL*8 :: temp4
|
|
REAL*8 :: temp2hb
|
|
REAL*8 :: temp3hb1
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
psi6hnrd = xhnrd
|
|
psi6 = x
|
|
psi1 = chi1
|
|
psi2 = zero
|
|
psi3 = zero
|
|
psi7 = chi7
|
|
psi8 = chi8
|
|
DO ii1=1,nions
|
|
molalhnrd(ii1) = 0.d0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
molalrhnrd(ii1) = 0.d0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
gamahnrd(ii1) = 0.d0
|
|
ENDDO
|
|
waterhnrd = 0.d0
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
DO i=1,2
|
|
CALL PUSHREAL8(a4hnrd)
|
|
C
|
|
a4hnrd = xk2*r*temp*2.0*gama(10)*(gamahnrd(10)*gama(5)-gama(10)*
|
|
+ gamahnrd(5))/(xkw*gama(5)**3)
|
|
CALL PUSHREAL8(a4)
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
CALL PUSHREAL8(a5hnrd)
|
|
a5hnrd = xk4*r*temp*2.0*water*(waterhnrd*gama(10)-water*gamahnrd
|
|
+ (10))/gama(10)**3
|
|
a5 = xk4*r*temp*(water/gama(10))**2.0
|
|
CALL PUSHREAL8(a6hnrd)
|
|
a6hnrd = xk3*r*temp*2.0*water*(waterhnrd*gama(11)-water*gamahnrd
|
|
+ (11))/gama(11)**3
|
|
CALL PUSHREAL8(a6)
|
|
a6 = xk3*r*temp*(water/gama(11))**2.0
|
|
CALL PUSHREAL8(psi5hnrd)
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
psi5hnrd = chi5*psi6hnrd - psi8*((a6hnrd*a5-a6*a5hnrd)*(chi6-
|
|
+ psi6-psi3)/a5**2-a6*psi6hnrd/a5)
|
|
CALL PUSHREAL8(psi5)
|
|
psi5 = chi5*(psi6+psi7) - a6/a5*psi8*(chi6-psi6-psi3)
|
|
CALL PUSHREAL8(psi5hnrd)
|
|
psi5hnrd = (psi5hnrd*(a6/a5*(chi6-psi6-psi3)+psi6+psi7)-psi5*((
|
|
+ a6hnrd*a5-a6*a5hnrd)*(chi6-psi6-psi3)/a5**2-a6*psi6hnrd/a5+
|
|
+ psi6hnrd))/(a6/a5*(chi6-psi6-psi3)+psi6+psi7)**2
|
|
CALL PUSHREAL8(psi5)
|
|
psi5 = psi5/(a6/a5*(chi6-psi6-psi3)+psi6+psi7)
|
|
IF (psi5 < tiny) THEN
|
|
psi5 = tiny
|
|
psi5hnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
psi5 = psi5
|
|
END IF
|
|
C
|
|
IF (w(3) > tiny .AND. water > tiny) THEN
|
|
CALL PUSHREAL8(bbhnrd)
|
|
C First try 3rd order soln
|
|
bbhnrd = -(psi6hnrd+psi5hnrd-a4hnrd/a4**2)
|
|
CALL PUSHREAL8(bb)
|
|
bb = -(chi4+psi6+psi5+1.d0/a4)
|
|
cchnrd = chi4*(psi5hnrd+psi6hnrd)
|
|
cc = chi4*(psi5+psi6)
|
|
ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (dd >= 0.) THEN
|
|
abs1 = dd
|
|
ELSE
|
|
abs1 = -dd
|
|
END IF
|
|
IF (abs1 < tiny) THEN
|
|
result1hnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
result1hnrd = ddhnrd/(2.0*SQRT(dd))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
psi4hnrd = 0.5d0*(-bbhnrd-result1hnrd)
|
|
psi4 = 0.5d0*(-bb-result1)
|
|
IF (psi4 > chi4) THEN
|
|
psi4 = chi4
|
|
psi4hnrd = 0.d0
|
|
CALL PUSHCONTROL2B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL2B(1)
|
|
psi4 = psi4
|
|
END IF
|
|
ELSE
|
|
CALL PUSHCONTROL2B(2)
|
|
psi4 = tiny
|
|
psi4hnrd = 0.d0
|
|
END IF
|
|
CALL PUSHREAL8(molalhnrd(2))
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
C NAI
|
|
molalhnrd(2) = 0.d0
|
|
CALL PUSHREAL8(molal(2))
|
|
molal(2) = psi8 + psi7 + 2.d0*psi1
|
|
CALL PUSHREAL8(molalhnrd(3))
|
|
C NH4I
|
|
molalhnrd(3) = psi4hnrd
|
|
CALL PUSHREAL8(molal(3))
|
|
molal(3) = psi4
|
|
CALL PUSHREAL8(molalhnrd(4))
|
|
C CLI
|
|
molalhnrd(4) = psi6hnrd
|
|
CALL PUSHREAL8(molal(4))
|
|
molal(4) = psi6 + psi7
|
|
CALL PUSHREAL8(molalhnrd(5))
|
|
C SO4I
|
|
molalhnrd(5) = 0.d0
|
|
CALL PUSHREAL8(molal(5))
|
|
molal(5) = psi2 + psi1
|
|
CALL PUSHREAL8(molalhnrd(6))
|
|
C HSO4I
|
|
molalhnrd(6) = 0.d0
|
|
CALL PUSHREAL8(molal(6))
|
|
molal(6) = zero
|
|
CALL PUSHREAL8(molalhnrd(7))
|
|
C NO3I
|
|
molalhnrd(7) = psi5hnrd
|
|
CALL PUSHREAL8(molal(7))
|
|
molal(7) = psi5 + psi8
|
|
CALL PUSHREAL8(sminhnrd)
|
|
C
|
|
C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3)
|
|
sminhnrd = psi5hnrd + psi6hnrd - psi4hnrd
|
|
CALL PUSHREAL8(smin)
|
|
smin = 2.d0*psi2 + psi5 + psi6 - psi4
|
|
CALL CALCPH_HNRD(smin, sminhnrd, hi, hihnrd, ohi)
|
|
CALL PUSHREAL8(molalhnrd(1))
|
|
molalhnrd(1) = hihnrd
|
|
CALL PUSHREAL8(molal(1))
|
|
molal(1) = hi
|
|
IF (chi4 - psi4 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
gnh3 = tiny
|
|
gnh3hnrd = 0.d0
|
|
ELSE
|
|
gnh3hnrd = -psi4hnrd
|
|
gnh3 = chi4 - psi4
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (chi5 - psi5 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (chi6 - psi6 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ghcl = tiny
|
|
ghclhnrd = 0.d0
|
|
ELSE
|
|
ghclhnrd = -psi6hnrd
|
|
ghcl = chi6 - psi6
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM RICH CASE
|
|
C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/
|
|
C
|
|
C NACL
|
|
molalrhnrd(1) = 0.d0
|
|
molalr(1) = psi7
|
|
C NA2SO4
|
|
molalrhnrd(2) = 0.d0
|
|
molalr(2) = psi1
|
|
C NANO3
|
|
molalrhnrd(3) = 0.d0
|
|
molalr(3) = psi8
|
|
C (NH4)2SO4
|
|
molalrhnrd(4) = 0.d0
|
|
molalr(4) = zero
|
|
IF (psi5 < zero) THEN
|
|
frno3 = zero
|
|
frno3hnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
frno3hnrd = psi5hnrd
|
|
frno3 = psi5
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (psi6 < zero) THEN
|
|
frcl = zero
|
|
frclhnrd = 0.d0
|
|
ELSE
|
|
frclhnrd = psi6hnrd
|
|
frcl = psi6
|
|
END IF
|
|
C MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3
|
|
C FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3
|
|
C MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL
|
|
IF (psi4 < frno3) THEN
|
|
molalrhnrd(5) = psi4hnrd
|
|
molalr(5) = psi4
|
|
IF (frcl > zero) THEN
|
|
molalrhnrd(6) = 0.d0
|
|
molalr(6) = zero
|
|
CALL PUSHCONTROL2B(0)
|
|
ELSE
|
|
molalrhnrd(6) = frclhnrd
|
|
molalr(6) = frcl
|
|
CALL PUSHCONTROL2B(1)
|
|
END IF
|
|
ELSE
|
|
molalrhnrd(5) = frno3hnrd
|
|
molalr(5) = frno3
|
|
IF (psi4 - frno3 < zero) THEN
|
|
frnh4 = zero
|
|
frnh4hnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
frnh4hnrd = psi4hnrd - frno3hnrd
|
|
frnh4 = psi4 - frno3
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (frcl > frnh4) THEN
|
|
molalrhnrd(6) = frnh4hnrd
|
|
molalr(6) = frnh4
|
|
CALL PUSHCONTROL2B(2)
|
|
ELSE
|
|
molalrhnrd(6) = frclhnrd
|
|
molalr(6) = frcl
|
|
CALL PUSHCONTROL2B(3)
|
|
END IF
|
|
END IF
|
|
CALL PUSHREAL8(water)
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
CALL PUSHREAL8(waterhnrd)
|
|
waterhnrd = 0.d0
|
|
DO j=1,npair
|
|
waterhnrd = waterhnrd + molalrhnrd(j)/m0(j)
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
waterhnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
CALL PUSHREAL8ARRAY(gamahnrd, npair)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3P_HNRD()
|
|
ENDDO
|
|
temp38hb0 = fh6abhnrdhb/a4**2
|
|
temp37 = a6**2
|
|
temp25 = a4/temp37
|
|
temp26hb = temp25*temp38hb0
|
|
temp36 = gnh3**2
|
|
temp29 = a6/temp36
|
|
temp30hb = temp29*temp26hb
|
|
temp35 = ghcl**2
|
|
temp32 = gnh3/temp35
|
|
temp33hb = temp32*temp30hb
|
|
temp34hb = ghcl*temp33hb
|
|
temp34 = molalhnrd(3)*molal(4) + molal(3)*molalhnrd(4)
|
|
temp33 = temp34*ghcl - ghclhnrd*molal(3)*molal(4)
|
|
temp32hb = temp33*temp30hb/temp35
|
|
temp31 = gnh3hnrd/ghcl
|
|
temp31hb = -(molal(3)*molal(4)*temp30hb/ghcl)
|
|
temp30 = temp33*temp32 - molal(3)*molal(4)*temp31
|
|
temp29hb = temp30*temp26hb/temp36
|
|
temp27 = ghcl*gnh3
|
|
temp28 = molal(4)/temp27
|
|
temp28hb = -(molal(3)*a6hnrd*temp26hb/temp27)
|
|
temp27hb = -(temp28*temp28hb)
|
|
temp26 = temp30*temp29 - molal(3)*a6hnrd*temp28
|
|
temp25hb = temp26*temp38hb0/temp37
|
|
temp22 = ghcl*gnh3*a6
|
|
temp23hb = -(temp38hb0/temp22)
|
|
temp24 = molal(3)*a4hnrd*molal(4)
|
|
temp23 = temp24/temp22
|
|
temp22hb = -(temp23*temp23hb)
|
|
temp38 = a6*a4
|
|
temp39 = ghcl*gnh3*temp38
|
|
temp40hb = fh6abhb/temp39
|
|
temp39hb = -(molal(3)*molal(4)*temp40hb/temp39)
|
|
temp38hb = ghcl*gnh3*temp39hb
|
|
molalhb(3) = molalhb(3) + molal(4)*temp40hb
|
|
molalhb(4) = molalhb(4) + molalhnrd(3)*temp34hb - ghclhnrd*molal(3
|
|
+ )*temp33hb - temp31*molal(3)*temp30hb + temp28hb + molal(3)*
|
|
+ a4hnrd*temp23hb + molal(3)*temp40hb
|
|
ghclhb = ghclhb + temp34*temp33hb - temp32*2*ghcl*temp32hb -
|
|
+ temp31*temp31hb + gnh3*temp27hb + a6*gnh3*temp22hb + temp38*gnh3
|
|
+ *temp39hb
|
|
gnh3hb = gnh3hb + temp32hb - temp29*2*gnh3*temp29hb + ghcl*
|
|
+ temp27hb + a6*ghcl*temp22hb + temp38*ghcl*temp39hb
|
|
a6hb = temp29hb - temp25*2*a6*temp25hb + ghcl*gnh3*temp22hb + a4*
|
|
+ temp38hb
|
|
a4hb = temp25hb - (temp26*temp25-temp23)*2*temp38hb0/a4 + a6*
|
|
+ temp38hb
|
|
DO ii10=1,nions
|
|
molalhnrdhb(ii10) = 0.D0
|
|
ENDDO
|
|
molalhnrdhb(3) = molalhnrdhb(3) + molal(4)*temp34hb
|
|
molalhb(3) = molalhb(3) + molal(4)*a4hnrd*temp23hb - temp28*a6hnrd
|
|
+ *temp26hb - temp31*molal(4)*temp30hb - ghclhnrd*molal(4)*
|
|
+ temp33hb + molalhnrd(4)*temp34hb
|
|
molalhnrdhb(4) = molalhnrdhb(4) + molal(3)*temp34hb
|
|
gnh3hnrdhb = temp31hb
|
|
a6hnrdhb = -(temp28*molal(3)*temp26hb)
|
|
a4hnrdhb = molal(4)*molal(3)*temp23hb
|
|
psi1hb = 0.D0
|
|
psi7hb = 0.D0
|
|
psi8hb = 0.D0
|
|
DO ii10=1,npair
|
|
gamahnrdhb(ii10) = 0.D0
|
|
ENDDO
|
|
waterhnrdhb = 0.D0
|
|
DO ii10=1,npair
|
|
molalrhnrdhb(ii10) = 0.D0
|
|
ENDDO
|
|
DO i=2,1,-1
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPREAL8ARRAY(gamahnrd, npair)
|
|
CALL CALCACT3P_HNRD_HB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
waterhb = 0.D0
|
|
waterhnrdhb = 0.D0
|
|
END IF
|
|
DO j=npair,1,-1
|
|
molalrhb(j) = molalrhb(j) + waterhb/m0(j)
|
|
molalrhnrdhb(j) = molalrhnrdhb(j) + waterhnrdhb/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(waterhnrd)
|
|
CALL POPREAL8(water)
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch < 2) THEN
|
|
IF (branch == 0) THEN
|
|
molalrhb(6) = 0.D0
|
|
molalrhnrdhb(6) = 0.D0
|
|
ELSE
|
|
molalrhb(6) = 0.D0
|
|
molalrhnrdhb(6) = 0.D0
|
|
END IF
|
|
psi4hb = molalrhb(5)
|
|
molalrhb(5) = 0.D0
|
|
psi4hnrdhb = molalrhnrdhb(5)
|
|
molalrhnrdhb(5) = 0.D0
|
|
frno3hb = 0.D0
|
|
frno3hnrdhb = 0.D0
|
|
ELSE
|
|
IF (branch == 2) THEN
|
|
frnh4hb = molalrhb(6)
|
|
molalrhb(6) = 0.D0
|
|
frnh4hnrdhb = molalrhnrdhb(6)
|
|
molalrhnrdhb(6) = 0.D0
|
|
ELSE
|
|
molalrhb(6) = 0.D0
|
|
molalrhnrdhb(6) = 0.D0
|
|
frnh4hb = 0.D0
|
|
frnh4hnrdhb = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
psi4hb = 0.D0
|
|
frno3hb = 0.D0
|
|
frno3hnrdhb = 0.D0
|
|
psi4hnrdhb = 0.D0
|
|
ELSE
|
|
psi4hb = frnh4hb
|
|
frno3hb = -frnh4hb
|
|
psi4hnrdhb = frnh4hnrdhb
|
|
frno3hnrdhb = -frnh4hnrdhb
|
|
END IF
|
|
frno3hb = frno3hb + molalrhb(5)
|
|
molalrhb(5) = 0.D0
|
|
frno3hnrdhb = frno3hnrdhb + molalrhnrdhb(5)
|
|
molalrhnrdhb(5) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
psi5hb = 0.D0
|
|
psi5hnrdhb = 0.D0
|
|
ELSE
|
|
psi5hb = frno3hb
|
|
psi5hnrdhb = frno3hnrdhb
|
|
END IF
|
|
molalrhb(4) = 0.D0
|
|
molalrhnrdhb(4) = 0.D0
|
|
psi8hb = psi8hb + molalrhb(3)
|
|
molalrhb(3) = 0.D0
|
|
molalrhnrdhb(3) = 0.D0
|
|
psi1hb = psi1hb + molalrhb(2)
|
|
molalrhb(2) = 0.D0
|
|
molalrhnrdhb(2) = 0.D0
|
|
psi7hb = psi7hb + molalrhb(1)
|
|
molalrhb(1) = 0.D0
|
|
molalrhnrdhb(1) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) chi6hb = chi6hb + ghclhb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
chi5hb = chi5hb + ghno3hb
|
|
psi5hb = psi5hb - ghno3hb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
chi4hb = chi4hb + gnh3hb
|
|
psi4hb = psi4hb - gnh3hb
|
|
psi4hnrdhb = psi4hnrdhb - gnh3hnrdhb
|
|
END IF
|
|
CALL POPREAL8(molal(1))
|
|
hihb = molalhb(1)
|
|
molalhb(1) = 0.D0
|
|
CALL POPREAL8(molalhnrd(1))
|
|
hihnrdhb = molalhnrdhb(1)
|
|
molalhnrdhb(1) = 0.D0
|
|
CALL CALCPH_HNRD_HB(smin, sminhb, sminhnrd, sminhnrdhb, hi, hihb
|
|
+ , hihnrd, hihnrdhb, ohi)
|
|
CALL POPREAL8(smin)
|
|
psi5hb = psi5hb + molalhb(7) + sminhb
|
|
CALL POPREAL8(sminhnrd)
|
|
psi5hnrdhb = psi5hnrdhb + molalhnrdhb(7) + sminhnrdhb
|
|
CALL POPREAL8(molal(7))
|
|
psi8hb = psi8hb + molalhb(7)
|
|
molalhb(7) = 0.D0
|
|
CALL POPREAL8(molalhnrd(7))
|
|
molalhnrdhb(7) = 0.D0
|
|
CALL POPREAL8(molal(6))
|
|
molalhb(6) = 0.D0
|
|
CALL POPREAL8(molalhnrd(6))
|
|
molalhnrdhb(6) = 0.D0
|
|
CALL POPREAL8(molal(5))
|
|
psi1hb = psi1hb + molalhb(5)
|
|
molalhb(5) = 0.D0
|
|
CALL POPREAL8(molalhnrd(5))
|
|
molalhnrdhb(5) = 0.D0
|
|
CALL POPREAL8(molal(4))
|
|
psi7hb = psi7hb + molalhb(4)
|
|
molalhb(4) = 0.D0
|
|
psi4hb = psi4hb + molalhb(3) - sminhb
|
|
CALL POPREAL8(molalhnrd(4))
|
|
molalhnrdhb(4) = 0.D0
|
|
psi4hnrdhb = psi4hnrdhb + molalhnrdhb(3) - sminhnrdhb
|
|
CALL POPREAL8(molal(3))
|
|
molalhb(3) = 0.D0
|
|
CALL POPREAL8(molalhnrd(3))
|
|
molalhnrdhb(3) = 0.D0
|
|
CALL POPREAL8(molal(2))
|
|
psi8hb = psi8hb + molalhb(2)
|
|
psi7hb = psi7hb + molalhb(2)
|
|
psi1hb = psi1hb + 2.d0*molalhb(2)
|
|
molalhb(2) = 0.D0
|
|
CALL POPREAL8(molalhnrd(2))
|
|
molalhnrdhb(2) = 0.D0
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch == 0) THEN
|
|
chi4hb = chi4hb + psi4hb
|
|
psi4hb = 0.D0
|
|
psi4hnrdhb = 0.D0
|
|
ELSE IF (branch /= 1) THEN
|
|
GOTO 100
|
|
END IF
|
|
bbhb = -(0.5d0*psi4hb)
|
|
result1hb = -(0.5d0*psi4hb)
|
|
bbhnrdhb = -(0.5d0*psi4hnrdhb)
|
|
result1hnrdhb = -(0.5d0*psi4hnrdhb)
|
|
cc = chi4*(psi5+psi6)
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (dd == 0.0) THEN
|
|
ddhb = 0.0
|
|
ELSE
|
|
ddhb = result1hb/(2.0*SQRT(dd))
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ddhnrdhb = 0.D0
|
|
ELSE
|
|
cchnrd = chi4*(psi5hnrd+psi6hnrd)
|
|
ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd
|
|
temp21 = SQRT(dd)
|
|
temp21hb0 = result1hnrdhb/(2.0*temp21)
|
|
ddhnrdhb = temp21hb0
|
|
IF (.NOT.dd == 0.0) ddhb = ddhb - ddhnrd*temp21hb0/(2.0*
|
|
+ temp21**2)
|
|
END IF
|
|
bbhb = bbhb + 2*bbhnrd*ddhnrdhb + 2*bb*ddhb
|
|
cchb = -(4.d0*ddhb)
|
|
bbhnrdhb = bbhnrdhb + 2*bb*ddhnrdhb
|
|
cchnrdhb = -(4.d0*ddhnrdhb)
|
|
chi4hb = chi4hb + (psi6hnrd+psi5hnrd)*cchnrdhb - bbhb + (psi6+
|
|
+ psi5)*cchb
|
|
psi5hb = psi5hb + chi4*cchb - bbhb
|
|
psi5hnrdhb = psi5hnrdhb + chi4*cchnrdhb - bbhnrdhb
|
|
CALL POPREAL8(bb)
|
|
CALL POPREAL8(bbhnrd)
|
|
temp21hb = bbhnrdhb/a4**2
|
|
a4hb = a4hb + bbhb/a4**2 - a4hnrd*2*temp21hb/a4
|
|
a4hnrdhb = a4hnrdhb + temp21hb
|
|
100 CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
psi5hb = 0.D0
|
|
psi5hnrdhb = 0.D0
|
|
END IF
|
|
temp1 = xkw*gama(5)**3
|
|
temp0 = gama(10)/temp1
|
|
temp1hb0 = xk2*2.0*r*temp*a4hnrdhb
|
|
temp1hb = temp0*temp1hb0
|
|
temp0hb = (gamahnrd(10)*gama(5)-gama(10)*gamahnrd(5))*temp1hb0/
|
|
+ temp1
|
|
temp2 = gama(10)/gama(5)
|
|
temp2hb = 2.0*temp2*xk2*r*temp*a4hb/(xkw*gama(5))
|
|
a5 = xk4*r*temp*(water/gama(10))**2.0
|
|
CALL POPREAL8(psi5)
|
|
temp19 = a6/a5
|
|
temp20 = psi6 + (chi6-psi3-psi6)*temp19 + psi7
|
|
temp20hb = -(psi5*psi5hb/temp20**2)
|
|
temp19hb = (chi6-psi3-psi6)*temp20hb/a5
|
|
CALL POPREAL8(psi5hnrd)
|
|
temp11 = a6/a5
|
|
temp12 = psi6 + (chi6-psi3-psi6)*temp11 + psi7
|
|
temp19hb0 = psi5hnrdhb/temp12**2
|
|
temp17 = a6/a5
|
|
temp18 = psi6 + (chi6-psi3-psi6)*temp17 + psi7
|
|
temp18hb = psi5hnrd*temp19hb0
|
|
temp17hb = (chi6-psi3-psi6)*temp18hb/a5
|
|
temp16 = a5**2
|
|
temp13 = (chi6-psi3-psi6)/temp16
|
|
temp14 = a6hnrd*a5 - a6*a5hnrd
|
|
temp15 = psi6hnrd + temp14*temp13 - psi6hnrd*a6/a5
|
|
psi5hb = psi5hb/temp20 - temp15*temp19hb0
|
|
temp15hb = -(psi5*temp19hb0)
|
|
temp14hb = temp13*temp15hb
|
|
temp13hb = temp14*temp15hb/temp16
|
|
temp13hb0 = -(psi6hnrd*temp15hb/a5)
|
|
temp12hb = -((psi5hnrd*temp18-psi5*temp15)*2*temp19hb0/temp12)
|
|
psi7hb = psi7hb + temp18hb + temp12hb + chi5*psi5hb + temp20hb
|
|
temp11hb = (chi6-psi3-psi6)*temp12hb/a5
|
|
psi5hnrdhb = temp18*temp19hb0
|
|
CALL POPREAL8(psi5)
|
|
temp10 = (chi6-psi3-psi6)/a5
|
|
temp10hb = -(a6*psi8*psi5hb/a5)
|
|
chi5hb = chi5hb + psi6hnrd*psi5hnrdhb + (psi6+psi7)*psi5hb
|
|
CALL POPREAL8(psi5hnrd)
|
|
temp9 = a5**2
|
|
temp7 = (chi6-psi3-psi6)/temp9
|
|
temp8 = a6hnrd*a5 - a6*a5hnrd
|
|
psi8hb = psi8hb - (temp8*temp7-psi6hnrd*(a6/a5))*psi5hnrdhb -
|
|
+ temp10*a6*psi5hb
|
|
temp9hb = -(psi8*psi5hnrdhb)
|
|
temp8hb = temp7*temp9hb
|
|
a6hnrdhb = a6hnrdhb + a5*temp8hb + a5*temp14hb
|
|
a5hnrdhb = -(a6*temp8hb) - a6*temp14hb
|
|
temp7hb = temp8*temp9hb/temp9
|
|
chi6hb = chi6hb + temp17*temp18hb + temp13hb + temp11*temp12hb +
|
|
+ temp7hb + temp10hb + temp19*temp20hb
|
|
temp7hb0 = -(psi6hnrd*temp9hb/a5)
|
|
a6hb = a6hb + temp17hb - a5hnrd*temp14hb + temp13hb0 + temp11hb
|
|
+ - a5hnrd*temp8hb + temp7hb0 - temp10*psi8*psi5hb + temp19hb
|
|
a5hb = a6hnrd*temp14hb - temp17*temp17hb - temp13*2*a5*temp13hb
|
|
+ - a6*temp13hb0/a5 - temp11*temp11hb + a6hnrd*temp8hb - temp7*2
|
|
+ *a5*temp7hb - a6*temp7hb0/a5 - temp10*temp10hb - temp19*
|
|
+ temp19hb
|
|
CALL POPREAL8(a6)
|
|
temp6 = water/gama(11)
|
|
temp6hb = 2.0*temp6*xk3*r*temp*a6hb/gama(11)
|
|
CALL POPREAL8(a6hnrd)
|
|
temp5 = gama(11)**3
|
|
temp5hb1 = xk3*2.0*r*temp*a6hnrdhb
|
|
temp5hb = water*temp5hb1/temp5
|
|
temp5hb0 = (waterhnrd*gama(11)-water*gamahnrd(11))*temp5hb1/
|
|
+ temp5
|
|
gamahb(11) = gamahb(11) + waterhnrd*temp5hb - water*3*gama(11)**
|
|
+ 2*temp5hb0/temp5 - temp6*temp6hb
|
|
gamahnrdhb(11) = gamahnrdhb(11) - water*temp5hb
|
|
temp4 = water/gama(10)
|
|
temp4hb = 2.0*temp4*xk4*r*temp*a5hb/gama(10)
|
|
CALL POPREAL8(a5hnrd)
|
|
temp3 = gama(10)**3
|
|
temp3hb1 = xk4*2.0*r*temp*a5hnrdhb
|
|
temp3hb = water*temp3hb1/temp3
|
|
waterhnrdhb = waterhnrdhb + gama(10)*temp3hb + gama(11)*temp5hb
|
|
temp3hb0 = (waterhnrd*gama(10)-water*gamahnrd(10))*temp3hb1/
|
|
+ temp3
|
|
waterhb = waterhb + temp5hb0 - gamahnrd(11)*temp5hb - gamahnrd(
|
|
+ 10)*temp3hb + temp3hb0 + temp4hb + temp6hb
|
|
gamahb(10) = gamahb(10) + waterhnrd*temp3hb - water*3*gama(10)**
|
|
+ 2*temp3hb0/temp3 + temp2hb - temp4*temp4hb
|
|
gamahnrdhb(10) = gamahnrdhb(10) + gama(5)*temp1hb - water*
|
|
+ temp3hb
|
|
CALL POPREAL8(a4)
|
|
gamahb(5) = gamahb(5) + gamahnrd(10)*temp1hb - xkw*temp0*3*gama(
|
|
+ 5)**2*temp0hb - temp2*temp2hb
|
|
CALL POPREAL8(a4hnrd)
|
|
gamahb(10) = gamahb(10) + temp0hb - gamahnrd(5)*temp1hb
|
|
gamahnrdhb(5) = gamahnrdhb(5) - gama(10)*temp1hb
|
|
gnh3hb = 0.D0
|
|
ghno3hb = 0.D0
|
|
ghclhb = 0.D0
|
|
a4hb = 0.D0
|
|
a6hb = 0.D0
|
|
a4hnrdhb = 0.D0
|
|
gnh3hnrdhb = 0.D0
|
|
a6hnrdhb = 0.D0
|
|
ENDDO
|
|
chi8hb = chi8hb + psi8hb
|
|
chi7hb = chi7hb + psi7hb
|
|
chi1hb = chi1hb + psi1hb
|
|
END
|
|
|
|
C Differentiation of calcph_hnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: hihnrd hi
|
|
C with respect to varying inputs: water waterhnrd gghnrd gg
|
|
C
|
|
C Differentiation of calcph in forward (tangent) mode:
|
|
C variations of useful results: hi
|
|
C with respect to varying inputs: water gg
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCPH
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCPH_HNRD_HB(gg, gghb, gghnrd, gghnrdhb, hi, hihb,
|
|
+ hihnrd, hihnrdhb, ohi)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: cn, gg, hi, ohi, bb, cc, dd
|
|
REAL*8 :: cnhb, gghb, hihb, ohihb, bbhb, cchb, ddhb
|
|
REAL*8 :: cnhnrd, gghnrd, hihnrd, ohihnrd, bbhnrd, cchnrd,
|
|
+ ddhnrd
|
|
REAL*8 :: cnhnrdhb, gghnrdhb, hihnrdhb, ohihnrdhb, bbhnrdhb
|
|
+ , cchnrdhb, ddhnrdhb
|
|
REAL*8 :: akw
|
|
REAL*8 :: akwhb
|
|
REAL*8 :: akwhnrd
|
|
REAL*8 :: akwhnrdhb
|
|
REAL*8 :: result1
|
|
REAL*8 :: result1hb
|
|
REAL*8 :: result1hnrd
|
|
REAL*8 :: result1hnrdhb
|
|
REAL*8 :: x2hnrd
|
|
REAL*8 :: x2hnrdhb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x2hb
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1hb
|
|
REAL*8 :: x1hnrd
|
|
REAL*8 :: x1hnrdhb
|
|
INTRINSIC SQRT
|
|
INTEGER :: branch
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0hb
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp3hb
|
|
REAL*8 :: temp1hb
|
|
REAL*8 :: temp0hb0
|
|
REAL*8 :: abs3
|
|
REAL*8 :: abs2
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp2hb
|
|
C
|
|
akwhnrd = xkw*rh*(waterhnrd*water+water*waterhnrd)
|
|
akw = xkw*rh*water*water
|
|
IF (akw >= 0.) THEN
|
|
abs1 = akw
|
|
ELSE
|
|
abs1 = -akw
|
|
END IF
|
|
IF (abs1 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
cnhnrd = 0.d0
|
|
ELSE
|
|
cnhnrd = akwhnrd/(2.0*SQRT(akw))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
cn = SQRT(akw)
|
|
C
|
|
C *** GG = (negative charge) - (positive charge)
|
|
C
|
|
IF (gg > tiny) THEN
|
|
C H+ in excess
|
|
bbhnrd = -gghnrd
|
|
bb = -gg
|
|
cchnrd = -akwhnrd
|
|
cc = -akw
|
|
ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (dd >= 0.) THEN
|
|
abs2 = dd
|
|
ELSE
|
|
abs2 = -dd
|
|
END IF
|
|
IF (abs2 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
x1 = 0.5d0*(-bb+result1)
|
|
IF (x1 < cn) THEN
|
|
cnhb = hihb
|
|
cnhnrdhb = hihnrdhb
|
|
x1hnrdhb = 0.D0
|
|
x1hb = 0.D0
|
|
ELSE
|
|
x1hb = hihb
|
|
x1hnrdhb = hihnrdhb
|
|
cnhnrdhb = 0.D0
|
|
cnhb = 0.D0
|
|
END IF
|
|
result1hb = 0.5d0*x1hb
|
|
bbhb = -(0.5d0*x1hb)
|
|
result1hnrdhb = 0.5d0*x1hnrdhb
|
|
bbhnrdhb = -(0.5d0*x1hnrdhb)
|
|
IF (dd == 0.0) THEN
|
|
ddhb = 0.0
|
|
ELSE
|
|
ddhb = result1hb/(2.0*SQRT(dd))
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ddhnrdhb = 0.D0
|
|
ELSE
|
|
temp1 = SQRT(dd)
|
|
temp1hb = result1hnrdhb/(2.0*temp1)
|
|
ddhnrdhb = temp1hb
|
|
IF (.NOT.dd == 0.0) ddhb = ddhb - ddhnrd*temp1hb/(2.0*temp1
|
|
+ **2)
|
|
END IF
|
|
bbhb = bbhb + 2*bbhnrd*ddhnrdhb + 2*bb*ddhb
|
|
cchb = -(4.d0*ddhb)
|
|
bbhnrdhb = bbhnrdhb + 2*bb*ddhnrdhb
|
|
cchnrdhb = -(4.d0*ddhnrdhb)
|
|
akwhb = -cchb
|
|
akwhnrdhb = -cchnrdhb
|
|
gghb = -bbhb
|
|
gghnrdhb = -bbhnrdhb
|
|
ELSE
|
|
C OH- in excess
|
|
bbhnrd = gghnrd
|
|
bb = gg
|
|
cchnrd = -akwhnrd
|
|
cc = -akw
|
|
ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (dd >= 0.) THEN
|
|
abs3 = dd
|
|
ELSE
|
|
abs3 = -dd
|
|
END IF
|
|
IF (abs3 < tiny) THEN
|
|
result1hnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
result1hnrd = ddhnrd/(2.0*SQRT(dd))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
x2hnrd = 0.5d0*(result1hnrd-bbhnrd)
|
|
x2 = 0.5d0*(-bb+result1)
|
|
IF (x2 < cn) THEN
|
|
ohihnrd = cnhnrd
|
|
ohi = cn
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
ohihnrd = x2hnrd
|
|
ohi = x2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
temp3hb = hihnrdhb/ohi**2
|
|
akwhb = hihb/ohi - ohihnrd*temp3hb
|
|
ohihb = (akwhnrd-(akwhnrd*ohi-akw*ohihnrd)*2/ohi)*temp3hb - akw*
|
|
+ hihb/ohi**2
|
|
akwhnrdhb = ohi*temp3hb
|
|
ohihnrdhb = -(akw*temp3hb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cnhb = ohihb
|
|
cnhnrdhb = ohihnrdhb
|
|
x2hb = 0.D0
|
|
x2hnrdhb = 0.D0
|
|
ELSE
|
|
x2hb = ohihb
|
|
x2hnrdhb = ohihnrdhb
|
|
cnhnrdhb = 0.D0
|
|
cnhb = 0.D0
|
|
END IF
|
|
result1hb = 0.5d0*x2hb
|
|
bbhb = -(0.5d0*x2hb)
|
|
result1hnrdhb = 0.5d0*x2hnrdhb
|
|
bbhnrdhb = -(0.5d0*x2hnrdhb)
|
|
IF (dd == 0.0) THEN
|
|
ddhb = 0.0
|
|
ELSE
|
|
ddhb = result1hb/(2.0*SQRT(dd))
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ddhnrdhb = 0.D0
|
|
ELSE
|
|
temp2 = SQRT(dd)
|
|
temp2hb = result1hnrdhb/(2.0*temp2)
|
|
ddhnrdhb = temp2hb
|
|
IF (.NOT.dd == 0.0) ddhb = ddhb - ddhnrd*temp2hb/(2.0*temp2
|
|
+ **2)
|
|
END IF
|
|
bbhb = bbhb + 2*bbhnrd*ddhnrdhb + 2*bb*ddhb
|
|
cchb = -(4.d0*ddhb)
|
|
bbhnrdhb = bbhnrdhb + 2*bb*ddhnrdhb
|
|
cchnrdhb = -(4.d0*ddhnrdhb)
|
|
akwhb = akwhb - cchb
|
|
akwhnrdhb = akwhnrdhb - cchnrdhb
|
|
gghb = bbhb
|
|
gghnrdhb = bbhnrdhb
|
|
END IF
|
|
IF (.NOT.akw == 0.0) akwhb = akwhb + cnhb/(2.0*SQRT(akw))
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp0 = SQRT(akw)
|
|
temp0hb0 = cnhnrdhb/(2.0*temp0)
|
|
akwhnrdhb = akwhnrdhb + temp0hb0
|
|
IF (.NOT.akw == 0.0) akwhb = akwhb - akwhnrd*temp0hb0/(2.0*
|
|
+ temp0**2)
|
|
END IF
|
|
temp0hb = xkw*rh*akwhnrdhb
|
|
waterhb = 2*waterhnrd*temp0hb + xkw*rh*2*water*akwhb
|
|
waterhnrdhb = 2*water*temp0hb
|
|
END
|
|
|
|
C Differentiation of calcact3p_hnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water molalhnrd
|
|
C gamahnrd waterhnrd
|
|
C with respect to varying inputs: molal gama water molalhnrd
|
|
C gamahnrd waterhnrd
|
|
C
|
|
C Differentiation of calcact3p in forward (tangent) mode:
|
|
C variations of useful results: gama
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3P_HNRD_HB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0hb(6, 4), sionhb, hhb, chhb, f1hb(3), f2hb(4)
|
|
REAL*8 :: g0hnrd(6, 4), sionhnrd, hhnrd, chhnrd, f1hnrd(3)
|
|
+ , f2hnrd(4)
|
|
REAL*8 :: g0hnrdhb(6, 4), sionhnrdhb, hhnrdhb, chhnrdhb,
|
|
+ f1hnrdhb(3), f2hnrdhb(4)
|
|
REAL*8 :: mpl, xij, yji
|
|
REAL*8 :: mplhb, xijhb, yjihb
|
|
REAL*8 :: mplhnrd, xijhnrd, yjihnrd
|
|
REAL*8 :: mplhnrdhb, xijhnrdhb, yjihnrdhb
|
|
REAL*8 :: ionichb, ionichnrd, ionichnrdhb
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01hb
|
|
REAL*8 :: g01hnrd
|
|
REAL*8 :: g01hnrdhb
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02hb
|
|
REAL*8 :: g02hnrd
|
|
REAL*8 :: g02hnrdhb
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03hb
|
|
REAL*8 :: g03hnrd
|
|
REAL*8 :: g03hnrdhb
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04hb
|
|
REAL*8 :: g04hnrd
|
|
REAL*8 :: g04hnrdhb
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05hb
|
|
REAL*8 :: g05hnrd
|
|
REAL*8 :: g05hnrdhb
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06hb
|
|
REAL*8 :: g06hnrd
|
|
REAL*8 :: g06hnrdhb
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07hb
|
|
REAL*8 :: g07hnrd
|
|
REAL*8 :: g07hnrdhb
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08hb
|
|
REAL*8 :: g08hnrd
|
|
REAL*8 :: g08hnrdhb
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09hb
|
|
REAL*8 :: g09hnrd
|
|
REAL*8 :: g09hnrdhb
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10hb
|
|
REAL*8 :: g10hnrd
|
|
REAL*8 :: g10hnrdhb
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11hb
|
|
REAL*8 :: g11hnrd
|
|
REAL*8 :: g11hnrdhb
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12hb
|
|
REAL*8 :: g12hnrd
|
|
REAL*8 :: g12hnrdhb
|
|
INTEGER :: j
|
|
REAL*8 :: x2hnrd
|
|
REAL*8 :: x2hnrdhb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x2hb
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1hb
|
|
REAL*8 :: x1hnrd
|
|
REAL*8 :: x1hnrdhb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
INTEGER :: branch
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp2hb19
|
|
REAL*8 :: temp2hb18
|
|
REAL*8 :: temp2hb17
|
|
REAL*8 :: temp2hb16
|
|
REAL*8 :: temp2hb15
|
|
REAL*8 :: temp2hb14
|
|
REAL*8 :: temp2hb13
|
|
REAL*8 :: temp2hb12
|
|
REAL*8 :: temp2hb11
|
|
REAL*8 :: temp2hb10
|
|
REAL*8 :: temp0hb
|
|
INTRINSIC ABS
|
|
INTEGER :: ii20
|
|
REAL*8 :: temp1hb
|
|
INTRINSIC LOG
|
|
REAL*8 :: temp0hb1
|
|
INTEGER :: ii10
|
|
REAL*8 :: temp0hb0
|
|
REAL*8 :: temp2hb25
|
|
REAL*8 :: temp2hb24
|
|
REAL*8 :: temp1hb4
|
|
REAL*8 :: temp2hb23
|
|
REAL*8 :: temp1hb3
|
|
REAL*8 :: temp2hb22
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp1hb2
|
|
REAL*8 :: temp2hb21
|
|
REAL*8 :: temp1hb1
|
|
REAL*8 :: temp2hb20
|
|
REAL*8 :: temp1hb0
|
|
REAL*8 :: temp2hb9
|
|
REAL*8 :: temp2hb8
|
|
REAL*8 :: temp2hb7
|
|
REAL*8 :: temp2hb6
|
|
REAL*8 :: temp2hb5
|
|
REAL*8 :: temp2hb4
|
|
REAL*8 :: temp2hb3
|
|
REAL*8 :: temp2hb2
|
|
REAL*8 :: temp2hb1
|
|
REAL*8 :: temp2hb0
|
|
REAL*8 :: temp2hb
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
ionichnrd = 0.d0
|
|
DO i=1,7
|
|
ionichnrd = ionichnrd + z(i)**2*molalhnrd(i)
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
x1hnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1hnrd = (0.5d0*ionichnrd*water-0.5d0*ionic*waterhnrd)/water**2
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHREAL8(ionichnrd)
|
|
ionichnrd = 0.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionichnrd)
|
|
ionichnrd = x1hnrd
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3_HNRD(ionic, ionichnrd, temp, g01, g01hnrd, g02,
|
|
+ g02hnrd, g03, g03hnrd, g04, g04hnrd, g05, g05hnrd
|
|
+ , g06, g06hnrd, g07, g07hnrd, g08, g08hnrd, g09,
|
|
+ g09hnrd, g10, g10hnrd, g11, g11hnrd, g12, g12hnrd
|
|
+ )
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0hnrd(ii2, ii1) = 0.d0
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
g0hnrd(1, 1) = g11hnrd
|
|
g0(1, 1) = g11
|
|
g0hnrd(1, 2) = g07hnrd
|
|
g0(1, 2) = g07
|
|
g0hnrd(1, 3) = g08hnrd
|
|
g0(1, 3) = g08
|
|
g0hnrd(1, 4) = g10hnrd
|
|
g0(1, 4) = g10
|
|
g0hnrd(2, 1) = g01hnrd
|
|
g0(2, 1) = g01
|
|
g0hnrd(2, 2) = g02hnrd
|
|
g0(2, 2) = g02
|
|
g0hnrd(2, 3) = g12hnrd
|
|
g0(2, 3) = g12
|
|
g0hnrd(2, 4) = g03hnrd
|
|
g0(2, 4) = g03
|
|
g0hnrd(3, 1) = g06hnrd
|
|
g0(3, 1) = g06
|
|
g0hnrd(3, 2) = g04hnrd
|
|
g0(3, 2) = g04
|
|
g0hnrd(3, 3) = g09hnrd
|
|
g0(3, 3) = g09
|
|
g0hnrd(3, 4) = g05hnrd
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
IF (ionic >= 0.) THEN
|
|
abs1 = ionic
|
|
ELSE
|
|
abs1 = -ionic
|
|
END IF
|
|
IF (abs1 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
sionhnrd = 0.d0
|
|
ELSE
|
|
sionhnrd = ionichnrd/(2.0*SQRT(ionic))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
hhnrd = (agama*sionhnrd*(1.d0+sion)-agama*sion*sionhnrd)/(1.d0+
|
|
+ sion)**2
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
DO ii1=1,3
|
|
f1hnrd(ii1) = 0.d0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2hnrd(ii1) = 0.d0
|
|
ENDDO
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mplhnrd)
|
|
mplhnrd = (molalhnrd(i)*water-molal(i)*waterhnrd)/water**2
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
chhnrd = -(0.25d0*(zpl+zmi)**2*ionichnrd/ionic**2)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xijhnrd = chhnrd*mpl + ch*mplhnrd
|
|
xij = ch*mpl
|
|
CALL PUSHREAL8(yjihnrd)
|
|
yjihnrd = ((chhnrd*molal(j+3)+ch*molalhnrd(j+3))*water-ch*
|
|
+ molal(j+3)*waterhnrd)/water**2
|
|
yji = ch*molal(j+3)/water
|
|
f1hnrd(i) = f1hnrd(i) + yjihnrd*(g0(i, j)+zpl*zmi*h) + yji*(
|
|
+ g0hnrd(i, j)+zpl*zmi*hhnrd)
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2hnrd(j) = f2hnrd(j) + xijhnrd*(g0(i, j)+zpl*zmi*h) + xij*(
|
|
+ g0hnrd(i, j)+zpl*zmi*hhnrd)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gamahnrd(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gamahnrd(1) = zz(1)*((f1hnrd(2)/z(2)+f2hnrd(1)/z(4))/(z(2)+z(4))-
|
|
+ hhnrd)
|
|
CALL PUSHREAL8(gama(1))
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gamahnrd(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gamahnrd(2) = zz(2)*((f1hnrd(2)/z(2)+f2hnrd(2)/z(5))/(z(2)+z(5))-
|
|
+ hhnrd)
|
|
CALL PUSHREAL8(gama(2))
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gamahnrd(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gamahnrd(3) = zz(3)*((f1hnrd(2)/z(2)+f2hnrd(4)/z(7))/(z(2)+z(7))-
|
|
+ hhnrd)
|
|
CALL PUSHREAL8(gama(3))
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gamahnrd(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gamahnrd(4) = zz(4)*((f1hnrd(3)/z(3)+f2hnrd(2)/z(5))/(z(3)+z(5))-
|
|
+ hhnrd)
|
|
CALL PUSHREAL8(gama(4))
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gamahnrd(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gamahnrd(5) = zz(5)*((f1hnrd(3)/z(3)+f2hnrd(4)/z(7))/(z(3)+z(7))-
|
|
+ hhnrd)
|
|
CALL PUSHREAL8(gama(5))
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gamahnrd(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gamahnrd(6) = zz(6)*((f1hnrd(3)/z(3)+f2hnrd(1)/z(4))/(z(3)+z(4))-
|
|
+ hhnrd)
|
|
CALL PUSHREAL8(gama(6))
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gamahnrd(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gamahnrd(7) = zz(7)*((f1hnrd(1)/z(1)+f2hnrd(2)/z(5))/(z(1)+z(5))-
|
|
+ hhnrd)
|
|
CALL PUSHREAL8(gama(7))
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gamahnrd(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gamahnrd(8) = zz(8)*((f1hnrd(1)/z(1)+f2hnrd(3)/z(6))/(z(1)+z(6))-
|
|
+ hhnrd)
|
|
CALL PUSHREAL8(gama(8))
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gamahnrd(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gamahnrd(9) = zz(9)*((f1hnrd(3)/z(3)+f2hnrd(3)/z(6))/(z(3)+z(6))-
|
|
+ hhnrd)
|
|
CALL PUSHREAL8(gama(9))
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gamahnrd(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gamahnrd(10) = zz(10)*((f1hnrd(1)/z(1)+f2hnrd(4)/z(7))/(z(1)+z(7))
|
|
+ -hhnrd)
|
|
CALL PUSHREAL8(gama(10))
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gamahnrd(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gamahnrd(11) = zz(11)*((f1hnrd(1)/z(1)+f2hnrd(1)/z(4))/(z(1)+z(4))
|
|
+ -hhnrd)
|
|
CALL PUSHREAL8(gama(11))
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gamahnrd(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gamahnrd(12) = zz(12)*((f1hnrd(2)/z(2)+f2hnrd(3)/z(6))/(z(2)+z(6))
|
|
+ -hhnrd)
|
|
CALL PUSHREAL8(gama(12))
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gamahnrd(13))
|
|
C LC ; SCAPE
|
|
gamahnrd(13) = 0.2d0*(3.d0*gamahnrd(4)+2.d0*gamahnrd(9))
|
|
CALL PUSHREAL8(gama(13))
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
x2hnrd = 0.d0
|
|
ELSE
|
|
x2hnrd = gamahnrd(i)
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHREAL8(gamahnrd(i))
|
|
gamahnrd(i) = 0.d0
|
|
CALL PUSHREAL8(gama(i))
|
|
gama(i) = -5.0d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(gamahnrd(i))
|
|
gamahnrd(i) = x2hnrd
|
|
CALL PUSHREAL8(gama(i))
|
|
gama(i) = x2
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
temp2hb25 = LOG(10.d0)*gamahnrdhb(i)
|
|
temp2 = 10.d0**gama(i)
|
|
gamahb(i) = gamahnrd(i)*temp2*LOG(10.d0)*temp2hb25 + 10.d0**gama
|
|
+ (i)*LOG(10.d0)*gamahb(i)
|
|
gamahnrdhb(i) = temp2*temp2hb25
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(gama(i))
|
|
gamahb(i) = 0.D0
|
|
CALL POPREAL8(gamahnrd(i))
|
|
gamahnrdhb(i) = 0.D0
|
|
x2hb = 0.D0
|
|
x2hnrdhb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(gama(i))
|
|
x2hb = gamahb(i)
|
|
gamahb(i) = 0.D0
|
|
CALL POPREAL8(gamahnrd(i))
|
|
x2hnrdhb = gamahnrdhb(i)
|
|
gamahnrdhb(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
gamahb(i) = gamahb(i) + x2hb
|
|
gamahnrdhb(i) = gamahnrdhb(i) + x2hnrdhb
|
|
END IF
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamahb(4) = gamahb(4) + 0.2d0*3.d0*gamahb(13)
|
|
gamahb(9) = gamahb(9) + 0.2d0*2.d0*gamahb(13)
|
|
gamahb(13) = 0.D0
|
|
CALL POPREAL8(gamahnrd(13))
|
|
gamahnrdhb(4) = gamahnrdhb(4) + 0.2d0*3.d0*gamahnrdhb(13)
|
|
gamahnrdhb(9) = gamahnrdhb(9) + 0.2d0*2.d0*gamahnrdhb(13)
|
|
gamahnrdhb(13) = 0.D0
|
|
DO ii10=1,3
|
|
f1hb(ii10) = 0.D0
|
|
ENDDO
|
|
DO ii10=1,4
|
|
f2hb(ii10) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp2hb1 = zz(12)*gamahb(12)/(z(2)+z(6))
|
|
f1hb(2) = f1hb(2) + temp2hb1/z(2)
|
|
f2hb(3) = f2hb(3) + temp2hb1/z(6)
|
|
hhb = -(zz(12)*gamahb(12))
|
|
gamahb(12) = 0.D0
|
|
DO ii10=1,3
|
|
f1hnrdhb(ii10) = 0.D0
|
|
ENDDO
|
|
DO ii10=1,4
|
|
f2hnrdhb(ii10) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gamahnrd(12))
|
|
temp2hb2 = zz(12)*gamahnrdhb(12)/(z(2)+z(6))
|
|
f1hnrdhb(2) = f1hnrdhb(2) + temp2hb2/z(2)
|
|
f2hnrdhb(3) = f2hnrdhb(3) + temp2hb2/z(6)
|
|
hhnrdhb = -(zz(12)*gamahnrdhb(12))
|
|
gamahnrdhb(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp2hb3 = zz(11)*gamahb(11)/(z(1)+z(4))
|
|
f2hb(1) = f2hb(1) + temp2hb3/z(4)
|
|
hhb = hhb - zz(11)*gamahb(11)
|
|
gamahb(11) = 0.D0
|
|
CALL POPREAL8(gamahnrd(11))
|
|
temp2hb5 = zz(11)*gamahnrdhb(11)/(z(1)+z(4))
|
|
f2hnrdhb(1) = f2hnrdhb(1) + temp2hb5/z(4)
|
|
hhnrdhb = hhnrdhb - zz(11)*gamahnrdhb(11)
|
|
gamahnrdhb(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp2hb4 = zz(10)*gamahb(10)/(z(1)+z(7))
|
|
f1hb(1) = f1hb(1) + temp2hb4/z(1) + temp2hb3/z(1)
|
|
f2hb(4) = f2hb(4) + temp2hb4/z(7)
|
|
hhb = hhb - zz(10)*gamahb(10)
|
|
gamahb(10) = 0.D0
|
|
CALL POPREAL8(gamahnrd(10))
|
|
temp2hb6 = zz(10)*gamahnrdhb(10)/(z(1)+z(7))
|
|
f1hnrdhb(1) = f1hnrdhb(1) + temp2hb6/z(1) + temp2hb5/z(1)
|
|
f2hnrdhb(4) = f2hnrdhb(4) + temp2hb6/z(7)
|
|
hhnrdhb = hhnrdhb - zz(10)*gamahnrdhb(10)
|
|
gamahnrdhb(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp2hb7 = zz(9)*gamahb(9)/(z(3)+z(6))
|
|
f1hb(3) = f1hb(3) + temp2hb7/z(3)
|
|
hhb = hhb - zz(9)*gamahb(9)
|
|
gamahb(9) = 0.D0
|
|
CALL POPREAL8(gamahnrd(9))
|
|
temp2hb9 = zz(9)*gamahnrdhb(9)/(z(3)+z(6))
|
|
f1hnrdhb(3) = f1hnrdhb(3) + temp2hb9/z(3)
|
|
hhnrdhb = hhnrdhb - zz(9)*gamahnrdhb(9)
|
|
gamahnrdhb(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp2hb8 = zz(8)*gamahb(8)/(z(1)+z(6))
|
|
f2hb(3) = f2hb(3) + temp2hb8/z(6) + temp2hb7/z(6)
|
|
hhb = hhb - zz(8)*gamahb(8)
|
|
gamahb(8) = 0.D0
|
|
CALL POPREAL8(gamahnrd(8))
|
|
temp2hb10 = zz(8)*gamahnrdhb(8)/(z(1)+z(6))
|
|
f2hnrdhb(3) = f2hnrdhb(3) + temp2hb10/z(6) + temp2hb9/z(6)
|
|
hhnrdhb = hhnrdhb - zz(8)*gamahnrdhb(8)
|
|
gamahnrdhb(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp2hb11 = zz(7)*gamahb(7)/(z(1)+z(5))
|
|
f1hb(1) = f1hb(1) + temp2hb11/z(1) + temp2hb8/z(1)
|
|
f2hb(2) = f2hb(2) + temp2hb11/z(5)
|
|
hhb = hhb - zz(7)*gamahb(7)
|
|
gamahb(7) = 0.D0
|
|
CALL POPREAL8(gamahnrd(7))
|
|
temp2hb12 = zz(7)*gamahnrdhb(7)/(z(1)+z(5))
|
|
f1hnrdhb(1) = f1hnrdhb(1) + temp2hb12/z(1) + temp2hb10/z(1)
|
|
f2hnrdhb(2) = f2hnrdhb(2) + temp2hb12/z(5)
|
|
hhnrdhb = hhnrdhb - zz(7)*gamahnrdhb(7)
|
|
gamahnrdhb(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp2hb13 = zz(6)*gamahb(6)/(z(3)+z(4))
|
|
f2hb(1) = f2hb(1) + temp2hb13/z(4)
|
|
hhb = hhb - zz(6)*gamahb(6)
|
|
gamahb(6) = 0.D0
|
|
CALL POPREAL8(gamahnrd(6))
|
|
temp2hb16 = zz(6)*gamahnrdhb(6)/(z(3)+z(4))
|
|
f2hnrdhb(1) = f2hnrdhb(1) + temp2hb16/z(4)
|
|
hhnrdhb = hhnrdhb - zz(6)*gamahnrdhb(6)
|
|
gamahnrdhb(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp2hb14 = zz(5)*gamahb(5)/(z(3)+z(7))
|
|
f2hb(4) = f2hb(4) + temp2hb14/z(7)
|
|
hhb = hhb - zz(5)*gamahb(5)
|
|
gamahb(5) = 0.D0
|
|
CALL POPREAL8(gamahnrd(5))
|
|
temp2hb17 = zz(5)*gamahnrdhb(5)/(z(3)+z(7))
|
|
f2hnrdhb(4) = f2hnrdhb(4) + temp2hb17/z(7)
|
|
hhnrdhb = hhnrdhb - zz(5)*gamahnrdhb(5)
|
|
gamahnrdhb(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp2hb15 = zz(4)*gamahb(4)/(z(3)+z(5))
|
|
f1hb(3) = f1hb(3) + temp2hb14/z(3) + temp2hb15/z(3) + temp2hb13/z(
|
|
+ 3)
|
|
f2hb(2) = f2hb(2) + temp2hb15/z(5)
|
|
hhb = hhb - zz(4)*gamahb(4)
|
|
gamahb(4) = 0.D0
|
|
CALL POPREAL8(gamahnrd(4))
|
|
temp2hb18 = zz(4)*gamahnrdhb(4)/(z(3)+z(5))
|
|
f1hnrdhb(3) = f1hnrdhb(3) + temp2hb17/z(3) + temp2hb18/z(3) +
|
|
+ temp2hb16/z(3)
|
|
f2hnrdhb(2) = f2hnrdhb(2) + temp2hb18/z(5)
|
|
hhnrdhb = hhnrdhb - zz(4)*gamahnrdhb(4)
|
|
gamahnrdhb(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp2hb19 = zz(3)*gamahb(3)/(z(2)+z(7))
|
|
f2hb(4) = f2hb(4) + temp2hb19/z(7)
|
|
hhb = hhb - zz(3)*gamahb(3)
|
|
gamahb(3) = 0.D0
|
|
CALL POPREAL8(gamahnrd(3))
|
|
temp2hb22 = zz(3)*gamahnrdhb(3)/(z(2)+z(7))
|
|
f2hnrdhb(4) = f2hnrdhb(4) + temp2hb22/z(7)
|
|
hhnrdhb = hhnrdhb - zz(3)*gamahnrdhb(3)
|
|
gamahnrdhb(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp2hb20 = zz(2)*gamahb(2)/(z(2)+z(5))
|
|
f2hb(2) = f2hb(2) + temp2hb20/z(5)
|
|
hhb = hhb - zz(2)*gamahb(2)
|
|
gamahb(2) = 0.D0
|
|
CALL POPREAL8(gamahnrd(2))
|
|
temp2hb23 = zz(2)*gamahnrdhb(2)/(z(2)+z(5))
|
|
f2hnrdhb(2) = f2hnrdhb(2) + temp2hb23/z(5)
|
|
hhnrdhb = hhnrdhb - zz(2)*gamahnrdhb(2)
|
|
gamahnrdhb(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp2hb21 = zz(1)*gamahb(1)/(z(2)+z(4))
|
|
f1hb(2) = f1hb(2) + temp2hb20/z(2) + temp2hb21/z(2) + temp2hb19/z(
|
|
+ 2)
|
|
f2hb(1) = f2hb(1) + temp2hb21/z(4)
|
|
hhb = hhb - zz(1)*gamahb(1)
|
|
gamahb(1) = 0.D0
|
|
CALL POPREAL8(gamahnrd(1))
|
|
temp2hb24 = zz(1)*gamahnrdhb(1)/(z(2)+z(4))
|
|
f1hnrdhb(2) = f1hnrdhb(2) + temp2hb23/z(2) + temp2hb24/z(2) +
|
|
+ temp2hb22/z(2)
|
|
f2hnrdhb(1) = f2hnrdhb(1) + temp2hb24/z(4)
|
|
hhnrdhb = hhnrdhb - zz(1)*gamahnrdhb(1)
|
|
gamahnrdhb(1) = 0.D0
|
|
ionichb = 0.D0
|
|
ionichnrdhb = 0.D0
|
|
DO ii10=1,4
|
|
DO ii20=1,6
|
|
g0hb(ii20, ii10) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO ii10=1,4
|
|
DO ii20=1,6
|
|
g0hnrdhb(ii20, ii10) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mplhnrdhb = 0.D0
|
|
mplhb = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijhb = (g0hnrd(i, j)+zpl*zmi*hhnrd)*f2hnrdhb(j) + (g0(i, j)+
|
|
+ zpl*zmi*h)*f2hb(j)
|
|
chhnrd = -(0.25d0*(zpl+zmi)**2*ionichnrd/ionic**2)
|
|
xijhnrd = chhnrd*mpl + ch*mplhnrd
|
|
xijhnrdhb = (g0(i, j)+zpl*zmi*h)*f2hnrdhb(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0hb(i, j) = g0hb(i, j) + xijhnrd*f2hnrdhb(j) + yjihnrd*
|
|
+ f1hnrdhb(i) + yji*f1hb(i) + xij*f2hb(j)
|
|
hhb = hhb + xijhnrd*zpl*zmi*f2hnrdhb(j) + yjihnrd*zpl*zmi*
|
|
+ f1hnrdhb(i) + yji*zpl*zmi*f1hb(i) + xij*zpl*zmi*f2hb(j)
|
|
g0hnrdhb(i, j) = g0hnrdhb(i, j) + yji*f1hnrdhb(i) + xij*
|
|
+ f2hnrdhb(j)
|
|
hhnrdhb = hhnrdhb + yji*zpl*zmi*f1hnrdhb(i) + xij*zpl*zmi*
|
|
+ f2hnrdhb(j)
|
|
yjihb = (g0hnrd(i, j)+zpl*zmi*hhnrd)*f1hnrdhb(i) + (g0(i, j)+
|
|
+ zpl*zmi*h)*f1hb(i)
|
|
yjihnrdhb = (g0(i, j)+zpl*zmi*h)*f1hnrdhb(i)
|
|
temp2hb = molal(j+3)*yjihb/water
|
|
CALL POPREAL8(yjihnrd)
|
|
temp2hb0 = yjihnrdhb/water**2
|
|
temp1hb2 = water*temp2hb0
|
|
molalhb(j+3) = molalhb(j+3) + chhnrd*temp1hb2 - ch*waterhnrd*
|
|
+ temp2hb0 + ch*yjihb/water
|
|
temp1 = chhnrd*molal(j+3) + ch*molalhnrd(j+3)
|
|
waterhb = waterhb + (temp1-(temp1*water-molal(j+3)*(ch*
|
|
+ waterhnrd))*2/water)*temp2hb0 - ch*temp2hb/water
|
|
temp1hb3 = -(molal(j+3)*temp2hb0)
|
|
chhb = molalhnrd(j+3)*temp1hb2 + waterhnrd*temp1hb3 + mplhnrd*
|
|
+ xijhnrdhb + mpl*xijhb + temp2hb
|
|
chhnrdhb = mpl*xijhnrdhb + molal(j+3)*temp1hb2
|
|
molalhnrdhb(j+3) = molalhnrdhb(j+3) + ch*temp1hb2
|
|
waterhnrdhb = waterhnrdhb + ch*temp1hb3
|
|
mplhb = mplhb + chhnrd*xijhnrdhb + ch*xijhb
|
|
mplhnrdhb = mplhnrdhb + ch*xijhnrdhb
|
|
temp1hb4 = -((zpl+zmi)**2*0.25d0*chhnrdhb/ionic**2)
|
|
ionichb = ionichb - ionichnrd*2*temp1hb4/ionic - (zpl+zmi)**2*
|
|
+ 0.25d0*chhb/ionic**2
|
|
ionichnrdhb = ionichnrdhb + temp1hb4
|
|
ENDDO
|
|
temp1hb1 = mplhnrdhb/water**2
|
|
CALL POPREAL8(mpl)
|
|
molalhb(i) = molalhb(i) + mplhb/water - waterhnrd*temp1hb1
|
|
waterhb = waterhb + (molalhnrd(i)-(molalhnrd(i)*water-molal(i)*
|
|
+ waterhnrd)*2/water)*temp1hb1 - molal(i)*mplhb/water**2
|
|
CALL POPREAL8(mplhnrd)
|
|
molalhnrdhb(i) = molalhnrdhb(i) + water*temp1hb1
|
|
waterhnrdhb = waterhnrdhb - molal(i)*temp1hb1
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp1hb0 = hhnrdhb/(sion+1.d0)**2
|
|
temp1hb = agama*hhb/(sion+1.d0)
|
|
sionhb = (1.D0-sion/(sion+1.d0))*temp1hb - (agama*(sionhnrd*(sion+
|
|
+ 1.d0))-agama*(sion*sionhnrd))*2*temp1hb0/(sion+1.d0)
|
|
sionhnrdhb = (agama*(sion+1.d0)-agama*sion)*temp1hb0
|
|
IF (.NOT.ionic == 0.0) ionichb = ionichb + sionhb/(2.0*SQRT(
|
|
+ ionic))
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp0 = SQRT(ionic)
|
|
temp0hb1 = sionhnrdhb/(2.0*temp0)
|
|
ionichnrdhb = ionichnrdhb + temp0hb1
|
|
IF (.NOT.ionic == 0.0) ionichb = ionichb - ionichnrd*temp0hb1/
|
|
+ (2.0*temp0**2)
|
|
END IF
|
|
g05hb = g0hb(3, 4)
|
|
g0hb(3, 4) = 0.D0
|
|
g05hnrdhb = g0hnrdhb(3, 4)
|
|
g0hnrdhb(3, 4) = 0.D0
|
|
g09hb = g0hb(3, 3)
|
|
g0hb(3, 3) = 0.D0
|
|
g09hnrdhb = g0hnrdhb(3, 3)
|
|
g0hnrdhb(3, 3) = 0.D0
|
|
g04hb = g0hb(3, 2)
|
|
g0hb(3, 2) = 0.D0
|
|
g04hnrdhb = g0hnrdhb(3, 2)
|
|
g0hnrdhb(3, 2) = 0.D0
|
|
g06hb = g0hb(3, 1)
|
|
g0hb(3, 1) = 0.D0
|
|
g06hnrdhb = g0hnrdhb(3, 1)
|
|
g0hnrdhb(3, 1) = 0.D0
|
|
g03hb = g0hb(2, 4)
|
|
g0hb(2, 4) = 0.D0
|
|
g03hnrdhb = g0hnrdhb(2, 4)
|
|
g0hnrdhb(2, 4) = 0.D0
|
|
g12hb = g0hb(2, 3)
|
|
g0hb(2, 3) = 0.D0
|
|
g12hnrdhb = g0hnrdhb(2, 3)
|
|
g0hnrdhb(2, 3) = 0.D0
|
|
g02hb = g0hb(2, 2)
|
|
g0hb(2, 2) = 0.D0
|
|
g02hnrdhb = g0hnrdhb(2, 2)
|
|
g0hnrdhb(2, 2) = 0.D0
|
|
g01hb = g0hb(2, 1)
|
|
g0hb(2, 1) = 0.D0
|
|
g01hnrdhb = g0hnrdhb(2, 1)
|
|
g0hnrdhb(2, 1) = 0.D0
|
|
g10hb = g0hb(1, 4)
|
|
g0hb(1, 4) = 0.D0
|
|
g10hnrdhb = g0hnrdhb(1, 4)
|
|
g0hnrdhb(1, 4) = 0.D0
|
|
g08hb = g0hb(1, 3)
|
|
g0hb(1, 3) = 0.D0
|
|
g08hnrdhb = g0hnrdhb(1, 3)
|
|
g0hnrdhb(1, 3) = 0.D0
|
|
g07hb = g0hb(1, 2)
|
|
g0hb(1, 2) = 0.D0
|
|
g07hnrdhb = g0hnrdhb(1, 2)
|
|
g0hnrdhb(1, 2) = 0.D0
|
|
g11hb = g0hb(1, 1)
|
|
g11hnrdhb = g0hnrdhb(1, 1)
|
|
CALL KMFUL3_HNRD_HB(ionic, ionichb, ionichnrd, ionichnrdhb, temp,
|
|
+ g01, g01hb, g01hnrd, g01hnrdhb, g02, g02hb,
|
|
+ g02hnrd, g02hnrdhb, g03, g03hb, g03hnrd,
|
|
+ g03hnrdhb, g04, g04hb, g04hnrd, g04hnrdhb, g05
|
|
+ , g05hb, g05hnrd, g05hnrdhb, g06, g06hb,
|
|
+ g06hnrd, g06hnrdhb, g07, g07hb, g07hnrd,
|
|
+ g07hnrdhb, g08, g08hb, g08hnrd, g08hnrdhb, g09
|
|
+ , g09hb, g09hnrd, g09hnrdhb, g10, g10hb,
|
|
+ g10hnrd, g10hnrdhb, g11, g11hb, g11hnrd,
|
|
+ g11hnrdhb, g12, g12hb, g12hnrd, g12hnrdhb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionichnrd)
|
|
CALL POPREAL8(ionic)
|
|
x1hnrdhb = 0.D0
|
|
x1hb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1hb = ionichb
|
|
CALL POPREAL8(ionichnrd)
|
|
x1hnrdhb = ionichnrdhb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ionichb = 0.D0
|
|
ionichnrdhb = 0.D0
|
|
ELSE
|
|
temp0hb0 = x1hnrdhb/water**2
|
|
temp0hb = 0.5d0*x1hb/water
|
|
ionichb = temp0hb - 0.5d0*waterhnrd*temp0hb0
|
|
waterhb = waterhb + (0.5d0*ionichnrd-(0.5d0*(ionichnrd*water)-
|
|
+ 0.5d0*(ionic*waterhnrd))*2/water)*temp0hb0 - ionic*temp0hb/
|
|
+ water
|
|
ionichnrdhb = 0.5d0*water*temp0hb0
|
|
waterhnrdhb = waterhnrdhb - 0.5d0*ionic*temp0hb0
|
|
END IF
|
|
DO i=7,1,-1
|
|
molalhb(i) = molalhb(i) + z(i)**2*ionichb
|
|
molalhnrdhb(i) = molalhnrdhb(i) + z(i)**2*ionichnrdhb
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of kmful3_hnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: g05hnrd g01hnrd ionichnrd g01
|
|
C g06hnrd g02 g03 g04 g05 g06 g07 g08 g09 g02hnrd
|
|
C g07hnrd g10hnrd g10 g11 g12 g03hnrd g08hnrd g11hnrd
|
|
C ionic g04hnrd g09hnrd g12hnrd
|
|
C with respect to varying inputs: ionichnrd ionic
|
|
C
|
|
C Differentiation of kmful3 in forward (tangent) mode:
|
|
C variations of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_HNRD_HB(ionic, ionichb, ionichnrd, ionichnrdhb,
|
|
+ temp, g01, g01hb, g01hnrd, g01hnrdhb,
|
|
+ g02, g02hb, g02hnrd, g02hnrdhb, g03,
|
|
+ g03hb, g03hnrd, g03hnrdhb, g04, g04hb,
|
|
+ g04hnrd, g04hnrdhb, g05, g05hb, g05hnrd
|
|
+ , g05hnrdhb, g06, g06hb, g06hnrd,
|
|
+ g06hnrdhb, g07, g07hb, g07hnrd,
|
|
+ g07hnrdhb, g08, g08hb, g08hnrd,
|
|
+ g08hnrdhb, g09, g09hb, g09hnrd,
|
|
+ g09hnrdhb, g10, g10hb, g10hnrd,
|
|
+ g10hnrdhb, g11, g11hb, g11hnrd,
|
|
+ g11hnrdhb, g12, g12hb, g12hnrd,
|
|
+ g12hnrdhb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionichb, sionhb, cf2hb
|
|
REAL*8 :: ionichnrd, sionhnrd, cf2hnrd
|
|
REAL*8 :: ionichnrdhb, sionhnrdhb, cf2hnrdhb
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01hb, g02hb, g03hb, g04hb, g05hb, g06hb, g07hb,
|
|
+ g08hb, g09hb, g10hb, g11hb, g12hb
|
|
REAL*8 :: g01hnrd, g02hnrd, g03hnrd, g04hnrd, g05hnrd,
|
|
+ g06hnrd, g07hnrd, g08hnrd, g09hnrd, g10hnrd,
|
|
+ g11hnrd, g12hnrd
|
|
REAL*8 :: g01hnrdhb, g02hnrdhb, g03hnrdhb, g04hnrdhb,
|
|
+ g05hnrdhb, g06hnrdhb, g07hnrdhb, g08hnrdhb,
|
|
+ g09hnrdhb, g10hnrdhb, g11hnrdhb, g12hnrdhb
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs1, tiny
|
|
INTRINSIC SQRT
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0hb
|
|
REAL*8 :: temp1hb
|
|
REAL*8 :: abs2
|
|
REAL*8 :: temp1hb3
|
|
REAL*8 :: temp1hb2
|
|
REAL*8 :: temp1hb1
|
|
REAL*8 :: temp1hb0
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
tiny = 1.d-20
|
|
IF (ionic >= 0.) THEN
|
|
abs2 = ionic
|
|
ELSE
|
|
abs2 = -ionic
|
|
END IF
|
|
IF (abs2 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
sionhnrd = 0.d0
|
|
ELSE
|
|
sionhnrd = ionichnrd/(2.0*SQRT(ionic))
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.d0) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01hb = g01hb + g12hb
|
|
g08hb = g08hb + g09hb + g12hb
|
|
g11hb = g11hb - g09hb - g12hb
|
|
g01hnrdhb = g01hnrdhb + g12hnrdhb
|
|
g08hnrdhb = g08hnrdhb + g09hnrdhb + g12hnrdhb
|
|
g11hnrdhb = g11hnrdhb - g09hnrdhb - g12hnrdhb
|
|
g06hb = g06hb + g09hb
|
|
g06hnrdhb = g06hnrdhb + g09hnrdhb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2hb = -(z10*g10hb) - z07*g07hb - z05*g05hb - z03*g03hb - z01*
|
|
+ g01hb - z02*g02hb - z04*g04hb - z06*g06hb - z08*g08hb - z11*
|
|
+ g11hb
|
|
g11hb = cf1*g11hb
|
|
cf2hnrdhb = -(z10*g10hnrdhb) - z07*g07hnrdhb - z05*g05hnrdhb -
|
|
+ z03*g03hnrdhb - z01*g01hnrdhb - z02*g02hnrdhb - z04*g04hnrdhb
|
|
+ - z06*g06hnrdhb - z08*g08hnrdhb - z11*g11hnrdhb
|
|
g11hnrdhb = cf1*g11hnrdhb
|
|
g10hb = cf1*g10hb
|
|
g10hnrdhb = cf1*g10hnrdhb
|
|
g08hb = cf1*g08hb
|
|
g08hnrdhb = cf1*g08hnrdhb
|
|
g07hb = cf1*g07hb
|
|
g07hnrdhb = cf1*g07hnrdhb
|
|
g06hb = cf1*g06hb
|
|
g06hnrdhb = cf1*g06hnrdhb
|
|
g05hb = cf1*g05hb
|
|
g05hnrdhb = cf1*g05hnrdhb
|
|
g04hb = cf1*g04hb
|
|
g04hnrdhb = cf1*g04hnrdhb
|
|
g03hb = cf1*g03hb
|
|
g03hnrdhb = cf1*g03hnrdhb
|
|
g02hb = cf1*g02hb
|
|
g02hnrdhb = cf1*g02hnrdhb
|
|
g01hb = cf1*g01hb
|
|
g01hnrdhb = cf1*g01hnrdhb
|
|
temp1hb = (0.125d0-ti*0.005d0)*cf2hb
|
|
temp1hb0 = -(0.41d0*temp1hb/(sion+1.d0))
|
|
temp1hb3 = (0.125d0-ti*0.005d0)*cf2hnrdhb
|
|
temp1hb1 = 0.92d0*0.039d0*temp1hb3
|
|
ionichb = ionichb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp1hb -
|
|
+ ionichnrd*0.8d0*ionic**(-1.8D0)*temp1hb1
|
|
temp1hb2 = -(temp1hb3/(sion+1.d0)**2)
|
|
sionhb = (1.D0-sion/(sion+1.d0))*temp1hb0 - (0.41d0*(sionhnrd*(
|
|
+ sion+1.d0))-0.41d0*(sion*sionhnrd))*2*temp1hb2/(sion+1.d0)
|
|
ionichnrdhb = ionichnrdhb + ionic**(-0.8d0)*temp1hb1
|
|
sionhnrdhb = (0.41d0*(sion+1.d0)-0.41d0*sion)*temp1hb2
|
|
ELSE
|
|
sionhb = 0.D0
|
|
sionhnrdhb = 0.D0
|
|
END IF
|
|
CALL MKBI_HNRD_HB(q11, ionic, ionichb, ionichnrd, ionichnrdhb,
|
|
+ sion, sionhb, sionhnrd, sionhnrdhb, z11, g11,
|
|
+ g11hb, g11hnrd, g11hnrdhb)
|
|
CALL MKBI_HNRD_HB(q10, ionic, ionichb, ionichnrd, ionichnrdhb,
|
|
+ sion, sionhb, sionhnrd, sionhnrdhb, z10, g10,
|
|
+ g10hb, g10hnrd, g10hnrdhb)
|
|
CALL MKBI_HNRD_HB(q8, ionic, ionichb, ionichnrd, ionichnrdhb, sion
|
|
+ , sionhb, sionhnrd, sionhnrdhb, z08, g08, g08hb
|
|
+ , g08hnrd, g08hnrdhb)
|
|
CALL MKBI_HNRD_HB(q7, ionic, ionichb, ionichnrd, ionichnrdhb, sion
|
|
+ , sionhb, sionhnrd, sionhnrdhb, z07, g07, g07hb
|
|
+ , g07hnrd, g07hnrdhb)
|
|
CALL MKBI_HNRD_HB(q6, ionic, ionichb, ionichnrd, ionichnrdhb, sion
|
|
+ , sionhb, sionhnrd, sionhnrdhb, z06, g06, g06hb
|
|
+ , g06hnrd, g06hnrdhb)
|
|
CALL MKBI_HNRD_HB(q5, ionic, ionichb, ionichnrd, ionichnrdhb, sion
|
|
+ , sionhb, sionhnrd, sionhnrdhb, z05, g05, g05hb
|
|
+ , g05hnrd, g05hnrdhb)
|
|
CALL MKBI_HNRD_HB(q4, ionic, ionichb, ionichnrd, ionichnrdhb, sion
|
|
+ , sionhb, sionhnrd, sionhnrdhb, z04, g04, g04hb
|
|
+ , g04hnrd, g04hnrdhb)
|
|
CALL MKBI_HNRD_HB(q3, ionic, ionichb, ionichnrd, ionichnrdhb, sion
|
|
+ , sionhb, sionhnrd, sionhnrdhb, z03, g03, g03hb
|
|
+ , g03hnrd, g03hnrdhb)
|
|
CALL MKBI_HNRD_HB(q2, ionic, ionichb, ionichnrd, ionichnrdhb, sion
|
|
+ , sionhb, sionhnrd, sionhnrdhb, z02, g02, g02hb
|
|
+ , g02hnrd, g02hnrdhb)
|
|
CALL MKBI_HNRD_HB(q1, ionic, ionichb, ionichnrd, ionichnrdhb, sion
|
|
+ , sionhb, sionhnrd, sionhnrdhb, z01, g01, g01hb
|
|
+ , g01hnrd, g01hnrdhb)
|
|
IF (.NOT.ionic == 0.0) ionichb = ionichb + sionhb/(2.0*SQRT(
|
|
+ ionic))
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp0 = SQRT(ionic)
|
|
temp0hb = sionhnrdhb/(2.0*temp0)
|
|
ionichnrdhb = ionichnrdhb + temp0hb
|
|
IF (.NOT.ionic == 0.0) ionichb = ionichb - ionichnrd*temp0hb/(
|
|
+ 2.0*temp0**2)
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of mkbi_hnrd in reverse (adjoint) mode:
|
|
C gradient of useful results: bihnrd ionichnrd sion bi ionic
|
|
C sionhnrd
|
|
C with respect to varying inputs: ionichnrd sion ionic sionhnrd
|
|
C
|
|
C Differentiation of mkbi in forward (tangent) mode:
|
|
C variations of useful results: bi
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_HNRD_HB(q, ionic, ionichb, ionichnrd, ionichnrdhb
|
|
+ , sion, sionhb, sionhnrd, sionhnrdhb, zip
|
|
+ , bi, bihb, bihnrd, bihnrdhb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionichb, sionhb, bihb
|
|
REAL*8 :: ionichnrd, sionhnrd, bihnrd
|
|
REAL*8 :: ionichnrdhb, sionhnrdhb, bihnrdhb
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: chb, xxhb
|
|
REAL*8 :: chnrd, xxhnrd
|
|
REAL*8 :: chnrdhb, xxhnrdhb
|
|
REAL*8 :: arg1
|
|
REAL*8 :: arg1hb
|
|
REAL*8 :: arg1hnrd
|
|
REAL*8 :: arg1hnrdhb
|
|
REAL*8 :: pwx1
|
|
REAL*8 :: pwx1hb
|
|
REAL*8 :: pwx1hnrd
|
|
REAL*8 :: pwx1hnrdhb
|
|
REAL*8 :: pwr1
|
|
REAL*8 :: pwr1hb
|
|
REAL*8 :: pwr1hnrd, tiny
|
|
REAL*8 :: pwr1hnrdhb
|
|
INTRINSIC EXP
|
|
INTRINSIC LOG10
|
|
INTEGER :: branch
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp0hb
|
|
INTRINSIC ABS
|
|
REAL*8 :: x1
|
|
REAL*8 :: temphb2
|
|
REAL*8 :: temphb1
|
|
REAL*8 :: temphb0
|
|
REAL*8 :: temp1hb
|
|
INTRINSIC LOG
|
|
INTRINSIC INT
|
|
REAL*8 :: abs3
|
|
REAL*8 :: abs2
|
|
REAL*8 :: temp1hb3
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp1hb2
|
|
REAL*8 :: temp1hb1
|
|
REAL*8 :: temp1hb0
|
|
REAL*8 :: temphb
|
|
REAL*8 :: temp
|
|
tiny = 1.d-20
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
arg1hnrd = -(.023d0*((ionichnrd*ionic+ionic*ionichnrd)*ionic+ionic
|
|
+ **2*ionichnrd))
|
|
arg1 = -(.023d0*ionic*ionic*ionic)
|
|
chnrd = .055d0*q*arg1hnrd*EXP(arg1)
|
|
c = 1.d0 + .055d0*q*EXP(arg1)
|
|
pwx1hnrd = .1d0*ionichnrd
|
|
pwx1 = 1.d0 + .1d0*ionic
|
|
x1 = q - INT(q)
|
|
IF (x1 >= 0.) THEN
|
|
abs1 = x1
|
|
ELSE
|
|
abs1 = -x1
|
|
END IF
|
|
IF (pwx1 > 0.d0 .OR. (pwx1 < 0.d0 .AND. abs1 < tiny))
|
|
+THEN
|
|
pwr1hnrd = q*pwx1**(q-1)*pwx1hnrd
|
|
CALL PUSHCONTROL2B(0)
|
|
ELSE
|
|
IF (pwx1 >= 0.) THEN
|
|
abs2 = pwx1
|
|
ELSE
|
|
abs2 = -pwx1
|
|
END IF
|
|
IF (q - 1.d0 >= 0.) THEN
|
|
abs3 = q - 1.d0
|
|
ELSE
|
|
abs3 = -(q-1.d0)
|
|
END IF
|
|
IF (abs2 < tiny .AND. abs3 < tiny) THEN
|
|
pwr1hnrd = pwx1hnrd
|
|
CALL PUSHCONTROL2B(1)
|
|
ELSE
|
|
pwr1hnrd = 0.d0
|
|
CALL PUSHCONTROL2B(2)
|
|
END IF
|
|
END IF
|
|
pwr1 = pwx1**q
|
|
bihnrd = b*pwr1hnrd
|
|
bi = 1.d0 + b*pwr1 - b
|
|
C
|
|
temp1 = LOG(10.d0)
|
|
temp1hb3 = zip*bihnrdhb/(temp1*bi)
|
|
xxhb = zip*bihb
|
|
bihb = zip*bihb/(bi*LOG(10.0)) - bihnrd*temp1hb3/bi
|
|
xxhnrdhb = zip*bihnrdhb
|
|
bihnrdhb = temp1hb3
|
|
pwr1hb = b*bihb
|
|
pwr1hnrdhb = b*bihnrdhb
|
|
IF (pwx1 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q))) THEN
|
|
pwx1hb = 0.0
|
|
ELSE
|
|
pwx1hb = q*pwx1**(q-1)*pwr1hb
|
|
END IF
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch == 0) THEN
|
|
IF (.NOT.(pwx1 <= 0.0 .AND. (q - 1 == 0.0 .OR. q - 1 /=
|
|
+ INT(q - 1)))) pwx1hb = pwx1hb + pwx1hnrd*q*(q-1)*pwx1**(q-2)
|
|
+ *pwr1hnrdhb
|
|
pwx1hnrdhb = q*pwx1**(q-1)*pwr1hnrdhb
|
|
ELSE IF (branch == 1) THEN
|
|
pwx1hnrdhb = pwr1hnrdhb
|
|
ELSE
|
|
pwx1hnrdhb = 0.D0
|
|
END IF
|
|
temp = c*sion + 1.d0
|
|
temp1hb2 = -(xxhnrdhb/temp**2)
|
|
temp1hb1 = 0.5107d0*sionhnrd*temp1hb2
|
|
temp0 = chnrd*sion + c*sionhnrd
|
|
temp0hb = -(0.5107d0*sion*temp1hb2)
|
|
temphb1 = -((0.5107d0*(sionhnrd*(c*sion+1.d0))-0.5107d0*(sion*
|
|
+ temp0))*2*temp1hb2/temp)
|
|
temp1hb = -(0.5107d0*xxhb/(c*sion+1.d0))
|
|
temp1hb0 = -(sion*temp1hb/(c*sion+1.d0))
|
|
chb = sion*temp1hb1 + sionhnrd*temp0hb + sion*temphb1 + sion*
|
|
+ temp1hb0
|
|
chnrdhb = sion*temp0hb
|
|
temphb2 = q*.055d0*chnrdhb
|
|
arg1hb = arg1hnrd*EXP(arg1)*temphb2 + q*.055d0*EXP(arg1)*chb
|
|
arg1hnrdhb = EXP(arg1)*temphb2
|
|
temphb = -(.023d0*arg1hnrdhb)
|
|
temphb0 = ionic*temphb
|
|
ionichb = ionichb + (ionichnrd*2*ionic+ionichnrd*ionic+ionic*
|
|
+ ionichnrd)*temphb - .023d0*3*ionic**2*arg1hb + 2*ionichnrd*
|
|
+ temphb0 + .1d0*pwx1hb
|
|
ionichnrdhb = ionichnrdhb + 2*ionic*temphb0 + ionic**2*temphb +
|
|
+ .1d0*pwx1hnrdhb
|
|
sionhb = sionhb + c*temp1hb1 - 0.5107d0*temp0*temp1hb2 + chnrd*
|
|
+ temp0hb + c*temphb1 + c*temp1hb0 + temp1hb
|
|
sionhnrdhb = sionhnrdhb + c*temp0hb + 0.5107d0*(c*sion+1.d0)*
|
|
+ temp1hb2
|
|
END
|
|
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of funch6ab in forward (tangent) mode:
|
|
C variations of useful results: fh6ab
|
|
C with respect to varying inputs: x
|
|
C RW status of diff variables: fh6ab:out x:in
|
|
C
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE FUNCH6AB
|
|
C *** CASE H6
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0)
|
|
C 2. THERE IS BOTH A LIQUID & SOLID PHASE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE FUNCH6AB_HNRD(x, xhnrd, fh6ab, fh6abhnrd)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: psi4hnrd
|
|
REAL*8 :: psi5hnrd
|
|
REAL*8 :: psi6hnrd
|
|
REAL*8 :: a4hnrd
|
|
REAL*8 :: a5hnrd
|
|
REAL*8 :: a6hnrd
|
|
C
|
|
INTEGER :: j
|
|
INTEGER :: i
|
|
REAL*8 :: bb
|
|
REAL*8 :: bbhnrd
|
|
REAL*8 :: cc
|
|
REAL*8 :: cchnrd
|
|
REAL*8 :: dd
|
|
REAL*8 :: ddhnrd
|
|
REAL*8 :: smin
|
|
REAL*8 :: sminhnrd
|
|
REAL*8 :: hi
|
|
REAL*8 :: hihnrd
|
|
REAL*8 :: ohi
|
|
REAL*8 :: frno3
|
|
REAL*8 :: frno3hnrd
|
|
REAL*8 :: frcl
|
|
REAL*8 :: frclhnrd
|
|
REAL*8 :: frnh4
|
|
REAL*8 :: frnh4hnrd
|
|
REAL*8 :: result1
|
|
REAL*8 :: result1hnrd, molalrhnrd(npair)
|
|
REAL*8 :: fh6ab
|
|
REAL*8 :: fh6abhnrd
|
|
REAL*8 :: x
|
|
REAL*8 :: xhnrd
|
|
INTRINSIC MAX
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
psi6hnrd = xhnrd
|
|
psi6 = x
|
|
psi1 = chi1
|
|
psi2 = zero
|
|
psi3 = zero
|
|
psi7 = chi7
|
|
psi8 = chi8
|
|
DO ii1=1,nions
|
|
molalhnrd(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
molalrhnrd(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,npair
|
|
gamahnrd(ii1) = 0.D0
|
|
ENDDO
|
|
waterhnrd = 0.D0
|
|
gnh3hnrd = 0.D0
|
|
ghclhnrd = 0.D0
|
|
a4hnrd = 0.D0
|
|
a6hnrd = 0.D0
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
DO i=1,2
|
|
C
|
|
a1 = xk5*(water/gama(2))**3.0
|
|
a4hnrd = xk2*r*temp*2.0*gama(10)*(gamahnrd(10)*gama(5)-gama(10)*
|
|
+ gamahnrd(5))/(xkw*gama(5)**3)
|
|
a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
a5hnrd = xk4*r*temp*2.0*water*(waterhnrd*gama(10)-water*gamahnrd
|
|
+ (10))/gama(10)**3
|
|
a5 = xk4*r*temp*(water/gama(10))**2.0
|
|
a6hnrd = xk3*r*temp*2.0*water*(waterhnrd*gama(11)-water*gamahnrd
|
|
+ (11))/gama(11)**3
|
|
a6 = xk3*r*temp*(water/gama(11))**2.0
|
|
a7 = xk8*(water/gama(1))**2.0
|
|
a8 = xk9*(water/gama(3))**2.0
|
|
a9 = xk1*water/gama(7)*(gama(8)/gama(7))**2.
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
psi5hnrd = chi5*psi6hnrd - psi8*((a6hnrd*a5-a6*a5hnrd)*(chi6-
|
|
+ psi6-psi3)/a5**2-a6*psi6hnrd/a5)
|
|
psi5 = chi5*(psi6+psi7) - a6/a5*psi8*(chi6-psi6-psi3)
|
|
psi5hnrd = (psi5hnrd*(a6/a5*(chi6-psi6-psi3)+psi6+psi7)-psi5*((
|
|
+ a6hnrd*a5-a6*a5hnrd)*(chi6-psi6-psi3)/a5**2-a6*psi6hnrd/a5+
|
|
+ psi6hnrd))/(a6/a5*(chi6-psi6-psi3)+psi6+psi7)**2
|
|
psi5 = psi5/(a6/a5*(chi6-psi6-psi3)+psi6+psi7)
|
|
IF (psi5 < tiny) THEN
|
|
psi5 = tiny
|
|
psi5hnrd = 0.D0
|
|
ELSE
|
|
psi5 = psi5
|
|
END IF
|
|
C
|
|
IF (w(3) > tiny .AND. water > tiny) THEN
|
|
C First try 3rd order soln
|
|
bbhnrd = -(psi6hnrd+psi5hnrd-a4hnrd/a4**2)
|
|
bb = -(chi4+psi6+psi5+1.d0/a4)
|
|
cchnrd = chi4*(psi5hnrd+psi6hnrd)
|
|
cc = chi4*(psi5+psi6)
|
|
ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (abs(dd) < tiny) THEN
|
|
result1hnrd = 0.D0
|
|
ELSE
|
|
result1hnrd = ddhnrd/(2.0*SQRT(dd))
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
psi4hnrd = 0.5d0*(-bbhnrd-result1hnrd)
|
|
psi4 = 0.5d0*(-bb-result1)
|
|
IF (psi4 > chi4) THEN
|
|
psi4 = chi4
|
|
psi4hnrd = 0.D0
|
|
ELSE
|
|
psi4 = psi4
|
|
END IF
|
|
ELSE
|
|
psi4 = tiny
|
|
psi4hnrd = 0.D0
|
|
END IF
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
C NAI
|
|
molalhnrd(2) = 0.D0
|
|
molal(2) = psi8 + psi7 + 2.d0*psi1
|
|
C NH4I
|
|
molalhnrd(3) = psi4hnrd
|
|
molal(3) = psi4
|
|
C CLI
|
|
molalhnrd(4) = psi6hnrd
|
|
molal(4) = psi6 + psi7
|
|
C SO4I
|
|
molalhnrd(5) = 0.D0
|
|
molal(5) = psi2 + psi1
|
|
C HSO4I
|
|
molalhnrd(6) = 0.D0
|
|
molal(6) = zero
|
|
C NO3I
|
|
molalhnrd(7) = psi5hnrd
|
|
molal(7) = psi5 + psi8
|
|
C
|
|
C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3)
|
|
sminhnrd = psi5hnrd + psi6hnrd - psi4hnrd
|
|
smin = 2.d0*psi2 + psi5 + psi6 - psi4
|
|
CALL CALCPH_HNRD(smin, sminhnrd, hi, hihnrd, ohi)
|
|
molalhnrd(1) = hihnrd
|
|
molal(1) = hi
|
|
IF (chi4 - psi4 < tiny) THEN
|
|
gnh3 = tiny
|
|
gnh3hnrd = 0.D0
|
|
ELSE
|
|
gnh3hnrd = -psi4hnrd
|
|
gnh3 = chi4 - psi4
|
|
END IF
|
|
IF (chi5 - psi5 < tiny) THEN
|
|
ghno3 = tiny
|
|
ELSE
|
|
ghno3 = chi5 - psi5
|
|
END IF
|
|
IF (chi6 - psi6 < tiny) THEN
|
|
ghcl = tiny
|
|
ghclhnrd = 0.D0
|
|
ELSE
|
|
ghclhnrd = -psi6hnrd
|
|
ghcl = chi6 - psi6
|
|
END IF
|
|
C
|
|
cnh42s4 = zero
|
|
cnh4no3 = zero
|
|
IF (chi7 - psi7 < zero) THEN
|
|
cnacl = zero
|
|
ELSE
|
|
cnacl = chi7 - psi7
|
|
END IF
|
|
IF (chi8 - psi8 < zero) THEN
|
|
cnano3 = zero
|
|
ELSE
|
|
cnano3 = chi8 - psi8
|
|
END IF
|
|
IF (chi1 - psi1 < zero) THEN
|
|
cna2so4 = zero
|
|
ELSE
|
|
cna2so4 = chi1 - psi1
|
|
END IF
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM RICH CASE
|
|
C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/
|
|
C
|
|
C NACL
|
|
molalrhnrd(1) = 0.D0
|
|
molalr(1) = psi7
|
|
C NA2SO4
|
|
molalrhnrd(2) = 0.D0
|
|
molalr(2) = psi1
|
|
C NANO3
|
|
molalrhnrd(3) = 0.D0
|
|
molalr(3) = psi8
|
|
C (NH4)2SO4
|
|
molalrhnrd(4) = 0.D0
|
|
molalr(4) = zero
|
|
IF (psi5 < zero) THEN
|
|
frno3 = zero
|
|
frno3hnrd = 0.D0
|
|
ELSE
|
|
frno3hnrd = psi5hnrd
|
|
frno3 = psi5
|
|
END IF
|
|
IF (psi6 < zero) THEN
|
|
frcl = zero
|
|
frclhnrd = 0.D0
|
|
ELSE
|
|
frclhnrd = psi6hnrd
|
|
frcl = psi6
|
|
END IF
|
|
C MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3
|
|
C FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3
|
|
C MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL
|
|
IF (psi4 < frno3) THEN
|
|
molalrhnrd(5) = psi4hnrd
|
|
molalr(5) = psi4
|
|
frnh4 = zero
|
|
IF (frcl > zero) THEN
|
|
molalrhnrd(6) = 0.D0
|
|
molalr(6) = zero
|
|
ELSE
|
|
molalrhnrd(6) = frclhnrd
|
|
molalr(6) = frcl
|
|
END IF
|
|
ELSE
|
|
molalrhnrd(5) = frno3hnrd
|
|
molalr(5) = frno3
|
|
IF (psi4 - frno3 < zero) THEN
|
|
frnh4 = zero
|
|
frnh4hnrd = 0.D0
|
|
ELSE
|
|
frnh4hnrd = psi4hnrd - frno3hnrd
|
|
frnh4 = psi4 - frno3
|
|
END IF
|
|
IF (frcl > frnh4) THEN
|
|
molalrhnrd(6) = frnh4hnrd
|
|
molalr(6) = frnh4
|
|
ELSE
|
|
molalrhnrd(6) = frclhnrd
|
|
molalr(6) = frcl
|
|
END IF
|
|
END IF
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
waterhnrd = 0.D0
|
|
DO j=1,npair
|
|
waterhnrd = waterhnrd + molalrhnrd(j)/m0(j)
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
waterhnrd = 0.D0
|
|
ELSE
|
|
water = water
|
|
END IF
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3P_HNRD()
|
|
ENDDO
|
|
C
|
|
C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP ***************************
|
|
C
|
|
fh6abhnrd = (((((molalhnrd(3)*molal(4)+molal(3)*molalhnrd(4))*ghcl
|
|
+ -molal(3)*molal(4)*ghclhnrd)*gnh3/ghcl**2-molal(3)*molal(4)*
|
|
+ gnh3hnrd/ghcl)*a6/gnh3**2-molal(3)*molal(4)*a6hnrd/(ghcl*gnh3))*
|
|
+ a4/a6**2-molal(3)*molal(4)*a4hnrd/(ghcl*gnh3*a6))/a4**2
|
|
fh6ab = molal(3)*molal(4)/ghcl/gnh3/a6/a4 - one
|
|
C
|
|
RETURN
|
|
END
|
|
C
|
|
C
|
|
C Differentiation of calcph in forward (tangent) mode:
|
|
C variations of useful results: hi
|
|
C with respect to varying inputs: water gg
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCPH
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCPH_HNRD(gg, gghnrd, hi, hihnrd, ohi)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: cn, gg, hi, ohi, bb, cc, dd
|
|
REAL*8 :: cnhnrd, gghnrd, hihnrd, ohihnrd, bbhnrd, cchnrd,
|
|
+ ddhnrd
|
|
REAL*8 :: akw
|
|
REAL*8 :: akwhnrd
|
|
REAL*8 :: result1
|
|
REAL*8 :: result1hnrd
|
|
REAL*8 :: x2hnrd
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1hnrd
|
|
INTRINSIC SQRT
|
|
C
|
|
akwhnrd = xkw*rh*(waterhnrd*water+water*waterhnrd)
|
|
akw = xkw*rh*water*water
|
|
IF (abs(akw) < tiny) THEN
|
|
cnhnrd = 0.D0
|
|
ELSE
|
|
cnhnrd = akwhnrd/(2.0*SQRT(akw))
|
|
END IF
|
|
cn = SQRT(akw)
|
|
C
|
|
C *** GG = (negative charge) - (positive charge)
|
|
C
|
|
IF (gg > tiny) THEN
|
|
C H+ in excess
|
|
bbhnrd = -gghnrd
|
|
bb = -gg
|
|
cchnrd = -akwhnrd
|
|
cc = -akw
|
|
ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (abs(dd) < tiny) THEN
|
|
result1hnrd = 0.D0
|
|
ELSE
|
|
result1hnrd = ddhnrd/(2.0*SQRT(dd))
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
x1hnrd = 0.5d0*(result1hnrd-bbhnrd)
|
|
x1 = 0.5d0*(-bb+result1)
|
|
IF (x1 < cn) THEN
|
|
hihnrd = cnhnrd
|
|
hi = cn
|
|
ELSE
|
|
hihnrd = x1hnrd
|
|
hi = x1
|
|
END IF
|
|
ohi = akw/hi
|
|
ELSE
|
|
C OH- in excess
|
|
bbhnrd = gghnrd
|
|
bb = gg
|
|
cchnrd = -akwhnrd
|
|
cc = -akw
|
|
ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (abs(dd) < tiny) THEN
|
|
result1hnrd = 0.D0
|
|
ELSE
|
|
result1hnrd = ddhnrd/(2.0*SQRT(dd))
|
|
END IF
|
|
result1 = SQRT(dd)
|
|
x2hnrd = 0.5d0*(result1hnrd-bbhnrd)
|
|
x2 = 0.5d0*(-bb+result1)
|
|
IF (x2 < cn) THEN
|
|
ohihnrd = cnhnrd
|
|
ohi = cn
|
|
ELSE
|
|
ohihnrd = x2hnrd
|
|
ohi = x2
|
|
END IF
|
|
hihnrd = (akwhnrd*ohi-akw*ohihnrd)/ohi**2
|
|
hi = akw/ohi
|
|
END IF
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C Differentiation of calcact3p in forward (tangent) mode:
|
|
C variations of useful results: gama
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3P_HNRD()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0hnrd(6, 4), sionhnrd, hhnrd, chhnrd, f1hnrd(3)
|
|
+ , f2hnrd(4)
|
|
REAL*8 :: mpl, xij, yji
|
|
REAL*8 :: mplhnrd, xijhnrd, yjihnrd, ionichnrd
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01hnrd
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02hnrd
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03hnrd
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04hnrd
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05hnrd
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06hnrd
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07hnrd
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08hnrd
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09hnrd
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10hnrd
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11hnrd
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12hnrd
|
|
INTEGER :: j
|
|
REAL*8 :: x2hnrd
|
|
INTRINSIC MAX
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1hnrd
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
ionichnrd = 0.D0
|
|
DO i=1,7
|
|
ionichnrd = ionichnrd + z(i)**2*molalhnrd(i)
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
x1hnrd = 0.D0
|
|
ELSE
|
|
x1hnrd = (0.5d0*ionichnrd*water-0.5d0*ionic*waterhnrd)/water**2
|
|
x1 = 0.5d0*ionic/water
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
ionic = tiny
|
|
ionichnrd = 0.D0
|
|
ELSE
|
|
ionichnrd = x1hnrd
|
|
ionic = x1
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3_HNRD(ionic, ionichnrd, temp, g01, g01hnrd, g02,
|
|
+ g02hnrd, g03, g03hnrd, g04, g04hnrd, g05, g05hnrd
|
|
+ , g06, g06hnrd, g07, g07hnrd, g08, g08hnrd, g09,
|
|
+ g09hnrd, g10, g10hnrd, g11, g11hnrd, g12, g12hnrd
|
|
+ )
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0hnrd(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
g0hnrd(1, 1) = g11hnrd
|
|
g0(1, 1) = g11
|
|
g0hnrd(1, 2) = g07hnrd
|
|
g0(1, 2) = g07
|
|
g0hnrd(1, 3) = g08hnrd
|
|
g0(1, 3) = g08
|
|
g0hnrd(1, 4) = g10hnrd
|
|
g0(1, 4) = g10
|
|
g0hnrd(2, 1) = g01hnrd
|
|
g0(2, 1) = g01
|
|
g0hnrd(2, 2) = g02hnrd
|
|
g0(2, 2) = g02
|
|
g0hnrd(2, 3) = g12hnrd
|
|
g0(2, 3) = g12
|
|
g0hnrd(2, 4) = g03hnrd
|
|
g0(2, 4) = g03
|
|
g0hnrd(3, 1) = g06hnrd
|
|
g0(3, 1) = g06
|
|
g0hnrd(3, 2) = g04hnrd
|
|
g0(3, 2) = g04
|
|
g0hnrd(3, 3) = g09hnrd
|
|
g0(3, 3) = g09
|
|
g0hnrd(3, 4) = g05hnrd
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
IF (abs(ionic) < tiny) THEN
|
|
sionhnrd = 0.D0
|
|
ELSE
|
|
sionhnrd = ionichnrd/(2.0*SQRT(ionic))
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
hhnrd = (agama*sionhnrd*(1.d0+sion)-agama*sion*sionhnrd)/(1.d0+
|
|
+ sion)**2
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1hnrd(i) = 0.D0
|
|
f1(i) = 0.d0
|
|
f2hnrd(i) = 0.D0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2hnrd(4) = 0.D0
|
|
f2(4) = 0.d0
|
|
DO ii1=1,3
|
|
f1hnrd(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2hnrd(ii1) = 0.D0
|
|
ENDDO
|
|
C
|
|
DO i=1,3
|
|
zpl = z(i)
|
|
mplhnrd = (molalhnrd(i)*water-molal(i)*waterhnrd)/water**2
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
chhnrd = -(0.25d0*(zpl+zmi)**2*ionichnrd/ionic**2)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xijhnrd = chhnrd*mpl + ch*mplhnrd
|
|
xij = ch*mpl
|
|
yjihnrd = ((chhnrd*molal(j+3)+ch*molalhnrd(j+3))*water-ch*
|
|
+ molal(j+3)*waterhnrd)/water**2
|
|
yji = ch*molal(j+3)/water
|
|
f1hnrd(i) = f1hnrd(i) + yjihnrd*(g0(i, j)+zpl*zmi*h) + yji*(
|
|
+ g0hnrd(i, j)+zpl*zmi*hhnrd)
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2hnrd(j) = f2hnrd(j) + xijhnrd*(g0(i, j)+zpl*zmi*h) + xij*(
|
|
+ g0hnrd(i, j)+zpl*zmi*hhnrd)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gamahnrd(1) = zz(1)*((f1hnrd(2)/z(2)+f2hnrd(1)/z(4))/(z(2)+z(4))-
|
|
+ hhnrd)
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gamahnrd(2) = zz(2)*((f1hnrd(2)/z(2)+f2hnrd(2)/z(5))/(z(2)+z(5))-
|
|
+ hhnrd)
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gamahnrd(3) = zz(3)*((f1hnrd(2)/z(2)+f2hnrd(4)/z(7))/(z(2)+z(7))-
|
|
+ hhnrd)
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gamahnrd(4) = zz(4)*((f1hnrd(3)/z(3)+f2hnrd(2)/z(5))/(z(3)+z(5))-
|
|
+ hhnrd)
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gamahnrd(5) = zz(5)*((f1hnrd(3)/z(3)+f2hnrd(4)/z(7))/(z(3)+z(7))-
|
|
+ hhnrd)
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gamahnrd(6) = zz(6)*((f1hnrd(3)/z(3)+f2hnrd(1)/z(4))/(z(3)+z(4))-
|
|
+ hhnrd)
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gamahnrd(7) = zz(7)*((f1hnrd(1)/z(1)+f2hnrd(2)/z(5))/(z(1)+z(5))-
|
|
+ hhnrd)
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gamahnrd(8) = zz(8)*((f1hnrd(1)/z(1)+f2hnrd(3)/z(6))/(z(1)+z(6))-
|
|
+ hhnrd)
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gamahnrd(9) = zz(9)*((f1hnrd(3)/z(3)+f2hnrd(3)/z(6))/(z(3)+z(6))-
|
|
+ hhnrd)
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gamahnrd(10) = zz(10)*((f1hnrd(1)/z(1)+f2hnrd(4)/z(7))/(z(1)+z(7))
|
|
+ -hhnrd)
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gamahnrd(11) = zz(11)*((f1hnrd(1)/z(1)+f2hnrd(1)/z(4))/(z(1)+z(4))
|
|
+ -hhnrd)
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gamahnrd(12) = zz(12)*((f1hnrd(2)/z(2)+f2hnrd(3)/z(6))/(z(2)+z(6))
|
|
+ -hhnrd)
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
C LC ; SCAPE
|
|
gamahnrd(13) = 0.2d0*(3.d0*gamahnrd(4)+2.d0*gamahnrd(9))
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
x2 = 5.0d0
|
|
x2hnrd = 0.D0
|
|
ELSE
|
|
x2hnrd = gamahnrd(i)
|
|
x2 = gama(i)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
gamahnrd(i) = 0.D0
|
|
gama(i) = -5.0d0
|
|
ELSE
|
|
gamahnrd(i) = x2hnrd
|
|
gama(i) = x2
|
|
END IF
|
|
gamahnrd(i) = 10.d0**gama(i)*LOG(10.d0)*gamahnrd(i)
|
|
gama(i) = 10.d0**gama(i)
|
|
ENDDO
|
|
C
|
|
C Increment ACTIVITY call counter
|
|
iclact = iclact + 1
|
|
C
|
|
C *** END OF SUBROUTINE ACTIVITY ****************************************
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C Differentiation of kmful3 in forward (tangent) mode:
|
|
C variations of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_HNRD(ionic, ionichnrd, temp, g01, g01hnrd, g02,
|
|
+ g02hnrd, g03, g03hnrd, g04, g04hnrd, g05,
|
|
+ g05hnrd, g06, g06hnrd, g07, g07hnrd, g08,
|
|
+ g08hnrd, g09, g09hnrd, g10, g10hnrd, g11,
|
|
+ g11hnrd, g12, g12hnrd)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionichnrd, sionhnrd, cf2hnrd
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01hnrd, g02hnrd, g03hnrd, g04hnrd, g05hnrd,
|
|
+ g06hnrd, g07hnrd, g08hnrd, g09hnrd, g10hnrd,
|
|
+ g11hnrd, g12hnrd
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs1, tiny
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
tiny = 1.d-20
|
|
IF (abs(ionic) < tiny) THEN
|
|
sionhnrd = 0.D0
|
|
ELSE
|
|
sionhnrd = ionichnrd/(2.0*SQRT(ionic))
|
|
END IF
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
CALL MKBI_HNRD(q1, ionic, ionichnrd, sion, sionhnrd, z01, g01,
|
|
+ g01hnrd)
|
|
CALL MKBI_HNRD(q2, ionic, ionichnrd, sion, sionhnrd, z02, g02,
|
|
+ g02hnrd)
|
|
CALL MKBI_HNRD(q3, ionic, ionichnrd, sion, sionhnrd, z03, g03,
|
|
+ g03hnrd)
|
|
CALL MKBI_HNRD(q4, ionic, ionichnrd, sion, sionhnrd, z04, g04,
|
|
+ g04hnrd)
|
|
CALL MKBI_HNRD(q5, ionic, ionichnrd, sion, sionhnrd, z05, g05,
|
|
+ g05hnrd)
|
|
CALL MKBI_HNRD(q6, ionic, ionichnrd, sion, sionhnrd, z06, g06,
|
|
+ g06hnrd)
|
|
CALL MKBI_HNRD(q7, ionic, ionichnrd, sion, sionhnrd, z07, g07,
|
|
+ g07hnrd)
|
|
CALL MKBI_HNRD(q8, ionic, ionichnrd, sion, sionhnrd, z08, g08,
|
|
+ g08hnrd)
|
|
CALL MKBI_HNRD(q10, ionic, ionichnrd, sion, sionhnrd, z10, g10,
|
|
+ g10hnrd)
|
|
CALL MKBI_HNRD(q11, ionic, ionichnrd, sion, sionhnrd, z11, g11,
|
|
+ g11hnrd)
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.d0) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
cf2hnrd = (0.125d0-0.005d0*ti)*(0.039d0*0.92d0*ionic**(-0.8D0)*
|
|
+ ionichnrd-(0.41d0*sionhnrd*(1.d0+sion)-0.41d0*sion*sionhnrd)/(
|
|
+ 1.d0+sion)**2)
|
|
cf2 = (0.125d0-0.005d0*ti)*(0.039d0*ionic**0.92d0-0.41d0*sion/(
|
|
+ 1.d0+sion))
|
|
g01hnrd = cf1*g01hnrd - z01*cf2hnrd
|
|
g01 = cf1*g01 - cf2*z01
|
|
g02hnrd = cf1*g02hnrd - z02*cf2hnrd
|
|
g02 = cf1*g02 - cf2*z02
|
|
g03hnrd = cf1*g03hnrd - z03*cf2hnrd
|
|
g03 = cf1*g03 - cf2*z03
|
|
g04hnrd = cf1*g04hnrd - z04*cf2hnrd
|
|
g04 = cf1*g04 - cf2*z04
|
|
g05hnrd = cf1*g05hnrd - z05*cf2hnrd
|
|
g05 = cf1*g05 - cf2*z05
|
|
g06hnrd = cf1*g06hnrd - z06*cf2hnrd
|
|
g06 = cf1*g06 - cf2*z06
|
|
g07hnrd = cf1*g07hnrd - z07*cf2hnrd
|
|
g07 = cf1*g07 - cf2*z07
|
|
g08hnrd = cf1*g08hnrd - z08*cf2hnrd
|
|
g08 = cf1*g08 - cf2*z08
|
|
g10hnrd = cf1*g10hnrd - z10*cf2hnrd
|
|
g10 = cf1*g10 - cf2*z10
|
|
g11hnrd = cf1*g11hnrd - z11*cf2hnrd
|
|
g11 = cf1*g11 - cf2*z11
|
|
END IF
|
|
C
|
|
g09hnrd = g06hnrd + g08hnrd - g11hnrd
|
|
g09 = g06 + g08 - g11
|
|
g12hnrd = g01hnrd + g08hnrd - g11hnrd
|
|
g12 = g01 + g08 - g11
|
|
C
|
|
C *** Return point ; End of subroutine
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C Differentiation of mkbi in forward (tangent) mode:
|
|
C variations of useful results: bi
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_HNRD(q, ionic, ionichnrd, sion, sionhnrd, zip, bi
|
|
+ , bihnrd)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionichnrd, sionhnrd, bihnrd
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: chnrd, xxhnrd
|
|
REAL*8 :: arg1
|
|
REAL*8 :: arg1hnrd
|
|
REAL*8 :: pwx1
|
|
REAL*8 :: pwx1hnrd
|
|
REAL*8 :: pwr1
|
|
REAL*8 :: pwr1hnrd, tiny
|
|
INTRINSIC EXP
|
|
INTRINSIC LOG10
|
|
tiny = 1.d-20
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
arg1hnrd = -(.023d0*((ionichnrd*ionic+ionic*ionichnrd)*ionic+ionic
|
|
+ **2*ionichnrd))
|
|
arg1 = -(.023d0*ionic*ionic*ionic)
|
|
chnrd = .055d0*q*arg1hnrd*EXP(arg1)
|
|
c = 1.d0 + .055d0*q*EXP(arg1)
|
|
xxhnrd = -((0.5107d0*sionhnrd*(1.d0+c*sion)-0.5107d0*sion*(chnrd*
|
|
+ sion+c*sionhnrd))/(1.d0+c*sion)**2)
|
|
xx = -(0.5107d0*sion/(1.d0+c*sion))
|
|
pwx1hnrd = .1d0*ionichnrd
|
|
pwx1 = 1.d0 + .1d0*ionic
|
|
IF (pwx1 > 0.d0 .OR. (pwx1 < 0.d0 .AND.
|
|
& abs(q-INT(q)) < tiny)) THEN
|
|
pwr1hnrd = q*pwx1**(q-1)*pwx1hnrd
|
|
ELSE IF (abs(pwx1) < tiny .AND. abs(q-1.d0) < tiny) THEN
|
|
pwr1hnrd = pwx1hnrd
|
|
ELSE
|
|
pwr1hnrd = 0.d0
|
|
END IF
|
|
pwr1 = pwx1**q
|
|
bihnrd = b*pwr1hnrd
|
|
bi = 1.d0 + b*pwr1 - b
|
|
bihnrd = zip*bihnrd/(bi*LOG(10.d0)) + zip*xxhnrd
|
|
bi = zip*LOG10(bi) + zip*xx
|
|
C
|
|
RETURN
|
|
END
|
|
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of isrp3f in reverse (adjoint) mode:
|
|
C gradient of useful results: aerliq gas
|
|
C with respect to varying inputs: wp aerliq gas
|
|
C RW status of diff variables: wp:out aerliq:in-out gas:in-out
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ISRP3F
|
|
C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF
|
|
C AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE & SODIUM
|
|
C RATIOS AND BY THE AMBIENT RELATIVE HUMIDITY.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISRP3F_IB(wpib,gasib, aerliqib)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: gas(3), aerliq(NIONS+NGASAQ+2)
|
|
REAL*8 :: wpib(ncomp), gasib(3), aerliqib(NIONS+NGASAQ+2)
|
|
REAL*8 :: rest
|
|
REAL*8 :: restib
|
|
INTEGER :: i, ncase, npflag
|
|
INTEGER :: branch
|
|
INTEGER :: ii1
|
|
C
|
|
C *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE *********
|
|
C
|
|
rest = 2.d0*w(2) + w(4) + w(5)
|
|
IF (w(1) > rest) THEN
|
|
C NA > 2*SO4+CL+NO3 ?
|
|
C Adjust Na amount
|
|
w(1) = (one-1d-6)*rest
|
|
CALL PUSHERR(50, 'ISRP3F')
|
|
C Warning error: Na adjusted
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHINTEGER4(iclact)
|
|
CALL PUSHREAL8(water)
|
|
CALL PUSHREAL8ARRAY(gamou, npair)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
CALL PUSHREAL8ARRAY(molalr, npair)
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
C
|
|
C IF(METSTBL == 1) THEN
|
|
C Only liquid (metastable)
|
|
CALL CALCI6()
|
|
C ELSE
|
|
C
|
|
C MINOR SPECIES: HNO3, HCl
|
|
CALL CALCNHA_IFWD()
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3()
|
|
CALL CALCACT3F()
|
|
C NH3
|
|
ghclib = gasib(3)
|
|
gasib(3) = 0.D0
|
|
ghno3ib = gasib(2)
|
|
gasib(2) = 0.D0
|
|
gnh3ib = gasib(1)
|
|
gasib(1) = 0.D0
|
|
aerliqib(nions+ngasaq+2) = 0.D0
|
|
waterib = 1.0d3*aerliqib(nions+1)/18.0d0
|
|
aerliqib(nions+1) = 0.D0
|
|
DO i=ngasaq,1,-1
|
|
aerliqib(nions+1+i) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,nions
|
|
molalib(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=nions,1,-1
|
|
molalib(i) = molalib(i) + aerliqib(i)
|
|
aerliqib(i) = 0.D0
|
|
ENDDO
|
|
CALL CALCNH3_IB()
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3_IB()
|
|
C WRITE(*,*) 'After CALCACT3_IB: molalib ',molalib
|
|
CALL CALCNHA_IBWD()
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL POPREAL8ARRAY(molalr, npair)
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPREAL8ARRAY(gamou, npair)
|
|
CALL POPREAL8(water)
|
|
CALL POPINTEGER4(iclact)
|
|
CALL CALCI6_IB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
restib = (one-1d-6)*wib(1)
|
|
wib(1) = 0.D0
|
|
ELSE
|
|
restib = 0.D0
|
|
END IF
|
|
wib(2) = wib(2) + 2.d0*restib
|
|
wib(4) = wib(4) + restib
|
|
wib(5) = wib(5) + restib
|
|
wpib = wib
|
|
C
|
|
END
|
|
|
|
C Differentiation of calci6 in reverse (adjoint) mode:
|
|
C gradient of useful results: w molal gama water ghno3 ghcl
|
|
C with respect to varying inputs: w
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCI6
|
|
C *** CASE I6
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0)
|
|
C 2. SOLID & LIQUID AEROSOL POSSIBLE
|
|
C 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCI6_IB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: molalrib(npair)
|
|
REAL*8 :: psi1ib
|
|
REAL*8 :: psi2ib
|
|
REAL*8 :: psi3ib
|
|
REAL*8 :: psi4ib
|
|
REAL*8 :: psi5ib
|
|
REAL*8 :: psi6ib
|
|
REAL*8 :: aerliq(NIONS+NGASAQ+2), gas(3)
|
|
REAL*8 :: frso4
|
|
REAL*8 :: frso4ib
|
|
REAL*8 :: frnh4
|
|
REAL*8 :: frnh4ib
|
|
INTEGER :: i
|
|
REAL*8 :: bb
|
|
REAL*8 :: bbib
|
|
REAL*8 :: cc
|
|
REAL*8 :: ccib
|
|
REAL*8 :: dd
|
|
REAL*8 :: ddib
|
|
INTEGER :: j
|
|
INTEGER :: branch
|
|
INTEGER :: ad_count
|
|
INTEGER :: i0
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: min1
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp1ib
|
|
REAL*8 :: temp2ib
|
|
REAL*8 :: min1ib
|
|
INTRINSIC MIN
|
|
REAL*8 :: temp0ib
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** FIND DRY COMPOSITION **********************************************
|
|
C
|
|
C CALL CALCI1A
|
|
C
|
|
C *** CALCULATE NON VOLATILE SOLIDS ***********************************
|
|
C
|
|
cna2so4 = 0.5d0*w(1)
|
|
cnh4hs4 = zero
|
|
cnahso4 = zero
|
|
cnh42s4 = zero
|
|
IF (w(2) - cna2so4 < zero) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
frso4 = zero
|
|
ELSE
|
|
frso4 = w(2) - cna2so4
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (w(3)/3.d0 > frso4/2.d0) THEN
|
|
clc = frso4/2.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
clc = w(3)/3.d0
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (frso4 - 2.d0*clc < zero) THEN
|
|
frso4 = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
frso4 = frso4 - 2.d0*clc
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (w(3) - 3.d0*clc < zero) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
frnh4 = zero
|
|
ELSE
|
|
frnh4 = w(3) - 3.d0*clc
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
IF (frso4 <= tiny) THEN
|
|
IF (clc - frnh4 < zero) THEN
|
|
clc = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
clc = clc - frnh4
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
cnh42s4 = 2.d0*frnh4
|
|
C
|
|
CALL PUSHCONTROL3B(0)
|
|
ELSE IF (frnh4 <= tiny) THEN
|
|
IF (frso4 > clc) THEN
|
|
min1 = clc
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
min1 = frso4
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
cnh4hs4 = 3.d0*min1
|
|
IF (clc - frso4 < zero) THEN
|
|
clc = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
clc = clc - frso4
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (cna2so4 > tiny) THEN
|
|
IF (frso4 - cnh4hs4/3.d0 < zero) THEN
|
|
frso4 = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
frso4 = frso4 - cnh4hs4/3.d0
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
cnahso4 = 2.d0*frso4
|
|
IF (cna2so4 - frso4 < zero) THEN
|
|
cna2so4 = zero
|
|
CALL PUSHCONTROL3B(4)
|
|
ELSE
|
|
cna2so4 = cna2so4 - frso4
|
|
CALL PUSHCONTROL3B(3)
|
|
END IF
|
|
ELSE
|
|
CALL PUSHCONTROL3B(1)
|
|
END IF
|
|
ELSE
|
|
CALL PUSHCONTROL3B(2)
|
|
END IF
|
|
C
|
|
C *** CALCULATE GAS SPECIES *********************************************
|
|
C
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
C Save from CALCI1 run
|
|
C
|
|
C ASSIGN INITIAL PSI's
|
|
psi1 = cnh4hs4
|
|
psi2 = clc
|
|
psi3 = cnahso4
|
|
psi4 = cna2so4
|
|
psi5 = cnh42s4
|
|
C
|
|
C Outer loop activity calculation flag
|
|
frst = .true.
|
|
calain = .true.
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
i = 1
|
|
ad_count = 0
|
|
DO WHILE (i <= nsweep .AND. calain)
|
|
C
|
|
a6 = xk1*water/gama(7)*(gama(8)/gama(7))**2.
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
C PSI6
|
|
bb = psi2 + psi4 + psi5 + a6
|
|
cc = -(a6*(psi2+psi3+psi1))
|
|
dd = bb*bb - 4.d0*cc
|
|
psi6 = 0.5d0*(-bb+SQRT(dd))
|
|
CALL PUSHREAL8(molal(1))
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
C HI
|
|
molal(1) = psi6
|
|
CALL PUSHREAL8(molal(2))
|
|
C NAI
|
|
molal(2) = 2.d0*psi4 + psi3
|
|
CALL PUSHREAL8(molal(3))
|
|
C NH4I
|
|
molal(3) = 3.d0*psi2 + 2.d0*psi5 + psi1
|
|
CALL PUSHREAL8(molal(5))
|
|
C SO4I
|
|
molal(5) = psi2 + psi4 + psi5 + psi6
|
|
CALL PUSHREAL8(molal(6))
|
|
C HSO4I
|
|
molal(6) = psi2 + psi3 + psi1 - psi6
|
|
C CALL CALCMR ! Water content
|
|
C (NH4)2SO4
|
|
molalr(4) = psi5
|
|
C NA2SO4
|
|
molalr(2) = psi4
|
|
C NH4HSO4
|
|
molalr(9) = psi1
|
|
C NAHSO4
|
|
molalr(12) = psi3
|
|
C LC
|
|
molalr(13) = psi2
|
|
CALL PUSHREAL8(water)
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
DO j=1,npair
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3()
|
|
i = i + 1
|
|
ad_count = ad_count + 1
|
|
ENDDO
|
|
CALL PUSHINTEGER4(ad_count)
|
|
DO ii1=1,npair
|
|
molalrib(ii1) = 0.D0
|
|
ENDDO
|
|
psi1ib = 0.D0
|
|
psi2ib = 0.D0
|
|
psi3ib = 0.D0
|
|
psi4ib = 0.D0
|
|
psi5ib = 0.D0
|
|
CALL POPINTEGER4(ad_count)
|
|
DO i0=1,ad_count
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3_IB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) waterib = 0.D0
|
|
DO j=npair,1,-1
|
|
molalrib(j) = molalrib(j) + waterib/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(water)
|
|
psi2ib = psi2ib + molalib(6) + molalrib(13)
|
|
molalrib(13) = 0.D0
|
|
psi3ib = psi3ib + molalib(6) + molalrib(12)
|
|
molalrib(12) = 0.D0
|
|
psi1ib = psi1ib + molalib(6) + molalrib(9)
|
|
molalrib(9) = 0.D0
|
|
CALL POPREAL8(molal(6))
|
|
psi6ib = -molalib(6)
|
|
molalib(6) = 0.D0
|
|
psi4ib = psi4ib + molalib(5) + molalrib(2)
|
|
molalrib(2) = 0.D0
|
|
psi5ib = psi5ib + molalib(5) + molalrib(4)
|
|
molalrib(4) = 0.D0
|
|
CALL POPREAL8(molal(5))
|
|
psi2ib = psi2ib + molalib(5)
|
|
psi6ib = psi6ib + molalib(5)
|
|
molalib(5) = 0.D0
|
|
CALL POPREAL8(molal(3))
|
|
psi2ib = psi2ib + 3.d0*molalib(3)
|
|
psi5ib = psi5ib + 2.d0*molalib(3)
|
|
psi1ib = psi1ib + molalib(3)
|
|
molalib(3) = 0.D0
|
|
CALL POPREAL8(molal(2))
|
|
psi4ib = psi4ib + 2.d0*molalib(2)
|
|
psi3ib = psi3ib + molalib(2)
|
|
molalib(2) = 0.D0
|
|
CALL POPREAL8(molal(1))
|
|
psi6ib = psi6ib + molalib(1)
|
|
molalib(1) = 0.D0
|
|
a6 = xk1*water/gama(7)*(gama(8)/gama(7))**2.
|
|
bb = psi2 + psi4 + psi5 + a6
|
|
cc = -(a6*(psi2+psi3+psi1))
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (dd == 0.0) THEN
|
|
ddib = 0.0
|
|
ELSE
|
|
ddib = 0.5d0*psi6ib/(2.0*SQRT(dd))
|
|
END IF
|
|
bbib = 2*bb*ddib - 0.5d0*psi6ib
|
|
ccib = -(4.d0*ddib)
|
|
temp2ib = -(a6*ccib)
|
|
a6ib = bbib - (psi2+psi3+psi1)*ccib
|
|
psi2ib = psi2ib + bbib + temp2ib
|
|
psi3ib = psi3ib + temp2ib
|
|
psi1ib = psi1ib + temp2ib
|
|
psi4ib = psi4ib + bbib
|
|
psi5ib = psi5ib + bbib
|
|
temp0 = water/gama(7)
|
|
temp1 = gama(8)/gama(7)
|
|
temp1ib = 2.*temp1*temp0*xk1*a6ib/gama(7)
|
|
temp0ib = temp1**2.*xk1*a6ib/gama(7)
|
|
gamaib(8) = gamaib(8) + temp1ib
|
|
gamaib(7) = gamaib(7) - temp0*temp0ib - temp1*temp1ib
|
|
waterib = temp0ib
|
|
ENDDO
|
|
cnh42s4ib = psi5ib
|
|
cna2so4ib = psi4ib
|
|
cnahso4ib = psi3ib
|
|
clcib = psi2ib
|
|
cnh4hs4ib = psi1ib
|
|
wib(5) = wib(5) + ghclib
|
|
wib(4) = wib(4) + ghno3ib
|
|
CALL POPCONTROL3B(branch)
|
|
IF (branch < 2) THEN
|
|
IF (branch == 0) THEN
|
|
frnh4ib = 2.d0*cnh42s4ib
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
clcib = 0.D0
|
|
ELSE
|
|
frnh4ib = frnh4ib - clcib
|
|
END IF
|
|
frso4ib = 0.D0
|
|
GOTO 110
|
|
ELSE
|
|
frso4ib = 0.D0
|
|
END IF
|
|
ELSE IF (branch == 2) THEN
|
|
frso4ib = 0.D0
|
|
GOTO 100
|
|
ELSE
|
|
IF (branch == 3) THEN
|
|
frso4ib = -cna2so4ib
|
|
ELSE
|
|
cna2so4ib = 0.D0
|
|
frso4ib = 0.D0
|
|
END IF
|
|
frso4ib = frso4ib + 2.d0*cnahso4ib
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
frso4ib = 0.D0
|
|
ELSE
|
|
cnh4hs4ib = cnh4hs4ib - frso4ib/3.d0
|
|
END IF
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
clcib = 0.D0
|
|
ELSE
|
|
frso4ib = frso4ib - clcib
|
|
END IF
|
|
min1ib = 3.d0*cnh4hs4ib
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
clcib = clcib + min1ib
|
|
ELSE
|
|
frso4ib = frso4ib + min1ib
|
|
END IF
|
|
100 frnh4ib = 0.D0
|
|
110 CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
wib(3) = wib(3) + frnh4ib
|
|
clcib = clcib - 3.d0*frnh4ib
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
frso4ib = 0.D0
|
|
ELSE
|
|
clcib = clcib - 2.d0*frso4ib
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
frso4ib = frso4ib + clcib/2.d0
|
|
ELSE
|
|
wib(3) = wib(3) + clcib/3.d0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
wib(2) = wib(2) + frso4ib
|
|
cna2so4ib = cna2so4ib - frso4ib
|
|
END IF
|
|
wib(1) = wib(1) + 0.5d0*cna2so4ib
|
|
END
|
|
|
|
C
|
|
C Differentiation of calcnh3 in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gnh3
|
|
C with respect to varying inputs: molal gama
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNH3
|
|
C *** CALCULATES AMMONIA IN GAS PHASE
|
|
C
|
|
C AMMONIA IN THE GAS PHASE IS ASSUMED A MINOR SPECIES, THAT
|
|
C DOES NOT SIGNIFICANTLY PERTURB THE AEROSOL EQUILIBRIUM.
|
|
C AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l)
|
|
C EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION.
|
|
C
|
|
C THIS IS THE VERSION USED BY THE DIRECT PROBLEM
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNH3_IB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: a1ib
|
|
REAL*8 :: chi1ib
|
|
REAL*8 :: chi2ib
|
|
C
|
|
REAL*8 :: bb, cc, diak, psi
|
|
REAL*8 :: bbib, ccib, diakib, psiib
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp1ib
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1ib
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
REAL*8 :: temp0ib
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** IS THERE A LIQUID PHASE? ******************************************
|
|
C
|
|
IF (water <= tiny) THEN
|
|
DO ii1=1,npair
|
|
gamaib(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
C
|
|
C *** CALCULATE NH3 SUBLIMATION *****************************************
|
|
C
|
|
a1 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
chi1 = molal(3)
|
|
chi2 = molal(1)
|
|
C
|
|
C a=1; b!=1; c!=1
|
|
bb = chi2 + one/a1
|
|
cc = -(chi1/a1)
|
|
C Always > 0
|
|
diak = SQRT(bb*bb - 4.d0*cc)
|
|
C One positive root
|
|
psi = 0.5*(-bb+diak)
|
|
IF (psi > chi1) THEN
|
|
x1 = chi1
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = psi
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
chi2ib = molalib(1)
|
|
psiib = molalib(1)
|
|
molalib(1) = 0.D0
|
|
chi1ib = molalib(3)
|
|
psiib = psiib + gnh3ib - molalib(3)
|
|
molalib(3) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
x1ib = 0.D0
|
|
ELSE
|
|
x1ib = psiib
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
chi1ib = chi1ib + x1ib
|
|
psiib = 0.D0
|
|
ELSE
|
|
psiib = x1ib
|
|
END IF
|
|
diakib = 0.5*psiib
|
|
IF (bb**2 - 4.d0*cc == 0.0) THEN
|
|
temp1ib = 0.0
|
|
ELSE
|
|
temp1ib = diakib/(2.0*SQRT(bb**2-4.d0*cc))
|
|
END IF
|
|
bbib = 2*bb*temp1ib - 0.5*psiib
|
|
ccib = -(4.d0*temp1ib)
|
|
chi1ib = chi1ib - ccib/a1
|
|
a1ib = chi1*ccib/a1**2 - one*bbib/a1**2
|
|
chi2ib = chi2ib + bbib
|
|
molalib(1) = molalib(1) + chi2ib
|
|
molalib(3) = molalib(3) + chi1ib
|
|
DO ii1=1,npair
|
|
gamaib(ii1) = 0.D0
|
|
ENDDO
|
|
temp0 = gama(10)/gama(5)
|
|
temp0ib = 2.0*temp0*xk2*r*temp*a1ib/(xkw*gama(5))
|
|
gamaib(10) = gamaib(10) + temp0ib
|
|
gamaib(5) = gamaib(5) - temp0*temp0ib
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of calcnha in reverse (adjoint) mode (forward sweep):
|
|
C gradient of useful results: molal gama water ghno3 ghcl
|
|
C with respect to varying inputs: w molal gama water ghno3 ghcl
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNHA
|
|
C
|
|
C THIS SUBROUTINE CALCULATES THE DISSOLUTION OF HCL, HNO3 AT
|
|
C THE PRESENCE OF (H,SO4). HCL, HNO3 ARE CONSIDERED MINOR SPECIES,
|
|
C THAT DO NOT SIGNIFICANTLY AFFECT THE EQUILIBRIUM POINT.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNHA_IFWD()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: m1, m2, m3, delcl, delno, omega
|
|
CHARACTER(LEN=40) errinf
|
|
REAL*8 :: c1
|
|
REAL*8 :: c2
|
|
REAL*8 :: c3
|
|
INTEGER :: islv
|
|
INTRINSIC MAX
|
|
INTRINSIC MIN
|
|
C
|
|
C *** SPECIAL CASE; WATER=ZERO ******************************************
|
|
C
|
|
IF (water <= tiny) THEN
|
|
IF (w(5) - molal(4) < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (w(4) - molal(7) < tiny) THEN
|
|
CALL PUSHCONTROL3B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL3B(0)
|
|
END IF
|
|
ELSE IF (w(5) <= tiny .AND. w(4) <= tiny) THEN
|
|
CALL PUSHCONTROL3B(2)
|
|
ELSE IF (w(5) <= tiny) THEN
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
C CALL HNO3 DISSOLUTION ROUTINE
|
|
CALL CALCNA()
|
|
C GOTO 60
|
|
C
|
|
C *** SPECIAL CASE; HNO3=ZERO *******************************************
|
|
C
|
|
CALL PUSHCONTROL3B(3)
|
|
ELSE IF (w(4) <= tiny) THEN
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
C CALL HCL DISSOLUTION ROUTINE
|
|
CALL CALCHA()
|
|
C GOTO 60
|
|
C ENDIF
|
|
CALL PUSHCONTROL3B(4)
|
|
ELSE
|
|
C
|
|
C *** CALCULATE EQUILIBRIUM CONSTANTS ***********************************
|
|
C
|
|
C HNO3
|
|
a3 = xk4*r*temp*(water/gama(10))**2.0
|
|
C HCL
|
|
a4 = xk3*r*temp*(water/gama(11))**2.0
|
|
C
|
|
C *** CALCULATE CUBIC EQUATION COEFFICIENTS *****************************
|
|
C
|
|
C
|
|
C H+
|
|
omega = molal(1)
|
|
C HNO3
|
|
chi3 = w(4)
|
|
C HCL
|
|
chi4 = w(5)
|
|
C
|
|
c1 = a3*chi3
|
|
c2 = a4*chi4
|
|
c3 = a3 - a4
|
|
C
|
|
m1 = (c1+c2+(omega+a4)*c3)/c3
|
|
m2 = ((omega+a4)*c2-a4*c3*chi4)/c3
|
|
m3 = -(a4*c2*chi4/c3)
|
|
C
|
|
C *** CALCULATE ROOTS ***************************************************
|
|
C
|
|
CALL POLY3(m1, m2, m3, delcl, islv)
|
|
C HCL DISSOLUTION
|
|
IF (islv /= 0) THEN
|
|
C TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT
|
|
delcl = tiny
|
|
C WRITE (ERRINF,'(1PE10.1)') TINY
|
|
C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
IF (delcl > chi4) THEN
|
|
delcl = chi4
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
delcl = delcl
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
delno = c1*delcl/(c2+c3*delcl)
|
|
IF (delno > chi3) THEN
|
|
delno = chi3
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
delno = delno
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
IF (((delcl < zero .OR. delno < zero) .OR. delcl > chi4
|
|
+ ) .OR. delno > chi3) THEN
|
|
CALL PUSHREAL8(delcl)
|
|
C TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT
|
|
delcl = tiny
|
|
delno = tiny
|
|
C WRITE (ERRINF,'(1PE10.1)') TINY
|
|
C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
CCC
|
|
CCC *** COMPARE DELTA TO TOTAL H+ ; ESTIMATE EFFECT TO HSO4 ***************
|
|
CCC
|
|
CC IF ((DELCL+DELNO)/MOLAL(1) > 0.1d0) THEN
|
|
CC WRITE (ERRINF,'(1PE10.3)') (DELCL+DELNO)/MOLAL(1)*100.0
|
|
CC CALL PUSHERR (0021, ERRINF)
|
|
CC ENDIF
|
|
C
|
|
C *** EFFECT ON LIQUID PHASE ********************************************
|
|
C
|
|
C H+ CHANGE
|
|
molal(1) = molal(1) + (delno+delcl)
|
|
C CL- CHANGE
|
|
molal(4) = molal(4) + delcl
|
|
C NO3- CHANGE
|
|
molal(7) = molal(7) + delno
|
|
IF (w(5) - molal(4) < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (w(4) - molal(7) < tiny) THEN
|
|
CALL PUSHREAL8(omega)
|
|
CALL PUSHREAL8(delcl)
|
|
CALL PUSHCONTROL3B(5)
|
|
ELSE
|
|
CALL PUSHREAL8(omega)
|
|
CALL PUSHREAL8(delcl)
|
|
CALL PUSHCONTROL3B(6)
|
|
END IF
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of calcnha in reverse (adjoint) mode (backward sweep):
|
|
C gradient of useful results: molal gama water ghno3 ghcl
|
|
C with respect to varying inputs: w molal gama water ghno3 ghcl
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNHA
|
|
C
|
|
C THIS SUBROUTINE CALCULATES THE DISSOLUTION OF HCL, HNO3 AT
|
|
C THE PRESENCE OF (H,SO4). HCL, HNO3 ARE CONSIDERED MINOR SPECIES,
|
|
C THAT DO NOT SIGNIFICANTLY AFFECT THE EQUILIBRIUM POINT.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNHA_IBWD()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: a3ib
|
|
REAL*8 :: a4ib
|
|
REAL*8 :: chi3ib
|
|
REAL*8 :: chi4ib
|
|
REAL*8 :: m1, m2, m3, delcl, delno, omega
|
|
REAL*8 :: m1ib, m2ib, m3ib, delclib, delnoib, omegaib
|
|
CHARACTER(LEN=40) :: errinf
|
|
REAL*8 :: c1
|
|
REAL*8 :: c1ib
|
|
REAL*8 :: c2
|
|
REAL*8 :: c2ib
|
|
REAL*8 :: c3
|
|
REAL*8 :: c3ib
|
|
INTEGER :: islv
|
|
INTEGER :: branch
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp3ib
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp2ib1
|
|
REAL*8 :: temp1ib
|
|
REAL*8 :: temp2ib0
|
|
REAL*8 :: temp3ib0
|
|
REAL*8 :: temp2ib
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
REAL*8 :: temp0ib
|
|
CALL POPCONTROL3B(branch)
|
|
IF (branch < 3) THEN
|
|
IF (branch == 0) THEN
|
|
DO ii1=1,ncomp
|
|
wib(ii1) = 0.D0
|
|
ENDDO
|
|
wib(4) = wib(4) + ghno3ib
|
|
molalib(7) = molalib(7) - ghno3ib
|
|
ELSE IF (branch == 1) THEN
|
|
DO ii1=1,ncomp
|
|
wib(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
DO ii1=1,ncomp
|
|
wib(ii1) = 0.D0
|
|
ENDDO
|
|
GOTO 100
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
wib(5) = wib(5) + ghclib
|
|
molalib(4) = molalib(4) - ghclib
|
|
END IF
|
|
ghno3ib = 0.D0
|
|
ghclib = 0.D0
|
|
ELSE
|
|
IF (branch < 5) THEN
|
|
IF (branch == 3) THEN
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL CALCNA_IB()
|
|
ghno3ib = 0.D0
|
|
GOTO 100
|
|
ELSE
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL CALCHA_IB()
|
|
END IF
|
|
ELSE
|
|
IF (branch == 5) THEN
|
|
CALL POPREAL8(delcl)
|
|
CALL POPREAL8(omega)
|
|
DO ii1=1,ncomp
|
|
wib(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
CALL POPREAL8(delcl)
|
|
CALL POPREAL8(omega)
|
|
DO ii1=1,ncomp
|
|
wib(ii1) = 0.D0
|
|
ENDDO
|
|
wib(4) = wib(4) + ghno3ib
|
|
molalib(7) = molalib(7) - ghno3ib
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
wib(5) = wib(5) + ghclib
|
|
molalib(4) = molalib(4) - ghclib
|
|
END IF
|
|
delnoib = molalib(1) + molalib(7)
|
|
delclib = molalib(1) + molalib(4)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
CALL POPREAL8(delcl)
|
|
delnoib = 0.D0
|
|
delclib = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
c1 = a3*chi3
|
|
c2 = a4*chi4
|
|
c3 = a3 - a4
|
|
chi3ib = delnoib
|
|
delnoib = 0.D0
|
|
ELSE
|
|
c1 = a3*chi3
|
|
c2 = a4*chi4
|
|
c3 = a3 - a4
|
|
chi3ib = 0.D0
|
|
END IF
|
|
temp3ib = delnoib/(c2+c3*delcl)
|
|
temp3ib0 = -(c1*delcl*temp3ib/(c2+c3*delcl))
|
|
c1ib = delcl*temp3ib
|
|
delclib = delclib + c3*temp3ib0 + c1*temp3ib
|
|
c2ib = temp3ib0
|
|
c3ib = delcl*temp3ib0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
chi4ib = delclib
|
|
delclib = 0.D0
|
|
ELSE
|
|
chi4ib = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) delclib = 0.D0
|
|
m1 = (c1+c2+(omega+a4)*c3)/c3
|
|
m2 = ((omega+a4)*c2-a4*c3*chi4)/c3
|
|
m3 = -(a4*c2*chi4/c3)
|
|
CALL POLY3_IB(m1, m1ib, m2, m2ib, m3, m3ib, delcl, delclib,
|
|
+ islv)
|
|
C WRITE(*,*) 'm1ib',m1ib,'m2ib',m2ib,'m3ib',m3ib
|
|
C WRITE(*,*) 'delcl(b)',delcl, delclib
|
|
C WRITE(*,*) 'islv',islv
|
|
temp2 = chi4/c3
|
|
temp2ib = -(a4*c2*m3ib/c3)
|
|
temp2ib0 = m2ib/c3
|
|
temp2ib1 = m1ib/c3
|
|
c2ib = c2ib + (omega+a4)*temp2ib0 + temp2ib1 - temp2*a4*m3ib
|
|
chi4ib = chi4ib + a4*c2ib - a4*c3*temp2ib0 + temp2ib
|
|
c3ib = c3ib + (-(((omega+a4)*c2-a4*c3*chi4)/c3)-chi4*a4)*
|
|
+ temp2ib0 + (omega-(c1+c2+(omega+a4)*c3)/c3+a4)*temp2ib1 -
|
|
+ temp2*temp2ib
|
|
a4ib = (c2-chi4*c3)*temp2ib0 - c3ib + chi4*c2ib + c3*temp2ib1
|
|
+ - temp2*c2*m3ib
|
|
omegaib = c3*temp2ib1 + c2*temp2ib0
|
|
c1ib = c1ib + temp2ib1
|
|
a3ib = chi3*c1ib + c3ib
|
|
chi3ib = chi3ib + a3*c1ib
|
|
wib(5) = wib(5) + chi4ib
|
|
wib(4) = wib(4) + chi3ib
|
|
molalib(1) = molalib(1) + omegaib
|
|
temp1 = water/gama(11)
|
|
temp1ib = 2.0*temp1*xk3*r*temp*a4ib/gama(11)
|
|
gamaib(11) = gamaib(11) - temp1*temp1ib
|
|
temp0 = water/gama(10)
|
|
temp0ib = 2.0*temp0*xk4*r*temp*a3ib/gama(10)
|
|
waterib = waterib + temp0ib + temp1ib
|
|
gamaib(10) = gamaib(10) - temp0*temp0ib
|
|
C WRITE(*,*) 'GAMA IB at end of CALCNHA_IBWD', gamaib(10)
|
|
C WRITE(*,*) 'wib(4,5)',wib(4),wib(5)
|
|
C WRITE(*,*) 'w ',w, 'rh',rh
|
|
C PAUSE
|
|
ghno3ib = 0.D0
|
|
END IF
|
|
ghclib = 0.D0
|
|
END IF
|
|
100 CONTINUE
|
|
END
|
|
|
|
C Differentiation of calcha in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water ghcl
|
|
C with respect to varying inputs: w molal gama water
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCHA
|
|
C *** CALCULATES CHLORIDES SPECIATION
|
|
C
|
|
C HYDROCHLORIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES,
|
|
C AND DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE
|
|
C HYDROCHLORIC ACID DISSOLVED IS CALCULATED FROM THE
|
|
C HCL(G) <-> (H+) + (CL-)
|
|
C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCHA_IB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: kapa, x, delt, alfa, diak
|
|
REAL*8 :: kapaib, xib, deltib, alfaib, diakib
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp1ib1
|
|
REAL*8 :: temp1ib0
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp1ib
|
|
INTEGER :: ii1
|
|
REAL*8 :: temp0ib
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** CALCULATE HCL DISSOLUTION *****************************************
|
|
C
|
|
x = w(5)
|
|
delt = 0.0d0
|
|
IF (water > tiny) THEN
|
|
kapa = molal(1)
|
|
alfa = xk3*r*temp*(water/gama(11))**2.0
|
|
diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x)
|
|
delt = 0.5*(-(kapa+alfa)+diak)
|
|
CC IF (DELT/KAPA > 0.1d0) THEN
|
|
CC WRITE (ERRINF,'(1PE10.3)') DELT/KAPA*100.0
|
|
CC CALL PUSHERR (0033, ERRINF)
|
|
CC ENDIF
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
IF (x - delt < 0.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
deltib = molalib(4) + molalib(1)
|
|
molalib(4) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
xib = 0.D0
|
|
ELSE
|
|
xib = ghclib
|
|
deltib = deltib - ghclib
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp1ib = 0.5*deltib
|
|
diakib = temp1ib
|
|
IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN
|
|
temp1ib1 = 0.0
|
|
ELSE
|
|
temp1ib1 = diakib/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x)))
|
|
END IF
|
|
temp1ib0 = 2.0*(kapa+alfa)*temp1ib1
|
|
alfaib = temp1ib0 + 4.0*x*temp1ib1 - temp1ib
|
|
kapaib = temp1ib0 - temp1ib
|
|
xib = xib + 4.0*alfa*temp1ib1
|
|
temp0 = water/gama(11)
|
|
temp0ib = 2.0*temp0*xk3*r*temp*alfaib/gama(11)
|
|
waterib = waterib + temp0ib
|
|
gamaib(11) = gamaib(11) - temp0*temp0ib
|
|
molalib(1) = molalib(1) + kapaib
|
|
END IF
|
|
DO ii1=1,ncomp
|
|
wib(ii1) = 0.D0
|
|
ENDDO
|
|
wib(5) = wib(5) + xib
|
|
END
|
|
|
|
C Differentiation of calcna in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water ghno3
|
|
C with respect to varying inputs: w molal gama water
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNA
|
|
C *** CALCULATES NITRATES SPECIATION
|
|
C
|
|
C NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT
|
|
C DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC
|
|
C ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> (H+) + (NO3-)
|
|
C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNA_IB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: alfa, delt, kapa, diak
|
|
REAL*8 :: alfaib, deltib, kapaib, diakib
|
|
REAL*8 :: x
|
|
REAL*8 :: xib
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
REAL*8 :: temp1ib1
|
|
REAL*8 :: temp1ib0
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp1ib
|
|
INTEGER :: ii1
|
|
REAL*8 :: temp0ib
|
|
INTRINSIC SQRT
|
|
C
|
|
C *** CALCULATE HNO3 DISSOLUTION ****************************************
|
|
C
|
|
x = w(4)
|
|
delt = 0.0d0
|
|
IF (water > tiny) THEN
|
|
kapa = molal(1)
|
|
alfa = xk4*r*temp*(water/gama(10))**2.0
|
|
diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x)
|
|
delt = 0.5*(-(kapa+alfa)+diak)
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
IF (x - delt < 0.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
deltib = molalib(7) + molalib(1)
|
|
molalib(7) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
xib = 0.D0
|
|
ELSE
|
|
xib = ghno3ib
|
|
deltib = deltib - ghno3ib
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp1ib = 0.5*deltib
|
|
diakib = temp1ib
|
|
IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN
|
|
temp1ib1 = 0.0
|
|
ELSE
|
|
temp1ib1 = diakib/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x)))
|
|
END IF
|
|
temp1ib0 = 2.0*(kapa+alfa)*temp1ib1
|
|
alfaib = temp1ib0 + 4.0*x*temp1ib1 - temp1ib
|
|
kapaib = temp1ib0 - temp1ib
|
|
xib = xib + 4.0*alfa*temp1ib1
|
|
temp0 = water/gama(10)
|
|
temp0ib = 2.0*temp0*xk4*r*temp*alfaib/gama(10)
|
|
waterib = waterib + temp0ib
|
|
gamaib(10) = gamaib(10) - temp0*temp0ib
|
|
molalib(1) = molalib(1) + kapaib
|
|
END IF
|
|
DO ii1=1,ncomp
|
|
wib(ii1) = 0.D0
|
|
ENDDO
|
|
wib(4) = wib(4) + xib
|
|
END
|
|
|
|
C Differentiation of calcact3 in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3_IB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0ib(6, 4), sionib, hib, chib, f1ib(3), f2ib(4)
|
|
REAL*8 :: mpl, xij, yji
|
|
REAL*8 :: mplib, xijib, yjiib, ionicib
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01ib
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02ib
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03ib
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04ib
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05ib
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06ib
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07ib
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08ib
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09ib
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10ib
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11ib
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12ib
|
|
INTEGER :: j
|
|
REAL*8 :: errou
|
|
REAL*8 :: errin
|
|
C
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0ib9
|
|
REAL*8 :: temp0ib8
|
|
REAL*8 :: temp0ib7
|
|
REAL*8 :: temp0ib6
|
|
REAL*8 :: temp0ib5
|
|
REAL*8 :: temp0ib4
|
|
REAL*8 :: temp0ib3
|
|
REAL*8 :: temp0ib2
|
|
REAL*8 :: temp0ib1
|
|
REAL*8 :: temp0ib0
|
|
INTRINSIC MAX
|
|
INTRINSIC ABS
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: x1ib
|
|
REAL*8 :: temp0ib13
|
|
REAL*8 :: temp0ib12
|
|
REAL*8 :: temp0ib11
|
|
REAL*8 :: temp0ib10
|
|
REAL*8 :: x2ib
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
REAL*8 :: temp0ib
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: y2
|
|
REAL*8 :: y1
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
DO i=1,7
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08,
|
|
+ g09, g10, g11, g12)
|
|
C
|
|
g0(1, 1) = g11
|
|
g0(1, 2) = g07
|
|
g0(1, 3) = g08
|
|
g0(1, 4) = g10
|
|
g0(2, 1) = g01
|
|
g0(2, 2) = g02
|
|
g0(2, 3) = g12
|
|
g0(2, 4) = g03
|
|
g0(3, 1) = g06
|
|
g0(3, 2) = g04
|
|
g0(3, 3) = g09
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
sion = SQRT(ionic)
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
yji = ch*molal(j+3)/water
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gama(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gama(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gama(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gama(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gama(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gama(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gama(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gama(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gama(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gama(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gama(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gama(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gama(13))
|
|
C LC ; SCAPE
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
ELSE
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
gamaib(i) = 10.d0**gama(i)*LOG(10.d0)*gamaib(i)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
gamaib(i) = 0.D0
|
|
x2ib = 0.D0
|
|
ELSE
|
|
x2ib = gamaib(i)
|
|
gamaib(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) gamaib(i) = gamaib(i) + x2ib
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamaib(4) = gamaib(4) + 0.2d0*3.d0*gamaib(13)
|
|
gamaib(9) = gamaib(9) + 0.2d0*2.d0*gamaib(13)
|
|
gamaib(13) = 0.D0
|
|
DO ii1=1,3
|
|
f1ib(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2ib(ii1) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp0ib2 = zz(12)*gamaib(12)/(z(2)+z(6))
|
|
f1ib(2) = f1ib(2) + temp0ib2/z(2)
|
|
f2ib(3) = f2ib(3) + temp0ib2/z(6)
|
|
hib = -(zz(12)*gamaib(12))
|
|
gamaib(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp0ib3 = zz(11)*gamaib(11)/(z(1)+z(4))
|
|
f2ib(1) = f2ib(1) + temp0ib3/z(4)
|
|
hib = hib - zz(11)*gamaib(11)
|
|
gamaib(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp0ib4 = zz(10)*gamaib(10)/(z(1)+z(7))
|
|
f1ib(1) = f1ib(1) + temp0ib4/z(1) + temp0ib3/z(1)
|
|
f2ib(4) = f2ib(4) + temp0ib4/z(7)
|
|
hib = hib - zz(10)*gamaib(10)
|
|
gamaib(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp0ib5 = zz(9)*gamaib(9)/(z(3)+z(6))
|
|
f1ib(3) = f1ib(3) + temp0ib5/z(3)
|
|
hib = hib - zz(9)*gamaib(9)
|
|
gamaib(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp0ib6 = zz(8)*gamaib(8)/(z(1)+z(6))
|
|
f2ib(3) = f2ib(3) + temp0ib6/z(6) + temp0ib5/z(6)
|
|
hib = hib - zz(8)*gamaib(8)
|
|
gamaib(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp0ib7 = zz(7)*gamaib(7)/(z(1)+z(5))
|
|
f1ib(1) = f1ib(1) + temp0ib7/z(1) + temp0ib6/z(1)
|
|
f2ib(2) = f2ib(2) + temp0ib7/z(5)
|
|
hib = hib - zz(7)*gamaib(7)
|
|
gamaib(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp0ib8 = zz(6)*gamaib(6)/(z(3)+z(4))
|
|
f2ib(1) = f2ib(1) + temp0ib8/z(4)
|
|
hib = hib - zz(6)*gamaib(6)
|
|
gamaib(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp0ib9 = zz(5)*gamaib(5)/(z(3)+z(7))
|
|
f2ib(4) = f2ib(4) + temp0ib9/z(7)
|
|
hib = hib - zz(5)*gamaib(5)
|
|
gamaib(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp0ib10 = zz(4)*gamaib(4)/(z(3)+z(5))
|
|
f1ib(3) = f1ib(3) + temp0ib9/z(3) + temp0ib10/z(3) + temp0ib8/z(3)
|
|
f2ib(2) = f2ib(2) + temp0ib10/z(5)
|
|
hib = hib - zz(4)*gamaib(4)
|
|
gamaib(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp0ib11 = zz(3)*gamaib(3)/(z(2)+z(7))
|
|
f2ib(4) = f2ib(4) + temp0ib11/z(7)
|
|
hib = hib - zz(3)*gamaib(3)
|
|
gamaib(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp0ib12 = zz(2)*gamaib(2)/(z(2)+z(5))
|
|
f2ib(2) = f2ib(2) + temp0ib12/z(5)
|
|
hib = hib - zz(2)*gamaib(2)
|
|
gamaib(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp0ib13 = zz(1)*gamaib(1)/(z(2)+z(4))
|
|
f1ib(2) = f1ib(2) + temp0ib12/z(2) + temp0ib13/z(2) + temp0ib11/z(
|
|
+ 2)
|
|
f2ib(1) = f2ib(1) + temp0ib13/z(4)
|
|
hib = hib - zz(1)*gamaib(1)
|
|
gamaib(1) = 0.D0
|
|
ionicib = 0.D0
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0ib(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mplib = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijib = (g0(i, j)+zpl*zmi*h)*f2ib(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0ib(i, j) = g0ib(i, j) + yji*f1ib(i) + xij*f2ib(j)
|
|
hib = hib + yji*zpl*zmi*f1ib(i) + xij*zpl*zmi*f2ib(j)
|
|
yjiib = (g0(i, j)+zpl*zmi*h)*f1ib(i)
|
|
temp0ib1 = molal(j+3)*yjiib/water
|
|
molalib(j+3) = molalib(j+3) + ch*yjiib/water
|
|
chib = mpl*xijib + temp0ib1
|
|
waterib = waterib - ch*temp0ib1/water
|
|
mplib = mplib + ch*xijib
|
|
ionicib = ionicib - (zpl+zmi)**2*0.25d0*chib/ionic**2
|
|
ENDDO
|
|
CALL POPREAL8(mpl)
|
|
molalib(i) = molalib(i) + mplib/water
|
|
waterib = waterib - molal(i)*mplib/water**2
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp0ib0 = agama*hib/(sion+1.d0)
|
|
sionib = (1.D0-sion/(sion+1.d0))*temp0ib0
|
|
IF (.NOT.ionic == 0.0) ionicib = ionicib + sionib/(2.0*SQRT(
|
|
+ ionic))
|
|
g05ib = g0ib(3, 4)
|
|
g0ib(3, 4) = 0.D0
|
|
g09ib = g0ib(3, 3)
|
|
g0ib(3, 3) = 0.D0
|
|
g04ib = g0ib(3, 2)
|
|
g0ib(3, 2) = 0.D0
|
|
g06ib = g0ib(3, 1)
|
|
g0ib(3, 1) = 0.D0
|
|
g03ib = g0ib(2, 4)
|
|
g0ib(2, 4) = 0.D0
|
|
g12ib = g0ib(2, 3)
|
|
g0ib(2, 3) = 0.D0
|
|
g02ib = g0ib(2, 2)
|
|
g0ib(2, 2) = 0.D0
|
|
g01ib = g0ib(2, 1)
|
|
g0ib(2, 1) = 0.D0
|
|
g10ib = g0ib(1, 4)
|
|
g0ib(1, 4) = 0.D0
|
|
g08ib = g0ib(1, 3)
|
|
g0ib(1, 3) = 0.D0
|
|
g07ib = g0ib(1, 2)
|
|
g0ib(1, 2) = 0.D0
|
|
g11ib = g0ib(1, 1)
|
|
CALL KMFUL3_IB(ionic, ionicib, temp, g01, g01ib, g02, g02ib, g03,
|
|
+ g03ib, g04, g04ib, g05, g05ib, g06, g06ib, g07,
|
|
+ g07ib, g08, g08ib, g09, g09ib, g10, g10ib, g11,
|
|
+ g11ib, g12, g12ib)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionic)
|
|
x1ib = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1ib = ionicib
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ionicib = 0.D0
|
|
ELSE
|
|
temp0ib = 0.5d0*x1ib/water
|
|
ionicib = temp0ib
|
|
waterib = waterib - ionic*temp0ib/water
|
|
END IF
|
|
DO i=7,1,-1
|
|
molalib(i) = molalib(i) + z(i)**2*ionicib
|
|
ENDDO
|
|
C WRITE(*,*) 'End of CALCACT3_IB: molalib ', molalib
|
|
END
|
|
|
|
C Differentiation of kmful3 in reverse (adjoint) mode:
|
|
C gradient of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12 ionic
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_IB(ionic, ionicib, temp, g01, g01ib, g02, g02ib
|
|
+ , g03, g03ib, g04, g04ib, g05, g05ib, g06,
|
|
+ g06ib, g07, g07ib, g08, g08ib, g09, g09ib,
|
|
+ g10, g10ib, g11, g11ib, g12, g12ib)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionicib, sionib, cf2ib
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01ib, g02ib, g03ib, g04ib, g05ib, g06ib, g07ib,
|
|
+ g08ib, g09ib, g10ib, g11ib, g12ib
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0ib0
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs1
|
|
REAL*8 :: temp0ib
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01ib = g01ib + g12ib
|
|
g08ib = g08ib + g09ib + g12ib
|
|
g11ib = g11ib - g09ib - g12ib
|
|
g06ib = g06ib + g09ib
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2ib = -(z10*g10ib) - z07*g07ib - z05*g05ib - z03*g03ib - z01*
|
|
+ g01ib - z02*g02ib - z04*g04ib - z06*g06ib - z08*g08ib - z11*
|
|
+ g11ib
|
|
g11ib = cf1*g11ib
|
|
g10ib = cf1*g10ib
|
|
g08ib = cf1*g08ib
|
|
g07ib = cf1*g07ib
|
|
g06ib = cf1*g06ib
|
|
g05ib = cf1*g05ib
|
|
g04ib = cf1*g04ib
|
|
g03ib = cf1*g03ib
|
|
g02ib = cf1*g02ib
|
|
g01ib = cf1*g01ib
|
|
temp0ib = (0.125d0-ti*0.005d0)*cf2ib
|
|
temp0ib0 = -(0.41d0*temp0ib/(sion+1.d0))
|
|
ionicib = ionicib + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0ib
|
|
sionib = (1.D0-sion/(sion+1.d0))*temp0ib0
|
|
ELSE
|
|
sionib = 0.D0
|
|
END IF
|
|
CALL MKBI_IB(q11, ionic, ionicib, sion, sionib, z11, g11, g11ib)
|
|
CALL MKBI_IB(q10, ionic, ionicib, sion, sionib, z10, g10, g10ib)
|
|
CALL MKBI_IB(q8, ionic, ionicib, sion, sionib, z08, g08, g08ib)
|
|
CALL MKBI_IB(q7, ionic, ionicib, sion, sionib, z07, g07, g07ib)
|
|
CALL MKBI_IB(q6, ionic, ionicib, sion, sionib, z06, g06, g06ib)
|
|
CALL MKBI_IB(q5, ionic, ionicib, sion, sionib, z05, g05, g05ib)
|
|
CALL MKBI_IB(q4, ionic, ionicib, sion, sionib, z04, g04, g04ib)
|
|
CALL MKBI_IB(q3, ionic, ionicib, sion, sionib, z03, g03, g03ib)
|
|
CALL MKBI_IB(q2, ionic, ionicib, sion, sionib, z02, g02, g02ib)
|
|
CALL MKBI_IB(q1, ionic, ionicib, sion, sionib, z01, g01, g01ib)
|
|
IF (.NOT.ionic == 0.0) ionicib = ionicib + sionib/(2.0*SQRT(
|
|
+ ionic))
|
|
END
|
|
|
|
C Differentiation of mkbi in reverse (adjoint) mode:
|
|
C gradient of useful results: sion bi ionic
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_IB(q, ionic, ionicib, sion, sionib, zip, bi, biib)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionicib, sionib, biib
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: cib, xxib
|
|
INTRINSIC EXP
|
|
REAL*8 :: tempib
|
|
INTRINSIC LOG10
|
|
REAL*8 :: tempib0
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
c = 1.d0 + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic))
|
|
bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b
|
|
C
|
|
xxib = zip*biib
|
|
biib = zip*biib/(bi*LOG(10.d0))
|
|
tempib = -(0.5107d0*xxib/(c*sion+1.d0))
|
|
tempib0 = -(sion*tempib/(c*sion+1.d0))
|
|
sionib = sionib + c*tempib0 + tempib
|
|
cib = sion*tempib0
|
|
IF (.1d0*ionic + 1.d0 <= 0.d0 .AND. (q == 0.d0 .OR. q /=
|
|
+ INT(q))) THEN
|
|
ionicib = ionicib - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*
|
|
+ ionic**2*cib
|
|
ELSE
|
|
ionicib = ionicib + q*(.1d0*ionic+1.d0)**(q-1.d0)*b*.1d0*biib -
|
|
+ .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cib
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of poly3 in reverse (adjoint) mode:
|
|
C gradient of useful results: root
|
|
C with respect to varying inputs: a1 a2 a3
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE POLY3
|
|
C *** FINDS THE REAL ROOTS OF THE THIRD ORDER ALGEBRAIC EQUATION:
|
|
C X**3 + A1*X**2 + A2*X + A3 = 0.0
|
|
C THE EQUATION IS SOLVED ANALYTICALLY.
|
|
C
|
|
C PARAMETERS A1, A2, A3 ARE SPECIFIED BY THE USER. THE MINIMUM
|
|
C NONEGATIVE ROOT IS RETURNED IN VARIABLE 'ROOT'. IF NO ROOT IS
|
|
C FOUND (WHICH IS GREATER THAN ZERO), ROOT HAS THE VALUE 1D30.
|
|
C AND THE FLAG ISLV HAS A VALUE GREATER THAN ZERO.
|
|
C
|
|
C SOLUTION FORMULA IS FOUND IN PAGE 32 OF:
|
|
C MATHEMATICAL HANDBOOK OF FORMULAS AND TABLES
|
|
C SCHAUM'S OUTLINE SERIES
|
|
C MURRAY SPIEGER, McGRAW-HILL, NEW YORK, 1968
|
|
C (GREEK TRANSLATION: BY SOTIRIOS PERSIDES, ESPI, ATHENS, 1976)
|
|
C
|
|
C A SPECIAL CASE IS CONSIDERED SEPERATELY ; WHEN A3 = 0, THEN
|
|
C ONE ROOT IS X=0.0, AND THE OTHER TWO FROM THE SOLUTION OF THE
|
|
C QUADRATIC EQUATION X**2 + A1*X + A2 = 0.0
|
|
C THIS SPECIAL CASE IS CONSIDERED BECAUSE THE ANALYTICAL FORMULA
|
|
C DOES NOT YIELD ACCURATE RESULTS (DUE TO NUMERICAL ROUNDOFF ERRORS)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE POLY3_IB(a1, a1ib, a2, a2ib, a3, a3ib, root, rootib,
|
|
+ islv)
|
|
IMPLICIT NONE
|
|
REAL*8 :: thet1
|
|
REAL*8 :: thet2
|
|
REAL*8 :: zero
|
|
REAL*8 :: expon
|
|
REAL*8 :: eps
|
|
REAL*8 :: pi
|
|
C
|
|
PARAMETER (expon=1.d0/3.d0, zero=0.d0, thet1=120.d0/180.d0, thet2=
|
|
+ 240.d0/180.d0, pi=3.1415926535897932D0, eps=1.d-50)
|
|
C REAL*8 :: X(3)
|
|
REAL*8 :: x(3), a1, a2, a3, root
|
|
REAL*8 :: xib(3), a1ib, a2ib, a3ib, rootib
|
|
INTEGER :: ix
|
|
REAL*8 :: d
|
|
REAL*8 :: dib
|
|
REAL*8 :: sqd
|
|
REAL*8 :: sqdib
|
|
REAL*8 :: q
|
|
REAL*8 :: qib
|
|
REAL*8 :: u
|
|
REAL*8 :: uib
|
|
REAL*8 :: thet
|
|
REAL*8 :: thetib
|
|
REAL*8 :: coef
|
|
REAL*8 :: coefib
|
|
REAL*8 :: ssig
|
|
REAL*8 :: s
|
|
REAL*8 :: sib
|
|
REAL*8 :: tsig
|
|
REAL*8 :: t
|
|
REAL*8 :: tib
|
|
INTEGER :: i
|
|
INTEGER :: branch
|
|
INTEGER :: islv
|
|
REAL*8 :: abs4ib
|
|
REAL*8 :: temp0
|
|
INTRINSIC COS
|
|
REAL*8 :: abs2ib
|
|
INTRINSIC SIGN
|
|
INTRINSIC ABS
|
|
REAL*8 :: tempib
|
|
REAL*8 :: abs3ib
|
|
INTRINSIC ACOS
|
|
REAL*8 :: abs4
|
|
REAL*8 :: abs3
|
|
REAL*8 :: abs2
|
|
REAL*8 :: abs1
|
|
REAL*8 :: tempib0
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp
|
|
IF (a3 >= 0.) THEN
|
|
abs1 = a3
|
|
ELSE
|
|
abs1 = -a3
|
|
END IF
|
|
C
|
|
C *** SPECIAL CASE : QUADRATIC*X EQUATION *****************************
|
|
C
|
|
IF (abs1 <= eps) THEN
|
|
ix = 1
|
|
x(1) = zero
|
|
d = a1*a1 - 4.d0*a2
|
|
IF (d >= zero) THEN
|
|
ix = 3
|
|
sqd = SQRT(d)
|
|
x(2) = 0.5*(-a1+sqd)
|
|
x(3) = 0.5*(-a1-sqd)
|
|
CALL PUSHCONTROL3B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL3B(1)
|
|
END IF
|
|
ELSE
|
|
C
|
|
C *** NORMAL CASE : CUBIC EQUATION ************************************
|
|
C
|
|
C DEFINE PARAMETERS Q, U, S, T, D
|
|
C
|
|
q = (3.d0*a2-a1*a1)/9.d0
|
|
u = (9.d0*a1*a2-27.d0*a3-2.d0*a1*a1*a1)/54.d0
|
|
d = q*q*q + u*u
|
|
C WRITE(*,*) 'd',d
|
|
C
|
|
C *** CALCULATE ROOTS *************************************************
|
|
C
|
|
C D < 0, THREE REAL ROOTS
|
|
C
|
|
IF (d < -eps) THEN
|
|
C D < -EPS : D < ZERO
|
|
ix = 3
|
|
thet = expon*ACOS(u/SQRT(-(q*q*q)))
|
|
coef = 2.d0*SQRT(-q)
|
|
x(1) = coef*COS(thet) - expon*a1
|
|
x(2) = coef*COS(thet+thet1*pi) - expon*a1
|
|
x(3) = coef*COS(thet+thet2*pi) - expon*a1
|
|
C
|
|
C D = 0, THREE REAL (ONE DOUBLE) ROOTS
|
|
C
|
|
CALL PUSHCONTROL3B(2)
|
|
ELSE IF (d <= eps) THEN
|
|
C -EPS <= D <= EPS : D = ZERO
|
|
ix = 2
|
|
ssig = SIGN(1.d0, u)
|
|
IF (u >= 0.) THEN
|
|
abs2 = u
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
abs2 = -u
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
s = ssig*abs2**expon
|
|
x(1) = 2.d0*s - expon*a1
|
|
x(2) = -s - expon*a1
|
|
C
|
|
C D > 0, ONE REAL ROOT
|
|
C
|
|
CALL PUSHCONTROL3B(3)
|
|
ELSE
|
|
C D > EPS : D > ZERO
|
|
ix = 1
|
|
sqd = SQRT(d)
|
|
C TRANSFER SIGN TO SSIG
|
|
ssig = SIGN(1.d0, u + sqd)
|
|
tsig = SIGN(1.d0, u - sqd)
|
|
IF (u + sqd >= 0.) THEN
|
|
abs3 = u + sqd
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
abs3 = -(u+sqd)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C EXPONENTIATE ABS()
|
|
s = ssig*abs3**expon
|
|
IF (u - sqd >= 0.) THEN
|
|
abs4 = u - sqd
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
abs4 = -(u-sqd)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
t = tsig*abs4**expon
|
|
x(1) = s + t - expon*a1
|
|
CALL PUSHCONTROL3B(4)
|
|
END IF
|
|
END IF
|
|
C
|
|
C *** SELECT APPROPRIATE ROOT *****************************************
|
|
C
|
|
root = 1.d30
|
|
DO i=1,ix
|
|
IF (x(i) > zero) THEN
|
|
IF (root > x(i)) THEN
|
|
root = x(i)
|
|
CALL PUSHCONTROL2B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL2B(2)
|
|
root = root
|
|
END IF
|
|
ELSE
|
|
CALL PUSHCONTROL2B(0)
|
|
END IF
|
|
ENDDO
|
|
DO ii1=1,3
|
|
xib(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=ix,1,-1
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch /= 0) THEN
|
|
IF (branch == 1) THEN
|
|
xib(i) = xib(i) + rootib
|
|
rootib = 0.D0
|
|
END IF
|
|
END IF
|
|
ENDDO
|
|
CALL POPCONTROL3B(branch)
|
|
IF (branch < 2) THEN
|
|
IF (branch == 0) THEN
|
|
a1ib = -(0.5*xib(3))
|
|
sqdib = -(0.5*xib(3))
|
|
xib(3) = 0.D0
|
|
sqdib = sqdib + 0.5*xib(2)
|
|
a1ib = a1ib - 0.5*xib(2)
|
|
IF (d == 0.0) THEN
|
|
dib = 0.0
|
|
ELSE
|
|
dib = sqdib/(2.0*SQRT(d))
|
|
END IF
|
|
ELSE
|
|
a1ib = 0.D0
|
|
dib = 0.D0
|
|
END IF
|
|
a1ib = a1ib + 2*a1*dib
|
|
a2ib = -(4.d0*dib)
|
|
a3ib = 0.D0
|
|
ELSE
|
|
IF (branch == 2) THEN
|
|
coefib = COS(thet2*pi+thet)*xib(3)
|
|
thetib = -(coef*SIN(thet2*pi+thet)*xib(3))
|
|
a1ib = -(expon*xib(3))
|
|
xib(3) = 0.D0
|
|
coefib = coefib + COS(thet1*pi+thet)*xib(2)
|
|
thetib = thetib - coef*SIN(thet1*pi+thet)*xib(2)
|
|
a1ib = a1ib - expon*xib(2)
|
|
xib(2) = 0.D0
|
|
coefib = coefib + COS(thet)*xib(1)
|
|
thetib = thetib - coef*SIN(thet)*xib(1)
|
|
a1ib = a1ib - expon*xib(1)
|
|
IF (-q == 0.0) THEN
|
|
qib = 0.0
|
|
ELSE
|
|
qib = -(2.d0*coefib/(2.0*SQRT(-q)))
|
|
END IF
|
|
temp0 = -(q**3)
|
|
temp = SQRT(temp0)
|
|
tempib0 = -(expon*thetib/(SQRT(1.0-(u/temp)**2)*temp))
|
|
uib = tempib0
|
|
IF (.NOT.temp0 == 0.0) qib = qib + u*3*q**2*tempib0/(2.0*
|
|
+ temp**2)
|
|
dib = 0.D0
|
|
ELSE
|
|
IF (branch == 3) THEN
|
|
sib = -xib(2)
|
|
a1ib = -(expon*xib(2))
|
|
xib(2) = 0.D0
|
|
sib = sib + 2.d0*xib(1)
|
|
a1ib = a1ib - expon*xib(1)
|
|
IF (abs2 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT(
|
|
+ expon))) THEN
|
|
abs2ib = 0.0
|
|
ELSE
|
|
abs2ib = ssig*expon*abs2**(expon-1)*sib
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
uib = abs2ib
|
|
ELSE
|
|
uib = -abs2ib
|
|
END IF
|
|
dib = 0.D0
|
|
ELSE
|
|
sib = xib(1)
|
|
tib = xib(1)
|
|
a1ib = -(expon*xib(1))
|
|
IF (abs4 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT(
|
|
+ expon))) THEN
|
|
abs4ib = 0.0
|
|
ELSE
|
|
abs4ib = tsig*expon*abs4**(expon-1)*tib
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
uib = abs4ib
|
|
sqdib = -abs4ib
|
|
ELSE
|
|
sqdib = abs4ib
|
|
uib = -abs4ib
|
|
END IF
|
|
IF (abs3 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT(
|
|
+ expon))) THEN
|
|
abs3ib = 0.0
|
|
ELSE
|
|
abs3ib = ssig*expon*abs3**(expon-1)*sib
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
uib = uib + abs3ib
|
|
sqdib = sqdib + abs3ib
|
|
ELSE
|
|
uib = uib - abs3ib
|
|
sqdib = sqdib - abs3ib
|
|
END IF
|
|
IF (d == 0.0) THEN
|
|
dib = 0.0
|
|
ELSE
|
|
dib = sqdib/(2.0*SQRT(d))
|
|
END IF
|
|
END IF
|
|
qib = 0.D0
|
|
END IF
|
|
qib = qib + 3*q**2*dib
|
|
uib = uib + 2*u*dib
|
|
tempib = uib/54.d0
|
|
a1ib = a1ib + (9.d0*a2-2.d0*3*a1**2)*tempib - 2*a1*qib/9.d0
|
|
a2ib = 3.d0*qib/9.d0 + 9.d0*a1*tempib
|
|
a3ib = -(27.d0*tempib)
|
|
END IF
|
|
END
|
|
|
|
C Generated by TAPENADE (INRIA, Tropics team)
|
|
C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21
|
|
C
|
|
C Differentiation of isrp3f in reverse (adjoint) mode:
|
|
C gradient of useful results: aerliq gas
|
|
C with respect to varying inputs: wp aerliq gas
|
|
C RW status of diff variables: wp:out aerliq:in-out gas:in-out
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE ISRP3F
|
|
C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF
|
|
C AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE & SODIUM
|
|
C RATIOS AND BY THE AMBIENT RELATIVE HUMIDITY.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE ISRP3F_JB(wpjb, gasjb, aerliqjb)
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: gas(3), aerliq(NIONS+NGASAQ+2)
|
|
REAL*8 :: wpjb(ncomp), gasjb(3), aerliqjb(NIONS+NGASAQ+2)
|
|
REAL*8 :: rest
|
|
REAL*8 :: restjb
|
|
INTEGER :: i, ncase, npflag
|
|
INTEGER :: branch
|
|
INTEGER :: ii1
|
|
C
|
|
C *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE *********
|
|
C
|
|
rest = 2.d0*w(2) + w(4) + w(5)
|
|
IF (w(1) > rest) THEN
|
|
C NA > 2*SO4+CL+NO3 ?
|
|
C Adjust Na amount
|
|
w(1) = (one-1d-6)*rest
|
|
CALL PUSHERR(50, 'ISRP3F')
|
|
C Warning error: Na adjusted
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
CALL PUSHINTEGER4(iclact)
|
|
CALL PUSHREAL8(water)
|
|
CALL PUSHREAL8ARRAY(gamou, npair)
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
CALL PUSHREAL8ARRAY(molalr, npair)
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
C
|
|
C *** CALCULATE SULFATE & SODIUM RATIOS *********************************
|
|
C
|
|
C
|
|
C *** FIND CALCULATION REGIME FROM (SULRAT,RH) **************************
|
|
C
|
|
C *** SULFATE POOR ; SODIUM POOR
|
|
C *** SULFATE RICH (FREE ACID)
|
|
C
|
|
C ELSEIF (SULRAT < 1.0) THEN
|
|
CC
|
|
CC IF(METSTBL == 1) THEN
|
|
C Only liquid (metastable)
|
|
CALL CALCJ3()
|
|
CC ELSE
|
|
C MINOR SPECIES: HNO3, HCl
|
|
CALL CALCNHA_JFWD()
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3()
|
|
CALL CALCACT3F()
|
|
C NH3
|
|
ghcljb = gasjb(3)
|
|
gasjb(3) = 0.D0
|
|
ghno3jb = gasjb(2)
|
|
gasjb(2) = 0.D0
|
|
gnh3jb = gasjb(1)
|
|
gasjb(1) = 0.D0
|
|
aerliqjb(nions+ngasaq+2) = 0.D0
|
|
waterjb = 1.0d3*aerliqjb(nions+1)/18.0d0
|
|
aerliqjb(nions+1) = 0.D0
|
|
DO i=ngasaq,1,-1
|
|
aerliqjb(nions+1+i) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,nions
|
|
molaljb(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=nions,1,-1
|
|
molaljb(i) = molaljb(i) + aerliqjb(i)
|
|
aerliqjb(i) = 0.D0
|
|
ENDDO
|
|
CALL CALCNH3_JB()
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3_JB()
|
|
CALL CALCNHA_JBWD()
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL POPREAL8ARRAY(molalr, npair)
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL POPREAL8ARRAY(gamou, npair)
|
|
CALL POPREAL8(water)
|
|
CALL POPINTEGER4(iclact)
|
|
CALL CALCJ3_JB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
restjb = (one-1d-6)*wjb(1)
|
|
wjb(1) = 0.D0
|
|
ELSE
|
|
restjb = 0.D0
|
|
END IF
|
|
wjb(2) = wjb(2) + 2.d0*restjb
|
|
wjb(4) = wjb(4) + restjb
|
|
wjb(5) = wjb(5) + restjb
|
|
DO ii1=1,5
|
|
wpjb(ii1) = 0.D0
|
|
ENDDO
|
|
wpjb = wjb
|
|
C
|
|
C ncase = 10
|
|
C NOFER = 0
|
|
C CALL ISERRINF (ERRSTK, ERRMSG, NOFER, STKOFL) ! Obtain error stack
|
|
C WRITE(*,*) 'Writing error code'
|
|
C IF (NOFER == 0) THEN ! No errors
|
|
C NONPHYS = .FALSE.
|
|
C npflag = 0
|
|
CC WRITE(*,*) 'Setting NONPHYS to FALSE'
|
|
C ELSE
|
|
C NONPHYS = .TRUE.
|
|
C npflag = 1
|
|
CC WRITE(*,*) 'Setting NONPHYS to TRUE'
|
|
CC PAUSE
|
|
CC WRITE(*,*) 'After pause'
|
|
C ENDIF
|
|
CC WRITE(*,*) 'wpb',wpb
|
|
C OPEN (199, FILE='adj_sens.csv',STATUS='UNKNOWN',
|
|
C & POSITION='APPEND')
|
|
C WRITE(199,888) w,rh,temp,wpjb,npflag,ncase
|
|
C CLOSE (199, STATUS='KEEP')
|
|
C 888 FORMAT (12(1PE11.4,","),I2,",",I2)
|
|
END
|
|
|
|
C Differentiation of calcj3 in reverse (adjoint) mode:
|
|
C gradient of useful results: w molal gama water
|
|
C with respect to varying inputs: w
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCJ3
|
|
C *** CASE J3
|
|
C
|
|
C THE MAIN CHARACTERISTICS OF THIS REGIME ARE:
|
|
C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0)
|
|
C 2. THERE IS ONLY A LIQUID PHASE
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCJ3_JB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: psi1jb
|
|
REAL*8 :: psi2jb
|
|
REAL*8 :: chi1jb
|
|
REAL*8 :: a3jb
|
|
REAL*8 :: chi2jb
|
|
C
|
|
REAL*8 :: lamda, kapa
|
|
REAL*8 :: lamdajb, kapajb
|
|
INTEGER :: i
|
|
REAL*8 :: bb
|
|
REAL*8 :: bbjb
|
|
REAL*8 :: cc
|
|
REAL*8 :: ccjb
|
|
REAL*8 :: dd
|
|
REAL*8 :: ddjb, molalrjb(npair)
|
|
INTEGER :: j
|
|
INTEGER :: branch
|
|
INTEGER :: ad_count
|
|
INTEGER :: i0
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp2jb
|
|
REAL*8 :: temp0jb
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp1jb
|
|
C
|
|
C *** SETUP PARAMETERS ************************************************
|
|
C
|
|
C Outer loop activity calculation flag
|
|
frst = .true.
|
|
calain = .true.
|
|
IF (w(2) - w(3) - w(1) < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
lamda = tiny
|
|
ELSE
|
|
lamda = w(2) - w(3) - w(1)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C NA TOTAL as NaHSO4
|
|
chi1 = w(1)
|
|
C NH4 TOTAL as NH4HSO4
|
|
chi2 = w(3)
|
|
psi1 = chi1
|
|
C ALL NH4HSO4 DELIQUESCED
|
|
psi2 = chi2
|
|
C
|
|
C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************
|
|
C
|
|
i = 1
|
|
ad_count = 0
|
|
DO WHILE (i <= nsweep .AND. calain)
|
|
C
|
|
a3 = xk1*water/gama(7)*(gama(8)/gama(7))**2.0
|
|
C
|
|
C CALCULATE DISSOCIATION QUANTITIES
|
|
C
|
|
C KAPA
|
|
bb = a3 + lamda
|
|
cc = -(a3*(lamda+psi1+psi2))
|
|
dd = bb*bb - 4.d0*cc
|
|
kapa = 0.5d0*(-bb+SQRT(dd))
|
|
CALL PUSHREAL8(molal(1))
|
|
C
|
|
C *** CALCULATE SPECIATION ********************************************
|
|
C
|
|
C HI
|
|
molal(1) = lamda + kapa
|
|
CALL PUSHREAL8(molal(2))
|
|
C NAI
|
|
molal(2) = psi1
|
|
CALL PUSHREAL8(molal(3))
|
|
C NH4I
|
|
molal(3) = psi2
|
|
CALL PUSHREAL8(molal(4))
|
|
C CLI
|
|
molal(4) = zero
|
|
CALL PUSHREAL8(molal(5))
|
|
C SO4I
|
|
molal(5) = kapa
|
|
CALL PUSHREAL8(molal(6))
|
|
C HSO4I
|
|
molal(6) = lamda + psi1 + psi2 - kapa
|
|
CALL PUSHREAL8(molal(7))
|
|
C NO3I
|
|
molal(7) = zero
|
|
C
|
|
C
|
|
C CALL CALCMR ! Water content
|
|
C
|
|
C NH4HSO4
|
|
molalr(9) = molal(3)
|
|
C NAHSO4
|
|
molalr(12) = molal(2)
|
|
C H2SO4
|
|
molalr(7) = molal(5) + molal(6) - molal(3) - molal(2)
|
|
IF (molalr(7) < zero) THEN
|
|
molalr(7) = zero
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
molalr(7) = molalr(7)
|
|
END IF
|
|
CALL PUSHREAL8(water)
|
|
C
|
|
C *** CALCULATE WATER CONTENT ; ZSR CORRELATION ***********************
|
|
C
|
|
water = zero
|
|
DO j=1,npair
|
|
water = water + molalr(j)/m0(j)
|
|
ENDDO
|
|
IF (water < tiny) THEN
|
|
water = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
water = water
|
|
END IF
|
|
CALL PUSHREAL8ARRAY(gama, npair)
|
|
C
|
|
C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP *****************
|
|
C
|
|
CALL CALCACT3()
|
|
i = i + 1
|
|
ad_count = ad_count + 1
|
|
ENDDO
|
|
CALL PUSHINTEGER4(ad_count)
|
|
DO ii1=1,npair
|
|
molalrjb(ii1) = 0.D0
|
|
ENDDO
|
|
psi1jb = 0.D0
|
|
psi2jb = 0.D0
|
|
lamdajb = 0.D0
|
|
CALL POPINTEGER4(ad_count)
|
|
DO i0=1,ad_count
|
|
CALL POPREAL8ARRAY(gama, npair)
|
|
CALL CALCACT3_JB()
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) waterjb = 0.D0
|
|
DO j=npair,1,-1
|
|
molalrjb(j) = molalrjb(j) + waterjb/m0(j)
|
|
ENDDO
|
|
CALL POPREAL8(water)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) molalrjb(7) = 0.D0
|
|
molaljb(5) = molaljb(5) + molalrjb(7)
|
|
molaljb(6) = molaljb(6) + molalrjb(7)
|
|
molaljb(3) = molaljb(3) - molalrjb(7)
|
|
molaljb(2) = molaljb(2) - molalrjb(7)
|
|
molalrjb(7) = 0.D0
|
|
molaljb(2) = molaljb(2) + molalrjb(12)
|
|
molalrjb(12) = 0.D0
|
|
molaljb(3) = molaljb(3) + molalrjb(9)
|
|
molalrjb(9) = 0.D0
|
|
CALL POPREAL8(molal(7))
|
|
molaljb(7) = 0.D0
|
|
CALL POPREAL8(molal(6))
|
|
lamdajb = lamdajb + molaljb(6)
|
|
psi1jb = psi1jb + molaljb(6)
|
|
psi2jb = psi2jb + molaljb(6)
|
|
kapajb = -molaljb(6)
|
|
molaljb(6) = 0.D0
|
|
CALL POPREAL8(molal(5))
|
|
kapajb = kapajb + molaljb(5)
|
|
molaljb(5) = 0.D0
|
|
CALL POPREAL8(molal(4))
|
|
molaljb(4) = 0.D0
|
|
CALL POPREAL8(molal(3))
|
|
psi2jb = psi2jb + molaljb(3)
|
|
molaljb(3) = 0.D0
|
|
CALL POPREAL8(molal(2))
|
|
psi1jb = psi1jb + molaljb(2)
|
|
molaljb(2) = 0.D0
|
|
CALL POPREAL8(molal(1))
|
|
kapajb = kapajb + molaljb(1)
|
|
a3 = xk1*water/gama(7)*(gama(8)/gama(7))**2.0
|
|
bb = a3 + lamda
|
|
cc = -(a3*(lamda+psi1+psi2))
|
|
dd = bb*bb - 4.d0*cc
|
|
IF (dd == 0.0) THEN
|
|
ddjb = 0.0
|
|
ELSE
|
|
ddjb = 0.5d0*kapajb/(2.0*SQRT(dd))
|
|
END IF
|
|
bbjb = 2*bb*ddjb - 0.5d0*kapajb
|
|
ccjb = -(4.d0*ddjb)
|
|
temp2jb = -(a3*ccjb)
|
|
lamdajb = lamdajb + temp2jb + bbjb + molaljb(1)
|
|
molaljb(1) = 0.D0
|
|
a3jb = bbjb - (lamda+psi1+psi2)*ccjb
|
|
psi1jb = psi1jb + temp2jb
|
|
psi2jb = psi2jb + temp2jb
|
|
temp0 = water/gama(7)
|
|
temp1 = gama(8)/gama(7)
|
|
temp1jb = 2.0*temp1*temp0*xk1*a3jb/gama(7)
|
|
temp0jb = temp1**2.0*xk1*a3jb/gama(7)
|
|
gamajb(8) = gamajb(8) + temp1jb
|
|
gamajb(7) = gamajb(7) - temp0*temp0jb - temp1*temp1jb
|
|
waterjb = temp0jb
|
|
ENDDO
|
|
chi2jb = psi2jb
|
|
chi1jb = psi1jb
|
|
wjb(3) = wjb(3) + chi2jb
|
|
wjb(1) = wjb(1) + chi1jb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
wjb(2) = wjb(2) + lamdajb
|
|
wjb(3) = wjb(3) - lamdajb
|
|
wjb(1) = wjb(1) - lamdajb
|
|
END IF
|
|
END
|
|
C
|
|
C Differentiation of calcnh3 in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gnh3
|
|
C with respect to varying inputs: molal gama
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNH3
|
|
C *** CALCULATES AMMONIA IN GAS PHASE
|
|
C
|
|
C AMMONIA IN THE GAS PHASE IS ASSUMED A MINOR SPECIES, THAT
|
|
C DOES NOT SIGNIFICANTLY PERTURB THE AEROSOL EQUILIBRIUM.
|
|
C AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l)
|
|
C EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION.
|
|
C
|
|
C THIS IS THE VERSION USED BY THE DIRECT PROBLEM
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNH3_JB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: a1jb
|
|
REAL*8 :: chi1jb
|
|
REAL*8 :: chi2jb
|
|
REAL*8 :: bb, cc, diak, psi
|
|
REAL*8 :: bbjb, ccjb, diakjb, psijb
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
REAL*8 :: x1jb
|
|
INTRINSIC MAX
|
|
REAL*8 :: x1
|
|
REAL*8 :: temp0jb
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp1jb
|
|
C
|
|
C *** IS THERE A LIQUID PHASE? ******************************************
|
|
C
|
|
IF (water <= tiny) THEN
|
|
DO ii1=1,npair
|
|
gamajb(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
C
|
|
C *** CALCULATE NH3 SUBLIMATION *****************************************
|
|
C
|
|
a1 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0
|
|
chi1 = molal(3)
|
|
chi2 = molal(1)
|
|
C
|
|
C a=1; b!=1; c!=1
|
|
bb = chi2 + one/a1
|
|
cc = -(chi1/a1)
|
|
C Always > 0
|
|
diak = SQRT(bb*bb - 4.d0*cc)
|
|
C One positive root
|
|
psi = 0.5*(-bb+diak)
|
|
IF (psi > chi1) THEN
|
|
x1 = chi1
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = psi
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
chi2jb = molaljb(1)
|
|
psijb = molaljb(1)
|
|
molaljb(1) = 0.D0
|
|
chi1jb = molaljb(3)
|
|
psijb = psijb + gnh3jb - molaljb(3)
|
|
molaljb(3) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
x1jb = 0.D0
|
|
ELSE
|
|
x1jb = psijb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
chi1jb = chi1jb + x1jb
|
|
psijb = 0.D0
|
|
ELSE
|
|
psijb = x1jb
|
|
END IF
|
|
diakjb = 0.5*psijb
|
|
IF (bb**2 - 4.d0*cc == 0.0) THEN
|
|
temp1jb = 0.0
|
|
ELSE
|
|
temp1jb = diakjb/(2.0*SQRT(bb**2-4.d0*cc))
|
|
END IF
|
|
bbjb = 2*bb*temp1jb - 0.5*psijb
|
|
ccjb = -(4.d0*temp1jb)
|
|
chi1jb = chi1jb - ccjb/a1
|
|
a1jb = chi1*ccjb/a1**2 - one*bbjb/a1**2
|
|
chi2jb = chi2jb + bbjb
|
|
molaljb(1) = molaljb(1) + chi2jb
|
|
molaljb(3) = molaljb(3) + chi1jb
|
|
DO ii1=1,npair
|
|
gamajb(ii1) = 0.D0
|
|
ENDDO
|
|
temp0 = gama(10)/gama(5)
|
|
temp0jb = 2.0*temp0*xk2*r*temp*a1jb/(xkw*gama(5))
|
|
gamajb(10) = gamajb(10) + temp0jb
|
|
gamajb(5) = gamajb(5) - temp0*temp0jb
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of calcnha in reverse (adjoint) mode (forward sweep):
|
|
C gradient of useful results: molal gama water ghno3 ghcl
|
|
C with respect to varying inputs: w molal gama water
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNHA
|
|
C
|
|
C THIS SUBROUTINE CALCULATES THE DISSOLUTION OF HCL, HNO3 AT
|
|
C THE PRESENCE OF (H,SO4). HCL, HNO3 ARE CONSIDERED MINOR SPECIES,
|
|
C THAT DO NOT SIGNIFICANTLY AFFECT THE EQUILIBRIUM POINT.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNHA_JFWD()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: m1, m2, m3, delcl, delno, omega
|
|
CHARACTER(LEN=40) errinf
|
|
REAL*8 :: c1
|
|
REAL*8 :: c2
|
|
REAL*8 :: c3
|
|
INTEGER :: islv
|
|
INTRINSIC MAX
|
|
INTRINSIC MIN
|
|
C
|
|
C *** SPECIAL CASE; WATER=ZERO ******************************************
|
|
C
|
|
IF (water <= tiny) THEN
|
|
IF (w(5) - molal(4) < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (w(4) - molal(7) < tiny) THEN
|
|
CALL PUSHCONTROL3B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL3B(0)
|
|
END IF
|
|
ELSE IF (w(5) <= tiny .AND. w(4) <= tiny) THEN
|
|
CALL PUSHCONTROL3B(2)
|
|
ELSE IF (w(5) <= tiny) THEN
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
C CALL HNO3 DISSOLUTION ROUTINE
|
|
CALL CALCNA()
|
|
C GOTO 60
|
|
C
|
|
C *** SPECIAL CASE; HNO3=ZERO *******************************************
|
|
C
|
|
CALL PUSHCONTROL3B(3)
|
|
ELSE IF (w(4) <= tiny) THEN
|
|
CALL PUSHREAL8ARRAY(molal, nions)
|
|
C CALL HCL DISSOLUTION ROUTINE
|
|
CALL CALCHA()
|
|
C GOTO 60
|
|
C ENDIF
|
|
CALL PUSHCONTROL3B(4)
|
|
ELSE
|
|
C
|
|
C *** CALCULATE EQUILIBRIUM CONSTANTS ***********************************
|
|
C
|
|
C HNO3
|
|
a3 = xk4*r*temp*(water/gama(10))**2.0
|
|
C HCL
|
|
a4 = xk3*r*temp*(water/gama(11))**2.0
|
|
C
|
|
C *** CALCULATE CUBIC EQUATION COEFFICIENTS *****************************
|
|
C
|
|
C
|
|
C H+
|
|
omega = molal(1)
|
|
C HNO3
|
|
chi3 = w(4)
|
|
C HCL
|
|
chi4 = w(5)
|
|
C
|
|
c1 = a3*chi3
|
|
c2 = a4*chi4
|
|
c3 = a3 - a4
|
|
C
|
|
m1 = (c1+c2+(omega+a4)*c3)/c3
|
|
m2 = ((omega+a4)*c2-a4*c3*chi4)/c3
|
|
m3 = -(a4*c2*chi4/c3)
|
|
C
|
|
C *** CALCULATE ROOTS ***************************************************
|
|
C
|
|
CALL POLY3(m1, m2, m3, delcl, islv)
|
|
C HCL DISSOLUTION
|
|
IF (islv /= 0) THEN
|
|
C TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT
|
|
delcl = tiny
|
|
C WRITE (ERRINF,'(1PE10.1)') TINY
|
|
C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
IF (delcl > chi4) THEN
|
|
delcl = chi4
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
delcl = delcl
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
delno = c1*delcl/(c2+c3*delcl)
|
|
IF (delno > chi3) THEN
|
|
delno = chi3
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
delno = delno
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
IF (((delcl < zero .OR. delno < zero) .OR. delcl > chi4
|
|
+ ) .OR. delno > chi3) THEN
|
|
CALL PUSHREAL8(delcl)
|
|
C TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT
|
|
delcl = tiny
|
|
delno = tiny
|
|
C WRITE (ERRINF,'(1PE10.1)') TINY
|
|
C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
CCC
|
|
CCC *** COMPARE DELTA TO TOTAL H+ ; ESTIMATE EFFECT TO HSO4 ***************
|
|
CCC
|
|
CC IF ((DELCL+DELNO)/MOLAL(1) > 0.1d0) THEN
|
|
CC WRITE (ERRINF,'(1PE10.3)') (DELCL+DELNO)/MOLAL(1)*100.0
|
|
CC CALL PUSHERR (0021, ERRINF)
|
|
CC ENDIF
|
|
C
|
|
C *** EFFECT ON LIQUID PHASE ********************************************
|
|
C
|
|
C H+ CHANGE
|
|
molal(1) = molal(1) + (delno+delcl)
|
|
C CL- CHANGE
|
|
molal(4) = molal(4) + delcl
|
|
C NO3- CHANGE
|
|
molal(7) = molal(7) + delno
|
|
IF (w(5) - molal(4) < tiny) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (w(4) - molal(7) < tiny) THEN
|
|
CALL PUSHREAL8(omega)
|
|
CALL PUSHREAL8(delcl)
|
|
CALL PUSHCONTROL3B(5)
|
|
ELSE
|
|
CALL PUSHREAL8(omega)
|
|
CALL PUSHREAL8(delcl)
|
|
CALL PUSHCONTROL3B(6)
|
|
END IF
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of calcnha in reverse (adjoint) mode (backward sweep):
|
|
C gradient of useful results: molal gama water ghno3 ghcl
|
|
C with respect to varying inputs: w molal gama water
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNHA
|
|
C
|
|
C THIS SUBROUTINE CALCULATES THE DISSOLUTION OF HCL, HNO3 AT
|
|
C THE PRESENCE OF (H,SO4). HCL, HNO3 ARE CONSIDERED MINOR SPECIES,
|
|
C THAT DO NOT SIGNIFICANTLY AFFECT THE EQUILIBRIUM POINT.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNHA_JBWD()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: a3jb
|
|
REAL*8 :: a4jb
|
|
REAL*8 :: chi3jb
|
|
REAL*8 :: chi4jb
|
|
REAL*8 :: m1, m2, m3, delcl, delno, omega
|
|
REAL*8 :: m1jb, m2jb, m3jb, delcljb, delnojb, omegajb
|
|
CHARACTER(LEN=40) errinf
|
|
REAL*8 :: c1
|
|
REAL*8 :: c1jb
|
|
REAL*8 :: c2
|
|
REAL*8 :: c2jb
|
|
REAL*8 :: c3
|
|
REAL*8 :: c3jb
|
|
INTEGER :: islv
|
|
INTEGER :: branch
|
|
REAL*8 :: temp2
|
|
REAL*8 :: temp1
|
|
REAL*8 :: temp0
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp2jb
|
|
REAL*8 :: temp0jb
|
|
REAL*8 :: temp2jb1
|
|
REAL*8 :: temp2jb0
|
|
REAL*8 :: temp3jb
|
|
REAL*8 :: temp3jb0
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
REAL*8 :: temp1jb
|
|
CALL POPCONTROL3B(branch)
|
|
IF (branch < 3) THEN
|
|
IF (branch == 0) THEN
|
|
DO ii1=1,ncomp
|
|
wjb(ii1) = 0.D0
|
|
ENDDO
|
|
wjb(4) = wjb(4) + ghno3jb
|
|
molaljb(7) = molaljb(7) - ghno3jb
|
|
ELSE IF (branch == 1) THEN
|
|
DO ii1=1,ncomp
|
|
wjb(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
DO ii1=1,ncomp
|
|
wjb(ii1) = 0.D0
|
|
ENDDO
|
|
GOTO 100
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
wjb(5) = wjb(5) + ghcljb
|
|
molaljb(4) = molaljb(4) - ghcljb
|
|
END IF
|
|
ELSE IF (branch < 5) THEN
|
|
IF (branch == 3) THEN
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL CALCNA_JB()
|
|
ELSE
|
|
CALL POPREAL8ARRAY(molal, nions)
|
|
CALL CALCHA_JB()
|
|
END IF
|
|
ELSE
|
|
IF (branch == 5) THEN
|
|
CALL POPREAL8(delcl)
|
|
CALL POPREAL8(omega)
|
|
DO ii1=1,ncomp
|
|
wjb(ii1) = 0.D0
|
|
ENDDO
|
|
ELSE
|
|
CALL POPREAL8(delcl)
|
|
CALL POPREAL8(omega)
|
|
DO ii1=1,ncomp
|
|
wjb(ii1) = 0.D0
|
|
ENDDO
|
|
wjb(4) = wjb(4) + ghno3jb
|
|
molaljb(7) = molaljb(7) - ghno3jb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
wjb(5) = wjb(5) + ghcljb
|
|
molaljb(4) = molaljb(4) - ghcljb
|
|
END IF
|
|
delnojb = molaljb(1) + molaljb(7)
|
|
delcljb = molaljb(1) + molaljb(4)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
CALL POPREAL8(delcl)
|
|
delnojb = 0.D0
|
|
delcljb = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
c1 = a3*chi3
|
|
c2 = a4*chi4
|
|
c3 = a3 - a4
|
|
chi3jb = delnojb
|
|
delnojb = 0.D0
|
|
ELSE
|
|
c1 = a3*chi3
|
|
c2 = a4*chi4
|
|
c3 = a3 - a4
|
|
chi3jb = 0.D0
|
|
END IF
|
|
temp3jb = delnojb/(c2+c3*delcl)
|
|
temp3jb0 = -(c1*delcl*temp3jb/(c2+c3*delcl))
|
|
c1jb = delcl*temp3jb
|
|
delcljb = delcljb + c3*temp3jb0 + c1*temp3jb
|
|
c2jb = temp3jb0
|
|
c3jb = delcl*temp3jb0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
chi4jb = delcljb
|
|
delcljb = 0.D0
|
|
ELSE
|
|
chi4jb = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) delcljb = 0.D0
|
|
m1 = (c1+c2+(omega+a4)*c3)/c3
|
|
m2 = ((omega+a4)*c2-a4*c3*chi4)/c3
|
|
m3 = -(a4*c2*chi4/c3)
|
|
CALL POLY3_JB(m1, m1jb, m2, m2jb, m3, m3jb, delcl, delcljb, islv
|
|
+ )
|
|
temp2 = chi4/c3
|
|
temp2jb = -(a4*c2*m3jb/c3)
|
|
temp2jb0 = m2jb/c3
|
|
temp2jb1 = m1jb/c3
|
|
c2jb = c2jb + (omega+a4)*temp2jb0 + temp2jb1 - temp2*a4*m3jb
|
|
chi4jb = chi4jb + a4*c2jb - a4*c3*temp2jb0 + temp2jb
|
|
c3jb = c3jb + (-(((omega+a4)*c2-a4*c3*chi4)/c3)-chi4*a4)*
|
|
+ temp2jb0 + (omega-(c1+c2+(omega+a4)*c3)/c3+a4)*temp2jb1 -
|
|
+ temp2*temp2jb
|
|
a4jb = (c2-chi4*c3)*temp2jb0 - c3jb + chi4*c2jb + c3*temp2jb1 -
|
|
+ temp2*c2*m3jb
|
|
omegajb = c3*temp2jb1 + c2*temp2jb0
|
|
c1jb = c1jb + temp2jb1
|
|
a3jb = chi3*c1jb + c3jb
|
|
chi3jb = chi3jb + a3*c1jb
|
|
wjb(5) = wjb(5) + chi4jb
|
|
wjb(4) = wjb(4) + chi3jb
|
|
molaljb(1) = molaljb(1) + omegajb
|
|
temp1 = water/gama(11)
|
|
temp1jb = 2.0*temp1*xk3*r*temp*a4jb/gama(11)
|
|
gamajb(11) = gamajb(11) - temp1*temp1jb
|
|
temp0 = water/gama(10)
|
|
temp0jb = 2.0*temp0*xk4*r*temp*a3jb/gama(10)
|
|
waterjb = waterjb + temp0jb + temp1jb
|
|
gamajb(10) = gamajb(10) - temp0*temp0jb
|
|
END IF
|
|
100 CONTINUE
|
|
END
|
|
|
|
C Differentiation of calcha in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water ghcl
|
|
C with respect to varying inputs: w molal gama water
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCHA
|
|
C *** CALCULATES CHLORIDES SPECIATION
|
|
C
|
|
C HYDROCHLORIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES,
|
|
C AND DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE
|
|
C HYDROCHLORIC ACID DISSOLVED IS CALCULATED FROM THE
|
|
C HCL(G) <-> (H+) + (CL-)
|
|
C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCHA_JB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: kapa, x, delt, alfa, diak
|
|
REAL*8 :: kapajb, xjb, deltjb, alfajb, diakjb
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp1jb1
|
|
REAL*8 :: temp0jb
|
|
REAL*8 :: temp1jb0
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp1jb
|
|
C
|
|
C *** CALCULATE HCL DISSOLUTION *****************************************
|
|
C
|
|
x = w(5)
|
|
delt = 0.0d0
|
|
IF (water > tiny) THEN
|
|
kapa = molal(1)
|
|
alfa = xk3*r*temp*(water/gama(11))**2.0
|
|
diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x)
|
|
delt = 0.5*(-(kapa+alfa)+diak)
|
|
CC IF (DELT/KAPA > 0.1d0) THEN
|
|
CC WRITE (ERRINF,'(1PE10.3)') DELT/KAPA*100.0
|
|
CC CALL PUSHERR (0033, ERRINF)
|
|
CC ENDIF
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
IF (x - delt < 0.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
deltjb = molaljb(4) + molaljb(1)
|
|
molaljb(4) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
xjb = 0.D0
|
|
ELSE
|
|
xjb = ghcljb
|
|
deltjb = deltjb - ghcljb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp1jb = 0.5*deltjb
|
|
diakjb = temp1jb
|
|
IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN
|
|
temp1jb1 = 0.0
|
|
ELSE
|
|
temp1jb1 = diakjb/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x)))
|
|
END IF
|
|
temp1jb0 = 2.0*(kapa+alfa)*temp1jb1
|
|
alfajb = temp1jb0 + 4.0*x*temp1jb1 - temp1jb
|
|
kapajb = temp1jb0 - temp1jb
|
|
xjb = xjb + 4.0*alfa*temp1jb1
|
|
temp0 = water/gama(11)
|
|
temp0jb = 2.0*temp0*xk3*r*temp*alfajb/gama(11)
|
|
waterjb = waterjb + temp0jb
|
|
gamajb(11) = gamajb(11) - temp0*temp0jb
|
|
molaljb(1) = molaljb(1) + kapajb
|
|
END IF
|
|
DO ii1=1,ncomp
|
|
wjb(ii1) = 0.D0
|
|
ENDDO
|
|
wjb(5) = wjb(5) + xjb
|
|
END
|
|
|
|
C Differentiation of calcna in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water ghno3
|
|
C with respect to varying inputs: w molal gama water
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCNA
|
|
C *** CALCULATES NITRATES SPECIATION
|
|
C
|
|
C NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT
|
|
C DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC
|
|
C ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> (H+) + (NO3-)
|
|
C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCNA_JB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: alfa, delt, kapa, diak
|
|
REAL*8 :: alfajb, deltjb, kapajb, diakjb
|
|
REAL*8 :: x
|
|
REAL*8 :: xjb
|
|
INTEGER :: branch
|
|
REAL*8 :: temp0
|
|
INTRINSIC MAX
|
|
REAL*8 :: temp1jb1
|
|
REAL*8 :: temp0jb
|
|
REAL*8 :: temp1jb0
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp1jb
|
|
C
|
|
C *** CALCULATE HNO3 DISSOLUTION ****************************************
|
|
C
|
|
x = w(4)
|
|
delt = 0.0d0
|
|
IF (water > tiny) THEN
|
|
kapa = molal(1)
|
|
alfa = xk4*r*temp*(water/gama(10))**2.0
|
|
diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x)
|
|
delt = 0.5*(-(kapa+alfa)+diak)
|
|
CALL PUSHCONTROL1B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(0)
|
|
END IF
|
|
IF (x - delt < 0.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
deltjb = molaljb(7) + molaljb(1)
|
|
molaljb(7) = 0.D0
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
xjb = 0.D0
|
|
ELSE
|
|
xjb = ghno3jb
|
|
deltjb = deltjb - ghno3jb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) THEN
|
|
temp1jb = 0.5*deltjb
|
|
diakjb = temp1jb
|
|
IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN
|
|
temp1jb1 = 0.0
|
|
ELSE
|
|
temp1jb1 = diakjb/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x)))
|
|
END IF
|
|
temp1jb0 = 2.0*(kapa+alfa)*temp1jb1
|
|
alfajb = temp1jb0 + 4.0*x*temp1jb1 - temp1jb
|
|
kapajb = temp1jb0 - temp1jb
|
|
xjb = xjb + 4.0*alfa*temp1jb1
|
|
temp0 = water/gama(10)
|
|
temp0jb = 2.0*temp0*xk4*r*temp*alfajb/gama(10)
|
|
waterjb = waterjb + temp0jb
|
|
gamajb(10) = gamajb(10) - temp0*temp0jb
|
|
molaljb(1) = molaljb(1) + kapajb
|
|
END IF
|
|
DO ii1=1,ncomp
|
|
wjb(ii1) = 0.D0
|
|
ENDDO
|
|
wjb(4) = wjb(4) + xjb
|
|
END
|
|
|
|
C Differentiation of calcact3 in reverse (adjoint) mode:
|
|
C gradient of useful results: molal gama water
|
|
C with respect to varying inputs: molal gama water
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE CALCACT3
|
|
C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS
|
|
C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY
|
|
C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3).
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE CALCACT3_JB()
|
|
INCLUDE 'isrpia_adj.inc'
|
|
C
|
|
REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2
|
|
+ (4)
|
|
REAL*8 :: g0jb(6, 4), sionjb, hjb, chjb, f1jb(3), f2jb(4)
|
|
REAL*8 :: mpl, xij, yji
|
|
REAL*8 :: mpljb, xijjb, yjijb, ionicjb
|
|
INTEGER :: i
|
|
REAL*8 :: g01
|
|
REAL*8 :: g01jb
|
|
REAL*8 :: g02
|
|
REAL*8 :: g02jb
|
|
REAL*8 :: g03
|
|
REAL*8 :: g03jb
|
|
REAL*8 :: g04
|
|
REAL*8 :: g04jb
|
|
REAL*8 :: g05
|
|
REAL*8 :: g05jb
|
|
REAL*8 :: g06
|
|
REAL*8 :: g06jb
|
|
REAL*8 :: g07
|
|
REAL*8 :: g07jb
|
|
REAL*8 :: g08
|
|
REAL*8 :: g08jb
|
|
REAL*8 :: g09
|
|
REAL*8 :: g09jb
|
|
REAL*8 :: g10
|
|
REAL*8 :: g10jb
|
|
REAL*8 :: g11
|
|
REAL*8 :: g11jb
|
|
REAL*8 :: g12
|
|
REAL*8 :: g12jb
|
|
INTEGER :: j
|
|
REAL*8 :: errou
|
|
REAL*8 :: errin
|
|
C
|
|
INTEGER :: branch
|
|
REAL*8 :: x1jb
|
|
INTRINSIC MAX
|
|
INTRINSIC ABS
|
|
REAL*8 :: x2
|
|
REAL*8 :: x1
|
|
REAL*8 :: temp0jb9
|
|
REAL*8 :: temp0jb8
|
|
REAL*8 :: temp0jb7
|
|
REAL*8 :: temp0jb6
|
|
REAL*8 :: x2jb
|
|
REAL*8 :: temp0jb5
|
|
REAL*8 :: temp0jb4
|
|
REAL*8 :: temp0jb3
|
|
REAL*8 :: temp0jb2
|
|
REAL*8 :: temp0jb1
|
|
REAL*8 :: temp0jb0
|
|
REAL*8 :: temp0jb
|
|
REAL*8 :: temp0jb13
|
|
REAL*8 :: temp0jb12
|
|
REAL*8 :: temp0jb11
|
|
REAL*8 :: temp0jb10
|
|
INTRINSIC MIN
|
|
INTEGER :: ii2
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: y2
|
|
REAL*8 :: y1
|
|
C
|
|
C
|
|
C *** CALCULATE IONIC ACTIVITY OF SOLUTION *****************************
|
|
C
|
|
ionic = 0.d0
|
|
DO i=1,7
|
|
ionic = ionic + molal(i)*z(i)*z(i)
|
|
ENDDO
|
|
IF (0.5d0*ionic/water > 200.d0) THEN
|
|
x1 = 200.d0
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
x1 = 0.5d0*ionic/water
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x1 < tiny) THEN
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = tiny
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHREAL8(ionic)
|
|
ionic = x1
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C
|
|
C *** CALCULATE BINARY ACTIVITY COEFFICIENTS ***************************
|
|
C
|
|
C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02
|
|
C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05
|
|
C
|
|
C
|
|
CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08,
|
|
+ g09, g10, g11, g12)
|
|
C
|
|
g0(1, 1) = g11
|
|
g0(1, 2) = g07
|
|
g0(1, 3) = g08
|
|
g0(1, 4) = g10
|
|
g0(2, 1) = g01
|
|
g0(2, 2) = g02
|
|
g0(2, 3) = g12
|
|
g0(2, 4) = g03
|
|
g0(3, 1) = g06
|
|
g0(3, 2) = g04
|
|
g0(3, 3) = g09
|
|
g0(3, 4) = g05
|
|
C
|
|
C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS *******************
|
|
C
|
|
C Debye Huckel const. at T
|
|
agama = 0.511d0*(298.d0/temp)**1.5d0
|
|
sion = SQRT(ionic)
|
|
h = agama*sion/(1.d0+sion)
|
|
C
|
|
DO i=1,3
|
|
f1(i) = 0.d0
|
|
f2(i) = 0.d0
|
|
ENDDO
|
|
f2(4) = 0.d0
|
|
C
|
|
DO i=1,3
|
|
CALL PUSHREAL8(zpl)
|
|
zpl = z(i)
|
|
CALL PUSHREAL8(mpl)
|
|
mpl = molal(i)/water
|
|
DO j=1,4
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
yji = ch*molal(j+3)/water
|
|
f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h)
|
|
f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h)
|
|
ENDDO
|
|
ENDDO
|
|
CALL PUSHREAL8(gama(1))
|
|
C
|
|
C *** LOG10 OF ACTIVITY COEFFICIENTS ***********************************
|
|
C
|
|
C GAMA(01) = G(2,1)*ZZ(01) ! NACL
|
|
C NACL
|
|
gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1)
|
|
CALL PUSHREAL8(gama(2))
|
|
C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4
|
|
C NA2SO4
|
|
gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2)
|
|
CALL PUSHREAL8(gama(3))
|
|
C GAMA(03) = G(2,4)*ZZ(03) ! NANO3
|
|
C NANO3
|
|
gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3)
|
|
CALL PUSHREAL8(gama(4))
|
|
C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4
|
|
C (NH4)2SO4
|
|
gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4)
|
|
CALL PUSHREAL8(gama(5))
|
|
C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3
|
|
C NH4NO3
|
|
gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5)
|
|
CALL PUSHREAL8(gama(6))
|
|
C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL
|
|
C NH4CL
|
|
gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6)
|
|
CALL PUSHREAL8(gama(7))
|
|
C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4
|
|
C 2H-SO4
|
|
gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7)
|
|
CALL PUSHREAL8(gama(8))
|
|
C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4
|
|
C H-HSO4
|
|
gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8)
|
|
CALL PUSHREAL8(gama(9))
|
|
C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4
|
|
C NH4HSO4
|
|
gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9)
|
|
CALL PUSHREAL8(gama(10))
|
|
C GAMA(10) = G(1,4)*ZZ(10) ! HNO3
|
|
C HNO3
|
|
gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10)
|
|
CALL PUSHREAL8(gama(11))
|
|
C GAMA(11) = G(1,1)*ZZ(11) ! HCL
|
|
C HCL
|
|
gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11)
|
|
CALL PUSHREAL8(gama(12))
|
|
C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4
|
|
C NAHSO4
|
|
gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12)
|
|
CALL PUSHREAL8(gama(13))
|
|
C LC ; SCAPE
|
|
gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9))
|
|
C
|
|
C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA **************************
|
|
C
|
|
DO i=1,13
|
|
IF (gama(i) > 5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
x2 = 5.0d0
|
|
ELSE
|
|
x2 = gama(i)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
IF (x2 < -5.0d0) THEN
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
ENDDO
|
|
DO i=13,1,-1
|
|
gamajb(i) = 10.d0**gama(i)*LOG(10.d0)*gamajb(i)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
gamajb(i) = 0.D0
|
|
x2jb = 0.D0
|
|
ELSE
|
|
x2jb = gamajb(i)
|
|
gamajb(i) = 0.D0
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch /= 0) gamajb(i) = gamajb(i) + x2jb
|
|
ENDDO
|
|
CALL POPREAL8(gama(13))
|
|
gamajb(4) = gamajb(4) + 0.2d0*3.d0*gamajb(13)
|
|
gamajb(9) = gamajb(9) + 0.2d0*2.d0*gamajb(13)
|
|
gamajb(13) = 0.D0
|
|
DO ii1=1,3
|
|
f1jb(ii1) = 0.D0
|
|
ENDDO
|
|
DO ii1=1,4
|
|
f2jb(ii1) = 0.D0
|
|
ENDDO
|
|
CALL POPREAL8(gama(12))
|
|
temp0jb2 = zz(12)*gamajb(12)/(z(2)+z(6))
|
|
f1jb(2) = f1jb(2) + temp0jb2/z(2)
|
|
f2jb(3) = f2jb(3) + temp0jb2/z(6)
|
|
hjb = -(zz(12)*gamajb(12))
|
|
gamajb(12) = 0.D0
|
|
CALL POPREAL8(gama(11))
|
|
temp0jb3 = zz(11)*gamajb(11)/(z(1)+z(4))
|
|
f2jb(1) = f2jb(1) + temp0jb3/z(4)
|
|
hjb = hjb - zz(11)*gamajb(11)
|
|
gamajb(11) = 0.D0
|
|
CALL POPREAL8(gama(10))
|
|
temp0jb4 = zz(10)*gamajb(10)/(z(1)+z(7))
|
|
f1jb(1) = f1jb(1) + temp0jb4/z(1) + temp0jb3/z(1)
|
|
f2jb(4) = f2jb(4) + temp0jb4/z(7)
|
|
hjb = hjb - zz(10)*gamajb(10)
|
|
gamajb(10) = 0.D0
|
|
CALL POPREAL8(gama(9))
|
|
temp0jb5 = zz(9)*gamajb(9)/(z(3)+z(6))
|
|
f1jb(3) = f1jb(3) + temp0jb5/z(3)
|
|
hjb = hjb - zz(9)*gamajb(9)
|
|
gamajb(9) = 0.D0
|
|
CALL POPREAL8(gama(8))
|
|
temp0jb6 = zz(8)*gamajb(8)/(z(1)+z(6))
|
|
f2jb(3) = f2jb(3) + temp0jb6/z(6) + temp0jb5/z(6)
|
|
hjb = hjb - zz(8)*gamajb(8)
|
|
gamajb(8) = 0.D0
|
|
CALL POPREAL8(gama(7))
|
|
temp0jb7 = zz(7)*gamajb(7)/(z(1)+z(5))
|
|
f1jb(1) = f1jb(1) + temp0jb7/z(1) + temp0jb6/z(1)
|
|
f2jb(2) = f2jb(2) + temp0jb7/z(5)
|
|
hjb = hjb - zz(7)*gamajb(7)
|
|
gamajb(7) = 0.D0
|
|
CALL POPREAL8(gama(6))
|
|
temp0jb8 = zz(6)*gamajb(6)/(z(3)+z(4))
|
|
f2jb(1) = f2jb(1) + temp0jb8/z(4)
|
|
hjb = hjb - zz(6)*gamajb(6)
|
|
gamajb(6) = 0.D0
|
|
CALL POPREAL8(gama(5))
|
|
temp0jb9 = zz(5)*gamajb(5)/(z(3)+z(7))
|
|
f2jb(4) = f2jb(4) + temp0jb9/z(7)
|
|
hjb = hjb - zz(5)*gamajb(5)
|
|
gamajb(5) = 0.D0
|
|
CALL POPREAL8(gama(4))
|
|
temp0jb10 = zz(4)*gamajb(4)/(z(3)+z(5))
|
|
f1jb(3) = f1jb(3) + temp0jb9/z(3) + temp0jb10/z(3) + temp0jb8/z(3)
|
|
f2jb(2) = f2jb(2) + temp0jb10/z(5)
|
|
hjb = hjb - zz(4)*gamajb(4)
|
|
gamajb(4) = 0.D0
|
|
CALL POPREAL8(gama(3))
|
|
temp0jb11 = zz(3)*gamajb(3)/(z(2)+z(7))
|
|
f2jb(4) = f2jb(4) + temp0jb11/z(7)
|
|
hjb = hjb - zz(3)*gamajb(3)
|
|
gamajb(3) = 0.D0
|
|
CALL POPREAL8(gama(2))
|
|
temp0jb12 = zz(2)*gamajb(2)/(z(2)+z(5))
|
|
f2jb(2) = f2jb(2) + temp0jb12/z(5)
|
|
hjb = hjb - zz(2)*gamajb(2)
|
|
gamajb(2) = 0.D0
|
|
CALL POPREAL8(gama(1))
|
|
temp0jb13 = zz(1)*gamajb(1)/(z(2)+z(4))
|
|
f1jb(2) = f1jb(2) + temp0jb12/z(2) + temp0jb13/z(2) + temp0jb11/z(
|
|
+ 2)
|
|
f2jb(1) = f2jb(1) + temp0jb13/z(4)
|
|
hjb = hjb - zz(1)*gamajb(1)
|
|
gamajb(1) = 0.D0
|
|
ionicjb = 0.D0
|
|
DO ii1=1,4
|
|
DO ii2=1,6
|
|
g0jb(ii2, ii1) = 0.D0
|
|
ENDDO
|
|
ENDDO
|
|
DO i=3,1,-1
|
|
mpljb = 0.D0
|
|
DO j=4,1,-1
|
|
zmi = z(j+3)
|
|
ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic
|
|
xij = ch*mpl
|
|
xijjb = (g0(i, j)+zpl*zmi*h)*f2jb(j)
|
|
yji = ch*molal(j+3)/water
|
|
g0jb(i, j) = g0jb(i, j) + yji*f1jb(i) + xij*f2jb(j)
|
|
hjb = hjb + yji*zpl*zmi*f1jb(i) + xij*zpl*zmi*f2jb(j)
|
|
yjijb = (g0(i, j)+zpl*zmi*h)*f1jb(i)
|
|
temp0jb1 = molal(j+3)*yjijb/water
|
|
molaljb(j+3) = molaljb(j+3) + ch*yjijb/water
|
|
chjb = mpl*xijjb + temp0jb1
|
|
waterjb = waterjb - ch*temp0jb1/water
|
|
mpljb = mpljb + ch*xijjb
|
|
ionicjb = ionicjb - (zpl+zmi)**2*0.25d0*chjb/ionic**2
|
|
ENDDO
|
|
CALL POPREAL8(mpl)
|
|
molaljb(i) = molaljb(i) + mpljb/water
|
|
waterjb = waterjb - molal(i)*mpljb/water**2
|
|
CALL POPREAL8(zpl)
|
|
ENDDO
|
|
temp0jb0 = agama*hjb/(sion+1.d0)
|
|
sionjb = (1.D0-sion/(sion+1.d0))*temp0jb0
|
|
IF (.NOT.ionic == 0.0) ionicjb = ionicjb + sionjb/(2.0*SQRT(
|
|
+ ionic))
|
|
g05jb = g0jb(3, 4)
|
|
g0jb(3, 4) = 0.D0
|
|
g09jb = g0jb(3, 3)
|
|
g0jb(3, 3) = 0.D0
|
|
g04jb = g0jb(3, 2)
|
|
g0jb(3, 2) = 0.D0
|
|
g06jb = g0jb(3, 1)
|
|
g0jb(3, 1) = 0.D0
|
|
g03jb = g0jb(2, 4)
|
|
g0jb(2, 4) = 0.D0
|
|
g12jb = g0jb(2, 3)
|
|
g0jb(2, 3) = 0.D0
|
|
g02jb = g0jb(2, 2)
|
|
g0jb(2, 2) = 0.D0
|
|
g01jb = g0jb(2, 1)
|
|
g0jb(2, 1) = 0.D0
|
|
g10jb = g0jb(1, 4)
|
|
g0jb(1, 4) = 0.D0
|
|
g08jb = g0jb(1, 3)
|
|
g0jb(1, 3) = 0.D0
|
|
g07jb = g0jb(1, 2)
|
|
g0jb(1, 2) = 0.D0
|
|
g11jb = g0jb(1, 1)
|
|
CALL KMFUL3_JB(ionic, ionicjb, temp, g01, g01jb, g02, g02jb, g03,
|
|
+ g03jb, g04, g04jb, g05, g05jb, g06, g06jb, g07,
|
|
+ g07jb, g08, g08jb, g09, g09jb, g10, g10jb, g11,
|
|
+ g11jb, g12, g12jb)
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
CALL POPREAL8(ionic)
|
|
x1jb = 0.D0
|
|
ELSE
|
|
CALL POPREAL8(ionic)
|
|
x1jb = ionicjb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ionicjb = 0.D0
|
|
ELSE
|
|
temp0jb = 0.5d0*x1jb/water
|
|
ionicjb = temp0jb
|
|
waterjb = waterjb - ionic*temp0jb/water
|
|
END IF
|
|
DO i=7,1,-1
|
|
molaljb(i) = molaljb(i) + z(i)**2*ionicjb
|
|
ENDDO
|
|
END
|
|
|
|
C Differentiation of kmful3 in reverse (adjoint) mode:
|
|
C gradient of useful results: g01 g02 g03 g04 g05 g06 g07
|
|
C g08 g09 g10 g11 g12 ionic
|
|
C with respect to varying inputs: ionic
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE KMFUL3
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD
|
|
C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C
|
|
C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE KMFUL3_JB(ionic, ionicjb, temp, g01, g01jb, g02, g02jb
|
|
+ , g03, g03jb, g04, g04jb, g05, g05jb, g06,
|
|
+ g06jb, g07, g07jb, g08, g08jb, g09, g09jb,
|
|
+ g10, g10jb, g11, g11jb, g12, g12jb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2
|
|
REAL*8 :: ionicjb, sionjb, cf2jb
|
|
REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10
|
|
+ , g11, g12
|
|
REAL*8 :: g01jb, g02jb, g03jb, g04jb, g05jb, g06jb, g07jb,
|
|
+ g08jb, g09jb, g10jb, g11jb, g12jb
|
|
REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11
|
|
REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11
|
|
INTEGER :: branch
|
|
INTRINSIC ABS
|
|
REAL*8 :: temp0jb0
|
|
REAL*8 :: temp0jb
|
|
REAL*8 :: abs1
|
|
INTRINSIC SQRT
|
|
DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0
|
|
+ , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/
|
|
C
|
|
sion = SQRT(ionic)
|
|
C
|
|
C *** Coefficients at 25 oC
|
|
C
|
|
q1 = 2.230d0
|
|
q2 = -0.19d0
|
|
q3 = -0.39d0
|
|
q4 = -0.25d0
|
|
q5 = -1.15d0
|
|
q6 = 0.820d0
|
|
q7 = -.100d0
|
|
q8 = 8.000d0
|
|
q10 = 2.600d0
|
|
q11 = 6.000d0
|
|
C
|
|
C
|
|
C *** Correct for T other than 298 K
|
|
C
|
|
ti = temp - 273.d0
|
|
tc = ti - 25.d0
|
|
IF (tc >= 0.) THEN
|
|
abs1 = tc
|
|
ELSE
|
|
abs1 = -tc
|
|
END IF
|
|
IF (abs1 > 1.d0) THEN
|
|
cf1 = 1.125d0 - 0.005d0*ti
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
g01jb = g01jb + g12jb
|
|
g08jb = g08jb + g09jb + g12jb
|
|
g11jb = g11jb - g09jb - g12jb
|
|
g06jb = g06jb + g09jb
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
cf2jb = -(z10*g10jb) - z07*g07jb - z05*g05jb - z03*g03jb - z01*
|
|
+ g01jb - z02*g02jb - z04*g04jb - z06*g06jb - z08*g08jb - z11*
|
|
+ g11jb
|
|
g11jb = cf1*g11jb
|
|
g10jb = cf1*g10jb
|
|
g08jb = cf1*g08jb
|
|
g07jb = cf1*g07jb
|
|
g06jb = cf1*g06jb
|
|
g05jb = cf1*g05jb
|
|
g04jb = cf1*g04jb
|
|
g03jb = cf1*g03jb
|
|
g02jb = cf1*g02jb
|
|
g01jb = cf1*g01jb
|
|
temp0jb = (0.125d0-ti*0.005d0)*cf2jb
|
|
temp0jb0 = -(0.41d0*temp0jb/(sion+1.d0))
|
|
ionicjb = ionicjb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0jb
|
|
sionjb = (1.D0-sion/(sion+1.d0))*temp0jb0
|
|
ELSE
|
|
sionjb = 0.D0
|
|
END IF
|
|
CALL MKBI_JB(q11, ionic, ionicjb, sion, sionjb, z11, g11, g11jb)
|
|
CALL MKBI_JB(q10, ionic, ionicjb, sion, sionjb, z10, g10, g10jb)
|
|
CALL MKBI_JB(q8, ionic, ionicjb, sion, sionjb, z08, g08, g08jb)
|
|
CALL MKBI_JB(q7, ionic, ionicjb, sion, sionjb, z07, g07, g07jb)
|
|
CALL MKBI_JB(q6, ionic, ionicjb, sion, sionjb, z06, g06, g06jb)
|
|
CALL MKBI_JB(q5, ionic, ionicjb, sion, sionjb, z05, g05, g05jb)
|
|
CALL MKBI_JB(q4, ionic, ionicjb, sion, sionjb, z04, g04, g04jb)
|
|
CALL MKBI_JB(q3, ionic, ionicjb, sion, sionjb, z03, g03, g03jb)
|
|
CALL MKBI_JB(q2, ionic, ionicjb, sion, sionjb, z02, g02, g02jb)
|
|
CALL MKBI_JB(q1, ionic, ionicjb, sion, sionjb, z01, g01, g01jb)
|
|
IF (.NOT.ionic == 0.0) ionicjb = ionicjb + sionjb/(2.0*SQRT(
|
|
+ ionic))
|
|
END
|
|
|
|
C Differentiation of mkbi in reverse (adjoint) mode:
|
|
C gradient of useful results: sion bi ionic
|
|
C with respect to varying inputs: sion ionic
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE MKBI
|
|
C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD.
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE MKBI_JB(q, ionic, ionicjb, sion, sionjb, zip, bi, bijb)
|
|
IMPLICIT NONE
|
|
REAL*8 :: q, ionic, sion, zip, bi
|
|
REAL*8 :: ionicjb, sionjb, bijb
|
|
REAL*8 :: b, c, xx
|
|
REAL*8 :: cjb, xxjb
|
|
INTRINSIC EXP
|
|
REAL*8 :: tempjb0
|
|
REAL*8 :: tempjb
|
|
INTRINSIC LOG10
|
|
C
|
|
b = .75d0 - .065d0*q
|
|
C C= 1.0
|
|
C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC)
|
|
c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic))
|
|
bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b
|
|
C
|
|
xxjb = zip*bijb
|
|
bijb = zip*bijb/(bi*LOG(10.0))
|
|
tempjb = -(0.5107d0*xxjb/(c*sion+1.d0))
|
|
tempjb0 = -(sion*tempjb/(c*sion+1.d0))
|
|
sionjb = sionjb + c*tempjb0 + tempjb
|
|
cjb = sion*tempjb0
|
|
IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q
|
|
+ ))) THEN
|
|
ionicjb = ionicjb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*
|
|
+ ionic**2*cjb
|
|
ELSE
|
|
ionicjb = ionicjb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bijb -
|
|
+ .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cjb
|
|
END IF
|
|
END
|
|
|
|
C Differentiation of poly3 in reverse (adjoint) mode:
|
|
C gradient of useful results: root
|
|
C with respect to varying inputs: a1 a2 a3
|
|
C
|
|
C
|
|
C=======================================================================
|
|
C
|
|
C *** ISORROPIA CODE
|
|
C *** SUBROUTINE POLY3
|
|
C *** FINDS THE REAL ROOTS OF THE THIRD ORDER ALGEBRAIC EQUATION:
|
|
C X**3 + A1*X**2 + A2*X + A3 = 0.0
|
|
C THE EQUATION IS SOLVED ANALYTICALLY.
|
|
C
|
|
C PARAMETERS A1, A2, A3 ARE SPECIFIED BY THE USER. THE MINIMUM
|
|
C NONEGATIVE ROOT IS RETURNED IN VARIABLE 'ROOT'. IF NO ROOT IS
|
|
C FOUND (WHICH IS GREATER THAN ZERO), ROOT HAS THE VALUE 1D30.
|
|
C AND THE FLAG ISLV HAS A VALUE GREATER THAN ZERO.
|
|
C
|
|
C SOLUTION FORMULA IS FOUND IN PAGE 32 OF:
|
|
C MATHEMATICAL HANDBOOK OF FORMULAS AND TABLES
|
|
C SCHAUM'S OUTLINE SERIES
|
|
C MURRAY SPIEGER, McGRAW-HILL, NEW YORK, 1968
|
|
C (GREEK TRANSLATION: BY SOTIRIOS PERSIDES, ESPI, ATHENS, 1976)
|
|
C
|
|
C A SPECIAL CASE IS CONSIDERED SEPERATELY ; WHEN A3 = 0, THEN
|
|
C ONE ROOT IS X=0.0, AND THE OTHER TWO FROM THE SOLUTION OF THE
|
|
C QUADRATIC EQUATION X**2 + A1*X + A2 = 0.0
|
|
C THIS SPECIAL CASE IS CONSIDERED BECAUSE THE ANALYTICAL FORMULA
|
|
C DOES NOT YIELD ACCURATE RESULTS (DUE TO NUMERICAL ROUNDOFF ERRORS)
|
|
C
|
|
C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
|
C *** GEORGIA INSTITUTE OF TECHNOLOGY
|
|
C *** WRITTEN BY ATHANASIOS NENES
|
|
C *** UPDATED BY CHRISTOS FOUNTOUKIS
|
|
C *** ADJOINT & UPDATE BY SHANNON CAPPS
|
|
C
|
|
C=======================================================================
|
|
C
|
|
SUBROUTINE POLY3_JB(a1, a1jb, a2, a2jb, a3, a3jb, root, rootjb,
|
|
+ islv)
|
|
IMPLICIT NONE
|
|
REAL*8 :: thet1
|
|
REAL*8 :: thet2
|
|
REAL*8 :: zero
|
|
REAL*8 :: expon
|
|
REAL*8 :: eps
|
|
REAL*8 :: pi
|
|
C
|
|
PARAMETER (expon=1.d0/3.d0, zero=0.d0, thet1=120.d0/180.d0, thet2=
|
|
+ 240.d0/180.d0, pi=3.1415926535897932D0, eps=1.d-50)
|
|
C REAL*8 :: X(3)
|
|
REAL*8 :: x(3), a1, a2, a3, root
|
|
REAL*8 :: xjb(3), a1jb, a2jb, a3jb, rootjb
|
|
INTEGER :: ix
|
|
REAL*8 :: d
|
|
REAL*8 :: djb
|
|
REAL*8 :: sqd
|
|
REAL*8 :: sqdjb
|
|
REAL*8 :: q
|
|
REAL*8 :: qjb
|
|
REAL*8 :: u
|
|
REAL*8 :: ujb
|
|
REAL*8 :: thet
|
|
REAL*8 :: thetjb
|
|
REAL*8 :: coef
|
|
REAL*8 :: coefjb
|
|
REAL*8 :: ssig
|
|
REAL*8 :: s
|
|
REAL*8 :: sjb
|
|
REAL*8 :: tsig
|
|
REAL*8 :: t
|
|
REAL*8 :: tjb
|
|
INTEGER :: i
|
|
INTEGER :: branch
|
|
INTEGER :: islv
|
|
REAL*8 :: temp0
|
|
INTRINSIC COS
|
|
REAL*8 :: tempjb0
|
|
REAL*8 :: tempjb
|
|
INTRINSIC SIGN
|
|
INTRINSIC ABS
|
|
REAL*8 :: abs3jb
|
|
REAL*8 :: abs4jb
|
|
INTRINSIC ACOS
|
|
REAL*8 :: abs4
|
|
REAL*8 :: abs3
|
|
REAL*8 :: abs2
|
|
REAL*8 :: abs1
|
|
INTRINSIC MIN
|
|
INTEGER :: ii1
|
|
INTRINSIC SQRT
|
|
REAL*8 :: temp
|
|
REAL*8 :: abs2jb
|
|
IF (a3 >= 0.) THEN
|
|
abs1 = a3
|
|
ELSE
|
|
abs1 = -a3
|
|
END IF
|
|
C
|
|
C *** SPECIAL CASE : QUADRATIC*X EQUATION *****************************
|
|
C
|
|
IF (abs1 <= eps) THEN
|
|
ix = 1
|
|
x(1) = zero
|
|
d = a1*a1 - 4.d0*a2
|
|
IF (d >= zero) THEN
|
|
ix = 3
|
|
sqd = SQRT(d)
|
|
x(2) = 0.5*(-a1+sqd)
|
|
x(3) = 0.5*(-a1-sqd)
|
|
CALL PUSHCONTROL3B(0)
|
|
ELSE
|
|
CALL PUSHCONTROL3B(1)
|
|
END IF
|
|
ELSE
|
|
C
|
|
C *** NORMAL CASE : CUBIC EQUATION ************************************
|
|
C
|
|
C DEFINE PARAMETERS Q, U, S, T, D
|
|
C
|
|
q = (3.d0*a2-a1*a1)/9.d0
|
|
u = (9.d0*a1*a2-27.d0*a3-2.d0*a1*a1*a1)/54.d0
|
|
d = q*q*q + u*u
|
|
C
|
|
C *** CALCULATE ROOTS *************************************************
|
|
C
|
|
C D < 0, THREE REAL ROOTS
|
|
C
|
|
IF (d < -eps) THEN
|
|
C D < -EPS : D < ZERO
|
|
ix = 3
|
|
thet = expon*ACOS(u/SQRT(-(q*q*q)))
|
|
coef = 2.d0*SQRT(-q)
|
|
x(1) = coef*COS(thet) - expon*a1
|
|
x(2) = coef*COS(thet+thet1*pi) - expon*a1
|
|
x(3) = coef*COS(thet+thet2*pi) - expon*a1
|
|
C
|
|
C D = 0, THREE REAL (ONE DOUBLE) ROOTS
|
|
C
|
|
CALL PUSHCONTROL3B(2)
|
|
ELSE IF (d <= eps) THEN
|
|
C -EPS <= D <= EPS : D = ZERO
|
|
ix = 2
|
|
ssig = SIGN(1.d0, u)
|
|
IF (u >= 0.) THEN
|
|
abs2 = u
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
abs2 = -u
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
s = ssig*abs2**expon
|
|
x(1) = 2.d0*s - expon*a1
|
|
x(2) = -s - expon*a1
|
|
C
|
|
C D > 0, ONE REAL ROOT
|
|
C
|
|
CALL PUSHCONTROL3B(3)
|
|
ELSE
|
|
C D > EPS : D > ZERO
|
|
ix = 1
|
|
sqd = SQRT(d)
|
|
C TRANSFER SIGN TO SSIG
|
|
ssig = SIGN(1.d0, u + sqd)
|
|
tsig = SIGN(1.d0, u - sqd)
|
|
IF (u + sqd >= 0.) THEN
|
|
abs3 = u + sqd
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
abs3 = -(u+sqd)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
C EXPONENTIATE ABS()
|
|
s = ssig*abs3**expon
|
|
IF (u - sqd >= 0.) THEN
|
|
abs4 = u - sqd
|
|
CALL PUSHCONTROL1B(0)
|
|
ELSE
|
|
abs4 = -(u-sqd)
|
|
CALL PUSHCONTROL1B(1)
|
|
END IF
|
|
t = tsig*abs4**expon
|
|
x(1) = s + t - expon*a1
|
|
CALL PUSHCONTROL3B(4)
|
|
END IF
|
|
END IF
|
|
C
|
|
C *** SELECT APPROPRIATE ROOT *****************************************
|
|
C
|
|
root = 1.d30
|
|
DO i=1,ix
|
|
IF (x(i) > zero) THEN
|
|
IF (root > x(i)) THEN
|
|
root = x(i)
|
|
CALL PUSHCONTROL2B(1)
|
|
ELSE
|
|
CALL PUSHCONTROL2B(2)
|
|
root = root
|
|
END IF
|
|
ELSE
|
|
CALL PUSHCONTROL2B(0)
|
|
END IF
|
|
ENDDO
|
|
DO ii1=1,3
|
|
xjb(ii1) = 0.D0
|
|
ENDDO
|
|
DO i=ix,1,-1
|
|
CALL POPCONTROL2B(branch)
|
|
IF (branch /= 0) THEN
|
|
IF (branch == 1) THEN
|
|
xjb(i) = xjb(i) + rootjb
|
|
rootjb = 0.D0
|
|
END IF
|
|
END IF
|
|
ENDDO
|
|
CALL POPCONTROL3B(branch)
|
|
IF (branch < 2) THEN
|
|
IF (branch == 0) THEN
|
|
a1jb = -(0.5*xjb(3))
|
|
sqdjb = -(0.5*xjb(3))
|
|
xjb(3) = 0.D0
|
|
sqdjb = sqdjb + 0.5*xjb(2)
|
|
a1jb = a1jb - 0.5*xjb(2)
|
|
IF (d == 0.0) THEN
|
|
djb = 0.0
|
|
ELSE
|
|
djb = sqdjb/(2.0*SQRT(d))
|
|
END IF
|
|
ELSE
|
|
a1jb = 0.D0
|
|
djb = 0.D0
|
|
END IF
|
|
a1jb = a1jb + 2*a1*djb
|
|
a2jb = -(4.d0*djb)
|
|
a3jb = 0.D0
|
|
ELSE
|
|
IF (branch == 2) THEN
|
|
coefjb = COS(thet2*pi+thet)*xjb(3)
|
|
thetjb = -(coef*SIN(thet2*pi+thet)*xjb(3))
|
|
a1jb = -(expon*xjb(3))
|
|
xjb(3) = 0.D0
|
|
coefjb = coefjb + COS(thet1*pi+thet)*xjb(2)
|
|
thetjb = thetjb - coef*SIN(thet1*pi+thet)*xjb(2)
|
|
a1jb = a1jb - expon*xjb(2)
|
|
xjb(2) = 0.D0
|
|
coefjb = coefjb + COS(thet)*xjb(1)
|
|
thetjb = thetjb - coef*SIN(thet)*xjb(1)
|
|
a1jb = a1jb - expon*xjb(1)
|
|
IF (-q == 0.0) THEN
|
|
qjb = 0.0
|
|
ELSE
|
|
qjb = -(2.d0*coefjb/(2.0*SQRT(-q)))
|
|
END IF
|
|
temp0 = -(q**3)
|
|
temp = SQRT(temp0)
|
|
tempjb0 = -(expon*thetjb/(SQRT(1.0-(u/temp)**2)*temp))
|
|
ujb = tempjb0
|
|
IF (.NOT.temp0 == 0.0) qjb = qjb + u*3*q**2*tempjb0/(2.0*
|
|
+ temp**2)
|
|
djb = 0.D0
|
|
ELSE
|
|
IF (branch == 3) THEN
|
|
sjb = -xjb(2)
|
|
a1jb = -(expon*xjb(2))
|
|
xjb(2) = 0.D0
|
|
sjb = sjb + 2.d0*xjb(1)
|
|
a1jb = a1jb - expon*xjb(1)
|
|
IF (abs2 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT(
|
|
+ expon))) THEN
|
|
abs2jb = 0.0
|
|
ELSE
|
|
abs2jb = ssig*expon*abs2**(expon-1)*sjb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ujb = abs2jb
|
|
ELSE
|
|
ujb = -abs2jb
|
|
END IF
|
|
djb = 0.D0
|
|
ELSE
|
|
sjb = xjb(1)
|
|
tjb = xjb(1)
|
|
a1jb = -(expon*xjb(1))
|
|
IF (abs4 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT(
|
|
+ expon))) THEN
|
|
abs4jb = 0.0
|
|
ELSE
|
|
abs4jb = tsig*expon*abs4**(expon-1)*tjb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ujb = abs4jb
|
|
sqdjb = -abs4jb
|
|
ELSE
|
|
sqdjb = abs4jb
|
|
ujb = -abs4jb
|
|
END IF
|
|
IF (abs3 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT(
|
|
+ expon))) THEN
|
|
abs3jb = 0.0
|
|
ELSE
|
|
abs3jb = ssig*expon*abs3**(expon-1)*sjb
|
|
END IF
|
|
CALL POPCONTROL1B(branch)
|
|
IF (branch == 0) THEN
|
|
ujb = ujb + abs3jb
|
|
sqdjb = sqdjb + abs3jb
|
|
ELSE
|
|
ujb = ujb - abs3jb
|
|
sqdjb = sqdjb - abs3jb
|
|
END IF
|
|
IF (d == 0.0) THEN
|
|
djb = 0.0
|
|
ELSE
|
|
djb = sqdjb/(2.0*SQRT(d))
|
|
END IF
|
|
END IF
|
|
qjb = 0.D0
|
|
END IF
|
|
qjb = qjb + 3*q**2*djb
|
|
ujb = ujb + 2*u*djb
|
|
tempjb = ujb/54.d0
|
|
a1jb = a1jb + (9.d0*a2-2.d0*3*a1**2)*tempjb - 2*a1*qjb/9.d0
|
|
a2jb = 3.d0*qjb/9.d0 + 9.d0*a1*tempjb
|
|
a3jb = -(27.d0*tempjb)
|
|
END IF
|
|
END
|