! ! 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 , 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 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 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).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).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).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).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