Sola/GEOS-Chem-adjoint-v35-note
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
389fdea5ae19f0bc6ba56683992d08d4ead79574
GEOS-Chem-adjoint-v35-note/code/adjoint/rpmares_adj_mod.f
Xuesong (Steve) f842cc9639 Add files via upload
2018-08-28 00:33:48 -04:00

3961 lines
118 KiB
Fortran
Raw Blame History

! $Id: rpmares_adj_mod.f,v 1.1 2009/09/09 06:12:55 daven Exp $
MODULE RPMARES_ADJ_MOD
!
!******************************************************************************
! Module RPMARES_ADJ_MOD is used to call the aerosol thermo adjoint
! subroutines (dkh, 09/08/09)
!
! Module Routines:
! ============================================================================
! (1 ) DO_RPMARES_ADJ : Driver which calls adjoint thermo routines
! (2 ) adactcof : adjoint of actcof
! (3 ) adawater : adjoint of awater
! (4 ) adrpmares_11 : adjoint of rpmares exit=11
! (5 ) adrpmares_12 : adjoint of rpmares exit=12
! (6 ) adrpmares_2 : adjoint of rpmares exit=2
! (7 ) adrpmares_3 : adjoint of rpmares exit=3
! (8 ) adrpmares_4 : adjoint of rpmares exit=4
! (9 ) adrpmares_6 : adjoint of rpmares exit=6 (old)
! (10) adrpmares_7 : adjoint of rpmares exit=7
! (11) adrpmares_8 : adjoint of rpmares exit=8
! (12) adcubic : adjoint of cubic
! (13) adrpmares_6_D5 : adjoint of rpmares exit=6 (correct)
!
! GEOS-CHEM modules referenced by chemistry_mod.f
! ============================================================================
! (1 ) checkpt_mod : Module w/ routines for checkpointing
! (2 ) dao_mod : Module containing arrays for DAO met fields
! (3 ) rpmares_mod : Module w/ routines for aerosol thermodynamics
! (4 ) tracerid_mod : Module containing pointers to tracers & emissions
!
! NOTES:
! (1 ) Updated to GCv8 (dkh, 09/09/09)
!
!******************************************************************************
!
IMPLICIT NONE
!=================================================================
! MODULE ROUTINES -- follow below the "CONTAINS" statement
!=================================================================
CONTAINS
!------------------------------------------------------------------------------
SUBROUTINE DO_RPMARES_ADJ ( )
!
!******************************************************************************
! Subroutine DO_RPMARES_ADJ is the driver for the TAMC generated adjoint of the
! aerosol thermodynamic routine RPMARES
! (dkh, 8/27/04, 09/08/09)
!
! Passed via checkpoint_mod.f
! ============================================================================
!
! NOTES:
! (1 ) Add error checking. Add ADJ_NAN, FIRST, ADJ_NAN_COUNT, ADJ_MAX...
! Check ADJ_STT for NAN and for large increases after calls to adrpmares.
! Now reference IT_IS_NAN. (dkh, 02/08/05)
! (2 ) Move paramters NCTOT and NPAR from CMN_ADJ to here. Replace many uses
! of NADJ with NCTOT. Initialize ADJ_TMP after initializing ADJ_STT_LOCAL.
! ADJ_STT_LOCAL is now dim = 8, not dim = NOBS, as NOBS may be much larger.
! Remove IS_DURING_OBSERVATION argument
! No longer force adjoints in this routine, do it in ???. (dkh, 03/03/05)
! (3 ) Now the ITS_TIME_FOR_CHEM section uses ADJ_STT [kg], so switch to
! [ug/m3] for this portion, and switch back at the end. (dkh, 03/10/05)
! (4 ) Replace the adjoint code for the high ratio case ( NRETURN = 6 ) with
! improved code that is more accurate and requires less checkpointing.
! (dkh, 06/01/05)
! (5 ) Now reference ADJ_CONVERT_UNITS from dao_mod.f (dkh, 11/03/05)
! (6 ) Udpated to GCv8, renamed from ADJ_AEROSOL to DO_RPMARES_ADJ.
!******************************************************************************
!
! References to F90 modules
USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD
USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ
USE CHECKPT_MOD, ONLY : RP_IN, RP_OUT
USE DAO_MOD, ONLY : AIRVOL
USE ERROR_MOD, ONLY : ERROR_STOP, IT_IS_NAN
USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD
USE TRACERID_MOD, ONLY : IDTSO4, IDTNH3, IDTNH4, IDTHNO3
USE TRACERID_MOD, ONLY : IDTNIT
USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT
# include "CMN_SIZE" ! Size params
! Parameters
INTEGER, PARAMETER :: MAX_ALLOWED_NAN = 10
INTEGER, PARAMETER :: MAX_ALLOWED_EXPLD = 10
REAL*8, PARAMETER :: MAX_ALLOWED_INCREASE = 10.0D10
INTEGER, PARAMETER :: NPAR = 2 ! Number of input variables to RPMARES that are
! parameters, i.e. temp and rh
INTEGER, PARAMETER :: NCTOT = 5 ! Number of input variables to RPMARES that are
! total concentrations, = NRPIN - NPAR
! Local variables
REAL*8 :: CTOT_P(NCTOT) ! Same size as argument of the ad_rpmares routines
REAL*8 :: PAR_P(NPAR)
REAL*8 :: ADJ_STT_LOCAL(8) ! Same size as argument of the ad_rpmares routines
REAL*8 :: ADJ_CTOT(NCTOT)
INTEGER :: I, J, L, N
INTEGER :: NRETURN
REAL*8 :: ADJ_TMP(NCTOT) ! Temp storage for resetting bad adjs to original value
REAL*8 :: MAX_ADJ_TMP ! Temp max value used for error checking
LOGICAL :: ADJ_NAN = .FALSE.
INTEGER :: ADJ_NAN_COUNT, ADJ_EXPLD_COUNT
LOGICAL, SAVE :: FIRST = .TRUE.
REAL*8 :: AVOL
!================================================================
! DO_RPMARES_ADJ begins here!
!================================================================
! Initialize ADJ_NAN_COUNT the first time through
IF ( FIRST ) THEN
ADJ_NAN_COUNT = 0
ADJ_EXPLD_COUNT = 0
FIRST = .FALSE.
ENDIF
! Save maximum adjoint for error checking later
MAX_ADJ_TMP = MAXVAL( ABS(STT_ADJ) )
!$OMP PARALLEL DO
!$OMP+DEFAULT( SHARED )
!$OMP+PRIVATE( I, J, L, N )
!$OMP+PRIVATE( CTOT_P, PAR_P, NRETURN, ADJ_STT_LOCAL )
!$OMP+PRIVATE( ADJ_TMP, ADJ_CTOT )
!$OMP+PRIVATE( AVOL )
DO L = 1, LLTROP
DO J = 1, JJPAR
DO I = 1, IIPAR
! Skip if we are in the stratosphere (bmy, 4/3/08)
IF ( ITS_IN_THE_STRAT( I, J, L ) ) CYCLE
! air volume
AVOL = AIRVOL(I,J,L)
! Load IN from RP_IN
CTOT_P(:) = RP_IN(I,J,L,1:NCTOT)
! Load parameters from RP_IN
PAR_P(:) = RP_IN(I,J,L,6:7)
! Find out where RPMARES exited during the forward run
NRETURN = RP_OUT(I,J,L,9)
! Initialize the independent and dependent variables to 0
ADJ_CTOT(:) = 0.D0
ADJ_STT_LOCAL(:) = 0.D0
! Copy current value of ADJ variable to ADJ_STT_LOCAL
! Always update the local adjoint input to the current adjoint tracer
! values
ADJ_STT_LOCAL(3) = STT_ADJ(I,J,L,IDTNIT) * AVOL * 1.d-9
ADJ_STT_LOCAL(5) = STT_ADJ(I,J,L,IDTNH4) * AVOL * 1.d-9
ADJ_STT_LOCAL(7) = STT_ADJ(I,J,L,IDTHNO3) * AVOL * 1.d-9
ADJ_STT_LOCAL(8) = STT_ADJ(I,J,L,IDTNH3) * AVOL * 1.d-9
! Since thermo doesn't modify total sulfate, don't need to
! pass it initial adjoint values for SO4 ?
ADJ_STT_LOCAL(6) = 0d0
! The forcing for these species is also zero
ADJ_STT_LOCAL(1) = 0.d0
ADJ_STT_LOCAL(2) = 0.d0
ADJ_STT_LOCAL(4) = 0.d0
! Store original values in ADJ_TMP
ADJ_TMP(1) = STT_ADJ(I,J,L,IDTSO4)
ADJ_TMP(2) = STT_ADJ(I,J,L,IDTHNO3)
ADJ_TMP(3) = STT_ADJ(I,J,L,IDTNH3)
ADJ_TMP(4) = STT_ADJ(I,J,L,IDTNIT)
ADJ_TMP(5) = STT_ADJ(I,J,L,IDTNH4)
IF ( LPRINTFD
& .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN
print*, 'before ', CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL
print*, 'NRETURN = ', NRETURN
ENDIF
!============================================================
! CALCULATE ADJOINT THERMO
!
! The thermodynamic routine is broken into several regimes.
! The regime from the forward calculation is marked by the
! NRETURN flag. Use this flag to push the adjoint calculation
! into the same regime.
!============================================================
IF (NRETURN == 1) THEN
! the adjoint variables are unchanged in this case
ADJ_CTOT(:) = ADJ_TMP(:)
ELSEIF (NRETURN == 2) THEN
CALL adrpmares_2( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL,
& I, J, L )
ELSEIF (NRETURN == 3 .OR. NRETURN == 5) THEN
CALL adrpmares_3( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL,
& I, J, L )
ELSEIF (NRETURN == 4) THEN
CALL adrpmares_4( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL,
& I, J, L )
ELSEIF (NRETURN == 6) THEN
CALL adrpmares_6_D5( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL,
& I, J, L )
ELSEIF (NRETURN == 7) THEN
CALL adrpmares_7( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL,
& I, J, L )
ELSEIF (NRETURN == 8 .OR. NRETURN == 9
& .OR. NRETURN == 10) THEN
CALL adrpmares_8( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL,
& I, J, L )
ELSEIF (NRETURN == 11) THEN
CALL adrpmares_11( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL,
& I, J, L )
ELSEIF (NRETURN == 12) THEN
CALL adrpmares_12( CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL,
& I, J, L )
ELSE
print*, ' NRETURN = ', NRETURN , I, J, L
CALL ERROR_STOP
& ('ERROR: NRETURN ill defined ','ADJ_AEROSOL')
ENDIF
IF ( LPRINTFD .AND.
& J == JFD .AND. L == LFD .AND. I == IFD) THEN
print*, 'after ', CTOT_P, PAR_P, ADJ_CTOT, ADJ_STT_LOCAL
ENDIF
! Check for NAN.
DO N = 1, NCTOT
IF ( IT_IS_NAN( ADJ_CTOT(N) ) ) THEN
! Echo location of NAN (probably leave this commented out
! unless you are getting lots of ADJ_NAN warnings
!WRITE(6,*) 'FOUND A NAN AT I,J,L,N = ',I,J,L,N
!$OMP CRITICAL
! Set ADJ_NAN flag so that a warning is echod to screen
ADJ_NAN = .TRUE.
!$OMP END CRITICAL
! Replace the NAN with the original value and continue
ADJ_CTOT(N) = ADJ_TMP(N)
ENDIF
ENDDO
! Update ADJ_STT array
STT_ADJ(I,J,L,IDTHNO3) = ADJ_CTOT(2) * 1.d9 / AVOL
STT_ADJ(I,J,L,IDTNH3) = ADJ_CTOT(3) * 1.d9 / AVOL
STT_ADJ(I,J,L,IDTNIT) = ADJ_CTOT(4) * 1.d9 / AVOL
STT_ADJ(I,J,L,IDTNH4) = ADJ_CTOT(5) * 1.d9 / AVOL
! Becuase we don't initiate the sulfate adjoint with STT_ADJ,
! do not overwrite.
STT_ADJ(I,J,L,IDTSO4) = STT_ADJ(I,J,L,IDTSO4)
& + ADJ_CTOT(1) * 1.d9 / AVOL
ENDDO
ENDDO
ENDDO
!$OMP END PARALLEL DO
! Error checking
IF ( ADJ_NAN ) THEN
! Echo a warning to the screen
WRITE(6,*)
& ' *** - WARNING: ADJ_NAN in routine ADJ_AEROSOL'
! keep track of how many times NANs have occured
ADJ_NAN_COUNT = ADJ_NAN_COUNT + 1
IF ( ADJ_NAN_COUNT > MAX_ALLOWED_NAN )
& CALL ERROR_STOP('Too many NANs', 'ADJ_AEROSOL')
ENDIF
! More error checking: warn of exploding adjoit values, except
! the first jump up from zero (MAX_ADJ_TMP = 0 first few times)
IF ( MAXVAL(ABS(STT_ADJ)) > (MAX_ADJ_TMP * MAX_ALLOWED_INCREASE)
& .AND. ( MAX_ADJ_TMP > 0d0 ) ) THEN
WRITE(6,*)' *** - WARNING: EXPLODING adjoints in ADJ_AEROSOL'
WRITE(6,*)' *** - MAX(ADJ_STT) before = ',MAX_ADJ_TMP
WRITE(6,*)' *** - MAX(ADJ_STT) after = ',MAXVAL(ABS(STT_ADJ))
ADJ_EXPLD_COUNT = ADJ_EXPLD_COUNT + 1
IF (ADJ_EXPLD_COUNT > MAX_ALLOWED_EXPLD )
& CALL ERROR_STOP('Too many exploding adjoints',
& 'ADJ_AEROSOL, adjoint_mod.f')
ENDIF
! Return to calling program
END SUBROUTINE DO_RPMARES_ADJ
!------------------------------------------------------------------------------
C DISCLAIMER
C
C This file was generated by TAMC version 5.3.2
C
C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES
C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS,
C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS
C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS.
C
C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION
C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS
C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT
C ALLOWED.
C
C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT
C info@FastOpt.com
C
subroutine adactcof( cat, an, adcat, adan, adgama )
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
C==============================================
C define parameters
C==============================================
integer nan
parameter ( nan = 3 )
integer ncat
parameter ( ncat = 2 )
C==============================================
C define common blocks
C==============================================
common /actcofsv/ pname, xmsg, zm, zp
character*(16) :: pname = ' driver program name'
character*(120) :: xmsg = ' '
real*8 :: zm(nan) = (/2.d0,1.d0,1.d0/)
real*8 :: zp(ncat) = (/1.d0,1.d0/)
C==============================================
C define arguments
C==============================================
real*8 adan(nan)
real*8 adcat(ncat)
real*8 adgama(ncat,nan)
real*8 an(nan)
real*8 cat(ncat)
C==============================================
C define local variables
C==============================================
real*8 adbgama(ncat,nan)
real*8 adf1(nan)
real*8 adf2(ncat)
real*8 adfgama
real*8 adi
real*8 adlgama0(ncat,nan)
real*8 adm(ncat,nan)
real*8 adsri
real*8 adta
real*8 adtc
real*8 adtexpv
real*8 adtrm
real*8 adtwoi
real*8 adtwosri
real*8 adx(ncat,nan)
real*8 ady(nan,ncat)
real*8 adzot1
real*8 beta0(ncat,nan)
real*8 beta1(ncat,nan)
real*8 bgama(ncat,nan)
real*8 cgama(ncat,nan)
integer exit
real*8 f1(nan)
real*8 f2(ncat)
real*8 fgama
real*8 i
integer ian
integer icat
integer ip1
integer ip2
real*8 lgama0(ncat,nan)
real*8 m(ncat,nan)
real*8 sri
real*8 ta
real*8 tb
real*8 tc
real*8 texpv
real*8 trm
real*8 twoi
real*8 twosri
real*8 v1(ncat,nan)
real*8 v2(ncat,nan)
real*8 x(ncat,nan)
real*8 y(nan,ncat)
real*8 zbar
real*8 zbar2
real*8 zot1
C==============================================
C define data
C==============================================
data beta0(1,1)/2.98d-2/
data beta1(1,1)/0.0d0/
data cgama(1,1)/4.38d-2/
data beta0(1,2)/1.2556d-1/
data beta1(1,2)/2.8778d-1/
data cgama(1,2)/-5.59d-3/
data beta0(1,3)/2.0651d-1/
data beta1(1,3)/5.556d-1/
data cgama(1,3)/0.0d0/
data beta0(2,1)/4.6465d-2/
data beta1(2,1)/-0.54196d0/
data cgama(2,1)/-1.2683d-3/
data beta0(2,2)/-7.26224d-3/
data beta1(2,2)/-1.168858d0/
data cgama(2,2)/3.51217d-5/
data beta0(2,3)/4.494d-2/
data beta1(2,3)/2.3594d-1/
data cgama(2,3)/-2.962d-3/
data v1(1,1),v2(1,1)/2.0d0,1.0d0/
data v1(2,1),v2(2,1)/2.0d0,1.0d0/
data v1(1,2),v2(1,2)/1.0d0,1.0d0/
data v1(2,2),v2(2,2)/1.0d0,1.0d0/
data v1(1,3),v2(1,3)/1.0d0,1.0d0/
data v1(2,3),v2(2,3)/1.0d0,1.0d0/
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
do ip2 = 1, nan
do ip1 = 1, ncat
adbgama(ip1,ip2) = 0.
end do
end do
do ip1 = 1, nan
adf1(ip1) = 0.
end do
do ip1 = 1, ncat
adf2(ip1) = 0.
end do
adfgama = 0.
adi = 0.
do ip2 = 1, nan
do ip1 = 1, ncat
adlgama0(ip1,ip2) = 0.
end do
end do
do ip2 = 1, nan
do ip1 = 1, ncat
adm(ip1,ip2) = 0.
end do
end do
adsri = 0.
adta = 0.
adtc = 0.
adtexpv = 0.
adtrm = 0.
adtwoi = 0.
adtwosri = 0.
do ip2 = 1, nan
do ip1 = 1, ncat
adx(ip1,ip2) = 0.
end do
end do
do ip2 = 1, ncat
do ip1 = 1, nan
ady(ip1,ip2) = 0.
end do
end do
adzot1 = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
exit = 0
if (exit .eq. 0) then
i = 0.d0
endif
do icat = 1, ncat
if (exit .eq. 0) then
i = i+cat(icat)*zp(icat)*zp(icat)
endif
end do
do ian = 1, nan
if (exit .eq. 0) then
i = i+an(ian)*zm(ian)*zm(ian)
endif
end do
if (exit .eq. 0) then
i = 0.5d0*i
endif
if (i .eq. 0.d0) then
if (exit .eq. 0) then
exit = 1
endif
endif
if (exit .eq. 0) then
sri = sqrt(i)
twosri = 2.d0*sri
twoi = 2.d0*i
texpv = 1.d0-exp(-twosri)*(1.d0+twosri-twoi)
zot1 = 0.511d0*sri/(1.d0+sri)
fgama = -(0.392d0*(sri/(1.d0+1.2d0*sri)+2.d0/1.2d0*log(1.d0+
$1.2d0*sri)))
do icat = 1, ncat
do ian = 1, nan
bgama(icat,ian) = 2.d0*beta0(icat,ian)+2.d0*beta1(icat,ian)/
$(4.d0*i)*texpv
m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian)
$)**(1.d0/(v1(icat,ian)+v2(icat,ian)))
lgama0(icat,ian) = (zp(icat)*zm(ian)*fgama+m(icat,ian)*2.d0*
$v1(icat,ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat,
$ian)+m(icat,ian)*m(icat,ian)*2.d0*(v1(icat,ian)*v2(icat,ian))**
$1.5d0/(v1(icat,ian)+v2(icat,ian))*cgama(icat,ian))/2.302585093d0
end do
end do
do ian = 1, nan
do icat = 1, ncat
zbar = (zp(icat)+zm(ian))*0.5d0
zbar2 = zbar*zbar
y(ian,icat) = zbar2*an(ian)/i
x(icat,ian) = zbar2*cat(icat)/i
end do
end do
do ian = 1, nan
f1(ian) = 0.d0
do icat = 1, ncat
f1(ian) = f1(ian)+x(icat,ian)*lgama0(icat,ian)+zot1*zp(icat)
$*zm(ian)*x(icat,ian)
end do
end do
do icat = 1, ncat
f2(icat) = 0.d0
do ian = 1, nan
f2(icat) = f2(icat)+y(ian,icat)*lgama0(icat,ian)+zot1*
$zp(icat)*zm(ian)*y(ian,icat)
end do
end do
do ian = 1, nan
adta = 0.
adtc = 0.
adtrm = 0.
do icat = 1, ncat
adta = 0.
adtc = 0.
adtrm = 0.
ta = -(zot1*zp(icat)*zm(ian))
tb = zp(icat)*zm(ian)/(zp(icat)+zm(ian))
tc = f2(icat)/zp(icat)+f1(ian)/zm(ian)
trm = ta+tb*tc
if (trm .gt. 30.d0) then
adgama(icat,ian) = 0.
else
adtrm = adtrm+adgama(icat,ian)*10.d0**trm*dlog(10.d0)
adgama(icat,ian) = 0.
endif
adta = adta+adtrm
adtc = adtc+adtrm*tb
adtrm = 0.
adf1(ian) = adf1(ian)+adtc/zm(ian)
adf2(icat) = adf2(icat)+adtc/zp(icat)
adtc = 0.
adzot1 = adzot1-adta*zp(icat)*zm(ian)
adta = 0.
end do
end do
do icat = 1, ncat
do ian = 1, nan
adlgama0(icat,ian) = adlgama0(icat,ian)+adf2(icat)*y(ian,
$icat)
ady(ian,icat) = ady(ian,icat)+adf2(icat)*(lgama0(icat,ian)+
$zot1*zp(icat)*zm(ian))
adzot1 = adzot1+adf2(icat)*zp(icat)*zm(ian)*y(ian,icat)
end do
adf2(icat) = 0.
end do
do ian = 1, nan
do icat = 1, ncat
adlgama0(icat,ian) = adlgama0(icat,ian)+adf1(ian)*x(icat,
$ian)
adx(icat,ian) = adx(icat,ian)+adf1(ian)*(lgama0(icat,ian)+
$zot1*zp(icat)*zm(ian))
adzot1 = adzot1+adf1(ian)*zp(icat)*zm(ian)*x(icat,ian)
end do
adf1(ian) = 0.
end do
do ian = 1, nan
do icat = 1, ncat
zbar = (zp(icat)+zm(ian))*0.5d0
zbar2 = zbar*zbar
adcat(icat) = adcat(icat)+adx(icat,ian)*(zbar2/i)
adi = adi-adx(icat,ian)*(zbar2*cat(icat)/(i*i))
adx(icat,ian) = 0.
adan(ian) = adan(ian)+ady(ian,icat)*(zbar2/i)
adi = adi-ady(ian,icat)*(zbar2*an(ian)/(i*i))
ady(ian,icat) = 0.
end do
end do
do icat = 1, ncat
do ian = 1, nan
bgama(icat,ian) = 2.d0*beta0(icat,ian)+2.d0*beta1(icat,ian)/
$(4.d0*i)*texpv
m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian)
$)**(1.d0/(v1(icat,ian)+v2(icat,ian)))
adbgama(icat,ian) = adbgama(icat,ian)+adlgama0(icat,ian)*
$(m(icat,ian)*(2.d0*v1(icat,ian)*v2(icat,ian)/(v1(icat,ian)+
$v2(icat,ian)))/2.302585093d0)
adfgama = adfgama+adlgama0(icat,ian)*(zp(icat)*zm(ian)/
$2.302585093d0)
adm(icat,ian) = adm(icat,ian)+adlgama0(icat,ian)*((2.d0*
$v1(icat,ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat,
$ian)+2*m(icat,ian)*2.d0*(v1(icat,ian)*v2(icat,ian))**1.5d0/
$(v1(icat,ian)+v2(icat,ian))*cgama(icat,ian))/2.302585093d0)
adlgama0(icat,ian) = 0.
! The next two IF statements added to avoid divide by zero
! segmentation fault (dkh)
IF (adm(icat,ian)*cat(icat)**v1(icat,ian)*
$v2(icat,ian)*an(ian) .NE. 0.D0 .AND.
$ (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian)) .NE. 0.D0)
$ adan(ian) = adan(ian)+adm(icat,ian)*cat(icat)**v1(icat,ian)*
$v2(icat,ian)*an(ian)**(v2(icat,ian)-1)*1.d0/(v1(icat,ian)+v2(icat,
$ian))*(cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))**(1.d0/
$(v1(icat,ian)+v2(icat,ian))-1)
IF (adm(icat,ian)*v1(icat,ian)*
$cat(icat) .NE. 0.D0 .AND. (cat(icat)**v1(icat,ian)*an(ian)**
$v2(icat,ian)) .NE. 0.D0)
$ adcat(icat) = adcat(icat)+adm(icat,ian)*v1(icat,ian)*
$cat(icat)**(v1(icat,ian)-1)*an(ian)**v2(icat,ian)*1.d0/(v1(icat,
$ian)+v2(icat,ian))*(cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))
$**(1.d0/(v1(icat,ian)+v2(icat,ian))-1)
adm(icat,ian) = 0.
adi = adi-adbgama(icat,ian)*8*beta1(icat,ian)/(16*i*i)*texpv
adtexpv = adtexpv+adbgama(icat,ian)*(2.d0*beta1(icat,ian)/
$(4.d0*i))
adbgama(icat,ian) = 0.
end do
end do
adsri = adsri-0.392d0*adfgama*(1/(1.d0+1.2d0*sri)-1.2d0*sri/
$((1.d0+1.2d0*sri)*(1.d0+1.2d0*sri))+2*(1./(1.d0+1.2d0*sri)))
adfgama = 0.
adsri = adsri+adzot1*(0.511d0/(1.d0+sri)-0.511d0*sri/((1.d0+sri)
$*(1.d0+sri)))
adzot1 = 0.
adtwoi = adtwoi+adtexpv*exp(-twosri)
adtwosri = adtwosri-adtexpv*(exp(-twosri)-(1.d0+twosri-twoi)*
$exp(-twosri))
adtexpv = 0.
adi = adi+2*adtwoi
adtwoi = 0.
adsri = adsri+2*adtwosri
adtwosri = 0.
adi = adi+adsri*(1./(2.*sqrt(i)))
adsri = 0.
endif
exit = 0
if (i .eq. 0.d0) then
if (exit .eq. 0) then
do ian = 1, nan
do icat = 1, ncat
adgama(icat,ian) = 0.
end do
end do
endif
endif
if (exit .eq. 0) then
adi = 0.5d0*adi
endif
do ian = 1, nan
if (exit .eq. 0) then
adan(ian) = adan(ian)+adi*zm(ian)*zm(ian)
endif
end do
do icat = 1, ncat
if (exit .eq. 0) then
adcat(icat) = adcat(icat)+adi*zp(icat)*zp(icat)
endif
end do
end SUBROUTINE ADACTCOF
!-----------------------------------------------------------------------------
subroutine adawater( irhx, mso4, mnh4, mno3, admso4, admnh4,
$admno3, adwh2o )
! Reference other f90 modules
USE RPMARES_MOD, ONLY : POLY4, POLY6
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
C==============================================
C define parameters
C==============================================
real*8 mwnh4
parameter ( mwnh4 = 18.0985d0 )
real*8 mwso4
parameter ( mwso4 = 96.0636d0 )
real*8 mw2
parameter ( mw2 = mwso4+2.d0*mwnh4 )
real*8 mwno3
parameter ( mwno3 = 62.0649d0 )
real*8 mwano3
parameter ( mwano3 = mwno3+mwnh4 )
C==============================================
C define common blocks
C==============================================
common /awatersv/ c0, c1, c15, c2, kno3, kso4
real*8 :: c0(4) = (/0.798079d0,-1.574367d0,2.536686d0,-
$1.735297d0/)
real*8 :: c1(4) = (/0.9995178d0,-0.7952896d0,0.99683673d0,-
$1.143874d0/)
real*8 :: c15(4) = (/1.697092d0,-4.045936d0,5.833688d0,-
$3.463783d0/)
real*8 :: c2(4) = (/2.085067d0,-6.024139d0,8.967967d0,-
$5.002934d0/)
real*8 :: kno3(6) = (/0.2906d0,6.83665d0,-26.9093d0,46.6983d0,-
$38.803d0,11.8837d0/)
real*8 :: kso4(6) = (/2.27515d0,-11.147d0,36.3369d0,-64.2134d0,
$56.8341d0,-20.0953d0/)
C==============================================
C define arguments
C==============================================
real*8 admnh4
real*8 admno3
real*8 admso4
real*8 adwh2o
integer irhx
real*8 mnh4
real*8 mno3
real*8 mso4
C==============================================
C define local variables
C==============================================
real*8 adawc
real*8 adtnh4
real*8 adtno3
real*8 adtso4
real*8 adx
real*8 ady
real*8 ady40
real*8 adyc
real*8 aw
real*8 awc
integer irh
real*8 mfs0
real*8 mfs1
real*8 mfs15
real*8 mfsno3
real*8 mfsso4
real*8 tnh4
real*8 tno3
real*8 tso4
real*8 x
real*8 y
real*8 y0
real*8 y1
real*8 y140
real*8 y15
real*8 y1540
real*8 y2
real*8 y3
real*8 y40
real*8 yc
!C==============================================
!C define external procedures and functions
!C==============================================
! double precision poly4
! external poly4
! double precision poly6
! external poly6
!
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
adawc = 0.
adtnh4 = 0.
adtno3 = 0.
adtso4 = 0.
adx = 0.
ady = 0.
ady40 = 0.
adyc = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
irh = irhx
irh = max(1,irh)
irh = min(irh,100)
aw = dble(irh)/100.d0
tso4 = max(mso4,0.d0)
tnh4 = max(mnh4,0.d0)
tno3 = max(mno3,0.d0)
x = 0.d0
if (tso4 .gt. 0.d0) then
x = tnh4/tso4
else
if (tno3 .gt. 0.d0 .and. tnh4 .gt. 0.d0) then
x = 10.d0
endif
endif
if (x .lt. 1.d0) then
mfs0 = poly4(c0,aw)
mfs1 = poly4(c1,aw)
y0 = (1.d0-mfs0)/mfs0
y1 = (1.d0-mfs1)/mfs1
y = (1.d0-x)*y0+x*y1
else if (x .lt. 1.5d0) then
if (irh .ge. 40) then
mfs1 = poly4(c1,aw)
mfs15 = poly4(c15,aw)
y1 = (1.d0-mfs1)/mfs1
y15 = (1.d0-mfs15)/mfs15
y = 2.d0*(y1*(1.5d0-x)+y15*(x-1.d0))
else
awc = 0.8d0*(x-1.d0)
y = 0.d0
if (aw .ge. awc) then
mfs1 = poly4(c1,0.4d0)
mfs15 = poly4(c15,0.4d0)
y140 = (1.d0-mfs1)/mfs1
y1540 = (1.d0-mfs15)/mfs15
y40 = 2.d0*(y140*(1.5d0-x)+y1540*(x-1.d0))
yc = 2.d0*y1540*(x-1.d0)
y = y40-(y40-yc)*(0.4d0-aw)/(0.4d0-awc)
endif
endif
else if (x .lt. 2.d0) then
y = 0.d0
if (irh .ge. 40) then
mfs15 = poly4(c15,aw)
y15 = (1.d0-mfs15)/mfs15
mfsso4 = poly6(kso4,aw)
y2 = (1.d0-mfsso4)/mfsso4
y = 2.d0*(y15*(2.d0-x)+y2*(x-1.5d0))
endif
else
y2 = 0.d0
y3 = 0.d0
if (irh .ge. 40) then
mfsso4 = poly6(kso4,aw)
mfsno3 = poly6(kno3,aw)
y2 = (1.d0-mfsso4)/mfsso4
y3 = (1.d0-mfsno3)/mfsno3
endif
endif
if (x .lt. 2.d0) then
adtnh4 = adtnh4+adwh2o*y*mwnh4
adtso4 = adtso4+adwh2o*y*mwso4
ady = ady+adwh2o*(tso4*mwso4+mwnh4*tnh4)
adwh2o = 0.
else
adtno3 = adtno3+adwh2o*y3*mwano3
adtso4 = adtso4+adwh2o*y2*mw2
adwh2o = 0.
endif
if (x .lt. 1.d0) then
adx = adx+ady*((-y0)+y1)
ady = 0.
else if (x .lt. 1.5d0) then
if (irh .ge. 40) then
adx = adx+2.d0*ady*((-y1)+y15)
ady = 0.
else
if (aw .ge. awc) then
adawc = adawc-ady*((y40-yc)*(0.4d0-aw)/((0.4d0-awc)*(0.4d0-
$awc)))
ady40 = ady40+ady*(1-(0.4d0-aw)/(0.4d0-awc))
adyc = adyc+ady*((0.4d0-aw)/(0.4d0-awc))
ady = 0.
adx = adx+2*adyc*y1540
adyc = 0.
adx = adx+2.d0*ady40*((-y140)+y1540)
ady40 = 0.
endif
adx = adx+0.8d0*adawc
adawc = 0.
endif
else if (x .lt. 2.d0) then
if (irh .ge. 40) then
adx = adx+2.d0*ady*((-y15)+y2)
ady = 0.
endif
endif
if (tso4 .gt. 0.d0) then
adtnh4 = adtnh4+adx/tso4
adtso4 = adtso4-adx*(tnh4/(tso4*tso4))
adx = 0.
endif
admno3 = admno3+adtno3*(0.5+sign(0.5d0,mno3-0.d0))
adtno3 = 0.
admnh4 = admnh4+adtnh4*(0.5+sign(0.5d0,mnh4-0.d0))
adtnh4 = 0.
admso4 = admso4+adtso4*(0.5+sign(0.5d0,mso4-0.d0))
adtso4 = 0.
end SUBROUTINE ADAWATER
!-----------------------------------------------------------------------------
subroutine adrpmares_11( in, par, adin, adout,
& I, J, L )
! References to f90 modules
USE CHECKPT_MOD
USE RPMARES_MOD, ONLY : CUBIC, AWATER, ACTCOF
# include "CMN_SIZE" ! Size params
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
C==============================================
C define parameters
C==============================================
real*8 floor
parameter ( floor = 1.d-30 )
real*8 mwhno3
parameter ( mwhno3 = 63.01287d0 )
real*8 mwnh3
parameter ( mwnh3 = 17.03061d0 )
real*8 mwnh4
parameter ( mwnh4 = 18.03858d0 )
real*8 mwno3
parameter ( mwno3 = 62.0049d0 )
real*8 mwso4
parameter ( mwso4 = 96.0576d0 )
C==============================================
C define common blocks
C==============================================
C==============================================
C define arguments
C==============================================
double precision adin(5)
double precision adout(8)
double precision in(5)
double precision par(2)
INTEGER :: I, J, L
C==============================================
C define local variables
C==============================================
real*8 a0
real*8 a1
real*8 a2
real*8 ada0
real*8 ada1
real*8 ada2
real*8 adah2o
real*8 adahso4
real*8 adan(3)
real*8 adanh4
real*8 adano3
real*8 adano3_in
real*8 adaso4
real*8 adcat(2)
real*8 adcrutes(3)
real*8 aderor
real aderorh
real*8 adgamahat
real*8 adgamana
real*8 adgamas1
real*8 adgamas2
real*8 adgamold
real*8 adgams(2,3)
real*8 adgnh3
real*8 adgno3
real*8 adhplus
real*8 admhso4
real*8 admna
real*8 admnh4
real*8 admso4
real*8 adrk2sa
real*8 adrkna
real*8 adrknwet
real*8 adso4
real*8 adt21
real*8 adtmasshno3
real*8 adtnh4
real*8 adtno3
real*8 adtso4
real*8 adwh2o
real*8 adxno3
real*8 adynh4
real*8 adzso4
real*8 ah2o
real*8 an(3)
real*8 anh4
real*8 ano3
real*8 cat(2)
real*8 crutes(3)
real*8 eror
real*8 erorh
integer exit
real*8 gamaab
real*8 gamahat
real*8 gamana
real*8 gamas1
real*8 gamas2
real*8 gamas2h
real*8 gamold
real*8 gams(2,3)
real*8 gnh3
real*8 gno3
real*8 hplus
integer ip1
integer ip2
integer irh
real*8 k2sa
real*8 kna
real*8 mhso4
real*8 mna
real*8 mnh4
real*8 molnu
real*8 mso4
integer nnn
integer nnn1
integer nr
real*8 phibar
real*8 rh
real*8 rk2sa
real*8 rkna
real*8 rknwet
real*8 so4
real*8 t1
real*8 t2
real*8 t21
real*8 t3
real*8 t4
real*8 t6
real*8 temp
real*8 tmasshno3
real*8 tnh4
real*8 tno3
real*8 toler2
real*8 tso4
real*8 wh2o
real*8 xno3
real*8 ynh4
real*8 zso4
C----------------------------------------------
C SAVE ARGUMENTS
C----------------------------------------------
!erorh = eror
erorh = 0.
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
ada0 = 0.
ada1 = 0.
ada2 = 0.
adah2o = 0.
adahso4 = 0.
do ip1 = 1, 3
adan(ip1) = 0.
end do
adanh4 = 0.
adano3 = 0.
adano3_in = 0.
adaso4 = 0.
do ip1 = 1, 2
adcat(ip1) = 0.
end do
do ip1 = 1, 3
adcrutes(ip1) = 0.
end do
aderor = 0.
adgamahat = 0.
adgamana = 0.
adgamas1 = 0.
adgamas2 = 0.
adgamold = 0.
do ip2 = 1, 3
do ip1 = 1, 2
adgams(ip1,ip2) = 0.
end do
end do
adgnh3 = 0.
adgno3 = 0.
adhplus = 0.
admhso4 = 0.
admna = 0.
admnh4 = 0.
admso4 = 0.
adrk2sa = 0.
adrkna = 0.
adrknwet = 0.
adso4 = 0.
adt21 = 0.
adtmasshno3 = 0.
adtnh4 = 0.
adtno3 = 0.
adtso4 = 0.
adwh2o = 0.
adxno3 = 0.
adynh4 = 0.
adzso4 = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
so4 = in(1)
gno3 = in(2)
gnh3 = in(3)
ano3 = in(4)
anh4 = in(5)
rh = par(1)
temp = par(2)
tso4 = max(floor,so4/mwso4)
tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3)
tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4)
tmasshno3 = max(0.d0,gno3+ano3)
irh = nint(100.*rh)
irh = max(1,irh)
irh = min(99,irh)
t6 = 8.2d-11*temp
t1 = 298.d0/temp
t2 = log(t1)
t3 = t1-1.d0
t4 = 1.d0+t2-t1
kna = 2511000.d0*exp(29.17d0*t3+16.83d0*t4)*t6
k2sa = 0.01015d0*exp(8.85d0*t3+25.14d0*t4)
call awater( irh,tso4,tnh4,tno3,ah2o )
wh2o = 0.001d0*ah2o
zso4 = tso4/wh2o
gamaab = 1.d0
mnh4 = tnh4/wh2o
ynh4 = tnh4
adgnh3 = adgnh3+adout(8)
adout(8) = 0.d0
adgno3 = adgno3+adout(7)
adout(7) = 0.d0
adso4 = adso4+adout(6)
adout(6) = 0.d0
adanh4 = adanh4+adout(5)
adout(5) = 0.d0
adah2o = adah2o+adout(4)
adout(4) = 0.d0
adano3 = adano3+adout(3)
adout(3) = 0.d0
adahso4 = adahso4+adout(2)
adout(2) = 0.d0
adaso4 = adaso4+adout(1)
adout(1) = 0.d0
do nnn = nitr_max(I,J,L), 1, -1
eror = erorh
exit = 0
call awater( irh,tso4,tnh4,tno3,ah2o )
wh2o = 0.001d0*ah2o
gamana = 1.d0
gamas1 = 1.d0
gamas2 = 1.d0
gamold = 1.d0
!=====================================================================
! CHECKPOINT
! The adjoint calculation needs the variables error,exit,gamana,gamas1,
! gamas2,gamold and wh2o at iteration nnn-1. Rather than recompute,
! use the values saved durring the forward run, but only if nnn-1 > 0
!=====================================================================
IF (nnn-1 .gt. 0) THEN
eror = eror_fwd(I,J,L,nnn-1)
exit = exit_fwd(I,J,L,nnn-1)
gamana = gamana_fwd(I,J,L,nnn-1)
gamas1 = gamas1_fwd(I,J,L,nnn-1)
gamas2 = gamas2_fwd(I,J,L,nnn-1)
gamold = gamold_fwd(I,J,L,nnn-1)
wh2o = wh2o_fwd(I,J,L,nnn-1)
ENDIF
! do nnn1 = 1, nnn-1
! if (exit .eq. 0) then
! rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1)
! rkna = kna/(gamana*gamana)
! rknwet = rkna*wh2o
! t21 = zso4-mnh4
! a2 = rk2sa+rknwet-t21
! a1 = rk2sa*rknwet-t21*(rk2sa+rknwet)-rk2sa*zso4-rkna*tno3
! a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3)
! call cubic( a2,a1,a0,nr,crutes )
! hplus = crutes(1)
! mso4 = rk2sa*zso4/(hplus+rk2sa)
! mhso4 = max(1.d-10,zso4-mso4)
! mna = rkna*tno3/(hplus+rknwet)
! mna = max(0.,mna)
! mna = min(mna,tno3/wh2o)
! xno3 = mna*wh2o
! call awater( irh,tso4,ynh4,xno3,ah2o )
! wh2o = 0.001d0*ah2o
! cat(1) = hplus
! cat(2) = mnh4
! an(1) = mso4
! an(2) = mna
! an(3) = mhso4
! call actcof( cat,an,gams,molnu,phibar )
! gamana = gams(1,2)
! gamas1 = gams(1,1)
! gamas2 = gams(1,3)
! gamahat = gamas2*gamas2/(gamaab*gamaab)
! eror = abs(gamold-gamahat)/gamold
! gamold = gamahat
! endif
! if (eror .le. toler2) then
! exit = 11
! endif
! end do
gamas2h = gamas2
if (exit .eq. 0) then
rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1)
rkna = kna/(gamana*gamana)
rknwet = rkna*wh2o
t21 = zso4-mnh4
a2 = rk2sa+rknwet-t21
a1 = rk2sa*rknwet-t21*(rk2sa+rknwet)-rk2sa*zso4-rkna*tno3
a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3)
call cubic( a2,a1,a0,nr,crutes )
hplus = crutes(1)
mso4 = rk2sa*zso4/(hplus+rk2sa)
mhso4 = max(1.d-10,zso4-mso4)
mna = rkna*tno3/(hplus+rknwet)
mna = max(0.,mna)
mna = min(mna,tno3/wh2o)
xno3 = mna*wh2o
ano3 = mna*wh2o*mwno3
cat(1) = hplus
cat(2) = mnh4
an(1) = mso4
an(2) = mna
an(3) = mhso4
call actcof( cat,an,gams,molnu,phibar )
gamas2 = gams(1,3)
gamahat = gamas2*gamas2/(gamaab*gamaab)
adgamahat = adgamahat+adgamold
adgamold = 0.
aderorh = aderor/gamold
adgamold = adgamold-aderor*(abs(gamold-gamahat)/(gamold*
$gamold))
adgamahat = adgamahat-aderorh*sign(1.d0,gamold-gamahat)
adgamold = adgamold+aderorh*sign(1.d0,gamold-gamahat)
aderor = 0.
adgamas2 = adgamas2+adgamahat*(2*gamas2/(gamaab*gamaab))
adgamahat = 0.
adgams(1,3) = adgams(1,3)+adgamas2
adgamas2 = 0.
adgams(1,1) = adgams(1,1)+adgamas1
adgamas1 = 0.
adgams(1,2) = adgams(1,2)+adgamana
adgamana = 0.
call adactcof( cat,an,adcat,adan,adgams )
admhso4 = admhso4+adan(3)
adan(3) = 0.
admna = admna+adan(2)
adan(2) = 0.
admso4 = admso4+adan(1)
adan(1) = 0.
admnh4 = admnh4+adcat(2)
adcat(2) = 0.
adhplus = adhplus+adcat(1)
adcat(1) = 0.
adah2o = adah2o+0.001d0*adwh2o
adwh2o = 0.
call adawater( irh,tso4,ynh4,xno3,adtso4,adynh4,adxno3,adah2o
$)
admhso4 = admhso4+adahso4*wh2o*mwso4
adwh2o = adwh2o+adahso4*mhso4*mwso4
adahso4 = 0.
admso4 = admso4+adaso4*wh2o*mwso4
adwh2o = adwh2o+adaso4*mso4*mwso4
adaso4 = 0.
adano3 =adano3-adgno3*(0.5-sign(0.5d0,floor-(tmasshno3-ano3)))
adtmasshno3 = adtmasshno3+adgno3*(0.5-sign(0.5d0,floor-
$(tmasshno3-ano3)))
adgno3 = 0.
admna = admna+adano3*wh2o*mwno3
adwh2o = adwh2o+adano3*mna*mwno3
adano3 = 0.
admna = admna+adxno3*wh2o
adwh2o = adwh2o+adxno3*mna
adxno3 = 0.
mna = rkna*tno3/(hplus+rknwet)
mna = max(0.,mna)
adtno3 = adtno3+admna*((0.5-sign(0.5d0,tno3/wh2o-mna))/wh2o)
adwh2o = adwh2o-admna*(0.5-sign(0.5d0,tno3/wh2o-mna))*(tno3/
$(wh2o*wh2o))
admna = admna*(0.5+sign(0.5d0,tno3/wh2o-mna))
mna = rkna*tno3/(hplus+rknwet)
admna = admna*(0.5-sign(0.5d0,0.-mna))
adhplus = adhplus-admna*(rkna*tno3/((hplus+rknwet)*(hplus+
$rknwet)))
adrkna = adrkna+admna*(tno3/(hplus+rknwet))
adrknwet = adrknwet-admna*(rkna*tno3/((hplus+rknwet)*(hplus+
$rknwet)))
adtno3 = adtno3+admna*(rkna/(hplus+rknwet))
admna = 0.
admso4 = admso4-admhso4*(0.5-sign(0.5d0,1.d-10-(zso4-mso4)))
adzso4 = adzso4+admhso4*(0.5-sign(0.5d0,1.d-10-(zso4-mso4)))
admhso4 = 0.
adhplus = adhplus-admso4*(rk2sa*zso4/((hplus+rk2sa)*(hplus+
$rk2sa)))
adrk2sa = adrk2sa+admso4*(zso4/(hplus+rk2sa)-rk2sa*zso4/
$((hplus+rk2sa)*(hplus+rk2sa)))
adzso4 = adzso4+admso4*(rk2sa/(hplus+rk2sa))
admso4 = 0.
adcrutes(1) = adcrutes(1)+adhplus
adhplus = 0.
call adcubic( a2,a1,a0,ada2,ada1,ada0,adcrutes )
adrk2sa = adrk2sa-ada0*(rknwet*(t21+zso4)+rkna*tno3)
adrkna = adrkna-ada0*rk2sa*tno3
adrknwet = adrknwet-ada0*rk2sa*(t21+zso4)
adt21 = adt21-ada0*rk2sa*rknwet
adtno3 = adtno3-ada0*rk2sa*rkna
adzso4 = adzso4-ada0*rk2sa*rknwet
ada0 = 0.
adrk2sa = adrk2sa+ada1*(rknwet-t21-zso4)
adrkna = adrkna-ada1*tno3
adrknwet = adrknwet+ada1*(rk2sa-t21)
adt21 = adt21-ada1*(rk2sa+rknwet)
adtno3 = adtno3-ada1*rkna
adzso4 = adzso4-ada1*rk2sa
ada1 = 0.
adrk2sa = adrk2sa+ada2
adrknwet = adrknwet+ada2
adt21 = adt21-ada2
ada2 = 0.
admnh4 = admnh4-adt21
adzso4 = adzso4+adt21
adt21 = 0.
adrkna = adrkna+adrknwet*wh2o
adwh2o = adwh2o+adrknwet*rkna
adrknwet = 0.
adgamana = adgamana-adrkna*(2*kna*gamana/(gamana*gamana*
$gamana*gamana))
adrkna = 0.
gamas2 = gamas2h
adgamas1 = adgamas1-adrk2sa*(3*k2sa*gamas2*gamas2*gamas1*
$gamas1/(gamas1*gamas1*gamas1*gamas1*gamas1*gamas1))
adgamas2 = adgamas2+adrk2sa*(2*k2sa*gamas2/(gamas1*gamas1*
$gamas1))
adrk2sa = 0.
endif
end do
adtnh4 = adtnh4+adynh4
adynh4 = 0.
call awater( irh,tso4,tnh4,tno3,ah2o )
wh2o = 0.001d0*ah2o
adtnh4 = adtnh4+admnh4/wh2o
adwh2o = adwh2o-admnh4*(tnh4/(wh2o*wh2o))
admnh4 = 0.
adtso4 = adtso4+adzso4/wh2o
adwh2o = adwh2o-adzso4*(tso4/(wh2o*wh2o))
adzso4 = 0.
adgnh3 = 0.
adano3 = adano3-adgno3
adtmasshno3 = adtmasshno3+adgno3
adgno3 = 0.
adano3_in = adano3_in+adano3
adano3 = 0.
adtnh4 = adtnh4+adanh4*mwnh4
adanh4 = 0.
adtso4 = adtso4+adahso4*mwso4
adahso4 = 0.
adaso4 = 0.
adah2o = adah2o+0.001d0*adwh2o
adwh2o = 0.
call adawater( irh,tso4,tnh4,tno3,adtso4,adtnh4,adtno3,adah2o )
ano3 = in(4)
adano3 = adano3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3)))
adgno3 = adgno3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3)))
adtmasshno3 = 0.
adano3 = adano3+adano3_in
adano3_in = 0.
adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh4)
adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh3)
adtnh4 = 0.
adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwno3)
adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwhno3)
adtno3 = 0.
adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4)
adtso4 = 0.
adin(5) = adin(5)+adanh4
adanh4 = 0.
adin(4) = adin(4)+adano3
adano3 = 0.
adin(3) = adin(3)+adgnh3
adgnh3 = 0.
adin(2) = adin(2)+adgno3
adgno3 = 0.
adin(1) = adin(1)+adso4
adso4 = 0.
end SUBROUTINE ADRPMARES_11
!-----------------------------------------------------------------------------
C DISCLAIMER
C
C This file was generated by TAMC version 5.3.2
C
C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES
C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS,
C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS
C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS.
C
C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION
C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS
C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT
C ALLOWED.
C
C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT
C info@FastOpt.com
C
subroutine adrpmares_12( in, par, adin, adout,
& I, J, L )
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
C==============================================
C define parameters
C==============================================
real*8 floor
parameter ( floor = 1.d-30 )
real*8 mwhno3
parameter ( mwhno3 = 63.01287d0 )
real*8 mwnh3
parameter ( mwnh3 = 17.03061d0 )
real*8 mwnh4
parameter ( mwnh4 = 18.03858d0 )
real*8 mwno3
parameter ( mwno3 = 62.0049d0 )
real*8 mwso4
parameter ( mwso4 = 96.0576d0 )
C==============================================
C define common blocks
C==============================================
C==============================================
C define arguments
C==============================================
double precision adin(5)
double precision adout(8)
double precision in(5)
double precision par(2)
INTEGER :: I, J, L
C==============================================
C define local variables
C==============================================
real*8 adah2o
real*8 adanh4
real*8 adano3
real*8 adano3_in
real*8 adaso4
real*8 adgnh3
real*8 adgno3
real*8 adgno3_in
real*8 adso4
real*8 adtnh4
real*8 adtno3
real*8 adtso4
real*8 anh4
real*8 ano3
real*8 gnh3
real*8 gno3
integer irh
real*8 rh
real*8 so4
real*8 tnh4
real*8 tno3
real*8 tso4
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
adah2o = 0.
adanh4 = 0.
adano3 = 0.
adano3_in = 0.
adaso4 = 0.
adgnh3 = 0.
adgno3 = 0.
adgno3_in = 0.
adso4 = 0.
adtnh4 = 0.
adtno3 = 0.
adtso4 = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
so4 = in(1)
gno3 = in(2)
gnh3 = in(3)
ano3 = in(4)
anh4 = in(5)
rh = par(1)
tso4 = max(floor,so4/mwso4)
tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3)
tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4)
irh = nint(100.*rh)
irh = max(1,irh)
irh = min(99,irh)
adgnh3 = adgnh3+adout(8)
adout(8) = 0.d0
adgno3 = adgno3+adout(7)
adout(7) = 0.d0
adso4 = adso4+adout(6)
adout(6) = 0.d0
adanh4 = adanh4+adout(5)
adout(5) = 0.d0
adah2o = adah2o+adout(4)
adout(4) = 0.d0
adano3 = adano3+adout(3)
adout(3) = 0.d0
adout(2) = 0.d0
adaso4 = adaso4+adout(1)
adout(1) = 0.d0
call adawater( irh,tso4,tnh4,tno3,adtso4,adtnh4,adtno3,adah2o )
adtso4 = adtso4+adaso4*mwso4
adaso4 = 0.
adano3_in = adano3_in+adano3
adano3 = 0.
adgno3_in = adgno3_in+adgno3
adgno3 = 0.
adgnh3 = 0.
adtnh4 = adtnh4+adanh4*mwnh4
adanh4 = 0.
adano3 = adano3+adano3_in
adano3_in = 0.
adgno3 = adgno3+adgno3_in
adgno3_in = 0.
adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh4)
adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh3)
adtnh4 = 0.
adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwno3)
adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwhno3)
adtno3 = 0.
adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4)
adtso4 = 0.
adin(5) = adin(5)+adanh4
adanh4 = 0.
adin(4) = adin(4)+adano3
adano3 = 0.
adin(3) = adin(3)+adgnh3
adgnh3 = 0.
adin(2) = adin(2)+adgno3
adgno3 = 0.
adin(1) = adin(1)+adso4
adso4 = 0.
end SUBROUTINE ADRPMARES_12
C DISCLAIMER
C
C This file was generated by TAMC version 5.3.2
C
C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES
C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS,
C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS
C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS.
C
C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION
C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS
C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT
C ALLOWED.
C
C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT
C info@FastOpt.com
C
subroutine adrpmares_2( in, par, adin, adout,
& I, J, L )
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
C==============================================
C define parameters
C==============================================
real*8 floor
parameter ( floor = 1.d-30 )
real*8 mwno3
parameter ( mwno3 = 62.0049d0 )
real*8 minno3
parameter ( minno3 = 1.d-6/mwno3 )
real*8 mwso4
parameter ( mwso4 = 96.0576d0 )
real*8 minso4
parameter ( minso4 = 1.d-6/mwso4 )
real*8 mwhno3
parameter ( mwhno3 = 63.01287d0 )
C==============================================
C define arguments
C==============================================
double precision adin(5)
double precision adout(8)
double precision in(5)
double precision par(2)
INTEGER :: I, J, L
C==============================================
C define local variables
C==============================================
real*8 adanh4
real*8 adano3
real*8 adaso4
real*8 adgnh3
real*8 adgno3
real*8 adso4
real*8 adtno3
real*8 adtso4
real*8 anh4
real*8 ano3
real*8 aso4
integer exit
real*8 gnh3
real*8 gno3
real*8 rh
real*8 so4
real*8 tno3
real*8 tso4
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
adanh4 = 0.
adano3 = 0.
adaso4 = 0.
adgnh3 = 0.
adgno3 = 0.
adso4 = 0.
adtno3 = 0.
adtso4 = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
so4 = in(1)
gno3 = in(2)
gnh3 = in(3)
ano3 = in(4)
anh4 = in(5)
rh = par(1)
aso4 = 0.d0
exit = 0
if (rh .lt. 0.01) then
exit = 1
endif
if (exit .eq. 0) then
tso4 = max(floor,so4/mwso4)
aso4 = so4
tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3)
endif
adgnh3 = adgnh3+adout(8)
adout(8) = 0.d0
adgno3 = adgno3+adout(7)
adout(7) = 0.d0
adso4 = adso4+adout(6)
adout(6) = 0.d0
adanh4 = adanh4+adout(5)
adout(5) = 0.d0
adout(4) = 0.d0
adano3 = adano3+adout(3)
adout(3) = 0.d0
adout(2) = 0.d0
adaso4 = adaso4+adout(1)
adout(1) = 0.d0
if (tso4 .lt. minso4 .and. tno3 .lt. minno3) then
if (exit .eq. 0) then
adgno3 = adgno3*(0.5-sign(0.5d0,floor-gno3))
adgnh3 = adgnh3*(0.5-sign(0.5d0,floor-gnh3))
adanh4 = adanh4*(0.5-sign(0.5d0,floor-anh4))
adano3 = adano3*(0.5-sign(0.5d0,floor-ano3))
adaso4 = adaso4*(0.5-sign(0.5d0,floor-aso4))
endif
endif
if (exit .eq. 0) then
adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwno3)
adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwhno3)
adtno3 = 0.
adso4 = adso4+adaso4
adaso4 = 0.
adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4)
adtso4 = 0.
endif
adin(5) = adin(5)+adanh4
adanh4 = 0.
adin(4) = adin(4)+adano3
adano3 = 0.
adin(3) = adin(3)+adgnh3
adgnh3 = 0.
adin(2) = adin(2)+adgno3
adgno3 = 0.
adin(1) = adin(1)+adso4
adso4 = 0.
end SUBROUTINE ADRPMARES_2
!-----------------------------------------------------------------------------
C DISCLAIMER
C
C This file was generated by TAMC version 5.3.2
C
C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES
C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS,
C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS
C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS.
C
C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION
C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS
C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT
C ALLOWED.
C
C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT
C info@FastOpt.com
C
subroutine adrpmares_3( in, par, adin, adout,
& I, J, L )
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
C==============================================
C define parameters
C==============================================
real*8 floor
parameter ( floor = 1.d-30 )
real*8 mwhno3
parameter ( mwhno3 = 63.01287d0 )
real*8 mwnh3
parameter ( mwnh3 = 17.03061d0 )
real*8 mwnh4
parameter ( mwnh4 = 18.03858d0 )
real*8 mwno3
parameter ( mwno3 = 62.0049d0 )
real*8 mwso4
parameter ( mwso4 = 96.0576d0 )
C==============================================
C define common blocks
C==============================================
C==============================================
C define arguments
C==============================================
double precision adin(5)
double precision adout(8)
double precision in(5)
double precision par(2)
INTEGER :: I, J, L
C==============================================
C define local variables
C==============================================
real*8 adah2o
real*8 adanh4
real*8 adano3
real*8 adano3_in
real*8 adaso4
real*8 adgnh3
real*8 adgno3
real*8 adgno3_in
real*8 adso4
real*8 adtnh4
real*8 adtno3
real*8 adtso4
real*8 adtwoso4
real*8 adwh2o
real*8 adynh4
real*8 anh4
real*8 ano3
real*8 gnh3
real*8 gno3
integer irh
real*8 rh
real*8 so4
real*8 tnh4
real*8 tno3
real*8 tso4
real*8 twoso4
real*8 ynh4
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
adah2o = 0.
adanh4 = 0.
adano3 = 0.
adano3_in = 0.
adaso4 = 0.
adgnh3 = 0.
adgno3 = 0.
adgno3_in = 0.
adso4 = 0.
adtnh4 = 0.
adtno3 = 0.
adtso4 = 0.
adtwoso4 = 0.
adwh2o = 0.
adynh4 = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
so4 = in(1)
gno3 = in(2)
gnh3 = in(3)
ano3 = in(4)
anh4 = in(5)
rh = par(1)
tso4 = max(floor,so4/mwso4)
tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3)
tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4)
irh = nint(100.*rh)
irh = max(1,irh)
irh = min(99,irh)
twoso4 = 2.*tso4
ynh4 = twoso4
adgnh3 = adgnh3+adout(8)
adout(8) = 0.d0
adgno3 = adgno3+adout(7)
adout(7) = 0.d0
adso4 = adso4+adout(6)
adout(6) = 0.d0
adanh4 = adanh4+adout(5)
adout(5) = 0.d0
adah2o = adah2o+adout(4)
adout(4) = 0.d0
adano3 = adano3+adout(3)
adout(3) = 0.d0
adout(2) = 0.d0
adaso4 = adaso4+adout(1)
adout(1) = 0.d0
adano3_in = adano3_in+adano3
adano3 = 0.
adgno3_in = adgno3_in+adgno3
adgno3 = 0.
adtnh4 = adtnh4+adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4)))
adynh4 = adynh4-adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4)))
adgnh3 = 0.
adynh4 = adynh4+adanh4*mwnh4
adanh4 = 0.
adtso4 = adtso4+adaso4*mwso4
adaso4 = 0.
adtwoso4 = adtwoso4+adynh4
adynh4 = 0.
adwh2o = adwh2o+1000*adah2o
adah2o = 0.
adah2o = adah2o+0.001d0*adwh2o
adwh2o = 0.
ynh4 = twoso4
call adawater( irh,tso4,ynh4,tno3,adtso4,adynh4,adtno3,adah2o )
adtwoso4 = adtwoso4+adynh4
adynh4 = 0.
adtso4 = adtso4+2*adtwoso4
adtwoso4 = 0.
adano3 = adano3+adano3_in
adano3_in = 0.
adgno3 = adgno3+adgno3_in
adgno3_in = 0.
adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh4)
adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh3)
adtnh4 = 0.
adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwno3)
adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwhno3)
adtno3 = 0.
adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4)
adtso4 = 0.
adin(5) = adin(5)+adanh4
adanh4 = 0.
adin(4) = adin(4)+adano3
adano3 = 0.
adin(3) = adin(3)+adgnh3
adgnh3 = 0.
adin(2) = adin(2)+adgno3
adgno3 = 0.
adin(1) = adin(1)+adso4
adso4 = 0.
end SUBROUTINE ADRPMARES_3
!-----------------------------------------------------------------------------
C DISCLAIMER
C
C This file was generated by TAMC version 5.3.2
C
C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES
C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS,
C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS
C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS.
C
C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION
C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS
C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT
C ALLOWED.
C
C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT
C info@FastOpt.com
C
subroutine adrpmares_4( in, par, adin, adout,
& I, J, L )
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
C==============================================
C define parameters
C==============================================
real*8 floor
parameter ( floor = 1.d-30 )
real*8 mwhno3
parameter ( mwhno3 = 63.01287d0 )
real*8 mwnh3
parameter ( mwnh3 = 17.03061d0 )
real*8 mwnh4
parameter ( mwnh4 = 18.03858d0 )
real*8 mwno3
parameter ( mwno3 = 62.0049d0 )
real*8 mwso4
parameter ( mwso4 = 96.0576d0 )
C==============================================
C define common blocks
C==============================================
C==============================================
C define arguments
C==============================================
double precision adin(5)
double precision adout(8)
double precision in(5)
double precision par(2)
INTEGER :: I, J, L
C==============================================
C define local variables
C==============================================
real aa
real*8 adah2o
real*8 adanh4
real*8 adano3
real*8 adaso4
real*8 adbb
real*8 adcc
real*8 addd
real*8 addisc
real*8 adfnh3
real*8 adgnh3
real*8 adgno3
real*8 adso4
real*8 adtmasshno3
real*8 adtnh4
real*8 adtno3
real*8 adtso4
real*8 adtwoso4
real*8 adwh2o
real*8 adxno3
real*8 adxxq
real*8 adynh4
real*8 anh4
real*8 ano3
real*8 bb
real*8 cc
real*8 convt
real*8 dd
real*8 disc
real*8 fnh3
real*8 gnh3
real*8 gno3
integer irh
real*8 k3
real*8 rh
real*8 so4
real*8 temp
real*8 tmasshno3
real*8 tnh4
real*8 tno3
real*8 tso4
real*8 twoso4
real*8 xno3
real*8 xxq
real*8 ynh4
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
adah2o = 0.
adanh4 = 0.
adano3 = 0.
adaso4 = 0.
adbb = 0.
adcc = 0.
addd = 0.
addisc = 0.
adfnh3 = 0.
adgnh3 = 0.
adgno3 = 0.
adso4 = 0.
adtmasshno3 = 0.
adtnh4 = 0.
adtno3 = 0.
adtso4 = 0.
adtwoso4 = 0.
adwh2o = 0.
adxno3 = 0.
adxxq = 0.
adynh4 = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
so4 = in(1)
gno3 = in(2)
gnh3 = in(3)
ano3 = in(4)
anh4 = in(5)
rh = par(1)
temp = par(2)
tso4 = max(floor,so4/mwso4)
tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3)
tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4)
tmasshno3 = max(0.d0,gno3+ano3)
irh = nint(100.*rh)
irh = max(1,irh)
irh = min(99,irh)
convt = 1.d0/(0.082d0*temp)
k3 = exp(118.87-24084./temp-6.025*log(temp))
k3 = k3*convt*convt
twoso4 = 2.*tso4
fnh3 = tnh4-twoso4
cc = tno3*fnh3-k3
if (cc .le. 0.d0) then
xno3 = 0.d0
else
aa = 1.d0
bb = -(tno3+fnh3)
disc = bb*bb-4.*cc
dd = sqrt(disc)
xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd))
xno3 = min(xxq/aa,cc/xxq)
endif
ynh4 = twoso4+xno3
ano3 = xno3*mwno3
adgnh3 = adgnh3+adout(8)
adout(8) = 0.d0
adgno3 = adgno3+adout(7)
adout(7) = 0.d0
adso4 = adso4+adout(6)
adout(6) = 0.d0
adanh4 = adanh4+adout(5)
adout(5) = 0.d0
adah2o = adah2o+adout(4)
adout(4) = 0.d0
adano3 = adano3+adout(3)
adout(3) = 0.d0
adout(2) = 0.d0
adaso4 = adaso4+adout(1)
adout(1) = 0.d0
adano3 = adano3-adgno3*(0.5-sign(0.5d0,floor-(tmasshno3-ano3)))
adtmasshno3 = adtmasshno3+adgno3*(0.5-sign(0.5d0,floor-(tmasshno3-
$ano3)))
adgno3 = 0.
adtnh4 = adtnh4+adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4)))
adynh4 = adynh4-adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4)))
adgnh3 = 0.
adynh4 = adynh4+adanh4*mwnh4
adanh4 = 0.
adxno3 = adxno3+adano3*mwno3
adano3 = 0.
adtso4 = adtso4+adaso4*mwso4
adaso4 = 0.
adtwoso4 = adtwoso4+adynh4
adxno3 = adxno3+adynh4
adynh4 = 0.
adwh2o = adwh2o+1000*adah2o
adah2o = 0.
if (cc .le. 0.d0) then
else
adcc = adcc+adxno3*((0.5-sign(0.5d0,cc/xxq-xxq/aa))/xxq)
adxxq = adxxq+adxno3*((0.5+sign(0.5d0,cc/xxq-xxq/aa))/aa-(0.5-
$sign(0.5d0,cc/xxq-xxq/aa))*(cc/(xxq*xxq)))
adxno3 = 0.
adbb = adbb-0.5d0*adxxq
addd = addd-0.5d0*adxxq*sign(1.d0,bb)
adxxq = 0.
addisc = addisc+addd*(1./(2.*sqrt(disc)))
addd = 0.
adbb = adbb+2*addisc*bb
adcc = adcc-4*addisc
addisc = 0.
adfnh3 = adfnh3-adbb
adtno3 = adtno3-adbb
adbb = 0.
endif
adfnh3 = adfnh3+adcc*tno3
adtno3 = adtno3+adcc*fnh3
adcc = 0.
adtnh4 = adtnh4+adfnh3
adtwoso4 = adtwoso4-adfnh3
adfnh3 = 0.
adah2o = adah2o+0.001d0*adwh2o
adwh2o = 0.
ynh4 = twoso4
call adawater( irh,tso4,ynh4,tno3,adtso4,adynh4,adtno3,adah2o )
adtwoso4 = adtwoso4+adynh4
adynh4 = 0.
adtso4 = adtso4+2*adtwoso4
adtwoso4 = 0.
ano3 = in(4)
adano3 = adano3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3)))
adgno3 = adgno3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3)))
adtmasshno3 = 0.
adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh4)
adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh3)
adtnh4 = 0.
adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwno3)
adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwhno3)
adtno3 = 0.
adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4)
adtso4 = 0.
adin(5) = adin(5)+adanh4
adanh4 = 0.
adin(4) = adin(4)+adano3
adano3 = 0.
adin(3) = adin(3)+adgnh3
adgnh3 = 0.
adin(2) = adin(2)+adgno3
adgno3 = 0.
adin(1) = adin(1)+adso4
adso4 = 0.
end SUBROUTINE ADRPMARES_4
!-----------------------------------------------------------------------------
C DISCLAIMER
C
C This file was generated by TAMC version 5.3.2
C
C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES
C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS,
C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS
C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS.
C
C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION
C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS
C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT
C ALLOWED.
C
C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT
C info@FastOpt.com
C
subroutine adrpmares_6( in, par, adin, adout,
& I, J, L )
! References to f90 modules
USE CHECKPT_MOD
USE RPMARES_MOD, ONLY : AWATER, ACTCOF
# include "CMN_SIZE" ! Size params
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
C==============================================
C define parameters
C==============================================
real*8 floor
parameter ( floor = 1.d-30 )
real*8 mwhno3
parameter ( mwhno3 = 63.01287d0 )
real*8 mwnh3
parameter ( mwnh3 = 17.03061d0 )
real*8 mwnh4
parameter ( mwnh4 = 18.03858d0 )
real*8 mwno3
parameter ( mwno3 = 62.0049d0 )
real*8 mwso4
parameter ( mwso4 = 96.0576d0 )
C==============================================
C define common blocks
C==============================================
C==============================================
C define arguments
C============================================= =
double precision adin(5)
double precision adout(8)
double precision in(5)
double precision par(2)
INTEGER :: I, J, L
C==============================================
C define local variables
C==============================================
real aa
real adaa
real*8 adah2o
real*8 adan(3)
real*8 adanh4
real*8 adano3
real*8 adaso4
real*8 adbb
real*8 adcat(2)
real*8 adcc
real*8 addd
real*8 addisc
real*8 aderor
real aderorh
real*8 adgamaan
real*8 adgamold
real*8 adgams(2,3)
real*8 adgasqd
real*8 adgnh3
real*8 adgno3
real*8 adkw2
real*8 adman
real*8 admas
real*8 admnh4
real*8 adrr1
real*8 adrr2
real*8 adso4
real*8 adtmasshno3
real*8 adtnh4
real*8 adtno3
real*8 adtso4
real*8 adtwoso4
real*8 adwh2o
real*8 adwsqd
real*8 adxno3
real*8 adxxq
real*8 adynh4
real*8 ah2o
real*8 an(3)
real*8 anh4
real*8 ano3
real*8 bb
real*8 cat(2)
real*8 cc
real*8 dd
real*8 disc
real*8 eror
integer exit
real*8 gamaan
real*8 gamaanh
real*8 gamold
real*8 gams(2,3)
real*8 gasqd
real*8 gnh3
real*8 gno3
integer ip1
integer ip2
integer irh
real*8 k1a
real*8 kan
real*8 khat
real*8 kna
real*8 kph
real*8 kw
real*8 kw2
real*8 man
real*8 mas
real*8 mnh4
real*8 molnu
integer nnn
integer nnn1
real*8 phibar
real*8 rh
real*8 rr1
real*8 rr2
real*8 so4
real*8 t1
real*8 t2
real*8 t3
real*8 t4
real*8 t6
real*8 temp
real*8 tmasshno3
real*8 tnh4
real*8 tno3
real*8 toler1
real*8 tso4
real*8 twoso4
real*8 wh2o
real*8 wh2oh
real*8 wsqd
real*8 xno3
real*8 xxq
real*8 ynh4
real*8 ynh4h
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
adaa = 0.
adah2o = 0.
do ip1 = 1, 3
adan(ip1) = 0.
end do
adanh4 = 0.
adano3 = 0.
adaso4 = 0.
adbb = 0.
do ip1 = 1, 2
adcat(ip1) = 0.
end do
adcc = 0.
addd = 0.
addisc = 0.
aderor = 0.
adgamaan = 0.
adgamold = 0.
do ip2 = 1, 3
do ip1 = 1, 2
adgams(ip1,ip2) = 0.
end do
end do
adgasqd = 0.
adgnh3 = 0.
adgno3 = 0.
adkw2 = 0.
adman = 0.
admas = 0.
admnh4 = 0.
adrr1 = 0.
adrr2 = 0.
adso4 = 0.
adtmasshno3 = 0.
adtnh4 = 0.
adtno3 = 0.
adtso4 = 0.
adtwoso4 = 0.
adwh2o = 0.
adwsqd = 0.
adxno3 = 0.
adxxq = 0.
adynh4 = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
so4 = in(1)
gno3 = in(2)
gnh3 = in(3)
ano3 = in(4)
anh4 = in(5)
rh = par(1)
temp = par(2)
tso4 = max(floor,so4/mwso4)
tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3)
tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4)
tmasshno3 = max(0.d0,gno3+ano3)
irh = nint(100.*rh)
irh = max(1,irh)
irh = min(99,irh)
t6 = 8.2d-11*temp
t1 = 298.d0/temp
t2 = log(t1)
t3 = t1-1.d0
t4 = 1.d0+t2-t1
kna = 2511000.d0*exp(29.17d0*t3+16.83d0*t4)*t6
k1a = 0.00001805d0*exp((-(1.5d0*t3))+26.92d0*t4)
kw = 1.01d-14*exp((-(22.52d0*t3))+26.92d0*t4)
kph = 57.639d0*exp(13.79d0*t3-5.39d0*t4)*t6
khat = kph*k1a/kw
kan = kna*khat
toler1 = 0.00001d0
twoso4 = 2.*tso4
adgnh3 = adgnh3+adout(8)
adout(8) = 0.d0
adgno3 = adgno3+adout(7)
adout(7) = 0.d0
adso4 = adso4+adout(6)
adout(6) = 0.d0
adanh4 = adanh4+adout(5)
adout(5) = 0.d0
adah2o = adah2o+adout(4)
adout(4) = 0.d0
adano3 = adano3+adout(3)
adout(3) = 0.d0
adout(2) = 0.d0
adaso4 = adaso4+adout(1)
adout(1) = 0.d0
!do nnn = 50, 1, -1
do nnn = nitr_max(I,J,L), 1, -1
exit = 0
gamold = 1.d0
gamaan = 0.1
ynh4 = twoso4
call awater( irh,tso4,ynh4,tno3,ah2o )
wh2o = 0.001d0*ah2o
ynh4 = twoso4
!=====================================================================
! CHECKPOINT
! The do loop below was soley for the recomputation of ynh4h, wh2oh,
! gamaanhm, exit and gamold.
! Instead of recomputing these quantities, get them from the forward
! calculation, except if nnn is 1, in which case they are just their
! normal values
!=====================================================================
IF (nnn-1 .gt. 0) THEN
ynh4h = ynh4_fwd(I,J,L,nnn-1)
wh2oh = wh2o_fwd(I,J,L,nnn-1)
gamaanh = gamaan_fwd(I,J,L,nnn-1)
gamold = gamold_fwd(I,J,L,nnn-1)
exit = exit_fwd(I,J,L,nnn-1)
ENDIF
! do nnn1 = 1, nnn-1
! gasqd = gamaan*gamaan
! wsqd = wh2o*wh2o
! kw2 = kan*wsqd/gasqd
! aa = 1.-kw2
! bb = twoso4+kw2*(tno3+tnh4-twoso4)
! cc = -(kw2*tno3*(tnh4-twoso4))
! disc = bb*bb-4.*aa*cc
! if (aa .ne. 0.d0) then
! dd = sqrt(disc)
! xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd))
! rr1 = xxq/aa
! rr2 = cc/xxq
! if (rr1*rr2 .lt. 0.d0) then
! xno3 = max(rr1,rr2)
! else
! xno3 = min(rr1,rr2)
! endif
! else
! xno3 = -(cc/bb)
! endif
! xno3 = min(xno3,tno3)
! call awater( irh,tso4,ynh4,xno3,ah2o )
! wh2o = 0.001*ah2o
! man = xno3/wh2o
! mas = tso4/wh2o
! mnh4 = 2.*mas+man
! ynh4 = mnh4*wh2o
! cat(1) = 0.
! cat(2) = mnh4
! an(1) = mas
! an(2) = man
! an(3) = 0.
! call actcof( cat,an,gams,molnu,phibar )
! gamaan = gams(2,2)
! eror = abs(gamold-gamaan)/gamold
! gamold = gamaan
! if (eror .le. toler1) then
! if (exit .eq. 0) then
! exit = 6
! endif
! endif
! end do
ynh4h = ynh4
wh2oh = wh2o
gamaanh = gamaan
gasqd = gamaan*gamaan
wsqd = wh2o*wh2o
kw2 = kan*wsqd/gasqd
aa = 1.-kw2
bb = twoso4+kw2*(tno3+tnh4-twoso4)
cc = -(kw2*tno3*(tnh4-twoso4))
disc = bb*bb-4.*aa*cc
if (aa .ne. 0.d0) then
dd = sqrt(disc)
xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd))
rr1 = xxq/aa
rr2 = cc/xxq
if (rr1*rr2 .lt. 0.d0) then
xno3 = max(rr1,rr2)
else
xno3 = min(rr1,rr2)
endif
else
xno3 = -(cc/bb)
endif
xno3 = min(xno3,tno3)
call awater( irh,tso4,ynh4,xno3,ah2o )
wh2o = 0.001*ah2o
man = xno3/wh2o
mas = tso4/wh2o
mnh4 = 2.*mas+man
ynh4 = mnh4*wh2o
cat(1) = 0.
cat(2) = mnh4
an(1) = mas
an(2) = man
an(3) = 0.
call actcof( cat,an,gams,molnu,phibar )
gamaan = gams(2,2)
eror = abs(gamold-gamaan)/gamold
if (eror .le. toler1) then
if (exit .eq. 0) then
ano3 = xno3*mwno3
adwh2o = adwh2o+1000*adah2o
adah2o = 0.
adtnh4 = adtnh4+adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4)
$))
adynh4 = adynh4-adgnh3*mwnh3*(0.5-sign(0.5d0,floor-(tnh4-ynh4)
$))
adgnh3 = 0.
adano3 = adano3-adgno3*(0.5-sign(0.5d0,floor-(tmasshno3-ano3))
$)
adtmasshno3 = adtmasshno3+adgno3*(0.5d0-sign(0.5d0,floor-
$(tmasshno3-ano3)))
adgno3 = 0.
adynh4 = adynh4+adanh4*mwnh4
adanh4 = 0.
adxno3 = adxno3+adano3*mwno3
adano3 = 0.
adtso4 = adtso4+adaso4*mwso4
adaso4 = 0.
endif
endif
adgamaan = adgamaan+adgamold
adgamold = 0.
aderorh = aderor/gamold
adgamold = adgamold-aderor*(abs(gamold-gamaan)/(gamold*gamold))
adgamaan = adgamaan-aderorh*sign(1.d0,gamold-gamaan)
adgamold = adgamold+aderorh*sign(1.d0,gamold-gamaan)
aderor = 0.
adgams(2,2) = adgams(2,2)+adgamaan
adgamaan = 0.
call adactcof( cat,an,adcat,adan,adgams )
adan(3) = 0.
adman = adman+adan(2)
adan(2) = 0.
admas = admas+adan(1)
adan(1) = 0.
admnh4 = admnh4+adcat(2)
adcat(2) = 0.
adcat(1) = 0.
admnh4 = admnh4+adynh4*wh2o
adwh2o = adwh2o+adynh4*mnh4
adynh4 = 0.
adman = adman+admnh4
admas = admas+2*admnh4
admnh4 = 0.
adtso4 = adtso4+admas/wh2o
adwh2o = adwh2o-admas*(tso4/(wh2o*wh2o))
admas = 0.
adwh2o = adwh2o-adman*(xno3/(wh2o*wh2o))
adxno3 = adxno3+adman/wh2o
adman = 0.
adah2o = adah2o+0.001*adwh2o
adwh2o = 0.
ynh4 = ynh4h
call adawater( irh,tso4,ynh4,xno3,adtso4,adynh4,adxno3,adah2o )
if (aa .ne. 0.d0) then
dd = sqrt(disc)
xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd))
rr1 = xxq/aa
rr2 = cc/xxq
if (rr1*rr2 .lt. 0.d0) then
xno3 = max(rr1,rr2)
else
xno3 = min(rr1,rr2)
endif
else
xno3 = -(cc/bb)
endif
adtno3 = adtno3+adxno3*(0.5-sign(0.5d0,tno3-xno3))
adxno3 = adxno3*(0.5+sign(0.5d0,tno3-xno3))
if (aa .ne. 0.d0) then
if (rr1*rr2 .lt. 0.d0) then
adrr1 = adrr1+adxno3*(0.5+sign(0.5d0,rr1-rr2))
adrr2 = adrr2+adxno3*(0.5-sign(0.5d0,rr1-rr2))
adxno3 = 0.
else
adrr1 = adrr1+adxno3*(0.5+sign(0.5d0,rr2-rr1))
adrr2 = adrr2+adxno3*(0.5-sign(0.5d0,rr2-rr1))
adxno3 = 0.
endif
adcc = adcc+adrr2/xxq
adxxq = adxxq-adrr2*(cc/(xxq*xxq))
adrr2 = 0.
adaa = adaa-adrr1*(xxq/(aa*aa))
adxxq = adxxq+adrr1/aa
adrr1 = 0.
adbb = adbb-0.5d0*adxxq
addd = addd-0.5d0*adxxq*sign(1.d0,bb)
adxxq = 0.
addisc = addisc+addd*(1./(2.*sqrt(disc)))
addd = 0.
else
adbb = adbb+adxno3*(cc/(bb*bb))
adcc = adcc-adxno3/bb
adxno3 = 0.
endif
adaa = adaa-4*addisc*cc
adbb = adbb+2*addisc*bb
adcc = adcc-4*addisc*aa
addisc = 0.
adkw2 = adkw2-adcc*tno3*(tnh4-twoso4)
adtnh4 = adtnh4-adcc*kw2*tno3
adtno3 = adtno3-adcc*kw2*(tnh4-twoso4)
adtwoso4 = adtwoso4+adcc*kw2*tno3
adcc = 0.
adkw2 = adkw2+adbb*(tno3+tnh4-twoso4)
adtnh4 = adtnh4+adbb*kw2
adtno3 = adtno3+adbb*kw2
adtwoso4 = adtwoso4+adbb*(1-kw2)
adbb = 0.
adkw2 = adkw2-adaa
adaa = 0.
adgasqd = adgasqd-adkw2*(kan*wsqd/(gasqd*gasqd))
adwsqd = adwsqd+adkw2*(kan/gasqd)
adkw2 = 0.
wh2o = wh2oh
adwh2o = adwh2o+2*adwsqd*wh2o
adwsqd = 0.
gamaan = gamaanh
adgamaan = adgamaan+2*adgasqd*gamaan
adgasqd = 0.
end do
adtwoso4 = adtwoso4+adynh4
adynh4 = 0.
adynh4 = adynh4+adanh4*mwnh4
adanh4 = 0.
adano3 = 0.
adtso4 = adtso4+adaso4*mwso4
adaso4 = 0.
adah2o = adah2o+0.001d0*adwh2o
adwh2o = 0.
ynh4 = twoso4
call adawater( irh,tso4,ynh4,tno3,adtso4,adynh4,adtno3,adah2o )
adtwoso4 = adtwoso4+adynh4
adynh4 = 0.
adtso4 = adtso4+2*adtwoso4
adtwoso4 = 0.
ano3 = in(4)
adano3 = adano3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3)))
adgno3 = adgno3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3)))
adtmasshno3 = 0.
adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh4)
adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh3)
adtnh4 = 0.
adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwno3)
adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwhno3)
adtno3 = 0.
adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4)
adtso4 = 0.
adin(5) = adin(5)+adanh4
adanh4 = 0.
adin(4) = adin(4)+adano3
adano3 = 0.
adin(3) = adin(3)+adgnh3
adgnh3 = 0.
adin(2) = adin(2)+adgno3
adgno3 = 0.
adin(1) = adin(1)+adso4
adso4 = 0.
end SUBROUTINE ADRPMARES_6
!-----------------------------------------------------------------------------
C DISCLAIMER
C
C This file was generated by TAMC version 5.3.2
C
C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES
C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS,
C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS
C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS.
C
C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION
C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS
C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT
C ALLOWED.
C
C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT
C info@FastOpt.com
C
subroutine adrpmares_7( in, par, adin, adout,
& I, J, L )
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
C==============================================
C define parameters
C==============================================
real*8 floor
parameter ( floor = 1.d-30 )
real*8 mwhno3
parameter ( mwhno3 = 63.01287d0 )
real*8 mwnh3
parameter ( mwnh3 = 17.03061d0 )
real*8 mwnh4
parameter ( mwnh4 = 18.03858d0 )
real*8 mwno3
parameter ( mwno3 = 62.0049d0 )
real*8 mwso4
parameter ( mwso4 = 96.0576d0 )
C==============================================
C define common blocks
C==============================================
C==============================================
C define arguments
C==============================================
double precision adin(5)
double precision adout(8)
double precision in(5)
double precision par(2)
INTEGER :: I, J, L
C==============================================
C define local variables
C==============================================
real*8 adah2o
real*8 adanh4
real*8 adano3
real*8 adano3_in
real*8 adaso4
real*8 adgnh3
real*8 adgno3
real*8 adgno3_in
real*8 adso4
real*8 adtnh4
real*8 adtno3
real*8 adtso4
real*8 adtwoso4
real*8 adxno3
real*8 adynh4
real*8 anh4
real*8 ano3
real*8 gnh3
real*8 gno3
integer irh
real*8 rh
real*8 so4
real*8 tnh4
real*8 tno3
real*8 tso4
real*8 twoso4
real*8 xno3
real*8 ynh4
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
adah2o = 0.
adanh4 = 0.
adano3 = 0.
adano3_in = 0.
adaso4 = 0.
adgnh3 = 0.
adgno3 = 0.
adgno3_in = 0.
adso4 = 0.
adtnh4 = 0.
adtno3 = 0.
adtso4 = 0.
adtwoso4 = 0.
adxno3 = 0.
adynh4 = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
so4 = in(1)
gno3 = in(2)
gnh3 = in(3)
ano3 = in(4)
anh4 = in(5)
rh = par(1)
tso4 = max(floor,so4/mwso4)
tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3)
tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4)
irh = nint(100.*rh)
irh = max(1,irh)
irh = min(99,irh)
twoso4 = 2.*tso4
xno3 = tno3/mwno3
ynh4 = twoso4
adgnh3 = adgnh3+adout(8)
adout(8) = 0.d0
adgno3 = adgno3+adout(7)
adout(7) = 0.d0
adso4 = adso4+adout(6)
adout(6) = 0.d0
adanh4 = adanh4+adout(5)
adout(5) = 0.d0
adah2o = adah2o+adout(4)
adout(4) = 0.d0
adano3 = adano3+adout(3)
adout(3) = 0.d0
adout(2) = 0.d0
adaso4 = adaso4+adout(1)
adout(1) = 0.d0
adtnh4 = adtnh4+adgnh3*(0.5-sign(0.5d0,floor-mwnh3*(tnh4-ynh4)))*
$mwnh3
adynh4 = adynh4-adgnh3*(0.5-sign(0.5d0,floor-mwnh3*(tnh4-ynh4)))*
$mwnh3
adgnh3 = 0.
adano3_in = adano3_in+adano3
adano3 = 0.
adgno3_in = adgno3_in+adgno3
adgno3 = 0.
call adawater( irh,tso4,ynh4,xno3,adtso4,adynh4,adxno3,adah2o )
adynh4 = adynh4+adanh4*mwnh4
adanh4 = 0.
adtwoso4 = adtwoso4+adynh4
adynh4 = 0.
adtno3 = adtno3+adxno3/mwno3
adxno3 = 0.
adtso4 = adtso4+adaso4*mwso4
adaso4 = 0.
ynh4 = twoso4
call adawater( irh,tso4,ynh4,tno3,adtso4,adynh4,adtno3,adah2o )
adtwoso4 = adtwoso4+adynh4
adynh4 = 0.
adtso4 = adtso4+2*adtwoso4
adtwoso4 = 0.
adano3 = adano3+adano3_in
adano3_in = 0.
adgno3 = adgno3+adgno3_in
adgno3_in = 0.
adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh4)
adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh3)
adtnh4 = 0.
adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwno3)
adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwhno3)
adtno3 = 0.
adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4)
adtso4 = 0.
adin(5) = adin(5)+adanh4
adanh4 = 0.
adin(4) = adin(4)+adano3
adano3 = 0.
adin(3) = adin(3)+adgnh3
adgnh3 = 0.
adin(2) = adin(2)+adgno3
adgno3 = 0.
adin(1) = adin(1)+adso4
adso4 = 0.
end SUBROUTINE ADRPMARES_7
!-----------------------------------------------------------------------------
C DISCLAIMER
C
C This file was generated by TAMC version 5.3.2
C
C THE AUTHOR DOES NOT MAKE ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES
C ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS,
C OR USEFULNESS OF ANY INFORMATION OR PROCESS DISCLOSED, OR REPRESENTS
C THAT ITS USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS.
C
C THIS CODE IS FOR NON-PROFIT-ORIENTATED ACADEMIC RESEARCH AND EDUCATION
C ONLY. ANY COMMERCIAL OR OTHER PROFIT-ORIENTATED USE OR EVALUATION IS
C STRICTLY FORBIDDEN. PASSING THIS CODE TO ANY THIRD PARTY IS NOT
C ALLOWED.
C
C FOR COMMERCIAL OR OTHER PROFIT-ORIENTATED APPLICATIONS PLEASE CONTACT
C info@FastOpt.com
C
subroutine adrpmares_8( in, par, adin, adout,
& I, J, L )
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
C==============================================
C define parameters
C==============================================
real*8 floor
parameter ( floor = 1.d-30 )
real*8 mwhno3
parameter ( mwhno3 = 63.01287d0 )
real*8 mwnh3
parameter ( mwnh3 = 17.03061d0 )
real*8 mwnh4
parameter ( mwnh4 = 18.03858d0 )
real*8 mwno3
parameter ( mwno3 = 62.0049d0 )
real*8 mwso4
parameter ( mwso4 = 96.0576d0 )
C==============================================
C define common blocks
C==============================================
C==============================================
C define arguments
C==============================================
double precision adin(5)
double precision adout(8)
double precision in(5)
double precision par(2)
INTEGER :: I, J, L
C==============================================
C define local variables
C==============================================
real*8 adah2o
real*8 adahso4
real*8 adanh4
real*8 adano3
real*8 adano3_in
real*8 adaso4
real*8 adgnh3
real*8 adgno3
real*8 adso4
real*8 adtmasshno3
real*8 adtnh4
real*8 adtno3
real*8 adtso4
real*8 anh4
real*8 ano3
real*8 gnh3
real*8 gno3
integer irh
real*8 rh
real*8 so4
real*8 tnh4
real*8 tno3
real*8 tso4
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
adah2o = 0.
adahso4 = 0.
adanh4 = 0.
adano3 = 0.
adano3_in = 0.
adaso4 = 0.
adgnh3 = 0.
adgno3 = 0.
adso4 = 0.
adtmasshno3 = 0.
adtnh4 = 0.
adtno3 = 0.
adtso4 = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
so4 = in(1)
gno3 = in(2)
gnh3 = in(3)
ano3 = in(4)
anh4 = in(5)
rh = par(1)
tso4 = max(floor,so4/mwso4)
tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3)
tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4)
irh = nint(100.*rh)
irh = max(1,irh)
irh = min(99,irh)
adgnh3 = adgnh3+adout(8)
adout(8) = 0.d0
adgno3 = adgno3+adout(7)
adout(7) = 0.d0
adso4 = adso4+adout(6)
adout(6) = 0.d0
adanh4 = adanh4+adout(5)
adout(5) = 0.d0
adah2o = adah2o+adout(4)
adout(4) = 0.d0
adano3 = adano3+adout(3)
adout(3) = 0.d0
adahso4 = adahso4+adout(2)
adout(2) = 0.d0
adaso4 = adaso4+adout(1)
adout(1) = 0.d0
adgnh3 = 0.
adano3 = adano3-adgno3
adtmasshno3 = adtmasshno3+adgno3
adgno3 = 0.
adano3_in = adano3_in+adano3
adano3 = 0.
adtnh4 = adtnh4+adanh4*mwnh4
adanh4 = 0.
adtso4 = adtso4+adahso4*mwso4
adahso4 = 0.
adaso4 = 0.
call adawater( irh,tso4,tnh4,tno3,adtso4,adtnh4,adtno3,adah2o )
adano3 = adano3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3)))
adgno3 = adgno3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3)))
adtmasshno3 = 0.
adano3 = adano3+adano3_in
adano3_in = 0.
adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh4)
adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh3)
adtnh4 = 0.
adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwno3)
adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwhno3)
adtno3 = 0.
adso4 = adso4+adtso4*((0.5-sign(0.5d0,floor-so4/mwso4))/mwso4)
adtso4 = 0.
adin(5) = adin(5)+adanh4
adanh4 = 0.
adin(4) = adin(4)+adano3
adano3 = 0.
adin(3) = adin(3)+adgnh3
adgnh3 = 0.
adin(2) = adin(2)+adgno3
adgno3 = 0.
adin(1) = adin(1)+adso4
adso4 = 0.
end SUBROUTINE ADRPMARES_8
!------------------------------------------------------------------------------
subroutine adcubic( a2, a1, a0, ada2, ada1, ada0, adcrutes )
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
implicit none
C==============================================
C define parameters
C==============================================
real*8 one
parameter ( one = 1.d0 )
real*8 one3rd
parameter ( one3rd = 0.333333333d0 )
real*8 sqrt3
parameter ( sqrt3 = 1.732050808d0 )
C==============================================
C define common blocks
C==============================================
C==============================================
C define arguments
C==============================================
real*8 a0
real*8 a1
real*8 a2
real*8 ada0
real*8 ada1
real*8 ada2
real*8 adcrutes(3)
C==============================================
C define local variables
C==============================================
real*8 a2sq
real*8 ada2sq
real*8 adcosth
real*8 addum1
real*8 addum2
real*8 adpart1
real*8 adpart2
real*8 adpart3
real*8 adphi
real*8 adqq
real*8 adrr
real*8 adrrsq
real*8 adsinth
real*8 adtheta
real*8 adyy1
real*8 adyy2
real*8 adyy3
real*8 costh
real*8 crutes(3)
real*8 dum1
real*8 dum2
real*8 part1
real*8 part2
real*8 part3
real*8 phi
real*8 qq
real*8 rr
real*8 rrsq
real*8 sinth
real*8 theta
real*8 yy1
real*8 yy2
real*8 yy3
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
ada2sq = 0.
adcosth = 0.
addum1 = 0.
addum2 = 0.
adpart1 = 0.
adpart2 = 0.
adpart3 = 0.
adphi = 0.
adqq = 0.
adrr = 0.
adrrsq = 0.
adsinth = 0.
adtheta = 0.
adyy1 = 0.
adyy2 = 0.
adyy3 = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
a2sq = a2*a2
qq = (a2sq-3.d0*a1)/9.d0
rr = (a2*(2.d0*a2sq-9.d0*a1)+27.d0*a0)/54.d0
dum1 = qq*qq*qq
rrsq = rr*rr
dum2 = dum1-rrsq
if (dum2 .ge. 0.d0) then
phi = sqrt(dum1)
if (abs(phi) .lt. 1.d-20) then
crutes(1) = 0.d0
crutes(2) = 0.d0
crutes(3) = 0.d0
endif
theta = acos(rr/phi)/3.d0
costh = cos(theta)
sinth = sin(theta)
part1 = sqrt(qq)
yy1 = part1*costh
yy2 = yy1-a2/3.d0
yy3 = sqrt3*part1*sinth
crutes(3) = (-(2.d0*yy1))-a2/3.d0
crutes(2) = yy2+yy3
crutes(1) = yy2-yy3
if (crutes(1) .lt. 0.d0) then
crutes(1) = 1.d+9
endif
if (crutes(2) .lt. 0.d0) then
crutes(2) = 1.d+9
endif
if (crutes(3) .lt. 0.d0) then
crutes(3) = 1.d+9
endif
adcrutes(2) = adcrutes(2)+adcrutes(1)*(0.5-sign(0.5d0,crutes(2)-
$crutes(1)))
adcrutes(1) = adcrutes(1)*(0.5+sign(0.5d0,crutes(2)-crutes(1)))
crutes(1) = yy2-yy3
if (crutes(1) .lt. 0.d0) then
crutes(1) = 1.d+9
endif
if (crutes(2) .lt. 0.d0) then
crutes(2) = 1.d+9
endif
if (crutes(3) .lt. 0.d0) then
adcrutes(3) = 0.
endif
crutes(1) = yy2-yy3
if (crutes(1) .lt. 0.d0) then
crutes(1) = 1.d+9
endif
if (crutes(2) .lt. 0.d0) then
adcrutes(2) = 0.
endif
crutes(1) = yy2-yy3
if (crutes(1) .lt. 0.d0) then
adcrutes(1) = 0.
endif
adyy2 = adyy2+adcrutes(1)
adyy3 = adyy3-adcrutes(1)
adcrutes(1) = 0.
adyy2 = adyy2+adcrutes(2)
adyy3 = adyy3+adcrutes(2)
adcrutes(2) = 0.
ada2 = ada2-0.333333333333d0*adcrutes(3)
adyy1 = adyy1-2*adcrutes(3)
adcrutes(3) = 0.
adpart1 = adpart1+adyy3*sqrt3*sinth
adsinth = adsinth+adyy3*sqrt3*part1
adyy3 = 0.
ada2 = ada2-0.333333333333d0*adyy2
adyy1 = adyy1+adyy2
adyy2 = 0.
adcosth = adcosth+adyy1*part1
adpart1 = adpart1+adyy1*costh
adyy1 = 0.
adqq = adqq+adpart1*(1./(2.*sqrt(qq)))
adpart1 = 0.
adtheta = adtheta+adsinth*cos(theta)
adsinth = 0.
adtheta = adtheta-adcosth*sin(theta)
adcosth = 0.
adphi = adphi+adtheta*(1./sqrt(1.-(rr/phi)**2)*(rr/(phi*phi))/
$3.d0)
adrr = adrr-adtheta*(1./sqrt(1.-(rr/phi)**2)/phi/3.d0)
adtheta = 0.
if (abs(phi) .lt. 1.d-20) then
adcrutes(3) = 0.
adcrutes(2) = 0.
adcrutes(1) = 0.
endif
addum1 = addum1+adphi*(1./(2.*sqrt(dum1)))
adphi = 0.
else
part1 = sqrt(rrsq-dum1)
part2 = abs(rr)
part3 = (part1+part2)**one3rd
adcrutes(3) = 0.
adcrutes(2) = 0.
ada2 = ada2-0.333333333333d0*adcrutes(1)
adpart3 = adpart3-adcrutes(1)*(1-qq/(part3*part3))*sign(one,rr)
adqq = adqq-adcrutes(1)/part3*sign(one,rr)
adcrutes(1) = 0.
adpart1 = adpart1+adpart3*one3rd*(part1+part2)**(one3rd-1)
adpart2 = adpart2+adpart3*one3rd*(part1+part2)**(one3rd-1)
adpart3 = 0.
adrr = adrr+adpart2*sign(1.d0,rr)
adpart2 = 0.
addum1 = addum1-adpart1*(1./(2.*sqrt(rrsq-dum1)))
adrrsq = adrrsq+adpart1*(1./(2.*sqrt(rrsq-dum1)))
adpart1 = 0.
endif
addum1 = addum1+addum2
adrrsq = adrrsq-addum2
addum2 = 0.
adrr = adrr+2*adrrsq*rr
adrrsq = 0.
adqq = adqq+3*addum1*qq*qq
addum1 = 0.
ada0 = ada0+0.5d0*adrr
ada1 = ada1+adrr*((-9)*a2/54.d0)
ada2 = ada2+adrr*((2.d0*a2sq-9.d0*a1)/54.d0)
ada2sq = ada2sq+adrr*(2*a2/54.d0)
adrr = 0.
ada1 = ada1-0.333333333333d0*adqq
ada2sq = ada2sq+0.111111111111d0*adqq
adqq = 0.
ada2 = ada2+2*ada2sq*a2
ada2sq = 0.
end SUBROUTINE ADCUBIC
!------------------------------------------------------------------------------
subroutine adrpmares_6_D5( in, par, adin, adout,
& I, J, L )
!
!******************************************************************************
! Subroutine adrpmares_6_D5 was created using a modified version of
! rpmares_short6.f which replaced the RETURN structure with a DOWHILE loop.
! (dkh, 06/01/05)
!
! Notes
! (1 ) The following changes are made to the code returned by TAMC:
! - Change the routine name
! - Expand argument list to include I, J, L
! - Eliminate the OUT variable as we are not returning results of fwd
! calculation from this subroutine.
! - Replace reference to TAMC storage routines with reference to our
! checkpointing variables xxx_fwd which are initialized in
! RECOMP_RPMARES. Comment out the portions of the code that were used
! to recompute these variables (idow, gamaan, wh2o, ynh4).
!
! (2 ) Unlike previous version, don't bother to use checkpointed values of
! gamanold Can just use gamaan_fwd(I,J,L,idow-1) to restore gamanold.
!
!******************************************************************************
!
! Reference to f90 modules
USE CHECKPT_MOD
USE RPMARES_MOD, ONLY : CUBIC, AWATER, ACTCOF
# include "CMN_SIZE" ! Size params
C***************************************************************
C***************************************************************
C** This routine was generated by the **
C** Tangent linear and Adjoint Model Compiler, TAMC 5.3.2 **
C***************************************************************
C***************************************************************
C==============================================
C all entries are defined explicitly
C==============================================
! implicit none
C==============================================
C define parameters
C==============================================
real*8 floor
parameter ( floor = 1.d-30 )
real*8 mwhno3
parameter ( mwhno3 = 63.01287d0 )
real*8 mwnh3
parameter ( mwnh3 = 17.03061d0 )
real*8 mwnh4
parameter ( mwnh4 = 18.03858d0 )
real*8 mwno3
parameter ( mwno3 = 62.0049d0 )
real*8 mwso4
parameter ( mwso4 = 96.0576d0 )
C==============================================
C define common blocks
C==============================================
C==============================================
C define arguments
C==============================================
double precision adin(5)
double precision adout(8)
double precision in(5)
! double precision out(8)
double precision par(2)
C==============================================
C define local variables
C==============================================
real aa
real adaa
real*8 adah2o
real*8 adan(3)
real*8 adanh4
real*8 adano3
real*8 adaso4
real*8 adbb
real*8 adcat(2)
real*8 adcc
real*8 addd
real*8 addisc
real*8 aderor
real aderori
real*8 adgamaan
real*8 adgamold
real*8 adgams(2,3)
real*8 adgasqd
real*8 adgnh3
real*8 adgno3
real*8 adkw2
real*8 adman
real*8 admas
real*8 admnh4
real*8 adrr1
real*8 adrr2
real*8 adso4
real*8 adtmasshno3
real*8 adtnh4
real*8 adtno3
real*8 adtso4
real*8 adtwoso4
real*8 adwh2o
real*8 adwsqd
real*8 adxno3
real*8 adxxq
real*8 adynh4
real*8 ah2o
real*8 ahso4
real*8 an(3)
real*8 anh4
real*8 ano3
real*8 aso4
real*8 bb
real*8 cat(2)
real*8 cc
logical converged
real*8 dd
real*8 disc
real*8 eror
real*8 gamaan
real*8 gamaani
real*8 gamold
real*8 gams(2,3)
real*8 gasqd
real*8 gnh3
real*8 gno3
integer idow
integer idow2
integer ip1
integer ip2
integer irh
real*8 k1a
real*8 kan
real*8 khat
real*8 kna
real*8 kph
real*8 kw
real*8 kw2
real*8 man
real*8 mas
real*8 mnh4
real*8 molnu
integer ndow
integer nnn
real*8 phibar
real*8 rh
real*8 rr1
real*8 rr2
real*8 so4
real*8 t1
real*8 t2
real*8 t3
real*8 t4
real*8 t6
real*8 temp
real*8 tmasshno3
real*8 tnh4
real*8 tno3
real*8 toler1
real*8 tso4
real*8 twoso4
real*8 wh2o
real*8 wh2oi
real*8 wsqd
real*8 xno3
real*8 xxq
real*8 ynh4
real*8 ynh4i
INTEGER I, J, L
C----------------------------------------------
C RESET LOCAL ADJOINT VARIABLES
C----------------------------------------------
adaa = 0.
adah2o = 0.
do ip1 = 1, 3
adan(ip1) = 0.
end do
adanh4 = 0.
adano3 = 0.
adaso4 = 0.
adbb = 0.
do ip1 = 1, 2
adcat(ip1) = 0.
end do
adcc = 0.
addd = 0.
addisc = 0.
aderor = 0.
adgamaan = 0.
adgamold = 0.
do ip2 = 1, 3
do ip1 = 1, 2
adgams(ip1,ip2) = 0.
end do
end do
adgasqd = 0.
adgnh3 = 0.
adgno3 = 0.
adkw2 = 0.
adman = 0.
admas = 0.
admnh4 = 0.
adrr1 = 0.
adrr2 = 0.
adso4 = 0.
adtmasshno3 = 0.
adtnh4 = 0.
adtno3 = 0.
adtso4 = 0.
adtwoso4 = 0.
adwh2o = 0.
adwsqd = 0.
adxno3 = 0.
adxxq = 0.
adynh4 = 0.
C----------------------------------------------
C ROUTINE BODY
C----------------------------------------------
C----------------------------------------------
C FUNCTION AND TAPE COMPUTATIONS
C----------------------------------------------
so4 = in(1)
gno3 = in(2)
gnh3 = in(3)
ano3 = in(4)
anh4 = in(5)
rh = par(1)
temp = par(2)
tso4 = max(floor,so4/mwso4)
tno3 = max(0.d0,ano3/mwno3+gno3/mwhno3)
tnh4 = max(0.d0,gnh3/mwnh3+anh4/mwnh4)
tmasshno3 = max(0.d0,gno3+ano3)
irh = nint(100.*rh)
irh = max(1,irh)
irh = min(99,irh)
t6 = 8.2d-11*temp
t1 = 298.d0/temp
t2 = log(t1)
t3 = t1-1.d0
t4 = 1.d0+t2-t1
kna = 2511000.d0*exp(29.17d0*t3+16.83d0*t4)*t6
k1a = 0.00001805d0*exp((-(1.5d0*t3))+26.92d0*t4)
kw = 1.01d-14*exp((-(22.52d0*t3))+26.92d0*t4)
kph = 57.639d0*exp(13.79d0*t3-5.39d0*t4)*t6
khat = kph*k1a/kw
kan = kna*khat
toler1 = 0.00001d0
gamold = 1.d0
gamaan = 0.1
twoso4 = 2.*tso4
ynh4 = twoso4
call awater( irh,tso4,ynh4,tno3,ah2o )
wh2o = 0.001d0*ah2o
aso4 = tso4*mwso4
ahso4 = 0.d0
ano3 = 0.d0
anh4 = ynh4*mwnh4
ynh4 = twoso4
nnn = 0
converged = .false.
idow = 0
!The following section is used by TAMC to recompute idow.
!We comment this out and use the values from nitr_max
! do while (converged .eq. .false. .or. nnn .gt. 50 )
! idow = idow+1
! nnn = nnn+1
! gasqd = gamaan*gamaan
! wsqd = wh2o*wh2o
! kw2 = kan*wsqd/gasqd
! aa = 1.-kw2
! bb = twoso4+kw2*(tno3+tnh4-twoso4)
! cc = -(kw2*tno3*(tnh4-twoso4))
! disc = bb*bb-4.*aa*cc
! if (aa .ne. 0.d0) then
! dd = sqrt(disc)
! xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd))
! rr1 = xxq/aa
! rr2 = cc/xxq
! if (rr1*rr2 .lt. 0.d0) then
! xno3 = max(rr1,rr2)
! else
! xno3 = min(rr1,rr2)
! endif
! else
! xno3 = -(cc/bb)
! endif
! xno3 = min(xno3,tno3)
! call awater( irh,tso4,ynh4,xno3,ah2o )
! wh2o = 0.001*ah2o
! man = xno3/wh2o
! mas = tso4/wh2o
! mnh4 = 2.*mas+man
! ynh4 = mnh4*wh2o
! cat(1) = 0.
! cat(2) = mnh4
! an(1) = mas
! an(2) = man
! an(3) = 0.
! call actcof( cat,an,gams,molnu,phibar )
! gamaan = gams(2,2)
! eror = abs(gamold-gamaan)/gamold
! gamold = gamaan
! if (eror .le. toler1) then
! aso4 = tso4*mwso4
! ahso4 = 0.
! ano3 = xno3*mwno3
! anh4 = ynh4*mwnh4
! gno3 = max(floor,tmasshno3-ano3)
! gnh3 = mwnh3*max(floor,tnh4-ynh4)
! converged = .true.
! endif
! end do
! call adstore( 'memory_1_rpmares_idow',21,idow,4,1,1 )
! out(1) = aso4
! out(2) = ahso4
! out(3) = ano3
! out(4) = ah2o
! out(5) = anh4
! out(6) = so4
! out(7) = gno3
! out(8) = gnh3
idow = nitr_max(I,J,L)
C----------------------------------------------
C ADJOINT COMPUTATIONS
C----------------------------------------------
ano3 = in(4)
adgnh3 = adgnh3+adout(8)
adout(8) = 0.d0
adgno3 = adgno3+adout(7)
adout(7) = 0.d0
adso4 = adso4+adout(6)
adout(6) = 0.d0
adanh4 = adanh4+adout(5)
adout(5) = 0.d0
adah2o = adah2o+adout(4)
adout(4) = 0.d0
adano3 = adano3+adout(3)
adout(3) = 0.d0
adout(2) = 0.d0
adaso4 = adaso4+adout(1)
adout(1) = 0.d0
!call adresto( 'memory_1_rpmares_idow',21,idow,4,1,1 )
ndow = idow
do idow = ndow, 1, -1
gamaan = 0.1
ynh4 = twoso4
call awater( irh,tso4,ynh4,tno3,ah2o )
wh2o = 0.001d0*ah2o
ynh4 = twoso4
! The following section is used to recompute gamaan, ynh4 and
! wh20 at each iteration. Instead, comment this out and use
! the checkpointed variables xxx_fwd.
! do idow2 = 1, idow-1
! gasqd = gamaan*gamaan
! wsqd = wh2o*wh2o
! kw2 = kan*wsqd/gasqd
! aa = 1.-kw2
! bb = twoso4+kw2*(tno3+tnh4-twoso4)
! cc = -(kw2*tno3*(tnh4-twoso4))
! disc = bb*bb-4.*aa*cc
! if (aa .ne. 0.d0) then
! dd = sqrt(disc)
! xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd))
! rr1 = xxq/aa
! rr2 = cc/xxq
! if (rr1*rr2 .lt. 0.d0) then
! xno3 = max(rr1,rr2)
! else
! xno3 = min(rr1,rr2)
! endif
! else
! xno3 = -(cc/bb)
! endif
! xno3 = min(xno3,tno3)
! call awater( irh,tso4,ynh4,xno3,ah2o )
! wh2o = 0.001*ah2o
! man = xno3/wh2o
! mas = tso4/wh2o
! mnh4 = 2.*mas+man
! ynh4 = mnh4*wh2o
! cat(1) = 0.
! cat(2) = mnh4
! an(1) = mas
! an(2) = man
! an(3) = 0.
! call actcof( cat,an,gams,molnu,phibar )
! gamaan = gams(2,2)
! gamold = gamaan
! end do
IF ( idow .gt. 1 ) THEN
gamaan = gamaan_fwd(I,J,L,idow-1)
wh2o = wh2o_fwd(I,J,L,idow-1)
ynh4 = ynh4_fwd(I,J,L,idow-1)
ENDIF
gamold = gamaan
ynh4i = ynh4
wh2oi = wh2o
gamaani = gamaan
gasqd = gamaan*gamaan
wsqd = wh2o*wh2o
kw2 = kan*wsqd/gasqd
aa = 1.-kw2
bb = twoso4+kw2*(tno3+tnh4-twoso4)
cc = -(kw2*tno3*(tnh4-twoso4))
disc = bb*bb-4.*aa*cc
if (aa .ne. 0.d0) then
dd = sqrt(disc)
xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd))
rr1 = xxq/aa
rr2 = cc/xxq
if (rr1*rr2 .lt. 0.d0) then
xno3 = max(rr1,rr2)
else
xno3 = min(rr1,rr2)
endif
else
xno3 = -(cc/bb)
endif
xno3 = min(xno3,tno3)
call awater( irh,tso4,ynh4,xno3,ah2o )
wh2o = 0.001*ah2o
man = xno3/wh2o
mas = tso4/wh2o
mnh4 = 2.*mas+man
ynh4 = mnh4*wh2o
cat(1) = 0.
cat(2) = mnh4
an(1) = mas
an(2) = man
an(3) = 0.
call actcof( cat,an,gams,molnu,phibar )
gamaan = gams(2,2)
eror = abs(gamold-gamaan)/gamold
if (eror .le. toler1) then
ano3 = xno3*mwno3
adwh2o = adwh2o+1000*adah2o
adah2o = 0.
adtnh4 = adtnh4+adgnh3*mwnh3*(0.5-sign(0.5,floor-(tnh4-ynh4)))
adynh4 = adynh4-adgnh3*mwnh3*(0.5-sign(0.5,floor-(tnh4-ynh4)))
adgnh3 = 0.
adano3 = adano3-adgno3*(0.5-sign(0.5,floor-(tmasshno3-ano3)))
adtmasshno3 = adtmasshno3+adgno3*(0.5-sign(0.5,floor-
$(tmasshno3-ano3)))
adgno3 = 0.
adynh4 = adynh4+adanh4*mwnh4
adanh4 = 0.
adxno3 = adxno3+adano3*mwno3
adano3 = 0.
adtso4 = adtso4+adaso4*mwso4
adaso4 = 0.
endif
adgamaan = adgamaan+adgamold
adgamold = 0.
aderori = aderor/gamold
adgamold = adgamold-aderor*(abs(gamold-gamaan)/(gamold*gamold))
adgamaan = adgamaan-aderori*sign(1.,gamold-gamaan)
adgamold = adgamold+aderori*sign(1.,gamold-gamaan)
aderor = 0.
adgams(2,2) = adgams(2,2)+adgamaan
adgamaan = 0.
call adactcof( cat,an,adcat,adan,adgams )
adan(3) = 0.
adman = adman+adan(2)
adan(2) = 0.
admas = admas+adan(1)
adan(1) = 0.
admnh4 = admnh4+adcat(2)
adcat(2) = 0.
adcat(1) = 0.
admnh4 = admnh4+adynh4*wh2o
adwh2o = adwh2o+adynh4*mnh4
adynh4 = 0.
adman = adman+admnh4
admas = admas+2*admnh4
admnh4 = 0.
adtso4 = adtso4+admas/wh2o
adwh2o = adwh2o-admas*(tso4/(wh2o*wh2o))
admas = 0.
adwh2o = adwh2o-adman*(xno3/(wh2o*wh2o))
adxno3 = adxno3+adman/wh2o
adman = 0.
adah2o = adah2o+0.001*adwh2o
adwh2o = 0.
ynh4 = ynh4i
call adawater( irh,tso4,ynh4,xno3,adtso4,adynh4,adxno3,adah2o )
if (aa .ne. 0.d0) then
dd = sqrt(disc)
xxq = -(0.5d0*(bb+sign(1.d0,bb)*dd))
rr1 = xxq/aa
rr2 = cc/xxq
if (rr1*rr2 .lt. 0.d0) then
xno3 = max(rr1,rr2)
else
xno3 = min(rr1,rr2)
endif
else
xno3 = -(cc/bb)
endif
adtno3 = adtno3+adxno3*(0.5-sign(0.5,tno3-xno3))
adxno3 = adxno3*(0.5+sign(0.5,tno3-xno3))
if (aa .ne. 0.d0) then
if (rr1*rr2 .lt. 0.d0) then
adrr1 = adrr1+adxno3*(0.5+sign(0.5,rr1-rr2))
adrr2 = adrr2+adxno3*(0.5-sign(0.5,rr1-rr2))
adxno3 = 0.
else
adrr1 = adrr1+adxno3*(0.5+sign(0.5,rr2-rr1))
adrr2 = adrr2+adxno3*(0.5-sign(0.5,rr2-rr1))
adxno3 = 0.
endif
adcc = adcc+adrr2/xxq
adxxq = adxxq-adrr2*(cc/(xxq*xxq))
adrr2 = 0.
adaa = adaa-adrr1*(xxq/(aa*aa))
adxxq = adxxq+adrr1/aa
adrr1 = 0.
adbb = adbb-0.5d0*adxxq
addd = addd-0.5d0*adxxq*sign(1.d0,bb)
adxxq = 0.
addisc = addisc+addd*(1./(2.*sqrt(disc)))
addd = 0.
else
adbb = adbb+adxno3*(cc/(bb*bb))
adcc = adcc-adxno3/bb
adxno3 = 0.
endif
adaa = adaa-4*addisc*cc
adbb = adbb+2*addisc*bb
adcc = adcc-4*addisc*aa
addisc = 0.
adkw2 = adkw2-adcc*tno3*(tnh4-twoso4)
adtnh4 = adtnh4-adcc*kw2*tno3
adtno3 = adtno3-adcc*kw2*(tnh4-twoso4)
adtwoso4 = adtwoso4+adcc*kw2*tno3
adcc = 0.
adkw2 = adkw2+adbb*(tno3+tnh4-twoso4)
adtnh4 = adtnh4+adbb*kw2
adtno3 = adtno3+adbb*kw2
adtwoso4 = adtwoso4+adbb*(1-kw2)
adbb = 0.
adkw2 = adkw2-adaa
adaa = 0.
adgasqd = adgasqd-adkw2*(kan*wsqd/(gasqd*gasqd))
adwsqd = adwsqd+adkw2*(kan/gasqd)
adkw2 = 0.
wh2o = wh2oi
adwh2o = adwh2o+2*adwsqd*wh2o
adwsqd = 0.
gamaan = gamaani
adgamaan = adgamaan+2*adgasqd*gamaan
adgasqd = 0.
end do
adtwoso4 = adtwoso4+adynh4
adynh4 = 0.
adah2o = adah2o+0.001d0*adwh2o
adwh2o = 0.
ynh4 = twoso4
call adawater( irh,tso4,ynh4,tno3,adtso4,adynh4,adtno3,adah2o )
adtwoso4 = adtwoso4+adynh4
adynh4 = 0.
adtso4 = adtso4+2*adtwoso4
adtwoso4 = 0.
ano3 = in(4)
adano3 = adano3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3)))
adgno3 = adgno3+adtmasshno3*(0.5-sign(0.5d0,0.d0-(gno3+ano3)))
adtmasshno3 = 0.
anh4 = in(5)
adanh4 = adanh4+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh4)
adgnh3 = adgnh3+adtnh4*((0.5-sign(0.5d0,0.d0-(gnh3/mwnh3+anh4/
$mwnh4)))/mwnh3)
adtnh4 = 0.
adano3 = adano3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwno3)
adgno3 = adgno3+adtno3*((0.5-sign(0.5d0,0.d0-(ano3/mwno3+gno3/
$mwhno3)))/mwhno3)
adtno3 = 0.
adso4 = adso4+adtso4*((0.5-sign(0.5,floor-so4/mwso4))/mwso4)
adtso4 = 0.
adin(5) = adin(5)+adanh4
adanh4 = 0.
adin(4) = adin(4)+adano3
adano3 = 0.
adin(3) = adin(3)+adgnh3
adgnh3 = 0.
adin(2) = adin(2)+adgno3
adgno3 = 0.
adin(1) = adin(1)+adso4
adso4 = 0.
end SUBROUTINE ADRPMARES_6_D5
!------------------------------------------------------------------------------
! End of module
END MODULE RPMARES_ADJ_MOD
Reference in New Issue View Git Blame Copy Permalink