From c7ac7673cc6c456a2ba415599b0d99c6a4075ef2 Mon Sep 17 00:00:00 2001 From: "Xuesong (Steve)" Date: Tue, 28 Aug 2018 00:39:32 -0400 Subject: [PATCH] Add files via upload --- code/new/adBuffer.c | 356 + code/new/adStack.c | 571 + code/new/blas.f | 261 + code/new/isoropiaII_adj_mod.f | 1845 ++ code/new/isoropiaIIcode_adj.f | 32408 ++++++++++++++++++++++++++++++++ code/new/isrpia_adj.inc | 551 + code/new/linoz.com | 38 + code/new/linoz_mod.f | 1434 ++ code/new/linpack.f | 218 + code/new/netcdf_util_mod.f | 1102 ++ code/new/routines.f | 3955 ++++ code/new/strat_chem_mod.f | 1224 ++ code/new/timer.f | 32 + 13 files changed, 43995 insertions(+) create mode 100644 code/new/adBuffer.c create mode 100644 code/new/adStack.c create mode 100644 code/new/blas.f create mode 100644 code/new/isoropiaII_adj_mod.f create mode 100644 code/new/isoropiaIIcode_adj.f create mode 100644 code/new/isrpia_adj.inc create mode 100644 code/new/linoz.com create mode 100644 code/new/linoz_mod.f create mode 100644 code/new/linpack.f create mode 100644 code/new/netcdf_util_mod.f create mode 100644 code/new/routines.f create mode 100644 code/new/strat_chem_mod.f create mode 100644 code/new/timer.f diff --git a/code/new/adBuffer.c b/code/new/adBuffer.c new file mode 100644 index 0000000..5ee91a5 --- /dev/null +++ b/code/new/adBuffer.c @@ -0,0 +1,356 @@ +/* +C implementation of C$Id: adBuffer.f 3723 2011-02-24 13:34:42Z llh $ + +Replac the faulty PUSH/POPs by assignments to/from local arrays, +each of them being declared localized to its thread, make it +thread-safe for OPENMP. + +If the OPENMP THREAD NUMBER IS GREATER THAN 256 on a single node, +the STACK_POOL_SEZE needs to be increased. + +This portion just ported the necessary codes which used by WRFPLUS +from adBuffer.f, NOT THE WHOLE CODES. +Check it carefully before using for your own case. + +2011-10-10 jliu@ucar.edu +*/ + +#include +#include +#include + +/* +#ifdef _OPENMP +*/ +#include +#define STACK_POOL_SIZE 256 +/* +#else +#define omp_get_thread_num() 0 +#define STACK_POOL_SIZE 1 +#endif +*/ +#define BUFF_SIZE 512 + +#define bit_set(x,y) ((x) | ((unsigned long)0x00000001 << (y))) +#define bit_clear(x,y) ((x) & ~((unsigned long)0x00000001 << (y))) +#define bit_test(x,y) ((x) >> (y) & (unsigned long)0x00000001) + +typedef int logical; + +static int c__1 = 1; +static int c__512 = 512; +static int c_n512 = -512; +static int c__4 = 4; +static int c_n2048 = -2048; +static int c__8 = 8; +static int c_n4096 = -4096; +static int c__16 = 16; +static int c_n8192 = -8192; +static int c_b101 = 1000000; +static int c__9 = 9; +static int c__3 = 3; + +static int adbitbuf[STACK_POOL_SIZE] = {0}; +static int adbitibuf[STACK_POOL_SIZE] = {0}; + +static int *adi4buf[STACK_POOL_SIZE] = {NULL}; +static int adi4ibuf[STACK_POOL_SIZE] = {0}; + +static double *adr8buf[STACK_POOL_SIZE] = {NULL}; +static int adr8ibuf[STACK_POOL_SIZE] = {0}; + +static int i4arrnum = 0; +static int r8arrnum = 0; + +static int i4num = 0; +static int r8num = 0; + +void print_ulong_bin(const unsigned long * const var, int bits) { + int i; + + #if defined(__LP64__) || defined(_LP64) + if( (bits > 64) || (bits <= 0) ) + #else + if( (bits > 32) || (bits <= 0) ) + #endif + return; + + for(i = 0; i < bits; i++) { + printf("%lu", (*var >> (bits - 1 - i)) & 0x01); + } + printf("\n"); +} + +/* ========================= BITS ============================*/ +int pushbit_( logical *bit ) +{ + int thread_id = omp_get_thread_num(); + + //printf("thread %i push %i bit %i\n", thread_id, *bit, adbitibuf[thread_id]); + + if (*bit) { + adbitbuf[thread_id] = bit_set(adbitbuf[thread_id], + adbitibuf[thread_id]); + } else { + adbitbuf[thread_id] = bit_clear(adbitbuf[thread_id], + adbitibuf[thread_id]); + } + if (adbitibuf[thread_id] == 31) { + //printf("thread %02i : pushbit : pushinteger4 %03i : ",thread_id, i4num++); + //print_ulong_bin(&adbitbuf[thread_id],32); + pushinteger4_(&adbitbuf[thread_id]); + adbitbuf[thread_id]=0; + adbitibuf[thread_id]=0; + } else { + adbitibuf[thread_id]++; + } + return 0; +} + +logical popbit_(void) +{ + logical ret_val; + int thread_id = omp_get_thread_num(); + if ( adbitibuf[thread_id] == 0 ) { + //printf("thread %02i : popbit : popinteger4 %03i : ",thread_id, --i4num); + //print_ulong_bin(&adbitbuf[thread_id],32); + popinteger4_(&adbitbuf[thread_id]); + adbitibuf[thread_id]=31; + } else { + adbitibuf[thread_id]--; + } + ret_val = bit_test(adbitbuf[thread_id], adbitibuf[thread_id]); + //printf("thread %i pop %i bit %i\n", thread_id, ret_val, adbitibuf[thread_id]); + return ret_val; +} + +/* ========================= CONTROL ========================= */ + +int pushcontrol1b_(int *cc) +{ + logical L; + L = *cc != 0; + pushbit_(&L); + return 0; +} + +int popcontrol1b_(int *cc) +{ + if (popbit_()) { + *cc = 1; + } else { + *cc = 0; + } + return 0; +} + +int pushcontrol2b_(int *cc) +{ + logical L; + L = bit_test(*cc,0); + pushbit_(&L); + L = bit_test(*cc,1); + pushbit_(&L); + return 0; +} + +int popcontrol2b_(int *cc) +{ + if (popbit_()) { + *cc = 2; + } else { + *cc = 0; + } + if (popbit_()) { + *cc = bit_set(*cc,0); + } + return 0; +} + +int pushcontrol3b_(int *cc) +{ + logical L; + L = bit_test(*cc,0); + pushbit_(&L); + L = bit_test(*cc,1); + pushbit_(&L); + L = bit_test(*cc,2); + pushbit_(&L); + return 0; +} + +int popcontrol3b_(int *cc) +{ + if (popbit_()) { + *cc = 4; + } else { + *cc = 0; + } + if (popbit_()) { + *cc = bit_set(*cc,1); + } + if (popbit_()) { + *cc = bit_set(*cc,0); + } + return 0; +} + +int pushcontrol4b_(int *cc) +{ + logical L; + L = bit_test(*cc,0); + pushbit_(&L); + L = bit_test(*cc,1); + pushbit_(&L); + L = bit_test(*cc,2); + pushbit_(&L); + L = bit_test(*cc,3); + pushbit_(&L); + return 0; +} + +int popcontrol4b_(int *cc) +{ + if (popbit_()) { + *cc = 8; + } else { + *cc = 0; + } + if (popbit_()) { + *cc = bit_set(*cc,2); + } + if (popbit_()) { + *cc = bit_set(*cc,1); + } + if (popbit_()) { + *cc = bit_set(*cc,0); + } + return 0; +} + +int pushcontrol5b_(int *cc) +{ + logical L; + L = bit_test(*cc,0); + pushbit_(&L); + L = bit_test(*cc,1); + pushbit_(&L); + L = bit_test(*cc,2); + pushbit_(&L); + L = bit_test(*cc,3); + pushbit_(&L); + L = bit_test(*cc,4); + pushbit_(&L); + return 0; +} + +int popcontrol5b_(int *cc) +{ + if (popbit_()) { + *cc = 16; + } else { + *cc = 0; + } + if (popbit_()) { + *cc = bit_set(*cc,3); + } + if (popbit_()) { + *cc = bit_set(*cc,2); + } + if (popbit_()) { + *cc = bit_set(*cc,1); + } + if (popbit_()) { + *cc = bit_set(*cc,0); + } + return 0; +} + +/* ======================= INTEGER*4 =========================: */ + +int pushinteger4_(int *x) +{ + int thread_id = omp_get_thread_num(); + + if ( adi4buf[thread_id] == NULL ) { + int *buf = (int*)calloc(BUFF_SIZE, sizeof(int)); + if ( buf == NULL ) { + puts("Memory allocation failed."); + exit(0); + } + adi4buf[thread_id] = buf; + } + adi4buf[thread_id][adi4ibuf[thread_id]] = *x; + ++adi4ibuf[thread_id]; + if ( adi4ibuf[thread_id] == BUFF_SIZE) { + //printf("thread %02i : pushinteger4 : pushinteger4array : %04i : ", thread_id, ++i4arrnum); + //printf("[0]: %i [%i] : %i\n",adi4buf[thread_id][0], adi4ibuf[thread_id]-1, adi4buf[thread_id][adi4ibuf[thread_id]-1]); + pushinteger4array_(adi4buf[thread_id], &c__512); + adi4ibuf[thread_id] = 0 ; + } + //printf("thread %i pushinteger4 %i buff %i\n ", thread_id, *x, adi4ibuf[thread_id]); + return 0; +} + +int popinteger4_(int *x) +{ + int thread_id = omp_get_thread_num(); + + if ( adi4ibuf[thread_id] == 0 ) { + popinteger4array_(adi4buf[thread_id], &c__512); + adi4ibuf[thread_id] = BUFF_SIZE; + //printf("thread %02i : popinteger4 : popinteger4array : %04i : ", thread_id, i4arrnum--); + //printf("[0]: %i [%i] : %i\n",adi4buf[thread_id][0], adi4ibuf[thread_id]-1, adi4buf[thread_id][adi4ibuf[thread_id]-1]); + } + --adi4ibuf[thread_id]; + *x = adi4buf[thread_id][adi4ibuf[thread_id]]; + //printf("thread %i popinteger4 %i buff %i\n", thread_id, *x, adi4ibuf[thread_id]); + return 0; +} + +/* ======================= REAL*8 ========================= */ +int pushreal8_(double *x) +{ + int thread_id = omp_get_thread_num(); + + if (adr8buf[thread_id] == NULL ) { + double *buf = (double*)calloc(BUFF_SIZE, sizeof(double)); + if ( buf == NULL ) { + puts("Memory allocation failed."); + exit(0); + } + adr8buf[thread_id] = buf; + } + adr8buf[thread_id][adr8ibuf[thread_id]] = *x; + ++adr8ibuf[thread_id]; + if ( adr8ibuf[thread_id] == BUFF_SIZE) { + + //printf("thread %02i : pushreal8 : pushreal8array : %04i : ", thread_id, ++r8arrnum); + //printf("[0]: %f [%i] : %f\n",adr8buf[thread_id][0], adr8ibuf[thread_id]-1, adr8buf[thread_id][adr8ibuf[thread_id]-1]); + + pushreal8array_(adr8buf[thread_id], &c__512); + adr8ibuf[thread_id] = 0 ; + } + //printf("thread %i pushreal8 %f buff %i\n", thread_id, *x,adr8ibuf[thread_id] ); + return 0; +} + +int popreal8_(double *x) +{ + int thread_id = omp_get_thread_num(); + + if ( adr8ibuf[thread_id] == 0 ) { + popreal8array_(adr8buf[thread_id], &c__512); + adr8ibuf[thread_id] = BUFF_SIZE; + + //printf("thread %02i : popreal8 : popreal8array : %04i : ", thread_id, r8arrnum--); + //printf("[0]: %f [%i] : %f\n",adr8buf[thread_id][0], adr8ibuf[thread_id]-1, adr8buf[thread_id][adr8ibuf[thread_id]-1]); + + } + --adr8ibuf[thread_id]; + *x = adr8buf[thread_id][adr8ibuf[thread_id]]; + //printf("thread %i popreal8 %f buff %i\n", thread_id, *x, adr8ibuf[thread_id]); + return 0; +} + diff --git a/code/new/adStack.c b/code/new/adStack.c new file mode 100644 index 0000000..07fe9c7 --- /dev/null +++ b/code/new/adStack.c @@ -0,0 +1,571 @@ +static char adSid[]="$Id: adStack.c 3723 2011-02-24 13:34:42Z llh $"; +/* +Replac the faulty PUSH/POPs by assignments to/from local arrays, +each of them being declared localized to its thread, make it +thread-safe for OPENMP. + +If the OPENMP THREAD NUMBER IS GREATER THAN 256 on a single node, +the STACK_POOL_SEZE needs to be increased. + +Please beware of this portion that just amended the necessary codes +which used by WRFPLUS to make it thread-safe, NOT THE WHOLE CODES. +Check it carefully before using for your own case. + +2011-10-10 jliu@ucar.edu + +*/ + +#ifndef CRAY +# ifdef NOUNDERSCORE +# define PUSHINTEGER4ARRAY pushinteger4array +# define POPINTEGER4ARRAY popinteger4array +# define PUSHREAL8ARRAY pushreal8array +# define POPREAL8ARRAY popreal8array +# else +# define PUSHINTEGER4ARRAY pushinteger4array_ +# define POPINTEGER4ARRAY popinteger4array_ +# define PUSHREAL8ARRAY pushreal8array_ +# define POPREAL8ARRAY popreal8array_ +# endif +#endif + + +#include +#include +#include + +/* +#ifdef _OPENMP +*/ +#include +#define STACK_POOL_SIZE 256 +/* +#else +#define omp_get_thread_num() 0 +#define STACK_POOL_SIZE 1 +#endif +*/ + +#define ONE_BLOCK_SIZE 16384 +#ifndef STACK_SIZE_TRACING +#define STACK_SIZE_TRACING 1 +#endif +/* The main stack is a double-chain of DoubleChainedBlock objects. + * Each DoubleChainedBlock holds an array[ONE_BLOCK_SIZE] of char. */ +typedef struct _doubleChainedBlock{ + struct _doubleChainedBlock *prev ; + char *contents ; + struct _doubleChainedBlock *next ; +} DoubleChainedBlock ; + +/* Globals that define the current position in the stack: */ +static DoubleChainedBlock *curStack[STACK_POOL_SIZE] = {NULL} ; +static char *curStackTop[STACK_POOL_SIZE] = {NULL} ; +/* Globals that define the current LOOKing position in the stack: */ +static DoubleChainedBlock *lookStack[STACK_POOL_SIZE] = {NULL} ; +static char *lookStackTop[STACK_POOL_SIZE] = {NULL} ; + +static long int mmctraffic = 0 ; +static long int mmctrafficM = 0 ; +#ifdef STACK_SIZE_TRACING +long int bigStackSize = 0; +#endif + +/* PUSHes "nbChars" consecutive chars from a location starting at address "x". + * Resets the LOOKing position if it was active. + * Checks that there is enough space left to hold "nbChars" chars. + * Otherwise, allocates the necessary space. */ +void pushNarray(char *x, unsigned int nbChars) { + int thread_id = omp_get_thread_num(); + unsigned int nbmax = (curStack[thread_id])?ONE_BLOCK_SIZE-(curStackTop[thread_id]-(curStack[thread_id]->contents)):0 ; +#ifdef STACK_SIZE_TRACING + bigStackSize += nbChars; +#endif + + mmctraffic += nbChars ; + while (mmctraffic >= 1000000) { + mmctraffic -= 1000000 ; + mmctrafficM++ ; + } + + lookStack[thread_id] = NULL ; + if (nbChars <= nbmax) { + memcpy(curStackTop[thread_id],x,nbChars) ; + curStackTop[thread_id]+=nbChars ; + } else { + char *inx = x+(nbChars-nbmax) ; + if (nbmax>0) memcpy(curStackTop[thread_id],inx,nbmax) ; + while (inx>x) { + if ((curStack[thread_id] == NULL) || (curStack[thread_id]->next == NULL)) { + /* Create new block: */ + DoubleChainedBlock *newStack ; + char *contents = (char*)malloc(ONE_BLOCK_SIZE*sizeof(char)) ; + newStack = (DoubleChainedBlock*)malloc(sizeof(DoubleChainedBlock)) ; + if ((contents == NULL) || (newStack == NULL)) { + DoubleChainedBlock *stack = curStack[thread_id] ; + int nbBlocks = (stack?-1:0) ; + while(stack) { + stack = stack->prev ; + nbBlocks++ ; + } + printf("Out of memory (allocated %i blocks of %i bytes)\n", + nbBlocks, ONE_BLOCK_SIZE) ; + exit(0); + } + if (curStack[thread_id] != NULL) curStack[thread_id]->next = newStack ; + newStack->prev = curStack[thread_id] ; + newStack->next = NULL ; + newStack->contents = contents ; + curStack[thread_id] = newStack ; + /* new block created! */ + } else + curStack[thread_id] = curStack[thread_id]->next ; + inx -= ONE_BLOCK_SIZE ; + if(inx>x) + memcpy(curStack[thread_id]->contents,inx,ONE_BLOCK_SIZE) ; + else { + unsigned int nbhead = (inx-x)+ONE_BLOCK_SIZE ; + curStackTop[thread_id] = curStack[thread_id]->contents ; + memcpy(curStackTop[thread_id],x,nbhead) ; + curStackTop[thread_id] += nbhead ; + } + } + } +} + +/* POPs "nbChars" consecutive chars to a location starting at address "x". + * Resets the LOOKing position if it was active. + * Checks that there is enough data to fill "nbChars" chars. + * Otherwise, pops as many blocks as necessary. */ +void popNarray(char *x, unsigned int nbChars) { + int thread_id = omp_get_thread_num(); + unsigned int nbmax = curStackTop[thread_id]-(curStack[thread_id]->contents) ; +#ifdef STACK_SIZE_TRACING + bigStackSize -= nbChars; +#endif + lookStack[thread_id] = NULL ; + if (nbChars <= nbmax) { + curStackTop[thread_id]-=nbChars ; + memcpy(x,curStackTop[thread_id],nbChars); + } else { + char *tlx = x+nbChars ; + if (nbmax>0) memcpy(x,curStack[thread_id]->contents,nbmax) ; + x+=nbmax ; + while (xprev ; + if (curStack==NULL) printf("Popping from an empty stack!!!") ; + if (x+ONE_BLOCK_SIZEcontents,ONE_BLOCK_SIZE) ; + x += ONE_BLOCK_SIZE ; + } else { + unsigned int nbtail = tlx-x ; + curStackTop[thread_id]=(curStack[thread_id]->contents)+ONE_BLOCK_SIZE-nbtail ; + memcpy(x,curStackTop[thread_id],nbtail) ; + x = tlx ; + } + } + } +} + +/* LOOKs "nbChars" consecutive chars to a location starting at address "x". + * Activates the LOOKing position if it was reset. + * LOOKing is just like POPping, except that the main pointer + * remains in place, so that the value is not POPped. + * Further PUSHs or POPs will start from the same place as if + * no LOOK had been made. */ +void lookNarray(char *x, unsigned int nbChars) { + int thread_id = omp_get_thread_num(); + unsigned int nbmax ; + if (lookStack[thread_id] == NULL) { + lookStack[thread_id] = curStack[thread_id] ; + lookStackTop[thread_id] = curStackTop[thread_id] ; + } + nbmax = lookStackTop[thread_id]-(lookStack[thread_id]->contents) ; + if (nbChars <= nbmax) { + lookStackTop[thread_id]-=nbChars ; + memcpy(x,lookStackTop[thread_id],nbChars); + } else { + char *tlx = x+nbChars ; + if (nbmax>0) memcpy(x,lookStack[thread_id]->contents,nbmax) ; + x+=nbmax ; + while (xprev ; + if (lookStack[thread_id]==NULL) printf("Looking into an empty stack!!!") ; + if (x+ONE_BLOCK_SIZEcontents,ONE_BLOCK_SIZE) ; + x += ONE_BLOCK_SIZE ; + } else { + unsigned int nbtail = tlx-x ; + lookStackTop[thread_id]=(lookStack[thread_id]->contents)+ONE_BLOCK_SIZE-nbtail ; + memcpy(x,lookStackTop[thread_id],nbtail) ; + x = tlx ; + } + } + } +} + +void resetadlookstack_() { + int thread_id = omp_get_thread_num(); + lookStack[thread_id]=NULL ; +} + +/****** Exported PUSH/POP/LOOK functions for ARRAYS: ******/ + +void pushcharacterarray_(char *x, unsigned int *n) { + pushNarray(x,*n) ; +} +void popcharacterarray_(char *x, unsigned int *n) { + popNarray(x,*n) ; +} +void lookcharacterarray_(char *x, unsigned int *n) { + lookNarray(x,*n) ; +} + +void pushbooleanarray_(char *x, unsigned int *n) { + pushNarray(x,(*n*4)) ; +} +void popbooleanarray_(char *x, unsigned int *n) { + popNarray(x,(*n*4)) ; +} +void lookbooleanarray_(char *x, unsigned int *n) { + lookNarray(x,(*n*4)) ; +} + +void PUSHINTEGER4ARRAY(char *x, unsigned int *n) { + pushNarray(x,(*n*4)) ; +} +void POPINTEGER4ARRAY(char *x, unsigned int *n) { + popNarray(x,(*n*4)) ; +} +void lookinteger4array_(char *x, unsigned int *n) { + lookNarray(x,(*n*4)) ; +} + +void pushinteger8array_(char *x, unsigned int *n) { + pushNarray(x,(*n*8)) ; +} +void popinteger8array_(char *x, unsigned int *n) { + popNarray(x,(*n*8)) ; +} +void lookinteger8array_(char *x, unsigned int *n) { + lookNarray(x,(*n*8)) ; +} + +void pushinteger16array_(char *x, unsigned int *n) { + pushNarray(x,(*n*16)) ; +} +void popinteger16array_(char *x, unsigned int *n) { + popNarray(x,(*n*16)) ; +} +void lookinteger16array_(char *x, unsigned int *n) { + lookNarray(x,(*n*16)) ; +} + +void pushreal4array_(char *x, unsigned int *n) { + pushNarray(x,(*n*4)) ; +} +void popreal4array_(char *x, unsigned int *n) { + popNarray(x,(*n*4)) ; +} +void lookreal4array_(char *x, unsigned int *n) { + lookNarray(x,(*n*4)) ; +} + +void PUSHREAL8ARRAY(char *x, unsigned int *n) { + pushNarray(x,(*n*8)) ; +} +void POPREAL8ARRAY(char *x, unsigned int *n) { + popNarray(x,(*n*8)) ; +} +void lookreal8array_(char *x, unsigned int *n) { + lookNarray(x,(*n*8)) ; +} + +void pushreal16array_(char *x, unsigned int *n) { + pushNarray(x,(*n*16)) ; +} +void popreal16array_(char *x, unsigned int *n) { + popNarray(x,(*n*16)) ; +} +void lookreal16array_(char *x, unsigned int *n) { + lookNarray(x,(*n*16)) ; +} + +void pushreal32array_(char *x, unsigned int *n) { + pushNarray(x,(*n*32)) ; +} +void popreal32array_(char *x, unsigned int *n) { + popNarray(x,(*n*32)) ; +} +void lookreal32array_(char *x, unsigned int *n) { + lookNarray(x,(*n*32)) ; +} + +void pushcomplex4array_(char *x, unsigned int *n) { + pushNarray(x,(*n*4)) ; +} +void popcomplex4array_(char *x, unsigned int *n) { + popNarray(x,(*n*4)) ; +} +void lookcomplex4array_(char *x, unsigned int *n) { + lookNarray(x,(*n*4)) ; +} + +void pushcomplex8array_(char *x, unsigned int *n) { + pushNarray(x,(*n*8)) ; +} +void popcomplex8array_(char *x, unsigned int *n) { + popNarray(x,(*n*8)) ; +} +void lookcomplex8array_(char *x, unsigned int *n) { + lookNarray(x,(*n*8)) ; +} + +void pushcomplex16array_(char *x, unsigned int *n) { + pushNarray(x,(*n*16)) ; +} +void popcomplex16array_(char *x, unsigned int *n) { + popNarray(x,(*n*16)) ; +} +void lookcomplex16array_(char *x, unsigned int *n) { + lookNarray(x,(*n*16)) ; +} + +void pushcomplex32array_(char *x, unsigned int *n) { + pushNarray(x,(*n*32)) ; +} +void popcomplex32array_(char *x, unsigned int *n) { + popNarray(x,(*n*32)) ; +} +void lookcomplex32array_(char *x, unsigned int *n) { + lookNarray(x,(*n*32)) ; +} + +/****** Exported PUSH/POP/LOOK functions for F95 POINTERS: ******/ + +/* IMPORTANT: Don't forget to add the following interface into each calling routines: + + INTERFACE + SUBROUTINE PUSHPOINTER(pp) + REAL, POINTER :: pp + END SUBROUTINE PUSHPOINTER + SUBROUTINE POPPOINTER(pp) + REAL, POINTER :: pp + END SUBROUTINE POPPOINTER + END INTERFACE + +*/ + +void pushpointer_(char *ppp) { + pushNarray(ppp, 4) ; +} + +void poppointer_(char *ppp) { + popNarray(ppp, 4) ; +} + + +/************* Debug displays of the state of the stack: ***********/ + +void printbigbytes(long int nbblocks, long int blocksz, long int nbunits) { + long int a3, b3, res3, res6, res9, res12 ; + int a0, b0, res0 ; + int printzeros = 0 ; + a0 = (int)nbblocks%1000 ; + a3 = nbblocks/1000 ; + b0 = (int)blocksz%1000 ; + b3 = blocksz/1000 ; + res0 = ((int)(nbunits%1000)) + a0*b0 ; + res3 = nbunits/1000 + a3*b0 + a0*b3 ; + res6 = a3*b3 ; + res3 += ((long int)(res0/1000)) ; + res0 = res0%1000 ; + res6 += res3/1000 ; + res3 = res3%1000 ; + res9 = res6/1000 ; + res6 = res6%1000 ; + res12 = res9/1000 ; + res9 = res9%1000 ; + if (res12>0) { + printf("%li ", res12) ; + printzeros = 1 ; + } + if ((res9/100)>0 || printzeros) { + printf("%li",res9/100) ; + printzeros = 1 ; + res9 = res9%100 ; + } + if ((res9/10)>0 || printzeros) { + printf("%li",res9/10) ; + printzeros = 1 ; + res9 = res9%10 ; + } + if (res9>0 || printzeros) { + printf("%li ",res9) ; + printzeros = 1 ; + } + if ((res6/100)>0 || printzeros) { + printf("%li",res6/100) ; + printzeros = 1 ; + res6 = res6%100 ; + } + if ((res6/10)>0 || printzeros) { + printf("%li",res6/10) ; + printzeros = 1 ; + res6 = res6%10 ; + } + if (res6>0 || printzeros) { + printf("%li ",res6) ; + printzeros = 1 ; + } + if ((res3/100)>0 || printzeros) { + printf("%li",res3/100) ; + printzeros = 1 ; + res3 = res3%100 ; + } + if ((res3/10)>0 || printzeros) { + printf("%li",res3/10) ; + printzeros = 1 ; + res3 = res3%10 ; + } + if (res3>0 || printzeros) { + printf("%li ",res3) ; + printzeros = 1 ; + } + if ((res0/100)>0 || printzeros) { + printf("%i",res0/100) ; + printzeros = 1 ; + res0 = res0%100 ; + } + if ((res0/10)>0 || printzeros) { + printf("%i",res0/10) ; + printzeros = 1 ; + res0 = res0%10 ; + } + printf("%i",res0) ; +} + +void printctraffic_() { + printf(" C Traffic: ") ; + printbigbytes(mmctrafficM, 1000000, mmctraffic) ; + printf(" bytes\n") ; +} + +void printftrafficinc_(long int *mmfM, int *mmfsz, int *mmf) { + printf(" F Traffic: ") ; + printbigbytes(*mmfM, (long int)*mmfsz, (long int)*mmf) ; + printf(" bytes\n") ; +} + +void printtopplace_() { + int thread_id = omp_get_thread_num(); + DoubleChainedBlock *stack = curStack[thread_id] ; + int nbBlocks = (stack?-1:0) ; + int remainder = 0; + while(stack) { + stack = stack->prev ; + nbBlocks++ ; + } + if (curStack[thread_id] && curStackTop[thread_id]) remainder = curStackTop[thread_id]-(curStack[thread_id]->contents) ; + printf(" Stack size: ") ; + printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE, (long int)remainder) ; + printf(" bytes\n") ; +} + +void printtopplacenum_(int *n) { + int thread_id = omp_get_thread_num(); + DoubleChainedBlock *stack = curStack[thread_id] ; + int nbBlocks = (stack?-1:0) ; + int remainder = 0; + while(stack) { + stack = stack->prev ; + nbBlocks++ ; + } + if (curStack[thread_id] && curStackTop[thread_id]) remainder = curStackTop[thread_id]-(curStack[thread_id]->contents) ; + printf(" Stack size at location %i : ", *n) ; + printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE, (long int)remainder) ; + printf(" bytes\n") ; +} + +void printstackmax_() { + int thread_id = omp_get_thread_num(); + DoubleChainedBlock *stack = curStack[thread_id] ; + int nbBlocks = (stack?-2:0) ; + int remainder = 0; + long int totalsz ; + while(stack) { + stack = stack->prev ; + nbBlocks++ ; + } + stack = curStack[thread_id] ; + while(stack) { + stack = stack->next ; + nbBlocks++ ; + } + + printf(" Max Stack size (%i blocks): ", nbBlocks) ; + printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE, (long int)0) ; + printf(" bytes\n") ; +} + +void printlookingplace_() { + int thread_id = omp_get_thread_num(); + if (lookStack[thread_id] == NULL) + printtopplace_() ; + else { + DoubleChainedBlock *stack = lookStack[thread_id] ; + int nbBlocks = (stack?-1:0) ; + while(stack) { + stack = stack->prev ; + nbBlocks++ ; + } + printf(" Stack look at: ") ; + printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE, + ((long int)(lookStackTop[thread_id]-(lookStack[thread_id]->contents)))) ; + printf(" bytes\n") ; + } +} + +void showrecentcstack_() { + int thread_id = omp_get_thread_num(); + if (curStack[thread_id] && curStackTop[thread_id]) { + int totalNumChars = 30 ; + DoubleChainedBlock *stack = curStack[thread_id] ; + char *stackTop = curStackTop[thread_id] ; + unsigned short int *st1 ; + printf("TOP OF C STACK : ") ; + while (totalNumChars>0 && stackTop>(stack->contents)) { + stackTop-- ; + st1 = (unsigned short int *)stackTop ; + printf("%02X,",*st1%256) ; + totalNumChars-- ; + } + while (totalNumChars>0 && stack->prev) { + printf(" || ") ; + stack = stack->prev ; + stackTop = (stack->contents)+ONE_BLOCK_SIZE ; + while (totalNumChars>0 && stackTop>(stack->contents)) { + stackTop-- ; + st1 = (unsigned short int *)stackTop ; + printf("%02X,",*st1%256) ; + totalNumChars-- ; + } + } + if (stack->prev || stackTop>(stack->contents)) + printf(" ...\n") ; + else + printf(" || BOTTOM\n") ; + } else { + printf("NOTHING IN C STACK.\n") ; + } +} + +void getnbblocksinstack_(int *nbblocks) { + int thread_id = omp_get_thread_num(); + DoubleChainedBlock *stack = curStack[thread_id] ; + *nbblocks = 0 ; + while(stack) { + stack = stack->prev ; + (*nbblocks)++ ; + } +} diff --git a/code/new/blas.f b/code/new/blas.f new file mode 100644 index 0000000..2d63e96 --- /dev/null +++ b/code/new/blas.f @@ -0,0 +1,261 @@ +c +c L-BFGS-B is released under the “New BSD License” (aka “Modified BSD License” +c or “3-clause license”) +c Please read attached file License.txt +c + + double precision function dnrm2(n,x,incx) + integer n,incx + double precision x(n) +c ********** +c +c Function dnrm2 +c +c Given a vector x of length n, this function calculates the +c Euclidean norm of x with stride incx. +c +c The function statement is +c +c double precision function dnrm2(n,x,incx) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c incx is a positive integer variable that specifies the +c stride of the vector. +c +c Subprograms called +c +c FORTRAN-supplied ... abs, max, sqrt +c +c MINPACK-2 Project. February 1991. +c Argonne National Laboratory. +c Brett M. Averick. +c +c ********** + integer i + double precision scale + + dnrm2 = 0.0d0 + scale = 0.0d0 + + do 10 i = 1, n, incx + scale = max(scale, abs(x(i))) + 10 continue + + if (scale .eq. 0.0d0) return + + do 20 i = 1, n, incx + dnrm2 = dnrm2 + (x(i)/scale)**2 + 20 continue + + dnrm2 = scale*sqrt(dnrm2) + + + return + + end + +c====================== The end of dnrm2 =============================== + + subroutine daxpy(n,da,dx,incx,dy,incy) +c +c constant times a vector plus a vector. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c + double precision dx(*),dy(*),da + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if (da .eq. 0.0d0) return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dy(iy) + da*dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,4) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dy(i) + da*dx(i) + 30 continue + if( n .lt. 4 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,4 + dy(i) = dy(i) + da*dx(i) + dy(i + 1) = dy(i + 1) + da*dx(i + 1) + dy(i + 2) = dy(i + 2) + da*dx(i + 2) + dy(i + 3) = dy(i + 3) + da*dx(i + 3) + 50 continue + return + end + +c====================== The end of daxpy =============================== + + subroutine dcopy(n,dx,incx,dy,incy) +c +c copies a vector, x, to a vector, y. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + dy(i) = dx(i) + dy(i + 1) = dx(i + 1) + dy(i + 2) = dx(i + 2) + dy(i + 3) = dx(i + 3) + dy(i + 4) = dx(i + 4) + dy(i + 5) = dx(i + 5) + dy(i + 6) = dx(i + 6) + 50 continue + return + end + +c====================== The end of dcopy =============================== + + double precision function ddot(n,dx,incx,dy,incy) +c +c forms the dot product of two vectors. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + ddot = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dtemp + dx(ix)*dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ddot = dtemp + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dx(i)*dy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) + 50 continue + 60 ddot = dtemp + return + end + +c====================== The end of ddot ================================ + + subroutine dscal(n,da,dx,incx) +c +c scales a vector by a constant. +c uses unrolled loops for increment equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c + double precision da,dx(*) + integer i,incx,m,mp1,n,nincx +c + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + nincx = n*incx + do 10 i = 1,nincx,incx + dx(i) = da*dx(i) + 10 continue + return +c +c code for increment equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dx(i) = da*dx(i) + 30 continue + if( n .lt. 5 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dx(i) = da*dx(i) + dx(i + 1) = da*dx(i + 1) + dx(i + 2) = da*dx(i + 2) + dx(i + 3) = da*dx(i + 3) + dx(i + 4) = da*dx(i + 4) + 50 continue + return + end + +c====================== The end of dscal =============================== + diff --git a/code/new/isoropiaII_adj_mod.f b/code/new/isoropiaII_adj_mod.f new file mode 100644 index 0000000..99c0a9b --- /dev/null +++ b/code/new/isoropiaII_adj_mod.f @@ -0,0 +1,1845 @@ +!------------------------------------------------------------------------------ +! Caltech Department of Chemical Engineering / Seinfeld Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: isoropiaii_adj_mod +! +! !DESCRIPTION: Module ISOROPIAII_ADJ\_MOD contains the routines that provide +! the interface between ISORROPIA II and GEOS-Chem. +!\\ +!\\ +! The actual ANISORROPIA code which performs Na-SO4-NH3-NO3-Cl +! aerosol thermodynamic equilibrium is in \texttt{isoropiaIIcode_adj.f}. +!\\ +!\\ +! !INTERFACE: +! + MODULE ISOROPIAII_ADJ_MOD +! +! !USES: +! + IMPLICIT NONE + PRIVATE +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: CLEANUP_ISOROPIAII + PUBLIC :: DO_ISOROPIAII + PUBLIC :: DO_ISOROPIAII_ADJ + PUBLIC :: GET_GNO3 + PUBLIC :: GET_ISRINFO +! +! !PRIVATE MEMBER FUNCTIONS: +! + PRIVATE :: GET_HNO3 + PRIVATE :: INIT_ISOROPIAII + PRIVATE :: SAFELOG10 + PRIVATE :: SET_HNO3 +! +! !REMARKS: +! Original Author: +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! . +! Original v1.3 isoropia implementation into GEOS-Chem by +! Becky Alexander and Bob Yantosca (bec, bmy, 4/12/05, 11/2/05) +! . +! For Ca,K,Mg = 0, ISOROPIA II performs exactly like ISOROPIAv1.7 +! Ca, K, Mg, Na from dust is not currently considered +! . +! To implement ISOROPIA II into GEOS-Chem: +! * cleanup_isoropiaII needs to be called from cleanup.f +! * DO_ISOROPIA needs to be replaced with DO_ISOROPIAII in chemistry_mod.f +! * Change ISOROPIA to ISOROPIAII in sulfate_mod.f +! * add isoropiaII_mod.f, isoropiaIIcode.f, and irspia.inc to Makefile +! . +! ISOROPIA II implementation notes by Havala O.T. Pye: +! (1) The original isoropia code from T.Nenes is left as unmodified as +! possible. Original isoropia code can be found in isoropiaIIcode.f +! and common blocks can be found in isrpia.inc. For future upgrades +! to isoropia, replace isrpia.inc and isoropiaIIcode.f with the new +! version of isoropia and modify the call to ISOROPIA in this module. +! Please let the original author know of any changes made to ISOROPIA. +! (2) As of Nov 2007, routines using non-zero Ca, K, and Mg do not always +! conserve mass. Ca, K, and Mg are set to zero. +! . +! NOTE: ISORROPIA is Greek for "equilibrium", in case you were wondering. +! +! ANISORROPIA implementation in GEOS-Chem adjoint by +! Shannon Capps (slc, 8/22/2011) +! (1) As of Aug 2011, only Na-SO4-NH3-NO3-Cl routines have an adjoint. +! (2) Adjoint calculations require online activity coefficient calculation +! unlike the default configuration in GEOS-Chem that uses look up tables. +! Reference: doi:10.5194/acp-12-527-2012 +! +! !REVISION HISTORY: +! 06 Jul 2007 - H. O. T. Pye - Initial version +! 29 Jan 2010 - R. Yantosca - Added ProTeX headers +! 21 Apr 2010 - R. Yantosca - Bug fix in DO_ISOROPIAII for offline aerosol +! 22 Aug 2011 - S. Capps - ANISORROPIA implementation +! +! *** VERY IMPORTANT PORTING WARNING (slc.1.2012) *** +! ANISORROPIA code is optimized for adjoint frameworks and will not +! perform commensurately with publicly released ISORROPIAII code. +! +! Please visit http://nenes.eas.gatech.edu/ISORROPIA for current +! releases of ISORROPIAII for forward modeling. +! +!EOP +!------------------------------------------------------------------------------ +!BOC + ! Array for offline HNO3 (for relaxation of M.M.) + REAL*8, ALLOCATABLE :: HNO3_sav(:,:,:) + + ! Array for offline use in sulfate_mod (SEASALT_CHEM) + REAL*8, ALLOCATABLE :: GAS_HNO3(:,:,:) + + ! AEROPH: Save information related to aerosol pH (hotp 8/11/09) + REAL*8, ALLOCATABLE :: PH_SAV(:,:,:) + REAL*8, ALLOCATABLE :: HPLUS_SAV(:,:,:) + REAL*8, ALLOCATABLE :: WATER_SAV(:,:,:) + REAL*8, ALLOCATABLE :: SULRAT_SAV(:,:,:) + REAL*8, ALLOCATABLE :: NARAT_SAV(:,:,:) + REAL*8, ALLOCATABLE :: ACIDPUR_SAV(:,:,:) + + CONTAINS +!EOC +!------------------------------------------------------------------------------ +! Caltech Department of Chemical Engineering / Seinfeld Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: do_isoropiaii +! +! !DESCRIPTION: Subroutine DO\_ISOROPIAII is the interface between the +! GEOS-Chem model and the aerosol thermodynamical equilibrium routine +! ISORROPIA II. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE DO_ISOROPIAII +! +! !USES: +! + USE CHECKPT_MOD, ONLY : ANISO_IN + USE DAO_MOD, ONLY : AIRVOL, RH, T + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE ERROR_MOD, ONLY : SAFE_DIV + USE GLOBAL_HNO3_MOD, ONLY : GET_GLOBAL_HNO3 + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : GET_MONTH, ITS_A_NEW_MONTH + USE TRACER_MOD + USE TRACERID_MOD, ONLY : IDTHNO3, IDTNIT, IDTNH4, IDTNH3 + USE TRACERID_MOD, ONLY : IDTSALA, IDTSO4 + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT +! + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_ADJ_MOD, ONLY : LADJ + + +# include "CMN_SIZE" ! Size parameters +! +! !REMARKS: +! Original isoropia v1.3 implmentation: (rjp, bec, bmy, 12/17/01, 8/22/05) +! +! !REVISION HISTORY: +! 24 Aug 2007 - H. O. T. Pye - Initial version, in ISORROPIA II +! 18 Dec 2009 - H. O. T. Pye - Added division checks +! 29 Jan 2010 - R. Yantosca - Added ProTeX headers +! 21 Apr 2010 - E. Sofen - Prevent out-of-bounds errors for offline +! aerosol simulations where HNO3 is undefined +! 23 Jul 2010 - R. Yantosca - Bug fix: corrected typo in ND42 diag section +! 22 Aug 2011 - S. Capps - ANISORROPIA implementation +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !DEFINED PARAMETERS: +! + ! Array dimensions + INTEGER, PARAMETER :: NOTHERA = 9 + INTEGER, PARAMETER :: NCTRLA = 2 + INTEGER, PARAMETER :: NCOMPA = 8 + INTEGER, PARAMETER :: NIONSA = 10 + INTEGER, PARAMETER :: NGASAQA = 3 + INTEGER, PARAMETER :: NSLDSA = 19 + + ! Concentration lower limit [mole/m3] + REAL*8, PARAMETER :: CONMIN = 1.0d-30 +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: I, J, L, N + REAL*8 :: ANO3, GNO3, RHI, TEMPI + REAL*8 :: TCA, TMG, TK, HNO3_DEN + REAL*8 :: TNA, TCL, TNH3, TNH4 + REAL*8 :: TNIT, TNO3, TSO4, VOL + REAL*8 :: AERLIQ(NIONSA+NGASAQA+2) + REAL*8 :: AERSLD(NSLDSA) + REAL*8 :: GAS(NGASAQA) + REAL*8 :: OTHER(NOTHERA) + REAL*8 :: WI(NCOMPA) + REAL*8 :: WT(NCOMPA) + REAL*8 :: CNTRL(NCTRLA) + CHARACTER(LEN=255) :: X + CHARACTER(LEN=15) :: SCASI + + ! Flag and integer indicative of ANISORROPIA internal error system + LOGICAL :: TRUSTISO + + !Temporary variables to check if division is safe + REAL*8 :: NUM_SAV, DEN_SAV + + ! AEROPH: Temporary variable for pH (hotp 8/11/09) + REAL*8 :: HPLUSTEMP + + ! debug variables + INTEGER :: Itemp, Jtemp, Ltemp + INTEGER :: ISOERRCOUNT,ISOCALLCOUNT + INTEGER :: NERR, NERR22, NERR33, NERR44, NERR100 + INTEGER :: NERR101, NERR102, NERR103, NERR104 + INTEGER :: NERR50, NERROTHER, COTHER + INTEGER :: CA, CB, CC, CD, CE, CF, CG, CH, CI, CJ + LOGICAL, SAVE :: FIRSTCHECK = .TRUE. + + !================================================================= + ! DO_ISOROPIAII begins here! + !================================================================= + + ! Location string + X = 'DO_ISOROPIAII (isoropiaII_mod.f)' + WRITE(6,*) X + + ! First-time initialization + IF ( FIRST ) THEN + + ! Make sure certain tracers are defined + IF ( IDTSO4 == 0 ) CALL ERROR_STOP( 'IDTSO4 is undefined!', X) + IF ( IDTNH3 == 0 ) CALL ERROR_STOP( 'IDTNH3 is undefined!', X) + IF ( IDTNH4 == 0 ) CALL ERROR_STOP( 'IDTNH4 is undefined!', X) + IF ( IDTNIT == 0 ) CALL ERROR_STOP( 'IDTNIT is undefined!', X) + IF ( IDTSALA == 0 ) CALL ERROR_STOP( 'IDTSALA is undefined!',X) + + ! Initialize arrays + CALL INIT_ISOROPIAII + !WRITE(*,*) 'Successfully finished INIT_ISOROPIAII' + + ! Reset first-time flag + FIRST = .FALSE. + + ! Reset error counting flag + ISOERRCOUNT = 0 + + ENDIF + + !================================================================= + ! Check to see if we have to read in monthly mean HNO3 + !================================================================= + IF ( IDTHNO3 == 0 ) THEN + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + ! Coupled simulation: stop w/ error since we need HNO3 + CALL ERROR_STOP( 'IDTHNO3 is not defined!', X ) + + ELSE IF ( ITS_AN_AEROSOL_SIM() ) THEN + + ! Offline simulation: read monthly mean HNO3 + IF ( ITS_A_NEW_MONTH() ) THEN + CALL GET_GLOBAL_HNO3( GET_MONTH() ) + ENDIF + + ! Initialize for each timestep (bec, bmy, 4/15/05) + GAS_HNO3 = 0d0 + + ELSE + + ! Otherwise stop w/ error + CALL ERROR_STOP( 'Invalid simulation type!', X ) + + ENDIF + ENDIF + + ! AEROPH: Initialize arrays all the way up to LLPAR for + ! aeroph. Arrays go up to LLPAR due to ND42 use (hotp 8/11/09) + PH_SAV = 0d0 + HPLUS_SAV = 0d0 + WATER_SAV = 0d0 + SULRAT_SAV = 0d0 + NARAT_SAV = 0d0 + ACIDPUR_SAV = 0d0 + + ! Initialize the error distribution flags + NERR22 = 0 + NERR33 = 0 + NERR44 = 0 + NERR100 = 0 + NERR101 = 0 + NERR102 = 0 + NERR103 = 0 + NERR104 = 0 + NERROTHER = 0 + + ISOCALLCOUNT = 0 + ISOERRCOUNT = 0 + + CA = 0 + CB = 0 + CC = 0 + CD = 0 + CE = 0 + CF = 0 + CG = 0 + CH = 0 + CI = 0 + CJ = 0 + COTHER = 0 + + IF ( LADJ ) THEN ! adj_group + ANISO_IN(:,:,:,1:14) = 0.d0 + ENDIF + + !WRITE(*,*) 'ANISO_IN: ',ANISO_IN(1,1,1,:) + + !================================================================= + ! Loop over grid boxes and call ISOROPIA (see comments in the + ! ISOROPIA routine ISOROPIAIICODE.f which describes + ! the input/output args) + !================================================================= + + ! AEROPH: add HPLUSTEMP as private (hotp 8/11/09) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, WI, WT, GAS, TEMPI ) +!$OMP+PRIVATE( RHI, VOL, TSO4, TNH3, TNA, TCL, ANO3, GNO3 ) +!$OMP+PRIVATE( TCA, TMG, TK, CNTRL, SCASI, TRUSTISO ) +!$OMP+PRIVATE( TNO3, AERLIQ, AERSLD, OTHER, TNH4, TNIT, NERR ) +!$OMP+PRIVATE( HPLUSTEMP, NUM_SAV, DEN_SAV, HNO3_DEN ) +!$OMP+SCHEDULE( DYNAMIC ) + + DO L = 1, LLTROP + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Skip strat boxes + IF ( ITS_IN_THE_STRAT( I, J, L ) ) CYCLE + + ! Initialize WI, WT + DO N = 1, NCOMPA + WI(N) = 0d0 + WT(N) = 0d0 + ENDDO + + ! Initialize GAS + DO N = 1, NGASAQA + GAS(N) = 0d0 + ENDDO + + ! Temperature [K] + TEMPI = T(I,J,L) + + ! Relative humidity [unitless] + RHI = RH(I,J,L) * 1.d-2 + + ! Force RH in the range 0.01 - 0.98 + RHI = MAX( 0.01d0, RHI ) + RHI = MIN( 0.98d0, RHI ) + + ! Volume of grid box [m3] + VOL = AIRVOL(I,J,L) + + !--------------------------------- + ! Compute quantities for ISOROPIA + !--------------------------------- + + ! Total SO4 [mole/m3] + ! Convert from kg to mole/m3 air + TSO4 = STT(I,J,L,IDTSO4) * 1.d3 / ( 96.d0 * VOL ) + + ! Total NH3 [mole/m3] + ! Convert from kg to mole/m3 air + TNH3 = STT(I,J,L,IDTNH4) * 1.d3 / ( 18.d0 * VOL ) + + & STT(I,J,L,IDTNH3) * 1.d3 / ( 17.d0 * VOL ) + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!%%% NOTE: The error-trap statement above will halt execution if IDTSALA is +!%%% undefined. Therefore this IF statement is superfluous. Comment out +!%%% for clarity. (hotp, bmy, 2/1/10) +!%%% +!%%% IF ( IDTSALA > 0 ) THEN + + ! Total Na+ (30.61% by weight of seasalt) [mole/m3] + TNA = STT(I,J,L,IDTSALA) * 0.3061d0 * 1.d3 / + & ( 22.99d0 * VOL ) + + ! Total Cl- (55.04% by weight of seasalt) [mole/m3] + TCL = STT(I,J,L,IDTSALA) * 0.5504d0 * 1.d3 / + & ( 35.45d0 * VOL ) + +!============================================================================== +!=== NOTE: As of 11/2007, ISORROPIAII does not conserve mass when Ca,K,Mg are +!=== non-zero. If you would like to consider Ca, K, Mg from seasalt and dust, +!=== isoropiaIIcode.f ISRP4F routines must be debugged. (hotp, bmy, 2/1/10) +!=== +!=== ! Total Ca2+ (1.16% by weight of seasalt) [mole/m3] +!=== TCA = STT(I,J,L,IDTSALA) * 0.0116d0 * 1.d3 / +!=== & ( 40.08d0 * VOL ) +!=== +!=== ! Total K+ (1.1% by weight of seasalt) [mole/m3] +!=== TK = STT(I,J,L,IDTSALA) * 0.0110d0 * 1.d3 / +!=== & ( 39.102d0 * VOL ) +!=== +!=== ! Total Mg+ (3.69% by weight of seasalt) [mole/m3] +!=== TMG = STT(I,J,L,IDTSALA) * 0.0369d0 * 1.d3 / +!=== & ( 24.312d0 * VOL ) + + ! Set Ca, K, Mg to zero for time being (hotp, bmy, 2/1/10) + TCA = 0d0 + TK = 0d0 + TMG = 0d0 +!============================================================================== +!%%% ELSE +!%%% +!%%% ! no seasalt, set to zero +!%%% TNA = 0.d0 +!%%% TCL = 0.d0 +!%%% TCA = 0.d0 +!%%% TK = 0.d0 +!%%% TMG = 0.d0 +!%%% +!%%% ENDIF +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! Compute gas-phase NO3 + IF ( IDTHNO3 > 0 ) THEN + + !--------------------- + ! COUPLED SIMULATION + !--------------------- + + ! Compute gas-phase HNO3 [mole/m3] from HNO3 tracer + GNO3 = STT(I,J,L,IDTHNO3) + GNO3 = MAX( GNO3 * 1.d3 / ( 63.d0 * VOL ), CONMIN ) + + ! Aerosol-phase NO3 [mole/m3] + ANO3 = STT(I,J,L,IDTNIT) * 1.d3 / ( 62.d0 * VOL ) + + ! Total NO3 [mole/m3] + TNO3 = GNO3 + ANO3 + + ELSE + + !--------------------- + ! OFFLINE SIMULATION + !--------------------- + + ! Convert total inorganic NO3 from [ug/m3] to [mole/m3]. + ! GET_HNO3, lets HNO3 conc's evolve, but relaxes to + ! monthly mean values every 3h. + TNO3 = GET_HNO3( I,J,L ) * 1.d-6 / 63.d0 + + ENDIF + + !--------------------------------- + ! Call ISOROPIAII + !--------------------------------- + + ! set type of ISOROPIA call + ! Forward problem, do not change this value + ! 0d0 represents forward problem + CNTRL(1) = 0.0d0 + + ! Metastable for now + ! 1d0 represents metastable problem + CNTRL(2) = 1.0d0 + + ! Insert concentrations [mole/m3] into WI & prevent underflow + WI(1) = MAX( TNA, CONMIN ) + WI(2) = MAX( TSO4, CONMIN ) + WI(3) = MAX( TNH3, CONMIN ) + WI(4) = MAX( TNO3, CONMIN ) + WI(5) = MAX( TCL, CONMIN ) + WI(6) = MAX( TCA, CONMIN ) + WI(7) = MAX( TK, CONMIN ) + WI(8) = MAX( TMG, CONMIN ) + + IF ( LPRINTFD + & .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN + WRITE(6,*) 'Forward, CELL(',I,',',J,',',L,')',WI(1:5) + WRITE(6,*) 'Temp',TEMPI, ' RHI',RHI + ENDIF + + ! Perform aerosol thermodynamic equilibrium + ! ISOROPIAII can be found in isoropiaIIcode_adj.f + ! inputs are WI, RHI, TEMPI, CNTRL + + ! adj_group: call special version for adjoint (slc.09.2011) + IF ( .not. LADJ ) THEN + CALL ISOROPIAII (WI, RHI, TEMPI, CNTRL, + & WT, GAS, AERLIQ, AERSLD, + & SCASI, OTHER, TRUSTISO,NERR) + + ELSE + ! Checkpoint ANISORROPIA input + ANISO_IN(I,J,L,1:8) = WI(:) + ANISO_IN(I,J,L,9) = RHI + ANISO_IN(I,J,L,10) = TEMPI + + CALL ISOROPIAII (WI, RHI, TEMPI, CNTRL, + & WT, GAS, AERLIQ, AERSLD, + & SCASI, OTHER, TRUSTISO,NERR) + + ! Debug ANISO checkpoint + IF ( LPRINTFD + & .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN + WRITE(6,*) ' After ISOROPIAII ', I, J, L + ! (slc.10.2011) debug - output of ISORROPIA + WRITE(6,*) 'GAS ',GAS(:) + WRITE(6,*) 'AERLIQ: 3,5,6,7 ',AERLIQ(3), + & AERLIQ(5),AERLIQ(6),AERLIQ(7) + WRITE(6,*) 'TRUSTISO ',TRUSTISO + ENDIF + + ENDIF ! Checkpointing for adjoint + + !--------------------------------- + ! Save back into tracer array + !--------------------------------- + + ! Convert ISOROPIA output from [mole/m3] to [kg] + TSO4 = MAX( 96.d-3 * VOL * WT(2), CONMIN ) + TNH3 = MAX( 17.d-3 * VOL * GAS(1), CONMIN ) + + ! (slc.9.2011) - for adjoint to work without WT_ADJ + ! TNH4 = MAX( 18.d-3 * VOL * ( WT(3) - GAS(1) ), CONMIN ) + ! TNIT = MAX( 62.d-3 * VOL * ( WT(4) - GAS(2) ), CONMIN ) + TNH4 = MAX( 18.d-3 * VOL * AERLIQ(3), CONMIN ) + TNIT = MAX( 62.d-3 * VOL * AERLIQ(7), CONMIN ) + + !------------------------------------ + ! Check as to whether error occurred. + !------------------------------------ + + IF ( TRUSTISO ) THEN + + ! Save tracers back into STT array [kg] + ! no longer save TSO4 back into STT. SO4 is all aerosol phase + ! (hotp 11/7/07) + ! STT(I,J,L,IDTSO4) = TSO4 + STT(I,J,L,IDTNH3) = TNH3 + STT(I,J,L,IDTNH4) = TNH4 + STT(I,J,L,IDTNIT) = TNIT + + ! slc.debug + IF ( LADJ ) THEN ! adj_group + IF ( 17.d-3 * VOL * GAS(1) < CONMIN ) THEN + + !WRITE(*,*) 'CONMIN > NH3', GAS(1) + !WRITE(*,*) 'CELL:(',I,',',J,',',L,')' + ANISO_IN(I,J,L,11) = 0.d0 + + ELSE + + ANISO_IN(I,J,L,11) = 1.d0 + + ENDIF + + IF ( 18.d-3 * VOL * AERLIQ(3) < CONMIN ) THEN + + !WRITE(*,*) 'CONMIN > NH4', AERLIQ(3) + !WRITE(*,*) 'CELL:(',I,',',J,',',L,')' + ANISO_IN(I,J,L,12) = 0.d0 + + ELSE + + ANISO_IN(I,J,L,12) = 1.d0 + + ENDIF + + IF ( 62.d-3 * VOL * AERLIQ(7) < CONMIN ) THEN + + !WRITE(*,*) 'CONMIN > NIT', AERLIQ(7) + !WRITE(*,*) 'CELL:(',I,',',J,',',L,')' + + ANISO_IN(I,J,L,13) = 0.d0 + + ELSE + + ANISO_IN(I,J,L,13) = 1.d0 + + ENDIF + + IF ( 96.d-3 * VOL * WT(2) < CONMIN ) THEN + + !WRITE(*,*) 'CONMIN > SUL', WT(2) + !WRITE(*,*) 'CELL:(',I,',',J,',',L,')' + + ANISO_IN(I,J,L,15) = 0.d0 + + ELSE + + ANISO_IN(I,J,L,15) = 1.d0 + + ENDIF + + ENDIF + + ELSE + + ! Echo location of NAN (probably leave this commented out + ! unless you are getting lots of ADJ_NAN warnings + !WRITE(6,*) 'Can't trust ANISO at I,J,L,N = ',I,J,L,N + + IF ( LADJ ) THEN ! adj_group + + ANISO_IN(I,J,L,11:15) = 0.d0 + + ENDIF + + !WRITE(*,*) 'ANISO_IN when TRUSTISO = .F.', + !& ANISO_IN(I,J,L,11:14) + +!!$OMP CRITICAL + ! Show TRUSTISO flag so that a warning is echoed to screen + TRUSTISO = .FALSE. +!!$OMP END CRITICAL + + ! Count number of errors and total calls + ISOERRCOUNT = ISOERRCOUNT + 1 + + + SELECT CASE (NERR) + CASE (22) + NERR22 = NERR22 + 1 + CASE (33) + NERR33 = NERR33 + 1 + CASE (50) + NERR50 = NERR50 + 1 + CASE (100) + NERR100 = NERR100 + 1 + CASE (101) + NERR101 = NERR101 + 1 + CASE (102) + NERR102 = NERR102 + 1 + CASE (103) + NERR103 = NERR103 + 1 + CASE (104) + NERR104 = NERR104 + 1 + CASE DEFAULT + NERROTHER = NERROTHER + 1 + END SELECT + + + ! Do not replace original value + !STT(I,J,L,IDTNH3) = STT(I,J,L,IDTNH3) + !STT(I,J,L,IDTNH4) = STT(I,J,L,IDTNH4) + + ENDIF + + ! slc.debug + + ISOCALLCOUNT = ISOCALLCOUNT + 1 + + SELECT CASE (SCASI) + CASE("A2") + CA = CA + 1 + CASE("B4") + CB = CB + 1 + CASE("C2") + CC = CC + 1 + CASE("D3") + CD = CD + 1 + CASE("E4") + CE = CE + 1 + CASE("F2") + CF = CF + 1 + CASE("G5") + CG = CG + 1 + CASE("H6") + CH = CH + 1 + CASE("I6") + CI = CI + 1 + CASE("J3") + CJ = CJ + 1 + CASE DEFAULT + COTHER = COTHER + 1 + END SELECT + + ! Special handling for HNO3 [kg] + IF ( IDTHNO3 > 0 ) THEN + + !--------------------- + ! COUPLED SIMULATION + !--------------------- + + !------------------------------------ + ! Check as to whether error occurred. + !------------------------------------ + + IF ( TRUSTISO ) THEN + + ! HNO3 [mole/m3] is in GAS(2); convert & store in STT [kg] + STT(I,J,L,IDTHNO3) = MAX( 63.d-3 * VOL * GAS(2), CONMIN ) + + ! slc.debug + IF ( LADJ ) THEN ! adj_group + + IF ( 63.d-3 * VOL * GAS(2) < CONMIN ) THEN + + !WRITE(*,*) 'CONMIN > HNO3', STT(I,J,L,IDTHNO3) + ANISO_IN(I,J,L,14) = 0.d0 + + ELSE + + ANISO_IN(I,J,L,14) = 1.d0 + + ENDIF + + ENDIF + + ! Save for use in DEN_SAV expression below (sofen, 4/21/10) + HNO3_DEN = STT(I,J,L,IDTHNO3) + + ENDIF + + ELSE + + !--------------------------------- + ! Check for trustworthiness. + !--------------------------------- + + IF ( TRUSTISO ) THEN + + !--------------------- + ! OFFLINE SIMULATION: + !--------------------- + + ! Convert total inorganic nitrate from [mole/m3] to [ug/m3] + ! and save for next time + ! WT(4) is in [mole/m3] -- unit conv is necessary! + CALL SET_HNO3( I, J, L, 63.d6 * WT(4) ) + + ! Save for use in sulfate_mod (SEASALT_CHEM) for offline + ! aerosol simulations (bec, 4/15/05) + GAS_HNO3(I,J,L) = GAS(2) + + ! Save for use in DEN_SAV expression below (sofen, 4/21/10) + HNO3_DEN = GAS(2) * VOL * 63d-3 + + !--------------------------------- + ! Check for trustworthiness. + !--------------------------------- + + !IF ( .NOT. TRUSTISO ) THEN + + ! STT(I,J,L,IDTHNO3) = STT(I,J,L,IDTHNO3) + ! STT(I,J,L,IDTNIT) = STT(I,J,L,IDTNIT) + + ENDIF + + ENDIF + + !--------------------------------- + ! Check for trustworthiness. + !--------------------------------- + +! IF ( TRUSTISO ) THEN +! +! !------------------------- +! ! ND42 diagnostic arrays +! !------------------------- +! +! ! AEROPH: get pH related info to SAV arrays (hotp 8/11/09) +! ! HPLUSTEMP is H+ in mol/L water, AERLIQ1 is H, AERLIQ8 is H2O +! ! in mol/m3 air --> convert to mol/L water +! IF ( AERLIQ(8) < 1d-32 ) THEN +! ! Aerosol is dry so HPLUSTEMP and PH_SAV are undefined +! ! We force HPLUSTEMP to 1d20 and PH_SAV to -999d0. +! ! (hotp, ccc, 12/18/09) +! HPLUSTEMP = 1d20 +! !------------------------------------------------------------- +! ! Prior to 7/23/10: +! ! Bug fix: this should be PH_SAV(I,J,L) (sofen, bmy, 7/12/10) +! !PH_SAV = -999d0 +! !------------------------------------------------------------- +! PH_SAV(I,J,L) = -999d0 +! ELSE +! HPLUSTEMP = AERLIQ(1) / AERLIQ(8) * 1d3/18d0 +! +! ! Use SAFELOG10 to prevent NAN +! PH_SAV(I,J,L) = -1d0 * SAFELOG10( HPLUSTEMP ) +! ENDIF +! +! ! Additional Info +! HPLUS_SAV(I,J,L) = AERLIQ(1) +! WATER_SAV(I,J,L) = AERLIQ(8) +! SULRAT_SAV(I,J,L) = OTHER(2) +! NARAT_SAV(I,J,L) = OTHER(4) +! +! NUM_SAV = ( STT(I,J,L,IDTNH3) /17d0 + +! & STT(I,J,L,IDTNH4) /18d0 + +! & STT(I,J,L,IDTSALA)*0.3061d0/23.0d0 ) +! +! DEN_SAV = ( STT(I,J,L,IDTSO4) / 96d0 * 2d0 + +! & STT(I,J,L,IDTNIT) / 62d0 + +! & HNO3_DEN / 63d0 + +! & STT(I,J,L,IDTSALA) * 0.55d0 / 35.45d0 ) +! +! ! Value if DEN_SAV and NUM_SAV too small. +! ACIDPUR_SAV(I,J,L) = SAFE_DIV(NUM_SAV, DEN_SAV, +! & 0d0, +! & 999d0) +! +! ENDIF + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + !WRITE(*,*) 'Finished with OMP loop in ISOII' !slc.debug + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### ISOROPIAII: a AERO_THERMO' ) + +! WRITE(6,*) 'ISO calls: ',ISOCALLCOUNT +! WRITE(6,*) 'ISO error occurrences: ',ISOERRCOUNT +! WRITE(6,*) 'Specific error codes: ' +! WRITE(6,*) 'Error 22: ',NERR22 +! WRITE(6,*) 'Error 33: ',NERR33 +! WRITE(6,*) 'Error 44: ',NERR44 +! WRITE(6,*) 'Error 100: ',NERR100 +! WRITE(6,*) 'Error 101: ',NERR101 +! WRITE(6,*) 'Error 102: ',NERR102 +! WRITE(6,*) 'Error 103: ',NERR103 +! WRITE(6,*) 'Error 104: ',NERR104 +! WRITE(6,*) 'Error Other: ', NERROTHER +! +! WRITE(6,*) '____________ Case Distribution ____________' +! WRITE(6,*) 'A: ',CA +! WRITE(6,*) 'B: ',CB +! WRITE(6,*) 'C: ',CC +! WRITE(6,*) 'D: ',CD +! WRITE(6,*) 'E: ',CE +! WRITE(6,*) 'F: ',CF +! WRITE(6,*) 'G: ',CG +! WRITE(6,*) 'H: ',CH +! WRITE(6,*) 'I: ',CI +! WRITE(6,*) 'J: ',CJ +! WRITE(6,*) 'Other: ', COTHER +! + ! Return to calling program + END SUBROUTINE DO_ISOROPIAII +!EOC + +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: do_isoropiaii_adj +! +! !DESCRIPTION: Subroutine DO\_ISOROPIAII_ADJ is the interface between the +! GEOS-Chem model and the adjoint of the aerosol thermodynamical +! equilibrium routine ISORROPIA II. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE DO_ISOROPIAII_ADJ +! +! !USES: +! + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD + USE ADJ_ARRAYS_MOD, ONLY : STT_ADJ + USE CHECKPT_MOD, ONLY : ANISO_IN + USE DAO_MOD, ONLY : AIRVOL, RH, T + USE ERROR_MOD, ONLY : DEBUG_MSG, ERROR_STOP + USE ERROR_MOD, ONLY : SAFE_DIV, IT_IS_NAN + USE GLOBAL_HNO3_MOD, ONLY : GET_GLOBAL_HNO3 + USE LOGICAL_ADJ_MOD, ONLY : LPRINTFD + USE LOGICAL_MOD, ONLY : LPRT + USE TIME_MOD, ONLY : GET_MONTH, ITS_A_NEW_MONTH + USE TRACER_MOD + USE TRACERID_MOD, ONLY : IDTHNO3, IDTNIT, IDTNH4, IDTNH3 + USE TRACERID_MOD, ONLY : IDTSALA, IDTSO4 + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_STRAT + +# include "CMN_SIZE" ! Size parameters +! +! !REMARKS: +! Original isoropia v1.3 implementation: (rjp, bec, bmy, 12/17/01, 8/22/05) +! +! !REVISION HISTORY: +! 30 Aug 2011 - S. Capps - Interface ANISORROPIA with adjoint +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !DEFINED PARAMETERS: +! + ! Array dimensions + INTEGER, PARAMETER :: NOTHERA = 9 + INTEGER, PARAMETER :: NCTRLA = 2 + INTEGER, PARAMETER :: NCOMPA = 8 + INTEGER, PARAMETER :: NIONSA = 10 + INTEGER, PARAMETER :: NGASAQA = 3 + INTEGER, PARAMETER :: NSLDSA = 19 + + ! Concentration lower limit [mole/m3] + REAL*8, PARAMETER :: CONMIN = 1.0d-30 + + ! Adjoint parameters + INTEGER, PARAMETER :: MAX_ALLOWED_NAN = 10 + INTEGER, PARAMETER :: MAX_ALLOWED_EXPLD = 10 + REAL*8, PARAMETER :: MAX_ALLOWED_INCREASE = 10.0D10 + +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRSTADJ = .TRUE. + INTEGER :: I, J, L, N + REAL*8 :: ANO3, GNO3, RHI, TEMPI + REAL*8 :: TCA, TMG, TK, HNO3_DEN + REAL*8 :: TNA, TCL, TNH3, TNH4 + REAL*8 :: TNIT, TNO3, TSO4, VOL + REAL*8 :: AERLIQ(NIONSA+NGASAQA+2) + REAL*8 :: AERSLD(NSLDSA) + REAL*8 :: GAS(NGASAQA) + REAL*8 :: OTHER(NOTHERA) + REAL*8 :: WI(NCOMPA) + REAL*8 :: WT(NCOMPA) + REAL*8 :: CNTRL(NCTRLA) + CHARACTER(LEN=255) :: X + CHARACTER(LEN=15) :: SCASI + LOGICAL :: TRUSTISO + + ! Adjoint variables + LOGICAL :: ADJ_NAN = .FALSE. + INTEGER :: ADJ_NAN_COUNT, ADJ_EXPLD_COUNT + REAL*8 :: WT_ADJ(NCOMPA) + REAL*8 :: WI_ADJ(NCOMPA) + REAL*8 :: GAS_ADJ(NGASAQA) + REAL*8 :: AERLIQ_ADJ(NIONSA+NGASAQA+2) + REAL*8 :: TNH3_ADJ, TNH4_ADJ, TNO3_ADJ + REAL*8 :: TSO4_ADJ, TNIT_ADJ, HNO3_ADJ + REAL*8 :: TCA_ADJ, TMG_ADJ, TK_ADJ + REAL*8 :: TNA_ADJ, TCL_ADJ + REAL*8 :: ANO3_ADJ, GNO3_ADJ + REAL*8 :: MAX_ADJ_TMP ! Temp max value used for error checking + + !Temporary variables to check if division is safe + REAL*8 :: NUM_SAV, DEN_SAV + + ! AEROPH: Temporary variable for pH (hotp 8/11/09) + REAL*8 :: HPLUSTEMP + + ! debug variables + INTEGER :: Itemp, Jtemp, Ltemp + INTEGER :: ANISOERRCOUNT, ANISOCALLCOUNT + INTEGER :: NERR, NERR22, NERR33, NERR44, NERR100 + INTEGER :: NERR101, NERR102, NERR103, NERR104 + INTEGER :: NERR50, NERROTHER, COTHER + INTEGER :: CA, CB, CC, CD, CE, CF, CG, CH, CI, CJ + LOGICAL, SAVE :: FIRSTCHECK = .TRUE. + + !================================================================= + ! DO_ISOROPIAII_ADJ begins here! + !================================================================= + + WRITE(6,*) 'Inside DO_ISOROPIAII_ADJ' + ! Location string + X = 'DO_ISOROPIAII_ADJ (isoropiaII_adj_mod.f)' + + ! First-time initialization + IF ( FIRSTADJ ) THEN + + ! Make sure certain tracers are defined + IF ( IDTSO4 == 0 ) CALL ERROR_STOP( 'IDTSO4 is undefined!', X) + IF ( IDTNH3 == 0 ) CALL ERROR_STOP( 'IDTNH3 is undefined!', X) + IF ( IDTNH4 == 0 ) CALL ERROR_STOP( 'IDTNH4 is undefined!', X) + IF ( IDTNIT == 0 ) CALL ERROR_STOP( 'IDTNIT is undefined!', X) + IF ( IDTSALA == 0 ) CALL ERROR_STOP( 'IDTSALA is undefined!',X) + + ! debug - slc.1.2012 + !! Initialize ADJ_NAN_COUNT + !ADJ_NAN_COUNT = 0 + !ADJ_EXPLD_COUNT = 0 + + ! Reset first-time flag + FIRSTADJ = .FALSE. + + ! Initialize error count flag + ANISOERRCOUNT = 0 + ENDIF + + ! Save maximum adjoint for error checking later + MAX_ADJ_TMP = MAXVAL( ABS(STT_ADJ) ) + + ! debug - slc.1.2012 + !WRITE(*,*) 'Successfully initialized' + + !================================================================= + ! Check to see if we have to read in monthly mean HNO3 + !================================================================= + IF ( IDTHNO3 == 0 ) THEN + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + ! Coupled simulation: stop w/ error since we need HNO3 + CALL ERROR_STOP( 'IDTHNO3 is not defined!', X ) + + ELSE IF ( ITS_AN_AEROSOL_SIM() ) THEN + + ! Offline simulation: read monthly mean HNO3 + IF ( ITS_A_NEW_MONTH() ) THEN + CALL GET_GLOBAL_HNO3( GET_MONTH() ) + ENDIF + + ! Initialize for each timestep (bec, bmy, 4/15/05) + GAS_HNO3 = 0d0 + + ELSE + + ! Otherwise stop w/ error + CALL ERROR_STOP( 'Invalid simulation type!', X ) + + ENDIF + ENDIF + + ! debug - slc.1.2012 + !WRITE(*,*) 'Successfully checked HNO3' + + ! AEROPH: Initialize arrays all the way up to LLPAR for + ! aeroph. Arrays go up to LLPAR due to ND42 use (hotp 8/11/09) + PH_SAV = 0d0 + HPLUS_SAV = 0d0 + WATER_SAV = 0d0 + SULRAT_SAV = 0d0 + NARAT_SAV = 0d0 + ACIDPUR_SAV = 0d0 + + ! Initialize the error distribution flags + NERR22 = 0 + NERR33 = 0 + NERR44 = 0 + NERR100 = 0 + NERR101 = 0 + NERR102 = 0 + NERR103 = 0 + NERR104 = 0 + NERROTHER = 0 + + ANISOCALLCOUNT = 0 + ANISOERRCOUNT = 0 + + CA = 0 + CB = 0 + CC = 0 + CD = 0 + CE = 0 + CF = 0 + CG = 0 + CH = 0 + CI = 0 + CJ = 0 + COTHER = 0 + + !================================================================= + ! Loop over grid boxes and call ISOROPIA (see comments in the + ! ISOROPIA routine ISOROPIAIICODE.f which describes + ! the input/output args) + !================================================================= + + ! AEROPH: add HPLUSTEMP as private (hotp 8/11/09) +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, WI, WT, GAS, TEMPI ) +!$OMP+PRIVATE( RHI, VOL, TSO4, TNH3, TNA, TCL, ANO3, GNO3 ) +!$OMP+PRIVATE( TCA, TMG, TK, CNTRL, SCASI, TRUSTISO ) +!$OMP+PRIVATE( TNO3, AERLIQ, AERSLD, OTHER, TNH4, TNIT, NERR ) +!$OMP+PRIVATE( HPLUSTEMP, NUM_SAV, DEN_SAV, HNO3_DEN ) +!$OMP+PRIVATE( WI_ADJ, WT_ADJ, GAS_ADJ, AERLIQ_ADJ, TSO4_ADJ ) +!$OMP+PRIVATE( TMG_ADJ, TK_ADJ, TCA_ADJ, TCL_ADJ, TNO3_ADJ, TNH3_ADJ ) +!$OMP+PRIVATE( TNA_ADJ, GNO3_ADJ, ANO3_ADJ ) + +!$OMP+SCHEDULE( DYNAMIC ) + DO L = 1, LLTROP + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Skip strat boxes + IF ( ITS_IN_THE_STRAT( I, J, L ) ) CYCLE + + + ! BEGIN RECALCULATION OF FORWARD VALUES --> + ! Initialize WI, WT + WI(:) = 0.d0 + WT(:) = 0.d0 + + ! Initialize adjoint variables WI_ADJ, WT_ADJ, GAS_ADJ, AERLIQ_ADJ + WI_ADJ(:) = 0d0 + WT_ADJ(:) = 0d0 + GAS_ADJ(:) = 0d0 + AERLIQ_ADJ(:) = 0d0 + + ! Initialize GAS + GAS(:) = 0.d0 + + + ! Volume of grid box [m3] + VOL = AIRVOL(I,J,L) + + + ! ! Compute gas-phase NO3 + ! IF ( IDTHNO3 > 0 ) THEN + ! + ! !--------------------- + ! ! COUPLED SIMULATION + ! !--------------------- + + ! ! Compute gas-phase HNO3 [mole/m3] from HNO3 tracer + ! GNO3 = STT(I,J,L,IDTHNO3) + ! GNO3 = MAX( GNO3 * 1.d3 / ( 63.d0 * VOL ), CONMIN ) + + ! ! Aerosol-phase NO3 [mole/m3] + ! ANO3 = STT(I,J,L,IDTNIT) * 1.d3 / ( 62.d0 * VOL ) + + ! ! Total NO3 [mole/m3] + ! TNO3 = GNO3 + ANO3 + + ! ELSE + + ! !--------------------- + ! ! OFFLINE SIMULATION - no adjoint for this type of run + ! !--------------------- + + ! ! Convert total inorganic NO3 from [ug/m3] to [mole/m3]. + ! ! GET_HNO3, lets HNO3 conc's evolve, but relaxes to + ! ! monthly mean values every 3h. + ! TNO3 = GET_HNO3( I,J,L ) * 1.d-6 / 63.d0 + + ! ENDIF + + !--------------------------------- + ! Call ANISORROPIA + !--------------------------------- + + ! set type of ANISORROPIA call + ! Forward problem, do not change this value + ! 0d0 represents forward problem + CNTRL(1) = 0.0d0 + + ! Metastable for now + ! 1d0 represents metastable problem + CNTRL(2) = 1.0d0 + + ! From checkpointed files, gather input values (slc.09.27.2011) + ! Load IN from ANISO_IN + + WI(:) = ANISO_IN(I,J,L,1:8) + + ! Load parameters from ANISO_IN + RHI = ANISO_IN(I,J,L,9) + TEMPI = ANISO_IN(I,J,L,10) + + !WRITE(*,*) 'ISO_ADJ, ANISO_IN: ',ANISO_IN(I,J,L,:) + !WRITE(*,*) 'STT_ADJ(IDTNIT): ', STT_ADJ(I,J,L,IDTNIT) + !WRITE(*,*) 'STT_ADJ(IDTHNO3): ', STT_ADJ(I,J,L,IDTHNO3) + !WRITE(*,*) 'STT_ADJ(IDTSO4): ', STT_ADJ(I,J,L,IDTSO4) + !WRITE(*,*) 'STT_ADJ(IDTNH4): ', STT_ADJ(I,J,L,IDTNH4) + !WRITE(*,*) 'STT_ADJ(IDTNH3): ', STT_ADJ(I,J,L,IDTNH3) + + !<--- END LOADING OF FORWARD VALUES + + !---> BEGIN ADJOINT CALCULATION + + + ! adj code + IF ( IDTHNO3 > 0 ) THEN + ! IF ( TRUSTISO ) THEN ! not defined ! + + ! fwd code: + ! STT(I,J,L,IDTHNO3) = MAX( 63.d-3 * VOL * GAS(2), CONMIN ) + ! adj code: + IF ( ANISO_IN(I,J,L,14) .GT. 0.d0 ) THEN + GAS_ADJ(2) = STT_ADJ(I,J,L,IDTHNO3) * 63.d-3 * VOL + ELSE + GAS_ADJ(2) = 0.d0 + ENDIF + ! ENDIF + ELSE + CALL ERROR_STOP('adj not supported for offline', X ) + ENDIF + + !IF ( TRUSTISO ) THEN ! not defined ! + + ! fwd code: + !STT(I,J,L,IDTSO4) = TSO4 - not in forward, but adding for + ! adjoint forcing only - slc.4.2013 + !STT(I,J,L,IDTNH3) = TNH3 + !STT(I,J,L,IDTNH4) = TNH4 + !STT(I,J,L,IDTNIT) = TNIT + ! adj code: + + IF ( ANISO_IN(I,J,L,15) .GT. 0.d0 ) THEN + TSO4_ADJ = STT_ADJ(I,J,L,IDTSO4) + ELSE + TSO4_ADJ = 0.d0 + ENDIF + + IF ( ANISO_IN(I,J,L,13) .GT. 0.d0 ) THEN + TNIT_ADJ = STT_ADJ(I,J,L,IDTNIT) + ELSE + TNIT_ADJ = 0.d0 + ENDIF + + IF ( ANISO_IN(I,J,L,11) .GT. 0.d0 ) THEN + TNH3_ADJ = STT_ADJ(I,J,L,IDTNH3) + ELSE + TNH3_ADJ = 0.d0 + ENDIF + + IF ( ANISO_IN(I,J,L,12) .GT. 0.d0 ) THEN + TNH4_ADJ = STT_ADJ(I,J,L,IDTNH4) + ELSE + TNH4_ADJ = 0.d0 + ENDIF + + + ! Debug ANISO checkpoint + !IF ( LPRINTFD + !& .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN + ! IF ( ( ABS(STT_ADJ(I,J,L,IDTNH4)) .GT. 1d10) .OR. + !& ( ABS(STT_ADJ(I,J,L,IDTNH3)) .GT. 1d10) .OR. + !& ( ABS(STT_ADJ(I,J,L,IDTHNO3)) .GT. 1d10) .OR. + !& ( ABS(STT_ADJ(I,J,L,IDTNIT)) .GT. 1d10) .OR. + !& ( ABS(STT_ADJ(I,J,L,IDTSO4)) .GT. 1d10) ) THEN + + ! print*, ' Before ISOROPIAII_ADJ ', I, J, L + ! print*, ' STT_ADJ(NIT) ', STT_ADJ(I,J,L,IDTNIT) + ! print*, ' STT_ADJ(HNO3) ', STT_ADJ(I,J,L,IDTHNO3) + ! print*, ' STT_ADJ(NH4) ', STT_ADJ(I,J,L,IDTNH4) + ! print*, ' STT_ADJ(NH3) ', STT_ADJ(I,J,L,IDTNH3) + ! print*, ' STT_ADJ(SO4) ', STT_ADJ(I,J,L,IDTSO4) + ! ENDIF + + + !ENDIF + + + ! fwd code: + !TSO4 = MAX( 96.d-3 * VOL * WT(2), CONMIN ) + !TNH3 = MAX( 17.d-3 * VOL * GAS(1), CONMIN ) + ! Changing for use of the adjoint without WT_ADJ + ! !TNH4 = MAX( 18.d-3 * VOL * ( WT(3) - GAS(1) ), CONMIN ) + ! !TNIT = MAX( 62.d-3 * VOL * ( WT(4) - GAS(2) ), CONMIN ) + !TNH4 = MAX( 18.d-3 * VOL * AERLIQ(3), CONMIN ) + !TNIT = MAX( 62.d-3 * VOL * AERLIQ(7), CONMIN ) + ! adj code (note that we don't overwrite GAS_ADJ(2), + ! which has already been assigned a value: + AERLIQ_ADJ(5) = 96.d-3 * VOL * TSO4_ADJ ! SO4 + AERLIQ_ADJ(6) = 97.d-3 * VOL * TSO4_ADJ ! HSO4 + AERLIQ_ADJ(7) = 62.d-3 * VOL * TNIT_ADJ + AERLIQ_ADJ(3) = 18.d-3 * VOL * TNH4_ADJ + GAS_ADJ(1) = 17.d-3 * VOL * TNH3_ADJ + + ! Changes implemented above (slc.4.2013) + !!! Always zero because the TSO4_ADJ = nothing + !!! WT_ADJ(2) = 96.d-3 * VOL * TSO4_ADJ + + !IF ( LPRINTFD + !& .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN + !WRITE(*,*) 'Adjoint, CELL(',I,',',J,',',L,')',WI(1:5) + !WRITE(*,*) 'Temp ',TEMPI ,' RH ', RHI + !WRITE(*,*) '------------------------' + !WRITE(*,*) 'adjoint forcing vectors ' + !WRITE(*,*) 'NH4 force', AERLIQ_ADJ(3) + !WRITE(*,*) 'NIT force', AERLIQ_ADJ(7) + !WRITE(*,*) 'NH3 force', GAS_ADJ(1) + !WRITE(*,*) 'HNO3 force', GAS_ADJ(2) + !ENDIF + + ! Perform aerosol thermodynamic equilibrium + ! ISOROPIAII_ADJ can be found in ISOROPIAIICODE_ADJ.f + ! inputs are WI, RHI, TEMPI, CNTRL, ADJ_GAS, ADJ_AERLIQ + CALL ISOROPIAII_ADJ(WI, WI_ADJ, RHI, TEMPI, CNTRL, + & WT, GAS, GAS_ADJ, AERLIQ, AERLIQ_ADJ, + & AERSLD, SCASI, OTHER, TRUSTISO,NERR) + + IF ( TRUSTISO ) THEN ! no ISOROPIAII_ADJ errors + ! fwd code: + !WI(1) = MAX( TNA, CONMIN ) + !WI(2) = MAX( TSO4, CONMIN ) + !WI(3) = MAX( TNH3, CONMIN ) + !WI(4) = MAX( TNO3, CONMIN ) + !WI(5) = MAX( TCL, CONMIN ) + !WI(6) = MAX( TCA, CONMIN ) + !WI(7) = MAX( TK, CONMIN ) + !WI(8) = MAX( TMG, CONMIN ) + ! adj code (not sure if need all these, but include anyways to be complete): + + ! Modification for testing ANISO with no seasalt or dust + ! adjoint - slc.4.2012 + + TMG_ADJ = 0.d0 ! WI_ADJ(8) + TK_ADJ = 0.d0 ! WI_ADJ(7) + TCA_ADJ = 0.d0 ! WI_ADJ(6) + TCL_ADJ = 0.d0 ! WI_ADJ(5) + TNO3_ADJ = WI_ADJ(4) + TNH3_ADJ = WI_ADJ(3) + TSO4_ADJ = WI_ADJ(2) + TNA_ADJ = 0.d0 ! WI_ADJ(1) - end of changes - slc.4.2012 + + IF ( LPRINTFD + & .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN + WRITE(*,*) 'Adjoint execution, WI_ADJ' + WRITE(*,*) 'SO4: ',WI_ADJ(2) + WRITE(*,*) 'NH4: ',WI_ADJ(3) + WRITE(*,*) 'NIT: ',WI_ADJ(4) + ENDIF + + IF ( IDTHNO3 > 0 ) THEN + + ! fwd code: + !TNO3 = GNO3 + ANO3 + ! adj code: + GNO3_ADJ = TNO3_ADJ + ANO3_ADJ = TNO3_ADJ + + ! fwd code: + !ANO3 = STT(I,J,L,IDTNIT) * 1.d3 / ( 62.d0 * VOL ) + ! adj code: + STT_ADJ(I,J,L,IDTNIT) = ANO3_ADJ * 1.d3 / ( 62.d0 * VOL ) + + ! fwd code: + !GNO3 = STT(I,J,L,IDTHNO3) + !GNO3 = MAX( GNO3 * 1.d3 / ( 63.d0 * VOL ), CONMIN ) + GNO3_ADJ = GNO3_ADJ * 1.d3 / ( 63.d0 * VOL) + STT_ADJ(I,J,L,IDTHNO3) = GNO3_ADJ + + + ELSE + CALL ERROR_STOP('adj not supported for offline', X ) + ENDIF + + ! fwd code: + !TCA = 0d0 + !TK = 0d0 + !TMG = 0d0 + ! adj code: + TCA_ADJ = 0d0 + TK_ADJ = 0d0 + TMG_ADJ = 0d0 + + ! Keep commented until seasalt adjoint is developed. + ! (slc.1.2012) + ! fwd code: + !TCL = STT(I,J,L,IDTSALA) * 0.5504d0 * 1.d3 / + ! ( 35.45d0 * VOL ) + ! adj code (would add this once we have SALA ADJ: + !STT_ADJ(I,J,L,IDTSALA) = TCL_ADJ * 0.5504d0 * 1.d3 / + ! ( 35.45d0 * VOL ) + + ! fwd code: + !TNA = STT(I,J,L,IDTSALA) * 0.3061d0 * 1.d3 / + ! ( 22.99d0 * VOL ) + ! adj code + !STT_ADJ(I,J,L,IDTSALA) = TNA_ADJ * 0.3061d0 * 1.d3 / + ! ( 22.99d0 * VOL ) + TNA_ADJ = 0d0 + TCL_ADJ = 0d0 + + !STT_ADJ(I,J,L,IDTDST1) = 0.d0 + STT_ADJ(I,J,L,IDTDST1) !TCA_ADJ + !STT_ADJ(I,J,L,IDTDST2) = 0.d0 + STT_ADJ(I,J,L,IDTDST2) !TK_ADJ + !STT_ADJ(I,J,L,IDTDST3) = 0.d0 + STT_ADJ(I,J,L,IDTDST3) !TMG_ADJ + !STT_ADJ(I,J,L,IDTDST4) = 0.d0 + STT_ADJ(I,J,L,IDTDST4) !TNA_ADJ + !STT_ADJ(I,J,L,IDTSALA) = 0.d0 + STT_ADJ(I,J,L,IDTSALA) !TCL_ADJ + !STT_ADJ(I,J,L,IDTSALC) = 0.d0 + STT_ADJ(I,J,L,IDTSALC) !TCL_ADJ + + ! fwd code: + + !TNH3 = STT(I,J,L,IDTNH4) * 1.d3 / ( 18.d0 * VOL ) + + ! STT(I,J,L,IDTNH3) * 1.d3 / ( 17.d0 * VOL ) + STT_ADJ(I,J,L,IDTNH4) = TNH3_ADJ * 1.d3 / ( 18.d0 * VOL ) + + STT_ADJ(I,J,L,IDTNH3) = TNH3_ADJ * 1.d3 / ( 17.d0 * VOL ) + + + ! fwd code: + !TSO4 = STT(I,J,L,IDTSO4) * 1.d3 / ( 96.d0 * VOL ) + ! adj code: + STT_ADJ(I,J,L,IDTSO4) = TSO4_ADJ * 1.d3 / ( 96.d0 * VOL ) + + IF ( LPRINTFD + & .and. J == JFD .AND. L == LFD .AND. I == IFD) THEN + WRITE(*,*) 'After ANISORROPIA, STT_ADJ' + WRITE(*,*) 'SO4 ',STT_ADJ(I,J,L,IDTSO4) + WRITE(*,*) 'NH4 ',STT_ADJ(I,J,L,IDTNH4) + WRITE(*,*) 'NH3 ',STT_ADJ(I,J,L,IDTNH3) + WRITE(*,*) 'HNO3',STT_ADJ(I,J,L,IDTHNO3) + WRITE(*,*) 'NIT ',STT_ADJ(I,J,L,IDTNIT) + !PAUSE + ENDIF + + ELSE + + ! Count the number of error flags & calls to reverse + ANISOERRCOUNT = ANISOERRCOUNT + 1 + SELECT CASE (NERR) + CASE (22) + NERR22 = NERR22 + 1 + CASE (33) + NERR33 = NERR33 + 1 + CASE (50) + NERR50 = NERR50 + 1 + CASE (100) + NERR100 = NERR100 + 1 + CASE (101) + NERR101 = NERR101 + 1 + CASE (102) + NERR102 = NERR102 + 1 + CASE (103) + NERR103 = NERR103 + 1 + CASE (104) + NERR104 = NERR104 + 1 + CASE DEFAULT + NERROTHER = NERROTHER + 1 + END SELECT + + ENDIF ! no ISOROPIAII_ADJ errors + + ! debug - slc.1.2012 + + ANISOCALLCOUNT = ANISOCALLCOUNT + 1 + SELECT CASE (SCASI) + CASE("A2") + CA = CA + 1 + CASE("B4") + CB = CB + 1 + CASE("C2") + CC = CC + 1 + CASE("D3") + CD = CD + 1 + CASE("E4") + CE = CE + 1 + CASE("F2") + CF = CF + 1 + CASE("G5") + CG = CG + 1 + CASE("H6") + CH = CH + 1 + CASE("I6") + CI = CI + 1 + CASE("J3") + CJ = CJ + 1 + CASE DEFAULT + COTHER = COTHER + 1 + END SELECT + + + + ! fwd code: + !DO N = 1, NCOMPA + ! WI(N) = 0d0 + ! WT(N) = 0d0 + !ENDDO + ! adj code (reset values for safety) + WI_ADJ(:) = 0d0 + WT_ADJ(:) = 0d0 + GAS_ADJ(:) = 0d0 + AERLIQ_ADJ(:) = 0d0 + + !<--- END ADJOINT CALCULATION + + ENDDO + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! More error checking: warn of exploding adjoit values, except + ! the first jump up from zero (MAX_ADJ_TMP = 0 first few times) + IF ( MAXVAL(ABS(STT_ADJ)) > (MAX_ADJ_TMP * MAX_ALLOWED_INCREASE) + & .AND. ( MAX_ADJ_TMP > 0d0 ) ) THEN + + WRITE(6,*)' *** - WARNING: EXPLODING adjoints in ADJ_AEROSOL' + WRITE(6,*)' *** - MAX(ADJ_STT) before = ',MAX_ADJ_TMP + WRITE(6,*)' *** - MAX(ADJ_STT) after = ',MAXVAL(ABS(STT_ADJ)) + + ADJ_EXPLD_COUNT = ADJ_EXPLD_COUNT + 1 + + IF (ADJ_EXPLD_COUNT > MAX_ALLOWED_EXPLD ) + & CALL ERROR_STOP('Too many exploding adjoints', + & 'ADJ_AEROSOL, adjoint_mod.f') + + ENDIF + + !### Debug + IF ( LPRT ) CALL DEBUG_MSG( '### ISOROPIAII_ADJ: AERO_THERMO_ADJ') +! WRITE(6,*) 'ANISO calls: ',ANISOCALLCOUNT +! WRITE(6,*) 'ANISO error occurrences: ',ANISOERRCOUNT +! WRITE(6,*) 'Specific error codes: ' +! WRITE(6,*) 'Error 22: ',NERR22 +! WRITE(6,*) 'Error 33: ',NERR33 +! WRITE(6,*) 'Error 44: ',NERR44 +! WRITE(6,*) 'Error 100: ',NERR100 +! WRITE(6,*) 'Error 101: ',NERR101 +! WRITE(6,*) 'Error 102: ',NERR102 +! WRITE(6,*) 'Error 103: ',NERR103 +! WRITE(6,*) 'Error 104: ',NERR104 +! WRITE(6,*) 'Error Other: ', NERROTHER +! +! WRITE(6,*) '____________ Case Distribution ____________' +! WRITE(6,*) 'A: ',CA +! WRITE(6,*) 'B: ',CB +! WRITE(6,*) 'C: ',CC +! WRITE(6,*) 'D: ',CD +! WRITE(6,*) 'E: ',CE +! WRITE(6,*) 'F: ',CF +! WRITE(6,*) 'G: ',CG +! WRITE(6,*) 'H: ',CH +! WRITE(6,*) 'I: ',CI +! WRITE(6,*) 'J: ',CJ +! WRITE(6,*) 'Other: ', COTHER + + ! Return to calling program + END SUBROUTINE DO_ISOROPIAII_ADJ +!EOC +!------------------------------------------------------------------------------ +! Caltech Department of Chemical Engineering / Seinfeld Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: safelog10 +! +! !DESCRIPTION: Calculates the LOG (base 10) of a number X. Returns a minimum +! value if X is too small, in order to avoid NaN or Infinity problems. +!\\ +!\\ +! !INTERFACE: +! + FUNCTION SAFELOG10( X ) RESULT ( SAFLOG ) +! +! !INPUT PARAMETERS: +! + REAL*8, INTENT(IN) :: X ! Argument for LOG10 function +! +! !RETURN VALUE: +! + REAL*8 :: SAFLOG ! LOG10 output -- +! +! !REVISION HISTORY: +! 11 Aug 2009 - H. O. T. Pye - Initial version, in ISORROPIA II +! 29 Jan 2010 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC + + IF ( X <= 1d-20 ) THEN + SAFLOG = -1d0*20d0 ! if X<0, make pH 20 + ELSE + SAFLOG = LOG10(X) + ENDIF + + END FUNCTION SAFELOG10 +!EOC +!------------------------------------------------------------------------------ +! Caltech Department of Chemical Engineering / Seinfeld Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: get_isrinfo +! +! !DESCRIPTION: Subroutine GET\_ISRINFO returns information related to +! aerosol pH. +!\\ +!\\ +! !INTERFACE: +! + FUNCTION GET_ISRINFO( I, J, L, N ) RESULT ( RETURNVALUE ) +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: I ! GEOS-Chem longitude index + INTEGER, INTENT(IN) :: J ! GEOS-Chem latitude index + INTEGER, INTENT(IN) :: L ! GEOS-Chem level index + INTEGER, INTENT(IN) :: N ! Flag for which information is desired +! +! !RETURN VALUE: +! + REAL*8 :: RETURNVALUE +! +! !REVISION HISTORY: +! 11 Aug 2009 - H. O. T. Pye - Initial version +! 29 Jan 2010 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC + IF ( N == 1 ) THEN + RETURNVALUE = PH_SAV( I, J, L ) + ELSEIF ( N == 2 ) THEN + RETURNVALUE = HPLUS_SAV( I, J, L ) + ELSEIF ( N == 3 ) THEN + RETURNVALUE = WATER_SAV( I, J, L ) + ELSEIF ( N == 4 ) THEN + RETURNVALUE = SULRAT_SAV( I, J, L ) + ELSEIF ( N == 5 ) THEN + RETURNVALUE = NARAT_SAV( I, J, L ) + ELSEIF ( N == 6 ) THEN + RETURNVALUE = ACIDPUR_SAV( I, J, L ) + ELSE + ! return large value to indicate problem + RETURNVALUE = 99999d0 + !FP_ISOP + WRITE(*,*) 'VALUE NOT DEFINED IN GET_ISRINFO' + ENDIF + + END FUNCTION GET_ISRINFO +!EOC +!------------------------------------------------------------------------------ +! Caltech Department of Chemical Engineering / Seinfeld Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: get_hno3 +! +! !DESCRIPTION: Subroutine GET\_HNO3 allows the HNO3 concentrations to evolve +! with time, but relaxes back to the monthly mean concentrations every 3 +! hours. +!\\ +!\\ +! !INTERFACE: +! + FUNCTION GET_HNO3( I, J, L ) RESULT ( HNO3_UGM3 ) +! +! !USES: +! + USE GLOBAL_HNO3_MOD, ONLY : GET_HNO3_UGM3 + USE TIME_MOD, ONLY : GET_ELAPSED_MIN +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: I ! GEOS-Chem longitude index + INTEGER, INTENT(IN) :: J ! GEOS-Chem latitude index + INTEGER, INTENT(IN) :: L ! GEOS-Chem level index +! +! !REVISION HISTORY: +! 16 Dec 2002 - R. Yantosca - Initial version, in ISORROPIA I +! 24 Mar 2003 - R. Yantosca - Now use function GET_ELAPSED_MIN() from the +! new "time_mod.f" to get the elapsed minutes +! since the start of run. +! 06 Jul 2007 - H. O. T. Pye - Initial version, in ISORROPIA II +! 29 Jan 2010 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + REAL*8 :: HNO3_UGM3 + + !================================================================= + ! GET_HNO3 begins here! + !================================================================= + + ! Relax to monthly mean HNO3 concentrations every 3 hours + ! Otherwise just return the concentration in HNO3_sav + IF ( MOD( GET_ELAPSED_MIN(), 180 ) == 0 ) THEN + HNO3_UGM3 = GET_HNO3_UGM3( I, J, L ) + ELSE + HNO3_UGM3 = HNO3_sav(I,J,L) + ENDIF + + ! Return to calling program + END FUNCTION GET_HNO3 +!EOC +!------------------------------------------------------------------------------ +! Caltech Department of Chemical Engineering / Seinfeld Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: set_hno3 +! +! !DESCRIPTION: Subroutine SET\_HNO3 stores the modified HNO3 value back +! into the HNO3\_sav array for the next timestep. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE SET_HNO3( I, J, L, HNO3_UGM3 ) +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: I ! GEOS-Chem longitude index + INTEGER, INTENT(IN) :: J ! GEOS-Chem longitude index + INTEGER, INTENT(IN) :: L ! GEOS-Chem longitude index + REAL*8, INTENT(IN) :: HNO3_UGM3 ! HNO3 concentration [ug/m3] +! +! !REVISION HISTORY: +! 16 Dec 2002 - R. Yantosca - Initial version, in ISORROPIA I +! 06 Jul 2007 - H. O. T. Pye - Initial version, in ISORROPIA II +! 29 Jan 2010 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC + HNO3_sav(I,J,L) = HNO3_UGM3 + + END SUBROUTINE SET_HNO3 +!EOC +!------------------------------------------------------------------------------ +! Caltech Department of Chemical Engineering / Seinfeld Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: get_gno3 +! +! !DESCRIPTION: Function GET\_GNO3 returns the gas-phase HNO3 [v/v] for +! calculation of sea-salt chemistry in sulfate\_mod (SEASALT\_CHEM). +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GET_GNO3( I, J, L, HNO3_kg ) +! +! !USES: +! + USE DAO_MOD, ONLY : AIRVOL, AD +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: I ! GEOS-Chem longitude index + INTEGER, INTENT(IN) :: J ! GEOS-Chem latitude index + INTEGER, INTENT(IN) :: L ! GEOS-Chem level index +! +! !OUTPUT PARAMETERS: +! + REAL*8, INTENT(OUT) :: HNO3_kg ! Gas-phase HNO3 [kg] +! +! !REVISION HISTORY: +! 15 Apr 2005 - B. Alexander - Initial version, in ISORROPIA I +! 06 Jul 2007 - H. O. T. Pye - Initial version, in ISORROPIA II +! 29 Jan 2010 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC + ! Zero variables + HNO3_kg = 0.D0 + + ! convert from [mole/m3] to [kg] + HNO3_kg = GAS_HNO3(I,J,L) * 63.d-3 * AIRVOL(I,J,L) + + ! Return to calling program + END SUBROUTINE GET_GNO3 +!EOC +!------------------------------------------------------------------------------ +! Caltech Department of Chemical Engineering / Seinfeld Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: init_isoropiaII +! +! !DESCRIPTION: Subroutine INIT\_ISOROPIAII initializes all module arrays. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE INIT_ISOROPIAII +! +! !USES: +! + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" ! Size parameters +! +! !REVISION HISTORY: +! 06 Jul 2007 - H. O. T. Pye - Initial version +! 29 Jan 2010 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER :: AS + + !================================================================= + ! INIT_ISOROPIAII begins here! + !================================================================= + + WRITE(*,*) 'INIT_ISOROPIAII' + + ALLOCATE( HNO3_sav( IIPAR, JJPAR, LLTROP ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'HNO3_sav' ) + HNO3_sav = 0d0 + + ALLOCATE( GAS_HNO3( IIPAR, JJPAR, LLTROP ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'GAS_HNO3' ) + GAS_HNO3 = 0d0 + + ! AEROPH: diagnostic info (hotp 8/11/09) + ! Allocate up to LLPAR, but zero above LLTROP + ALLOCATE( PH_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PH_SAV' ) + PH_SAV = 0d0 + + ALLOCATE( HPLUS_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'HPLUS_SAV' ) + HPLUS_SAV = 0d0 + + ALLOCATE( WATER_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'WATER_SAV' ) + WATER_SAV = 0d0 + + ALLOCATE( SULRAT_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SULRAT_SAV' ) + SULRAT_SAV = 0d0 + + ALLOCATE( NARAT_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'NARAT_SAV' ) + NARAT_SAV = 0d0 + + ALLOCATE( ACIDPUR_SAV( IIPAR, JJPAR, LLPAR ) , STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'ACIDPUR_SAV' ) + ACIDPUR_SAV = 0d0 + + ! Return to calling program + END SUBROUTINE INIT_ISOROPIAII +!EOC +!------------------------------------------------------------------------------ +! Caltech Department of Chemical Engineering / Seinfeld Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: cleanup_isoropiaII +! +! !DESCRIPTION: Subroutine CLEANUP\_ISOROPIAII deallocates all module arrays. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE CLEANUP_ISOROPIAII +! +! !REVISION HISTORY: +! 06 Jul 2007 - H. O. T. Pye - Initial version +! 29 Jan 2010 - R. Yantosca - Added ProTeX headers +!EOP +!------------------------------------------------------------------------------ +!BOC + + IF ( ALLOCATED( HNO3_sav ) ) DEALLOCATE( HNO3_sav ) + IF ( ALLOCATED( GAS_HNO3 ) ) DEALLOCATE( GAS_HNO3 ) + ! AEROPH: Deallocate arrays for pH (hotp 8/11/09) + IF ( ALLOCATED( PH_SAV ) ) DEALLOCATE( PH_SAV ) + IF ( ALLOCATED( HPLUS_SAV ) ) DEALLOCATE( HPLUS_SAV ) + IF ( ALLOCATED( WATER_SAV ) ) DEALLOCATE( WATER_SAV ) + IF ( ALLOCATED( SULRAT_SAV ) ) DEALLOCATE( SULRAT_SAV ) + IF ( ALLOCATED( NARAT_SAV ) ) DEALLOCATE( NARAT_SAV ) + IF ( ALLOCATED( ACIDPUR_SAV ) ) DEALLOCATE( ACIDPUR_SAV) + + END SUBROUTINE CLEANUP_ISOROPIAII +!EOC + END MODULE ISOROPIAII_ADJ_MOD diff --git a/code/new/isoropiaIIcode_adj.f b/code/new/isoropiaIIcode_adj.f new file mode 100644 index 0000000..a8d2407 --- /dev/null +++ b/code/new/isoropiaIIcode_adj.f @@ -0,0 +1,32408 @@ +! +! NOTES: +! (1 ) Removed references to reverse problem code since GEOS-Chem +! will only need forward problem solution (hotp 8/1/07) +! (2 ) Explicitly declared some variables and made some common blocks +! THREADPRIVATE (hotp 8/2/07) +! (3 ) Removed DATA structure in CALCACT4 for parallelization +! (hotp 8/23/07) +! (4 ) Removed DELT and A2 print statement (hotp 8/30/07) +! (5 ) Removed SETPARM routine because it's not called (hotp 8/30/07) +! (6 ) Changed NADJ from 0 to 1 to force mass balance (hotp 11/7/07) +! (7 ) Stop code if ISRP4F is called due to mass balance +! issues (hotp 11/7/07) +! (8 ) If you wish to calculated act coeff online, check that DATA +! statements in KMFUL are not problematic for parallelization +! (9 ) Changed 1d-10 in ISRP3F to TINY for mass balance (hotp +! 11/14/07) +! (10 ) Added fix for negative H+ in CALCHS4 (hotp 8/25/09) +! search for 'PHFIX' to see where the fix was applied +! fix must be activated to use +! 23 Aug 2011 - S. Capps - ANISORROPIA implementation +! - only metastable routines included +! - online activity coefficient calculation only +! - removed auxiliary reverse problem routines +! +! *** VERY IMPORTANT PORTING WARNING (slc.1.2012) *** +! ANISORROPIA code is optimized for adjoint frameworks and will not +! perform commensurately with publicly released ISORROPIAII code. +! +! Please visit http://nenes.eas.gatech.edu/ISORROPIA for current +! releases of ISORROPIAII for forward modeling. +! +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ISOROPIAII +C *** THIS SUBROUTINE IS THE MASTER ROUTINE FOR THE ISORROPIA +C THERMODYNAMIC EQUILIBRIUM AEROSOL MODEL (VERSION 1.1 and above) +C +C ======================== ARGUMENTS / USAGE =========================== +C +C INPUT: +C 1. [WI] +C REAL*8 :: array of length [8]. +C Concentrations, expressed in moles/m3. Depending on the type of +C problem solved (specified in CNTRL(1)), WI contains either +C GAS+AEROSOL or AEROSOL only concentratios. +C WI(1) - sodium +C WI(2) - sulfate +C WI(3) - ammonium +C WI(4) - nitrate +C WI(5) - chloride +C WI(6) - calcium +C WI(7) - potassium +C WI(8) - magnesium +C +C 2. [RHI] +C REAL*8 :: variable. +C Ambient relative humidity expressed on a (0,1) scale. +C +C 3. [TEMPI] +C REAL*8 :: variable. +C Ambient temperature expressed in Kelvins. +C +C 4. [CNTRL] +C REAL*8 :: array of length [2]. +C Parameters that control the type of problem solved. +C +C CNTRL(1): Defines the type of problem solved. +C 0 - Forward problem is solved. In this case, array WI contains +C GAS and AEROSOL concentrations together. +C 1 - Reverse problem is solved. In this case, array WI contains +C AEROSOL concentrations only. +C +C CNTRL(2): Defines the state of the aerosol +C 0 - The aerosol can have both solid+liquid phases (deliquescent) +C 1 - The aerosol is in only liquid state (metastable aerosol) +C +C OUTPUT: +C 1. [WT] +C REAL*8 :: array of length [8]. +C Total concentrations (GAS+AEROSOL) of species, expressed in moles/m3. +C If the forward probelm is solved (CNTRL(1)=0), array WT is +C identical to array WI. +C WT(1) - total sodium +C WT(2) - total sulfate +C WT(3) - total ammonium +C WT(4) - total nitrate +C WT(5) - total chloride +C WT(6) - total calcium +C WT(7) - total potassium +C WT(8) - total magnesium +C +C 2. [GAS] +C REAL*8 :: array of length [03]. +C Gaseous species concentrations, expressed in moles/m3. +C GAS(1) - NH3 +C GAS(2) - HNO3 +C GAS(3) - HCl +C +C 3. [AERLIQ] +C REAL*8 :: array of length [15]. +C Liquid aerosol species concentrations, expressed in moles/m3. +C AERLIQ(01) - H+(aq) +C AERLIQ(02) - Na+(aq) +C AERLIQ(03) - NH4+(aq) +C AERLIQ(04) - Cl-(aq) +C AERLIQ(05) - SO4--(aq) +C AERLIQ(06) - HSO4-(aq) +C AERLIQ(07) - NO3-(aq) +C AERLIQ(08) - H2O +C AERLIQ(09) - NH3(aq) (undissociated) +C AERLIQ(10) - HNCl(aq) (undissociated) +C AERLIQ(11) - HNO3(aq) (undissociated) +C AERLIQ(12) - OH-(aq) +C AERLIQ(13) - Ca2+(aq) +C AERLIQ(14) - K+(aq) +C AERLIQ(15) - Mg2+(aq) +C +C 4. [AERSLD] +C REAL*8 :: array of length [19]. +C Solid aerosol species concentrations, expressed in moles/m3. +C AERSLD(01) - NaNO3(s) +C AERSLD(02) - NH4NO3(s) +C AERSLD(03) - NaCl(s) +C AERSLD(04) - NH4Cl(s) +C AERSLD(05) - Na2SO4(s) +C AERSLD(06) - (NH4)2SO4(s) +C AERSLD(07) - NaHSO4(s) +C AERSLD(08) - NH4HSO4(s) +C AERSLD(09) - (NH4)4H(SO4)2(s) +C AERSLD(10) - CaSO4(s) +C AERSLD(11) - Ca(NO3)2(s) +C AERSLD(12) - CaCl2(s) +C AERSLD(13) - K2SO4(s) +C AERSLD(14) - KHSO4(s) +C AERSLD(15) - KNO3(s) +C AERSLD(16) - KCl(s) +C AERSLD(17) - MgSO4(s) +C AERSLD(18) - Mg(NO3)2(s) +C AERSLD(19) - MgCl2(s) +C +C 5. [SCASI] +C CHARACTER*15 variable. +C Returns the subcase which the input corresponds to. +C +C 6. [OTHER] +C REAL*8 :: array of length [9]. +C Returns solution information. +C +C OTHER(1): Shows if aerosol water exists. +C 0 - Aerosol is WET +C 1 - Aerosol is DRY +C +C OTHER(2): Aerosol Sulfate ratio, defined as (in moles/m3) : +C (total ammonia + total Na) / (total sulfate) +C +C OTHER(3): Sulfate ratio based on aerosol properties that defines +C a sulfate poor system: +C (aerosol ammonia + aerosol Na) / (aerosol sulfate) +C +C OTHER(4): Aerosol sodium ratio, defined as (in moles/m3) : +C (total Na) / (total sulfate) +C +C OTHER(5): Ionic strength of the aqueous aerosol (if it exists). +C +C OTHER(6): Total number of calls to the activity coefficient +C calculation subroutine. +C +C OTHER(7): Sulfate ratio with crustal species, defined as (in moles/m3) : +C (total ammonia + total crustal species + total Na) / (total sulfate) +C +C OTHER(8): Crustal species + sodium ratio, defined as (in moles/m3) : +C (total crustal species + total Na) / (total sulfate) +C +C OTHER(9): Crustal species ratio, defined as (in moles/m3) : +C (total crustal species) / (total sulfate) +C +C 7. [TRUSTISO] +C LOGICAL variable. +C Returns internal error information. +C +C TRUE - no error occurred +C FALSE - error occurred +C +C 8. [NERR] +C INTEGER variable. +C Returns specific internal error information. +C +C Zero if no error occurred; otherwise, code of first error produced. +C - see subroutine ERRSTAT for classification of error codes. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ISOROPIAII (WI, RHI, TEMPI, CNTRL, + & WT, GAS, AERLIQ, AERSLD, SCASI, OTHER, + & TRUSTISO,NERR) + INCLUDE 'isrpia_adj.inc' + INTEGER, PARAMETER :: NCTRL = 2 + INTEGER, PARAMETER :: NOTHER = 9 + CHARACTER(LEN=15) :: SCASI + REAL*8 :: CNTRL, AERSLD, OTHER + LOGICAL :: TRUSTISO + REAL*8 :: WI, RHI, TEMPI, WT, GAS, AERLIQ + DIMENSION WI(NCOMP), WT(NCOMP), GAS(NGASAQ), AERSLD(NSLDS), + & AERLIQ(NIONS+NGASAQ+2), CNTRL(NCTRL), OTHER(NOTHER) + INTEGER :: ERRSTKI(25), NERR + CHARACTER(LEN=40) :: ERRMSGI(25) +C +C *** PROBLEM TYPE (0=FORWARD, 1=REVERSE) ****************************** +C + IPROB = NINT(CNTRL(1)) +C +C *** AEROSOL STATE (0=SOLID+LIQUID, 1=METASTABLE) ********************** +C + METSTBL = NINT(CNTRL(2)) +C +C *** SOLVE FORWARD PROBLEM ******************************************** +C +50 IF (IPROB == 0) THEN + IF ((WI(1)+WI(2)+WI(3)+WI(4)+WI(5)) <= TINY) THEN ! Everything=0 + !WRITE(*,*) 'Only calling INIT1' + CALL INIT1 (WI, RHI, TEMPI) + ELSE IF ((WI(1)+WI(4)+WI(5)) <= TINY) THEN ! Na,Cl,NO3=0 + !WRITE(*,*) 'Calling ISRP1F' + CALL ISRP1F (WI, RHI, TEMPI) + ELSE IF ((WI(1)+WI(5)) <= TINY) THEN ! Na,Cl=0 + !WRITE(*,*) 'Calling ISRP2F' + CALL ISRP2F (WI, RHI, TEMPI) + ELSE + !WRITE(*,*) 'Calling ISRP3F' + CALL ISRP3F (WI, RHI, TEMPI) + ENDIF +C +C *** SOLVE REVERSE PROBLEM ********************************************* +C +C ELSE +C IF ((WI(1)+WI(2)+WI(3)+WI(4)+WI(5)) <= TINY) THEN ! Everything=0 +CC CALL INIT1 (WI, RHI, TEMPI) +C ELSE IF ((WI(1)+WI(4)+WI(5)) <= TINY) THEN ! Na,Cl,NO3=0 +C CALL ISRP1R (WI, RHI, TEMPI) +C ELSE IF ((WI(1)+WI(5)) <= TINY) THEN ! Na,Cl=0 +C CALL ISRP2R (WI, RHI, TEMPI) +C ELSE +C CALL ISRP3R (WI, RHI, TEMPI) +C ENDIF + ENDIF +C +C *** ADJUST MASS BALANCE *********************************************** +C + IF (NADJ == 1) CALL ADJUST (WI) +ccC +ccC *** IF METASTABLE AND NO WATER - RESOLVE AS NORMAL ******************** +ccC +cc IF (WATER <= TINY .AND. METSTBL == 1) THEN +cc METSTBL = 0 +cc GOTO 50 +cc ENDIF +C +C *** SAVE RESULTS TO ARRAYS (units = mole/m3) **************************** +C + GAS(1) = GNH3 ! Gaseous aerosol species + GAS(2) = GHNO3 + GAS(3) = GHCL +C + DO I=1,7 ! Liquid aerosol species + AERLIQ(I) = MOLAL(I) + ENDDO + DO I=1,NGASAQ + AERLIQ(7+1+I) = GASAQ(I) + ENDDO + AERLIQ(7+1) = WATER*1.0D3/18.0D0 + AERLIQ(7+NGASAQ+2) = COH +C + DO I=8,10 ! Liquid aerosol species + AERLIQ(I+5) = MOLAL(I) + ENDDO +C + AERSLD(1) = CNANO3 ! Solid aerosol species + AERSLD(2) = CNH4NO3 + AERSLD(3) = CNACL + AERSLD(4) = CNH4CL + AERSLD(5) = CNA2SO4 + AERSLD(6) = CNH42S4 + AERSLD(7) = CNAHSO4 + AERSLD(8) = CNH4HS4 + AERSLD(9) = CLC + AERSLD(10) = CCASO4 + AERSLD(11) = CCANO32 + AERSLD(12) = CCACL2 + AERSLD(13) = CK2SO4 + AERSLD(14) = CKHSO4 + AERSLD(15) = CKNO3 + AERSLD(16) = CKCL + AERSLD(17) = CMGSO4 + AERSLD(18) = CMGNO32 + AERSLD(19) = CMGCL2 +C + IF(WATER <= TINY) THEN ! Dry flag + OTHER(1) = 1.d0 + ELSE + OTHER(1) = 0.d0 + ENDIF +C + OTHER(2) = SULRAT ! Other stuff + OTHER(3) = SULRATW + OTHER(4) = SODRAT + OTHER(5) = IONIC + OTHER(6) = ICLACT + OTHER(7) = SO4RAT + OTHER(8) = CRNARAT + OTHER(9) = CRRAT +C + SCASI = SCASE +C + WT(1) = WI(1) ! Total gas+aerosol phase + WT(2) = WI(2) + WT(3) = WI(3) + WT(4) = WI(4) + WT(5) = WI(5) + WT(6) = WI(6) + WT(7) = WI(7) + WT(8) = WI(8) + + ! For reverse mode only (slc.8.2012) + !IF (IPROB > 0 .AND. WATER > TINY) THEN + ! WT(3) = WT(3) + GNH3 + ! WT(4) = WT(4) + GHNO3 + ! WT(5) = WT(5) + GHCL + !ENDIF + + NERR = 0 +C +C slc.debug +C +C WRITE(*,*) '============= ANISORROPIA Debug ==============' +C WRITE(*,*) 'Inside ISORROPIA Forward' +C WRITE(*,*) 'WI: ',WI +C WRITE(*,*) 'RHI: ',RHI, ' TEMPI: ',TEMPI +C WRITE(*,*) 'GAS: ',GAS +C WRITE(*,*) 'AERLIQ: ',AERLIQ(1:7) +C WRITE(*,*) AERLIQ(8:13) +C WRITE(*,*) '==============================================' +C WRITE(*,*) 'SCASE: ',SCASE +C WRITE(*,*) 'TRUSTISO ',TRUSTISO +C WRITE(*,*) '==============================================' +C +C *** Check for errors **************************************************** +C + TRUSTISO = .TRUE. + !WRITE(*,*) 'ISO, TRUSTISO: ',TRUSTISO,', RH: ',RHI,', T: ',TEMPI + CALL ISERRINF (ERRSTKI, ERRMSGI, NOFER, STKOFL) ! Obtain error stack +C IF (NOFER > 0) TRUSTISO = .FALSE. ! Errors found + IF (NOFER > 0) THEN + + TRUSTISO = .FALSE. ! Errors found + NERR = ERRSTKI(1) + +C WRITE(*,*) 'Forward: TRUSTISO = F', ERRSTKI(1) +C WRITE(6,*) 'Err Msg',ERRMSGI(1) +C WRITE(6,*) '# of errors ', NOFER + ENDIF +C + RETURN +C +C *** END OF SUBROUTINE ISOROPIA ****************************************** +C + END + + +C======================================================================= +C +C *** ANISORROPIA CODE +C *** SUBROUTINE ISOROPIA_B +C *** THIS SUBROUTINE IS THE MASTER ROUTINE FOR THE ADJOINT OF ISORROPIA +C THERMODYNAMIC EQUILIBRIUM AEROSOL MODEL (VERSION 1.1 and above) +C +C ANISORROPIA ROUTINE. (slc.8.2011) +C +C======================================================================= +C + SUBROUTINE ISOROPIAII_ADJ(WI, WPB, RHI, TEMPI, CNTRL, + & WT, GAS, GASb, AERLIQ, AERLIQb, AERSLD, + & SCASI, OTHER, TRUSTISO, NERR) + INCLUDE 'isrpia_adj.inc' + INTEGER, PARAMETER :: NCTRL = 2 + INTEGER, PARAMETER :: NOTHER = 9 + CHARACTER(LEN=15) :: SCASI + LOGICAL :: TRUSTISO + REAL*8 :: wp(ncomp), aerliq, gas + REAL*8 :: wpb(ncomp) + REAL*8 :: WTORIG, GASORIG, AERLIQORIG + REAL*8 :: wi, RHI + REAL*8 :: gasb(ngasaq), aerliqb(nions+ngasaq+2) + INTEGER :: ERRSTKI(25), NERR + CHARACTER(LEN=40) :: ERRMSGI(25) + DIMENSION WI(NCOMP), WT(NCOMP), GAS(NGASAQ), AERSLD(NSLDS), + & AERLIQ(NIONS+NGASAQ+2), CNTRL(NCTRL), OTHER(NOTHER) +C +C slc.debug +C +C WRITE(*,*) '============= ANISORROPIA Debug ==============' +C WRITE(*,*) 'Inside ANISORROPIA' +C WRITE(*,*) 'WI: ',WI +C WRITE(*,*) 'RHI: ',RHI, ' TEMPI: ',TEMPI +C WRITE(*,*) '==============================================' +C WRITE(*,*) 'gas_b: ',gasb +C WRITE(*,*) 'aerliq_b: ',aerliqb(1:7) +C WRITE(*,*) aerliqb(8:13) +C WRITE(*,*) '==============================================' +C +C *** PROBLEM TYPE (0=FORWARD, 1=REVERSE) ****************************** +C + IPROB = NINT(CNTRL(1)) +C +C *** AEROSOL STATE (0=SOLID+LIQUID, 1=METASTABLE) ********************** +C + METSTBL = NINT(CNTRL(2)) +C +C *** SOLVE FORWARD PROBLEM ******************************************** +C + IF (WI(1)+WI(2)+WI(3)+WI(4)+WI(5) <= TINY) THEN ! Everything=0 + CALL INIT1 (WI,RHI,TEMPI) + ELSE IF (WI(1)+WI(4)+WI(5) <= TINY) THEN ! Na,Cl,NO3=0 +C CALL ISRP1F (WI, RHI, TEMPI) +C +C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +C + CALL INIT1 (WI, RHI, TEMPI) +C WP = W +C +C *** CALCULATE SULFATE RATIO TO SEND TO APPROPRIATE CALC *************** +C + SULRAT = W(3)/W(2) +C +C *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** +C + IF (2.0 <= SULRAT) THEN + SCASE = 'A2' + CALL ISRP1FA_AB(wpb, gasb, aerliqb) + ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN + SCASE = 'B4' + CALL CALCB4_BB(wpb, gasb, aerliqb) + ELSEIF (SULRAT < 1.0) THEN + SCASE = 'C2' + CALL CALCC2_CB(wpb, gasb, aerliqb) + ELSE + RETURN + ENDIF + !RETURN + ELSE IF (WI(1)+WI(5) <= TINY) THEN ! Na,Cl=0 +C +C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +C + CALL INIT2 (WI, RHI, TEMPI) +C +C *** CALCULATE SULFATE RATIO TO SEND TO APPROPRIATE CALC *************** +C + SULRAT = W(3)/W(2) +C +C *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** +C + IF (2.0 <= SULRAT) THEN + SCASE = 'D3' + CALL CALCD3_B(wpb, gasb, aerliqb) + ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN + SCASE = 'E4' + CALL CALCB4E_EB(wpb, gasb, aerliqb) + ELSEIF (SULRAT < 1.0) THEN + SCASE = 'F2' + CALL CALCC2F_FB(wpb, gasb, aerliqb) + ELSE + RETURN + ENDIF + !RETURN +C + ELSE IF (WI(1)+WI(5) > TINY) THEN ! Na,Cl>0 +C +C *** SULFATE POOR ; SODIUM POOR +C + REST = 2.D0*WI(2) + WI(4) + WI(5) + IF (WI(1) > REST) THEN ! NA > 2*SO4+CL+NO3 ? + WI(1) = (ONE-1D-6)*REST ! Adjust Na amount + CALL PUSHERR (0050, 'ISRP3F') ! Warning error: Na adjusted + ENDIF +C +C *** CALCULATE SULFATE & SODIUM RATIOS ********************************* +C + SULRAT = (WI(1)+WI(3))/WI(2) + SODRAT = WI(1)/WI(2) +C + IF (2.0 <= SULRAT .AND. SODRAT < 2.0) THEN +C +C *** ADJUST FOR TOO LITTLE AMMONIUM AND CHLORIDE *********************** +C + WI(3) = MAX (WI(3), 1.D-10) ! NH4+ : 1e-4 umoles/m3 + WI(5) = MAX (WI(5), 1.D-10) ! Cl- : 1e-4 umoles/m3 +C +C *** ADJUST FOR TOO LITTLE SODIUM, SULFATE AND NITRATE COMBINED ******** +C + IF (WI(1)+WI(2)+WI(4) <= 1d-10) THEN + WI(1) = 1.D-10 ! Na+ : 1e-4 umoles/m3 + WI(2) = 1.D-10 ! SO4- : 1e-4 umoles/m3 + ENDIF +C +C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +C + CALL ISOINIT3 (WI, RHI, TEMPI) +C +C *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE ********* +C + REST = 2.D0*W(2) + W(4) + W(5) + IF (W(1) > REST) THEN ! NA > 2*SO4+CL+NO3 ? + W(1) = (ONE-1D-6)*REST ! Adjust Na amount + CALL PUSHERR (0050, 'ISRP3F') ! Warning error: Na adjusted + ENDIF +C +C *** CALCULATE SULFATE & SODIUM RATIOS ********************************* +C + SULRAT = (W(1)+W(3))/W(2) + SODRAT = W(1)/W(2) +C +C *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** + SCASE = 'G5' + CALL CALCG5_B(wpb, gasb, aerliqb) ! Only liquid (metastable) +C + ELSEIF (SULRAT >= 2.0 .AND. SODRAT >= 2.0) THEN +C +C *** ADJUST FOR TOO LITTLE AMMONIUM AND CHLORIDE *********************** +C + WI(3) = MAX (WI(3), 1.D-10) ! NH4+ : 1e-4 umoles/m3 + WI(5) = MAX (WI(5), 1.D-10) ! Cl- : 1e-4 umoles/m3 +C +C *** ADJUST FOR TOO LITTLE SODIUM, SULFATE AND NITRATE COMBINED ******** +C + IF (WI(1)+WI(2)+WI(4) <= 1d-10) THEN + WI(1) = 1.D-10 ! Na+ : 1e-4 umoles/m3 + WI(2) = 1.D-10 ! SO4- : 1e-4 umoles/m3 + ENDIF +C +C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +C + CALL ISOINIT3 (WI, RHI, TEMPI) +C +C *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE ********* +C + REST = 2.D0*W(2) + W(4) + W(5) + IF (W(1) > REST) THEN ! NA > 2*SO4+CL+NO3 ? + W(1) = (ONE-1D-6)*REST ! Adjust Na amount + CALL PUSHERR (0050, 'ISRP3F') ! Warning error: Na adjusted + ENDIF +C +C *** CALCULATE SULFATE & SODIUM RATIOS ********************************* +C + SULRAT = (W(1)+W(3))/W(2) + SODRAT = W(1)/W(2) +C + SCASE = 'H6' + CALL CALCH6_B(wpb, gasb, aerliqb) ! Only liquid (metastable) + ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN + CALL ISOINIT3 (WI, RHI, TEMPI) + SCASE = 'I6' + CALL ISRP3F_IB(wpb, gasb, aerliqb, rhi, tempi) ! Only liquid (metastable) + ELSEIF (SULRAT < 1.0) THEN + CALL ISOINIT3 (WI, RHI, TEMPI) + SCASE = 'J3' + CALL ISRP3F_JB(wpb, gasb, aerliqb, rhi, tempi) ! Only liquid (metastable) + ENDIF + ENDIF +C +C *** SOLVE REVERSE PROBLEM ********************************************* +C +C ELSE +C +C *** Reverse routines not yet treated ********************************** +C +C IF (WI(1)+WI(2)+WI(3)+WI(4)+WI(5) <= TINY) THEN ! Everything=0 +C CALL INIT1 (WI, RHI, TEMPI) +C ELSE IF (WI(1)+WI(4)+WI(5) <= TINY) THEN ! Na,Cl,NO3=0 +C CALL ISRP1R (WI, RHI, TEMPI) +C ELSE IF (WI(1)+WI(5) <= TINY) THEN ! Na,Cl=0 +C CALL ISRP2R (WI, RHI, TEMPI) +C ELSE +C CALL ISRP3R (WI, RHI, TEMPI) +C ENDIF +C ENDIF +C RETURN +C +C *** ADJUST MASS BALANCE *********************************************** +C + IF (NADJ == 1) CALL ADJUST (WI) +ccC +ccC *** IF METASTABLE AND NO WATER - RESOLVE AS NORMAL ******************** +ccC +cc IF (WATER <= TINY .AND. METSTBL == 1) THEN +cc METSTBL = 0 +cc GOTO 50 +cc ENDIF +C +C *** SAVE RESULTS TO ARRAYS (units = MICROGRAMS/m3) **************************** +C +C + GAS(1) = GNH3 ! Gaseous aerosol species + GAS(2) = GHNO3 + GAS(3) = GHCL +C + DO I=1,7 ! Liquid aerosol species + AERLIQ(I) = MOLAL(I) + ENDDO + DO I=1,NGASAQ + AERLIQ(7+1+I) = GASAQ(I) + ENDDO + AERLIQ(7+1) = WATER*1.0D3/18.0D0 + AERLIQ(7+NGASAQ+2) = COH +C + DO I=8,10 ! Liquid aerosol species + AERLIQ(I+5) = MOLAL(I) + ENDDO +C + AERSLD(1) = CNANO3 ! Solid aerosol species + AERSLD(2) = CNH4NO3 + AERSLD(3) = CNACL + AERSLD(4) = CNH4CL + AERSLD(5) = CNA2SO4 + AERSLD(6) = CNH42S4 + AERSLD(7) = CNAHSO4 + AERSLD(8) = CNH4HS4 + AERSLD(9) = CLC + AERSLD(10) = CCASO4 + AERSLD(11) = CCANO32 + AERSLD(12) = CCACL2 + AERSLD(13) = CK2SO4 + AERSLD(14) = CKHSO4 + AERSLD(15) = CKNO3 + AERSLD(16) = CKCL + AERSLD(17) = CMGSO4 + AERSLD(18) = CMGNO32 + AERSLD(19) = CMGCL2 +C + IF(WATER <= TINY) THEN ! Dry flag + OTHER(1) = 1.d0 + ELSE + OTHER(1) = 0.d0 + ENDIF +C + OTHER(2) = SULRAT ! Other stuff + OTHER(3) = SULRATW + OTHER(4) = SODRAT + OTHER(5) = IONIC + OTHER(6) = ICLACT + OTHER(7) = SO4RAT + OTHER(8) = CRNARAT + OTHER(9) = CRRAT +C + SCASI = SCASE +C +C slc.debug +C +C WRITE(*,*) '==============================================' +C WRITE(*,*) 'GAS: ',GAS +C WRITE(*,*) 'AERLIQ: ',AERLIQ(1:7) +C WRITE(*,*) AERLIQ(8:13) +C WRITE(*,*) 'wp_b: ',wpb +C WRITE(*,*) 'SCASE: ',SCASE +C WRITE(*,*) 'TRUSTISO ',TRUSTISO +C WRITE(*,*) '==============================================' +C + ! For reverse mode only (slc.8.2012) + !IF (IPROB > 0 .AND. WATER > TINY) THEN + ! WT(3) = WT(3) + GNH3 + ! WT(4) = WT(4) + GHNO3 + ! WT(5) = WT(5) + GHCL + !ENDIF +C +C *** Check for errors **************************************************** +C + TRUSTISO = .TRUE. + CALL ISERRINF (ERRSTKI, ERRMSGI, NOFER, STKOFL) ! Obtain error stack + IF (NOFER > 0) THEN + + TRUSTISO = .FALSE. ! Errors found + NERR = ERRSTKI(1) + +C WRITE(*,*) 'Forward: TRUSTISO = F', ERRSTKI(1) +C WRITE(6,*) 'Err Msg',ERRMSGI(1) +C WRITE(6,*) '# of errors ', NOFER + ENDIF +C + RETURN +C +C *** END OF SUBROUTINE ISOROPIA ****************************************** +C + END +C +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE SETPARM +C *** THIS SUBROUTINE REDEFINES THE SOLUTION PARAMETERS OF ISORROPIA +C +C ======================== ARGUMENTS / USAGE =========================== +C +C *** NOTE: IF NEGATIVE VALUES ARE GIVEN FOR A PARAMETER, IT IS +C IGNORED AND THE CURRENT VALUE IS USED INSTEAD. +C +C INPUT: +C 1. [WFTYPI] +C INTEGER variable. +C Defines the type of weighting algorithm for the solution in Mutual +C Deliquescence Regions (MDR's): +C 0 - MDR's are assumed dry. This is equivalent to the approach +C used by SEQUILIB. +C 1 - The solution is assumed "half" dry and "half" wet throughout +C the MDR. +C 2 - The solution is a relative-humidity weighted mean of the +C dry and wet solutions (as defined in Nenes et al., 1998) +C +C 2. [IACALCI] +C INTEGER variable. +C Method of activity coefficient calculation: +C 0 - Calculate coefficients during runtime +C 1 - Use precalculated tables +C +C 3. [EPSI] +C DOUBLE PRECITION variable. +C Defines the convergence criterion for all iterative processes +C in ISORROPIA, except those for activity coefficient calculations +C (EPSACTI controls that). +C +C 4. [MAXITI] +C INTEGER variable. +C Defines the maximum number of iterations for all iterative +C processes in ISORROPIA, except for activity coefficient calculations +C (NSWEEPI controls that). +C +C 5. [NSWEEPI] +C INTEGER variable. +C Defines the maximum number of iterations for activity coefficient +C calculations. +C +C 6. [EPSACTI] +C REAL*8 :: variable. +C Defines the convergence criterion for activity coefficient +C calculations. +C +C 7. [NDIV] +C INTEGER variable. +C Defines the number of subdivisions needed for the initial root +C tracking for the bisection method. Usually this parameter should +C not be altered, but is included for completeness. +C +C 8. [NADJ] +C INTEGER variable. +C Forces the solution obtained to satisfy total mass balance +C to machine precision +C 0 - No adjustment done (default) +C 1 - Do adjustment +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C +! SUBROUTINE SETPARM (WFTYPI, IACALCI, EPSI, MAXITI, NSWEEPI, +! & EPSACTI, NDIVI, NADJI) +! INCLUDE 'isrpia_adj.inc' +! REAL*8 :: EPSI, EPSACTI +! INTEGER :: WFTYPI +!C +!C *** SETUP SOLUTION PARAMETERS ***************************************** +!C +! IF (WFTYPI >= 0) WFTYP = WFTYPI +! IF (IACALCI >= 0) IACALC = IACALCI +! IF (EPSI >= ZERO) EPS = EPSI +! IF (MAXITI > 0) MAXIT = MAXITI +! IF (NSWEEPI > 0) NSWEEP = NSWEEPI +! IF (EPSACTI >= ZERO) EPSACT = EPSACTI +! IF (NDIVI > 0) NDIV = NDIVI +! IF (NADJI >= 0) NADJ = NADJI +!C +!C *** END OF SUBROUTINE SETPARM ***************************************** +!C +! RETURN +! END +! +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE GETPARM +C *** THIS SUBROUTINE OBTAINS THE CURRENT VAULES OF THE SOLUTION +C PARAMETERS OF ISORROPIA +C +C ======================== ARGUMENTS / USAGE =========================== +C +C *** THE PARAMETERS ARE THOSE OF SUBROUTINE SETPARM +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE GETPARM (WFTYPI, IACALCI, EPSI, MAXITI, NSWEEPI, + & EPSACTI, NDIVI, NADJI) + INCLUDE 'isrpia_adj.inc' + INTEGER WFTYPI +C +C *** GET SOLUTION PARAMETERS ******************************************* +C + WFTYPI = WFTYP + IACALCI = IACALC + EPSI = EPS + MAXITI = MAXIT + NSWEEPI = NSWEEP + EPSACTI = EPSACT + NDIVI = NDIV + NADJI = NADJ +C +C *** END OF SUBROUTINE GETPARM ***************************************** +C + RETURN + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** BLOCK DATA BLKISO +C *** THIS SUBROUTINE PROVIDES INITIAL (DEFAULT) VALUES TO PROGRAM +C PARAMETERS VIA DATA STATEMENTS +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C *** ZSR RELATIONSHIP PARAMETERS MODIFIED BY DOUGLAS WALDRON +C *** OCTOBER 2003 +C *** BASED ON AIM MODEL III (http://mae.ucdavis.edu/wexler/aim) +C +C======================================================================= +C + BLOCK DATA BLKISO + INCLUDE 'isrpia_adj.inc' +C +C *** DEFAULT VALUES ************************************************* +C +C DATA TEMP/298.0/, R/82.0567D-6/, RH/0.9D0/, EPS/1D-10/, +C & MAXIT/100/, TINY/1D-20/, GREAT/1D10/, ZERO/0.0D0/, +C & ONE/1.0D0/,NSWEEP/10/, TINY2/1D-11/, NDIV/5/ + +C ! EPS = 1d-10 instead of 1d-6 !slc.8.2011! +C ! Increase the stringency of convergence criteria +C +C ! NSWEEP = 10 instead of 4 +C ! Increase number of iterations possible to attain convergence + +C +C DATA MOLAL/NIONS*0.0D0/, MOLALR/NPAIR*0.0D0/, GAMA/NPAIR*0.1D0/, +C & GAMOU/NPAIR*1D10/, GAMIN/NPAIR*1D10/, CALAIN/.TRUE./, +C & CALAOU/.TRUE./, EPSACT/1D-10/, ICLACT/0/, +C & IACALC/0/, NADJ/0/, WFTYP/2/ + +C ! EPSACT = 1d-10 instead of 5d-2 !slc.8.2011! +C ! Increase precision of activity coefficient calculation +C +C ! NADJ = 0 instead of 1 +C ! No mass conservation routines have an adjoint +C +C ! IACALC = 0 instead of 1 +C ! Online activity coefficient calculation required + +C +C DATA ERRSTK/NERRMX*0/, ERRMSG/NERRMX*' '/, NOFER/0/, +C & STKOFL/.FALSE./ +C +C DATA IPROB/0/, METSTBL/0/ +C +C DATA VERSION /'2.0 (03/19/07)'/ +C +C *** OTHER PARAMETERS *********************************************** +C +C DATA SMW/58.5,142.,85.0,132.,80.0,53.5,98.0,98.0,115.,63.0, +C & 36.5,120.,247./ +C & IMW/ 1.0,23.0,18.0,35.5,96.0,97.0,63.0/, +C & WMW/23.0,98.0,17.0,63.0,36.5/ +C +C REAL*8 :: ZZ(NPAIR) = (/ 1,2,1,2,1,1,2,1,1,1,1,1,2,4,2,2,2, +C & 1,1,1,4,2,2 /) +C REAL*8 :: Z(NIONS) = (/ 1.0D0, 1.0D0, 1.0D0, 1.0D0, 2.0D0, +C & 1.0D0, 1.0D0, 2.0D0, 1.0D0, 2.0D0 /) +C +C *** ZSR RELATIONSHIP PARAMETERS ************************************** +C +C awas= ammonium sulfate +C + DATA AWAS/10*187.72, + & 158.13,134.41,115.37,100.10, 87.86, 78.00, 70.00, 63.45, 58.02, + & 53.46, + & 49.59, 46.26, 43.37, 40.84, 38.59, 36.59, 34.79, 33.16, 31.67, + & 30.31, + & 29.07, 27.91, 26.84, 25.84, 24.91, 24.03, 23.21, 22.44, 21.70, + & 21.01, + & 20.34, 19.71, 19.11, 18.54, 17.99, 17.46, 16.95, 16.46, 15.99, + & 15.54, + & 15.10, 14.67, 14.26, 13.86, 13.47, 13.09, 12.72, 12.36, 12.01, + & 11.67, + & 11.33, 11.00, 10.68, 10.37, 10.06, 9.75, 9.45, 9.15, 8.86, + & 8.57, + & 8.29, 8.01, 7.73, 7.45, 7.18, 6.91, 6.64, 6.37, 6.10, + & 5.83, + & 5.56, 5.29, 5.02, 4.74, 4.47, 4.19, 3.91, 3.63, 3.34, + & 3.05, + & 2.75, 2.45, 2.14, 1.83, 1.51, 1.19, 0.87, 0.56, 0.26, + & 0.1/ +C +C awsn= sodium nitrate +C + DATA AWSN/10*394.54, + & 338.91,293.01,254.73,222.61,195.56,172.76,153.53,137.32,123.65, + & 112.08, + & 102.26, 93.88, 86.68, 80.45, 75.02, 70.24, 66.02, 62.26, 58.89, + & 55.85, + & 53.09, 50.57, 48.26, 46.14, 44.17, 42.35, 40.65, 39.06, 37.57, + & 36.17, + & 34.85, 33.60, 32.42, 31.29, 30.22, 29.20, 28.22, 27.28, 26.39, + & 25.52, + & 24.69, 23.89, 23.12, 22.37, 21.65, 20.94, 20.26, 19.60, 18.96, + & 18.33, + & 17.72, 17.12, 16.53, 15.96, 15.40, 14.85, 14.31, 13.78, 13.26, + & 12.75, + & 12.25, 11.75, 11.26, 10.77, 10.29, 9.82, 9.35, 8.88, 8.42, + & 7.97, + & 7.52, 7.07, 6.62, 6.18, 5.75, 5.32, 4.89, 4.47, 4.05, + & 3.64, + & 3.24, 2.84, 2.45, 2.07, 1.70, 1.34, 0.99, 0.65, 0.31, + & 0.1/ +C +C awsc= sodium chloride +C + DATA AWSC/10*28.16, + & 27.17, 26.27, 25.45, 24.69, 23.98, 23.33, 22.72, 22.14, 21.59, + & 21.08, + & 20.58, 20.12, 19.67, 19.24, 18.82, 18.43, 18.04, 17.67, 17.32, + & 16.97, + & 16.63, 16.31, 15.99, 15.68, 15.38, 15.08, 14.79, 14.51, 14.24, + & 13.97, + & 13.70, 13.44, 13.18, 12.93, 12.68, 12.44, 12.20, 11.96, 11.73, + & 11.50, + & 11.27, 11.05, 10.82, 10.60, 10.38, 10.16, 9.95, 9.74, 9.52, + & 9.31, + & 9.10, 8.89, 8.69, 8.48, 8.27, 8.07, 7.86, 7.65, 7.45, + & 7.24, + & 7.04, 6.83, 6.62, 6.42, 6.21, 6.00, 5.79, 5.58, 5.36, + & 5.15, + & 4.93, 4.71, 4.48, 4.26, 4.03, 3.80, 3.56, 3.32, 3.07, + & 2.82, + & 2.57, 2.30, 2.04, 1.76, 1.48, 1.20, 0.91, 0.61, 0.30, + & 0.1/ +C +C awac= ammonium chloride +C + DATA AWAC/10*1209.00, + & 1067.60,949.27,848.62,761.82,686.04,619.16,559.55,505.92,457.25, + & 412.69, + & 371.55,333.21,297.13,262.81,229.78,197.59,165.98,135.49,108.57, + & 88.29, + & 74.40, 64.75, 57.69, 52.25, 47.90, 44.30, 41.27, 38.65, 36.36, + & 34.34, + & 32.52, 30.88, 29.39, 28.02, 26.76, 25.60, 24.51, 23.50, 22.55, + & 21.65, + & 20.80, 20.00, 19.24, 18.52, 17.83, 17.17, 16.54, 15.93, 15.35, + & 14.79, + & 14.25, 13.73, 13.22, 12.73, 12.26, 11.80, 11.35, 10.92, 10.49, + & 10.08, + & 9.67, 9.28, 8.89, 8.51, 8.14, 7.77, 7.42, 7.06, 6.72, + & 6.37, + & 6.03, 5.70, 5.37, 5.05, 4.72, 4.40, 4.08, 3.77, 3.45, + & 3.14, + & 2.82, 2.51, 2.20, 1.89, 1.57, 1.26, 0.94, 0.62, 0.31, + & 0.1/ +C +C awss= sodium sulfate +C + DATA AWSS/10*24.10, + & 23.17, 22.34, 21.58, 20.90, 20.27, 19.69, 19.15, 18.64, 18.17, + & 17.72, + & 17.30, 16.90, 16.52, 16.16, 15.81, 15.48, 15.16, 14.85, 14.55, + & 14.27, + & 13.99, 13.73, 13.47, 13.21, 12.97, 12.73, 12.50, 12.27, 12.05, + & 11.84, + & 11.62, 11.42, 11.21, 11.01, 10.82, 10.63, 10.44, 10.25, 10.07, + & 9.89, + & 9.71, 9.53, 9.36, 9.19, 9.02, 8.85, 8.68, 8.51, 8.35, + & 8.19, + & 8.02, 7.86, 7.70, 7.54, 7.38, 7.22, 7.06, 6.90, 6.74, + & 6.58, + & 6.42, 6.26, 6.10, 5.94, 5.78, 5.61, 5.45, 5.28, 5.11, + & 4.93, + & 4.76, 4.58, 4.39, 4.20, 4.01, 3.81, 3.60, 3.39, 3.16, + & 2.93, + & 2.68, 2.41, 2.13, 1.83, 1.52, 1.19, 0.86, 0.54, 0.25, + & 0.1/ +C +C awab= ammonium bisulfate +C + DATA AWAB/10*312.84, + & 271.43,237.19,208.52,184.28,163.64,145.97,130.79,117.72,106.42, + & 96.64, + & 88.16, 80.77, 74.33, 68.67, 63.70, 59.30, 55.39, 51.89, 48.76, + & 45.93, + & 43.38, 41.05, 38.92, 36.97, 35.18, 33.52, 31.98, 30.55, 29.22, + & 27.98, + & 26.81, 25.71, 24.67, 23.70, 22.77, 21.90, 21.06, 20.27, 19.52, + & 18.80, + & 18.11, 17.45, 16.82, 16.21, 15.63, 15.07, 14.53, 14.01, 13.51, + & 13.02, + & 12.56, 12.10, 11.66, 11.24, 10.82, 10.42, 10.04, 9.66, 9.29, + & 8.93, + & 8.58, 8.24, 7.91, 7.58, 7.26, 6.95, 6.65, 6.35, 6.05, + & 5.76, + & 5.48, 5.20, 4.92, 4.64, 4.37, 4.09, 3.82, 3.54, 3.27, + & 2.99, + & 2.70, 2.42, 2.12, 1.83, 1.52, 1.22, 0.90, 0.59, 0.28, + & 0.1/ +C +C awsa= sulfuric acid +C + DATA AWSA/34.00, 33.56, 29.22, 26.55, 24.61, 23.11, 21.89, 20.87, + & 19.99, 18.45, + & 17.83, 17.26, 16.73, 16.25, 15.80, 15.38, 14.98, 14.61, 14.26, + & 13.93, + & 13.61, 13.30, 13.01, 12.73, 12.47, 12.21, 11.96, 11.72, 11.49, + & 11.26, + & 11.04, 10.83, 10.62, 10.42, 10.23, 10.03, 9.85, 9.67, 9.49, + & 9.31, + & 9.14, 8.97, 8.81, 8.65, 8.49, 8.33, 8.18, 8.02, 7.87, + & 7.73, + & 7.58, 7.44, 7.29, 7.15, 7.01, 6.88, 6.74, 6.61, 6.47, + & 6.34, + & 6.21, 6.07, 5.94, 5.81, 5.68, 5.55, 5.43, 5.30, 5.17, + & 5.04, + & 4.91, 4.78, 4.65, 4.52, 4.39, 4.26, 4.13, 4.00, 3.86, + & 3.73, + & 3.59, 3.45, 3.31, 3.17, 3.02, 2.87, 2.71, 2.56, 2.39, + & 2.22, + & 2.05, 1.87, 1.68, 1.48, 1.27, 1.04, 0.80, 0.55, 0.28, + & 0.1/ +C +C awlc= (NH4)3H(SO4)2 +C + DATA AWLC/10*125.37, + & 110.10, 97.50, 86.98, 78.08, 70.49, 63.97, 58.33, 53.43, 49.14, + & 45.36, + & 42.03, 39.07, 36.44, 34.08, 31.97, 30.06, 28.33, 26.76, 25.32, + & 24.01, + & 22.81, 21.70, 20.67, 19.71, 18.83, 18.00, 17.23, 16.50, 15.82, + & 15.18, + & 14.58, 14.01, 13.46, 12.95, 12.46, 11.99, 11.55, 11.13, 10.72, + & 10.33, + & 9.96, 9.60, 9.26, 8.93, 8.61, 8.30, 8.00, 7.72, 7.44, + & 7.17, + & 6.91, 6.66, 6.42, 6.19, 5.96, 5.74, 5.52, 5.31, 5.11, + & 4.91, + & 4.71, 4.53, 4.34, 4.16, 3.99, 3.81, 3.64, 3.48, 3.31, + & 3.15, + & 2.99, 2.84, 2.68, 2.53, 2.37, 2.22, 2.06, 1.91, 1.75, + & 1.60, + & 1.44, 1.28, 1.12, 0.95, 0.79, 0.62, 0.45, 0.29, 0.14, + & 0.1/ +C +C awan= ammonium nitrate +C + DATA AWAN/10*960.19, + & 853.15,763.85,688.20,623.27,566.92,517.54,473.91,435.06,400.26, + & 368.89, + & 340.48,314.63,291.01,269.36,249.46,231.11,214.17,198.50,184.00, + & 170.58, + & 158.15,146.66,136.04,126.25,117.24,108.97,101.39, 94.45, 88.11, + & 82.33, + & 77.06, 72.25, 67.85, 63.84, 60.16, 56.78, 53.68, 50.81, 48.17, + & 45.71, + & 43.43, 41.31, 39.32, 37.46, 35.71, 34.06, 32.50, 31.03, 29.63, + & 28.30, + & 27.03, 25.82, 24.67, 23.56, 22.49, 21.47, 20.48, 19.53, 18.61, + & 17.72, + & 16.86, 16.02, 15.20, 14.41, 13.64, 12.89, 12.15, 11.43, 10.73, + & 10.05, + & 9.38, 8.73, 8.09, 7.47, 6.86, 6.27, 5.70, 5.15, 4.61, + & 4.09, + & 3.60, 3.12, 2.66, 2.23, 1.81, 1.41, 1.03, 0.67, 0.32, + & 0.1/ +C +C awsb= sodium bisulfate +C + DATA AWSB/10*55.99, + & 53.79, 51.81, 49.99, 48.31, 46.75, 45.28, 43.91, 42.62, 41.39, + & 40.22, + & 39.10, 38.02, 36.99, 36.00, 35.04, 34.11, 33.21, 32.34, 31.49, + & 30.65, + & 29.84, 29.04, 28.27, 27.50, 26.75, 26.01, 25.29, 24.57, 23.87, + & 23.17, + & 22.49, 21.81, 21.15, 20.49, 19.84, 19.21, 18.58, 17.97, 17.37, + & 16.77, + & 16.19, 15.63, 15.08, 14.54, 14.01, 13.51, 13.01, 12.53, 12.07, + & 11.62, + & 11.19, 10.77, 10.36, 9.97, 9.59, 9.23, 8.87, 8.53, 8.20, + & 7.88, + & 7.57, 7.27, 6.97, 6.69, 6.41, 6.14, 5.88, 5.62, 5.36, + & 5.11, + & 4.87, 4.63, 4.39, 4.15, 3.92, 3.68, 3.45, 3.21, 2.98, + & 2.74, + & 2.49, 2.24, 1.98, 1.72, 1.44, 1.16, 0.87, 0.57, 0.28, + & 0.1/ +C +C awpc= potassium chloride +C + DATA AWPC/172.62, 165.75, 159.10, 152.67, 146.46, 140.45, 134.64, + & 129.03, 123.61, 118.38, 113.34, 108.48, 103.79, 99.27, + & 94.93, 90.74, 86.71, 82.84, 79.11, 75.53, 72.09, 68.79, + & 65.63, 62.59, 59.68, 56.90, 54.23, 51.68, 49.24, 46.91, + & 44.68, 42.56, 40.53, 38.60, 36.76, 35.00, 33.33, 31.75, + & 30.24, 28.81, 27.45, 26.16, 24.94, 23.78, 22.68, 21.64, + & 20.66, 19.74, 18.86, 18.03, 17.25, 16.51, 15.82, 15.16, + & 14.54, 13.96, 13.41, 12.89, 12.40, 11.94, 11.50, 11.08, + & 10.69, 10.32, 9.96, 9.62, 9.30, 8.99, 8.69, 8.40, 8.12, + & 7.85, 7.59, 7.33, 7.08, 6.83, 6.58, 6.33, 6.08, 5.84, + & 5.59, 5.34, 5.09, 4.83, 4.57, 4.31, 4.04, 3.76, 3.48, + & 3.19, 2.90, 2.60, 2.29, 1.98, 1.66, 1.33, 0.99, 0.65, + & 0.30, 0.1/ +C +C awps= potassium sulfate +C + DATA AWPS/1014.82, 969.72, 926.16, 884.11, 843.54, 804.41, 766.68, + & 730.32, 695.30, 661.58, 629.14, 597.93, 567.92, 539.09, + & 511.41, 484.83, 459.34, 434.89, 411.47, 389.04, 367.58, + & 347.05, 327.43, 308.69, 290.80, 273.73, 257.47, 241.98, + & 227.24, 213.22, 199.90, 187.26, 175.27, 163.91, 153.15, + & 142.97, 133.36, 124.28, 115.73, 107.66, 100.08, 92.95, + & 86.26, 79.99, 74.12, 68.63, 63.50, 58.73, 54.27, 50.14, + & 46.30, 42.74, 39.44, 36.40, 33.59, 31.00, 28.63, 26.45, + & 24.45, 22.62, 20.95, 19.43, 18.05, 16.79, 15.64, 14.61, + & 13.66, 12.81, 12.03, 11.33, 10.68, 10.09, 9.55, 9.06, + & 8.60, 8.17, 7.76, 7.38, 7.02, 6.66, 6.32, 5.98, 5.65, + & 5.31, 4.98, 4.64, 4.31, 3.96, 3.62, 3.27, 2.92, 2.57, + & 2.22, 1.87, 1.53, 1.20, 0.87, 0.57, 0.28, 0.1/ +C +C awpn= potassium nitrate +C + DATA AWPN/44*1000.00, 953.05, 881.09, 813.39, + & 749.78, 690.09, 634.14, 581.77, 532.83, 487.16, 444.61, + & 405.02, 368.26, 334.18, 302.64, 273.51, 246.67, 221.97, + & 199.31, 178.56, 159.60, 142.33, 126.63, 112.40, 99.54, + & 87.96, 77.55, 68.24, 59.92, 52.53, 45.98, 40.2, 35.11, + & 30.65, 26.75, 23.35, 20.40, 17.85, 15.63, 13.72, 12.06, + & 10.61, 9.35, 8.24, 7.25, 6.37, 5.56, 4.82, 4.12, 3.47, + & 2.86, 2.28, 1.74, 1.24, 0.79, 0.40, 0.1/ +C +C awpb= potassium bisulfate +C + DATA AWPB/10*55.99, + & 53.79, 51.81, 49.99, 48.31, 46.75, 45.28, 43.91, 42.62, 41.39, + & 40.22, + & 39.10, 38.02, 36.99, 36.00, 35.04, 34.11, 33.21, 32.34, 31.49, + & 30.65, + & 29.84, 29.04, 28.27, 27.50, 26.75, 26.01, 25.29, 24.57, 23.87, + & 23.17, + & 22.49, 21.81, 21.15, 20.49, 19.84, 19.21, 18.58, 17.97, 17.37, + & 16.77, + & 16.19, 15.63, 15.08, 14.54, 14.01, 13.51, 13.01, 12.53, 12.07, + & 11.62, + & 11.19, 10.77, 10.36, 9.97, 9.59, 9.23, 8.87, 8.53, 8.20, + & 7.88, + & 7.57, 7.27, 6.97, 6.69, 6.41, 6.14, 5.88, 5.62, 5.36, + & 5.11, + & 4.87, 4.63, 4.39, 4.15, 3.92, 3.68, 3.45, 3.21, 2.98, + & 2.74, + & 2.49, 2.24, 1.98, 1.72, 1.44, 1.16, 0.87, 0.57, 0.28, + & 0.1/ +C +C awcc= calcium chloride +C + DATA AWCC/19.9, 19.0, 18.15, 17.35, 16.6, 15.89, 15.22, 14.58, + & 13.99, 13.43, 12.90, 12.41, 11.94, 11.50, 11.09, 10.7, + & 10.34, 9.99, 9.67, 9.37, 9.09, 8.83, 8.57, 8.34, 8.12, + & 7.91, 7.71, 7.53, 7.35, 7.19, 7.03, 6.88, 6.74, 6.6, + & 6.47, 6.35, 6.23, 6.12, 6.01, 5.90, 5.80, 5.70, 5.61, + & 5.51, 5.42, 5.33, 5.24, 5.16, 5.07, 4.99, 4.91, 4.82, + & 4.74, 4.66, 4.58, 4.50, 4.42, 4.34, 4.26, 4.19, 4.11, + & 4.03, 3.95, 3.87, 3.79, 3.72, 3.64, 3.56, 3.48, 3.41, + & 3.33, 3.25, 3.17, 3.09, 3.01, 2.93, 2.85, 2.76, 2.68, + & 2.59, 2.50, 2.41, 2.32, 2.23, 2.13, 2.03, 1.93, 1.82, + & 1.71, 1.59, 1.47, 1.35, 1.22, 1.07, 0.93, 0.77, 0.61, + & 0.44, 0.25, 0.1/ +C +C awcn= calcium nitrate +C + DATA AWCN/32.89, 31.46, 30.12, 28.84, 27.64, 26.51, 25.44, 24.44, + & 23.49, 22.59, 21.75, 20.96, 20.22, 19.51, 18.85, 18.23, + & 17.64, 17.09, 16.56, 16.07, 15.61, 15.17, 14.75, 14.36, + & 13.99, 13.63, 13.3, 12.98, 12.68, 12.39, 12.11, 11.84, + & 11.59, 11.35, 11.11, 10.88, 10.66, 10.45, 10.24, 10.04, + & 9.84, 9.65, 9.46, 9.28, 9.1, 8.92, 8.74, 8.57, 8.4, + & 8.23, 8.06, 7.9, 7.73, 7.57, 7.41, 7.25, 7.1,6.94, 6.79, + & 6.63, 6.48, 6.33, 6.18, 6.03, 5.89, 5.74, 5.60, 5.46, + & 5.32, 5.17, 5.04, 4.9, 4.76, 4.62, 4.49, 4.35, 4.22, + & 4.08, 3.94, 3.80, 3.66, 3.52, 3.38, 3.23, 3.08, 2.93, + & 2.77, 2.60, 2.43, 2.25, 2.07, 1.87, 1.67, 1.45, 1.22, + & 0.97, 0.72, 0.44, 0.14, 0.1/ +C +C awmc= magnesium chloride +C + DATA AWMC/11.24, 10.99, 10.74, 10.5, 10.26, 10.03, 9.81, 9.59, + & 9.38, 9.18, 8.98, 8.79, 8.60, 8.42, 8.25, 8.07, 7.91, + & 7.75, 7.59, 7.44, 7.29, 7.15, 7.01, 6.88, 6.75, 6.62, + & 6.5, 6.38, 6.27, 6.16, 6.05, 5.94, 5.85, 5.75, 5.65, + & 5.56, 5.47, 5.38, 5.30, 5.22, 5.14, 5.06, 4.98, 4.91, + & 4.84, 4.77, 4.7, 4.63, 4.57, 4.5, 4.44, 4.37, 4.31, + & 4.25, 4.19, 4.13, 4.07, 4.01, 3.95, 3.89, 3.83, 3.77, + & 3.71, 3.65, 3.58, 3.52, 3.46, 3.39, 3.33, 3.26, 3.19, + & 3.12, 3.05, 2.98, 2.9, 2.82, 2.75, 2.67, 2.58, 2.49, + & 2.41, 2.32, 2.22, 2.13, 2.03, 1.92, 1.82, 1.71, 1.60, + & 1.48, 1.36, 1.24, 1.11, 0.98, 0.84, 0.70, 0.56, 0.41, + & 0.25, 0.1/ +C +C awmn= magnesium nitrate +C + DATA AWMN/12.00, 11.84, 11.68, 11.52, 11.36, 11.2, 11.04, 10.88, + & 10.72, 10.56, 10.40, 10.25, 10.09, 9.93, 9.78, 9.63, + & 9.47, 9.32, 9.17, 9.02, 8.87, 8.72, 8.58, 8.43, 8.29, + & 8.15, 8.01, 7.87, 7.73, 7.59, 7.46, 7.33, 7.2, 7.07, + & 6.94, 6.82, 6.69, 6.57, 6.45, 6.33, 6.21, 6.01, 5.98, + & 5.87, 5.76, 5.65, 5.55, 5.44, 5.34, 5.24, 5.14, 5.04, + & 4.94, 4.84, 4.75, 4.66, 4.56, 4.47, 4.38, 4.29, 4.21, + & 4.12, 4.03, 3.95, 3.86, 3.78, 3.69, 3.61, 3.53, 3.45, + & 3.36, 3.28, 3.19, 3.11, 3.03, 2.94, 2.85, 2.76, 2.67, + & 2.58, 2.49, 2.39, 2.3, 2.2, 2.1, 1.99, 1.88, 1.77, 1.66, + & 1.54, 1.42, 1.29, 1.16, 1.02, 0.88, 0.73, 0.58, 0.42, + & 0.25, 0.1/ +C +C awmn= magnesium sulfate +C + DATA AWMS/0.93, 2.5, 3.94, 5.25, 6.45, 7.54, 8.52, 9.40, 10.19, + & 10.89, 11.50, 12.04, 12.51, 12.90, 13.23, 13.50, 13.72, + & 13.88, 13.99, 14.07, 14.1, 14.09, 14.05, 13.98, 13.88, + & 13.75, 13.6, 13.43, 13.25, 13.05, 12.83, 12.61, 12.37, + & 12.13, 11.88, 11.63, 11.37, 11.12, 10.86, 10.60, 10.35, + & 10.09, 9.85, 9.6, 9.36, 9.13, 8.9, 8.68, 8.47, 8.26, + & 8.07, 7.87, 7.69, 7.52, 7.35, 7.19, 7.03, 6.89, 6.75, + & 6.62, 6.49, 6.37, 6.26, 6.15, 6.04, 5.94, 5.84, 5.75, + & 5.65, 5.56, 5.47, 5.38, 5.29, 5.20, 5.11, 5.01, 4.92, + & 4.82, 4.71, 4.60, 4.49, 4.36, 4.24, 4.10, 3.96, 3.81, + & 3.65, 3.48, 3.30, 3.11, 2.92, 2.71, 2.49, 2.26, 2.02, + & 1.76, 1.50, 1.22, 0.94, 0.64/ +C +C *** END OF BLOCK DATA SUBPROGRAM ************************************* +C + END +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE INIT1 +C *** THIS SUBROUTINE INITIALIZES ALL GLOBAL VARIABLES FOR AMMONIUM +C SULFATE AEROSOL SYSTEMS (SUBROUTINE ISRP1) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE INIT1 (WI, RHI, TEMPI) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: WI, RHI, TEMPI + DIMENSION WI(NCOMP) + REAL*8 :: IC,GII,GI0,XX + REAL*8, PARAMETER :: LN10 = 2.30258509299404568402D0 +C +C *** SAVE INPUT VARIABLES IN COMMON BLOCK ****************************** +C + IF (IPROB == 0) THEN ! FORWARD CALCULATION + DO I=1,NCOMP +C W(I) = (WI(I), TINY) + IF (TINY > (WI(I))) THEN + W(I) = TINY + ELSE + W(I) = WI(I) + ENDIF +C WB(I) = 0.d0 + ENDDO + ELSE + DO I=1,NCOMP ! REVERSE CALCULATION +C WAER(I) = MAX(WI(I), TINY) + IF (TINY > (WI(I))) THEN + WAER(I) = TINY + ELSE + WAER(I) = WI(I) + ENDIF + W(I) = ZERO + ENDDO + ENDIF + RH = RHI + TEMP = TEMPI +C +C *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +C + XK1 = 1.015d-2 ! HSO4(aq) <==> H(aq) + SO4(aq) + XK21 = 57.639d0 ! NH3(g) <==> NH3(aq) + XK22 = 1.805d-5 ! NH3(aq) <==> NH4(aq) + OH(aq) + XK7 = 1.817d0 ! (NH4)2SO4(s) <==> 2*NH4(aq) + SO4(aq) + XK12 = 1.382d2 ! NH4HSO4(s) <==> NH4(aq) + HSO4(aq) + XK13 = 29.268d0 ! (NH4)3H(SO4)2(s) <==> 3*NH4(aq) + HSO4(aq) + SO4(aq) + XKW = 1.010d-14 ! H2O <==> H(aq) + OH(aq) +C + IF (INT(TEMP) /= 298) THEN ! FOR T != 298K or 298.15K + T0 = 298.15d0 + T0T = T0/TEMP + COEF= 1.d0+LOG(T0T)-T0T + XK1 = XK1 *EXP( 8.85d0*(T0T-1.d0) + 25.140d0*COEF) + XK21= XK21*EXP( 13.79d0*(T0T-1.d0) - 5.393d0*COEF) + XK22= XK22*EXP( -1.50d0*(T0T-1.d0) + 26.920d0*COEF) + XK7 = XK7 *EXP( -2.65d0*(T0T-1.d0) + 38.570d0*COEF) + XK12= XK12*EXP( -2.87d0*(T0T-1.d0) + 15.830d0*COEF) + XK13= XK13*EXP( -5.19d0*(T0T-1.d0) + 54.400d0*COEF) + XKW = XKW *EXP(-22.52d0*(T0T-1.d0) + 26.920d0*COEF) + ENDIF + XK2 = XK21*XK22 +C +C *** CALCULATE DELIQUESCENCE RELATIVE HUMIDITIES (UNICOMPONENT) ******** +C + DRH2SO4 = 0.0000D0 + DRNH42S4 = 0.7997D0 + DRNH4HS4 = 0.4000D0 + DRLC = 0.6900D0 + IF (INT(TEMP) /= 298) THEN + T0 = 298.15d0 + TCF = 1.d0/TEMP - 1.d0/T0 + DRNH42S4 = DRNH42S4*EXP( 80.d0*TCF) + DRNH4HS4 = DRNH4HS4*EXP(384.d0*TCF) + DRLC = DRLC *EXP(186.d0*TCF) + ENDIF +C +C *** CALCULATE MUTUAL DELIQUESCENCE RELATIVE HUMIDITIES **************** +C + DRMLCAB = 0.3780D0 ! (NH4)3H(SO4)2 & NH4HSO4 + DRMLCAS = 0.6900D0 ! (NH4)3H(SO4)2 & (NH4)2SO4 +CCC IF (INT(TEMP) /= 298) THEN ! For the time being. +CCC T0 = 298.15d0 +CCC TCF = 1.0/TEMP - 1.0/T0 +CCC DRMLCAB = DRMLCAB*EXP(507.506*TCF) +CCC DRMLCAS = DRMLCAS*EXP(133.865*TCF) +CCC ENDIF +C +C *** LIQUID PHASE ****************************************************** +C + CHNO3 = ZERO + CHCL = ZERO + CH2SO4 = ZERO + COH = ZERO + WATER = TINY +C + DO I=1,NPAIR + MOLALR(I)=ZERO + GAMA(I) =0.1d0 + GAMIN(I) =GREAT + GAMOU(I) =GREAT + M0(I) =1.d5 + ENDDO +C + DO I=1,NPAIR + GAMA(I) = 0.1d0 + ENDDO +C + DO I=1,NIONS +C MOLALB(I) = 0.d0 + MOLAL(I)=ZERO + ENDDO + COH = ZERO +C + DO I=1,NGASAQ + GASAQ(I)=ZERO + ENDDO +C +C *** SOLID PHASE ******************************************************* +C + CNH42S4= ZERO + CNH4HS4= ZERO + CNACL = ZERO + CNA2SO4= ZERO + CNANO3 = ZERO + CNH4NO3= ZERO + CNH4CL = ZERO + CNAHSO4= ZERO + CLC = ZERO + CCASO4 = ZERO + CCANO32= ZERO + CCACL2 = ZERO + CK2SO4 = ZERO + CKHSO4 = ZERO + CKNO3 = ZERO + CKCL = ZERO + CMGSO4 = ZERO + CMGNO32= ZERO + CMGCL2 = ZERO +C +C *** GAS PHASE ********************************************************* +C + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO +C +C *** CALCULATE ZSR PARAMETERS ****************************************** +C + IRH = MIN (INT(RH*NZSR+0.5d0),NZSR) ! Position in ZSR arrays + IRH = MAX (IRH, 1) +C +C M0(01) = AWSC(IRH) ! NACl +C IF (M0(01) < 100.0) THEN +C IC = M0(01) +C CALL KMTAB(IC,298.0, GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(01) = M0(01)*EXP(LN10*(GI0-GII)) +C ENDIF +C +C M0(02) = AWSS(IRH) ! (NA)2SO4 +C IF (M0(02) < 100.0) THEN +C IC = 3.0*M0(02) +C CALL KMTAB(IC,298.0, XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(02) = M0(02)*EXP(LN10*(GI0-GII)) +C ENDIF +C +C M0(03) = AWSN(IRH) ! NANO3 +C IF (M0(03) < 100.0) THEN +C IC = M0(03) +C CALL KMTAB(IC,298.0, XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(03) = M0(03)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(04) = AWAS(IRH) ! (NH4)2SO4 +C IF (M0(04) < 100.0) THEN +C IC = 3.0*M0(04) +C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(04) = M0(04)*EXP(LN10*(GI0-GII)) +C ENDIF +C +C M0(05) = AWAN(IRH) ! NH4NO3 +C IF (M0(05) < 100.0) THEN +C IC = M0(05) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX) +C M0(05) = M0(05)*EXP(LN10*(GI0-GII)) +C ENDIF +C +C M0(06) = AWAC(IRH) ! NH4CL +C IF (M0(06) < 100.0) THEN +C IC = M0(06) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX) +C M0(06) = M0(06)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(07) = AWSA(IRH) ! 2H-SO4 +C IF (M0(07) < 100.0) THEN +C IC = 3.0*M0(07) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX) +C M0(07) = M0(07)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(08) = AWSA(IRH) ! H-HSO4 +CCC IF (M0(08) < 100.0) THEN ! These are redundant, because M0(8) is not used +CCC IC = M0(08) +CCC CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +CCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +CCCCCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX) +CCC M0(08) = M0(08)*EXP(LN10*(GI0-GII)) +CCC ENDIF +C + M0(09) = AWAB(IRH) ! NH4HSO4 +C IF (M0(09) < 100.0) THEN +C IC = M0(09) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX) +C M0(09) = M0(09)*EXP(LN10*(GI0-GII)) +C ENDIF +C +C M0(12) = AWSB(IRH) ! NAHSO4 +C IF (M0(12) < 100.0) THEN +C IC = M0(12) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GI0) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GII) +C M0(12) = M0(12)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(13) = AWLC(IRH) ! (NH4)3H(SO4)2 +C IF (M0(13) < 100.0) THEN +C IC = 4.0*M0(13) +C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +C G130 = 0.2*(3.0*GI0+2.0*GII) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +C G13I = 0.2*(3.0*GI0+2.0*GII) +C M0(13) = M0(13)*EXP(LN10*SNGL(G130-G13I)) +C ENDIF +C +C *** OTHER INITIALIZATIONS ********************************************* +C + ICLACT = 0 + CALAOU = .TRUE. + CALAIN = .TRUE. + FRST = .TRUE. + SCASE = 'XX' + SULRATW = 2.D0 + SODRAT = ZERO + CRNARAT = ZERO + CRRAT = ZERO + NOFER = 0 + STKOFL =.FALSE. + DO I=1,NERRMX + ERRSTK(I) =-999 + ERRMSG(I) = 'MESSAGE N/A' + ENDDO +C +C *** END OF SUBROUTINE INIT1 ******************************************* +C + END + + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE INIT2 +C *** THIS SUBROUTINE INITIALIZES ALL GLOBAL VARIABLES FOR AMMONIUM, +C NITRATE, SULFATE AEROSOL SYSTEMS (SUBROUTINE ISRP2) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE INIT2 (WI, RHI, TEMPI) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: WI, RHI, TEMPI + DIMENSION WI(NCOMP) + LOGICAL FLAGNP + REAL*8 :: IC,GII,GI0,XX + REAL*8, PARAMETER :: LN10 = 2.30258509299404568402D0 +C +C *** SAVE INPUT VARIABLES IN COMMON BLOCK ****************************** +C +! IF (IPROB == 0) THEN ! FORWARD CALCULATION + DO I=1,NCOMP +C W(I) = (WI(I), TINY) + IF (TINY > (WI(I))) THEN + W(I) = ZERO! TINY + ELSE + W(I) = WI(I) + ENDIF +C WB(I) = ZERO + ENDDO +! ELSE +! DO I=1,NCOMP ! REVERSE CALCULATION +C WAER(I) = MAX(WI(I), TINY) +! IF (TINY > (WI(I))) THEN +! WAER(I) = TINY +! ELSE +! WAER(I) = WI(I) +! ENDIF +! W(I) = ZERO +! ENDDO +! ENDIF + RH = RHI + TEMP = TEMPI +C +C *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +C + XK1 = 1.015d-2 ! HSO4(aq) <==> H(aq) + SO4(aq) + XK21 = 57.639d0 ! NH3(g) <==> NH3(aq) + XK22 = 1.805d-5 ! NH3(aq) <==> NH4(aq) + OH(aq) + XK4 = 2.511d6 ! HNO3(g) <==> H(aq) + NO3(aq) ! ISORR +CCC XK4 = 3.638e6 ! HNO3(g) <==> H(aq) + NO3(aq) ! SEQUIL + XK41 = 2.100d5 ! HNO3(g) <==> HNO3(aq) + XK7 = 1.817d0 ! (NH4)2SO4(s) <==> 2*NH4(aq) + SO4(aq) + XK10 = 5.746d-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! ISORR +CCC XK10 = 2.985e-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! SEQUIL + XK12 = 1.382d2 ! NH4HSO4(s) <==> NH4(aq) + HSO4(aq) + XK13 = 29.268d0 ! (NH4)3H(SO4)2(s) <==> 3*NH4(aq) + HSO4(aq) + SO4(aq) + XKW = 1.010d-14 ! H2O <==> H(aq) + OH(aq) +C + IF (INT(TEMP) /= 298) THEN ! FOR T != 298K or 298.15K + T0 = 298.15D0 + T0T = T0/TEMP + COEF= 1.0+LOG(T0T)-T0T + XK1 = XK1 *EXP( 8.85d0*(T0T-1.d0) + 25.140d0*COEF) + XK21= XK21*EXP( 13.79d0*(T0T-1.d0) - 5.393d0*COEF) + XK22= XK22*EXP( -1.50d0*(T0T-1.d0) + 26.920d0*COEF) + XK4 = XK4 *EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF) !ISORR +CCC XK4 = XK4 *EXP( 29.47d0*(T0T-1.d0) + 16.840d0*COEF) ! SEQUIL + XK41= XK41*EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF) + XK7 = XK7 *EXP( -2.65d0*(T0T-1.d0) + 38.570d0*COEF) + XK10= XK10*EXP(-74.38d0*(T0T-1.d0) + 6.120d0*COEF) ! ISORR +CCC XK10= XK10*EXP(-75.11d0*(T0T-1.d0) + 13.460d0*COEF) ! SEQUIL + XK12= XK12*EXP( -2.87d0*(T0T-1.d0) + 15.830d0*COEF) + XK13= XK13*EXP( -5.19d0*(T0T-1.d0) + 54.400d0*COEF) + XKW = XKW *EXP(-22.52d0*(T0T-1.d0) + 26.920d0*COEF) + ENDIF + XK2 = XK21*XK22 + XK42 = XK4/XK41 +C +C *** CALCULATE DELIQUESCENCE RELATIVE HUMIDITIES (UNICOMPONENT) ******** +C + DRH2SO4 = ZERO + DRNH42S4 = 0.7997D0 + DRNH4HS4 = 0.4000D0 + DRNH4NO3 = 0.6183D0 + DRLC = 0.6900D0 + IF (INT(TEMP) /= 298) THEN + T0 = 298.15D0 + TCF = 1.0d0/TEMP - 1.0d0/T0 + DRNH4NO3 = DRNH4NO3*EXP(852.d0*TCF) + DRNH42S4 = DRNH42S4*EXP( 80.d0*TCF) + DRNH4HS4 = DRNH4HS4*EXP(384.d0*TCF) + DRLC = DRLC *EXP(186.d0*TCF) + DRNH4NO3 = MIN ((DRNH4NO3),(DRNH42S4)) ! ADJUST FOR DRH CROSSOVER AT T<271K + ENDIF +C +C *** CALCULATE MUTUAL DELIQUESCENCE RELATIVE HUMIDITIES **************** +C + DRMLCAB = 0.3780D0 ! (NH4)3H(SO4)2 & NH4HSO4 + DRMLCAS = 0.6900D0 ! (NH4)3H(SO4)2 & (NH4)2SO4 + DRMASAN = 0.6000D0 ! (NH4)2SO4 & NH4NO3 +CCC IF (INT(TEMP) /= 298) THEN ! For the time being +CCC T0 = 298.15d0 +CCC TCF = 1.0/TEMP - 1.0/T0 +CCC DRMLCAB = DRMLCAB*EXP( 507.506*TCF) +CCC DRMLCAS = DRMLCAS*EXP( 133.865*TCF) +CCC DRMASAN = DRMASAN*EXP(1269.068*TCF) +CCC ENDIF +C +C *** LIQUID PHASE ****************************************************** +C + CHNO3 = ZERO + CHCL = ZERO + CH2SO4 = ZERO + COH = ZERO + WATER = TINY +C + DO I=1,NPAIR + MOLALR(I)=ZERO + GAMA(I) = 0.1D0 + GAMIN(I) = 1.D10 ! GREAT + GAMOU(I) = 1.D10 !GREAT + M0(I) = 1d5 + ENDDO +C + DO I=1,NPAIR + GAMA(I) = 0.1d0 + ENDDO +C + DO I=1,NIONS + MOLAL(I)=ZERO + ENDDO + COH = ZERO +C + DO I=1,NGASAQ + GASAQ(I)=ZERO + ENDDO +C +C *** SOLID PHASE ****************************************************** +C + CNH42S4= ZERO + CNH4HS4= ZERO + CNACL = ZERO + CNA2SO4= ZERO + CNANO3 = ZERO + CNH4NO3= ZERO + CNH4CL = ZERO + CNAHSO4= ZERO + CLC = ZERO + CCASO4 = ZERO + CCANO32= ZERO + CCACL2 = ZERO + CK2SO4 = ZERO + CKHSO4 = ZERO + CKNO3 = ZERO + CKCL = ZERO + CMGSO4 = ZERO + CMGNO32= ZERO + CMGCL2 = ZERO +C +C *** GAS PHASE ********************************************************* +C + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO +C +C *** CALCULATE ZSR PARAMETERS ****************************************** +C + IRH = MIN (INT(RH*NZSR+0.5d0),NZSR) ! Position in ZSR arrays + IRH = MAX (IRH, 1) +C +C M0(01) = AWSC(IRH) ! NACl +C IF (M0(01) < 100.0) THEN +C IC = M0(01) +C CALL KMTAB(IC,298.0, GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(01) = M0(01)*EXP(LN10*(GI0-GII)) +C ENDIF +C +C M0(02) = AWSS(IRH) ! (NA)2SO4 +C IF (M0(02) < 100.0) THEN +C IC = 3.0*M0(02) +C CALL KMTAB(IC,298.0, XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(02) = M0(02)*EXP(LN10*(GI0-GII)) +C ENDIF +C +C M0(03) = AWSN(IRH) ! NANO3 +C IF (M0(03) < 100.0) THEN +C IC = M0(03) +C CALL KMTAB(IC,298.0, XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(03) = M0(03)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(04) = AWAS(IRH) ! (NH4)2SO4 +C IF (M0(04) < 100.0) THEN +C IC = 3.0*M0(04) +C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(04) = M0(04)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(05) = AWAN(IRH) ! NH4NO3 +C IF (M0(05) < 100.0) THEN +C IC = M0(05) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX) +C M0(05) = M0(05)*EXP(LN10*(GI0-GII)) +C ENDIF +C +C M0(06) = AWAC(IRH) ! NH4CL +C IF (M0(06) < 100.0) THEN +C IC = M0(06) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX) +C M0(06) = M0(06)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(07) = AWSA(IRH) ! 2H-SO4 +C IF (M0(07) < 100.0) THEN +C IC = 3.0*M0(07) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX) +C M0(07) = M0(07)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(08) = AWSA(IRH) ! H-HSO4 +CCC IF (M0(08) < 100.0) THEN ! These are redundant, because M0(8) is not used +CCC IC = M0(08) +CCC CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +CCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +CCCCCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX) +CCC M0(08) = M0(08)*EXP(LN10*(GI0-GII)) +CCC ENDIF +C + M0(09) = AWAB(IRH) ! NH4HSO4 +C IF (M0(09) < 100.0) THEN +C IC = M0(09) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX) +C M0(09) = M0(09)*EXP(LN10*(GI0-GII)) +C ENDIF +C +C M0(12) = AWSB(IRH) ! NAHSO4 +C IF (M0(12) < 100.0) THEN +C IC = M0(12) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GI0) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GII) +C M0(12) = M0(12)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(13) = AWLC(IRH) ! (NH4)3H(SO4)2 +C IF (M0(13) < 100.0) THEN +C IC = 4.0*M0(13) +C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +C G130 = 0.2*(3.0*GI0+2.0*GII) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +C G13I = 0.2*(3.0*GI0+2.0*GII) +C M0(13) = M0(13)*EXP(LN10*SNGL(G130-G13I)) +C ENDIF +C +C *** OTHER INITIALIZATIONS ********************************************* +C + ICLACT = 0 + CALAOU = .TRUE. + CALAIN = .TRUE. + FRST = .TRUE. + FLAGNP = .FALSE. + NONPHYS = .FALSE. + SCASE = 'XX' + SULRATW = 2.D0 + SODRAT = ZERO + CRNARAT = ZERO + CRRAT = ZERO + NOFER = 0 + STKOFL =.FALSE. + DO I=1,NERRMX + ERRSTK(I) =-999 + ERRMSG(I) = 'MESSAGE N/A' + ENDDO +C +C *** END OF SUBROUTINE INIT2 ******************************************* +C + END + + + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ISOINIT3 +C *** THIS SUBROUTINE INITIALIZES ALL GLOBAL VARIABLES FOR AMMONIUM, +C SODIUM, CHLORIDE, NITRATE, SULFATE AEROSOL SYSTEMS (SUBROUTINE +C ISRP3) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ISOINIT3 (WI, RHI, TEMPI) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: WI(NCOMP), RHI, TEMPI + REAL*8 :: IC,GII,GI0,XX + REAL*8, PARAMETER :: LN10 = 2.30258509299404568402D0 +C +C *** SAVE INPUT VARIABLES IN COMMON BLOCK ****************************** +C +! IF (IPROB == 0) THEN ! FORWARD CALCULATION + DO I=1,NCOMP +C W(I) = (WI(I), TINY) + IF (TINY > (WI(I))) THEN + W(I) = TINY + ELSE + W(I) = WI(I) + ENDIF + ENDDO +! ELSE +! DO I=1,NCOMP ! REVERSE CALCULATION +C WAER(I) = MAX(WI(I), TINY) +! IF (TINY > (WI(I))) THEN +! WAER(I) = TINY +! ELSE +! WAER(I) = WI(I) +! ENDIF +! W(I) = ZERO +! ENDDO +! ENDIF + RH = RHI + TEMP = TEMPI +C +C *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +C + XK1 = 1.015D-2 ! HSO4(aq) <==> H(aq) + SO4(aq) + XK21 = 57.639D0 ! NH3(g) <==> NH3(aq) + XK22 = 1.805D-5 ! NH3(aq) <==> NH4(aq) + OH(aq) + XK3 = 1.971D6 ! HCL(g) <==> H(aq) + CL(aq) + XK31 = 2.500d3 ! HCL(g) <==> HCL(aq) + XK4 = 2.511d6 ! HNO3(g) <==> H(aq) + NO3(aq) ! ISORR +CCC XK4 = 3.638e6 ! HNO3(g) <==> H(aq) + NO3(aq) ! SEQUIL + XK41 = 2.100d5 ! HNO3(g) <==> HNO3(aq) + XK5 = 0.4799D0 ! NA2SO4(s) <==> 2*NA(aq) + SO4(aq) + XK6 = 1.086D-16 ! NH4CL(s) <==> NH3(g) + HCL(g) + XK7 = 1.817D0 ! (NH4)2SO4(s) <==> 2*NH4(aq) + SO4(aq) + XK8 = 37.661D0 ! NACL(s) <==> NA(aq) + CL(aq) + XK10 = 5.746D-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! ISORR +CCC XK10 = 2.985e-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! SEQUIL + XK11 = 2.413D4 ! NAHSO4(s) <==> NA(aq) + HSO4(aq) + XK12 = 1.382D2 ! NH4HSO4(s) <==> NH4(aq) + HSO4(aq) + XK13 = 29.268D0 ! (NH4)3H(SO4)2(s) <==> 3*NH4(aq) + HSO4(aq) + SO4(aq) + XK14 = 22.05D0 ! NH4CL(s) <==> NH4(aq) + CL(aq) + XKW = 1.010D-14 ! H2O <==> H(aq) + OH(aq) + XK9 = 11.977D0 ! NANO3(s) <==> NA(aq) + NO3(aq) +C + IF (INT(TEMP) /= 298) THEN ! FOR T != 298K or 298.15K + T0 = 298.15D0 + T0T = T0/TEMP + COEF= 1.d0+LOG(T0T)-T0T + XK1 = XK1 *EXP( 8.85d0*(T0T-1.d0) + 25.140d0*COEF) + XK21= XK21*EXP( 13.79d0*(T0T-1.d0) - 5.393d0*COEF) + XK22= XK22*EXP( -1.50d0*(T0T-1.d0) + 26.920d0*COEF) + XK3 = XK3 *EXP( 30.20d0*(T0T-1.d0) + 19.910d0*COEF) + XK31= XK31*EXP( 30.20d0*(T0T-1.d0) + 19.910d0*COEF) + XK4 = XK4 *EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF) !ISORR +CCC XK4 = XK4 *EXP( 29.47*(T0T-1.d0) + 16.840d0*COEF) ! SEQUIL + XK41= XK41*EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF) + XK5 = XK5 *EXP( 0.98d0*(T0T-1.d0) + 39.500d0*COEF) + XK6 = XK6 *EXP(-71.00d0*(T0T-1.d0) + 2.400d0*COEF) + XK7 = XK7 *EXP( -2.65d0*(T0T-1.d0) + 38.570d0*COEF) + XK8 = XK8 *EXP( -1.56d0*(T0T-1.d0) + 16.900d0*COEF) + XK9 = XK9 *EXP( -8.22d0*(T0T-1.d0) + 16.010d0*COEF) + XK10= XK10*EXP(-74.38d0*(T0T-1.d0) + 6.120d0*COEF) ! ISORR +CCC XK10= XK10*EXP(-75.11*(T0T-1.d0) + 13.460d0*COEF) ! SEQUIL + XK11= XK11*EXP( 0.79d0*(T0T-1.d0) + 14.746d0*COEF) + XK12= XK12*EXP( -2.87d0*(T0T-1.d0) + 15.830d0*COEF) + XK13= XK13*EXP( -5.19d0*(T0T-1.d0) + 54.400d0*COEF) + XK14= XK14*EXP( 24.55d0*(T0T-1.d0) + 16.900d0*COEF) + XKW = XKW *EXP(-22.52d0*(T0T-1.d0) + 26.920d0*COEF) + ENDIF + XK2 = XK21*XK22 + XK42 = XK4/XK41 + XK32 = XK3/XK31 +C +C *** CALCULATE DELIQUESCENCE RELATIVE HUMIDITIES (UNICOMPONENT) ******** +C + DRH2SO4 = ZERO + DRNH42S4 = 0.7997D0 + DRNH4HS4 = 0.4000D0 + DRLC = 0.6900D0 + DRNACL = 0.7528D0 + DRNANO3 = 0.7379D0 + DRNH4CL = 0.7710D0 + DRNH4NO3 = 0.6183D0 + DRNA2SO4 = 0.9300D0 + DRNAHSO4 = 0.5200D0 + IF (INT(TEMP) /= 298) THEN + T0 = 298.15D0 + TCF = 1.d0/TEMP - 1.d0/T0 + DRNACL = DRNACL *EXP( 25.d0*TCF) + DRNANO3 = DRNANO3 *EXP(304.d0*TCF) + DRNA2SO4 = DRNA2SO4*EXP( 80.d0*TCF) + DRNH4NO3 = DRNH4NO3*EXP(852.d0*TCF) + DRNH42S4 = DRNH42S4*EXP( 80.d0*TCF) + DRNH4HS4 = DRNH4HS4*EXP(384.d0*TCF) + DRLC = DRLC *EXP(186.d0*TCF) + DRNH4CL = DRNH4Cl *EXP(239.d0*TCF) + DRNAHSO4 = DRNAHSO4*EXP(-45.d0*TCF) +C +C *** ADJUST FOR DRH "CROSSOVER" AT LOW TEMPERATURES +C +C DRNH4NO3 = MIN (DRNH4NO3, DRNH4CL, DRNH42S4, DRNANO3, DRNACL) slc.1.2011 due to TAPENADE's FORTRAN parser + DRNH42S4 = MIN (DRNH42S4, DRNANO3, DRNACL) ! slc.1.2011 due to TAPENADE's FORTRAN parser + DRNH4NO3 = MIN (DRNH4NO3, DRNH4CL, DRNH42S4) ! slc.1.2011 due to TAPENADE's FORTRAN parser + DRNANO3 = MIN (DRNANO3, DRNACL) + DRNH4CL = MIN (DRNH4Cl, DRNH42S4) +C + ENDIF +C +C *** CALCULATE MUTUAL DELIQUESCENCE RELATIVE HUMIDITIES **************** +C + DRMLCAB = 0.378D0 ! (NH4)3H(SO4)2 & NH4HSO4 + DRMLCAS = 0.690D0 ! (NH4)3H(SO4)2 & (NH4)2SO4 + DRMASAN = 0.600D0 ! (NH4)2SO4 & NH4NO3 + DRMG1 = 0.460D0 ! (NH4)2SO4, NH4NO3, NA2SO4, NH4CL + DRMG2 = 0.691D0 ! (NH4)2SO4, NA2SO4, NH4CL + DRMG3 = 0.697D0 ! (NH4)2SO4, NA2SO4 + DRMH1 = 0.240D0 ! NA2SO4, NANO3, NACL, NH4NO3, NH4CL + DRMH2 = 0.596D0 ! NA2SO4, NANO3, NACL, NH4CL + DRMI1 = 0.240D0 ! LC, NAHSO4, NH4HSO4, NA2SO4, (NH4)2SO4 + DRMI2 = 0.363D0 ! LC, NAHSO4, NA2SO4, (NH4)2SO4 - NO DATA - + DRMI3 = 0.610D0 ! LC, NA2SO4, (NH4)2SO4 + DRMQ1 = 0.494D0 ! (NH4)2SO4, NH4NO3, NA2SO4 + DRMR1 = 0.663D0 ! NA2SO4, NANO3, NACL + DRMR2 = 0.735D0 ! NA2SO4, NACL + DRMR3 = 0.673D0 ! NANO3, NACL + DRMR4 = 0.694D0 ! NA2SO4, NACL, NH4CL + DRMR5 = 0.731D0 ! NA2SO4, NH4CL + DRMR6 = 0.596D0 ! NA2SO4, NANO3, NH4CL + DRMR7 = 0.380D0 ! NA2SO4, NANO3, NACL, NH4NO3 + DRMR8 = 0.380D0 ! NA2SO4, NACL, NH4NO3 + DRMR9 = 0.494D0 ! NA2SO4, NH4NO3 + DRMR10 = 0.476D0 ! NA2SO4, NANO3, NH4NO3 + DRMR11 = 0.340D0 ! NA2SO4, NACL, NH4NO3, NH4CL + DRMR12 = 0.460D0 ! NA2SO4, NH4NO3, NH4CL + DRMR13 = 0.438D0 ! NA2SO4, NANO3, NH4NO3, NH4CL +CCC IF (INT(TEMP) /= 298) THEN +CCC T0 = 298.15d0 +CCC TCF = 1.0/TEMP - 1.0/T0 +CCC DRMLCAB = DRMLCAB*EXP( 507.506*TCF) +CCC DRMLCAS = DRMLCAS*EXP( 133.865*TCF) +CCC DRMASAN = DRMASAN*EXP(1269.068*TCF) +CCC DRMG1 = DRMG1 *EXP( 572.207*TCF) +CCC DRMG2 = DRMG2 *EXP( 58.166*TCF) +CCC DRMG3 = DRMG3 *EXP( 22.253*TCF) +CCC DRMH1 = DRMH1 *EXP(2116.542*TCF) +CCC DRMH2 = DRMH2 *EXP( 650.549*TCF) +CCC DRMI1 = DRMI1 *EXP( 565.743*TCF) +CCC DRMI2 = DRMI2 *EXP( 91.745*TCF) +CCC DRMI3 = DRMI3 *EXP( 161.272*TCF) +CCC DRMQ1 = DRMQ1 *EXP(1616.621*TCF) +CCC DRMR1 = DRMR1 *EXP( 292.564*TCF) +CCC DRMR2 = DRMR2 *EXP( 14.587*TCF) +CCC DRMR3 = DRMR3 *EXP( 307.907*TCF) +CCC DRMR4 = DRMR4 *EXP( 97.605*TCF) +CCC DRMR5 = DRMR5 *EXP( 98.523*TCF) +CCC DRMR6 = DRMR6 *EXP( 465.500*TCF) +CCC DRMR7 = DRMR7 *EXP( 324.425*TCF) +CCC DRMR8 = DRMR8 *EXP(2660.184*TCF) +CCC DRMR9 = DRMR9 *EXP(1617.178*TCF) +CCC DRMR10 = DRMR10 *EXP(1745.226*TCF) +CCC DRMR11 = DRMR11 *EXP(3691.328*TCF) +CCC DRMR12 = DRMR12 *EXP(1836.842*TCF) +CCC DRMR13 = DRMR13 *EXP(1967.938*TCF) +CCC ENDIF +C +C *** LIQUID PHASE ****************************************************** +C + CHNO3 = ZERO + CHCL = ZERO + CH2SO4 = ZERO + COH = ZERO + WATER = TINY +C + DO I=1,NPAIR + MOLALR(I)=ZERO +C MOLALRB(I) = ZERO + GAMA(I) =0.1d0 + GAMIN(I) =GREAT + GAMOU(I) =GREAT + M0(I) =1d5 + ENDDO +C + DO I=1,NPAIR + GAMA(I) = 0.1d0 + ENDDO +C + DO I=1,NIONS + MOLAL(I)=ZERO + ENDDO + COH = ZERO +C + DO I=1,NGASAQ + GASAQ(I)=ZERO + ENDDO +C +C *** SOLID PHASE ******************************************************* +C + CNH42S4= ZERO + CNH4HS4= ZERO + CNACL = ZERO + CNA2SO4= ZERO + CNANO3 = ZERO + CNH4NO3= ZERO + CNH4CL = ZERO + CNAHSO4= ZERO + CLC = ZERO + CCASO4 = ZERO + CCANO32= ZERO + CCACL2 = ZERO + CK2SO4 = ZERO + CKHSO4 = ZERO + CKNO3 = ZERO + CKCL = ZERO + CMGSO4 = ZERO + CMGNO32= ZERO + CMGCL2 = ZERO +C +C *** GAS PHASE ********************************************************* +C + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO +C +C *** CALCULATE ZSR PARAMETERS ****************************************** +C + IRH = MIN (INT(RH*NZSR+0.5d0),NZSR) ! Position in ZSR arrays + IRH = MAX (IRH, 1) +C + M0(01) = AWSC(IRH) ! NACl +C IF (M0(01) < 100.0) THEN +C IC = M0(01) +C CALL KMTAB(IC,298.0, GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(01) = M0(01)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(02) = AWSS(IRH) ! (NA)2SO4 +C IF (M0(02) < 100.0) THEN +C IC = 3.0*M0(02) +C CALL KMTAB(IC,298.0, XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(02) = M0(02)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(03) = AWSN(IRH) ! NANO3 +C IF (M0(03) < 100.0) THEN +C IC = M0(03) +C CALL KMTAB(IC,298.0, XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(03) = M0(03)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(04) = AWAS(IRH) ! (NH4)2SO4 +C IF (M0(04) < 100.0) THEN +C IC = 3.0*M0(04) +C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(04) = M0(04)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(05) = AWAN(IRH) ! NH4NO3 +C IF (M0(05) < 100.0) THEN +C IC = M0(05) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX) +C M0(05) = M0(05)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(06) = AWAC(IRH) ! NH4CL +C IF (M0(06) < 100.0) THEN +C IC = M0(06) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX) +C M0(06) = M0(06)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(07) = AWSA(IRH) ! 2H-SO4 +C IF (M0(07) < 100.0) THEN +C IC = 3.0*M0(07) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX) +C M0(07) = M0(07)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(08) = AWSA(IRH) ! H-HSO4 +CCC IF (M0(08) < 100.0) THEN ! These are redundant, because M0(8) is not used +CCC IC = M0(08) +CCC CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +CCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +CCCCCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX) +CCC M0(08) = M0(08)*EXP(LN10*(GI0-GII)) +CCC ENDIF +C + M0(09) = AWAB(IRH) ! NH4HSO4 +C IF (M0(09) < 100.0) THEN +C IC = M0(09) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX) +C M0(09) = M0(09)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(12) = AWSB(IRH) ! NAHSO4 +C IF (M0(12) < 100.0) THEN +C IC = M0(12) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GI0) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GII) +C M0(12) = M0(12)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(13) = AWLC(IRH) ! (NH4)3H(SO4)2 +C IF (M0(13) < 100.0) THEN +C IC = 4.0*M0(13) +C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +C G130 = 0.2*(3.0*GI0+2.0*GII) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +C G13I = 0.2*(3.0*GI0+2.0*GII) +C M0(13) = M0(13)*EXP(LN10*SNGL(G130-G13I)) +C ENDIF +C +C *** OTHER INITIALIZATIONS ********************************************* +C + ICLACT = 0 + CALAOU = .TRUE. + CALAIN = .TRUE. + FRST = .TRUE. + SCASE = 'XX' + SULRATW = 2.D0 + CRNARAT = ZERO + CRRAT = ZERO + NOFER = 0 + STKOFL =.FALSE. + DO I=1,NERRMX + ERRSTK(I) =-999 + ERRMSG(I) = 'MESSAGE N/A' + ENDDO +C +C *** END OF SUBROUTINE ISOINIT3 ******************************************* +C + END + +C======================================================================= +C +C *** ISORROPIA CODE II +C *** SUBROUTINE INIT4 +C *** THIS SUBROUTINE INITIALIZES ALL GLOBAL VARIABLES FOR AMMONIUM, +C SODIUM, CHLORIDE, NITRATE, SULFATE, CALCIUM, POTASSIUM, MAGNESIUM +C AEROSOL SYSTEMS (SUBROUTINE ISRP4) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY CHRISTOS FOUNTOUKIS AND ATHANASIOS NENES +C +C======================================================================= +C + SUBROUTINE INIT4 (WI, RHI, TEMPI) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: WI(NCOMP), RHI, TEMPI + REAL*8 :: IC,GII,GI0,XX + REAL*8, PARAMETER :: LN10 = 2.30258509299404568402D0 +C +C *** SAVE INPUT VARIABLES IN COMMON BLOCK ****************************** +C +! IF (IPROB == 0) THEN ! FORWARD CALCULATION + DO I=1,NCOMP + W(I) = MAX(WI(I), TINY) + ENDDO +! ELSE +! DO I=1,NCOMP ! REVERSE CALCULATION +! WAER(I) = MAX(WI(I), TINY) +! W(I) = ZERO +! ENDDO +! ENDIF + RH = RHI + TEMP = TEMPI +C +C *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +C + XK1 = 1.015D-2 ! HSO4(aq) <==> H(aq) + SO4(aq) + XK21 = 57.639D0 ! NH3(g) <==> NH3(aq) + XK22 = 1.805D-5 ! NH3(aq) <==> NH4(aq) + OH(aq) + XK3 = 1.971D6 ! HCL(g) <==> H(aq) + CL(aq) + XK31 = 2.500d3 ! HCL(g) <==> HCL(aq) + XK4 = 2.511d6 ! HNO3(g) <==> H(aq) + NO3(aq) ! ISORR +C XK4 = 3.638d6 ! HNO3(g) <==> H(aq) + NO3(aq) ! SEQUIL + XK41 = 2.100d5 ! HNO3(g) <==> HNO3(aq) + XK5 = 0.4799D0 ! NA2SO4(s) <==> 2*NA(aq) + SO4(aq) + XK6 = 1.086D-16 ! NH4CL(s) <==> NH3(g) + HCL(g) + XK7 = 1.817D0 ! (NH4)2SO4(s) <==> 2*NH4(aq) + SO4(aq) + XK8 = 37.661D0 ! NACL(s) <==> NA(aq) + CL(aq) +C XK10 = 5.746D-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! ISORR + XK10 = 4.199D-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! (Mozurkewich, 1993) +C XK10 = 2.985d-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! SEQUIL + XK11 = 2.413D4 ! NAHSO4(s) <==> NA(aq) + HSO4(aq) + XK12 = 1.382D2 ! NH4HSO4(s) <==> NH4(aq) + HSO4(aq) + XK13 = 29.268D0 ! (NH4)3H(SO4)2(s) <==> 3*NH4(aq) + HSO4(aq) + SO4(aq) + XK14 = 22.05D0 ! NH4CL(s) <==> NH4(aq) + CL(aq) + XKW = 1.010D-14 ! H2O <==> H(aq) + OH(aq) + XK9 = 11.977D0 ! NANO3(s) <==> NA(aq) + NO3(aq) +CCC + XK15 = 6.067D5 ! CA(NO3)2(s) <==> CA(aq) + 2NO3(aq) + XK16 = 7.974D11 ! CACL2(s) <==> CA(aq) + 2CL(aq) + XK17 = 1.569D-2 ! K2SO4(s) <==> 2K(aq) + SO4(aq) + XK18 = 24.016d0 ! KHSO4(s) <==> K(aq) + HSO4(aq) + XK19 = 0.872d0 ! KNO3(s) <==> K(aq) + NO3(aq) + XK20 = 8.680d0 ! KCL(s) <==> K(aq) + CL(aq) + XK23 = 1.079D5 ! MGS04(s) <==> MG(aq) + SO4(aq) + XK24 = 2.507D15 ! MG(NO3)2(s) <==> MG(aq) + 2NO3(aq) + XK25 = 9.557D21 ! MGCL2(s) <==> MG(aq) + 2CL(aq) +C XK26 = 4.299D-7 ! CO2(aq) + H2O <==> HCO3(aq) + H(aq) +C XK27 = 4.678D-11 ! HCO3(aq) <==> CO3(aq) + H(aq) + +C + IF (INT(TEMP) .NE. 298) THEN ! FOR T != 298K or 298.15K + T0 = 298.15D0 + T0T = T0/TEMP + COEF= 1.d0+LOG(T0T)-T0T + XK1 = XK1 *EXP( 8.85d0*(T0T-1.d0) + 25.140d0*COEF) + XK21= XK21*EXP( 13.79d0*(T0T-1.d0) - 5.393d0*COEF) + XK22= XK22*EXP( -1.50d0*(T0T-1.d0) + 26.920d0*COEF) + XK3 = XK3 *EXP( 30.20d0*(T0T-1.d0) + 19.910d0*COEF) + XK31= XK31*EXP( 30.20d0*(T0T-1.d0) + 19.910d0*COEF) + XK4 = XK4 *EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF) !ISORR +C XK4 = XK4 *EXP( 29.47d0*(T0T-1.d0) + 16.840d0*COEF) ! SEQUIL + XK41= XK41*EXP( 29.17d0*(T0T-1.d0) + 16.830d0*COEF) + XK5 = XK5 *EXP( 0.98d0*(T0T-1.d0) + 39.500d0*COEF) + XK6 = XK6 *EXP(-71.00d0*(T0T-1.d0) + 2.400d0*COEF) + XK7 = XK7 *EXP( -2.65d0*(T0T-1.d0) + 38.570d0*COEF) + XK8 = XK8 *EXP( -1.56d0*(T0T-1.d0) + 16.900d0*COEF) + XK9 = XK9 *EXP( -8.22d0*(T0T-1.d0) + 16.010d0*COEF) +C XK10= XK10*EXP(-74.38d0*(T0T-1.d0) + 6.120d0*COEF) ! ISORR + XK10= XK10*EXP(-74.7351d0*(T0T-1.d0) + 6.025d0*COEF) ! (Mozurkewich, 1993) +C XK10= XK10*EXP(-75.11d0*(T0T-1.d0) + 13.460d0*COEF) ! SEQUIL + XK11= XK11*EXP( 0.79d0*(T0T-1.d0) + 14.746d0*COEF) + XK12= XK12*EXP( -2.87d0*(T0T-1.d0) + 15.830d0*COEF) + XK13= XK13*EXP( -5.19d0*(T0T-1.d0) + 54.400d0*COEF) + XK14= XK14*EXP( 24.55d0*(T0T-1.d0) + 16.900d0*COEF) + XKW = XKW *EXP(-22.52d0*(T0T-1.d0) + 26.920d0*COEF) +CCC +C XK15= XK15 *EXP( .0d0*(T0T-1.d0) + .0d0*COEF) +C XK16= XK16 *EXP( .0d0*(T0T-1.d0) + .0d0*COEF) + XK17= XK17 *EXP(-9.585d0*(T0T-1.d0) + 45.81d0*COEF) + XK18= XK18 *EXP(-8.423d0*(T0T-1.d0) + 17.96d0*COEF) + XK19= XK19 *EXP(-14.08d0*(T0T-1.d0) + 19.39d0*COEF) + XK20= XK20 *EXP(-6.902d0*(T0T-1.d0) + 19.95d0*COEF) +C XK23= XK23 *EXP( .0d0*(T0T-1.d0) + .0d0*COEF) +C XK24= XK24 *EXP( .0d0*(T0T-1.d0) + .0d0*COEF) +C XK25= XK25 *EXP( .0d0*(T0T-1.d0) + .0d0*COEF) +C XK26= XK26 *EXP(-3.0821d0*(T0T-1.d0) + 31.8139*COEF) +C XK27= XK27 *EXP(-5.9908d0*(T0T-1.d0) + 38.844*COEF) + + ENDIF + XK2 = XK21*XK22 + XK42 = XK4/XK41 + XK32 = XK3/XK31 +C +C *** CALCULATE DELIQUESCENCE RELATIVE HUMIDITIES (UNICOMPONENT) ******** +C + DRH2SO4 = ZERO + DRNH42S4 = 0.7997D0 + DRNH4HS4 = 0.4000D0 + DRLC = 0.6900D0 + DRNACL = 0.7528D0 + DRNANO3 = 0.7379D0 + DRNH4CL = 0.7710D0 + DRNH4NO3 = 0.6183D0 + DRNA2SO4 = 0.9300D0 + DRNAHSO4 = 0.5200D0 + DRCANO32 = 0.4906D0 + DRCACL2 = 0.2830D0 + DRK2SO4 = 0.9750D0 + DRKHSO4 = 0.8600D0 + DRKNO3 = 0.9248D0 + DRKCL = 0.8426D0 + DRMGSO4 = 0.8613D0 + DRMGNO32 = 0.5400D0 + DRMGCL2 = 0.3284D0 + IF (INT(TEMP) .NE. 298) THEN + T0 = 298.15D0 + TCF = 1.d0/TEMP - 1.d0/T0 + DRNACL = DRNACL *EXP( 25.d0*TCF) + DRNANO3 = DRNANO3 *EXP(304.d0*TCF) + DRNA2SO4 = DRNA2SO4*EXP( 80.d0*TCF) + DRNH4NO3 = DRNH4NO3*EXP(852.d0*TCF) + DRNH42S4 = DRNH42S4*EXP( 80.d0*TCF) + DRNH4HS4 = DRNH4HS4*EXP(384.d0*TCF) + DRLC = DRLC *EXP(186.d0*TCF) + DRNH4CL = DRNH4Cl *EXP(239.d0*TCF) + DRNAHSO4 = DRNAHSO4*EXP(-45.d0*TCF) +C DRCANO32 = DRCANO32*EXP(-430.5d0*TCF) + DRCANO32 = DRCANO32*EXP(509.4d0*TCF) ! KELLY & WEXLER (2005) FOR CANO32.4H20 +C DRCACL2 = DRCACL2 *EXP(-1121.d0*TCF) + DRCACL2 = DRCACL2 *EXP(551.1d0*TCF) ! KELLY & WEXLER (2005) FOR CACL2.6H20 + DRK2SO4 = DRK2SO4 *EXP(35.6d0*TCF) +C DRKHSO4 = DRKHSO4 *EXP( 0.d0*TCF) +C DRKNO3 = DRKNO3 *EXP( 0.d0*TCF) + DRKCL = DRKCL *EXP(159.d0*TCF) + DRMGSO4 = DRMGSO4 *EXP(-714.45d0*TCF) + DRMGNO32 = DRMGNO32*EXP(230.2d0*TCF) ! KELLY & WEXLER (2005) FOR MGNO32.6H20 +C DRMGCL2 = DRMGCL2 *EXP(-1860.d0*TCF) + DRMGCL2 = DRMGCL2 *EXP(42.23d0*TCF) ! KELLY & WEXLER (2005) FOR MGCL2.6H20 +C + ENDIF +C +C *** CALCULATE MUTUAL DELIQUESCENCE RELATIVE HUMIDITIES **************** +C + DRMLCAB = 0.378D0 ! (NH4)3H(SO4)2 & NH4HSO4 + DRMLCAS = 0.690D0 ! (NH4)3H(SO4)2 & (NH4)2SO4 + DRMASAN = 0.600D0 ! (NH4)2SO4 & NH4NO3 + DRMG1 = 0.460D0 ! (NH4)2SO4, NH4NO3, NA2SO4, NH4CL + DRMG2 = 0.691D0 ! (NH4)2SO4, NA2SO4, NH4CL + DRMG3 = 0.697D0 ! (NH4)2SO4, NA2SO4 + DRMH1 = 0.240D0 ! NA2SO4, NANO3, NACL, NH4NO3, NH4CL + DRMH2 = 0.596D0 ! NA2SO4, NANO3, NACL, NH4CL + DRMI1 = 0.240D0 ! LC, NAHSO4, NH4HSO4, NA2SO4, (NH4)2SO4 + DRMI2 = 0.363D0 ! LC, NAHSO4, NA2SO4, (NH4)2SO4 - NO DATA - + DRMI3 = 0.610D0 ! LC, NA2SO4, (NH4)2SO4 + DRMQ1 = 0.494D0 ! (NH4)2SO4, NH4NO3, NA2SO4 + DRMR1 = 0.663D0 ! NA2SO4, NANO3, NACL + DRMR2 = 0.735D0 ! NA2SO4, NACL + DRMR3 = 0.673D0 ! NANO3, NACL + DRMR4 = 0.694D0 ! NA2SO4, NACL, NH4CL + DRMR5 = 0.731D0 ! NA2SO4, NH4CL + DRMR6 = 0.596D0 ! NA2SO4, NANO3, NH4CL + DRMR7 = 0.380D0 ! NA2SO4, NANO3, NACL, NH4NO3 + DRMR8 = 0.380D0 ! NA2SO4, NACL, NH4NO3 + DRMR9 = 0.494D0 ! NA2SO4, NH4NO3 + DRMR10 = 0.476D0 ! NA2SO4, NANO3, NH4NO3 + DRMR11 = 0.340D0 ! NA2SO4, NACL, NH4NO3, NH4CL + DRMR12 = 0.460D0 ! NA2SO4, NH4NO3, NH4CL + DRMR13 = 0.438D0 ! NA2SO4, NANO3, NH4NO3, NH4CL +C + DRMO1 = 0.460D0 ! (NH4)2SO4, NH4NO3, NH4Cl, NA2SO4, K2SO4, MGSO4 + DRMO2 = 0.691D0 ! (NH4)2SO4, NH4Cl, NA2SO4, K2SO4, MGSO4 + DRMO3 = 0.697D0 ! (NH4)2SO4, NA2SO4, K2SO4, MGSO4 + DRML1 = 0.240D0 ! K2SO4, MGSO4, KHSO4, NH4HSO4, NAHSO4, (NH4)2SO4, NA2SO4, LC + DRML2 = 0.363D0 ! K2SO4, MGSO4, KHSO4, NAHSO4, (NH4)2SO4, NA2SO4, LC + DRML3 = 0.610D0 ! K2SO4, MGSO4, KHSO4, (NH4)2SO4, NA2SO4, LC + DRMM1 = 0.240D0 ! K2SO4, NA2SO4, MGSO4, NH4CL, NACL, NANO3, NH4NO3 + DRMM2 = 0.596D0 ! K2SO4, NA2SO4, MGSO4, NH4CL, NACL, NANO3 + DRMP1 = 0.200D0 ! CA(NO3)2, CACL2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL + DRMP2 = 0.240D0 ! CA(NO3)2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL + DRMP3 = 0.240D0 ! CA(NO3)2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL + DRMP4 = 0.240D0 ! K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL + DRMP5 = 0.240D0 ! K2SO4, KNO3, KCL, MGSO4, NANO3, NACL, NH4NO3, NH4CL +CC + DRMV1 = 0.494D0 ! (NH4)2SO4, NH4NO3, NA2SO4, K2SO4, MGSO4 +CC +CC +C DRMO1 = 0.1D0 ! (NH4)2SO4, NH4NO3, NH4Cl, NA2SO4, K2SO4, MGSO4 +C DRMO2 = 0.1D0 ! (NH4)2SO4, NH4Cl, NA2SO4, K2SO4, MGSO4 +C DRMO3 = 0.1D0 ! (NH4)2SO4, NA2SO4, K2SO4, MGSO4 +C DRML1 = 0.1D0 ! K2SO4, MGSO4, KHSO4, NH4HSO4, NAHSO4, (NH4)2SO4, NA2SO4, LC +C DRML2 = 0.1D0 ! K2SO4, MGSO4, KHSO4, NAHSO4, (NH4)2SO4, NA2SO4, LC +C DRML3 = 0.1D0 ! K2SO4, MGSO4, KHSO4, (NH4)2SO4, NA2SO4, LC +C DRMM1 = 0.1D0 ! K2SO4, NA2SO4, MGSO4, NH4CL, NACL, NANO3, NH4NO3 +C DRMM2 = 0.1D0 ! K2SO4, NA2SO4, MGSO4, NH4CL, NACL, NANO3 +C DRMP1 = 0.1D0 ! CA(NO3)2, CACL2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL +C DRMP2 = 0.1D0 ! CA(NO3)2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL +C DRMP3 = 0.1D0 ! CA(NO3)2, K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL +C DRMP4 = 0.1D0 ! K2SO4, KNO3, KCL, MGSO4, MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL +C DRMP5 = 0.1D0 ! K2SO4, KNO3, KCL, MGSO4, NANO3, NACL, NH4NO3, NH4CL +CC +C DRMV1 = 0.1D0 ! (NH4)2SO4, NH4NO3, NA2SO4, K2SO4, MGSO4 +C +CCC IF (INT(TEMP) .NE. 298) THEN +CCC T0 = 298.15d0 +CCC TCF = 1.0/TEMP - 1.0/T0 +CCC DRMLCAB = DRMLCAB*EXP( 507.506*TCF) +CCC DRMLCAS = DRMLCAS*EXP( 133.865*TCF) +CCC DRMASAN = DRMASAN*EXP(1269.068*TCF) +CCC DRMG1 = DRMG1 *EXP( 572.207*TCF) +CCC DRMG2 = DRMG2 *EXP( 58.166*TCF) +CCC DRMG3 = DRMG3 *EXP( 22.253*TCF) +CCC DRMH1 = DRMH1 *EXP(2116.542*TCF) +CCC DRMH2 = DRMH2 *EXP( 650.549*TCF) +CCC DRMI1 = DRMI1 *EXP( 565.743*TCF) +CCC DRMI2 = DRMI2 *EXP( 91.745*TCF) +CCC DRMI3 = DRMI3 *EXP( 161.272*TCF) +CCC DRMQ1 = DRMQ1 *EXP(1616.621*TCF) +CCC DRMR1 = DRMR1 *EXP( 292.564*TCF) +CCC DRMR2 = DRMR2 *EXP( 14.587*TCF) +CCC DRMR3 = DRMR3 *EXP( 307.907*TCF) +CCC DRMR4 = DRMR4 *EXP( 97.605*TCF) +CCC DRMR5 = DRMR5 *EXP( 98.523*TCF) +CCC DRMR6 = DRMR6 *EXP( 465.500*TCF) +CCC DRMR7 = DRMR7 *EXP( 324.425*TCF) +CCC DRMR8 = DRMR8 *EXP(2660.184*TCF) +CCC DRMR9 = DRMR9 *EXP(1617.178*TCF) +CCC DRMR10 = DRMR10 *EXP(1745.226*TCF) +CCC DRMR11 = DRMR11 *EXP(3691.328*TCF) +CCC DRMR12 = DRMR12 *EXP(1836.842*TCF) +CCC DRMR13 = DRMR13 *EXP(1967.938*TCF) +CCC ENDIF +C +C *** LIQUID PHASE ****************************************************** +C + CHNO3 = ZERO + CHCL = ZERO + CH2SO4 = ZERO + COH = ZERO + WATER = TINY +C + DO I=1,NPAIR + MOLALR(I)=ZERO + GAMA(I) =0.1d0 + GAMIN(I) =GREAT + GAMOU(I) =GREAT + M0(I) =1d5 + ENDDO +C + DO I=1,NPAIR + GAMA(I) = 0.1d0 + ENDDO +C + DO I=1,NIONS + MOLAL(I)=ZERO + ENDDO + COH = ZERO +C + DO I=1,NGASAQ + GASAQ(I)=ZERO + ENDDO +C +C *** SOLID PHASE ******************************************************* +C + CNH42S4= ZERO + CNH4HS4= ZERO + CNACL = ZERO + CNA2SO4= ZERO + CNANO3 = ZERO + CNH4NO3= ZERO + CNH4CL = ZERO + CNAHSO4= ZERO + CLC = ZERO + CCASO4 = ZERO + CCANO32= ZERO + CCACL2 = ZERO + CK2SO4 = ZERO + CKHSO4 = ZERO + CKNO3 = ZERO + CKCL = ZERO + CMGSO4 = ZERO + CMGNO32= ZERO + CMGCL2 = ZERO +C +C *** GAS PHASE ********************************************************* +C + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO +C +C *** CALCULATE ZSR PARAMETERS ****************************************** +C + IRH = MIN (INT(RH*NZSR+0.5d0),NZSR) ! Position in ZSR arrays + IRH = MAX (IRH, 1) +C + M0(01) = AWSC(IRH) ! NACl +C IF (M0(01) < 100.0) THEN +C IC = M0(01) +C CALL KMTAB(IC,298.0, GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(01) = M0(01)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(02) = AWSS(IRH) ! (NA)2SO4 +C IF (M0(02) < 100.0) THEN +C IC = 3.0*M0(02) +C CALL KMTAB(IC,298.0, XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(02) = M0(02)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(03) = AWSN(IRH) ! NANO3 +C IF (M0(03) < 100.0) THEN +C IC = M0(03) +C CALL KMTAB(IC,298.0, XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(03) = M0(03)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(04) = AWAS(IRH) ! (NH4)2SO4 +C IF (M0(04) < 100.0) THEN +C IC = 3.0*M0(04) +C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(04) = M0(04)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(05) = AWAN(IRH) ! NH4NO3 +C IF (M0(05) < 100.0) THEN +C IC = M0(05) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(05) = M0(05)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(06) = AWAC(IRH) ! NH4CL +C IF (M0(06) < 100.0) THEN +C IC = M0(06) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(06) = M0(06)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(07) = AWSA(IRH) ! 2H-SO4 +C IF (M0(07) < 100.0) THEN +C IC = 3.0*M0(07) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(07) = M0(07)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(08) = AWSA(IRH) ! H-HSO4 +CCC IF (M0(08) < 100.0) THEN ! These are redundant, because M0(8) is not used +CCC IC = M0(08) +CCC CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +CCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +CCCCCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX) +CCC M0(08) = M0(08)*EXP(LN10*(GI0-GII)) +CCC ENDIF +C + M0(09) = AWAB(IRH) ! NH4HSO4 +C IF (M0(09) < 100.0) THEN +C IC = M0(09) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(09) = M0(09)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(12) = AWSB(IRH) ! NAHSO4 +C IF (M0(12) < 100.0) THEN +C IC = M0(12) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GI0, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GII, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(12) = M0(12)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(13) = AWLC(IRH) ! (NH4)3H(SO4)2 +C IF (M0(13) < 100.0) THEN +C IC = 4.0*M0(13) +C CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C G130 = 0.2*(3.0*GI0+2.0*GII) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,XX) +C G13I = 0.2*(3.0*GI0+2.0*GII) +C M0(13) = M0(13)*EXP(LN10*SNGL(G130-G13I)) +C ENDIF +C + M0(15) = AWCN(IRH) ! CA(NO3)2 +C IF (M0(15) < 100.0) THEN +C IC = M0(15) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & GI0,XX,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & GII,XX,XX,XX,XX,XX,XX,XX,XX) +C M0(15) = M0(15)*EXP(LN10*(GI0-GII)) +C ENDIF +CC + M0(16) = AWCC(IRH) ! CACl2 +C IF (M0(16) < 100.0) THEN +C IC = M0(16) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,GI0,XX,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,GII,XX,XX,XX,XX,XX,XX,XX) +C M0(16) = M0(16)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(17) = AWPS(IRH) ! K2SO4 +C IF (M0(17) < 100.0) THEN +C IC = M0(17) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,GI0,XX,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,GII,XX,XX,XX,XX,XX,XX) +C M0(17) = M0(17)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(18) = AWPB(IRH) ! KHSO4 +C IF (M0(18) < 100.0) THEN +C IC = M0(18) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,GI0,XX,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,GII,XX,XX,XX,XX,XX) +C M0(18) = M0(18)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(19) = AWPN(IRH) ! KNO3 +C IF (M0(19) < 100.0) THEN +C IC = M0(19) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,GI0,XX,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,GII,XX,XX,XX,XX) +C M0(19) = M0(19)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(20) = AWPC(IRH) ! KCl +C IF (M0(20) < 100.0) THEN +C IC = M0(20) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,GI0,XX,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,GII,XX,XX,XX) +C M0(20) = M0(20)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(21) = AWMS(IRH) ! MGSO4 +C IF (M0(21) < 100.0) THEN +C IC = M0(21) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,GI0,XX,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,GII,XX,XX) +C M0(21) = M0(21)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(22) = AWMN(IRH) ! MG(NO3)2 +C IF (M0(22) < 100.0) THEN +C IC = M0(22) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,GI0,XX) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,GII,XX) +C M0(22) = M0(22)*EXP(LN10*(GI0-GII)) +C ENDIF +C + M0(23) = AWMC(IRH) ! MGCL2 +C IF (M0(23) < 100.0) THEN +C IC = M0(23) +C CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,GI0) +C CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX, +C & XX,XX,XX,XX,XX,XX,XX,XX,GII) +C M0(23) = M0(23)*EXP(LN10*(GI0-GII)) +C ENDIF +C +C *** OTHER INITIALIZATIONS ********************************************* +C + ICLACT = 0 + CALAOU = .TRUE. + CALAIN = .TRUE. + FRST = .TRUE. + SCASE = '??' + SULRATW = 2.D0 + SO4RAT = 2.D0 + CRNARAT = 2.D0 + CRRAT = 2.D0 + NOFER = 0 + STKOFL =.FALSE. + DO I=1,NERRMX + ERRSTK(I) =-999 + ERRMSG(I) = 'MESSAGE N/A' + ENDDO +C +C *** END OF SUBROUTINE INIT4 ******************************************* +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ADJUST +C *** ADJUSTS FOR MASS BALANCE BETWEEN VOLATILE SPECIES AND SULFATE +C FIRST CALCULATE THE EXCESS OF EACH PRECURSOR, AND IF IT EXISTS, THEN +C ADJUST SEQUENTIALY AEROSOL PHASE SPECIES WHICH CONTAIN THE EXCESS +C PRECURSOR. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ADJUST (WI) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: WI(*) +C +C *** FOR AMMONIUM ***************************************************** +C + IF (IPROB == 0) THEN ! Calculate excess (solution - input) + EXNH4 = GNH3 + MOLAL(3) + CNH4CL + CNH4NO3 + CNH4HS4 + & + 2D0*CNH42S4 + 3D0*CLC + & -WI(3) + ELSE + EXNH4 = MOLAL(3) + CNH4CL + CNH4NO3 + CNH4HS4 + 2D0*CNH42S4 + & + 3D0*CLC + & -WI(3) + + ENDIF + EXNH4 = MAX(EXNH4,ZERO) + IF ((EXNH4) < TINY) GOTO 20 ! No excess NH4, go to next precursor +C + IF ((MOLAL(3)) > (EXNH4)) THEN ! Adjust aqueous phase NH4 + MOLAL(3) = MOLAL(3) - EXNH4 + GOTO 20 + ELSE + EXNH4 = EXNH4 - MOLAL(3) + MOLAL(3) = ZERO + ENDIF +C + IF ((CNH4CL) > (EXNH4)) THEN ! Adjust NH4Cl(s) + CNH4CL = CNH4CL - EXNH4 ! more solid than excess + GHCL = GHCL + EXNH4 ! evaporate Cl to gas phase + GOTO 20 + ELSE ! less solid than excess + GHCL = GHCL + CNH4CL ! evaporate into gas phase + EXNH4 = EXNH4 - CNH4CL ! reduce excess + CNH4CL = ZERO ! zero salt concentration + ENDIF +C + IF ((CNH4NO3) > (EXNH4)) THEN ! Adjust NH4NO3(s) + CNH4NO3 = CNH4NO3- EXNH4 ! more solid than excess + GHNO3 = GHNO3 + EXNH4 ! evaporate NO3 to gas phase + GOTO 20 + ELSE ! less solid than excess + GHNO3 = GHNO3 + CNH4NO3! evaporate into gas phase + EXNH4 = EXNH4 - CNH4NO3! reduce excess + CNH4NO3 = ZERO ! zero salt concentration + ENDIF +C + IF ((CLC) > 3d0*(EXNH4)) THEN ! Adjust (NH4)3H(SO4)2(s) + CLC = CLC - EXNH4/3d0 ! more solid than excess + GOTO 20 + ELSE ! less solid than excess + EXNH4 = EXNH4 - 3d0*CLC ! reduce excess + CLC = ZERO ! zero salt concentration + ENDIF +C + IF ((CNH4HS4) > (EXNH4)) THEN ! Adjust NH4HSO4(s) + CNH4HS4 = CNH4HS4- EXNH4 ! more solid than excess + GOTO 20 + ELSE ! less solid than excess + EXNH4 = EXNH4 - CNH4HS4! reduce excess + CNH4HS4 = ZERO ! zero salt concentration + ENDIF +C + IF ((CNH42S4) > (EXNH4)) THEN ! Adjust (NH4)2SO4(s) + CNH42S4 = CNH42S4- EXNH4 ! more solid than excess + GOTO 20 + ELSE ! less solid than excess + EXNH4 = EXNH4 - CNH42S4! reduce excess + CNH42S4 = ZERO ! zero salt concentration + ENDIF +C +C *** FOR NITRATE ****************************************************** +C + 20 IF (IPROB == 0) THEN ! Calculate excess (solution - input) + EXNO3 = GHNO3 + MOLAL(7) + CNH4NO3 + & -WI(4) + ELSE + EXNO3 = MOLAL(7) + CNH4NO3 + & -WI(4) + ENDIF + EXNO3 = MAX(EXNO3,ZERO) + IF ((EXNO3) < TINY) GOTO 30 ! No excess NO3, go to next precursor +C + IF ((MOLAL(7)) > (EXNO3)) THEN ! Adjust aqueous phase NO3 + MOLAL(7) = MOLAL(7) - EXNO3 + GOTO 30 + ELSE + EXNO3 = EXNO3 - MOLAL(7) + MOLAL(7) = ZERO + ENDIF +C + IF ((CNH4NO3) > (EXNO3)) THEN ! Adjust NH4NO3(s) + CNH4NO3 = CNH4NO3- EXNO3 ! more solid than excess + GNH3 = GNH3 + EXNO3 ! evaporate NO3 to gas phase + GOTO 30 + ELSE ! less solid than excess + GNH3 = GNH3 + CNH4NO3! evaporate into gas phase + EXNO3 = EXNO3 - CNH4NO3! reduce excess + CNH4NO3 = ZERO ! zero salt concentration + ENDIF +C +C *** FOR CHLORIDE ***************************************************** +C + 30 IF (IPROB == 0) THEN ! Calculate excess (solution - input) + EXCl = GHCL + MOLAL(4) + CNH4CL + & -WI(5) + ELSE + EXCl = MOLAL(4) + CNH4CL + & -WI(5) + ENDIF + EXCl = MAX(EXCl,ZERO) + IF ((EXCl) < TINY) GOTO 40 ! No excess Cl, go to next precursor +C + IF ((MOLAL(4)) > (EXCL)) THEN ! Adjust aqueous phase Cl + MOLAL(4) = MOLAL(4) - EXCL + GOTO 40 + ELSE + EXCL = EXCL - MOLAL(4) + MOLAL(4) = ZERO + ENDIF +C + IF ((CNH4CL) > (EXCL)) THEN ! Adjust NH4Cl(s) + CNH4CL = CNH4CL - EXCL ! more solid than excess + GHCL = GHCL + EXCL ! evaporate Cl to gas phase + GOTO 40 + ELSE ! less solid than excess + GHCL = GHCL + CNH4CL ! evaporate into gas phase + EXCL = EXCL - CNH4CL ! reduce excess + CNH4CL = ZERO ! zero salt concentration + ENDIF +C +C *** FOR SULFATE ****************************************************** +C + 40 EXS4 = MOLAL(5) + MOLAL(6) + 2.d0*CLC + CNH42S4 + CNH4HS4 + + & CNA2SO4 + CNAHSO4 - WI(2) + EXS4 = MAX(EXS4,ZERO) ! Calculate excess (solution - input) + IF ((EXS4) < TINY) GOTO 50 ! No excess SO4, return +C + IF ((MOLAL(6)) > (EXS4)) THEN ! Adjust aqueous phase HSO4 + MOLAL(6) = MOLAL(6) - EXS4 + GOTO 50 + ELSE + EXS4 = EXS4 - MOLAL(6) + MOLAL(6) = ZERO + ENDIF +C + IF ((MOLAL(5)) > (EXS4)) THEN ! Adjust aqueous phase SO4 + MOLAL(5) = MOLAL(5) - EXS4 + GOTO 50 + ELSE + EXS4 = EXS4 - MOLAL(5) + MOLAL(5) = ZERO + ENDIF +C + IF ((CLC) > 2d0*(EXS4)) THEN ! Adjust (NH4)3H(SO4)2(s) + CLC = CLC - EXS4/2d0 ! more solid than excess + GNH3 = GNH3 +1.5d0*EXS4! evaporate NH3 to gas phase + GOTO 50 + ELSE ! less solid than excess + GNH3 = GNH3 + 1.5d0*CLC! evaporate NH3 to gas phase + EXS4 = EXS4 - 2d0*CLC ! reduce excess + CLC = ZERO ! zero salt concentration + ENDIF +C + IF ((CNH4HS4) > (EXS4)) THEN ! Adjust NH4HSO4(s) + CNH4HS4 = CNH4HS4 - EXS4 ! more solid than excess + GNH3 = GNH3 + EXS4 ! evaporate NH3 to gas phase + GOTO 50 + ELSE ! less solid than excess + GNH3 = GNH3 + CNH4HS4 ! evaporate NH3 to gas phase + EXS4 = EXS4 - CNH4HS4 ! reduce excess + CNH4HS4 = ZERO ! zero salt concentration + ENDIF +C + IF ((CNH42S4) > (EXS4)) THEN ! Adjust (NH4)2SO4(s) + CNH42S4 = CNH42S4- EXS4 ! more solid than excess + GNH3 = GNH3 + 2.d0*EXS4! evaporate NH3 to gas phase + GOTO 50 + ELSE ! less solid than excess + GNH3 = GNH3+2.d0*CNH42S4 ! evaporate NH3 to gas phase + EXS4 = EXS4 - CNH42S4 ! reduce excess + CNH42S4 = ZERO ! zero salt concentration + ENDIF +C +C *** RETURN ********************************************************** +C + 50 RETURN + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** FUNCTION GETASR +C *** CALCULATES THE LIMITING NH4+/SO4 RATIO OF A SULFATE POOR SYSTEM +C (i.e. SULFATE RATIO = 2.0) FOR GIVEN SO4 LEVEL AND RH +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + REAL*8 FUNCTION GETASR (SO4I, RHI) + IMPLICIT NONE + INTEGER, PARAMETER :: NSO4S = 14 + INTEGER, PARAMETER :: NRHS = 20 + INTEGER, PARAMETER :: NASRD = NSO4S*NRHS + REAL*8 :: WF, ASRAT, ASSO4 + COMMON /ASRC/ ASRAT(NASRD), ASSO4(NSO4S) +!$OMP THREADPRIVATE( /ASRC/ ) + REAL*8 :: SO4I, RHI, RAT + INTEGER :: IA1, A1, INDS, INDR, INDSL, INDSH, IPOSL, IPOSH +CCC +CCC *** SOLVE USING FULL COMPUTATIONS, NOT LOOK-UP TABLES ************** +CCC +CCC W(2) = WAER(2) +CCC W(3) = WAER(2)*2.0001D0 +CCC CALL CALCA2 +CCC SULRATW = MOLAL(3)/WAER(2) +CCC CALL INIT1 (WI, RHI, TEMPI) ! Re-initialize COMMON BLOCK +C +C *** CALCULATE INDICES ************************************************ +C + RAT = SO4I/1.D-9 + A1 = INT(LOG10(RAT)) ! Magnitude of RAT + IA1 = INT(RAT/2.5d0/10.d0**A1) +C + INDS = INT(4.d0*A1 + MIN(IA1,4)) + INDS = MIN(MAX(0, INDS), NSO4S-1) + 1 ! SO4 component of IPOS +C + INDR = INT(99.d0-RHI*100.d0) + 1 + INDR = MIN(MAX(1, INDR), NRHS) ! RH component of IPOS +C +C *** GET VALUE AND RETURN ********************************************* +C + INDSL = INDS + INDSH = MIN(INDSL+1, NSO4S) + IPOSL = (INDSL-1)*NRHS + INDR ! Low position in array + IPOSH = (INDSH-1)*NRHS + INDR ! High position in array +C + WF = (SO4I-ASSO4(INDSL))/(ASSO4(INDSH)-ASSO4(INDSL) + 1.D-7) + WF = MIN(MAX((WF), 0.d0), 1.d0) +! IF ((WF) < 0.D0) THEN +! WF = 0.d0 +! ELSEIF ((WF) > 1.D0) THEN +! WF = 1.d0 +! ENDIF +C + GETASR = WF*ASRAT(IPOSH) + (1.D0-WF)*ASRAT(IPOSL) +C +C *** END OF FUNCTION GETASR ******************************************* +C + RETURN + END + + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** BLOCK DATA AERSR +C *** CONTAINS DATA FOR AEROSOL SULFATE RATIO ARRAY NEEDED IN FUNCTION +C GETASR +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + BLOCK DATA AERSR + INTEGER, PARAMETER :: NSO4S = 14 + INTEGER, PARAMETER :: NRHS = 20 + INTEGER, PARAMETER :: NASRD = NSO4S*NRHS + COMMON /ASRC/ ASRAT(NASRD), ASSO4(NSO4S) +C + DATA ASSO4/1.0D-9, 2.5D-9, 5.0D-9, 7.5D-9, 1.0D-8, + & 2.5D-8, 5.0D-8, 7.5D-8, 1.0D-7, 2.5D-7, + & 5.0D-7, 7.5D-7, 1.0D-6, 5.0D-6/ +C + DATA (ASRAT(I), I=1,100)/ + & 1.020464, 0.9998130, 0.9960167, 0.9984423, 1.004004, + & 1.010885, 1.018356, 1.026726, 1.034268, 1.043846, + & 1.052933, 1.062230, 1.062213, 1.080050, 1.088350, + & 1.096603, 1.104289, 1.111745, 1.094662, 1.121594, + & 1.268909, 1.242444, 1.233815, 1.232088, 1.234020, + & 1.238068, 1.243455, 1.250636, 1.258734, 1.267543, + & 1.276948, 1.286642, 1.293337, 1.305592, 1.314726, + & 1.323463, 1.333258, 1.343604, 1.344793, 1.355571, + & 1.431463, 1.405204, 1.395791, 1.393190, 1.394403, + & 1.398107, 1.403811, 1.411744, 1.420560, 1.429990, + & 1.439742, 1.449507, 1.458986, 1.468403, 1.477394, + & 1.487373, 1.495385, 1.503854, 1.512281, 1.520394, + & 1.514464, 1.489699, 1.480686, 1.478187, 1.479446, + & 1.483310, 1.489316, 1.497517, 1.506501, 1.515816, + & 1.524724, 1.533950, 1.542758, 1.551730, 1.559587, + & 1.568343, 1.575610, 1.583140, 1.590440, 1.596481, + & 1.567743, 1.544426, 1.535928, 1.533645, 1.535016, + & 1.539003, 1.545124, 1.553283, 1.561886, 1.570530, + & 1.579234, 1.587813, 1.595956, 1.603901, 1.611349, + & 1.618833, 1.625819, 1.632543, 1.639032, 1.645276/ + + DATA (ASRAT(I), I=101,200)/ + & 1.707390, 1.689553, 1.683198, 1.681810, 1.683490, + & 1.687477, 1.693148, 1.700084, 1.706917, 1.713507, + & 1.719952, 1.726190, 1.731985, 1.737544, 1.742673, + & 1.747756, 1.752431, 1.756890, 1.761141, 1.765190, + & 1.785657, 1.771851, 1.767063, 1.766229, 1.767901, + & 1.771455, 1.776223, 1.781769, 1.787065, 1.792081, + & 1.796922, 1.801561, 1.805832, 1.809896, 1.813622, + & 1.817292, 1.820651, 1.823841, 1.826871, 1.829745, + & 1.822215, 1.810497, 1.806496, 1.805898, 1.807480, + & 1.810684, 1.814860, 1.819613, 1.824093, 1.828306, + & 1.832352, 1.836209, 1.839748, 1.843105, 1.846175, + & 1.849192, 1.851948, 1.854574, 1.857038, 1.859387, + & 1.844588, 1.834208, 1.830701, 1.830233, 1.831727, + & 1.834665, 1.838429, 1.842658, 1.846615, 1.850321, + & 1.853869, 1.857243, 1.860332, 1.863257, 1.865928, + & 1.868550, 1.870942, 1.873208, 1.875355, 1.877389, + & 1.899556, 1.892637, 1.890367, 1.890165, 1.891317, + & 1.893436, 1.896036, 1.898872, 1.901485, 1.903908, + & 1.906212, 1.908391, 1.910375, 1.912248, 1.913952, + & 1.915621, 1.917140, 1.918576, 1.919934, 1.921220/ + + DATA (ASRAT(I), I=201,280)/ + & 1.928264, 1.923245, 1.921625, 1.921523, 1.922421, + & 1.924016, 1.925931, 1.927991, 1.929875, 1.931614, + & 1.933262, 1.934816, 1.936229, 1.937560, 1.938769, + & 1.939951, 1.941026, 1.942042, 1.943003, 1.943911, + & 1.941205, 1.937060, 1.935734, 1.935666, 1.936430, + & 1.937769, 1.939359, 1.941061, 1.942612, 1.944041, + & 1.945393, 1.946666, 1.947823, 1.948911, 1.949900, + & 1.950866, 1.951744, 1.952574, 1.953358, 1.954099, + & 1.948985, 1.945372, 1.944221, 1.944171, 1.944850, + & 1.946027, 1.947419, 1.948902, 1.950251, 1.951494, + & 1.952668, 1.953773, 1.954776, 1.955719, 1.956576, + & 1.957413, 1.958174, 1.958892, 1.959571, 1.960213, + & 1.977193, 1.975540, 1.975023, 1.975015, 1.975346, + & 1.975903, 1.976547, 1.977225, 1.977838, 1.978401, + & 1.978930, 1.979428, 1.979879, 1.980302, 1.980686, + & 1.981060, 1.981401, 1.981722, 1.982025, 1.982312/ +C +C *** END OF BLOCK DATA AERSR ****************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCHA +C *** CALCULATES CHLORIDES SPECIATION +C +C HYDROCHLORIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, +C AND DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE +C HYDROCHLORIC ACID DISSOLVED IS CALCULATED FROM THE +C HCL(G) <-> (H+) + (CL-) +C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCHA + INCLUDE 'isrpia_adj.inc' + REAL*8 :: KAPA, X, DELT, ALFA, DIAK +CC CHARACTER(LEN=40) errinf +C +C *** CALCULATE HCL DISSOLUTION ***************************************** +C + X = W(5) + DELT = 0.0d0 + IF ((WATER) > TINY) THEN + KAPA = MOLAL(1) + ALFA = XK3*R*TEMP*(WATER/GAMA(11))**2.D0 + DIAK = SQRT( (KAPA+ALFA)**2.D0 + 4.D0*ALFA*X) + DELT = 0.5D0*(-(KAPA+ALFA) + DIAK) +CC IF (DELT/KAPA > 0.1d0) THEN +CC WRITE (ERRINF,'(1PE10.3)') DELT/KAPA*100.0 +CC CALL PUSHERR (0033, ERRINF) +CC ENDIF + ENDIF +C +C *** CALCULATE HCL SPECIATION IN THE GAS PHASE ************************* +C + GHCL = MAX(X-DELT, 0.0d0) ! GAS HCL +C +C *** CALCULATE HCL SPECIATION IN THE LIQUID PHASE ********************** +C + MOLAL(4) = DELT ! CL- + MOLAL(1) = MOLAL(1) + DELT ! H+ +C + RETURN +C +C *** END OF SUBROUTINE CALCHA ****************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNA +C *** CALCULATES NITRATES SPECIATION +C +C NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT +C DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC +C ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> (H+) + (NO3-) +C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNA + INCLUDE 'isrpia_adj.inc' + REAL*8 :: ALFA, DELT, KAPA, DIAK +CC CHARACTER(LEN=40) errinf +C +C *** CALCULATE HNO3 DISSOLUTION **************************************** +C + X = W(4) + DELT = 0.0d0 + IF ((WATER) > TINY) THEN + KAPA = MOLAL(1) + ALFA = XK4*R*TEMP*(WATER/GAMA(10))**2.D0 + DIAK = SQRT( (KAPA+ALFA)**2.D0 + 4.d0*ALFA*X) + DELT = 0.5d0*(-(KAPA+ALFA) + DIAK) +CC IF (DELT/KAPA > 0.1d0) THEN +CC WRITE (ERRINF,'(1PE10.3)') DELT/KAPA*100.0 +CC CALL PUSHERR (0019, ERRINF) ! WARNING ERROR: NO SOLUTION +CC ENDIF + ENDIF +C +C *** CALCULATE HNO3 SPECIATION IN THE GAS PHASE ************************ +C + GHNO3 = MAX(X-DELT, 0.0d0) ! GAS HNO3 +C +C *** CALCULATE HNO3 SPECIATION IN THE LIQUID PHASE ********************* +C + MOLAL(7) = DELT ! NO3- + MOLAL(1) = MOLAL(1) + DELT ! H+ +C + RETURN +C +C *** END OF SUBROUTINE CALCNA ****************************************** +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNH3 +C *** CALCULATES AMMONIA IN GAS PHASE +C +C AMMONIA IN THE GAS PHASE IS ASSUMED A MINOR SPECIES, THAT +C DOES NOT SIGNIFICANTLY PERTURB THE AEROSOL EQUILIBRIUM. +C AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l) +C EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION. +C +C THIS IS THE VERSION USED BY THE DIRECT PROBLEM +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNH3 + INCLUDE 'isrpia_adj.inc' + REAL*8 :: BB, CC, DIAK, PSI +C +C *** IS THERE A LIQUID PHASE? ****************************************** +C + IF ((WATER) <= TINY) RETURN +C +C *** CALCULATE NH3 SUBLIMATION ***************************************** +C + A1 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + CHI1 = MOLAL(3) + CHI2 = MOLAL(1) +C + BB =(CHI2 + ONE/A1) ! a=1; b!=1; c!=1 + CC =-CHI1/A1 + DIAK = SQRT(BB*BB - 4.D0*CC) ! Always > 0 + PSI = 0.5d0*(-BB + DIAK) ! One positive root + PSI = MAX(MIN(PSI,CHI1), TINY) ! Constrict in acceptible range +C +C *** CALCULATE NH3 SPECIATION IN THE GAS PHASE ************************* +C + GNH3 = PSI ! GAS HNO3 +C +C *** CALCULATE NH3 AFFECT IN THE LIQUID PHASE ************************** +C + MOLAL(3) = CHI1 - PSI ! NH4+ + MOLAL(1) = CHI2 + PSI ! H+ +C + RETURN +C +C *** END OF SUBROUTINE CALCNH3 ***************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNHA +C +C THIS SUBROUTINE CALCULATES THE DISSOLUTION OF HCL, HNO3 AT +C THE PRESENCE OF (H,SO4). HCL, HNO3 ARE CONSIDERED MINOR SPECIES, +C THAT DO NOT SIGNIFICANTLY AFFECT THE EQUILIBRIUM POINT. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNHA + INCLUDE 'isrpia_adj.inc' + REAL*8 :: M1, M2, M3, DELCL, DELNO, OMEGA + CHARACTER(LEN=40) errinf +C +C *** SPECIAL CASE; WATER=ZERO ****************************************** +C + IF ((WATER) <= TINY) THEN +c wz + GOTO 55 +C +C *** SPECIAL CASE; HCL=HNO3=ZERO *************************************** +C + ELSEIF ((W(5)) <= TINY .AND. (W(4)) <= TINY) THEN + GOTO 60 +C +C *** SPECIAL CASE; HCL=ZERO ******************************************** +C + ELSE IF ((W(5)) <= TINY) THEN + CALL CALCNA ! CALL HNO3 DISSOLUTION ROUTINE + GOTO 60 +C +C *** SPECIAL CASE; HNO3=ZERO ******************************************* +C + ELSE IF ((W(4)) <= TINY) THEN + CALL CALCHA ! CALL HCL DISSOLUTION ROUTINE + GOTO 60 + ENDIF +C +C *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +C + A3 = XK4*R*TEMP*(WATER/GAMA(10))**2.D0 ! HNO3 + A4 = XK3*R*TEMP*(WATER/GAMA(11))**2.D0 ! HCL +C +C *** CALCULATE CUBIC EQUATION COEFFICIENTS ***************************** +C + DELCL = ZERO + DELNO = ZERO +C + OMEGA = MOLAL(1) ! H+ + CHI3 = W(4) ! HNO3 + CHI4 = W(5) ! HCL +C + C1 = A3*CHI3 + C2 = A4*CHI4 + C3 = A3 - A4 +C + M1 = (C1 + C2 + (OMEGA+A4)*C3)/C3 + M2 = ((OMEGA+A4)*C2 - A4*C3*CHI4)/C3 + M3 =-A4*C2*CHI4/C3 +C +C *** CALCULATE ROOTS *************************************************** +C + CALL POLY3 (M1, M2, M3, DELCL, ISLV) ! HCL DISSOLUTION + + IF (ISLV /= 0) THEN + DELCL = TINY ! TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT +C +C * Commenting this error since the tiny assumption was shown to be +C * reliable by A.Nenes. +C +C WRITE (ERRINF,'(1PE10.1)') TINY +C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION + ENDIF + DELCL = MIN(DELCL, CHI4) +C + DELNO = C1*DELCL/(C2 + C3*DELCL) + DELNO = MIN(DELNO, CHI3) +C + IF ((DELCL) < ZERO .OR. (DELNO) < ZERO .OR. + & (DELCL) > (CHI4) .OR. (DELNO) > (CHI3)) THEN + DELCL = TINY ! TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT + DELNO = TINY +C +C * Commenting this error since the tiny assumption was shown to be +C * reliable by A.Nenes. +C +C WRITE (ERRINF,'(1PE10.1)') TINY +C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION + ENDIF +CCC +CCC *** COMPARE DELTA TO TOTAL H+ ; ESTIMATE EFFECT TO HSO4 *************** +CCC +CC IF ((DELCL+DELNO)/MOLAL(1) > 0.1d0) THEN +CC WRITE (ERRINF,'(1PE10.3)') (DELCL+DELNO)/MOLAL(1)*100.0 +CC CALL PUSHERR (0021, ERRINF) +CC ENDIF +C +C *** EFFECT ON LIQUID PHASE ******************************************** +C +50 MOLAL(1) = MOLAL(1) + (DELNO+DELCL) ! H+ CHANGE + MOLAL(4) = MOLAL(4) + DELCL ! CL- CHANGE + MOLAL(7) = MOLAL(7) + DELNO ! NO3- CHANGE +C +C *** EFFECT ON GAS PHASE *********************************************** +C +55 GHCL = MAX((W(5) - MOLAL(4)), TINY) + GHNO3 = MAX((W(4) - MOLAL(7)), TINY) +C +60 RETURN +C +C *** END OF SUBROUTINE CALCNHA ***************************************** +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCAMAQ +C *** THIS SUBROUTINE CALCULATES THE NH3(aq) GENERATED FROM (H,NH4+). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCAMAQ (NH4I, OHI, DELT) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: NH4I, OHI, OM1, OM2, BB, CC, DD, DEL1, DEL2 +CC CHARACTER(LEN=40) errinf +C +C *** EQUILIBRIUM CONSTANTS +C + A22 = XK22/XKW/WATER*(GAMA(8)/GAMA(9))**2.D0 ! GAMA(NH3) ASSUMED 1 + AKW = XKW *RH*WATER*WATER +C +C *** FIND ROOT +C + OM1 = NH4I + OM2 = OHI + BB =-(OM1+OM2+A22*AKW) + CC = OM1*OM2 + DD = SQRT(BB*BB-4.D0*CC) + + DEL1 = 0.5D0*(-BB - DD) + DEL2 = 0.5D0*(-BB + DD) +C +C *** GET APPROPRIATE ROOT. +C + IF ((DEL1) < ZERO) THEN + IF ((DEL2) > (NH4I) .OR. (DEL2) > (OHI)) THEN + DELT = ZERO + ELSE + DELT = DEL2 + ENDIF + ELSE + DELT = DEL1 + ENDIF +CC +CC *** COMPARE DELTA TO TOTAL NH4+ ; ESTIMATE EFFECT ********************* +CC +CC IF (DELTA/HYD > 0.1d0) THEN +CC WRITE (ERRINF,'(1PE10.3)') DELTA/HYD*100.0 +CC CALL PUSHERR (0020, ERRINF) +CC ENDIF +C + RETURN +C +C *** END OF SUBROUTINE CALCAMAQ **************************************** +C + END + + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCAMAQ2 +C +C THIS SUBROUTINE CALCULATES THE NH3(aq) GENERATED FROM (H,NH4+). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCAMAQ2 (GGNH3, NH4I, OHI, NH3AQ) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: NH4I, NH3AQ, ALF1, ALF2, BB, CC, DEL, OHI +C +C *** EQUILIBRIUM CONSTANTS +C + A22 = XK22/XKW/WATER*(GAMA(8)/GAMA(9))**2.d0 ! GAMA(NH3) ASSUMED 1 + AKW = XKW *RH*WATER*WATER +C +C *** FIND ROOT +C + ALF1 = NH4I - GGNH3 + ALF2 = GGNH3 + BB = ALF1 + A22*AKW + CC =-A22*AKW*ALF2 + DEL = 0.5D0*(-BB + SQRT(BB*BB-4.D0*CC)) +C +C *** ADJUST CONCENTRATIONS +C + NH4I = ALF1 + DEL + OHI = DEL + IF ((OHI) <= TINY) OHI = SQRT(AKW) ! If solution is neutral. + NH3AQ = ALF2 - DEL +C + RETURN +C +C *** END OF SUBROUTINE CALCAMAQ2 **************************************** +C + END + + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCCLAQ +C +C THIS SUBROUTINE CALCULATES THE HCL(aq) GENERATED FROM (H+,CL-). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCCLAQ (CLI, HI, DELT) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: CLI, HI, OM1, OM2, BB, CC, DD, DELT +C +C *** EQUILIBRIUM CONSTANTS +C + A32 = XK32*WATER/(GAMA(11))**2.D0 ! GAMA(HCL) ASSUMED 1 +C +C *** FIND ROOT +C + OM1 = CLI + OM2 = HI + BB =-(OM1+OM2+A32) + CC = OM1*OM2 + DD = SQRT(BB*BB-4.D0*CC) + + DEL1 = 0.5D0*(-BB - DD) + DEL2 = 0.5D0*(-BB + DD) +C +C *** GET APPROPRIATE ROOT. +C + IF ((DEL1) < ZERO) THEN + IF ((DEL2) < ZERO .OR. (DEL2) > (CLI) .OR. + + (DEL2) > (HI)) THEN + DELT = ZERO + ELSE + DELT = DEL2 + ENDIF + ELSE + DELT = DEL1 + ENDIF +C + RETURN +C +C *** END OF SUBROUTINE CALCCLAQ **************************************** +C + END + + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCCLAQ2 +C +C THIS SUBROUTINE CALCULATES THE HCL(aq) GENERATED FROM (H+,CL-). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCCLAQ2 (GGCL, CLI, HI, CLAQ) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: GGCL, CLI, HI, CLAQ, ALF1, ALF2, DEL1 +C +C *** EQUILIBRIUM CONSTANTS +C + A32 = XK32*WATER/(GAMA(11))**2.D0 ! GAMA(HCL) ASSUMED 1 + AKW = XKW *RH*WATER*WATER +C +C *** FIND ROOT +C + ALF1 = CLI - GGCL + ALF2 = GGCL + COEF = (ALF1+A32) + DEL1 = 0.5d0*(-COEF + SQRT(COEF*COEF+4.D0*A32*ALF2)) +C +C *** CORRECT CONCENTRATIONS +C + CLI = ALF1 + DEL1 + HI = DEL1 + IF ((HI) <= TINY) HI = SQRT(AKW) ! If solution is neutral. + CLAQ = ALF2 - DEL1 +C + RETURN +C +C *** END OF SUBROUTINE CALCCLAQ2 **************************************** +C + END + + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNIAQ +C +C THIS SUBROUTINE CALCULATES THE HNO3(aq) GENERATED FROM (H,NO3-). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNIAQ (NO3I, HI, DELT) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: NO3I, HI, DELT + REAL*8 :: OM1, OM2, BB, CC, DD, DEL1, DEL2 +C +C *** EQUILIBRIUM CONSTANTS +C + A42 = XK42*WATER/(GAMA(10))**2.D0 ! GAMA(HNO3) ASSUMED 1 +C +C *** FIND ROOT +C + OM1 = NO3I + OM2 = HI + BB =-(OM1+OM2+A42) + CC = OM1*OM2 + DD = SQRT(BB*BB-4.D0*CC) + + DEL1 = 0.5D0*(-BB - DD) + DEL2 = 0.5D0*(-BB + DD) +C +C *** GET APPROPRIATE ROOT. +C + IF ((DEL1) < ZERO .OR. (DEL1) > (HI) .OR. + & (DEL1) > (NO3I)) THEN + DELT = ZERO + ELSE + DELT = DEL1 + RETURN + ENDIF +C + IF ((DEL2) < ZERO .OR. (DEL2) > (NO3I) .OR. + & (DEL2) > (HI)) THEN + DELT = ZERO + ELSE + DELT = DEL2 + ENDIF +C + RETURN +C +C *** END OF SUBROUTINE CALCNIAQ **************************************** +C + END + + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNIAQ2 +C +C THIS SUBROUTINE CALCULATES THE UNDISSOCIATED HNO3(aq) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: GGNO3, NO3I, HI, NO3AQ + REAL*8 :: OM1, OM2, BB, CC, DD, ALF1, ALF2, ALF3, DEL1 +C +C *** EQUILIBRIUM CONSTANTS +C + A42 = XK42*WATER/(GAMA(10))**2.d0 ! GAMA(HNO3) ASSUMED 1 + AKW = XKW *RH*WATER*WATER +C +C *** FIND ROOT +C + ALF1 = NO3I - GGNO3 + ALF2 = GGNO3 + ALF3 = HI +C + BB = ALF3 + ALF1 + A42 + CC = ALF3*ALF1 - A42*ALF2 + DEL1 = 0.5d0*(-BB + SQRT(BB*BB-4.D0*CC)) +C +C *** CORRECT CONCENTRATIONS +C + NO3I = ALF1 + DEL1 + HI = ALF3 + DEL1 + IF ((HI) <= TINY) HI = SQRT(AKW) ! If solution is neutral. + NO3AQ = ALF2 - DEL1 +C + RETURN +C +C *** END OF SUBROUTINE CALCNIAQ2 **************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCMR +C *** THIS SUBROUTINE CALCULATES: +C 1. ION PAIR CONCENTRATIONS (FROM [MOLAR] ARRAY) +C 2. WATER CONTENT OF LIQUID AEROSOL PHASE (FROM ZSR CORRELATION) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCMR + INCLUDE 'isrpia_adj.inc' + + CHARACTER SC*1 + REAL*8 :: HSO4I, SO4I, AML5, TOTS4, FRNO3, FRCL, FRNH4 +C +C *** CALCULATE ION PAIR CONCENTRATIONS ACCORDING TO SPECIFIC CASE **** +C + SC =SCASE(1:1) ! SULRAT & SODRAT case +C +C *** NH4-SO4 SYSTEM ; SULFATE POOR CASE +C + IF (SC == 'A') THEN + MOLALR(4) = MOLAL(5)+MOLAL(6) ! (NH4)2SO4 - CORRECT FOR SO4 TO HSO4 +C +C *** NH4-SO4 SYSTEM ; SULFATE RICH CASE ; NO FREE ACID +C + ELSE IF (SC == 'B') THEN + SO4I = MOLAL(5)-MOLAL(1) ! CORRECT FOR HSO4 DISSOCIATION + HSO4I = MOLAL(6)+MOLAL(1) + IF ((SO4I) < (HSO4I)) THEN + MOLALR(13) = SO4I ! [LC] = [SO4] + MOLALR(9) = MAX(HSO4I-SO4I, ZERO) ! NH4HSO4 + ELSE + MOLALR(13) = HSO4I ! [LC] = [HSO4] + MOLALR(4) = MAX(SO4I-HSO4I, ZERO) ! (NH4)2SO4 + ENDIF +C +C *** NH4-SO4 SYSTEM ; SULFATE RICH CASE ; FREE ACID +C + ELSE IF (SC == 'C') THEN + MOLALR(9) = MOLAL(3) ! NH4HSO4 + MOLALR(7) = MAX(W(2)-W(3), ZERO) ! H2SO4 +C +C *** NH4-SO4-NO3 SYSTEM ; SULFATE POOR CASE +C + ELSE IF (SC == 'D') THEN + MOLALR(4) = MOLAL(5) + MOLAL(6) ! (NH4)2SO4 + AML5 = MOLAL(3)-2.D0*MOLALR(4) ! "free" NH4 + MOLALR(5) = MAX(MIN(AML5,MOLAL(7)), ZERO)! NH4NO3 = MIN("free", NO3) +C +C *** NH4-SO4-NO3 SYSTEM ; SULFATE RICH CASE ; NO FREE ACID +C + ELSE IF (SC == 'E') THEN + SO4I = MAX(MOLAL(5)-MOLAL(1),ZERO) ! FROM HSO4 DISSOCIATION + HSO4I = MOLAL(6)+MOLAL(1) + IF ((SO4I) < (HSO4I)) THEN + MOLALR(13) = SO4I ! [LC] = [SO4] + MOLALR(9) = MAX(HSO4I-SO4I, ZERO) ! NH4HSO4 + ELSE + MOLALR(13) = HSO4I ! [LC] = [HSO4] + MOLALR(4) = MAX(SO4I-HSO4I, ZERO) ! (NH4)2SO4 + ENDIF +C +C *** NH4-SO4-NO3 SYSTEM ; SULFATE RICH CASE ; FREE ACID +C + ELSE IF (SC == 'F') THEN + MOLALR(9) = MOLAL(3) ! NH4HSO4 + MOLALR(7) = MAX(MOLAL(5)+MOLAL(6)-MOLAL(3),ZERO) ! H2SO4 +C +C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM POOR CASE +C + ELSE IF (SC == 'G') THEN + MOLALR(2) = 0.5D0*MOLAL(2) ! NA2SO4 + TOTS4 = MOLAL(5)+MOLAL(6) ! Total SO4 + MOLALR(4) = MAX(TOTS4 - MOLALR(2), ZERO) ! (NH4)2SO4 + FRNH4 = MAX(MOLAL(3) - 2.D0*MOLALR(4), ZERO) + MOLALR(5) = MIN(MOLAL(7),FRNH4) ! NH4NO3 + FRNH4 = MAX(FRNH4 - MOLALR(5), ZERO) + MOLALR(6) = MIN(MOLAL(4), FRNH4) ! NH4CL +C +C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM RICH CASE +C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/ +C + ELSE IF (SC == 'H') THEN + MOLALR(1) = PSI7 ! NACL + MOLALR(2) = PSI1 ! NA2SO4 + MOLALR(3) = PSI8 ! NANO3 + MOLALR(4) = ZERO ! (NH4)2SO4 + FRNO3 = MAX(MOLAL(7) - MOLALR(3), ZERO) ! "FREE" NO3 + FRCL = MAX(MOLAL(4) - MOLALR(1), ZERO) ! "FREE" CL + MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3 + FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3 + MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL +C +C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE RICH CASE ; NO FREE ACID +C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/ +C + ELSE IF (SC == 'I') THEN + MOLALR(04) = PSI5 ! (NH4)2SO4 + MOLALR(02) = PSI4 ! NA2SO4 + MOLALR(09) = PSI1 ! NH4HSO4 + MOLALR(12) = PSI3 ! NAHSO4 + MOLALR(13) = PSI2 ! LC +C +C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE RICH CASE ; FREE ACID +C + ELSE IF (SC == 'J') THEN + MOLALR(09) = MOLAL(3) ! NH4HSO4 + MOLALR(12) = MOLAL(2) ! NAHSO4 + MOLALR(07) = MOLAL(5)+MOLAL(6)-MOLAL(3)-MOLAL(2) ! H2SO4 + MOLALR(07) = MAX(MOLALR(07),ZERO) +C +C *** NA-NH4-SO4-NO3-CL-CA-K-MG SYSTEM ; SULFATE POOR ; CR+NA POOR CASE +C + ELSE IF (SC.EQ.'O') THEN + MOLALR(2) = 0.5D0*MOLAL(2) ! NA2SO4 + TOTS4 = MOLAL(5)+MOLAL(6) ! Total SO4 + MOLALR(17)= 0.5D0*MOLAL(9) ! K2SO4 + MOLALR(21)= MOLAL(10) ! MGSO4 + MOLALR(4) = MAX(TOTS4 - MOLALR(2) - MOLALR(17) + & - MOLALR(21), ZERO) ! (NH4)2SO4 + FRNH4 = MAX(MOLAL(3) - 2.D0*MOLALR(4), ZERO) + MOLALR(5) = MIN(MOLAL(7),FRNH4) ! NH4NO3 + FRNH4 = MAX(FRNH4 - MOLALR(5), ZERO) + MOLALR(6) = MIN(MOLAL(4), FRNH4) ! NH4CL +C +C *** NA-NH4-SO4-NO3-CL-CA-K-MG SYSTEM ; SULFATE POOR ; CR+NA RICH; CR POOR CASE +C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/ +C + ELSE IF (SC.EQ.'M') THEN + MOLALR(1) = PSI7 ! NACL + MOLALR(2) = PSI1 ! NA2SO4 + MOLALR(3) = PSI8 ! NANO3 + MOLALR(4) = ZERO ! (NH4)2SO4 + FRNO3 = MAX(MOLAL(7) - MOLALR(3), ZERO) ! "FREE" NO3 + FRCL = MAX(MOLAL(4) - MOLALR(1), ZERO) ! "FREE" CL + MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3 + FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3 + MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL + MOLALR(17)= PSI9 ! K2SO4 + MOLALR(21)= PSI10 ! MGSO4 +C +C *** NA-NH4-SO4-NO3-CL-CA-K-MG SYSTEM ; SULFATE POOR ; CR+NA RICH; CR RICH CASE +C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/ +C + ELSE IF (SC.EQ.'P') THEN + MOLALR(1) = PSI7 ! NACL + MOLALR(3) = PSI8 ! NANO3 + MOLALR(15)= PSI12 ! CANO32 + MOLALR(16)= PSI17 ! CACL2 + MOLALR(19)= PSI13 ! KNO3 + MOLALR(20)= PSI14 ! KCL + MOLALR(22)= PSI15 ! MGNO32 + MOLALR(23)= PSI16 ! MGCL2 + FRNO3 = MAX(MOLAL(7)-MOLALR(3)-2.D0*MOLALR(15) + & -MOLALR(19)-2.D0*MOLALR(22), ZERO) ! "FREE" NO3 + FRCL = MAX(MOLAL(4)-MOLALR(1)-2.D0*MOLALR(16) + & -MOLALR(20)-2.D0*MOLALR(23), ZERO) ! "FREE" CL + MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3 + FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3 + MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL + MOLALR(17)= PSI9 ! K2SO4 + MOLALR(21)= PSI10 ! MGSO4 +C +C *** NA-NH4-SO4-NO3-CL-CA-K-MG SYSTEM ; SULFATE RICH CASE ; NO FREE ACID +C + ELSE IF (SC.EQ.'L') THEN + MOLALR(04) = PSI5 ! (NH4)2SO4 + MOLALR(02) = PSI4 ! NA2SO4 + MOLALR(09) = PSI1 ! NH4HSO4 + MOLALR(12) = PSI3 ! NAHSO4 + MOLALR(13) = PSI2 ! LC + MOLALR(17) = PSI6 ! K2SO4 + MOLALR(21) = PSI7 ! MGSO4 + MOLALR(18) = PSI8 ! KHSO4 +C +C *** NA-NH4-SO4-NO3-CL-CA-K-MG SYSTEM ; SULFATE SUPER RICH CASE ; FREE ACID +C + ELSE IF (SC.EQ.'K') THEN + MOLALR(09) = MOLAL(3) ! NH4HSO4 + MOLALR(12) = MOLAL(2) ! NAHSO4 + MOLALR(14) = MOLAL(8) ! CASO4 + MOLALR(18) = MOLAL(9) ! KHSO4 + MOLALR(07) = MOLAL(5)+MOLAL(6)-MOLAL(3) + & -MOLAL(2)-MOLAL(8)-MOLAL(9) ! H2SO4 + MOLALR(07) = MAX(MOLALR(07),ZERO) +C +C ======= REVERSE PROBLEMS =========================================== +C +C *** NH4-SO4-NO3 SYSTEM ; SULFATE POOR CASE +C + ELSE IF (SC == 'N') THEN + MOLALR(4) = MOLAL(5) + MOLAL(6) ! (NH4)2SO4 + AML5 = WAER(3)-2.D0*MOLALR(4) ! "free" NH4 + MOLALR(5) = MAX(MIN(AML5,WAER(4)), ZERO) ! NH4NO3 = MIN("free", NO3) +C +C *** NH4-SO4-NO3-NA-CL SYSTEM ; SULFATE POOR, SODIUM POOR CASE +C + ELSE IF (SC == 'Q') THEN + MOLALR(2) = PSI1 ! NA2SO4 + MOLALR(4) = PSI6 ! (NH4)2SO4 + MOLALR(5) = PSI5 ! NH4NO3 + MOLALR(6) = PSI4 ! NH4CL +C +C *** NH4-SO4-NO3-NA-CL SYSTEM ; SULFATE POOR, SODIUM RICH CASE +C + ELSE IF (SC == 'R') THEN + MOLALR(1) = PSI3 ! NACL + MOLALR(2) = PSI1 ! NA2SO4 + MOLALR(3) = PSI2 ! NANO3 + MOLALR(4) = ZERO ! (NH4)2SO4 + MOLALR(5) = PSI5 ! NH4NO3 + MOLALR(6) = PSI4 ! NH4CL +C +C *** NH4-SO4-NO3-NA-CL-CA-K-MG SYSTEM ; SULFATE POOR, CRUSTAL&SODIUM POOR CASE +C + ELSE IF (SC.EQ.'V') THEN + MOLALR(2) = PSI1 ! NA2SO4 + MOLALR(4) = PSI6 ! (NH4)2SO4 + MOLALR(5) = PSI5 ! NH4NO3 + MOLALR(6) = PSI4 ! NH4CL + MOLALR(17)= PSI7 ! K2SO4 + MOLALR(21)= PSI8 ! MGSO4 +C +C *** NH4-SO4-NO3-NA-CL-CA-K-MG SYSTEM ; SULFATE POOR, CRUSTAL&SODIUM RICH, CRUSTAL POOR CASE +C + ELSE IF (SC.EQ.'U') THEN + MOLALR(1) = PSI3 ! NACL + MOLALR(2) = PSI1 ! NA2SO4 + MOLALR(3) = PSI2 ! NANO3 + MOLALR(5) = PSI5 ! NH4NO3 + MOLALR(6) = PSI4 ! NH4CL + MOLALR(17)= PSI7 ! K2SO4 + MOLALR(21)= PSI8 ! MGSO4 +C +C *** NH4-SO4-NO3-NA-CL-CA-K-MG SYSTEM ; SULFATE POOR, CRUSTAL&SODIUM RICH, CRUSTAL RICH CASE +C + ELSE IF (SC.EQ.'W') THEN + MOLALR(1) = PSI7 ! NACL + MOLALR(3) = PSI8 ! NANO3 + MOLALR(5) = PSI6 ! NH4NO3 + MOLALR(6) = PSI5 ! NH4CL + MOLALR(15)= PSI12 ! CANO32 + MOLALR(16)= PSI17 ! CACL2 + MOLALR(17)= PSI9 ! K2SO4 + MOLALR(19)= PSI13 ! KNO3 + MOLALR(20)= PSI14 ! KCL + MOLALR(21)= PSI10 ! MGSO4 + MOLALR(22)= PSI15 ! MGNO32 + MOLALR(23)= PSI16 ! MGCL2 +C +C *** UNKNOWN CASE +C + ELSE + CALL PUSHERR (1001, ' ') ! FATAL ERROR: CASE NOT SUPPORTED + ENDIF +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + WATER = ZERO + DO I=1,NPAIR + WATER = WATER + MOLALR(I)/M0(I) + ENDDO + WATER = MAX(WATER, TINY) +C + RETURN +C +C *** END OF SUBROUTINE CALCMR ****************************************** +C + END +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCMDRH +C +C THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL +C DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED +C SOLUTIONS ; THE 'DRY' SOLUTION (SUBROUTINE DRYCASE) AND THE +C 'SATURATED LIQUID' SOLUTION (SUBROUTINE LIQCASE). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C +C======================================================================= +C + SUBROUTINE CALCMDRH (RHI, RHDRY, RHLIQ, DRYCASE, LIQCASE) + INCLUDE 'isrpia_adj.inc' + EXTERNAL DRYCASE, LIQCASE +C +C *** FIND WEIGHT FACTOR ********************************************** +C + IF (WFTYP.EQ.0) THEN + WF = ONE + ELSEIF (WFTYP.EQ.1) THEN + WF = 0.5D0 + ELSE + WF = (RHLIQ-RHI)/(RHLIQ-RHDRY) + ENDIF + ONEMWF = ONE - WF +C +C *** FIND FIRST SECTION ; DRY ONE ************************************ +C + CALL DRYCASE + IF (ABS(ONEMWF).LE.1D-5) GOTO 200 ! DRY AEROSOL +C + CNH42SO = CNH42S4 ! FIRST (DRY) SOLUTION + CNH4HSO = CNH4HS4 + CLCO = CLC + CNH4N3O = CNH4NO3 + CNH4CLO = CNH4CL + CNA2SO = CNA2SO4 + CNAHSO = CNAHSO4 + CNANO = CNANO3 + CNACLO = CNACL + GNH3O = GNH3 + GHNO3O = GHNO3 + GHCLO = GHCL +C +C *** FIND SECOND SECTION ; DRY & LIQUID ****************************** +C + CNH42S4 = ZERO + CNH4HS4 = ZERO + CLC = ZERO + CNH4NO3 = ZERO + CNH4CL = ZERO + CNA2SO4 = ZERO + CNAHSO4 = ZERO + CNANO3 = ZERO + CNACL = ZERO + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO + CALL LIQCASE ! SECOND (LIQUID) SOLUTION +C +C *** ADJUST THINGS FOR THE CASE THAT THE LIQUID SUB PREDICTS DRY AEROSOL +C + IF (WATER.LE.TINY) THEN + DO 100 I=1,NIONS + MOLAL(I)= ZERO ! Aqueous phase + 100 CONTINUE + WATER = ZERO +C + CNH42S4 = CNH42SO ! Solid phase + CNA2SO4 = CNA2SO + CNAHSO4 = CNAHSO + CNH4HS4 = CNH4HSO + CLC = CLCO + CNH4NO3 = CNH4N3O + CNANO3 = CNANO + CNACL = CNACLO + CNH4CL = CNH4CLO +C + GNH3 = GNH3O ! Gas phase + GHNO3 = GHNO3O + GHCL = GHCLO +C + GOTO 200 + ENDIF +C +C *** FIND SALT DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS. +C + DAMSUL = CNH42SO - CNH42S4 + DSOSUL = CNA2SO - CNA2SO4 + DAMBIS = CNH4HSO - CNH4HS4 + DSOBIS = CNAHSO - CNAHSO4 + DLC = CLCO - CLC + DAMNIT = CNH4N3O - CNH4NO3 + DAMCHL = CNH4CLO - CNH4CL + DSONIT = CNANO - CNANO3 + DSOCHL = CNACLO - CNACL +C +C *** FIND GAS DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS. +C + DAMG = GNH3O - GNH3 + DHAG = GHCLO - GHCL + DNAG = GHNO3O - GHNO3 +C +C *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS. +C +C LIQUID +C + MOLAL(1)= ONEMWF*MOLAL(1) ! H+ + MOLAL(2)= ONEMWF*(2.D0*DSOSUL + DSOBIS + DSONIT + DSOCHL) ! NA+ + MOLAL(3)= ONEMWF*(2.D0*DAMSUL + DAMG + DAMBIS + DAMCHL + + & 3.D0*DLC + DAMNIT ) ! NH4+ + MOLAL(4)= ONEMWF*( DAMCHL + DSOCHL + DHAG) ! CL- + MOLAL(5)= ONEMWF*( DAMSUL + DSOSUL + DLC - MOLAL(6)) ! SO4-- !VB 17 Sept 2001 + MOLAL(6)= ONEMWF*( MOLAL(6) + DSOBIS + DAMBIS + DLC) ! HSO4- + MOLAL(7)= ONEMWF*( DAMNIT + DSONIT + DNAG) ! NO3- + WATER = ONEMWF*WATER +C +C SOLID +C + CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4 + CNA2SO4 = WF*CNA2SO + ONEMWF*CNA2SO4 + CNAHSO4 = WF*CNAHSO + ONEMWF*CNAHSO4 + CNH4HS4 = WF*CNH4HSO + ONEMWF*CNH4HS4 + CLC = WF*CLCO + ONEMWF*CLC + CNH4NO3 = WF*CNH4N3O + ONEMWF*CNH4NO3 + CNANO3 = WF*CNANO + ONEMWF*CNANO3 + CNACL = WF*CNACLO + ONEMWF*CNACL + CNH4CL = WF*CNH4CLO + ONEMWF*CNH4CL +C +C GAS +C + GNH3 = WF*GNH3O + ONEMWF*GNH3 + GHNO3 = WF*GHNO3O + ONEMWF*GHNO3 + GHCL = WF*GHCLO + ONEMWF*GHCL +C +C *** RETURN POINT +C +200 RETURN +C +C *** END OF SUBROUTINE CALCMDRH **************************************** +C + END + +C======================================================================= +C +C *** ISORROPIA CODE II +C *** SUBROUTINE CALCMDRH2 +C +C THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL +C DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED +C SOLUTIONS ; THE 'DRY' SOLUTION (SUBROUTINE DRYCASE) AND THE +C 'SATURATED LIQUID' SOLUTION (SUBROUTINE LIQCASE). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C +C======================================================================= +C + SUBROUTINE CALCMDRH2 (RHI, RHDRY, RHLIQ, DRYCASE, LIQCASE) + INCLUDE 'isrpia_adj.inc' + EXTERNAL DRYCASE, LIQCASE +C +C *** FIND WEIGHT FACTOR ********************************************** +C + IF (WFTYP.EQ.0) THEN + WF = ONE + ELSEIF (WFTYP.EQ.1) THEN + WF = 0.5D0 + ELSE + WF = (RHLIQ-RHI)/(RHLIQ-RHDRY) + ENDIF + ONEMWF = ONE - WF +C +C *** FIND FIRST SECTION ; DRY ONE ************************************ +C + CALL DRYCASE + IF (ABS(ONEMWF).LE.1D-5) GOTO 200 ! DRY AEROSOL +C + CNH42SO = CNH42S4 ! FIRST (DRY) SOLUTION + CNH4HSO = CNH4HS4 + CLCO = CLC + CNH4N3O = CNH4NO3 + CNH4CLO = CNH4CL + CNA2SO = CNA2SO4 + CNAHSO = CNAHSO4 + CNANO = CNANO3 + CNACLO = CNACL + GNH3O = GNH3 + GHNO3O = GHNO3 + GHCLO = GHCL +C + CCASO = CCASO4 + CK2SO = CK2SO4 + CMGSO = CMGSO4 + CKHSO = CKHSO4 + CCAN32O = CCANO32 + CCAC2L = CCACL2 + CKN3O = CKNO3 + CKCLO = CKCL + CMGN32O = CMGNO32 + CMGC2L = CMGCL2 +C +C *** FIND SECOND SECTION ; DRY & LIQUID ****************************** +C + CNH42S4 = ZERO + CNH4HS4 = ZERO + CLC = ZERO + CNH4NO3 = ZERO + CNH4CL = ZERO + CNA2SO4 = ZERO + CNAHSO4 = ZERO + CNANO3 = ZERO + CNACL = ZERO + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO +C + CCASO4 = ZERO + CK2SO4 = ZERO + CMGSO4 = ZERO + CKHSO4 = ZERO + CCANO32 = ZERO + CCACL2 = ZERO + CKNO3 = ZERO + CKCL = ZERO + CMGNO32 = ZERO + CMGCL2 = ZERO +C + CALL LIQCASE ! SECOND (LIQUID) SOLUTION +C +C *** ADJUST THINGS FOR THE CASE THAT THE LIQUID SUB PREDICTS DRY AEROSOL +C + IF (WATER.LE.TINY) THEN + DO 100 I=1,NIONS + MOLAL(I)= ZERO ! Aqueous phase + 100 CONTINUE + WATER = ZERO +C + CNH42S4 = CNH42SO ! Solid phase + CNA2SO4 = CNA2SO + CNAHSO4 = CNAHSO + CNH4HS4 = CNH4HSO + CLC = CLCO + CNH4NO3 = CNH4N3O + CNANO3 = CNANO + CNACL = CNACLO + CNH4CL = CNH4CLO +C + GNH3 = GNH3O ! Gas phase + GHNO3 = GHNO3O + GHCL = GHCLO +C + CCASO4 = CCASO + CK2SO4 = CK2SO + CMGSO4 = CMGSO + CKHSO4 = CKHSO + CCANO32 = CCAN32O + CCACL2 = CCAC2L + CKNO3 = CKN3O + CKCL = CKCLO + CMGNO32 = CMGN32O + CMGCL2 = CMGC2L +C + GOTO 200 + ENDIF +C +C *** FIND SALT DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS. +C + DAMSUL = CNH42SO - CNH42S4 + DSOSUL = CNA2SO - CNA2SO4 + DAMBIS = CNH4HSO - CNH4HS4 + DSOBIS = CNAHSO - CNAHSO4 + DLC = CLCO - CLC + DAMNIT = CNH4N3O - CNH4NO3 + DAMCHL = CNH4CLO - CNH4CL + DSONIT = CNANO - CNANO3 + DSOCHL = CNACLO - CNACL +C + DCASUL = CCASO - CCASO4 + DPOSUL = CK2SO - CK2SO4 + DMGSUL = CMGSO - CMGSO4 + DPOBIS = CKHSO - CKHSO4 + DCANIT = CCAN32O - CCANO32 + DCACHL = CCAC2L - CCACL2 + DPONIT = CKN3O - CKNO3 + DPOCHL = CKCLO - CKCL + DMGNIT = CMGN32O - CMGNO32 + DMGCHL = CMGC2L - CMGCL2 +C +C *** FIND GAS DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS. +C + DAMG = GNH3O - GNH3 + DHAG = GHCLO - GHCL + DNAG = GHNO3O - GHNO3 +C +C *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS. +C +C LIQUID +C + MOLAL(1) = ONEMWF*MOLAL(1) ! H+ + MOLAL(2) = ONEMWF*(2.D0*DSOSUL + DSOBIS + DSONIT + DSOCHL) ! NA+ + MOLAL(3) = ONEMWF*(2.D0*DAMSUL + DAMG + DAMBIS + DAMCHL + + & 3.D0*DLC + DAMNIT ) ! NH4+ + MOLAL(4) = ONEMWF*(DAMCHL + DSOCHL + DHAG + 2.D0*DCACHL + + & 2.D0*DMGCHL + DPOCHL) ! CL- + MOLAL(5) = ONEMWF*(DAMSUL + DSOSUL + DLC - MOLAL(6) + & +DCASUL + DPOSUL + DMGSUL) ! SO4-- !VB 17 Sept 2001 + MOLAL(6) = ONEMWF*(MOLAL(6) + DSOBIS + DAMBIS + DLC + DPOBIS) ! HSO4- + MOLAL(7) = ONEMWF*(DAMNIT + DSONIT + DNAG + 2.D0*DCANIT + & + 2.D0*DMGNIT + DPONIT) ! NO3- + MOLAL(8) = ONEMWF*(DCASUL + DCANIT + DCACHL) ! CA2+ + MOLAL(9) = ONEMWF*(2.D0*DPOSUL + DPONIT + DPOCHL + DPOBIS) ! K+ + MOLAL(10)= ONEMWF*(DMGSUL + DMGNIT + DMGCHL) ! MG2+ + WATER = ONEMWF*WATER +C +C SOLID +C + CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4 + CNA2SO4 = WF*CNA2SO + ONEMWF*CNA2SO4 + CNAHSO4 = WF*CNAHSO + ONEMWF*CNAHSO4 + CNH4HS4 = WF*CNH4HSO + ONEMWF*CNH4HS4 + CLC = WF*CLCO + ONEMWF*CLC + CNH4NO3 = WF*CNH4N3O + ONEMWF*CNH4NO3 + CNANO3 = WF*CNANO + ONEMWF*CNANO3 + CNACL = WF*CNACLO + ONEMWF*CNACL + CNH4CL = WF*CNH4CLO + ONEMWF*CNH4CL +C + CCASO4 = WF*CCASO + ONEMWF*CCASO4 + CK2SO4 = WF*CK2SO + ONEMWF*CK2SO4 + CMGSO4 = WF*CMGSO + ONEMWF*CMGSO4 + CKHSO4 = WF*CKHSO + ONEMWF*CKHSO4 + CCANO32 = WF*CCAN32O + ONEMWF*CCANO32 + CCACL2 = WF*CCAC2L + ONEMWF*CCACL2 + CMGNO32 = WF*CMGN32O + ONEMWF*CMGNO32 + CMGCL2 = WF*CMGC2L + ONEMWF*CMGCL2 + CKCL = WF*CKCLO + ONEMWF*CKCL +C +C GAS +C + GNH3 = WF*GNH3O + ONEMWF*GNH3 + GHNO3 = WF*GHNO3O + ONEMWF*GHNO3 + GHCL = WF*GHCLO + ONEMWF*GHCL +C +C *** RETURN POINT +C +200 RETURN +C +C *** END OF SUBROUTINE CALCMDRH2 **************************************** +C + END +C + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCMDRP +C +C THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL +C DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED +C SOLUTIONS ; THE 'DRY' SOLUTION (SUBROUTINE DRYCASE) AND THE +C 'SATURATED LIQUID' SOLUTION (SUBROUTINE LIQCASE). (REVERSE PROBLEM) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C +C======================================================================= +C + SUBROUTINE CALCMDRP (RHI, RHDRY, RHLIQ, DRYCASE, LIQCASE) + INCLUDE 'isrpia_adj.inc' + EXTERNAL DRYCASE, LIQCASE +C +C *** FIND WEIGHT FACTOR ********************************************** +C + IF (WFTYP.EQ.0) THEN + WF = ONE + ELSEIF (WFTYP.EQ.1) THEN + WF = 0.5D0 + ELSE + WF = (RHLIQ-RHI)/(RHLIQ-RHDRY) + ENDIF + ONEMWF = ONE - WF +C +C *** FIND FIRST SECTION ; DRY ONE ************************************ +C + CALL DRYCASE + IF (ABS(ONEMWF).LE.1D-5) GOTO 200 ! DRY AEROSOL +C + CNH42SO = CNH42S4 ! FIRST (DRY) SOLUTION + CNH4HSO = CNH4HS4 + CLCO = CLC + CNH4N3O = CNH4NO3 + CNH4CLO = CNH4CL + CNA2SO = CNA2SO4 + CNAHSO = CNAHSO4 + CNANO = CNANO3 + CNACLO = CNACL +C +C *** FIND SECOND SECTION ; DRY & LIQUID ****************************** +C + CNH42S4 = ZERO + CNH4HS4 = ZERO + CLC = ZERO + CNH4NO3 = ZERO + CNH4CL = ZERO + CNA2SO4 = ZERO + CNAHSO4 = ZERO + CNANO3 = ZERO + CNACL = ZERO + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO + CALL LIQCASE ! SECOND (LIQUID) SOLUTION +C +C *** ADJUST THINGS FOR THE CASE THAT THE LIQUID SUB PREDICTS DRY AEROSOL +C + IF (WATER.LE.TINY) THEN + WATER = ZERO + DO 100 I=1,NIONS + MOLAL(I)= ZERO + 100 CONTINUE + CALL DRYCASE + GOTO 200 + ENDIF +C +C *** FIND SALT DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS. +C + DAMBIS = CNH4HSO - CNH4HS4 + DSOBIS = CNAHSO - CNAHSO4 + DLC = CLCO - CLC +C +C *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS. +C +C *** SOLID +C + CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4 + CNA2SO4 = WF*CNA2SO + ONEMWF*CNA2SO4 + CNAHSO4 = WF*CNAHSO + ONEMWF*CNAHSO4 + CNH4HS4 = WF*CNH4HSO + ONEMWF*CNH4HS4 + CLC = WF*CLCO + ONEMWF*CLC + CNH4NO3 = WF*CNH4N3O + ONEMWF*CNH4NO3 + CNANO3 = WF*CNANO + ONEMWF*CNANO3 + CNACL = WF*CNACLO + ONEMWF*CNACL + CNH4CL = WF*CNH4CLO + ONEMWF*CNH4CL +C +C *** LIQUID +C + WATER = ONEMWF*WATER +C + MOLAL(2)= WAER(1) - 2.D0*CNA2SO4 - CNAHSO4 - CNANO3 - + & CNACL ! NA+ + MOLAL(3)= WAER(3) - 2.D0*CNH42S4 - CNH4HS4 - CNH4CL - + & 3.D0*CLC - CNH4NO3 ! NH4+ + MOLAL(4)= WAER(5) - CNACL - CNH4CL ! CL- + MOLAL(7)= WAER(4) - CNANO3 - CNH4NO3 ! NO3- + MOLAL(6)= ONEMWF*(MOLAL(6) + DSOBIS + DAMBIS + DLC) ! HSO4- + MOLAL(5)= WAER(2) - MOLAL(6) - CLC - CNH42S4 - CNA2SO4 ! SO4-- +C + A8 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. + IF (MOLAL(5).LE.TINY) THEN + HIEQ = SQRT(XKW *RH*WATER*WATER) ! Neutral solution + ELSE + HIEQ = A8*MOLAL(6)/MOLAL(5) + ENDIF + HIEN = MOLAL(4) + MOLAL(7) + MOLAL(6) + 2.D0*MOLAL(5) - + & MOLAL(2) - MOLAL(3) + MOLAL(1)= MAX (HIEQ, HIEN) ! H+ +C +C *** GAS (ACTIVITY COEFS FROM LIQUID SOLUTION) +C + A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +C + GNH3 = MOLAL(3)/MAX(MOLAL(1),TINY)/A2 + GHNO3 = MOLAL(1)*MOLAL(7)/A3 + GHCL = MOLAL(1)*MOLAL(4)/A4 +C +200 RETURN +C +C *** END OF SUBROUTINE CALCMDRP **************************************** +C + END +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCMDRPII +C +C THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL +C DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED +C SOLUTIONS ; THE 'DRY' SOLUTION (SUBROUTINE DRYCASE) AND THE +C 'SATURATED LIQUID' SOLUTION (SUBROUTINE LIQCASE). (REVERSE PROBLEM) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C +C======================================================================= +C + SUBROUTINE CALCMDRPII (RHI, RHDRY, RHLIQ, DRYCASE, LIQCASE) + INCLUDE 'isrpia_adj.inc' + EXTERNAL DRYCASE, LIQCASE +C +C *** FIND WEIGHT FACTOR ********************************************** +C + IF (WFTYP.EQ.0) THEN + WF = ONE + ELSEIF (WFTYP.EQ.1) THEN + WF = 0.5D0 + ELSE + WF = (RHLIQ-RHI)/(RHLIQ-RHDRY) + ENDIF + ONEMWF = ONE - WF +C +C *** FIND FIRST SECTION ; DRY ONE ************************************ +C + CALL DRYCASE + IF (ABS(ONEMWF).LE.1D-5) GOTO 200 ! DRY AEROSOL +C + CNH42SO = CNH42S4 ! FIRST (DRY) SOLUTION + CNH4HSO = CNH4HS4 + CLCO = CLC + CNH4N3O = CNH4NO3 + CNH4CLO = CNH4CL + CNA2SO = CNA2SO4 + CNAHSO = CNAHSO4 + CNANO = CNANO3 + CNACLO = CNACL +C + CCASO = CCASO4 + CK2SO = CK2SO4 + CMGSO = CMGSO4 + CKHSO = CKHSO4 + CCAN32O = CCANO32 + CCAC2L = CCACL2 + CKN3O = CKNO3 + CKCLO = CKCL + CMGN32O = CMGNO32 + CMGC2L = CMGCL2 +C +C *** FIND SECOND SECTION ; DRY & LIQUID ****************************** +C + CNH42S4 = ZERO + CNH4HS4 = ZERO + CLC = ZERO + CNH4NO3 = ZERO + CNH4CL = ZERO + CNA2SO4 = ZERO + CNAHSO4 = ZERO + CNANO3 = ZERO + CNACL = ZERO + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO +C + CCASO4 = ZERO + CK2SO4 = ZERO + CMGSO4 = ZERO + CKHSO4 = ZERO + CCANO32 = ZERO + CCACL2 = ZERO + CKNO3 = ZERO + CKCL = ZERO + CMGNO32 = ZERO + CMGCL2 = ZERO +C + CALL LIQCASE ! SECOND (LIQUID) SOLUTION +C +C *** ADJUST THINGS FOR THE CASE THAT THE LIQUID SUB PREDICTS DRY AEROSOL +C + IF (WATER.LE.TINY) THEN + WATER = ZERO + DO 100 I=1,NIONS + MOLAL(I)= ZERO + 100 CONTINUE + CALL DRYCASE + GOTO 200 + ENDIF +C +C *** FIND SALT DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS. +C + DAMBIS = CNH4HSO - CNH4HS4 + DSOBIS = CNAHSO - CNAHSO4 + DLC = CLCO - CLC + DPOBIS = CKHSO - CKHSO4 +C +C *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS. +C +C *** SOLID +C + CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4 + CNA2SO4 = WF*CNA2SO + ONEMWF*CNA2SO4 + CNAHSO4 = WF*CNAHSO + ONEMWF*CNAHSO4 + CNH4HS4 = WF*CNH4HSO + ONEMWF*CNH4HS4 + CLC = WF*CLCO + ONEMWF*CLC + CNH4NO3 = WF*CNH4N3O + ONEMWF*CNH4NO3 + CNANO3 = WF*CNANO + ONEMWF*CNANO3 + CNACL = WF*CNACLO + ONEMWF*CNACL + CNH4CL = WF*CNH4CLO + ONEMWF*CNH4CL +C + CCASO4 = WF*CCASO + ONEMWF*CCASO4 + CK2SO4 = WF*CK2SO + ONEMWF*CK2SO4 + CMGSO4 = WF*CMGSO + ONEMWF*CMGSO4 + CKHSO4 = WF*CKHSO + ONEMWF*CKHSO4 + CCANO32 = WF*CCAN32O + ONEMWF*CCANO32 + CCACL2 = WF*CCAC2L + ONEMWF*CCACL2 + CMGNO32 = WF*CMGN32O + ONEMWF*CMGNO32 + CMGCL2 = WF*CMGC2L + ONEMWF*CMGCL2 + CKCL = WF*CKCLO + ONEMWF*CKCL +C +C *** LIQUID +C + WATER = ONEMWF*WATER +C + MOLAL(2)= WAER(1) - 2.D0*CNA2SO4 - CNAHSO4 - CNANO3 - + & CNACL ! NA+ + MOLAL(3)= WAER(3) - 2.D0*CNH42S4 - CNH4HS4 - CNH4CL - + & 3.D0*CLC - CNH4NO3 ! NH4+ + MOLAL(4)= WAER(5) - CNACL - CNH4CL - 2.D0*CCACL2 - + & 2.D0*CMGCL2 - CKCL ! CL- + MOLAL(7)= WAER(4) - CNANO3 - CNH4NO3 - CKNO3 + & - 2.D0*CCANO32 - 2.D0*CMGNO32 ! NO3- + MOLAL(6)= ONEMWF*(MOLAL(6) + DSOBIS + DAMBIS + DLC + DPOBIS) ! HSO4- + MOLAL(5)= WAER(2) - MOLAL(6) - CLC - CNH42S4 - CNA2SO4 + & - CCASO4 - CK2SO4 - CMGSO4 ! SO4-- + MOLAL(8)= WAER(6) - CCASO4 - CCANO32 - CCACL2 ! CA++ + MOLAL(9)= WAER(7) - 2.D0*CK2SO4 - CKNO3 - CKCL - CKHSO4 ! K+ + MOLAL(10)=WAER(8) - CMGSO4 - CMGNO32 - CMGCL2 ! MG++ +C + A8 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. + IF (MOLAL(5).LE.TINY) THEN + HIEQ = SQRT(XKW *RH*WATER*WATER) ! Neutral solution + ELSE + HIEQ = A8*MOLAL(6)/MOLAL(5) + ENDIF + HIEN = MOLAL(4) + MOLAL(7) + MOLAL(6) + 2.D0*MOLAL(5) - + & MOLAL(2) - MOLAL(3) + MOLAL(1)= MAX (HIEQ, HIEN) ! H+ +C +C *** GAS (ACTIVITY COEFS FROM LIQUID SOLUTION) +C + A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +C + GNH3 = MOLAL(3)/MAX(MOLAL(1),TINY)/A2 + GHNO3 = MOLAL(1)*MOLAL(7)/A3 + GHCL = MOLAL(1)*MOLAL(4)/A4 +C +200 RETURN +C +C *** END OF SUBROUTINE CALCMDRPII ************************************** +C + END +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCHS4 +C *** THIS SUBROUTINE CALCULATES THE HSO4 GENERATED FROM (H,SO4). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCHS4 (HI, SO4I, HSO4I, DELTA) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: HI, SO4I, HSO4I, DELTA, BB, CC, DD, SQDD, DELTA1, + & DELTA2 +CC CHARACTER(LEN=40) errinf +C +C *** IF TOO LITTLE WATER, DONT SOLVE +C + IF ((WATER) <= 1d1*TINY) THEN + DELTA = ZERO + RETURN + ENDIF +C +C *** CALCULATE HSO4 SPECIATION ***************************************** +C + A8 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.d0 +C + BB =-(HI + SO4I + A8) + CC = HI*SO4I - HSO4I*A8 + DD = BB*BB - 4.D0*CC +C + IF ((DD) >= ZERO) THEN + SQDD = SQRT(DD) + DELTA1 = 0.5d0*(-BB + SQDD) + DELTA2 = 0.5d0*(-BB - SQDD) + IF ((HSO4I) <= TINY) THEN + DELTA = DELTA2 + ELSEIF( (HI*SO4I) >= (A8*HSO4I) ) THEN + DELTA = DELTA2 + ELSEIF( (HI*SO4I) < (A8*HSO4I) ) THEN + DELTA = DELTA1 + ELSE + DELTA = ZERO + ENDIF + ELSE + DELTA = ZERO + ENDIF + + ! PHFIX applied by Havala (just a quick fix, not a final solution) + ! make sure H+ is positive (hotp 8/19/09) + ! Negative H+ was due to subtracting two similar, small numbers + ! for a set of test conditions examined + !IF ( DELTA > HI ) DELTA = HI - 1d-30 + +CCC +CCC *** COMPARE DELTA TO TOTAL H+ ; ESTIMATE EFFECT OF HSO4 *************** +CCC +CC HYD = MAX(HI, MOLAL(1)) +CC IF (HYD > TINY) THEN +CC IF (DELTA/HYD > 0.1d0) THEN +CC WRITE (ERRINF,'(1PE10.3)') DELTA/HYD*100.0 +CC CALL PUSHERR (0020, ERRINF) +CC ENDIF +CC ENDIF +C + RETURN +C +C *** END OF SUBROUTINE CALCHS4 ***************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCPH +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCPH (GG, HI, OHI) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: CN, GG, HI, OHI, BB, CC, DD +C + AKW = XKW *RH*WATER*WATER + CN = SQRT(AKW) +C +C *** GG = (negative charge) - (positive charge) +C + IF ((GG) > TINY) THEN ! H+ in excess + BB =-GG + CC =-AKW + DD = BB*BB - 4.D0*CC + HI = MAX(0.5D0*(-BB + SQRT(DD)),CN) + OHI= AKW/HI + ELSE ! OH- in excess + BB = GG + CC =-AKW + DD = BB*BB - 4.D0*CC + OHI= MAX(0.5D0*(-BB + SQRT(DD)),CN) + HI = AKW/OHI + ENDIF +C + RETURN +C +C *** END OF SUBROUTINE CALCPH ****************************************** +C + END + +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE RSTGAM +C *** RESETS ACTIVITY COEFFICIENT ARRAYS TO DEFAULT VALUE OF 0.1 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE RSTGAM + INCLUDE 'isrpia_adj.inc' +C + DO I=1, NPAIR + GAMA(I) = 0.1D0 + ENDDO +C +C *** END OF SUBROUTINE RSTGAM ****************************************** +C + RETURN + END +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE RSTGAMP +C *** RESETS ACTIVITY COEFFICIENT ARRAYS TO DEFAULT VALUE OF 0.1 IF +C *** GREATER THAN THE THRESHOLD VALUE. +C +C ANISORROPIA ROUTINE. (slc.8.2011) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE RSTGAMP + INCLUDE 'isrpia_adj.inc' + REAL*8 :: GMAX, GTHRESH + INTEGER I +C + GTHRESH = 100.D0 + GMAX = 0.1D0 + DO I=1, NPAIR + GMAX = MAX(GMAX,GAMA(I)) + ENDDO + IF ((GMAX) > (GTHRESH)) THEN + DO I = 1,NPAIR + GAMA(I) = 1.D-1 + GAMIN(I) = GREAT + GAMOU(I) = GREAT + ENDDO + CALAOU = .TRUE. + FRST = .TRUE. + ENDIF +C + END SUBROUTINE RSTGAMP +C======================================================================= +C +C *** ISORROPIA CODE II +C *** SUBROUTINE CALCACT4 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM-CALCIUM-POTASSIUM-MAGNESIUM +C AEROSOL SYSTEM. THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL4). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C +C======================================================================= +C +C SUBROUTINE CALCACT4 +C INCLUDE 'isrpia_adj.inc' +CC +C REAL EX10 +C REAL G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(6),F2A(4),F2B(4) +C REAL*8 :: MPL, XIJ, YJI +C +C ! hotp removed for parallelization (8/23/07), integer declared +C !DATA G0/24*0D0/ +C INTEGER I,J +C +CC +C GA(I,J)= (F1(I)/Z(I) + F2A(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H +C GB(I,J)= (F1(I)/Z(I+4) + F2B(J)/Z(J+3)) / (Z(I+4)+Z(J+3)) - H +C +C ! initialize G0 array here (hotp 8/23/07) +C DO J = 1, 4 +C DO I = 1, 6 +C G0(I,J) = 0.0 +C ENDDO +C ENDDO +CC +CC *** SAVE ACTIVITIES IN OLD ARRAY ************************************* +CC +C IF (FRST) THEN ! Outer loop +C DO 10 I=1,NPAIR +C GAMOU(I) = GAMA(I) +C10 CONTINUE +C ENDIF +CC +C DO 20 I=1,NPAIR ! Inner loop +C GAMIN(I) = GAMA(I) +C20 CONTINUE +CC +CC *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +CC +C IONIC=0.0 +C DO 30 I=1,NIONS +C IONIC=IONIC + MOLAL(I)*Z(I)*Z(I) +C30 CONTINUE +C IONIC = MAX(MIN(0.5*IONIC/WATER,100.d0), TINY) +CC +CC *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +CC +CC G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +CC G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +CC +C IF (IACALC.EQ.0) THEN ! K.M.; FULL +C CALL KMFUL4 (IONIC, SNGL(TEMP),G0(2,1),G0(2,2),G0(2,4), +C & G0(3,2),G0(3,4),G0(3,1),G0(1,2),G0(1,3),G0(3,3), +C & G0(1,4),G0(1,1),G0(2,3),G0(4,4),G0(4,1),G0(5,2), +C & G0(5,3),G0(5,4),G0(5,1),G0(6,2),G0(6,4),G0(6,1)) +C ELSE ! K.M.; TABULATED +C CALL KMTAB (IONIC, SNGL(TEMP),G0(2,1),G0(2,2),G0(2,4), +C & G0(3,2),G0(3,4),G0(3,1),G0(1,2),G0(1,3),G0(3,3), +C & G0(1,4),G0(1,1),G0(2,3),G0(4,4),G0(4,1),G0(5,2), +C & G0(5,3),G0(5,4),G0(5,1),G0(6,2),G0(6,4),G0(6,1)) +C ENDIF +CC +CC *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +CC +C AGAMA = 0.511*(298.0/TEMP)**1.5 ! Debye Huckel const. at T +C SION = SQRT(IONIC) +C H = AGAMA*SION/(1+SION) +CC +C DO 100 I=1,4 +C F1(I)=0.0 +C F2A(I)=0.0 +C F2B(I)=0.0 +C100 CONTINUE +C F1(5)=0.0 +C F1(6)=0.0 +CC +C DO 110 I=1,3 +C ZPL = Z(I) +C MPL = MOLAL(I)/WATER +C DO 110 J=1,4 +C ZMI = Z(J+3) +C CH = 0.25*(ZPL+ZMI)*(ZPL+ZMI)/IONIC +C XIJ = CH*MPL +C YJI = CH*MOLAL(J+3)/WATER +C F1(I) = F1(I) + SNGL(YJI*(G0(I,J) + ZPL*ZMI*H)) +C F2A(J) = F2A(J) + SNGL(XIJ*(G0(I,J) + ZPL*ZMI*H)) +C110 CONTINUE +CC +C DO 330 I=4,6 +C ZPL = Z(I+4) +C MPL = MOLAL(I+4)/WATER +C DO 330 J=1,4 +C ZMI = Z(J+3) +C IF (J.EQ.3) THEN +C IF (I.EQ.4 .OR. I.EQ.6) THEN +C GO TO 330 +C ENDIF +C ENDIF +C CH = 0.25*(ZPL+ZMI)*(ZPL+ZMI)/IONIC +C XIJ = CH*MPL +C YJI = CH*MOLAL(J+3)/WATER +C F1(I) = F1(I) + SNGL(YJI*(G0(I,J) + ZPL*ZMI*H)) +C F2B(J) = F2B(J) + SNGL(XIJ*(G0(I,J) + ZPL*ZMI*H)) +C330 CONTINUE +C +CC +CC *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +CC +C GAMA(01) = GA(2,1)*ZZ(01) ! NACL +C GAMA(02) = GA(2,2)*ZZ(02) ! NA2SO4 +C GAMA(03) = GA(2,4)*ZZ(03) ! NANO3 +C GAMA(04) = GA(3,2)*ZZ(04) ! (NH4)2SO4 +C GAMA(05) = GA(3,4)*ZZ(05) ! NH4NO3 +C GAMA(06) = GA(3,1)*ZZ(06) ! NH4CL +C GAMA(07) = GA(1,2)*ZZ(07) ! 2H-SO4 +C GAMA(08) = GA(1,3)*ZZ(08) ! H-HSO4 +C GAMA(09) = GA(3,3)*ZZ(09) ! NH4HSO4 +C GAMA(10) = GA(1,4)*ZZ(10) ! HNO3 +C GAMA(11) = GA(1,1)*ZZ(11) ! HCL +C GAMA(12) = GA(2,3)*ZZ(12) ! NAHSO4 +C GAMA(13) = 0.20*(3.0*GAMA(04)+2.0*GAMA(09)) ! LC ; SCAPE +CCC GAMA(13) = 0.50*(GAMA(04)+GAMA(09)) ! LC ; SEQUILIB +CCC GAMA(13) = 0.25*(3.0*GAMA(04)+GAMA(07)) ! LC ; AIM +C GAMA(14) = 0.0d0 ! CASO4 +C GAMA(15) = GB(4,4)*ZZ(15) ! CA(NO3)2 +C GAMA(16) = GB(4,1)*ZZ(16) ! CACL2 +C GAMA(17) = GB(5,2)*ZZ(17) ! K2SO4 +C GAMA(18) = GB(5,3)*ZZ(18) ! KHSO4 +C GAMA(19) = GB(5,4)*ZZ(19) ! KNO3 +C GAMA(20) = GB(5,1)*ZZ(20) ! KCL +C GAMA(21) = GB(6,2)*ZZ(21) ! MGSO4 +C GAMA(22) = GB(6,4)*ZZ(22) ! MG(NO3)2 +C GAMA(23) = GB(6,1)*ZZ(23) ! MGCL2 +CC +CC *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +CC +C DO 200 I=1,NPAIR +C GAMA(I)=MAX(-5.0d0, MIN(GAMA(I),5.0d0) ) ! F77 LIBRARY ROUTINE +C GAMA(I)=10.0**GAMA(I) +CCC GAMA(I)=EX10(SNGL(GAMA(I)), 5.0) ! CUTOFF SET TO [-5,5] +C 200 CONTINUE +CC +CC *** SETUP ACTIVITY CALCULATION FLAGS ******************************** +CC +CC OUTER CALCULATION LOOP ; ONLY IF FRST=.TRUE. +CC +C IF (FRST) THEN +C ERROU = ZERO ! CONVERGENCE CRITERION +C DO 210 I=1,NPAIR +C ERROU=MAX(ERROU, ABS((GAMOU(I)-GAMA(I))/GAMOU(I))) +C210 CONTINUE +C CALAOU = ERROU .GE. EPSACT ! SETUP FLAGS +C FRST =.FALSE. +C ENDIF +CC +CC INNER CALCULATION LOOP ; ALWAYS +CC +C ERRIN = ZERO ! CONVERGENCE CRITERION +C DO 220 I=1,NPAIR +C ERRIN = MAX (ERRIN, ABS((GAMIN(I)-GAMA(I))/GAMIN(I))) +C220 CONTINUE +C CALAIN = ERRIN .GE. EPSACT +CC +C ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter +CC +CC *** END OF SUBROUTINE ACTIVITY **************************************** +CC +C RETURN +C END +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3 + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(3),F2(4) + REAL*8 :: MPL, XIJ, YJI, CHECK + CHARACTER(LEN=40) :: errinf +C +C +C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H +C +C *** SAVE ACTIVITIES IN OLD ARRAY ************************************* +C + IF (FRST) THEN ! Outer loop + GAMOU = GAMA + ENDIF +C + GAMIN = GAMA +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + IONIC=0.D0 + DO I=1,7 + IONIC=IONIC + MOLAL(I)*Z(I)*Z(I) + ENDDO + CHECK = 0.5d0*IONIC/WATER + IF (CHECK > 200.d0) THEN +C WRITE(*,*) 'Threshold exceeded in CALCACT: WATER',water,'IONIc' +C & ,IONIC + WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')' + CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD + ELSEIF (CHECK < TINY) THEN + WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')' + CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD + ENDIF + IONIC = MAX(MIN(0.5D0*IONIC/WATER,200.d0), TINY) +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3 (IONIC, TEMP,G01,G02,G03, + & G04,G05,G06,G07,G08,G09, + & G10,G11,G12) +C + G0(1,1)=G11 + G0(1,2)=G07 + G0(1,3)=G08 + G0(1,4)=G10 + G0(2,1)=G01 + G0(2,2)=G02 + G0(2,3)=G12 + G0(2,4)=G03 + G0(3,1)=G06 + G0(3,2)=G04 + G0(3,3)=G09 + G0(3,4)=G05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C + AGAMA = 0.511D0*(298.D0/TEMP)**1.5D0 ! Debye Huckel const. at T + SION = SQRT(IONIC) + H = AGAMA*SION/(1.D0+SION) + +C + DO I=1,3 + F1(I)=0.D0 + F2(I)=0.D0 + ENDDO + F2(4)=0.D0 +C + DO I=1,3 + ZPL = Z(I) + MPL = MOLAL(I)/WATER + DO J=1,4 + ZMI = Z(J+3) + CH = 0.25D0*(ZPL+ZMI)*(ZPL+ZMI)/IONIC + XIJ = CH*MPL + YJI = CH*MOLAL(J+3)/WATER + F1(I) = F1(I) + (YJI*(G0(I,J) + ZPL*ZMI*H)) + F2(J) = F2(J) + (XIJ*(G0(I,J) + ZPL*ZMI*H)) + ENDDO + ENDDO +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL + GAMA(01) = ((F1(2)/Z(2) + F2(1)/Z(4)) / (Z(2)+Z(4)) - H)*ZZ(01) ! NACL +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 + GAMA(02) = ((F1(2)/Z(2) + F2(2)/Z(5)) / (Z(2)+Z(5)) - H)*ZZ(02) ! NA2SO4 +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 + GAMA(03) = ((F1(2)/Z(2) + F2(4)/Z(7)) / (Z(2)+Z(7)) - H)*ZZ(03) ! NANO3 +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 + GAMA(04) = ((F1(3)/Z(3) + F2(2)/Z(5)) / (Z(3)+Z(5)) - H)*ZZ(04) ! (NH4)2SO4 +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 + GAMA(05) = ((F1(3)/Z(3) + F2(4)/Z(7)) / (Z(3)+Z(7)) - H)*ZZ(05) ! NH4NO3 +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL + GAMA(06) = ((F1(3)/Z(3) + F2(1)/Z(4)) / (Z(3)+Z(4)) - H)*ZZ(06) ! NH4CL +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 + GAMA(07) = ((F1(1)/Z(1) + F2(2)/Z(5)) / (Z(1)+Z(5)) - H)*ZZ(07) ! 2H-SO4 +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 + GAMA(08) = ((F1(1)/Z(1) + F2(3)/Z(6)) / (Z(1)+Z(6)) - H)*ZZ(08) ! H-HSO4 +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 + GAMA(09) = ((F1(3)/Z(3) + F2(3)/Z(6)) / (Z(3)+Z(6)) - H)*ZZ(09) ! NH4HSO4 +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 + GAMA(10) = ((F1(1)/Z(1) + F2(4)/Z(7)) / (Z(1)+Z(7)) - H)*ZZ(10) ! HNO3 +C GAMA(11) = G(1,1)*ZZ(11) ! HCL + GAMA(11) = ((F1(1)/Z(1) + F2(1)/Z(4)) / (Z(1)+Z(4)) - H)*ZZ(11) ! HCL +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 + GAMA(12) = ((F1(2)/Z(2) + F2(3)/Z(6)) / (Z(2)+Z(6)) - H)*ZZ(12) ! NAHSO4 + GAMA(13) = 0.2D0*(3.D0*GAMA(04)+2.D0*GAMA(09)) ! LC ; SCAPE +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO I=1,13 + GAMA(I)=MAX(MIN(GAMA(I),5.0d0), -5.0d0) ! F77 LIBRARY ROUTINE + GAMA(I)=10.D0**GAMA(I) + ENDDO +C +C *** SETUP ACTIVITY CALCULATION FLAGS ********************************* +C +C OUTER CALCULATION LOOP ; ONLY IF FRST=.TRUE. +C + IF (FRST) THEN + ERROU = ZERO ! CONVERGENCE CRITERION + DO I=1,13 + ERROU=MAX(ERROU, ((GAMOU(I)-GAMA(I))/GAMOU(I))) + ENDDO + CALAOU = (ERROU) >= (EPSACT) ! SETUP FLAGS + FRST =.FALSE. + ENDIF +C +C INNER CALCULATION LOOP ; ALWAYS +C + ERRIN = ZERO ! CONVERGENCE CRITERION + DO I=1,13 + ERRIN = MAX(ERRIN, ABS((GAMIN(I)-GAMA(I))/GAMIN(I))) + ENDDO + CALAIN = (ERRIN) >= (EPSACT) +C + ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter +C +C *** END OF SUBROUTINE ACTIVITY **************************************** +C + RETURN + END +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3P +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C ANISORROPIA ROUTINE. (slc.8.2011) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3P + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(3),F2(4) + REAL*8 :: MPL, XIJ, YJI, CHECK + CHARACTER(LEN=40) errinf +C +C +C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + IONIC=0.D0 + DO I=1,7 + IONIC=IONIC + MOLAL(I)*Z(I)*Z(I) + ENDDO + CHECK = 0.5d0*IONIC/WATER + IF (CHECK > 200.d0) THEN +C WRITE(*,*) 'Threshold exceeded in CALCACT: WATER',water,'IONIc' +C & ,IONIC + WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')' + CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD + ELSEIF (CHECK < TINY) THEN + WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')' + CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD + ENDIF + IONIC = MAX(MIN(0.5D0*IONIC/WATER,200.d0), TINY) +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3 (IONIC, TEMP,G01,G02,G03, + & G04,G05,G06,G07,G08,G09, + & G10,G11,G12) +C + G0(1,1)=G11 + G0(1,2)=G07 + G0(1,3)=G08 + G0(1,4)=G10 + G0(2,1)=G01 + G0(2,2)=G02 + G0(2,3)=G12 + G0(2,4)=G03 + G0(3,1)=G06 + G0(3,2)=G04 + G0(3,3)=G09 + G0(3,4)=G05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C + AGAMA = 0.511D0*(298.D0/TEMP)**1.5D0 ! Debye Huckel const. at T + SION = SQRT(IONIC) + H = AGAMA*SION/(1.D0+SION) +C + DO I=1,3 + F1(I)=0.D0 + F2(I)=0.D0 + ENDDO + F2(4)=0.D0 +C + DO I=1,3 + ZPL = Z(I) + MPL = MOLAL(I)/WATER + DO J=1,4 + ZMI = Z(J+3) + CH = 0.25D0*(ZPL+ZMI)*(ZPL+ZMI)/IONIC + XIJ = CH*MPL + YJI = CH*MOLAL(J+3)/WATER + F1(I) = F1(I) + (YJI*(G0(I,J) + ZPL*ZMI*H)) + F2(J) = F2(J) + (XIJ*(G0(I,J) + ZPL*ZMI*H)) + ENDDO + ENDDO +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL + GAMA(01) = ((F1(2)/Z(2) + F2(1)/Z(4)) / (Z(2)+Z(4)) - H)*ZZ(01) ! NACL +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 + GAMA(02) = ((F1(2)/Z(2) + F2(2)/Z(5)) / (Z(2)+Z(5)) - H)*ZZ(02) ! NA2SO4 +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 + GAMA(03) = ((F1(2)/Z(2) + F2(4)/Z(7)) / (Z(2)+Z(7)) - H)*ZZ(03) ! NANO3 +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 + GAMA(04) = ((F1(3)/Z(3) + F2(2)/Z(5)) / (Z(3)+Z(5)) - H)*ZZ(04) ! (NH4)2SO4 +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 + GAMA(05) = ((F1(3)/Z(3) + F2(4)/Z(7)) / (Z(3)+Z(7)) - H)*ZZ(05) ! NH4NO3 +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL + GAMA(06) = ((F1(3)/Z(3) + F2(1)/Z(4)) / (Z(3)+Z(4)) - H)*ZZ(06) ! NH4CL +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 + GAMA(07) = ((F1(1)/Z(1) + F2(2)/Z(5)) / (Z(1)+Z(5)) - H)*ZZ(07) ! 2H-SO4 +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 + GAMA(08) = ((F1(1)/Z(1) + F2(3)/Z(6)) / (Z(1)+Z(6)) - H)*ZZ(08) ! H-HSO4 +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 + GAMA(09) = ((F1(3)/Z(3) + F2(3)/Z(6)) / (Z(3)+Z(6)) - H)*ZZ(09) ! NH4HSO4 +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 + GAMA(10) = ((F1(1)/Z(1) + F2(4)/Z(7)) / (Z(1)+Z(7)) - H)*ZZ(10) ! HNO3 +C GAMA(11) = G(1,1)*ZZ(11) ! HCL + GAMA(11) = ((F1(1)/Z(1) + F2(1)/Z(4)) / (Z(1)+Z(4)) - H)*ZZ(11) ! HCL +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 + GAMA(12) = ((F1(2)/Z(2) + F2(3)/Z(6)) / (Z(2)+Z(6)) - H)*ZZ(12) ! NAHSO4 + GAMA(13) = 0.2D0*(3.D0*GAMA(04)+2.D0*GAMA(09)) ! LC ; SCAPE +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO I=1,13 + GAMA(I)=MAX(MIN(GAMA(I),5.0d0), -5.0d0) ! F77 LIBRARY ROUTINE + GAMA(I)=10.D0**GAMA(I) + ENDDO +C + ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter +C +C *** END OF SUBROUTINE ACTIVITY **************************************** +C + RETURN + END +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3F +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C +C======================================================================= +C + SUBROUTINE CALCACT3F + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(3),F2(4) + REAL*8 :: MPL, XIJ, YJI, CHECK + CHARACTER(LEN=40) errinf +C +C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + IONIC=0.D0 + DO I=1,7 + IONIC=IONIC + MOLAL(I)*Z(I)*Z(I) + ENDDO + CHECK = 0.5d0*IONIC/WATER + IF (CHECK .GT. 200.d0) THEN +C WRITE(*,*) 'Threshold exceeded in CALCACT: WATER',water,'IONIc' +C & ,IONIC + WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')' +C * slc.debug +C WRITE(*,*) '102,ACT3F,',CHECK +C WRITE(*,*) 'Water: ',WATER ,', IONIC: ',IONIC +C WRITE(*,*) 'W: ',W +C WRITE(*,*) 'RH: ',RH, ', TEMP:',TEMP + CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD + ELSEIF (CHECK .LT. TINY) THEN + WRITE(ERRINF, '(A,E12.5,A)') 'CALCACT (',CHECK,')' +C * slc.debug +C WRITE(*,*) '102,ACT3F,',CHECK +C WRITE(*,*) 'Water: ',WATER ,', IONIC: ',IONIC +C WRITE(*,*) 'W: ',W +C WRITE(*,*) 'RH: ',RH, ', TEMP:',TEMP + CALL PUSHERR (0102, ERRINF) ! WARNING ERROR: EXCEED IONIC THRESHOLD + ENDIF + IONIC = MAX(MIN(0.5D0*IONIC/WATER,200.d0), TINY) +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3 (IONIC, TEMP,G01,G02,G03, + & G04,G05,G06,G07,G08,G09, + & G10,G11,G12) +C + G0(1,1)=G11 + G0(1,2)=G07 + G0(1,3)=G08 + G0(1,4)=G10 + G0(2,1)=G01 + G0(2,2)=G02 + G0(2,3)=G12 + G0(2,4)=G03 + G0(3,1)=G06 + G0(3,2)=G04 + G0(3,3)=G09 + G0(3,4)=G05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C + AGAMA = 0.511D0*(298.D0/TEMP)**1.5D0 ! Debye Huckel const. at T + SION = SQRT(IONIC) + H = AGAMA*SION/(1.D0+SION) +C + DO I=1,3 + F1(I)=0.D0 + F2(I)=0.D0 + ENDDO + F2(4)=0.D0 +C + DO I=1,3 + ZPL = Z(I) + MPL = MOLAL(I)/WATER + DO J=1,4 + ZMI = Z(J+3) + CH = 0.25D0*(ZPL+ZMI)*(ZPL+ZMI)/IONIC + XIJ = CH*MPL + YJI = CH*MOLAL(J+3)/WATER + F1(I) = F1(I) + (YJI*(G0(I,J) + ZPL*ZMI*H)) + F2(J) = F2(J) + (XIJ*(G0(I,J) + ZPL*ZMI*H)) + ENDDO + ENDDO +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL + GAMA(01) = ((F1(2)/Z(2) + F2(1)/Z(4)) / (Z(2)+Z(4)) - H)*ZZ(01) ! NACL +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 + GAMA(02) = ((F1(2)/Z(2) + F2(2)/Z(5)) / (Z(2)+Z(5)) - H)*ZZ(02) ! NA2SO4 +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 + GAMA(03) = ((F1(2)/Z(2) + F2(4)/Z(7)) / (Z(2)+Z(7)) - H)*ZZ(03) ! NANO3 +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 + GAMA(04) = ((F1(3)/Z(3) + F2(2)/Z(5)) / (Z(3)+Z(5)) - H)*ZZ(04) ! (NH4)2SO4 +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 + GAMA(05) = ((F1(3)/Z(3) + F2(4)/Z(7)) / (Z(3)+Z(7)) - H)*ZZ(05) ! NH4NO3 +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL + GAMA(06) = ((F1(3)/Z(3) + F2(1)/Z(4)) / (Z(3)+Z(4)) - H)*ZZ(06) ! NH4CL +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 + GAMA(07) = ((F1(1)/Z(1) + F2(2)/Z(5)) / (Z(1)+Z(5)) - H)*ZZ(07) ! 2H-SO4 +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 + GAMA(08) = ((F1(1)/Z(1) + F2(3)/Z(6)) / (Z(1)+Z(6)) - H)*ZZ(08) ! H-HSO4 +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 + GAMA(09) = ((F1(3)/Z(3) + F2(3)/Z(6)) / (Z(3)+Z(6)) - H)*ZZ(09) ! NH4HSO4 +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 + GAMA(10) = ((F1(1)/Z(1) + F2(4)/Z(7)) / (Z(1)+Z(7)) - H)*ZZ(10) ! HNO3 +C GAMA(11) = G(1,1)*ZZ(11) ! HCL + GAMA(11) = ((F1(1)/Z(1) + F2(1)/Z(4)) / (Z(1)+Z(4)) - H)*ZZ(11) ! HCL +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 + GAMA(12) = ((F1(2)/Z(2) + F2(3)/Z(6)) / (Z(2)+Z(6)) - H)*ZZ(12) ! NAHSO4 + GAMA(13) = 0.2D0*(3.D0*GAMA(04)+2.D0*GAMA(09)) ! LC ; SCAPE +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO I=1,13 + GAMA(I)=MAX(MIN(GAMA(I),5.0d0), -5.0d0) ! F77 LIBRARY ROUTINE + GAMA(I)=10.D0**GAMA(I) + ENDDO +C + ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter +C +C *** END OF SUBROUTINE ACTIVITY **************************************** +C + RETURN + END +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT2 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL2). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C +C SUBROUTINE CALCACT2 +C INCLUDE 'isrpia_adj.inc' +CC +C REAL*8 :: G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(3),F2(4) +C REAL*8 :: MPL, XIJ, YJI +CC +C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H +CC +CC *** SAVE ACTIVITIES IN OLD ARRAY ************************************* +CC +C IF (FRST) THEN ! Outer loop +C DO I=7,10 +C GAMOU(I) = GAMA(I) +C ENDDO +C GAMOU(4) = GAMA(4) +C GAMOU(5) = GAMA(5) +C GAMOU(13) = GAMA(13) +C ENDIF +CC +C DO I=7,10 ! Inner loop +C GAMIN(I) = GAMA(I) +C ENDDO +C GAMIN(4) = GAMA(4) +C GAMIN(5) = GAMA(5) +C GAMIN(13) = GAMA(13) +CC +CC *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +CC +C IONIC=0.D0 +C MOLAL(2) = ZERO +C MOLAL(4) = ZERO +C DO I=1,7 +C IONIC=IONIC + MOLAL(I)*Z(I)*Z(I) +C ENDDO +C IONIC = MAX(MIN(0.5D0*IONIC/WATER,100.d0), TINY) +CC +CC *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +CC +CC G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +CC G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +CC +C CALL KMFUL2 (IONIC,TEMP,G0(3,2),G0(3,4),G0(1,2), +C & G0(1,3),G0(3,3),G0(1,4)) +CC +CC *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +CC +C AGAMA = 0.511D0*(298.D0/TEMP)**1.5D0 ! Debye Huckel const. at T +C SION = SQRT(IONIC) +C H = AGAMA*SION/(1.D0+SION) +CC +C DO I=1,3 +C F1(I)=0.D0 +C F2(I)=0.D0 +C ENDDO +C F2(4)=0.D0 +CC +C DO I=1,3,2 +C ZPL = Z(I) +C MPL = MOLAL(I)/WATER +C DO J=2,4 +C ZMI = Z(J+3) +C CH = 0.25D0*(ZPL+ZMI)*(ZPL+ZMI)/IONIC +C XIJ = CH*MPL +C YJI = CH*MOLAL(J+3)/WATER +C F1(I) = F1(I) + (YJI*(G0(I,J) + ZPL*ZMI*H)) +C F2(J) = F2(J) + (XIJ*(G0(I,J) + ZPL*ZMI*H)) +C ENDDO +C ENDDO +CC +CC *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +CC +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C GAMA(13) = 0.2D0*(3.D0*GAMA(04)+2.D0*GAMA(09)) ! LC ; SCAPE +CC +CC *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +CC +C DO I=7,10 +C GAMA(I)=MAX(-5.0d0, MIN(GAMA(I),5.0d0) ) ! F77 LIBRARY ROUTINE +C GAMA(I)=10.D0**GAMA(I) +C ENDDO +CC +C GAMA(4)=MAX(-5.0d0, MIN(GAMA(4),5.0d0) ) ! F77 LIBRARY ROUTINE +C GAMA(4)=10.D0**GAMA(4) +CC +C GAMA(5)=MAX(-5.0d0, MIN(GAMA(5),5.0d0) ) ! F77 LIBRARY ROUTINE +C GAMA(5)=10.D0**GAMA(5) +CC +C GAMA(13)=MAX(-5.0d0, MIN(GAMA(13),5.0d0) ) ! F77 LIBRARY ROUTINE +C GAMA(13)=10.D0**GAMA(13) +CC +CC *** SETUP ACTIVITY CALCULATION FLAGS ********************************* +CC +CC OUTER CALCULATION LOOP ; ONLY IF FRST=.TRUE. +CC +C IF (FRST) THEN +C ERROU = ZERO ! CONVERGENCE CRITERION +C DO I=7,10 +C ERROU=MAX(ERROU, ABS((GAMOU(I)-GAMA(I))/GAMOU(I))) +C ENDDO +C ERROU=MAX(ERROU, ABS((GAMOU(4)-GAMA(4))/GAMOU(4))) +C ERROU=MAX(ERROU, ABS((GAMOU(5)-GAMA(5))/GAMOU(5))) +C ERROU=MAX(ERROU, ABS((GAMOU(13)-GAMA(13))/GAMOU(13))) +CC +C CALAOU = ERROU >= EPSACT ! SETUP FLAGS +C FRST =.FALSE. +C ENDIF +CC +CC INNER CALCULATION LOOP ; ALWAYS +CC +C ERRIN = ZERO ! CONVERGENCE CRITERION +C DO I=7,10 +C ERRIN = MAX (ERRIN, ABS((GAMIN(I)-GAMA(I))/GAMIN(I))) +C ENDDO +C ERRIN = MAX (ERRIN, ABS((GAMIN(4)-GAMA(4))/GAMIN(4))) +C ERRIN = MAX (ERRIN, ABS((GAMIN(5)-GAMA(5))/GAMIN(5))) +C ERRIN = MAX (ERRIN, ABS((GAMIN(13)-GAMA(13))/GAMIN(13))) +C CALAIN = ERRIN >= EPSACT +CC +C ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter +CC +CC *** END OF SUBROUTINE ACTIVITY **************************************** +CC +C RETURN +C END +CC +CC======================================================================= +CC +CC *** ISORROPIA CODE +CC *** SUBROUTINE CALCACT1 +CC *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +CC METHOD FOR AN AMMONIUM-SULFATE AEROSOL SYSTEM. +CC THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +CC KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL1). +CC +CC *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +CC *** GEORGIA INSTITUTE OF TECHNOLOGY +CC +CC *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +CC +CC======================================================================= +CC +C SUBROUTINE CALCACT1 +C INCLUDE 'isrpia_adj.inc' +CC +C REAL*8 :: G0(6,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(3),F2(4) +C REAL*8 :: MPL, XIJ, YJI +CC +C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H +CC +CC *** SAVE ACTIVITIES IN OLD ARRAY ************************************* +CC +C IF (FRST) THEN ! Outer loop +C DO I=7,9 +C GAMOU(I) = GAMA(I) +C ENDDO +C GAMOU(4) = GAMA(4) +C GAMOU(13) = GAMA(13) +C ENDIF +CC +C DO I=7,9 ! Inner loop +C GAMIN(I) = GAMA(I) +C ENDDO +C GAMIN(4) = GAMA(4) +C GAMIN(13) = GAMA(13) +CC +CC *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +CC +C IONIC=0.D0 +C MOLAL(2) = ZERO +C MOLAL(4) = ZERO +C MOLAL(7) = ZERO +C DO I=1,7 +C IONIC=IONIC + MOLAL(I)*Z(I)*Z(I) +C ENDDO +C IONIC = MAX(MIN(0.5D0*IONIC/WATER,100.d0), TINY) +CC +CC *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +CC +CC G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +CC G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +CC +C CALL KMFUL1 (IONIC,TEMP,G0(3,2),G0(1,2), +C & G0(1,3)) +CC +CC *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +CC +C AGAMA = 0.511D0*(298.D0/TEMP)**1.5D0 ! Debye Huckel const. at T +C SION = SQRT(IONIC) +C H = AGAMA*SION/(1.D0+SION) +CC +C DO I=1,3 +C F1(I)=0.D0 +C F2(I)=0.D0 +C ENDDO +C F2(4)=0.D0 +CC +C DO I=1,3,2 +C ZPL = Z(I) +C MPL = MOLAL(I)/WATER +C DO J=2,3 +C ZMI = Z(J+3) +C CH = 0.25D0*(ZPL+ZMI)*(ZPL+ZMI)/IONIC +C XIJ = CH*MPL +C YJI = CH*MOLAL(J+3)/WATER +C F1(I) = F1(I) + (YJI*(G0(I,J) + ZPL*ZMI*H)) +C F2(J) = F2(J) + (XIJ*(G0(I,J) + ZPL*ZMI*H)) +C ENDDO +C ENDDO +CC +CC *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +CC +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C GAMA(09) = 0.5D0*(GAMA(04)+GAMA(07)) ! NH4HSO4 ; AIM (Wexler & Seinfeld, 1991) +C GAMA(13) = 0.20D0*(3.D0*GAMA(04)+2.D0*GAMA(09)) ! LC ; SCAPE +CC +CC *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +CC +C DO I=7,9 +C GAMA(I)=MAX(-5.0d0, MIN(GAMA(I),5.0d0) ) ! F77 LIBRARY ROUTINE +C GAMA(I)=10.D0**GAMA(I) +C ENDDO +CC +C GAMA(4)=MAX(-5.0d0, MIN(GAMA(4),5.0d0) ) ! F77 LIBRARY ROUTINE +C GAMA(4)=10.D0**GAMA(4) +CC +C GAMA(13)=MAX(-5.0d0, MIN(GAMA(13),5.0d0) ) ! F77 LIBRARY ROUTINE +C GAMA(13)=10.D0**GAMA(13) +CC +CC *** SETUP ACTIVITY CALCULATION FLAGS ********************************* +CC +CC OUTER CALCULATION LOOP ; ONLY IF FRST=.TRUE. +CC +C IF (FRST) THEN +C ERROU = ZERO ! CONVERGENCE CRITERION +C DO I=7,9 +C ERROU=MAX(ERROU, ABS((GAMOU(I)-GAMA(I))/GAMOU(I))) +C ENDDO +C ERROU=MAX(ERROU, ABS((GAMOU(4)-GAMA(4))/GAMOU(4))) +C ERROU=MAX(ERROU, ABS((GAMOU(13)-GAMA(13))/GAMOU(13))) +CC +C CALAOU = ERROU >= EPSACT ! SETUP FLAGS +C FRST =.FALSE. +C ENDIF +CC +CC INNER CALCULATION LOOP ; ALWAYS +CC +C ERRIN = ZERO ! CONVERGENCE CRITERION +C DO I=7,9 +C ERRIN = MAX (ERRIN, ABS((GAMIN(I)-GAMA(I))/GAMIN(I))) +C ENDDO +C ERRIN = MAX (ERRIN, ABS((GAMIN(4)-GAMA(4))/GAMIN(4))) +C ERRIN = MAX (ERRIN, ABS((GAMIN(13)-GAMA(13))/GAMIN(13))) +C CALAIN = ERRIN >= EPSACT +CC +C ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter +CC +CC *** END OF SUBROUTINE ACTIVITY **************************************** +CC +C RETURN +C END +CC +CC======================================================================= +CC +CC *** ISORROPIA CODE +CC *** SUBROUTINE RSTGAM +CC *** RESETS ACTIVITY COEFFICIENT ARRAYS TO DEFAULT VALUE OF 0.1 +CC +CC *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +CC *** GEORGIA INSTITUTE OF TECHNOLOGY +CC *** WRITTEN BY ATHANASIOS NENES +CC *** UPDATED BY CHRISTOS FOUNTOUKIS +CC +CC======================================================================= +CC +C SUBROUTINE RSTGAM +C INCLUDE 'isrpia_adj.inc' +CC +C DO I=1, NPAIR +C GAMA(I) = 0.1D0 +C ENDDO +CC +CC *** END OF SUBROUTINE RSTGAM ****************************************** +CC +C RETURN +C END +CC +CC======================================================================= +CC +CC *** ISORROPIA CODE II +CC *** SUBROUTINE KMFUL4 +CC *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +CC FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM-CALCIUM-POTASSIUM-MAGNESIUM +CC AEROSOL SYSTEM. +CC +CC *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +CC *** GEORGIA INSTITUTE OF TECHNOLOGY +CC +CC *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +CC +CC======================================================================= +CC +C SUBROUTINE KMFUL4 (IONIC,TEMP,G01,G02,G03,G04,G05,G06,G07,G08,G09, +C & G10,G11,G12,G15,G16,G17,G18,G19,G20, +C & G21,G22,G23) +C IMPLICIT NONE +C REAL*8 :: IONIC, TEMP, SION, TI, TC, CF1, CF2 +C REAL*8 :: G01,G02,G03,G04,G05,G06,G07,G08,G09, +C & G10,G11,G12,G15,G16,G17,G18,G19,G20,G21,G22,G23 +C REAL*8 :: Q1, Q2, Q3, Q4, Q5, Q6, Q7, Q8, Q10, Q11, +C & Q15, Q16, Q17, Q19, Q20, Q21, Q22, Q23 +C REAL*8 :: Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11,Z15,Z16, +C & Z17,Z19,Z20,Z21,Z22,Z23 +C DATA Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11,Z15,Z16,Z17,Z19,Z20, +C & Z21,Z22,Z23/1.D0,2.D0,1.D0,2.D0,1.D0,1.D0,2.D0,1.D0,1.D0, +C & 1.D0,2.D0,2.D0,2.D0,1.D0,1.D0,4.D0,2.D0,2.D0/ +CC +C SION = SQRT(IONIC) +CC +CC *** Coefficients at 25 oC +CC +C Q1 = 2.230D0 +C Q2 = -0.19D0 +C Q3 = -0.39D0 +C Q4 = -0.25D0 +C Q5 = -1.15D0 +C Q6 = 0.820D0 +C Q7 = -.100D0 +C Q8 = 8.000D0 +C Q10 = 2.600D0 +C Q11 = 6.000D0 +C Q15 = 0.930D0 +C Q16 = 2.400D0 +C Q17 = -0.25D0 +C Q19 = -2.33D0 +C Q20 = 0.920D0 +C Q21 = 0.150D0 +C Q22 = 2.320D0 +C Q23 = 2.900D0 +CC +C CALL MKBI(Q1 , IONIC, SION, Z01, G01) +C CALL MKBI(Q2 , IONIC, SION, Z02, G02) +C CALL MKBI(Q3 , IONIC, SION, Z03, G03) +C CALL MKBI(Q4 , IONIC, SION, Z04, G04) +C CALL MKBI(Q5 , IONIC, SION, Z05, G05) +C CALL MKBI(Q6 , IONIC, SION, Z06, G06) +C CALL MKBI(Q7 , IONIC, SION, Z07, G07) +C CALL MKBI(Q8 , IONIC, SION, Z08, G08) +C CALL MKBI(Q10, IONIC, SION, Z10, G10) +C CALL MKBI(Q11, IONIC, SION, Z11, G11) +C CALL MKBI(Q15, IONIC, SION, Z15, G15) +C CALL MKBI(Q16, IONIC, SION, Z16, G16) +C CALL MKBI(Q17, IONIC, SION, Z17, G17) +C CALL MKBI(Q19, IONIC, SION, Z19, G19) +C CALL MKBI(Q20, IONIC, SION, Z20, G20) +C CALL MKBI(Q21, IONIC, SION, Z21, G21) +C CALL MKBI(Q22, IONIC, SION, Z22, G22) +C CALL MKBI(Q23, IONIC, SION, Z23, G23) +CC +CC *** Correct for T other than 298 K +CC +C TI = TEMP-273.D0 +C TC = TI-25.D0 +C IF (ABS(TC) > 1.D0) THEN +C CF1 = 1.125D0-0.005D0*TI +C CF2 = (0.125D0-0.005D0*TI)* +C & (0.039D0*IONIC**0.92D0-0.41D0*SION/(1.D0+SION)) +C G01 = CF1*G01 - CF2*Z01 +C G02 = CF1*G02 - CF2*Z02 +C G03 = CF1*G03 - CF2*Z03 +C G04 = CF1*G04 - CF2*Z04 +C G05 = CF1*G05 - CF2*Z05 +C G06 = CF1*G06 - CF2*Z06 +C G07 = CF1*G07 - CF2*Z07 +C G08 = CF1*G08 - CF2*Z08 +C G10 = CF1*G10 - CF2*Z10 +C G11 = CF1*G11 - CF2*Z11 +C G15 = CF1*G15 - CF2*Z15 +C G16 = CF1*G16 - CF2*Z16 +C G17 = CF1*G17 - CF2*Z17 +C G19 = CF1*G19 - CF2*Z19 +C G20 = CF1*G20 - CF2*Z20 +C G21 = CF1*G21 - CF2*Z21 +C G22 = CF1*G22 - CF2*Z22 +C G23 = CF1*G23 - CF2*Z23 +C +C ENDIF +CC +C G09 = G06 + G08 - G11 +C G12 = G01 + G08 - G11 +C G18 = G08 + G20 - G11 +CC +CC *** Return point ; End of subroutine +CC +C RETURN +C END +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3 (IONIC,TEMP,G01,G02,G03,G04,G05,G06,G07,G08,G09, + & G10,G11,G12) + IMPLICIT NONE + REAL*8 :: IONIC, TEMP, SION, TI, TC, CF1, CF2 + REAL*8 :: G01,G02,G03,G04,G05,G06,G07,G08,G09, + & G10,G11,G12 + REAL*8 :: Q1, Q2, Q3, Q4, Q5, Q6, Q7, Q8, Q10, Q11 + REAL*8 :: Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11 + DATA Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11 + & /1.d0, 2.d0, 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + SION = SQRT(IONIC) +C +C *** Coefficients at 25 oC +C + Q1 = 2.230D0 + Q2 = -0.19D0 + Q3 = -0.39D0 + Q4 = -0.25D0 + Q5 = -1.15D0 + Q6 = 0.820D0 + Q7 = -.100D0 + Q8 = 8.000D0 + Q10 = 2.600D0 + Q11 = 6.000D0 +C + CALL MKBI(Q1 , IONIC, SION, Z01, G01) + CALL MKBI(Q2 , IONIC, SION, Z02, G02) + CALL MKBI(Q3 , IONIC, SION, Z03, G03) + CALL MKBI(Q4 , IONIC, SION, Z04, G04) + CALL MKBI(Q5 , IONIC, SION, Z05, G05) + CALL MKBI(Q6 , IONIC, SION, Z06, G06) + CALL MKBI(Q7 , IONIC, SION, Z07, G07) + CALL MKBI(Q8 , IONIC, SION, Z08, G08) + CALL MKBI(Q10, IONIC, SION, Z10, G10) + CALL MKBI(Q11, IONIC, SION, Z11, G11) +C +C *** Correct for T other than 298 K +C + TI = TEMP-273.D0 + TC = TI-25.D0 + IF (ABS(TC) > 1.D0) THEN + CF1 = 1.125D0-0.005D0*TI + CF2 = (0.125D0-0.005D0*TI)*(0.039D0*IONIC**0.92D0- + & 0.41D0*SION/(1.D0+SION)) + G01 = CF1*G01 - CF2*Z01 + G02 = CF1*G02 - CF2*Z02 + G03 = CF1*G03 - CF2*Z03 + G04 = CF1*G04 - CF2*Z04 + G05 = CF1*G05 - CF2*Z05 + G06 = CF1*G06 - CF2*Z06 + G07 = CF1*G07 - CF2*Z07 + G08 = CF1*G08 - CF2*Z08 + G10 = CF1*G10 - CF2*Z10 + G11 = CF1*G11 - CF2*Z11 + ENDIF +C + G09 = G06 + G08 - G11 + G12 = G01 + G08 - G11 +C +C *** Return point ; End of subroutine +C + RETURN + END +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL2 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C +C SUBROUTINE KMFUL2 (IONIC,TEMP,G04,G05,G07,G08,G09,G10) +C IMPLICIT NONE +C REAL*8 :: IONIC, TEMP, SION, TI, TC, CF1, CF2 +C REAL*8 :: G01,G02,G03,G04,G05,G06,G07,G08,G09, +C & G10,G11,G12 +C REAL*8 :: Q4, Q5, Q7, Q8, Q10 +C REAL*8 :: Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11 +C DATA Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11 +C & /1.d0, 2.d0, 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +CC +C SION = SQRT(IONIC) +CC +CC *** Coefficients at 25 oC +CC +C Q4 = -0.25D0 +C Q5 = -1.15D0 +C Q7 = -.100D0 +C Q8 = 8.000D0 +C Q10 = 2.600D0 +CC +C CALL MKBI(Q4 , IONIC, SION, Z04, G04) +C CALL MKBI(Q5 , IONIC, SION, Z05, G05) +C CALL MKBI(Q7 , IONIC, SION, Z07, G07) +C CALL MKBI(Q8 , IONIC, SION, Z08, G08) +C CALL MKBI(Q10, IONIC, SION, Z10, G10) +CC +CC *** Correct for T other than 298 K +CC +C TI = TEMP-273.D0 +C TC = TI-25.D0 +C IF (ABSIRE(TC) > 1.D0) THEN +C CF1 = 1.125D0-0.005D0*TI +C CF2 = (0.125D0-0.005D0*TI)*(0.039D0*IONIC**0.92D0- +C & 0.41D0*SION/(1.D0+SION)) +C G04 = CF1*G04 - CF2*Z04 +C G05 = CF1*G05 - CF2*Z05 +C G07 = CF1*G07 - CF2*Z07 +C G08 = CF1*G08 - CF2*Z08 +C G10 = CF1*G10 - CF2*Z10 +C ENDIF +CC +C G09 = G05 + G08 - G10 +CC +CC *** Return point ; End of subroutine +CC +C RETURN +C END +CC======================================================================= +CC +CC *** ISORROPIA CODE +CC *** SUBROUTINE KMFUL1 +CC *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +CC FOR AN AMMONIUM-SULFATE AEROSOL SYSTEM. +CC +CC *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +CC *** GEORGIA INSTITUTE OF TECHNOLOGY +CC +CC *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +CC +CC======================================================================= +CC +C SUBROUTINE KMFUL1 (IONIC,TEMP,G04,G07,G08) +C IMPLICIT NONE +C REAL*8 :: IONIC, TEMP, SION, TI, TC, CF1, CF2 +C REAL*8 :: G01,G02,G03,G04,G05,G06,G07,G08,G09, +C & G10,G11,G12 +C REAL*8 :: Q4, Q7, Q8 +C REAL*8 :: Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11 +C DATA Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11 +C & /1.d0, 2.d0, 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +CC +C SION = SQRT(IONIC) +CC +CC *** Coefficients at 25 oC +CC +C Q4 = -0.25D0 +C Q7 = -.100D0 +C Q8 = 8.000D0 +CC +C CALL MKBI(Q4 , IONIC, SION, Z04, G04) +C CALL MKBI(Q7 , IONIC, SION, Z07, G07) +C CALL MKBI(Q8 , IONIC, SION, Z08, G08) +CC +CC *** Correct for T other than 298 K +CC +C TI = TEMP-273.D0 +C TC = TI-25.D0 +C IF (ABSIRE(TC) > 1.D0) THEN +C CF1 = 1.125D0-0.005D0*TI +C CF2 = (0.125D0-0.005D0*TI)*(0.039D0*IONIC**0.92D0- +C & 0.41D0*SION/(1.D0+SION)) +C G04 = CF1*G04 - CF2*Z04 +C G07 = CF1*G07 - CF2*Z07 +C G08 = CF1*G08 - CF2*Z08 +C ENDIF +CC +CC *** Return point ; End of subroutine +CC +C RETURN +C END +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI(Q,IONIC,SION,ZIP,BI) +C + IMPLICIT NONE + REAL*8 :: Q, IONIC, SION, ZIP, BI + REAL*8 :: B, C, XX +C + B=.75D0-.065D0*Q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + C=1.d0+.055D0*Q*EXP(-.023D0*IONIC*IONIC*IONIC) + XX=-0.5107D0*SION/(1.D0+C*SION) + BI=(1.D0+B*(1.D0+.1D0*IONIC)**Q-B) + BI=ZIP*LOG10(BI) + ZIP*XX +C + RETURN + END +C +CC************************************************************************* +CC +CC TOOLBOX LIBRARY v.1.0 (May 1995) +CC +CC Program unit : SUBROUTINE CHRBLN +CC Purpose : Position of last non-blank character in a string +CC Author : Athanasios Nenes +CC +CC ======================= ARGUMENTS / USAGE ============================= +CC +CC STR is the CHARACTER variable containing the string examined +CC IBLK is a INTEGER variable containing the position of last non +CC blank character. If string is all spaces (ie ' '), then +CC the value returned is 1. +CC +CC EXAMPLE: +CC STR = 'TEST1.DAT ' +CC CALL CHRBLN (STR, IBLK) +CC +CC after execution of this code segment, "IBLK" has the value "9", which +CC is the position of the last non-blank character of "STR". +CC +CC*********************************************************************** +CC + SUBROUTINE CHRBLN (STR, IBLK) +CC +CC*********************************************************************** + CHARACTER*(*) STR +C + IBLK = 1 ! Substring pointer (default=1) + ILEN = LEN(STR) ! Length of string + DO 10 i=ILEN,1,-1 + IF (STR(i:i) /= ' ' .AND. STR(i:i) /= CHAR(0)) THEN + IBLK = i + RETURN + ENDIF +10 CONTINUE + RETURN +C + END + + +CC************************************************************************* +CC +CC TOOLBOX LIBRARY v.1.0 (May 1995) +CC +CC Program unit : SUBROUTINE SHFTRGHT +CC Purpose : RIGHT-JUSTIFICATION FUNCTION ON A STRING +CC Author : Athanasios Nenes +CC +CC ======================= ARGUMENTS / USAGE ============================= +CC +CC STRING is the CHARACTER variable with the string to be justified +CC +CC EXAMPLE: +CC STRING = 'AAAA ' +CC CALL SHFTRGHT (STRING) +CC +CC after execution of this code segment, STRING contains the value +CC ' AAAA'. +CC +CC************************************************************************* +CC + SUBROUTINE SHFTRGHT (CHR) +CC +CC*********************************************************************** + CHARACTER CHR*(*) +C + I1 = LEN(CHR) ! Total length of string + CALL CHRBLN(CHR,I2) ! Position of last non-blank character + IF (I2 == I1) RETURN +C + DO 10 I=I2,1,-1 ! Shift characters + CHR(I1+I-I2:I1+I-I2) = CHR(I:I) + CHR(I:I) = ' ' +10 CONTINUE + RETURN +C + END + + + + +CC************************************************************************* +CC +CC TOOLBOX LIBRARY v.1.0 (May 1995) +CC +CC Program unit : SUBROUTINE RPLSTR +CC Purpose : REPLACE CHARACTERS OCCURING IN A STRING +CC Author : Athanasios Nenes +CC +CC ======================= ARGUMENTS / USAGE ============================= +CC +CC STRING is the CHARACTER variable with the string to be edited +CC OLD is the old character which is to be replaced +CC NEW is the new character which OLD is to be replaced with +CC IERR is 0 if everything went well, is 1 if 'NEW' contains 'OLD'. +CC In this case, this is invalid, and no change is done. +CC +CC EXAMPLE: +CC STRING = 'AAAA' +CC OLD = 'A' +CC NEW = 'B' +CC CALL RPLSTR (STRING, OLD, NEW) +CC +CC after execution of this code segment, STRING contains the value +CC 'BBBB'. +CC +CC************************************************************************* +CC + SUBROUTINE RPLSTR (STRING, OLD, NEW, IERR) +CC +CC*********************************************************************** + CHARACTER STRING*(*), OLD*(*), NEW*(*) +C +C *** INITIALIZE ******************************************************** +C + ILO = LEN(OLD) +C +C *** CHECK AND SEE IF 'NEW' CONTAINS 'OLD', WHICH CANNOT *************** +C + IP = INDEX(NEW,OLD) + IF (IP /= 0) THEN + IERR = 1 + RETURN + ELSE + IERR = 0 + ENDIF +C +C *** PROCEED WITH REPLACING ******************************************* +C +10 IP = INDEX(STRING,OLD) ! SEE IF 'OLD' EXISTS IN 'STRING' + IF (IP == 0) RETURN ! 'OLD' DOES NOT EXIST ; RETURN + STRING(IP:IP+ILO-1) = NEW ! REPLACE SUBSTRING 'OLD' WITH 'NEW' + GOTO 10 ! GO FOR NEW OCCURANCE OF 'OLD' +C + END + + +CC************************************************************************* +CC +CC TOOLBOX LIBRARY v.1.0 (May 1995) +CC +CC Program unit : SUBROUTINE INPTD +CC Purpose : Prompts user for a value (DOUBLE). A default value +CC is provided, so if user presses , the default +CC is used. +CC Author : Athanasios Nenes +CC +CC ======================= ARGUMENTS / USAGE ============================= +CC +CC VAR is the REAL*8 :: variable which value is to be saved +CC DEF is a REAL*8 :: variable, with the default value of VAR. +CC PROMPT is a CHARACTER varible containing the prompt string. +CC PRFMT is a CHARACTER variable containing the FORMAT specifier +CC for the default value DEF. +CC IERR is an INTEGER error flag, and has the values: +CC 0 - No error detected. +CC 1 - Invalid FORMAT and/or Invalid default value. +CC 2 - Bad value specified by user +CC +CC EXAMPLE: +CC CALL INPTD (VAR, 1.0D0, 'Give value for A ', '*', Ierr) +CC +CC after execution of this code segment, the user is prompted for the +CC value of variable VAR. If is pressed (ie no value is specified) +CC then 1.0 is assigned to VAR. The default value is displayed in free- +CC format. The error status is specified by variable Ierr +CC +CC*********************************************************************** +CC + SUBROUTINE INPTD (VAR, DEF, PROMPT, PRFMT, IERR) +CC +CC*********************************************************************** + CHARACTER PROMPT*(*), PRFMT*(*), BUFFER*128 + REAL*8 :: DEF, VAR + INTEGER IERR +C + IERR = 0 +C +C *** WRITE DEFAULT VALUE TO WORK BUFFER ******************************* +C + WRITE (BUFFER, FMT=PRFMT, ERR=10) DEF + CALL CHRBLN (BUFFER, IEND) +C +C *** PROMPT USER FOR INPUT AND READ IT ******************************** +C +C WRITE (*,*) PROMPT,' [',BUFFER(1:IEND),']: ' +C READ (*, '(A)', ERR=20, END=20) BUFFER + CALL CHRBLN (BUFFER,IEND) +C +C *** READ DATA OR SET DEFAULT ? **************************************** +C + IF (IEND == 1 .AND. BUFFER(1:1) == ' ') THEN + VAR = DEF + ELSE + READ (BUFFER, *, ERR=20, END=20) VAR + ENDIF +C +C *** RETURN POINT ****************************************************** +C +30 RETURN +C +C *** ERROR HANDLER ***************************************************** +C +10 IERR = 1 ! Bad FORMAT and/or bad default value + GOTO 30 +C +20 IERR = 2 ! Bad number given by user + GOTO 30 +C + END + + +CC************************************************************************* +CC +CC TOOLBOX LIBRARY v.1.0 (May 1995) +CC +CC Program unit : SUBROUTINE Pushend +CC Purpose : Positions the pointer of a sequential file at its end +CC Simulates the ACCESS='APPEND' clause of a F77L OPEN +CC statement with Standard Fortran commands. +CC +CC ======================= ARGUMENTS / USAGE ============================= +CC +CC Iunit is a INTEGER variable, the file unit which the file is +CC connected to. +CC +CC EXAMPLE: +CC CALL PUSHEND (10) +CC +CC after execution of this code segment, the pointer of unit 10 is +CC pushed to its end. +CC +CC*********************************************************************** +CC + SUBROUTINE Pushend (Iunit) +CC +CC*********************************************************************** +C + LOGICAL OPNED +C +C *** INQUIRE IF Iunit CONNECTED TO FILE ******************************** +C + INQUIRE (UNIT=Iunit, OPENED=OPNED) + IF (.NOT.OPNED) GOTO 25 +C +C *** Iunit CONNECTED, PUSH POINTER TO END ****************************** +C +10 READ (Iunit,'()', ERR=20, END=20) + GOTO 10 +C +C *** RETURN POINT ****************************************************** +C +20 BACKSPACE (Iunit) +25 RETURN + END + + + +CC************************************************************************* +CC +CC TOOLBOX LIBRARY v.1.0 (May 1995) +CC +CC Program unit : SUBROUTINE APPENDEXT +CC Purpose : Fix extension in file name string +CC +CC ======================= ARGUMENTS / USAGE ============================= +CC +CC Filename is the CHARACTER variable with the file name +CC Defext is the CHARACTER variable with extension (including '.', +CC ex. '.DAT') +CC Overwrite is a LOGICAL value, .TRUE. overwrites any existing extension +CC in "Filename" with "Defext", .FALSE. puts "Defext" only if +CC there is no extension in "Filename". +CC +CC EXAMPLE: +CC FILENAME1 = 'TEST.DAT' +CC FILENAME2 = 'TEST.DAT' +CC CALL APPENDEXT (FILENAME1, '.TXT', .FALSE.) +CC CALL APPENDEXT (FILENAME2, '.TXT', .TRUE. ) +CC +CC after execution of this code segment, "FILENAME1" has the value +CC 'TEST.DAT', while "FILENAME2" has the value 'TEST.TXT' +CC +CC*********************************************************************** +CC + SUBROUTINE Appendext (Filename, Defext, Overwrite) +CC +CC*********************************************************************** + CHARACTER*(*) Filename, Defext + LOGICAL Overwrite +C + CALL CHRBLN (Filename, Iend) + IF (Filename(1:1) == ' ' .AND. Iend == 1) RETURN ! Filename empty + Idot = INDEX (Filename, '.') ! Append extension ? + IF (Idot == 0) Filename = Filename(1:Iend)//Defext + IF (Overwrite .AND. Idot /= 0) + & Filename = Filename(:Idot-1)//Defext + RETURN + END + + + +C SUBROUTINE TEST_QTCRT(degree,a,z) +C !----------------------------------------------------------------------- +C ! Test program written to be compatible with ELF90 by +C ! Alan Miller +C ! amiller @ bigpond.net.au +C ! WWW-page: http://users.bigpond.net.au/amiller +C ! Latest revision - 27 February 1997 +C !----------------------------------------------------------------------- +C USE constants_NSWC +C IMPLICIT NONE +C +C INTEGER :: degree, i +C REAL (dp) :: a(0:4) +C COMPLEX (dp) :: z(4) +C +C INTERFACE +C SUBROUTINE qdcrt (a, z) +C USE constants_NSWC +C IMPLICIT NONE +C REAL (dp), INTENT(IN) :: a(:) +C COMPLEX (dp), INTENT(OUT) :: z(:) +C END SUBROUTINE qdcrt +C +C SUBROUTINE cbcrt (a, z) +C USE constants_NSWC +C IMPLICIT NONE +C REAL (dp), INTENT(IN) :: a(:) +C COMPLEX (dp), INTENT(OUT) :: z(:) +C END SUBROUTINE cbcrt +C +C SUBROUTINE qtcrt (a, z) +C USE constants_NSWC +C IMPLICIT NONE +C REAL (dp), INTENT(IN) :: a(:) +C COMPLEX (dp), INTENT(OUT) :: z(:) +C END SUBROUTINE qtcrt +C END INTERFACE +C +C WRITE(*, *) 'Solve quadratic, cubic, quartic eq. w/REAL coeffs' +C WRITE(*, *) +C +CC DO +C WRITE(*, *)'Enter 2, 3, 4 for quadratic, cubic or quartic eqn.:' +CC READ(*, *) degree +C SELECT CASE (degree) +C CASE (2) +C WRITE(*, *)'Enter a(0), a(1) then a(2): ' +C WRITE(*, *) a(0), a(1), a(2) +C CALL qdcrt(a, z) +C WRITE(*, '(a, 2(/2g20.12))') ' Rts: REAL PART IMAG PART', +C & (DBLE(z(i)), AIMAG(z(i)), i=1,2) +C CASE (3) +C WRITE(*, *)'Enter a(0), a(1), a(2) then a(3): ' +C WRITE(*, *) a(0), a(1), a(2), a(3) +C CALL cbcrt(a, z) +C WRITE(*, '(a, 3(/2g20.12))') ' Rts: REAL PART IMAG PART', +C & (DBLE(z(i)), AIMAG(z(i)), i=1,3) +C CASE (4) +C WRITE(*, *)'Enter a(0), a(1), a(2), a(3) then a(4): ' +C WRITE(*, *) a(0), a(1), a(2), a(3), a(4) +C CALL qtcrt(a, z) +C WRITE(*, '(a, 4(/2g20.12))') ' Rts: REAL PART IMAG PART', +C & (DBLE(z(i)), AIMAG(z(i)), i=1,4) +C CASE DEFAULT +C WRITE(*, *)'*** Try again! ***' +C WRITE(*, *)'Use Ctrl-C to exit the program' +C END SELECT +CC END DO +C +C RETURN +C END SUBROUTINE TEST_QTCRT + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE POLY3 +C *** FINDS THE REAL ROOTS OF THE THIRD ORDER ALGEBRAIC EQUATION: +C X**3 + A1*X**2 + A2*X + A3 = 0.0 +C THE EQUATION IS SOLVED ANALYTICALLY. +C +C PARAMETERS A1, A2, A3 ARE SPECIFIED BY THE USER. THE MINIMUM +C NONEGATIVE ROOT IS RETURNED IN VARIABLE 'ROOT'. IF NO ROOT IS +C FOUND (WHICH IS GREATER THAN ZERO), ROOT HAS THE VALUE 1D30. +C AND THE FLAG ISLV HAS A VALUE GREATER THAN ZERO. +C +C SOLUTION FORMULA IS FOUND IN PAGE 32 OF: +C MATHEMATICAL HANDBOOK OF FORMULAS AND TABLES +C SCHAUM'S OUTLINE SERIES +C MURRAY SPIEGER, McGRAW-HILL, NEW YORK, 1968 +C (GREEK TRANSLATION: BY SOTIRIOS PERSIDES, ESPI, ATHENS, 1976) +C +C A SPECIAL CASE IS CONSIDERED SEPERATELY ; WHEN A3 = 0, THEN +C ONE ROOT IS X=0.0, AND THE OTHER TWO FROM THE SOLUTION OF THE +C QUADRATIC EQUATION X**2 + A1*X + A2 = 0.0 +C THIS SPECIAL CASE IS CONSIDERED BECAUSE THE ANALYTICAL FORMULA +C DOES NOT YIELD ACCURATE RESULTS (DUE TO NUMERICAL ROUNDOFF ERRORS) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE POLY3 (A1, A2, A3, ROOT, ISLV) +C + IMPLICIT NONE + REAL*8, PARAMETER :: EXPON=1.D0/3.D0 + REAL*8, PARAMETER :: ZERO=0.D0 + REAL*8, PARAMETER :: THET1=120.D0/180.D0 + REAL*8, PARAMETER :: THET2=240.D0/180.D0 + REAL*8, PARAMETER :: PI=3.1415926535897932D0 + REAL*8, PARAMETER :: EPS=1.D-50 + + REAL*8 :: x(3), a1, a2, a3, root + INTEGER :: ix, i, islv + REAL*8 :: d, q, u, s, t + REAL*8 :: sqd + REAL*8 :: thet + REAL*8 :: coef + REAL*8 :: ssig, tsig +C +C *** SPECIAL CASE : QUADRATIC*X EQUATION ***************************** +C + IF (ABS(A3) <= EPS) THEN + ISLV = 1 + IX = 1 + X(1) = ZERO + D = A1*A1-4.D0*A2 + IF ((D) >= ZERO) THEN + IX = 3 + SQD = SQRT(D) + X(2) = 0.5*(-A1+SQD) + X(3) = 0.5*(-A1-SQD) + ELSE +C WRITE(*,*) 'No solution being determined' + PAUSE + ENDIF + ELSE +C +C *** NORMAL CASE : CUBIC EQUATION ************************************ +C +C DEFINE PARAMETERS Q, U, S, T, D +C + ISLV= 1 + Q = (3.D0*A2 - A1*A1)/9.D0 + U = (9.D0*A1*A2 - 27.D0*A3 - 2.D0*A1*A1*A1)/54.D0 + D = Q*Q*Q + U*U +C +C *** CALCULATE ROOTS ************************************************* +C +C D < 0, THREE REAL ROOTS +C + IF ((D) < -EPS) THEN ! D < -EPS : D < ZERO + IX = 3 + THET = EXPON*ACOS(U/SQRT(-Q*Q*Q)) + COEF = 2.D0*SQRT(-Q) + X(1) = COEF*COS(THET) - EXPON*A1 + X(2) = COEF*COS(THET + THET1*PI) - EXPON*A1 + X(3) = COEF*COS(THET + THET2*PI) - EXPON*A1 +C +C D = 0, THREE REAL (ONE DOUBLE) ROOTS +C + ELSE IF ((D) <= EPS) THEN ! -EPS <= D <= EPS : D = ZERO + IX = 2 + SSIG = SIGN (1.D0, U) + S = SSIG*(ABS(U))**EXPON + X(1) = 2.D0*S - EXPON*A1 + X(2) = -S - EXPON*A1 +C +C D > 0, ONE REAL ROOT +C + ELSE ! D > EPS : D > ZERO + IX = 1 + SQD = SQRT(D) + SSIG = SIGN (1.D0, U+SQD) ! TRANSFER SIGN TO SSIG + TSIG = SIGN (1.D0, U-SQD) + S = SSIG*(ABS(U+SQD))**EXPON ! EXPONENTIATE ABS() + T = TSIG*(ABS(U-SQD))**EXPON + X(1) = S + T - EXPON*A1 + ENDIF + ENDIF +C +C *** SELECT APPROPRIATE ROOT ***************************************** +C + ROOT = 1.D30 + DO I=1,IX + IF ((X(I)) > ZERO) THEN + ROOT = MIN(ROOT, X(I)) + ISLV = 0 + ENDIF + ENDDO +C +C *** END OF SUBROUTINE POLY3 ***************************************** +C + RETURN + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** FUNCTION EX10 +C *** 10^X FUNCTION ; ALTERNATE OF LIBRARY ROUTINE ; USED BECAUSE IT IS +C MUCH FASTER BUT WITHOUT GREAT LOSS IN ACCURACY. , +C MAXIMUM ERROR IS 2%, EXECUTION TIME IS 42% OF THE LIBRARY ROUTINE +C (ON A 80286/80287 MACHINE, using Lahey FORTRAN 77 v.3.0). +C +C EXPONENT RANGE IS BETWEEN -K AND K (K IS THE REAL ARGUMENT 'K') +C MAX VALUE FOR K: 9.999 +C IF X < -K, X IS SET TO -K, IF X > K, X IS SET TO K +C +C THE EXPONENT IS CALCULATED BY THE PRODUCT ADEC*AINT, WHERE ADEC +C IS THE MANTISSA AND AINT IS THE MAGNITUDE (EXPONENT). BOTH +C MANTISSA AND MAGNITUDE ARE PRE-CALCULATED AND STORED IN LOOKUP +C TABLES ; THIS LEADS TO THE INCREASED SPEED. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + FUNCTION EX10(X,K) + REAL X, EX10, Y, AINT10, ADEC10, K + INTEGER K1, K2 + COMMON /EXPNC/ AINT10(20), ADEC10(200) +C +C *** LIMIT X TO [-K, K] RANGE ***************************************** +C + Y = MAX(-K, MIN(X,K)) ! MIN: -9.999, MAX: 9.999 +C +C *** GET INTEGER AND DECIMAL PART ************************************* +C + K1 = INT(Y) + K2 = INT(100*(Y-K1)) +C +C *** CALCULATE EXP FUNCTION ******************************************* +C + EX10 = AINT10(K1+10)*ADEC10(K2+100) +C +C *** END OF EXP FUNCTION ********************************************** +C + RETURN + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** BLOCK DATA EXPON +C *** CONTAINS DATA FOR EXPONENT ARRAYS NEEDED IN FUNCTION EXP10 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + BLOCK DATA EXPONb +C +C *** Common block definition +C + REAL*8 :: AINT10, ADEC10 + COMMON /EXPNC/ AINT10(20), ADEC10(200) +C +C *** Integer part +C + DATA AINT10/ + & 0.1000E-08, 0.1000E-07, 0.1000E-06, 0.1000E-05, 0.1000E-04, + & 0.1000E-03, 0.1000E-02, 0.1000E-01, 0.1000E+00, 0.1000E+01, + & 0.1000E+02, 0.1000E+03, 0.1000E+04, 0.1000E+05, 0.1000E+06, + & 0.1000E+07, 0.1000E+08, 0.1000E+09, 0.1000E+10, 0.1000E+11 + & / +C +C *** decimal part +C + DATA (ADEC10(I),I=1,100)/ + & 0.1023E+00, 0.1047E+00, 0.1072E+00, 0.1096E+00, 0.1122E+00, + & 0.1148E+00, 0.1175E+00, 0.1202E+00, 0.1230E+00, 0.1259E+00, + & 0.1288E+00, 0.1318E+00, 0.1349E+00, 0.1380E+00, 0.1413E+00, + & 0.1445E+00, 0.1479E+00, 0.1514E+00, 0.1549E+00, 0.1585E+00, + & 0.1622E+00, 0.1660E+00, 0.1698E+00, 0.1738E+00, 0.1778E+00, + & 0.1820E+00, 0.1862E+00, 0.1905E+00, 0.1950E+00, 0.1995E+00, + & 0.2042E+00, 0.2089E+00, 0.2138E+00, 0.2188E+00, 0.2239E+00, + & 0.2291E+00, 0.2344E+00, 0.2399E+00, 0.2455E+00, 0.2512E+00, + & 0.2570E+00, 0.2630E+00, 0.2692E+00, 0.2754E+00, 0.2818E+00, + & 0.2884E+00, 0.2951E+00, 0.3020E+00, 0.3090E+00, 0.3162E+00, + & 0.3236E+00, 0.3311E+00, 0.3388E+00, 0.3467E+00, 0.3548E+00, + & 0.3631E+00, 0.3715E+00, 0.3802E+00, 0.3890E+00, 0.3981E+00, + & 0.4074E+00, 0.4169E+00, 0.4266E+00, 0.4365E+00, 0.4467E+00, + & 0.4571E+00, 0.4677E+00, 0.4786E+00, 0.4898E+00, 0.5012E+00, + & 0.5129E+00, 0.5248E+00, 0.5370E+00, 0.5495E+00, 0.5623E+00, + & 0.5754E+00, 0.5888E+00, 0.6026E+00, 0.6166E+00, 0.6310E+00, + & 0.6457E+00, 0.6607E+00, 0.6761E+00, 0.6918E+00, 0.7079E+00, + & 0.7244E+00, 0.7413E+00, 0.7586E+00, 0.7762E+00, 0.7943E+00, + & 0.8128E+00, 0.8318E+00, 0.8511E+00, 0.8710E+00, 0.8913E+00, + & 0.9120E+00, 0.9333E+00, 0.9550E+00, 0.9772E+00, 0.1000E+01/ + + DATA (ADEC10(I),I=101,200)/ + & 0.1023E+01, 0.1047E+01, 0.1072E+01, 0.1096E+01, 0.1122E+01, + & 0.1148E+01, 0.1175E+01, 0.1202E+01, 0.1230E+01, 0.1259E+01, + & 0.1288E+01, 0.1318E+01, 0.1349E+01, 0.1380E+01, 0.1413E+01, + & 0.1445E+01, 0.1479E+01, 0.1514E+01, 0.1549E+01, 0.1585E+01, + & 0.1622E+01, 0.1660E+01, 0.1698E+01, 0.1738E+01, 0.1778E+01, + & 0.1820E+01, 0.1862E+01, 0.1905E+01, 0.1950E+01, 0.1995E+01, + & 0.2042E+01, 0.2089E+01, 0.2138E+01, 0.2188E+01, 0.2239E+01, + & 0.2291E+01, 0.2344E+01, 0.2399E+01, 0.2455E+01, 0.2512E+01, + & 0.2570E+01, 0.2630E+01, 0.2692E+01, 0.2754E+01, 0.2818E+01, + & 0.2884E+01, 0.2951E+01, 0.3020E+01, 0.3090E+01, 0.3162E+01, + & 0.3236E+01, 0.3311E+01, 0.3388E+01, 0.3467E+01, 0.3548E+01, + & 0.3631E+01, 0.3715E+01, 0.3802E+01, 0.3890E+01, 0.3981E+01, + & 0.4074E+01, 0.4169E+01, 0.4266E+01, 0.4365E+01, 0.4467E+01, + & 0.4571E+01, 0.4677E+01, 0.4786E+01, 0.4898E+01, 0.5012E+01, + & 0.5129E+01, 0.5248E+01, 0.5370E+01, 0.5495E+01, 0.5623E+01, + & 0.5754E+01, 0.5888E+01, 0.6026E+01, 0.6166E+01, 0.6310E+01, + & 0.6457E+01, 0.6607E+01, 0.6761E+01, 0.6918E+01, 0.7079E+01, + & 0.7244E+01, 0.7413E+01, 0.7586E+01, 0.7762E+01, 0.7943E+01, + & 0.8128E+01, 0.8318E+01, 0.8511E+01, 0.8710E+01, 0.8913E+01, + & 0.9120E+01, 0.9333E+01, 0.9550E+01, 0.9772E+01, 0.1000E+02 + & / +C +C *** END OF BLOCK DATA EXPON ****************************************** +C + END +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE PUSHERR +C *** THIS SUBROUTINE SAVES AN ERROR MESSAGE IN THE ERROR STACK +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE PUSHERR (IERR,ERRINF) + INCLUDE 'isrpia_adj.inc' + CHARACTER(LEN=*) :: ERRINF +C +C *** SAVE ERROR CODE IF THERE IS ANY SPACE *************************** +C +C WRITE(*,*) 'Calling Error, IERR: ',IERR,ERRINF +C PAUSE + IF (NOFER < NERRMX) THEN + NOFER = NOFER + 1 + ERRSTK(NOFER) = IERR + ERRMSG(NOFER) = ERRINF + STKOFL =.FALSE. + ELSE + STKOFL =.TRUE. ! STACK OVERFLOW + ENDIF +C +C *** END OF SUBROUTINE PUSHERR **************************************** +C + END + + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ISERRINF +C *** THIS SUBROUTINE OBTAINS A COPY OF THE ERROR STACK (& MESSAGES) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ISERRINF (ERRSTKI, ERRMSGI, NOFERI, STKOFLI) + INCLUDE 'isrpia_adj.inc' + CHARACTER(LEN=40) :: ERRMSGI(NERRMX) + INTEGER :: ERRSTKI(NERRMX) + LOGICAL :: STKOFLI +C +C *** OBTAIN WHOLE ERROR STACK **************************************** +C + DO I=1,NOFER ! Error messages & codes + ERRSTKI(I) = ERRSTK(I) + ERRMSGI(I) = ERRMSG(I) + ENDDO +C + STKOFLI = STKOFL + NOFERI = NOFER +C + RETURN +C +C *** END OF SUBROUTINE ISERRINF *************************************** +C + END + + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ERRSTAT +C *** THIS SUBROUTINE REPORTS ERROR MESSAGES TO UNIT 'IO' +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ERRSTAT (IO,IERR,ERRINF) + INCLUDE 'isrpia_adj.inc' + CHARACTER(LEN=4) :: CER + CHARACTER(LEN=29) :: NCIS = 'NO CONVERGENCE IN SUBROUTINE ' + CHARACTER(LEN=27) :: NCIF = 'NO CONVERGENCE IN FUNCTION ' + CHARACTER(LEN=26) :: NSIS = 'NO SOLUTION IN SUBROUTINE ' + CHARACTER(LEN=24) :: NSIF = 'NO SOLUTION IN FUNCTION ' + CHARACTER(*) :: ERRINF +C +C *** WRITE ERROR IN CHARACTER ***************************************** +C +C WRITE (*,'(I4)') IERR + WRITE (CER,'(I4)') IERR + CALL RPLSTR (CER, ' ', '0',IOK) ! REPLACE BLANKS WITH ZEROS + CALL CHRBLN (ERRINF, IEND) ! LAST POSITION OF ERRINF CHAR +C +C *** WRITE ERROR TYPE (FATAL, WARNING ) ******************************* +C + IF (IERR == 0) THEN + WRITE (IO,1000) 'NO ERRORS DETECTED ' + GOTO 10 +C + ELSE IF (IERR < 0) THEN + WRITE (IO,1000) 'ERROR STACK EXHAUSTED ' + GOTO 10 +C + ELSE IF (IERR > 1000) THEN + WRITE (IO,1100) 'FATAL',CER +C + ELSE + WRITE (IO,1100) 'WARNING',CER + ENDIF +C +C *** WRITE ERROR MESSAGE ********************************************** +C +C FATAL MESSAGES +C + IF (IERR == 1001) THEN + CALL CHRBLN (SCASE, IEND) + WRITE (IO,1000) 'CASE NOT SUPPORTED IN CALCMR ['//SCASE(1:IEND) + & //']' +C + ELSEIF (IERR == 1002) THEN + CALL CHRBLN (SCASE, IEND) + WRITE (IO,1000) 'CASE NOT SUPPORTED ['//SCASE(1:IEND)//']' +C +C WARNING MESSAGES +C + ELSEIF (IERR == 0001) THEN + WRITE (IO,1000) NSIS,ERRINF +C + ELSEIF (IERR == 0002) THEN + WRITE (IO,1000) NCIS,ERRINF +C + ELSEIF (IERR == 0003) THEN + WRITE (IO,1000) NSIF,ERRINF +C + ELSEIF (IERR == 0004) THEN + WRITE (IO,1000) NCIF,ERRINF +C + ELSE IF (IERR == 0019) THEN + WRITE (IO,1000) 'HNO3(aq) AFFECTS H+, WHICH '// + & 'MIGHT AFFECT SO4/HSO4 RATIO' + WRITE (IO,1000) 'DIRECT INCREASE IN H+ [',ERRINF(1:IEND),'] %' +C + ELSE IF (IERR == 0020) THEN + IF ((W(4)) > TINY .AND. (W(5)) > TINY) THEN + WRITE (IO,1000) 'HSO4-SO4 EQUILIBRIUM MIGHT AFFECT HNO3,' + & //'HCL DISSOLUTION' + ELSE + WRITE (IO,1000) 'HSO4-SO4 EQUILIBRIUM MIGHT AFFECT NH3 ' + & //'DISSOLUTION' + ENDIF + WRITE (IO,1000) 'DIRECT DECREASE IN H+ [',ERRINF(1:IEND),'] %' +C + ELSE IF (IERR == 0021) THEN + WRITE (IO,1000) 'HNO3(aq),HCL(aq) AFFECT H+, WHICH '// + & 'MIGHT AFFECT SO4/HSO4 RATIO' + WRITE (IO,1000) 'DIRECT INCREASE IN H+ [',ERRINF(1:IEND),'] %' +C + ELSE IF (IERR == 0022) THEN + WRITE (IO,1000) 'HCL(g) EQUILIBRIUM YIELDS NONPHYSICAL '// + & 'DISSOLUTION' + WRITE (IO,1000) 'A TINY AMOUNT [',ERRINF(1:IEND),'] IS '// + & 'ASSUMED TO BE DISSOLVED' +C + ELSEIF (IERR == 0033) THEN + WRITE (IO,1000) 'HCL(aq) AFFECTS H+, WHICH '// + & 'MIGHT AFFECT SO4/HSO4 RATIO' + WRITE (IO,1000) 'DIRECT INCREASE IN H+ [',ERRINF(1:IEND),'] %' +C + ELSEIF (IERR == 0050) THEN + WRITE (IO,1000) 'TOO MUCH SODIUM GIVEN AS INPUT.' + WRITE (IO,1000) 'REDUCED TO COMPLETELY NEUTRALIZE SO4,Cl,NO3.' + WRITE (IO,1000) 'EXCESS SODIUM IS IGNORED.' +C + ELSEIF (IERR == 0100) THEN +C WRITE(*,*) 'Executing PUSHERR 100' + WRITE (IO,1000) 'CONVERGENCE TO VALUE OTHER THAN 0 ' + WRITE (IO,1000) 'FUNCTION AND VALUE: ',ERRINF(1:IEND),'.' +C + ELSEIF (IERR == 0101) THEN +C WRITE(*,*) 'Executing PUSHERR 101' + WRITE (IO,1000) 'CONVERGENCE AT INITIAL VALUE.' + WRITE (IO,1000) 'FUNCTION AND VALUE: ',ERRINF(1:IEND),'.' +C + ELSEIF (IERR == 0102) THEN +C WRITE(*,*) 'Executing PUSHERR 102' + WRITE (IO,1000) 'EXCEEDED THE THRESHOLD VALUE FOR IONIC.' + WRITE (IO,1000) 'FUNCTION AND VALUE: ',ERRINF(1:IEND),'.' +C + ELSEIF (IERR == 0103) THEN +C WRITE(*,*) 'Executing PUSHERR 103' + WRITE (IO,1000) 'VERY SMALL VALUE FOR TEST VARIABLE.' + WRITE (IO,1000) 'FUNCTION AND VALUE: ',ERRINF(1:IEND),'.' +C + ELSEIF (IERR == 0104) THEN +C WRITE(*,*) 'Executing PUSHERR 104' + WRITE (IO,1000) 'NEWTON METHOD NOT CONVERGING.' + WRITE (IO,1000) 'FUNCTION AND Y1-Y2 DIFF: ',ERRINF(1:IEND),'.' +C + ELSE + WRITE (IO,1000) 'NO DIAGNOSTIC MESSAGE AVAILABLE' + ENDIF +C +10 RETURN +C +C *** FORMAT STATEMENTS ************************************* +C +1000 FORMAT (1X,A:A:A:A:A) +1100 FORMAT (1X,A,' ERROR [',A4,']:') +C +C *** END OF SUBROUTINE ERRSTAT ***************************** +C + END +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ISORINF +C *** THIS SUBROUTINE PROVIDES INFORMATION ABOUT ISORROPIA +C +C ======================== ARGUMENTS / USAGE =========================== +C +C OUTPUT: +C 1. [VERSI] +C CHARACTER*15 variable. +C Contains version-date information of ISORROPIA +C +C 2. [NCMP] +C INTEGER variable. +C The number of components needed in input array WI +C (or, the number of major species accounted for by ISORROPIA) +C +C 3. [NION] +C INTEGER variable +C The number of ions considered in the aqueous phase +C +C 4. [NAQGAS] +C INTEGER variable +C The number of undissociated species found in aqueous aerosol +C phase +C +C 5. [NSOL] +C INTEGER variable +C The number of solids considered in the solid aerosol phase +C +C 6. [NERR] +C INTEGER variable +C The size of the error stack (maximum number of errors that can +C be stored before the stack exhausts). +C +C 7. [TIN] +C REAL*8 :: variable +C The value used for a very small number. +C +C 8. [GRT] +C REAL*8 :: variable +C The value used for a very large number. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ISORINF (VERSI, NCMP, NION, NAQGAS, NSOL, NERR, TIN, + & GRT) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: TIN, GRT + CHARACTER VERSI*(*) +C +C *** ASSIGN INFO ******************************************************* +C + VERSI = VERSION + NCMP = NCOMP + NION = NIONS + NAQGAS = NGASAQ + NSOL = NSLDS + NERR = NERRMX + TIN = TINY + GRT = GREAT +C + RETURN +C +C *** END OF SUBROUTINE ISORINF ******************************************* +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ISRP1F +C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF +C AN AMMONIUM-SULFATE AEROSOL SYSTEM. +C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY +C THE AMBIENT RELATIVE HUMIDITY. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ISRP1F (WI, RHI, TEMPI) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: WI(NCOMP), RHI, TEMPI + REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2) + REAL*8 :: DC +C +C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +C + CALL INIT1 (WI, RHI, TEMPI) +C +C *** CALCULATE SULFATE RATIO ******************************************* +C + SULRAT = (W(3))/(W(2)) +C +C *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** +C +C *** SULFATE POOR +C + IF (2.0 <= SULRAT) THEN +C WP = W + !WRITE(*,*) 'Calling ISRP1FA, WI: ',WI + CALL ISRP1FA ! Wrapper for TAPENADE to process correctly +C DC = W(3) - 2.001D0*W(2) ! For numerical stability +C W(3) = W(3) + MAX(-DC, ZERO) +CC +CC IF(METSTBL == 1) THEN +C SCASE = 'A2' +C CALL CALCA2 ! Only liquid (metastable) +C ELSE +C +C IF (RH < DRNH42S4) THEN +C SCASE = 'A1' +C CALL CALCA1 ! NH42SO4 ; case A1 +CC +C ELSEIF (DRNH42S4 <= RH) THEN +C SCASE = 'A2' +C CALL CALCA2 ! Only liquid ; case A2 +C ENDIF +C ENDIF +C +C *** SULFATE RICH (NO ACID) +C + ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN +C +C IF(METSTBL == 1) THEN + !WRITE(*,*) 'Calling CALCB4, WI: ',WI + SCASE = 'B4' +C WP = W + CALL CALCB4 ! Only liquid (metastable) +C ELSE +CC +C IF (RH < DRNH4HS4) THEN +C SCASE = 'B1' +C CALL CALCB1 ! NH4HSO4,LC,NH42SO4 ; case B1 +CC +C ELSEIF (DRNH4HS4 <= RH .AND. RH < DRLC) THEN +C SCASE = 'B2' +C CALL CALCB2 ! LC,NH42S4 ; case B2 +CC +C ELSEIF (DRLC <= RH .AND. RH < DRNH42S4) THEN +C SCASE = 'B3' +C CALL CALCB3 ! NH42S4 ; case B3 +CC +C ELSEIF (DRNH42S4 <= RH) THEN +C SCASE = 'B4' +C CALL CALCB4 ! Only liquid ; case B4 +C ENDIF +C ENDIF + CALL CALCACT3F ! Checking for IONIC too high + CALL CALCNH3 +C +C *** SULFATE RICH (FREE ACID) +C + ELSEIF (SULRAT < 1.0) THEN +C +C IF(METSTBL == 1) THEN + !WRITE(*,*) 'Calling CALCC2, WI: ',WI + SCASE = 'C2' + CALL CALCC2 ! Only liquid (metastable) +C ELSE +CC +C IF (RH < DRNH4HS4) THEN +C SCASE = 'C1' +C CALL CALCC1 ! NH4HSO4 ; case C1 +CC +C ELSEIF (DRNH4HS4 <= RH) THEN +C SCASE = 'C2' +C CALL CALCC2 ! Only liquid ; case C2 +CC +C ENDIF +C ENDIF + CALL CALCACT3F ! Checking for IONIC too high + CALL CALCNH3 + ENDIF +C +C *** RETURN POINT +C + RETURN +C +C *** END OF SUBROUTINE ISRP1F ***************************************** +C + END +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ISRP1F +C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF +C AN AMMONIUM-SULFATE AEROSOL SYSTEM. +C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY +C THE AMBIENT RELATIVE HUMIDITY. +C +C ANISORROPIA ROUTINE. (slc.8.2011) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ISRP1FA + INCLUDE 'isrpia_adj.inc' + REAL*8 :: WI(NCOMP), RHI, TEMPI + REAL*8 :: WP(NCOMP), MOLALP(NIONS) + REAL*8 :: DC, GAS(3), AERLIQ(NIONS+NGASAQ+2) + +C W = WP + + DC = W(3) - 2.001D0*W(2) ! For numerical stability + W(3) = W(3) + MAX(-DC, ZERO) +C + SCASE = 'A2' + CALL CALCA2 ! Only liquid (metastable) + +C GAS(1) = GNH3 ! Gaseous aerosol species +C GAS(2) = GHNO3 +C GAS(3) = GHCL +CC +C DO I=1,NIONS ! Liquid aerosol species +C AERLIQ(I) = MOLAL(I) +C ENDDO +C +C *** RETURN POINT +C + RETURN +C +C *** END OF SUBROUTINE ISRP1F ***************************************** +C + END +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ISRP2F +C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF +C AN AMMONIUM-SULFATE-NITRATE AEROSOL SYSTEM. +C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY +C THE AMBIENT RELATIVE HUMIDITY. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ISRP2F (WI, RHI, TEMPI) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: WI(NCOMP), RHI, TEMPI + REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2) +C +C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +C + CALL INIT2 (WI, RHI, TEMPI) + !WRITE(*,*) 'ISRP2F, SULRAT: ',SULRAT +C +C *** CALCULATE SULFATE RATIO ******************************************* +C + SULRAT = (W(3))/(W(2)) +C +C *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** +C +C *** SULFATE POOR +C + IF (2.0 <= SULRAT) THEN +C +C IF(METSTBL == 1) THEN + !WRITE(*,*) 'ISRP2F, SCASE: ',SCASE + SCASE = 'D3' + CALL CALCD3 ! Only liquid (metastable) +C ENDIF +C +C *** SULFATE RICH (NO ACID) +C FOR SOLVING THIS CASE, NITRIC ACID IS ASSUMED A MINOR SPECIES, +C THAT DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. +C SUBROUTINES CALCB? ARE CALLED, AND THEN THE NITRIC ACID IS DISSOLVED +C FROM THE HNO3(G) -> (H+) + (NO3-) EQUILIBRIUM. +C + ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN +C +C IF(METSTBL == 1) THEN +C WP = W + !WRITE(*,*) 'ISRP2F, SCASE: ',SCASE + SCASE = 'E4' + CALL CALCB4E ! Only liquid (metastable) + SCASE = 'E4' +C ENDIF +C + CALL CALCACT3F ! Checking for IONIC too high + CALL CALCNA ! HNO3(g) DISSOLUTION +C +C *** SULFATE RICH (FREE ACID) +C FOR SOLVING THIS CASE, NITRIC ACID IS ASSUMED A MINOR SPECIES, +C THAT DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM +C SUBROUTINE CALCC? IS CALLED, AND THEN THE NITRIC ACID IS DISSOLVED +C FROM THE HNO3(G) -> (H+) + (NO3-) EQUILIBRIUM. +C + ELSEIF (SULRAT < 1.0) THEN +C +C IF(METSTBL == 1) THEN +C WP = W + !WRITE(*,*) 'ISRP2F, SCASE: ',SCASE + SCASE = 'F2' + CALL CALCC2F ! Only liquid (metastable) + SCASE = 'F2' +C ENDIF +C + CALL CALCACT3F ! Checking for IONIC too high + CALL CALCNA ! HNO3(g) DISSOLUTION + ENDIF +C +C *** RETURN POINT +C + RETURN +C +C *** END OF SUBROUTINE ISRP2F ***************************************** +C + END +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ISRP3F +C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF +C AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE & SODIUM +C RATIOS AND BY THE AMBIENT RELATIVE HUMIDITY. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ISRP3F (WI, RHI, TEMPI) + INCLUDE 'isrpia_adj.inc' + REAL*8 :: WI(NCOMP), RHI, TEMPI + REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2) +C +C *** ADJUST FOR TOO LITTLE AMMONIUM AND CHLORIDE *********************** +C + ! To have better conservation of mass, change to TINY + ! (hotp 11/14/07) + !WI(3) = MAX (WI(3), 1.D-10) ! NH4+ : 1e-4 umoles/m3 + !WI(5) = MAX (WI(5), 1.D-10) ! Cl- : 1e-4 umoles/m3 + WI(3) = MAX (WI(3), TINY) ! NH4+ : 1e-4 umoles/m3 + WI(5) = MAX (WI(5), TINY) ! Cl- : 1e-4 umoles/m3 +C +C *** ADJUST FOR TOO LITTLE SODIUM, SULFATE AND NITRATE COMBINED ******** +C + ! To have better conservation of mass, change to TINY + ! (hotp 11/14/07) + !IF (WI(1)+WI(2)+WI(4) .LE. 1d-10) THEN + ! WI(1) = 1.D-10 ! Na+ : 1e-4 umoles/m3 + ! WI(2) = 1.D-10 ! SO4- : 1e-4 umoles/m3 + !ENDIF + IF (WI(1)+WI(2)+WI(4) .LE. TINY) THEN + WI(1) = TINY ! Na+ : 1e-4 umoles/m3 + WI(2) = TINY ! SO4- : 1e-4 umoles/m3 + ENDIF +C +C *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +C + CALL ISOINIT3 (WI, RHI, TEMPI) +C +C *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE ********* +C + REST = 2.D0*W(2) + W(4) + W(5) + IF (W(1) > REST) THEN ! NA > 2*SO4+CL+NO3 ? + W(1) = (ONE-1D-6)*REST ! Adjust Na amount + CALL PUSHERR (0050, 'ISRP3F') ! Warning error: Na adjusted + ENDIF +C +C *** CALCULATE SULFATE & SODIUM RATIOS ********************************* +C + SULRAT = (W(1)+W(3))/W(2) + SODRAT = W(1)/W(2) +C +C *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** + +C *** SULFATE POOR ; SODIUM POOR +C + IF (2.0 <= SULRAT .AND. SODRAT < 2.0) THEN +C +C IF(METSTBL == 1) THEN + !WRITE(*,*) 'Calling CALCG5, WI: ',WI + SCASE = 'G5' + CALL CALCG5 ! Only liquid (metastable) +C ENDIF +C +C *** SULFATE POOR ; SODIUM RICH +C + ELSE IF (SULRAT >= 2.0 .AND. SODRAT >= 2.0) THEN +C +C IF(METSTBL == 1) THEN + !WRITE(*,*) 'Calling CALCH6, WI: ',WI + SCASE = 'H6' + CALL CALCH6 ! Only liquid (metastable) +C ENDIF +C +C *** SULFATE RICH (NO ACID) +C + ELSEIF (1.0 <= SULRAT .AND. SULRAT < 2.0) THEN +C +C IF(METSTBL == 1) THEN + !WRITE(*,*) 'Calling CALCI6, WI: ',WI + SCASE = 'I6' + CALL CALCI6 ! Only liquid (metastable) +C ENDIF +C + CALL CALCNHA ! MINOR SPECIES: HNO3, HCl + CALL CALCACT3F ! Checking for IONIC too high + CALL CALCNH3 ! NH3 +C +C *** SULFATE RICH (FREE ACID) +C + ELSEIF (SULRAT < 1.0) THEN +C +C IF(METSTBL == 1) THEN + !WRITE(*,*) 'Calling CALCJ3, WI: ',WI + SCASE = 'J3' + CALL CALCJ3 ! Only liquid (metastable) +C ENDIF +C + CALL CALCNHA ! MINOR SPECIES: HNO3, HCl + CALL CALCACT3F ! Checking for IONIC too high + CALL CALCNH3 ! NH3 + ENDIF +C +C *** RETURN POINT +C + RETURN +C +C *** END OF SUBROUTINE ISRP3F ***************************************** +C + END +C +C +C======================================================================= +C +C *** ISORROPIA CODE II +C *** SUBROUTINE ISRP4F +C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF +C AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM-CALCIUM-POTASSIUM-MAGNESIUM +C AEROSOL SYSTEM. +C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE & SODIUM +C RATIOS AND BY THE AMBIENT RELATIVE HUMIDITY. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY CHRISTOS FOUNTOUKIS AND ATHANASIOS NENES +C +C======================================================================= +C +C SUBROUTINE ISRP4F (WI, RHI, TEMPI) +C INCLUDE 'isrpia_adj.inc' +C DIMENSION WI(NCOMP) +C REAL*8 :: NAFRI, NO3FRI +CC +CC *** ADJUST FOR TOO LITTLE AMMONIUM AND CHLORIDE *********************** +CC +CC WI(3) = MAX (WI(3), 1.D-10) ! NH4+ : 1e-4 umoles/m3 +CC WI(5) = MAX (WI(5), 1.D-10) ! Cl- : 1e-4 umoles/m3 +CC +CC *** ADJUST FOR TOO LITTLE SODIUM, SULFATE AND NITRATE COMBINED ******** +CC +CC IF (WI(1)+WI(2)+WI(4) .LE. 1d-10) THEN +CC WI(1) = 1.D-10 ! Na+ : 1e-4 umoles/m3 +CC WI(2) = 1.D-10 ! SO4- : 1e-4 umoles/m3 +CC ENDIF +CC +CC *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +CC +C CALL INIT4 (WI, RHI, TEMPI) +CC +CC *** CHECK IF TOO MUCH SODIUM+CRUSTALS ; ADJUST AND ISSUE ERROR MESSAGE +CC +C REST = 2.D0*W(2) + W(4) + W(5) +CC +C IF (W(1)+W(6)+W(7)+W(8).GT.REST) THEN +CC +C CCASO4I = MIN (W(2),W(6)) +C FRSO4I = MAX (W(2) - CCASO4I, ZERO) +C CAFRI = MAX (W(6) - CCASO4I, ZERO) +C CCANO32I = MIN (CAFRI, 0.5D0*W(4)) +C CAFRI = MAX (CAFRI - CCANO32I, ZERO) +C NO3FRI = MAX (W(4) - 2.D0*CCANO32I, ZERO) +C CCACL2I = MIN (CAFRI, 0.5D0*W(5)) +C CLFRI = MAX (W(5) - 2.D0*CCACL2I, ZERO) +C REST1 = 2.D0*FRSO4I + NO3FRI + CLFRI +CC +C CNA2SO4I = MIN (FRSO4I, 0.5D0*W(1)) +C FRSO4I = MAX (FRSO4I - CNA2SO4I, ZERO) +C NAFRI = MAX (W(1) - 2.D0*CNA2SO4I, ZERO) +C CNACLI = MIN (NAFRI, CLFRI) +C NAFRI = MAX (NAFRI - CNACLI, ZERO) +C CLFRI = MAX (CLFRI - CNACLI, ZERO) +C CNANO3I = MIN (NAFRI, NO3FRI) +C NO3FR = MAX (NO3FRI - CNANO3I, ZERO) +C REST2 = 2.D0*FRSO4I + NO3FRI + CLFRI +CC +C CMGSO4I = MIN (FRSO4I, W(8)) +C FRMGI = MAX (W(8) - CMGSO4I, ZERO) +C FRSO4I = MAX (FRSO4I - CMGSO4I, ZERO) +C CMGNO32I = MIN (FRMGI, 0.5D0*NO3FRI) +C FRMGI = MAX (FRMGI - CMGNO32I, ZERO) +C NO3FRI = MAX (NO3FRI - 2.D0*CMGNO32I, ZERO) +C CMGCL2I = MIN (FRMGI, 0.5D0*CLFRI) +C CLFRI = MAX (CLFRI - 2.D0*CMGCL2I, ZERO) +C REST3 = 2.D0*FRSO4I + NO3FRI + CLFRI +CC +C IF (W(6).GT.REST) THEN ! Ca > 2*SO4+CL+NO3 ? +C W(6) = (ONE-1D-6)*REST ! Adjust Ca amount +C W(1)= ZERO ! Adjust Na amount +C W(7)= ZERO ! Adjust K amount +C W(8)= ZERO ! Adjust Mg amount +C CALL PUSHERR (0051, 'ISRP4F') ! Warning error: Ca, Na, K, Mg in excess +CC +C ELSE IF (W(1).GT.REST1) THEN ! Na > 2*FRSO4+FRCL+FRNO3 ? +C W(1) = (ONE-1D-6)*REST1 ! Adjust Na amount +C W(7)= ZERO ! Adjust K amount +C W(8)= ZERO ! Adjust Mg amount +C CALL PUSHERR (0052, 'ISRP4F') ! Warning error: Na, K, Mg in excess +CC +C ELSE IF (W(8).GT.REST2) THEN ! Mg > 2*FRSO4+FRCL+FRNO3 ? +C W(8) = (ONE-1D-6)*REST2 ! Adjust Mg amount +C W(7)= ZERO ! Adjust K amount +C CALL PUSHERR (0053, 'ISRP4F') ! Warning error: K, Mg in excess +CC +C ELSE IF (W(7).GT.REST3) THEN ! K > 2*FRSO4+FRCL+FRNO3 ? +C W(7) = (ONE-1D-6)*REST3 ! Adjust K amount +C CALL PUSHERR (0054, 'ISRP4F') ! Warning error: K in excess +C ENDIF +C ENDIF +CC +CC *** CALCULATE RATIOS ************************************************* +CC +C SO4RAT = (W(1)+W(3)+W(6)+W(7)+W(8))/W(2) +C CRNARAT = (W(1)+W(6)+W(7)+W(8))/W(2) +C CRRAT = (W(6)+W(7)+W(8))/W(2) +CC +CC *** FIND CALCULATION REGIME FROM (SO4RAT, CRNARAT, CRRAT, RRH) ******** +CC +CC *** SULFATE POOR: Rso4>2; (DUST + SODIUM) POOR: R(Cr+Na)<2 +CC +C IF (2.0.LE.SO4RAT .AND. CRNARAT.LT.2.0) THEN +CC +C IF(METSTBL.EQ.1) THEN +C SCASE = 'O7' +C CALL CALCO7 ! Only liquid (metastable) +C ELSE +CC +C IF (RH.LT.DRNH4NO3) THEN +C SCASE = 'O1' +C CALL CALCO1 ! CaSO4, NH4NO3, NH4CL, (NH4)2SO4, MGSO4, NA2SO4, K2SO4 +CC +C ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNH4CL) THEN +C SCASE = 'O2' +C CALL CALCO2 ! CaSO4, NH4CL, (NH4)2SO4, MGSO4, NA2SO4, K2SO4 +CC +C ELSEIF (DRNH4CL.LE.RH .AND. RH.LT.DRNH42S4) THEN +C SCASE = 'O3' +C CALL CALCO3 ! CaSO4, (NH4)2SO4, MGSO4, NA2SO4, K2SO4 +CC +C ELSEIF (DRNH42S4.LE.RH .AND. RH.LT.DRMGSO4) THEN +C SCASE = 'O4' +C CALL CALCO4 ! CaSO4, MGSO4, NA2SO4, K2SO4 +CC +C ELSEIF (DRMGSO4.LE.RH .AND. RH.LT.DRNA2SO4) THEN +C SCASE = 'O5' +C CALL CALCO5 ! CaSO4, NA2SO4, K2SO4 +CC +C ELSEIF (DRNA2SO4.LE.RH .AND. RH.LT.DRK2SO4) THEN +C SCASE = 'O6' +C CALL CALCO6 ! CaSO4, K2SO4 +CC +C ELSEIF (DRK2SO4.LE.RH) THEN +C SCASE = 'O7' +C CALL CALCO7 ! CaSO4 +C ENDIF +C ENDIF +CC +CC *** SULFATE POOR: Rso4>2; (DUST + SODIUM) RICH: R(Cr+Na)>2; DUST POOR: Rcr<2. +CC +C ELSEIF (SO4RAT.GE.2.0 .AND. CRNARAT.GE.2.0) THEN +CC +C IF (CRRAT.LE.2.0) THEN +CC +C IF(METSTBL.EQ.1) THEN +C SCASE = 'M8' +C CALL CALCM8 ! Only liquid (metastable) +C ELSE +CC +C IF (RH.LT.DRNH4NO3) THEN +C SCASE = 'M1' +C CALL CALCM1 ! CaSO4, NH4NO3, NH4CL, MGSO4, NA2SO4, K2SO4, NACL, NANO3 +CC +C ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNANO3) THEN +C SCASE = 'M2' +C CALL CALCM2 ! CaSO4, NH4CL, MGSO4, NA2SO4, K2SO4, NACL, NANO3 +CC +C ELSEIF (DRNANO3.LE.RH .AND. RH.LT.DRNACL) THEN +C SCASE = 'M3' +C CALL CALCM3 ! CaSO4, NH4CL, MGSO4, NA2SO4, K2SO4, NACL +CC +C ELSEIF (DRNACL.LE.RH .AND. RH.LT.DRNH4Cl) THEN +C SCASE = 'M4' +C CALL CALCM4 ! CaSO4, NH4CL, MGSO4, NA2SO4, K2SO4 +CC +C ELSEIF (DRNH4Cl.LE.RH .AND. RH.LT.DRMGSO4) THEN +C SCASE = 'M5' +C CALL CALCM5 ! CaSO4, MGSO4, NA2SO4, K2SO4 +CC +C ELSEIF (DRMGSO4.LE.RH .AND. RH.LT.DRNA2SO4) THEN +C SCASE = 'M6' +C CALL CALCM6 ! CaSO4, NA2SO4, K2SO4 +CC +C ELSEIF (DRNA2SO4.LE.RH .AND. RH.LT.DRK2SO4) THEN +C SCASE = 'M7' +C CALL CALCM7 ! CaSO4, K2SO4 +CC +C ELSEIF (DRK2SO4.LE.RH) THEN +C SCASE = 'M8' +C CALL CALCM8 ! CaSO4 +C ENDIF +C ENDIF +CC CALL CALCHCO3 +CC +CC *** SULFATE POOR: Rso4>2; (DUST + SODIUM) RICH: R(Cr+Na)>2; DUST POOR: Rcr<2. +CC +C ELSEIF (CRRAT.GT.2.0) THEN +CC +C IF(METSTBL.EQ.1) THEN +C SCASE = 'P13' +C CALL CALCP13 ! Only liquid (metastable) +C ELSE +CC +C IF (RH.LT.DRCACL2) THEN +C SCASE = 'P1' +C CALL CALCP1 ! CaSO4, CA(NO3)2, CACL2, K2SO4, KNO3, KCL, MGSO4, +CC ! MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL +CC +C ELSEIF (DRCACL2.LE.RH .AND. RH.LT.DRMGCL2) THEN +C SCASE = 'P2' +C CALL CALCP2 ! CaSO4, CA(NO3)2, K2SO4, KNO3, KCL, MGSO4, +CC ! MG(NO3)2, MGCL2, NANO3, NACL, NH4NO3, NH4CL +CC +C ELSEIF (DRMGCL2.LE.RH .AND. RH.LT.DRCANO32) THEN +C SCASE = 'P3' +C CALL CALCP3 ! CaSO4, CA(NO3)2, K2SO4, KNO3, KCL, MGSO4, +CC ! MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL +CC +C ELSEIF (DRCANO32.LE.RH .AND. RH.LT.DRMGNO32) THEN +C SCASE = 'P4' +C CALL CALCP4 ! CaSO4, K2SO4, KNO3, KCL, MGSO4, +CC ! MG(NO3)2, NANO3, NACL, NH4NO3, NH4CL +CC +C ELSEIF (DRMGNO32.LE.RH .AND. RH.LT.DRNH4NO3) THEN +C SCASE = 'P5' +C CALL CALCP5 ! CaSO4, K2SO4, KNO3, KCL, MGSO4, +CC ! NANO3, NACL, NH4NO3, NH4CL +CC +C ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNANO3) THEN +C SCASE = 'P6' +C CALL CALCP6 ! CaSO4, K2SO4, KNO3, KCL, MGSO4, NANO3, NACL, NH4CL +CC +C ELSEIF (DRNANO3.LE.RH .AND. RH.LT.DRNACL) THEN +C SCASE = 'P7' +C CALL CALCP7 ! CaSO4, K2SO4, KNO3, KCL, MGSO4, NACL, NH4CL +CC +C ELSEIF (DRNACL.LE.RH .AND. RH.LT.DRNH4CL) THEN +C SCASE = 'P8' +C CALL CALCP8 ! CaSO4, K2SO4, KNO3, KCL, MGSO4, NH4CL +CC +C ELSEIF (DRNH4CL.LE.RH .AND. RH.LT.DRKCL) THEN +C SCASE = 'P9' +C CALL CALCP9 ! CaSO4, K2SO4, KNO3, KCL, MGSO4 +CC +C ELSEIF (DRKCL.LE.RH .AND. RH.LT.DRMGSO4) THEN +C SCASE = 'P10' +C CALL CALCP10 ! CaSO4, K2SO4, KNO3, MGSO4 +CC +C ELSEIF (DRMGSO4.LE.RH .AND. RH.LT.DRKNO3) THEN +C SCASE = 'P11' +C CALL CALCP11 ! CaSO4, K2SO4, KNO3 +CC +C ELSEIF (DRKNO3.LE.RH .AND. RH.LT.DRK2SO4) THEN +C SCASE = 'P12' +C CALL CALCP12 ! CaSO4, K2SO4 +CC +C ELSEIF (DRK2SO4.LE.RH) THEN +C SCASE = 'P13' +C CALL CALCP13 ! CaSO4 +C ENDIF +C ENDIF +CC CALL CALCHCO3 +C ENDIF +CC +CC *** SULFATE RICH (NO ACID): 1 2.0) +C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE +C +C FOR CALCULATIONS, AN ITERATIVE ALGORITHM REDUCES X TO THE ROOT, +C THE AMOUNT OF HYDROGEN IONS (H+) FOUND IN THE LIQUID PHASE. +C FOR EACH ESTIMATION OF H+, FUNCTION FUNCB2A CALCULATES THE +C CONCENTRATION OF IONS FROM THE NH3(GAS) - NH4+(LIQ) EQUILIBRIUM. +C ELECTRONEUTRALITY IS USED AS THE OBJECTIVE FUNCTION. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCA2 + INCLUDE 'isrpia_adj.inc' + REAL*8 :: DELTA +C +C *** SETUP PARAMETERS ************************************************ +C + CALAOU =.TRUE. ! Outer loop activity calculation flag +C UCONLO = TINY ! Low limit: No excess NH3 dissolves +C UCONHI = W(3) - 2.0D0*W(2) ! High limit: All NH3 remaining in gas dissolves +C +C *** CALCULATE WATER CONTENT ***************************************** +C + MOLAL(5) = W(2) + MOLAL(6) = ZERO +C +C CALL CALCMR +C + MOLALR(4) = MOLAL(5)+MOLAL(6) ! (NH4)2SO4 - CORRECT FOR SO4 TO HSO4 +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + WATER = ZERO + DO I=1,NPAIR + WATER = WATER + MOLALR(I)/M0(I) + ENDDO + WATER = MAX(WATER, TINY) +C +C *** CREATE ITERATION FOR ACTIVITY COEFFICIENTS +C + CALL FUNCA2P +C + IF ((MOLAL(1)) > TINY) THEN + CALL CALCHS4 (MOLAL(1), MOLAL(5), ZERO, DELTA) + MOLAL(1) = MOLAL(1) - DELTA ! H+ EFFECT + MOLAL(5) = MOLAL(5) - DELTA ! SO4 EFFECT + MOLAL(6) = DELTA ! HSO4 EFFECT + ENDIF +C + RETURN +C +C *** END OF SUBROUTINE CALCA2H **************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** FUNCTION FUNCA2P +C *** CASE A2 +C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE A2 ; +C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCA2P. +C +C CREATED FOR ANISORROPIA. (slc.5.2010) +C +C======================================================================= +C + SUBROUTINE FUNCA2P + INCLUDE 'isrpia_adj.inc' + REAL*8 :: LAMDA, DISC, SQDR, THRSHHI, THRSHLO + REAL*8 :: NCON, QCON, UCON, UCONOLD + REAL*8 :: W2, W3 + LOGICAL TST, TST2 + INTEGER I +C +C *** SETUP PARAMETERS ************************************************ +C + TST = .TRUE. + TST2 = .TRUE. + FRST = .TRUE. + CALAIN = .TRUE. + W2 = W(2) ! INITIAL AMOUNT OF (NH4)2SO4 IN SOLUTION + W3 = W(3) +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + I=1 + UCON = 0.D0 + DO WHILE ((I <= 14).AND. TST .AND. TST2) + UCONOLD = UCON + A2 = XK2*R*TEMP/XKW*(GAMA(8)/GAMA(9))**2. +C + AA = -A2 + BB = A2*W3 - 2.D0*A2*W2 + 1.d0 + CC = 2.d0*W2 + DISC = BB*BB - 4.D0*AA*CC + SQDR = SQRT(DISC) +C + RT1 = (-BB + SQDR)/2.D0/AA + RT2 = (-BB - SQDR)/2.D0/AA +C + IF ((RT1) < ZERO .AND. (RT2) >= ZERO) THEN + UCON = RT1 + ELSEIF ((RT2) < ZERO .AND. (RT1) >= ZERO) THEN + UCON = RT2 + ELSE + TST2 = .FALSE. + ENDIF +C + QCON = -UCON +C +C *** SPECIATION & WATER CONTENT *************************************** +C + MOLAL (1) = QCON ! HI +C MOLAL (3) = MAX(W(3)/(ONE/A2/OMEGI + ONE), 2.*MOLAL(5)) ! NH4I +C MOLAL (3) = MAX(2.D0*W2 + UCON, TINY) ! NH4I + IF (TINY > (2.D0*W2 + UCON)) THEN + MOLAL(3) = TINY + ELSE + MOLAL(3) = 2.D0*W2 + UCON + ENDIF + MOLAL (5) = W2 ! SO4I + MOLAL (6) = ZERO ! HSO4I +C GNH3 = MAX(W(3)-MOLAL(3), TINY) ! NH3GI + IF (TINY > (W(3)-MOLAL(3))) THEN + GNH3 = TINY + ELSE + GNH3 = W(3)-MOLAL(3) + ENDIF + COH = XKW/QCON ! OHI +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + THRSHLO = UCONOLD - UCONOLD*1.0D-15 + THRSHHI = UCONOLD + UCONOLD*1.0D-15 + IF (((UCON).LE.(THRSHLO)).AND. + & ((UCON).GE.(THRSHHI))) THEN + TST = .FALSE. + CALL CALCACT3F + ELSE + TST = .TRUE. + CALL CALCACT3P + ENDIF + I = I + 1 + + ENDDO ! Iterative solution to the A2 system +C +C *** END OF FUNCTION FUNCA2 ******************************************** +C + END SUBROUTINE FUNCA2P +C + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCB4 +C *** CASE B4 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE +C +C FOR CALCULATIONS, A BISECTION IS PERFORMED WITH RESPECT TO H+. +C THE OBJECTIVE FUNCTION IS THE DIFFERENCE BETWEEN THE ESTIMATED H+ +C AND THAT CALCULATED FROM ELECTRONEUTRALITY. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCB4 + INCLUDE 'isrpia_adj.inc' + REAL*8 :: X,Y, SO4I, HSO4I, BB, CC, DD + REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2) + INTEGER :: I +C +C *** SOLVE EQUATIONS ************************************************** +C + FRST = .TRUE. + CALAIN = .TRUE. + CALAOU = .TRUE. +C +C *** CALCULATE WATER CONTENT ****************************************** +C +C CALL CALCB1A ! GET DRY SALT CONTENT, AND USE FOR WATER. +C +C *** SETUP PARAMETERS ************************************************ +C + X = 2.d0*W(2)-W(3) ! Equivalent NH4HSO4 + Y = W(3)-W(2) ! Equivalent (NH4)2SO4 +C +C *** CALCULATE COMPOSITION ******************************************* +C + IF ((X) <= (Y)) THEN ! LC is the MIN(x,y) + CLC = 2.D0*W(2)-W(3) !X ! NH4HSO4 >= (NH4)2S04 + CNH4HS4 = ZERO + CNH42S4 = 2.D0*W(3) - 3.D0*W(2) !Y-X + ELSE + CLC = W(3)-W(2) !Y ! NH4HSO4 < (NH4)2S04 + CNH4HS4 = 3.D0*W(2) - 2.D0*W(3) !X-Y + CNH42S4 = ZERO + ENDIF +C + MOLALR(13) = CLC + MOLALR(9) = CNH4HS4 + MOLALR(4) = CNH42S4 + CLC = ZERO + CNH4HS4 = ZERO + CNH42S4 = ZERO + WATER = MOLALR(13)/M0(13)+MOLALR(9)/M0(9)+MOLALR(4)/M0(4) +C + MOLAL(3) = W(3) ! NH4I +C + I = 1 + DO WHILE ((I <= NSWEEP).AND.(CALAIN)) + + AK1 = XK1*((GAMA(8)/GAMA(7))**2.)*(WATER/GAMA(7)) + BET = W(2) + GAM = MOLAL(3) +C + BB = BET + AK1 - GAM + CC =-AK1*BET + DD = BB*BB - 4.D0*CC +C +C *** SPECIATION & WATER CONTENT *************************************** +C + MOLAL (5) = MAX(MIN(0.5d0*(-BB + SQRT(DD)), W(2)),TINY) ! SO4I + MOLAL (6) = MAX(MIN(W(2)-MOLAL(5), W(2)), TINY) ! HSO4I + MOLAL (1) = MAX(MIN(AK1*MOLAL(6)/MOLAL(5), W(2)), TINY) ! HI +C +C CALL CALCMR ! Water content +C + SO4I = MOLAL(5)-MOLAL(1) ! CORRECT FOR HSO4 DISSOCIATION + HSO4I = MOLAL(6)+MOLAL(1) + IF ((SO4I) < (HSO4I)) THEN + MOLALR(13) = SO4I ! [LC] = [SO4] + MOLALR(9) = MAX(HSO4I-SO4I, ZERO) ! NH4HSO4 + ELSE + MOLALR(13) = HSO4I ! [LC] = [HSO4] + MOLALR(4) = MAX(SO4I-HSO4I, ZERO) ! (NH4)2SO4 + ENDIF +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + WATER = ZERO + DO J=1,NPAIR + WATER = WATER + MOLALR(J)/M0(J) + ENDDO + WATER = MAX(WATER, TINY) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + I = I + 1 + CALL CALCACT3 + + ENDDO ! Iterative loop for convergence of B4 aerosol system + + IF (CALAIN .AND. (I > (NSWEEP+1))) THEN + CALL PUSHERR (0001, 'CALCB4') ! WARNING ERROR: NO SOLUTION + ENDIF +C +C *** END OF SUBROUTINE CALCB4 ****************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCB4E +C *** CASE E4 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE +C +C FOR CALCULATIONS, A BISECTION IS PERFORMED WITH RESPECT TO H+. +C THE OBJECTIVE FUNCTION IS THE DIFFERENCE BETWEEN THE ESTIMATED H+ +C AND THAT CALCULATED FROM ELECTRONEUTRALITY. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCB4E + INCLUDE 'isrpia_adj.inc' + REAL*8 :: X,Y, SO4I, HSO4I, BB, CC, DD + REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2) + INTEGER :: I +C +C *** SOLVE EQUATIONS ************************************************** +C + FRST = .TRUE. + CALAIN = .TRUE. + CALAOU = .TRUE. +C +C *** CALCULATE WATER CONTENT ****************************************** +C +C CALL CALCB1A ! GET DRY SALT CONTENT, AND USE FOR WATER. +C +C *** SETUP PARAMETERS ************************************************ +C + X = 2.d0*W(2)-W(3) ! Equivalent NH4HSO4 + Y = W(3)-W(2) ! Equivalent (NH4)2SO4 +C +C *** CALCULATE COMPOSITION ******************************************* +C + IF ((X) <= (Y)) THEN ! LC is the MIN(x,y) + CLC = 2.d0*W(2)-W(3) !X ! NH4HSO4 >= (NH4)2S04 + CNH4HS4 = ZERO + CNH42S4 = 2.d0*W(3)-3.d0*W(2) !Y-X + ELSE + CLC = W(3)-W(2) !Y ! NH4HSO4 < (NH4)2S04 + CNH4HS4 = 3.d0*W(2)-2.d0*W(3) !X-Y + CNH42S4 = ZERO + ENDIF +C + MOLALR(13) = CLC + MOLALR(9) = CNH4HS4 + MOLALR(4) = CNH42S4 + CLC = ZERO + CNH4HS4 = ZERO + CNH42S4 = ZERO + WATER = MOLALR(13)/M0(13)+MOLALR(9)/M0(9)+MOLALR(4)/M0(4) +C + MOLAL(3) = W(3) ! NH4I +C + I = 1 + + DO WHILE ((I <= NSWEEP).AND.(CALAIN)) + AK1 = XK1*((GAMA(8)/GAMA(7))**2.d0)*(WATER/GAMA(7)) + BET = W(2) + GAM = MOLAL(3) +C + BB = BET + AK1 - GAM + CC =-AK1*BET + DD = BB*BB - 4.D0*CC +C +C *** SPECIATION & WATER CONTENT *************************************** +C + MOLAL (5) = MAX(MIN(0.5d0*(-BB + SQRT(DD)), W(2)),TINY) ! SO4I + MOLAL (6) = MAX(MIN(W(2)-MOLAL(5), W(2)), TINY) ! HSO4I + MOLAL (1) = MAX(MIN(AK1*MOLAL(6)/MOLAL(5), W(2)), TINY) ! HI +C + SO4I = MOLAL(5)-MOLAL(1) ! CORRECT FOR HSO4 DISSOCIATION as from B4 +C SO4I = MAX(MOLAL(5)-MOLAL(1),ZERO) ! FROM HSO4 DISSOCIATION + HSO4I = MOLAL(6)+MOLAL(1) + IF ((SO4I) < (HSO4I)) THEN + MOLALR(13) = SO4I ! [LC] = [SO4] + MOLALR(9) = MAX(HSO4I-SO4I, ZERO) ! NH4HSO4 + ELSE + MOLALR(13) = HSO4I ! [LC] = [HSO4] + MOLALR(4) = MAX(SO4I-HSO4I, ZERO) ! (NH4)2SO4 + ENDIF +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + WATER = ZERO + DO J=1,NPAIR + WATER = WATER + MOLALR(J)/M0(J) + ENDDO + WATER = MAX(WATER, TINY) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + I = I + 1 + CALL CALCACT3 + + ENDDO ! Iterative loop for E4 aerosol system solution + + IF (CALAIN .AND. (I > (NSWEEP+1))) THEN + CALL PUSHERR (0001, 'CALCB4E') ! WARNING ERROR: NO SOLUTION + ENDIF +C +C *** END OF SUBROUTINE CALCB4E ***************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCC2 +C *** CASE C2 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +C 2. THERE IS ONLY A LIQUID PHASE +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCC2 + INCLUDE 'isrpia_adj.inc' + REAL*8 :: LAMDA, KAPA, PSI, PARM + REAL*8 :: BB, CC + REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2) + INTEGER :: I +C + CALAOU =.TRUE. ! Outer loop activity calculation flag + FRST =.TRUE. + CALAIN =.TRUE. +C +C *** SOLVE EQUATIONS ************************************************** +C + LAMDA = W(3) ! NH4HSO4 INITIALLY IN SOLUTION + PSI = W(2)-W(3) ! H2SO4 IN SOLUTION + I = 1 + + DO WHILE ((I <= NSWEEP).AND.(CALAIN)) + + PARM = WATER*XK1/GAMA(7)*(GAMA(8)/GAMA(7))**2. + BB = PSI+PARM + CC =-PARM*(LAMDA+PSI) + KAPA = 0.5d0*(-BB+SQRT(BB*BB-4.0*CC)) +C +C *** SPECIATION & WATER CONTENT *************************************** +C + MOLAL(1) = PSI+KAPA ! HI + MOLAL(3) = LAMDA ! NH4I + MOLAL(5) = KAPA ! SO4I + MOLAL(6) = MAX(LAMDA+PSI-KAPA, TINY) ! HSO4I + CH2SO4 = MAX(MOLAL(5)+MOLAL(6)-MOLAL(3), ZERO) ! Free H2SO4 +C +C CALL CALCMR ! Water content +C + MOLALR(9) = MOLAL(3) ! NH4HSO4 *** As in ISORROPIA 1.7 + MOLALR(7) = MAX(W(2)-W(3), ZERO) ! H2SO4 + WATER = ZERO + DO J=1,NPAIR + WATER = WATER + MOLALR(J)/M0(J) + ENDDO + WATER = MAX(WATER, TINY) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + I = I + 1 + CALL CALCACT3 + + ENDDO ! Iterative loop for C2 aerosol system + + IF (CALAIN .AND. (I > (NSWEEP+1))) THEN + CALL PUSHERR (0001, 'CALCC2') ! WARNING ERROR: NO SOLUTION + ENDIF +C +C *** END OF SUBROUTINE CALCC2 ***************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCC2F +C *** CASE F2 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +C 2. THERE IS ONLY A LIQUID PHASE +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCC2F + INCLUDE 'isrpia_adj.inc' + REAL*8 :: LAMDA, KAPA, PSI, PARM + REAL*8 :: BB, CC + REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2) + INTEGER :: I +C + CALAOU =.TRUE. ! Outer loop activity calculation flag + FRST =.TRUE. + CALAIN =.TRUE. +C +C *** SOLVE EQUATIONS ************************************************** +C + LAMDA = W(3) ! NH4HSO4 INITIALLY IN SOLUTION + PSI = W(2)-W(3) ! H2SO4 IN SOLUTION + I = 1 + DO WHILE ((I <= NSWEEP).AND.(CALAIN)) + + PARM = WATER*XK1/GAMA(7)*(GAMA(8)/GAMA(7))**2.d0 + BB = PSI+PARM + CC =-PARM*(LAMDA+PSI) + KAPA = 0.5d0*(-BB+SQRT(BB*BB-4.d0*CC)) +C +C *** SPECIATION & WATER CONTENT *************************************** +C + MOLAL(1) = PSI+KAPA ! HI + MOLAL(3) = LAMDA ! NH4I + MOLAL(5) = KAPA ! SO4I + MOLAL(6) = MAX(LAMDA+PSI-KAPA, TINY) ! HSO4I + CH2SO4 = MAX(MOLAL(5)+MOLAL(6)-MOLAL(3), ZERO) ! Free H2SO4 +C +C CALL CALCMR ! Water content +C +C slc.1.2011 - calling CALCMR for case F rather than C +C + MOLALR(9) = MOLAL(3) ! NH4HSO4 - slc.1.2011 - from ISORROPIA 1.7 + MOLALR(7) = MAX(MOLAL(5)+MOLAL(6)-MOLAL(3),ZERO) ! H2SO4 + WATER = ZERO + DO J=1,NPAIR + WATER = WATER + MOLALR(J)/M0(J) + ENDDO + WATER = MAX(WATER, TINY) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + I = I + 1 + CALL CALCACT3 + + ENDDO ! Iterative loop for F2 aerosol system + + IF (CALAIN .AND. (I > (NSWEEP+1))) THEN + CALL PUSHERR (0001, 'CALCC2F') ! WARNING ERROR: NO SOLUTION + ENDIF +C +C *** END OF SUBROUTINE CALCC2F **************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCD3 +C *** CASE D3 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) +C 2. THERE IS OLNY A LIQUID PHASE +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCD3 + INCLUDE 'isrpia_adj.inc' +C + INTEGER :: NDIVOLD + LOGICAL :: CHNDIVF, BISECT, EARLY, REX, LDIFFX + REAL*8 :: X1, X2, Y1, Y2, X3, Y3, YF, YLO + REAL*8 :: THRSH, DIFF, TSTSIGN, PSI4LO, PSI4HI, P4 + REAL*8 :: DIFFX, DIFFXQ + REAL*8 :: FEPS + LOGICAL :: TST1, TST2, TST + CHARACTER(LEN=40) :: ERRINF + INTEGER :: ERRSTKI(25), J, CHECKIT + LOGICAL :: DEXS, IEXS, EOF + CHARACTER(LEN=40) :: ERRMSGI(25) + REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2) +C +C *** FIND DRY COMPOSITION ********************************************** +C + FEPS = 1.d-5 + REX = .FALSE. + CALL CALCD1AL +C +C *** SETUP PARAMETERS ************************************************ +C + CHI1 = CNH4NO3 ! Save from CALCD1 run + CHI2 = CNH42S4 + CHI3 = GHNO3 + CHI4 = GNH3 +C + PSI1 = CNH4NO3 ! ASSIGN INITIAL PSI's + PSI2 = CHI2 + PSI3 = ZERO + PSI4 = ZERO +C + MOLAL(5) = PSI2 ! slc.7.2010 - include dissolved sulfate in initial water calc + MOLAL(6) = ZERO + MOLAL(3) = PSI1 + MOLAL(7) = PSI1 + CALL CALCMR ! Initial water +C + CALAOU = .TRUE. ! Outer loop activity calculation flag + TST1 = .TRUE. + TST2 = .TRUE. + CHECKIT = 1 + PSI4LO = TINY ! Low limit + PSI4HI = CHI4 ! High limit +C +C *** INITIAL VALUES FOR BISECTION ************************************ +C +60 X1 = PSI4LO + CALL RSTGAMP + CALL FUNCD3 (X1, Y1) + IF (ABS(Y1) <= (EPS)) THEN + X3 = X1 + GOTO 50 + ENDIF + YLO = Y1 ! Save Y-value at HI position +C +C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +C + DX = (PSI4HI-PSI4LO)/FLOAT(NDIV) + X2 = X1 + Y2 = Y1 + I = 1 + DO WHILE ((I <= NDIV) .AND. TST1) + X1 = X2 + Y1 = Y2 + X2 = X1+DX + CALL FUNCD3 (X2, Y2) +C IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2) < ZERO) THEN + IF (((Y1) < ZERO) .AND. ((Y2) > ZERO)) THEN + TST1 = .FALSE.! (Y1*Y2 < ZERO) + ENDIF + I = I + 1 + ENDDO + IF (.NOT.TST1) GOTO 20 +C +C *** NO SUBDIVISION WITH SOLUTION FOUND +C + YHI= Y1 ! Save Y-value at Hi position + IF (ABS(Y2) < EPS) THEN ! X2 IS A SOLUTION + X3 = X2 + Y3 = Y2 + GOTO 50 +C +C *** { YLO, YHI } < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NH3 +C Physically I dont know when this might happen, but I have put this +C branch in for completeness. I assume there is no solution; all NO3 goes to the +C gas phase. +C + ELSE IF ((YLO) < ZERO .AND. (YHI) < ZERO) THEN + P4 = TINY ! PSI4LO ! CHI4 + CALL RSTGAMP + CALL FUNCD3(P4, Y3) + X3 = P4 + GOTO 50 +C +C *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NH3 +C This happens when Sul.Rat. = 2.0, so some NH4+ from sulfate evaporates +C and goes to the gas phase ; so I redefine the LO and HI limits of PSI4 +C and proceed again with root tracking. +C + ELSE IF ((YLO) > ZERO .AND. (YHI) > ZERO) THEN + PSI4HI = PSI4LO + PSI4LO = PSI4LO - 0.1*(PSI1+PSI2) ! No solution; some NH3 evaporates + IF ((PSI4LO) < (-1.D0*(PSI1+PSI2))) THEN +C WRITE(*,*) 'Error' + CALL PUSHERR (0001, 'CALCD3') ! WARNING ERROR: NO SOLUTION + RETURN + ELSE + MOLAL(5) = PSI2 ! so4 included in water calc + MOLAL(6) = ZERO + MOLAL(3) = PSI1 + MOLAL(7) = PSI1 + CALL CALCMR ! Initial water +C WRITE(*,*) 'Re-executing' + IF ( CHECKIT .LT. 15 ) THEN + REX = .TRUE. + CHECKIT = CHECKIT + 1 + GOTO 60 ! Redo root tracking + ELSE + CALL PUSHERR (0002, 'CALCD3') ! WARNING ERROR: NO CONVERGENCE + GOTO 50 + ENDIF + ENDIF + ENDIF +C +C *** PERFORM BISECTION *********************************************** +C +20 I = 1 + TST2 = .TRUE. + Y3 = Y2 + DO WHILE ((I <= MAXIT) .AND. TST2) + X3 = 0.5*(X1+X2) + CALL RSTGAMP + CALL FUNCD3 (X3,Y3) + IF (SIGN(1.d0,(Y1))*SIGN(1.d0,(Y3)) <= ZERO) THEN ! (Y1*Y3 <= ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF ((ABS(X2-X1) <= EPS*ABS(X1)) .AND. + & (ABS(Y3) < FEPS)) THEN + TST2 = .FALSE. + ENDIF +C WRITE(*, '(A,E12.5,A,E12.5)') 'In loop: X3',(X3),'Y3',(Y3) + I = I + 1 + ENDDO + + IF ((I > MAXIT+1) .AND. TST2) THEN + CALL PUSHERR (0002, 'CALCD3') ! WARNING ERROR: NO CONVERGENCE + ENDIF +C +C *** CONVERGED ; RETURN ********************************************** +C + X3 = 0.5*(X1+X2) + CALL RSTGAMP + CALL FUNCD3 (X3, Y3) +C +50 CONTINUE +C IF (ABS(Y3) > FEPS) THEN +C WRITE(ERRINF, '(A,E12.5,A)') 'CALCD3 (',(Y3),')' +C CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE +C RETURN +C ENDIF +C + CALL FUNCD3P(X3,YF) ! Execute Newton-Raphson for adjoint +C + RETURN +C +C *** END OF SUBROUTINE CALCD3 ****************************************** +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCD3 +C *** CASE D3 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) +C 2. THERE IS OLNY A LIQUID PHASE +C +C CREATED FOR ANISORROPIA. (slc.8.2010) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCD3_B(wpb, gasb, aerliqb) + INCLUDE 'isrpia_adj.inc' +C + INTEGER :: NDIVOLD + LOGICAL :: CHNDIVF, BISECT, EARLY, REX, LDIFFX + REAL*8 :: X1, X2, Y1, Y2, X3, Y3, YF, YLO + REAL*8 :: THRSH, DIFF, TSTSIGN, PSI4LO, PSI4HI, P4 + REAL*8 :: DIFFX, DIFFXQ + REAL*8 :: FEPS + LOGICAL :: TST1, TST2, TST + CHARACTER(LEN=40) :: ERRINF + INTEGER :: ERRSTKI(25), J, CHECKIT + LOGICAL :: DEXS, IEXS, EOF + CHARACTER(LEN=40) :: ERRMSGI(25) + REAL*8 :: WP(NCOMP), GAS(3), AERLIQ(NIONS+NGASAQ+2) + REAL*8 :: WPB(NCOMP), GASB(3), AERLIQB(NIONS+NGASAQ+2) + REAL*8 :: WPDB(NCOMP), GASDB(3), AERLIQDB(NIONS+NGASAQ+2) +C +C *** FIND DRY COMPOSITION ********************************************** +C + !WRITE(*,*) 'CALCD3, NDIV: ',NDIV + FEPS = 1d-5 + REX = .FALSE. + CALL CALCD1AL +C +C *** SETUP PARAMETERS ************************************************ +C + CHI1 = CNH4NO3 ! Save from CALCD1 run + CHI2 = CNH42S4 + CHI3 = GHNO3 + CHI4 = GNH3 +C + PSI1 = CNH4NO3 ! ASSIGN INITIAL PSI's + PSI2 = CHI2 + PSI3 = ZERO + PSI4 = ZERO +C + MOLAL(5) = PSI2 ! sc.7.2010 - include dissolved sulfate in initial water calc + MOLAL(6) = ZERO + MOLAL(3) = PSI1 + MOLAL(7) = PSI1 + CALL CALCMR ! Initial water +C + CALAOU = .TRUE. ! Outer loop activity calculation flag + TST1 = .TRUE. + TST2 = .TRUE. + CHECKIT = 1 + PSI4LO = TINY ! Low limit + PSI4HI = CHI4 ! High limit +C +C *** INITIAL VALUES FOR BISECTION ************************************ +C +60 X1 = PSI4LO + CALL RSTGAMP + CALL FUNCD3 (X1, Y1) + IF (ABS(Y1) <= (EPS)) THEN + X3 = X1 + GOTO 50 + ENDIF + YLO = Y1 ! Save Y-value at HI position +C +C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +C + DX = (PSI4HI-PSI4LO)/FLOAT(NDIV) + X2 = X1 + Y2 = Y1 + I = 1 + DO WHILE ((I <= NDIV) .AND. TST1) + X1 = X2 + Y1 = Y2 + X2 = X1+DX + CALL FUNCD3 (X2, Y2) +C IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2) < ZERO) THEN + IF (((Y1) < ZERO) .AND. ((Y2) > ZERO)) THEN + TST1 = .FALSE.! (Y1*Y2 < ZERO) + ENDIF + I = I + 1 + ENDDO + IF (.NOT.TST1) GOTO 20 +C +C *** NO SUBDIVISION WITH SOLUTION FOUND +C + YHI= Y1 ! Save Y-value at Hi position + IF (ABS(Y2) < EPS) THEN ! X2 IS A SOLUTION + X3 = X2 + Y3 = Y2 + GOTO 50 +C +C *** { YLO, YHI } < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NH3 +C Physically I dont know when this might happen, but I have put this +C branch in for completeness. I assume there is no solution; all NO3 goes to the +C gas phase. +C + ELSE IF ((YLO) < ZERO .AND. (YHI) < ZERO) THEN + P4 = TINY ! PSI4LO ! CHI4 + CALL RSTGAMP + CALL FUNCD3(P4, Y3) + X3 = P4 + GOTO 50 +C +C *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NH3 +C This happens when Sul.Rat. = 2.0, so some NH4+ from sulfate evaporates +C and goes to the gas phase ; so I redefine the LO and HI limits of PSI4 +C and proceed again with root tracking. +C + ELSE IF ((YLO) > ZERO .AND. (YHI) > ZERO) THEN + PSI4HI = PSI4LO + PSI4LO = PSI4LO - 0.1*(PSI1+PSI2) ! No solution; some NH3 evaporates + IF ((PSI4LO) < (-1.D0*(PSI1+PSI2))) THEN +C WRITE(*,*) 'Error' + CALL PUSHERR (0001, 'CALCD3') ! WARNING ERROR: NO SOLUTION + RETURN + ELSE + MOLAL(5) = PSI2 ! so4 included in water calc + MOLAL(6) = ZERO + MOLAL(3) = PSI1 + MOLAL(7) = PSI1 + CALL CALCMR ! Initial water + IF ( CHECKIT .LT. 15 ) THEN + REX = .TRUE. + CHECKIT = CHECKIT + 1 + GOTO 60 ! Redo root tracking + ELSE + CALL PUSHERR (0002, 'CALCD3') ! WARNING ERROR: NO CONVERGENCE + GOTO 50 + ENDIF + ENDIF + ENDIF +C +C *** PERFORM BISECTION *********************************************** +C +20 I = 1 + TST2 = .TRUE. + Y3 = Y2 + DO WHILE ((I <= MAXIT) .AND. TST2) + X3 = 0.5d0*(X1+X2) + CALL RSTGAMP + CALL FUNCD3 (X3,Y3) + IF (SIGN(1.d0,(Y1))*SIGN(1.d0,(Y3)) <= ZERO) THEN ! (Y1*Y3 <= ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF ((ABS(X2-X1) <= EPS*ABS(X1)) .AND. + + (ABS(Y3) < FEPS)) THEN + TST2 = .FALSE. + ENDIF + I = I + 1 + ENDDO + + IF ((I > MAXIT+1) .AND. TST2) THEN + CALL PUSHERR (0002, 'CALCD3') ! WARNING ERROR: NO CONVERGENCE + ENDIF +C +C *** CONVERGED ; RETURN ********************************************** +C + X3 = 0.5*(X1+X2) + CALL RSTGAMP + CALL FUNCD3 (X3, Y3) +C +50 CONTINUE +C IF (ABS(Y3) > FEPS) THEN +C WRITE(ERRINF, '(A,E12.5,A)') 'CALCD3 (',(Y3),')' +C CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE +C RETURN +C ENDIF +C + CALL FUNCD3P_DB(x3, y1, wpdb, gasb, aerliqb) +C + RETURN +C +C *** END OF SUBROUTINE CALCD3 ****************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** FUNCTION FUNCD3 +C *** CASE D3 +C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ; +C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3. +C +C======================================================================= +C + SUBROUTINE FUNCD3(P4, FD3) + INCLUDE 'isrpia_adj.inc' +C + LOGICAL :: TST + REAL*8 :: GMAX, GTHRESH, P4, FD3, BB, DENM + INTEGER :: I +C +C *** SETUP PARAMETERS ************************************************ +C + FRST = .TRUE. + CALAIN = .TRUE. + TST = .TRUE. + PSI4 = P4 + I = 1 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + DO WHILE ((I <= NSWEEP) .AND. TST) +C + IF (I > 1) CALL CALCACT3 +C + A2 = XK7*(WATER/GAMA(4))**3.0 + A3 = XK4*R*TEMP*(WATER/GAMA(10))**2.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A7 = XKW *RH*WATER*WATER +C + PSI3 = A3*A4*CHI3*(CHI4-PSI4) - PSI1*(2.D0*PSI2+PSI1+PSI4) + PSI3 = PSI3/(A3*A4*(CHI4-PSI4) + 2.D0*PSI2+PSI1+PSI4) + PSI3 = MIN(MAX(PSI3, ZERO), CHI3) +C + BB = PSI4 - PSI3 + + DENM = BB+SQRT(BB*BB + 4.d0*A7) + IF ((DENM) <= TINY) THEN ! Avoid overflow when HI->0 + ABB = ABS(BB) + DENM = BB + ABB + 2.0*A7/ABB - (2.0*A7*A7)/ABB**3.0 ! Taylor expansion of SQRT + ENDIF + AHI = 2.0*A7/DENM +C +C *** SPECIATION & WATER CONTENT *************************************** +C + MOLAL (1) = AHI ! HI + MOLAL (3) = PSI1 + PSI4 + 2.D0*PSI2 ! NH4I + MOLAL (5) = PSI2 ! SO4I + MOLAL (6) = ZERO ! HSO4I + MOLAL (7) = PSI3 + PSI1 ! NO3I + CNH42S4 = CHI2 - PSI2 ! Solid (NH4)2SO4 + CNH4NO3 = ZERO ! Solid NH4NO3 + GHNO3 = CHI3 - PSI3 ! Gas HNO3 + GNH3 = CHI4 - PSI4 ! Gas NH3 + CALL CALCMR ! Water content +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + TST = .TRUE. + ELSE + TST = .FALSE. + ENDIF + I = I+1 + ENDDO +C +C *** CALCULATE OBJECTIVE FUNCTION ************************************ +C +CCC FUNCD3= NH4I/HI/MAXCOMP(GNH3,TINY)/A4 - ONE + FD3= MOLAL(3)/MOLAL(1)/MAX(GNH3,TINY)/A4 - ONE + + RETURN +C +C *** END OF FUNCTION FUNCD3 ******************************************** +C + END +C======================================================================= +C +C *** ISORROPIA CODE +C *** FUNCTION FUNCD3P +C *** CASE D3 +C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ; +C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3. +C +C CREATED FOR ANISORROPIA. (slc.8.2010) +C NEWTON-RAPHSON SOLUTION ABOUT THE ROOT. +C +C======================================================================= +C + SUBROUTINE FUNCD3P (P4, Y1) + INCLUDE 'isrpia_adj.inc' + + REAL*8 :: P4, Y1, PARM, X + REAL*8 :: X1, X2, XT, Y1D, Y2, XTD + REAL*8 :: OMPS, DIAK, DELTA + CHARACTER(LEN=40) :: ERRINF + INTEGER :: ERRSTKI(25) + LOGICAL :: DEXS, IEXS, EOF + REAL*8 :: OM, PS, ZE, FEPS + CHARACTER(LEN=40) :: ERRMSGI(25) +C +C *** SETUP PARAMETERS ************************************************ +C + FEPS = 1.D-5 + PARM = XK10/(R*TEMP)/(R*TEMP) +C +C *** CALCULATE NH4NO3 THAT VOLATIZES ********************************* +C + CNH42S4 = W(2) + X = MIN(W(3)-2.d0*W(2), W(4)) + IF ((X) > ZERO) THEN + IF (((W(3) - 2.0*W(2))) < (W(4))) THEN + PS = ZERO + OM = W(4) - W(3) + 2.0*W(2) + IF ((OM) < TINY) THEN + OM = ZERO + ENDIF + ELSE + PS = W(3) - W(4) - 2.0*W(2) + IF ((PS) < TINY) THEN + PS = ZERO + ENDIF + OM = ZERO + ENDIF + ELSE + X = ZERO + PS = MAX(W(3) - 2.d0*W(2), ZERO) + IF ((PS) < TINY) THEN + PS = ZERO + ENDIF + OM = W(4) + ENDIF +C + OMPS = OM+PS + DIAK = SQRT(OMPS*OMPS + 4.0*PARM) ! DIAKRINOUSA + ZE = MIN(X, 0.5*(-OMPS + DIAK)) ! THETIKI RIZA +C +C *** SPECIATION ******************************************************* +C + CNH4NO3 = X - ZE ! Solid NH4NO3 + GNH3 = PS + ZE ! Gas NH3 + GHNO3 = OM + ZE ! Gas HNO3 +C + CHI1 = CNH4NO3 ! Save from CALCD1 run + CHI2 = CNH42S4 + CHI3 = GHNO3 + CHI4 = GNH3 +C + PSI1 = CNH4NO3 ! ASSIGN INITIAL PSI's + PSI2 = CHI2 + PSI3 = ZERO + PSI4 = P4 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C +C +C *** NEWTON-RAPHSON DETERMINATION OF ROOT ********************** +C + XT = PSI4 + XTD = 1.D0 + + CALL FUNCD3B_DNRD(XT, XTD, Y1, Y1D) + X2 = XT - (Y1/(Y1D*1.d0)) + CALL FUNCD3B(X2,Y2) + + IF (abs(Y2) > 10.d0*FEPS) THEN + WRITE(ERRINF, '(A,E12.5,A)') 'CALCD3 (',(Y2),')' + CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE + RETURN + ENDIF +C + IF ((MOLAL(1)) > TINY .AND. (MOLAL(5)) > TINY) THEN + CALL CALCHS4 (MOLAL(1), MOLAL(5), ZERO, DELTA) + MOLAL(1) = MOLAL(1) - DELTA ! H+ EFFECT + MOLAL(5) = MOLAL(5) - DELTA ! SO4 EFFECT + MOLAL(6) = DELTA ! HSO4 EFFECT + ENDIF +C + RETURN +C +C *** END OF FUNCTION FUNCD3P ******************************************* +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** FUNCTION FUNCD3 +C *** CASE D3 +C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ; +C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3. +C +C======================================================================= +C + SUBROUTINE FUNCD3B (P4,FD3B) + INCLUDE 'isrpia_adj.inc' + + REAL*8 :: WP(NCOMP), MOLALP(NIONS) + REAL*8 :: P4, BB, DENM, AHI, AML5, FD3B + CHARACTER(LEN=40) :: ERRINF + INTEGER :: ERRSTKI(25), K, J + LOGICAL :: DEXS, IEXS, EOF + CHARACTER(LEN=40) :: ERRMSGI(25) + LOGICAL :: TST +C +C *** SETUP PARAMETERS ************************************************ +C + PSI4 = P4 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + DO I = 1,3 +C + A2 = XK7*(WATER/GAMA(4))**3.0 + A3 = XK4*R*TEMP*(WATER/GAMA(10))**2.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A7 = XKW *RH*WATER*WATER +C + PSI3 = A3*A4*CHI3*(CHI4-PSI4) - PSI1*(2.D0*PSI2+PSI1+PSI4) + PSI3 = PSI3/(A3*A4*(CHI4-PSI4) + 2.D0*PSI2+PSI1+PSI4) + PSI3 = MIN(MAX(PSI3, ZERO), CHI3) +C + BB = PSI4 - PSI3 + DENM = BB+SQRT(BB*BB + 4.d0*A7) + IF ((DENM) <= TINY) THEN ! Avoid overflow when HI->0 + ABB = ABS(BB) + DENM = BB + ABB + 2.d0*A7/ABB - (2.d0*A7*A7)/ABB**3.d0 ! Taylor expansion of SQRT + ENDIF + AHI = 2.d0*A7/DENM +C +C *** SPECIATION & WATER CONTENT *************************************** +C + MOLAL (1) = AHI ! HI + MOLAL (3) = PSI1 + PSI4 + 2.D0*PSI2 ! NH4I + MOLAL (5) = PSI2 ! SO4I + MOLAL (6) = ZERO ! HSO4I + MOLAL (7) = PSI3 + PSI1 ! NO3I + CNH42S4 = CHI2 - PSI2 ! Solid (NH4)2SO4 + CNH4NO3 = ZERO ! Solid NH4NO3 + GHNO3 = CHI3 - PSI3 ! Gas HNO3 + GNH3 = CHI4 - PSI4 ! Gas NH3 +C +C CALL CALCMR ! Water content +C + MOLALR(4) = MOLAL(5) + MOLAL(6) ! (NH4)2SO4 + AML5 = MOLAL(3)-2.D0*MOLALR(4) ! "free" NH4 + MOLALR(5) = MAX(MIN(AML5,MOLAL(7)), ZERO) ! NH4NO3 = MIN("free", NO3) +C +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + WATER = ZERO + DO J=1,NPAIR + WATER = WATER + MOLALR(J)/M0(J) + ENDDO + WATER = MAX(WATER, TINY) +C + CALL CALCACT3F + ENDDO +C +C *** CALCULATE OBJECTIVE FUNCTION ************************************ +C +CCC FUNCD3= NH4I/HI/MAX(GNH3,TINY)/A4 - ONE + FD3B = MOLAL(3)/MOLAL(1)/MAX(GNH3,TINY)/A4 - ONE + RETURN +C +C *** END OF FUNCTION FUNCD3P ******************************************* +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCD1A +C *** CASE D1 ; SUBCASE 1 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) +C 2. SOLID AEROSOL ONLY +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4NO3 +C +C THE SOLID (NH4)2SO4 IS CALCULATED FROM THE SULFATES, WHILE NH4NO3 +C IS CALCULATED FROM NH3-HNO3 EQUILIBRIUM. 'ZE' IS THE AMOUNT OF +C NH4NO3 THAT VOLATIZES WHEN ALL POSSILBE NH4NO3 IS INITIALLY IN +C THE SOLID PHASE. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCD1A + INCLUDE 'isrpia_adj.inc' + REAL*8 :: PARM, PS, OM, OMPS, DIAK, ZE, X +C +C *** SETUP PARAMETERS ************************************************ +C + PARM = XK10/(R*TEMP)/(R*TEMP) +C +C *** CALCULATE NH4NO3 THAT VOLATIZES ********************************* +C + CNH42S4 = W(2) + X = MAX(MIN(W(3)-2.d0*CNH42S4, W(4)), ZERO) ! MAX NH4NO3 + PS = MAX(W(3) - X - 2.d0*CNH42S4, ZERO) + OM = MAX(W(4) - X, ZERO) +C + OMPS = OM+PS + DIAK = SQRT(OMPS*OMPS + 4.0*PARM) ! DIAKRINOUSA + ZE = MIN(X, 0.5*(-OMPS + DIAK)) ! THETIKI RIZA +C +C *** SPECIATION ******************************************************* +C + CNH4NO3 = X - ZE ! Solid NH4NO3 + GNH3 = PS + ZE ! Gas NH3 + GHNO3 = OM + ZE ! Gas HNO3 +C +C PAUSE + RETURN +C +C *** END OF SUBROUTINE CALCD1A ***************************************** +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCD1AL +C *** CASE D1 ; SUBCASE 1 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) +C 2. SOLID AEROSOL ONLY +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4NO3 +C +C THE SOLID (NH4)2SO4 IS CALCULATED FROM THE SULFATES, WHILE NH4NO3 +C IS CALCULATED FROM NH3-HNO3 EQUILIBRIUM. 'ZE' IS THE AMOUNT OF +C NH4NO3 THAT VOLATIZES WHEN ALL POSSILBE NH4NO3 IS INITIALLY IN +C THE SOLID PHASE. +C +C CREATED FOR ANISORROPIA. (slc.8.2010) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCD1AL + INCLUDE 'isrpia_adj.inc' + REAL*8 :: PARM, PS, OM, OMPS, DIAK, ZE, X +C +C *** SETUP PARAMETERS ************************************************ +C + PARM = XK10/(R*TEMP)/(R*TEMP) +C +C *** CALCULATE NH4NO3 THAT VOLATIZES ********************************* +C + CNH42S4 = W(2) + X = MIN(W(3)-2.d0*W(2), W(4)) + IF ((X) > ZERO) THEN + IF ((W(3) - 2.d0*W(2)) < (W(4))) THEN + PS = ZERO + OM = W(4) - W(3) + 2.d0*W(2) + IF ((OM) < TINY) THEN + OM = ZERO + ENDIF + ELSE + PS = W(3) - W(4) - 2.d0*W(2) + IF ((PS) < TINY) THEN + PS = ZERO + ENDIF + OM = ZERO + ENDIF + ELSE + X = ZERO + PS = MAX(W(3) - 2.d0*W(2), ZERO) + IF ((PS) < TINY) THEN + PS = ZERO + ENDIF + OM = W(4) + ENDIF +C + OMPS = OM+PS + DIAK = SQRT(OMPS*OMPS + 4.d0*PARM) ! DIAKRINOUSA + ZE = MIN(X, 0.5d0*(-OMPS + DIAK)) ! THETIKI RIZA +C +C *** SPECIATION ******************************************************* +C + CNH4NO3 = X - ZE ! Solid NH4NO3 + GNH3 = PS + ZE ! Gas NH3 + GHNO3 = OM + ZE ! Gas HNO3 +C + RETURN +C +C *** END OF SUBROUTINE CALCD1A ***************************************** +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCG5 +C *** CASE G5 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCG5 + INCLUDE 'isrpia_adj.inc' +C + LOGICAL :: TST1, TST2 + INTEGER :: I + CHARACTER(LEN=40) :: ERRINF + INTEGER :: ERRSTKI(25) + CHARACTER(LEN=40) :: ERRMSGI(25) + REAL*8 :: AERLIQ(NIONS+NGASAQ+2), GAS(3) + REAL*8 :: WP(NCOMP) + REAL*8 :: LAMDA, FEPS +C +C *** SETUP PARAMETERS ************************************************ +C + FEPS = 1.D-5 + CALAOU = .TRUE. + CHI1 = 0.5d0*W(1) + CHI2 = MAX (W(2)-0.5d0*W(1), ZERO) + CHI3 = ZERO + CHI4 = MAX (W(3)-2.D0*CHI2, ZERO) + CHI5 = W(4) + CHI6 = W(5) +C + PSI1 = CHI1 + PSI2 = CHI2 + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +C + WATER = CHI2/M0(4) + CHI1/M0(2) +C +C *** INITIAL VALUES FOR BISECTION ************************************ +C + X1 = PSI6LO + CALL FUNCG5A (X1, Y1) + IF (CHI6 <= TINY) THEN + X3 = X1 + Y3 = Y1 + GOTO 50 + ENDIF +ccc IF (ABS(Y1) <= EPS .OR. CHI6 <= TINY) GOTO 50 +ccc IF (WATER <= TINY) RETURN ! No water +C +C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +C + DX = (PSI6HI-PSI6LO)/FLOAT(NDIV) + X2 = X1 + Y2 = Y1 + I = 1 + TST1 = .TRUE. + + DO WHILE ((I <= NDIV) .AND. TST1) + X1 = X2 + Y1 = Y2 + X2 = X1+DX + CALL FUNCG5A (X2, Y2) + IF ((Y1 < ZERO) .AND. (Y2 > ZERO)) THEN + TST1 = .FALSE.! (Y1*Y2 < ZERO) + ENDIF + I = I+1 + ENDDO +C +C *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) EPS).AND.TST1.AND.(I > NDIV+1)) THEN + CALL RSTGAMP + CALL FUNCG5A (PSI6LO, Y3) + X3 = PSI6LO + CALL PUSHERR (0002, 'CALCG5') ! WARNING ERROR: NO CONVERGENCE + GOTO 50 + ENDIF +C +C *** PERFORM BISECTION *********************************************** +C + I = 1 + TST2 = .TRUE. + DO WHILE ((I <= MAXIT).AND.TST2) + X3 = 0.5*(X1+X2) + CALL RSTGAMP + CALL FUNCG5A (X3, Y3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) <= ZERO) THEN ! (Y1*Y3 <= ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) <= EPS*X1 .AND. (ABS(Y3) < FEPS)) THEN + TST2 = .FALSE. !GOTO 40 + ENDIF + I = I+1 + ENDDO + IF ((I > (MAXIT+1)) .AND. TST2) THEN + CALL PUSHERR (0002, 'CALCG5') ! WARNING ERROR: NO CONVERGENCE + ENDIF +C +C *** CONVERGED ; RETURN ********************************************** +C + X3 = 0.5*(X1+X2) + CALL RSTGAMP + CALL FUNCG5A (X3, Y3) +C +C *** CALCULATE HSO4 SPECIATION AND RETURN ******************************* +C +50 CONTINUE + +C *** Execute differentiable Newtons function once *********************** + +! * slc.11.2011 - commenting since error does not prevent call of FUNCG5AP_GB +! +! IF (ABS(Y3) > FEPS) THEN +! WRITE(ERRINF, '(A,E12.5,A)') 'CALCG5 (',Y3,')' +! CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE +! WRITE(*,*) 'CALCG5 - Err 104: ',Y3 +! ENDIF +C + CALL FUNCG5AP(X3) +C + RETURN +C +C *** END OF SUBROUTINE CALCG5 ******************************************* +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCG5 +C *** CASE G5 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCG5_B(wpb, gasb, aerliqb) + INCLUDE 'isrpia_adj.inc' +C + LOGICAL :: TST1, TST2 + INTEGER :: I + CHARACTER(LEN=40) :: ERRINF + INTEGER :: ERRSTKI(25) + CHARACTER(LEN=40) :: ERRMSGI(25) + REAL*8 :: AERLIQ(NIONS+NGASAQ+2), GAS(3), WP(NCOMP) + REAL*8 :: LAMDA, wpb(ncomp) + REAL*8 :: gasb(ngasaq), aerliqb(nions+ngasaq+2) +C +C *** SETUP PARAMETERS ************************************************ +C + FEPS = 1.d-5 + CALAOU = .TRUE. + CHI1 = 0.5d0*W(1) + CHI2 = MAX (W(2)-0.5d0*W(1), ZERO) + CHI3 = ZERO + CHI4 = MAX (W(3)-2.D0*CHI2, ZERO) + CHI5 = W(4) + CHI6 = W(5) +C + PSI1 = CHI1 + PSI2 = CHI2 + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +C + WATER = CHI2/M0(4) + CHI1/M0(2) +C +C *** INITIAL VALUES FOR BISECTION ************************************ +C + X1 = PSI6LO + CALL FUNCG5A (X1, Y1) + IF (CHI6 <= TINY) THEN + X3 = X1 + Y3 = Y1 + GOTO 50 + ENDIF +ccc IF (ABS(Y1) <= EPS .OR. CHI6 <= TINY) GOTO 50 +ccc IF (WATER <= TINY) RETURN ! No water +C +C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +C + DX = (PSI6HI-PSI6LO)/FLOAT(NDIV) + X2 = X1 + Y2 = Y1 + I = 1 + TST1 = .TRUE. + + DO WHILE ((I <= NDIV) .AND. TST1) + X1 = X2 + Y1 = Y2 + X2 = X1+DX + CALL FUNCG5A (X2, Y2) + IF ((Y1 < ZERO) .AND. (Y2 > ZERO)) THEN + TST1 = .FALSE.! (Y1*Y2 < ZERO) + ENDIF + I = I+1 + ENDDO +C +C *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) EPS).AND.TST1.AND.(I > NDIV+1)) THEN + CALL RSTGAMP + CALL FUNCG5A (PSI6LO, Y3) + X3 = PSI6LO + CALL PUSHERR (0002, 'CALCG5') ! WARNING ERROR: NO CONVERGENCE + GOTO 50 + ENDIF +C +C *** PERFORM BISECTION *********************************************** +C + I = 1 + TST2 = .TRUE. + FEPS = 1.D-5 + DO WHILE ((I <= MAXIT).AND.TST2) + X3 = 0.5d0*(X1+X2) + CALL RSTGAMP + CALL FUNCG5A (X3, Y3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) <= ZERO) THEN ! (Y1*Y3 <= ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) <= EPS*X1 .AND. (ABS(Y3) < FEPS)) THEN + TST2 = .FALSE. !GOTO 40 + ENDIF + I = I+1 + ENDDO + + IF ((I > (MAXIT+1)) .AND. TST2) THEN + CALL PUSHERR (0002, 'CALCG5') ! WARNING ERROR: NO CONVERGENCE + ENDIF +C +C *** CONVERGED ; RETURN ********************************************** +C + X3 = 0.5d0*(X1+X2) + CALL RSTGAMP + CALL FUNCG5A (X3, Y3) +C +C *** CALCULATE HSO4 SPECIATION AND RETURN ******************************* +C +50 CONTINUE + +C *** Execute differentiable Newton's function once *********************** + +! * slc.11.2011 - commenting since error does not prevent call of FUNCG5AP_GB +! +! IF (ABS(Y3) > FEPS) THEN +! WRITE(ERRINF, '(A,E12.5,A)') 'CALCG5 (',Y3,')' +! CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE +! WRITE(*,*) 'W: ',W +! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP +! WRITE(*,*) 'CALCG5_B, before NR - Err 104: ',Y3 +! ENDIF +C + CALL FUNCG5AP_GB(x3, wpb, gasb, aerliqb) +C + RETURN +C +C *** END OF SUBROUTINE CALCG5 ******************************************* +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCG5A +C *** CASE G5 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCG5A (X, FG5A) + INCLUDE 'isrpia_adj.inc' +C + LOGICAL :: TST + INTEGER :: SO4FLG + REAL*8 :: LAMDA, FG5A +C +C *** SETUP PARAMETERS ************************************************ +C + PSI6 = X + I = 1 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + TST = .TRUE. + DO WHILE ((I <= NSWEEP).AND. TST) +C + A1 = XK5 *(WATER/GAMA(2))**3.0 + A2 = XK7 *(WATER/GAMA(4))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 + AKK = A4*A6 +C +C CALCULATE DISSOCIATION QUANTITIES +C + IF (CHI5 >= TINY) THEN + PSI5 = PSI6*CHI5/(A6/A5*(CHI6-PSI6) + PSI6) + ELSE + PSI5 = TINY + ENDIF +C +CCC IF(CHI4 > TINY) THEN + IF(W(2) > TINY) THEN ! Accounts for NH3 evaporation + BB =-(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) - 2.d0*PSI2/A4 + DD = MAX(BB*BB-4.d0*CC,ZERO) ! Patch proposed by Uma Shankar, 19/11/01 + PSI4 =0.5d0*(-BB - SQRT(DD)) + ELSE + PSI4 = TINY + ENDIF +C +C *** CALCULATE SPECIATION ******************************************** +C + MOLAL (2) = W(1) ! NAI +C MOLAL (3) = 2.0*PSI2 + PSI4 ! NH4I + MOLAL (4) = PSI6 ! CLI + IF (W(2)-0.5d0*W(1) > ZERO) THEN + MOLAL(3) = 2.d0*W(2) - W(1) + PSI4 + MOLAL(5) = W(2) ! SO4I + ELSE + MOLAL(3) = PSI4 + MOLAL(5) = 0.5d0*W(1) ! SO4I + ENDIF + MOLAL (6) = ZERO + MOLAL (7) = PSI5 ! NO3I +C +C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + SMIN = PSI5 + PSI6 - PSI4 + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +C + GNH3 = MAX(CHI4 - PSI4, TINY) ! Gas NH3 + GHNO3 = MAX(CHI5 - PSI5, TINY) ! Gas HNO3 + GHCL = MAX(CHI6 - PSI6, TINY) ! Gas HCl +C + CNH42S4 = ZERO ! Solid (NH4)2SO4 + CNH4NO3 = ZERO ! Solid NH4NO3 + CNH4CL = ZERO ! Solid NH4Cl +C +C CALL CALCMR ! Water content +C +C WRITE(*,*) 'MOLAL ',MOLAL + MOLALR(2) = 0.5d0*W(1) ! NA2SO4 + IF ((W(2)-0.5d0*W(1)) > ZERO) THEN + TOTS4 = W(2) ! Total SO4 + MOLALR(4) = W(2)-0.5d0*W(1) ! (NH4)2SO4 + FRNH4 = MAX(PSI4, ZERO) + ELSE + TOTS4 = 0.5d0*W(1) ! Total SO4 + MOLALR(4) = ZERO ! (NH4)2SO4 + FRNH4 = MAX(2.d0*W(2)-W(1) + PSI4, ZERO) + ENDIF + IF ((PSI5) < (FRNH4)) THEN + MOLALR(5) = PSI5 + FRNH4 = MAX(FRNH4 - PSI5, ZERO) + ELSE + MOLALR(5) = FRNH4 + FRNH4 = ZERO + ENDIF + MOLALR(6) = MIN(PSI6, FRNH4) ! NH4CL +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + WATER = ZERO + DO J=1,NPAIR + WATER = WATER + MOLALR(J)/M0(J) + ENDDO + WATER = MAX(WATER, TINY) +C WRITE(*,*) 'After CALCMR: WATER ',WATER +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + TST = .TRUE. + ELSE + TST = .FALSE. + ENDIF + CALL CALCACT3 + I = I + 1 +C + ENDDO +C +C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +C +20 FG5A = MOLAL(1)*MOLAL(4)/GHCL/A6 - ONE +C + RETURN +C +C *** END OF FUNCTION FUNCG5A ******************************************* +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCG5AB +C *** CASE G5 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCG5AB (X, FG5AB) + INCLUDE 'isrpia_adj.inc' +C + LOGICAL :: TST + INTEGER :: SO4FLG + REAL*8 :: LAMDA, FG5AB +C +C *** SETUP PARAMETERS ************************************************ +C + PSI6 = X +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C +C WRITE(*,*) 'NSWEEP ',NSWEEP,'WATER',WATER + DO I = 1,2 +C + A1 = XK5 *(WATER/GAMA(2))**3.0 + A2 = XK7 *(WATER/GAMA(4))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 + AKK = A4*A6 +C +C CALCULATE DISSOCIATION QUANTITIES +C + IF (CHI5 >= TINY) THEN + PSI5 = PSI6*CHI5/(A6/A5*(CHI6-PSI6) + PSI6) + ELSE + PSI5 = TINY + ENDIF +C +CCC IF(CHI4 > TINY) THEN + IF(W(2) > TINY) THEN ! Accounts for NH3 evaporation + BB = -(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) - 2.d0*PSI2/A4 + DD = MAX(BB*BB-4.d0*CC,ZERO) ! Patch proposed by Uma Shankar, 19/11/01 + PSI4 = 0.5d0*(-BB - SQRT(DD)) + ELSE + PSI4 = TINY + ENDIF +C +C *** CALCULATE SPECIATION ******************************************** +C + MOLAL (2) = W(1) ! NAI + MOLAL (4) = PSI6 ! CLI + IF (W(2)-0.5d0*W(1) > ZERO) THEN + MOLAL(3) = 2.d0*W(2) - W(1) + PSI4 + MOLAL(5) = W(2) ! SO4I + ELSE + MOLAL(3) = PSI4 + MOLAL(5) = 0.5d0*W(1) ! SO4I + ENDIF + MOLAL (6) = ZERO + MOLAL (7) = PSI5 ! NO3I +C +C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + SMIN = PSI5 + PSI6 - PSI4 + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +C + GNH3 = MAX(CHI4 - PSI4, TINY) ! Gas NH3 + GHNO3 = MAX(CHI5 - PSI5, TINY) ! Gas HNO3 + GHCL = MAX(CHI6 - PSI6, TINY) ! Gas HCl +C + CNH42S4 = ZERO ! Solid (NH4)2SO4 + CNH4NO3 = ZERO ! Solid NH4NO3 + CNH4CL = ZERO ! Solid NH4Cl +C +C CALL CALCMR ! Water content +C + MOLALR(2) = 0.5*W(1) ! NA2SO4 + IF (W(2)-0.5d0*W(1) > ZERO) THEN + TOTS4 = W(2) ! Total SO4 + MOLALR(4) = W(2)-0.5d0*W(1) ! (NH4)2SO4 + FRNH4 = MAX(PSI4, ZERO) + ELSE + TOTS4 = 0.5d0*W(1) ! Total SO4 + MOLALR(4) = ZERO ! (NH4)2SO4 + FRNH4 = MAX(2.d0*W(2)-W(1) + PSI4, ZERO) + ENDIF + IF (PSI5 < FRNH4) THEN + MOLALR(5) = PSI5 + FRNH4 = MAX(FRNH4 - PSI5, ZERO) + ELSE + MOLALR(5) = FRNH4 + FRNH4 = ZERO + ENDIF + MOLALR(6) = MIN(PSI6, FRNH4) ! NH4CL +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + WATER = ZERO + DO J=1,NPAIR + WATER = WATER + MOLALR(J)/M0(J) + ENDDO + WATER = MAX(WATER, TINY) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3F + ENDDO +C +C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +C +20 FG5AB = MOLAL(1)*MOLAL(4)/GHCL/A6 - ONE +C + RETURN +C +C *** END OF FUNCTION FUNCG5A ******************************************* +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCG5A +C *** CASE G5 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C CREATED FOR ANISORROPIA. (slc.5.2011) +C NEWTON-RAPHSON SOLUTION ABOUT THE ROOT. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCG5AP (X1) + INCLUDE 'isrpia_adj.inc' +C + LOGICAL :: TST + CHARACTER(LEN=40) :: ERRINF + REAL*8 :: LAMDA, FEPS + REAL*8 :: WP(5), X1 + REAL*8 :: AERLIQ(NIONS+NGASAQ+2), GAS(3) +C +C *** SETUP PARAMETERS ************************************************ +C + FEPS = 1.d-5 + CHI1 = 0.5d0*W(1) + CHI2 = MAX (W(2)-0.5d0*W(1), ZERO) + CHI3 = ZERO + CHI4 = MAX (W(3)-2.D0*CHI2, ZERO) + CHI5 = W(4) + CHI6 = W(5) +C + PSI1 = CHI1 + PSI2 = CHI2 + I = 1 + PSI6 = X1 + FRST = .TRUE. + CALAIN = .TRUE. + TST = .TRUE. +C +C *** NEWTON-RAPHSON DETERMINATION OF ROOT ********************** +C + XT = X1 + XTD = 1.D0 +CCCC$AD NOCHECKPOINT + CALL FUNCG5AB_GNRD(XT, XTD, Y1, Y1D) + X2 = XT - (Y1/(Y1D*1.d0)) + CALL FUNCG5AB(X2,Y2) + IF (abs(Y2) > 10.d0*FEPS) THEN + WRITE(ERRINF, '(A,E12.5,A)') 'CALCG5 (',(Y2),')' + CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE +! WRITE(*,*) 'W: ',W +! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP +! WRITE(*,*) 'FUNCG5AP, after NR - Err 104: ',Y2 + RETURN + ENDIF +C + IF (MOLAL(1) > TINY .AND. MOLAL(5) > TINY) THEN + CALL CALCHS4 (MOLAL(1), MOLAL(5), ZERO, DELTA) + MOLAL(1) = MOLAL(1) - DELTA ! H+ EFFECT + MOLAL(5) = MOLAL(5) - DELTA ! SO4 EFFECT + MOLAL(6) = DELTA ! HSO4 EFFECT + ENDIF +C +C *** END OF FUNCTION FUNCG5A ******************************************* +C + END +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCH6 +C *** CASE H6 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCH6 + INCLUDE 'isrpia_adj.inc' +C + LOGICAL :: TST1, TST2, TST + REAL*8 :: FEPS, WP(ncomp), AERLIQ(NIONS+NGASAQ+2) + REAL*8 :: GAS(3) + CHARACTER(LEN=40) :: ERRINF + INTEGER :: ERRSTKI(25) + CHARACTER(LEN=40) :: ERRMSGI(25) +C +C *** SETUP PARAMETERS ************************************************ +C + CALAOU = .TRUE. + TST1 = .TRUE. + TST2 = .TRUE. + CHI1 = W(2) ! CNA2SO4 + CHI2 = ZERO ! CNH42S4 + CHI3 = ZERO ! CNH4CL + FRNA = MAX (W(1)-2.D0*W(2), ZERO) + CHI8 = MIN (FRNA, W(4)) ! CNANO3 + CHI4 = W(3) ! NH3(g) + IF (FRNA < W(4)) THEN + CHI5 = MAX(W(4)-FRNA, ZERO) + CHI7 = MIN(ZERO,W(5)) + CHI6 = MAX(W(5),ZERO) + ELSE + CHI5 = ZERO + IF (MAX(FRNA-W(4),ZERO) < W(5)) THEN + CHI7 = MAX(FRNA-W(4),ZERO) + CHI6 = MAX(W(5)-CHI7,ZERO) + ELSE + CHI7 = W(5) + CHI6 = ZERO + ENDIF + ENDIF +C + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +C +C *** INITIAL VALUES FOR BISECTION ************************************ +C + X1 = PSI6LO + CALL FUNCH6A (X1, Y1) + IF (ABS(Y1) <= EPS .OR. CHI6 <= TINY) THEN + X3 = X1 + Y3 = Y1 + GOTO 50 + ENDIF +C +C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +C + I = 1 + X2 = X1 + Y2 = Y1 + DX = (PSI6HI-PSI6LO)/FLOAT(NDIV) + DO WHILE ((I <= NDIV) .AND. TST1) + X1 = X2 + Y2 = Y2 + X2 = X1+DX + CALL FUNCH6A (X2, Y2) + IF ((Y1 < ZERO) .AND. (Y2 > ZERO)) THEN + TST1 = .FALSE.! (Y1*Y2 < ZERO) + ENDIF + I = I+1 + ENDDO +C +C *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) EPS).AND.TST1.AND.(I > NDIV+1)) THEN + CALL RSTGAMP + CALL FUNCH6A (PSI6LO, Y3) + X3 = PSI6LO + CALL PUSHERR (0002, 'CALCH6') ! WARNING ERROR: NO CONVERGENCE + GOTO 50 + ENDIF +C +C *** PERFORM BISECTION *********************************************** +C + I = 1 + TST2 = .TRUE. + FEPS = 1.D-5 + DO WHILE ((I <= MAXIT) .AND. TST2) + X3 = 0.5*(X1+X2) + CALL RSTGAMP + CALL FUNCH6A (X3, Y3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) <= ZERO) THEN ! (Y1*Y3 <= ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF ((ABS(X2-X1) <= EPS*X1) .AND. (ABS(Y3) < FEPS)) THEN + TST2 = .FALSE. + ENDIF + I = I+1 + ENDDO + IF ((I > (MAXIT+1)) .AND. TST2) THEN + CALL PUSHERR (0002, 'CALCH6') ! WARNING ERROR: NO CONVERGENCE + ENDIF +C +C *** CONVERGED ; RETURN ********************************************** +C + X3 = 0.5d0*(X1+X2) + CALL RSTGAMP + CALL FUNCH6A (X3, Y3) +C +C *** CALCULATE HSO4 SPECIATION AND RETURN ******************************* +C +50 CONTINUE +C + CALL FUNCH6AP(X3) +C + RETURN +C +C *** END OF SUBROUTINE CALCH6 ****************************************** +C + END + +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCH6_B +C *** CASE H6 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C CREATED FOR ANISORROPIA. (slc.5.2011) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCH6_B(wpb, gasb, aerliqb) + INCLUDE 'isrpia_adj.inc' +C + LOGICAL :: TST1, TST2, TST + REAL*8 :: FEPS, AERLIQ(NIONS+NGASAQ+2) + REAL*8 :: GAS(3), wpb(ncomp) + CHARACTER(LEN=40) :: ERRINF + INTEGER :: ERRSTKI(25), npflag + CHARACTER(LEN=40) :: ERRMSGI(25) + REAL*8 :: gasb(3), aerliqb(NIONS+NGASAQ+2) +C +C +C *** SETUP PARAMETERS ************************************************ +C + FEPS = 1.D-5 + CALAOU = .TRUE. + TST1 = .TRUE. + TST2 = .TRUE. + CHI1 = W(2) ! CNA2SO4 + CHI2 = ZERO ! CNH42S4 + CHI3 = ZERO ! CNH4CL + FRNA = MAX (W(1)-2.D0*W(2), ZERO) + CHI8 = MIN (FRNA, W(4)) ! CNANO3 + CHI4 = W(3) ! NH3(g) + IF (FRNA < W(4)) THEN + CHI5 = MAX(W(4)-FRNA, ZERO) + CHI7 = MIN(ZERO,W(5)) + CHI6 = MAX(W(5),ZERO) + ELSE + CHI5 = ZERO + IF (MAX(FRNA-W(4),ZERO) < W(5)) THEN + CHI7 = MAX(FRNA-W(4),ZERO) + CHI6 = MAX(W(5)-CHI7,ZERO) + ELSE + CHI7 = W(5) + CHI6 = ZERO + ENDIF + ENDIF +C + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +C +C *** INITIAL VALUES FOR BISECTION ************************************ +C + X1 = PSI6LO + CALL FUNCH6A (X1, Y1) + IF (ABS(Y1) <= EPS .OR. CHI6 <= TINY) THEN + X3 = X1 + Y3 = Y1 + GOTO 50 + ENDIF +C +C *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +C + I = 1 + X2 = X1 + Y2 = Y1 + DX = (PSI6HI-PSI6LO)/FLOAT(NDIV) + DO WHILE ((I <= NDIV) .AND. TST1) + X1 = X2 + Y2 = Y2 + X2 = X1+DX + CALL FUNCH6A (X2, Y2) + IF ((Y1 < ZERO) .AND. (Y2 > ZERO)) THEN + TST1 = .FALSE.! (Y1*Y2 < ZERO) + ENDIF + I = I+1 + ENDDO +C +C *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) EPS).AND.TST1.AND.(I > NDIV+1)) THEN + CALL RSTGAMP + CALL FUNCH6A (PSI6LO, Y3) + X3 = PSI6LO + CALL PUSHERR (0002, 'CALCH6') ! WARNING ERROR: NO CONVERGENCE + GOTO 50 + ENDIF +C +C *** PERFORM BISECTION *********************************************** +C + I = 1 + TST2 = .TRUE. + DO WHILE ((I <= MAXIT) .AND. TST2) + X3 = 0.5d0*(X1+X2) + CALL RSTGAMP + CALL FUNCH6A (X3, Y3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) <= ZERO) THEN ! (Y1*Y3 <= ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF ((ABS(X2-X1) <= EPS*X1) .AND. (ABS(Y3) < FEPS)) THEN + TST2 = .FALSE. + ENDIF + I = I+1 + ENDDO + IF ((I > (MAXIT+1)) .AND. TST2) THEN + CALL PUSHERR (0002, 'CALCH6') ! WARNING ERROR: NO CONVERGENCE + ENDIF +C +C *** CONVERGED ; RETURN ********************************************** +C + X3 = 0.5d0*(X1+X2) + CALL RSTGAMP + CALL FUNCH6A (X3, Y3) +C +C *** CALCULATE HSO4 SPECIATION AND RETURN ******************************* +C +50 CONTINUE + +! * slc.11.2011 - commenting since error does not prevent call of FUNCG5AP_GB +! +! IF (ABS(Y3) > FEPS) THEN +! WRITE(ERRINF, '(A,E12.5,A)') 'CALCH6 (',Y3,')' +! CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE +! WRITE(*,*) 'W: ',W +! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP +! WRITE(*,*) 'CALCH6_B, before NR - Err 104: ',Y3 +! ENDIF +C + CALL FUNCH6AP_HB(x3, wpb, gasb, aerliqb) +C + RETURN +C +C *** END OF SUBROUTINE CALCH6 ****************************************** +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCH6A +C *** CASE H6 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCH6A (X, FH6A) + INCLUDE 'isrpia_adj.inc' +C + LOGICAL :: TST +C +C *** SETUP PARAMETERS ************************************************ +C + I = 1 + PSI6 = X + PSI1 = CHI1 + PSI2 = ZERO + PSI3 = ZERO + PSI7 = CHI7 + PSI8 = CHI8 + FRST = .TRUE. + CALAIN = .TRUE. + TST = .TRUE. +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + DO WHILE ((I <= NSWEEP) .AND. TST) +C + A1 = XK5 *(WATER/GAMA(2))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 + A7 = XK8 *(WATER/GAMA(1))**2.0 + A8 = XK9 *(WATER/GAMA(3))**2.0 + A9 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. +C +C CALCULATE DISSOCIATION QUANTITIES +C + PSI5 = CHI5*(PSI6+PSI7) - A6/A5*PSI8*(CHI6-PSI6-PSI3) + PSI5 = PSI5/(A6/A5*(CHI6-PSI6-PSI3) + PSI6 + PSI7) + PSI5 = MAX(PSI5, TINY) +C + IF (W(3) > TINY .AND. WATER > TINY) THEN ! First try 3rd order soln + BB = -(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) + DD = BB*BB-4.d0*CC + PSI4 = 0.5d0*(-BB - SQRT(DD)) + PSI4 = MIN(PSI4,CHI4) + ELSE + PSI4 = TINY + ENDIF +C +C *** CALCULATE SPECIATION ******************************************** +C + MOLAL (2) = PSI8 + PSI7 + 2.D0*PSI1 ! NAI + MOLAL (3) = PSI4 ! NH4I + MOLAL (4) = PSI6 + PSI7 ! CLI + MOLAL (5) = PSI2 + PSI1 ! SO4I + MOLAL (6) = ZERO ! HSO4I + MOLAL (7) = PSI5 + PSI8 ! NO3I +C +C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + SMIN = 2.d0*PSI2 + PSI5 + PSI6 - PSI4 + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +C + GNH3 = MAX(CHI4 - PSI4, TINY) + GHNO3 = MAX(CHI5 - PSI5, TINY) + GHCL = MAX(CHI6 - PSI6, TINY) +C + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNACL = MAX(CHI7 - PSI7, ZERO) + CNANO3 = MAX(CHI8 - PSI8, ZERO) + CNA2SO4 = MAX(CHI1 - PSI1, ZERO) +C + CALL CALCMR ! Water content +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + TST = .TRUE. + ELSE + TST = .FALSE. + ENDIF + CALL CALCACT3 + I = I + 1 + ENDDO +C +C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +C + FH6A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE +C + RETURN +C +C *** END OF FUNCTION FUNCH6A ******************************************* +C + END + + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCH6AP +C *** CASE H6 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C CREATED FOR ANISORROPIA. (slc.5.2011) +C NEWTON-RAPHSON SOLUTION ABOUT THE ROOT. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCH6AP (X1) + INCLUDE 'isrpia_adj.inc' +C + CHARACTER(LEN=40) :: ERRINF + REAL*8 :: AERLIQ(NIONS+NGASAQ+2), GAS(3), FEPS +C +C *** SETUP PARAMETERS ************************************************ +C + FEPS = 1.d-5 + CHI1 = W(2) ! CNA2SO4 + CHI2 = ZERO ! CNH42S4 + CHI3 = ZERO ! CNH4CL + FRNA = MAX (W(1)-2.D0*W(2), ZERO) + CHI8 = MIN (FRNA, W(4)) ! CNANO3 + CHI4 = W(3) ! NH3(g) + IF (FRNA < W(4)) THEN + CHI5 = MAX(W(4)-FRNA, ZERO) + CHI7 = MIN(ZERO,W(5)) + CHI6 = MAX(W(5),ZERO) + ELSE + CHI5 = ZERO + IF (MAX(FRNA-W(4),ZERO) < W(5)) THEN + CHI7 = MAX(FRNA-W(4),ZERO) + CHI6 = MAX(W(5)-CHI7,ZERO) + ELSE + CHI7 = W(5) + CHI6 = ZERO + ENDIF + ENDIF +C + PSI1 = CHI1 + PSI2 = ZERO + PSI3 = ZERO + PSI7 = CHI7 + PSI8 = CHI8 + PSI6 = X1 +C +C *** NEWTON-RAPHSON DETERMINATION OF ROOT ********************** +C + XT = X1 + XTD = 1.D0 + CALL FUNCH6AB_HNRD(XT, XTD, Y1, Y1D) + X2 = XT - (Y1/(Y1D*1.d0)) + CALL FUNCH6AB(X2,Y2) + IF (abs(Y2) > 10.d0*FEPS) THEN + WRITE(ERRINF, '(A,E12.5,A)') 'CALCH6 (',(Y2),')' + CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE +! WRITE(*,*) 'W: ',W +! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP +! WRITE(*,*) 'CALCH6AP, after NR - Err 104: ',Y2 + RETURN + ENDIF +C + IF (MOLAL(1) > TINY .AND. MOLAL(5) > TINY) THEN + CALL CALCHS4 (MOLAL(1), MOLAL(5), ZERO, DELTA) + MOLAL(1) = MOLAL(1) - DELTA ! H+ EFFECT + MOLAL(5) = MOLAL(5) - DELTA ! SO4 EFFECT + MOLAL(6) = DELTA ! HSO4 EFFECT + ENDIF +C +C *** END OF FUNCTION FUNCH6A ******************************************* +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCH6AB +C *** CASE H6 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C CREATED FOR ANISORROPIA. (slc.5.2011) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCH6AB (X, FH6AB) + INCLUDE 'isrpia_adj.inc' +C + INTEGER :: J +C +C *** SETUP PARAMETERS ************************************************ +C + PSI6 = X + PSI1 = CHI1 + PSI2 = ZERO + PSI3 = ZERO + PSI7 = CHI7 + PSI8 = CHI8 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + DO I = 1,2 +C + A1 = XK5 *(WATER/GAMA(2))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 + A7 = XK8 *(WATER/GAMA(1))**2.0 + A8 = XK9 *(WATER/GAMA(3))**2.0 + A9 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.0 +C +C CALCULATE DISSOCIATION QUANTITIES +C + PSI5 = CHI5*(PSI6+PSI7) - A6/A5*PSI8*(CHI6-PSI6-PSI3) + PSI5 = PSI5/(A6/A5*(CHI6-PSI6-PSI3) + PSI6 + PSI7) + PSI5 = MAX(PSI5, TINY) +C + IF (W(3) > TINY .AND. WATER > TINY) THEN ! First try 3rd order soln + BB = -(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) + DD = BB*BB-4.d0*CC + PSI4 = 0.5d0*(-BB - SQRT(DD)) + PSI4 = MIN(PSI4,CHI4) + ELSE + PSI4 = TINY + ENDIF +C +C *** CALCULATE SPECIATION ******************************************** +C + MOLAL (2) = PSI8 + PSI7 + 2.D0*PSI1 ! NAI + MOLAL (3) = PSI4 ! NH4I + MOLAL (4) = PSI6 + PSI7 ! CLI + MOLAL (5) = PSI2 + PSI1 ! SO4I + MOLAL (6) = ZERO ! HSO4I + MOLAL (7) = PSI5 + PSI8 ! NO3I +C +C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + SMIN = 2.d0*PSI2 + PSI5 + PSI6 - PSI4 + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +C + GNH3 = MAX(CHI4 - PSI4, TINY) + GHNO3 = MAX(CHI5 - PSI5, TINY) + GHCL = MAX(CHI6 - PSI6, TINY) +C + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNACL = MAX(CHI7 - PSI7, ZERO) + CNANO3 = MAX(CHI8 - PSI8, ZERO) + CNA2SO4 = MAX(CHI1 - PSI1, ZERO) +C +C CALL CALCMR ! Water content +C +C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM RICH CASE +C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/ +C + MOLALR(1) = PSI7 ! NACL + MOLALR(2) = PSI1 ! NA2SO4 + MOLALR(3) = PSI8 ! NANO3 + MOLALR(4) = ZERO ! (NH4)2SO4 +C FRNO3 = MAX(MOLAL(7) - MOLALR(3), ZERO) ! "FREE" NO3 + FRNO3 = MAX(PSI5, ZERO) +C FRCL = MAX(MOLAL(4) - MOLALR(1), ZERO) ! "FREE" CL + FRCL = MAX(PSI6, ZERO) +C MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3 +C FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3 +C MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL + IF (PSI4 < FRNO3) THEN + MOLALR(5) = PSI4 + FRNH4 = ZERO + MOLALR(6) = MIN(FRCL, ZERO) + ELSE + MOLALR(5) = FRNO3 + FRNH4 = MAX(PSI4-FRNO3,ZERO) + MOLALR(6) = MIN(FRCL, FRNH4) + ENDIF +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + WATER = ZERO + DO J=1,NPAIR + WATER = WATER + MOLALR(J)/M0(J) + ENDDO + WATER = MAX(WATER, TINY) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3F + ENDDO +C +C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +C + FH6AB = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE +C + RETURN +C +C *** END OF FUNCTION FUNCH6A ******************************************* +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCI6 +C *** CASE I6 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +C 2. SOLID & LIQUID AEROSOL POSSIBLE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCI6 + INCLUDE 'isrpia_adj.inc' + REAL*8 :: AERLIQ(NIONS+NGASAQ+2), GAS(3) +C +C *** FIND DRY COMPOSITION ********************************************** +C +C CALL CALCI1A +C +C *** CALCULATE NON VOLATILE SOLIDS *********************************** +C + CNA2SO4 = 0.5D0*W(1) + CNH4HS4 = ZERO + CNAHSO4 = ZERO + CNH42S4 = ZERO + FRSO4 = MAX(W(2)-CNA2SO4, ZERO) +C + CLC = MIN(W(3)/3.D0, FRSO4/2.D0) + FRSO4 = MAX(FRSO4-2.D0*CLC, ZERO) + FRNH4 = MAX(W(3)-3.D0*CLC, ZERO) +C + IF (FRSO4 <= TINY) THEN + CLC = MAX(CLC - FRNH4, ZERO) + CNH42S4 = 2.D0*FRNH4 + + ELSEIF (FRNH4 <= TINY) THEN + CNH4HS4 = 3.D0*MIN(FRSO4, CLC) + CLC = MAX(CLC-FRSO4, ZERO) + IF (CNA2SO4 > TINY) THEN + FRSO4 = MAX(FRSO4-CNH4HS4/3.D0, ZERO) + CNAHSO4 = 2.D0*FRSO4 + CNA2SO4 = MAX(CNA2SO4-FRSO4, ZERO) + ENDIF + ENDIF +C +C *** CALCULATE GAS SPECIES ********************************************* +C + GHNO3 = W(4) + GHCL = W(5) + GNH3 = ZERO +C +C *** SETUP PARAMETERS ************************************************ +C + CHI1 = CNH4HS4 ! Save from CALCI1 run + CHI2 = CLC + CHI3 = CNAHSO4 + CHI4 = CNA2SO4 + CHI5 = CNH42S4 +C + PSI1 = CNH4HS4 ! ASSIGN INITIAL PSI's + PSI2 = CLC + PSI3 = CNAHSO4 + PSI4 = CNA2SO4 + PSI5 = CNH42S4 +C + CALAOU = .TRUE. ! Outer loop activity calculation flag + FRST = .TRUE. + CALAIN = .TRUE. +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + J = 1 + DO WHILE ((J <= NSWEEP).AND.(CALAIN)) +C + A6 = XK1 *WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.d0 +C +C CALCULATE DISSOCIATION QUANTITIES +C + BB = PSI2 + PSI4 + PSI5 + A6 ! PSI6 + CC = -A6*(PSI2 + PSI3 + PSI1) + DD = BB*BB - 4.D0*CC + PSI6 = 0.5D0*(-BB + SQRT(DD)) +C +C *** CALCULATE SPECIATION ******************************************** +C + MOLAL (1) = PSI6 ! HI + MOLAL (2) = 2.D0*PSI4 + PSI3 ! NAI + MOLAL (3) = 3.D0*PSI2 + 2.D0*PSI5 + PSI1 ! NH4I + MOLAL (5) = PSI2 + PSI4 + PSI5 + PSI6 ! SO4I + MOLAL (6) = PSI2 + PSI3 + PSI1 - PSI6 ! HSO4I + CLC = ZERO + CNAHSO4 = ZERO + CNA2SO4 = CHI4 - PSI4 + CNH42S4 = ZERO + CNH4HS4 = ZERO + + MOLALR(04) = PSI5 ! (NH4)2SO4 + MOLALR(02) = PSI4 ! NA2SO4 + MOLALR(09) = PSI1 ! NH4HSO4 + MOLALR(12) = PSI3 ! NAHSO4 + MOLALR(13) = PSI2 ! LC +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + WATER = ZERO + DO I=1,NPAIR + WATER = WATER + MOLALR(I)/M0(I) + ENDDO + WATER = MAX(WATER, TINY) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3 + J = J+1 + ENDDO + + IF (CALAIN .AND. (J > (NSWEEP+1))) THEN + CALL PUSHERR (0001, 'CALCI6') ! WARNING ERROR: NO SOLUTION + ENDIF +C +20 RETURN +C +C *** END OF SUBROUTINE CALCI6 ***************************************** +C + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCJ3 +C *** CASE J3 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +C 2. THERE IS ONLY A LIQUID PHASE +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCJ3 + INCLUDE 'isrpia_adj.inc' +C + INTEGER :: J + REAL*8 :: LAMDA, KAPA +C +C *** SETUP PARAMETERS ************************************************ +C + CALAOU = .TRUE. ! Outer loop activity calculation flag + FRST = .TRUE. + CALAIN = .TRUE. +C + LAMDA = MAX(W(2) - W(3) - W(1), TINY) ! FREE H2SO4 + CHI1 = W(1) ! NA TOTAL as NaHSO4 + CHI2 = W(3) ! NH4 TOTAL as NH4HSO4 + PSI1 = CHI1 + PSI2 = CHI2 ! ALL NH4HSO4 DELIQUESCED +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + J = 1 + DO WHILE ((J <= NSWEEP).AND.(CALAIN)) +C + A3 = XK1 *WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.0 +C +C CALCULATE DISSOCIATION QUANTITIES +C + BB = A3+LAMDA ! KAPA + CC =-A3*(LAMDA + PSI1 + PSI2) + DD = BB*BB-4.D0*CC + KAPA = 0.5D0*(-BB+SQRT(DD)) +C +C *** CALCULATE SPECIATION ******************************************** +C + MOLAL (1) = LAMDA + KAPA ! HI + MOLAL (2) = PSI1 ! NAI + MOLAL (3) = PSI2 ! NH4I + MOLAL (4) = ZERO ! CLI + MOLAL (5) = KAPA ! SO4I + MOLAL (6) = LAMDA + PSI1 + PSI2 - KAPA ! HSO4I + MOLAL (7) = ZERO ! NO3I +C + CNAHSO4 = ZERO + CNH4HS4 = ZERO +C +C CALL CALCMR ! Water content +C + MOLALR(09) = MOLAL(3) ! NH4HSO4 + MOLALR(12) = MOLAL(2) ! NAHSO4 + MOLALR(07) = MOLAL(5)+MOLAL(6)-MOLAL(3)-MOLAL(2) ! H2SO4 + MOLALR(07) = MAX(MOLALR(07),ZERO) +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + WATER = ZERO + DO I=1,NPAIR + WATER = WATER + MOLALR(I)/M0(I) + ENDDO + WATER = MAX(WATER, TINY) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3 + J = J+1 + ENDDO + + IF (CALAIN .AND. (J > (NSWEEP+1))) THEN + CALL PUSHERR (0001, 'CALCJ3') ! WARNING ERROR: NO SOLUTION + ENDIF +C +50 RETURN +C +C *** END OF SUBROUTINE CALCJ3 ****************************************** +C + END + + +C +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of isrp1fa in reverse (adjoint) mode: +C gradient of useful results: aerliq gas +C with respect to varying inputs: wp aerliq gas +C RW status of diff variables: wp:out aerliq:in-out gas:in-out +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ISRP1F_AB +C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FOREWARD PROBLEM OF +C AN AMMONIUM-SULFATE AEROSOL SYSTEM. +C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY +C THE AMBIENT RELATIVE HUMIDITY. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C +C======================================================================= +C + SUBROUTINE ISRP1FA_AB(wpab, gasab, aerliqab) + INCLUDE 'isrpia_adj.inc' + + REAL*8 :: wpab(ncomp) + REAL*8 :: dc, gas(3), aerliq(nions+ngasaq+2) + REAL*8 :: dcab, gasab(3), aerliqab(nions+ngasaq+2) + INTEGER :: i, npflag, ncase + INTEGER :: branch + INTRINSIC MAX + REAL*8 :: max1ab + INTEGER :: ii1 + REAL*8 :: max1 +C +C For numerical stability + dc = w(3) - 2.001d0*w(2) + IF (-dc .LT. zero) THEN + max1 = zero + CALL PUSHCONTROL1B(0) + ELSE + max1 = -dc + CALL PUSHCONTROL1B(1) + END IF + w(3) = w(3) + max1 +C +C Only liquid (metastable) +C Gaseous aerosol species + DO ii1=1,nions + molalab(ii1) = 0.D0 + ENDDO + DO i=nions,1,-1 + molalab(i) = molalab(i) + aerliqab(i) + ENDDO + aerliqab = 0.D0 + gasab(3) = 0.D0 + gasab(2) = 0.D0 + gnh3ab = gasab(1) + gasab(1) = 0.D0 + CALL CALCA2_AB() + max1ab = wab(3) + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + dcab = 0.D0 + ELSE + dcab = -max1ab + END IF + wab(3) = wab(3) + dcab + wab(2) = wab(2) - 2.001d0*dcab + wpab = wab +C + END + +C Differentiation of calca2 in reverse (adjoint) mode: +C gradient of useful results: molal gnh3 +C with respect to varying inputs: w +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCA2 +C *** CASE A2 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) +C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE +C +C FOR CALCULATIONS, A !!!!!BISECTION IS PERFORMED TOWARDS X, THE +C AMOUNT OF HYDROGEN IONS (H+) FOUND IN THE LIQUID PHASE. +C FOR EACH ESTIMATION OF H+, FUNCTION FUNCB2A CALCULATES THE +C CONCENTRATION OF IONS FROM THE NH3(GAS) - NH4+(LIQ) EQUILIBRIUM. +C ELECTRONEUTRALITY IS USED AS THE OBJECTIVE FUNCTION. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C +C======================================================================= +C + SUBROUTINE CALCA2_AB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: delta + REAL*8 :: deltaab + INTEGER :: i + INTEGER :: ii1 + INTEGER :: branch + INTRINSIC :: MAX + REAL*8 :: molalrab(npair) +C +C *** CALCULATE WATER CONTENT ***************************************** +C + molal(5) = w(2) + molal(6) = zero +C +C CALL CALCMR +C +C (NH4)2SO4 - CORRECT FOR SO4 TO HSO4 + molalr(4) = molal(5) + molal(6) +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + DO i=1,npair + water = water + molalr(i)/m0(i) + ENDDO + IF (water .LT. tiny) THEN + water = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF + CALL PUSHINTEGER4(iclact) + CALL PUSHREAL8ARRAY(gama, npair) + CALL PUSHREAL8ARRAY(molal, nions) +C +C *** CREATE ITERATION FOR ACTIVITY COEFFICIENTS +C + CALL FUNCA2P() +C + IF (molal(1) .GT. tiny) THEN + deltaab = molalab(6) + molalab(6) = 0.D0 + deltaab = deltaab - molalab(1) - molalab(5) + CALL CALCHS4_AB(molal(1), molalab(1), molal(5), molalab(5), zero + + , delta, deltaab) + ELSE + DO ii1=1,npair + gamaab(ii1) = 0.D0 + ENDDO + waterab = 0.D0 + END IF + CALL POPREAL8ARRAY(molal, nions) + CALL POPREAL8ARRAY(gama, npair) + CALL POPINTEGER4(iclact) + CALL FUNCA2P_AB() + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) waterab = 0.D0 + DO ii1=1,npair + molalrab(ii1) = 0.D0 + ENDDO + DO i=npair,1,-1 + molalrab(i) = molalrab(i) + waterab/m0(i) + ENDDO + molalab(5) = molalab(5) + molalrab(4) + molalab(6) = 0.D0 + wab(2) = wab(2) + molalab(5) + END + +C Differentiation of funca2p in reverse (adjoint) mode: +C gradient of useful results: molal gama water gnh3 +C with respect to varying inputs: w molal water +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** FUNCTION FUNCA2P +C *** CASE A2 +C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE A2 ; +C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCA2P. +C +C======================================================================= +C + SUBROUTINE FUNCA2P_AB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: lamda, disc, sqdr, thrshhi, thrshlo + REAL*8 :: discab, sqdrab + REAL*8 :: ncon, qcon, ucon, uconold + REAL*8 :: qconab, uconab + REAL*8 :: w2, w3 + REAL*8 :: w2ab, w3ab + LOGICAL tst, tst2 + INTEGER :: i + REAL*8 :: aa + REAL*8 :: aaab + REAL*8 :: bb + REAL*8 :: bbab + REAL*8 :: cc + REAL*8 :: ccab + REAL*8 :: rt1 + REAL*8 :: rt1ab + REAL*8 :: rt2 + REAL*8 :: rt2ab + INTEGER :: branch + INTEGER :: ad_count + INTEGER :: i0 + REAL*8 :: temp0 + REAL*8 :: temp1ab0 + REAL*8 :: temp0ab + REAL*8 :: temp1ab + INTEGER :: ii1 + INTRINSIC :: SQRT +C +C *** SETUP PARAMETERS ************************************************ +C + tst = .true. + tst2 = .true. +C INITIAL AMOUNT OF (NH4)2SO4 IN SOLUTION + w2 = w(2) + w3 = w(3) +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + i = 1 + ucon = 0.d0 + ad_count = 0 + DO WHILE (i .LE. 14 .AND. tst .AND. tst2) +C DO I=1,14 !NSWEEP + uconold = ucon + CALL PUSHREAL8(a2) + a2 = xk2*r*temp/xkw*(gama(8)/gama(9))**2. + CALL PUSHREAL8(aa) +C + aa = -a2 + CALL PUSHREAL8(bb) + bb = a2*w3 - 2.d0*a2*w2 + 1 + cc = 2.d0*w2 + disc = bb*bb - 4.d0*aa*cc + CALL PUSHREAL8(sqdr) + sqdr = SQRT(disc) +C + rt1 = (-bb+sqdr)/2.d0/aa + rt2 = (-bb-sqdr)/2.d0/aa +C WRITE(*,*) 'ROOTS', RT1, RT2 +C + IF (rt1 .LT. zero .AND. rt2 .GE. zero) THEN + ucon = rt1 + CALL PUSHCONTROL2B(0) + ELSE IF (rt2 .LT. zero .AND. rt1 .GE. zero) THEN + ucon = rt2 + CALL PUSHCONTROL2B(1) + ELSE + tst2 = .false. + CALL PUSHCONTROL2B(2) + END IF +C + qcon = -ucon + CALL PUSHREAL8(molal(1)) +C +C *** SPECIATION & WATER CONTENT *************************************** +C +C HI + molal(1) = qcon +C MOLAL (3) = MAX(W(3)/(ONE/A2/OMEGI + ONE), 2.*MOLAL(5)) ! NH4I +C MOLAL (3) = MAX(2.D0*W2 + UCON, TINY) ! NH4I + IF (tiny .GT. 2.d0*w2 + ucon) THEN + CALL PUSHREAL8(molal(3)) + molal(3) = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(molal(3)) + molal(3) = 2.d0*w2 + ucon + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8(molal(5)) +C SO4I + molal(5) = w2 + CALL PUSHREAL8(molal(6)) +C HSO4I + molal(6) = zero +C GNH3 = MAX(W(3)-MOLAL(3), TINY) ! NH3GI + IF (tiny .GT. w(3) - molal(3)) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8ARRAY(gama, npair) +C OHI +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3P() + thrshlo = uconold - uconold*1.0d-15 + thrshhi = uconold + uconold*1.0d-15 + IF (ucon .LE. thrshlo .AND. ucon .GE. thrshhi) THEN + tst = .false. + ELSE + tst = .true. + END IF +C CALL CALCACT +C ELSE +C GOTO 20 +C ENDIF + i = i + 1 + ad_count = ad_count + 1 + ENDDO + DO ii1=1,ncomp + wab(ii1) = 0.D0 + ENDDO + uconab = 0.D0 + w2ab = 0.D0 + w3ab = 0.D0 + DO i0=1,ad_count + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3P_AB() + CALL POPCONTROL1B(branch) + IF (branch .NE. 0) THEN + wab(3) = wab(3) + gnh3ab + molalab(3) = molalab(3) - gnh3ab + END IF + CALL POPREAL8(molal(6)) + molalab(6) = 0.D0 + CALL POPREAL8(molal(5)) + w2ab = w2ab + molalab(5) + molalab(5) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL8(molal(3)) + molalab(3) = 0.D0 + ELSE + CALL POPREAL8(molal(3)) + w2ab = w2ab + 2.d0*molalab(3) + uconab = uconab + molalab(3) + molalab(3) = 0.D0 + END IF + CALL POPREAL8(molal(1)) + qconab = molalab(1) + molalab(1) = 0.D0 + uconab = uconab - qconab + CALL POPCONTROL2B(branch) + IF (branch .EQ. 0) THEN + rt1ab = uconab + rt2ab = 0.D0 + uconab = 0.D0 + ELSE + IF (branch .EQ. 1) THEN + rt2ab = uconab + uconab = 0.D0 + ELSE + rt2ab = 0.D0 + END IF + rt1ab = 0.D0 + END IF + temp1ab0 = rt1ab/(2.d0*aa) + temp1ab = rt2ab/(2.d0*aa) + sqdrab = temp1ab0 - temp1ab + cc = 2.d0*w2 + disc = bb*bb - 4.d0*aa*cc + IF (disc .EQ. 0.0) THEN + discab = 0.0 + ELSE + discab = sqdrab/(2.0*SQRT(disc)) + END IF + bbab = 2*bb*discab - temp1ab0 - temp1ab + aaab = -((sqdr-bb)*temp1ab0/aa) - 4.d0*cc*discab - (-bb-sqdr)* + + temp1ab/aa + CALL POPREAL8(sqdr) + ccab = -(4.d0*aa*discab) + w2ab = w2ab + 2.d0*ccab - 2.d0*a2*bbab + CALL POPREAL8(bb) + a2ab = (w3-2.d0*w2)*bbab - aaab + w3ab = w3ab + a2*bbab + CALL POPREAL8(aa) + CALL POPREAL8(a2) + temp0 = gama(8)/gama(9) + temp0ab = 2.*temp0*xk2*r*temp*a2ab/(xkw*gama(9)) + gamaab(8) = gamaab(8) + temp0ab + gamaab(9) = gamaab(9) - temp0*temp0ab + gnh3ab = 0.D0 + ENDDO + wab(3) = wab(3) + w3ab + wab(2) = wab(2) + w2ab + END + +C Differentiation of calchs4 in reverse (adjoint) mode: +C gradient of useful results: hi so4i delta +C with respect to varying inputs: gama water hi so4i +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCHS4 +C *** THIS SUBROUTINE CALCULATES THE HSO4 GENERATED FROM (H,SO4). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C +C======================================================================= +C + SUBROUTINE CALCHS4_AB(hi, hiab, so4i, so4iab, hso4i, delta, + + deltaab) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: hi, so4i, hso4i, delta, bb, cc, dd, sqdd, delta1 + + , delta2 + REAL*8 :: hiab, so4iab, deltaab, bbab, ccab, ddab, sqddab, + + delta1ab, delta2ab + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp0ab + REAL*8 :: temp1ab + INTEGER :: ii1 + INTRINSIC :: SQRT +C +C *** IF TOO LITTLE WATER, DONT SOLVE +C + IF (water .LE. 1d1*tiny) THEN + DO ii1=1,npair + gamaab(ii1) = 0.D0 + ENDDO + waterab = 0.D0 + ELSE +C +C *** CALCULATE HSO4 SPECIATION ***************************************** +C + a8 = xk1*water/gama(7)*(gama(8)/gama(7))**2. +C + bb = -(hi+so4i+a8) + cc = hi*so4i - hso4i*a8 + dd = bb*bb - 4.d0*cc +C + IF (dd .GE. zero) THEN + IF (hso4i .LE. tiny) THEN + delta2ab = deltaab + delta1ab = 0.D0 + ELSE IF (hi*so4i .GE. a8*hso4i) THEN + delta2ab = deltaab + delta1ab = 0.D0 + ELSE + IF (hi*so4i .LT. a8*hso4i) THEN + delta1ab = deltaab + ELSE + delta1ab = 0.D0 + END IF + delta2ab = 0.D0 + END IF + bbab = -(0.5*delta1ab) - 0.5*delta2ab + sqddab = 0.5*delta1ab - 0.5*delta2ab + IF (dd .EQ. 0.0) THEN + ddab = 0.0 + ELSE + ddab = sqddab/(2.0*SQRT(dd)) + END IF + ELSE + ddab = 0.D0 + bbab = 0.D0 + END IF + bbab = bbab + 2*bb*ddab + ccab = -(4.d0*ddab) + hiab = hiab + so4i*ccab - bbab + so4iab = so4iab + hi*ccab - bbab + a8ab = -bbab - hso4i*ccab + DO ii1=1,npair + gamaab(ii1) = 0.D0 + ENDDO + temp0 = water/gama(7) + temp1 = gama(8)/gama(7) + temp1ab = 2.*temp1*temp0*xk1*a8ab/gama(7) + temp0ab = temp1**2.*xk1*a8ab/gama(7) + gamaab(8) = gamaab(8) + temp1ab + gamaab(7) = gamaab(7) - temp0*temp0ab - temp1*temp1ab + waterab = temp0ab + END IF + END + +C Differentiation of calcact3p in reverse (adjoint) mode: +C gradient of useful results: molal gama water +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C +C======================================================================= +C + SUBROUTINE CALCACT3P_AB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0ab(6, 4), sionab, hab, chab, f1ab(3), f2ab(4) + REAL*8 :: mpl, xij, yji, ionicab + REAL*8 :: mplab, xijab, yjiab + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01ab + REAL*8 :: g02 + REAL*8 :: g02ab + REAL*8 :: g03 + REAL*8 :: g03ab + REAL*8 :: g04 + REAL*8 :: g04ab + REAL*8 :: g05 + REAL*8 :: g05ab + REAL*8 :: g06 + REAL*8 :: g06ab + REAL*8 :: g07 + REAL*8 :: g07ab + REAL*8 :: g08 + REAL*8 :: g08ab + REAL*8 :: g09 + REAL*8 :: g09ab + REAL*8 :: g10 + REAL*8 :: g10ab + REAL*8 :: g11 + REAL*8 :: g11ab + REAL*8 :: g12 + REAL*8 :: g12ab + INTEGER :: j + INTEGER :: branch + REAL*8 :: temp0ab0 + INTRINSIC MAX + REAL*8 :: x2ab + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: temp0ab + INTRINSIC MIN + REAL*8 :: x1ab + REAL*8 :: temp0ab13 + REAL*8 :: temp0ab12 + INTEGER :: ii2 + INTEGER :: ii1 + REAL*8 :: temp0ab11 + INTRINSIC SQRT + REAL*8 :: temp0ab9 + REAL*8 :: temp0ab10 + REAL*8 :: temp0ab8 + REAL*8 :: temp0ab7 + REAL*8 :: temp0ab6 + REAL*8 :: temp0ab5 + REAL*8 :: temp0ab4 + REAL*8 :: temp0ab3 + REAL*8 :: temp0ab2 + REAL*8 :: temp0ab1 +C +C +C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + DO i=1,7 + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water .GT. 200.d0) THEN + x1 = 200.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 .LT. tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08, + + g09, g10, g11, g12) +C + g0(1, 1) = g11 + g0(1, 2) = g07 + g0(1, 3) = g08 + g0(1, 4) = g10 + g0(2, 1) = g01 + g0(2, 2) = g02 + g0(2, 3) = g12 + g0(2, 4) = g03 + g0(3, 1) = g06 + g0(3, 2) = g04 + g0(3, 3) = g09 + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + sion = SQRT(ionic) + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + yji = ch*molal(j+3)/water + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gama(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gama(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gama(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gama(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gama(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gama(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gama(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gama(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gama(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gama(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gama(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gama(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gama(13)) +C LC ; SCAPE + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) .GT. 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + ELSE + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 .LT. -5.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + gamaab(i) = 10.d0**gama(i)*LOG(10.d0)*gamaab(i) + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + gamaab(i) = 0.D0 + x2ab = 0.D0 + ELSE + x2ab = gamaab(i) + gamaab(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch .NE. 0) gamaab(i) = gamaab(i) + x2ab + ENDDO + CALL POPREAL8(gama(13)) + gamaab(4) = gamaab(4) + 0.2d0*3.d0*gamaab(13) + gamaab(9) = gamaab(9) + 0.2d0*2.d0*gamaab(13) + gamaab(13) = 0.D0 + DO ii1=1,3 + f1ab(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2ab(ii1) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp0ab2 = zz(12)*gamaab(12)/(z(2)+z(6)) + f1ab(2) = f1ab(2) + temp0ab2/z(2) + f2ab(3) = f2ab(3) + temp0ab2/z(6) + hab = -(zz(12)*gamaab(12)) + gamaab(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp0ab3 = zz(11)*gamaab(11)/(z(1)+z(4)) + f2ab(1) = f2ab(1) + temp0ab3/z(4) + hab = hab - zz(11)*gamaab(11) + gamaab(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp0ab4 = zz(10)*gamaab(10)/(z(1)+z(7)) + f1ab(1) = f1ab(1) + temp0ab4/z(1) + temp0ab3/z(1) + f2ab(4) = f2ab(4) + temp0ab4/z(7) + hab = hab - zz(10)*gamaab(10) + gamaab(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp0ab5 = zz(9)*gamaab(9)/(z(3)+z(6)) + f1ab(3) = f1ab(3) + temp0ab5/z(3) + hab = hab - zz(9)*gamaab(9) + gamaab(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp0ab6 = zz(8)*gamaab(8)/(z(1)+z(6)) + f2ab(3) = f2ab(3) + temp0ab6/z(6) + temp0ab5/z(6) + hab = hab - zz(8)*gamaab(8) + gamaab(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp0ab7 = zz(7)*gamaab(7)/(z(1)+z(5)) + f1ab(1) = f1ab(1) + temp0ab7/z(1) + temp0ab6/z(1) + f2ab(2) = f2ab(2) + temp0ab7/z(5) + hab = hab - zz(7)*gamaab(7) + gamaab(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp0ab8 = zz(6)*gamaab(6)/(z(3)+z(4)) + f2ab(1) = f2ab(1) + temp0ab8/z(4) + hab = hab - zz(6)*gamaab(6) + gamaab(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp0ab9 = zz(5)*gamaab(5)/(z(3)+z(7)) + f2ab(4) = f2ab(4) + temp0ab9/z(7) + hab = hab - zz(5)*gamaab(5) + gamaab(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp0ab10 = zz(4)*gamaab(4)/(z(3)+z(5)) + f1ab(3) = f1ab(3) + temp0ab9/z(3) + temp0ab10/z(3) + temp0ab8/z(3) + f2ab(2) = f2ab(2) + temp0ab10/z(5) + hab = hab - zz(4)*gamaab(4) + gamaab(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp0ab11 = zz(3)*gamaab(3)/(z(2)+z(7)) + f2ab(4) = f2ab(4) + temp0ab11/z(7) + hab = hab - zz(3)*gamaab(3) + gamaab(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp0ab12 = zz(2)*gamaab(2)/(z(2)+z(5)) + f2ab(2) = f2ab(2) + temp0ab12/z(5) + hab = hab - zz(2)*gamaab(2) + gamaab(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp0ab13 = zz(1)*gamaab(1)/(z(2)+z(4)) + f1ab(2) = f1ab(2) + temp0ab12/z(2) + temp0ab13/z(2) + temp0ab11/z( + + 2) + f2ab(1) = f2ab(1) + temp0ab13/z(4) + hab = hab - zz(1)*gamaab(1) + gamaab(1) = 0.D0 + ionicab = 0.D0 + DO ii1=1,4 + DO ii2=1,6 + g0ab(ii2, ii1) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mplab = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijab = (g0(i, j)+zpl*zmi*h)*f2ab(j) + yji = ch*molal(j+3)/water + g0ab(i, j) = g0ab(i, j) + yji*f1ab(i) + xij*f2ab(j) + hab = hab + yji*zpl*zmi*f1ab(i) + xij*zpl*zmi*f2ab(j) + yjiab = (g0(i, j)+zpl*zmi*h)*f1ab(i) + temp0ab1 = molal(j+3)*yjiab/water + molalab(j+3) = molalab(j+3) + ch*yjiab/water + chab = mpl*xijab + temp0ab1 + waterab = waterab - ch*temp0ab1/water + mplab = mplab + ch*xijab + ionicab = ionicab - (zpl+zmi)**2*0.25d0*chab/ionic**2 + ENDDO + CALL POPREAL8(mpl) + molalab(i) = molalab(i) + mplab/water + waterab = waterab - molal(i)*mplab/water**2 + CALL POPREAL8(zpl) + ENDDO + temp0ab0 = agama*hab/(sion+1.d0) + sionab = (1.D0-sion/(sion+1.d0))*temp0ab0 + IF (.NOT.ionic .EQ. 0.0) ionicab = ionicab + sionab/(2.0*SQRT( + + ionic)) + g05ab = g0ab(3, 4) + g0ab(3, 4) = 0.D0 + g09ab = g0ab(3, 3) + g0ab(3, 3) = 0.D0 + g04ab = g0ab(3, 2) + g0ab(3, 2) = 0.D0 + g06ab = g0ab(3, 1) + g0ab(3, 1) = 0.D0 + g03ab = g0ab(2, 4) + g0ab(2, 4) = 0.D0 + g12ab = g0ab(2, 3) + g0ab(2, 3) = 0.D0 + g02ab = g0ab(2, 2) + g0ab(2, 2) = 0.D0 + g01ab = g0ab(2, 1) + g0ab(2, 1) = 0.D0 + g10ab = g0ab(1, 4) + g0ab(1, 4) = 0.D0 + g08ab = g0ab(1, 3) + g0ab(1, 3) = 0.D0 + g07ab = g0ab(1, 2) + g0ab(1, 2) = 0.D0 + g11ab = g0ab(1, 1) + CALL KMFUL3_AB(ionic, ionicab, temp, g01, g01ab, g02, g02ab, g03, + + g03ab, g04, g04ab, g05, g05ab, g06, g06ab, g07, + + g07ab, g08, g08ab, g09, g09ab, g10, g10ab, g11, + + g11ab, g12, g12ab) + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + CALL POPREAL8(ionic) + x1ab = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1ab = ionicab + END IF + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + ionicab = 0.D0 + ELSE + temp0ab = 0.5d0*x1ab/water + ionicab = temp0ab + waterab = waterab - ionic*temp0ab/water + END IF + DO i=7,1,-1 + molalab(i) = molalab(i) + z(i)**2*ionicab + ENDDO + END + +C Differentiation of kmful3 in reverse (adjoint) mode: +C gradient of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 ionic +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C +C======================================================================= +C + SUBROUTINE KMFUL3_AB(ionic, ionicab, temp, g01, g01ab, g02, g02ab + + , g03, g03ab, g04, g04ab, g05, g05ab, g06, + + g06ab, g07, g07ab, g08, g08ab, g09, g09ab, + + g10, g10ab, g11, g11ab, g12, g12ab) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionicab, sionab, cf2ab + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01ab, g02ab, g03ab, g04ab, g05ab, g06ab, g07ab, + + g08ab, g09ab, g10ab, g11ab, g12ab + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTEGER :: branch + REAL*8 :: temp0ab0 + INTRINSIC ABS + REAL*8 :: temp0ab + REAL*8 :: abs1 + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc .GE. 0.) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 .GT. 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01ab = g01ab + g12ab + g08ab = g08ab + g09ab + g12ab + g11ab = g11ab - g09ab - g12ab + g06ab = g06ab + g09ab + CALL POPCONTROL1B(branch) + IF (branch .EQ. 0) THEN + cf2ab = -(z10*g10ab) - z07*g07ab - z05*g05ab - z03*g03ab - z01* + + g01ab - z02*g02ab - z04*g04ab - z06*g06ab - z08*g08ab - z11* + + g11ab + g11ab = cf1*g11ab + g10ab = cf1*g10ab + g08ab = cf1*g08ab + g07ab = cf1*g07ab + g06ab = cf1*g06ab + g05ab = cf1*g05ab + g04ab = cf1*g04ab + g03ab = cf1*g03ab + g02ab = cf1*g02ab + g01ab = cf1*g01ab + temp0ab = (0.125d0-ti*0.005d0)*cf2ab + temp0ab0 = -(0.41d0*temp0ab/(sion+1.d0)) + ionicab = ionicab + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0ab + sionab = (1.D0-sion/(sion+1.d0))*temp0ab0 + ELSE + sionab = 0.D0 + END IF + CALL MKBI_AB(q11, ionic, ionicab, sion, sionab, z11, g11, g11ab) + CALL MKBI_AB(q10, ionic, ionicab, sion, sionab, z10, g10, g10ab) + CALL MKBI_AB(q8, ionic, ionicab, sion, sionab, z08, g08, g08ab) + CALL MKBI_AB(q7, ionic, ionicab, sion, sionab, z07, g07, g07ab) + CALL MKBI_AB(q6, ionic, ionicab, sion, sionab, z06, g06, g06ab) + CALL MKBI_AB(q5, ionic, ionicab, sion, sionab, z05, g05, g05ab) + CALL MKBI_AB(q4, ionic, ionicab, sion, sionab, z04, g04, g04ab) + CALL MKBI_AB(q3, ionic, ionicab, sion, sionab, z03, g03, g03ab) + CALL MKBI_AB(q2, ionic, ionicab, sion, sionab, z02, g02, g02ab) + CALL MKBI_AB(q1, ionic, ionicab, sion, sionab, z01, g01, g01ab) + IF (.NOT.ionic .EQ. 0.0) ionicab = ionicab + sionab/(2.0*SQRT( + + ionic)) + END + +C Differentiation of mkbi in reverse (adjoint) mode: +C gradient of useful results: sion bi ionic +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C +C======================================================================= +C + SUBROUTINE MKBI_AB(q, ionic, ionicab, sion, sionab, zip, bi, biab) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionicab, sionab, biab + REAL*8 :: b, c, xx + REAL*8 :: cab, xxab + REAL*8 :: tempab + INTRINSIC EXP + REAL*8 :: tempab0 + INTRINSIC LOG10 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC.LT.6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic)) + bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b +C + xxab = zip*biab + biab = zip*biab/(bi*LOG(10.0)) + tempab = -(0.5107d0*xxab/(c*sion+1.d0)) + tempab0 = -(sion*tempab/(c*sion+1.d0)) + sionab = sionab + c*tempab0 + tempab + cab = sion*tempab0 + IF (.1d0*ionic + 1.d0 .LE. 0.0 .AND. (q .EQ. 0.0 .OR. q .NE. INT(q + + ))) THEN + ionicab = ionicab - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3* + + ionic**2*cab + ELSE + ionicab = ionicab + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*biab - + + .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cab + END IF + END + +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of calcb4 in reverse (adjoint) mode: +C gradient of useful results: aerliq gas +C with respect to varying inputs: wp aerliq gas +C RW status of diff variables: wp:out aerliq:in-out gas:in-out +C +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCB4 +C *** CASE B4 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE +C +C FOR CALCULATIONS, A BISECTION IS PERFORMED WITH RESPECT TO H+. +C THE OBJECTIVE FUNCTION IS THE DIFFERENCE BETWEEN THE ESTIMATED H+ +C AND THAT CALCULATED FROM ELECTRONEUTRALITY. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCB4_BB(wpbb, gasbb, aerliqbb) + INCLUDE 'isrpia_adj.inc' + + REAL*8 :: x, y, so4i, hso4i, bb, cc, dd + REAL*8 :: so4ibb, hso4ibb, bbbb, ccbb, ddbb + REAL*8 :: gas(3), AERLIQ(NIONS+NGASAQ+2) + REAL*8 :: wpbb(ncomp), gasbb(3), aerliqbb(NIONS+NGASAQ+2) + REAL*8 :: wbb(ncomp) + INTEGER :: i + REAL*8 :: ak1 + REAL*8 :: ak1bb + REAL*8 :: bet + REAL*8 :: betbb + REAL*8 :: gam + REAL*8 :: gambb + INTEGER :: j + INTEGER :: branch + INTEGER :: ad_count + INTEGER :: i0 + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp0bb + INTRINSIC MAX + REAL*8 :: x4 + REAL*8 :: x3 + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x3bb + REAL*8 :: temp1bb + REAL*8 :: x1bb + REAL*8 :: x4bb + INTRINSIC MIN + REAL*8 :: temp2bb + INTEGER :: ii1, npflag, ncase + INTRINSIC SQRT + REAL*8 :: x2bb + REAL*8 :: molalrbb(npair) +C +C *** SOLVE EQUATIONS ************************************************** +C + frst = .true. + calain = .true. +C +C *** CALCULATE WATER CONTENT ****************************************** +C +C +C CALL CALCB1A ! GET DRY SALT CONTENT, AND USE FOR WATER. +C +C *** SETUP PARAMETERS ************************************************ +C +C Equivalent NH4HSO4 + x = 2.d0*w(2) - w(3) +C Equivalent (NH4)2SO4 + y = w(3) - w(2) +C +C *** CALCULATE COMPOSITION ******************************************* +C + IF (x <= y) THEN +C LC is the MIN(x,y) +CX ! NH4HSO4 >= (NH4)2S04 + clc = 2.d0*w(2) - w(3) + cnh4hs4 = zero +CY-X + cnh42s4 = 2.d0*w(3) - 3.d0*w(2) + CALL PUSHCONTROL1B(0) + ELSE +CY ! NH4HSO4 < (NH4)2S04 + clc = w(3) - w(2) +CX-Y + cnh4hs4 = 3.d0*w(2) - 2.d0*w(3) + cnh42s4 = zero + CALL PUSHCONTROL1B(1) + END IF +C + molalr(13) = clc + molalr(9) = cnh4hs4 + molalr(4) = cnh42s4 + water = molalr(13)/m0(13) + molalr(9)/m0(9) + molalr(4)/m0(4) +C +C NH4I + molal(3) = w(3) +C + i = 1 + ad_count = 0 +C NSWEEP = 50 + DO WHILE (i <= nsweep .AND. calain) + CALL PUSHREAL8(ak1) +C IF (I > 1) CALL CALCACT3 + ak1 = xk1*(gama(8)/gama(7))**2.*(water/gama(7)) + bet = w(2) + gam = molal(3) + CALL PUSHREAL8(bb) +C + bb = bet + ak1 - gam + cc = -(ak1*bet) + dd = bb*bb - 4.d0*cc + x4 = 0.5*(-bb+SQRT(dd)) + IF (x4 > w(2)) THEN + x1 = w(2) + CALL PUSHCONTROL1B(0) + ELSE + x1 = x4 + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(molal(5)) + molal(5) = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(molal(5)) + molal(5) = x1 + CALL PUSHCONTROL1B(1) + END IF + IF (w(2) - molal(5) > w(2)) THEN + x2 = w(2) + CALL PUSHCONTROL1B(0) + ELSE + x2 = w(2) - molal(5) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < tiny) THEN + CALL PUSHREAL8(molal(6)) + molal(6) = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(molal(6)) + molal(6) = x2 + CALL PUSHCONTROL1B(1) + END IF + IF (ak1*molal(6)/molal(5) > w(2)) THEN + x3 = w(2) + CALL PUSHCONTROL1B(0) + ELSE + x3 = ak1*molal(6)/molal(5) + CALL PUSHCONTROL1B(1) + END IF + IF (x3 < tiny) THEN + CALL PUSHREAL8(molal(1)) + molal(1) = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(molal(1)) + molal(1) = x3 + CALL PUSHCONTROL1B(1) + END IF +C +C CALL CALCMR ! Water content +C +C CORRECT FOR HSO4 DISSOCIATION + so4i = molal(5) - molal(1) + hso4i = molal(6) + molal(1) + IF (so4i < hso4i) THEN +C [LC] = [SO4] + molalr(13) = so4i + IF (hso4i - so4i < zero) THEN + molalr(9) = zero + CALL PUSHCONTROL2B(1) + ELSE + molalr(9) = hso4i - so4i + CALL PUSHCONTROL2B(0) + END IF + ELSE +C [LC] = [HSO4] + molalr(13) = hso4i + IF (so4i - hso4i < zero) THEN + molalr(4) = zero + CALL PUSHCONTROL2B(3) + ELSE + molalr(4) = so4i - hso4i + CALL PUSHCONTROL2B(2) + END IF + END IF + CALL PUSHREAL8(water) +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + DO j=1,npair + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C +C IF (.NOT.CALAIN) GOTO 30 + i = i + 1 + CALL PUSHREAL8ARRAY(gama, npair) +C*** slc.11.2009 moved to beginning of loop + CALL CALCACT3() + ad_count = ad_count + 1 + ENDDO + IF (CALAIN .AND. (I > (NSWEEP+1))) THEN + CALL PUSHERR (0001, 'CALCB4') ! WARNING ERROR: NO SOLUTION + ENDIF + CALL PUSHINTEGER4(ad_count) + DO ii1=1,nions + molalbb(ii1) = 0.D0 + ENDDO + DO i=nions,1,-1 + molalbb(i) = molalbb(i) + aerliqbb(i) + ENDDO + aerliqbb = 0.D0 + gasbb(3) = 0.D0 + gasbb(2) = 0.D0 + gnh3bb = gasbb(1) + gasbb(1) = 0.D0 + CALL CALCNH3_BB() + DO ii1=1,ncomp + wbb(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + molalrbb(ii1) = 0.D0 + ENDDO + waterbb = 0.D0 + CALL POPINTEGER4(ad_count) + DO i0=1,ad_count + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3_BB() + CALL POPCONTROL1B(branch) + IF (branch == 0) waterbb = 0.D0 + DO j=npair,1,-1 + molalrbb(j) = molalrbb(j) + waterbb/m0(j) + ENDDO + CALL POPREAL8(water) + CALL POPCONTROL2B(branch) + IF (branch < 2) THEN + IF (branch == 0) THEN + hso4ibb = molalrbb(9) + so4ibb = -molalrbb(9) + molalrbb(9) = 0.D0 + ELSE + molalrbb(9) = 0.D0 + hso4ibb = 0.D0 + so4ibb = 0.D0 + END IF + so4ibb = so4ibb + molalrbb(13) + molalrbb(13) = 0.D0 + ELSE + IF (branch == 2) THEN + so4ibb = molalrbb(4) + hso4ibb = -molalrbb(4) + molalrbb(4) = 0.D0 + ELSE + molalrbb(4) = 0.D0 + hso4ibb = 0.D0 + so4ibb = 0.D0 + END IF + hso4ibb = hso4ibb + molalrbb(13) + molalrbb(13) = 0.D0 + END IF + molalbb(6) = molalbb(6) + hso4ibb + molalbb(1) = molalbb(1) + hso4ibb + molalbb(5) = molalbb(5) + so4ibb + molalbb(1) = molalbb(1) - so4ibb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(molal(1)) + molalbb(1) = 0.D0 + x3bb = 0.D0 + ELSE + CALL POPREAL8(molal(1)) + x3bb = molalbb(1) + molalbb(1) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + wbb(2) = wbb(2) + x3bb + ak1 = xk1*(gama(8)/gama(7))**2.*(water/gama(7)) + ak1bb = 0.D0 + ELSE + temp2bb = x3bb/molal(5) + ak1bb = molal(6)*temp2bb + molalbb(6) = molalbb(6) + ak1*temp2bb + molalbb(5) = molalbb(5) - ak1*molal(6)*temp2bb/molal(5) + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(molal(6)) + molalbb(6) = 0.D0 + x2bb = 0.D0 + ELSE + CALL POPREAL8(molal(6)) + x2bb = molalbb(6) + molalbb(6) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + wbb(2) = wbb(2) + x2bb + ELSE + wbb(2) = wbb(2) + x2bb + molalbb(5) = molalbb(5) - x2bb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(molal(5)) + molalbb(5) = 0.D0 + x1bb = 0.D0 + ELSE + CALL POPREAL8(molal(5)) + x1bb = molalbb(5) + molalbb(5) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + wbb(2) = wbb(2) + x1bb + x4bb = 0.D0 + ELSE + x4bb = x1bb + END IF + bet = w(2) + gam = molal(3) + bb = bet + ak1 - gam + cc = -(ak1*bet) + dd = bb*bb - 4.d0*cc + IF (dd == 0.0) THEN + ddbb = 0.0 + ELSE + ddbb = 0.5*x4bb/(2.0*SQRT(dd)) + END IF + bbbb = 2*bb*ddbb - 0.5*x4bb + ccbb = -(4.d0*ddbb) + ak1bb = ak1bb + bbbb - bet*ccbb + betbb = bbbb - ak1*ccbb + CALL POPREAL8(bb) + gambb = -bbbb + molalbb(3) = molalbb(3) + gambb + wbb(2) = wbb(2) + betbb + CALL POPREAL8(ak1) + temp0 = water/gama(7) + temp1 = gama(8)/gama(7) + temp1bb = 2.*temp1*temp0*xk1*ak1bb/gama(7) + temp0bb = temp1**2.*xk1*ak1bb/gama(7) + gamabb(8) = gamabb(8) + temp1bb + gamabb(7) = gamabb(7) - temp0*temp0bb - temp1*temp1bb + waterbb = temp0bb + ENDDO + wbb(3) = wbb(3) + molalbb(3) + molalrbb(13) = molalrbb(13) + waterbb/m0(13) + molalrbb(9) = molalrbb(9) + waterbb/m0(9) + molalrbb(4) = molalrbb(4) + waterbb/m0(4) + cnh42s4bb = molalrbb(4) + molalrbb(4) = 0.D0 + cnh4hs4bb = molalrbb(9) + molalrbb(9) = 0.D0 + clcbb = molalrbb(13) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + wbb(3) = wbb(3) + 2.d0*cnh42s4bb + wbb(2) = wbb(2) + 2.d0*clcbb - 3.d0*cnh42s4bb + wbb(3) = wbb(3) - clcbb + ELSE + wbb(2) = wbb(2) + 3.d0*cnh4hs4bb + wbb(3) = wbb(3) + clcbb - 2.d0*cnh4hs4bb + wbb(2) = wbb(2) - clcbb + END IF + wpbb = wbb + + END +C +C Differentiation of calcnh3 in reverse (adjoint) mode: +C gradient of useful results: molal gnh3 +C with respect to varying inputs: molal gama +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNH3 +C *** CALCULATES AMMONIA IN GAS PHASE +C +C AMMONIA IN THE GAS PHASE IS ASSUMED A MINOR SPECIES, THAT +C DOES NOT SIGNIFICANTLY PERTURB THE AEROSOL EQUILIBRIUM. +C AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l) +C EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION. +C +C THIS IS THE VERSION USED BY THE DIRECT PROBLEM +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNH3_BB() + INCLUDE 'isrpia_adj.inc' + + REAL*8 :: a1bb + REAL*8 :: chi1bb + REAL*8 :: chi2bb +C + REAL*8 :: bb, cc, diak, psi + REAL*8 :: bbbb, ccbb, diakbb, psibb + INTEGER :: branch + REAL*8 :: temp0 + REAL*8 :: temp0bb + INTRINSIC MAX + REAL*8 :: x1 + REAL*8 :: temp1bb + REAL*8 :: x1bb + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** IS THERE A LIQUID PHASE? ****************************************** +C + IF (water <= tiny) THEN + DO ii1=1,npair + gamabb(ii1) = 0.D0 + ENDDO + ELSE +C +C *** CALCULATE NH3 SUBLIMATION ***************************************** +C + a1 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + chi1 = molal(3) + chi2 = molal(1) +C +C a=1; b!=1; c!=1 + bb = chi2 + one/a1 + cc = -(chi1/a1) +C Always > 0 + diak = SQRT(bb*bb - 4.d0*cc) +C One positive root + psi = 0.5*(-bb+diak) + IF (psi > chi1) THEN + x1 = chi1 + CALL PUSHCONTROL1B(0) + ELSE + x1 = psi + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + chi2bb = molalbb(1) + psibb = molalbb(1) + molalbb(1) = 0.D0 + chi1bb = molalbb(3) + psibb = psibb + gnh3bb - molalbb(3) + molalbb(3) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + x1bb = 0.D0 + ELSE + x1bb = psibb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + chi1bb = chi1bb + x1bb + psibb = 0.D0 + ELSE + psibb = x1bb + END IF + diakbb = 0.5*psibb + IF (bb**2 - 4.d0*cc == 0.0) THEN + temp1bb = 0.0 + ELSE + temp1bb = diakbb/(2.0*SQRT(bb**2-4.d0*cc)) + END IF + bbbb = 2*bb*temp1bb - 0.5*psibb + ccbb = -(4.d0*temp1bb) + chi1bb = chi1bb - ccbb/a1 + a1bb = chi1*ccbb/a1**2 - one*bbbb/a1**2 + chi2bb = chi2bb + bbbb + molalbb(1) = molalbb(1) + chi2bb + molalbb(3) = molalbb(3) + chi1bb + DO ii1=1,npair + gamabb(ii1) = 0.D0 + ENDDO + temp0 = gama(10)/gama(5) + temp0bb = 2.0*temp0*xk2*r*temp*a1bb/(xkw*gama(5)) + gamabb(10) = gamabb(10) + temp0bb + gamabb(5) = gamabb(5) - temp0*temp0bb + END IF + END + +C Differentiation of calcact3 in reverse (adjoint) mode: +C gradient of useful results: molal gama water +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3_BB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2(4) + REAL*8 :: g0bb(6, 4), sionbb, hbb, chbb, f1bb(3), f2bb(4) + REAL*8 :: mpl, xij, yji, ionicbb + REAL*8 :: mplbb, xijbb, yjibb + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01bb + REAL*8 :: g02 + REAL*8 :: g02bb + REAL*8 :: g03 + REAL*8 :: g03bb + REAL*8 :: g04 + REAL*8 :: g04bb + REAL*8 :: g05 + REAL*8 :: g05bb + REAL*8 :: g06 + REAL*8 :: g06bb + REAL*8 :: g07 + REAL*8 :: g07bb + REAL*8 :: g08 + REAL*8 :: g08bb + REAL*8 :: g09 + REAL*8 :: g09bb + REAL*8 :: g10 + REAL*8 :: g10bb + REAL*8 :: g11 + REAL*8 :: g11bb + REAL*8 :: g12 + REAL*8 :: g12bb + INTEGER :: j + REAL*8 :: errou + REAL*8 :: errin +C + INTEGER :: branch + REAL*8 :: temp0bb10 + REAL*8 :: temp0bb + INTRINSIC MAX + INTRINSIC ABS + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: temp0bb9 + REAL*8 :: temp0bb8 + REAL*8 :: temp0bb7 + REAL*8 :: temp0bb6 + REAL*8 :: temp0bb5 + REAL*8 :: temp0bb4 + REAL*8 :: temp0bb3 + REAL*8 :: temp0bb2 + REAL*8 :: temp0bb1 + REAL*8 :: temp0bb0 + REAL*8 :: x1bb + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: x2bb + REAL*8 :: temp0bb13 + REAL*8 :: temp0bb12 + REAL*8 :: y1 + REAL*8 :: temp0bb11 +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + DO i=1,7 + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08, + + g09, g10, g11, g12) +C + g0(1, 1) = g11 + g0(1, 2) = g07 + g0(1, 3) = g08 + g0(1, 4) = g10 + g0(2, 1) = g01 + g0(2, 2) = g02 + g0(2, 3) = g12 + g0(2, 4) = g03 + g0(3, 1) = g06 + g0(3, 2) = g04 + g0(3, 3) = g09 + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + sion = SQRT(ionic) + h = agama*sion/(1.d0+sion) +C +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + yji = ch*molal(j+3)/water + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gama(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gama(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gama(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gama(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gama(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gama(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gama(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gama(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gama(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gama(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gama(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gama(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gama(13)) +C LC ; SCAPE + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + ELSE + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + gamabb(i) = 10.d0**gama(i)*LOG(10.d0)*gamabb(i) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + gamabb(i) = 0.D0 + x2bb = 0.D0 + ELSE + x2bb = gamabb(i) + gamabb(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) gamabb(i) = gamabb(i) + x2bb + ENDDO + CALL POPREAL8(gama(13)) + gamabb(4) = gamabb(4) + 0.2d0*3.d0*gamabb(13) + gamabb(9) = gamabb(9) + 0.2d0*2.d0*gamabb(13) + gamabb(13) = 0.D0 + DO ii1=1,3 + f1bb(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2bb(ii1) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp0bb2 = zz(12)*gamabb(12)/(z(2)+z(6)) + f1bb(2) = f1bb(2) + temp0bb2/z(2) + f2bb(3) = f2bb(3) + temp0bb2/z(6) + hbb = -(zz(12)*gamabb(12)) + gamabb(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp0bb3 = zz(11)*gamabb(11)/(z(1)+z(4)) + f2bb(1) = f2bb(1) + temp0bb3/z(4) + hbb = hbb - zz(11)*gamabb(11) + gamabb(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp0bb4 = zz(10)*gamabb(10)/(z(1)+z(7)) + f1bb(1) = f1bb(1) + temp0bb4/z(1) + temp0bb3/z(1) + f2bb(4) = f2bb(4) + temp0bb4/z(7) + hbb = hbb - zz(10)*gamabb(10) + gamabb(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp0bb5 = zz(9)*gamabb(9)/(z(3)+z(6)) + f1bb(3) = f1bb(3) + temp0bb5/z(3) + hbb = hbb - zz(9)*gamabb(9) + gamabb(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp0bb6 = zz(8)*gamabb(8)/(z(1)+z(6)) + f2bb(3) = f2bb(3) + temp0bb6/z(6) + temp0bb5/z(6) + hbb = hbb - zz(8)*gamabb(8) + gamabb(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp0bb7 = zz(7)*gamabb(7)/(z(1)+z(5)) + f1bb(1) = f1bb(1) + temp0bb7/z(1) + temp0bb6/z(1) + f2bb(2) = f2bb(2) + temp0bb7/z(5) + hbb = hbb - zz(7)*gamabb(7) + gamabb(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp0bb8 = zz(6)*gamabb(6)/(z(3)+z(4)) + f2bb(1) = f2bb(1) + temp0bb8/z(4) + hbb = hbb - zz(6)*gamabb(6) + gamabb(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp0bb9 = zz(5)*gamabb(5)/(z(3)+z(7)) + f2bb(4) = f2bb(4) + temp0bb9/z(7) + hbb = hbb - zz(5)*gamabb(5) + gamabb(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp0bb10 = zz(4)*gamabb(4)/(z(3)+z(5)) + f1bb(3) = f1bb(3) + temp0bb9/z(3) + temp0bb10/z(3) + temp0bb8/z(3) + f2bb(2) = f2bb(2) + temp0bb10/z(5) + hbb = hbb - zz(4)*gamabb(4) + gamabb(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp0bb11 = zz(3)*gamabb(3)/(z(2)+z(7)) + f2bb(4) = f2bb(4) + temp0bb11/z(7) + hbb = hbb - zz(3)*gamabb(3) + gamabb(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp0bb12 = zz(2)*gamabb(2)/(z(2)+z(5)) + f2bb(2) = f2bb(2) + temp0bb12/z(5) + hbb = hbb - zz(2)*gamabb(2) + gamabb(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp0bb13 = zz(1)*gamabb(1)/(z(2)+z(4)) + f1bb(2) = f1bb(2) + temp0bb12/z(2) + temp0bb13/z(2) + temp0bb11/z( + + 2) + f2bb(1) = f2bb(1) + temp0bb13/z(4) + hbb = hbb - zz(1)*gamabb(1) + gamabb(1) = 0.D0 + ionicbb = 0.D0 + DO ii1=1,4 + DO ii2=1,6 + g0bb(ii2, ii1) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mplbb = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijbb = (g0(i, j)+zpl*zmi*h)*f2bb(j) + yji = ch*molal(j+3)/water + g0bb(i, j) = g0bb(i, j) + yji*f1bb(i) + xij*f2bb(j) + hbb = hbb + yji*zpl*zmi*f1bb(i) + xij*zpl*zmi*f2bb(j) + yjibb = (g0(i, j)+zpl*zmi*h)*f1bb(i) + temp0bb1 = molal(j+3)*yjibb/water + molalbb(j+3) = molalbb(j+3) + ch*yjibb/water + chbb = mpl*xijbb + temp0bb1 + waterbb = waterbb - ch*temp0bb1/water + mplbb = mplbb + ch*xijbb + ionicbb = ionicbb - (zpl+zmi)**2*0.25d0*chbb/ionic**2 + ENDDO + CALL POPREAL8(mpl) + molalbb(i) = molalbb(i) + mplbb/water + waterbb = waterbb - molal(i)*mplbb/water**2 + CALL POPREAL8(zpl) + ENDDO + temp0bb0 = agama*hbb/(sion+1.d0) + sionbb = (1.D0-sion/(sion+1.d0))*temp0bb0 + IF (.NOT.ionic == 0.0) ionicbb = ionicbb + sionbb/(2.0*SQRT( + + ionic)) + g05bb = g0bb(3, 4) + g0bb(3, 4) = 0.D0 + g09bb = g0bb(3, 3) + g0bb(3, 3) = 0.D0 + g04bb = g0bb(3, 2) + g0bb(3, 2) = 0.D0 + g06bb = g0bb(3, 1) + g0bb(3, 1) = 0.D0 + g03bb = g0bb(2, 4) + g0bb(2, 4) = 0.D0 + g12bb = g0bb(2, 3) + g0bb(2, 3) = 0.D0 + g02bb = g0bb(2, 2) + g0bb(2, 2) = 0.D0 + g01bb = g0bb(2, 1) + g0bb(2, 1) = 0.D0 + g10bb = g0bb(1, 4) + g0bb(1, 4) = 0.D0 + g08bb = g0bb(1, 3) + g0bb(1, 3) = 0.D0 + g07bb = g0bb(1, 2) + g0bb(1, 2) = 0.D0 + g11bb = g0bb(1, 1) + CALL KMFUL3_BB(ionic, ionicbb, temp, g01, g01bb, g02, g02bb, g03, + + g03bb, g04, g04bb, g05, g05bb, g06, g06bb, g07, + + g07bb, g08, g08bb, g09, g09bb, g10, g10bb, g11, + + g11bb, g12, g12bb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionic) + x1bb = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1bb = ionicbb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ionicbb = 0.D0 + ELSE + temp0bb = 0.5d0*x1bb/water + ionicbb = temp0bb + waterbb = waterbb - ionic*temp0bb/water + END IF + DO i=7,1,-1 + molalbb(i) = molalbb(i) + z(i)**2*ionicbb + ENDDO + END + +C Differentiation of kmful3 in reverse (adjoint) mode: +C gradient of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 ionic +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_BB(ionic, ionicbb, temp, g01, g01bb, g02, g02bb + + , g03, g03bb, g04, g04bb, g05, g05bb, g06, + + g06bb, g07, g07bb, g08, g08bb, g09, g09bb, + + g10, g10bb, g11, g11bb, g12, g12bb) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionicbb, sionbb, cf2bb + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01bb, g02bb, g03bb, g04bb, g05bb, g06bb, g07bb, + + g08bb, g09bb, g10bb, g11bb, g12bb + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTEGER :: branch + REAL*8 :: temp0bb + INTRINSIC ABS + REAL*8 :: temp0bb0 + REAL*8 :: abs1 + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01bb = g01bb + g12bb + g08bb = g08bb + g09bb + g12bb + g11bb = g11bb - g09bb - g12bb + g06bb = g06bb + g09bb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2bb = -(z10*g10bb) - z07*g07bb - z05*g05bb - z03*g03bb - z01* + + g01bb - z02*g02bb - z04*g04bb - z06*g06bb - z08*g08bb - z11* + + g11bb + g11bb = cf1*g11bb + g10bb = cf1*g10bb + g08bb = cf1*g08bb + g07bb = cf1*g07bb + g06bb = cf1*g06bb + g05bb = cf1*g05bb + g04bb = cf1*g04bb + g03bb = cf1*g03bb + g02bb = cf1*g02bb + g01bb = cf1*g01bb + temp0bb = (0.125d0-ti*0.005d0)*cf2bb + temp0bb0 = -(0.41d0*temp0bb/(sion+1.d0)) + ionicbb = ionicbb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0bb + sionbb = (1.D0-sion/(sion+1.d0))*temp0bb0 + ELSE + sionbb = 0.D0 + END IF + CALL MKBI_BB(q11, ionic, ionicbb, sion, sionbb, z11, g11, g11bb) + CALL MKBI_BB(q10, ionic, ionicbb, sion, sionbb, z10, g10, g10bb) + CALL MKBI_BB(q8, ionic, ionicbb, sion, sionbb, z08, g08, g08bb) + CALL MKBI_BB(q7, ionic, ionicbb, sion, sionbb, z07, g07, g07bb) + CALL MKBI_BB(q6, ionic, ionicbb, sion, sionbb, z06, g06, g06bb) + CALL MKBI_BB(q5, ionic, ionicbb, sion, sionbb, z05, g05, g05bb) + CALL MKBI_BB(q4, ionic, ionicbb, sion, sionbb, z04, g04, g04bb) + CALL MKBI_BB(q3, ionic, ionicbb, sion, sionbb, z03, g03, g03bb) + CALL MKBI_BB(q2, ionic, ionicbb, sion, sionbb, z02, g02, g02bb) + CALL MKBI_BB(q1, ionic, ionicbb, sion, sionbb, z01, g01, g01bb) + IF (.NOT.ionic == 0.0) ionicbb = ionicbb + sionbb/(2.0*SQRT( + + ionic)) + END + +C Differentiation of mkbi in reverse (adjoint) mode: +C gradient of useful results: sion bi ionic +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_BB(q, ionic, ionicbb, sion, sionbb, zip, bi, bibb) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionicbb, sionbb, bibb + REAL*8 :: b, c, xx + REAL*8 :: cbb, xxbb + INTRINSIC EXP + REAL*8 :: tempbb0 + REAL*8 :: tempbb + INTRINSIC LOG10 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic)) + bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b +C + xxbb = zip*bibb + bibb = zip*bibb/(bi*LOG(10.0)) + tempbb = -(0.5107d0*xxbb/(c*sion+1.d0)) + tempbb0 = -(sion*tempbb/(c*sion+1.d0)) + sionbb = sionbb + c*tempbb0 + tempbb + cbb = sion*tempbb0 + IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q + + ))) THEN + ionicbb = ionicbb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3* + + ionic**2*cbb + ELSE + ionicbb = ionicbb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bibb - + + .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cbb + END IF + END + +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of calcc2 in reverse (adjoint) mode: +C gradient of useful results: aerliq gas +C with respect to varying inputs: wp aerliq gas +C RW status of diff variables: wp:out aerliq:in-out gas:in-out +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCC2 +C *** CASE C2 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +C 2. THERE IS ONLY A LIQUID PHASE +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCC2_CB(wpcb, gascb, aerliqcb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: lamda, kapa, psi, parm + REAL*8 :: lamdacb, kapacb, psicb, parmcb + REAL*8 :: bb, cc + REAL*8 :: bbcb, cccb + REAL*8 :: molalrcb(npair) + REAL*8 :: gas(3), AERLIQ(NIONS+NGASAQ+2) + REAL*8 :: wcb(ncomp) + REAL*8 :: wpcb(ncomp), gascb(3), aerliqcb(NIONS+NGASAQ+2) + INTEGER :: i + INTEGER :: j + INTEGER :: branch + INTEGER :: ad_count + INTEGER :: i0 + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp1cb + INTRINSIC MAX + REAL*8 :: temp2cb + REAL*8 :: temp0cb + INTEGER :: ii1, npflag, ncase + INTRINSIC SQRT +C +C Outer loop activity calculation flag + frst = .true. + calain = .true. +C +C *** SOLVE EQUATIONS ************************************************** +C +C NH4HSO4 INITIALLY IN SOLUTION + lamda = w(3) +C H2SO4 IN SOLUTION + psi = w(2) - w(3) + i = 1 + ad_count = 0 +C NSWEEP = 50 + DO WHILE (i <= nsweep .AND. calain) +C IF (I > 1) CALL CALCACT3 + parm = water*xk1/gama(7)*(gama(8)/gama(7))**2. + bb = psi + parm + cc = -(parm*(lamda+psi)) + kapa = 0.5*(-bb+SQRT(bb*bb-4.0*cc)) + CALL PUSHREAL8(molal(1)) +C +C *** SPECIATION & WATER CONTENT *************************************** +C +C HI + molal(1) = psi + kapa + CALL PUSHREAL8(molal(3)) +C NH4I + molal(3) = lamda + CALL PUSHREAL8(molal(5)) +C SO4I + molal(5) = kapa + IF (lamda + psi - kapa < tiny) THEN + CALL PUSHREAL8(molal(6)) + molal(6) = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(molal(6)) + molal(6) = lamda + psi - kapa + CALL PUSHCONTROL1B(1) + END IF +C +C CALL CALCMR ! Water content +C +C MOLALR(9) = MOLAL(3) ! NH4HSO4 *** As in ISORROPIA 1.7 +C NH4HSO4 + molalr(4) = molal(3) + IF (w(2) - w(3) < zero) THEN + molalr(7) = zero + CALL PUSHCONTROL1B(0) + ELSE + molalr(7) = w(2) - w(3) + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8(water) + water = zero + DO j=1,npair + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C +C IF (.NOT.CALAIN) GOTO 30 + i = i + 1 + CALL PUSHREAL8ARRAY(gama, npair) +C*** slc.11.2009 moved to beginning of loop + CALL CALCACT3() + ad_count = ad_count + 1 + ENDDO + IF (CALAIN .AND. (I > (NSWEEP+1))) THEN + CALL PUSHERR (0001, 'CALCC2') ! WARNING ERROR: NO SOLUTION + ENDIF + CALL PUSHINTEGER4(ad_count) + DO ii1=1,nions + molalcb(ii1) = 0.D0 + ENDDO + DO i=nions,1,-1 + molalcb(i) = molalcb(i) + aerliqcb(i) + ENDDO + aerliqcb = 0.D0 + gascb(3) = 0.D0 + gascb(2) = 0.D0 + gnh3cb = gascb(1) + gascb(1) = 0.D0 + CALL CALCNH3_CB() + DO ii1=1,ncomp + wcb(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + molalrcb(ii1) = 0.D0 + ENDDO + watercb = 0.D0 + psicb = 0.D0 + lamdacb = 0.D0 + CALL POPINTEGER4(ad_count) + DO i0=1,ad_count + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3_CB() + CALL POPCONTROL1B(branch) + IF (branch == 0) watercb = 0.D0 + DO j=npair,1,-1 + molalrcb(j) = molalrcb(j) + watercb/m0(j) + ENDDO + CALL POPREAL8(water) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + molalrcb(7) = 0.D0 + ELSE + wcb(2) = wcb(2) + molalrcb(7) + wcb(3) = wcb(3) - molalrcb(7) + molalrcb(7) = 0.D0 + END IF + molalcb(3) = molalcb(3) + molalrcb(4) + molalrcb(4) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(molal(6)) + molalcb(6) = 0.D0 + kapacb = 0.D0 + ELSE + CALL POPREAL8(molal(6)) + lamdacb = lamdacb + molalcb(6) + psicb = psicb + molalcb(6) + kapacb = -molalcb(6) + molalcb(6) = 0.D0 + END IF + CALL POPREAL8(molal(5)) + kapacb = kapacb + molalcb(5) + molalcb(5) = 0.D0 + CALL POPREAL8(molal(3)) + lamdacb = lamdacb + molalcb(3) + molalcb(3) = 0.D0 + CALL POPREAL8(molal(1)) + kapacb = kapacb + molalcb(1) + parm = water*xk1/gama(7)*(gama(8)/gama(7))**2. + bb = psi + parm + cc = -(parm*(lamda+psi)) + IF (bb**2 - 4.0*cc == 0.0) THEN + temp2cb = 0.0 + ELSE + temp2cb = 0.5*kapacb/(2.0*SQRT(bb**2-4.0*cc)) + END IF + bbcb = 2*bb*temp2cb - 0.5*kapacb + cccb = -(4.0*temp2cb) + psicb = psicb + bbcb - parm*cccb + molalcb(1) + molalcb(1) = 0.D0 + parmcb = bbcb - (lamda+psi)*cccb + lamdacb = lamdacb - parm*cccb + temp0 = water/gama(7) + temp1 = gama(8)/gama(7) + temp1cb = 2.*temp1*temp0*xk1*parmcb/gama(7) + temp0cb = temp1**2.*xk1*parmcb/gama(7) + gamacb(8) = gamacb(8) + temp1cb + gamacb(7) = gamacb(7) - temp0*temp0cb - temp1*temp1cb + watercb = temp0cb + ENDDO + wcb(2) = wcb(2) + psicb + wcb(3) = wcb(3) + lamdacb - psicb + wpcb = wcb +C + END +C +C +C Differentiation of calcnh3 in reverse (adjoint) mode: +C gradient of useful results: molal gnh3 +C with respect to varying inputs: molal gama +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNH3 +C *** CALCULATES AMMONIA IN GAS PHASE +C +C AMMONIA IN THE GAS PHASE IS ASSUMED A MINOR SPECIES, THAT +C DOES NOT SIGNIFICANTLY PERTURB THE AEROSOL EQUILIBRIUM. +C AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l) +C EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION. +C +C THIS IS THE VERSION USED BY THE DIRECT PROBLEM +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNH3_CB() + INCLUDE 'isrpia_adj.inc' +! + REAL*8 :: a1cb + REAL*8 :: chi1cb + REAL*8 :: chi2cb + REAL*8 :: bb, cc, diak, psi + REAL*8 :: bbcb, cccb, diakcb, psicb + INTEGER :: branch + REAL*8 :: temp0 + REAL*8 :: temp1cb + INTRINSIC MAX + REAL*8 :: x1cb + REAL*8 :: x1 + REAL*8 :: temp0cb + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** IS THERE A LIQUID PHASE? ****************************************** +C + IF (water <= tiny) THEN + DO ii1=1,npair + gamacb(ii1) = 0.D0 + ENDDO + ELSE +C +C *** CALCULATE NH3 SUBLIMATION ***************************************** +C + a1 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + chi1 = molal(3) + chi2 = molal(1) +C +C a=1; b!=1; c!=1 + bb = chi2 + one/a1 + cc = -(chi1/a1) +C Always > 0 + diak = SQRT(bb*bb - 4.d0*cc) +C One positive root + psi = 0.5*(-bb+diak) + IF (psi > chi1) THEN + x1 = chi1 + CALL PUSHCONTROL1B(0) + ELSE + x1 = psi + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + chi2cb = molalcb(1) + psicb = molalcb(1) + molalcb(1) = 0.D0 + chi1cb = molalcb(3) + psicb = psicb + gnh3cb - molalcb(3) + molalcb(3) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + x1cb = 0.D0 + ELSE + x1cb = psicb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + chi1cb = chi1cb + x1cb + psicb = 0.D0 + ELSE + psicb = x1cb + END IF + diakcb = 0.5*psicb + IF (bb**2 - 4.d0*cc == 0.0) THEN + temp1cb = 0.0 + ELSE + temp1cb = diakcb/(2.0*SQRT(bb**2-4.d0*cc)) + END IF + bbcb = 2*bb*temp1cb - 0.5*psicb + cccb = -(4.d0*temp1cb) + chi1cb = chi1cb - cccb/a1 + a1cb = chi1*cccb/a1**2 - one*bbcb/a1**2 + chi2cb = chi2cb + bbcb + molalcb(1) = molalcb(1) + chi2cb + molalcb(3) = molalcb(3) + chi1cb + DO ii1=1,npair + gamacb(ii1) = 0.D0 + ENDDO + temp0 = gama(10)/gama(5) + temp0cb = 2.0*temp0*xk2*r*temp*a1cb/(xkw*gama(5)) + gamacb(10) = gamacb(10) + temp0cb + gamacb(5) = gamacb(5) - temp0*temp0cb + END IF + END + +C Differentiation of calcact3 in reverse (adjoint) mode: +C gradient of useful results: molal gama water +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3_CB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0cb(6, 4), sioncb, hcb, chcb, f1cb(3), f2cb(4) + REAL*8 :: mpl, xij, yji, ioniccb + REAL*8 :: mplcb, xijcb, yjicb + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01cb + REAL*8 :: g02 + REAL*8 :: g02cb + REAL*8 :: g03 + REAL*8 :: g03cb + REAL*8 :: g04 + REAL*8 :: g04cb + REAL*8 :: g05 + REAL*8 :: g05cb + REAL*8 :: g06 + REAL*8 :: g06cb + REAL*8 :: g07 + REAL*8 :: g07cb + REAL*8 :: g08 + REAL*8 :: g08cb + REAL*8 :: g09 + REAL*8 :: g09cb + REAL*8 :: g10 + REAL*8 :: g10cb + REAL*8 :: g11 + REAL*8 :: g11cb + REAL*8 :: g12 + REAL*8 :: g12cb + INTEGER :: j + REAL*8 :: errou + REAL*8 :: errin +C + INTEGER :: branch + REAL*8 :: temp0cb13 + REAL*8 :: temp0cb12 + REAL*8 :: temp0cb11 + REAL*8 :: temp0cb10 + INTRINSIC MAX + REAL*8 :: x1cb + INTRINSIC ABS + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x2cb + REAL*8 :: temp0cb9 + REAL*8 :: temp0cb8 + REAL*8 :: temp0cb7 + REAL*8 :: temp0cb6 + REAL*8 :: temp0cb5 + REAL*8 :: temp0cb4 + REAL*8 :: temp0cb3 + REAL*8 :: temp0cb + REAL*8 :: temp0cb2 + REAL*8 :: temp0cb1 + REAL*8 :: temp0cb0 + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: y1 +C +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + DO i=1,7 + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08, + + g09, g10, g11, g12) +C + g0(1, 1) = g11 + g0(1, 2) = g07 + g0(1, 3) = g08 + g0(1, 4) = g10 + g0(2, 1) = g01 + g0(2, 2) = g02 + g0(2, 3) = g12 + g0(2, 4) = g03 + g0(3, 1) = g06 + g0(3, 2) = g04 + g0(3, 3) = g09 + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + sion = SQRT(ionic) + h = agama*sion/(1.d0+sion) +C +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + yji = ch*molal(j+3)/water + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gama(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gama(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gama(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gama(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gama(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gama(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gama(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gama(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gama(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gama(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gama(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gama(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gama(13)) +C LC ; SCAPE + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + ELSE + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + gamacb(i) = 10.d0**gama(i)*LOG(10.d0)*gamacb(i) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + gamacb(i) = 0.D0 + x2cb = 0.D0 + ELSE + x2cb = gamacb(i) + gamacb(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) gamacb(i) = gamacb(i) + x2cb + ENDDO + CALL POPREAL8(gama(13)) + gamacb(4) = gamacb(4) + 0.2d0*3.d0*gamacb(13) + gamacb(9) = gamacb(9) + 0.2d0*2.d0*gamacb(13) + gamacb(13) = 0.D0 + DO ii1=1,3 + f1cb(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2cb(ii1) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp0cb2 = zz(12)*gamacb(12)/(z(2)+z(6)) + f1cb(2) = f1cb(2) + temp0cb2/z(2) + f2cb(3) = f2cb(3) + temp0cb2/z(6) + hcb = -(zz(12)*gamacb(12)) + gamacb(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp0cb3 = zz(11)*gamacb(11)/(z(1)+z(4)) + f2cb(1) = f2cb(1) + temp0cb3/z(4) + hcb = hcb - zz(11)*gamacb(11) + gamacb(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp0cb4 = zz(10)*gamacb(10)/(z(1)+z(7)) + f1cb(1) = f1cb(1) + temp0cb4/z(1) + temp0cb3/z(1) + f2cb(4) = f2cb(4) + temp0cb4/z(7) + hcb = hcb - zz(10)*gamacb(10) + gamacb(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp0cb5 = zz(9)*gamacb(9)/(z(3)+z(6)) + f1cb(3) = f1cb(3) + temp0cb5/z(3) + hcb = hcb - zz(9)*gamacb(9) + gamacb(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp0cb6 = zz(8)*gamacb(8)/(z(1)+z(6)) + f2cb(3) = f2cb(3) + temp0cb6/z(6) + temp0cb5/z(6) + hcb = hcb - zz(8)*gamacb(8) + gamacb(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp0cb7 = zz(7)*gamacb(7)/(z(1)+z(5)) + f1cb(1) = f1cb(1) + temp0cb7/z(1) + temp0cb6/z(1) + f2cb(2) = f2cb(2) + temp0cb7/z(5) + hcb = hcb - zz(7)*gamacb(7) + gamacb(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp0cb8 = zz(6)*gamacb(6)/(z(3)+z(4)) + f2cb(1) = f2cb(1) + temp0cb8/z(4) + hcb = hcb - zz(6)*gamacb(6) + gamacb(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp0cb9 = zz(5)*gamacb(5)/(z(3)+z(7)) + f2cb(4) = f2cb(4) + temp0cb9/z(7) + hcb = hcb - zz(5)*gamacb(5) + gamacb(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp0cb10 = zz(4)*gamacb(4)/(z(3)+z(5)) + f1cb(3) = f1cb(3) + temp0cb9/z(3) + temp0cb10/z(3) + temp0cb8/z(3) + f2cb(2) = f2cb(2) + temp0cb10/z(5) + hcb = hcb - zz(4)*gamacb(4) + gamacb(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp0cb11 = zz(3)*gamacb(3)/(z(2)+z(7)) + f2cb(4) = f2cb(4) + temp0cb11/z(7) + hcb = hcb - zz(3)*gamacb(3) + gamacb(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp0cb12 = zz(2)*gamacb(2)/(z(2)+z(5)) + f2cb(2) = f2cb(2) + temp0cb12/z(5) + hcb = hcb - zz(2)*gamacb(2) + gamacb(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp0cb13 = zz(1)*gamacb(1)/(z(2)+z(4)) + f1cb(2) = f1cb(2) + temp0cb12/z(2) + temp0cb13/z(2) + temp0cb11/z( + + 2) + f2cb(1) = f2cb(1) + temp0cb13/z(4) + hcb = hcb - zz(1)*gamacb(1) + gamacb(1) = 0.D0 + ioniccb = 0.D0 + DO ii1=1,4 + DO ii2=1,6 + g0cb(ii2, ii1) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mplcb = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijcb = (g0(i, j)+zpl*zmi*h)*f2cb(j) + yji = ch*molal(j+3)/water + g0cb(i, j) = g0cb(i, j) + yji*f1cb(i) + xij*f2cb(j) + hcb = hcb + yji*zpl*zmi*f1cb(i) + xij*zpl*zmi*f2cb(j) + yjicb = (g0(i, j)+zpl*zmi*h)*f1cb(i) + temp0cb1 = molal(j+3)*yjicb/water + molalcb(j+3) = molalcb(j+3) + ch*yjicb/water + chcb = mpl*xijcb + temp0cb1 + watercb = watercb - ch*temp0cb1/water + mplcb = mplcb + ch*xijcb + ioniccb = ioniccb - (zpl+zmi)**2*0.25d0*chcb/ionic**2 + ENDDO + CALL POPREAL8(mpl) + molalcb(i) = molalcb(i) + mplcb/water + watercb = watercb - molal(i)*mplcb/water**2 + CALL POPREAL8(zpl) + ENDDO + temp0cb0 = agama*hcb/(sion+1.d0) + sioncb = (1.D0-sion/(sion+1.d0))*temp0cb0 + IF (.NOT.ionic == 0.0) ioniccb = ioniccb + sioncb/(2.0*SQRT( + + ionic)) + g05cb = g0cb(3, 4) + g0cb(3, 4) = 0.D0 + g09cb = g0cb(3, 3) + g0cb(3, 3) = 0.D0 + g04cb = g0cb(3, 2) + g0cb(3, 2) = 0.D0 + g06cb = g0cb(3, 1) + g0cb(3, 1) = 0.D0 + g03cb = g0cb(2, 4) + g0cb(2, 4) = 0.D0 + g12cb = g0cb(2, 3) + g0cb(2, 3) = 0.D0 + g02cb = g0cb(2, 2) + g0cb(2, 2) = 0.D0 + g01cb = g0cb(2, 1) + g0cb(2, 1) = 0.D0 + g10cb = g0cb(1, 4) + g0cb(1, 4) = 0.D0 + g08cb = g0cb(1, 3) + g0cb(1, 3) = 0.D0 + g07cb = g0cb(1, 2) + g0cb(1, 2) = 0.D0 + g11cb = g0cb(1, 1) + CALL KMFUL3_CB(ionic, ioniccb, temp, g01, g01cb, g02, g02cb, g03, + + g03cb, g04, g04cb, g05, g05cb, g06, g06cb, g07, + + g07cb, g08, g08cb, g09, g09cb, g10, g10cb, g11, + + g11cb, g12, g12cb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionic) + x1cb = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1cb = ioniccb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ioniccb = 0.D0 + ELSE + temp0cb = 0.5d0*x1cb/water + ioniccb = temp0cb + watercb = watercb - ionic*temp0cb/water + END IF + DO i=7,1,-1 + molalcb(i) = molalcb(i) + z(i)**2*ioniccb + ENDDO + END + +C Differentiation of kmful3 in reverse (adjoint) mode: +C gradient of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 ionic +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_CB(ionic, ioniccb, temp, g01, g01cb, g02, g02cb + + , g03, g03cb, g04, g04cb, g05, g05cb, g06, + + g06cb, g07, g07cb, g08, g08cb, g09, g09cb, + + g10, g10cb, g11, g11cb, g12, g12cb) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ioniccb, sioncb, cf2cb + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01cb, g02cb, g03cb, g04cb, g05cb, g06cb, g07cb, + + g08cb, g09cb, g10cb, g11cb, g12cb + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTEGER :: branch + INTRINSIC ABS + REAL*8 :: temp0cb + REAL*8 :: temp0cb0 + REAL*8 :: abs1 + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01cb = g01cb + g12cb + g08cb = g08cb + g09cb + g12cb + g11cb = g11cb - g09cb - g12cb + g06cb = g06cb + g09cb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2cb = -(z10*g10cb) - z07*g07cb - z05*g05cb - z03*g03cb - z01* + + g01cb - z02*g02cb - z04*g04cb - z06*g06cb - z08*g08cb - z11* + + g11cb + g11cb = cf1*g11cb + g10cb = cf1*g10cb + g08cb = cf1*g08cb + g07cb = cf1*g07cb + g06cb = cf1*g06cb + g05cb = cf1*g05cb + g04cb = cf1*g04cb + g03cb = cf1*g03cb + g02cb = cf1*g02cb + g01cb = cf1*g01cb + temp0cb = (0.125d0-ti*0.005d0)*cf2cb + temp0cb0 = -(0.41d0*temp0cb/(sion+1.d0)) + ioniccb = ioniccb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0cb + sioncb = (1.D0-sion/(sion+1.d0))*temp0cb0 + ELSE + sioncb = 0.D0 + END IF + CALL MKBI_CB(q11, ionic, ioniccb, sion, sioncb, z11, g11, g11cb) + CALL MKBI_CB(q10, ionic, ioniccb, sion, sioncb, z10, g10, g10cb) + CALL MKBI_CB(q8, ionic, ioniccb, sion, sioncb, z08, g08, g08cb) + CALL MKBI_CB(q7, ionic, ioniccb, sion, sioncb, z07, g07, g07cb) + CALL MKBI_CB(q6, ionic, ioniccb, sion, sioncb, z06, g06, g06cb) + CALL MKBI_CB(q5, ionic, ioniccb, sion, sioncb, z05, g05, g05cb) + CALL MKBI_CB(q4, ionic, ioniccb, sion, sioncb, z04, g04, g04cb) + CALL MKBI_CB(q3, ionic, ioniccb, sion, sioncb, z03, g03, g03cb) + CALL MKBI_CB(q2, ionic, ioniccb, sion, sioncb, z02, g02, g02cb) + CALL MKBI_CB(q1, ionic, ioniccb, sion, sioncb, z01, g01, g01cb) + IF (.NOT.ionic == 0.0) ioniccb = ioniccb + sioncb/(2.0*SQRT( + + ionic)) + END + +C Differentiation of mkbi in reverse (adjoint) mode: +C gradient of useful results: sion bi ionic +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_CB(q, ionic, ioniccb, sion, sioncb, zip, bi, bicb) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ioniccb, sioncb, bicb + REAL*8 :: b, c, xx + REAL*8 :: ccb, xxcb + INTRINSIC EXP + REAL*8 :: tempcb + REAL*8 :: tempcb0 + INTRINSIC LOG10 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic)) + bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b +C + xxcb = zip*bicb + bicb = zip*bicb/(bi*LOG(10.0)) + tempcb = -(0.5107d0*xxcb/(c*sion+1.d0)) + tempcb0 = -(sion*tempcb/(c*sion+1.d0)) + sioncb = sioncb + c*tempcb0 + tempcb + ccb = sion*tempcb0 + IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q + + ))) THEN + ioniccb = ioniccb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3* + + ionic**2*ccb + ELSE + ioniccb = ioniccb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bicb - + + .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*ccb + END IF + END + +C + +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of funcd3p in reverse (adjoint) mode: +C gradient of useful results: aerliq gas +C with respect to varying inputs: wp aerliq gas +C RW status of diff variables: wp:out aerliq:in-out gas:in-out +C======================================================================= +C +C *** ISORROPIA CODE +C *** FUNCTION FUNCD3P +C *** CASE D3 +C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ; +C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3. +C +C======================================================================= +C + SUBROUTINE FUNCD3P_DB(p4, y1, wpdb, gasdb, aerliqdb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: chi2db +C + REAL*8 :: gas(3), AERLIQ(NIONS+NGASAQ+2) + REAL*8 :: wpdb(ncomp),gasdb(3) + REAL*8 :: aerliqdb(NIONS+NGASAQ+2) + REAL*8 :: wdb(ncomp) + REAL*8 :: p4, y1, parm, x + REAL*8 :: y1db, xdb + REAL*8 :: x1, x2, xt, y1d, y2, xtd + REAL*8 :: x2db, y1ddb + REAL*8 :: ps, om, omps, diak, ze, delta + REAL*8 :: psdb, omdb, ompsdb, diakdb, zedb, deltadb + CHARACTER(LEN=40) :: errinf + INTEGER :: errstki(25) + LOGICAL :: dexs, iexs, eof + REAL*8 :: absire, feps + CHARACTER(LEN=40) :: errmsgi(25) + INTEGER :: i + INTEGER :: branch, npflag, ncase + INTRINSIC MAX + INTRINSIC ABS + REAL*8 :: abs1 + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** SETUP PARAMETERS ************************************************ +C +C WRITE(*,*) 'Within FUNCD3P_DB' + feps = 1.d-5 + parm = xk10/(r*temp)/(r*temp) +C +C *** CALCULATE NH4NO3 THAT VOLATIZES ********************************* +C + cnh42s4 = w(2) + IF (w(3) - 2.d0*w(2) > w(4)) THEN + x = w(4) + CALL PUSHCONTROL1B(0) + ELSE + x = w(3) - 2.d0*w(2) + CALL PUSHCONTROL1B(1) + END IF + IF (x > zero) THEN + IF (w(3) - 2.0*w(2) < w(4)) THEN + ps = zero + om = w(4) - w(3) + 2.0*w(2) + IF (om < tiny) THEN + om = zero + CALL PUSHCONTROL3B(4) + ELSE + CALL PUSHCONTROL3B(3) + END IF + ELSE + ps = w(3) - w(4) - 2.0*w(2) + IF (ps < tiny) THEN + ps = zero + CALL PUSHCONTROL3B(1) + ELSE + CALL PUSHCONTROL3B(2) + END IF + om = zero + END IF + ELSE + x = zero + IF (w(3) - 2.d0*w(2) < zero) THEN + CALL PUSHCONTROL1B(0) + ps = zero + ELSE + ps = w(3) - 2.d0*w(2) + CALL PUSHCONTROL1B(1) + END IF + IF (ps < tiny) THEN + ps = zero + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + om = w(4) + CALL PUSHCONTROL3B(0) + END IF +C + omps = om + ps +C DIAKRINOUSA + diak = SQRT(omps*omps + 4.0*parm) + IF (x > 0.5*(-omps+diak)) THEN + ze = 0.5*(-omps+diak) + CALL PUSHCONTROL1B(0) + ELSE + ze = x + CALL PUSHCONTROL1B(1) + END IF +C +C *** SPECIATION ******************************************************* +C +C Solid NH4NO3 + cnh4no3 = x - ze +C Gas NH3 + gnh3 = ps + ze +C Gas HNO3 + ghno3 = om + ze +C +C Save from CALCD1 run + chi2 = cnh42s4 + chi3 = ghno3 + chi4 = gnh3 +C +C ASSIGN INITIAL PSI's + psi1 = cnh4no3 + psi2 = chi2 + psi4 = p4 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C +C +C *** NEWTON-RAPHSON DETERMINATION OF ROOT ********************** +C +C WRITE(*,*) 'Before FUNCD3B_DNRD, xt: ',PSI4 + xt = psi4 + xtd = 1.d0 + CALL PUSHREAL8ARRAY(gamadnrd, npair) + CALL PUSHREAL8ARRAY(molaldnrd, nions) + CALL PUSHINTEGER4(iclact) + CALL PUSHREAL8(water) + CALL PUSHREAL8ARRAY(gama, npair) + CALL PUSHREAL8ARRAY(molalr, npair) + CALL PUSHREAL8ARRAY(molal, nions) +C WRITE(*,*) 'PSI4 ',PSI4 +C CALL FUNCD3B(XT,Y1) + CALL FUNCD3B_DNRD(xt, xtd, y1, y1d) + x2 = xt - y1/(y1d*1.d0) + CALL PUSHINTEGER4(iclact) + CALL PUSHREAL8(water) + CALL PUSHREAL8ARRAY(gama, npair) + CALL PUSHREAL8ARRAY(molalr, npair) + CALL PUSHREAL8ARRAY(molal, nions) + CALL FUNCD3B(x2, y2) +C WRITE(*,*) 'x2 ', x2, ' y2 ',y2 + IF (y2 >= 0.) THEN + abs1 = y2 + ELSE + abs1 = -y2 + END IF + IF (abs1 > 10.d0*feps) THEN +C WRITE(*,*) 'abs1 > feps', abs1 + WRITE(ERRINF, '(A,E12.5,A)') 'CALCD3 (',(abs1),')' + CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE + DO ii1=1,nions + molaldb(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + gamadb(ii1) = 0.D0 + ENDDO + waterdb = 0.D0 + gnh3db = 0.D0 + ghno3db = 0.D0 + ELSE +C WRITE(*,*) '********** Testing Newton in CVM *******************' +C WRITE(*,*) 'XT ',XT +C WRITE(*,*) 'Y1 ', Y1 +C WRITE(*,*) 'Y1D ', Y1D +C WRITE(*,*) 'X2 ',X2 +C WRITE(*,*) 'Y2 ',Y2 +C WRITE(*,*) '******** End of testing Newton in CVM ***************' +C + IF (molal(1) > tiny .AND. molal(5) > tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + DO ii1=1,nions + molaldb(ii1) = 0.D0 + ENDDO + DO i=nions,1,-1 + molaldb(i) = molaldb(i) + aerliqdb(i) + ENDDO + aerliqdb = 0.D0 +C WRITE(*,*) 'molaldb',molaldb + gasdb(3) = 0.D0 + ghno3db = gasdb(2) + gasdb(2) = 0.D0 + gnh3db = gasdb(1) + gasdb(1) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + deltadb = molaldb(6) + molaldb(6) = 0.D0 + deltadb = deltadb - molaldb(1) - molaldb(5) + CALL CALCHS4_DB(molal(1), molaldb(1), molal(5), molaldb(5), + + zero, delta, deltadb) + ELSE + DO ii1=1,npair + gamadb(ii1) = 0.D0 + ENDDO + waterdb = 0.D0 + END IF + END IF + CALL POPREAL8ARRAY(molal, nions) + CALL POPREAL8ARRAY(molalr, npair) + CALL POPREAL8ARRAY(gama, npair) + CALL POPREAL8(water) + CALL POPINTEGER4(iclact) + CALL FUNCD3B_DB(x2, x2db, y2) + y1db = -(x2db/y1d) + y1ddb = y1*x2db/y1d**2 + CALL POPREAL8ARRAY(molal, nions) + CALL POPREAL8ARRAY(molalr, npair) + CALL POPREAL8ARRAY(gama, npair) + CALL POPREAL8(water) + CALL POPINTEGER4(iclact) + CALL POPREAL8ARRAY(molaldnrd, nions) + CALL POPREAL8ARRAY(gamadnrd, npair) + CALL FUNCD3B_DNRD_DB(xt, xtd, y1, y1db, y1d, y1ddb) + chi2db = psi2db + cnh4no3db = psi1db + gnh3db = gnh3db + chi4db + ghno3db = ghno3db + chi3db + cnh42s4db = chi2db + omdb = ghno3db + zedb = gnh3db - cnh4no3db + ghno3db + psdb = gnh3db + xdb = cnh4no3db + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + diakdb = 0.5*zedb + ompsdb = -(0.5*zedb) + ELSE + xdb = xdb + zedb + diakdb = 0.D0 + ompsdb = 0.D0 + END IF + IF (.NOT.parm*4.0 + omps**2 == 0.0) ompsdb = ompsdb + 2*omps* + + diakdb/(2.0*SQRT(parm*4.0+omps**2)) + omdb = omdb + ompsdb + psdb = psdb + ompsdb + CALL POPCONTROL3B(branch) + IF (branch < 2) THEN + IF (branch == 0) THEN + DO ii1=1,ncomp + wdb(ii1) = 0.D0 + ENDDO + wdb(4) = wdb(4) + omdb + CALL POPCONTROL1B(branch) + IF (branch == 0) psdb = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + wdb(3) = wdb(3) + psdb + wdb(2) = wdb(2) - 2.d0*psdb + END IF + xdb = 0.D0 + GOTO 100 + ELSE + psdb = 0.D0 + END IF + ELSE IF (branch /= 2) THEN + IF (branch /= 3) omdb = 0.D0 + DO ii1=1,ncomp + wdb(ii1) = 0.D0 + ENDDO + wdb(4) = wdb(4) + omdb + wdb(3) = wdb(3) - omdb + wdb(2) = wdb(2) + 2.0*omdb + GOTO 100 + END IF + DO ii1=1,ncomp + wdb(ii1) = 0.D0 + ENDDO + wdb(3) = wdb(3) + psdb + wdb(4) = wdb(4) - psdb + wdb(2) = wdb(2) - 2.0*psdb + 100 CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + wdb(4) = wdb(4) + xdb + ELSE + wdb(3) = wdb(3) + xdb + wdb(2) = wdb(2) - 2.d0*xdb + END IF + wdb(2) = wdb(2) + cnh42s4db + wpdb = wdb + END + +C Differentiation of funcd3b in reverse (adjoint) mode: +C gradient of useful results: molal gama water gnh3 ghno3 +C with respect to varying inputs: molal molalr gama water gnh3 +C ghno3 chi3 chi4 psi1 psi2 p4 +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** FUNCTION FUNCD3 +C *** CASE D3 +C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ; +C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3. +C +C======================================================================= +C + SUBROUTINE FUNCD3B_DB(p4, p4db, fd3b) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: psi3db + REAL*8 :: psi4db + REAL*8 :: a3db + REAL*8 :: a4db + REAL*8 :: a7db +C + REAL*8 :: p4, bb, denm, ahi, aml5, fd3b + REAL*8 :: p4db, bbdb, denmdb, ahidb, aml5db + CHARACTER(LEN=40) :: errinf + INTEGER :: errstki(25), k, j + LOGICAL :: dexs, iexs, eof + CHARACTER(LEN=40) :: errmsgi(25) + LOGICAL :: tst + INTEGER :: i + REAL*8 :: abb + REAL*8 :: abbdb + INTEGER :: branch + REAL*8 :: temp3 + REAL*8 :: temp2 + REAL*8 :: temp4db + REAL*8 :: temp1 + REAL*8 :: temp0 + INTRINSIC MAX + REAL*8 :: temp2db + INTRINSIC ABS + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x2db + REAL*8 :: temp2db3 + REAL*8 :: temp2db2 + REAL*8 :: temp2db1 + REAL*8 :: temp2db0 + REAL*8 :: temp3db0 + REAL*8 :: temp0db + REAL*8 :: temp4db0 + REAL*8 :: temp3db + REAL*8 :: temp1db + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: x1db + REAL*8 :: max1 +C +C *** SETUP PARAMETERS ************************************************ +C + psi4 = p4 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + DO i=1,3 +C + a3 = xk4*r*temp*(water/gama(10))**2.0 + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + CALL PUSHREAL8(a7) + a7 = xkw*rh*water*water +C + psi3 = a3*a4*chi3*(chi4-psi4) - psi1*(2.d0*psi2+psi1+psi4) + CALL PUSHREAL8(psi3) + psi3 = psi3/(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4) + IF (psi3 < zero) THEN + x1 = zero + CALL PUSHCONTROL1B(0) + ELSE + x1 = psi3 + CALL PUSHCONTROL1B(1) + END IF + IF (x1 > chi3) THEN + psi3 = chi3 + CALL PUSHCONTROL1B(0) + ELSE + psi3 = x1 + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8(bb) +C + bb = psi4 - psi3 + CALL PUSHREAL8(denm) + denm = bb + SQRT(bb*bb + 4.d0*a7) + IF (denm <= tiny) THEN + IF (bb >= 0.) THEN + CALL PUSHREAL8(abb) + abb = bb + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(abb) + abb = -bb + CALL PUSHCONTROL1B(1) + END IF +C Taylor expansion of SQRT + denm = bb + abb + 2.0*a7/abb - 2.0*a7*a7/abb**3.0 +C WRITE(*,*) 'TS approx. of DENM: ',DENM + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + ahi = 2.0*a7/denm + CALL PUSHREAL8(molal(1)) +C +C *** SPECIATION & WATER CONTENT *************************************** +C +C HI + molal(1) = ahi + CALL PUSHREAL8(molal(3)) +C NH4I + molal(3) = psi1 + psi4 + 2.d0*psi2 + CALL PUSHREAL8(molal(5)) +C SO4I + molal(5) = psi2 + CALL PUSHREAL8(molal(6)) +C HSO4I + molal(6) = zero + CALL PUSHREAL8(molal(7)) +C NO3I + molal(7) = psi3 + psi1 +C Solid (NH4)2SO4 +C Solid NH4NO3 +C Gas HNO3 +C Gas NH3 +C +C CALL CALCMR ! Water content +C +C (NH4)2SO4 + molalr(4) = molal(5) + molal(6) +C "free" NH4 + aml5 = molal(3) - 2.d0*molalr(4) + IF (aml5 > molal(7)) THEN + x2 = molal(7) + CALL PUSHCONTROL1B(0) + ELSE + x2 = aml5 + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < zero) THEN + molalr(5) = zero + CALL PUSHCONTROL1B(0) + ELSE + molalr(5) = x2 + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8(water) +C +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + DO j=1,npair + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF + CALL PUSHREAL8ARRAY(gama, npair) +C + CALL CALCACT3P() + ENDDO + DO ii1=1,npair + molalrdb(ii1) = 0.D0 + ENDDO + chi3db = 0.D0 + chi4db = 0.D0 + psi1db = 0.D0 + psi2db = 0.D0 + psi4db = 0.D0 + DO i=3,1,-1 + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3P_DB() + CALL POPCONTROL1B(branch) + IF (branch == 0) waterdb = 0.D0 + DO j=npair,1,-1 + molalrdb(j) = molalrdb(j) + waterdb/m0(j) + ENDDO + CALL POPREAL8(water) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + molalrdb(5) = 0.D0 + x2db = 0.D0 + ELSE + x2db = molalrdb(5) + molalrdb(5) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + molaldb(7) = molaldb(7) + x2db + aml5db = 0.D0 + ELSE + aml5db = x2db + END IF + molaldb(3) = molaldb(3) + aml5db + molalrdb(4) = molalrdb(4) - 2.d0*aml5db + molaldb(5) = molaldb(5) + molalrdb(4) + molaldb(6) = molaldb(6) + molalrdb(4) + molalrdb(4) = 0.D0 + chi4db = chi4db + gnh3db + chi3db = chi3db + ghno3db + psi3db = molaldb(7) - ghno3db + CALL POPREAL8(molal(7)) + psi1db = psi1db + molaldb(7) + molaldb(7) = 0.D0 + CALL POPREAL8(molal(6)) + molaldb(6) = 0.D0 + CALL POPREAL8(molal(5)) + psi2db = psi2db + molaldb(5) + molaldb(5) = 0.D0 + psi4db = psi4db + molaldb(3) - gnh3db + CALL POPREAL8(molal(3)) + psi1db = psi1db + molaldb(3) + psi2db = psi2db + 2.d0*molaldb(3) + molaldb(3) = 0.D0 + CALL POPREAL8(molal(1)) + ahidb = molaldb(1) + molaldb(1) = 0.D0 + temp4db0 = 2.0*ahidb/denm + a7db = temp4db0 + denmdb = -(a7*temp4db0/denm) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + bbdb = 0.D0 + ELSE + temp4db = 2.0*denmdb/abb + temp3 = abb**3.0 + temp3db0 = -(2.0*denmdb/temp3) + bbdb = denmdb + abbdb = denmdb - a7*temp4db/abb - a7**2*3.0*abb**2.0*temp3db0/ + + temp3 + a7db = a7db + 2*a7*temp3db0 + temp4db + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(abb) + bbdb = bbdb + abbdb + ELSE + CALL POPREAL8(abb) + bbdb = bbdb - abbdb + END IF + denmdb = 0.D0 + END IF + CALL POPREAL8(denm) + IF (bb**2 + 4.d0*a7 == 0.0) THEN + temp3db = 0.0 + ELSE + temp3db = denmdb/(2.0*SQRT(bb**2+4.d0*a7)) + END IF + bbdb = bbdb + 2*bb*temp3db + denmdb + a7db = a7db + 4.d0*temp3db + CALL POPREAL8(bb) + psi4db = psi4db + bbdb + psi3db = psi3db - bbdb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + chi3db = chi3db + psi3db + x1db = 0.D0 + ELSE + x1db = psi3db + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + psi3db = 0.D0 + ELSE + psi3db = x1db + END IF + a3 = xk4*r*temp*(water/gama(10))**2.0 + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + CALL POPREAL8(psi3) + temp2 = a3*a4*(chi4-psi4) + 2.d0*psi2 + psi1 + psi4 + temp2db = -(psi3*psi3db/temp2**2) + temp2db0 = a3*a4*temp2db + psi3db = psi3db/temp2 + temp2db1 = chi3*(chi4-psi4)*psi3db + a3db = a4*temp2db1 + (chi4-psi4)*a4*temp2db + a4db = a3*temp2db1 + (chi4-psi4)*a3*temp2db + temp2db2 = a3*a4*psi3db + chi4db = chi4db + chi3*temp2db2 + temp2db0 + temp2db3 = -(psi1*psi3db) + psi4db = psi4db + temp2db3 - chi3*temp2db2 + temp2db - temp2db0 + psi2db = psi2db + 2.d0*temp2db3 + 2.d0*temp2db + psi1db = psi1db + temp2db3 - (2.d0*psi2+psi1+psi4)*psi3db + + + temp2db + chi3db = chi3db + (chi4-psi4)*temp2db2 + CALL POPREAL8(a7) + temp1 = gama(10)/gama(5) + temp1db = 2.0*temp1*xk2*r*temp*a4db/(xkw*gama(5)) + gamadb(10) = gamadb(10) + temp1db + gamadb(5) = gamadb(5) - temp1*temp1db + temp0 = water/gama(10) + temp0db = 2.0*temp0*xk4*r*temp*a3db/gama(10) + waterdb = temp0db + xkw*rh*2*water*a7db + gamadb(10) = gamadb(10) - temp0*temp0db + gnh3db = 0.D0 + ghno3db = 0.D0 + ENDDO + p4db = psi4db + END + +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCHS4 +C *** THIS SUBROUTINE CALCULATES THE HSO4 GENERATED FROM (H,SO4). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCHS4_DB(hi, hidb, so4i, so4idb, hso4i, delta, + + deltadb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: a8db +C + REAL*8 :: hi, so4i, hso4i, delta, bb, cc, dd, sqdd, delta1 + + , delta2 + REAL*8 :: hidb, so4idb, deltadb, bbdb, ccdb, dddb, sqdddb, + + delta1db, delta2db + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp0db + REAL*8 :: temp1db + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** IF TOO LITTLE WATER, DONT SOLVE +C + IF (water <= 1d1*tiny) THEN + DO ii1=1,npair + gamadb(ii1) = 0.D0 + ENDDO + waterdb = 0.D0 + ELSE +C +C *** CALCULATE HSO4 SPECIATION ***************************************** +C + a8 = xk1*water/gama(7)*(gama(8)/gama(7))**2. +C + bb = -(hi+so4i+a8) + cc = hi*so4i - hso4i*a8 + dd = bb*bb - 4.d0*cc +C + IF (dd >= zero) THEN + IF (hso4i <= tiny) THEN + delta2db = deltadb + delta1db = 0.D0 + ELSE IF (hi*so4i >= a8*hso4i) THEN + delta2db = deltadb + delta1db = 0.D0 + ELSE + IF (hi*so4i < a8*hso4i) THEN + delta1db = deltadb + ELSE + delta1db = 0.D0 + END IF + delta2db = 0.D0 + END IF + bbdb = -(0.5*delta1db) - 0.5*delta2db + sqdddb = 0.5*delta1db - 0.5*delta2db + IF (dd == 0.0) THEN + dddb = 0.0 + ELSE + dddb = sqdddb/(2.0*SQRT(dd)) + END IF + ELSE + dddb = 0.D0 + bbdb = 0.D0 + END IF + bbdb = bbdb + 2*bb*dddb + ccdb = -(4.d0*dddb) + hidb = hidb + so4i*ccdb - bbdb + so4idb = so4idb + hi*ccdb - bbdb + a8db = -bbdb - hso4i*ccdb + DO ii1=1,npair + gamadb(ii1) = 0.D0 + ENDDO + temp0 = water/gama(7) + temp1 = gama(8)/gama(7) + temp1db = 2.*temp1*temp0*xk1*a8db/gama(7) + temp0db = temp1**2.*xk1*a8db/gama(7) + gamadb(8) = gamadb(8) + temp1db + gamadb(7) = gamadb(7) - temp0*temp0db - temp1*temp1db + waterdb = temp0db + END IF + END + +C Differentiation of calcact3p in reverse (adjoint) mode: +C gradient of useful results: molal gama water +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3P_DB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0db(6, 4), siondb, hdb, chdb, f1db(3), f2db(4) + REAL*8 :: mpl, xij, yji, ionicdb + REAL*8 :: mpldb, xijdb, yjidb + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01db + REAL*8 :: g02 + REAL*8 :: g02db + REAL*8 :: g03 + REAL*8 :: g03db + REAL*8 :: g04 + REAL*8 :: g04db + REAL*8 :: g05 + REAL*8 :: g05db + REAL*8 :: g06 + REAL*8 :: g06db + REAL*8 :: g07 + REAL*8 :: g07db + REAL*8 :: g08 + REAL*8 :: g08db + REAL*8 :: g09 + REAL*8 :: g09db + REAL*8 :: g10 + REAL*8 :: g10db + REAL*8 :: g11 + REAL*8 :: g11db + REAL*8 :: g12 + REAL*8 :: g12db + INTEGER :: j + INTEGER :: branch + REAL*8 :: temp0db9 + REAL*8 :: temp0db8 + REAL*8 :: temp0db7 + REAL*8 :: temp0db6 + REAL*8 :: temp0db5 + REAL*8 :: temp0db4 + REAL*8 :: temp0db3 + REAL*8 :: temp0db2 + REAL*8 :: temp0db13 + REAL*8 :: temp0db1 + REAL*8 :: temp0db12 + REAL*8 :: temp0db0 + REAL*8 :: temp0db11 + REAL*8 :: temp0db10 + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x2db + REAL*8 :: temp0db + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: x1db +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + DO i=1,7 + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08, + + g09, g10, g11, g12) +C + g0(1, 1) = g11 + g0(1, 2) = g07 + g0(1, 3) = g08 + g0(1, 4) = g10 + g0(2, 1) = g01 + g0(2, 2) = g02 + g0(2, 3) = g12 + g0(2, 4) = g03 + g0(3, 1) = g06 + g0(3, 2) = g04 + g0(3, 3) = g09 + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + sion = SQRT(ionic) + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + yji = ch*molal(j+3)/water + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gama(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gama(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gama(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gama(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gama(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gama(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gama(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gama(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gama(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gama(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gama(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gama(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gama(13)) +C LC ; SCAPE + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + ELSE + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + gamadb(i) = 10.d0**gama(i)*LOG(10.d0)*gamadb(i) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + gamadb(i) = 0.D0 + x2db = 0.D0 + ELSE + x2db = gamadb(i) + gamadb(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) gamadb(i) = gamadb(i) + x2db + ENDDO + CALL POPREAL8(gama(13)) + gamadb(4) = gamadb(4) + 0.2d0*3.d0*gamadb(13) + gamadb(9) = gamadb(9) + 0.2d0*2.d0*gamadb(13) + gamadb(13) = 0.D0 + DO ii1=1,3 + f1db(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2db(ii1) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp0db2 = zz(12)*gamadb(12)/(z(2)+z(6)) + f1db(2) = f1db(2) + temp0db2/z(2) + f2db(3) = f2db(3) + temp0db2/z(6) + hdb = -(zz(12)*gamadb(12)) + gamadb(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp0db3 = zz(11)*gamadb(11)/(z(1)+z(4)) + f2db(1) = f2db(1) + temp0db3/z(4) + hdb = hdb - zz(11)*gamadb(11) + gamadb(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp0db4 = zz(10)*gamadb(10)/(z(1)+z(7)) + f1db(1) = f1db(1) + temp0db4/z(1) + temp0db3/z(1) + f2db(4) = f2db(4) + temp0db4/z(7) + hdb = hdb - zz(10)*gamadb(10) + gamadb(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp0db5 = zz(9)*gamadb(9)/(z(3)+z(6)) + f1db(3) = f1db(3) + temp0db5/z(3) + hdb = hdb - zz(9)*gamadb(9) + gamadb(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp0db6 = zz(8)*gamadb(8)/(z(1)+z(6)) + f2db(3) = f2db(3) + temp0db6/z(6) + temp0db5/z(6) + hdb = hdb - zz(8)*gamadb(8) + gamadb(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp0db7 = zz(7)*gamadb(7)/(z(1)+z(5)) + f1db(1) = f1db(1) + temp0db7/z(1) + temp0db6/z(1) + f2db(2) = f2db(2) + temp0db7/z(5) + hdb = hdb - zz(7)*gamadb(7) + gamadb(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp0db8 = zz(6)*gamadb(6)/(z(3)+z(4)) + f2db(1) = f2db(1) + temp0db8/z(4) + hdb = hdb - zz(6)*gamadb(6) + gamadb(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp0db9 = zz(5)*gamadb(5)/(z(3)+z(7)) + f2db(4) = f2db(4) + temp0db9/z(7) + hdb = hdb - zz(5)*gamadb(5) + gamadb(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp0db10 = zz(4)*gamadb(4)/(z(3)+z(5)) + f1db(3) = f1db(3) + temp0db9/z(3) + temp0db10/z(3) + temp0db8/z(3) + f2db(2) = f2db(2) + temp0db10/z(5) + hdb = hdb - zz(4)*gamadb(4) + gamadb(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp0db11 = zz(3)*gamadb(3)/(z(2)+z(7)) + f2db(4) = f2db(4) + temp0db11/z(7) + hdb = hdb - zz(3)*gamadb(3) + gamadb(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp0db12 = zz(2)*gamadb(2)/(z(2)+z(5)) + f2db(2) = f2db(2) + temp0db12/z(5) + hdb = hdb - zz(2)*gamadb(2) + gamadb(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp0db13 = zz(1)*gamadb(1)/(z(2)+z(4)) + f1db(2) = f1db(2) + temp0db12/z(2) + temp0db13/z(2) + temp0db11/z( + + 2) + f2db(1) = f2db(1) + temp0db13/z(4) + hdb = hdb - zz(1)*gamadb(1) + gamadb(1) = 0.D0 + ionicdb = 0.D0 + DO ii1=1,4 + DO ii2=1,6 + g0db(ii2, ii1) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mpldb = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijdb = (g0(i, j)+zpl*zmi*h)*f2db(j) + yji = ch*molal(j+3)/water + g0db(i, j) = g0db(i, j) + yji*f1db(i) + xij*f2db(j) + hdb = hdb + yji*zpl*zmi*f1db(i) + xij*zpl*zmi*f2db(j) + yjidb = (g0(i, j)+zpl*zmi*h)*f1db(i) + temp0db1 = molal(j+3)*yjidb/water + molaldb(j+3) = molaldb(j+3) + ch*yjidb/water + chdb = mpl*xijdb + temp0db1 + waterdb = waterdb - ch*temp0db1/water + mpldb = mpldb + ch*xijdb + ionicdb = ionicdb - (zpl+zmi)**2*0.25d0*chdb/ionic**2 + ENDDO + CALL POPREAL8(mpl) + molaldb(i) = molaldb(i) + mpldb/water + waterdb = waterdb - molal(i)*mpldb/water**2 + CALL POPREAL8(zpl) + ENDDO + temp0db0 = agama*hdb/(sion+1.d0) + siondb = (1.D0-sion/(sion+1.d0))*temp0db0 + IF (.NOT.ionic == 0.0) ionicdb = ionicdb + siondb/(2.0*SQRT( + + ionic)) + g05db = g0db(3, 4) + g0db(3, 4) = 0.D0 + g09db = g0db(3, 3) + g0db(3, 3) = 0.D0 + g04db = g0db(3, 2) + g0db(3, 2) = 0.D0 + g06db = g0db(3, 1) + g0db(3, 1) = 0.D0 + g03db = g0db(2, 4) + g0db(2, 4) = 0.D0 + g12db = g0db(2, 3) + g0db(2, 3) = 0.D0 + g02db = g0db(2, 2) + g0db(2, 2) = 0.D0 + g01db = g0db(2, 1) + g0db(2, 1) = 0.D0 + g10db = g0db(1, 4) + g0db(1, 4) = 0.D0 + g08db = g0db(1, 3) + g0db(1, 3) = 0.D0 + g07db = g0db(1, 2) + g0db(1, 2) = 0.D0 + g11db = g0db(1, 1) + CALL KMFUL3_DB(ionic, ionicdb, temp, g01, g01db, g02, g02db, g03, + + g03db, g04, g04db, g05, g05db, g06, g06db, g07, + + g07db, g08, g08db, g09, g09db, g10, g10db, g11, + + g11db, g12, g12db) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionic) + x1db = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1db = ionicdb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ionicdb = 0.D0 + ELSE + temp0db = 0.5d0*x1db/water + ionicdb = temp0db + waterdb = waterdb - ionic*temp0db/water + END IF + DO i=7,1,-1 + molaldb(i) = molaldb(i) + z(i)**2*ionicdb + ENDDO + END + +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_DB(ionic, ionicdb, temp, g01, g01db, g02, g02db + + , g03, g03db, g04, g04db, g05, g05db, g06, + + g06db, g07, g07db, g08, g08db, g09, g09db, + + g10, g10db, g11, g11db, g12, g12db) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionicdb, siondb, cf2db + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01db, g02db, g03db, g04db, g05db, g06db, g07db, + + g08db, g09db, g10db, g11db, g12db + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTEGER :: branch + REAL*8 :: temp0db0 + INTRINSIC ABS + REAL*8 :: temp0db + REAL*8 :: abs1 + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01db = g01db + g12db + g08db = g08db + g09db + g12db + g11db = g11db - g09db - g12db + g06db = g06db + g09db + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2db = -(z10*g10db) - z07*g07db - z05*g05db - z03*g03db - z01* + + g01db - z02*g02db - z04*g04db - z06*g06db - z08*g08db - z11* + + g11db + g11db = cf1*g11db + g10db = cf1*g10db + g08db = cf1*g08db + g07db = cf1*g07db + g06db = cf1*g06db + g05db = cf1*g05db + g04db = cf1*g04db + g03db = cf1*g03db + g02db = cf1*g02db + g01db = cf1*g01db + temp0db = (0.125d0-ti*0.005d0)*cf2db + temp0db0 = -(0.41d0*temp0db/(sion+1.d0)) + ionicdb = ionicdb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0db + siondb = (1.D0-sion/(sion+1.d0))*temp0db0 + ELSE + siondb = 0.D0 + END IF + CALL MKBI_DB(q11, ionic, ionicdb, sion, siondb, z11, g11, g11db) + CALL MKBI_DB(q10, ionic, ionicdb, sion, siondb, z10, g10, g10db) + CALL MKBI_DB(q8, ionic, ionicdb, sion, siondb, z08, g08, g08db) + CALL MKBI_DB(q7, ionic, ionicdb, sion, siondb, z07, g07, g07db) + CALL MKBI_DB(q6, ionic, ionicdb, sion, siondb, z06, g06, g06db) + CALL MKBI_DB(q5, ionic, ionicdb, sion, siondb, z05, g05, g05db) + CALL MKBI_DB(q4, ionic, ionicdb, sion, siondb, z04, g04, g04db) + CALL MKBI_DB(q3, ionic, ionicdb, sion, siondb, z03, g03, g03db) + CALL MKBI_DB(q2, ionic, ionicdb, sion, siondb, z02, g02, g02db) + CALL MKBI_DB(q1, ionic, ionicdb, sion, siondb, z01, g01, g01db) + IF (.NOT.ionic == 0.0) ionicdb = ionicdb + siondb/(2.0*SQRT( + + ionic)) + END + +C Differentiation of mkbi in reverse (adjoint) mode: +C gradient of useful results: sion bi ionic +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_DB(q, ionic, ionicdb, sion, siondb, zip, bi, bidb) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionicdb, siondb, bidb + REAL*8 :: b, c, xx + REAL*8 :: cdb, xxdb + INTRINSIC EXP + REAL*8 :: tempdb + INTRINSIC LOG10 + REAL*8 :: tempdb0 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic)) + bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b +C + xxdb = zip*bidb + bidb = zip*bidb/(bi*LOG(10.0)) + tempdb = -(0.5107d0*xxdb/(c*sion+1.d0)) + tempdb0 = -(sion*tempdb/(c*sion+1.d0)) + siondb = siondb + c*tempdb0 + tempdb + cdb = sion*tempdb0 + IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q + + ))) THEN + ionicdb = ionicdb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3* + + ionic**2*cdb + ELSE + ionicdb = ionicdb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bidb - + + .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cdb + END IF + END + +C Differentiation of funcd3b_dnrd in reverse (adjoint) mode: +C gradient of useful results: molal molalr gama water gnh3 +C ghno3 chi3 chi4 psi1 psi2 fd3bdnrd fd3b +C with respect to varying inputs: gnh3 ghno3 chi3 chi4 psi1 psi2 +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of funcd3b in forward (tangent) mode: +C variations of useful results: fd3b +C with respect to varying inputs: p4 +C RW status of diff variables: p4:in fd3b:out +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** FUNCTION FUNCD3 +C *** CASE D3 +C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ; +C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3. +C +C======================================================================= +C + SUBROUTINE FUNCD3B_DNRD_DB(p4, p4dnrd, fd3b, fd3bdb, fd3bdnrd, + + fd3bdnrddb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: psi3db + REAL*8 :: psi3dnrd + REAL*8 :: psi3dnrddb + REAL*8 :: psi4dnrd + REAL*8 :: a3db + REAL*8 :: a3dnrd + REAL*8 :: a3dnrddb + REAL*8 :: a4db + REAL*8 :: a4dnrd + REAL*8 :: a4dnrddb + REAL*8 :: a7db + REAL*8 :: a7dnrd + REAL*8 :: a7dnrddb + + REAL*8 :: p4, bb, denm, ahi, aml5, fd3b + REAL*8 :: bbdb, denmdb, ahidb, aml5db, fd3bdb + REAL*8 :: p4dnrd, bbdnrd, denmdnrd, ahidnrd, aml5dnrd, + + fd3bdnrd + REAL*8 :: bbdnrddb, denmdnrddb, ahidnrddb, aml5dnrddb, + + fd3bdnrddb + REAL*8 :: molalrdnrd(npair), molalrdnrddb(npair) + CHARACTER(LEN=40) errinf + INTEGER :: errstki(25), k, j + LOGICAL :: dexs, iexs, eof + CHARACTER(LEN=40) errmsgi(25) + LOGICAL tst + INTEGER :: i + REAL*8 :: abb + REAL*8 :: abbdb + REAL*8 :: abbdnrd + REAL*8 :: abbdnrddb + REAL*8 :: arg1 + REAL*8 :: arg1db + REAL*8 :: arg1dnrd + REAL*8 :: arg1dnrddb + REAL*8 :: result1 + REAL*8 :: result1db + REAL*8 :: result1dnrd + REAL*8 :: result1dnrddb + REAL*8 :: x1dnrd + REAL*8 :: x1dnrddb + INTRINSIC MAX + INTRINSIC ABS + REAL*8 :: x2 + REAL*8 :: x2db + REAL*8 :: x1 + REAL*8 :: x1db + REAL*8 :: max1dnrd + REAL*8 :: x2dnrd + REAL*8 :: x2dnrddb + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: max1 + REAL*8 :: max1db + INTEGER :: branch + REAL*8 :: temp3 + REAL*8 :: temp2 + REAL*8 :: temp4db + REAL*8 :: temp1 + REAL*8 :: temp27 + REAL*8 :: temp0 + REAL*8 :: temp26 + REAL*8 :: temp25 + REAL*8 :: temp24 + REAL*8 :: temp23 + REAL*8 :: temp22 + REAL*8 :: temp21 + REAL*8 :: temp20 + REAL*8 :: temp23db + REAL*8 :: temp0db1 + REAL*8 :: temp0db0 + REAL*8 :: temp7db + REAL*8 :: temp16db + REAL*8 :: temp2db + REAL*8 :: temp11db + REAL*8 :: temp27db0 + REAL*8 :: temp19 + REAL*8 :: temp18 + REAL*8 :: temp17 + REAL*8 :: temp16 + REAL*8 :: temp21db + REAL*8 :: temp15 + REAL*8 :: temp14 + REAL*8 :: temp13 + REAL*8 :: temp19db + REAL*8 :: temp12 + REAL*8 :: temp11 + REAL*8 :: temp10 + REAL*8 :: temp5db + REAL*8 :: temp14db + REAL*8 :: temp3db0 + REAL*8 :: temp0db + REAL*8 :: temp17db0 + REAL*8 :: temp24db + REAL*8 :: temp8db + REAL*8 :: temp18db2 + REAL*8 :: temp17db + REAL*8 :: temp18db1 + REAL*8 :: temp18db0 + REAL*8 :: temp5db0 + REAL*8 :: temp3db + REAL*8 :: temp12db + REAL*8 :: temp27db + REAL*8 :: temp6db2 + REAL*8 :: temp6db1 + REAL*8 :: temp6db0 + INTEGER :: ii10 + REAL*8 :: temp22db + REAL*8 :: temp6db + REAL*8 :: abs1 + REAL*8 :: temp1db + REAL*8 :: temp10db + REAL*8 :: temp10db0 + REAL*8 :: temp9 + REAL*8 :: temp8 + REAL*8 :: temp20db + REAL*8 :: temp7 + REAL*8 :: temp9db + REAL*8 :: temp6 + REAL*8 :: temp5 + REAL*8 :: temp18db + REAL*8 :: temp4 +C +C *** SETUP PARAMETERS ************************************************ +C + psi4dnrd = p4dnrd + psi4 = p4 + DO ii1=1,nions + molaldnrd(ii1) = 0.d0 + ENDDO + DO ii1=1,npair + molalrdnrd(ii1) = 0.d0 + ENDDO + DO ii1=1,npair + gamadnrd(ii1) = 0.d0 + ENDDO + waterdnrd = 0.d0 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + DO i=1,3 + CALL PUSHREAL8(a3dnrd) +C + a3dnrd = xk4*r*temp*2.0*water*(waterdnrd*gama(10)-water*gamadnrd + + (10))/gama(10)**3 + a3 = xk4*r*temp*(water/gama(10))**2.0 + CALL PUSHREAL8(a4dnrd) + a4dnrd = xk2*r*temp*2.0*gama(10)*(gamadnrd(10)*gama(5)-gama(10)* + + gamadnrd(5))/(xkw*gama(5)**3) + CALL PUSHREAL8(a4) + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + CALL PUSHREAL8(a7dnrd) + a7dnrd = xkw*rh*(waterdnrd*water+water*waterdnrd) + CALL PUSHREAL8(a7) + a7 = xkw*rh*water*water +C + psi3dnrd = chi3*((a3dnrd*a4+a3*a4dnrd)*(chi4-psi4)-a3*a4* + + psi4dnrd) - psi1*psi4dnrd + psi3 = a3*a4*chi3*(chi4-psi4) - psi1*(2.d0*psi2+psi1+psi4) + CALL PUSHREAL8(psi3dnrd) + psi3dnrd = (psi3dnrd*(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4)- + + psi3*((a3dnrd*a4+a3*a4dnrd)*(chi4-psi4)-a3*a4*psi4dnrd+ + + psi4dnrd))/(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4)**2 + CALL PUSHREAL8(psi3) + psi3 = psi3/(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4) + IF (psi3 < zero) THEN + x1 = zero + x1dnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1dnrd = psi3dnrd + x1 = psi3 + CALL PUSHCONTROL1B(1) + END IF + IF (x1 > chi3) THEN + psi3 = chi3 + psi3dnrd = 0.d0 + CALL PUSHCONTROL1B(1) + ELSE + psi3dnrd = x1dnrd + psi3 = x1 + CALL PUSHCONTROL1B(0) + END IF + CALL PUSHREAL8(bbdnrd) +C + bbdnrd = psi4dnrd - psi3dnrd + CALL PUSHREAL8(bb) + bb = psi4 - psi3 + arg1dnrd = bbdnrd*bb + bb*bbdnrd + 4.d0*a7dnrd + arg1 = bb*bb + 4.d0*a7 + IF (arg1 >= 0.) THEN + abs1 = arg1 + ELSE + abs1 = -arg1 + END IF + IF (abs1 < tiny) THEN + result1dnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + result1dnrd = arg1dnrd/(2.0*SQRT(arg1)) + CALL PUSHCONTROL1B(1) + END IF + result1 = SQRT(arg1) + CALL PUSHREAL8(denmdnrd) + denmdnrd = bbdnrd + result1dnrd + CALL PUSHREAL8(denm) + denm = bb + result1 + IF (denm <= tiny) THEN + IF (bb >= 0.d0) THEN + CALL PUSHREAL8(abbdnrd) + abbdnrd = bbdnrd + CALL PUSHREAL8(abb) + abb = bb + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(abbdnrd) + abbdnrd = -bbdnrd + CALL PUSHREAL8(abb) + abb = -bb + CALL PUSHCONTROL1B(1) + END IF +C Taylor expansion of SQRT + denmdnrd = bbdnrd + abbdnrd + (2.0*a7dnrd*abb-2.0*a7*abbdnrd)/ + + abb**2 - (2.0*(a7dnrd*a7+a7*a7dnrd)*abb**3.0-2.0*a7**2*3.0* + + abb**2.0*abbdnrd)/(abb**3.0)**2 + denm = bb + abb + 2.0*a7/abb - 2.0*a7*a7/abb**3.0 +C WRITE(*,*) 'TS approx. of DENM: ',DENM + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + ahidnrd = (2.d0*a7dnrd*denm-2.d0*a7*denmdnrd)/denm**2 + ahi = 2.d0*a7/denm + CALL PUSHREAL8(molaldnrd(1)) +C +C *** SPECIATION & WATER CONTENT *************************************** +C +C HI + molaldnrd(1) = ahidnrd + CALL PUSHREAL8(molal(1)) + molal(1) = ahi + CALL PUSHREAL8(molaldnrd(3)) +C NH4I + molaldnrd(3) = psi4dnrd + CALL PUSHREAL8(molal(3)) + molal(3) = psi1 + psi4 + 2.d0*psi2 + CALL PUSHREAL8(molaldnrd(5)) +C SO4I + molaldnrd(5) = 0.d0 + CALL PUSHREAL8(molal(5)) + molal(5) = psi2 + CALL PUSHREAL8(molaldnrd(6)) +C HSO4I + molaldnrd(6) = 0.d0 + CALL PUSHREAL8(molal(6)) + molal(6) = zero + CALL PUSHREAL8(molaldnrd(7)) +C NO3I + molaldnrd(7) = psi3dnrd + CALL PUSHREAL8(molal(7)) + molal(7) = psi3 + psi1 +C Solid (NH4)2SO4 +C Solid NH4NO3 +C Gas HNO3 +C Gas NH3 + gnh3dnrd = -psi4dnrd + gnh3 = chi4 - psi4 +C +C CALL CALCMR ! Water content +C +C (NH4)2SO4 + molalrdnrd(4) = molaldnrd(5) + molaldnrd(6) + molalr(4) = molal(5) + molal(6) +C "free" NH4 + aml5dnrd = molaldnrd(3) - 2.d0*molalrdnrd(4) + aml5 = molal(3) - 2.d0*molalr(4) + IF (aml5 > molal(7)) THEN + x2dnrd = molaldnrd(7) + x2 = molal(7) + CALL PUSHCONTROL1B(0) + ELSE + x2dnrd = aml5dnrd + x2 = aml5 + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < zero) THEN + molalrdnrd(5) = 0.d0 + molalr(5) = zero + CALL PUSHCONTROL1B(0) + ELSE + molalrdnrd(5) = x2dnrd + molalr(5) = x2 + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8(water) +C +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + CALL PUSHREAL8(waterdnrd) + waterdnrd = 0.d0 + DO j=1,npair + waterdnrd = waterdnrd + molalrdnrd(j)/m0(j) + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + waterdnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF + CALL PUSHREAL8ARRAY(gamadnrd, npair) + CALL PUSHREAL8ARRAY(gama, npair) +C + CALL CALCACT3P_DNRD() + ENDDO + IF (gnh3 < tiny) THEN + CALL PUSHCONTROL1B(0) + max1 = tiny + max1dnrd = 0.d0 + ELSE + max1dnrd = gnh3dnrd + max1 = gnh3 + CALL PUSHCONTROL1B(1) + END IF + temp27db0 = fd3bdnrddb/a4**2 + temp26 = max1**2 + temp20 = a4/temp26 + temp21db = temp20*temp27db0 + temp25 = molal(1)**2 + temp23 = max1/temp25 + temp24db = temp23*temp21db + temp24 = molaldnrd(3)*molal(1) - molal(3)*molaldnrd(1) + temp23db = temp24*temp21db/temp25 + temp22 = molal(3)/molal(1) + temp22db = -(max1dnrd*temp21db/molal(1)) + temp21 = temp24*temp23 - max1dnrd*temp22 + temp20db = temp21*temp27db0/temp26 + temp18 = molal(1)*max1 + temp19db = -(temp27db0/temp18) + temp19 = molal(3)*a4dnrd/temp18 + temp18db2 = -(temp19*temp19db) + temp27 = molal(1)*max1*a4 + temp27db = -(molal(3)*fd3bdb/temp27**2) + molaldb(3) = molaldb(3) + fd3bdb/temp27 + molaldb(1) = molaldb(1) + molaldnrd(3)*temp24db - temp23*2*molal(1 + + )*temp23db - temp22*temp22db + max1*temp18db2 + max1*a4*temp27db + max1db = temp23db - temp20*2*max1*temp20db + molal(1)*temp18db2 + + + molal(1)*a4*temp27db + a4db = temp20db - (temp21*temp20-temp19)*2*temp27db0/a4 + molal(1) + + *max1*temp27db + DO ii10=1,nions + molaldnrddb(ii10) = 0.D0 + ENDDO + molaldnrddb(3) = molaldnrddb(3) + molal(1)*temp24db + molaldb(3) = molaldb(3) + a4dnrd*temp19db + temp22db - molaldnrd(1 + + )*temp24db + molaldnrddb(1) = molaldnrddb(1) - molal(3)*temp24db + a4dnrddb = molal(3)*temp19db + CALL POPCONTROL1B(branch) + IF (branch /= 0) gnh3db = gnh3db + max1db + DO ii10=1,npair + gamadnrddb(ii10) = 0.D0 + ENDDO + waterdnrddb = 0.D0 + DO ii10=1,npair + molalrdnrddb(ii10) = 0.D0 + ENDDO + DO i=3,1,-1 + CALL POPREAL8ARRAY(gama, npair) + CALL POPREAL8ARRAY(gamadnrd, npair) + CALL CALCACT3P_DNRD_DB() + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + waterdb = 0.D0 + waterdnrddb = 0.D0 + END IF + DO j=npair,1,-1 + molalrdb(j) = molalrdb(j) + waterdb/m0(j) + molalrdnrddb(j) = molalrdnrddb(j) + waterdnrddb/m0(j) + ENDDO + CALL POPREAL8(waterdnrd) + CALL POPREAL8(water) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + molalrdb(5) = 0.D0 + molalrdnrddb(5) = 0.D0 + x2dnrddb = 0.D0 + x2db = 0.D0 + ELSE + x2db = molalrdb(5) + molalrdb(5) = 0.D0 + x2dnrddb = molalrdnrddb(5) + molalrdnrddb(5) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + molaldb(7) = molaldb(7) + x2db + molaldnrddb(7) = molaldnrddb(7) + x2dnrddb + aml5dnrddb = 0.D0 + aml5db = 0.D0 + ELSE + aml5db = x2db + aml5dnrddb = x2dnrddb + END IF + molaldb(3) = molaldb(3) + aml5db + molalrdb(4) = molalrdb(4) - 2.d0*aml5db + molaldnrddb(3) = molaldnrddb(3) + aml5dnrddb + molalrdnrddb(4) = molalrdnrddb(4) - 2.d0*aml5dnrddb + molaldb(5) = molaldb(5) + molalrdb(4) + molaldb(6) = molaldb(6) + molalrdb(4) + molalrdb(4) = 0.D0 + molaldnrddb(5) = molaldnrddb(5) + molalrdnrddb(4) + molaldnrddb(6) = molaldnrddb(6) + molalrdnrddb(4) + molalrdnrddb(4) = 0.D0 + chi4db = chi4db + gnh3db + chi3db = chi3db + ghno3db + psi3db = molaldb(7) - ghno3db + CALL POPREAL8(molal(7)) + psi1db = psi1db + molaldb(7) + molaldb(7) = 0.D0 + CALL POPREAL8(molaldnrd(7)) + psi3dnrddb = molaldnrddb(7) + molaldnrddb(7) = 0.D0 + CALL POPREAL8(molal(6)) + molaldb(6) = 0.D0 + CALL POPREAL8(molaldnrd(6)) + molaldnrddb(6) = 0.D0 + CALL POPREAL8(molal(5)) + psi2db = psi2db + molaldb(5) + molaldb(5) = 0.D0 + CALL POPREAL8(molaldnrd(5)) + molaldnrddb(5) = 0.D0 + CALL POPREAL8(molal(3)) + psi1db = psi1db + molaldb(3) + psi2db = psi2db + 2.d0*molaldb(3) + molaldb(3) = 0.D0 + CALL POPREAL8(molaldnrd(3)) + molaldnrddb(3) = 0.D0 + CALL POPREAL8(molal(1)) + ahidb = molaldb(1) + molaldb(1) = 0.D0 + CALL POPREAL8(molaldnrd(1)) + ahidnrddb = molaldnrddb(1) + molaldnrddb(1) = 0.D0 + temp18db0 = 2.d0*ahidb/denm + temp18db1 = ahidnrddb/denm**2 + a7db = temp18db0 - 2.d0*denmdnrd*temp18db1 + denmdb = (2.d0*a7dnrd-(2.d0*(a7dnrd*denm)-2.d0*(a7*denmdnrd))*2/ + + denm)*temp18db1 - a7*temp18db0/denm + a7dnrddb = 2.d0*denm*temp18db1 + denmdnrddb = -(2.d0*a7*temp18db1) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + temp16 = abb**3.0 + temp16db = -(denmdnrddb/temp16**2) + temp15 = abb**3.0 + temp14 = a7dnrd*a7 + a7*a7dnrd + temp14db = 2.0*temp15*temp16db + temp13 = abb**2.0 + temp12 = a7**2*abbdnrd + temp12db = -(3.0*2.0*temp16db) + temp17db0 = denmdnrddb/abb**2 + temp18db = 2.0*denmdb/abb + temp17 = abb**3.0 + temp17db = -(2.0*denmdb/temp17) + bbdb = denmdb + abbdb = (2.0*a7dnrd-(2.0*(a7dnrd*abb)-2.0*(a7*abbdnrd))*2/abb) + + *temp17db0 + (temp14*2.0*3.0*abb**2.0-2*(2.0*(temp14*temp15) + + -3.0*2.0*(temp12*temp13))*3.0*abb**2.0/temp16)*temp16db + + + temp12*2.0*abb*temp12db - a7**2*3.0*abb**2.0*temp17db/temp17 + + - a7*temp18db/abb + denmdb + a7db = a7db + 2*a7dnrd*temp14db - 2.0*abbdnrd*temp17db0 + + + abbdnrd*temp13*2*a7*temp12db + 2*a7*temp17db + temp18db + bbdnrddb = denmdnrddb + abbdnrddb = temp13*a7**2*temp12db - 2.0*a7*temp17db0 + + + denmdnrddb + a7dnrddb = a7dnrddb + 2*a7*temp14db + 2.0*abb*temp17db0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(abb) + bbdb = bbdb + abbdb + CALL POPREAL8(abbdnrd) + bbdnrddb = bbdnrddb + abbdnrddb + ELSE + CALL POPREAL8(abb) + bbdb = bbdb - abbdb + CALL POPREAL8(abbdnrd) + bbdnrddb = bbdnrddb - abbdnrddb + END IF + denmdnrddb = 0.D0 + denmdb = 0.D0 + ELSE + bbdnrddb = 0.D0 + bbdb = 0.D0 + END IF + CALL POPREAL8(denm) + bbdb = bbdb + denmdb + result1db = denmdb + CALL POPREAL8(denmdnrd) + bbdnrddb = bbdnrddb + denmdnrddb + result1dnrddb = denmdnrddb + arg1 = bb*bb + 4.d0*a7 + IF (arg1 == 0.0) THEN + arg1db = 0.0 + ELSE + arg1db = result1db/(2.0*SQRT(arg1)) + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + arg1dnrddb = 0.D0 + ELSE + arg1dnrd = bbdnrd*bb + bb*bbdnrd + 4.d0*a7dnrd + temp11 = SQRT(arg1) + temp11db = result1dnrddb/(2.0*temp11) + arg1dnrddb = temp11db + IF (.NOT.arg1 == 0.0) arg1db = arg1db - arg1dnrd*temp11db/( + + 2.0*temp11**2) + END IF + bbdb = bbdb + 2*bbdnrd*arg1dnrddb + 2*bb*arg1db + a7db = a7db + 4.d0*arg1db + bbdnrddb = bbdnrddb + 2*bb*arg1dnrddb + a7dnrddb = a7dnrddb + 4.d0*arg1dnrddb + CALL POPREAL8(bb) + psi3db = psi3db - bbdb + CALL POPREAL8(bbdnrd) + psi3dnrddb = psi3dnrddb - bbdnrddb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + x1db = psi3db + x1dnrddb = psi3dnrddb + ELSE + chi3db = chi3db + psi3db + x1db = 0.D0 + x1dnrddb = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + psi3db = 0.D0 + psi3dnrddb = 0.D0 + ELSE + psi3db = x1db + psi3dnrddb = x1dnrddb + END IF + a3 = xk4*r*temp*(water/gama(10))**2.0 + CALL POPREAL8(psi3) + temp10 = psi4 + a3*a4*(chi4-psi4) + 2.d0*psi2 + psi1 + temp10db = -(psi3*psi3db/temp10**2) + CALL POPREAL8(psi3dnrd) + temp6 = psi4 + a3*a4*(chi4-psi4) + 2.d0*psi2 + psi1 + temp10db0 = psi3dnrddb/temp6**2 + temp9 = psi4 + a3*a4*(chi4-psi4) + 2.d0*psi2 + psi1 + temp9db = psi3dnrd*temp10db0 + temp7 = a3dnrd*a4 + a3*a4dnrd + temp8 = psi4dnrd + temp7*(chi4-psi4) - psi4dnrd*a3*a4 + psi3db = psi3db/temp10 - temp8*temp10db0 + temp8db = -(psi3*temp10db0) + temp7db = (chi4-psi4)*temp8db + temp6db = -((psi3dnrd*temp9-psi3*temp8)*2*temp10db0/temp6) + psi2db = psi2db + 2.d0*temp9db + 2.d0*temp6db - psi1*2.d0*psi3db + + + 2.d0*temp10db + psi3dnrddb = temp9*temp10db0 + psi1db = psi1db + temp9db + temp6db - psi4dnrd*psi3dnrddb + ((-2 + + )*psi1-psi4-2.d0*psi2)*psi3db + temp10db + temp6db1 = chi3*(chi4-psi4)*psi3db + temp6db2 = a3*a4*psi3db + temp5 = a3dnrd*a4 + a3*a4dnrd + chi3db = chi3db + (temp5*(chi4-psi4)-psi4dnrd*(a3*a4))* + + psi3dnrddb + (chi4-psi4)*temp6db2 + temp6db0 = chi3*psi3dnrddb + chi4db = chi4db + a3*a4*temp9db + temp7*temp8db + a3*a4*temp6db + + + temp5*temp6db0 + chi3*temp6db2 + a3*a4*temp10db + temp5db = (chi4-psi4)*temp6db0 + a3db = (chi4-psi4)*a4*temp9db + a4dnrd*temp7db - psi4dnrd*a4* + + temp8db + (chi4-psi4)*a4*temp6db + a4dnrd*temp5db - psi4dnrd* + + a4*temp6db0 + a4*temp6db1 + (chi4-psi4)*a4*temp10db + a4db = a4db + (chi4-psi4)*a3*temp9db + a3dnrd*temp7db - psi4dnrd + + *a3*temp8db + (chi4-psi4)*a3*temp6db + a3dnrd*temp5db - + + psi4dnrd*a3*temp6db0 + a3*temp6db1 + (chi4-psi4)*a3*temp10db + a3dnrddb = a4*temp5db + a4*temp7db + a4dnrddb = a4dnrddb + a3*temp5db + a3*temp7db + CALL POPREAL8(a7) + CALL POPREAL8(a7dnrd) + temp5db0 = xkw*rh*a7dnrddb + CALL POPREAL8(a4) + temp4 = gama(10)/gama(5) + temp4db = 2.0*temp4*xk2*r*temp*a4db/(xkw*gama(5)) + gamadb(10) = gamadb(10) + temp4db + CALL POPREAL8(a4dnrd) + temp3 = xkw*gama(5)**3 + temp2 = gama(10)/temp3 + temp3db0 = xk2*2.0*r*temp*a4dnrddb + temp3db = temp2*temp3db0 + temp2db = (gamadnrd(10)*gama(5)-gama(10)*gamadnrd(5))*temp3db0/ + + temp3 + gamadb(5) = gamadb(5) + gamadnrd(10)*temp3db - xkw*temp2*3*gama( + + 5)**2*temp2db - temp4*temp4db + gamadnrddb(10) = gamadnrddb(10) + gama(5)*temp3db + gamadnrddb(5) = gamadnrddb(5) - gama(10)*temp3db + temp1 = water/gama(10) + temp1db = 2.0*temp1*xk4*r*temp*a3db/gama(10) + CALL POPREAL8(a3dnrd) + temp0 = gama(10)**3 + temp0db1 = xk4*2.0*r*temp*a3dnrddb + temp0db = water*temp0db1/temp0 + waterdnrddb = gama(10)*temp0db + 2*water*temp5db0 + temp0db0 = (waterdnrd*gama(10)-water*gamadnrd(10))*temp0db1/ + + temp0 + waterdb = 2*waterdnrd*temp5db0 - gamadnrd(10)*temp0db + temp0db0 + + + temp1db + xkw*rh*2*water*a7db + gamadb(10) = gamadb(10) + waterdnrd*temp0db - water*3*gama(10)** + + 2*temp0db0/temp0 - temp1*temp1db + temp2db - gamadnrd(5)* + + temp3db + gamadnrddb(10) = gamadnrddb(10) - water*temp0db + gnh3db = 0.D0 + ghno3db = 0.D0 + a4db = 0.D0 + a4dnrddb = 0.D0 + ENDDO + END + +C Differentiation of calcact3p_dnrd in reverse (adjoint) mode: +C gradient of useful results: molal gama water molaldnrd +C gamadnrd waterdnrd +C with respect to varying inputs: molal gama water molaldnrd +C gamadnrd waterdnrd +C +C Differentiation of calcact3p in forward (tangent) mode: +C variations of useful results: gama +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3P_DNRD_DB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0db(6, 4), siondb, hdb, chdb, f1db(3), f2db(4) + REAL*8 :: g0dnrd(6, 4), siondnrd, hdnrd, chdnrd, f1dnrd(3) + + , f2dnrd(4) + REAL*8 :: g0dnrddb(6, 4), siondnrddb, hdnrddb, chdnrddb, + + f1dnrddb(3), f2dnrddb(4) + REAL*8 :: mpl, xij, yji + REAL*8 :: mpldb, xijdb, yjidb, ionicdnrddb + REAL*8 :: mpldnrd, xijdnrd, yjidnrd, ionicdb + REAL*8 :: mpldnrddb, xijdnrddb, yjidnrddb, ionicdnrd + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01db + REAL*8 :: g01dnrd + REAL*8 :: g01dnrddb + REAL*8 :: g02 + REAL*8 :: g02db + REAL*8 :: g02dnrd + REAL*8 :: g02dnrddb + REAL*8 :: g03 + REAL*8 :: g03db + REAL*8 :: g03dnrd + REAL*8 :: g03dnrddb + REAL*8 :: g04 + REAL*8 :: g04db + REAL*8 :: g04dnrd + REAL*8 :: g04dnrddb + REAL*8 :: g05 + REAL*8 :: g05db + REAL*8 :: g05dnrd + REAL*8 :: g05dnrddb + REAL*8 :: g06 + REAL*8 :: g06db + REAL*8 :: g06dnrd + REAL*8 :: g06dnrddb + REAL*8 :: g07 + REAL*8 :: g07db + REAL*8 :: g07dnrd + REAL*8 :: g07dnrddb + REAL*8 :: g08 + REAL*8 :: g08db + REAL*8 :: g08dnrd + REAL*8 :: g08dnrddb + REAL*8 :: g09 + REAL*8 :: g09db + REAL*8 :: g09dnrd + REAL*8 :: g09dnrddb + REAL*8 :: g10 + REAL*8 :: g10db + REAL*8 :: g10dnrd + REAL*8 :: g10dnrddb + REAL*8 :: g11 + REAL*8 :: g11db + REAL*8 :: g11dnrd + REAL*8 :: g11dnrddb + REAL*8 :: g12 + REAL*8 :: g12db + REAL*8 :: g12dnrd + REAL*8 :: g12dnrddb + INTEGER :: j + REAL*8 :: x1dnrd + REAL*8 :: x1dnrddb + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x2db + REAL*8 :: x1 + REAL*8 :: x1db + REAL*8 :: x2dnrd + REAL*8 :: x2dnrddb + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT + INTEGER :: branch + REAL*8 :: temp2 + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp0db1 + REAL*8 :: temp0db0 + REAL*8 :: temp1db4 + REAL*8 :: temp2db + REAL*8 :: temp1db3 + REAL*8 :: temp1db2 + REAL*8 :: temp1db1 + REAL*8 :: temp1db0 + REAL*8 :: temp2db9 + REAL*8 :: temp2db8 + REAL*8 :: temp2db7 + INTRINSIC ABS + REAL*8 :: temp2db6 + REAL*8 :: temp2db5 + REAL*8 :: temp2db4 + REAL*8 :: temp2db3 + REAL*8 :: temp2db2 + REAL*8 :: temp2db1 + REAL*8 :: temp2db0 + REAL*8 :: temp2db25 + REAL*8 :: temp2db24 + INTEGER :: ii20 + REAL*8 :: temp2db23 + REAL*8 :: temp2db22 + REAL*8 :: temp2db21 + REAL*8 :: temp0db + REAL*8 :: temp2db20 + INTRINSIC LOG + REAL*8 :: temp2db19 + REAL*8 :: temp2db18 + REAL*8 :: temp2db17 + REAL*8 :: temp2db16 + REAL*8 :: temp2db15 + INTEGER :: ii10 + REAL*8 :: temp2db14 + REAL*8 :: temp2db13 + REAL*8 :: temp2db12 + REAL*8 :: temp2db11 + REAL*8 :: temp2db10 + REAL*8 :: abs1 + REAL*8 :: temp1db +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + ionicdnrd = 0.d0 + DO i=1,7 + ionicdnrd = ionicdnrd + z(i)**2*molaldnrd(i) + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + x1dnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1dnrd = (0.5d0*ionicdnrd*water-0.5d0*ionic*waterdnrd)/water**2 + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHREAL8(ionicdnrd) + ionicdnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionicdnrd) + ionicdnrd = x1dnrd + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3_DNRD(ionic, ionicdnrd, temp, g01, g01dnrd, g02, + + g02dnrd, g03, g03dnrd, g04, g04dnrd, g05, g05dnrd + + , g06, g06dnrd, g07, g07dnrd, g08, g08dnrd, g09, + + g09dnrd, g10, g10dnrd, g11, g11dnrd, g12, g12dnrd + + ) + DO ii1=1,4 + DO ii2=1,6 + g0dnrd(ii2, ii1) = 0.d0 + ENDDO + ENDDO +C + g0dnrd(1, 1) = g11dnrd + g0(1, 1) = g11 + g0dnrd(1, 2) = g07dnrd + g0(1, 2) = g07 + g0dnrd(1, 3) = g08dnrd + g0(1, 3) = g08 + g0dnrd(1, 4) = g10dnrd + g0(1, 4) = g10 + g0dnrd(2, 1) = g01dnrd + g0(2, 1) = g01 + g0dnrd(2, 2) = g02dnrd + g0(2, 2) = g02 + g0dnrd(2, 3) = g12dnrd + g0(2, 3) = g12 + g0dnrd(2, 4) = g03dnrd + g0(2, 4) = g03 + g0dnrd(3, 1) = g06dnrd + g0(3, 1) = g06 + g0dnrd(3, 2) = g04dnrd + g0(3, 2) = g04 + g0dnrd(3, 3) = g09dnrd + g0(3, 3) = g09 + g0dnrd(3, 4) = g05dnrd + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + IF (ionic >= 0.) THEN + abs1 = ionic + ELSE + abs1 = -ionic + END IF + IF (abs1 < tiny) THEN + CALL PUSHCONTROL1B(0) + siondnrd = 0.d0 + ELSE + siondnrd = ionicdnrd/(2.0*SQRT(ionic)) + CALL PUSHCONTROL1B(1) + END IF + sion = SQRT(ionic) + hdnrd = (agama*siondnrd*(1.d0+sion)-agama*sion*siondnrd)/(1.d0+ + + sion)**2 + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 + DO ii1=1,3 + f1dnrd(ii1) = 0.d0 + ENDDO + DO ii1=1,4 + f2dnrd(ii1) = 0.d0 + ENDDO +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mpldnrd) + mpldnrd = (molaldnrd(i)*water-molal(i)*waterdnrd)/water**2 + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + chdnrd = -(0.25d0*(zpl+zmi)**2*ionicdnrd/ionic**2) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xijdnrd = chdnrd*mpl + ch*mpldnrd + xij = ch*mpl + CALL PUSHREAL8(yjidnrd) + yjidnrd = ((chdnrd*molal(j+3)+ch*molaldnrd(j+3))*water-ch* + + molal(j+3)*waterdnrd)/water**2 + yji = ch*molal(j+3)/water + f1dnrd(i) = f1dnrd(i) + yjidnrd*(g0(i, j)+zpl*zmi*h) + yji*( + + g0dnrd(i, j)+zpl*zmi*hdnrd) + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2dnrd(j) = f2dnrd(j) + xijdnrd*(g0(i, j)+zpl*zmi*h) + xij*( + + g0dnrd(i, j)+zpl*zmi*hdnrd) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gamadnrd(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gamadnrd(1) = zz(1)*((f1dnrd(2)/z(2)+f2dnrd(1)/z(4))/(z(2)+z(4))- + + hdnrd) + CALL PUSHREAL8(gama(1)) + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gamadnrd(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gamadnrd(2) = zz(2)*((f1dnrd(2)/z(2)+f2dnrd(2)/z(5))/(z(2)+z(5))- + + hdnrd) + CALL PUSHREAL8(gama(2)) + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gamadnrd(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gamadnrd(3) = zz(3)*((f1dnrd(2)/z(2)+f2dnrd(4)/z(7))/(z(2)+z(7))- + + hdnrd) + CALL PUSHREAL8(gama(3)) + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gamadnrd(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gamadnrd(4) = zz(4)*((f1dnrd(3)/z(3)+f2dnrd(2)/z(5))/(z(3)+z(5))- + + hdnrd) + CALL PUSHREAL8(gama(4)) + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gamadnrd(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gamadnrd(5) = zz(5)*((f1dnrd(3)/z(3)+f2dnrd(4)/z(7))/(z(3)+z(7))- + + hdnrd) + CALL PUSHREAL8(gama(5)) + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gamadnrd(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gamadnrd(6) = zz(6)*((f1dnrd(3)/z(3)+f2dnrd(1)/z(4))/(z(3)+z(4))- + + hdnrd) + CALL PUSHREAL8(gama(6)) + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gamadnrd(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gamadnrd(7) = zz(7)*((f1dnrd(1)/z(1)+f2dnrd(2)/z(5))/(z(1)+z(5))- + + hdnrd) + CALL PUSHREAL8(gama(7)) + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gamadnrd(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gamadnrd(8) = zz(8)*((f1dnrd(1)/z(1)+f2dnrd(3)/z(6))/(z(1)+z(6))- + + hdnrd) + CALL PUSHREAL8(gama(8)) + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gamadnrd(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gamadnrd(9) = zz(9)*((f1dnrd(3)/z(3)+f2dnrd(3)/z(6))/(z(3)+z(6))- + + hdnrd) + CALL PUSHREAL8(gama(9)) + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gamadnrd(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gamadnrd(10) = zz(10)*((f1dnrd(1)/z(1)+f2dnrd(4)/z(7))/(z(1)+z(7)) + + -hdnrd) + CALL PUSHREAL8(gama(10)) + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gamadnrd(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gamadnrd(11) = zz(11)*((f1dnrd(1)/z(1)+f2dnrd(1)/z(4))/(z(1)+z(4)) + + -hdnrd) + CALL PUSHREAL8(gama(11)) + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gamadnrd(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gamadnrd(12) = zz(12)*((f1dnrd(2)/z(2)+f2dnrd(3)/z(6))/(z(2)+z(6)) + + -hdnrd) + CALL PUSHREAL8(gama(12)) + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gamadnrd(13)) +C LC ; SCAPE + gamadnrd(13) = 0.2d0*(3.d0*gamadnrd(4)+2.d0*gamadnrd(9)) + CALL PUSHREAL8(gama(13)) + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + x2dnrd = 0.d0 + ELSE + x2dnrd = gamadnrd(i) + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHREAL8(gamadnrd(i)) + gamadnrd(i) = 0.d0 + CALL PUSHREAL8(gama(i)) + gama(i) = -5.0d0 + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(gamadnrd(i)) + gamadnrd(i) = x2dnrd + CALL PUSHREAL8(gama(i)) + gama(i) = x2 + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + temp2db25 = LOG(10.d0)*gamadnrddb(i) + temp2 = 10.d0**gama(i) + gamadb(i) = gamadnrd(i)*temp2*LOG(10.d0)*temp2db25 + 10.d0**gama + + (i)*LOG(10.d0)*gamadb(i) + gamadnrddb(i) = temp2*temp2db25 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(gama(i)) + gamadb(i) = 0.D0 + CALL POPREAL8(gamadnrd(i)) + gamadnrddb(i) = 0.D0 + x2dnrddb = 0.D0 + x2db = 0.D0 + ELSE + CALL POPREAL8(gama(i)) + x2db = gamadb(i) + gamadb(i) = 0.D0 + CALL POPREAL8(gamadnrd(i)) + x2dnrddb = gamadnrddb(i) + gamadnrddb(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + gamadb(i) = gamadb(i) + x2db + gamadnrddb(i) = gamadnrddb(i) + x2dnrddb + END IF + ENDDO + CALL POPREAL8(gama(13)) + gamadb(4) = gamadb(4) + 0.2d0*3.d0*gamadb(13) + gamadb(9) = gamadb(9) + 0.2d0*2.d0*gamadb(13) + gamadb(13) = 0.D0 + CALL POPREAL8(gamadnrd(13)) + gamadnrddb(4) = gamadnrddb(4) + 0.2d0*3.d0*gamadnrddb(13) + gamadnrddb(9) = gamadnrddb(9) + 0.2d0*2.d0*gamadnrddb(13) + gamadnrddb(13) = 0.D0 + DO ii10=1,3 + f1db(ii10) = 0.D0 + ENDDO + DO ii10=1,4 + f2db(ii10) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp2db1 = zz(12)*gamadb(12)/(z(2)+z(6)) + f1db(2) = f1db(2) + temp2db1/z(2) + f2db(3) = f2db(3) + temp2db1/z(6) + hdb = -(zz(12)*gamadb(12)) + gamadb(12) = 0.D0 + DO ii10=1,4 + f2dnrddb(ii10) = 0.D0 + ENDDO + DO ii10=1,3 + f1dnrddb(ii10) = 0.D0 + ENDDO + CALL POPREAL8(gamadnrd(12)) + temp2db2 = zz(12)*gamadnrddb(12)/(z(2)+z(6)) + f1dnrddb(2) = f1dnrddb(2) + temp2db2/z(2) + f2dnrddb(3) = f2dnrddb(3) + temp2db2/z(6) + hdnrddb = -(zz(12)*gamadnrddb(12)) + gamadnrddb(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp2db3 = zz(11)*gamadb(11)/(z(1)+z(4)) + f2db(1) = f2db(1) + temp2db3/z(4) + hdb = hdb - zz(11)*gamadb(11) + gamadb(11) = 0.D0 + CALL POPREAL8(gamadnrd(11)) + temp2db5 = zz(11)*gamadnrddb(11)/(z(1)+z(4)) + f2dnrddb(1) = f2dnrddb(1) + temp2db5/z(4) + hdnrddb = hdnrddb - zz(11)*gamadnrddb(11) + gamadnrddb(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp2db4 = zz(10)*gamadb(10)/(z(1)+z(7)) + f1db(1) = f1db(1) + temp2db4/z(1) + temp2db3/z(1) + f2db(4) = f2db(4) + temp2db4/z(7) + hdb = hdb - zz(10)*gamadb(10) + gamadb(10) = 0.D0 + CALL POPREAL8(gamadnrd(10)) + temp2db6 = zz(10)*gamadnrddb(10)/(z(1)+z(7)) + f1dnrddb(1) = f1dnrddb(1) + temp2db6/z(1) + temp2db5/z(1) + f2dnrddb(4) = f2dnrddb(4) + temp2db6/z(7) + hdnrddb = hdnrddb - zz(10)*gamadnrddb(10) + gamadnrddb(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp2db7 = zz(9)*gamadb(9)/(z(3)+z(6)) + f1db(3) = f1db(3) + temp2db7/z(3) + hdb = hdb - zz(9)*gamadb(9) + gamadb(9) = 0.D0 + CALL POPREAL8(gamadnrd(9)) + temp2db9 = zz(9)*gamadnrddb(9)/(z(3)+z(6)) + f1dnrddb(3) = f1dnrddb(3) + temp2db9/z(3) + hdnrddb = hdnrddb - zz(9)*gamadnrddb(9) + gamadnrddb(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp2db8 = zz(8)*gamadb(8)/(z(1)+z(6)) + f2db(3) = f2db(3) + temp2db8/z(6) + temp2db7/z(6) + hdb = hdb - zz(8)*gamadb(8) + gamadb(8) = 0.D0 + CALL POPREAL8(gamadnrd(8)) + temp2db10 = zz(8)*gamadnrddb(8)/(z(1)+z(6)) + f2dnrddb(3) = f2dnrddb(3) + temp2db10/z(6) + temp2db9/z(6) + hdnrddb = hdnrddb - zz(8)*gamadnrddb(8) + gamadnrddb(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp2db11 = zz(7)*gamadb(7)/(z(1)+z(5)) + f1db(1) = f1db(1) + temp2db11/z(1) + temp2db8/z(1) + f2db(2) = f2db(2) + temp2db11/z(5) + hdb = hdb - zz(7)*gamadb(7) + gamadb(7) = 0.D0 + CALL POPREAL8(gamadnrd(7)) + temp2db12 = zz(7)*gamadnrddb(7)/(z(1)+z(5)) + f1dnrddb(1) = f1dnrddb(1) + temp2db12/z(1) + temp2db10/z(1) + f2dnrddb(2) = f2dnrddb(2) + temp2db12/z(5) + hdnrddb = hdnrddb - zz(7)*gamadnrddb(7) + gamadnrddb(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp2db13 = zz(6)*gamadb(6)/(z(3)+z(4)) + f2db(1) = f2db(1) + temp2db13/z(4) + hdb = hdb - zz(6)*gamadb(6) + gamadb(6) = 0.D0 + CALL POPREAL8(gamadnrd(6)) + temp2db16 = zz(6)*gamadnrddb(6)/(z(3)+z(4)) + f2dnrddb(1) = f2dnrddb(1) + temp2db16/z(4) + hdnrddb = hdnrddb - zz(6)*gamadnrddb(6) + gamadnrddb(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp2db14 = zz(5)*gamadb(5)/(z(3)+z(7)) + f2db(4) = f2db(4) + temp2db14/z(7) + hdb = hdb - zz(5)*gamadb(5) + gamadb(5) = 0.D0 + CALL POPREAL8(gamadnrd(5)) + temp2db17 = zz(5)*gamadnrddb(5)/(z(3)+z(7)) + f2dnrddb(4) = f2dnrddb(4) + temp2db17/z(7) + hdnrddb = hdnrddb - zz(5)*gamadnrddb(5) + gamadnrddb(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp2db15 = zz(4)*gamadb(4)/(z(3)+z(5)) + f1db(3) = f1db(3) + temp2db14/z(3) + temp2db15/z(3) + temp2db13/z( + + 3) + f2db(2) = f2db(2) + temp2db15/z(5) + hdb = hdb - zz(4)*gamadb(4) + gamadb(4) = 0.D0 + CALL POPREAL8(gamadnrd(4)) + temp2db18 = zz(4)*gamadnrddb(4)/(z(3)+z(5)) + f1dnrddb(3) = f1dnrddb(3) + temp2db17/z(3) + temp2db18/z(3) + + + temp2db16/z(3) + f2dnrddb(2) = f2dnrddb(2) + temp2db18/z(5) + hdnrddb = hdnrddb - zz(4)*gamadnrddb(4) + gamadnrddb(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp2db19 = zz(3)*gamadb(3)/(z(2)+z(7)) + f2db(4) = f2db(4) + temp2db19/z(7) + hdb = hdb - zz(3)*gamadb(3) + gamadb(3) = 0.D0 + CALL POPREAL8(gamadnrd(3)) + temp2db22 = zz(3)*gamadnrddb(3)/(z(2)+z(7)) + f2dnrddb(4) = f2dnrddb(4) + temp2db22/z(7) + hdnrddb = hdnrddb - zz(3)*gamadnrddb(3) + gamadnrddb(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp2db20 = zz(2)*gamadb(2)/(z(2)+z(5)) + f2db(2) = f2db(2) + temp2db20/z(5) + hdb = hdb - zz(2)*gamadb(2) + gamadb(2) = 0.D0 + CALL POPREAL8(gamadnrd(2)) + temp2db23 = zz(2)*gamadnrddb(2)/(z(2)+z(5)) + f2dnrddb(2) = f2dnrddb(2) + temp2db23/z(5) + hdnrddb = hdnrddb - zz(2)*gamadnrddb(2) + gamadnrddb(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp2db21 = zz(1)*gamadb(1)/(z(2)+z(4)) + f1db(2) = f1db(2) + temp2db20/z(2) + temp2db21/z(2) + temp2db19/z( + + 2) + f2db(1) = f2db(1) + temp2db21/z(4) + hdb = hdb - zz(1)*gamadb(1) + gamadb(1) = 0.D0 + CALL POPREAL8(gamadnrd(1)) + temp2db24 = zz(1)*gamadnrddb(1)/(z(2)+z(4)) + f1dnrddb(2) = f1dnrddb(2) + temp2db23/z(2) + temp2db24/z(2) + + + temp2db22/z(2) + f2dnrddb(1) = f2dnrddb(1) + temp2db24/z(4) + hdnrddb = hdnrddb - zz(1)*gamadnrddb(1) + gamadnrddb(1) = 0.D0 + ionicdb = 0.D0 + DO ii10=1,4 + DO ii20=1,6 + g0dnrddb(ii20, ii10) = 0.D0 + ENDDO + ENDDO + DO ii10=1,4 + DO ii20=1,6 + g0db(ii20, ii10) = 0.D0 + ENDDO + ENDDO + ionicdnrddb = 0.D0 + DO i=3,1,-1 + mpldb = 0.D0 + mpldnrddb = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijdb = (g0dnrd(i, j)+zpl*zmi*hdnrd)*f2dnrddb(j) + (g0(i, j)+ + + zpl*zmi*h)*f2db(j) + chdnrd = -(0.25d0*(zpl+zmi)**2*ionicdnrd/ionic**2) + xijdnrd = chdnrd*mpl + ch*mpldnrd + xijdnrddb = (g0(i, j)+zpl*zmi*h)*f2dnrddb(j) + yji = ch*molal(j+3)/water + g0db(i, j) = g0db(i, j) + xijdnrd*f2dnrddb(j) + yjidnrd* + + f1dnrddb(i) + yji*f1db(i) + xij*f2db(j) + hdb = hdb + xijdnrd*zpl*zmi*f2dnrddb(j) + yjidnrd*zpl*zmi* + + f1dnrddb(i) + yji*zpl*zmi*f1db(i) + xij*zpl*zmi*f2db(j) + g0dnrddb(i, j) = g0dnrddb(i, j) + yji*f1dnrddb(i) + xij* + + f2dnrddb(j) + hdnrddb = hdnrddb + yji*zpl*zmi*f1dnrddb(i) + xij*zpl*zmi* + + f2dnrddb(j) + yjidb = (g0dnrd(i, j)+zpl*zmi*hdnrd)*f1dnrddb(i) + (g0(i, j)+ + + zpl*zmi*h)*f1db(i) + yjidnrddb = (g0(i, j)+zpl*zmi*h)*f1dnrddb(i) + temp2db = molal(j+3)*yjidb/water + CALL POPREAL8(yjidnrd) + temp2db0 = yjidnrddb/water**2 + temp1db2 = water*temp2db0 + molaldb(j+3) = molaldb(j+3) + chdnrd*temp1db2 - ch*waterdnrd* + + temp2db0 + ch*yjidb/water + temp1 = chdnrd*molal(j+3) + ch*molaldnrd(j+3) + waterdb = waterdb + (temp1-(temp1*water-molal(j+3)*(ch* + + waterdnrd))*2/water)*temp2db0 - ch*temp2db/water + temp1db3 = -(molal(j+3)*temp2db0) + chdb = molaldnrd(j+3)*temp1db2 + waterdnrd*temp1db3 + mpldnrd* + + xijdnrddb + mpl*xijdb + temp2db + chdnrddb = mpl*xijdnrddb + molal(j+3)*temp1db2 + molaldnrddb(j+3) = molaldnrddb(j+3) + ch*temp1db2 + waterdnrddb = waterdnrddb + ch*temp1db3 + mpldb = mpldb + chdnrd*xijdnrddb + ch*xijdb + mpldnrddb = mpldnrddb + ch*xijdnrddb + temp1db4 = -((zpl+zmi)**2*0.25d0*chdnrddb/ionic**2) + ionicdb = ionicdb - ionicdnrd*2*temp1db4/ionic - (zpl+zmi)**2* + + 0.25d0*chdb/ionic**2 + ionicdnrddb = ionicdnrddb + temp1db4 + ENDDO + temp1db1 = mpldnrddb/water**2 + CALL POPREAL8(mpl) + molaldb(i) = molaldb(i) + mpldb/water - waterdnrd*temp1db1 + waterdb = waterdb + (molaldnrd(i)-(molaldnrd(i)*water-molal(i)* + + waterdnrd)*2/water)*temp1db1 - molal(i)*mpldb/water**2 + CALL POPREAL8(mpldnrd) + molaldnrddb(i) = molaldnrddb(i) + water*temp1db1 + waterdnrddb = waterdnrddb - molal(i)*temp1db1 + CALL POPREAL8(zpl) + ENDDO + temp1db0 = hdnrddb/(sion+1.d0)**2 + temp1db = agama*hdb/(sion+1.d0) + siondb = (1.D0-sion/(sion+1.d0))*temp1db - (agama*(siondnrd*(sion+ + + 1.d0))-agama*(sion*siondnrd))*2*temp1db0/(sion+1.d0) + siondnrddb = (agama*(sion+1.d0)-agama*sion)*temp1db0 + IF (.NOT.ionic == 0.0) ionicdb = ionicdb + siondb/(2.0*SQRT( + + ionic)) + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp0 = SQRT(ionic) + temp0db1 = siondnrddb/(2.0*temp0) + ionicdnrddb = ionicdnrddb + temp0db1 + IF (.NOT.ionic == 0.0) ionicdb = ionicdb - ionicdnrd*temp0db1/ + + (2.0*temp0**2) + END IF + g05db = g0db(3, 4) + g0db(3, 4) = 0.D0 + g05dnrddb = g0dnrddb(3, 4) + g0dnrddb(3, 4) = 0.D0 + g09db = g0db(3, 3) + g0db(3, 3) = 0.D0 + g09dnrddb = g0dnrddb(3, 3) + g0dnrddb(3, 3) = 0.D0 + g04db = g0db(3, 2) + g0db(3, 2) = 0.D0 + g04dnrddb = g0dnrddb(3, 2) + g0dnrddb(3, 2) = 0.D0 + g06db = g0db(3, 1) + g0db(3, 1) = 0.D0 + g06dnrddb = g0dnrddb(3, 1) + g0dnrddb(3, 1) = 0.D0 + g03db = g0db(2, 4) + g0db(2, 4) = 0.D0 + g03dnrddb = g0dnrddb(2, 4) + g0dnrddb(2, 4) = 0.D0 + g12db = g0db(2, 3) + g0db(2, 3) = 0.D0 + g12dnrddb = g0dnrddb(2, 3) + g0dnrddb(2, 3) = 0.D0 + g02db = g0db(2, 2) + g0db(2, 2) = 0.D0 + g02dnrddb = g0dnrddb(2, 2) + g0dnrddb(2, 2) = 0.D0 + g01db = g0db(2, 1) + g0db(2, 1) = 0.D0 + g01dnrddb = g0dnrddb(2, 1) + g0dnrddb(2, 1) = 0.D0 + g10db = g0db(1, 4) + g0db(1, 4) = 0.D0 + g10dnrddb = g0dnrddb(1, 4) + g0dnrddb(1, 4) = 0.D0 + g08db = g0db(1, 3) + g0db(1, 3) = 0.D0 + g08dnrddb = g0dnrddb(1, 3) + g0dnrddb(1, 3) = 0.D0 + g07db = g0db(1, 2) + g0db(1, 2) = 0.D0 + g07dnrddb = g0dnrddb(1, 2) + g0dnrddb(1, 2) = 0.D0 + g11db = g0db(1, 1) + g11dnrddb = g0dnrddb(1, 1) + CALL KMFUL3_DNRD_DB(ionic, ionicdb, ionicdnrd, ionicdnrddb, temp, + + g01, g01db, g01dnrd, g01dnrddb, g02, g02db, + + g02dnrd, g02dnrddb, g03, g03db, g03dnrd, + + g03dnrddb, g04, g04db, g04dnrd, g04dnrddb, g05 + + , g05db, g05dnrd, g05dnrddb, g06, g06db, + + g06dnrd, g06dnrddb, g07, g07db, g07dnrd, + + g07dnrddb, g08, g08db, g08dnrd, g08dnrddb, g09 + + , g09db, g09dnrd, g09dnrddb, g10, g10db, + + g10dnrd, g10dnrddb, g11, g11db, g11dnrd, + + g11dnrddb, g12, g12db, g12dnrd, g12dnrddb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionicdnrd) + CALL POPREAL8(ionic) + x1db = 0.D0 + x1dnrddb = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1db = ionicdb + CALL POPREAL8(ionicdnrd) + x1dnrddb = ionicdnrddb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ionicdb = 0.D0 + ionicdnrddb = 0.D0 + ELSE + temp0db0 = x1dnrddb/water**2 + temp0db = 0.5d0*x1db/water + ionicdb = temp0db - 0.5d0*waterdnrd*temp0db0 + waterdb = waterdb + (0.5d0*ionicdnrd-(0.5d0*(ionicdnrd*water)- + + 0.5d0*(ionic*waterdnrd))*2/water)*temp0db0 - ionic*temp0db/ + + water + ionicdnrddb = 0.5d0*water*temp0db0 + waterdnrddb = waterdnrddb - 0.5d0*ionic*temp0db0 + END IF + DO i=7,1,-1 + molaldb(i) = molaldb(i) + z(i)**2*ionicdb + molaldnrddb(i) = molaldnrddb(i) + z(i)**2*ionicdnrddb + ENDDO + END + +C Differentiation of kmful3_dnrd in reverse (adjoint) mode: +C gradient of useful results: g11dnrd g04dnrd g09dnrd g01 +C g02 g03 g04 g12dnrd g05 g06 g07 g08 g09 g05dnrd +C g10 g11 g12 g01dnrd ionicdnrd g06dnrd ionic g02dnrd +C g07dnrd g10dnrd g03dnrd g08dnrd +C with respect to varying inputs: ionicdnrd ionic +C +C Differentiation of kmful3 in forward (tangent) mode: +C variations of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_DNRD_DB(ionic, ionicdb, ionicdnrd, ionicdnrddb, + + temp, g01, g01db, g01dnrd, g01dnrddb, + + g02, g02db, g02dnrd, g02dnrddb, g03, + + g03db, g03dnrd, g03dnrddb, g04, g04db, + + g04dnrd, g04dnrddb, g05, g05db, g05dnrd + + , g05dnrddb, g06, g06db, g06dnrd, + + g06dnrddb, g07, g07db, g07dnrd, + + g07dnrddb, g08, g08db, g08dnrd, + + g08dnrddb, g09, g09db, g09dnrd, + + g09dnrddb, g10, g10db, g10dnrd, + + g10dnrddb, g11, g11db, g11dnrd, + + g11dnrddb, g12, g12db, g12dnrd, + + g12dnrddb) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionicdb, siondb, cf2db + REAL*8 :: ionicdnrd, siondnrd, cf2dnrd + REAL*8 :: ionicdnrddb, siondnrddb, cf2dnrddb + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01db, g02db, g03db, g04db, g05db, g06db, g07db, + + g08db, g09db, g10db, g11db, g12db + REAL*8 :: g01dnrd, g02dnrd, g03dnrd, g04dnrd, g05dnrd, + + g06dnrd, g07dnrd, g08dnrd, g09dnrd, g10dnrd, + + g11dnrd, g12dnrd + REAL*8 :: g01dnrddb, g02dnrddb, g03dnrddb, g04dnrddb, + + g05dnrddb, g06dnrddb, g07dnrddb, g08dnrddb, + + g09dnrddb, g10dnrddb, g11dnrddb, g12dnrddb + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTRINSIC ABS + REAL*8 :: abs1 + INTRINSIC SQRT + REAL*8 :: tiny + INTEGER :: branch + REAL*8 :: temp0 + REAL*8 :: temp1db3 + REAL*8 :: temp1db2 + REAL*8 :: temp1db1 + REAL*8 :: temp1db0 + REAL*8 :: temp0db + REAL*8 :: abs2 + REAL*8 :: temp1db + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ + tiny = 1.d-20 + IF (ionic >= 0.) THEN + abs2 = ionic + ELSE + abs2 = -ionic + END IF +C + IF (abs2 < tiny) THEN + CALL PUSHCONTROL1B(0) + siondnrd = 0.d0 + ELSE + siondnrd = ionicdnrd/(2.0*SQRT(ionic)) + CALL PUSHCONTROL1B(1) + END IF + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.d0) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01db = g01db + g12db + g08db = g08db + g09db + g12db + g11db = g11db - g09db - g12db + g01dnrddb = g01dnrddb + g12dnrddb + g08dnrddb = g08dnrddb + g09dnrddb + g12dnrddb + g11dnrddb = g11dnrddb - g09dnrddb - g12dnrddb + g06db = g06db + g09db + g06dnrddb = g06dnrddb + g09dnrddb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2db = -(z10*g10db) - z07*g07db - z05*g05db - z03*g03db - z01* + + g01db - z02*g02db - z04*g04db - z06*g06db - z08*g08db - z11* + + g11db + g11db = cf1*g11db + cf2dnrddb = -(z10*g10dnrddb) - z07*g07dnrddb - z05*g05dnrddb - + + z03*g03dnrddb - z01*g01dnrddb - z02*g02dnrddb - z04*g04dnrddb + + - z06*g06dnrddb - z08*g08dnrddb - z11*g11dnrddb + g11dnrddb = cf1*g11dnrddb + g10db = cf1*g10db + g10dnrddb = cf1*g10dnrddb + g08db = cf1*g08db + g08dnrddb = cf1*g08dnrddb + g07db = cf1*g07db + g07dnrddb = cf1*g07dnrddb + g06db = cf1*g06db + g06dnrddb = cf1*g06dnrddb + g05db = cf1*g05db + g05dnrddb = cf1*g05dnrddb + g04db = cf1*g04db + g04dnrddb = cf1*g04dnrddb + g03db = cf1*g03db + g03dnrddb = cf1*g03dnrddb + g02db = cf1*g02db + g02dnrddb = cf1*g02dnrddb + g01db = cf1*g01db + g01dnrddb = cf1*g01dnrddb + temp1db = (0.125d0-ti*0.005d0)*cf2db + temp1db0 = -(0.41d0*temp1db/(sion+1.d0)) + temp1db3 = (0.125d0-ti*0.005d0)*cf2dnrddb + temp1db1 = 0.92d0*0.039d0*temp1db3 + ionicdb = ionicdb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp1db - + + ionicdnrd*0.8d0*ionic**(-1.8D0)*temp1db1 + temp1db2 = -(temp1db3/(sion+1.d0)**2) + siondb = (1.D0-sion/(sion+1.d0))*temp1db0 - (0.41d0*(siondnrd*( + + sion+1.d0))-0.41d0*(sion*siondnrd))*2*temp1db2/(sion+1.d0) + ionicdnrddb = ionicdnrddb + ionic**(-0.8d0)*temp1db1 + siondnrddb = (0.41d0*(sion+1.d0)-0.41d0*sion)*temp1db2 + ELSE + siondnrddb = 0.D0 + siondb = 0.D0 + END IF + CALL MKBI_DNRD_DB(q11, ionic, ionicdb, ionicdnrd, ionicdnrddb, + + sion, siondb, siondnrd, siondnrddb, z11, g11, + + g11db, g11dnrd, g11dnrddb) + CALL MKBI_DNRD_DB(q10, ionic, ionicdb, ionicdnrd, ionicdnrddb, + + sion, siondb, siondnrd, siondnrddb, z10, g10, + + g10db, g10dnrd, g10dnrddb) + CALL MKBI_DNRD_DB(q8, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion + + , siondb, siondnrd, siondnrddb, z08, g08, g08db + + , g08dnrd, g08dnrddb) + CALL MKBI_DNRD_DB(q7, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion + + , siondb, siondnrd, siondnrddb, z07, g07, g07db + + , g07dnrd, g07dnrddb) + CALL MKBI_DNRD_DB(q6, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion + + , siondb, siondnrd, siondnrddb, z06, g06, g06db + + , g06dnrd, g06dnrddb) + CALL MKBI_DNRD_DB(q5, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion + + , siondb, siondnrd, siondnrddb, z05, g05, g05db + + , g05dnrd, g05dnrddb) + CALL MKBI_DNRD_DB(q4, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion + + , siondb, siondnrd, siondnrddb, z04, g04, g04db + + , g04dnrd, g04dnrddb) + CALL MKBI_DNRD_DB(q3, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion + + , siondb, siondnrd, siondnrddb, z03, g03, g03db + + , g03dnrd, g03dnrddb) + CALL MKBI_DNRD_DB(q2, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion + + , siondb, siondnrd, siondnrddb, z02, g02, g02db + + , g02dnrd, g02dnrddb) + CALL MKBI_DNRD_DB(q1, ionic, ionicdb, ionicdnrd, ionicdnrddb, sion + + , siondb, siondnrd, siondnrddb, z01, g01, g01db + + , g01dnrd, g01dnrddb) + IF (.NOT.ionic == 0.0) ionicdb = ionicdb + siondb/(2.0*SQRT( + + ionic)) + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp0 = SQRT(ionic) + temp0db = siondnrddb/(2.0*temp0) + ionicdnrddb = ionicdnrddb + temp0db + IF (.NOT.ionic == 0.0) ionicdb = ionicdb - ionicdnrd*temp0db/( + + 2.0*temp0**2) + END IF + END + +C Differentiation of mkbi_dnrd in reverse (adjoint) mode: +C gradient of useful results: siondnrd sion bi bidnrd ionicdnrd +C ionic +C with respect to varying inputs: siondnrd sion ionicdnrd ionic +C +C Differentiation of mkbi in forward (tangent) mode: +C variations of useful results: bi +C with respect to varying inputs: sion ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_DNRD_DB(q, ionic, ionicdb, ionicdnrd, ionicdnrddb + + , sion, siondb, siondnrd, siondnrddb, zip + + , bi, bidb, bidnrd, bidnrddb) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionicdb, siondb, bidb + REAL*8 :: ionicdnrd, siondnrd, bidnrd + REAL*8 :: ionicdnrddb, siondnrddb, bidnrddb + REAL*8 :: b, c, xx + REAL*8 :: cdb, xxdb + REAL*8 :: cdnrd, xxdnrd + REAL*8 :: cdnrddb, xxdnrddb + REAL*8 :: arg1 + REAL*8 :: arg1db + REAL*8 :: arg1dnrd + REAL*8 :: arg1dnrddb + REAL*8 :: pwx1 + REAL*8 :: pwx1db + REAL*8 :: pwx1dnrd + REAL*8 :: pwx1dnrddb + REAL*8 :: pwr1 + REAL*8 :: pwr1db + REAL*8 :: pwr1dnrd + REAL*8 :: pwr1dnrddb + INTRINSIC EXP + INTRINSIC LOG10 + REAL*8 :: tiny + INTEGER :: branch + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: tempdb + REAL*8 :: temp1db3 + REAL*8 :: temp1db2 + REAL*8 :: temp1db1 + REAL*8 :: temp1db0 + INTRINSIC ABS + REAL*8 :: x1 + REAL*8 :: temp0db + INTRINSIC LOG + INTRINSIC INT + REAL*8 :: abs3 + REAL*8 :: abs2 + REAL*8 :: abs1 + REAL*8 :: tempdb2 + REAL*8 :: temp1db + REAL*8 :: tempdb1 + REAL*8 :: tempdb0 + REAL*8 :: temp + tiny = 1.d-20 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + arg1dnrd = -(.023d0*((ionicdnrd*ionic+ionic*ionicdnrd)*ionic+ionic + + **2*ionicdnrd)) + arg1 = -(.023d0*ionic*ionic*ionic) + cdnrd = .055d0*q*arg1dnrd*EXP(arg1) + c = 1. + .055d0*q*EXP(arg1) + pwx1dnrd = .1d0*ionicdnrd + pwx1 = 1.d0 + .1d0*ionic + x1 = q - INT(q) + IF (x1 >= 0.) THEN + abs1 = x1 + ELSE + abs1 = -x1 + END IF + IF (pwx1 .GT. 0.d0 .OR. (pwx1 .LT. 0.d0 .AND. abs1 .LT. tiny)) + +THEN + pwr1dnrd = q*pwx1**(q-1)*pwx1dnrd + CALL PUSHCONTROL2B(0) + ELSE + IF (pwx1 .GE. 0.) THEN + abs2 = pwx1 + ELSE + abs2 = -pwx1 + END IF + IF (q - 1.d0 .GE. 0.) THEN + abs3 = q - 1.d0 + ELSE + abs3 = -(q-1.d0) + END IF + IF (abs2 .LT. tiny .AND. abs3 .LT. tiny) THEN + pwr1dnrd = pwx1dnrd + CALL PUSHCONTROL2B(1) + ELSE + pwr1dnrd = 0.0 + CALL PUSHCONTROL2B(2) + END IF + END IF + pwr1 = pwx1**q + bidnrd = b*pwr1dnrd + bi = 1.d0 + b*pwr1 - b +C + temp1 = LOG(10.d0) + temp1db3 = zip*bidnrddb/(temp1*bi) + xxdb = zip*bidb + bidb = zip*bidb/(bi*LOG(10.0)) - bidnrd*temp1db3/bi + xxdnrddb = zip*bidnrddb + bidnrddb = temp1db3 + pwr1db = b*bidb + pwr1dnrddb = b*bidnrddb + IF (pwx1 .LE. 0.0 .AND. (q .EQ. 0.0 .OR. q .NE. INT(q))) THEN + pwx1db = 0.0 + ELSE + pwx1db = q*pwx1**(q-1)*pwr1db + END IF + CALL POPCONTROL2B(branch) + IF (branch .EQ. 0) THEN + IF (.NOT.(pwx1 .LE. 0.0 .AND. (q - 1 .EQ. 0.0 .OR. q - 1 .NE. + + INT(q - 1)))) pwx1db = pwx1db + pwx1dnrd*q*(q-1)*pwx1**(q-2) + + *pwr1dnrddb + pwx1dnrddb = q*pwx1**(q-1)*pwr1dnrddb + ELSE IF (branch .EQ. 1) THEN + pwx1dnrddb = pwr1dnrddb + ELSE + pwx1dnrddb = 0.D0 + END IF + temp = c*sion + 1.d0 + temp1db2 = -(xxdnrddb/temp**2) + temp1db1 = 0.5107d0*siondnrd*temp1db2 + temp0 = cdnrd*sion + c*siondnrd + temp0db = -(0.5107d0*sion*temp1db2) + tempdb1 = -((0.5107d0*(siondnrd*(c*sion+1.d0))-0.5107d0*(sion* + + temp0))*2*temp1db2/temp) + temp1db = -(0.5107d0*xxdb/(c*sion+1.d0)) + temp1db0 = -(sion*temp1db/(c*sion+1.d0)) + cdb = sion*temp1db1 + siondnrd*temp0db + sion*tempdb1 + sion* + + temp1db0 + cdnrddb = sion*temp0db + tempdb2 = q*.055d0*cdnrddb + arg1db = arg1dnrd*EXP(arg1)*tempdb2 + q*.055d0*EXP(arg1)*cdb + arg1dnrddb = EXP(arg1)*tempdb2 + tempdb = -(.023d0*arg1dnrddb) + tempdb0 = ionic*tempdb + ionicdb = ionicdb + (ionicdnrd*2*ionic+ionicdnrd*ionic+ionic* + + ionicdnrd)*tempdb - .023d0*3*ionic**2*arg1db + 2*ionicdnrd* + + tempdb0 + .1d0*pwx1db + ionicdnrddb = ionicdnrddb + 2*ionic*tempdb0 + ionic**2*tempdb + + + .1d0*pwx1dnrddb + siondb = siondb + c*temp1db1 - 0.5107d0*temp0*temp1db2 + cdnrd* + + temp0db + c*tempdb1 + c*temp1db0 + temp1db + siondnrddb = siondnrddb + c*temp0db + 0.5107d0*(c*sion+1.d0)* + + temp1db2 + END +C +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of funcd3b in forward (tangent) mode: +C variations of useful results: fd3b +C with respect to varying inputs: p4 +C RW status of diff variables: p4:in fd3b:out +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** FUNCTION FUNCD3 +C *** CASE D3 +C FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ; +C AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3. +C +C======================================================================= +C + SUBROUTINE FUNCD3B_DNRD(p4, p4dnrd, fd3b, fd3bdnrd) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: psi3dnrd + REAL*8 :: psi4dnrd + REAL*8 :: a3dnrd + REAL*8 :: a4dnrd + REAL*8 :: a7dnrd + REAL*8 :: p4, bb, denm, ahi, aml5, fd3b + REAL*8 :: p4dnrd, bbdnrd, denmdnrd, ahidnrd, aml5dnrd, + + fd3bdnrd + CHARACTER(LEN=40) errinf + INTEGER :: errstki(25), k, j + LOGICAL dexs, iexs, eof + CHARACTER(LEN=40) errmsgi(25) + LOGICAL tst + INTEGER :: i + REAL*8 :: molalrdnrd(npair) + REAL*8 :: abb + REAL*8 :: abbdnrd + REAL*8 :: arg1 + REAL*8 :: arg1dnrd + REAL*8 :: result1 + REAL*8 :: result1dnrd + REAL*8 :: x1dnrd + INTRINSIC MAX + INTRINSIC ABS + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: max1dnrd + REAL*8 :: x2dnrd + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: max1 +C +C *** SETUP PARAMETERS ************************************************ +C +C WRITE(*,*) 'Within FUNCD3B_DNRD: ',p4,p4dnrd + psi4dnrd = p4dnrd + psi4 = p4 + DO ii1=1,nions + molaldnrd(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + molalrdnrd(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + gamadnrd(ii1) = 0.D0 + ENDDO + waterdnrd = 0.D0 + gnh3dnrd = 0.D0 + a4dnrd = 0.D0 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + DO i=1,3 +C + a2 = xk7*(water/gama(4))**3.0 + a3dnrd = xk4*r*temp*2.0*water*(waterdnrd*gama(10)-water*gamadnrd + + (10))/gama(10)**3 + a3 = xk4*r*temp*(water/gama(10))**2.0 + a4dnrd = xk2*r*temp*2.0*gama(10)*(gamadnrd(10)*gama(5)-gama(10)* + + gamadnrd(5))/(xkw*gama(5)**3) + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + a7dnrd = xkw*rh*(waterdnrd*water+water*waterdnrd) + a7 = xkw*rh*water*water +C + psi3dnrd = chi3*((a3dnrd*a4+a3*a4dnrd)*(chi4-psi4)-a3*a4* + + psi4dnrd) - psi1*psi4dnrd + psi3 = a3*a4*chi3*(chi4-psi4) - psi1*(2.d0*psi2+psi1+psi4) + psi3dnrd = (psi3dnrd*(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4)- + + psi3*((a3dnrd*a4+a3*a4dnrd)*(chi4-psi4)-a3*a4*psi4dnrd+ + + psi4dnrd))/(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4)**2 + psi3 = psi3/(a3*a4*(chi4-psi4)+2.d0*psi2+psi1+psi4) + IF (psi3 < zero) THEN + x1 = zero + x1dnrd = 0.D0 + ELSE + x1dnrd = psi3dnrd + x1 = psi3 + END IF + IF (x1 > chi3) THEN + psi3 = chi3 + psi3dnrd = 0.D0 + ELSE + psi3dnrd = x1dnrd + psi3 = x1 + END IF +C + bbdnrd = psi4dnrd - psi3dnrd + bb = psi4 - psi3 + arg1dnrd = bbdnrd*bb + bb*bbdnrd + 4.d0*a7dnrd + arg1 = bb*bb + 4.d0*a7 + IF (abs(arg1) < tiny) THEN + result1dnrd = 0.D0 + ELSE + result1dnrd = arg1dnrd/(2.0*SQRT(arg1)) + END IF + result1 = SQRT(arg1) + denmdnrd = bbdnrd + result1dnrd + denm = bb + result1 + IF (denm <= tiny) THEN + IF (bb >= 0.D0) THEN + abbdnrd = bbdnrd + abb = bb + ELSE + abbdnrd = -bbdnrd + abb = -bb + END IF +C Taylor expansion of SQRT + denmdnrd = bbdnrd + abbdnrd + (2.0*a7dnrd*abb-2.0*a7*abbdnrd)/ + + abb**2 - (2.0*(a7dnrd*a7+a7*a7dnrd)*abb**3.0-2.0*a7**2*3.0* + + abb**2.0*abbdnrd)/(abb**3.0)**2 + denm = bb + abb + 2.0*a7/abb - 2.0*a7*a7/abb**3.0 +C WRITE(*,*) 'TS approx. of DENM: ',DENM + END IF + ahidnrd = (2.D0*a7dnrd*denm-2.D0*a7*denmdnrd)/denm**2 + ahi = 2.D0*a7/denm +C +C *** SPECIATION & WATER CONTENT *************************************** +C +C HI + molaldnrd(1) = ahidnrd + molal(1) = ahi +C NH4I + molaldnrd(3) = psi4dnrd + molal(3) = psi1 + psi4 + 2.d0*psi2 +C SO4I + molaldnrd(5) = 0.D0 + molal(5) = psi2 +C HSO4I + molaldnrd(6) = 0.D0 + molal(6) = zero +C NO3I + molaldnrd(7) = psi3dnrd + molal(7) = psi3 + psi1 +C Solid (NH4)2SO4 + cnh42s4 = chi2 - psi2 +C Solid NH4NO3 + cnh4no3 = zero +C Gas HNO3 + ghno3 = chi3 - psi3 +C Gas NH3 + gnh3dnrd = -psi4dnrd + gnh3 = chi4 - psi4 +C +C CALL CALCMR ! Water content +C +C (NH4)2SO4 + molalrdnrd(4) = molaldnrd(5) + molaldnrd(6) + molalr(4) = molal(5) + molal(6) +C "free" NH4 + aml5dnrd = molaldnrd(3) - 2.d0*molalrdnrd(4) + aml5 = molal(3) - 2.d0*molalr(4) + IF (aml5 > molal(7)) THEN + x2dnrd = molaldnrd(7) + x2 = molal(7) + ELSE + x2dnrd = aml5dnrd + x2 = aml5 + END IF + IF (x2 < zero) THEN + molalrdnrd(5) = 0.D0 + molalr(5) = zero + ELSE + molalrdnrd(5) = x2dnrd + molalr(5) = x2 + END IF +C +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + waterdnrd = 0.D0 + DO j=1,npair + waterdnrd = waterdnrd + molalrdnrd(j)/m0(j) + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + waterdnrd = 0.D0 + ELSE + water = water + END IF +C + CALL CALCACT3P_DNRD() + ENDDO + IF (gnh3 < tiny) THEN + max1 = tiny + max1dnrd = 0.D0 + ELSE + max1dnrd = gnh3dnrd + max1 = gnh3 + END IF +C +C *** CALCULATE OBJECTIVE FUNCTION ************************************ +C +CCC FUNCD3= NH4I/HI/MAXCOMP(GNH3,TINY)/A4 - ONE + fd3bdnrd = (((molaldnrd(3)*molal(1)-molal(3)*molaldnrd(1))*max1/ + + molal(1)**2-molal(3)*max1dnrd/molal(1))*a4/max1**2-molal(3)* + + a4dnrd/(molal(1)*max1))/a4**2 + fd3b = molal(3)/molal(1)/max1/a4 - one + RETURN + END +C +C Differentiation of calcact3p in forward (tangent) mode: +C variations of useful results: gama +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3P_DNRD() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0dnrd(6, 4), siondnrd, hdnrd, chdnrd, f1dnrd(3) + + , f2dnrd(4) + REAL*8 :: mpl, xij, yji, ionicdnrd + REAL*8 :: mpldnrd, xijdnrd, yjidnrd + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01dnrd + REAL*8 :: g02 + REAL*8 :: g02dnrd + REAL*8 :: g03 + REAL*8 :: g03dnrd + REAL*8 :: g04 + REAL*8 :: g04dnrd + REAL*8 :: g05 + REAL*8 :: g05dnrd + REAL*8 :: g06 + REAL*8 :: g06dnrd + REAL*8 :: g07 + REAL*8 :: g07dnrd + REAL*8 :: g08 + REAL*8 :: g08dnrd + REAL*8 :: g09 + REAL*8 :: g09dnrd + REAL*8 :: g10 + REAL*8 :: g10dnrd + REAL*8 :: g11 + REAL*8 :: g11dnrd + REAL*8 :: g12 + REAL*8 :: g12dnrd + INTEGER :: j + REAL*8 :: x1dnrd + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x2dnrd + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + ionicdnrd = 0.D0 + DO i=1,7 + ionicdnrd = ionicdnrd + z(i)**2*molaldnrd(i) + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + x1dnrd = 0.D0 + ELSE + x1dnrd = (0.5d0*ionicdnrd*water-0.5d0*ionic*waterdnrd)/water**2 + x1 = 0.5d0*ionic/water + END IF + IF (x1 < tiny) THEN + ionic = tiny + ionicdnrd = 0.D0 + ELSE + ionicdnrd = x1dnrd + ionic = x1 + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3_DNRD(ionic, ionicdnrd, temp, g01, g01dnrd, g02, + + g02dnrd, g03, g03dnrd, g04, g04dnrd, g05, g05dnrd + + , g06, g06dnrd, g07, g07dnrd, g08, g08dnrd, g09, + + g09dnrd, g10, g10dnrd, g11, g11dnrd, g12, g12dnrd + + ) + DO ii1=1,4 + DO ii2=1,6 + g0dnrd(ii2, ii1) = 0.D0 + ENDDO + ENDDO +C + g0dnrd(1, 1) = g11dnrd + g0(1, 1) = g11 + g0dnrd(1, 2) = g07dnrd + g0(1, 2) = g07 + g0dnrd(1, 3) = g08dnrd + g0(1, 3) = g08 + g0dnrd(1, 4) = g10dnrd + g0(1, 4) = g10 + g0dnrd(2, 1) = g01dnrd + g0(2, 1) = g01 + g0dnrd(2, 2) = g02dnrd + g0(2, 2) = g02 + g0dnrd(2, 3) = g12dnrd + g0(2, 3) = g12 + g0dnrd(2, 4) = g03dnrd + g0(2, 4) = g03 + g0dnrd(3, 1) = g06dnrd + g0(3, 1) = g06 + g0dnrd(3, 2) = g04dnrd + g0(3, 2) = g04 + g0dnrd(3, 3) = g09dnrd + g0(3, 3) = g09 + g0dnrd(3, 4) = g05dnrd + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + IF (abs(ionic) < tiny) THEN + siondnrd = 0.D0 + ELSE + siondnrd = ionicdnrd/(2.0*SQRT(ionic)) + END IF + sion = SQRT(ionic) + hdnrd = (agama*siondnrd*(1.d0+sion)-agama*sion*siondnrd)/(1.d0+ + + sion)**2 + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1dnrd(i) = 0.D0 + f1(i) = 0.d0 + f2dnrd(i) = 0.D0 + f2(i) = 0.d0 + ENDDO + f2dnrd(4) = 0.D0 + f2(4) = 0.d0 + DO ii1=1,3 + f1dnrd(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2dnrd(ii1) = 0.D0 + ENDDO +C + DO i=1,3 + zpl = z(i) + mpldnrd = (molaldnrd(i)*water-molal(i)*waterdnrd)/water**2 + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + chdnrd = -(0.25d0*(zpl+zmi)**2*ionicdnrd/ionic**2) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xijdnrd = chdnrd*mpl + ch*mpldnrd + xij = ch*mpl + yjidnrd = ((chdnrd*molal(j+3)+ch*molaldnrd(j+3))*water-ch* + + molal(j+3)*waterdnrd)/water**2 + yji = ch*molal(j+3)/water + f1dnrd(i) = f1dnrd(i) + yjidnrd*(g0(i, j)+zpl*zmi*h) + yji*( + + g0dnrd(i, j)+zpl*zmi*hdnrd) + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2dnrd(j) = f2dnrd(j) + xijdnrd*(g0(i, j)+zpl*zmi*h) + xij*( + + g0dnrd(i, j)+zpl*zmi*hdnrd) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gamadnrd(1) = zz(1)*((f1dnrd(2)/z(2)+f2dnrd(1)/z(4))/(z(2)+z(4))- + + hdnrd) + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gamadnrd(2) = zz(2)*((f1dnrd(2)/z(2)+f2dnrd(2)/z(5))/(z(2)+z(5))- + + hdnrd) + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gamadnrd(3) = zz(3)*((f1dnrd(2)/z(2)+f2dnrd(4)/z(7))/(z(2)+z(7))- + + hdnrd) + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gamadnrd(4) = zz(4)*((f1dnrd(3)/z(3)+f2dnrd(2)/z(5))/(z(3)+z(5))- + + hdnrd) + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gamadnrd(5) = zz(5)*((f1dnrd(3)/z(3)+f2dnrd(4)/z(7))/(z(3)+z(7))- + + hdnrd) + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gamadnrd(6) = zz(6)*((f1dnrd(3)/z(3)+f2dnrd(1)/z(4))/(z(3)+z(4))- + + hdnrd) + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gamadnrd(7) = zz(7)*((f1dnrd(1)/z(1)+f2dnrd(2)/z(5))/(z(1)+z(5))- + + hdnrd) + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gamadnrd(8) = zz(8)*((f1dnrd(1)/z(1)+f2dnrd(3)/z(6))/(z(1)+z(6))- + + hdnrd) + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gamadnrd(9) = zz(9)*((f1dnrd(3)/z(3)+f2dnrd(3)/z(6))/(z(3)+z(6))- + + hdnrd) + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gamadnrd(10) = zz(10)*((f1dnrd(1)/z(1)+f2dnrd(4)/z(7))/(z(1)+z(7)) + + -hdnrd) + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gamadnrd(11) = zz(11)*((f1dnrd(1)/z(1)+f2dnrd(1)/z(4))/(z(1)+z(4)) + + -hdnrd) + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gamadnrd(12) = zz(12)*((f1dnrd(2)/z(2)+f2dnrd(3)/z(6))/(z(2)+z(6)) + + -hdnrd) + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) +C LC ; SCAPE + gamadnrd(13) = 0.2d0*(3.d0*gamadnrd(4)+2.d0*gamadnrd(9)) + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + x2 = 5.0d0 + x2dnrd = 0.D0 + ELSE + x2dnrd = gamadnrd(i) + x2 = gama(i) + END IF + IF (x2 < -5.0d0) THEN + gamadnrd(i) = 0.D0 + gama(i) = -5.0d0 + ELSE + gamadnrd(i) = x2dnrd + gama(i) = x2 + END IF + gamadnrd(i) = 10.d0**gama(i)*LOG(10.d0)*gamadnrd(i) + gama(i) = 10.d0**gama(i) + ENDDO +C +C Increment ACTIVITY call counter + iclact = iclact + 1 +C +C *** END OF SUBROUTINE ACTIVITY **************************************** +C + RETURN + END + +C Differentiation of kmful3 in forward (tangent) mode: +C variations of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_DNRD(ionic, ionicdnrd, temp, g01, g01dnrd, g02, + + g02dnrd, g03, g03dnrd, g04, g04dnrd, g05, + + g05dnrd, g06, g06dnrd, g07, g07dnrd, g08, + + g08dnrd, g09, g09dnrd, g10, g10dnrd, g11, + + g11dnrd, g12, g12dnrd) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionicdnrd, siondnrd, cf2dnrd + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01dnrd, g02dnrd, g03dnrd, g04dnrd, g05dnrd, + + g06dnrd, g07dnrd, g08dnrd, g09dnrd, g10dnrd, + + g11dnrd, g12dnrd + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTRINSIC ABS + REAL*8 :: abs1 + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ + REAL*8 :: tiny + tiny = 1.d-20 +C + IF (abs(ionic) < tiny) THEN + siondnrd = 0.D0 + ELSE + siondnrd = ionicdnrd/(2.0*SQRT(ionic)) + END IF + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C + CALL MKBI_DNRD(q1, ionic, ionicdnrd, sion, siondnrd, z01, g01, + + g01dnrd) + CALL MKBI_DNRD(q2, ionic, ionicdnrd, sion, siondnrd, z02, g02, + + g02dnrd) + CALL MKBI_DNRD(q3, ionic, ionicdnrd, sion, siondnrd, z03, g03, + + g03dnrd) + CALL MKBI_DNRD(q4, ionic, ionicdnrd, sion, siondnrd, z04, g04, + + g04dnrd) + CALL MKBI_DNRD(q5, ionic, ionicdnrd, sion, siondnrd, z05, g05, + + g05dnrd) + CALL MKBI_DNRD(q6, ionic, ionicdnrd, sion, siondnrd, z06, g06, + + g06dnrd) + CALL MKBI_DNRD(q7, ionic, ionicdnrd, sion, siondnrd, z07, g07, + + g07dnrd) + CALL MKBI_DNRD(q8, ionic, ionicdnrd, sion, siondnrd, z08, g08, + + g08dnrd) + CALL MKBI_DNRD(q10, ionic, ionicdnrd, sion, siondnrd, z10, g10, + + g10dnrd) + CALL MKBI_DNRD(q11, ionic, ionicdnrd, sion, siondnrd, z11, g11, + + g11dnrd) +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.D0) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + cf2dnrd = (0.125d0-0.005d0*ti)*(0.039d0*0.92d0*ionic**(-0.8D0)* + + ionicdnrd-(0.41d0*siondnrd*(1.d0+sion)-0.41d0*sion*siondnrd)/( + + 1.d0+sion)**2) + cf2 = (0.125d0-0.005d0*ti)*(0.039d0*ionic**0.92d0-0.41d0*sion/( + + 1.d0+sion)) + g01dnrd = cf1*g01dnrd - z01*cf2dnrd + g01 = cf1*g01 - cf2*z01 + g02dnrd = cf1*g02dnrd - z02*cf2dnrd + g02 = cf1*g02 - cf2*z02 + g03dnrd = cf1*g03dnrd - z03*cf2dnrd + g03 = cf1*g03 - cf2*z03 + g04dnrd = cf1*g04dnrd - z04*cf2dnrd + g04 = cf1*g04 - cf2*z04 + g05dnrd = cf1*g05dnrd - z05*cf2dnrd + g05 = cf1*g05 - cf2*z05 + g06dnrd = cf1*g06dnrd - z06*cf2dnrd + g06 = cf1*g06 - cf2*z06 + g07dnrd = cf1*g07dnrd - z07*cf2dnrd + g07 = cf1*g07 - cf2*z07 + g08dnrd = cf1*g08dnrd - z08*cf2dnrd + g08 = cf1*g08 - cf2*z08 + g10dnrd = cf1*g10dnrd - z10*cf2dnrd + g10 = cf1*g10 - cf2*z10 + g11dnrd = cf1*g11dnrd - z11*cf2dnrd + g11 = cf1*g11 - cf2*z11 + END IF +C + g09dnrd = g06dnrd + g08dnrd - g11dnrd + g09 = g06 + g08 - g11 + g12dnrd = g01dnrd + g08dnrd - g11dnrd + g12 = g01 + g08 - g11 +C +C *** Return point ; End of subroutine +C + RETURN + END + +C Differentiation of mkbi in forward (tangent) mode: +C variations of useful results: bi +C with respect to varying inputs: sion ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_DNRD(q, ionic, ionicdnrd, sion, siondnrd, zip, bi + + , bidnrd) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionicdnrd, siondnrd, bidnrd + REAL*8 :: b, c, xx + REAL*8 :: cdnrd, xxdnrd + REAL*8 :: arg1 + REAL*8 :: arg1dnrd + REAL*8 :: pwx1 + REAL*8 :: pwx1dnrd + REAL*8 :: pwr1 + REAL*8 :: pwr1dnrd + INTRINSIC EXP + INTRINSIC LOG10 + REAL*8 :: tiny + tiny = 1.d-20 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + arg1dnrd = -(.023d0*((ionicdnrd*ionic+ionic*ionicdnrd)*ionic+ionic + + **2*ionicdnrd)) + arg1 = -(.023d0*ionic*ionic*ionic) + cdnrd = .055d0*q*arg1dnrd*EXP(arg1) + c = 1. + .055d0*q*EXP(arg1) + xxdnrd = -((0.5107d0*siondnrd*(1.d0+c*sion)-0.5107d0*sion*(cdnrd* + + sion+c*siondnrd))/(1.d0+c*sion)**2) + xx = -(0.5107d0*sion/(1.d0+c*sion)) + pwx1dnrd = .1d0*ionicdnrd + pwx1 = 1.d0 + .1d0*ionic + IF (pwx1 > 0.d0 .OR. (pwx1 < 0.d0 .AND. + & abs(q-INT(q)) < tiny)) THEN + pwr1dnrd = q*pwx1**(q-1)*pwx1dnrd + ELSE IF (abs(pwx1) < tiny .AND. abs(q-1.D0) < tiny) THEN + pwr1dnrd = pwx1dnrd + ELSE + pwr1dnrd = 0.0 + END IF + pwr1 = pwx1**q + bidnrd = b*pwr1dnrd + bi = 1.d0 + b*pwr1 - b + bidnrd = zip*bidnrd/(bi*LOG(10.D0)) + zip*xxdnrd + bi = zip*LOG10(bi) + zip*xx + RETURN + END + +C + +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of calcb4e in reverse (adjoint) mode: +C gradient of useful results: aerliq gas +C with respect to varying inputs: wp aerliq gas +C RW status of diff variables: wp:out aerliq:in-out gas:in-out +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCB4E +C *** CASE B4 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +C 2. LIQUID AEROSOL PHASE ONLY POSSIBLE +C +C FOR CALCULATIONS, A BISECTION IS PERFORMED WITH RESPECT TO H+. +C THE OBJECTIVE FUNCTION IS THE DIFFERENCE BETWEEN THE ESTIMATED H+ +C AND THAT CALCULATED FROM ELECTRONEUTRALITY. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCB4E_EB(wpeb, gaseb, aerliqeb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: molalreb(npair) + REAL*8 :: x, y, so4i, hso4i, bb, cc, dd + REAL*8 :: so4ieb, hso4ieb, bbeb, cceb, ddeb + REAL*8 :: gas(3), AERLIQ(NIONS+NGASAQ+2) + REAL*8 :: wpeb(ncomp), gaseb(3), aerliqeb(NIONS+NGASAQ+2) + INTEGER :: i + REAL*8 :: ak1 + REAL*8 :: ak1eb + REAL*8 :: bet + REAL*8 :: beteb + REAL*8 :: gam + REAL*8 :: gameb + INTEGER :: j + INTEGER :: branch + INTEGER :: ad_count + INTEGER :: i0 + REAL*8 :: x2eb + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp0eb + INTRINSIC MAX + REAL*8 :: x4 + REAL*8 :: x3 + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x3eb + REAL*8 :: temp1eb + REAL*8 :: x1eb + REAL*8 :: x4eb + INTRINSIC MIN + INTEGER :: ii1, npflag, ncase + INTRINSIC SQRT + REAL*8 :: temp2eb +C +C *** SOLVE EQUATIONS ************************************************** +C + frst = .true. + calain = .true. +C +C *** CALCULATE WATER CONTENT ****************************************** +C +C +C CALL CALCB1A ! GET DRY SALT CONTENT, AND USE FOR WATER. +C +C *** SETUP PARAMETERS ************************************************ +C +C Equivalent NH4HSO4 + x = 2.d0*w(2) - w(3) +C Equivalent (NH4)2SO4 + y = w(3) - w(2) +C +C *** CALCULATE COMPOSITION ******************************************* +C + IF (x <= y) THEN +C LC is the MIN(x,y) +C CLC = X ! NH4HSO4 >= (NH4)2S04 + clc = 2.d0*w(2) - w(3) + cnh4hs4 = zero +C CNH42S4 = Y-X + cnh42s4 = 2.d0*w(3) - 3.d0*w(2) + CALL PUSHCONTROL1B(0) + ELSE +C CLC = Y ! NH4HSO4 < (NH4)2S04 + clc = w(3) - w(2) +C CNH4HS4 = X-Y + cnh4hs4 = 3.d0*w(2) - 2.d0*w(3) + cnh42s4 = zero + CALL PUSHCONTROL1B(1) + END IF +C + molalr(13) = clc + molalr(9) = cnh4hs4 + molalr(4) = cnh42s4 + water = molalr(13)/m0(13) + molalr(9)/m0(9) + molalr(4)/m0(4) +C +C NH4I + molal(3) = w(3) +C + i = 1 + ad_count = 0 +C NSWEEP = 50 + DO WHILE (i <= nsweep .AND. calain) + CALL PUSHREAL8(ak1) +C IF (I > 1) CALL CALCACT3 + ak1 = xk1*(gama(8)/gama(7))**2.*(water/gama(7)) + bet = w(2) + gam = molal(3) + CALL PUSHREAL8(bb) +C + bb = bet + ak1 - gam + cc = -(ak1*bet) + dd = bb*bb - 4.d0*cc + x4 = 0.5d0*(-bb+SQRT(dd)) + IF (x4 > w(2)) THEN + x1 = w(2) + CALL PUSHCONTROL1B(0) + ELSE + x1 = x4 + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(molal(5)) + molal(5) = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(molal(5)) + molal(5) = x1 + CALL PUSHCONTROL1B(1) + END IF + IF (w(2) - molal(5) > w(2)) THEN + x2 = w(2) + CALL PUSHCONTROL1B(0) + ELSE + x2 = w(2) - molal(5) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < tiny) THEN + CALL PUSHREAL8(molal(6)) + molal(6) = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(molal(6)) + molal(6) = x2 + CALL PUSHCONTROL1B(1) + END IF + IF (ak1*molal(6)/molal(5) > w(2)) THEN + x3 = w(2) + CALL PUSHCONTROL1B(0) + ELSE + x3 = ak1*molal(6)/molal(5) + CALL PUSHCONTROL1B(1) + END IF + IF (x3 < tiny) THEN + CALL PUSHREAL8(molal(1)) + molal(1) = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(molal(1)) + molal(1) = x3 + CALL PUSHCONTROL1B(1) + END IF +C WRITE(*,*) 'MOLAL(5, 6) ', MOLAL(5), MOLAL(6) +C +C CALL CALCMR ! Water content +C slc.1.2011 - calling CALCMR for case E rather than B +C +C CORRECT FOR HSO4 DISSOCIATION as from B4 + so4i = molal(5) - molal(1) +C SO4I = MAX(MOLAL(5)-MOLAL(1),ZERO) ! FROM HSO4 DISSOCIATION + hso4i = molal(6) + molal(1) + IF (so4i < hso4i) THEN +C [LC] = [SO4] + molalr(13) = so4i + IF (hso4i - so4i < zero) THEN + molalr(9) = zero + CALL PUSHCONTROL2B(1) + ELSE + molalr(9) = hso4i - so4i + CALL PUSHCONTROL2B(0) + END IF + ELSE +C [LC] = [HSO4] + molalr(13) = hso4i + IF (so4i - hso4i < zero) THEN + molalr(4) = zero + CALL PUSHCONTROL2B(3) + ELSE + molalr(4) = so4i - hso4i + CALL PUSHCONTROL2B(2) + END IF + END IF + CALL PUSHREAL8(water) +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + DO j=1,npair + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C +C IF (.NOT.CALAIN) GOTO 30 + i = i + 1 + CALL PUSHREAL8ARRAY(gama, npair) +C*** slc.11.2009 moved to beginning of loop + CALL CALCACT3() + ad_count = ad_count + 1 + ENDDO + IF (CALAIN .AND. (I > (NSWEEP+1))) THEN + CALL PUSHERR (0001, 'CALCB4E') ! WARNING ERROR: NO SOLUTION + ENDIF + CALL PUSHINTEGER4(ad_count) + DO ii1=1,nions + molaleb(ii1) = 0.D0 + ENDDO + DO i=nions,1,-1 + molaleb(i) = molaleb(i) + aerliqeb(i) + ENDDO + aerliqeb = 0.D0 + gaseb(3) = 0.D0 + ghno3eb = gaseb(2) + gaseb(2) = 0.D0 + gaseb(1) = 0.D0 + CALL CALCNA_EB() + DO ii1=1,npair + molalreb(ii1) = 0.D0 + ENDDO + CALL POPINTEGER4(ad_count) + DO i0=1,ad_count + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3_EB() + CALL POPCONTROL1B(branch) + IF (branch == 0) watereb = 0.D0 + DO j=npair,1,-1 + molalreb(j) = molalreb(j) + watereb/m0(j) + ENDDO + CALL POPREAL8(water) + CALL POPCONTROL2B(branch) + IF (branch < 2) THEN + IF (branch == 0) THEN + hso4ieb = molalreb(9) + so4ieb = -molalreb(9) + molalreb(9) = 0.D0 + ELSE + molalreb(9) = 0.D0 + hso4ieb = 0.D0 + so4ieb = 0.D0 + END IF + so4ieb = so4ieb + molalreb(13) + molalreb(13) = 0.D0 + ELSE + IF (branch == 2) THEN + so4ieb = molalreb(4) + hso4ieb = -molalreb(4) + molalreb(4) = 0.D0 + ELSE + molalreb(4) = 0.D0 + hso4ieb = 0.D0 + so4ieb = 0.D0 + END IF + hso4ieb = hso4ieb + molalreb(13) + molalreb(13) = 0.D0 + END IF + molaleb(6) = molaleb(6) + hso4ieb + molaleb(1) = molaleb(1) + hso4ieb + molaleb(5) = molaleb(5) + so4ieb + molaleb(1) = molaleb(1) - so4ieb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(molal(1)) + molaleb(1) = 0.D0 + x3eb = 0.D0 + ELSE + CALL POPREAL8(molal(1)) + x3eb = molaleb(1) + molaleb(1) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + web(2) = web(2) + x3eb + ak1 = xk1*(gama(8)/gama(7))**2.*(water/gama(7)) + ak1eb = 0.D0 + ELSE + temp2eb = x3eb/molal(5) + ak1eb = molal(6)*temp2eb + molaleb(6) = molaleb(6) + ak1*temp2eb + molaleb(5) = molaleb(5) - ak1*molal(6)*temp2eb/molal(5) + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(molal(6)) + molaleb(6) = 0.D0 + x2eb = 0.D0 + ELSE + CALL POPREAL8(molal(6)) + x2eb = molaleb(6) + molaleb(6) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + web(2) = web(2) + x2eb + ELSE + web(2) = web(2) + x2eb + molaleb(5) = molaleb(5) - x2eb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(molal(5)) + molaleb(5) = 0.D0 + x1eb = 0.D0 + ELSE + CALL POPREAL8(molal(5)) + x1eb = molaleb(5) + molaleb(5) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + web(2) = web(2) + x1eb + x4eb = 0.D0 + ELSE + x4eb = x1eb + END IF + bet = w(2) + gam = molal(3) + bb = bet + ak1 - gam + cc = -(ak1*bet) + dd = bb*bb - 4.d0*cc + IF (dd == 0.0) THEN + ddeb = 0.0 + ELSE + ddeb = 0.5d0*x4eb/(2.0*SQRT(dd)) + END IF + bbeb = 2*bb*ddeb - 0.5d0*x4eb + cceb = -(4.d0*ddeb) + ak1eb = ak1eb + bbeb - bet*cceb + beteb = bbeb - ak1*cceb + CALL POPREAL8(bb) + gameb = -bbeb + molaleb(3) = molaleb(3) + gameb + web(2) = web(2) + beteb + CALL POPREAL8(ak1) + temp0 = water/gama(7) + temp1 = gama(8)/gama(7) + temp1eb = 2.*temp1*temp0*xk1*ak1eb/gama(7) + temp0eb = temp1**2.*xk1*ak1eb/gama(7) + gamaeb(8) = gamaeb(8) + temp1eb + gamaeb(7) = gamaeb(7) - temp0*temp0eb - temp1*temp1eb + watereb = temp0eb + ENDDO + web(3) = web(3) + molaleb(3) + molalreb(13) = molalreb(13) + watereb/m0(13) + molalreb(9) = molalreb(9) + watereb/m0(9) + molalreb(4) = molalreb(4) + watereb/m0(4) + cnh42s4eb = molalreb(4) + molalreb(4) = 0.D0 + cnh4hs4eb = molalreb(9) + molalreb(9) = 0.D0 + clceb = molalreb(13) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + web(3) = web(3) + 2*cnh42s4eb + web(2) = web(2) + 2*clceb - 3*cnh42s4eb + web(3) = web(3) - clceb + ELSE + web(2) = web(2) + 3*cnh4hs4eb + web(3) = web(3) + clceb - 2*cnh4hs4eb + web(2) = web(2) - clceb + END IF + wpeb = web + !WRITE(*,*) 'E4, wpeb: ',wpeb + + END + +C Differentiation of calcna in reverse (adjoint) mode: +C gradient of useful results: molal ghno3 +C with respect to varying inputs: w molal gama water +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNA +C *** CALCULATES NITRATES SPECIATION +C +C NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT +C DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC +C ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> (H+) + (NO3-) +C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNA_EB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: alfa, delt, kapa, diak + REAL*8 :: alfaeb, delteb, kapaeb, diakeb + REAL*8 :: x + REAL*8 :: xeb + INTEGER :: branch + REAL*8 :: temp0 + REAL*8 :: temp0eb + INTRINSIC MAX + REAL*8 :: temp1eb + REAL*8 :: temp1eb1 + REAL*8 :: temp1eb0 + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** CALCULATE HNO3 DISSOLUTION **************************************** +C + x = w(4) + delt = 0.0d0 + IF (water > tiny) THEN + kapa = molal(1) + alfa = xk4*r*temp*(water/gama(10))**2.0 + diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x) + delt = 0.5*(-(kapa+alfa)+diak) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + IF (x - delt < 0.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + delteb = molaleb(7) + molaleb(1) + molaleb(7) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + xeb = 0.D0 + ELSE + xeb = ghno3eb + delteb = delteb - ghno3eb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + DO ii1=1,npair + gamaeb(ii1) = 0.D0 + ENDDO + watereb = 0.D0 + ELSE + temp1eb = 0.5*delteb + diakeb = temp1eb + IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN + temp1eb1 = 0.0 + ELSE + temp1eb1 = diakeb/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x))) + END IF + temp1eb0 = 2.0*(kapa+alfa)*temp1eb1 + alfaeb = temp1eb0 + 4.0*x*temp1eb1 - temp1eb + kapaeb = temp1eb0 - temp1eb + xeb = xeb + 4.0*alfa*temp1eb1 + DO ii1=1,npair + gamaeb(ii1) = 0.D0 + ENDDO + temp0 = water/gama(10) + temp0eb = 2.0*temp0*xk4*r*temp*alfaeb/gama(10) + watereb = temp0eb + gamaeb(10) = gamaeb(10) - temp0*temp0eb + molaleb(1) = molaleb(1) + kapaeb + END IF + DO ii1=1,ncomp + web(ii1) = 0.D0 + ENDDO + web(4) = web(4) + xeb + END + +C Differentiation of calcact3 in reverse (adjoint) mode: +C gradient of useful results: molal gama water +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3_EB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0eb(6, 4), sioneb, heb, cheb, f1eb(3), f2eb(4) + REAL*8 :: mpl, xij, yji + REAL*8 :: mpleb, xijeb, yjieb, ioniceb + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01eb + REAL*8 :: g02 + REAL*8 :: g02eb + REAL*8 :: g03 + REAL*8 :: g03eb + REAL*8 :: g04 + REAL*8 :: g04eb + REAL*8 :: g05 + REAL*8 :: g05eb + REAL*8 :: g06 + REAL*8 :: g06eb + REAL*8 :: g07 + REAL*8 :: g07eb + REAL*8 :: g08 + REAL*8 :: g08eb + REAL*8 :: g09 + REAL*8 :: g09eb + REAL*8 :: g10 + REAL*8 :: g10eb + REAL*8 :: g11 + REAL*8 :: g11eb + REAL*8 :: g12 + REAL*8 :: g12eb + INTEGER :: j + REAL*8 :: errou + REAL*8 :: errin +C +C +C G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H +C +C *** SAVE ACTIVITIES IN OLD ARRAY ************************************* +C + INTEGER :: branch + REAL*8 :: x2eb + REAL*8 :: temp0eb + INTRINSIC MAX + REAL*8 :: temp0eb13 + REAL*8 :: temp0eb12 + REAL*8 :: temp0eb11 + REAL*8 :: temp0eb10 + INTRINSIC ABS + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: temp0eb9 + REAL*8 :: temp0eb8 + REAL*8 :: temp0eb7 + REAL*8 :: temp0eb6 + REAL*8 :: temp0eb5 + REAL*8 :: temp0eb4 + REAL*8 :: temp0eb3 + REAL*8 :: temp0eb2 + REAL*8 :: temp0eb1 + REAL*8 :: temp0eb0 + REAL*8 :: x1eb + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: y1 +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + DO i=1,7 + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08, + + g09, g10, g11, g12) +C + g0(1, 1) = g11 + g0(1, 2) = g07 + g0(1, 3) = g08 + g0(1, 4) = g10 + g0(2, 1) = g01 + g0(2, 2) = g02 + g0(2, 3) = g12 + g0(2, 4) = g03 + g0(3, 1) = g06 + g0(3, 2) = g04 + g0(3, 3) = g09 + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + sion = SQRT(ionic) + h = agama*sion/(1.d0+sion) +C +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + yji = ch*molal(j+3)/water + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gama(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gama(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gama(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gama(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gama(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gama(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gama(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gama(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gama(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gama(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gama(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gama(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gama(13)) +C LC ; SCAPE + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + ELSE + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + gamaeb(i) = 10.d0**gama(i)*LOG(10.d0)*gamaeb(i) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + gamaeb(i) = 0.D0 + x2eb = 0.D0 + ELSE + x2eb = gamaeb(i) + gamaeb(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) gamaeb(i) = gamaeb(i) + x2eb + ENDDO + CALL POPREAL8(gama(13)) + gamaeb(4) = gamaeb(4) + 0.2d0*3.d0*gamaeb(13) + gamaeb(9) = gamaeb(9) + 0.2d0*2.d0*gamaeb(13) + gamaeb(13) = 0.D0 + DO ii1=1,3 + f1eb(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2eb(ii1) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp0eb2 = zz(12)*gamaeb(12)/(z(2)+z(6)) + f1eb(2) = f1eb(2) + temp0eb2/z(2) + f2eb(3) = f2eb(3) + temp0eb2/z(6) + heb = -(zz(12)*gamaeb(12)) + gamaeb(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp0eb3 = zz(11)*gamaeb(11)/(z(1)+z(4)) + f2eb(1) = f2eb(1) + temp0eb3/z(4) + heb = heb - zz(11)*gamaeb(11) + gamaeb(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp0eb4 = zz(10)*gamaeb(10)/(z(1)+z(7)) + f1eb(1) = f1eb(1) + temp0eb4/z(1) + temp0eb3/z(1) + f2eb(4) = f2eb(4) + temp0eb4/z(7) + heb = heb - zz(10)*gamaeb(10) + gamaeb(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp0eb5 = zz(9)*gamaeb(9)/(z(3)+z(6)) + f1eb(3) = f1eb(3) + temp0eb5/z(3) + heb = heb - zz(9)*gamaeb(9) + gamaeb(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp0eb6 = zz(8)*gamaeb(8)/(z(1)+z(6)) + f2eb(3) = f2eb(3) + temp0eb6/z(6) + temp0eb5/z(6) + heb = heb - zz(8)*gamaeb(8) + gamaeb(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp0eb7 = zz(7)*gamaeb(7)/(z(1)+z(5)) + f1eb(1) = f1eb(1) + temp0eb7/z(1) + temp0eb6/z(1) + f2eb(2) = f2eb(2) + temp0eb7/z(5) + heb = heb - zz(7)*gamaeb(7) + gamaeb(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp0eb8 = zz(6)*gamaeb(6)/(z(3)+z(4)) + f2eb(1) = f2eb(1) + temp0eb8/z(4) + heb = heb - zz(6)*gamaeb(6) + gamaeb(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp0eb9 = zz(5)*gamaeb(5)/(z(3)+z(7)) + f2eb(4) = f2eb(4) + temp0eb9/z(7) + heb = heb - zz(5)*gamaeb(5) + gamaeb(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp0eb10 = zz(4)*gamaeb(4)/(z(3)+z(5)) + f1eb(3) = f1eb(3) + temp0eb9/z(3) + temp0eb10/z(3) + temp0eb8/z(3) + f2eb(2) = f2eb(2) + temp0eb10/z(5) + heb = heb - zz(4)*gamaeb(4) + gamaeb(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp0eb11 = zz(3)*gamaeb(3)/(z(2)+z(7)) + f2eb(4) = f2eb(4) + temp0eb11/z(7) + heb = heb - zz(3)*gamaeb(3) + gamaeb(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp0eb12 = zz(2)*gamaeb(2)/(z(2)+z(5)) + f2eb(2) = f2eb(2) + temp0eb12/z(5) + heb = heb - zz(2)*gamaeb(2) + gamaeb(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp0eb13 = zz(1)*gamaeb(1)/(z(2)+z(4)) + f1eb(2) = f1eb(2) + temp0eb12/z(2) + temp0eb13/z(2) + temp0eb11/z( + + 2) + f2eb(1) = f2eb(1) + temp0eb13/z(4) + heb = heb - zz(1)*gamaeb(1) + gamaeb(1) = 0.D0 + ioniceb = 0.D0 + DO ii1=1,4 + DO ii2=1,6 + g0eb(ii2, ii1) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mpleb = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijeb = (g0(i, j)+zpl*zmi*h)*f2eb(j) + yji = ch*molal(j+3)/water + g0eb(i, j) = g0eb(i, j) + yji*f1eb(i) + xij*f2eb(j) + heb = heb + yji*zpl*zmi*f1eb(i) + xij*zpl*zmi*f2eb(j) + yjieb = (g0(i, j)+zpl*zmi*h)*f1eb(i) + temp0eb1 = molal(j+3)*yjieb/water + molaleb(j+3) = molaleb(j+3) + ch*yjieb/water + cheb = mpl*xijeb + temp0eb1 + watereb = watereb - ch*temp0eb1/water + mpleb = mpleb + ch*xijeb + ioniceb = ioniceb - (zpl+zmi)**2*0.25d0*cheb/ionic**2 + ENDDO + CALL POPREAL8(mpl) + molaleb(i) = molaleb(i) + mpleb/water + watereb = watereb - molal(i)*mpleb/water**2 + CALL POPREAL8(zpl) + ENDDO + temp0eb0 = agama*heb/(sion+1.d0) + sioneb = (1.D0-sion/(sion+1.d0))*temp0eb0 + IF (.NOT.ionic == 0.0) ioniceb = ioniceb + sioneb/(2.0*SQRT( + + ionic)) + g05eb = g0eb(3, 4) + g0eb(3, 4) = 0.D0 + g09eb = g0eb(3, 3) + g0eb(3, 3) = 0.D0 + g04eb = g0eb(3, 2) + g0eb(3, 2) = 0.D0 + g06eb = g0eb(3, 1) + g0eb(3, 1) = 0.D0 + g03eb = g0eb(2, 4) + g0eb(2, 4) = 0.D0 + g12eb = g0eb(2, 3) + g0eb(2, 3) = 0.D0 + g02eb = g0eb(2, 2) + g0eb(2, 2) = 0.D0 + g01eb = g0eb(2, 1) + g0eb(2, 1) = 0.D0 + g10eb = g0eb(1, 4) + g0eb(1, 4) = 0.D0 + g08eb = g0eb(1, 3) + g0eb(1, 3) = 0.D0 + g07eb = g0eb(1, 2) + g0eb(1, 2) = 0.D0 + g11eb = g0eb(1, 1) + CALL KMFUL3_EB(ionic, ioniceb, temp, g01, g01eb, g02, g02eb, g03, + + g03eb, g04, g04eb, g05, g05eb, g06, g06eb, g07, + + g07eb, g08, g08eb, g09, g09eb, g10, g10eb, g11, + + g11eb, g12, g12eb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionic) + x1eb = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1eb = ioniceb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ioniceb = 0.D0 + ELSE + temp0eb = 0.5d0*x1eb/water + ioniceb = temp0eb + watereb = watereb - ionic*temp0eb/water + END IF + DO i=7,1,-1 + molaleb(i) = molaleb(i) + z(i)**2*ioniceb + ENDDO + END + +C Differentiation of kmful3 in reverse (adjoint) mode: +C gradient of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 ionic +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_EB(ionic, ioniceb, temp, g01, g01eb, g02, g02eb + + , g03, g03eb, g04, g04eb, g05, g05eb, g06, + + g06eb, g07, g07eb, g08, g08eb, g09, g09eb, + + g10, g10eb, g11, g11eb, g12, g12eb) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ioniceb, sioneb, cf2eb + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01eb, g02eb, g03eb, g04eb, g05eb, g06eb, g07eb, + + g08eb, g09eb, g10eb, g11eb, g12eb + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTEGER :: branch + REAL*8 :: temp0eb + INTRINSIC ABS + REAL*8 :: temp0eb0 + REAL*8 :: abs1 + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01eb = g01eb + g12eb + g08eb = g08eb + g09eb + g12eb + g11eb = g11eb - g09eb - g12eb + g06eb = g06eb + g09eb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2eb = -(z10*g10eb) - z07*g07eb - z05*g05eb - z03*g03eb - z01* + + g01eb - z02*g02eb - z04*g04eb - z06*g06eb - z08*g08eb - z11* + + g11eb + g11eb = cf1*g11eb + g10eb = cf1*g10eb + g08eb = cf1*g08eb + g07eb = cf1*g07eb + g06eb = cf1*g06eb + g05eb = cf1*g05eb + g04eb = cf1*g04eb + g03eb = cf1*g03eb + g02eb = cf1*g02eb + g01eb = cf1*g01eb + temp0eb = (0.125d0-ti*0.005d0)*cf2eb + temp0eb0 = -(0.41d0*temp0eb/(sion+1.d0)) + ioniceb = ioniceb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0eb + sioneb = (1.D0-sion/(sion+1.d0))*temp0eb0 + ELSE + sioneb = 0.D0 + END IF + CALL MKBI_EB(q11, ionic, ioniceb, sion, sioneb, z11, g11, g11eb) + CALL MKBI_EB(q10, ionic, ioniceb, sion, sioneb, z10, g10, g10eb) + CALL MKBI_EB(q8, ionic, ioniceb, sion, sioneb, z08, g08, g08eb) + CALL MKBI_EB(q7, ionic, ioniceb, sion, sioneb, z07, g07, g07eb) + CALL MKBI_EB(q6, ionic, ioniceb, sion, sioneb, z06, g06, g06eb) + CALL MKBI_EB(q5, ionic, ioniceb, sion, sioneb, z05, g05, g05eb) + CALL MKBI_EB(q4, ionic, ioniceb, sion, sioneb, z04, g04, g04eb) + CALL MKBI_EB(q3, ionic, ioniceb, sion, sioneb, z03, g03, g03eb) + CALL MKBI_EB(q2, ionic, ioniceb, sion, sioneb, z02, g02, g02eb) + CALL MKBI_EB(q1, ionic, ioniceb, sion, sioneb, z01, g01, g01eb) + IF (.NOT.ionic == 0.0) ioniceb = ioniceb + sioneb/(2.0*SQRT( + + ionic)) + END + +C Differentiation of mkbi in reverse (adjoint) mode: +C gradient of useful results: sion bi ionic +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_EB(q, ionic, ioniceb, sion, sioneb, zip, bi, bieb) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ioniceb, sioneb, bieb + REAL*8 :: b, c, xx + REAL*8 :: ceb, xxeb + INTRINSIC EXP + REAL*8 :: tempeb0 + REAL*8 :: tempeb + INTRINSIC LOG10 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic)) + bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b +C + xxeb = zip*bieb + bieb = zip*bieb/(bi*LOG(10.0)) + tempeb = -(0.5107d0*xxeb/(c*sion+1.d0)) + tempeb0 = -(sion*tempeb/(c*sion+1.d0)) + sioneb = sioneb + c*tempeb0 + tempeb + ceb = sion*tempeb0 + IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q + + ))) THEN + ioniceb = ioniceb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3* + + ionic**2*ceb + ELSE + ioniceb = ioniceb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bieb - + + .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*ceb + END IF + END + + +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of calcc2f in reverse (adjoint) mode: +C gradient of useful results: aerliq gas +C with respect to varying inputs: wp aerliq gas +C RW status of diff variables: wp:out aerliq:in-out gas:in-out +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCC2 +C *** CASE C2 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +C 2. THERE IS ONLY A LIQUID PHASE +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCC2F_FB(wpfb, gasfb, aerliqfb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: molalrfb(npair) + REAL*8 :: lamda, kapa, psi, parm + REAL*8 :: lamdafb, kapafb, psifb, parmfb + REAL*8 :: bb, cc + REAL*8 :: bbfb, ccfb + REAL*8 :: gas(3), AERLIQ(NIONS+NGASAQ+2) + REAL*8 :: wpfb(ncomp), gasfb(3), aerliqfb(NIONS+NGASAQ+2) + INTEGER :: i + INTEGER :: j + INTEGER :: branch + INTEGER :: ad_count + INTEGER :: i0 + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp1fb + INTRINSIC MAX + REAL*8 :: temp2fb + REAL*8 :: temp0fb + INTEGER :: ii1, npflag, ncase + INTRINSIC SQRT + + !WRITE(*,*) 'F5, gasfb: ',gasfb + !WRITE(*,*) 'F5, aerliqfb: ',aerliqfb +C +C Outer loop activity calculation flag + frst = .true. + calain = .true. +C +C *** SOLVE EQUATIONS ************************************************** +C +C NH4HSO4 INITIALLY IN SOLUTION + lamda = w(3) +C H2SO4 IN SOLUTION + psi = w(2) - w(3) + i = 1 + ad_count = 0 +C NSWEEP = 50 + DO WHILE (i <= nsweep .AND. calain) +C IF (I > 1) CALL CALCACT3 + parm = water*xk1/gama(7)*(gama(8)/gama(7))**2. + bb = psi + parm + cc = -(parm*(lamda+psi)) + kapa = 0.5*(-bb+SQRT(bb*bb-4.0*cc)) + CALL PUSHREAL8(molal(1)) +C +C *** SPECIATION & WATER CONTENT *************************************** +C +C HI + molal(1) = psi + kapa + CALL PUSHREAL8(molal(3)) +C NH4I + molal(3) = lamda + CALL PUSHREAL8(molal(5)) +C SO4I + molal(5) = kapa + IF (lamda + psi - kapa < tiny) THEN + CALL PUSHREAL8(molal(6)) + molal(6) = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(molal(6)) + molal(6) = lamda + psi - kapa + CALL PUSHCONTROL1B(1) + END IF +C +C CALL CALCMR ! Water content +C +C slc.1.2011 - calling CALCMR for case F rather than C +C +C NH4HSO4 ! slc.1.2011 - different than ISORROPIA 1.7 + molalr(4) = molal(3) + IF (molal(5) + molal(6) - molal(3) < zero) THEN + molalr(7) = zero + CALL PUSHCONTROL1B(0) + ELSE + molalr(7) = molal(5) + molal(6) - molal(3) + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8(water) + water = zero + DO j=1,npair + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF +C WRITE(*,*) 'Iteration: i', I +C WRITE(*,*) 'MOLAL ',MOLAL(1), MOLAL(3), MoLAL(5), MOLAL(6) +C WRITE(*,*) 'MOLALR ', (MOLALR(7)), (MOLALR(4)) +C WRITE(*,*) 'M0 ',(M0(7)), (M0(4)) +C WRITE(*,*) 'GAMA ', (GAMA) +C WRITE(*,*) 'water', water +C PAUSE +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C +C IF (.NOT.CALAIN) GOTO 30 + i = i + 1 + CALL PUSHREAL8ARRAY(gama, npair) +C*** slc.11.2009 moved to beginning of loop + CALL CALCACT3() + ad_count = ad_count + 1 + ENDDO + IF (CALAIN .AND. (I > (NSWEEP+1))) THEN + CALL PUSHERR (0001, 'CALCC2F') ! WARNING ERROR: NO SOLUTION + ENDIF + CALL PUSHINTEGER4(ad_count) + DO ii1=1,nions + molalfb(ii1) = 0.D0 + ENDDO + DO i=nions,1,-1 + molalfb(i) = molalfb(i) + aerliqfb(i) + ENDDO + aerliqfb = 0.D0 + gasfb(3) = 0.D0 + ghno3fb = gasfb(2) + gasfb(2) = 0.D0 + gasfb(1) = 0.D0 + CALL CALCNA_FB() + DO ii1=1,npair + molalrfb(ii1) = 0.D0 + ENDDO + psifb = 0.D0 + lamdafb = 0.D0 + CALL POPINTEGER4(ad_count) + DO i0=1,ad_count + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3_FB() + CALL POPCONTROL1B(branch) + IF (branch == 0) waterfb = 0.D0 + DO j=npair,1,-1 + molalrfb(j) = molalrfb(j) + waterfb/m0(j) + ENDDO + CALL POPREAL8(water) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + molalrfb(7) = 0.D0 + ELSE + molalfb(5) = molalfb(5) + molalrfb(7) + molalfb(6) = molalfb(6) + molalrfb(7) + molalfb(3) = molalfb(3) - molalrfb(7) + molalrfb(7) = 0.D0 + END IF + molalfb(3) = molalfb(3) + molalrfb(4) + molalrfb(4) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(molal(6)) + molalfb(6) = 0.D0 + kapafb = 0.D0 + ELSE + CALL POPREAL8(molal(6)) + lamdafb = lamdafb + molalfb(6) + psifb = psifb + molalfb(6) + kapafb = -molalfb(6) + molalfb(6) = 0.D0 + END IF + CALL POPREAL8(molal(5)) + kapafb = kapafb + molalfb(5) + molalfb(5) = 0.D0 + CALL POPREAL8(molal(3)) + lamdafb = lamdafb + molalfb(3) + molalfb(3) = 0.D0 + CALL POPREAL8(molal(1)) + kapafb = kapafb + molalfb(1) + parm = water*xk1/gama(7)*(gama(8)/gama(7))**2. + bb = psi + parm + cc = -(parm*(lamda+psi)) + IF (bb**2 - 4.0*cc == 0.0) THEN + temp2fb = 0.0 + ELSE + temp2fb = 0.5*kapafb/(2.0*SQRT(bb**2-4.0*cc)) + END IF + bbfb = 2*bb*temp2fb - 0.5*kapafb + ccfb = -(4.0*temp2fb) + psifb = psifb + bbfb - parm*ccfb + molalfb(1) + molalfb(1) = 0.D0 + parmfb = bbfb - (lamda+psi)*ccfb + lamdafb = lamdafb - parm*ccfb + temp0 = water/gama(7) + temp1 = gama(8)/gama(7) + temp1fb = 2.*temp1*temp0*xk1*parmfb/gama(7) + temp0fb = temp1**2.*xk1*parmfb/gama(7) + gamafb(8) = gamafb(8) + temp1fb + gamafb(7) = gamafb(7) - temp0*temp0fb - temp1*temp1fb + waterfb = temp0fb + ENDDO + wfb(2) = wfb(2) + psifb + wfb(3) = wfb(3) + lamdafb - psifb +C + wpfb = wfb + !WRITE(*,*) 'F5, wpfb: ',wpfb +C + END + +C Differentiation of calcna in reverse (adjoint) mode: +C gradient of useful results: molal ghno3 +C with respect to varying inputs: w molal gama water +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNA +C *** CALCULATES NITRATES SPECIATION +C +C NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT +C DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC +C ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> (H+) + (NO3-) +C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNA_FB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: alfa, delt, kapa, diak + REAL*8 :: alfafb, deltfb, kapafb, diakfb + REAL*8 :: x + REAL*8 :: xfb + INTEGER :: branch + REAL*8 :: temp0 + REAL*8 :: temp1fb1 + REAL*8 :: temp1fb0 + REAL*8 :: temp1fb + INTRINSIC MAX + REAL*8 :: temp0fb + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** CALCULATE HNO3 DISSOLUTION **************************************** +C + x = w(4) + delt = 0.0d0 + IF (water > tiny) THEN + kapa = molal(1) + alfa = xk4*r*temp*(water/gama(10))**2.0 + diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x) + delt = 0.5*(-(kapa+alfa)+diak) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + IF (x - delt < 0.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + deltfb = molalfb(7) + molalfb(1) + molalfb(7) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + xfb = 0.D0 + ELSE + xfb = ghno3fb + deltfb = deltfb - ghno3fb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + DO ii1=1,npair + gamafb(ii1) = 0.D0 + ENDDO + waterfb = 0.D0 + ELSE + temp1fb = 0.5*deltfb + diakfb = temp1fb + IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN + temp1fb1 = 0.0 + ELSE + temp1fb1 = diakfb/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x))) + END IF + temp1fb0 = 2.0*(kapa+alfa)*temp1fb1 + alfafb = temp1fb0 + 4.0*x*temp1fb1 - temp1fb + kapafb = temp1fb0 - temp1fb + xfb = xfb + 4.0*alfa*temp1fb1 + DO ii1=1,npair + gamafb(ii1) = 0.D0 + ENDDO + temp0 = water/gama(10) + temp0fb = 2.0*temp0*xk4*r*temp*alfafb/gama(10) + waterfb = temp0fb + gamafb(10) = gamafb(10) - temp0*temp0fb + molalfb(1) = molalfb(1) + kapafb + END IF + DO ii1=1,ncomp + wfb(ii1) = 0.D0 + ENDDO + wfb(4) = wfb(4) + xfb + END + +C Differentiation of calcact3 in reverse (adjoint) mode: +C gradient of useful results: molal gama water +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3_FB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0fb(6, 4), sionfb, hfb, chfb, f1fb(3), f2fb(4) + REAL*8 :: mpl, xij, yji + REAL*8 :: mplfb, xijfb, yjifb, ionicfb + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01fb + REAL*8 :: g02 + REAL*8 :: g02fb + REAL*8 :: g03 + REAL*8 :: g03fb + REAL*8 :: g04 + REAL*8 :: g04fb + REAL*8 :: g05 + REAL*8 :: g05fb + REAL*8 :: g06 + REAL*8 :: g06fb + REAL*8 :: g07 + REAL*8 :: g07fb + REAL*8 :: g08 + REAL*8 :: g08fb + REAL*8 :: g09 + REAL*8 :: g09fb + REAL*8 :: g10 + REAL*8 :: g10fb + REAL*8 :: g11 + REAL*8 :: g11fb + REAL*8 :: g12 + REAL*8 :: g12fb + INTEGER :: j + REAL*8 :: errou + REAL*8 :: errin +C + INTEGER :: branch + INTRINSIC MAX + INTRINSIC ABS + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x1fb + REAL*8 :: temp0fb13 + REAL*8 :: temp0fb12 + REAL*8 :: temp0fb11 + REAL*8 :: temp0fb10 + REAL*8 :: x2fb + REAL*8 :: temp0fb + INTRINSIC MIN + REAL*8 :: temp0fb9 + REAL*8 :: temp0fb8 + REAL*8 :: temp0fb7 + REAL*8 :: temp0fb6 + INTEGER :: ii2 + INTEGER :: ii1 + REAL*8 :: temp0fb5 + INTRINSIC SQRT + REAL*8 :: temp0fb4 + REAL*8 :: temp0fb3 + REAL*8 :: temp0fb2 + REAL*8 :: temp0fb1 + REAL*8 :: temp0fb0 + REAL*8 :: y1 +C +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + DO i=1,7 + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08, + + g09, g10, g11, g12) +C + g0(1, 1) = g11 + g0(1, 2) = g07 + g0(1, 3) = g08 + g0(1, 4) = g10 + g0(2, 1) = g01 + g0(2, 2) = g02 + g0(2, 3) = g12 + g0(2, 4) = g03 + g0(3, 1) = g06 + g0(3, 2) = g04 + g0(3, 3) = g09 + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + sion = SQRT(ionic) + h = agama*sion/(1.d0+sion) +C +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + yji = ch*molal(j+3)/water + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gama(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gama(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gama(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gama(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gama(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gama(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gama(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gama(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gama(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gama(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gama(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gama(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gama(13)) +C LC ; SCAPE + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + ELSE + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + gamafb(i) = 10.d0**gama(i)*LOG(10.d0)*gamafb(i) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + gamafb(i) = 0.D0 + x2fb = 0.D0 + ELSE + x2fb = gamafb(i) + gamafb(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) gamafb(i) = gamafb(i) + x2fb + ENDDO + CALL POPREAL8(gama(13)) + gamafb(4) = gamafb(4) + 0.2d0*3.d0*gamafb(13) + gamafb(9) = gamafb(9) + 0.2d0*2.d0*gamafb(13) + gamafb(13) = 0.D0 + DO ii1=1,3 + f1fb(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2fb(ii1) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp0fb2 = zz(12)*gamafb(12)/(z(2)+z(6)) + f1fb(2) = f1fb(2) + temp0fb2/z(2) + f2fb(3) = f2fb(3) + temp0fb2/z(6) + hfb = -(zz(12)*gamafb(12)) + gamafb(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp0fb3 = zz(11)*gamafb(11)/(z(1)+z(4)) + f2fb(1) = f2fb(1) + temp0fb3/z(4) + hfb = hfb - zz(11)*gamafb(11) + gamafb(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp0fb4 = zz(10)*gamafb(10)/(z(1)+z(7)) + f1fb(1) = f1fb(1) + temp0fb4/z(1) + temp0fb3/z(1) + f2fb(4) = f2fb(4) + temp0fb4/z(7) + hfb = hfb - zz(10)*gamafb(10) + gamafb(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp0fb5 = zz(9)*gamafb(9)/(z(3)+z(6)) + f1fb(3) = f1fb(3) + temp0fb5/z(3) + hfb = hfb - zz(9)*gamafb(9) + gamafb(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp0fb6 = zz(8)*gamafb(8)/(z(1)+z(6)) + f2fb(3) = f2fb(3) + temp0fb6/z(6) + temp0fb5/z(6) + hfb = hfb - zz(8)*gamafb(8) + gamafb(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp0fb7 = zz(7)*gamafb(7)/(z(1)+z(5)) + f1fb(1) = f1fb(1) + temp0fb7/z(1) + temp0fb6/z(1) + f2fb(2) = f2fb(2) + temp0fb7/z(5) + hfb = hfb - zz(7)*gamafb(7) + gamafb(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp0fb8 = zz(6)*gamafb(6)/(z(3)+z(4)) + f2fb(1) = f2fb(1) + temp0fb8/z(4) + hfb = hfb - zz(6)*gamafb(6) + gamafb(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp0fb9 = zz(5)*gamafb(5)/(z(3)+z(7)) + f2fb(4) = f2fb(4) + temp0fb9/z(7) + hfb = hfb - zz(5)*gamafb(5) + gamafb(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp0fb10 = zz(4)*gamafb(4)/(z(3)+z(5)) + f1fb(3) = f1fb(3) + temp0fb9/z(3) + temp0fb10/z(3) + temp0fb8/z(3) + f2fb(2) = f2fb(2) + temp0fb10/z(5) + hfb = hfb - zz(4)*gamafb(4) + gamafb(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp0fb11 = zz(3)*gamafb(3)/(z(2)+z(7)) + f2fb(4) = f2fb(4) + temp0fb11/z(7) + hfb = hfb - zz(3)*gamafb(3) + gamafb(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp0fb12 = zz(2)*gamafb(2)/(z(2)+z(5)) + f2fb(2) = f2fb(2) + temp0fb12/z(5) + hfb = hfb - zz(2)*gamafb(2) + gamafb(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp0fb13 = zz(1)*gamafb(1)/(z(2)+z(4)) + f1fb(2) = f1fb(2) + temp0fb12/z(2) + temp0fb13/z(2) + temp0fb11/z( + + 2) + f2fb(1) = f2fb(1) + temp0fb13/z(4) + hfb = hfb - zz(1)*gamafb(1) + gamafb(1) = 0.D0 + ionicfb = 0.D0 + DO ii1=1,4 + DO ii2=1,6 + g0fb(ii2, ii1) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mplfb = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijfb = (g0(i, j)+zpl*zmi*h)*f2fb(j) + yji = ch*molal(j+3)/water + g0fb(i, j) = g0fb(i, j) + yji*f1fb(i) + xij*f2fb(j) + hfb = hfb + yji*zpl*zmi*f1fb(i) + xij*zpl*zmi*f2fb(j) + yjifb = (g0(i, j)+zpl*zmi*h)*f1fb(i) + temp0fb1 = molal(j+3)*yjifb/water + molalfb(j+3) = molalfb(j+3) + ch*yjifb/water + chfb = mpl*xijfb + temp0fb1 + waterfb = waterfb - ch*temp0fb1/water + mplfb = mplfb + ch*xijfb + ionicfb = ionicfb - (zpl+zmi)**2*0.25d0*chfb/ionic**2 + ENDDO + CALL POPREAL8(mpl) + molalfb(i) = molalfb(i) + mplfb/water + waterfb = waterfb - molal(i)*mplfb/water**2 + CALL POPREAL8(zpl) + ENDDO + temp0fb0 = agama*hfb/(sion+1.d0) + sionfb = (1.D0-sion/(sion+1.d0))*temp0fb0 + IF (.NOT.ionic == 0.0) ionicfb = ionicfb + sionfb/(2.0*SQRT( + + ionic)) + g05fb = g0fb(3, 4) + g0fb(3, 4) = 0.D0 + g09fb = g0fb(3, 3) + g0fb(3, 3) = 0.D0 + g04fb = g0fb(3, 2) + g0fb(3, 2) = 0.D0 + g06fb = g0fb(3, 1) + g0fb(3, 1) = 0.D0 + g03fb = g0fb(2, 4) + g0fb(2, 4) = 0.D0 + g12fb = g0fb(2, 3) + g0fb(2, 3) = 0.D0 + g02fb = g0fb(2, 2) + g0fb(2, 2) = 0.D0 + g01fb = g0fb(2, 1) + g0fb(2, 1) = 0.D0 + g10fb = g0fb(1, 4) + g0fb(1, 4) = 0.D0 + g08fb = g0fb(1, 3) + g0fb(1, 3) = 0.D0 + g07fb = g0fb(1, 2) + g0fb(1, 2) = 0.D0 + g11fb = g0fb(1, 1) + CALL KMFUL3_FB(ionic, ionicfb, temp, g01, g01fb, g02, g02fb, g03, + + g03fb, g04, g04fb, g05, g05fb, g06, g06fb, g07, + + g07fb, g08, g08fb, g09, g09fb, g10, g10fb, g11, + + g11fb, g12, g12fb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionic) + x1fb = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1fb = ionicfb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ionicfb = 0.D0 + ELSE + temp0fb = 0.5d0*x1fb/water + ionicfb = temp0fb + waterfb = waterfb - ionic*temp0fb/water + END IF + DO i=7,1,-1 + molalfb(i) = molalfb(i) + z(i)**2*ionicfb + ENDDO + END + +C Differentiation of kmful3 in reverse (adjoint) mode: +C gradient of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 ionic +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_FB(ionic, ionicfb, temp, g01, g01fb, g02, g02fb + + , g03, g03fb, g04, g04fb, g05, g05fb, g06, + + g06fb, g07, g07fb, g08, g08fb, g09, g09fb, + + g10, g10fb, g11, g11fb, g12, g12fb) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionicfb, sionfb, cf2fb + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01fb, g02fb, g03fb, g04fb, g05fb, g06fb, g07fb, + + g08fb, g09fb, g10fb, g11fb, g12fb + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTEGER :: branch + INTRINSIC ABS + REAL*8 :: abs1 + REAL*8 :: temp0fb + INTRINSIC SQRT + REAL*8 :: temp0fb0 + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01fb = g01fb + g12fb + g08fb = g08fb + g09fb + g12fb + g11fb = g11fb - g09fb - g12fb + g06fb = g06fb + g09fb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2fb = -(z10*g10fb) - z07*g07fb - z05*g05fb - z03*g03fb - z01* + + g01fb - z02*g02fb - z04*g04fb - z06*g06fb - z08*g08fb - z11* + + g11fb + g11fb = cf1*g11fb + g10fb = cf1*g10fb + g08fb = cf1*g08fb + g07fb = cf1*g07fb + g06fb = cf1*g06fb + g05fb = cf1*g05fb + g04fb = cf1*g04fb + g03fb = cf1*g03fb + g02fb = cf1*g02fb + g01fb = cf1*g01fb + temp0fb = (0.125d0-ti*0.005d0)*cf2fb + temp0fb0 = -(0.41d0*temp0fb/(sion+1.d0)) + ionicfb = ionicfb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0fb + sionfb = (1.D0-sion/(sion+1.d0))*temp0fb0 + ELSE + sionfb = 0.D0 + END IF + CALL MKBI_FB(q11, ionic, ionicfb, sion, sionfb, z11, g11, g11fb) + CALL MKBI_FB(q10, ionic, ionicfb, sion, sionfb, z10, g10, g10fb) + CALL MKBI_FB(q8, ionic, ionicfb, sion, sionfb, z08, g08, g08fb) + CALL MKBI_FB(q7, ionic, ionicfb, sion, sionfb, z07, g07, g07fb) + CALL MKBI_FB(q6, ionic, ionicfb, sion, sionfb, z06, g06, g06fb) + CALL MKBI_FB(q5, ionic, ionicfb, sion, sionfb, z05, g05, g05fb) + CALL MKBI_FB(q4, ionic, ionicfb, sion, sionfb, z04, g04, g04fb) + CALL MKBI_FB(q3, ionic, ionicfb, sion, sionfb, z03, g03, g03fb) + CALL MKBI_FB(q2, ionic, ionicfb, sion, sionfb, z02, g02, g02fb) + CALL MKBI_FB(q1, ionic, ionicfb, sion, sionfb, z01, g01, g01fb) + IF (.NOT.ionic == 0.0) ionicfb = ionicfb + sionfb/(2.0*SQRT( + + ionic)) + END + +C Differentiation of mkbi in reverse (adjoint) mode: +C gradient of useful results: sion bi ionic +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_FB(q, ionic, ionicfb, sion, sionfb, zip, bi, bifb) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionicfb, sionfb, bifb + REAL*8 :: b, c, xx + REAL*8 :: cfb, xxfb + INTRINSIC EXP + REAL*8 :: tempfb + REAL*8 :: tempfb0 + INTRINSIC LOG10 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic)) + bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b +C + xxfb = zip*bifb + bifb = zip*bifb/(bi*LOG(10.0)) + tempfb = -(0.5107d0*xxfb/(c*sion+1.d0)) + tempfb0 = -(sion*tempfb/(c*sion+1.d0)) + sionfb = sionfb + c*tempfb0 + tempfb + cfb = sion*tempfb0 + IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q + + ))) THEN + ionicfb = ionicfb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3* + + ionic**2*cfb + ELSE + ionicfb = ionicfb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bifb - + + .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cfb + END IF + END + +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of funcg5ap in reverse (adjoint) mode: +C gradient of useful results: aerliq gas +C with respect to varying inputs: wp aerliq gas +C RW status of diff variables: wp:out aerliq:in-out gas:in-out +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCG5A +C *** CASE G5 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCG5AP_GB(x1, wpgb, gasgb, aerliqgb) + INCLUDE 'isrpia_adj.inc' +C + LOGICAL :: tst + REAL*8 :: lamda + REAL*8 :: x1 + REAL*8 :: wpgb(ncomp) + REAL*8 :: AERLIQ(NIONS+NGASAQ+2), gas(3) + REAL*8 :: aerliqgb(NIONS+NGASAQ+2), gasgb(3) + CHARACTER(LEN=40) :: ERRINF + INTEGER :: errstki(25) + CHARACTER(LEN=40) :: errmsgi(25) + REAL*8 :: feps + INTEGER :: i + REAL*8 :: xt + REAL*8 :: xtd + REAL*8 :: y1 + REAL*8 :: y1gb + REAL*8 :: y1d + REAL*8 :: y1dgb + REAL*8 :: x2 + REAL*8 :: x2gb + REAL*8 :: y2 + REAL*8 :: delta + REAL*8 :: deltagb + INTEGER :: branch + INTRINSIC MAX + INTRINSIC ABS + REAL*8 :: abs1 + INTEGER :: ii1 +C +C *** SETUP PARAMETERS ************************************************ +C + feps = 1.d-5 + IF (w(2) - 0.5d0*w(1) < zero) THEN + CALL PUSHCONTROL1B(0) + chi2 = zero + ELSE + chi2 = w(2) - 0.5d0*w(1) + CALL PUSHCONTROL1B(1) + END IF + IF (w(3) - 2.d0*chi2 < zero) THEN + CALL PUSHCONTROL1B(0) + chi4 = zero + ELSE + chi4 = w(3) - 2.d0*chi2 + CALL PUSHCONTROL1B(1) + END IF + chi5 = w(4) + chi6 = w(5) +C + psi2 = chi2 +C +C *** NEWTON-RAPHSON DETERMINATION OF ROOT ********************** +C + xt = x1 + xtd = 1.d0 + CALL PUSHREAL8ARRAY(gamagnrd, npair) + CALL PUSHREAL8ARRAY(molalgnrd, nions) + CALL PUSHINTEGER4(iclact) + CALL PUSHREAL8(water) + CALL PUSHREAL8ARRAY(gama, npair) + CALL PUSHREAL8ARRAY(molalr, npair) + CALL PUSHREAL8ARRAY(molal, nions) +CCCC$AD NOCHECKPOINT + CALL FUNCG5AB_GNRD(xt, xtd, y1, y1d) + x2 = xt - y1/(y1d*1.d0) + CALL PUSHINTEGER4(iclact) + CALL PUSHREAL8(water) + CALL PUSHREAL8ARRAY(gama, npair) + CALL PUSHREAL8ARRAY(molalr, npair) + CALL PUSHREAL8ARRAY(molal, nions) + CALL FUNCG5AB(x2, y2) +C WRITE(*,*) 'x2 ',x2,' y2 ',y2 + IF (y2 >= 0.) THEN + abs1 = y2 + ELSE + abs1 = -y2 + END IF +C CALL FUNCG5AB(XT,Y2) +C + IF (abs1 > 10.d0*feps) THEN + DO ii1=1,nions + molalgb(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + gamagb(ii1) = 0.D0 + ENDDO + watergb = 0.D0 + gnh3gb = 0.D0 + ghno3gb = 0.D0 + ghclgb = 0.D0 + WRITE(ERRINF, '(A,E12.5,A)') 'CALCG5 (',(abs1),')' + CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE +! WRITE(*,*) 'W: ',W +! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP +! WRITE(*,*) 'FUNCG5AP_GB, after NR - Err 104: ',abs1 +! RETURN + ELSE +C + IF (molal(1) > tiny .AND. molal(5) > tiny) THEN + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + ghclgb = gasgb(3) + gasgb(3) = 0.D0 + ghno3gb = gasgb(2) + gasgb(2) = 0.D0 + gnh3gb = gasgb(1) + gasgb(1) = 0.D0 + aerliqgb(nions+ngasaq+2) = 0.D0 + watergb = 1.0d3*aerliqgb(nions+1)/18.0d0 + aerliqgb(nions+1) = 0.D0 + DO i=ngasaq,1,-1 + aerliqgb(nions+1+i) = 0.D0 + ENDDO + DO ii1=1,nions + molalgb(ii1) = 0.D0 + ENDDO + DO i=nions,1,-1 + molalgb(i) = molalgb(i) + aerliqgb(i) + aerliqgb(i) = 0.D0 + ENDDO + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + DO ii1=1,npair + gamagb(ii1) = 0.D0 + ENDDO + ELSE + deltagb = molalgb(6) + molalgb(6) = 0.D0 + deltagb = deltagb - molalgb(1) - molalgb(5) + CALL CALCHS4_GB(molal(1), molalgb(1), molal(5), molalgb(5), + + zero, delta, deltagb) + END IF + END IF + CALL POPREAL8ARRAY(molal, nions) + CALL POPREAL8ARRAY(molalr, npair) + CALL POPREAL8ARRAY(gama, npair) + CALL POPREAL8(water) + CALL POPINTEGER4(iclact) + CALL FUNCG5AB_GB(x2, x2gb, y2) + y1gb = -(x2gb/y1d) + y1dgb = y1*x2gb/y1d**2 +C WRITE(*,*) 'y1gb ',y1gb,'y1dgb ',y1dgb + CALL POPREAL8ARRAY(molal, nions) + CALL POPREAL8ARRAY(molalr, npair) + CALL POPREAL8ARRAY(gama, npair) + CALL POPREAL8(water) + CALL POPINTEGER4(iclact) + CALL POPREAL8ARRAY(molalgnrd, nions) + CALL POPREAL8ARRAY(gamagnrd, npair) + CALL FUNCG5AB_GNRD_GB(xt, xtd, y1, y1gb, y1d, y1dgb) + chi2gb = psi2gb + wgb(5) = wgb(5) + chi6gb + wgb(4) = wgb(4) + chi5gb + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + wgb(3) = wgb(3) + chi4gb + chi2gb = chi2gb - 2.d0*chi4gb + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + wgb(2) = wgb(2) + chi2gb + wgb(1) = wgb(1) - 0.5d0*chi2gb + END IF + DO ii1=1,5 + wpgb(ii1) = 0.D0 + ENDDO + wpgb = wgb +C PAUSE + END + +C Differentiation of funcg5ab in reverse (adjoint) mode: +C gradient of useful results: molal gama water gnh3 ghno3 +C ghcl +C with respect to varying inputs: w molal molalr gama water gnh3 +C ghno3 ghcl chi4 chi5 chi6 psi2 x +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCG5A +C *** CASE G5 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCG5AB_GB(x, xgb, fg5ab) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: psi4gb + REAL*8 :: psi5gb + REAL*8 :: psi6gb + REAL*8 :: a4gb + REAL*8 :: a5gb + REAL*8 :: a6gb +C + LOGICAL tst + INTEGER :: so4flg + REAL*8 :: lamda, fg5ab + INTEGER :: i + REAL*8 :: akk + REAL*8 :: bb + REAL*8 :: bbgb + REAL*8 :: cc + REAL*8 :: ccgb + REAL*8 :: dd + REAL*8 :: ddgb + REAL*8 :: smin + REAL*8 :: smingb + REAL*8 :: hi + REAL*8 :: higb + REAL*8 :: ohi + REAL*8 :: tots4 + REAL*8 :: frnh4 + REAL*8 :: frnh4gb + INTEGER :: j + INTEGER :: branch + REAL*8 :: x + REAL*8 :: xgb + REAL*8 :: temp3 + REAL*8 :: temp2 + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp4gb + INTRINSIC MAX + REAL*8 :: temp2gb + REAL*8 :: temp5gb + REAL*8 :: temp0gb + REAL*8 :: temp3gb + REAL*8 :: temp5gb0 + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: temp1gb + REAL*8 :: temp4 +C +C *** SETUP PARAMETERS ************************************************ +C + psi6 = x +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C +C WRITE(*,*) 'NSWEEP ',NSWEEP,'WATER',WATER + DO i=1,2 +C +C IF (I > 1) CALL CALCACT3P +C WRITE(*,*) 'GAMA ', GAMA +C + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + a5 = xk4*r*temp*(water/gama(10))**2.0 + a6 = xk3*r*temp*(water/gama(11))**2.0 +C WRITE(*,*) 'a6/a5', a6/a5 +C +C CALCULATE DISSOCIATION QUANTITIES +C + IF (chi5 >= tiny) THEN + CALL PUSHREAL8(psi5) + psi5 = psi6*chi5/(a6/a5*(chi6-psi6)+psi6) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(psi5) + psi5 = tiny + CALL PUSHCONTROL1B(1) + END IF +C +CCC IF(CHI4 > TINY) THEN + IF (w(2) > tiny) THEN + CALL PUSHREAL8(bb) +C Accounts for NH3 evaporation + bb = -(chi4+psi6+psi5+1.d0/a4) + cc = chi4*(psi5+psi6) - 2.d0*psi2/a4 + IF (bb*bb - 4.d0*cc < zero) THEN + CALL PUSHREAL8(dd) + dd = zero + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(dd) + dd = bb*bb - 4.d0*cc + CALL PUSHCONTROL1B(1) + END IF + psi4 = 0.5d0*(-bb-SQRT(dd)) + CALL PUSHCONTROL1B(0) + ELSE + psi4 = tiny + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8(molal(2)) +C +C *** CALCULATE SPECIATION ******************************************** +C +C NAI + molal(2) = w(1) + CALL PUSHREAL8(molal(4)) +C MOLAL (3) = 2.0*PSI2 + PSI4 ! NH4I +C CLI + molal(4) = psi6 + IF (w(2) - 0.5d0*w(1) > zero) THEN + CALL PUSHREAL8(molal(3)) + molal(3) = 2.d0*w(2) - w(1) + psi4 + CALL PUSHREAL8(molal(5)) +C SO4I + molal(5) = w(2) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHREAL8(molal(3)) + molal(3) = psi4 + CALL PUSHREAL8(molal(5)) +C SO4I + molal(5) = 0.5d0*w(1) + CALL PUSHCONTROL1B(0) + END IF + CALL PUSHREAL8(molal(6)) + molal(6) = zero + CALL PUSHREAL8(molal(7)) +C NO3I + molal(7) = psi5 + CALL PUSHREAL8(smin) +C +C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + smin = psi5 + psi6 - psi4 + CALL CALCPH(smin, hi, ohi) + CALL PUSHREAL8(molal(1)) + molal(1) = hi + IF (chi4 - psi4 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + IF (chi5 - psi5 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + IF (chi6 - psi6 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF +C +C Solid (NH4)2SO4 +C Solid NH4NO3 +C Solid NH4Cl +C +C CALL CALCMR ! Water content +C +C WRITE(*,*) 'MOLAL ',MOLAL +C NA2SO4 + molalr(2) = 0.5*w(1) + IF (w(2) - 0.5d0*w(1) > zero) THEN +C Total SO4 +C (NH4)2SO4 + molalr(4) = w(2) - 0.5d0*w(1) + IF (psi4 < zero) THEN + frnh4 = zero + CALL PUSHCONTROL2B(1) + ELSE + frnh4 = psi4 + CALL PUSHCONTROL2B(0) + END IF + ELSE +C Total SO4 +C (NH4)2SO4 + molalr(4) = zero + IF (2.d0*w(2) - w(1) + psi4 < zero) THEN + frnh4 = zero + CALL PUSHCONTROL2B(3) + ELSE + frnh4 = 2.d0*w(2) - w(1) + psi4 + CALL PUSHCONTROL2B(2) + END IF + END IF + IF (psi5 < frnh4) THEN + molalr(5) = psi5 + IF (frnh4 - psi5 < zero) THEN + frnh4 = zero + CALL PUSHCONTROL2B(2) + ELSE + frnh4 = frnh4 - psi5 + CALL PUSHCONTROL2B(1) + END IF + ELSE + molalr(5) = frnh4 + frnh4 = zero + CALL PUSHCONTROL2B(0) + END IF + IF (psi6 > frnh4) THEN + molalr(6) = frnh4 + CALL PUSHCONTROL1B(0) + ELSE + molalr(6) = psi6 + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8(water) +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + DO j=1,npair + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF + CALL PUSHREAL8ARRAY(gama, npair) +C WRITE(*,*) 'After CALCMR_AB: WATER ',WATER +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3P() + ENDDO + DO ii1=1,ncomp + wgb(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + molalrgb(ii1) = 0.D0 + ENDDO + chi4gb = 0.D0 + chi5gb = 0.D0 + chi6gb = 0.D0 + psi2gb = 0.D0 + psi6gb = 0.D0 + DO i=2,1,-1 + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3P_GB() + CALL POPCONTROL1B(branch) + IF (branch == 0) watergb = 0.D0 + DO j=npair,1,-1 + molalrgb(j) = molalrgb(j) + watergb/m0(j) + ENDDO + CALL POPREAL8(water) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + frnh4gb = molalrgb(6) + molalrgb(6) = 0.D0 + ELSE + psi6gb = psi6gb + molalrgb(6) + molalrgb(6) = 0.D0 + frnh4gb = 0.D0 + END IF + CALL POPCONTROL2B(branch) + IF (branch == 0) THEN + frnh4gb = molalrgb(5) + molalrgb(5) = 0.D0 + psi5gb = 0.D0 + ELSE + IF (branch == 1) THEN + psi5gb = -frnh4gb + ELSE + psi5gb = 0.D0 + frnh4gb = 0.D0 + END IF + psi5gb = psi5gb + molalrgb(5) + molalrgb(5) = 0.D0 + END IF + CALL POPCONTROL2B(branch) + IF (branch < 2) THEN + IF (branch == 0) THEN + psi4gb = frnh4gb + ELSE + psi4gb = 0.D0 + END IF + wgb(2) = wgb(2) + molalrgb(4) + wgb(1) = wgb(1) - 0.5d0*molalrgb(4) + molalrgb(4) = 0.D0 + ELSE + IF (branch == 2) THEN + wgb(2) = wgb(2) + 2.d0*frnh4gb + wgb(1) = wgb(1) - frnh4gb + psi4gb = frnh4gb + ELSE + psi4gb = 0.D0 + END IF + molalrgb(4) = 0.D0 + END IF + wgb(1) = wgb(1) + 0.5*molalrgb(2) + molalrgb(2) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + chi6gb = chi6gb + ghclgb + psi6gb = psi6gb - ghclgb + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + chi5gb = chi5gb + ghno3gb + psi5gb = psi5gb - ghno3gb + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + chi4gb = chi4gb + gnh3gb + psi4gb = psi4gb - gnh3gb + END IF + CALL POPREAL8(molal(1)) + higb = molalgb(1) + molalgb(1) = 0.D0 + CALL CALCPH_GB(smin, smingb, hi, higb, ohi) + CALL POPREAL8(smin) + psi5gb = psi5gb + molalgb(7) + smingb + psi6gb = psi6gb + smingb + psi4gb = psi4gb - smingb + CALL POPREAL8(molal(7)) + molalgb(7) = 0.D0 + CALL POPREAL8(molal(6)) + molalgb(6) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(molal(5)) + wgb(1) = wgb(1) + 0.5d0*molalgb(5) + molalgb(5) = 0.D0 + CALL POPREAL8(molal(3)) + psi4gb = psi4gb + molalgb(3) + molalgb(3) = 0.D0 + ELSE + CALL POPREAL8(molal(5)) + wgb(2) = wgb(2) + molalgb(5) + molalgb(5) = 0.D0 + CALL POPREAL8(molal(3)) + wgb(2) = wgb(2) + 2.d0*molalgb(3) + wgb(1) = wgb(1) - molalgb(3) + psi4gb = psi4gb + molalgb(3) + molalgb(3) = 0.D0 + END IF + CALL POPREAL8(molal(4)) + psi6gb = psi6gb + molalgb(4) + molalgb(4) = 0.D0 + CALL POPREAL8(molal(2)) + wgb(1) = wgb(1) + molalgb(2) + molalgb(2) = 0.D0 + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + bbgb = -(0.5d0*psi4gb) + IF (dd == 0.0) THEN + ddgb = 0.0 + ELSE + ddgb = -(0.5d0*psi4gb/(2.0*SQRT(dd))) + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(dd) + ccgb = 0.D0 + ELSE + CALL POPREAL8(dd) + bbgb = bbgb + 2*bb*ddgb + ccgb = -(4.d0*ddgb) + END IF + temp5gb0 = -(2.d0*ccgb/a4) + chi4gb = chi4gb + (psi5+psi6)*ccgb - bbgb + psi5gb = psi5gb + chi4*ccgb - bbgb + psi6gb = psi6gb + chi4*ccgb - bbgb + psi2gb = psi2gb + temp5gb0 + a4gb = bbgb/a4**2 - psi2*temp5gb0/a4 + CALL POPREAL8(bb) + ELSE + a4gb = 0.D0 + END IF + a5 = xk4*r*temp*(water/gama(10))**2.0 + a6 = xk3*r*temp*(water/gama(11))**2.0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(psi5) + temp3 = a6/a5 + temp4 = (chi6-psi6)*temp3 + psi6 + temp5gb = psi5gb/temp4 + temp4gb = -(psi6*chi5*temp5gb/temp4) + temp3gb = (chi6-psi6)*temp4gb/a5 + psi6gb = psi6gb + (1.D0-temp3)*temp4gb + chi5*temp5gb + chi5gb = chi5gb + psi6*temp5gb + chi6gb = chi6gb + temp3*temp4gb + a6gb = temp3gb + a5gb = -(temp3*temp3gb) + ELSE + CALL POPREAL8(psi5) + a5gb = 0.D0 + a6gb = 0.D0 + END IF + temp0 = gama(10)/gama(5) + temp0gb = 2.0*temp0*xk2*r*temp*a4gb/(xkw*gama(5)) + temp1 = water/gama(10) + temp1gb = 2.0*temp1*xk4*r*temp*a5gb/gama(10) + temp2 = water/gama(11) + temp2gb = 2.0*temp2*xk3*r*temp*a6gb/gama(11) + watergb = watergb + temp1gb + temp2gb + gamagb(11) = gamagb(11) - temp2*temp2gb + gamagb(10) = gamagb(10) + temp0gb - temp1*temp1gb + gamagb(5) = gamagb(5) - temp0*temp0gb + gnh3gb = 0.D0 + ghno3gb = 0.D0 + ghclgb = 0.D0 + ENDDO + xgb = psi6gb + END + +C +C Differentiation of calchs4 in reverse (adjoint) mode: +C gradient of useful results: water hi so4i delta +C with respect to varying inputs: gama water hi so4i +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCHS4 +C *** THIS SUBROUTINE CALCULATES THE HSO4 GENERATED FROM (H,SO4). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCHS4_GB(hi, higb, so4i, so4igb, hso4i, delta, + + deltagb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: a8gb + REAL*8 :: hi, so4i, hso4i, delta, bb, cc, dd, sqdd, delta1 + + , delta2 + REAL*8 :: higb, so4igb, deltagb, bbgb, ccgb, ddgb, sqddgb, + + delta1gb, delta2gb + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp0gb + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: temp1gb +C +C *** IF TOO LITTLE WATER, DONT SOLVE +C + IF (water <= 1d1*tiny) THEN + DO ii1=1,npair + gamagb(ii1) = 0.D0 + ENDDO + ELSE +C +C *** CALCULATE HSO4 SPECIATION ***************************************** +C + a8 = xk1*water/gama(7)*(gama(8)/gama(7))**2. +C + bb = -(hi+so4i+a8) + cc = hi*so4i - hso4i*a8 + dd = bb*bb - 4.d0*cc +C + IF (dd >= zero) THEN + IF (hso4i <= tiny) THEN + delta2gb = deltagb + delta1gb = 0.D0 + ELSE IF (hi*so4i >= a8*hso4i) THEN + delta2gb = deltagb + delta1gb = 0.D0 + ELSE + IF (hi*so4i < a8*hso4i) THEN + delta1gb = deltagb + ELSE + delta1gb = 0.D0 + END IF + delta2gb = 0.D0 + END IF + bbgb = -(0.5*delta1gb) - 0.5*delta2gb + sqddgb = 0.5*delta1gb - 0.5*delta2gb + IF (dd == 0.0) THEN + ddgb = 0.0 + ELSE + ddgb = sqddgb/(2.0*SQRT(dd)) + END IF + ELSE + ddgb = 0.D0 + bbgb = 0.D0 + END IF + bbgb = bbgb + 2*bb*ddgb + ccgb = -(4.d0*ddgb) + higb = higb + so4i*ccgb - bbgb + so4igb = so4igb + hi*ccgb - bbgb + a8gb = -bbgb - hso4i*ccgb + DO ii1=1,npair + gamagb(ii1) = 0.D0 + ENDDO + temp0 = water/gama(7) + temp1 = gama(8)/gama(7) + temp1gb = 2.*temp1*temp0*xk1*a8gb/gama(7) + temp0gb = temp1**2.*xk1*a8gb/gama(7) + gamagb(8) = gamagb(8) + temp1gb + gamagb(7) = gamagb(7) - temp0*temp0gb - temp1*temp1gb + watergb = watergb + temp0gb + END IF + END + +C Differentiation of calcph in reverse (adjoint) mode: +C gradient of useful results: hi +C with respect to varying inputs: water gg +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCPH +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCPH_GB(gg, gggb, hi, higb, ohi) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: cn, gg, hi, ohi, bb, cc, dd + REAL*8 :: cngb, gggb, higb, ohigb, bbgb, ccgb, ddgb + REAL*8 :: akw + REAL*8 :: akwgb + INTEGER :: branch + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x2gb + INTRINSIC SQRT + REAL*8 :: x1gb +C + akw = xkw*rh*water*water + cn = SQRT(akw) +C +C *** GG = (negative charge) - (positive charge) +C + IF (gg > tiny) THEN +C H+ in excess + bb = -gg + cc = -akw + dd = bb*bb - 4.d0*cc + x1 = 0.5d0*(-bb+SQRT(dd)) + IF (x1 < cn) THEN + cngb = higb + x1gb = 0.D0 + ELSE + x1gb = higb + cngb = 0.D0 + END IF + IF (dd == 0.0) THEN + ddgb = 0.0 + ELSE + ddgb = 0.5d0*x1gb/(2.0*SQRT(dd)) + END IF + bbgb = 2*bb*ddgb - 0.5d0*x1gb + ccgb = -(4.d0*ddgb) + akwgb = -ccgb + gggb = -bbgb + ELSE +C OH- in excess + bb = gg + cc = -akw + dd = bb*bb - 4.d0*cc + x2 = 0.5d0*(-bb+SQRT(dd)) + IF (x2 < cn) THEN + ohi = cn + CALL PUSHCONTROL1B(0) + ELSE + ohi = x2 + CALL PUSHCONTROL1B(1) + END IF + akwgb = higb/ohi + ohigb = -(akw*higb/ohi**2) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cngb = ohigb + x2gb = 0.D0 + ELSE + x2gb = ohigb + cngb = 0.D0 + END IF + IF (dd == 0.0) THEN + ddgb = 0.0 + ELSE + ddgb = 0.5d0*x2gb/(2.0*SQRT(dd)) + END IF + bbgb = 2*bb*ddgb - 0.5d0*x2gb + ccgb = -(4.d0*ddgb) + akwgb = akwgb - ccgb + gggb = bbgb + END IF + IF (.NOT.akw == 0.0) akwgb = akwgb + cngb/(2.0*SQRT(akw)) + watergb = xkw*rh*2*water*akwgb + END + +C Differentiation of calcact3p in reverse (adjoint) mode: +C gradient of useful results: molal gama water +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3P_GB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0gb(6, 4), siongb, hgb, chgb, f1gb(3), f2gb(4) + REAL*8 :: mpl, xij, yji + REAL*8 :: mplgb, xijgb, yjigb, ionicgb + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01gb + REAL*8 :: g02 + REAL*8 :: g02gb + REAL*8 :: g03 + REAL*8 :: g03gb + REAL*8 :: g04 + REAL*8 :: g04gb + REAL*8 :: g05 + REAL*8 :: g05gb + REAL*8 :: g06 + REAL*8 :: g06gb + REAL*8 :: g07 + REAL*8 :: g07gb + REAL*8 :: g08 + REAL*8 :: g08gb + REAL*8 :: g09 + REAL*8 :: g09gb + REAL*8 :: g10 + REAL*8 :: g10gb + REAL*8 :: g11 + REAL*8 :: g11gb + REAL*8 :: g12 + REAL*8 :: g12gb + INTEGER :: j + INTEGER :: branch + INTRINSIC MAX + REAL*8 :: temp0gb9 + REAL*8 :: temp0gb8 + REAL*8 :: temp0gb7 + REAL*8 :: temp0gb6 + REAL*8 :: x2 + REAL*8 :: temp0gb5 + REAL*8 :: x1 + REAL*8 :: temp0gb4 + REAL*8 :: temp0gb3 + REAL*8 :: temp0gb2 + REAL*8 :: temp0gb1 + REAL*8 :: temp0gb0 + REAL*8 :: x2gb + REAL*8 :: temp0gb13 + REAL*8 :: temp0gb12 + REAL*8 :: temp0gb11 + REAL*8 :: temp0gb10 + REAL*8 :: temp0gb + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: x1gb +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + DO i=1,7 + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08, + + g09, g10, g11, g12) +C + g0(1, 1) = g11 + g0(1, 2) = g07 + g0(1, 3) = g08 + g0(1, 4) = g10 + g0(2, 1) = g01 + g0(2, 2) = g02 + g0(2, 3) = g12 + g0(2, 4) = g03 + g0(3, 1) = g06 + g0(3, 2) = g04 + g0(3, 3) = g09 + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + sion = SQRT(ionic) + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + yji = ch*molal(j+3)/water + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gama(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gama(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gama(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gama(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gama(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gama(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gama(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gama(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gama(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gama(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gama(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gama(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gama(13)) +C LC ; SCAPE + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + ELSE + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + gamagb(i) = 10.d0**gama(i)*LOG(10.d0)*gamagb(i) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + gamagb(i) = 0.D0 + x2gb = 0.D0 + ELSE + x2gb = gamagb(i) + gamagb(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) gamagb(i) = gamagb(i) + x2gb + ENDDO + CALL POPREAL8(gama(13)) + gamagb(4) = gamagb(4) + 0.2d0*3.d0*gamagb(13) + gamagb(9) = gamagb(9) + 0.2d0*2.d0*gamagb(13) + gamagb(13) = 0.D0 + DO ii1=1,3 + f1gb(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2gb(ii1) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp0gb2 = zz(12)*gamagb(12)/(z(2)+z(6)) + f1gb(2) = f1gb(2) + temp0gb2/z(2) + f2gb(3) = f2gb(3) + temp0gb2/z(6) + hgb = -(zz(12)*gamagb(12)) + gamagb(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp0gb3 = zz(11)*gamagb(11)/(z(1)+z(4)) + f2gb(1) = f2gb(1) + temp0gb3/z(4) + hgb = hgb - zz(11)*gamagb(11) + gamagb(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp0gb4 = zz(10)*gamagb(10)/(z(1)+z(7)) + f1gb(1) = f1gb(1) + temp0gb4/z(1) + temp0gb3/z(1) + f2gb(4) = f2gb(4) + temp0gb4/z(7) + hgb = hgb - zz(10)*gamagb(10) + gamagb(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp0gb5 = zz(9)*gamagb(9)/(z(3)+z(6)) + f1gb(3) = f1gb(3) + temp0gb5/z(3) + hgb = hgb - zz(9)*gamagb(9) + gamagb(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp0gb6 = zz(8)*gamagb(8)/(z(1)+z(6)) + f2gb(3) = f2gb(3) + temp0gb6/z(6) + temp0gb5/z(6) + hgb = hgb - zz(8)*gamagb(8) + gamagb(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp0gb7 = zz(7)*gamagb(7)/(z(1)+z(5)) + f1gb(1) = f1gb(1) + temp0gb7/z(1) + temp0gb6/z(1) + f2gb(2) = f2gb(2) + temp0gb7/z(5) + hgb = hgb - zz(7)*gamagb(7) + gamagb(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp0gb8 = zz(6)*gamagb(6)/(z(3)+z(4)) + f2gb(1) = f2gb(1) + temp0gb8/z(4) + hgb = hgb - zz(6)*gamagb(6) + gamagb(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp0gb9 = zz(5)*gamagb(5)/(z(3)+z(7)) + f2gb(4) = f2gb(4) + temp0gb9/z(7) + hgb = hgb - zz(5)*gamagb(5) + gamagb(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp0gb10 = zz(4)*gamagb(4)/(z(3)+z(5)) + f1gb(3) = f1gb(3) + temp0gb9/z(3) + temp0gb10/z(3) + temp0gb8/z(3) + f2gb(2) = f2gb(2) + temp0gb10/z(5) + hgb = hgb - zz(4)*gamagb(4) + gamagb(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp0gb11 = zz(3)*gamagb(3)/(z(2)+z(7)) + f2gb(4) = f2gb(4) + temp0gb11/z(7) + hgb = hgb - zz(3)*gamagb(3) + gamagb(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp0gb12 = zz(2)*gamagb(2)/(z(2)+z(5)) + f2gb(2) = f2gb(2) + temp0gb12/z(5) + hgb = hgb - zz(2)*gamagb(2) + gamagb(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp0gb13 = zz(1)*gamagb(1)/(z(2)+z(4)) + f1gb(2) = f1gb(2) + temp0gb12/z(2) + temp0gb13/z(2) + temp0gb11/z( + + 2) + f2gb(1) = f2gb(1) + temp0gb13/z(4) + hgb = hgb - zz(1)*gamagb(1) + gamagb(1) = 0.D0 + ionicgb = 0.D0 + DO ii1=1,4 + DO ii2=1,6 + g0gb(ii2, ii1) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mplgb = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijgb = (g0(i, j)+zpl*zmi*h)*f2gb(j) + yji = ch*molal(j+3)/water + g0gb(i, j) = g0gb(i, j) + yji*f1gb(i) + xij*f2gb(j) + hgb = hgb + yji*zpl*zmi*f1gb(i) + xij*zpl*zmi*f2gb(j) + yjigb = (g0(i, j)+zpl*zmi*h)*f1gb(i) + temp0gb1 = molal(j+3)*yjigb/water + molalgb(j+3) = molalgb(j+3) + ch*yjigb/water + chgb = mpl*xijgb + temp0gb1 + watergb = watergb - ch*temp0gb1/water + mplgb = mplgb + ch*xijgb + ionicgb = ionicgb - (zpl+zmi)**2*0.25d0*chgb/ionic**2 + ENDDO + CALL POPREAL8(mpl) + molalgb(i) = molalgb(i) + mplgb/water + watergb = watergb - molal(i)*mplgb/water**2 + CALL POPREAL8(zpl) + ENDDO + temp0gb0 = agama*hgb/(sion+1.d0) + siongb = (1.D0-sion/(sion+1.d0))*temp0gb0 + IF (.NOT.ionic == 0.0) ionicgb = ionicgb + siongb/(2.0*SQRT( + + ionic)) + g05gb = g0gb(3, 4) + g0gb(3, 4) = 0.D0 + g09gb = g0gb(3, 3) + g0gb(3, 3) = 0.D0 + g04gb = g0gb(3, 2) + g0gb(3, 2) = 0.D0 + g06gb = g0gb(3, 1) + g0gb(3, 1) = 0.D0 + g03gb = g0gb(2, 4) + g0gb(2, 4) = 0.D0 + g12gb = g0gb(2, 3) + g0gb(2, 3) = 0.D0 + g02gb = g0gb(2, 2) + g0gb(2, 2) = 0.D0 + g01gb = g0gb(2, 1) + g0gb(2, 1) = 0.D0 + g10gb = g0gb(1, 4) + g0gb(1, 4) = 0.D0 + g08gb = g0gb(1, 3) + g0gb(1, 3) = 0.D0 + g07gb = g0gb(1, 2) + g0gb(1, 2) = 0.D0 + g11gb = g0gb(1, 1) + CALL KMFUL3_GB(ionic, ionicgb, temp, g01, g01gb, g02, g02gb, g03, + + g03gb, g04, g04gb, g05, g05gb, g06, g06gb, g07, + + g07gb, g08, g08gb, g09, g09gb, g10, g10gb, g11, + + g11gb, g12, g12gb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionic) + x1gb = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1gb = ionicgb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ionicgb = 0.D0 + ELSE + temp0gb = 0.5d0*x1gb/water + ionicgb = temp0gb + watergb = watergb - ionic*temp0gb/water + END IF + DO i=7,1,-1 + molalgb(i) = molalgb(i) + z(i)**2*ionicgb + ENDDO + END + +C Differentiation of kmful3 in reverse (adjoint) mode: +C gradient of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 ionic +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_GB(ionic, ionicgb, temp, g01, g01gb, g02, g02gb + + , g03, g03gb, g04, g04gb, g05, g05gb, g06, + + g06gb, g07, g07gb, g08, g08gb, g09, g09gb, + + g10, g10gb, g11, g11gb, g12, g12gb) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionicgb, siongb, cf2gb + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01gb, g02gb, g03gb, g04gb, g05gb, g06gb, g07gb, + + g08gb, g09gb, g10gb, g11gb, g12gb + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTEGER :: branch + INTRINSIC ABS + REAL*8 :: temp0gb0 + REAL*8 :: temp0gb + REAL*8 :: abs1 + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01gb = g01gb + g12gb + g08gb = g08gb + g09gb + g12gb + g11gb = g11gb - g09gb - g12gb + g06gb = g06gb + g09gb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2gb = -(z10*g10gb) - z07*g07gb - z05*g05gb - z03*g03gb - z01* + + g01gb - z02*g02gb - z04*g04gb - z06*g06gb - z08*g08gb - z11* + + g11gb + g11gb = cf1*g11gb + g10gb = cf1*g10gb + g08gb = cf1*g08gb + g07gb = cf1*g07gb + g06gb = cf1*g06gb + g05gb = cf1*g05gb + g04gb = cf1*g04gb + g03gb = cf1*g03gb + g02gb = cf1*g02gb + g01gb = cf1*g01gb + temp0gb = (0.125d0-ti*0.005d0)*cf2gb + temp0gb0 = -(0.41d0*temp0gb/(sion+1.d0)) + ionicgb = ionicgb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0gb + siongb = (1.D0-sion/(sion+1.d0))*temp0gb0 + ELSE + siongb = 0.D0 + END IF + CALL MKBI_GB(q11, ionic, ionicgb, sion, siongb, z11, g11, g11gb) + CALL MKBI_GB(q10, ionic, ionicgb, sion, siongb, z10, g10, g10gb) + CALL MKBI_GB(q8, ionic, ionicgb, sion, siongb, z08, g08, g08gb) + CALL MKBI_GB(q7, ionic, ionicgb, sion, siongb, z07, g07, g07gb) + CALL MKBI_GB(q6, ionic, ionicgb, sion, siongb, z06, g06, g06gb) + CALL MKBI_GB(q5, ionic, ionicgb, sion, siongb, z05, g05, g05gb) + CALL MKBI_GB(q4, ionic, ionicgb, sion, siongb, z04, g04, g04gb) + CALL MKBI_GB(q3, ionic, ionicgb, sion, siongb, z03, g03, g03gb) + CALL MKBI_GB(q2, ionic, ionicgb, sion, siongb, z02, g02, g02gb) + CALL MKBI_GB(q1, ionic, ionicgb, sion, siongb, z01, g01, g01gb) + IF (.NOT.ionic == 0.0) ionicgb = ionicgb + siongb/(2.0*SQRT( + + ionic)) + END + +C Differentiation of mkbi in reverse (adjoint) mode: +C gradient of useful results: sion bi ionic +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_GB(q, ionic, ionicgb, sion, siongb, zip, bi, bigb) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionicgb, siongb, bigb + REAL*8 :: b, c, xx + REAL*8 :: cgb, xxgb + REAL*8 :: tempgb0 + INTRINSIC EXP + REAL*8 :: tempgb + INTRINSIC LOG10 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic)) + bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b +C + xxgb = zip*bigb + bigb = zip*bigb/(bi*LOG(10.0)) + tempgb = -(0.5107d0*xxgb/(c*sion+1.d0)) + tempgb0 = -(sion*tempgb/(c*sion+1.d0)) + siongb = siongb + c*tempgb0 + tempgb + cgb = sion*tempgb0 + IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q + + ))) THEN + ionicgb = ionicgb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3* + + ionic**2*cgb + ELSE + ionicgb = ionicgb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bigb - + + .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cgb + END IF + END + +C Differentiation of funcg5ab_gnrd in reverse (adjoint) mode: +C gradient of useful results: w molal molalr gama water gnh3 +C ghno3 ghcl chi4 chi5 chi6 psi2 fg5abgnrd fg5ab +C with respect to varying inputs: w chi4 chi5 chi6 psi2 +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of funcg5ab in forward (tangent) mode: +C variations of useful results: fg5ab +C with respect to varying inputs: x +C RW status of diff variables: x:in fg5ab:out +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCG5A +C *** CASE G5 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCG5AB_GNRD_GB(x, xgnrd, fg5ab, fg5abgb, fg5abgnrd, + + fg5abgnrdgb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: psi4gnrd + REAL*8 :: psi4gnrdgb + REAL*8 :: psi5gb + REAL*8 :: psi5gnrd + REAL*8 :: psi5gnrdgb + REAL*8 :: psi6gnrd + REAL*8 :: a4gb + REAL*8 :: a4gnrd + REAL*8 :: a4gnrdgb + REAL*8 :: a5gb + REAL*8 :: a5gnrd + REAL*8 :: a5gnrdgb + REAL*8 :: a6gb + REAL*8 :: a6gnrd + REAL*8 :: a6gnrdgb +C + REAL*8 :: molalrgnrd(npair), molalrgnrdgb(npair) + LOGICAL tst + INTEGER :: so4flg + REAL*8 :: lamda, fg5ab + REAL*8 :: fg5abgb + REAL*8 :: fg5abgnrd + REAL*8 :: fg5abgnrdgb + INTEGER :: i + REAL*8 :: akk + REAL*8 :: bb + REAL*8 :: bbgb + REAL*8 :: bbgnrd + REAL*8 :: bbgnrdgb + REAL*8 :: cc + REAL*8 :: ccgb + REAL*8 :: ccgnrd + REAL*8 :: ccgnrdgb + REAL*8 :: dd + REAL*8 :: ddgb + REAL*8 :: ddgnrd + REAL*8 :: ddgnrdgb + REAL*8 :: smin + REAL*8 :: smingb + REAL*8 :: smingnrd + REAL*8 :: smingnrdgb + REAL*8 :: hi + REAL*8 :: higb + REAL*8 :: hignrd + REAL*8 :: hignrdgb + REAL*8 :: ohi + REAL*8 :: tots4 + REAL*8 :: frnh4 + REAL*8 :: frnh4gb + REAL*8 :: frnh4gnrd + REAL*8 :: frnh4gnrdgb + INTEGER :: j + REAL*8 :: result1 + REAL*8 :: result1gb + REAL*8 :: result1gnrd + REAL*8 :: result1gnrdgb + REAL*8 :: x + REAL*8 :: xgnrd + INTRINSIC MAX + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT + INTEGER :: branch + REAL*8 :: temp3 + REAL*8 :: temp2 + REAL*8 :: temp1 + REAL*8 :: temp20gb + REAL*8 :: temp0 + REAL*8 :: temp9gb + REAL*8 :: temp18gb + REAL*8 :: temp22 + REAL*8 :: temp4gb + REAL*8 :: temp21 + REAL*8 :: temp20 + REAL*8 :: temp13gb + REAL*8 :: temp23gb1 + REAL*8 :: temp23gb0 + REAL*8 :: temp9gb0 + REAL*8 :: temp23gb + REAL*8 :: temp7gb + REAL*8 :: temp16gb + INTRINSIC ABS + REAL*8 :: temp2gb + REAL*8 :: temp19 + REAL*8 :: temp11gb + REAL*8 :: temp18 + REAL*8 :: temp17 + REAL*8 :: temp16 + REAL*8 :: temp15 + REAL*8 :: temp14 + REAL*8 :: temp13 + REAL*8 :: temp12 + REAL*8 :: temp11 + REAL*8 :: temp10 + REAL*8 :: temp21gb + REAL*8 :: temp1gb0 + REAL*8 :: temp19gb + REAL*8 :: temp5gb + REAL*8 :: temp14gb + REAL*8 :: temp15gb0 + REAL*8 :: temp0gb + REAL*8 :: temp3gb1 + REAL*8 :: temp3gb0 + REAL*8 :: temp8gb + REAL*8 :: temp17gb3 + REAL*8 :: temp17gb + REAL*8 :: temp17gb2 + REAL*8 :: temp17gb1 + REAL*8 :: temp17gb0 + REAL*8 :: temp3gb + INTEGER :: ii10 + REAL*8 :: temp5gb1 + REAL*8 :: temp5gb0 + REAL*8 :: abs1 + REAL*8 :: temp6gb + REAL*8 :: temp15gb + REAL*8 :: temp1gb + REAL*8 :: temp10gb + REAL*8 :: temp9 + REAL*8 :: temp8 + REAL*8 :: temp7 + REAL*8 :: temp6 + REAL*8 :: temp5 + REAL*8 :: temp4 +C +C *** SETUP PARAMETERS ************************************************ +C + psi6gnrd = xgnrd + psi6 = x + DO ii1=1,nions + molalgnrd(ii1) = 0.d0 + ENDDO + DO ii1=1,npair + molalrgnrd(ii1) = 0.d0 + ENDDO + DO ii1=1,npair + gamagnrd(ii1) = 0.d0 + ENDDO + watergnrd = 0.d0 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C +C WRITE(*,*) 'NSWEEP ',NSWEEP,'WATER',WATER + DO i=1,2 + CALL PUSHREAL8(a4gnrd) +C +C IF (I > 1) CALL CALCACT3P +C WRITE(*,*) 'GAMA ', GAMA +C + a4gnrd = xk2*r*temp*2.0*gama(10)*(gamagnrd(10)*gama(5)-gama(10)* + + gamagnrd(5))/(xkw*gama(5)**3) + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + CALL PUSHREAL8(a5gnrd) + a5gnrd = xk4*r*temp*2.0*water*(watergnrd*gama(10)-water*gamagnrd + + (10))/gama(10)**3 + a5 = xk4*r*temp*(water/gama(10))**2.0 + CALL PUSHREAL8(a6gnrd) + a6gnrd = xk3*r*temp*2.0*water*(watergnrd*gama(11)-water*gamagnrd + + (11))/gama(11)**3 + CALL PUSHREAL8(a6) + a6 = xk3*r*temp*(water/gama(11))**2.0 +C +C CALCULATE DISSOCIATION QUANTITIES +C + IF (chi5 >= tiny) THEN + CALL PUSHREAL8(psi5gnrd) + psi5gnrd = (chi5*psi6gnrd*(a6/a5*(chi6-psi6)+psi6)-psi6*chi5*( + + (a6gnrd*a5-a6*a5gnrd)*(chi6-psi6)/a5**2-a6*psi6gnrd/a5+ + + psi6gnrd))/(a6/a5*(chi6-psi6)+psi6)**2 + CALL PUSHREAL8(psi5) + psi5 = psi6*chi5/(a6/a5*(chi6-psi6)+psi6) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(psi5) + psi5 = tiny + CALL PUSHREAL8(psi5gnrd) + psi5gnrd = 0.d0 + CALL PUSHCONTROL1B(1) + END IF +C +CCC IF(CHI4 > TINY) THEN + IF (w(2) > tiny) THEN + CALL PUSHREAL8(bbgnrd) +C Accounts for NH3 evaporation + bbgnrd = -(psi6gnrd+psi5gnrd-a4gnrd/a4**2) + CALL PUSHREAL8(bb) + bb = -(chi4+psi6+psi5+1.d0/a4) + ccgnrd = chi4*(psi5gnrd+psi6gnrd) + 2.d0*psi2*a4gnrd/a4**2 + cc = chi4*(psi5+psi6) - 2.d0*psi2/a4 + IF (bb*bb - 4.d0*cc < zero) THEN + CALL PUSHREAL8(dd) + dd = zero + CALL PUSHREAL8(ddgnrd) + ddgnrd = 0.d0 + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHREAL8(ddgnrd) + ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd + CALL PUSHREAL8(dd) + dd = bb*bb - 4.d0*cc + CALL PUSHCONTROL1B(0) + END IF + IF (dd >= 0.) THEN + abs1 = dd + ELSE + abs1 = -dd + END IF + IF (abs1 < tiny) THEN + result1gnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + result1gnrd = ddgnrd/(2.0*SQRT(dd)) + CALL PUSHCONTROL1B(1) + END IF + result1 = SQRT(dd) + psi4gnrd = 0.5d0*(-bbgnrd-result1gnrd) + psi4 = 0.5d0*(-bb-result1) + CALL PUSHCONTROL1B(0) + ELSE + psi4 = tiny + psi4gnrd = 0.d0 + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8(molalgnrd(2)) +C +C *** CALCULATE SPECIATION ******************************************** +C +C NAI + molalgnrd(2) = 0.d0 + CALL PUSHREAL8(molal(2)) + molal(2) = w(1) + CALL PUSHREAL8(molalgnrd(4)) +C MOLAL (3) = 2.0*PSI2 + PSI4 ! NH4I +C CLI + molalgnrd(4) = psi6gnrd + CALL PUSHREAL8(molal(4)) + molal(4) = psi6 + IF (w(2) - 0.5d0*w(1) > zero) THEN + CALL PUSHREAL8(molalgnrd(3)) + molalgnrd(3) = psi4gnrd + CALL PUSHREAL8(molal(3)) + molal(3) = 2.d0*w(2) - w(1) + psi4 + CALL PUSHREAL8(molalgnrd(5)) +C SO4I + molalgnrd(5) = 0.d0 + CALL PUSHREAL8(molal(5)) + molal(5) = w(2) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(molalgnrd(3)) + molalgnrd(3) = psi4gnrd + CALL PUSHREAL8(molal(3)) + molal(3) = psi4 + CALL PUSHREAL8(molalgnrd(5)) +C SO4I + molalgnrd(5) = 0.d0 + CALL PUSHREAL8(molal(5)) + molal(5) = 0.5d0*w(1) + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8(molalgnrd(6)) + molalgnrd(6) = 0.d0 + CALL PUSHREAL8(molal(6)) + molal(6) = zero + CALL PUSHREAL8(molalgnrd(7)) +C NO3I + molalgnrd(7) = psi5gnrd + CALL PUSHREAL8(molal(7)) + molal(7) = psi5 + CALL PUSHREAL8(smingnrd) +C +C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + smingnrd = psi5gnrd + psi6gnrd - psi4gnrd + CALL PUSHREAL8(smin) + smin = psi5 + psi6 - psi4 + CALL CALCPH_GNRD(smin, smingnrd, hi, hignrd, ohi) + CALL PUSHREAL8(molalgnrd(1)) + molalgnrd(1) = hignrd + CALL PUSHREAL8(molal(1)) + molal(1) = hi + IF (chi4 - psi4 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + IF (chi5 - psi5 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + IF (chi6 - psi6 < tiny) THEN + CALL PUSHCONTROL1B(0) + ghcl = tiny + ghclgnrd = 0.d0 + ELSE + ghclgnrd = -psi6gnrd + ghcl = chi6 - psi6 + CALL PUSHCONTROL1B(1) + END IF +C +C Solid (NH4)2SO4 +C Solid NH4NO3 +C Solid NH4Cl +C +C CALL CALCMR ! Water content +C +C WRITE(*,*) 'MOLAL ',MOLAL +C NA2SO4 + molalrgnrd(2) = 0.d0 + molalr(2) = 0.5*w(1) + IF (w(2) - 0.5d0*w(1) > zero) THEN +C Total SO4 +C (NH4)2SO4 + molalrgnrd(4) = 0.d0 + molalr(4) = w(2) - 0.5d0*w(1) + IF (psi4 < zero) THEN + frnh4 = zero + frnh4gnrd = 0.d0 + CALL PUSHCONTROL2B(0) + ELSE + frnh4gnrd = psi4gnrd + frnh4 = psi4 + CALL PUSHCONTROL2B(1) + END IF + ELSE +C Total SO4 +C (NH4)2SO4 + molalrgnrd(4) = 0.d0 + molalr(4) = zero + IF (2.d0*w(2) - w(1) + psi4 < zero) THEN + frnh4 = zero + frnh4gnrd = 0.d0 + CALL PUSHCONTROL2B(2) + ELSE + frnh4gnrd = psi4gnrd + frnh4 = 2.d0*w(2) - w(1) + psi4 + CALL PUSHCONTROL2B(3) + END IF + END IF + IF (psi5 < frnh4) THEN + molalrgnrd(5) = psi5gnrd + molalr(5) = psi5 + IF (frnh4 - psi5 < zero) THEN + frnh4 = zero + frnh4gnrd = 0.d0 + CALL PUSHCONTROL2B(0) + ELSE + frnh4gnrd = frnh4gnrd - psi5gnrd + frnh4 = frnh4 - psi5 + CALL PUSHCONTROL2B(1) + END IF + ELSE + molalrgnrd(5) = frnh4gnrd + molalr(5) = frnh4 + frnh4 = zero + frnh4gnrd = 0.d0 + CALL PUSHCONTROL2B(2) + END IF + IF (psi6 > frnh4) THEN + molalrgnrd(6) = frnh4gnrd + molalr(6) = frnh4 + CALL PUSHCONTROL1B(0) + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHREAL8(water) +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + CALL PUSHREAL8(watergnrd) + watergnrd = 0.d0 + DO j=1,npair + watergnrd = watergnrd + molalrgnrd(j)/m0(j) + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + watergnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF + CALL PUSHREAL8ARRAY(gamagnrd, npair) + CALL PUSHREAL8ARRAY(gama, npair) +C WRITE(*,*) 'After CALCMR: WATER ',WATER +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3P_GNRD() + ENDDO + temp23gb1 = fg5abgnrdgb/a6**2 + temp22 = ghcl**2 + temp19 = a6/temp22 + temp20gb = temp19*temp23gb1 + temp21gb = ghcl*temp20gb + temp21 = molalgnrd(1)*molal(4) + molal(1)*molalgnrd(4) + temp20 = temp21*ghcl - ghclgnrd*molal(1)*molal(4) + temp19gb = temp20*temp23gb1/temp22 + temp18 = a6gnrd/ghcl + temp18gb = -(molal(1)*molal(4)*temp23gb1/ghcl) + temp23gb = fg5abgb/(ghcl*a6) + temp23gb0 = -(molal(1)*molal(4)*temp23gb/(ghcl*a6)) + molalgb(1) = molalgb(1) + molal(4)*temp23gb + molalgb(4) = molalgb(4) + molalgnrd(1)*temp21gb - ghclgnrd*molal(1 + + )*temp20gb - temp18*molal(1)*temp23gb1 + molal(1)*temp23gb + ghclgb = ghclgb + temp21*temp20gb - temp19*2*ghcl*temp19gb - + + temp18*temp18gb + a6*temp23gb0 + a6gb = temp19gb - (temp20*temp19-molal(1)*molal(4)*temp18)*2* + + temp23gb1/a6 + ghcl*temp23gb0 + DO ii10=1,nions + molalgnrdgb(ii10) = 0.D0 + ENDDO + molalgnrdgb(1) = molalgnrdgb(1) + molal(4)*temp21gb + molalgb(1) = molalgb(1) + molalgnrd(4)*temp21gb - ghclgnrd*molal(4 + + )*temp20gb - temp18*molal(4)*temp23gb1 + molalgnrdgb(4) = molalgnrdgb(4) + molal(1)*temp21gb + a6gnrdgb = temp18gb + DO ii10=1,npair + gamagnrdgb(ii10) = 0.D0 + ENDDO + watergnrdgb = 0.D0 + DO ii10=1,npair + molalrgnrdgb(ii10) = 0.D0 + ENDDO + DO i=2,1,-1 + CALL POPREAL8ARRAY(gama, npair) + CALL POPREAL8ARRAY(gamagnrd, npair) + CALL CALCACT3P_GNRD_GB() + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + watergb = 0.D0 + watergnrdgb = 0.D0 + END IF + DO j=npair,1,-1 + molalrgb(j) = molalrgb(j) + watergb/m0(j) + molalrgnrdgb(j) = molalrgnrdgb(j) + watergnrdgb/m0(j) + ENDDO + CALL POPREAL8(watergnrd) + CALL POPREAL8(water) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + frnh4gb = molalrgb(6) + molalrgb(6) = 0.D0 + frnh4gnrdgb = molalrgnrdgb(6) + molalrgnrdgb(6) = 0.D0 + ELSE + molalrgb(6) = 0.D0 + molalrgnrdgb(6) = 0.D0 + frnh4gb = 0.D0 + frnh4gnrdgb = 0.D0 + END IF + CALL POPCONTROL2B(branch) + IF (branch == 0) THEN + psi5gb = 0.D0 + psi5gnrdgb = 0.D0 + frnh4gb = 0.D0 + frnh4gnrdgb = 0.D0 + ELSE IF (branch == 1) THEN + psi5gb = -frnh4gb + psi5gnrdgb = -frnh4gnrdgb + ELSE + frnh4gb = molalrgb(5) + molalrgb(5) = 0.D0 + frnh4gnrdgb = molalrgnrdgb(5) + molalrgnrdgb(5) = 0.D0 + psi5gb = 0.D0 + psi5gnrdgb = 0.D0 + GOTO 100 + END IF + psi5gb = psi5gb + molalrgb(5) + molalrgb(5) = 0.D0 + psi5gnrdgb = psi5gnrdgb + molalrgnrdgb(5) + molalrgnrdgb(5) = 0.D0 + 100 CALL POPCONTROL2B(branch) + IF (branch < 2) THEN + IF (branch == 0) THEN + psi4gb = 0.D0 + psi4gnrdgb = 0.D0 + ELSE + psi4gb = frnh4gb + psi4gnrdgb = frnh4gnrdgb + END IF + wgb(2) = wgb(2) + molalrgb(4) + wgb(1) = wgb(1) - 0.5d0*molalrgb(4) + molalrgb(4) = 0.D0 + molalrgnrdgb(4) = 0.D0 + ELSE + IF (branch == 2) THEN + psi4gb = 0.D0 + psi4gnrdgb = 0.D0 + ELSE + wgb(2) = wgb(2) + 2.d0*frnh4gb + wgb(1) = wgb(1) - frnh4gb + psi4gb = frnh4gb + psi4gnrdgb = frnh4gnrdgb + END IF + molalrgb(4) = 0.D0 + molalrgnrdgb(4) = 0.D0 + END IF + wgb(1) = wgb(1) + 0.5*molalrgb(2) + molalrgb(2) = 0.D0 + molalrgnrdgb(2) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch /= 0) chi6gb = chi6gb + ghclgb + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + chi5gb = chi5gb + ghno3gb + psi5gb = psi5gb - ghno3gb + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + chi4gb = chi4gb + gnh3gb + psi4gb = psi4gb - gnh3gb + END IF + CALL POPREAL8(molal(1)) + higb = molalgb(1) + molalgb(1) = 0.D0 + CALL POPREAL8(molalgnrd(1)) + hignrdgb = molalgnrdgb(1) + molalgnrdgb(1) = 0.D0 + CALL CALCPH_GNRD_GB(smin, smingb, smingnrd, smingnrdgb, hi, higb + + , hignrd, hignrdgb, ohi) + CALL POPREAL8(smin) + psi5gb = psi5gb + molalgb(7) + smingb + psi4gb = psi4gb - smingb + CALL POPREAL8(smingnrd) + psi5gnrdgb = psi5gnrdgb + molalgnrdgb(7) + smingnrdgb + psi4gnrdgb = psi4gnrdgb - smingnrdgb + CALL POPREAL8(molal(7)) + molalgb(7) = 0.D0 + CALL POPREAL8(molalgnrd(7)) + molalgnrdgb(7) = 0.D0 + CALL POPREAL8(molal(6)) + molalgb(6) = 0.D0 + CALL POPREAL8(molalgnrd(6)) + molalgnrdgb(6) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(molal(5)) + wgb(2) = wgb(2) + molalgb(5) + molalgb(5) = 0.D0 + CALL POPREAL8(molalgnrd(5)) + molalgnrdgb(5) = 0.D0 + CALL POPREAL8(molal(3)) + wgb(2) = wgb(2) + 2.d0*molalgb(3) + wgb(1) = wgb(1) - molalgb(3) + psi4gb = psi4gb + molalgb(3) + molalgb(3) = 0.D0 + CALL POPREAL8(molalgnrd(3)) + psi4gnrdgb = psi4gnrdgb + molalgnrdgb(3) + molalgnrdgb(3) = 0.D0 + ELSE + CALL POPREAL8(molal(5)) + wgb(1) = wgb(1) + 0.5d0*molalgb(5) + molalgb(5) = 0.D0 + CALL POPREAL8(molalgnrd(5)) + molalgnrdgb(5) = 0.D0 + CALL POPREAL8(molal(3)) + psi4gb = psi4gb + molalgb(3) + molalgb(3) = 0.D0 + CALL POPREAL8(molalgnrd(3)) + psi4gnrdgb = psi4gnrdgb + molalgnrdgb(3) + molalgnrdgb(3) = 0.D0 + END IF + CALL POPREAL8(molal(4)) + molalgb(4) = 0.D0 + CALL POPREAL8(molalgnrd(4)) + molalgnrdgb(4) = 0.D0 + CALL POPREAL8(molal(2)) + wgb(1) = wgb(1) + molalgb(2) + molalgb(2) = 0.D0 + CALL POPREAL8(molalgnrd(2)) + molalgnrdgb(2) = 0.D0 + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + bbgb = -(0.5d0*psi4gb) + result1gb = -(0.5d0*psi4gb) + bbgnrdgb = -(0.5d0*psi4gnrdgb) + result1gnrdgb = -(0.5d0*psi4gnrdgb) + IF (dd == 0.0) THEN + ddgb = 0.0 + ELSE + ddgb = result1gb/(2.0*SQRT(dd)) + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ddgnrdgb = 0.D0 + ELSE + temp17 = SQRT(dd) + temp17gb3 = result1gnrdgb/(2.0*temp17) + ddgnrdgb = temp17gb3 + IF (.NOT.dd == 0.0) ddgb = ddgb - ddgnrd*temp17gb3/(2.0* + + temp17**2) + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(dd) + bbgb = bbgb + 2*bbgnrd*ddgnrdgb + 2*bb*ddgb + ccgb = -(4.d0*ddgb) + CALL POPREAL8(ddgnrd) + bbgnrdgb = bbgnrdgb + 2*bb*ddgnrdgb + ccgnrdgb = -(4.d0*ddgnrdgb) + ELSE + CALL POPREAL8(ddgnrd) + CALL POPREAL8(dd) + ccgnrdgb = 0.D0 + ccgb = 0.D0 + END IF + temp17gb2 = bbgnrdgb/a4**2 + temp17gb1 = 2.d0*ccgnrdgb/a4**2 + temp17gb0 = -(2.d0*ccgb/a4) + chi4gb = chi4gb + (psi6gnrd+psi5gnrd)*ccgnrdgb - bbgb + (psi6+ + + psi5)*ccgb + psi5gb = psi5gb + chi4*ccgb - bbgb + psi2gb = psi2gb + a4gnrd*temp17gb1 + temp17gb0 + a4gb = bbgb/a4**2 - a4gnrd*2*temp17gb2/a4 - psi2*a4gnrd*2* + + temp17gb1/a4 - psi2*temp17gb0/a4 + psi5gnrdgb = psi5gnrdgb + chi4*ccgnrdgb - bbgnrdgb + a4gnrdgb = temp17gb2 + psi2*temp17gb1 + CALL POPREAL8(bb) + CALL POPREAL8(bbgnrd) + ELSE + a4gb = 0.D0 + a4gnrdgb = 0.D0 + END IF + a5 = xk4*r*temp*(water/gama(10))**2.0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + temp7 = a6/a5 + temp8 = psi6 + (chi6-psi6)*temp7 + temp15gb0 = psi5gnrdgb/temp8**2 + temp13 = a6/a5 + temp14 = psi6 + (chi6-psi6)*temp13 + temp14gb = psi6gnrd*temp15gb0 + temp13gb = (chi6-psi6)*chi5*temp14gb/a5 + temp12 = a5**2 + temp9 = (chi6-psi6)/temp12 + temp10 = a6gnrd*a5 - a6*a5gnrd + temp11 = psi6gnrd + temp10*temp9 - psi6gnrd*a6/a5 + temp11gb = -(psi6*chi5*temp15gb0) + temp10gb = temp9*temp11gb + temp9gb = temp10*temp11gb/temp12 + temp9gb0 = -(psi6gnrd*temp11gb/a5) + temp8gb = -((psi6gnrd*(chi5*temp14)-psi6*(chi5*temp11))*2* + + temp15gb0/temp8) + temp7gb = (chi6-psi6)*temp8gb/a5 + CALL POPREAL8(psi5) + temp15 = a6/a5 + temp16 = psi6 + (chi6-psi6)*temp15 + temp17gb = psi6*psi5gb/temp16 + temp16gb = -(chi5*temp17gb/temp16) + temp15gb = (chi6-psi6)*temp16gb/a5 + chi5gb = chi5gb + temp14*temp14gb - psi6*temp11*temp15gb0 + + + temp17gb + chi6gb = chi6gb + chi5*temp13*temp14gb + temp9gb + temp7* + + temp8gb + temp15*temp16gb + a6gb = a6gb + temp13gb - a5gnrd*temp10gb + temp9gb0 + temp7gb + + + temp15gb + a5gb = a6gnrd*temp10gb - temp13*temp13gb - temp9*2*a5*temp9gb + + - a6*temp9gb0/a5 - temp7*temp7gb - temp15*temp15gb + CALL POPREAL8(psi5gnrd) + a6gnrdgb = a6gnrdgb + a5*temp10gb + a5gnrdgb = -(a6*temp10gb) + ELSE + CALL POPREAL8(psi5gnrd) + CALL POPREAL8(psi5) + a5gb = 0.D0 + a5gnrdgb = 0.D0 + END IF + temp1 = xkw*gama(5)**3 + temp0 = gama(10)/temp1 + temp1gb0 = xk2*2.0*r*temp*a4gnrdgb + temp1gb = temp0*temp1gb0 + temp0gb = (gamagnrd(10)*gama(5)-gama(10)*gamagnrd(5))*temp1gb0/ + + temp1 + temp2 = gama(10)/gama(5) + temp2gb = 2.0*temp2*xk2*r*temp*a4gb/(xkw*gama(5)) + temp3 = gama(10)**3 + temp3gb1 = xk4*2.0*r*temp*a5gnrdgb + temp3gb = water*temp3gb1/temp3 + temp3gb0 = (watergnrd*gama(10)-water*gamagnrd(10))*temp3gb1/ + + temp3 + temp4 = water/gama(10) + temp4gb = 2.0*temp4*xk4*r*temp*a5gb/gama(10) + temp5 = gama(11)**3 + temp5gb1 = xk3*2.0*r*temp*a6gnrdgb + temp5gb = water*temp5gb1/temp5 + temp5gb0 = (watergnrd*gama(11)-water*gamagnrd(11))*temp5gb1/ + + temp5 + CALL POPREAL8(a6) + temp6 = water/gama(11) + temp6gb = 2.0*temp6*xk3*r*temp*a6gb/gama(11) + watergb = watergb + temp5gb0 - gamagnrd(11)*temp5gb - gamagnrd( + + 10)*temp3gb + temp3gb0 + temp4gb + temp6gb + gamagb(11) = gamagb(11) + watergnrd*temp5gb - water*3*gama(11)** + + 2*temp5gb0/temp5 - temp6*temp6gb + CALL POPREAL8(a6gnrd) + watergnrdgb = watergnrdgb + gama(10)*temp3gb + gama(11)*temp5gb + gamagnrdgb(11) = gamagnrdgb(11) - water*temp5gb + gamagb(10) = gamagb(10) + watergnrd*temp3gb - water*3*gama(10)** + + 2*temp3gb0/temp3 + temp2gb - temp4*temp4gb + CALL POPREAL8(a5gnrd) + gamagnrdgb(10) = gamagnrdgb(10) + gama(5)*temp1gb - water* + + temp3gb + gamagb(5) = gamagb(5) + gamagnrd(10)*temp1gb - xkw*temp0*3*gama( + + 5)**2*temp0gb - temp2*temp2gb + CALL POPREAL8(a4gnrd) + gamagb(10) = gamagb(10) + temp0gb - gamagnrd(5)*temp1gb + gamagnrdgb(5) = gamagnrdgb(5) - gama(10)*temp1gb + gnh3gb = 0.D0 + ghno3gb = 0.D0 + ghclgb = 0.D0 + a6gb = 0.D0 + a6gnrdgb = 0.D0 + ENDDO + END + +C Differentiation of calcph_gnrd in reverse (adjoint) mode: +C gradient of useful results: hi hignrd +C with respect to varying inputs: water watergnrd gggnrd gg +C +C Differentiation of calcph in forward (tangent) mode: +C variations of useful results: hi +C with respect to varying inputs: water gg +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCPH +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCPH_GNRD_GB(gg, gggb, gggnrd, gggnrdgb, hi, higb, + + hignrd, hignrdgb, ohi) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: cn, gg, hi, ohi, bb, cc, dd + REAL*8 :: cngb, gggb, higb, ohigb, bbgb, ccgb, ddgb + REAL*8 :: cngnrd, gggnrd, hignrd, ohignrd, bbgnrd, ccgnrd, + + ddgnrd + REAL*8 :: cngnrdgb, gggnrdgb, hignrdgb, ohignrdgb, bbgnrdgb + + , ccgnrdgb, ddgnrdgb + REAL*8 :: akw + REAL*8 :: akwgb + REAL*8 :: akwgnrd + REAL*8 :: akwgnrdgb + REAL*8 :: result1 + REAL*8 :: result1gb + REAL*8 :: result1gnrd + REAL*8 :: result1gnrdgb + REAL*8 :: x2gnrd + REAL*8 :: x2gnrdgb + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x2gb + REAL*8 :: x1gnrd + REAL*8 :: x1gnrdgb + REAL*8 :: x1 + REAL*8 :: x1gb + INTRINSIC SQRT + INTEGER :: branch + REAL*8 :: temp2 + REAL*8 :: temp1 + REAL*8 :: temp0 + INTRINSIC ABS + REAL*8 :: temp2gb + REAL*8 :: temp0gb0 + REAL*8 :: temp0gb + REAL*8 :: temp3gb + REAL*8 :: abs3 + REAL*8 :: abs2 + REAL*8 :: abs1 + REAL*8 :: temp1gb +C + akwgnrd = xkw*rh*(watergnrd*water+water*watergnrd) + akw = xkw*rh*water*water + IF (akw >= 0.) THEN + abs1 = akw + ELSE + abs1 = -akw + END IF + IF (abs1 < tiny) THEN + CALL PUSHCONTROL1B(0) + cngnrd = 0.d0 + ELSE + cngnrd = akwgnrd/(2.0*SQRT(akw)) + CALL PUSHCONTROL1B(1) + END IF + cn = SQRT(akw) +C +C *** GG = (negative charge) - (positive charge) +C + IF (gg > tiny) THEN +C H+ in excess + bbgnrd = -gggnrd + bb = -gg + ccgnrd = -akwgnrd + cc = -akw + ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd + dd = bb*bb - 4.d0*cc + IF (dd >= 0.) THEN + abs2 = dd + ELSE + abs2 = -dd + END IF + IF (abs2 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + result1 = SQRT(dd) + x1 = 0.5d0*(-bb+result1) + IF (x1 < cn) THEN + cngb = higb + cngnrdgb = hignrdgb + x1gb = 0.D0 + x1gnrdgb = 0.D0 + ELSE + x1gb = higb + x1gnrdgb = hignrdgb + cngb = 0.D0 + cngnrdgb = 0.D0 + END IF + result1gb = 0.5d0*x1gb + bbgb = -(0.5d0*x1gb) + result1gnrdgb = 0.5d0*x1gnrdgb + bbgnrdgb = -(0.5d0*x1gnrdgb) + IF (dd == 0.0) THEN + ddgb = 0.0 + ELSE + ddgb = result1gb/(2.0*SQRT(dd)) + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ddgnrdgb = 0.D0 + ELSE + temp1 = SQRT(dd) + temp1gb = result1gnrdgb/(2.0*temp1) + ddgnrdgb = temp1gb + IF (.NOT.dd == 0.0) ddgb = ddgb - ddgnrd*temp1gb/(2.0*temp1 + + **2) + END IF + bbgb = bbgb + 2*bbgnrd*ddgnrdgb + 2*bb*ddgb + ccgb = -(4.d0*ddgb) + bbgnrdgb = bbgnrdgb + 2*bb*ddgnrdgb + ccgnrdgb = -(4.d0*ddgnrdgb) + akwgb = -ccgb + akwgnrdgb = -ccgnrdgb + gggb = -bbgb + gggnrdgb = -bbgnrdgb + ELSE +C OH- in excess + bbgnrd = gggnrd + bb = gg + ccgnrd = -akwgnrd + cc = -akw + ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd + dd = bb*bb - 4.d0*cc + IF (dd >= 0.) THEN + abs3 = dd + ELSE + abs3 = -dd + END IF + IF (abs3 < tiny) THEN + result1gnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + result1gnrd = ddgnrd/(2.0*SQRT(dd)) + CALL PUSHCONTROL1B(1) + END IF + result1 = SQRT(dd) + x2gnrd = 0.5d0*(result1gnrd-bbgnrd) + x2 = 0.5d0*(-bb+result1) + IF (x2 < cn) THEN + ohignrd = cngnrd + ohi = cn + CALL PUSHCONTROL1B(0) + ELSE + ohignrd = x2gnrd + ohi = x2 + CALL PUSHCONTROL1B(1) + END IF + temp3gb = hignrdgb/ohi**2 + akwgb = higb/ohi - ohignrd*temp3gb + ohigb = (akwgnrd-(akwgnrd*ohi-akw*ohignrd)*2/ohi)*temp3gb - akw* + + higb/ohi**2 + akwgnrdgb = ohi*temp3gb + ohignrdgb = -(akw*temp3gb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cngb = ohigb + cngnrdgb = ohignrdgb + x2gb = 0.D0 + x2gnrdgb = 0.D0 + ELSE + x2gb = ohigb + x2gnrdgb = ohignrdgb + cngb = 0.D0 + cngnrdgb = 0.D0 + END IF + result1gb = 0.5d0*x2gb + bbgb = -(0.5d0*x2gb) + result1gnrdgb = 0.5d0*x2gnrdgb + bbgnrdgb = -(0.5d0*x2gnrdgb) + IF (dd == 0.0) THEN + ddgb = 0.0 + ELSE + ddgb = result1gb/(2.0*SQRT(dd)) + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ddgnrdgb = 0.D0 + ELSE + temp2 = SQRT(dd) + temp2gb = result1gnrdgb/(2.0*temp2) + ddgnrdgb = temp2gb + IF (.NOT.dd == 0.0) ddgb = ddgb - ddgnrd*temp2gb/(2.0*temp2 + + **2) + END IF + bbgb = bbgb + 2*bbgnrd*ddgnrdgb + 2*bb*ddgb + ccgb = -(4.d0*ddgb) + bbgnrdgb = bbgnrdgb + 2*bb*ddgnrdgb + ccgnrdgb = -(4.d0*ddgnrdgb) + akwgb = akwgb - ccgb + akwgnrdgb = akwgnrdgb - ccgnrdgb + gggb = bbgb + gggnrdgb = bbgnrdgb + END IF + IF (.NOT.akw == 0.0) akwgb = akwgb + cngb/(2.0*SQRT(akw)) + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp0 = SQRT(akw) + temp0gb0 = cngnrdgb/(2.0*temp0) + akwgnrdgb = akwgnrdgb + temp0gb0 + IF (.NOT.akw == 0.0) akwgb = akwgb - akwgnrd*temp0gb0/(2.0* + + temp0**2) + END IF + temp0gb = xkw*rh*akwgnrdgb + watergb = 2*watergnrd*temp0gb + xkw*rh*2*water*akwgb + watergnrdgb = 2*water*temp0gb + END + +C Differentiation of calcact3p_gnrd in reverse (adjoint) mode: +C gradient of useful results: molal gama water molalgnrd +C gamagnrd watergnrd +C with respect to varying inputs: molal gama water molalgnrd +C gamagnrd watergnrd +C +C Differentiation of calcact3p in forward (tangent) mode: +C variations of useful results: gama +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3P_GNRD_GB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0gb(6, 4), siongb, hgb, chgb, f1gb(3), f2gb(4) + REAL*8 :: g0gnrd(6, 4), siongnrd, hgnrd, chgnrd, f1gnrd(3) + + , f2gnrd(4) + REAL*8 :: g0gnrdgb(6, 4), siongnrdgb, hgnrdgb, chgnrdgb, + + f1gnrdgb(3), f2gnrdgb(4) + REAL*8 :: mpl, xij, yji + REAL*8 :: mplgb, xijgb, yjigb + REAL*8 :: mplgnrd, xijgnrd, yjignrd + REAL*8 :: mplgnrdgb, xijgnrdgb, yjignrdgb + REAL*8 :: ionicgb, ionicgnrd, ionicgnrdgb + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01gb + REAL*8 :: g01gnrd + REAL*8 :: g01gnrdgb + REAL*8 :: g02 + REAL*8 :: g02gb + REAL*8 :: g02gnrd + REAL*8 :: g02gnrdgb + REAL*8 :: g03 + REAL*8 :: g03gb + REAL*8 :: g03gnrd + REAL*8 :: g03gnrdgb + REAL*8 :: g04 + REAL*8 :: g04gb + REAL*8 :: g04gnrd + REAL*8 :: g04gnrdgb + REAL*8 :: g05 + REAL*8 :: g05gb + REAL*8 :: g05gnrd + REAL*8 :: g05gnrdgb + REAL*8 :: g06 + REAL*8 :: g06gb + REAL*8 :: g06gnrd + REAL*8 :: g06gnrdgb + REAL*8 :: g07 + REAL*8 :: g07gb + REAL*8 :: g07gnrd + REAL*8 :: g07gnrdgb + REAL*8 :: g08 + REAL*8 :: g08gb + REAL*8 :: g08gnrd + REAL*8 :: g08gnrdgb + REAL*8 :: g09 + REAL*8 :: g09gb + REAL*8 :: g09gnrd + REAL*8 :: g09gnrdgb + REAL*8 :: g10 + REAL*8 :: g10gb + REAL*8 :: g10gnrd + REAL*8 :: g10gnrdgb + REAL*8 :: g11 + REAL*8 :: g11gb + REAL*8 :: g11gnrd + REAL*8 :: g11gnrdgb + REAL*8 :: g12 + REAL*8 :: g12gb + REAL*8 :: g12gnrd + REAL*8 :: g12gnrdgb + INTEGER :: j + REAL*8 :: x2gnrd + REAL*8 :: x2gnrdgb + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x2gb + REAL*8 :: x1gnrd + REAL*8 :: x1gnrdgb + REAL*8 :: x1 + REAL*8 :: x1gb + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT + INTEGER :: branch + REAL*8 :: temp2gb13 + REAL*8 :: temp2gb12 + REAL*8 :: temp2 + REAL*8 :: temp1 + REAL*8 :: temp2gb11 + REAL*8 :: temp0 + REAL*8 :: temp2gb10 + INTRINSIC ABS + REAL*8 :: temp2gb + REAL*8 :: temp0gb1 + REAL*8 :: temp0gb0 + REAL*8 :: temp1gb4 + REAL*8 :: temp1gb3 + REAL*8 :: temp1gb2 + INTEGER :: ii20 + REAL*8 :: temp1gb1 + REAL*8 :: temp1gb0 + REAL*8 :: temp2gb9 + REAL*8 :: temp2gb8 + REAL*8 :: temp2gb7 + REAL*8 :: temp2gb6 + REAL*8 :: temp2gb5 + REAL*8 :: temp2gb4 + REAL*8 :: temp2gb3 + REAL*8 :: temp2gb2 + REAL*8 :: temp2gb1 + REAL*8 :: temp0gb + REAL*8 :: temp2gb0 + INTRINSIC LOG + REAL*8 :: temp2gb25 + REAL*8 :: temp2gb24 + REAL*8 :: temp2gb23 + REAL*8 :: temp2gb22 + REAL*8 :: temp2gb21 + INTEGER :: ii10 + REAL*8 :: temp2gb20 + REAL*8 :: abs1 + REAL*8 :: temp1gb + REAL*8 :: temp2gb19 + REAL*8 :: temp2gb18 + REAL*8 :: temp2gb17 + REAL*8 :: temp2gb16 + REAL*8 :: temp2gb15 + REAL*8 :: temp2gb14 +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + ionicgnrd = 0.d0 + DO i=1,7 + ionicgnrd = ionicgnrd + z(i)**2*molalgnrd(i) + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + x1gnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1gnrd = (0.5d0*ionicgnrd*water-0.5d0*ionic*watergnrd)/water**2 + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHREAL8(ionicgnrd) + ionicgnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionicgnrd) + ionicgnrd = x1gnrd + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3_GNRD(ionic, ionicgnrd, temp, g01, g01gnrd, g02, + + g02gnrd, g03, g03gnrd, g04, g04gnrd, g05, g05gnrd + + , g06, g06gnrd, g07, g07gnrd, g08, g08gnrd, g09, + + g09gnrd, g10, g10gnrd, g11, g11gnrd, g12, g12gnrd + + ) + DO ii1=1,4 + DO ii2=1,6 + g0gnrd(ii2, ii1) = 0.d0 + ENDDO + ENDDO +C + g0gnrd(1, 1) = g11gnrd + g0(1, 1) = g11 + g0gnrd(1, 2) = g07gnrd + g0(1, 2) = g07 + g0gnrd(1, 3) = g08gnrd + g0(1, 3) = g08 + g0gnrd(1, 4) = g10gnrd + g0(1, 4) = g10 + g0gnrd(2, 1) = g01gnrd + g0(2, 1) = g01 + g0gnrd(2, 2) = g02gnrd + g0(2, 2) = g02 + g0gnrd(2, 3) = g12gnrd + g0(2, 3) = g12 + g0gnrd(2, 4) = g03gnrd + g0(2, 4) = g03 + g0gnrd(3, 1) = g06gnrd + g0(3, 1) = g06 + g0gnrd(3, 2) = g04gnrd + g0(3, 2) = g04 + g0gnrd(3, 3) = g09gnrd + g0(3, 3) = g09 + g0gnrd(3, 4) = g05gnrd + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + IF (ionic >= 0.) THEN + abs1 = ionic + ELSE + abs1 = -ionic + END IF + IF (abs1 < tiny) THEN + CALL PUSHCONTROL1B(0) + siongnrd = 0.d0 + ELSE + siongnrd = ionicgnrd/(2.0*SQRT(ionic)) + CALL PUSHCONTROL1B(1) + END IF + sion = SQRT(ionic) + hgnrd = (agama*siongnrd*(1.d0+sion)-agama*sion*siongnrd)/(1.d0+ + + sion)**2 + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 + DO ii1=1,3 + f1gnrd(ii1) = 0.d0 + ENDDO + DO ii1=1,4 + f2gnrd(ii1) = 0.d0 + ENDDO +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mplgnrd) + mplgnrd = (molalgnrd(i)*water-molal(i)*watergnrd)/water**2 + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + chgnrd = -(0.25d0*(zpl+zmi)**2*ionicgnrd/ionic**2) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xijgnrd = chgnrd*mpl + ch*mplgnrd + xij = ch*mpl + CALL PUSHREAL8(yjignrd) + yjignrd = ((chgnrd*molal(j+3)+ch*molalgnrd(j+3))*water-ch* + + molal(j+3)*watergnrd)/water**2 + yji = ch*molal(j+3)/water + f1gnrd(i) = f1gnrd(i) + yjignrd*(g0(i, j)+zpl*zmi*h) + yji*( + + g0gnrd(i, j)+zpl*zmi*hgnrd) + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2gnrd(j) = f2gnrd(j) + xijgnrd*(g0(i, j)+zpl*zmi*h) + xij*( + + g0gnrd(i, j)+zpl*zmi*hgnrd) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gamagnrd(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gamagnrd(1) = zz(1)*((f1gnrd(2)/z(2)+f2gnrd(1)/z(4))/(z(2)+z(4))- + + hgnrd) + CALL PUSHREAL8(gama(1)) + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gamagnrd(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gamagnrd(2) = zz(2)*((f1gnrd(2)/z(2)+f2gnrd(2)/z(5))/(z(2)+z(5))- + + hgnrd) + CALL PUSHREAL8(gama(2)) + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gamagnrd(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gamagnrd(3) = zz(3)*((f1gnrd(2)/z(2)+f2gnrd(4)/z(7))/(z(2)+z(7))- + + hgnrd) + CALL PUSHREAL8(gama(3)) + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gamagnrd(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gamagnrd(4) = zz(4)*((f1gnrd(3)/z(3)+f2gnrd(2)/z(5))/(z(3)+z(5))- + + hgnrd) + CALL PUSHREAL8(gama(4)) + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gamagnrd(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gamagnrd(5) = zz(5)*((f1gnrd(3)/z(3)+f2gnrd(4)/z(7))/(z(3)+z(7))- + + hgnrd) + CALL PUSHREAL8(gama(5)) + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gamagnrd(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gamagnrd(6) = zz(6)*((f1gnrd(3)/z(3)+f2gnrd(1)/z(4))/(z(3)+z(4))- + + hgnrd) + CALL PUSHREAL8(gama(6)) + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gamagnrd(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gamagnrd(7) = zz(7)*((f1gnrd(1)/z(1)+f2gnrd(2)/z(5))/(z(1)+z(5))- + + hgnrd) + CALL PUSHREAL8(gama(7)) + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gamagnrd(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gamagnrd(8) = zz(8)*((f1gnrd(1)/z(1)+f2gnrd(3)/z(6))/(z(1)+z(6))- + + hgnrd) + CALL PUSHREAL8(gama(8)) + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gamagnrd(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gamagnrd(9) = zz(9)*((f1gnrd(3)/z(3)+f2gnrd(3)/z(6))/(z(3)+z(6))- + + hgnrd) + CALL PUSHREAL8(gama(9)) + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gamagnrd(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gamagnrd(10) = zz(10)*((f1gnrd(1)/z(1)+f2gnrd(4)/z(7))/(z(1)+z(7)) + + -hgnrd) + CALL PUSHREAL8(gama(10)) + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gamagnrd(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gamagnrd(11) = zz(11)*((f1gnrd(1)/z(1)+f2gnrd(1)/z(4))/(z(1)+z(4)) + + -hgnrd) + CALL PUSHREAL8(gama(11)) + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gamagnrd(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gamagnrd(12) = zz(12)*((f1gnrd(2)/z(2)+f2gnrd(3)/z(6))/(z(2)+z(6)) + + -hgnrd) + CALL PUSHREAL8(gama(12)) + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gamagnrd(13)) +C LC ; SCAPE + gamagnrd(13) = 0.2d0*(3.d0*gamagnrd(4)+2.d0*gamagnrd(9)) + CALL PUSHREAL8(gama(13)) + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + x2gnrd = 0.d0 + ELSE + x2gnrd = gamagnrd(i) + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHREAL8(gamagnrd(i)) + gamagnrd(i) = 0.d0 + CALL PUSHREAL8(gama(i)) + gama(i) = -5.0d0 + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(gamagnrd(i)) + gamagnrd(i) = x2gnrd + CALL PUSHREAL8(gama(i)) + gama(i) = x2 + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + temp2gb25 = LOG(10.d0)*gamagnrdgb(i) + temp2 = 10.d0**gama(i) + gamagb(i) = gamagnrd(i)*temp2*LOG(10.d0)*temp2gb25 + 10.d0**gama + + (i)*LOG(10.d0)*gamagb(i) + gamagnrdgb(i) = temp2*temp2gb25 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(gama(i)) + gamagb(i) = 0.D0 + CALL POPREAL8(gamagnrd(i)) + gamagnrdgb(i) = 0.D0 + x2gb = 0.D0 + x2gnrdgb = 0.D0 + ELSE + CALL POPREAL8(gama(i)) + x2gb = gamagb(i) + gamagb(i) = 0.D0 + CALL POPREAL8(gamagnrd(i)) + x2gnrdgb = gamagnrdgb(i) + gamagnrdgb(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + gamagb(i) = gamagb(i) + x2gb + gamagnrdgb(i) = gamagnrdgb(i) + x2gnrdgb + END IF + ENDDO + CALL POPREAL8(gama(13)) + gamagb(4) = gamagb(4) + 0.2d0*3.d0*gamagb(13) + gamagb(9) = gamagb(9) + 0.2d0*2.d0*gamagb(13) + gamagb(13) = 0.D0 + CALL POPREAL8(gamagnrd(13)) + gamagnrdgb(4) = gamagnrdgb(4) + 0.2d0*3.d0*gamagnrdgb(13) + gamagnrdgb(9) = gamagnrdgb(9) + 0.2d0*2.d0*gamagnrdgb(13) + gamagnrdgb(13) = 0.D0 + DO ii10=1,3 + f1gb(ii10) = 0.D0 + ENDDO + DO ii10=1,4 + f2gb(ii10) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp2gb1 = zz(12)*gamagb(12)/(z(2)+z(6)) + f1gb(2) = f1gb(2) + temp2gb1/z(2) + f2gb(3) = f2gb(3) + temp2gb1/z(6) + hgb = -(zz(12)*gamagb(12)) + gamagb(12) = 0.D0 + DO ii10=1,3 + f1gnrdgb(ii10) = 0.D0 + ENDDO + DO ii10=1,4 + f2gnrdgb(ii10) = 0.D0 + ENDDO + CALL POPREAL8(gamagnrd(12)) + temp2gb2 = zz(12)*gamagnrdgb(12)/(z(2)+z(6)) + f1gnrdgb(2) = f1gnrdgb(2) + temp2gb2/z(2) + f2gnrdgb(3) = f2gnrdgb(3) + temp2gb2/z(6) + hgnrdgb = -(zz(12)*gamagnrdgb(12)) + gamagnrdgb(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp2gb3 = zz(11)*gamagb(11)/(z(1)+z(4)) + f2gb(1) = f2gb(1) + temp2gb3/z(4) + hgb = hgb - zz(11)*gamagb(11) + gamagb(11) = 0.D0 + CALL POPREAL8(gamagnrd(11)) + temp2gb5 = zz(11)*gamagnrdgb(11)/(z(1)+z(4)) + f2gnrdgb(1) = f2gnrdgb(1) + temp2gb5/z(4) + hgnrdgb = hgnrdgb - zz(11)*gamagnrdgb(11) + gamagnrdgb(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp2gb4 = zz(10)*gamagb(10)/(z(1)+z(7)) + f1gb(1) = f1gb(1) + temp2gb4/z(1) + temp2gb3/z(1) + f2gb(4) = f2gb(4) + temp2gb4/z(7) + hgb = hgb - zz(10)*gamagb(10) + gamagb(10) = 0.D0 + CALL POPREAL8(gamagnrd(10)) + temp2gb6 = zz(10)*gamagnrdgb(10)/(z(1)+z(7)) + f1gnrdgb(1) = f1gnrdgb(1) + temp2gb6/z(1) + temp2gb5/z(1) + f2gnrdgb(4) = f2gnrdgb(4) + temp2gb6/z(7) + hgnrdgb = hgnrdgb - zz(10)*gamagnrdgb(10) + gamagnrdgb(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp2gb7 = zz(9)*gamagb(9)/(z(3)+z(6)) + f1gb(3) = f1gb(3) + temp2gb7/z(3) + hgb = hgb - zz(9)*gamagb(9) + gamagb(9) = 0.D0 + CALL POPREAL8(gamagnrd(9)) + temp2gb9 = zz(9)*gamagnrdgb(9)/(z(3)+z(6)) + f1gnrdgb(3) = f1gnrdgb(3) + temp2gb9/z(3) + hgnrdgb = hgnrdgb - zz(9)*gamagnrdgb(9) + gamagnrdgb(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp2gb8 = zz(8)*gamagb(8)/(z(1)+z(6)) + f2gb(3) = f2gb(3) + temp2gb8/z(6) + temp2gb7/z(6) + hgb = hgb - zz(8)*gamagb(8) + gamagb(8) = 0.D0 + CALL POPREAL8(gamagnrd(8)) + temp2gb10 = zz(8)*gamagnrdgb(8)/(z(1)+z(6)) + f2gnrdgb(3) = f2gnrdgb(3) + temp2gb10/z(6) + temp2gb9/z(6) + hgnrdgb = hgnrdgb - zz(8)*gamagnrdgb(8) + gamagnrdgb(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp2gb11 = zz(7)*gamagb(7)/(z(1)+z(5)) + f1gb(1) = f1gb(1) + temp2gb11/z(1) + temp2gb8/z(1) + f2gb(2) = f2gb(2) + temp2gb11/z(5) + hgb = hgb - zz(7)*gamagb(7) + gamagb(7) = 0.D0 + CALL POPREAL8(gamagnrd(7)) + temp2gb12 = zz(7)*gamagnrdgb(7)/(z(1)+z(5)) + f1gnrdgb(1) = f1gnrdgb(1) + temp2gb12/z(1) + temp2gb10/z(1) + f2gnrdgb(2) = f2gnrdgb(2) + temp2gb12/z(5) + hgnrdgb = hgnrdgb - zz(7)*gamagnrdgb(7) + gamagnrdgb(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp2gb13 = zz(6)*gamagb(6)/(z(3)+z(4)) + f2gb(1) = f2gb(1) + temp2gb13/z(4) + hgb = hgb - zz(6)*gamagb(6) + gamagb(6) = 0.D0 + CALL POPREAL8(gamagnrd(6)) + temp2gb16 = zz(6)*gamagnrdgb(6)/(z(3)+z(4)) + f2gnrdgb(1) = f2gnrdgb(1) + temp2gb16/z(4) + hgnrdgb = hgnrdgb - zz(6)*gamagnrdgb(6) + gamagnrdgb(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp2gb14 = zz(5)*gamagb(5)/(z(3)+z(7)) + f2gb(4) = f2gb(4) + temp2gb14/z(7) + hgb = hgb - zz(5)*gamagb(5) + gamagb(5) = 0.D0 + CALL POPREAL8(gamagnrd(5)) + temp2gb17 = zz(5)*gamagnrdgb(5)/(z(3)+z(7)) + f2gnrdgb(4) = f2gnrdgb(4) + temp2gb17/z(7) + hgnrdgb = hgnrdgb - zz(5)*gamagnrdgb(5) + gamagnrdgb(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp2gb15 = zz(4)*gamagb(4)/(z(3)+z(5)) + f1gb(3) = f1gb(3) + temp2gb14/z(3) + temp2gb15/z(3) + temp2gb13/z( + + 3) + f2gb(2) = f2gb(2) + temp2gb15/z(5) + hgb = hgb - zz(4)*gamagb(4) + gamagb(4) = 0.D0 + CALL POPREAL8(gamagnrd(4)) + temp2gb18 = zz(4)*gamagnrdgb(4)/(z(3)+z(5)) + f1gnrdgb(3) = f1gnrdgb(3) + temp2gb17/z(3) + temp2gb18/z(3) + + + temp2gb16/z(3) + f2gnrdgb(2) = f2gnrdgb(2) + temp2gb18/z(5) + hgnrdgb = hgnrdgb - zz(4)*gamagnrdgb(4) + gamagnrdgb(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp2gb19 = zz(3)*gamagb(3)/(z(2)+z(7)) + f2gb(4) = f2gb(4) + temp2gb19/z(7) + hgb = hgb - zz(3)*gamagb(3) + gamagb(3) = 0.D0 + CALL POPREAL8(gamagnrd(3)) + temp2gb22 = zz(3)*gamagnrdgb(3)/(z(2)+z(7)) + f2gnrdgb(4) = f2gnrdgb(4) + temp2gb22/z(7) + hgnrdgb = hgnrdgb - zz(3)*gamagnrdgb(3) + gamagnrdgb(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp2gb20 = zz(2)*gamagb(2)/(z(2)+z(5)) + f2gb(2) = f2gb(2) + temp2gb20/z(5) + hgb = hgb - zz(2)*gamagb(2) + gamagb(2) = 0.D0 + CALL POPREAL8(gamagnrd(2)) + temp2gb23 = zz(2)*gamagnrdgb(2)/(z(2)+z(5)) + f2gnrdgb(2) = f2gnrdgb(2) + temp2gb23/z(5) + hgnrdgb = hgnrdgb - zz(2)*gamagnrdgb(2) + gamagnrdgb(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp2gb21 = zz(1)*gamagb(1)/(z(2)+z(4)) + f1gb(2) = f1gb(2) + temp2gb20/z(2) + temp2gb21/z(2) + temp2gb19/z( + + 2) + f2gb(1) = f2gb(1) + temp2gb21/z(4) + hgb = hgb - zz(1)*gamagb(1) + gamagb(1) = 0.D0 + CALL POPREAL8(gamagnrd(1)) + temp2gb24 = zz(1)*gamagnrdgb(1)/(z(2)+z(4)) + f1gnrdgb(2) = f1gnrdgb(2) + temp2gb23/z(2) + temp2gb24/z(2) + + + temp2gb22/z(2) + f2gnrdgb(1) = f2gnrdgb(1) + temp2gb24/z(4) + hgnrdgb = hgnrdgb - zz(1)*gamagnrdgb(1) + gamagnrdgb(1) = 0.D0 + ionicgb = 0.D0 + ionicgnrdgb = 0.D0 + DO ii10=1,4 + DO ii20=1,6 + g0gb(ii20, ii10) = 0.D0 + ENDDO + ENDDO + DO ii10=1,4 + DO ii20=1,6 + g0gnrdgb(ii20, ii10) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mplgnrdgb = 0.D0 + mplgb = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijgb = (g0gnrd(i, j)+zpl*zmi*hgnrd)*f2gnrdgb(j) + (g0(i, j)+ + + zpl*zmi*h)*f2gb(j) + chgnrd = -(0.25d0*(zpl+zmi)**2*ionicgnrd/ionic**2) + xijgnrd = chgnrd*mpl + ch*mplgnrd + xijgnrdgb = (g0(i, j)+zpl*zmi*h)*f2gnrdgb(j) + yji = ch*molal(j+3)/water + g0gb(i, j) = g0gb(i, j) + xijgnrd*f2gnrdgb(j) + yjignrd* + + f1gnrdgb(i) + yji*f1gb(i) + xij*f2gb(j) + hgb = hgb + xijgnrd*zpl*zmi*f2gnrdgb(j) + yjignrd*zpl*zmi* + + f1gnrdgb(i) + yji*zpl*zmi*f1gb(i) + xij*zpl*zmi*f2gb(j) + g0gnrdgb(i, j) = g0gnrdgb(i, j) + yji*f1gnrdgb(i) + xij* + + f2gnrdgb(j) + hgnrdgb = hgnrdgb + yji*zpl*zmi*f1gnrdgb(i) + xij*zpl*zmi* + + f2gnrdgb(j) + yjigb = (g0gnrd(i, j)+zpl*zmi*hgnrd)*f1gnrdgb(i) + (g0(i, j)+ + + zpl*zmi*h)*f1gb(i) + yjignrdgb = (g0(i, j)+zpl*zmi*h)*f1gnrdgb(i) + temp2gb = molal(j+3)*yjigb/water + CALL POPREAL8(yjignrd) + temp2gb0 = yjignrdgb/water**2 + temp1gb2 = water*temp2gb0 + molalgb(j+3) = molalgb(j+3) + chgnrd*temp1gb2 - ch*watergnrd* + + temp2gb0 + ch*yjigb/water + temp1 = chgnrd*molal(j+3) + ch*molalgnrd(j+3) + watergb = watergb + (temp1-(temp1*water-molal(j+3)*(ch* + + watergnrd))*2/water)*temp2gb0 - ch*temp2gb/water + temp1gb3 = -(molal(j+3)*temp2gb0) + chgb = molalgnrd(j+3)*temp1gb2 + watergnrd*temp1gb3 + mplgnrd* + + xijgnrdgb + mpl*xijgb + temp2gb + chgnrdgb = mpl*xijgnrdgb + molal(j+3)*temp1gb2 + molalgnrdgb(j+3) = molalgnrdgb(j+3) + ch*temp1gb2 + watergnrdgb = watergnrdgb + ch*temp1gb3 + mplgb = mplgb + chgnrd*xijgnrdgb + ch*xijgb + mplgnrdgb = mplgnrdgb + ch*xijgnrdgb + temp1gb4 = -((zpl+zmi)**2*0.25d0*chgnrdgb/ionic**2) + ionicgb = ionicgb - ionicgnrd*2*temp1gb4/ionic - (zpl+zmi)**2* + + 0.25d0*chgb/ionic**2 + ionicgnrdgb = ionicgnrdgb + temp1gb4 + ENDDO + temp1gb1 = mplgnrdgb/water**2 + CALL POPREAL8(mpl) + molalgb(i) = molalgb(i) + mplgb/water - watergnrd*temp1gb1 + watergb = watergb + (molalgnrd(i)-(molalgnrd(i)*water-molal(i)* + + watergnrd)*2/water)*temp1gb1 - molal(i)*mplgb/water**2 + CALL POPREAL8(mplgnrd) + molalgnrdgb(i) = molalgnrdgb(i) + water*temp1gb1 + watergnrdgb = watergnrdgb - molal(i)*temp1gb1 + CALL POPREAL8(zpl) + ENDDO + temp1gb0 = hgnrdgb/(sion+1.d0)**2 + temp1gb = agama*hgb/(sion+1.d0) + siongb = (1.D0-sion/(sion+1.d0))*temp1gb - (agama*(siongnrd*(sion+ + + 1.d0))-agama*(sion*siongnrd))*2*temp1gb0/(sion+1.d0) + siongnrdgb = (agama*(sion+1.d0)-agama*sion)*temp1gb0 + IF (.NOT.ionic == 0.0) ionicgb = ionicgb + siongb/(2.0*SQRT( + + ionic)) + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp0 = SQRT(ionic) + temp0gb1 = siongnrdgb/(2.0*temp0) + ionicgnrdgb = ionicgnrdgb + temp0gb1 + IF (.NOT.ionic == 0.0) ionicgb = ionicgb - ionicgnrd*temp0gb1/ + + (2.0*temp0**2) + END IF + g05gb = g0gb(3, 4) + g0gb(3, 4) = 0.D0 + g05gnrdgb = g0gnrdgb(3, 4) + g0gnrdgb(3, 4) = 0.D0 + g09gb = g0gb(3, 3) + g0gb(3, 3) = 0.D0 + g09gnrdgb = g0gnrdgb(3, 3) + g0gnrdgb(3, 3) = 0.D0 + g04gb = g0gb(3, 2) + g0gb(3, 2) = 0.D0 + g04gnrdgb = g0gnrdgb(3, 2) + g0gnrdgb(3, 2) = 0.D0 + g06gb = g0gb(3, 1) + g0gb(3, 1) = 0.D0 + g06gnrdgb = g0gnrdgb(3, 1) + g0gnrdgb(3, 1) = 0.D0 + g03gb = g0gb(2, 4) + g0gb(2, 4) = 0.D0 + g03gnrdgb = g0gnrdgb(2, 4) + g0gnrdgb(2, 4) = 0.D0 + g12gb = g0gb(2, 3) + g0gb(2, 3) = 0.D0 + g12gnrdgb = g0gnrdgb(2, 3) + g0gnrdgb(2, 3) = 0.D0 + g02gb = g0gb(2, 2) + g0gb(2, 2) = 0.D0 + g02gnrdgb = g0gnrdgb(2, 2) + g0gnrdgb(2, 2) = 0.D0 + g01gb = g0gb(2, 1) + g0gb(2, 1) = 0.D0 + g01gnrdgb = g0gnrdgb(2, 1) + g0gnrdgb(2, 1) = 0.D0 + g10gb = g0gb(1, 4) + g0gb(1, 4) = 0.D0 + g10gnrdgb = g0gnrdgb(1, 4) + g0gnrdgb(1, 4) = 0.D0 + g08gb = g0gb(1, 3) + g0gb(1, 3) = 0.D0 + g08gnrdgb = g0gnrdgb(1, 3) + g0gnrdgb(1, 3) = 0.D0 + g07gb = g0gb(1, 2) + g0gb(1, 2) = 0.D0 + g07gnrdgb = g0gnrdgb(1, 2) + g0gnrdgb(1, 2) = 0.D0 + g11gb = g0gb(1, 1) + g11gnrdgb = g0gnrdgb(1, 1) + CALL KMFUL3_GNRD_GB(ionic, ionicgb, ionicgnrd, ionicgnrdgb, temp, + + g01, g01gb, g01gnrd, g01gnrdgb, g02, g02gb, + + g02gnrd, g02gnrdgb, g03, g03gb, g03gnrd, + + g03gnrdgb, g04, g04gb, g04gnrd, g04gnrdgb, g05 + + , g05gb, g05gnrd, g05gnrdgb, g06, g06gb, + + g06gnrd, g06gnrdgb, g07, g07gb, g07gnrd, + + g07gnrdgb, g08, g08gb, g08gnrd, g08gnrdgb, g09 + + , g09gb, g09gnrd, g09gnrdgb, g10, g10gb, + + g10gnrd, g10gnrdgb, g11, g11gb, g11gnrd, + + g11gnrdgb, g12, g12gb, g12gnrd, g12gnrdgb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionicgnrd) + CALL POPREAL8(ionic) + x1gb = 0.D0 + x1gnrdgb = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1gb = ionicgb + CALL POPREAL8(ionicgnrd) + x1gnrdgb = ionicgnrdgb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ionicgb = 0.D0 + ionicgnrdgb = 0.D0 + ELSE + temp0gb0 = x1gnrdgb/water**2 + temp0gb = 0.5d0*x1gb/water + ionicgb = temp0gb - 0.5d0*watergnrd*temp0gb0 + watergb = watergb + (0.5d0*ionicgnrd-(0.5d0*(ionicgnrd*water)- + + 0.5d0*(ionic*watergnrd))*2/water)*temp0gb0 - ionic*temp0gb/ + + water + ionicgnrdgb = 0.5d0*water*temp0gb0 + watergnrdgb = watergnrdgb - 0.5d0*ionic*temp0gb0 + END IF + DO i=7,1,-1 + molalgb(i) = molalgb(i) + z(i)**2*ionicgb + molalgnrdgb(i) = molalgnrdgb(i) + z(i)**2*ionicgnrdgb + ENDDO + END + +C Differentiation of kmful3_gnrd in reverse (adjoint) mode: +C gradient of useful results: g05gnrd g01 g02 g03 g04 g05 +C g06 g01gnrd g07 g08 ionicgnrd g09 g06gnrd g02gnrd +C g10 g11 g07gnrd g12 g10gnrd g03gnrd ionic g08gnrd +C g11gnrd g04gnrd g09gnrd g12gnrd +C with respect to varying inputs: ionicgnrd ionic +C +C Differentiation of kmful3 in forward (tangent) mode: +C variations of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_GNRD_GB(ionic, ionicgb, ionicgnrd, ionicgnrdgb, + + temp, g01, g01gb, g01gnrd, g01gnrdgb, + + g02, g02gb, g02gnrd, g02gnrdgb, g03, + + g03gb, g03gnrd, g03gnrdgb, g04, g04gb, + + g04gnrd, g04gnrdgb, g05, g05gb, g05gnrd + + , g05gnrdgb, g06, g06gb, g06gnrd, + + g06gnrdgb, g07, g07gb, g07gnrd, + + g07gnrdgb, g08, g08gb, g08gnrd, + + g08gnrdgb, g09, g09gb, g09gnrd, + + g09gnrdgb, g10, g10gb, g10gnrd, + + g10gnrdgb, g11, g11gb, g11gnrd, + + g11gnrdgb, g12, g12gb, g12gnrd, + + g12gnrdgb) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionicgb, siongb, cf2gb + REAL*8 :: ionicgnrd, siongnrd, cf2gnrd + REAL*8 :: ionicgnrdgb, siongnrdgb, cf2gnrdgb + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01gb, g02gb, g03gb, g04gb, g05gb, g06gb, g07gb, + + g08gb, g09gb, g10gb, g11gb, g12gb + REAL*8 :: g01gnrd, g02gnrd, g03gnrd, g04gnrd, g05gnrd, + + g06gnrd, g07gnrd, g08gnrd, g09gnrd, g10gnrd, + + g11gnrd, g12gnrd + REAL*8 :: g01gnrdgb, g02gnrdgb, g03gnrdgb, g04gnrdgb, + + g05gnrdgb, g06gnrdgb, g07gnrdgb, g08gnrdgb, + + g09gnrdgb, g10gnrdgb, g11gnrdgb, g12gnrdgb + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTRINSIC ABS + REAL*8 :: abs1, tiny + INTRINSIC SQRT + INTEGER :: branch + REAL*8 :: temp0 + REAL*8 :: temp1gb3 + REAL*8 :: temp1gb2 + REAL*8 :: temp1gb1 + REAL*8 :: temp1gb0 + REAL*8 :: temp0gb + REAL*8 :: abs2 + REAL*8 :: temp1gb + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + tiny = 1.d-20 + IF (ionic >= 0.) THEN + abs2 = ionic + ELSE + abs2 = -ionic + END IF + IF (abs2 < tiny) THEN + CALL PUSHCONTROL1B(0) + siongnrd = 0.d0 + ELSE + siongnrd = ionicgnrd/(2.0*SQRT(ionic)) + CALL PUSHCONTROL1B(1) + END IF + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.d0) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01gb = g01gb + g12gb + g08gb = g08gb + g09gb + g12gb + g11gb = g11gb - g09gb - g12gb + g01gnrdgb = g01gnrdgb + g12gnrdgb + g08gnrdgb = g08gnrdgb + g09gnrdgb + g12gnrdgb + g11gnrdgb = g11gnrdgb - g09gnrdgb - g12gnrdgb + g06gb = g06gb + g09gb + g06gnrdgb = g06gnrdgb + g09gnrdgb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2gb = -(z10*g10gb) - z07*g07gb - z05*g05gb - z03*g03gb - z01* + + g01gb - z02*g02gb - z04*g04gb - z06*g06gb - z08*g08gb - z11* + + g11gb + g11gb = cf1*g11gb + cf2gnrdgb = -(z10*g10gnrdgb) - z07*g07gnrdgb - z05*g05gnrdgb - + + z03*g03gnrdgb - z01*g01gnrdgb - z02*g02gnrdgb - z04*g04gnrdgb + + - z06*g06gnrdgb - z08*g08gnrdgb - z11*g11gnrdgb + g11gnrdgb = cf1*g11gnrdgb + g10gb = cf1*g10gb + g10gnrdgb = cf1*g10gnrdgb + g08gb = cf1*g08gb + g08gnrdgb = cf1*g08gnrdgb + g07gb = cf1*g07gb + g07gnrdgb = cf1*g07gnrdgb + g06gb = cf1*g06gb + g06gnrdgb = cf1*g06gnrdgb + g05gb = cf1*g05gb + g05gnrdgb = cf1*g05gnrdgb + g04gb = cf1*g04gb + g04gnrdgb = cf1*g04gnrdgb + g03gb = cf1*g03gb + g03gnrdgb = cf1*g03gnrdgb + g02gb = cf1*g02gb + g02gnrdgb = cf1*g02gnrdgb + g01gb = cf1*g01gb + g01gnrdgb = cf1*g01gnrdgb + temp1gb = (0.125d0-ti*0.005d0)*cf2gb + temp1gb0 = -(0.41d0*temp1gb/(sion+1.d0)) + temp1gb3 = (0.125d0-ti*0.005d0)*cf2gnrdgb + temp1gb1 = 0.92d0*0.039d0*temp1gb3 + ionicgb = ionicgb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp1gb - + + ionicgnrd*0.8d0*ionic**(-1.8D0)*temp1gb1 + temp1gb2 = -(temp1gb3/(sion+1.d0)**2) + siongb = (1.D0-sion/(sion+1.d0))*temp1gb0 - (0.41d0*(siongnrd*( + + sion+1.d0))-0.41d0*(sion*siongnrd))*2*temp1gb2/(sion+1.d0) + ionicgnrdgb = ionicgnrdgb + ionic**(-0.8d0)*temp1gb1 + siongnrdgb = (0.41d0*(sion+1.d0)-0.41d0*sion)*temp1gb2 + ELSE + siongb = 0.D0 + siongnrdgb = 0.D0 + END IF + CALL MKBI_GNRD_GB(q11, ionic, ionicgb, ionicgnrd, ionicgnrdgb, + + sion, siongb, siongnrd, siongnrdgb, z11, g11, + + g11gb, g11gnrd, g11gnrdgb) + CALL MKBI_GNRD_GB(q10, ionic, ionicgb, ionicgnrd, ionicgnrdgb, + + sion, siongb, siongnrd, siongnrdgb, z10, g10, + + g10gb, g10gnrd, g10gnrdgb) + CALL MKBI_GNRD_GB(q8, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion + + , siongb, siongnrd, siongnrdgb, z08, g08, g08gb + + , g08gnrd, g08gnrdgb) + CALL MKBI_GNRD_GB(q7, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion + + , siongb, siongnrd, siongnrdgb, z07, g07, g07gb + + , g07gnrd, g07gnrdgb) + CALL MKBI_GNRD_GB(q6, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion + + , siongb, siongnrd, siongnrdgb, z06, g06, g06gb + + , g06gnrd, g06gnrdgb) + CALL MKBI_GNRD_GB(q5, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion + + , siongb, siongnrd, siongnrdgb, z05, g05, g05gb + + , g05gnrd, g05gnrdgb) + CALL MKBI_GNRD_GB(q4, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion + + , siongb, siongnrd, siongnrdgb, z04, g04, g04gb + + , g04gnrd, g04gnrdgb) + CALL MKBI_GNRD_GB(q3, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion + + , siongb, siongnrd, siongnrdgb, z03, g03, g03gb + + , g03gnrd, g03gnrdgb) + CALL MKBI_GNRD_GB(q2, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion + + , siongb, siongnrd, siongnrdgb, z02, g02, g02gb + + , g02gnrd, g02gnrdgb) + CALL MKBI_GNRD_GB(q1, ionic, ionicgb, ionicgnrd, ionicgnrdgb, sion + + , siongb, siongnrd, siongnrdgb, z01, g01, g01gb + + , g01gnrd, g01gnrdgb) + IF (.NOT.ionic == 0.0) ionicgb = ionicgb + siongb/(2.0*SQRT( + + ionic)) + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp0 = SQRT(ionic) + temp0gb = siongnrdgb/(2.0*temp0) + ionicgnrdgb = ionicgnrdgb + temp0gb + IF (.NOT.ionic == 0.0) ionicgb = ionicgb - ionicgnrd*temp0gb/( + + 2.0*temp0**2) + END IF + END + +C Differentiation of mkbi_gnrd in reverse (adjoint) mode: +C gradient of useful results: sion bignrd ionicgnrd bi ionic +C siongnrd +C with respect to varying inputs: sion ionicgnrd ionic siongnrd +C +C Differentiation of mkbi in forward (tangent) mode: +C variations of useful results: bi +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_GNRD_GB(q, ionic, ionicgb, ionicgnrd, ionicgnrdgb + + , sion, siongb, siongnrd, siongnrdgb, zip + + , bi, bigb, bignrd, bignrdgb) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionicgb, siongb, bigb + REAL*8 :: ionicgnrd, siongnrd, bignrd + REAL*8 :: ionicgnrdgb, siongnrdgb, bignrdgb + REAL*8 :: b, c, xx + REAL*8 :: cgb, xxgb + REAL*8 :: cgnrd, xxgnrd + REAL*8 :: cgnrdgb, xxgnrdgb + REAL*8 :: arg1 + REAL*8 :: arg1gb + REAL*8 :: arg1gnrd + REAL*8 :: arg1gnrdgb + REAL*8 :: pwx1 + REAL*8 :: pwx1gb + REAL*8 :: pwx1gnrd + REAL*8 :: pwx1gnrdgb + REAL*8 :: pwr1 + REAL*8 :: pwr1gb + REAL*8 :: pwr1gnrd, tiny + REAL*8 :: pwr1gnrdgb + INTRINSIC EXP + INTRINSIC LOG10 + INTEGER :: branch + REAL*8 :: tempgb2 + REAL*8 :: tempgb1 + REAL*8 :: tempgb0 + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: tempgb + INTRINSIC ABS + REAL*8 :: x1 + REAL*8 :: temp1gb3 + REAL*8 :: temp1gb2 + REAL*8 :: temp1gb1 + REAL*8 :: temp1gb0 + REAL*8 :: temp0gb + INTRINSIC LOG + INTRINSIC INT + REAL*8 :: abs3 + REAL*8 :: abs2 + REAL*8 :: abs1 + REAL*8 :: temp + REAL*8 :: temp1gb + tiny = 1.d-20 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + arg1gnrd = -(.023d0*((ionicgnrd*ionic+ionic*ionicgnrd)*ionic+ionic + + **2*ionicgnrd)) + arg1 = -(.023d0*ionic*ionic*ionic) + cgnrd = .055d0*q*arg1gnrd*EXP(arg1) + c = 1. + .055d0*q*EXP(arg1) + pwx1gnrd = .1d0*ionicgnrd + pwx1 = 1.d0 + .1d0*ionic + x1 = q - INT(q) + IF (x1 >= 0.) THEN + abs1 = x1 + ELSE + abs1 = -x1 + END IF + IF (pwx1 > 0.d0 .OR. (pwx1 < 0.d0 .AND. abs1 < tiny)) + +THEN + pwr1gnrd = q*pwx1**(q-1)*pwx1gnrd + CALL PUSHCONTROL2B(0) + ELSE + IF (pwx1 >= 0.) THEN + abs2 = pwx1 + ELSE + abs2 = -pwx1 + END IF + IF (q - 1.d0 >= 0.) THEN + abs3 = q - 1.d0 + ELSE + abs3 = -(q-1.d0) + END IF + IF (abs2 < tiny .AND. abs3 < tiny) THEN + pwr1gnrd = pwx1gnrd + CALL PUSHCONTROL2B(1) + ELSE + pwr1gnrd = 0.0 + CALL PUSHCONTROL2B(2) + END IF + END IF + pwr1 = pwx1**q + bignrd = b*pwr1gnrd + bi = 1.d0 + b*pwr1 - b +C + temp1 = LOG(10.d0) + temp1gb3 = zip*bignrdgb/(temp1*bi) + xxgb = zip*bigb + bigb = zip*bigb/(bi*LOG(10.0)) - bignrd*temp1gb3/bi + xxgnrdgb = zip*bignrdgb + bignrdgb = temp1gb3 + pwr1gb = b*bigb + pwr1gnrdgb = b*bignrdgb + IF (pwx1 <= 0.d0 .AND. (q == 0.d0 .OR. q /= INT(q))) THEN + pwx1gb = 0.d0 + ELSE + pwx1gb = q*pwx1**(q-1.d0)*pwr1gb + END IF + CALL POPCONTROL2B(branch) + IF (branch == 0) THEN + IF (.NOT.(pwx1 <= 0.d0 .AND. (q - 1.d0 == 0.d0 .OR. + + q - 1.d0 /= INT(q - 1.d0)))) pwx1gb = pwx1gb + + + pwx1gnrd*q*(q-1)*pwx1**(q-2)*pwr1gnrdgb + pwx1gnrdgb = q*pwx1**(q-1)*pwr1gnrdgb + ELSE IF (branch == 1) THEN + pwx1gnrdgb = pwr1gnrdgb + ELSE + pwx1gnrdgb = 0.D0 + END IF + temp = c*sion + 1.d0 + temp1gb2 = -(xxgnrdgb/temp**2) + temp1gb1 = 0.5107d0*siongnrd*temp1gb2 + temp0 = cgnrd*sion + c*siongnrd + temp0gb = -(0.5107d0*sion*temp1gb2) + tempgb1 = -((0.5107d0*(siongnrd*(c*sion+1.d0))-0.5107d0*(sion* + + temp0))*2*temp1gb2/temp) + temp1gb = -(0.5107d0*xxgb/(c*sion+1.d0)) + temp1gb0 = -(sion*temp1gb/(c*sion+1.d0)) + cgb = sion*temp1gb1 + siongnrd*temp0gb + sion*tempgb1 + sion* + + temp1gb0 + cgnrdgb = sion*temp0gb + tempgb2 = q*.055d0*cgnrdgb + arg1gb = arg1gnrd*EXP(arg1)*tempgb2 + q*.055d0*EXP(arg1)*cgb + arg1gnrdgb = EXP(arg1)*tempgb2 + tempgb = -(.023d0*arg1gnrdgb) + tempgb0 = ionic*tempgb + ionicgb = ionicgb + (ionicgnrd*2*ionic+ionicgnrd*ionic+ionic* + + ionicgnrd)*tempgb - .023d0*3*ionic**2*arg1gb + 2*ionicgnrd* + + tempgb0 + .1d0*pwx1gb + ionicgnrdgb = ionicgnrdgb + 2*ionic*tempgb0 + ionic**2*tempgb + + + .1d0*pwx1gnrdgb + siongb = siongb + c*temp1gb1 - 0.5107d0*temp0*temp1gb2 + cgnrd* + + temp0gb + c*tempgb1 + c*temp1gb0 + temp1gb + siongnrdgb = siongnrdgb + c*temp0gb + 0.5107d0*(c*sion+1.d0)* + + temp1gb2 + END + +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of funcg5ab in forward (tangent) mode: +C variations of useful results: fg5ab +C with respect to varying inputs: x +C RW status of diff variables: x:in fg5ab:out +C +C +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCG5A +C *** CASE G5 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCG5AB_GNRD(x, xgnrd, fg5ab, fg5abgnrd) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: psi4gnrd + REAL*8 :: psi5gnrd + REAL*8 :: psi6gnrd + REAL*8 :: a4gnrd + REAL*8 :: a5gnrd + REAL*8 :: a6gnrd +C + LOGICAL tst + REAL*8 :: molalrgnrd(npair) + INTEGER :: so4flg + REAL*8 :: lamda, fg5a + INTEGER :: i + REAL*8 :: akk + REAL*8 :: bb + REAL*8 :: bbgnrd + REAL*8 :: cc + REAL*8 :: ccgnrd + REAL*8 :: dd + REAL*8 :: ddgnrd + REAL*8 :: smin + REAL*8 :: smingnrd + REAL*8 :: hi + REAL*8 :: hignrd + REAL*8 :: ohi + INTEGER :: j + REAL*8 :: result1 + REAL*8 :: result1gnrd + REAL*8 :: x + REAL*8 :: xgnrd + REAL*8 :: fg5ab + REAL*8 :: fg5abgnrd + INTRINSIC MAX + INTRINSIC ABS + REAL*8 :: abs9 + REAL*8 :: abs8 + REAL*8 :: abs7 + REAL*8 :: abs6 + REAL*8 :: abs5 + REAL*8 :: abs4 + REAL*8 :: abs3 + REAL*8 :: abs2 + REAL*8 :: abs1 + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** SETUP PARAMETERS ************************************************ +C + psi6gnrd = xgnrd + psi6 = x + DO ii1=1,nions + molalgnrd(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + molalrgnrd(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + gamagnrd(ii1) = 0.D0 + ENDDO + watergnrd = 0.D0 + ghclgnrd = 0.D0 + a6gnrd = 0.D0 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C +C WRITE(*,*) 'NSWEEP ',NSWEEP,'WATER',WATER + DO i=1,2 +C + a1 = xk5*(water/gama(2))**3.0 + a2 = xk7*(water/gama(4))**3.0 + a4gnrd = xk2*r*temp*2.0*gama(10)*(gamagnrd(10)*gama(5)-gama(10)* + + gamagnrd(5))/(xkw*gama(5)**3) + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + a5gnrd = xk4*r*temp*2.0*water*(watergnrd*gama(10)-water*gamagnrd + + (10))/gama(10)**3 + a5 = xk4*r*temp*(water/gama(10))**2.0 + a6gnrd = xk3*r*temp*2.0*water*(watergnrd*gama(11)-water*gamagnrd + + (11))/gama(11)**3 + a6 = xk3*r*temp*(water/gama(11))**2.0 + akk = a4*a6 +C +C CALCULATE DISSOCIATION QUANTITIES +C + IF (chi5 >= tiny) THEN + psi5gnrd = (chi5*psi6gnrd*(a6/a5*(chi6-psi6)+psi6)-psi6*chi5*( + + (a6gnrd*a5-a6*a5gnrd)*(chi6-psi6)/a5**2-a6*psi6gnrd/a5+ + + psi6gnrd))/(a6/a5*(chi6-psi6)+psi6)**2 + psi5 = psi6*chi5/(a6/a5*(chi6-psi6)+psi6) + ELSE + psi5 = tiny + psi5gnrd = 0.D0 + END IF +C +CCC IF(CHI4 > TINY) THEN + IF (w(2) > tiny) THEN +C Accounts for NH3 evaporation + bbgnrd = -(psi6gnrd+psi5gnrd-a4gnrd/a4**2) + bb = -(chi4+psi6+psi5+1.d0/a4) + ccgnrd = chi4*(psi5gnrd+psi6gnrd) + 2.d0*psi2*a4gnrd/a4**2 + cc = chi4*(psi5+psi6) - 2.d0*psi2/a4 + IF (bb*bb - 4.d0*cc < zero) THEN + dd = zero + ddgnrd = 0.D0 + ELSE + ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd + dd = bb*bb - 4.d0*cc + END IF + IF (abs(dd) < tiny) THEN + result1gnrd = 0.D0 + ELSE + result1gnrd = ddgnrd/(2.0*SQRT(dd)) + END IF + result1 = SQRT(dd) + psi4gnrd = 0.5d0*(-bbgnrd-result1gnrd) + psi4 = 0.5d0*(-bb-result1) + ELSE + psi4 = tiny + psi4gnrd = 0.D0 + END IF +C +C *** CALCULATE SPECIATION ******************************************** +C +C NAI + molalgnrd(2) = 0.D0 + molal(2) = w(1) +C MOLAL (3) = 2.0*PSI2 + PSI4 ! NH4I +C CLI + molalgnrd(4) = psi6gnrd + molal(4) = psi6 + IF (w(2) - 0.5d0*w(1) > zero) THEN + molalgnrd(3) = psi4gnrd + molal(3) = 2.d0*w(2) - w(1) + psi4 +C SO4I + molalgnrd(5) = 0.D0 + molal(5) = w(2) + ELSE + molalgnrd(3) = psi4gnrd + molal(3) = psi4 +C SO4I + molalgnrd(5) = 0.D0 + molal(5) = 0.5d0*w(1) + END IF + molalgnrd(6) = 0.D0 + molal(6) = zero +C NO3I + molalgnrd(7) = psi5gnrd + molal(7) = psi5 +C +C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + smingnrd = psi5gnrd + psi6gnrd - psi4gnrd + smin = psi5 + psi6 - psi4 + CALL CALCPH_GNRD(smin, smingnrd, hi, hignrd, ohi) + molalgnrd(1) = hignrd + molal(1) = hi + IF (chi4 - psi4 < tiny) THEN + gnh3 = tiny + ELSE + gnh3 = chi4 - psi4 + END IF + IF (chi5 - psi5 < tiny) THEN + ghno3 = tiny + ELSE + ghno3 = chi5 - psi5 + END IF + IF (chi6 - psi6 < tiny) THEN + ghcl = tiny + ghclgnrd = 0.D0 + ELSE + ghclgnrd = -psi6gnrd + ghcl = chi6 - psi6 + END IF +C +C Solid (NH4)2SO4 + cnh42s4 = zero +C Solid NH4NO3 + cnh4no3 = zero +C Solid NH4Cl + cnh4cl = zero +C +C CALL CALCMR ! Water content +C +C WRITE(*,*) 'MOLAL ',MOLAL +C NA2SO4 + molalrgnrd(2) = 0.D0 + molalr(2) = 0.5d0*w(1) + IF (w(2) - 0.5d0*w(1) >= 0.) THEN + abs1 = w(2) - 0.5d0*w(1) + ELSE + abs1 = -(w(2)-0.5d0*w(1)) + END IF + IF (abs1 > tiny) THEN +C WRITE(*,*) 'W(2) - 0.5D0W(1) > ZERO' + molalrgnrd(4) = 0.D0 + molalr(4) = w(2) - 0.5d0*w(1) + IF (psi4 >= 0.) THEN + abs2 = psi4 + ELSE + abs2 = -psi4 + END IF + IF (abs2 > tiny) THEN +C FRNH4,2 = PSI4 + IF (psi5 < psi4) THEN +C + molalrgnrd(5) = psi5gnrd + molalr(5) = psi5 + IF (psi4 - psi5 >= 0.) THEN + abs3 = psi4 - psi5 + ELSE + abs3 = -(psi4-psi5) + END IF + IF (abs3 > tiny) THEN + IF (psi6 > psi4 - psi5) THEN + molalrgnrd(6) = psi4gnrd - psi5gnrd + molalr(6) = psi4 - psi5 + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + ELSE IF (psi6 > zero) THEN + molalrgnrd(6) = 0.D0 + molalr(6) = zero + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + ELSE +C FRNH4,2 = ZERO + molalrgnrd(5) = psi4gnrd + molalr(5) = psi4 + IF (psi6 > zero) THEN + molalrgnrd(6) = 0.D0 + molalr(6) = zero + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + END IF + ELSE + IF (psi5 >= 0.) THEN + abs4 = psi5 + ELSE + abs4 = -psi5 + END IF +C WRITE(*,*) 'MOLALR(4,5,6)',MOLALR(4),MOLALR(5),MOLALR(6) +C PAUSE + IF (abs4 < tiny) THEN + molalrgnrd(5) = psi5gnrd + molalr(5) = psi5 + IF (-psi5 >= 0.) THEN + abs5 = -psi5 + ELSE + abs5 = psi5 + END IF + IF (abs5 > tiny) THEN + IF (psi6 > -psi5) THEN + molalrgnrd(6) = -psi5gnrd + molalr(6) = -psi5 + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + ELSE IF (psi6 > zero) THEN + molalrgnrd(6) = 0.D0 + molalr(6) = zero + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + ELSE + molalrgnrd(5) = 0.D0 + molalr(5) = zero + IF (psi6 > zero) THEN + molalrgnrd(6) = 0.D0 + molalr(6) = zero + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + END IF + END IF + ELSE +C W(2) - 0.5D0W(1) < ZERO +C WRITE(*,*) 'W(2) - 0.5D0W(1) < ZERO' + molalrgnrd(4) = 0.D0 + molalr(4) = zero + IF (2.d0*psi2 + psi4 >= 0.) THEN + abs6 = 2.d0*psi2 + psi4 + ELSE + abs6 = -(2.d0*psi2+psi4) + END IF + IF (abs6 > tiny) THEN + IF (psi5 < 2.d0*w(2) - w(1) + psi4) THEN + molalrgnrd(5) = psi5gnrd + molalr(5) = psi5 + IF (2.d0*w(2) - w(1) + psi4 - psi5 >= 0.) THEN + abs7 = 2.d0*w(2) - w(1) + psi4 - psi5 + ELSE + abs7 = -(2.d0*w(2)-w(1)+psi4-psi5) + END IF + IF (abs7 > tiny) THEN + IF (psi6 > 2.d0*w(2) - w(1) + psi4 - psi5) THEN + molalrgnrd(6) = psi4gnrd - psi5gnrd + molalr(6) = 2.d0*w(2) - w(1) + psi4 - psi5 + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + ELSE IF (psi6 > zero) THEN + molalrgnrd(6) = 0.D0 + molalr(6) = zero + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + ELSE + molalrgnrd(5) = psi4gnrd + molalr(5) = 2.d0*w(2) - w(1) + psi4 + IF (psi6 > zero) THEN + molalrgnrd(6) = 0.D0 + molalr(6) = zero + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + END IF + ELSE + IF (psi5 >= 0.) THEN + abs8 = psi5 + ELSE + abs8 = -psi5 + END IF + IF (abs8 < tiny) THEN + molalrgnrd(5) = psi5gnrd + molalr(5) = psi5 + IF (-psi5 >= 0.) THEN + abs9 = -psi5 + ELSE + abs9 = psi5 + END IF + IF (abs9 < tiny) THEN + IF (psi6 > -psi5) THEN + molalrgnrd(6) = -psi5gnrd + molalr(6) = -psi5 + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + ELSE IF (psi6 > zero) THEN + molalrgnrd(6) = 0.D0 + molalr(6) = zero + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + ELSE + molalrgnrd(5) = 0.D0 + molalr(5) = zero + IF (psi6 > zero) THEN + molalrgnrd(6) = 0.D0 + molalr(6) = zero + ELSE + molalrgnrd(6) = psi6gnrd + molalr(6) = psi6 + END IF + END IF + END IF + END IF +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + watergnrd = 0.D0 + DO j=1,npair + watergnrd = watergnrd + molalrgnrd(j)/m0(j) + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + watergnrd = 0.D0 + ELSE + water = water + END IF +C WRITE(*,*) 'After CALCMR: WATER ',WATER +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3P_GNRD() + ENDDO +C +C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +C + fg5abgnrd = (((molalgnrd(1)*molal(4)+molal(1)*molalgnrd(4))*ghcl- + + molal(1)*molal(4)*ghclgnrd)*a6/ghcl**2-molal(1)*molal(4)*a6gnrd/ + + ghcl)/a6**2 + fg5ab = molal(1)*molal(4)/ghcl/a6 - one +CCC FUNCG5A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE +C + RETURN + END + +C +C Differentiation of calcph in forward (tangent) mode: +C variations of useful results: hi +C with respect to varying inputs: water gg +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCPH +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCPH_GNRD(gg, gggnrd, hi, hignrd, ohi) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: cn, gg, hi, ohi, bb, cc, dd + REAL*8 :: cngnrd, gggnrd, hignrd, ohignrd, bbgnrd, ccgnrd, + + ddgnrd + REAL*8 :: akw + REAL*8 :: akwgnrd + REAL*8 :: result1 + REAL*8 :: result1gnrd + REAL*8 :: x2gnrd + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x1gnrd + REAL*8 :: x1 + INTRINSIC SQRT +C + akwgnrd = xkw*rh*(watergnrd*water+water*watergnrd) + akw = xkw*rh*water*water + IF (abs(akw) < tiny) THEN + cngnrd = 0.D0 + ELSE + cngnrd = akwgnrd/(2.0*SQRT(akw)) + END IF + cn = SQRT(akw) +C +C *** GG = (negative charge) - (positive charge) +C + IF (gg > tiny) THEN +C H+ in excess + bbgnrd = -gggnrd + bb = -gg + ccgnrd = -akwgnrd + cc = -akw + ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd + dd = bb*bb - 4.d0*cc + IF (abs(dd) < tiny) THEN + result1gnrd = 0.D0 + ELSE + result1gnrd = ddgnrd/(2.0*SQRT(dd)) + END IF + result1 = SQRT(dd) + x1gnrd = 0.5d0*(result1gnrd-bbgnrd) + x1 = 0.5d0*(-bb+result1) + IF (x1 < cn) THEN + hignrd = cngnrd + hi = cn + ELSE + hignrd = x1gnrd + hi = x1 + END IF + ohi = akw/hi + ELSE +C OH- in excess + bbgnrd = gggnrd + bb = gg + ccgnrd = -akwgnrd + cc = -akw + ddgnrd = bbgnrd*bb + bb*bbgnrd - 4.d0*ccgnrd + dd = bb*bb - 4.d0*cc + IF (ABS(dd) < tiny) THEN + result1gnrd = 0.D0 + ELSE + result1gnrd = ddgnrd/(2.0*SQRT(dd)) + END IF + result1 = SQRT(dd) + x2gnrd = 0.5d0*(result1gnrd-bbgnrd) + x2 = 0.5d0*(-bb+result1) + IF (x2 < cn) THEN + ohignrd = cngnrd + ohi = cn + ELSE + ohignrd = x2gnrd + ohi = x2 + END IF + hignrd = (akwgnrd*ohi-akw*ohignrd)/ohi**2 + hi = akw/ohi + END IF +C + RETURN + END + +C Differentiation of calcact3p in forward (tangent) mode: +C variations of useful results: gama +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3P_GNRD() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0gnrd(6, 4), siongnrd, hgnrd, chgnrd, f1gnrd(3) + + , f2gnrd(4) + REAL*8 :: mpl, xij, yji + REAL*8 :: mplgnrd, xijgnrd, yjignrd, ionicgnrd + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01gnrd + REAL*8 :: g02 + REAL*8 :: g02gnrd + REAL*8 :: g03 + REAL*8 :: g03gnrd + REAL*8 :: g04 + REAL*8 :: g04gnrd + REAL*8 :: g05 + REAL*8 :: g05gnrd + REAL*8 :: g06 + REAL*8 :: g06gnrd + REAL*8 :: g07 + REAL*8 :: g07gnrd + REAL*8 :: g08 + REAL*8 :: g08gnrd + REAL*8 :: g09 + REAL*8 :: g09gnrd + REAL*8 :: g10 + REAL*8 :: g10gnrd + REAL*8 :: g11 + REAL*8 :: g11gnrd + REAL*8 :: g12 + REAL*8 :: g12gnrd + INTEGER :: j + REAL*8 :: x2gnrd + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x1gnrd + REAL*8 :: x1 + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + ionicgnrd = 0.D0 + DO i=1,7 + ionicgnrd = ionicgnrd + z(i)**2*molalgnrd(i) + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + x1gnrd = 0.D0 + ELSE + x1gnrd = (0.5d0*ionicgnrd*water-0.5d0*ionic*watergnrd)/water**2 + x1 = 0.5d0*ionic/water + END IF + IF (x1 < tiny) THEN + ionic = tiny + ionicgnrd = 0.D0 + ELSE + ionicgnrd = x1gnrd + ionic = x1 + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3_GNRD(ionic, ionicgnrd, temp, g01, g01gnrd, g02, + + g02gnrd, g03, g03gnrd, g04, g04gnrd, g05, g05gnrd + + , g06, g06gnrd, g07, g07gnrd, g08, g08gnrd, g09, + + g09gnrd, g10, g10gnrd, g11, g11gnrd, g12, g12gnrd + + ) + DO ii1=1,4 + DO ii2=1,6 + g0gnrd(ii2, ii1) = 0.D0 + ENDDO + ENDDO +C + g0gnrd(1, 1) = g11gnrd + g0(1, 1) = g11 + g0gnrd(1, 2) = g07gnrd + g0(1, 2) = g07 + g0gnrd(1, 3) = g08gnrd + g0(1, 3) = g08 + g0gnrd(1, 4) = g10gnrd + g0(1, 4) = g10 + g0gnrd(2, 1) = g01gnrd + g0(2, 1) = g01 + g0gnrd(2, 2) = g02gnrd + g0(2, 2) = g02 + g0gnrd(2, 3) = g12gnrd + g0(2, 3) = g12 + g0gnrd(2, 4) = g03gnrd + g0(2, 4) = g03 + g0gnrd(3, 1) = g06gnrd + g0(3, 1) = g06 + g0gnrd(3, 2) = g04gnrd + g0(3, 2) = g04 + g0gnrd(3, 3) = g09gnrd + g0(3, 3) = g09 + g0gnrd(3, 4) = g05gnrd + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + IF (abs(ionic) < tiny) THEN + siongnrd = 0.D0 + ELSE + siongnrd = ionicgnrd/(2.0*SQRT(ionic)) + END IF + sion = SQRT(ionic) + hgnrd = (agama*siongnrd*(1.d0+sion)-agama*sion*siongnrd)/(1.d0+ + + sion)**2 + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1gnrd(i) = 0.D0 + f1(i) = 0.d0 + f2gnrd(i) = 0.D0 + f2(i) = 0.d0 + ENDDO + f2gnrd(4) = 0.D0 + f2(4) = 0.d0 + DO ii1=1,3 + f1gnrd(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2gnrd(ii1) = 0.D0 + ENDDO +C + DO i=1,3 + zpl = z(i) + mplgnrd = (molalgnrd(i)*water-molal(i)*watergnrd)/water**2 + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + chgnrd = -(0.25d0*(zpl+zmi)**2*ionicgnrd/ionic**2) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xijgnrd = chgnrd*mpl + ch*mplgnrd + xij = ch*mpl + yjignrd = ((chgnrd*molal(j+3)+ch*molalgnrd(j+3))*water-ch* + + molal(j+3)*watergnrd)/water**2 + yji = ch*molal(j+3)/water + f1gnrd(i) = f1gnrd(i) + yjignrd*(g0(i, j)+zpl*zmi*h) + yji*( + + g0gnrd(i, j)+zpl*zmi*hgnrd) + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2gnrd(j) = f2gnrd(j) + xijgnrd*(g0(i, j)+zpl*zmi*h) + xij*( + + g0gnrd(i, j)+zpl*zmi*hgnrd) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gamagnrd(1) = zz(1)*((f1gnrd(2)/z(2)+f2gnrd(1)/z(4))/(z(2)+z(4))- + + hgnrd) + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gamagnrd(2) = zz(2)*((f1gnrd(2)/z(2)+f2gnrd(2)/z(5))/(z(2)+z(5))- + + hgnrd) + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gamagnrd(3) = zz(3)*((f1gnrd(2)/z(2)+f2gnrd(4)/z(7))/(z(2)+z(7))- + + hgnrd) + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gamagnrd(4) = zz(4)*((f1gnrd(3)/z(3)+f2gnrd(2)/z(5))/(z(3)+z(5))- + + hgnrd) + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gamagnrd(5) = zz(5)*((f1gnrd(3)/z(3)+f2gnrd(4)/z(7))/(z(3)+z(7))- + + hgnrd) + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gamagnrd(6) = zz(6)*((f1gnrd(3)/z(3)+f2gnrd(1)/z(4))/(z(3)+z(4))- + + hgnrd) + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gamagnrd(7) = zz(7)*((f1gnrd(1)/z(1)+f2gnrd(2)/z(5))/(z(1)+z(5))- + + hgnrd) + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gamagnrd(8) = zz(8)*((f1gnrd(1)/z(1)+f2gnrd(3)/z(6))/(z(1)+z(6))- + + hgnrd) + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gamagnrd(9) = zz(9)*((f1gnrd(3)/z(3)+f2gnrd(3)/z(6))/(z(3)+z(6))- + + hgnrd) + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gamagnrd(10) = zz(10)*((f1gnrd(1)/z(1)+f2gnrd(4)/z(7))/(z(1)+z(7)) + + -hgnrd) + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gamagnrd(11) = zz(11)*((f1gnrd(1)/z(1)+f2gnrd(1)/z(4))/(z(1)+z(4)) + + -hgnrd) + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gamagnrd(12) = zz(12)*((f1gnrd(2)/z(2)+f2gnrd(3)/z(6))/(z(2)+z(6)) + + -hgnrd) + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) +C LC ; SCAPE + gamagnrd(13) = 0.2d0*(3.d0*gamagnrd(4)+2.d0*gamagnrd(9)) + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + x2 = 5.0d0 + x2gnrd = 0.D0 + ELSE + x2gnrd = gamagnrd(i) + x2 = gama(i) + END IF + IF (x2 < -5.0d0) THEN + gamagnrd(i) = 0.D0 + gama(i) = -5.0d0 + ELSE + gamagnrd(i) = x2gnrd + gama(i) = x2 + END IF + gamagnrd(i) = 10.d0**gama(i)*LOG(10.d0)*gamagnrd(i) + gama(i) = 10.d0**gama(i) + ENDDO +C +C Increment ACTIVITY call counter + iclact = iclact + 1 +C +C *** END OF SUBROUTINE ACTIVITY **************************************** +C + RETURN + END + +C Differentiation of kmful3 in forward (tangent) mode: +C variations of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_GNRD(ionic, ionicgnrd, temp, g01, g01gnrd, g02, + + g02gnrd, g03, g03gnrd, g04, g04gnrd, g05, + + g05gnrd, g06, g06gnrd, g07, g07gnrd, g08, + + g08gnrd, g09, g09gnrd, g10, g10gnrd, g11, + + g11gnrd, g12, g12gnrd) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionicgnrd, siongnrd, cf2gnrd + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01gnrd, g02gnrd, g03gnrd, g04gnrd, g05gnrd, + + g06gnrd, g07gnrd, g08gnrd, g09gnrd, g10gnrd, + + g11gnrd, g12gnrd + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTRINSIC ABS + REAL*8 :: abs1, tiny + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ + tiny = 1.d-20 +C + IF (abs(ionic) < tiny) THEN + siongnrd = 0.D0 + ELSE + siongnrd = ionicgnrd/(2.0*SQRT(ionic)) + END IF + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C + CALL MKBI_GNRD(q1, ionic, ionicgnrd, sion, siongnrd, z01, g01, + + g01gnrd) + CALL MKBI_GNRD(q2, ionic, ionicgnrd, sion, siongnrd, z02, g02, + + g02gnrd) + CALL MKBI_GNRD(q3, ionic, ionicgnrd, sion, siongnrd, z03, g03, + + g03gnrd) + CALL MKBI_GNRD(q4, ionic, ionicgnrd, sion, siongnrd, z04, g04, + + g04gnrd) + CALL MKBI_GNRD(q5, ionic, ionicgnrd, sion, siongnrd, z05, g05, + + g05gnrd) + CALL MKBI_GNRD(q6, ionic, ionicgnrd, sion, siongnrd, z06, g06, + + g06gnrd) + CALL MKBI_GNRD(q7, ionic, ionicgnrd, sion, siongnrd, z07, g07, + + g07gnrd) + CALL MKBI_GNRD(q8, ionic, ionicgnrd, sion, siongnrd, z08, g08, + + g08gnrd) + CALL MKBI_GNRD(q10, ionic, ionicgnrd, sion, siongnrd, z10, g10, + + g10gnrd) + CALL MKBI_GNRD(q11, ionic, ionicgnrd, sion, siongnrd, z11, g11, + + g11gnrd) +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.d0) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + cf2gnrd = (0.125d0-0.005d0*ti)*(0.039d0*0.92d0*ionic**(-0.8D0)* + + ionicgnrd-(0.41d0*siongnrd*(1.d0+sion)-0.41d0*sion*siongnrd)/( + + 1.d0+sion)**2) + cf2 = (0.125d0-0.005d0*ti)*(0.039d0*ionic**0.92d0-0.41d0*sion/( + + 1.d0+sion)) + g01gnrd = cf1*g01gnrd - z01*cf2gnrd + g01 = cf1*g01 - cf2*z01 + g02gnrd = cf1*g02gnrd - z02*cf2gnrd + g02 = cf1*g02 - cf2*z02 + g03gnrd = cf1*g03gnrd - z03*cf2gnrd + g03 = cf1*g03 - cf2*z03 + g04gnrd = cf1*g04gnrd - z04*cf2gnrd + g04 = cf1*g04 - cf2*z04 + g05gnrd = cf1*g05gnrd - z05*cf2gnrd + g05 = cf1*g05 - cf2*z05 + g06gnrd = cf1*g06gnrd - z06*cf2gnrd + g06 = cf1*g06 - cf2*z06 + g07gnrd = cf1*g07gnrd - z07*cf2gnrd + g07 = cf1*g07 - cf2*z07 + g08gnrd = cf1*g08gnrd - z08*cf2gnrd + g08 = cf1*g08 - cf2*z08 + g10gnrd = cf1*g10gnrd - z10*cf2gnrd + g10 = cf1*g10 - cf2*z10 + g11gnrd = cf1*g11gnrd - z11*cf2gnrd + g11 = cf1*g11 - cf2*z11 + END IF +C + g09gnrd = g06gnrd + g08gnrd - g11gnrd + g09 = g06 + g08 - g11 + g12gnrd = g01gnrd + g08gnrd - g11gnrd + g12 = g01 + g08 - g11 +C +C *** Return point ; End of subroutine +C + RETURN + END + +C Differentiation of mkbi in forward (tangent) mode: +C variations of useful results: bi +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_GNRD(q, ionic, ionicgnrd, sion, siongnrd, zip, bi + + , bignrd) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionicgnrd, siongnrd, bignrd + REAL*8 :: b, c, xx + REAL*8 :: cgnrd, xxgnrd + REAL*8 :: arg1 + REAL*8 :: arg1gnrd + REAL*8 :: pwx1 + REAL*8 :: pwx1gnrd + REAL*8 :: pwr1 + REAL*8 :: pwr1gnrd, tiny + INTRINSIC EXP + INTRINSIC LOG10 + tiny = 1.d-20 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + arg1gnrd = -(.023d0*((ionicgnrd*ionic+ionic*ionicgnrd)*ionic+ionic + + **2*ionicgnrd)) + arg1 = -(.023d0*ionic*ionic*ionic) + cgnrd = .055d0*q*arg1gnrd*EXP(arg1) + c = 1. + .055d0*q*EXP(arg1) + xxgnrd = -((0.5107d0*siongnrd*(1.d0+c*sion)-0.5107d0*sion*(cgnrd* + + sion+c*siongnrd))/(1.d0+c*sion)**2) + xx = -(0.5107d0*sion/(1.d0+c*sion)) + pwx1gnrd = .1d0*ionicgnrd + pwx1 = 1.d0 + .1d0*ionic + IF (pwx1 > 0.d0 .OR. (pwx1 < 0.d0 + & .AND. (q-INT(q)) < tiny)) THEN + pwr1gnrd = q*pwx1**(q-1)*pwx1gnrd + ELSE IF (abs(pwx1) < TINY .AND. abs(q-1.d0) < tiny) THEN + pwr1gnrd = pwx1gnrd + ELSE + pwr1gnrd = 0.d0 + END IF + pwr1 = pwx1**q + bignrd = b*pwr1gnrd + bi = 1.d0 + b*pwr1 - b + bignrd = zip*bignrd/(bi*LOG(10.d0)) + zip*xxgnrd + bi = zip*LOG10(bi) + zip*xx +C + RETURN + END + +C + +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of funch6ap in reverse (adjoint) mode: +C gradient of useful results: aerliq gas +C with respect to varying inputs: wp aerliq gas +C RW status of diff variables: wp:out aerliq:in-out gas:in-out +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCH6AB +C *** CASE H6 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCH6AP_HB(x1, wphb, gashb, aerliqhb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: aerliq(NIONS+NGASAQ+2), gas(3) + REAL*8 :: aerliqhb(NIONS+NGASAQ+2), gashb(3), wphb(ncomp) + REAL*8 :: whb(ncomp) + CHARACTER(LEN=40) ERRINF + INTEGER :: errstki(25) + CHARACTER(LEN=40) errmsgi(25) + REAL*8 :: feps + REAL*8 :: frna + REAL*8 :: frnahb + REAL*8 :: xt + REAL*8 :: xtd + REAL*8 :: y1 + REAL*8 :: y1hb + REAL*8 :: y1d + REAL*8 :: y1dhb + REAL*8 :: x2 + REAL*8 :: x2hb + REAL*8 :: y2 + REAL*8 :: delta + REAL*8 :: deltahb + INTEGER :: i + INTEGER :: branch + REAL*8 :: x1 + INTRINSIC MAX + INTRINSIC ABS + REAL*8 :: abs1 + INTRINSIC MIN + INTEGER :: ii1 + REAL*8 :: max1 +C +C *** SETUP PARAMETERS ************************************************ +C + feps = 1.d-5 +C CNA2SO4 + chi1 = w(2) +C CNH42S4 +C CNH4CL + IF (w(1) - 2.d0*w(2) < zero) THEN + !WRITE(*,*) 'First in H6, PUSHCONTROL1B: 0, before' + CALL PUSHCONTROL1B(0) + !WRITE(*,*) 'First in H6, PUSHCONTROL1B: 0, after' + frna = zero + ELSE + frna = w(1) - 2.d0*w(2) + !WRITE(*,*) 'First in H6, PUSHCONTROL1B: 0, before' + CALL PUSHCONTROL1B(1) + !WRITE(*,*) 'First in H6, PUSHCONTROL1B: 0, after' + END IF + IF (frna > w(4)) THEN + chi8 = w(4) + CALL PUSHCONTROL1B(0) + ELSE + chi8 = frna + CALL PUSHCONTROL1B(1) + END IF +C NH3(g) + chi4 = w(3) +C CHI5 = MAX (W(4)-CHI8, ZERO) ! HNO3(g) +C CHI7 = MIN (MAX(FRNA-CHI8, ZERO), W(5)) ! CNACL +C CHI6 = MAX (W(5)-CHI7, ZERO) ! HCL(g) + IF (frna < w(4)) THEN + IF (w(4) - frna < zero) THEN + chi5 = zero + CALL PUSHCONTROL1B(0) + ELSE + chi5 = w(4) - frna + CALL PUSHCONTROL1B(1) + END IF + IF (zero > w(5)) THEN + chi7 = w(5) + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + chi7 = zero + END IF + IF (w(5) < zero) THEN + chi6 = zero + CALL PUSHCONTROL3B(2) + ELSE + chi6 = w(5) + CALL PUSHCONTROL3B(1) + END IF + ELSE + chi5 = zero + IF (frna - w(4) < zero) THEN + max1 = zero + ELSE + max1 = frna - w(4) + END IF + IF (max1 < w(5)) THEN + IF (frna - w(4) < zero) THEN + chi7 = zero + CALL PUSHCONTROL1B(0) + ELSE + chi7 = frna - w(4) + CALL PUSHCONTROL1B(1) + END IF + IF (w(5) - chi7 < zero) THEN + chi6 = zero + CALL PUSHCONTROL3B(4) + ELSE + chi6 = w(5) - chi7 + CALL PUSHCONTROL3B(3) + END IF + ELSE + chi7 = w(5) + chi6 = zero + CALL PUSHCONTROL3B(0) + END IF + END IF +C +C +C *** NEWTON-RAPHSON DETERMINATION OF ROOT ********************** +C + xt = x1 + xtd = 1.d0 + CALL PUSHREAL8ARRAY(gamahnrd, npair) + CALL PUSHREAL8ARRAY(molalhnrd, nions) + CALL PUSHINTEGER4(iclact) + CALL PUSHREAL8(water) + CALL PUSHREAL8ARRAY(gama, npair) + CALL PUSHREAL8ARRAY(molalr, npair) + CALL PUSHREAL8ARRAY(molal, nions) + CALL FUNCH6AB_HNRD(xt, xtd, y1, y1d) + x2 = xt - y1/(y1d*1.d0) + CALL PUSHINTEGER4(iclact) + CALL PUSHREAL8(water) + CALL PUSHREAL8ARRAY(gama, npair) + CALL PUSHREAL8ARRAY(molalr, npair) + CALL PUSHREAL8ARRAY(molal, nions) + CALL FUNCH6AB(x2, y2) + IF (y2 >= 0.) THEN + abs1 = y2 + ELSE + abs1 = -y2 + END IF +C + IF (abs1 > 10.d0*feps) THEN + DO ii1=1,nions + molalhb(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + gamahb(ii1) = 0.D0 + ENDDO + waterhb = 0.D0 + gnh3hb = 0.D0 + ghno3hb = 0.D0 + ghclhb = 0.D0 + WRITE(ERRINF, '(A,E12.5,A)') 'CALCH6 (',(abs1),')' + CALL PUSHERR (0104, ERRINF) ! WARNING ERROR: NO CONVERGENCE +! WRITE(*,*) 'W: ',W +! WRITE(*,*) 'RH: ',RH, ' TEMP: ',TEMP +! WRITE(*,*) 'FUNCH6AP_HB, after NR - Err 104: ',abs1 +! RETURN + ELSE +C +C CALL FUNCH6AB(XT,Y2) +C + IF (molal(1) > tiny .AND. molal(5) > tiny) THEN + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + ghclhb = gashb(3) + gashb(3) = 0.D0 + ghno3hb = gashb(2) + gashb(2) = 0.D0 + gnh3hb = gashb(1) + gashb(1) = 0.D0 + aerliqhb(nions+ngasaq+2) = 0.D0 + waterhb = 1.0d3*aerliqhb(nions+1)/18.0d0 + aerliqhb(nions+1) = 0.D0 + DO i=ngasaq,1,-1 + aerliqhb(nions+1+i) = 0.D0 + ENDDO + DO ii1=1,nions + molalhb(ii1) = 0.D0 + ENDDO + DO i=nions,1,-1 + molalhb(i) = molalhb(i) + aerliqhb(i) + aerliqhb(i) = 0.D0 + ENDDO + !WRITE(*,*) 'First in H6, POPCONTROL1B: 0, before' + CALL POPCONTROL1B(branch) + !WRITE(*,*) 'First in H6, POPCONTROL1B: 0, after' + IF (branch == 0) THEN + DO ii1=1,npair + gamahb(ii1) = 0.D0 + ENDDO + ELSE + deltahb = molalhb(6) + molalhb(6) = 0.D0 + deltahb = deltahb - molalhb(1) - molalhb(5) + CALL CALCHS4_HB(molal(1), molalhb(1), molal(5), molalhb(5), + + zero, delta, deltahb) + END IF + END IF + !WRITE(*,*) 'First in H6, POPREAL8ARRAY, before' + CALL POPREAL8ARRAY(molal, nions) + !WRITE(*,*) 'First in H6, POPREAL8ARRAY, after' + CALL POPREAL8ARRAY(molalr, npair) + CALL POPREAL8ARRAY(gama, npair) + CALL POPREAL8(water) + CALL POPINTEGER4(iclact) + CALL FUNCH6AB_HB(x2, x2hb, y2) + y1hb = -(x2hb/y1d) + y1dhb = y1*x2hb/y1d**2 + CALL POPREAL8ARRAY(molal, nions) + CALL POPREAL8ARRAY(molalr, npair) + CALL POPREAL8ARRAY(gama, npair) + CALL POPREAL8(water) + CALL POPINTEGER4(iclact) + CALL POPREAL8ARRAY(molalhnrd, nions) + CALL POPREAL8ARRAY(gamahnrd, npair) + CALL FUNCH6AB_HNRD_HB(xt, xtd, y1, y1hb, y1d, y1dhb) + CALL POPCONTROL3B(branch) + IF (branch < 2) THEN + IF (branch == 0) THEN + DO ii1=1,ncomp + whb(ii1) = 0.D0 + ENDDO + whb(5) = whb(5) + chi7hb + frnahb = 0.D0 + GOTO 100 + ELSE + DO ii1=1,ncomp + whb(ii1) = 0.D0 + ENDDO + whb(5) = whb(5) + chi6hb + END IF + ELSE IF (branch == 2) THEN + DO ii1=1,ncomp + whb(ii1) = 0.D0 + ENDDO + ELSE + IF (branch == 3) THEN + DO ii1=1,ncomp + whb(ii1) = 0.D0 + ENDDO + whb(5) = whb(5) + chi6hb + chi7hb = chi7hb - chi6hb + ELSE + DO ii1=1,ncomp + whb(ii1) = 0.D0 + ENDDO + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + frnahb = 0.D0 + ELSE + frnahb = chi7hb + whb(4) = whb(4) - chi7hb + END IF + GOTO 100 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) whb(5) = whb(5) + chi7hb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + frnahb = 0.D0 + ELSE + whb(4) = whb(4) + chi5hb + frnahb = -chi5hb + END IF + 100 whb(3) = whb(3) + chi4hb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + whb(4) = whb(4) + chi8hb + ELSE + frnahb = frnahb + chi8hb + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + whb(1) = whb(1) + frnahb + whb(2) = whb(2) - 2.d0*frnahb + END IF + whb(2) = whb(2) + chi1hb + DO ii1=1,5 + wphb(ii1) = 0.D0 + ENDDO + wphb = whb + END + +C Differentiation of funch6ab in reverse (adjoint) mode: +C gradient of useful results: molal gama water gnh3 ghno3 +C ghcl +C with respect to varying inputs: molal molalr gama water gnh3 +C ghno3 ghcl chi1 chi4 chi5 chi6 chi7 chi8 x +C +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCH6AB +C *** CASE H6 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCH6AB_HB(x, xhb, fh6ab) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: psi1hb + REAL*8 :: psi4hb + REAL*8 :: psi5hb + REAL*8 :: psi6hb + REAL*8 :: psi7hb + REAL*8 :: psi8hb + REAL*8 :: a4hb + REAL*8 :: a5hb + REAL*8 :: a6hb +C + INTEGER :: j + INTEGER :: i + REAL*8 :: bb + REAL*8 :: bbhb + REAL*8 :: cc + REAL*8 :: cchb + REAL*8 :: dd + REAL*8 :: ddhb + REAL*8 :: smin + REAL*8 :: sminhb + REAL*8 :: hi + REAL*8 :: hihb + REAL*8 :: ohi + REAL*8 :: frno3 + REAL*8 :: frno3hb + REAL*8 :: frcl + REAL*8 :: frclhb + REAL*8 :: frnh4 + REAL*8 :: frnh4hb + INTEGER :: branch + REAL*8 :: fh6ab + REAL*8 :: x + REAL*8 :: xhb + REAL*8 :: temp3 + REAL*8 :: temp2 + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp5hb + REAL*8 :: temp0hb + INTRINSIC MAX + REAL*8 :: temp3hb + REAL*8 :: temp1hb + REAL*8 :: temp4hb + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: temp5 + REAL*8 :: temp4 + REAL*8 :: temp2hb +C +C *** SETUP PARAMETERS ************************************************ +C + psi6 = x + psi1 = chi1 + psi2 = zero + psi3 = zero + psi7 = chi7 + psi8 = chi8 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + DO i=1,2 +C + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + a5 = xk4*r*temp*(water/gama(10))**2.0 + a6 = xk3*r*temp*(water/gama(11))**2.0 + CALL PUSHREAL8(psi5) +C +C CALCULATE DISSOCIATION QUANTITIES +C + psi5 = chi5*(psi6+psi7) - a6/a5*psi8*(chi6-psi6-psi3) + CALL PUSHREAL8(psi5) + psi5 = psi5/(a6/a5*(chi6-psi6-psi3)+psi6+psi7) + IF (psi5 < tiny) THEN + psi5 = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + psi5 = psi5 + END IF +C + IF (w(3) > tiny .AND. water > tiny) THEN + CALL PUSHREAL8(bb) +C First try 3rd order soln + bb = -(chi4+psi6+psi5+1.d0/a4) + cc = chi4*(psi5+psi6) + dd = bb*bb - 4.d0*cc + psi4 = 0.5d0*(-bb-SQRT(dd)) + IF (psi4 > chi4) THEN + psi4 = chi4 + CALL PUSHCONTROL2B(2) + ELSE + CALL PUSHCONTROL2B(1) + psi4 = psi4 + END IF + ELSE + psi4 = tiny + CALL PUSHCONTROL2B(0) + END IF + CALL PUSHREAL8(molal(2)) +C +C *** CALCULATE SPECIATION ******************************************** +C +C NAI + molal(2) = psi8 + psi7 + 2.d0*psi1 + CALL PUSHREAL8(molal(3)) +C NH4I + molal(3) = psi4 + CALL PUSHREAL8(molal(4)) +C CLI + molal(4) = psi6 + psi7 + CALL PUSHREAL8(molal(5)) +C SO4I + molal(5) = psi2 + psi1 + CALL PUSHREAL8(molal(6)) +C HSO4I + molal(6) = zero + CALL PUSHREAL8(molal(7)) +C NO3I + molal(7) = psi5 + psi8 + CALL PUSHREAL8(smin) +C +C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + smin = 2.d0*psi2 + psi5 + psi6 - psi4 + CALL CALCPH(smin, hi, ohi) + CALL PUSHREAL8(molal(1)) + molal(1) = hi + IF (chi4 - psi4 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + IF (chi5 - psi5 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + IF (chi6 - psi6 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF +C +C CALL CALCMR ! Water content +C +C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM RICH CASE +C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/ +C +C NACL + molalr(1) = psi7 +C NA2SO4 + molalr(2) = psi1 +C NANO3 + molalr(3) = psi8 +C (NH4)2SO4 + molalr(4) = zero + IF (psi5 < zero) THEN + frno3 = zero + CALL PUSHCONTROL1B(0) + ELSE + frno3 = psi5 + CALL PUSHCONTROL1B(1) + END IF + IF (psi6 < zero) THEN + CALL PUSHCONTROL1B(0) + frcl = zero + ELSE + frcl = psi6 + CALL PUSHCONTROL1B(1) + END IF +C MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3 +C FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3 +C MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL + IF (psi4 < frno3) THEN + molalr(5) = psi4 + IF (frcl > zero) THEN + molalr(6) = zero + CALL PUSHCONTROL2B(1) + ELSE + molalr(6) = frcl + CALL PUSHCONTROL2B(0) + END IF + ELSE + molalr(5) = frno3 + IF (psi4 - frno3 < zero) THEN + frnh4 = zero + CALL PUSHCONTROL1B(0) + ELSE + frnh4 = psi4 - frno3 + CALL PUSHCONTROL1B(1) + END IF + IF (frcl > frnh4) THEN + molalr(6) = frnh4 + CALL PUSHCONTROL2B(3) + ELSE + molalr(6) = frcl + CALL PUSHCONTROL2B(2) + END IF + END IF + CALL PUSHREAL8(water) +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + DO j=1,npair + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF + CALL PUSHREAL8ARRAY(gama, npair) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3P() + ENDDO + DO ii1=1,npair + molalrhb(ii1) = 0.D0 + ENDDO + chi4hb = 0.D0 + chi5hb = 0.D0 + chi6hb = 0.D0 + psi1hb = 0.D0 + psi6hb = 0.D0 + psi7hb = 0.D0 + psi8hb = 0.D0 + DO i=2,1,-1 + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3P_HB() + CALL POPCONTROL1B(branch) + IF (branch == 0) waterhb = 0.D0 + DO j=npair,1,-1 + molalrhb(j) = molalrhb(j) + waterhb/m0(j) + ENDDO + CALL POPREAL8(water) + CALL POPCONTROL2B(branch) + IF (branch < 2) THEN + IF (branch == 0) THEN + frclhb = molalrhb(6) + molalrhb(6) = 0.D0 + ELSE + molalrhb(6) = 0.D0 + frclhb = 0.D0 + END IF + psi4hb = molalrhb(5) + molalrhb(5) = 0.D0 + frno3hb = 0.D0 + ELSE + IF (branch == 2) THEN + frclhb = molalrhb(6) + molalrhb(6) = 0.D0 + frnh4hb = 0.D0 + ELSE + frnh4hb = molalrhb(6) + molalrhb(6) = 0.D0 + frclhb = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + psi4hb = 0.D0 + frno3hb = 0.D0 + ELSE + psi4hb = frnh4hb + frno3hb = -frnh4hb + END IF + frno3hb = frno3hb + molalrhb(5) + molalrhb(5) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) psi6hb = psi6hb + frclhb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + psi5hb = 0.D0 + ELSE + psi5hb = frno3hb + END IF + molalrhb(4) = 0.D0 + psi8hb = psi8hb + molalrhb(3) + molalrhb(3) = 0.D0 + psi1hb = psi1hb + molalrhb(2) + molalrhb(2) = 0.D0 + psi7hb = psi7hb + molalrhb(1) + molalrhb(1) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + chi6hb = chi6hb + ghclhb + psi6hb = psi6hb - ghclhb + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + chi5hb = chi5hb + ghno3hb + psi5hb = psi5hb - ghno3hb + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + chi4hb = chi4hb + gnh3hb + psi4hb = psi4hb - gnh3hb + END IF + CALL POPREAL8(molal(1)) + hihb = molalhb(1) + molalhb(1) = 0.D0 + CALL CALCPH_HB(smin, sminhb, hi, hihb, ohi) + CALL POPREAL8(smin) + psi5hb = psi5hb + molalhb(7) + sminhb + CALL POPREAL8(molal(7)) + psi8hb = psi8hb + molalhb(7) + molalhb(7) = 0.D0 + CALL POPREAL8(molal(6)) + molalhb(6) = 0.D0 + CALL POPREAL8(molal(5)) + psi1hb = psi1hb + molalhb(5) + molalhb(5) = 0.D0 + psi6hb = psi6hb + molalhb(4) + sminhb + CALL POPREAL8(molal(4)) + psi7hb = psi7hb + molalhb(4) + molalhb(4) = 0.D0 + psi4hb = psi4hb + molalhb(3) - sminhb + CALL POPREAL8(molal(3)) + molalhb(3) = 0.D0 + CALL POPREAL8(molal(2)) + psi8hb = psi8hb + molalhb(2) + psi7hb = psi7hb + molalhb(2) + psi1hb = psi1hb + 2.d0*molalhb(2) + molalhb(2) = 0.D0 + CALL POPCONTROL2B(branch) + IF (branch == 0) THEN + a4hb = 0.D0 + ELSE + IF (branch /= 1) THEN + chi4hb = chi4hb + psi4hb + psi4hb = 0.D0 + END IF + cc = chi4*(psi5+psi6) + dd = bb*bb - 4.d0*cc + IF (dd == 0.0) THEN + ddhb = 0.0 + ELSE + ddhb = -(0.5d0*psi4hb/(2.0*SQRT(dd))) + END IF + bbhb = 2*bb*ddhb - 0.5d0*psi4hb + cchb = -(4.d0*ddhb) + chi4hb = chi4hb + (psi5+psi6)*cchb - bbhb + psi5hb = psi5hb + chi4*cchb - bbhb + psi6hb = psi6hb + chi4*cchb - bbhb + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + CALL POPREAL8(bb) + a4hb = bbhb/a4**2 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) psi5hb = 0.D0 + temp0 = gama(10)/gama(5) + temp0hb = 2.0*temp0*xk2*r*temp*a4hb/(xkw*gama(5)) + a5 = xk4*r*temp*(water/gama(10))**2.0 + a6 = xk3*r*temp*(water/gama(11))**2.0 + CALL POPREAL8(psi5) + temp4 = a6/a5 + temp5 = (chi6-psi3-psi6)*temp4 + psi6 + psi7 + temp5hb = -(psi5*psi5hb/temp5**2) + temp4hb = (chi6-psi3-psi6)*temp5hb/a5 + psi5hb = psi5hb/temp5 + psi7hb = psi7hb + chi5*psi5hb + temp5hb + CALL POPREAL8(psi5) + temp3 = (chi6-psi3-psi6)/a5 + a6hb = temp4hb - temp3*psi8*psi5hb + temp3hb = -(a6*psi8*psi5hb/a5) + chi6hb = chi6hb + temp3hb + temp4*temp5hb + psi6hb = psi6hb + chi5*psi5hb - temp3hb + (1.D0-temp4)*temp5hb + a5hb = -(temp3*temp3hb) - temp4*temp4hb + chi5hb = chi5hb + (psi6+psi7)*psi5hb + psi8hb = psi8hb - temp3*a6*psi5hb + temp2 = water/gama(11) + temp2hb = 2.0*temp2*xk3*r*temp*a6hb/gama(11) + gamahb(11) = gamahb(11) - temp2*temp2hb + temp1 = water/gama(10) + temp1hb = 2.0*temp1*xk4*r*temp*a5hb/gama(10) + waterhb = waterhb + temp1hb + temp2hb + gamahb(10) = gamahb(10) + temp0hb - temp1*temp1hb + gamahb(5) = gamahb(5) - temp0*temp0hb + gnh3hb = 0.D0 + ghno3hb = 0.D0 + ghclhb = 0.D0 + ENDDO + chi8hb = psi8hb + chi7hb = psi7hb + chi1hb = psi1hb + xhb = psi6hb + END + +C +C Differentiation of calchs4 in reverse (adjoint) mode: +C gradient of useful results: water hi so4i delta +C with respect to varying inputs: gama water hi so4i +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCHS4 +C *** THIS SUBROUTINE CALCULATES THE HSO4 GENERATED FROM (H,SO4). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCHS4_HB(hi, hihb, so4i, so4ihb, hso4i, delta, + + deltahb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: a8hb + REAL*8 :: hi, so4i, hso4i, delta, bb, cc, dd, sqdd, delta1 + + , delta2 + REAL*8 :: hihb, so4ihb, deltahb, bbhb, cchb, ddhb, sqddhb, + + delta1hb, delta2hb + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp0hb + REAL*8 :: temp1hb + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** IF TOO LITTLE WATER, DONT SOLVE +C + IF (water <= 1d1*tiny) THEN + DO ii1=1,npair + gamahb(ii1) = 0.D0 + ENDDO + ELSE +C +C *** CALCULATE HSO4 SPECIATION ***************************************** +C + a8 = xk1*water/gama(7)*(gama(8)/gama(7))**2. +C + bb = -(hi+so4i+a8) + cc = hi*so4i - hso4i*a8 + dd = bb*bb - 4.d0*cc +C + IF (dd >= zero) THEN + IF (hso4i <= tiny) THEN + delta2hb = deltahb + delta1hb = 0.D0 + ELSE IF (hi*so4i >= a8*hso4i) THEN + delta2hb = deltahb + delta1hb = 0.D0 + ELSE + IF (hi*so4i < a8*hso4i) THEN + delta1hb = deltahb + ELSE + delta1hb = 0.D0 + END IF + delta2hb = 0.D0 + END IF + bbhb = -(0.5*delta1hb) - 0.5*delta2hb + sqddhb = 0.5*delta1hb - 0.5*delta2hb + IF (dd == 0.0) THEN + ddhb = 0.0 + ELSE + ddhb = sqddhb/(2.0*SQRT(dd)) + END IF + ELSE + ddhb = 0.D0 + bbhb = 0.D0 + END IF + bbhb = bbhb + 2*bb*ddhb + cchb = -(4.d0*ddhb) + hihb = hihb + so4i*cchb - bbhb + so4ihb = so4ihb + hi*cchb - bbhb + a8hb = -bbhb - hso4i*cchb + DO ii1=1,npair + gamahb(ii1) = 0.D0 + ENDDO + temp0 = water/gama(7) + temp1 = gama(8)/gama(7) + temp1hb = 2.*temp1*temp0*xk1*a8hb/gama(7) + temp0hb = temp1**2.*xk1*a8hb/gama(7) + gamahb(8) = gamahb(8) + temp1hb + gamahb(7) = gamahb(7) - temp0*temp0hb - temp1*temp1hb + waterhb = waterhb + temp0hb + END IF + END + +C Differentiation of calcph in reverse (adjoint) mode: +C gradient of useful results: hi +C with respect to varying inputs: water gg +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCPH +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCPH_HB(gg, gghb, hi, hihb, ohi) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: cn, gg, hi, ohi, bb, cc, dd + REAL*8 :: cnhb, gghb, hihb, ohihb, bbhb, cchb, ddhb + REAL*8 :: akw + REAL*8 :: akwhb + INTEGER :: branch + REAL*8 :: x2hb + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x1hb + INTRINSIC SQRT +C + akw = xkw*rh*water*water + cn = SQRT(akw) +C +C *** GG = (negative charge) - (positive charge) +C + IF (gg > tiny) THEN +C H+ in excess + bb = -gg + cc = -akw + dd = bb*bb - 4.d0*cc + x1 = 0.5d0*(-bb+SQRT(dd)) + IF (x1 < cn) THEN + cnhb = hihb + x1hb = 0.D0 + ELSE + x1hb = hihb + cnhb = 0.D0 + END IF + IF (dd == 0.0) THEN + ddhb = 0.0 + ELSE + ddhb = 0.5d0*x1hb/(2.0*SQRT(dd)) + END IF + bbhb = 2*bb*ddhb - 0.5d0*x1hb + cchb = -(4.d0*ddhb) + akwhb = -cchb + gghb = -bbhb + ELSE +C OH- in excess + bb = gg + cc = -akw + dd = bb*bb - 4.d0*cc + x2 = 0.5d0*(-bb+SQRT(dd)) + IF (x2 < cn) THEN + ohi = cn + CALL PUSHCONTROL1B(0) + ELSE + ohi = x2 + CALL PUSHCONTROL1B(1) + END IF + akwhb = hihb/ohi + ohihb = -(akw*hihb/ohi**2) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cnhb = ohihb + x2hb = 0.D0 + ELSE + x2hb = ohihb + cnhb = 0.D0 + END IF + IF (dd == 0.0) THEN + ddhb = 0.0 + ELSE + ddhb = 0.5d0*x2hb/(2.0*SQRT(dd)) + END IF + bbhb = 2*bb*ddhb - 0.5d0*x2hb + cchb = -(4.d0*ddhb) + akwhb = akwhb - cchb + gghb = bbhb + END IF + IF (.NOT.akw == 0.0) akwhb = akwhb + cnhb/(2.0*SQRT(akw)) + waterhb = xkw*rh*2*water*akwhb + END + +C Differentiation of calcact3p in reverse (adjoint) mode: +C gradient of useful results: molal gama water +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3P_HB() + INCLUDE 'isrpia_adj.inc' +C +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0hb(6, 4), sionhb, hhb, chhb, f1hb(3), f2hb(4) + REAL*8 :: mpl, xij, yji + REAL*8 :: mplhb, xijhb, yjihb, ionichb + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01hb + REAL*8 :: g02 + REAL*8 :: g02hb + REAL*8 :: g03 + REAL*8 :: g03hb + REAL*8 :: g04 + REAL*8 :: g04hb + REAL*8 :: g05 + REAL*8 :: g05hb + REAL*8 :: g06 + REAL*8 :: g06hb + REAL*8 :: g07 + REAL*8 :: g07hb + REAL*8 :: g08 + REAL*8 :: g08hb + REAL*8 :: g09 + REAL*8 :: g09hb + REAL*8 :: g10 + REAL*8 :: g10hb + REAL*8 :: g11 + REAL*8 :: g11hb + REAL*8 :: g12 + REAL*8 :: g12hb + INTEGER :: j + INTEGER :: branch + REAL*8 :: x2hb + REAL*8 :: temp0hb + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: temp0hb13 + REAL*8 :: temp0hb12 + REAL*8 :: temp0hb11 + REAL*8 :: temp0hb10 + REAL*8 :: temp0hb9 + REAL*8 :: temp0hb8 + REAL*8 :: temp0hb7 + REAL*8 :: temp0hb6 + REAL*8 :: x1hb + REAL*8 :: temp0hb5 + REAL*8 :: temp0hb4 + REAL*8 :: temp0hb3 + REAL*8 :: temp0hb2 + REAL*8 :: temp0hb1 + REAL*8 :: temp0hb0 + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + DO i=1,7 + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08, + + g09, g10, g11, g12) +C + g0(1, 1) = g11 + g0(1, 2) = g07 + g0(1, 3) = g08 + g0(1, 4) = g10 + g0(2, 1) = g01 + g0(2, 2) = g02 + g0(2, 3) = g12 + g0(2, 4) = g03 + g0(3, 1) = g06 + g0(3, 2) = g04 + g0(3, 3) = g09 + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + sion = SQRT(ionic) + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + yji = ch*molal(j+3)/water + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gama(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gama(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gama(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gama(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gama(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gama(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gama(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gama(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gama(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gama(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gama(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gama(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gama(13)) +C LC ; SCAPE + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + ELSE + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + gamahb(i) = 10.d0**gama(i)*LOG(10.d0)*gamahb(i) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + gamahb(i) = 0.D0 + x2hb = 0.D0 + ELSE + x2hb = gamahb(i) + gamahb(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) gamahb(i) = gamahb(i) + x2hb + ENDDO + CALL POPREAL8(gama(13)) + gamahb(4) = gamahb(4) + 0.2d0*3.d0*gamahb(13) + gamahb(9) = gamahb(9) + 0.2d0*2.d0*gamahb(13) + gamahb(13) = 0.D0 + DO ii1=1,3 + f1hb(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2hb(ii1) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp0hb2 = zz(12)*gamahb(12)/(z(2)+z(6)) + f1hb(2) = f1hb(2) + temp0hb2/z(2) + f2hb(3) = f2hb(3) + temp0hb2/z(6) + hhb = -(zz(12)*gamahb(12)) + gamahb(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp0hb3 = zz(11)*gamahb(11)/(z(1)+z(4)) + f2hb(1) = f2hb(1) + temp0hb3/z(4) + hhb = hhb - zz(11)*gamahb(11) + gamahb(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp0hb4 = zz(10)*gamahb(10)/(z(1)+z(7)) + f1hb(1) = f1hb(1) + temp0hb4/z(1) + temp0hb3/z(1) + f2hb(4) = f2hb(4) + temp0hb4/z(7) + hhb = hhb - zz(10)*gamahb(10) + gamahb(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp0hb5 = zz(9)*gamahb(9)/(z(3)+z(6)) + f1hb(3) = f1hb(3) + temp0hb5/z(3) + hhb = hhb - zz(9)*gamahb(9) + gamahb(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp0hb6 = zz(8)*gamahb(8)/(z(1)+z(6)) + f2hb(3) = f2hb(3) + temp0hb6/z(6) + temp0hb5/z(6) + hhb = hhb - zz(8)*gamahb(8) + gamahb(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp0hb7 = zz(7)*gamahb(7)/(z(1)+z(5)) + f1hb(1) = f1hb(1) + temp0hb7/z(1) + temp0hb6/z(1) + f2hb(2) = f2hb(2) + temp0hb7/z(5) + hhb = hhb - zz(7)*gamahb(7) + gamahb(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp0hb8 = zz(6)*gamahb(6)/(z(3)+z(4)) + f2hb(1) = f2hb(1) + temp0hb8/z(4) + hhb = hhb - zz(6)*gamahb(6) + gamahb(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp0hb9 = zz(5)*gamahb(5)/(z(3)+z(7)) + f2hb(4) = f2hb(4) + temp0hb9/z(7) + hhb = hhb - zz(5)*gamahb(5) + gamahb(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp0hb10 = zz(4)*gamahb(4)/(z(3)+z(5)) + f1hb(3) = f1hb(3) + temp0hb9/z(3) + temp0hb10/z(3) + temp0hb8/z(3) + f2hb(2) = f2hb(2) + temp0hb10/z(5) + hhb = hhb - zz(4)*gamahb(4) + gamahb(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp0hb11 = zz(3)*gamahb(3)/(z(2)+z(7)) + f2hb(4) = f2hb(4) + temp0hb11/z(7) + hhb = hhb - zz(3)*gamahb(3) + gamahb(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp0hb12 = zz(2)*gamahb(2)/(z(2)+z(5)) + f2hb(2) = f2hb(2) + temp0hb12/z(5) + hhb = hhb - zz(2)*gamahb(2) + gamahb(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp0hb13 = zz(1)*gamahb(1)/(z(2)+z(4)) + f1hb(2) = f1hb(2) + temp0hb12/z(2) + temp0hb13/z(2) + temp0hb11/z( + + 2) + f2hb(1) = f2hb(1) + temp0hb13/z(4) + hhb = hhb - zz(1)*gamahb(1) + gamahb(1) = 0.D0 + ionichb = 0.D0 + DO ii1=1,4 + DO ii2=1,6 + g0hb(ii2, ii1) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mplhb = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijhb = (g0(i, j)+zpl*zmi*h)*f2hb(j) + yji = ch*molal(j+3)/water + g0hb(i, j) = g0hb(i, j) + yji*f1hb(i) + xij*f2hb(j) + hhb = hhb + yji*zpl*zmi*f1hb(i) + xij*zpl*zmi*f2hb(j) + yjihb = (g0(i, j)+zpl*zmi*h)*f1hb(i) + temp0hb1 = molal(j+3)*yjihb/water + molalhb(j+3) = molalhb(j+3) + ch*yjihb/water + chhb = mpl*xijhb + temp0hb1 + waterhb = waterhb - ch*temp0hb1/water + mplhb = mplhb + ch*xijhb + ionichb = ionichb - (zpl+zmi)**2*0.25d0*chhb/ionic**2 + ENDDO + CALL POPREAL8(mpl) + molalhb(i) = molalhb(i) + mplhb/water + waterhb = waterhb - molal(i)*mplhb/water**2 + CALL POPREAL8(zpl) + ENDDO + temp0hb0 = agama*hhb/(sion+1.d0) + sionhb = (1.D0-sion/(sion+1.d0))*temp0hb0 + IF (.NOT.ionic == 0.0) ionichb = ionichb + sionhb/(2.0*SQRT( + + ionic)) + g05hb = g0hb(3, 4) + g0hb(3, 4) = 0.D0 + g09hb = g0hb(3, 3) + g0hb(3, 3) = 0.D0 + g04hb = g0hb(3, 2) + g0hb(3, 2) = 0.D0 + g06hb = g0hb(3, 1) + g0hb(3, 1) = 0.D0 + g03hb = g0hb(2, 4) + g0hb(2, 4) = 0.D0 + g12hb = g0hb(2, 3) + g0hb(2, 3) = 0.D0 + g02hb = g0hb(2, 2) + g0hb(2, 2) = 0.D0 + g01hb = g0hb(2, 1) + g0hb(2, 1) = 0.D0 + g10hb = g0hb(1, 4) + g0hb(1, 4) = 0.D0 + g08hb = g0hb(1, 3) + g0hb(1, 3) = 0.D0 + g07hb = g0hb(1, 2) + g0hb(1, 2) = 0.D0 + g11hb = g0hb(1, 1) + CALL KMFUL3_HB(ionic, ionichb, temp, g01, g01hb, g02, g02hb, g03, + + g03hb, g04, g04hb, g05, g05hb, g06, g06hb, g07, + + g07hb, g08, g08hb, g09, g09hb, g10, g10hb, g11, + + g11hb, g12, g12hb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionic) + x1hb = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1hb = ionichb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ionichb = 0.D0 + ELSE + temp0hb = 0.5d0*x1hb/water + ionichb = temp0hb + waterhb = waterhb - ionic*temp0hb/water + END IF + DO i=7,1,-1 + molalhb(i) = molalhb(i) + z(i)**2*ionichb + ENDDO + END + +C Differentiation of kmful3 in reverse (adjoint) mode: +C gradient of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 ionic +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_HB(ionic, ionichb, temp, g01, g01hb, g02, g02hb + + , g03, g03hb, g04, g04hb, g05, g05hb, g06, + + g06hb, g07, g07hb, g08, g08hb, g09, g09hb, + + g10, g10hb, g11, g11hb, g12, g12hb) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionichb, sionhb, cf2hb + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01hb, g02hb, g03hb, g04hb, g05hb, g06hb, g07hb, + + g08hb, g09hb, g10hb, g11hb, g12hb + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTEGER :: branch + REAL*8 :: temp0hb + INTRINSIC ABS + REAL*8 :: temp0hb0 + REAL*8 :: abs1 + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01hb = g01hb + g12hb + g08hb = g08hb + g09hb + g12hb + g11hb = g11hb - g09hb - g12hb + g06hb = g06hb + g09hb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2hb = -(z10*g10hb) - z07*g07hb - z05*g05hb - z03*g03hb - z01* + + g01hb - z02*g02hb - z04*g04hb - z06*g06hb - z08*g08hb - z11* + + g11hb + g11hb = cf1*g11hb + g10hb = cf1*g10hb + g08hb = cf1*g08hb + g07hb = cf1*g07hb + g06hb = cf1*g06hb + g05hb = cf1*g05hb + g04hb = cf1*g04hb + g03hb = cf1*g03hb + g02hb = cf1*g02hb + g01hb = cf1*g01hb + temp0hb = (0.125d0-ti*0.005d0)*cf2hb + temp0hb0 = -(0.41d0*temp0hb/(sion+1.d0)) + ionichb = ionichb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0hb + sionhb = (1.D0-sion/(sion+1.d0))*temp0hb0 + ELSE + sionhb = 0.D0 + END IF + CALL MKBI_HB(q11, ionic, ionichb, sion, sionhb, z11, g11, g11hb) + CALL MKBI_HB(q10, ionic, ionichb, sion, sionhb, z10, g10, g10hb) + CALL MKBI_HB(q8, ionic, ionichb, sion, sionhb, z08, g08, g08hb) + CALL MKBI_HB(q7, ionic, ionichb, sion, sionhb, z07, g07, g07hb) + CALL MKBI_HB(q6, ionic, ionichb, sion, sionhb, z06, g06, g06hb) + CALL MKBI_HB(q5, ionic, ionichb, sion, sionhb, z05, g05, g05hb) + CALL MKBI_HB(q4, ionic, ionichb, sion, sionhb, z04, g04, g04hb) + CALL MKBI_HB(q3, ionic, ionichb, sion, sionhb, z03, g03, g03hb) + CALL MKBI_HB(q2, ionic, ionichb, sion, sionhb, z02, g02, g02hb) + CALL MKBI_HB(q1, ionic, ionichb, sion, sionhb, z01, g01, g01hb) + IF (.NOT.ionic == 0.0) ionichb = ionichb + sionhb/(2.0*SQRT( + + ionic)) + END + +C Differentiation of mkbi in reverse (adjoint) mode: +C gradient of useful results: sion bi ionic +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_HB(q, ionic, ionichb, sion, sionhb, zip, bi, bihb) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionichb, sionhb, bihb + REAL*8 :: b, c, xx + REAL*8 :: chb, xxhb + INTRINSIC EXP + REAL*8 :: temphb0 + INTRINSIC LOG10 + REAL*8 :: temphb +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic)) + bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b +C + xxhb = zip*bihb + bihb = zip*bihb/(bi*LOG(10.0)) + temphb = -(0.5107d0*xxhb/(c*sion+1.d0)) + temphb0 = -(sion*temphb/(c*sion+1.d0)) + sionhb = sionhb + c*temphb0 + temphb + chb = sion*temphb0 + IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q + + ))) THEN + ionichb = ionichb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3* + + ionic**2*chb + ELSE + ionichb = ionichb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bihb - + + .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*chb + END IF + END + +C Differentiation of funch6ab_hnrd in reverse (adjoint) mode: +C gradient of useful results: molal molalr gama water gnh3 +C ghno3 ghcl chi1 chi4 chi5 chi6 chi7 chi8 fh6ab +C fh6abhnrd +C with respect to varying inputs: chi1 chi4 chi5 chi6 chi7 chi8 +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of funch6ab in forward (tangent) mode: +C variations of useful results: fh6ab +C with respect to varying inputs: x +C RW status of diff variables: fh6ab:out x:in +C +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCH6AB +C *** CASE H6 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCH6AB_HNRD_HB(x, xhnrd, fh6ab, fh6abhb, fh6abhnrd, + + fh6abhnrdhb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: psi1hb + REAL*8 :: psi4hb + REAL*8 :: psi4hnrd + REAL*8 :: psi4hnrdhb + REAL*8 :: psi5hb + REAL*8 :: psi5hnrd + REAL*8 :: psi5hnrdhb + REAL*8 :: psi6hnrd + REAL*8 :: psi7hb + REAL*8 :: psi8hb + REAL*8 :: a4hb + REAL*8 :: a4hnrd + REAL*8 :: a4hnrdhb + REAL*8 :: a5hb + REAL*8 :: a5hnrd + REAL*8 :: a5hnrdhb + REAL*8 :: a6hb + REAL*8 :: a6hnrd + REAL*8 :: a6hnrdhb +C + INTEGER :: j + INTEGER :: i + REAL*8 :: bb + REAL*8 :: bbhb + REAL*8 :: bbhnrd + REAL*8 :: bbhnrdhb + REAL*8 :: cc + REAL*8 :: cchb + REAL*8 :: cchnrd + REAL*8 :: cchnrdhb + REAL*8 :: dd + REAL*8 :: ddhb + REAL*8 :: ddhnrd + REAL*8 :: ddhnrdhb + REAL*8 :: smin + REAL*8 :: sminhb + REAL*8 :: sminhnrd + REAL*8 :: sminhnrdhb + REAL*8 :: hi + REAL*8 :: hihb + REAL*8 :: hihnrd + REAL*8 :: hihnrdhb + REAL*8 :: ohi + REAL*8 :: frno3 + REAL*8 :: frno3hb + REAL*8 :: frno3hnrd + REAL*8 :: frno3hnrdhb + REAL*8 :: frcl + REAL*8 :: frclhnrd + REAL*8 :: frnh4 + REAL*8 :: frnh4hb + REAL*8 :: frnh4hnrd + REAL*8 :: frnh4hnrdhb + REAL*8 :: result1 + REAL*8 :: result1hb + REAL*8 :: result1hnrd + REAL*8 :: result1hnrdhb + REAL*8 :: fh6ab + REAL*8 :: fh6abhb + REAL*8 :: fh6abhnrd + REAL*8 :: fh6abhnrdhb + REAL*8 :: x + REAL*8 :: xhnrd, molalrhnrd(npair), molalrhnrdhb(npair) + INTRINSIC MAX + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT + INTEGER :: branch + REAL*8 :: temp3 + REAL*8 :: temp3hb0 + REAL*8 :: temp29 + REAL*8 :: temp2 + REAL*8 :: temp11hb + REAL*8 :: temp28 + REAL*8 :: temp1 + REAL*8 :: temp27 + REAL*8 :: temp0 + REAL*8 :: temp26 + REAL*8 :: temp25 + REAL*8 :: temp24 + REAL*8 :: temp26hb + REAL*8 :: temp23 + REAL*8 :: temp22 + REAL*8 :: temp21 + REAL*8 :: temp20 + REAL*8 :: temp21hb + REAL*8 :: temp19hb + REAL*8 :: temp5hb + REAL*8 :: temp5hb1 + REAL*8 :: temp14hb + REAL*8 :: temp5hb0 + REAL*8 :: temp31hb + REAL*8 :: temp0hb + REAL*8 :: temp29hb + REAL*8 :: temp19hb0 + INTRINSIC ABS + REAL*8 :: temp19 + REAL*8 :: temp39hb + REAL*8 :: temp18 + REAL*8 :: temp21hb0 + REAL*8 :: temp17 + REAL*8 :: temp8hb + REAL*8 :: temp16 + REAL*8 :: temp15 + REAL*8 :: temp17hb + REAL*8 :: temp14 + REAL*8 :: temp7hb0 + REAL*8 :: temp34hb + REAL*8 :: temp13 + REAL*8 :: temp12 + REAL*8 :: temp3hb + REAL*8 :: temp11 + REAL*8 :: temp10 + REAL*8 :: temp12hb + REAL*8 :: temp27hb + REAL*8 :: temp22hb + REAL*8 :: temp6hb + REAL*8 :: temp15hb + REAL*8 :: temp32hb + REAL*8 :: temp1hb + REAL*8 :: temp10hb + REAL*8 :: temp25hb + REAL*8 :: temp39 + REAL*8 :: temp38 + REAL*8 :: temp20hb + REAL*8 :: temp13hb0 + REAL*8 :: temp37 + REAL*8 :: temp9hb + REAL*8 :: temp36 + INTEGER :: ii10 + REAL*8 :: temp35 + REAL*8 :: temp18hb + REAL*8 :: temp34 + REAL*8 :: temp38hb0 + REAL*8 :: temp33 + REAL*8 :: temp32 + REAL*8 :: temp4hb + REAL*8 :: temp31 + REAL*8 :: temp30 + REAL*8 :: temp13hb + REAL*8 :: abs1 + REAL*8 :: temp30hb + REAL*8 :: temp1hb0 + REAL*8 :: temp28hb + REAL*8 :: temp23hb + REAL*8 :: temp40hb + REAL*8 :: temp38hb + REAL*8 :: temp9 + REAL*8 :: temp7hb + REAL*8 :: temp8 + REAL*8 :: temp7 + REAL*8 :: temp6 + REAL*8 :: temp33hb + REAL*8 :: temp5 + REAL*8 :: temp4 + REAL*8 :: temp2hb + REAL*8 :: temp3hb1 +C +C *** SETUP PARAMETERS ************************************************ +C + psi6hnrd = xhnrd + psi6 = x + psi1 = chi1 + psi2 = zero + psi3 = zero + psi7 = chi7 + psi8 = chi8 + DO ii1=1,nions + molalhnrd(ii1) = 0.d0 + ENDDO + DO ii1=1,npair + molalrhnrd(ii1) = 0.d0 + ENDDO + DO ii1=1,npair + gamahnrd(ii1) = 0.d0 + ENDDO + waterhnrd = 0.d0 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + DO i=1,2 + CALL PUSHREAL8(a4hnrd) +C + a4hnrd = xk2*r*temp*2.0*gama(10)*(gamahnrd(10)*gama(5)-gama(10)* + + gamahnrd(5))/(xkw*gama(5)**3) + CALL PUSHREAL8(a4) + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + CALL PUSHREAL8(a5hnrd) + a5hnrd = xk4*r*temp*2.0*water*(waterhnrd*gama(10)-water*gamahnrd + + (10))/gama(10)**3 + a5 = xk4*r*temp*(water/gama(10))**2.0 + CALL PUSHREAL8(a6hnrd) + a6hnrd = xk3*r*temp*2.0*water*(waterhnrd*gama(11)-water*gamahnrd + + (11))/gama(11)**3 + CALL PUSHREAL8(a6) + a6 = xk3*r*temp*(water/gama(11))**2.0 + CALL PUSHREAL8(psi5hnrd) +C +C CALCULATE DISSOCIATION QUANTITIES +C + psi5hnrd = chi5*psi6hnrd - psi8*((a6hnrd*a5-a6*a5hnrd)*(chi6- + + psi6-psi3)/a5**2-a6*psi6hnrd/a5) + CALL PUSHREAL8(psi5) + psi5 = chi5*(psi6+psi7) - a6/a5*psi8*(chi6-psi6-psi3) + CALL PUSHREAL8(psi5hnrd) + psi5hnrd = (psi5hnrd*(a6/a5*(chi6-psi6-psi3)+psi6+psi7)-psi5*(( + + a6hnrd*a5-a6*a5hnrd)*(chi6-psi6-psi3)/a5**2-a6*psi6hnrd/a5+ + + psi6hnrd))/(a6/a5*(chi6-psi6-psi3)+psi6+psi7)**2 + CALL PUSHREAL8(psi5) + psi5 = psi5/(a6/a5*(chi6-psi6-psi3)+psi6+psi7) + IF (psi5 < tiny) THEN + psi5 = tiny + psi5hnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + psi5 = psi5 + END IF +C + IF (w(3) > tiny .AND. water > tiny) THEN + CALL PUSHREAL8(bbhnrd) +C First try 3rd order soln + bbhnrd = -(psi6hnrd+psi5hnrd-a4hnrd/a4**2) + CALL PUSHREAL8(bb) + bb = -(chi4+psi6+psi5+1.d0/a4) + cchnrd = chi4*(psi5hnrd+psi6hnrd) + cc = chi4*(psi5+psi6) + ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd + dd = bb*bb - 4.d0*cc + IF (dd >= 0.) THEN + abs1 = dd + ELSE + abs1 = -dd + END IF + IF (abs1 < tiny) THEN + result1hnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + result1hnrd = ddhnrd/(2.0*SQRT(dd)) + CALL PUSHCONTROL1B(1) + END IF + result1 = SQRT(dd) + psi4hnrd = 0.5d0*(-bbhnrd-result1hnrd) + psi4 = 0.5d0*(-bb-result1) + IF (psi4 > chi4) THEN + psi4 = chi4 + psi4hnrd = 0.d0 + CALL PUSHCONTROL2B(0) + ELSE + CALL PUSHCONTROL2B(1) + psi4 = psi4 + END IF + ELSE + CALL PUSHCONTROL2B(2) + psi4 = tiny + psi4hnrd = 0.d0 + END IF + CALL PUSHREAL8(molalhnrd(2)) +C +C *** CALCULATE SPECIATION ******************************************** +C +C NAI + molalhnrd(2) = 0.d0 + CALL PUSHREAL8(molal(2)) + molal(2) = psi8 + psi7 + 2.d0*psi1 + CALL PUSHREAL8(molalhnrd(3)) +C NH4I + molalhnrd(3) = psi4hnrd + CALL PUSHREAL8(molal(3)) + molal(3) = psi4 + CALL PUSHREAL8(molalhnrd(4)) +C CLI + molalhnrd(4) = psi6hnrd + CALL PUSHREAL8(molal(4)) + molal(4) = psi6 + psi7 + CALL PUSHREAL8(molalhnrd(5)) +C SO4I + molalhnrd(5) = 0.d0 + CALL PUSHREAL8(molal(5)) + molal(5) = psi2 + psi1 + CALL PUSHREAL8(molalhnrd(6)) +C HSO4I + molalhnrd(6) = 0.d0 + CALL PUSHREAL8(molal(6)) + molal(6) = zero + CALL PUSHREAL8(molalhnrd(7)) +C NO3I + molalhnrd(7) = psi5hnrd + CALL PUSHREAL8(molal(7)) + molal(7) = psi5 + psi8 + CALL PUSHREAL8(sminhnrd) +C +C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + sminhnrd = psi5hnrd + psi6hnrd - psi4hnrd + CALL PUSHREAL8(smin) + smin = 2.d0*psi2 + psi5 + psi6 - psi4 + CALL CALCPH_HNRD(smin, sminhnrd, hi, hihnrd, ohi) + CALL PUSHREAL8(molalhnrd(1)) + molalhnrd(1) = hihnrd + CALL PUSHREAL8(molal(1)) + molal(1) = hi + IF (chi4 - psi4 < tiny) THEN + CALL PUSHCONTROL1B(0) + gnh3 = tiny + gnh3hnrd = 0.d0 + ELSE + gnh3hnrd = -psi4hnrd + gnh3 = chi4 - psi4 + CALL PUSHCONTROL1B(1) + END IF + IF (chi5 - psi5 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + IF (chi6 - psi6 < tiny) THEN + CALL PUSHCONTROL1B(0) + ghcl = tiny + ghclhnrd = 0.d0 + ELSE + ghclhnrd = -psi6hnrd + ghcl = chi6 - psi6 + CALL PUSHCONTROL1B(1) + END IF +C +C CALL CALCMR ! Water content +C +C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM RICH CASE +C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/ +C +C NACL + molalrhnrd(1) = 0.d0 + molalr(1) = psi7 +C NA2SO4 + molalrhnrd(2) = 0.d0 + molalr(2) = psi1 +C NANO3 + molalrhnrd(3) = 0.d0 + molalr(3) = psi8 +C (NH4)2SO4 + molalrhnrd(4) = 0.d0 + molalr(4) = zero + IF (psi5 < zero) THEN + frno3 = zero + frno3hnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + frno3hnrd = psi5hnrd + frno3 = psi5 + CALL PUSHCONTROL1B(1) + END IF + IF (psi6 < zero) THEN + frcl = zero + frclhnrd = 0.d0 + ELSE + frclhnrd = psi6hnrd + frcl = psi6 + END IF +C MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3 +C FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3 +C MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL + IF (psi4 < frno3) THEN + molalrhnrd(5) = psi4hnrd + molalr(5) = psi4 + IF (frcl > zero) THEN + molalrhnrd(6) = 0.d0 + molalr(6) = zero + CALL PUSHCONTROL2B(0) + ELSE + molalrhnrd(6) = frclhnrd + molalr(6) = frcl + CALL PUSHCONTROL2B(1) + END IF + ELSE + molalrhnrd(5) = frno3hnrd + molalr(5) = frno3 + IF (psi4 - frno3 < zero) THEN + frnh4 = zero + frnh4hnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + frnh4hnrd = psi4hnrd - frno3hnrd + frnh4 = psi4 - frno3 + CALL PUSHCONTROL1B(1) + END IF + IF (frcl > frnh4) THEN + molalrhnrd(6) = frnh4hnrd + molalr(6) = frnh4 + CALL PUSHCONTROL2B(2) + ELSE + molalrhnrd(6) = frclhnrd + molalr(6) = frcl + CALL PUSHCONTROL2B(3) + END IF + END IF + CALL PUSHREAL8(water) +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + CALL PUSHREAL8(waterhnrd) + waterhnrd = 0.d0 + DO j=1,npair + waterhnrd = waterhnrd + molalrhnrd(j)/m0(j) + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + waterhnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF + CALL PUSHREAL8ARRAY(gamahnrd, npair) + CALL PUSHREAL8ARRAY(gama, npair) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3P_HNRD() + ENDDO + temp38hb0 = fh6abhnrdhb/a4**2 + temp37 = a6**2 + temp25 = a4/temp37 + temp26hb = temp25*temp38hb0 + temp36 = gnh3**2 + temp29 = a6/temp36 + temp30hb = temp29*temp26hb + temp35 = ghcl**2 + temp32 = gnh3/temp35 + temp33hb = temp32*temp30hb + temp34hb = ghcl*temp33hb + temp34 = molalhnrd(3)*molal(4) + molal(3)*molalhnrd(4) + temp33 = temp34*ghcl - ghclhnrd*molal(3)*molal(4) + temp32hb = temp33*temp30hb/temp35 + temp31 = gnh3hnrd/ghcl + temp31hb = -(molal(3)*molal(4)*temp30hb/ghcl) + temp30 = temp33*temp32 - molal(3)*molal(4)*temp31 + temp29hb = temp30*temp26hb/temp36 + temp27 = ghcl*gnh3 + temp28 = molal(4)/temp27 + temp28hb = -(molal(3)*a6hnrd*temp26hb/temp27) + temp27hb = -(temp28*temp28hb) + temp26 = temp30*temp29 - molal(3)*a6hnrd*temp28 + temp25hb = temp26*temp38hb0/temp37 + temp22 = ghcl*gnh3*a6 + temp23hb = -(temp38hb0/temp22) + temp24 = molal(3)*a4hnrd*molal(4) + temp23 = temp24/temp22 + temp22hb = -(temp23*temp23hb) + temp38 = a6*a4 + temp39 = ghcl*gnh3*temp38 + temp40hb = fh6abhb/temp39 + temp39hb = -(molal(3)*molal(4)*temp40hb/temp39) + temp38hb = ghcl*gnh3*temp39hb + molalhb(3) = molalhb(3) + molal(4)*temp40hb + molalhb(4) = molalhb(4) + molalhnrd(3)*temp34hb - ghclhnrd*molal(3 + + )*temp33hb - temp31*molal(3)*temp30hb + temp28hb + molal(3)* + + a4hnrd*temp23hb + molal(3)*temp40hb + ghclhb = ghclhb + temp34*temp33hb - temp32*2*ghcl*temp32hb - + + temp31*temp31hb + gnh3*temp27hb + a6*gnh3*temp22hb + temp38*gnh3 + + *temp39hb + gnh3hb = gnh3hb + temp32hb - temp29*2*gnh3*temp29hb + ghcl* + + temp27hb + a6*ghcl*temp22hb + temp38*ghcl*temp39hb + a6hb = temp29hb - temp25*2*a6*temp25hb + ghcl*gnh3*temp22hb + a4* + + temp38hb + a4hb = temp25hb - (temp26*temp25-temp23)*2*temp38hb0/a4 + a6* + + temp38hb + DO ii10=1,nions + molalhnrdhb(ii10) = 0.D0 + ENDDO + molalhnrdhb(3) = molalhnrdhb(3) + molal(4)*temp34hb + molalhb(3) = molalhb(3) + molal(4)*a4hnrd*temp23hb - temp28*a6hnrd + + *temp26hb - temp31*molal(4)*temp30hb - ghclhnrd*molal(4)* + + temp33hb + molalhnrd(4)*temp34hb + molalhnrdhb(4) = molalhnrdhb(4) + molal(3)*temp34hb + gnh3hnrdhb = temp31hb + a6hnrdhb = -(temp28*molal(3)*temp26hb) + a4hnrdhb = molal(4)*molal(3)*temp23hb + psi1hb = 0.D0 + psi7hb = 0.D0 + psi8hb = 0.D0 + DO ii10=1,npair + gamahnrdhb(ii10) = 0.D0 + ENDDO + waterhnrdhb = 0.D0 + DO ii10=1,npair + molalrhnrdhb(ii10) = 0.D0 + ENDDO + DO i=2,1,-1 + CALL POPREAL8ARRAY(gama, npair) + CALL POPREAL8ARRAY(gamahnrd, npair) + CALL CALCACT3P_HNRD_HB() + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + waterhb = 0.D0 + waterhnrdhb = 0.D0 + END IF + DO j=npair,1,-1 + molalrhb(j) = molalrhb(j) + waterhb/m0(j) + molalrhnrdhb(j) = molalrhnrdhb(j) + waterhnrdhb/m0(j) + ENDDO + CALL POPREAL8(waterhnrd) + CALL POPREAL8(water) + CALL POPCONTROL2B(branch) + IF (branch < 2) THEN + IF (branch == 0) THEN + molalrhb(6) = 0.D0 + molalrhnrdhb(6) = 0.D0 + ELSE + molalrhb(6) = 0.D0 + molalrhnrdhb(6) = 0.D0 + END IF + psi4hb = molalrhb(5) + molalrhb(5) = 0.D0 + psi4hnrdhb = molalrhnrdhb(5) + molalrhnrdhb(5) = 0.D0 + frno3hb = 0.D0 + frno3hnrdhb = 0.D0 + ELSE + IF (branch == 2) THEN + frnh4hb = molalrhb(6) + molalrhb(6) = 0.D0 + frnh4hnrdhb = molalrhnrdhb(6) + molalrhnrdhb(6) = 0.D0 + ELSE + molalrhb(6) = 0.D0 + molalrhnrdhb(6) = 0.D0 + frnh4hb = 0.D0 + frnh4hnrdhb = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + psi4hb = 0.D0 + frno3hb = 0.D0 + frno3hnrdhb = 0.D0 + psi4hnrdhb = 0.D0 + ELSE + psi4hb = frnh4hb + frno3hb = -frnh4hb + psi4hnrdhb = frnh4hnrdhb + frno3hnrdhb = -frnh4hnrdhb + END IF + frno3hb = frno3hb + molalrhb(5) + molalrhb(5) = 0.D0 + frno3hnrdhb = frno3hnrdhb + molalrhnrdhb(5) + molalrhnrdhb(5) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + psi5hb = 0.D0 + psi5hnrdhb = 0.D0 + ELSE + psi5hb = frno3hb + psi5hnrdhb = frno3hnrdhb + END IF + molalrhb(4) = 0.D0 + molalrhnrdhb(4) = 0.D0 + psi8hb = psi8hb + molalrhb(3) + molalrhb(3) = 0.D0 + molalrhnrdhb(3) = 0.D0 + psi1hb = psi1hb + molalrhb(2) + molalrhb(2) = 0.D0 + molalrhnrdhb(2) = 0.D0 + psi7hb = psi7hb + molalrhb(1) + molalrhb(1) = 0.D0 + molalrhnrdhb(1) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch /= 0) chi6hb = chi6hb + ghclhb + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + chi5hb = chi5hb + ghno3hb + psi5hb = psi5hb - ghno3hb + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + chi4hb = chi4hb + gnh3hb + psi4hb = psi4hb - gnh3hb + psi4hnrdhb = psi4hnrdhb - gnh3hnrdhb + END IF + CALL POPREAL8(molal(1)) + hihb = molalhb(1) + molalhb(1) = 0.D0 + CALL POPREAL8(molalhnrd(1)) + hihnrdhb = molalhnrdhb(1) + molalhnrdhb(1) = 0.D0 + CALL CALCPH_HNRD_HB(smin, sminhb, sminhnrd, sminhnrdhb, hi, hihb + + , hihnrd, hihnrdhb, ohi) + CALL POPREAL8(smin) + psi5hb = psi5hb + molalhb(7) + sminhb + CALL POPREAL8(sminhnrd) + psi5hnrdhb = psi5hnrdhb + molalhnrdhb(7) + sminhnrdhb + CALL POPREAL8(molal(7)) + psi8hb = psi8hb + molalhb(7) + molalhb(7) = 0.D0 + CALL POPREAL8(molalhnrd(7)) + molalhnrdhb(7) = 0.D0 + CALL POPREAL8(molal(6)) + molalhb(6) = 0.D0 + CALL POPREAL8(molalhnrd(6)) + molalhnrdhb(6) = 0.D0 + CALL POPREAL8(molal(5)) + psi1hb = psi1hb + molalhb(5) + molalhb(5) = 0.D0 + CALL POPREAL8(molalhnrd(5)) + molalhnrdhb(5) = 0.D0 + CALL POPREAL8(molal(4)) + psi7hb = psi7hb + molalhb(4) + molalhb(4) = 0.D0 + psi4hb = psi4hb + molalhb(3) - sminhb + CALL POPREAL8(molalhnrd(4)) + molalhnrdhb(4) = 0.D0 + psi4hnrdhb = psi4hnrdhb + molalhnrdhb(3) - sminhnrdhb + CALL POPREAL8(molal(3)) + molalhb(3) = 0.D0 + CALL POPREAL8(molalhnrd(3)) + molalhnrdhb(3) = 0.D0 + CALL POPREAL8(molal(2)) + psi8hb = psi8hb + molalhb(2) + psi7hb = psi7hb + molalhb(2) + psi1hb = psi1hb + 2.d0*molalhb(2) + molalhb(2) = 0.D0 + CALL POPREAL8(molalhnrd(2)) + molalhnrdhb(2) = 0.D0 + CALL POPCONTROL2B(branch) + IF (branch == 0) THEN + chi4hb = chi4hb + psi4hb + psi4hb = 0.D0 + psi4hnrdhb = 0.D0 + ELSE IF (branch /= 1) THEN + GOTO 100 + END IF + bbhb = -(0.5d0*psi4hb) + result1hb = -(0.5d0*psi4hb) + bbhnrdhb = -(0.5d0*psi4hnrdhb) + result1hnrdhb = -(0.5d0*psi4hnrdhb) + cc = chi4*(psi5+psi6) + dd = bb*bb - 4.d0*cc + IF (dd == 0.0) THEN + ddhb = 0.0 + ELSE + ddhb = result1hb/(2.0*SQRT(dd)) + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ddhnrdhb = 0.D0 + ELSE + cchnrd = chi4*(psi5hnrd+psi6hnrd) + ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd + temp21 = SQRT(dd) + temp21hb0 = result1hnrdhb/(2.0*temp21) + ddhnrdhb = temp21hb0 + IF (.NOT.dd == 0.0) ddhb = ddhb - ddhnrd*temp21hb0/(2.0* + + temp21**2) + END IF + bbhb = bbhb + 2*bbhnrd*ddhnrdhb + 2*bb*ddhb + cchb = -(4.d0*ddhb) + bbhnrdhb = bbhnrdhb + 2*bb*ddhnrdhb + cchnrdhb = -(4.d0*ddhnrdhb) + chi4hb = chi4hb + (psi6hnrd+psi5hnrd)*cchnrdhb - bbhb + (psi6+ + + psi5)*cchb + psi5hb = psi5hb + chi4*cchb - bbhb + psi5hnrdhb = psi5hnrdhb + chi4*cchnrdhb - bbhnrdhb + CALL POPREAL8(bb) + CALL POPREAL8(bbhnrd) + temp21hb = bbhnrdhb/a4**2 + a4hb = a4hb + bbhb/a4**2 - a4hnrd*2*temp21hb/a4 + a4hnrdhb = a4hnrdhb + temp21hb + 100 CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + psi5hb = 0.D0 + psi5hnrdhb = 0.D0 + END IF + temp1 = xkw*gama(5)**3 + temp0 = gama(10)/temp1 + temp1hb0 = xk2*2.0*r*temp*a4hnrdhb + temp1hb = temp0*temp1hb0 + temp0hb = (gamahnrd(10)*gama(5)-gama(10)*gamahnrd(5))*temp1hb0/ + + temp1 + temp2 = gama(10)/gama(5) + temp2hb = 2.0*temp2*xk2*r*temp*a4hb/(xkw*gama(5)) + a5 = xk4*r*temp*(water/gama(10))**2.0 + CALL POPREAL8(psi5) + temp19 = a6/a5 + temp20 = psi6 + (chi6-psi3-psi6)*temp19 + psi7 + temp20hb = -(psi5*psi5hb/temp20**2) + temp19hb = (chi6-psi3-psi6)*temp20hb/a5 + CALL POPREAL8(psi5hnrd) + temp11 = a6/a5 + temp12 = psi6 + (chi6-psi3-psi6)*temp11 + psi7 + temp19hb0 = psi5hnrdhb/temp12**2 + temp17 = a6/a5 + temp18 = psi6 + (chi6-psi3-psi6)*temp17 + psi7 + temp18hb = psi5hnrd*temp19hb0 + temp17hb = (chi6-psi3-psi6)*temp18hb/a5 + temp16 = a5**2 + temp13 = (chi6-psi3-psi6)/temp16 + temp14 = a6hnrd*a5 - a6*a5hnrd + temp15 = psi6hnrd + temp14*temp13 - psi6hnrd*a6/a5 + psi5hb = psi5hb/temp20 - temp15*temp19hb0 + temp15hb = -(psi5*temp19hb0) + temp14hb = temp13*temp15hb + temp13hb = temp14*temp15hb/temp16 + temp13hb0 = -(psi6hnrd*temp15hb/a5) + temp12hb = -((psi5hnrd*temp18-psi5*temp15)*2*temp19hb0/temp12) + psi7hb = psi7hb + temp18hb + temp12hb + chi5*psi5hb + temp20hb + temp11hb = (chi6-psi3-psi6)*temp12hb/a5 + psi5hnrdhb = temp18*temp19hb0 + CALL POPREAL8(psi5) + temp10 = (chi6-psi3-psi6)/a5 + temp10hb = -(a6*psi8*psi5hb/a5) + chi5hb = chi5hb + psi6hnrd*psi5hnrdhb + (psi6+psi7)*psi5hb + CALL POPREAL8(psi5hnrd) + temp9 = a5**2 + temp7 = (chi6-psi3-psi6)/temp9 + temp8 = a6hnrd*a5 - a6*a5hnrd + psi8hb = psi8hb - (temp8*temp7-psi6hnrd*(a6/a5))*psi5hnrdhb - + + temp10*a6*psi5hb + temp9hb = -(psi8*psi5hnrdhb) + temp8hb = temp7*temp9hb + a6hnrdhb = a6hnrdhb + a5*temp8hb + a5*temp14hb + a5hnrdhb = -(a6*temp8hb) - a6*temp14hb + temp7hb = temp8*temp9hb/temp9 + chi6hb = chi6hb + temp17*temp18hb + temp13hb + temp11*temp12hb + + + temp7hb + temp10hb + temp19*temp20hb + temp7hb0 = -(psi6hnrd*temp9hb/a5) + a6hb = a6hb + temp17hb - a5hnrd*temp14hb + temp13hb0 + temp11hb + + - a5hnrd*temp8hb + temp7hb0 - temp10*psi8*psi5hb + temp19hb + a5hb = a6hnrd*temp14hb - temp17*temp17hb - temp13*2*a5*temp13hb + + - a6*temp13hb0/a5 - temp11*temp11hb + a6hnrd*temp8hb - temp7*2 + + *a5*temp7hb - a6*temp7hb0/a5 - temp10*temp10hb - temp19* + + temp19hb + CALL POPREAL8(a6) + temp6 = water/gama(11) + temp6hb = 2.0*temp6*xk3*r*temp*a6hb/gama(11) + CALL POPREAL8(a6hnrd) + temp5 = gama(11)**3 + temp5hb1 = xk3*2.0*r*temp*a6hnrdhb + temp5hb = water*temp5hb1/temp5 + temp5hb0 = (waterhnrd*gama(11)-water*gamahnrd(11))*temp5hb1/ + + temp5 + gamahb(11) = gamahb(11) + waterhnrd*temp5hb - water*3*gama(11)** + + 2*temp5hb0/temp5 - temp6*temp6hb + gamahnrdhb(11) = gamahnrdhb(11) - water*temp5hb + temp4 = water/gama(10) + temp4hb = 2.0*temp4*xk4*r*temp*a5hb/gama(10) + CALL POPREAL8(a5hnrd) + temp3 = gama(10)**3 + temp3hb1 = xk4*2.0*r*temp*a5hnrdhb + temp3hb = water*temp3hb1/temp3 + waterhnrdhb = waterhnrdhb + gama(10)*temp3hb + gama(11)*temp5hb + temp3hb0 = (waterhnrd*gama(10)-water*gamahnrd(10))*temp3hb1/ + + temp3 + waterhb = waterhb + temp5hb0 - gamahnrd(11)*temp5hb - gamahnrd( + + 10)*temp3hb + temp3hb0 + temp4hb + temp6hb + gamahb(10) = gamahb(10) + waterhnrd*temp3hb - water*3*gama(10)** + + 2*temp3hb0/temp3 + temp2hb - temp4*temp4hb + gamahnrdhb(10) = gamahnrdhb(10) + gama(5)*temp1hb - water* + + temp3hb + CALL POPREAL8(a4) + gamahb(5) = gamahb(5) + gamahnrd(10)*temp1hb - xkw*temp0*3*gama( + + 5)**2*temp0hb - temp2*temp2hb + CALL POPREAL8(a4hnrd) + gamahb(10) = gamahb(10) + temp0hb - gamahnrd(5)*temp1hb + gamahnrdhb(5) = gamahnrdhb(5) - gama(10)*temp1hb + gnh3hb = 0.D0 + ghno3hb = 0.D0 + ghclhb = 0.D0 + a4hb = 0.D0 + a6hb = 0.D0 + a4hnrdhb = 0.D0 + gnh3hnrdhb = 0.D0 + a6hnrdhb = 0.D0 + ENDDO + chi8hb = chi8hb + psi8hb + chi7hb = chi7hb + psi7hb + chi1hb = chi1hb + psi1hb + END + +C Differentiation of calcph_hnrd in reverse (adjoint) mode: +C gradient of useful results: hihnrd hi +C with respect to varying inputs: water waterhnrd gghnrd gg +C +C Differentiation of calcph in forward (tangent) mode: +C variations of useful results: hi +C with respect to varying inputs: water gg +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCPH +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCPH_HNRD_HB(gg, gghb, gghnrd, gghnrdhb, hi, hihb, + + hihnrd, hihnrdhb, ohi) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: cn, gg, hi, ohi, bb, cc, dd + REAL*8 :: cnhb, gghb, hihb, ohihb, bbhb, cchb, ddhb + REAL*8 :: cnhnrd, gghnrd, hihnrd, ohihnrd, bbhnrd, cchnrd, + + ddhnrd + REAL*8 :: cnhnrdhb, gghnrdhb, hihnrdhb, ohihnrdhb, bbhnrdhb + + , cchnrdhb, ddhnrdhb + REAL*8 :: akw + REAL*8 :: akwhb + REAL*8 :: akwhnrd + REAL*8 :: akwhnrdhb + REAL*8 :: result1 + REAL*8 :: result1hb + REAL*8 :: result1hnrd + REAL*8 :: result1hnrdhb + REAL*8 :: x2hnrd + REAL*8 :: x2hnrdhb + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x2hb + REAL*8 :: x1 + REAL*8 :: x1hb + REAL*8 :: x1hnrd + REAL*8 :: x1hnrdhb + INTRINSIC SQRT + INTEGER :: branch + REAL*8 :: temp2 + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp0hb + INTRINSIC ABS + REAL*8 :: temp3hb + REAL*8 :: temp1hb + REAL*8 :: temp0hb0 + REAL*8 :: abs3 + REAL*8 :: abs2 + REAL*8 :: abs1 + REAL*8 :: temp2hb +C + akwhnrd = xkw*rh*(waterhnrd*water+water*waterhnrd) + akw = xkw*rh*water*water + IF (akw >= 0.) THEN + abs1 = akw + ELSE + abs1 = -akw + END IF + IF (abs1 < tiny) THEN + CALL PUSHCONTROL1B(0) + cnhnrd = 0.d0 + ELSE + cnhnrd = akwhnrd/(2.0*SQRT(akw)) + CALL PUSHCONTROL1B(1) + END IF + cn = SQRT(akw) +C +C *** GG = (negative charge) - (positive charge) +C + IF (gg > tiny) THEN +C H+ in excess + bbhnrd = -gghnrd + bb = -gg + cchnrd = -akwhnrd + cc = -akw + ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd + dd = bb*bb - 4.d0*cc + IF (dd >= 0.) THEN + abs2 = dd + ELSE + abs2 = -dd + END IF + IF (abs2 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + result1 = SQRT(dd) + x1 = 0.5d0*(-bb+result1) + IF (x1 < cn) THEN + cnhb = hihb + cnhnrdhb = hihnrdhb + x1hnrdhb = 0.D0 + x1hb = 0.D0 + ELSE + x1hb = hihb + x1hnrdhb = hihnrdhb + cnhnrdhb = 0.D0 + cnhb = 0.D0 + END IF + result1hb = 0.5d0*x1hb + bbhb = -(0.5d0*x1hb) + result1hnrdhb = 0.5d0*x1hnrdhb + bbhnrdhb = -(0.5d0*x1hnrdhb) + IF (dd == 0.0) THEN + ddhb = 0.0 + ELSE + ddhb = result1hb/(2.0*SQRT(dd)) + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ddhnrdhb = 0.D0 + ELSE + temp1 = SQRT(dd) + temp1hb = result1hnrdhb/(2.0*temp1) + ddhnrdhb = temp1hb + IF (.NOT.dd == 0.0) ddhb = ddhb - ddhnrd*temp1hb/(2.0*temp1 + + **2) + END IF + bbhb = bbhb + 2*bbhnrd*ddhnrdhb + 2*bb*ddhb + cchb = -(4.d0*ddhb) + bbhnrdhb = bbhnrdhb + 2*bb*ddhnrdhb + cchnrdhb = -(4.d0*ddhnrdhb) + akwhb = -cchb + akwhnrdhb = -cchnrdhb + gghb = -bbhb + gghnrdhb = -bbhnrdhb + ELSE +C OH- in excess + bbhnrd = gghnrd + bb = gg + cchnrd = -akwhnrd + cc = -akw + ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd + dd = bb*bb - 4.d0*cc + IF (dd >= 0.) THEN + abs3 = dd + ELSE + abs3 = -dd + END IF + IF (abs3 < tiny) THEN + result1hnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + result1hnrd = ddhnrd/(2.0*SQRT(dd)) + CALL PUSHCONTROL1B(1) + END IF + result1 = SQRT(dd) + x2hnrd = 0.5d0*(result1hnrd-bbhnrd) + x2 = 0.5d0*(-bb+result1) + IF (x2 < cn) THEN + ohihnrd = cnhnrd + ohi = cn + CALL PUSHCONTROL1B(0) + ELSE + ohihnrd = x2hnrd + ohi = x2 + CALL PUSHCONTROL1B(1) + END IF + temp3hb = hihnrdhb/ohi**2 + akwhb = hihb/ohi - ohihnrd*temp3hb + ohihb = (akwhnrd-(akwhnrd*ohi-akw*ohihnrd)*2/ohi)*temp3hb - akw* + + hihb/ohi**2 + akwhnrdhb = ohi*temp3hb + ohihnrdhb = -(akw*temp3hb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cnhb = ohihb + cnhnrdhb = ohihnrdhb + x2hb = 0.D0 + x2hnrdhb = 0.D0 + ELSE + x2hb = ohihb + x2hnrdhb = ohihnrdhb + cnhnrdhb = 0.D0 + cnhb = 0.D0 + END IF + result1hb = 0.5d0*x2hb + bbhb = -(0.5d0*x2hb) + result1hnrdhb = 0.5d0*x2hnrdhb + bbhnrdhb = -(0.5d0*x2hnrdhb) + IF (dd == 0.0) THEN + ddhb = 0.0 + ELSE + ddhb = result1hb/(2.0*SQRT(dd)) + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ddhnrdhb = 0.D0 + ELSE + temp2 = SQRT(dd) + temp2hb = result1hnrdhb/(2.0*temp2) + ddhnrdhb = temp2hb + IF (.NOT.dd == 0.0) ddhb = ddhb - ddhnrd*temp2hb/(2.0*temp2 + + **2) + END IF + bbhb = bbhb + 2*bbhnrd*ddhnrdhb + 2*bb*ddhb + cchb = -(4.d0*ddhb) + bbhnrdhb = bbhnrdhb + 2*bb*ddhnrdhb + cchnrdhb = -(4.d0*ddhnrdhb) + akwhb = akwhb - cchb + akwhnrdhb = akwhnrdhb - cchnrdhb + gghb = bbhb + gghnrdhb = bbhnrdhb + END IF + IF (.NOT.akw == 0.0) akwhb = akwhb + cnhb/(2.0*SQRT(akw)) + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp0 = SQRT(akw) + temp0hb0 = cnhnrdhb/(2.0*temp0) + akwhnrdhb = akwhnrdhb + temp0hb0 + IF (.NOT.akw == 0.0) akwhb = akwhb - akwhnrd*temp0hb0/(2.0* + + temp0**2) + END IF + temp0hb = xkw*rh*akwhnrdhb + waterhb = 2*waterhnrd*temp0hb + xkw*rh*2*water*akwhb + waterhnrdhb = 2*water*temp0hb + END + +C Differentiation of calcact3p_hnrd in reverse (adjoint) mode: +C gradient of useful results: molal gama water molalhnrd +C gamahnrd waterhnrd +C with respect to varying inputs: molal gama water molalhnrd +C gamahnrd waterhnrd +C +C Differentiation of calcact3p in forward (tangent) mode: +C variations of useful results: gama +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3P_HNRD_HB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0hb(6, 4), sionhb, hhb, chhb, f1hb(3), f2hb(4) + REAL*8 :: g0hnrd(6, 4), sionhnrd, hhnrd, chhnrd, f1hnrd(3) + + , f2hnrd(4) + REAL*8 :: g0hnrdhb(6, 4), sionhnrdhb, hhnrdhb, chhnrdhb, + + f1hnrdhb(3), f2hnrdhb(4) + REAL*8 :: mpl, xij, yji + REAL*8 :: mplhb, xijhb, yjihb + REAL*8 :: mplhnrd, xijhnrd, yjihnrd + REAL*8 :: mplhnrdhb, xijhnrdhb, yjihnrdhb + REAL*8 :: ionichb, ionichnrd, ionichnrdhb + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01hb + REAL*8 :: g01hnrd + REAL*8 :: g01hnrdhb + REAL*8 :: g02 + REAL*8 :: g02hb + REAL*8 :: g02hnrd + REAL*8 :: g02hnrdhb + REAL*8 :: g03 + REAL*8 :: g03hb + REAL*8 :: g03hnrd + REAL*8 :: g03hnrdhb + REAL*8 :: g04 + REAL*8 :: g04hb + REAL*8 :: g04hnrd + REAL*8 :: g04hnrdhb + REAL*8 :: g05 + REAL*8 :: g05hb + REAL*8 :: g05hnrd + REAL*8 :: g05hnrdhb + REAL*8 :: g06 + REAL*8 :: g06hb + REAL*8 :: g06hnrd + REAL*8 :: g06hnrdhb + REAL*8 :: g07 + REAL*8 :: g07hb + REAL*8 :: g07hnrd + REAL*8 :: g07hnrdhb + REAL*8 :: g08 + REAL*8 :: g08hb + REAL*8 :: g08hnrd + REAL*8 :: g08hnrdhb + REAL*8 :: g09 + REAL*8 :: g09hb + REAL*8 :: g09hnrd + REAL*8 :: g09hnrdhb + REAL*8 :: g10 + REAL*8 :: g10hb + REAL*8 :: g10hnrd + REAL*8 :: g10hnrdhb + REAL*8 :: g11 + REAL*8 :: g11hb + REAL*8 :: g11hnrd + REAL*8 :: g11hnrdhb + REAL*8 :: g12 + REAL*8 :: g12hb + REAL*8 :: g12hnrd + REAL*8 :: g12hnrdhb + INTEGER :: j + REAL*8 :: x2hnrd + REAL*8 :: x2hnrdhb + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x2hb + REAL*8 :: x1 + REAL*8 :: x1hb + REAL*8 :: x1hnrd + REAL*8 :: x1hnrdhb + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT + INTEGER :: branch + REAL*8 :: temp2 + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp2hb19 + REAL*8 :: temp2hb18 + REAL*8 :: temp2hb17 + REAL*8 :: temp2hb16 + REAL*8 :: temp2hb15 + REAL*8 :: temp2hb14 + REAL*8 :: temp2hb13 + REAL*8 :: temp2hb12 + REAL*8 :: temp2hb11 + REAL*8 :: temp2hb10 + REAL*8 :: temp0hb + INTRINSIC ABS + INTEGER :: ii20 + REAL*8 :: temp1hb + INTRINSIC LOG + REAL*8 :: temp0hb1 + INTEGER :: ii10 + REAL*8 :: temp0hb0 + REAL*8 :: temp2hb25 + REAL*8 :: temp2hb24 + REAL*8 :: temp1hb4 + REAL*8 :: temp2hb23 + REAL*8 :: temp1hb3 + REAL*8 :: temp2hb22 + REAL*8 :: abs1 + REAL*8 :: temp1hb2 + REAL*8 :: temp2hb21 + REAL*8 :: temp1hb1 + REAL*8 :: temp2hb20 + REAL*8 :: temp1hb0 + REAL*8 :: temp2hb9 + REAL*8 :: temp2hb8 + REAL*8 :: temp2hb7 + REAL*8 :: temp2hb6 + REAL*8 :: temp2hb5 + REAL*8 :: temp2hb4 + REAL*8 :: temp2hb3 + REAL*8 :: temp2hb2 + REAL*8 :: temp2hb1 + REAL*8 :: temp2hb0 + REAL*8 :: temp2hb +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + ionichnrd = 0.d0 + DO i=1,7 + ionichnrd = ionichnrd + z(i)**2*molalhnrd(i) + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + x1hnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1hnrd = (0.5d0*ionichnrd*water-0.5d0*ionic*waterhnrd)/water**2 + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHREAL8(ionichnrd) + ionichnrd = 0.d0 + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionichnrd) + ionichnrd = x1hnrd + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3_HNRD(ionic, ionichnrd, temp, g01, g01hnrd, g02, + + g02hnrd, g03, g03hnrd, g04, g04hnrd, g05, g05hnrd + + , g06, g06hnrd, g07, g07hnrd, g08, g08hnrd, g09, + + g09hnrd, g10, g10hnrd, g11, g11hnrd, g12, g12hnrd + + ) + DO ii1=1,4 + DO ii2=1,6 + g0hnrd(ii2, ii1) = 0.d0 + ENDDO + ENDDO +C + g0hnrd(1, 1) = g11hnrd + g0(1, 1) = g11 + g0hnrd(1, 2) = g07hnrd + g0(1, 2) = g07 + g0hnrd(1, 3) = g08hnrd + g0(1, 3) = g08 + g0hnrd(1, 4) = g10hnrd + g0(1, 4) = g10 + g0hnrd(2, 1) = g01hnrd + g0(2, 1) = g01 + g0hnrd(2, 2) = g02hnrd + g0(2, 2) = g02 + g0hnrd(2, 3) = g12hnrd + g0(2, 3) = g12 + g0hnrd(2, 4) = g03hnrd + g0(2, 4) = g03 + g0hnrd(3, 1) = g06hnrd + g0(3, 1) = g06 + g0hnrd(3, 2) = g04hnrd + g0(3, 2) = g04 + g0hnrd(3, 3) = g09hnrd + g0(3, 3) = g09 + g0hnrd(3, 4) = g05hnrd + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + IF (ionic >= 0.) THEN + abs1 = ionic + ELSE + abs1 = -ionic + END IF + IF (abs1 < tiny) THEN + CALL PUSHCONTROL1B(0) + sionhnrd = 0.d0 + ELSE + sionhnrd = ionichnrd/(2.0*SQRT(ionic)) + CALL PUSHCONTROL1B(1) + END IF + sion = SQRT(ionic) + hhnrd = (agama*sionhnrd*(1.d0+sion)-agama*sion*sionhnrd)/(1.d0+ + + sion)**2 + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 + DO ii1=1,3 + f1hnrd(ii1) = 0.d0 + ENDDO + DO ii1=1,4 + f2hnrd(ii1) = 0.d0 + ENDDO +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mplhnrd) + mplhnrd = (molalhnrd(i)*water-molal(i)*waterhnrd)/water**2 + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + chhnrd = -(0.25d0*(zpl+zmi)**2*ionichnrd/ionic**2) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xijhnrd = chhnrd*mpl + ch*mplhnrd + xij = ch*mpl + CALL PUSHREAL8(yjihnrd) + yjihnrd = ((chhnrd*molal(j+3)+ch*molalhnrd(j+3))*water-ch* + + molal(j+3)*waterhnrd)/water**2 + yji = ch*molal(j+3)/water + f1hnrd(i) = f1hnrd(i) + yjihnrd*(g0(i, j)+zpl*zmi*h) + yji*( + + g0hnrd(i, j)+zpl*zmi*hhnrd) + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2hnrd(j) = f2hnrd(j) + xijhnrd*(g0(i, j)+zpl*zmi*h) + xij*( + + g0hnrd(i, j)+zpl*zmi*hhnrd) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gamahnrd(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gamahnrd(1) = zz(1)*((f1hnrd(2)/z(2)+f2hnrd(1)/z(4))/(z(2)+z(4))- + + hhnrd) + CALL PUSHREAL8(gama(1)) + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gamahnrd(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gamahnrd(2) = zz(2)*((f1hnrd(2)/z(2)+f2hnrd(2)/z(5))/(z(2)+z(5))- + + hhnrd) + CALL PUSHREAL8(gama(2)) + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gamahnrd(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gamahnrd(3) = zz(3)*((f1hnrd(2)/z(2)+f2hnrd(4)/z(7))/(z(2)+z(7))- + + hhnrd) + CALL PUSHREAL8(gama(3)) + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gamahnrd(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gamahnrd(4) = zz(4)*((f1hnrd(3)/z(3)+f2hnrd(2)/z(5))/(z(3)+z(5))- + + hhnrd) + CALL PUSHREAL8(gama(4)) + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gamahnrd(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gamahnrd(5) = zz(5)*((f1hnrd(3)/z(3)+f2hnrd(4)/z(7))/(z(3)+z(7))- + + hhnrd) + CALL PUSHREAL8(gama(5)) + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gamahnrd(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gamahnrd(6) = zz(6)*((f1hnrd(3)/z(3)+f2hnrd(1)/z(4))/(z(3)+z(4))- + + hhnrd) + CALL PUSHREAL8(gama(6)) + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gamahnrd(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gamahnrd(7) = zz(7)*((f1hnrd(1)/z(1)+f2hnrd(2)/z(5))/(z(1)+z(5))- + + hhnrd) + CALL PUSHREAL8(gama(7)) + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gamahnrd(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gamahnrd(8) = zz(8)*((f1hnrd(1)/z(1)+f2hnrd(3)/z(6))/(z(1)+z(6))- + + hhnrd) + CALL PUSHREAL8(gama(8)) + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gamahnrd(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gamahnrd(9) = zz(9)*((f1hnrd(3)/z(3)+f2hnrd(3)/z(6))/(z(3)+z(6))- + + hhnrd) + CALL PUSHREAL8(gama(9)) + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gamahnrd(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gamahnrd(10) = zz(10)*((f1hnrd(1)/z(1)+f2hnrd(4)/z(7))/(z(1)+z(7)) + + -hhnrd) + CALL PUSHREAL8(gama(10)) + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gamahnrd(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gamahnrd(11) = zz(11)*((f1hnrd(1)/z(1)+f2hnrd(1)/z(4))/(z(1)+z(4)) + + -hhnrd) + CALL PUSHREAL8(gama(11)) + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gamahnrd(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gamahnrd(12) = zz(12)*((f1hnrd(2)/z(2)+f2hnrd(3)/z(6))/(z(2)+z(6)) + + -hhnrd) + CALL PUSHREAL8(gama(12)) + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gamahnrd(13)) +C LC ; SCAPE + gamahnrd(13) = 0.2d0*(3.d0*gamahnrd(4)+2.d0*gamahnrd(9)) + CALL PUSHREAL8(gama(13)) + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + x2hnrd = 0.d0 + ELSE + x2hnrd = gamahnrd(i) + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHREAL8(gamahnrd(i)) + gamahnrd(i) = 0.d0 + CALL PUSHREAL8(gama(i)) + gama(i) = -5.0d0 + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(gamahnrd(i)) + gamahnrd(i) = x2hnrd + CALL PUSHREAL8(gama(i)) + gama(i) = x2 + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + temp2hb25 = LOG(10.d0)*gamahnrdhb(i) + temp2 = 10.d0**gama(i) + gamahb(i) = gamahnrd(i)*temp2*LOG(10.d0)*temp2hb25 + 10.d0**gama + + (i)*LOG(10.d0)*gamahb(i) + gamahnrdhb(i) = temp2*temp2hb25 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(gama(i)) + gamahb(i) = 0.D0 + CALL POPREAL8(gamahnrd(i)) + gamahnrdhb(i) = 0.D0 + x2hb = 0.D0 + x2hnrdhb = 0.D0 + ELSE + CALL POPREAL8(gama(i)) + x2hb = gamahb(i) + gamahb(i) = 0.D0 + CALL POPREAL8(gamahnrd(i)) + x2hnrdhb = gamahnrdhb(i) + gamahnrdhb(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + gamahb(i) = gamahb(i) + x2hb + gamahnrdhb(i) = gamahnrdhb(i) + x2hnrdhb + END IF + ENDDO + CALL POPREAL8(gama(13)) + gamahb(4) = gamahb(4) + 0.2d0*3.d0*gamahb(13) + gamahb(9) = gamahb(9) + 0.2d0*2.d0*gamahb(13) + gamahb(13) = 0.D0 + CALL POPREAL8(gamahnrd(13)) + gamahnrdhb(4) = gamahnrdhb(4) + 0.2d0*3.d0*gamahnrdhb(13) + gamahnrdhb(9) = gamahnrdhb(9) + 0.2d0*2.d0*gamahnrdhb(13) + gamahnrdhb(13) = 0.D0 + DO ii10=1,3 + f1hb(ii10) = 0.D0 + ENDDO + DO ii10=1,4 + f2hb(ii10) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp2hb1 = zz(12)*gamahb(12)/(z(2)+z(6)) + f1hb(2) = f1hb(2) + temp2hb1/z(2) + f2hb(3) = f2hb(3) + temp2hb1/z(6) + hhb = -(zz(12)*gamahb(12)) + gamahb(12) = 0.D0 + DO ii10=1,3 + f1hnrdhb(ii10) = 0.D0 + ENDDO + DO ii10=1,4 + f2hnrdhb(ii10) = 0.D0 + ENDDO + CALL POPREAL8(gamahnrd(12)) + temp2hb2 = zz(12)*gamahnrdhb(12)/(z(2)+z(6)) + f1hnrdhb(2) = f1hnrdhb(2) + temp2hb2/z(2) + f2hnrdhb(3) = f2hnrdhb(3) + temp2hb2/z(6) + hhnrdhb = -(zz(12)*gamahnrdhb(12)) + gamahnrdhb(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp2hb3 = zz(11)*gamahb(11)/(z(1)+z(4)) + f2hb(1) = f2hb(1) + temp2hb3/z(4) + hhb = hhb - zz(11)*gamahb(11) + gamahb(11) = 0.D0 + CALL POPREAL8(gamahnrd(11)) + temp2hb5 = zz(11)*gamahnrdhb(11)/(z(1)+z(4)) + f2hnrdhb(1) = f2hnrdhb(1) + temp2hb5/z(4) + hhnrdhb = hhnrdhb - zz(11)*gamahnrdhb(11) + gamahnrdhb(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp2hb4 = zz(10)*gamahb(10)/(z(1)+z(7)) + f1hb(1) = f1hb(1) + temp2hb4/z(1) + temp2hb3/z(1) + f2hb(4) = f2hb(4) + temp2hb4/z(7) + hhb = hhb - zz(10)*gamahb(10) + gamahb(10) = 0.D0 + CALL POPREAL8(gamahnrd(10)) + temp2hb6 = zz(10)*gamahnrdhb(10)/(z(1)+z(7)) + f1hnrdhb(1) = f1hnrdhb(1) + temp2hb6/z(1) + temp2hb5/z(1) + f2hnrdhb(4) = f2hnrdhb(4) + temp2hb6/z(7) + hhnrdhb = hhnrdhb - zz(10)*gamahnrdhb(10) + gamahnrdhb(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp2hb7 = zz(9)*gamahb(9)/(z(3)+z(6)) + f1hb(3) = f1hb(3) + temp2hb7/z(3) + hhb = hhb - zz(9)*gamahb(9) + gamahb(9) = 0.D0 + CALL POPREAL8(gamahnrd(9)) + temp2hb9 = zz(9)*gamahnrdhb(9)/(z(3)+z(6)) + f1hnrdhb(3) = f1hnrdhb(3) + temp2hb9/z(3) + hhnrdhb = hhnrdhb - zz(9)*gamahnrdhb(9) + gamahnrdhb(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp2hb8 = zz(8)*gamahb(8)/(z(1)+z(6)) + f2hb(3) = f2hb(3) + temp2hb8/z(6) + temp2hb7/z(6) + hhb = hhb - zz(8)*gamahb(8) + gamahb(8) = 0.D0 + CALL POPREAL8(gamahnrd(8)) + temp2hb10 = zz(8)*gamahnrdhb(8)/(z(1)+z(6)) + f2hnrdhb(3) = f2hnrdhb(3) + temp2hb10/z(6) + temp2hb9/z(6) + hhnrdhb = hhnrdhb - zz(8)*gamahnrdhb(8) + gamahnrdhb(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp2hb11 = zz(7)*gamahb(7)/(z(1)+z(5)) + f1hb(1) = f1hb(1) + temp2hb11/z(1) + temp2hb8/z(1) + f2hb(2) = f2hb(2) + temp2hb11/z(5) + hhb = hhb - zz(7)*gamahb(7) + gamahb(7) = 0.D0 + CALL POPREAL8(gamahnrd(7)) + temp2hb12 = zz(7)*gamahnrdhb(7)/(z(1)+z(5)) + f1hnrdhb(1) = f1hnrdhb(1) + temp2hb12/z(1) + temp2hb10/z(1) + f2hnrdhb(2) = f2hnrdhb(2) + temp2hb12/z(5) + hhnrdhb = hhnrdhb - zz(7)*gamahnrdhb(7) + gamahnrdhb(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp2hb13 = zz(6)*gamahb(6)/(z(3)+z(4)) + f2hb(1) = f2hb(1) + temp2hb13/z(4) + hhb = hhb - zz(6)*gamahb(6) + gamahb(6) = 0.D0 + CALL POPREAL8(gamahnrd(6)) + temp2hb16 = zz(6)*gamahnrdhb(6)/(z(3)+z(4)) + f2hnrdhb(1) = f2hnrdhb(1) + temp2hb16/z(4) + hhnrdhb = hhnrdhb - zz(6)*gamahnrdhb(6) + gamahnrdhb(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp2hb14 = zz(5)*gamahb(5)/(z(3)+z(7)) + f2hb(4) = f2hb(4) + temp2hb14/z(7) + hhb = hhb - zz(5)*gamahb(5) + gamahb(5) = 0.D0 + CALL POPREAL8(gamahnrd(5)) + temp2hb17 = zz(5)*gamahnrdhb(5)/(z(3)+z(7)) + f2hnrdhb(4) = f2hnrdhb(4) + temp2hb17/z(7) + hhnrdhb = hhnrdhb - zz(5)*gamahnrdhb(5) + gamahnrdhb(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp2hb15 = zz(4)*gamahb(4)/(z(3)+z(5)) + f1hb(3) = f1hb(3) + temp2hb14/z(3) + temp2hb15/z(3) + temp2hb13/z( + + 3) + f2hb(2) = f2hb(2) + temp2hb15/z(5) + hhb = hhb - zz(4)*gamahb(4) + gamahb(4) = 0.D0 + CALL POPREAL8(gamahnrd(4)) + temp2hb18 = zz(4)*gamahnrdhb(4)/(z(3)+z(5)) + f1hnrdhb(3) = f1hnrdhb(3) + temp2hb17/z(3) + temp2hb18/z(3) + + + temp2hb16/z(3) + f2hnrdhb(2) = f2hnrdhb(2) + temp2hb18/z(5) + hhnrdhb = hhnrdhb - zz(4)*gamahnrdhb(4) + gamahnrdhb(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp2hb19 = zz(3)*gamahb(3)/(z(2)+z(7)) + f2hb(4) = f2hb(4) + temp2hb19/z(7) + hhb = hhb - zz(3)*gamahb(3) + gamahb(3) = 0.D0 + CALL POPREAL8(gamahnrd(3)) + temp2hb22 = zz(3)*gamahnrdhb(3)/(z(2)+z(7)) + f2hnrdhb(4) = f2hnrdhb(4) + temp2hb22/z(7) + hhnrdhb = hhnrdhb - zz(3)*gamahnrdhb(3) + gamahnrdhb(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp2hb20 = zz(2)*gamahb(2)/(z(2)+z(5)) + f2hb(2) = f2hb(2) + temp2hb20/z(5) + hhb = hhb - zz(2)*gamahb(2) + gamahb(2) = 0.D0 + CALL POPREAL8(gamahnrd(2)) + temp2hb23 = zz(2)*gamahnrdhb(2)/(z(2)+z(5)) + f2hnrdhb(2) = f2hnrdhb(2) + temp2hb23/z(5) + hhnrdhb = hhnrdhb - zz(2)*gamahnrdhb(2) + gamahnrdhb(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp2hb21 = zz(1)*gamahb(1)/(z(2)+z(4)) + f1hb(2) = f1hb(2) + temp2hb20/z(2) + temp2hb21/z(2) + temp2hb19/z( + + 2) + f2hb(1) = f2hb(1) + temp2hb21/z(4) + hhb = hhb - zz(1)*gamahb(1) + gamahb(1) = 0.D0 + CALL POPREAL8(gamahnrd(1)) + temp2hb24 = zz(1)*gamahnrdhb(1)/(z(2)+z(4)) + f1hnrdhb(2) = f1hnrdhb(2) + temp2hb23/z(2) + temp2hb24/z(2) + + + temp2hb22/z(2) + f2hnrdhb(1) = f2hnrdhb(1) + temp2hb24/z(4) + hhnrdhb = hhnrdhb - zz(1)*gamahnrdhb(1) + gamahnrdhb(1) = 0.D0 + ionichb = 0.D0 + ionichnrdhb = 0.D0 + DO ii10=1,4 + DO ii20=1,6 + g0hb(ii20, ii10) = 0.D0 + ENDDO + ENDDO + DO ii10=1,4 + DO ii20=1,6 + g0hnrdhb(ii20, ii10) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mplhnrdhb = 0.D0 + mplhb = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijhb = (g0hnrd(i, j)+zpl*zmi*hhnrd)*f2hnrdhb(j) + (g0(i, j)+ + + zpl*zmi*h)*f2hb(j) + chhnrd = -(0.25d0*(zpl+zmi)**2*ionichnrd/ionic**2) + xijhnrd = chhnrd*mpl + ch*mplhnrd + xijhnrdhb = (g0(i, j)+zpl*zmi*h)*f2hnrdhb(j) + yji = ch*molal(j+3)/water + g0hb(i, j) = g0hb(i, j) + xijhnrd*f2hnrdhb(j) + yjihnrd* + + f1hnrdhb(i) + yji*f1hb(i) + xij*f2hb(j) + hhb = hhb + xijhnrd*zpl*zmi*f2hnrdhb(j) + yjihnrd*zpl*zmi* + + f1hnrdhb(i) + yji*zpl*zmi*f1hb(i) + xij*zpl*zmi*f2hb(j) + g0hnrdhb(i, j) = g0hnrdhb(i, j) + yji*f1hnrdhb(i) + xij* + + f2hnrdhb(j) + hhnrdhb = hhnrdhb + yji*zpl*zmi*f1hnrdhb(i) + xij*zpl*zmi* + + f2hnrdhb(j) + yjihb = (g0hnrd(i, j)+zpl*zmi*hhnrd)*f1hnrdhb(i) + (g0(i, j)+ + + zpl*zmi*h)*f1hb(i) + yjihnrdhb = (g0(i, j)+zpl*zmi*h)*f1hnrdhb(i) + temp2hb = molal(j+3)*yjihb/water + CALL POPREAL8(yjihnrd) + temp2hb0 = yjihnrdhb/water**2 + temp1hb2 = water*temp2hb0 + molalhb(j+3) = molalhb(j+3) + chhnrd*temp1hb2 - ch*waterhnrd* + + temp2hb0 + ch*yjihb/water + temp1 = chhnrd*molal(j+3) + ch*molalhnrd(j+3) + waterhb = waterhb + (temp1-(temp1*water-molal(j+3)*(ch* + + waterhnrd))*2/water)*temp2hb0 - ch*temp2hb/water + temp1hb3 = -(molal(j+3)*temp2hb0) + chhb = molalhnrd(j+3)*temp1hb2 + waterhnrd*temp1hb3 + mplhnrd* + + xijhnrdhb + mpl*xijhb + temp2hb + chhnrdhb = mpl*xijhnrdhb + molal(j+3)*temp1hb2 + molalhnrdhb(j+3) = molalhnrdhb(j+3) + ch*temp1hb2 + waterhnrdhb = waterhnrdhb + ch*temp1hb3 + mplhb = mplhb + chhnrd*xijhnrdhb + ch*xijhb + mplhnrdhb = mplhnrdhb + ch*xijhnrdhb + temp1hb4 = -((zpl+zmi)**2*0.25d0*chhnrdhb/ionic**2) + ionichb = ionichb - ionichnrd*2*temp1hb4/ionic - (zpl+zmi)**2* + + 0.25d0*chhb/ionic**2 + ionichnrdhb = ionichnrdhb + temp1hb4 + ENDDO + temp1hb1 = mplhnrdhb/water**2 + CALL POPREAL8(mpl) + molalhb(i) = molalhb(i) + mplhb/water - waterhnrd*temp1hb1 + waterhb = waterhb + (molalhnrd(i)-(molalhnrd(i)*water-molal(i)* + + waterhnrd)*2/water)*temp1hb1 - molal(i)*mplhb/water**2 + CALL POPREAL8(mplhnrd) + molalhnrdhb(i) = molalhnrdhb(i) + water*temp1hb1 + waterhnrdhb = waterhnrdhb - molal(i)*temp1hb1 + CALL POPREAL8(zpl) + ENDDO + temp1hb0 = hhnrdhb/(sion+1.d0)**2 + temp1hb = agama*hhb/(sion+1.d0) + sionhb = (1.D0-sion/(sion+1.d0))*temp1hb - (agama*(sionhnrd*(sion+ + + 1.d0))-agama*(sion*sionhnrd))*2*temp1hb0/(sion+1.d0) + sionhnrdhb = (agama*(sion+1.d0)-agama*sion)*temp1hb0 + IF (.NOT.ionic == 0.0) ionichb = ionichb + sionhb/(2.0*SQRT( + + ionic)) + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp0 = SQRT(ionic) + temp0hb1 = sionhnrdhb/(2.0*temp0) + ionichnrdhb = ionichnrdhb + temp0hb1 + IF (.NOT.ionic == 0.0) ionichb = ionichb - ionichnrd*temp0hb1/ + + (2.0*temp0**2) + END IF + g05hb = g0hb(3, 4) + g0hb(3, 4) = 0.D0 + g05hnrdhb = g0hnrdhb(3, 4) + g0hnrdhb(3, 4) = 0.D0 + g09hb = g0hb(3, 3) + g0hb(3, 3) = 0.D0 + g09hnrdhb = g0hnrdhb(3, 3) + g0hnrdhb(3, 3) = 0.D0 + g04hb = g0hb(3, 2) + g0hb(3, 2) = 0.D0 + g04hnrdhb = g0hnrdhb(3, 2) + g0hnrdhb(3, 2) = 0.D0 + g06hb = g0hb(3, 1) + g0hb(3, 1) = 0.D0 + g06hnrdhb = g0hnrdhb(3, 1) + g0hnrdhb(3, 1) = 0.D0 + g03hb = g0hb(2, 4) + g0hb(2, 4) = 0.D0 + g03hnrdhb = g0hnrdhb(2, 4) + g0hnrdhb(2, 4) = 0.D0 + g12hb = g0hb(2, 3) + g0hb(2, 3) = 0.D0 + g12hnrdhb = g0hnrdhb(2, 3) + g0hnrdhb(2, 3) = 0.D0 + g02hb = g0hb(2, 2) + g0hb(2, 2) = 0.D0 + g02hnrdhb = g0hnrdhb(2, 2) + g0hnrdhb(2, 2) = 0.D0 + g01hb = g0hb(2, 1) + g0hb(2, 1) = 0.D0 + g01hnrdhb = g0hnrdhb(2, 1) + g0hnrdhb(2, 1) = 0.D0 + g10hb = g0hb(1, 4) + g0hb(1, 4) = 0.D0 + g10hnrdhb = g0hnrdhb(1, 4) + g0hnrdhb(1, 4) = 0.D0 + g08hb = g0hb(1, 3) + g0hb(1, 3) = 0.D0 + g08hnrdhb = g0hnrdhb(1, 3) + g0hnrdhb(1, 3) = 0.D0 + g07hb = g0hb(1, 2) + g0hb(1, 2) = 0.D0 + g07hnrdhb = g0hnrdhb(1, 2) + g0hnrdhb(1, 2) = 0.D0 + g11hb = g0hb(1, 1) + g11hnrdhb = g0hnrdhb(1, 1) + CALL KMFUL3_HNRD_HB(ionic, ionichb, ionichnrd, ionichnrdhb, temp, + + g01, g01hb, g01hnrd, g01hnrdhb, g02, g02hb, + + g02hnrd, g02hnrdhb, g03, g03hb, g03hnrd, + + g03hnrdhb, g04, g04hb, g04hnrd, g04hnrdhb, g05 + + , g05hb, g05hnrd, g05hnrdhb, g06, g06hb, + + g06hnrd, g06hnrdhb, g07, g07hb, g07hnrd, + + g07hnrdhb, g08, g08hb, g08hnrd, g08hnrdhb, g09 + + , g09hb, g09hnrd, g09hnrdhb, g10, g10hb, + + g10hnrd, g10hnrdhb, g11, g11hb, g11hnrd, + + g11hnrdhb, g12, g12hb, g12hnrd, g12hnrdhb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionichnrd) + CALL POPREAL8(ionic) + x1hnrdhb = 0.D0 + x1hb = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1hb = ionichb + CALL POPREAL8(ionichnrd) + x1hnrdhb = ionichnrdhb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ionichb = 0.D0 + ionichnrdhb = 0.D0 + ELSE + temp0hb0 = x1hnrdhb/water**2 + temp0hb = 0.5d0*x1hb/water + ionichb = temp0hb - 0.5d0*waterhnrd*temp0hb0 + waterhb = waterhb + (0.5d0*ionichnrd-(0.5d0*(ionichnrd*water)- + + 0.5d0*(ionic*waterhnrd))*2/water)*temp0hb0 - ionic*temp0hb/ + + water + ionichnrdhb = 0.5d0*water*temp0hb0 + waterhnrdhb = waterhnrdhb - 0.5d0*ionic*temp0hb0 + END IF + DO i=7,1,-1 + molalhb(i) = molalhb(i) + z(i)**2*ionichb + molalhnrdhb(i) = molalhnrdhb(i) + z(i)**2*ionichnrdhb + ENDDO + END + +C Differentiation of kmful3_hnrd in reverse (adjoint) mode: +C gradient of useful results: g05hnrd g01hnrd ionichnrd g01 +C g06hnrd g02 g03 g04 g05 g06 g07 g08 g09 g02hnrd +C g07hnrd g10hnrd g10 g11 g12 g03hnrd g08hnrd g11hnrd +C ionic g04hnrd g09hnrd g12hnrd +C with respect to varying inputs: ionichnrd ionic +C +C Differentiation of kmful3 in forward (tangent) mode: +C variations of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_HNRD_HB(ionic, ionichb, ionichnrd, ionichnrdhb, + + temp, g01, g01hb, g01hnrd, g01hnrdhb, + + g02, g02hb, g02hnrd, g02hnrdhb, g03, + + g03hb, g03hnrd, g03hnrdhb, g04, g04hb, + + g04hnrd, g04hnrdhb, g05, g05hb, g05hnrd + + , g05hnrdhb, g06, g06hb, g06hnrd, + + g06hnrdhb, g07, g07hb, g07hnrd, + + g07hnrdhb, g08, g08hb, g08hnrd, + + g08hnrdhb, g09, g09hb, g09hnrd, + + g09hnrdhb, g10, g10hb, g10hnrd, + + g10hnrdhb, g11, g11hb, g11hnrd, + + g11hnrdhb, g12, g12hb, g12hnrd, + + g12hnrdhb) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionichb, sionhb, cf2hb + REAL*8 :: ionichnrd, sionhnrd, cf2hnrd + REAL*8 :: ionichnrdhb, sionhnrdhb, cf2hnrdhb + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01hb, g02hb, g03hb, g04hb, g05hb, g06hb, g07hb, + + g08hb, g09hb, g10hb, g11hb, g12hb + REAL*8 :: g01hnrd, g02hnrd, g03hnrd, g04hnrd, g05hnrd, + + g06hnrd, g07hnrd, g08hnrd, g09hnrd, g10hnrd, + + g11hnrd, g12hnrd + REAL*8 :: g01hnrdhb, g02hnrdhb, g03hnrdhb, g04hnrdhb, + + g05hnrdhb, g06hnrdhb, g07hnrdhb, g08hnrdhb, + + g09hnrdhb, g10hnrdhb, g11hnrdhb, g12hnrdhb + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTRINSIC ABS + REAL*8 :: abs1, tiny + INTRINSIC SQRT + INTEGER :: branch + REAL*8 :: temp0 + REAL*8 :: temp0hb + REAL*8 :: temp1hb + REAL*8 :: abs2 + REAL*8 :: temp1hb3 + REAL*8 :: temp1hb2 + REAL*8 :: temp1hb1 + REAL*8 :: temp1hb0 + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + tiny = 1.d-20 + IF (ionic >= 0.) THEN + abs2 = ionic + ELSE + abs2 = -ionic + END IF + IF (abs2 < tiny) THEN + CALL PUSHCONTROL1B(0) + sionhnrd = 0.d0 + ELSE + sionhnrd = ionichnrd/(2.0*SQRT(ionic)) + CALL PUSHCONTROL1B(1) + END IF + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.d0) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01hb = g01hb + g12hb + g08hb = g08hb + g09hb + g12hb + g11hb = g11hb - g09hb - g12hb + g01hnrdhb = g01hnrdhb + g12hnrdhb + g08hnrdhb = g08hnrdhb + g09hnrdhb + g12hnrdhb + g11hnrdhb = g11hnrdhb - g09hnrdhb - g12hnrdhb + g06hb = g06hb + g09hb + g06hnrdhb = g06hnrdhb + g09hnrdhb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2hb = -(z10*g10hb) - z07*g07hb - z05*g05hb - z03*g03hb - z01* + + g01hb - z02*g02hb - z04*g04hb - z06*g06hb - z08*g08hb - z11* + + g11hb + g11hb = cf1*g11hb + cf2hnrdhb = -(z10*g10hnrdhb) - z07*g07hnrdhb - z05*g05hnrdhb - + + z03*g03hnrdhb - z01*g01hnrdhb - z02*g02hnrdhb - z04*g04hnrdhb + + - z06*g06hnrdhb - z08*g08hnrdhb - z11*g11hnrdhb + g11hnrdhb = cf1*g11hnrdhb + g10hb = cf1*g10hb + g10hnrdhb = cf1*g10hnrdhb + g08hb = cf1*g08hb + g08hnrdhb = cf1*g08hnrdhb + g07hb = cf1*g07hb + g07hnrdhb = cf1*g07hnrdhb + g06hb = cf1*g06hb + g06hnrdhb = cf1*g06hnrdhb + g05hb = cf1*g05hb + g05hnrdhb = cf1*g05hnrdhb + g04hb = cf1*g04hb + g04hnrdhb = cf1*g04hnrdhb + g03hb = cf1*g03hb + g03hnrdhb = cf1*g03hnrdhb + g02hb = cf1*g02hb + g02hnrdhb = cf1*g02hnrdhb + g01hb = cf1*g01hb + g01hnrdhb = cf1*g01hnrdhb + temp1hb = (0.125d0-ti*0.005d0)*cf2hb + temp1hb0 = -(0.41d0*temp1hb/(sion+1.d0)) + temp1hb3 = (0.125d0-ti*0.005d0)*cf2hnrdhb + temp1hb1 = 0.92d0*0.039d0*temp1hb3 + ionichb = ionichb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp1hb - + + ionichnrd*0.8d0*ionic**(-1.8D0)*temp1hb1 + temp1hb2 = -(temp1hb3/(sion+1.d0)**2) + sionhb = (1.D0-sion/(sion+1.d0))*temp1hb0 - (0.41d0*(sionhnrd*( + + sion+1.d0))-0.41d0*(sion*sionhnrd))*2*temp1hb2/(sion+1.d0) + ionichnrdhb = ionichnrdhb + ionic**(-0.8d0)*temp1hb1 + sionhnrdhb = (0.41d0*(sion+1.d0)-0.41d0*sion)*temp1hb2 + ELSE + sionhb = 0.D0 + sionhnrdhb = 0.D0 + END IF + CALL MKBI_HNRD_HB(q11, ionic, ionichb, ionichnrd, ionichnrdhb, + + sion, sionhb, sionhnrd, sionhnrdhb, z11, g11, + + g11hb, g11hnrd, g11hnrdhb) + CALL MKBI_HNRD_HB(q10, ionic, ionichb, ionichnrd, ionichnrdhb, + + sion, sionhb, sionhnrd, sionhnrdhb, z10, g10, + + g10hb, g10hnrd, g10hnrdhb) + CALL MKBI_HNRD_HB(q8, ionic, ionichb, ionichnrd, ionichnrdhb, sion + + , sionhb, sionhnrd, sionhnrdhb, z08, g08, g08hb + + , g08hnrd, g08hnrdhb) + CALL MKBI_HNRD_HB(q7, ionic, ionichb, ionichnrd, ionichnrdhb, sion + + , sionhb, sionhnrd, sionhnrdhb, z07, g07, g07hb + + , g07hnrd, g07hnrdhb) + CALL MKBI_HNRD_HB(q6, ionic, ionichb, ionichnrd, ionichnrdhb, sion + + , sionhb, sionhnrd, sionhnrdhb, z06, g06, g06hb + + , g06hnrd, g06hnrdhb) + CALL MKBI_HNRD_HB(q5, ionic, ionichb, ionichnrd, ionichnrdhb, sion + + , sionhb, sionhnrd, sionhnrdhb, z05, g05, g05hb + + , g05hnrd, g05hnrdhb) + CALL MKBI_HNRD_HB(q4, ionic, ionichb, ionichnrd, ionichnrdhb, sion + + , sionhb, sionhnrd, sionhnrdhb, z04, g04, g04hb + + , g04hnrd, g04hnrdhb) + CALL MKBI_HNRD_HB(q3, ionic, ionichb, ionichnrd, ionichnrdhb, sion + + , sionhb, sionhnrd, sionhnrdhb, z03, g03, g03hb + + , g03hnrd, g03hnrdhb) + CALL MKBI_HNRD_HB(q2, ionic, ionichb, ionichnrd, ionichnrdhb, sion + + , sionhb, sionhnrd, sionhnrdhb, z02, g02, g02hb + + , g02hnrd, g02hnrdhb) + CALL MKBI_HNRD_HB(q1, ionic, ionichb, ionichnrd, ionichnrdhb, sion + + , sionhb, sionhnrd, sionhnrdhb, z01, g01, g01hb + + , g01hnrd, g01hnrdhb) + IF (.NOT.ionic == 0.0) ionichb = ionichb + sionhb/(2.0*SQRT( + + ionic)) + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp0 = SQRT(ionic) + temp0hb = sionhnrdhb/(2.0*temp0) + ionichnrdhb = ionichnrdhb + temp0hb + IF (.NOT.ionic == 0.0) ionichb = ionichb - ionichnrd*temp0hb/( + + 2.0*temp0**2) + END IF + END + +C Differentiation of mkbi_hnrd in reverse (adjoint) mode: +C gradient of useful results: bihnrd ionichnrd sion bi ionic +C sionhnrd +C with respect to varying inputs: ionichnrd sion ionic sionhnrd +C +C Differentiation of mkbi in forward (tangent) mode: +C variations of useful results: bi +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_HNRD_HB(q, ionic, ionichb, ionichnrd, ionichnrdhb + + , sion, sionhb, sionhnrd, sionhnrdhb, zip + + , bi, bihb, bihnrd, bihnrdhb) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionichb, sionhb, bihb + REAL*8 :: ionichnrd, sionhnrd, bihnrd + REAL*8 :: ionichnrdhb, sionhnrdhb, bihnrdhb + REAL*8 :: b, c, xx + REAL*8 :: chb, xxhb + REAL*8 :: chnrd, xxhnrd + REAL*8 :: chnrdhb, xxhnrdhb + REAL*8 :: arg1 + REAL*8 :: arg1hb + REAL*8 :: arg1hnrd + REAL*8 :: arg1hnrdhb + REAL*8 :: pwx1 + REAL*8 :: pwx1hb + REAL*8 :: pwx1hnrd + REAL*8 :: pwx1hnrdhb + REAL*8 :: pwr1 + REAL*8 :: pwr1hb + REAL*8 :: pwr1hnrd, tiny + REAL*8 :: pwr1hnrdhb + INTRINSIC EXP + INTRINSIC LOG10 + INTEGER :: branch + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp0hb + INTRINSIC ABS + REAL*8 :: x1 + REAL*8 :: temphb2 + REAL*8 :: temphb1 + REAL*8 :: temphb0 + REAL*8 :: temp1hb + INTRINSIC LOG + INTRINSIC INT + REAL*8 :: abs3 + REAL*8 :: abs2 + REAL*8 :: temp1hb3 + REAL*8 :: abs1 + REAL*8 :: temp1hb2 + REAL*8 :: temp1hb1 + REAL*8 :: temp1hb0 + REAL*8 :: temphb + REAL*8 :: temp + tiny = 1.d-20 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + arg1hnrd = -(.023d0*((ionichnrd*ionic+ionic*ionichnrd)*ionic+ionic + + **2*ionichnrd)) + arg1 = -(.023d0*ionic*ionic*ionic) + chnrd = .055d0*q*arg1hnrd*EXP(arg1) + c = 1.d0 + .055d0*q*EXP(arg1) + pwx1hnrd = .1d0*ionichnrd + pwx1 = 1.d0 + .1d0*ionic + x1 = q - INT(q) + IF (x1 >= 0.) THEN + abs1 = x1 + ELSE + abs1 = -x1 + END IF + IF (pwx1 > 0.d0 .OR. (pwx1 < 0.d0 .AND. abs1 < tiny)) + +THEN + pwr1hnrd = q*pwx1**(q-1)*pwx1hnrd + CALL PUSHCONTROL2B(0) + ELSE + IF (pwx1 >= 0.) THEN + abs2 = pwx1 + ELSE + abs2 = -pwx1 + END IF + IF (q - 1.d0 >= 0.) THEN + abs3 = q - 1.d0 + ELSE + abs3 = -(q-1.d0) + END IF + IF (abs2 < tiny .AND. abs3 < tiny) THEN + pwr1hnrd = pwx1hnrd + CALL PUSHCONTROL2B(1) + ELSE + pwr1hnrd = 0.d0 + CALL PUSHCONTROL2B(2) + END IF + END IF + pwr1 = pwx1**q + bihnrd = b*pwr1hnrd + bi = 1.d0 + b*pwr1 - b +C + temp1 = LOG(10.d0) + temp1hb3 = zip*bihnrdhb/(temp1*bi) + xxhb = zip*bihb + bihb = zip*bihb/(bi*LOG(10.0)) - bihnrd*temp1hb3/bi + xxhnrdhb = zip*bihnrdhb + bihnrdhb = temp1hb3 + pwr1hb = b*bihb + pwr1hnrdhb = b*bihnrdhb + IF (pwx1 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q))) THEN + pwx1hb = 0.0 + ELSE + pwx1hb = q*pwx1**(q-1)*pwr1hb + END IF + CALL POPCONTROL2B(branch) + IF (branch == 0) THEN + IF (.NOT.(pwx1 <= 0.0 .AND. (q - 1 == 0.0 .OR. q - 1 /= + + INT(q - 1)))) pwx1hb = pwx1hb + pwx1hnrd*q*(q-1)*pwx1**(q-2) + + *pwr1hnrdhb + pwx1hnrdhb = q*pwx1**(q-1)*pwr1hnrdhb + ELSE IF (branch == 1) THEN + pwx1hnrdhb = pwr1hnrdhb + ELSE + pwx1hnrdhb = 0.D0 + END IF + temp = c*sion + 1.d0 + temp1hb2 = -(xxhnrdhb/temp**2) + temp1hb1 = 0.5107d0*sionhnrd*temp1hb2 + temp0 = chnrd*sion + c*sionhnrd + temp0hb = -(0.5107d0*sion*temp1hb2) + temphb1 = -((0.5107d0*(sionhnrd*(c*sion+1.d0))-0.5107d0*(sion* + + temp0))*2*temp1hb2/temp) + temp1hb = -(0.5107d0*xxhb/(c*sion+1.d0)) + temp1hb0 = -(sion*temp1hb/(c*sion+1.d0)) + chb = sion*temp1hb1 + sionhnrd*temp0hb + sion*temphb1 + sion* + + temp1hb0 + chnrdhb = sion*temp0hb + temphb2 = q*.055d0*chnrdhb + arg1hb = arg1hnrd*EXP(arg1)*temphb2 + q*.055d0*EXP(arg1)*chb + arg1hnrdhb = EXP(arg1)*temphb2 + temphb = -(.023d0*arg1hnrdhb) + temphb0 = ionic*temphb + ionichb = ionichb + (ionichnrd*2*ionic+ionichnrd*ionic+ionic* + + ionichnrd)*temphb - .023d0*3*ionic**2*arg1hb + 2*ionichnrd* + + temphb0 + .1d0*pwx1hb + ionichnrdhb = ionichnrdhb + 2*ionic*temphb0 + ionic**2*temphb + + + .1d0*pwx1hnrdhb + sionhb = sionhb + c*temp1hb1 - 0.5107d0*temp0*temp1hb2 + chnrd* + + temp0hb + c*temphb1 + c*temp1hb0 + temp1hb + sionhnrdhb = sionhnrdhb + c*temp0hb + 0.5107d0*(c*sion+1.d0)* + + temp1hb2 + END + +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of funch6ab in forward (tangent) mode: +C variations of useful results: fh6ab +C with respect to varying inputs: x +C RW status of diff variables: fh6ab:out x:in +C +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE FUNCH6AB +C *** CASE H6 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +C 2. THERE IS BOTH A LIQUID & SOLID PHASE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE FUNCH6AB_HNRD(x, xhnrd, fh6ab, fh6abhnrd) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: psi4hnrd + REAL*8 :: psi5hnrd + REAL*8 :: psi6hnrd + REAL*8 :: a4hnrd + REAL*8 :: a5hnrd + REAL*8 :: a6hnrd +C + INTEGER :: j + INTEGER :: i + REAL*8 :: bb + REAL*8 :: bbhnrd + REAL*8 :: cc + REAL*8 :: cchnrd + REAL*8 :: dd + REAL*8 :: ddhnrd + REAL*8 :: smin + REAL*8 :: sminhnrd + REAL*8 :: hi + REAL*8 :: hihnrd + REAL*8 :: ohi + REAL*8 :: frno3 + REAL*8 :: frno3hnrd + REAL*8 :: frcl + REAL*8 :: frclhnrd + REAL*8 :: frnh4 + REAL*8 :: frnh4hnrd + REAL*8 :: result1 + REAL*8 :: result1hnrd, molalrhnrd(npair) + REAL*8 :: fh6ab + REAL*8 :: fh6abhnrd + REAL*8 :: x + REAL*8 :: xhnrd + INTRINSIC MAX + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** SETUP PARAMETERS ************************************************ +C + psi6hnrd = xhnrd + psi6 = x + psi1 = chi1 + psi2 = zero + psi3 = zero + psi7 = chi7 + psi8 = chi8 + DO ii1=1,nions + molalhnrd(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + molalrhnrd(ii1) = 0.D0 + ENDDO + DO ii1=1,npair + gamahnrd(ii1) = 0.D0 + ENDDO + waterhnrd = 0.D0 + gnh3hnrd = 0.D0 + ghclhnrd = 0.D0 + a4hnrd = 0.D0 + a6hnrd = 0.D0 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + DO i=1,2 +C + a1 = xk5*(water/gama(2))**3.0 + a4hnrd = xk2*r*temp*2.0*gama(10)*(gamahnrd(10)*gama(5)-gama(10)* + + gamahnrd(5))/(xkw*gama(5)**3) + a4 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + a5hnrd = xk4*r*temp*2.0*water*(waterhnrd*gama(10)-water*gamahnrd + + (10))/gama(10)**3 + a5 = xk4*r*temp*(water/gama(10))**2.0 + a6hnrd = xk3*r*temp*2.0*water*(waterhnrd*gama(11)-water*gamahnrd + + (11))/gama(11)**3 + a6 = xk3*r*temp*(water/gama(11))**2.0 + a7 = xk8*(water/gama(1))**2.0 + a8 = xk9*(water/gama(3))**2.0 + a9 = xk1*water/gama(7)*(gama(8)/gama(7))**2. +C +C CALCULATE DISSOCIATION QUANTITIES +C + psi5hnrd = chi5*psi6hnrd - psi8*((a6hnrd*a5-a6*a5hnrd)*(chi6- + + psi6-psi3)/a5**2-a6*psi6hnrd/a5) + psi5 = chi5*(psi6+psi7) - a6/a5*psi8*(chi6-psi6-psi3) + psi5hnrd = (psi5hnrd*(a6/a5*(chi6-psi6-psi3)+psi6+psi7)-psi5*(( + + a6hnrd*a5-a6*a5hnrd)*(chi6-psi6-psi3)/a5**2-a6*psi6hnrd/a5+ + + psi6hnrd))/(a6/a5*(chi6-psi6-psi3)+psi6+psi7)**2 + psi5 = psi5/(a6/a5*(chi6-psi6-psi3)+psi6+psi7) + IF (psi5 < tiny) THEN + psi5 = tiny + psi5hnrd = 0.D0 + ELSE + psi5 = psi5 + END IF +C + IF (w(3) > tiny .AND. water > tiny) THEN +C First try 3rd order soln + bbhnrd = -(psi6hnrd+psi5hnrd-a4hnrd/a4**2) + bb = -(chi4+psi6+psi5+1.d0/a4) + cchnrd = chi4*(psi5hnrd+psi6hnrd) + cc = chi4*(psi5+psi6) + ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd + dd = bb*bb - 4.d0*cc + IF (abs(dd) < tiny) THEN + result1hnrd = 0.D0 + ELSE + result1hnrd = ddhnrd/(2.0*SQRT(dd)) + END IF + result1 = SQRT(dd) + psi4hnrd = 0.5d0*(-bbhnrd-result1hnrd) + psi4 = 0.5d0*(-bb-result1) + IF (psi4 > chi4) THEN + psi4 = chi4 + psi4hnrd = 0.D0 + ELSE + psi4 = psi4 + END IF + ELSE + psi4 = tiny + psi4hnrd = 0.D0 + END IF +C +C *** CALCULATE SPECIATION ******************************************** +C +C NAI + molalhnrd(2) = 0.D0 + molal(2) = psi8 + psi7 + 2.d0*psi1 +C NH4I + molalhnrd(3) = psi4hnrd + molal(3) = psi4 +C CLI + molalhnrd(4) = psi6hnrd + molal(4) = psi6 + psi7 +C SO4I + molalhnrd(5) = 0.D0 + molal(5) = psi2 + psi1 +C HSO4I + molalhnrd(6) = 0.D0 + molal(6) = zero +C NO3I + molalhnrd(7) = psi5hnrd + molal(7) = psi5 + psi8 +C +C SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + sminhnrd = psi5hnrd + psi6hnrd - psi4hnrd + smin = 2.d0*psi2 + psi5 + psi6 - psi4 + CALL CALCPH_HNRD(smin, sminhnrd, hi, hihnrd, ohi) + molalhnrd(1) = hihnrd + molal(1) = hi + IF (chi4 - psi4 < tiny) THEN + gnh3 = tiny + gnh3hnrd = 0.D0 + ELSE + gnh3hnrd = -psi4hnrd + gnh3 = chi4 - psi4 + END IF + IF (chi5 - psi5 < tiny) THEN + ghno3 = tiny + ELSE + ghno3 = chi5 - psi5 + END IF + IF (chi6 - psi6 < tiny) THEN + ghcl = tiny + ghclhnrd = 0.D0 + ELSE + ghclhnrd = -psi6hnrd + ghcl = chi6 - psi6 + END IF +C + cnh42s4 = zero + cnh4no3 = zero + IF (chi7 - psi7 < zero) THEN + cnacl = zero + ELSE + cnacl = chi7 - psi7 + END IF + IF (chi8 - psi8 < zero) THEN + cnano3 = zero + ELSE + cnano3 = chi8 - psi8 + END IF + IF (chi1 - psi1 < zero) THEN + cna2so4 = zero + ELSE + cna2so4 = chi1 - psi1 + END IF +C +C CALL CALCMR ! Water content +C +C *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM RICH CASE +C *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/ +C +C NACL + molalrhnrd(1) = 0.D0 + molalr(1) = psi7 +C NA2SO4 + molalrhnrd(2) = 0.D0 + molalr(2) = psi1 +C NANO3 + molalrhnrd(3) = 0.D0 + molalr(3) = psi8 +C (NH4)2SO4 + molalrhnrd(4) = 0.D0 + molalr(4) = zero + IF (psi5 < zero) THEN + frno3 = zero + frno3hnrd = 0.D0 + ELSE + frno3hnrd = psi5hnrd + frno3 = psi5 + END IF + IF (psi6 < zero) THEN + frcl = zero + frclhnrd = 0.D0 + ELSE + frclhnrd = psi6hnrd + frcl = psi6 + END IF +C MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3 +C FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3 +C MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL + IF (psi4 < frno3) THEN + molalrhnrd(5) = psi4hnrd + molalr(5) = psi4 + frnh4 = zero + IF (frcl > zero) THEN + molalrhnrd(6) = 0.D0 + molalr(6) = zero + ELSE + molalrhnrd(6) = frclhnrd + molalr(6) = frcl + END IF + ELSE + molalrhnrd(5) = frno3hnrd + molalr(5) = frno3 + IF (psi4 - frno3 < zero) THEN + frnh4 = zero + frnh4hnrd = 0.D0 + ELSE + frnh4hnrd = psi4hnrd - frno3hnrd + frnh4 = psi4 - frno3 + END IF + IF (frcl > frnh4) THEN + molalrhnrd(6) = frnh4hnrd + molalr(6) = frnh4 + ELSE + molalrhnrd(6) = frclhnrd + molalr(6) = frcl + END IF + END IF +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + waterhnrd = 0.D0 + DO j=1,npair + waterhnrd = waterhnrd + molalrhnrd(j)/m0(j) + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + waterhnrd = 0.D0 + ELSE + water = water + END IF +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3P_HNRD() + ENDDO +C +C *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +C + fh6abhnrd = (((((molalhnrd(3)*molal(4)+molal(3)*molalhnrd(4))*ghcl + + -molal(3)*molal(4)*ghclhnrd)*gnh3/ghcl**2-molal(3)*molal(4)* + + gnh3hnrd/ghcl)*a6/gnh3**2-molal(3)*molal(4)*a6hnrd/(ghcl*gnh3))* + + a4/a6**2-molal(3)*molal(4)*a4hnrd/(ghcl*gnh3*a6))/a4**2 + fh6ab = molal(3)*molal(4)/ghcl/gnh3/a6/a4 - one +C + RETURN + END +C +C +C Differentiation of calcph in forward (tangent) mode: +C variations of useful results: hi +C with respect to varying inputs: water gg +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCPH +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCPH_HNRD(gg, gghnrd, hi, hihnrd, ohi) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: cn, gg, hi, ohi, bb, cc, dd + REAL*8 :: cnhnrd, gghnrd, hihnrd, ohihnrd, bbhnrd, cchnrd, + + ddhnrd + REAL*8 :: akw + REAL*8 :: akwhnrd + REAL*8 :: result1 + REAL*8 :: result1hnrd + REAL*8 :: x2hnrd + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x1hnrd + INTRINSIC SQRT +C + akwhnrd = xkw*rh*(waterhnrd*water+water*waterhnrd) + akw = xkw*rh*water*water + IF (abs(akw) < tiny) THEN + cnhnrd = 0.D0 + ELSE + cnhnrd = akwhnrd/(2.0*SQRT(akw)) + END IF + cn = SQRT(akw) +C +C *** GG = (negative charge) - (positive charge) +C + IF (gg > tiny) THEN +C H+ in excess + bbhnrd = -gghnrd + bb = -gg + cchnrd = -akwhnrd + cc = -akw + ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd + dd = bb*bb - 4.d0*cc + IF (abs(dd) < tiny) THEN + result1hnrd = 0.D0 + ELSE + result1hnrd = ddhnrd/(2.0*SQRT(dd)) + END IF + result1 = SQRT(dd) + x1hnrd = 0.5d0*(result1hnrd-bbhnrd) + x1 = 0.5d0*(-bb+result1) + IF (x1 < cn) THEN + hihnrd = cnhnrd + hi = cn + ELSE + hihnrd = x1hnrd + hi = x1 + END IF + ohi = akw/hi + ELSE +C OH- in excess + bbhnrd = gghnrd + bb = gg + cchnrd = -akwhnrd + cc = -akw + ddhnrd = bbhnrd*bb + bb*bbhnrd - 4.d0*cchnrd + dd = bb*bb - 4.d0*cc + IF (abs(dd) < tiny) THEN + result1hnrd = 0.D0 + ELSE + result1hnrd = ddhnrd/(2.0*SQRT(dd)) + END IF + result1 = SQRT(dd) + x2hnrd = 0.5d0*(result1hnrd-bbhnrd) + x2 = 0.5d0*(-bb+result1) + IF (x2 < cn) THEN + ohihnrd = cnhnrd + ohi = cn + ELSE + ohihnrd = x2hnrd + ohi = x2 + END IF + hihnrd = (akwhnrd*ohi-akw*ohihnrd)/ohi**2 + hi = akw/ohi + END IF +C + RETURN + END + +C Differentiation of calcact3p in forward (tangent) mode: +C variations of useful results: gama +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3P_HNRD() + INCLUDE 'isrpia_adj.inc' +C +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0hnrd(6, 4), sionhnrd, hhnrd, chhnrd, f1hnrd(3) + + , f2hnrd(4) + REAL*8 :: mpl, xij, yji + REAL*8 :: mplhnrd, xijhnrd, yjihnrd, ionichnrd + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01hnrd + REAL*8 :: g02 + REAL*8 :: g02hnrd + REAL*8 :: g03 + REAL*8 :: g03hnrd + REAL*8 :: g04 + REAL*8 :: g04hnrd + REAL*8 :: g05 + REAL*8 :: g05hnrd + REAL*8 :: g06 + REAL*8 :: g06hnrd + REAL*8 :: g07 + REAL*8 :: g07hnrd + REAL*8 :: g08 + REAL*8 :: g08hnrd + REAL*8 :: g09 + REAL*8 :: g09hnrd + REAL*8 :: g10 + REAL*8 :: g10hnrd + REAL*8 :: g11 + REAL*8 :: g11hnrd + REAL*8 :: g12 + REAL*8 :: g12hnrd + INTEGER :: j + REAL*8 :: x2hnrd + INTRINSIC MAX + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x1hnrd + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + ionichnrd = 0.D0 + DO i=1,7 + ionichnrd = ionichnrd + z(i)**2*molalhnrd(i) + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + x1hnrd = 0.D0 + ELSE + x1hnrd = (0.5d0*ionichnrd*water-0.5d0*ionic*waterhnrd)/water**2 + x1 = 0.5d0*ionic/water + END IF + IF (x1 < tiny) THEN + ionic = tiny + ionichnrd = 0.D0 + ELSE + ionichnrd = x1hnrd + ionic = x1 + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3_HNRD(ionic, ionichnrd, temp, g01, g01hnrd, g02, + + g02hnrd, g03, g03hnrd, g04, g04hnrd, g05, g05hnrd + + , g06, g06hnrd, g07, g07hnrd, g08, g08hnrd, g09, + + g09hnrd, g10, g10hnrd, g11, g11hnrd, g12, g12hnrd + + ) + DO ii1=1,4 + DO ii2=1,6 + g0hnrd(ii2, ii1) = 0.D0 + ENDDO + ENDDO +C + g0hnrd(1, 1) = g11hnrd + g0(1, 1) = g11 + g0hnrd(1, 2) = g07hnrd + g0(1, 2) = g07 + g0hnrd(1, 3) = g08hnrd + g0(1, 3) = g08 + g0hnrd(1, 4) = g10hnrd + g0(1, 4) = g10 + g0hnrd(2, 1) = g01hnrd + g0(2, 1) = g01 + g0hnrd(2, 2) = g02hnrd + g0(2, 2) = g02 + g0hnrd(2, 3) = g12hnrd + g0(2, 3) = g12 + g0hnrd(2, 4) = g03hnrd + g0(2, 4) = g03 + g0hnrd(3, 1) = g06hnrd + g0(3, 1) = g06 + g0hnrd(3, 2) = g04hnrd + g0(3, 2) = g04 + g0hnrd(3, 3) = g09hnrd + g0(3, 3) = g09 + g0hnrd(3, 4) = g05hnrd + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + IF (abs(ionic) < tiny) THEN + sionhnrd = 0.D0 + ELSE + sionhnrd = ionichnrd/(2.0*SQRT(ionic)) + END IF + sion = SQRT(ionic) + hhnrd = (agama*sionhnrd*(1.d0+sion)-agama*sion*sionhnrd)/(1.d0+ + + sion)**2 + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1hnrd(i) = 0.D0 + f1(i) = 0.d0 + f2hnrd(i) = 0.D0 + f2(i) = 0.d0 + ENDDO + f2hnrd(4) = 0.D0 + f2(4) = 0.d0 + DO ii1=1,3 + f1hnrd(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2hnrd(ii1) = 0.D0 + ENDDO +C + DO i=1,3 + zpl = z(i) + mplhnrd = (molalhnrd(i)*water-molal(i)*waterhnrd)/water**2 + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + chhnrd = -(0.25d0*(zpl+zmi)**2*ionichnrd/ionic**2) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xijhnrd = chhnrd*mpl + ch*mplhnrd + xij = ch*mpl + yjihnrd = ((chhnrd*molal(j+3)+ch*molalhnrd(j+3))*water-ch* + + molal(j+3)*waterhnrd)/water**2 + yji = ch*molal(j+3)/water + f1hnrd(i) = f1hnrd(i) + yjihnrd*(g0(i, j)+zpl*zmi*h) + yji*( + + g0hnrd(i, j)+zpl*zmi*hhnrd) + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2hnrd(j) = f2hnrd(j) + xijhnrd*(g0(i, j)+zpl*zmi*h) + xij*( + + g0hnrd(i, j)+zpl*zmi*hhnrd) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gamahnrd(1) = zz(1)*((f1hnrd(2)/z(2)+f2hnrd(1)/z(4))/(z(2)+z(4))- + + hhnrd) + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gamahnrd(2) = zz(2)*((f1hnrd(2)/z(2)+f2hnrd(2)/z(5))/(z(2)+z(5))- + + hhnrd) + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gamahnrd(3) = zz(3)*((f1hnrd(2)/z(2)+f2hnrd(4)/z(7))/(z(2)+z(7))- + + hhnrd) + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gamahnrd(4) = zz(4)*((f1hnrd(3)/z(3)+f2hnrd(2)/z(5))/(z(3)+z(5))- + + hhnrd) + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gamahnrd(5) = zz(5)*((f1hnrd(3)/z(3)+f2hnrd(4)/z(7))/(z(3)+z(7))- + + hhnrd) + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gamahnrd(6) = zz(6)*((f1hnrd(3)/z(3)+f2hnrd(1)/z(4))/(z(3)+z(4))- + + hhnrd) + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gamahnrd(7) = zz(7)*((f1hnrd(1)/z(1)+f2hnrd(2)/z(5))/(z(1)+z(5))- + + hhnrd) + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gamahnrd(8) = zz(8)*((f1hnrd(1)/z(1)+f2hnrd(3)/z(6))/(z(1)+z(6))- + + hhnrd) + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gamahnrd(9) = zz(9)*((f1hnrd(3)/z(3)+f2hnrd(3)/z(6))/(z(3)+z(6))- + + hhnrd) + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gamahnrd(10) = zz(10)*((f1hnrd(1)/z(1)+f2hnrd(4)/z(7))/(z(1)+z(7)) + + -hhnrd) + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gamahnrd(11) = zz(11)*((f1hnrd(1)/z(1)+f2hnrd(1)/z(4))/(z(1)+z(4)) + + -hhnrd) + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gamahnrd(12) = zz(12)*((f1hnrd(2)/z(2)+f2hnrd(3)/z(6))/(z(2)+z(6)) + + -hhnrd) + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) +C LC ; SCAPE + gamahnrd(13) = 0.2d0*(3.d0*gamahnrd(4)+2.d0*gamahnrd(9)) + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + x2 = 5.0d0 + x2hnrd = 0.D0 + ELSE + x2hnrd = gamahnrd(i) + x2 = gama(i) + END IF + IF (x2 < -5.0d0) THEN + gamahnrd(i) = 0.D0 + gama(i) = -5.0d0 + ELSE + gamahnrd(i) = x2hnrd + gama(i) = x2 + END IF + gamahnrd(i) = 10.d0**gama(i)*LOG(10.d0)*gamahnrd(i) + gama(i) = 10.d0**gama(i) + ENDDO +C +C Increment ACTIVITY call counter + iclact = iclact + 1 +C +C *** END OF SUBROUTINE ACTIVITY **************************************** +C + RETURN + END + +C Differentiation of kmful3 in forward (tangent) mode: +C variations of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_HNRD(ionic, ionichnrd, temp, g01, g01hnrd, g02, + + g02hnrd, g03, g03hnrd, g04, g04hnrd, g05, + + g05hnrd, g06, g06hnrd, g07, g07hnrd, g08, + + g08hnrd, g09, g09hnrd, g10, g10hnrd, g11, + + g11hnrd, g12, g12hnrd) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionichnrd, sionhnrd, cf2hnrd + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01hnrd, g02hnrd, g03hnrd, g04hnrd, g05hnrd, + + g06hnrd, g07hnrd, g08hnrd, g09hnrd, g10hnrd, + + g11hnrd, g12hnrd + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTRINSIC ABS + REAL*8 :: abs1, tiny + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + tiny = 1.d-20 + IF (abs(ionic) < tiny) THEN + sionhnrd = 0.D0 + ELSE + sionhnrd = ionichnrd/(2.0*SQRT(ionic)) + END IF + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C + CALL MKBI_HNRD(q1, ionic, ionichnrd, sion, sionhnrd, z01, g01, + + g01hnrd) + CALL MKBI_HNRD(q2, ionic, ionichnrd, sion, sionhnrd, z02, g02, + + g02hnrd) + CALL MKBI_HNRD(q3, ionic, ionichnrd, sion, sionhnrd, z03, g03, + + g03hnrd) + CALL MKBI_HNRD(q4, ionic, ionichnrd, sion, sionhnrd, z04, g04, + + g04hnrd) + CALL MKBI_HNRD(q5, ionic, ionichnrd, sion, sionhnrd, z05, g05, + + g05hnrd) + CALL MKBI_HNRD(q6, ionic, ionichnrd, sion, sionhnrd, z06, g06, + + g06hnrd) + CALL MKBI_HNRD(q7, ionic, ionichnrd, sion, sionhnrd, z07, g07, + + g07hnrd) + CALL MKBI_HNRD(q8, ionic, ionichnrd, sion, sionhnrd, z08, g08, + + g08hnrd) + CALL MKBI_HNRD(q10, ionic, ionichnrd, sion, sionhnrd, z10, g10, + + g10hnrd) + CALL MKBI_HNRD(q11, ionic, ionichnrd, sion, sionhnrd, z11, g11, + + g11hnrd) +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.d0) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + cf2hnrd = (0.125d0-0.005d0*ti)*(0.039d0*0.92d0*ionic**(-0.8D0)* + + ionichnrd-(0.41d0*sionhnrd*(1.d0+sion)-0.41d0*sion*sionhnrd)/( + + 1.d0+sion)**2) + cf2 = (0.125d0-0.005d0*ti)*(0.039d0*ionic**0.92d0-0.41d0*sion/( + + 1.d0+sion)) + g01hnrd = cf1*g01hnrd - z01*cf2hnrd + g01 = cf1*g01 - cf2*z01 + g02hnrd = cf1*g02hnrd - z02*cf2hnrd + g02 = cf1*g02 - cf2*z02 + g03hnrd = cf1*g03hnrd - z03*cf2hnrd + g03 = cf1*g03 - cf2*z03 + g04hnrd = cf1*g04hnrd - z04*cf2hnrd + g04 = cf1*g04 - cf2*z04 + g05hnrd = cf1*g05hnrd - z05*cf2hnrd + g05 = cf1*g05 - cf2*z05 + g06hnrd = cf1*g06hnrd - z06*cf2hnrd + g06 = cf1*g06 - cf2*z06 + g07hnrd = cf1*g07hnrd - z07*cf2hnrd + g07 = cf1*g07 - cf2*z07 + g08hnrd = cf1*g08hnrd - z08*cf2hnrd + g08 = cf1*g08 - cf2*z08 + g10hnrd = cf1*g10hnrd - z10*cf2hnrd + g10 = cf1*g10 - cf2*z10 + g11hnrd = cf1*g11hnrd - z11*cf2hnrd + g11 = cf1*g11 - cf2*z11 + END IF +C + g09hnrd = g06hnrd + g08hnrd - g11hnrd + g09 = g06 + g08 - g11 + g12hnrd = g01hnrd + g08hnrd - g11hnrd + g12 = g01 + g08 - g11 +C +C *** Return point ; End of subroutine +C + RETURN + END + +C Differentiation of mkbi in forward (tangent) mode: +C variations of useful results: bi +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_HNRD(q, ionic, ionichnrd, sion, sionhnrd, zip, bi + + , bihnrd) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionichnrd, sionhnrd, bihnrd + REAL*8 :: b, c, xx + REAL*8 :: chnrd, xxhnrd + REAL*8 :: arg1 + REAL*8 :: arg1hnrd + REAL*8 :: pwx1 + REAL*8 :: pwx1hnrd + REAL*8 :: pwr1 + REAL*8 :: pwr1hnrd, tiny + INTRINSIC EXP + INTRINSIC LOG10 + tiny = 1.d-20 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + arg1hnrd = -(.023d0*((ionichnrd*ionic+ionic*ionichnrd)*ionic+ionic + + **2*ionichnrd)) + arg1 = -(.023d0*ionic*ionic*ionic) + chnrd = .055d0*q*arg1hnrd*EXP(arg1) + c = 1.d0 + .055d0*q*EXP(arg1) + xxhnrd = -((0.5107d0*sionhnrd*(1.d0+c*sion)-0.5107d0*sion*(chnrd* + + sion+c*sionhnrd))/(1.d0+c*sion)**2) + xx = -(0.5107d0*sion/(1.d0+c*sion)) + pwx1hnrd = .1d0*ionichnrd + pwx1 = 1.d0 + .1d0*ionic + IF (pwx1 > 0.d0 .OR. (pwx1 < 0.d0 .AND. + & abs(q-INT(q)) < tiny)) THEN + pwr1hnrd = q*pwx1**(q-1)*pwx1hnrd + ELSE IF (abs(pwx1) < tiny .AND. abs(q-1.d0) < tiny) THEN + pwr1hnrd = pwx1hnrd + ELSE + pwr1hnrd = 0.d0 + END IF + pwr1 = pwx1**q + bihnrd = b*pwr1hnrd + bi = 1.d0 + b*pwr1 - b + bihnrd = zip*bihnrd/(bi*LOG(10.d0)) + zip*xxhnrd + bi = zip*LOG10(bi) + zip*xx +C + RETURN + END + +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of isrp3f in reverse (adjoint) mode: +C gradient of useful results: aerliq gas +C with respect to varying inputs: wp aerliq gas +C RW status of diff variables: wp:out aerliq:in-out gas:in-out +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ISRP3F +C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF +C AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE & SODIUM +C RATIOS AND BY THE AMBIENT RELATIVE HUMIDITY. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ISRP3F_IB(wpib,gasib, aerliqib) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: gas(3), aerliq(NIONS+NGASAQ+2) + REAL*8 :: wpib(ncomp), gasib(3), aerliqib(NIONS+NGASAQ+2) + REAL*8 :: rest + REAL*8 :: restib + INTEGER :: i, ncase, npflag + INTEGER :: branch + INTEGER :: ii1 +C +C *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE ********* +C + rest = 2.d0*w(2) + w(4) + w(5) + IF (w(1) > rest) THEN +C NA > 2*SO4+CL+NO3 ? +C Adjust Na amount + w(1) = (one-1d-6)*rest + CALL PUSHERR(50, 'ISRP3F') +C Warning error: Na adjusted + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHINTEGER4(iclact) + CALL PUSHREAL8(water) + CALL PUSHREAL8ARRAY(gamou, npair) + CALL PUSHREAL8ARRAY(gama, npair) + CALL PUSHREAL8ARRAY(molalr, npair) + CALL PUSHREAL8ARRAY(molal, nions) +C +C IF(METSTBL == 1) THEN +C Only liquid (metastable) + CALL CALCI6() +C ELSE +C +C MINOR SPECIES: HNO3, HCl + CALL CALCNHA_IFWD() + CALL PUSHREAL8ARRAY(gama, npair) + CALL CALCACT3() + CALL CALCACT3F() +C NH3 + ghclib = gasib(3) + gasib(3) = 0.D0 + ghno3ib = gasib(2) + gasib(2) = 0.D0 + gnh3ib = gasib(1) + gasib(1) = 0.D0 + aerliqib(nions+ngasaq+2) = 0.D0 + waterib = 1.0d3*aerliqib(nions+1)/18.0d0 + aerliqib(nions+1) = 0.D0 + DO i=ngasaq,1,-1 + aerliqib(nions+1+i) = 0.D0 + ENDDO + DO ii1=1,nions + molalib(ii1) = 0.D0 + ENDDO + DO i=nions,1,-1 + molalib(i) = molalib(i) + aerliqib(i) + aerliqib(i) = 0.D0 + ENDDO + CALL CALCNH3_IB() + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3_IB() +C WRITE(*,*) 'After CALCACT3_IB: molalib ',molalib + CALL CALCNHA_IBWD() + CALL POPREAL8ARRAY(molal, nions) + CALL POPREAL8ARRAY(molalr, npair) + CALL POPREAL8ARRAY(gama, npair) + CALL POPREAL8ARRAY(gamou, npair) + CALL POPREAL8(water) + CALL POPINTEGER4(iclact) + CALL CALCI6_IB() + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + restib = (one-1d-6)*wib(1) + wib(1) = 0.D0 + ELSE + restib = 0.D0 + END IF + wib(2) = wib(2) + 2.d0*restib + wib(4) = wib(4) + restib + wib(5) = wib(5) + restib + wpib = wib +C + END + +C Differentiation of calci6 in reverse (adjoint) mode: +C gradient of useful results: w molal gama water ghno3 ghcl +C with respect to varying inputs: w +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCI6 +C *** CASE I6 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +C 2. SOLID & LIQUID AEROSOL POSSIBLE +C 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4 +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCI6_IB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: molalrib(npair) + REAL*8 :: psi1ib + REAL*8 :: psi2ib + REAL*8 :: psi3ib + REAL*8 :: psi4ib + REAL*8 :: psi5ib + REAL*8 :: psi6ib + REAL*8 :: aerliq(NIONS+NGASAQ+2), gas(3) + REAL*8 :: frso4 + REAL*8 :: frso4ib + REAL*8 :: frnh4 + REAL*8 :: frnh4ib + INTEGER :: i + REAL*8 :: bb + REAL*8 :: bbib + REAL*8 :: cc + REAL*8 :: ccib + REAL*8 :: dd + REAL*8 :: ddib + INTEGER :: j + INTEGER :: branch + INTEGER :: ad_count + INTEGER :: i0 + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: min1 + INTRINSIC MAX + REAL*8 :: temp1ib + REAL*8 :: temp2ib + REAL*8 :: min1ib + INTRINSIC MIN + REAL*8 :: temp0ib + INTEGER :: ii1 + INTRINSIC SQRT +C +C *** FIND DRY COMPOSITION ********************************************** +C +C CALL CALCI1A +C +C *** CALCULATE NON VOLATILE SOLIDS *********************************** +C + cna2so4 = 0.5d0*w(1) + cnh4hs4 = zero + cnahso4 = zero + cnh42s4 = zero + IF (w(2) - cna2so4 < zero) THEN + CALL PUSHCONTROL1B(0) + frso4 = zero + ELSE + frso4 = w(2) - cna2so4 + CALL PUSHCONTROL1B(1) + END IF + IF (w(3)/3.d0 > frso4/2.d0) THEN + clc = frso4/2.d0 + CALL PUSHCONTROL1B(0) + ELSE + clc = w(3)/3.d0 + CALL PUSHCONTROL1B(1) + END IF + IF (frso4 - 2.d0*clc < zero) THEN + frso4 = zero + CALL PUSHCONTROL1B(0) + ELSE + frso4 = frso4 - 2.d0*clc + CALL PUSHCONTROL1B(1) + END IF + IF (w(3) - 3.d0*clc < zero) THEN + CALL PUSHCONTROL1B(0) + frnh4 = zero + ELSE + frnh4 = w(3) - 3.d0*clc + CALL PUSHCONTROL1B(1) + END IF +C + IF (frso4 <= tiny) THEN + IF (clc - frnh4 < zero) THEN + clc = zero + CALL PUSHCONTROL1B(0) + ELSE + clc = clc - frnh4 + CALL PUSHCONTROL1B(1) + END IF + cnh42s4 = 2.d0*frnh4 +C + CALL PUSHCONTROL3B(0) + ELSE IF (frnh4 <= tiny) THEN + IF (frso4 > clc) THEN + min1 = clc + CALL PUSHCONTROL1B(0) + ELSE + min1 = frso4 + CALL PUSHCONTROL1B(1) + END IF + cnh4hs4 = 3.d0*min1 + IF (clc - frso4 < zero) THEN + clc = zero + CALL PUSHCONTROL1B(0) + ELSE + clc = clc - frso4 + CALL PUSHCONTROL1B(1) + END IF + IF (cna2so4 > tiny) THEN + IF (frso4 - cnh4hs4/3.d0 < zero) THEN + frso4 = zero + CALL PUSHCONTROL1B(0) + ELSE + frso4 = frso4 - cnh4hs4/3.d0 + CALL PUSHCONTROL1B(1) + END IF + cnahso4 = 2.d0*frso4 + IF (cna2so4 - frso4 < zero) THEN + cna2so4 = zero + CALL PUSHCONTROL3B(4) + ELSE + cna2so4 = cna2so4 - frso4 + CALL PUSHCONTROL3B(3) + END IF + ELSE + CALL PUSHCONTROL3B(1) + END IF + ELSE + CALL PUSHCONTROL3B(2) + END IF +C +C *** CALCULATE GAS SPECIES ********************************************* +C +C +C *** SETUP PARAMETERS ************************************************ +C +C Save from CALCI1 run +C +C ASSIGN INITIAL PSI's + psi1 = cnh4hs4 + psi2 = clc + psi3 = cnahso4 + psi4 = cna2so4 + psi5 = cnh42s4 +C +C Outer loop activity calculation flag + frst = .true. + calain = .true. +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + i = 1 + ad_count = 0 + DO WHILE (i <= nsweep .AND. calain) +C + a6 = xk1*water/gama(7)*(gama(8)/gama(7))**2. +C +C CALCULATE DISSOCIATION QUANTITIES +C +C PSI6 + bb = psi2 + psi4 + psi5 + a6 + cc = -(a6*(psi2+psi3+psi1)) + dd = bb*bb - 4.d0*cc + psi6 = 0.5d0*(-bb+SQRT(dd)) + CALL PUSHREAL8(molal(1)) +C +C *** CALCULATE SPECIATION ******************************************** +C +C HI + molal(1) = psi6 + CALL PUSHREAL8(molal(2)) +C NAI + molal(2) = 2.d0*psi4 + psi3 + CALL PUSHREAL8(molal(3)) +C NH4I + molal(3) = 3.d0*psi2 + 2.d0*psi5 + psi1 + CALL PUSHREAL8(molal(5)) +C SO4I + molal(5) = psi2 + psi4 + psi5 + psi6 + CALL PUSHREAL8(molal(6)) +C HSO4I + molal(6) = psi2 + psi3 + psi1 - psi6 +C CALL CALCMR ! Water content +C (NH4)2SO4 + molalr(4) = psi5 +C NA2SO4 + molalr(2) = psi4 +C NH4HSO4 + molalr(9) = psi1 +C NAHSO4 + molalr(12) = psi3 +C LC + molalr(13) = psi2 + CALL PUSHREAL8(water) +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + DO j=1,npair + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF + CALL PUSHREAL8ARRAY(gama, npair) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3() + i = i + 1 + ad_count = ad_count + 1 + ENDDO + CALL PUSHINTEGER4(ad_count) + DO ii1=1,npair + molalrib(ii1) = 0.D0 + ENDDO + psi1ib = 0.D0 + psi2ib = 0.D0 + psi3ib = 0.D0 + psi4ib = 0.D0 + psi5ib = 0.D0 + CALL POPINTEGER4(ad_count) + DO i0=1,ad_count + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3_IB() + CALL POPCONTROL1B(branch) + IF (branch == 0) waterib = 0.D0 + DO j=npair,1,-1 + molalrib(j) = molalrib(j) + waterib/m0(j) + ENDDO + CALL POPREAL8(water) + psi2ib = psi2ib + molalib(6) + molalrib(13) + molalrib(13) = 0.D0 + psi3ib = psi3ib + molalib(6) + molalrib(12) + molalrib(12) = 0.D0 + psi1ib = psi1ib + molalib(6) + molalrib(9) + molalrib(9) = 0.D0 + CALL POPREAL8(molal(6)) + psi6ib = -molalib(6) + molalib(6) = 0.D0 + psi4ib = psi4ib + molalib(5) + molalrib(2) + molalrib(2) = 0.D0 + psi5ib = psi5ib + molalib(5) + molalrib(4) + molalrib(4) = 0.D0 + CALL POPREAL8(molal(5)) + psi2ib = psi2ib + molalib(5) + psi6ib = psi6ib + molalib(5) + molalib(5) = 0.D0 + CALL POPREAL8(molal(3)) + psi2ib = psi2ib + 3.d0*molalib(3) + psi5ib = psi5ib + 2.d0*molalib(3) + psi1ib = psi1ib + molalib(3) + molalib(3) = 0.D0 + CALL POPREAL8(molal(2)) + psi4ib = psi4ib + 2.d0*molalib(2) + psi3ib = psi3ib + molalib(2) + molalib(2) = 0.D0 + CALL POPREAL8(molal(1)) + psi6ib = psi6ib + molalib(1) + molalib(1) = 0.D0 + a6 = xk1*water/gama(7)*(gama(8)/gama(7))**2. + bb = psi2 + psi4 + psi5 + a6 + cc = -(a6*(psi2+psi3+psi1)) + dd = bb*bb - 4.d0*cc + IF (dd == 0.0) THEN + ddib = 0.0 + ELSE + ddib = 0.5d0*psi6ib/(2.0*SQRT(dd)) + END IF + bbib = 2*bb*ddib - 0.5d0*psi6ib + ccib = -(4.d0*ddib) + temp2ib = -(a6*ccib) + a6ib = bbib - (psi2+psi3+psi1)*ccib + psi2ib = psi2ib + bbib + temp2ib + psi3ib = psi3ib + temp2ib + psi1ib = psi1ib + temp2ib + psi4ib = psi4ib + bbib + psi5ib = psi5ib + bbib + temp0 = water/gama(7) + temp1 = gama(8)/gama(7) + temp1ib = 2.*temp1*temp0*xk1*a6ib/gama(7) + temp0ib = temp1**2.*xk1*a6ib/gama(7) + gamaib(8) = gamaib(8) + temp1ib + gamaib(7) = gamaib(7) - temp0*temp0ib - temp1*temp1ib + waterib = temp0ib + ENDDO + cnh42s4ib = psi5ib + cna2so4ib = psi4ib + cnahso4ib = psi3ib + clcib = psi2ib + cnh4hs4ib = psi1ib + wib(5) = wib(5) + ghclib + wib(4) = wib(4) + ghno3ib + CALL POPCONTROL3B(branch) + IF (branch < 2) THEN + IF (branch == 0) THEN + frnh4ib = 2.d0*cnh42s4ib + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + clcib = 0.D0 + ELSE + frnh4ib = frnh4ib - clcib + END IF + frso4ib = 0.D0 + GOTO 110 + ELSE + frso4ib = 0.D0 + END IF + ELSE IF (branch == 2) THEN + frso4ib = 0.D0 + GOTO 100 + ELSE + IF (branch == 3) THEN + frso4ib = -cna2so4ib + ELSE + cna2so4ib = 0.D0 + frso4ib = 0.D0 + END IF + frso4ib = frso4ib + 2.d0*cnahso4ib + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + frso4ib = 0.D0 + ELSE + cnh4hs4ib = cnh4hs4ib - frso4ib/3.d0 + END IF + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + clcib = 0.D0 + ELSE + frso4ib = frso4ib - clcib + END IF + min1ib = 3.d0*cnh4hs4ib + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + clcib = clcib + min1ib + ELSE + frso4ib = frso4ib + min1ib + END IF + 100 frnh4ib = 0.D0 + 110 CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + wib(3) = wib(3) + frnh4ib + clcib = clcib - 3.d0*frnh4ib + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + frso4ib = 0.D0 + ELSE + clcib = clcib - 2.d0*frso4ib + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + frso4ib = frso4ib + clcib/2.d0 + ELSE + wib(3) = wib(3) + clcib/3.d0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + wib(2) = wib(2) + frso4ib + cna2so4ib = cna2so4ib - frso4ib + END IF + wib(1) = wib(1) + 0.5d0*cna2so4ib + END + +C +C Differentiation of calcnh3 in reverse (adjoint) mode: +C gradient of useful results: molal gnh3 +C with respect to varying inputs: molal gama +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNH3 +C *** CALCULATES AMMONIA IN GAS PHASE +C +C AMMONIA IN THE GAS PHASE IS ASSUMED A MINOR SPECIES, THAT +C DOES NOT SIGNIFICANTLY PERTURB THE AEROSOL EQUILIBRIUM. +C AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l) +C EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION. +C +C THIS IS THE VERSION USED BY THE DIRECT PROBLEM +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNH3_IB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: a1ib + REAL*8 :: chi1ib + REAL*8 :: chi2ib +C + REAL*8 :: bb, cc, diak, psi + REAL*8 :: bbib, ccib, diakib, psiib + INTEGER :: branch + REAL*8 :: temp0 + INTRINSIC MAX + REAL*8 :: temp1ib + REAL*8 :: x1 + REAL*8 :: x1ib + INTRINSIC MIN + INTEGER :: ii1 + REAL*8 :: temp0ib + INTRINSIC SQRT +C +C *** IS THERE A LIQUID PHASE? ****************************************** +C + IF (water <= tiny) THEN + DO ii1=1,npair + gamaib(ii1) = 0.D0 + ENDDO + ELSE +C +C *** CALCULATE NH3 SUBLIMATION ***************************************** +C + a1 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + chi1 = molal(3) + chi2 = molal(1) +C +C a=1; b!=1; c!=1 + bb = chi2 + one/a1 + cc = -(chi1/a1) +C Always > 0 + diak = SQRT(bb*bb - 4.d0*cc) +C One positive root + psi = 0.5*(-bb+diak) + IF (psi > chi1) THEN + x1 = chi1 + CALL PUSHCONTROL1B(0) + ELSE + x1 = psi + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + chi2ib = molalib(1) + psiib = molalib(1) + molalib(1) = 0.D0 + chi1ib = molalib(3) + psiib = psiib + gnh3ib - molalib(3) + molalib(3) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + x1ib = 0.D0 + ELSE + x1ib = psiib + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + chi1ib = chi1ib + x1ib + psiib = 0.D0 + ELSE + psiib = x1ib + END IF + diakib = 0.5*psiib + IF (bb**2 - 4.d0*cc == 0.0) THEN + temp1ib = 0.0 + ELSE + temp1ib = diakib/(2.0*SQRT(bb**2-4.d0*cc)) + END IF + bbib = 2*bb*temp1ib - 0.5*psiib + ccib = -(4.d0*temp1ib) + chi1ib = chi1ib - ccib/a1 + a1ib = chi1*ccib/a1**2 - one*bbib/a1**2 + chi2ib = chi2ib + bbib + molalib(1) = molalib(1) + chi2ib + molalib(3) = molalib(3) + chi1ib + DO ii1=1,npair + gamaib(ii1) = 0.D0 + ENDDO + temp0 = gama(10)/gama(5) + temp0ib = 2.0*temp0*xk2*r*temp*a1ib/(xkw*gama(5)) + gamaib(10) = gamaib(10) + temp0ib + gamaib(5) = gamaib(5) - temp0*temp0ib + END IF + END + +C Differentiation of calcnha in reverse (adjoint) mode (forward sweep): +C gradient of useful results: molal gama water ghno3 ghcl +C with respect to varying inputs: w molal gama water ghno3 ghcl +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNHA +C +C THIS SUBROUTINE CALCULATES THE DISSOLUTION OF HCL, HNO3 AT +C THE PRESENCE OF (H,SO4). HCL, HNO3 ARE CONSIDERED MINOR SPECIES, +C THAT DO NOT SIGNIFICANTLY AFFECT THE EQUILIBRIUM POINT. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNHA_IFWD() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: m1, m2, m3, delcl, delno, omega + CHARACTER(LEN=40) errinf + REAL*8 :: c1 + REAL*8 :: c2 + REAL*8 :: c3 + INTEGER :: islv + INTRINSIC MAX + INTRINSIC MIN +C +C *** SPECIAL CASE; WATER=ZERO ****************************************** +C + IF (water <= tiny) THEN + IF (w(5) - molal(4) < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + IF (w(4) - molal(7) < tiny) THEN + CALL PUSHCONTROL3B(1) + ELSE + CALL PUSHCONTROL3B(0) + END IF + ELSE IF (w(5) <= tiny .AND. w(4) <= tiny) THEN + CALL PUSHCONTROL3B(2) + ELSE IF (w(5) <= tiny) THEN + CALL PUSHREAL8ARRAY(molal, nions) +C CALL HNO3 DISSOLUTION ROUTINE + CALL CALCNA() +C GOTO 60 +C +C *** SPECIAL CASE; HNO3=ZERO ******************************************* +C + CALL PUSHCONTROL3B(3) + ELSE IF (w(4) <= tiny) THEN + CALL PUSHREAL8ARRAY(molal, nions) +C CALL HCL DISSOLUTION ROUTINE + CALL CALCHA() +C GOTO 60 +C ENDIF + CALL PUSHCONTROL3B(4) + ELSE +C +C *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +C +C HNO3 + a3 = xk4*r*temp*(water/gama(10))**2.0 +C HCL + a4 = xk3*r*temp*(water/gama(11))**2.0 +C +C *** CALCULATE CUBIC EQUATION COEFFICIENTS ***************************** +C +C +C H+ + omega = molal(1) +C HNO3 + chi3 = w(4) +C HCL + chi4 = w(5) +C + c1 = a3*chi3 + c2 = a4*chi4 + c3 = a3 - a4 +C + m1 = (c1+c2+(omega+a4)*c3)/c3 + m2 = ((omega+a4)*c2-a4*c3*chi4)/c3 + m3 = -(a4*c2*chi4/c3) +C +C *** CALCULATE ROOTS *************************************************** +C + CALL POLY3(m1, m2, m3, delcl, islv) +C HCL DISSOLUTION + IF (islv /= 0) THEN +C TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT + delcl = tiny +C WRITE (ERRINF,'(1PE10.1)') TINY +C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + IF (delcl > chi4) THEN + delcl = chi4 + CALL PUSHCONTROL1B(0) + ELSE + delcl = delcl + CALL PUSHCONTROL1B(1) + END IF +C + delno = c1*delcl/(c2+c3*delcl) + IF (delno > chi3) THEN + delno = chi3 + CALL PUSHCONTROL1B(0) + ELSE + delno = delno + CALL PUSHCONTROL1B(1) + END IF +C + IF (((delcl < zero .OR. delno < zero) .OR. delcl > chi4 + + ) .OR. delno > chi3) THEN + CALL PUSHREAL8(delcl) +C TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT + delcl = tiny + delno = tiny +C WRITE (ERRINF,'(1PE10.1)') TINY +C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF +CCC +CCC *** COMPARE DELTA TO TOTAL H+ ; ESTIMATE EFFECT TO HSO4 *************** +CCC +CC IF ((DELCL+DELNO)/MOLAL(1) > 0.1d0) THEN +CC WRITE (ERRINF,'(1PE10.3)') (DELCL+DELNO)/MOLAL(1)*100.0 +CC CALL PUSHERR (0021, ERRINF) +CC ENDIF +C +C *** EFFECT ON LIQUID PHASE ******************************************** +C +C H+ CHANGE + molal(1) = molal(1) + (delno+delcl) +C CL- CHANGE + molal(4) = molal(4) + delcl +C NO3- CHANGE + molal(7) = molal(7) + delno + IF (w(5) - molal(4) < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + IF (w(4) - molal(7) < tiny) THEN + CALL PUSHREAL8(omega) + CALL PUSHREAL8(delcl) + CALL PUSHCONTROL3B(5) + ELSE + CALL PUSHREAL8(omega) + CALL PUSHREAL8(delcl) + CALL PUSHCONTROL3B(6) + END IF + END IF + END + +C Differentiation of calcnha in reverse (adjoint) mode (backward sweep): +C gradient of useful results: molal gama water ghno3 ghcl +C with respect to varying inputs: w molal gama water ghno3 ghcl +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNHA +C +C THIS SUBROUTINE CALCULATES THE DISSOLUTION OF HCL, HNO3 AT +C THE PRESENCE OF (H,SO4). HCL, HNO3 ARE CONSIDERED MINOR SPECIES, +C THAT DO NOT SIGNIFICANTLY AFFECT THE EQUILIBRIUM POINT. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNHA_IBWD() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: a3ib + REAL*8 :: a4ib + REAL*8 :: chi3ib + REAL*8 :: chi4ib + REAL*8 :: m1, m2, m3, delcl, delno, omega + REAL*8 :: m1ib, m2ib, m3ib, delclib, delnoib, omegaib + CHARACTER(LEN=40) :: errinf + REAL*8 :: c1 + REAL*8 :: c1ib + REAL*8 :: c2 + REAL*8 :: c2ib + REAL*8 :: c3 + REAL*8 :: c3ib + INTEGER :: islv + INTEGER :: branch + REAL*8 :: temp2 + REAL*8 :: temp1 + REAL*8 :: temp0 + REAL*8 :: temp3ib + INTRINSIC MAX + REAL*8 :: temp2ib1 + REAL*8 :: temp1ib + REAL*8 :: temp2ib0 + REAL*8 :: temp3ib0 + REAL*8 :: temp2ib + INTRINSIC MIN + INTEGER :: ii1 + REAL*8 :: temp0ib + CALL POPCONTROL3B(branch) + IF (branch < 3) THEN + IF (branch == 0) THEN + DO ii1=1,ncomp + wib(ii1) = 0.D0 + ENDDO + wib(4) = wib(4) + ghno3ib + molalib(7) = molalib(7) - ghno3ib + ELSE IF (branch == 1) THEN + DO ii1=1,ncomp + wib(ii1) = 0.D0 + ENDDO + ELSE + DO ii1=1,ncomp + wib(ii1) = 0.D0 + ENDDO + GOTO 100 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + wib(5) = wib(5) + ghclib + molalib(4) = molalib(4) - ghclib + END IF + ghno3ib = 0.D0 + ghclib = 0.D0 + ELSE + IF (branch < 5) THEN + IF (branch == 3) THEN + CALL POPREAL8ARRAY(molal, nions) + CALL CALCNA_IB() + ghno3ib = 0.D0 + GOTO 100 + ELSE + CALL POPREAL8ARRAY(molal, nions) + CALL CALCHA_IB() + END IF + ELSE + IF (branch == 5) THEN + CALL POPREAL8(delcl) + CALL POPREAL8(omega) + DO ii1=1,ncomp + wib(ii1) = 0.D0 + ENDDO + ELSE + CALL POPREAL8(delcl) + CALL POPREAL8(omega) + DO ii1=1,ncomp + wib(ii1) = 0.D0 + ENDDO + wib(4) = wib(4) + ghno3ib + molalib(7) = molalib(7) - ghno3ib + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + wib(5) = wib(5) + ghclib + molalib(4) = molalib(4) - ghclib + END IF + delnoib = molalib(1) + molalib(7) + delclib = molalib(1) + molalib(4) + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + CALL POPREAL8(delcl) + delnoib = 0.D0 + delclib = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + c1 = a3*chi3 + c2 = a4*chi4 + c3 = a3 - a4 + chi3ib = delnoib + delnoib = 0.D0 + ELSE + c1 = a3*chi3 + c2 = a4*chi4 + c3 = a3 - a4 + chi3ib = 0.D0 + END IF + temp3ib = delnoib/(c2+c3*delcl) + temp3ib0 = -(c1*delcl*temp3ib/(c2+c3*delcl)) + c1ib = delcl*temp3ib + delclib = delclib + c3*temp3ib0 + c1*temp3ib + c2ib = temp3ib0 + c3ib = delcl*temp3ib0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + chi4ib = delclib + delclib = 0.D0 + ELSE + chi4ib = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) delclib = 0.D0 + m1 = (c1+c2+(omega+a4)*c3)/c3 + m2 = ((omega+a4)*c2-a4*c3*chi4)/c3 + m3 = -(a4*c2*chi4/c3) + CALL POLY3_IB(m1, m1ib, m2, m2ib, m3, m3ib, delcl, delclib, + + islv) +C WRITE(*,*) 'm1ib',m1ib,'m2ib',m2ib,'m3ib',m3ib +C WRITE(*,*) 'delcl(b)',delcl, delclib +C WRITE(*,*) 'islv',islv + temp2 = chi4/c3 + temp2ib = -(a4*c2*m3ib/c3) + temp2ib0 = m2ib/c3 + temp2ib1 = m1ib/c3 + c2ib = c2ib + (omega+a4)*temp2ib0 + temp2ib1 - temp2*a4*m3ib + chi4ib = chi4ib + a4*c2ib - a4*c3*temp2ib0 + temp2ib + c3ib = c3ib + (-(((omega+a4)*c2-a4*c3*chi4)/c3)-chi4*a4)* + + temp2ib0 + (omega-(c1+c2+(omega+a4)*c3)/c3+a4)*temp2ib1 - + + temp2*temp2ib + a4ib = (c2-chi4*c3)*temp2ib0 - c3ib + chi4*c2ib + c3*temp2ib1 + + - temp2*c2*m3ib + omegaib = c3*temp2ib1 + c2*temp2ib0 + c1ib = c1ib + temp2ib1 + a3ib = chi3*c1ib + c3ib + chi3ib = chi3ib + a3*c1ib + wib(5) = wib(5) + chi4ib + wib(4) = wib(4) + chi3ib + molalib(1) = molalib(1) + omegaib + temp1 = water/gama(11) + temp1ib = 2.0*temp1*xk3*r*temp*a4ib/gama(11) + gamaib(11) = gamaib(11) - temp1*temp1ib + temp0 = water/gama(10) + temp0ib = 2.0*temp0*xk4*r*temp*a3ib/gama(10) + waterib = waterib + temp0ib + temp1ib + gamaib(10) = gamaib(10) - temp0*temp0ib +C WRITE(*,*) 'GAMA IB at end of CALCNHA_IBWD', gamaib(10) +C WRITE(*,*) 'wib(4,5)',wib(4),wib(5) +C WRITE(*,*) 'w ',w, 'rh',rh +C PAUSE + ghno3ib = 0.D0 + END IF + ghclib = 0.D0 + END IF + 100 CONTINUE + END + +C Differentiation of calcha in reverse (adjoint) mode: +C gradient of useful results: molal gama water ghcl +C with respect to varying inputs: w molal gama water +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCHA +C *** CALCULATES CHLORIDES SPECIATION +C +C HYDROCHLORIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, +C AND DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE +C HYDROCHLORIC ACID DISSOLVED IS CALCULATED FROM THE +C HCL(G) <-> (H+) + (CL-) +C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCHA_IB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: kapa, x, delt, alfa, diak + REAL*8 :: kapaib, xib, deltib, alfaib, diakib + INTEGER :: branch + REAL*8 :: temp0 + REAL*8 :: temp1ib1 + REAL*8 :: temp1ib0 + INTRINSIC MAX + REAL*8 :: temp1ib + INTEGER :: ii1 + REAL*8 :: temp0ib + INTRINSIC SQRT +C +C *** CALCULATE HCL DISSOLUTION ***************************************** +C + x = w(5) + delt = 0.0d0 + IF (water > tiny) THEN + kapa = molal(1) + alfa = xk3*r*temp*(water/gama(11))**2.0 + diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x) + delt = 0.5*(-(kapa+alfa)+diak) +CC IF (DELT/KAPA > 0.1d0) THEN +CC WRITE (ERRINF,'(1PE10.3)') DELT/KAPA*100.0 +CC CALL PUSHERR (0033, ERRINF) +CC ENDIF + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + IF (x - delt < 0.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + deltib = molalib(4) + molalib(1) + molalib(4) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + xib = 0.D0 + ELSE + xib = ghclib + deltib = deltib - ghclib + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp1ib = 0.5*deltib + diakib = temp1ib + IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN + temp1ib1 = 0.0 + ELSE + temp1ib1 = diakib/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x))) + END IF + temp1ib0 = 2.0*(kapa+alfa)*temp1ib1 + alfaib = temp1ib0 + 4.0*x*temp1ib1 - temp1ib + kapaib = temp1ib0 - temp1ib + xib = xib + 4.0*alfa*temp1ib1 + temp0 = water/gama(11) + temp0ib = 2.0*temp0*xk3*r*temp*alfaib/gama(11) + waterib = waterib + temp0ib + gamaib(11) = gamaib(11) - temp0*temp0ib + molalib(1) = molalib(1) + kapaib + END IF + DO ii1=1,ncomp + wib(ii1) = 0.D0 + ENDDO + wib(5) = wib(5) + xib + END + +C Differentiation of calcna in reverse (adjoint) mode: +C gradient of useful results: molal gama water ghno3 +C with respect to varying inputs: w molal gama water +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNA +C *** CALCULATES NITRATES SPECIATION +C +C NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT +C DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC +C ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> (H+) + (NO3-) +C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNA_IB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: alfa, delt, kapa, diak + REAL*8 :: alfaib, deltib, kapaib, diakib + REAL*8 :: x + REAL*8 :: xib + INTEGER :: branch + REAL*8 :: temp0 + REAL*8 :: temp1ib1 + REAL*8 :: temp1ib0 + INTRINSIC MAX + REAL*8 :: temp1ib + INTEGER :: ii1 + REAL*8 :: temp0ib + INTRINSIC SQRT +C +C *** CALCULATE HNO3 DISSOLUTION **************************************** +C + x = w(4) + delt = 0.0d0 + IF (water > tiny) THEN + kapa = molal(1) + alfa = xk4*r*temp*(water/gama(10))**2.0 + diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x) + delt = 0.5*(-(kapa+alfa)+diak) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + IF (x - delt < 0.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + deltib = molalib(7) + molalib(1) + molalib(7) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + xib = 0.D0 + ELSE + xib = ghno3ib + deltib = deltib - ghno3ib + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp1ib = 0.5*deltib + diakib = temp1ib + IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN + temp1ib1 = 0.0 + ELSE + temp1ib1 = diakib/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x))) + END IF + temp1ib0 = 2.0*(kapa+alfa)*temp1ib1 + alfaib = temp1ib0 + 4.0*x*temp1ib1 - temp1ib + kapaib = temp1ib0 - temp1ib + xib = xib + 4.0*alfa*temp1ib1 + temp0 = water/gama(10) + temp0ib = 2.0*temp0*xk4*r*temp*alfaib/gama(10) + waterib = waterib + temp0ib + gamaib(10) = gamaib(10) - temp0*temp0ib + molalib(1) = molalib(1) + kapaib + END IF + DO ii1=1,ncomp + wib(ii1) = 0.D0 + ENDDO + wib(4) = wib(4) + xib + END + +C Differentiation of calcact3 in reverse (adjoint) mode: +C gradient of useful results: molal gama water +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3_IB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0ib(6, 4), sionib, hib, chib, f1ib(3), f2ib(4) + REAL*8 :: mpl, xij, yji + REAL*8 :: mplib, xijib, yjiib, ionicib + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01ib + REAL*8 :: g02 + REAL*8 :: g02ib + REAL*8 :: g03 + REAL*8 :: g03ib + REAL*8 :: g04 + REAL*8 :: g04ib + REAL*8 :: g05 + REAL*8 :: g05ib + REAL*8 :: g06 + REAL*8 :: g06ib + REAL*8 :: g07 + REAL*8 :: g07ib + REAL*8 :: g08 + REAL*8 :: g08ib + REAL*8 :: g09 + REAL*8 :: g09ib + REAL*8 :: g10 + REAL*8 :: g10ib + REAL*8 :: g11 + REAL*8 :: g11ib + REAL*8 :: g12 + REAL*8 :: g12ib + INTEGER :: j + REAL*8 :: errou + REAL*8 :: errin +C + INTEGER :: branch + REAL*8 :: temp0ib9 + REAL*8 :: temp0ib8 + REAL*8 :: temp0ib7 + REAL*8 :: temp0ib6 + REAL*8 :: temp0ib5 + REAL*8 :: temp0ib4 + REAL*8 :: temp0ib3 + REAL*8 :: temp0ib2 + REAL*8 :: temp0ib1 + REAL*8 :: temp0ib0 + INTRINSIC MAX + INTRINSIC ABS + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: x1ib + REAL*8 :: temp0ib13 + REAL*8 :: temp0ib12 + REAL*8 :: temp0ib11 + REAL*8 :: temp0ib10 + REAL*8 :: x2ib + INTRINSIC MIN + INTEGER :: ii2 + REAL*8 :: temp0ib + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: y2 + REAL*8 :: y1 +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + DO i=1,7 + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08, + + g09, g10, g11, g12) +C + g0(1, 1) = g11 + g0(1, 2) = g07 + g0(1, 3) = g08 + g0(1, 4) = g10 + g0(2, 1) = g01 + g0(2, 2) = g02 + g0(2, 3) = g12 + g0(2, 4) = g03 + g0(3, 1) = g06 + g0(3, 2) = g04 + g0(3, 3) = g09 + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + sion = SQRT(ionic) + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + yji = ch*molal(j+3)/water + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gama(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gama(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gama(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gama(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gama(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gama(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gama(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gama(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gama(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gama(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gama(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gama(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gama(13)) +C LC ; SCAPE + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + ELSE + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + gamaib(i) = 10.d0**gama(i)*LOG(10.d0)*gamaib(i) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + gamaib(i) = 0.D0 + x2ib = 0.D0 + ELSE + x2ib = gamaib(i) + gamaib(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) gamaib(i) = gamaib(i) + x2ib + ENDDO + CALL POPREAL8(gama(13)) + gamaib(4) = gamaib(4) + 0.2d0*3.d0*gamaib(13) + gamaib(9) = gamaib(9) + 0.2d0*2.d0*gamaib(13) + gamaib(13) = 0.D0 + DO ii1=1,3 + f1ib(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2ib(ii1) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp0ib2 = zz(12)*gamaib(12)/(z(2)+z(6)) + f1ib(2) = f1ib(2) + temp0ib2/z(2) + f2ib(3) = f2ib(3) + temp0ib2/z(6) + hib = -(zz(12)*gamaib(12)) + gamaib(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp0ib3 = zz(11)*gamaib(11)/(z(1)+z(4)) + f2ib(1) = f2ib(1) + temp0ib3/z(4) + hib = hib - zz(11)*gamaib(11) + gamaib(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp0ib4 = zz(10)*gamaib(10)/(z(1)+z(7)) + f1ib(1) = f1ib(1) + temp0ib4/z(1) + temp0ib3/z(1) + f2ib(4) = f2ib(4) + temp0ib4/z(7) + hib = hib - zz(10)*gamaib(10) + gamaib(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp0ib5 = zz(9)*gamaib(9)/(z(3)+z(6)) + f1ib(3) = f1ib(3) + temp0ib5/z(3) + hib = hib - zz(9)*gamaib(9) + gamaib(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp0ib6 = zz(8)*gamaib(8)/(z(1)+z(6)) + f2ib(3) = f2ib(3) + temp0ib6/z(6) + temp0ib5/z(6) + hib = hib - zz(8)*gamaib(8) + gamaib(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp0ib7 = zz(7)*gamaib(7)/(z(1)+z(5)) + f1ib(1) = f1ib(1) + temp0ib7/z(1) + temp0ib6/z(1) + f2ib(2) = f2ib(2) + temp0ib7/z(5) + hib = hib - zz(7)*gamaib(7) + gamaib(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp0ib8 = zz(6)*gamaib(6)/(z(3)+z(4)) + f2ib(1) = f2ib(1) + temp0ib8/z(4) + hib = hib - zz(6)*gamaib(6) + gamaib(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp0ib9 = zz(5)*gamaib(5)/(z(3)+z(7)) + f2ib(4) = f2ib(4) + temp0ib9/z(7) + hib = hib - zz(5)*gamaib(5) + gamaib(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp0ib10 = zz(4)*gamaib(4)/(z(3)+z(5)) + f1ib(3) = f1ib(3) + temp0ib9/z(3) + temp0ib10/z(3) + temp0ib8/z(3) + f2ib(2) = f2ib(2) + temp0ib10/z(5) + hib = hib - zz(4)*gamaib(4) + gamaib(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp0ib11 = zz(3)*gamaib(3)/(z(2)+z(7)) + f2ib(4) = f2ib(4) + temp0ib11/z(7) + hib = hib - zz(3)*gamaib(3) + gamaib(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp0ib12 = zz(2)*gamaib(2)/(z(2)+z(5)) + f2ib(2) = f2ib(2) + temp0ib12/z(5) + hib = hib - zz(2)*gamaib(2) + gamaib(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp0ib13 = zz(1)*gamaib(1)/(z(2)+z(4)) + f1ib(2) = f1ib(2) + temp0ib12/z(2) + temp0ib13/z(2) + temp0ib11/z( + + 2) + f2ib(1) = f2ib(1) + temp0ib13/z(4) + hib = hib - zz(1)*gamaib(1) + gamaib(1) = 0.D0 + ionicib = 0.D0 + DO ii1=1,4 + DO ii2=1,6 + g0ib(ii2, ii1) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mplib = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijib = (g0(i, j)+zpl*zmi*h)*f2ib(j) + yji = ch*molal(j+3)/water + g0ib(i, j) = g0ib(i, j) + yji*f1ib(i) + xij*f2ib(j) + hib = hib + yji*zpl*zmi*f1ib(i) + xij*zpl*zmi*f2ib(j) + yjiib = (g0(i, j)+zpl*zmi*h)*f1ib(i) + temp0ib1 = molal(j+3)*yjiib/water + molalib(j+3) = molalib(j+3) + ch*yjiib/water + chib = mpl*xijib + temp0ib1 + waterib = waterib - ch*temp0ib1/water + mplib = mplib + ch*xijib + ionicib = ionicib - (zpl+zmi)**2*0.25d0*chib/ionic**2 + ENDDO + CALL POPREAL8(mpl) + molalib(i) = molalib(i) + mplib/water + waterib = waterib - molal(i)*mplib/water**2 + CALL POPREAL8(zpl) + ENDDO + temp0ib0 = agama*hib/(sion+1.d0) + sionib = (1.D0-sion/(sion+1.d0))*temp0ib0 + IF (.NOT.ionic == 0.0) ionicib = ionicib + sionib/(2.0*SQRT( + + ionic)) + g05ib = g0ib(3, 4) + g0ib(3, 4) = 0.D0 + g09ib = g0ib(3, 3) + g0ib(3, 3) = 0.D0 + g04ib = g0ib(3, 2) + g0ib(3, 2) = 0.D0 + g06ib = g0ib(3, 1) + g0ib(3, 1) = 0.D0 + g03ib = g0ib(2, 4) + g0ib(2, 4) = 0.D0 + g12ib = g0ib(2, 3) + g0ib(2, 3) = 0.D0 + g02ib = g0ib(2, 2) + g0ib(2, 2) = 0.D0 + g01ib = g0ib(2, 1) + g0ib(2, 1) = 0.D0 + g10ib = g0ib(1, 4) + g0ib(1, 4) = 0.D0 + g08ib = g0ib(1, 3) + g0ib(1, 3) = 0.D0 + g07ib = g0ib(1, 2) + g0ib(1, 2) = 0.D0 + g11ib = g0ib(1, 1) + CALL KMFUL3_IB(ionic, ionicib, temp, g01, g01ib, g02, g02ib, g03, + + g03ib, g04, g04ib, g05, g05ib, g06, g06ib, g07, + + g07ib, g08, g08ib, g09, g09ib, g10, g10ib, g11, + + g11ib, g12, g12ib) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionic) + x1ib = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1ib = ionicib + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ionicib = 0.D0 + ELSE + temp0ib = 0.5d0*x1ib/water + ionicib = temp0ib + waterib = waterib - ionic*temp0ib/water + END IF + DO i=7,1,-1 + molalib(i) = molalib(i) + z(i)**2*ionicib + ENDDO +C WRITE(*,*) 'End of CALCACT3_IB: molalib ', molalib + END + +C Differentiation of kmful3 in reverse (adjoint) mode: +C gradient of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 ionic +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_IB(ionic, ionicib, temp, g01, g01ib, g02, g02ib + + , g03, g03ib, g04, g04ib, g05, g05ib, g06, + + g06ib, g07, g07ib, g08, g08ib, g09, g09ib, + + g10, g10ib, g11, g11ib, g12, g12ib) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionicib, sionib, cf2ib + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01ib, g02ib, g03ib, g04ib, g05ib, g06ib, g07ib, + + g08ib, g09ib, g10ib, g11ib, g12ib + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTEGER :: branch + REAL*8 :: temp0ib0 + INTRINSIC ABS + REAL*8 :: abs1 + REAL*8 :: temp0ib + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01ib = g01ib + g12ib + g08ib = g08ib + g09ib + g12ib + g11ib = g11ib - g09ib - g12ib + g06ib = g06ib + g09ib + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2ib = -(z10*g10ib) - z07*g07ib - z05*g05ib - z03*g03ib - z01* + + g01ib - z02*g02ib - z04*g04ib - z06*g06ib - z08*g08ib - z11* + + g11ib + g11ib = cf1*g11ib + g10ib = cf1*g10ib + g08ib = cf1*g08ib + g07ib = cf1*g07ib + g06ib = cf1*g06ib + g05ib = cf1*g05ib + g04ib = cf1*g04ib + g03ib = cf1*g03ib + g02ib = cf1*g02ib + g01ib = cf1*g01ib + temp0ib = (0.125d0-ti*0.005d0)*cf2ib + temp0ib0 = -(0.41d0*temp0ib/(sion+1.d0)) + ionicib = ionicib + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0ib + sionib = (1.D0-sion/(sion+1.d0))*temp0ib0 + ELSE + sionib = 0.D0 + END IF + CALL MKBI_IB(q11, ionic, ionicib, sion, sionib, z11, g11, g11ib) + CALL MKBI_IB(q10, ionic, ionicib, sion, sionib, z10, g10, g10ib) + CALL MKBI_IB(q8, ionic, ionicib, sion, sionib, z08, g08, g08ib) + CALL MKBI_IB(q7, ionic, ionicib, sion, sionib, z07, g07, g07ib) + CALL MKBI_IB(q6, ionic, ionicib, sion, sionib, z06, g06, g06ib) + CALL MKBI_IB(q5, ionic, ionicib, sion, sionib, z05, g05, g05ib) + CALL MKBI_IB(q4, ionic, ionicib, sion, sionib, z04, g04, g04ib) + CALL MKBI_IB(q3, ionic, ionicib, sion, sionib, z03, g03, g03ib) + CALL MKBI_IB(q2, ionic, ionicib, sion, sionib, z02, g02, g02ib) + CALL MKBI_IB(q1, ionic, ionicib, sion, sionib, z01, g01, g01ib) + IF (.NOT.ionic == 0.0) ionicib = ionicib + sionib/(2.0*SQRT( + + ionic)) + END + +C Differentiation of mkbi in reverse (adjoint) mode: +C gradient of useful results: sion bi ionic +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_IB(q, ionic, ionicib, sion, sionib, zip, bi, biib) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionicib, sionib, biib + REAL*8 :: b, c, xx + REAL*8 :: cib, xxib + INTRINSIC EXP + REAL*8 :: tempib + INTRINSIC LOG10 + REAL*8 :: tempib0 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + c = 1.d0 + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic)) + bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b +C + xxib = zip*biib + biib = zip*biib/(bi*LOG(10.d0)) + tempib = -(0.5107d0*xxib/(c*sion+1.d0)) + tempib0 = -(sion*tempib/(c*sion+1.d0)) + sionib = sionib + c*tempib0 + tempib + cib = sion*tempib0 + IF (.1d0*ionic + 1.d0 <= 0.d0 .AND. (q == 0.d0 .OR. q /= + + INT(q))) THEN + ionicib = ionicib - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3* + + ionic**2*cib + ELSE + ionicib = ionicib + q*(.1d0*ionic+1.d0)**(q-1.d0)*b*.1d0*biib - + + .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cib + END IF + END + +C Differentiation of poly3 in reverse (adjoint) mode: +C gradient of useful results: root +C with respect to varying inputs: a1 a2 a3 +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE POLY3 +C *** FINDS THE REAL ROOTS OF THE THIRD ORDER ALGEBRAIC EQUATION: +C X**3 + A1*X**2 + A2*X + A3 = 0.0 +C THE EQUATION IS SOLVED ANALYTICALLY. +C +C PARAMETERS A1, A2, A3 ARE SPECIFIED BY THE USER. THE MINIMUM +C NONEGATIVE ROOT IS RETURNED IN VARIABLE 'ROOT'. IF NO ROOT IS +C FOUND (WHICH IS GREATER THAN ZERO), ROOT HAS THE VALUE 1D30. +C AND THE FLAG ISLV HAS A VALUE GREATER THAN ZERO. +C +C SOLUTION FORMULA IS FOUND IN PAGE 32 OF: +C MATHEMATICAL HANDBOOK OF FORMULAS AND TABLES +C SCHAUM'S OUTLINE SERIES +C MURRAY SPIEGER, McGRAW-HILL, NEW YORK, 1968 +C (GREEK TRANSLATION: BY SOTIRIOS PERSIDES, ESPI, ATHENS, 1976) +C +C A SPECIAL CASE IS CONSIDERED SEPERATELY ; WHEN A3 = 0, THEN +C ONE ROOT IS X=0.0, AND THE OTHER TWO FROM THE SOLUTION OF THE +C QUADRATIC EQUATION X**2 + A1*X + A2 = 0.0 +C THIS SPECIAL CASE IS CONSIDERED BECAUSE THE ANALYTICAL FORMULA +C DOES NOT YIELD ACCURATE RESULTS (DUE TO NUMERICAL ROUNDOFF ERRORS) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE POLY3_IB(a1, a1ib, a2, a2ib, a3, a3ib, root, rootib, + + islv) + IMPLICIT NONE + REAL*8 :: thet1 + REAL*8 :: thet2 + REAL*8 :: zero + REAL*8 :: expon + REAL*8 :: eps + REAL*8 :: pi +C + PARAMETER (expon=1.d0/3.d0, zero=0.d0, thet1=120.d0/180.d0, thet2= + + 240.d0/180.d0, pi=3.1415926535897932D0, eps=1.d-50) +C REAL*8 :: X(3) + REAL*8 :: x(3), a1, a2, a3, root + REAL*8 :: xib(3), a1ib, a2ib, a3ib, rootib + INTEGER :: ix + REAL*8 :: d + REAL*8 :: dib + REAL*8 :: sqd + REAL*8 :: sqdib + REAL*8 :: q + REAL*8 :: qib + REAL*8 :: u + REAL*8 :: uib + REAL*8 :: thet + REAL*8 :: thetib + REAL*8 :: coef + REAL*8 :: coefib + REAL*8 :: ssig + REAL*8 :: s + REAL*8 :: sib + REAL*8 :: tsig + REAL*8 :: t + REAL*8 :: tib + INTEGER :: i + INTEGER :: branch + INTEGER :: islv + REAL*8 :: abs4ib + REAL*8 :: temp0 + INTRINSIC COS + REAL*8 :: abs2ib + INTRINSIC SIGN + INTRINSIC ABS + REAL*8 :: tempib + REAL*8 :: abs3ib + INTRINSIC ACOS + REAL*8 :: abs4 + REAL*8 :: abs3 + REAL*8 :: abs2 + REAL*8 :: abs1 + REAL*8 :: tempib0 + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: temp + IF (a3 >= 0.) THEN + abs1 = a3 + ELSE + abs1 = -a3 + END IF +C +C *** SPECIAL CASE : QUADRATIC*X EQUATION ***************************** +C + IF (abs1 <= eps) THEN + ix = 1 + x(1) = zero + d = a1*a1 - 4.d0*a2 + IF (d >= zero) THEN + ix = 3 + sqd = SQRT(d) + x(2) = 0.5*(-a1+sqd) + x(3) = 0.5*(-a1-sqd) + CALL PUSHCONTROL3B(0) + ELSE + CALL PUSHCONTROL3B(1) + END IF + ELSE +C +C *** NORMAL CASE : CUBIC EQUATION ************************************ +C +C DEFINE PARAMETERS Q, U, S, T, D +C + q = (3.d0*a2-a1*a1)/9.d0 + u = (9.d0*a1*a2-27.d0*a3-2.d0*a1*a1*a1)/54.d0 + d = q*q*q + u*u +C WRITE(*,*) 'd',d +C +C *** CALCULATE ROOTS ************************************************* +C +C D < 0, THREE REAL ROOTS +C + IF (d < -eps) THEN +C D < -EPS : D < ZERO + ix = 3 + thet = expon*ACOS(u/SQRT(-(q*q*q))) + coef = 2.d0*SQRT(-q) + x(1) = coef*COS(thet) - expon*a1 + x(2) = coef*COS(thet+thet1*pi) - expon*a1 + x(3) = coef*COS(thet+thet2*pi) - expon*a1 +C +C D = 0, THREE REAL (ONE DOUBLE) ROOTS +C + CALL PUSHCONTROL3B(2) + ELSE IF (d <= eps) THEN +C -EPS <= D <= EPS : D = ZERO + ix = 2 + ssig = SIGN(1.d0, u) + IF (u >= 0.) THEN + abs2 = u + CALL PUSHCONTROL1B(0) + ELSE + abs2 = -u + CALL PUSHCONTROL1B(1) + END IF + s = ssig*abs2**expon + x(1) = 2.d0*s - expon*a1 + x(2) = -s - expon*a1 +C +C D > 0, ONE REAL ROOT +C + CALL PUSHCONTROL3B(3) + ELSE +C D > EPS : D > ZERO + ix = 1 + sqd = SQRT(d) +C TRANSFER SIGN TO SSIG + ssig = SIGN(1.d0, u + sqd) + tsig = SIGN(1.d0, u - sqd) + IF (u + sqd >= 0.) THEN + abs3 = u + sqd + CALL PUSHCONTROL1B(0) + ELSE + abs3 = -(u+sqd) + CALL PUSHCONTROL1B(1) + END IF +C EXPONENTIATE ABS() + s = ssig*abs3**expon + IF (u - sqd >= 0.) THEN + abs4 = u - sqd + CALL PUSHCONTROL1B(0) + ELSE + abs4 = -(u-sqd) + CALL PUSHCONTROL1B(1) + END IF + t = tsig*abs4**expon + x(1) = s + t - expon*a1 + CALL PUSHCONTROL3B(4) + END IF + END IF +C +C *** SELECT APPROPRIATE ROOT ***************************************** +C + root = 1.d30 + DO i=1,ix + IF (x(i) > zero) THEN + IF (root > x(i)) THEN + root = x(i) + CALL PUSHCONTROL2B(1) + ELSE + CALL PUSHCONTROL2B(2) + root = root + END IF + ELSE + CALL PUSHCONTROL2B(0) + END IF + ENDDO + DO ii1=1,3 + xib(ii1) = 0.D0 + ENDDO + DO i=ix,1,-1 + CALL POPCONTROL2B(branch) + IF (branch /= 0) THEN + IF (branch == 1) THEN + xib(i) = xib(i) + rootib + rootib = 0.D0 + END IF + END IF + ENDDO + CALL POPCONTROL3B(branch) + IF (branch < 2) THEN + IF (branch == 0) THEN + a1ib = -(0.5*xib(3)) + sqdib = -(0.5*xib(3)) + xib(3) = 0.D0 + sqdib = sqdib + 0.5*xib(2) + a1ib = a1ib - 0.5*xib(2) + IF (d == 0.0) THEN + dib = 0.0 + ELSE + dib = sqdib/(2.0*SQRT(d)) + END IF + ELSE + a1ib = 0.D0 + dib = 0.D0 + END IF + a1ib = a1ib + 2*a1*dib + a2ib = -(4.d0*dib) + a3ib = 0.D0 + ELSE + IF (branch == 2) THEN + coefib = COS(thet2*pi+thet)*xib(3) + thetib = -(coef*SIN(thet2*pi+thet)*xib(3)) + a1ib = -(expon*xib(3)) + xib(3) = 0.D0 + coefib = coefib + COS(thet1*pi+thet)*xib(2) + thetib = thetib - coef*SIN(thet1*pi+thet)*xib(2) + a1ib = a1ib - expon*xib(2) + xib(2) = 0.D0 + coefib = coefib + COS(thet)*xib(1) + thetib = thetib - coef*SIN(thet)*xib(1) + a1ib = a1ib - expon*xib(1) + IF (-q == 0.0) THEN + qib = 0.0 + ELSE + qib = -(2.d0*coefib/(2.0*SQRT(-q))) + END IF + temp0 = -(q**3) + temp = SQRT(temp0) + tempib0 = -(expon*thetib/(SQRT(1.0-(u/temp)**2)*temp)) + uib = tempib0 + IF (.NOT.temp0 == 0.0) qib = qib + u*3*q**2*tempib0/(2.0* + + temp**2) + dib = 0.D0 + ELSE + IF (branch == 3) THEN + sib = -xib(2) + a1ib = -(expon*xib(2)) + xib(2) = 0.D0 + sib = sib + 2.d0*xib(1) + a1ib = a1ib - expon*xib(1) + IF (abs2 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT( + + expon))) THEN + abs2ib = 0.0 + ELSE + abs2ib = ssig*expon*abs2**(expon-1)*sib + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + uib = abs2ib + ELSE + uib = -abs2ib + END IF + dib = 0.D0 + ELSE + sib = xib(1) + tib = xib(1) + a1ib = -(expon*xib(1)) + IF (abs4 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT( + + expon))) THEN + abs4ib = 0.0 + ELSE + abs4ib = tsig*expon*abs4**(expon-1)*tib + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + uib = abs4ib + sqdib = -abs4ib + ELSE + sqdib = abs4ib + uib = -abs4ib + END IF + IF (abs3 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT( + + expon))) THEN + abs3ib = 0.0 + ELSE + abs3ib = ssig*expon*abs3**(expon-1)*sib + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + uib = uib + abs3ib + sqdib = sqdib + abs3ib + ELSE + uib = uib - abs3ib + sqdib = sqdib - abs3ib + END IF + IF (d == 0.0) THEN + dib = 0.0 + ELSE + dib = sqdib/(2.0*SQRT(d)) + END IF + END IF + qib = 0.D0 + END IF + qib = qib + 3*q**2*dib + uib = uib + 2*u*dib + tempib = uib/54.d0 + a1ib = a1ib + (9.d0*a2-2.d0*3*a1**2)*tempib - 2*a1*qib/9.d0 + a2ib = 3.d0*qib/9.d0 + 9.d0*a1*tempib + a3ib = -(27.d0*tempib) + END IF + END + +C Generated by TAPENADE (INRIA, Tropics team) +C Tapenade 3.5 (r3619) - 22 Dec 2010 19:21 +C +C Differentiation of isrp3f in reverse (adjoint) mode: +C gradient of useful results: aerliq gas +C with respect to varying inputs: wp aerliq gas +C RW status of diff variables: wp:out aerliq:in-out gas:in-out +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE ISRP3F +C *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF +C AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE & SODIUM +C RATIOS AND BY THE AMBIENT RELATIVE HUMIDITY. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE ISRP3F_JB(wpjb, gasjb, aerliqjb) + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: gas(3), aerliq(NIONS+NGASAQ+2) + REAL*8 :: wpjb(ncomp), gasjb(3), aerliqjb(NIONS+NGASAQ+2) + REAL*8 :: rest + REAL*8 :: restjb + INTEGER :: i, ncase, npflag + INTEGER :: branch + INTEGER :: ii1 +C +C *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE ********* +C + rest = 2.d0*w(2) + w(4) + w(5) + IF (w(1) > rest) THEN +C NA > 2*SO4+CL+NO3 ? +C Adjust Na amount + w(1) = (one-1d-6)*rest + CALL PUSHERR(50, 'ISRP3F') +C Warning error: Na adjusted + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + CALL PUSHINTEGER4(iclact) + CALL PUSHREAL8(water) + CALL PUSHREAL8ARRAY(gamou, npair) + CALL PUSHREAL8ARRAY(gama, npair) + CALL PUSHREAL8ARRAY(molalr, npair) + CALL PUSHREAL8ARRAY(molal, nions) +C +C *** CALCULATE SULFATE & SODIUM RATIOS ********************************* +C +C +C *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** +C +C *** SULFATE POOR ; SODIUM POOR +C *** SULFATE RICH (FREE ACID) +C +C ELSEIF (SULRAT < 1.0) THEN +CC +CC IF(METSTBL == 1) THEN +C Only liquid (metastable) + CALL CALCJ3() +CC ELSE +C MINOR SPECIES: HNO3, HCl + CALL CALCNHA_JFWD() + CALL PUSHREAL8ARRAY(gama, npair) + CALL CALCACT3() + CALL CALCACT3F() +C NH3 + ghcljb = gasjb(3) + gasjb(3) = 0.D0 + ghno3jb = gasjb(2) + gasjb(2) = 0.D0 + gnh3jb = gasjb(1) + gasjb(1) = 0.D0 + aerliqjb(nions+ngasaq+2) = 0.D0 + waterjb = 1.0d3*aerliqjb(nions+1)/18.0d0 + aerliqjb(nions+1) = 0.D0 + DO i=ngasaq,1,-1 + aerliqjb(nions+1+i) = 0.D0 + ENDDO + DO ii1=1,nions + molaljb(ii1) = 0.D0 + ENDDO + DO i=nions,1,-1 + molaljb(i) = molaljb(i) + aerliqjb(i) + aerliqjb(i) = 0.D0 + ENDDO + CALL CALCNH3_JB() + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3_JB() + CALL CALCNHA_JBWD() + CALL POPREAL8ARRAY(molal, nions) + CALL POPREAL8ARRAY(molalr, npair) + CALL POPREAL8ARRAY(gama, npair) + CALL POPREAL8ARRAY(gamou, npair) + CALL POPREAL8(water) + CALL POPINTEGER4(iclact) + CALL CALCJ3_JB() + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + restjb = (one-1d-6)*wjb(1) + wjb(1) = 0.D0 + ELSE + restjb = 0.D0 + END IF + wjb(2) = wjb(2) + 2.d0*restjb + wjb(4) = wjb(4) + restjb + wjb(5) = wjb(5) + restjb + DO ii1=1,5 + wpjb(ii1) = 0.D0 + ENDDO + wpjb = wjb +C +C ncase = 10 +C NOFER = 0 +C CALL ISERRINF (ERRSTK, ERRMSG, NOFER, STKOFL) ! Obtain error stack +C WRITE(*,*) 'Writing error code' +C IF (NOFER == 0) THEN ! No errors +C NONPHYS = .FALSE. +C npflag = 0 +CC WRITE(*,*) 'Setting NONPHYS to FALSE' +C ELSE +C NONPHYS = .TRUE. +C npflag = 1 +CC WRITE(*,*) 'Setting NONPHYS to TRUE' +CC PAUSE +CC WRITE(*,*) 'After pause' +C ENDIF +CC WRITE(*,*) 'wpb',wpb +C OPEN (199, FILE='adj_sens.csv',STATUS='UNKNOWN', +C & POSITION='APPEND') +C WRITE(199,888) w,rh,temp,wpjb,npflag,ncase +C CLOSE (199, STATUS='KEEP') +C 888 FORMAT (12(1PE11.4,","),I2,",",I2) + END + +C Differentiation of calcj3 in reverse (adjoint) mode: +C gradient of useful results: w molal gama water +C with respect to varying inputs: w +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCJ3 +C *** CASE J3 +C +C THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +C 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +C 2. THERE IS ONLY A LIQUID PHASE +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCJ3_JB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: psi1jb + REAL*8 :: psi2jb + REAL*8 :: chi1jb + REAL*8 :: a3jb + REAL*8 :: chi2jb +C + REAL*8 :: lamda, kapa + REAL*8 :: lamdajb, kapajb + INTEGER :: i + REAL*8 :: bb + REAL*8 :: bbjb + REAL*8 :: cc + REAL*8 :: ccjb + REAL*8 :: dd + REAL*8 :: ddjb, molalrjb(npair) + INTEGER :: j + INTEGER :: branch + INTEGER :: ad_count + INTEGER :: i0 + REAL*8 :: temp1 + REAL*8 :: temp0 + INTRINSIC MAX + REAL*8 :: temp2jb + REAL*8 :: temp0jb + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: temp1jb +C +C *** SETUP PARAMETERS ************************************************ +C +C Outer loop activity calculation flag + frst = .true. + calain = .true. + IF (w(2) - w(3) - w(1) < tiny) THEN + CALL PUSHCONTROL1B(0) + lamda = tiny + ELSE + lamda = w(2) - w(3) - w(1) + CALL PUSHCONTROL1B(1) + END IF +C NA TOTAL as NaHSO4 + chi1 = w(1) +C NH4 TOTAL as NH4HSO4 + chi2 = w(3) + psi1 = chi1 +C ALL NH4HSO4 DELIQUESCED + psi2 = chi2 +C +C *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +C + i = 1 + ad_count = 0 + DO WHILE (i <= nsweep .AND. calain) +C + a3 = xk1*water/gama(7)*(gama(8)/gama(7))**2.0 +C +C CALCULATE DISSOCIATION QUANTITIES +C +C KAPA + bb = a3 + lamda + cc = -(a3*(lamda+psi1+psi2)) + dd = bb*bb - 4.d0*cc + kapa = 0.5d0*(-bb+SQRT(dd)) + CALL PUSHREAL8(molal(1)) +C +C *** CALCULATE SPECIATION ******************************************** +C +C HI + molal(1) = lamda + kapa + CALL PUSHREAL8(molal(2)) +C NAI + molal(2) = psi1 + CALL PUSHREAL8(molal(3)) +C NH4I + molal(3) = psi2 + CALL PUSHREAL8(molal(4)) +C CLI + molal(4) = zero + CALL PUSHREAL8(molal(5)) +C SO4I + molal(5) = kapa + CALL PUSHREAL8(molal(6)) +C HSO4I + molal(6) = lamda + psi1 + psi2 - kapa + CALL PUSHREAL8(molal(7)) +C NO3I + molal(7) = zero +C +C +C CALL CALCMR ! Water content +C +C NH4HSO4 + molalr(9) = molal(3) +C NAHSO4 + molalr(12) = molal(2) +C H2SO4 + molalr(7) = molal(5) + molal(6) - molal(3) - molal(2) + IF (molalr(7) < zero) THEN + molalr(7) = zero + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + molalr(7) = molalr(7) + END IF + CALL PUSHREAL8(water) +C +C *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +C + water = zero + DO j=1,npair + water = water + molalr(j)/m0(j) + ENDDO + IF (water < tiny) THEN + water = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + water = water + END IF + CALL PUSHREAL8ARRAY(gama, npair) +C +C *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +C + CALL CALCACT3() + i = i + 1 + ad_count = ad_count + 1 + ENDDO + CALL PUSHINTEGER4(ad_count) + DO ii1=1,npair + molalrjb(ii1) = 0.D0 + ENDDO + psi1jb = 0.D0 + psi2jb = 0.D0 + lamdajb = 0.D0 + CALL POPINTEGER4(ad_count) + DO i0=1,ad_count + CALL POPREAL8ARRAY(gama, npair) + CALL CALCACT3_JB() + CALL POPCONTROL1B(branch) + IF (branch == 0) waterjb = 0.D0 + DO j=npair,1,-1 + molalrjb(j) = molalrjb(j) + waterjb/m0(j) + ENDDO + CALL POPREAL8(water) + CALL POPCONTROL1B(branch) + IF (branch == 0) molalrjb(7) = 0.D0 + molaljb(5) = molaljb(5) + molalrjb(7) + molaljb(6) = molaljb(6) + molalrjb(7) + molaljb(3) = molaljb(3) - molalrjb(7) + molaljb(2) = molaljb(2) - molalrjb(7) + molalrjb(7) = 0.D0 + molaljb(2) = molaljb(2) + molalrjb(12) + molalrjb(12) = 0.D0 + molaljb(3) = molaljb(3) + molalrjb(9) + molalrjb(9) = 0.D0 + CALL POPREAL8(molal(7)) + molaljb(7) = 0.D0 + CALL POPREAL8(molal(6)) + lamdajb = lamdajb + molaljb(6) + psi1jb = psi1jb + molaljb(6) + psi2jb = psi2jb + molaljb(6) + kapajb = -molaljb(6) + molaljb(6) = 0.D0 + CALL POPREAL8(molal(5)) + kapajb = kapajb + molaljb(5) + molaljb(5) = 0.D0 + CALL POPREAL8(molal(4)) + molaljb(4) = 0.D0 + CALL POPREAL8(molal(3)) + psi2jb = psi2jb + molaljb(3) + molaljb(3) = 0.D0 + CALL POPREAL8(molal(2)) + psi1jb = psi1jb + molaljb(2) + molaljb(2) = 0.D0 + CALL POPREAL8(molal(1)) + kapajb = kapajb + molaljb(1) + a3 = xk1*water/gama(7)*(gama(8)/gama(7))**2.0 + bb = a3 + lamda + cc = -(a3*(lamda+psi1+psi2)) + dd = bb*bb - 4.d0*cc + IF (dd == 0.0) THEN + ddjb = 0.0 + ELSE + ddjb = 0.5d0*kapajb/(2.0*SQRT(dd)) + END IF + bbjb = 2*bb*ddjb - 0.5d0*kapajb + ccjb = -(4.d0*ddjb) + temp2jb = -(a3*ccjb) + lamdajb = lamdajb + temp2jb + bbjb + molaljb(1) + molaljb(1) = 0.D0 + a3jb = bbjb - (lamda+psi1+psi2)*ccjb + psi1jb = psi1jb + temp2jb + psi2jb = psi2jb + temp2jb + temp0 = water/gama(7) + temp1 = gama(8)/gama(7) + temp1jb = 2.0*temp1*temp0*xk1*a3jb/gama(7) + temp0jb = temp1**2.0*xk1*a3jb/gama(7) + gamajb(8) = gamajb(8) + temp1jb + gamajb(7) = gamajb(7) - temp0*temp0jb - temp1*temp1jb + waterjb = temp0jb + ENDDO + chi2jb = psi2jb + chi1jb = psi1jb + wjb(3) = wjb(3) + chi2jb + wjb(1) = wjb(1) + chi1jb + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + wjb(2) = wjb(2) + lamdajb + wjb(3) = wjb(3) - lamdajb + wjb(1) = wjb(1) - lamdajb + END IF + END +C +C Differentiation of calcnh3 in reverse (adjoint) mode: +C gradient of useful results: molal gnh3 +C with respect to varying inputs: molal gama +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNH3 +C *** CALCULATES AMMONIA IN GAS PHASE +C +C AMMONIA IN THE GAS PHASE IS ASSUMED A MINOR SPECIES, THAT +C DOES NOT SIGNIFICANTLY PERTURB THE AEROSOL EQUILIBRIUM. +C AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l) +C EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION. +C +C THIS IS THE VERSION USED BY THE DIRECT PROBLEM +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNH3_JB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: a1jb + REAL*8 :: chi1jb + REAL*8 :: chi2jb + REAL*8 :: bb, cc, diak, psi + REAL*8 :: bbjb, ccjb, diakjb, psijb + INTEGER :: branch + REAL*8 :: temp0 + REAL*8 :: x1jb + INTRINSIC MAX + REAL*8 :: x1 + REAL*8 :: temp0jb + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: temp1jb +C +C *** IS THERE A LIQUID PHASE? ****************************************** +C + IF (water <= tiny) THEN + DO ii1=1,npair + gamajb(ii1) = 0.D0 + ENDDO + ELSE +C +C *** CALCULATE NH3 SUBLIMATION ***************************************** +C + a1 = xk2/xkw*r*temp*(gama(10)/gama(5))**2.0 + chi1 = molal(3) + chi2 = molal(1) +C +C a=1; b!=1; c!=1 + bb = chi2 + one/a1 + cc = -(chi1/a1) +C Always > 0 + diak = SQRT(bb*bb - 4.d0*cc) +C One positive root + psi = 0.5*(-bb+diak) + IF (psi > chi1) THEN + x1 = chi1 + CALL PUSHCONTROL1B(0) + ELSE + x1 = psi + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + chi2jb = molaljb(1) + psijb = molaljb(1) + molaljb(1) = 0.D0 + chi1jb = molaljb(3) + psijb = psijb + gnh3jb - molaljb(3) + molaljb(3) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + x1jb = 0.D0 + ELSE + x1jb = psijb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + chi1jb = chi1jb + x1jb + psijb = 0.D0 + ELSE + psijb = x1jb + END IF + diakjb = 0.5*psijb + IF (bb**2 - 4.d0*cc == 0.0) THEN + temp1jb = 0.0 + ELSE + temp1jb = diakjb/(2.0*SQRT(bb**2-4.d0*cc)) + END IF + bbjb = 2*bb*temp1jb - 0.5*psijb + ccjb = -(4.d0*temp1jb) + chi1jb = chi1jb - ccjb/a1 + a1jb = chi1*ccjb/a1**2 - one*bbjb/a1**2 + chi2jb = chi2jb + bbjb + molaljb(1) = molaljb(1) + chi2jb + molaljb(3) = molaljb(3) + chi1jb + DO ii1=1,npair + gamajb(ii1) = 0.D0 + ENDDO + temp0 = gama(10)/gama(5) + temp0jb = 2.0*temp0*xk2*r*temp*a1jb/(xkw*gama(5)) + gamajb(10) = gamajb(10) + temp0jb + gamajb(5) = gamajb(5) - temp0*temp0jb + END IF + END + +C Differentiation of calcnha in reverse (adjoint) mode (forward sweep): +C gradient of useful results: molal gama water ghno3 ghcl +C with respect to varying inputs: w molal gama water +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNHA +C +C THIS SUBROUTINE CALCULATES THE DISSOLUTION OF HCL, HNO3 AT +C THE PRESENCE OF (H,SO4). HCL, HNO3 ARE CONSIDERED MINOR SPECIES, +C THAT DO NOT SIGNIFICANTLY AFFECT THE EQUILIBRIUM POINT. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNHA_JFWD() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: m1, m2, m3, delcl, delno, omega + CHARACTER(LEN=40) errinf + REAL*8 :: c1 + REAL*8 :: c2 + REAL*8 :: c3 + INTEGER :: islv + INTRINSIC MAX + INTRINSIC MIN +C +C *** SPECIAL CASE; WATER=ZERO ****************************************** +C + IF (water <= tiny) THEN + IF (w(5) - molal(4) < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + IF (w(4) - molal(7) < tiny) THEN + CALL PUSHCONTROL3B(1) + ELSE + CALL PUSHCONTROL3B(0) + END IF + ELSE IF (w(5) <= tiny .AND. w(4) <= tiny) THEN + CALL PUSHCONTROL3B(2) + ELSE IF (w(5) <= tiny) THEN + CALL PUSHREAL8ARRAY(molal, nions) +C CALL HNO3 DISSOLUTION ROUTINE + CALL CALCNA() +C GOTO 60 +C +C *** SPECIAL CASE; HNO3=ZERO ******************************************* +C + CALL PUSHCONTROL3B(3) + ELSE IF (w(4) <= tiny) THEN + CALL PUSHREAL8ARRAY(molal, nions) +C CALL HCL DISSOLUTION ROUTINE + CALL CALCHA() +C GOTO 60 +C ENDIF + CALL PUSHCONTROL3B(4) + ELSE +C +C *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +C +C HNO3 + a3 = xk4*r*temp*(water/gama(10))**2.0 +C HCL + a4 = xk3*r*temp*(water/gama(11))**2.0 +C +C *** CALCULATE CUBIC EQUATION COEFFICIENTS ***************************** +C +C +C H+ + omega = molal(1) +C HNO3 + chi3 = w(4) +C HCL + chi4 = w(5) +C + c1 = a3*chi3 + c2 = a4*chi4 + c3 = a3 - a4 +C + m1 = (c1+c2+(omega+a4)*c3)/c3 + m2 = ((omega+a4)*c2-a4*c3*chi4)/c3 + m3 = -(a4*c2*chi4/c3) +C +C *** CALCULATE ROOTS *************************************************** +C + CALL POLY3(m1, m2, m3, delcl, islv) +C HCL DISSOLUTION + IF (islv /= 0) THEN +C TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT + delcl = tiny +C WRITE (ERRINF,'(1PE10.1)') TINY +C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + IF (delcl > chi4) THEN + delcl = chi4 + CALL PUSHCONTROL1B(0) + ELSE + delcl = delcl + CALL PUSHCONTROL1B(1) + END IF +C + delno = c1*delcl/(c2+c3*delcl) + IF (delno > chi3) THEN + delno = chi3 + CALL PUSHCONTROL1B(0) + ELSE + delno = delno + CALL PUSHCONTROL1B(1) + END IF +C + IF (((delcl < zero .OR. delno < zero) .OR. delcl > chi4 + + ) .OR. delno > chi3) THEN + CALL PUSHREAL8(delcl) +C TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT + delcl = tiny + delno = tiny +C WRITE (ERRINF,'(1PE10.1)') TINY +C CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF +CCC +CCC *** COMPARE DELTA TO TOTAL H+ ; ESTIMATE EFFECT TO HSO4 *************** +CCC +CC IF ((DELCL+DELNO)/MOLAL(1) > 0.1d0) THEN +CC WRITE (ERRINF,'(1PE10.3)') (DELCL+DELNO)/MOLAL(1)*100.0 +CC CALL PUSHERR (0021, ERRINF) +CC ENDIF +C +C *** EFFECT ON LIQUID PHASE ******************************************** +C +C H+ CHANGE + molal(1) = molal(1) + (delno+delcl) +C CL- CHANGE + molal(4) = molal(4) + delcl +C NO3- CHANGE + molal(7) = molal(7) + delno + IF (w(5) - molal(4) < tiny) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + IF (w(4) - molal(7) < tiny) THEN + CALL PUSHREAL8(omega) + CALL PUSHREAL8(delcl) + CALL PUSHCONTROL3B(5) + ELSE + CALL PUSHREAL8(omega) + CALL PUSHREAL8(delcl) + CALL PUSHCONTROL3B(6) + END IF + END IF + END + +C Differentiation of calcnha in reverse (adjoint) mode (backward sweep): +C gradient of useful results: molal gama water ghno3 ghcl +C with respect to varying inputs: w molal gama water +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNHA +C +C THIS SUBROUTINE CALCULATES THE DISSOLUTION OF HCL, HNO3 AT +C THE PRESENCE OF (H,SO4). HCL, HNO3 ARE CONSIDERED MINOR SPECIES, +C THAT DO NOT SIGNIFICANTLY AFFECT THE EQUILIBRIUM POINT. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNHA_JBWD() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: a3jb + REAL*8 :: a4jb + REAL*8 :: chi3jb + REAL*8 :: chi4jb + REAL*8 :: m1, m2, m3, delcl, delno, omega + REAL*8 :: m1jb, m2jb, m3jb, delcljb, delnojb, omegajb + CHARACTER(LEN=40) errinf + REAL*8 :: c1 + REAL*8 :: c1jb + REAL*8 :: c2 + REAL*8 :: c2jb + REAL*8 :: c3 + REAL*8 :: c3jb + INTEGER :: islv + INTEGER :: branch + REAL*8 :: temp2 + REAL*8 :: temp1 + REAL*8 :: temp0 + INTRINSIC MAX + REAL*8 :: temp2jb + REAL*8 :: temp0jb + REAL*8 :: temp2jb1 + REAL*8 :: temp2jb0 + REAL*8 :: temp3jb + REAL*8 :: temp3jb0 + INTRINSIC MIN + INTEGER :: ii1 + REAL*8 :: temp1jb + CALL POPCONTROL3B(branch) + IF (branch < 3) THEN + IF (branch == 0) THEN + DO ii1=1,ncomp + wjb(ii1) = 0.D0 + ENDDO + wjb(4) = wjb(4) + ghno3jb + molaljb(7) = molaljb(7) - ghno3jb + ELSE IF (branch == 1) THEN + DO ii1=1,ncomp + wjb(ii1) = 0.D0 + ENDDO + ELSE + DO ii1=1,ncomp + wjb(ii1) = 0.D0 + ENDDO + GOTO 100 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + wjb(5) = wjb(5) + ghcljb + molaljb(4) = molaljb(4) - ghcljb + END IF + ELSE IF (branch < 5) THEN + IF (branch == 3) THEN + CALL POPREAL8ARRAY(molal, nions) + CALL CALCNA_JB() + ELSE + CALL POPREAL8ARRAY(molal, nions) + CALL CALCHA_JB() + END IF + ELSE + IF (branch == 5) THEN + CALL POPREAL8(delcl) + CALL POPREAL8(omega) + DO ii1=1,ncomp + wjb(ii1) = 0.D0 + ENDDO + ELSE + CALL POPREAL8(delcl) + CALL POPREAL8(omega) + DO ii1=1,ncomp + wjb(ii1) = 0.D0 + ENDDO + wjb(4) = wjb(4) + ghno3jb + molaljb(7) = molaljb(7) - ghno3jb + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + wjb(5) = wjb(5) + ghcljb + molaljb(4) = molaljb(4) - ghcljb + END IF + delnojb = molaljb(1) + molaljb(7) + delcljb = molaljb(1) + molaljb(4) + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + CALL POPREAL8(delcl) + delnojb = 0.D0 + delcljb = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + c1 = a3*chi3 + c2 = a4*chi4 + c3 = a3 - a4 + chi3jb = delnojb + delnojb = 0.D0 + ELSE + c1 = a3*chi3 + c2 = a4*chi4 + c3 = a3 - a4 + chi3jb = 0.D0 + END IF + temp3jb = delnojb/(c2+c3*delcl) + temp3jb0 = -(c1*delcl*temp3jb/(c2+c3*delcl)) + c1jb = delcl*temp3jb + delcljb = delcljb + c3*temp3jb0 + c1*temp3jb + c2jb = temp3jb0 + c3jb = delcl*temp3jb0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + chi4jb = delcljb + delcljb = 0.D0 + ELSE + chi4jb = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) delcljb = 0.D0 + m1 = (c1+c2+(omega+a4)*c3)/c3 + m2 = ((omega+a4)*c2-a4*c3*chi4)/c3 + m3 = -(a4*c2*chi4/c3) + CALL POLY3_JB(m1, m1jb, m2, m2jb, m3, m3jb, delcl, delcljb, islv + + ) + temp2 = chi4/c3 + temp2jb = -(a4*c2*m3jb/c3) + temp2jb0 = m2jb/c3 + temp2jb1 = m1jb/c3 + c2jb = c2jb + (omega+a4)*temp2jb0 + temp2jb1 - temp2*a4*m3jb + chi4jb = chi4jb + a4*c2jb - a4*c3*temp2jb0 + temp2jb + c3jb = c3jb + (-(((omega+a4)*c2-a4*c3*chi4)/c3)-chi4*a4)* + + temp2jb0 + (omega-(c1+c2+(omega+a4)*c3)/c3+a4)*temp2jb1 - + + temp2*temp2jb + a4jb = (c2-chi4*c3)*temp2jb0 - c3jb + chi4*c2jb + c3*temp2jb1 - + + temp2*c2*m3jb + omegajb = c3*temp2jb1 + c2*temp2jb0 + c1jb = c1jb + temp2jb1 + a3jb = chi3*c1jb + c3jb + chi3jb = chi3jb + a3*c1jb + wjb(5) = wjb(5) + chi4jb + wjb(4) = wjb(4) + chi3jb + molaljb(1) = molaljb(1) + omegajb + temp1 = water/gama(11) + temp1jb = 2.0*temp1*xk3*r*temp*a4jb/gama(11) + gamajb(11) = gamajb(11) - temp1*temp1jb + temp0 = water/gama(10) + temp0jb = 2.0*temp0*xk4*r*temp*a3jb/gama(10) + waterjb = waterjb + temp0jb + temp1jb + gamajb(10) = gamajb(10) - temp0*temp0jb + END IF + 100 CONTINUE + END + +C Differentiation of calcha in reverse (adjoint) mode: +C gradient of useful results: molal gama water ghcl +C with respect to varying inputs: w molal gama water +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCHA +C *** CALCULATES CHLORIDES SPECIATION +C +C HYDROCHLORIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, +C AND DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE +C HYDROCHLORIC ACID DISSOLVED IS CALCULATED FROM THE +C HCL(G) <-> (H+) + (CL-) +C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCHA_JB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: kapa, x, delt, alfa, diak + REAL*8 :: kapajb, xjb, deltjb, alfajb, diakjb + INTEGER :: branch + REAL*8 :: temp0 + INTRINSIC MAX + REAL*8 :: temp1jb1 + REAL*8 :: temp0jb + REAL*8 :: temp1jb0 + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: temp1jb +C +C *** CALCULATE HCL DISSOLUTION ***************************************** +C + x = w(5) + delt = 0.0d0 + IF (water > tiny) THEN + kapa = molal(1) + alfa = xk3*r*temp*(water/gama(11))**2.0 + diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x) + delt = 0.5*(-(kapa+alfa)+diak) +CC IF (DELT/KAPA > 0.1d0) THEN +CC WRITE (ERRINF,'(1PE10.3)') DELT/KAPA*100.0 +CC CALL PUSHERR (0033, ERRINF) +CC ENDIF + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + IF (x - delt < 0.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + deltjb = molaljb(4) + molaljb(1) + molaljb(4) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + xjb = 0.D0 + ELSE + xjb = ghcljb + deltjb = deltjb - ghcljb + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp1jb = 0.5*deltjb + diakjb = temp1jb + IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN + temp1jb1 = 0.0 + ELSE + temp1jb1 = diakjb/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x))) + END IF + temp1jb0 = 2.0*(kapa+alfa)*temp1jb1 + alfajb = temp1jb0 + 4.0*x*temp1jb1 - temp1jb + kapajb = temp1jb0 - temp1jb + xjb = xjb + 4.0*alfa*temp1jb1 + temp0 = water/gama(11) + temp0jb = 2.0*temp0*xk3*r*temp*alfajb/gama(11) + waterjb = waterjb + temp0jb + gamajb(11) = gamajb(11) - temp0*temp0jb + molaljb(1) = molaljb(1) + kapajb + END IF + DO ii1=1,ncomp + wjb(ii1) = 0.D0 + ENDDO + wjb(5) = wjb(5) + xjb + END + +C Differentiation of calcna in reverse (adjoint) mode: +C gradient of useful results: molal gama water ghno3 +C with respect to varying inputs: w molal gama water +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCNA +C *** CALCULATES NITRATES SPECIATION +C +C NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT +C DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC +C ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> (H+) + (NO3-) +C EQUILIBRIUM, USING THE (H+) FROM THE SULFATES. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCNA_JB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: alfa, delt, kapa, diak + REAL*8 :: alfajb, deltjb, kapajb, diakjb + REAL*8 :: x + REAL*8 :: xjb + INTEGER :: branch + REAL*8 :: temp0 + INTRINSIC MAX + REAL*8 :: temp1jb1 + REAL*8 :: temp0jb + REAL*8 :: temp1jb0 + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: temp1jb +C +C *** CALCULATE HNO3 DISSOLUTION **************************************** +C + x = w(4) + delt = 0.0d0 + IF (water > tiny) THEN + kapa = molal(1) + alfa = xk4*r*temp*(water/gama(10))**2.0 + diak = SQRT((kapa+alfa)**2.0 + 4.0*alfa*x) + delt = 0.5*(-(kapa+alfa)+diak) + CALL PUSHCONTROL1B(1) + ELSE + CALL PUSHCONTROL1B(0) + END IF + IF (x - delt < 0.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + deltjb = molaljb(7) + molaljb(1) + molaljb(7) = 0.D0 + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + xjb = 0.D0 + ELSE + xjb = ghno3jb + deltjb = deltjb - ghno3jb + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) THEN + temp1jb = 0.5*deltjb + diakjb = temp1jb + IF ((kapa+alfa)**2.0 + 4.0*(alfa*x) == 0.0) THEN + temp1jb1 = 0.0 + ELSE + temp1jb1 = diakjb/(2.0*SQRT((kapa+alfa)**2.0+4.0*(alfa*x))) + END IF + temp1jb0 = 2.0*(kapa+alfa)*temp1jb1 + alfajb = temp1jb0 + 4.0*x*temp1jb1 - temp1jb + kapajb = temp1jb0 - temp1jb + xjb = xjb + 4.0*alfa*temp1jb1 + temp0 = water/gama(10) + temp0jb = 2.0*temp0*xk4*r*temp*alfajb/gama(10) + waterjb = waterjb + temp0jb + gamajb(10) = gamajb(10) - temp0*temp0jb + molaljb(1) = molaljb(1) + kapajb + END IF + DO ii1=1,ncomp + wjb(ii1) = 0.D0 + ENDDO + wjb(4) = wjb(4) + xjb + END + +C Differentiation of calcact3 in reverse (adjoint) mode: +C gradient of useful results: molal gama water +C with respect to varying inputs: molal gama water +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE CALCACT3 +C *** CALCULATES MULTI-COMPONENT ACTIVITY COEFFICIENTS FROM BROMLEYS +C METHOD FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +C KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL3). +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE CALCACT3_JB() + INCLUDE 'isrpia_adj.inc' +C + REAL*8 :: g0(6, 4), zpl, zmi, agama, sion, h, ch, f1(3), f2 + + (4) + REAL*8 :: g0jb(6, 4), sionjb, hjb, chjb, f1jb(3), f2jb(4) + REAL*8 :: mpl, xij, yji + REAL*8 :: mpljb, xijjb, yjijb, ionicjb + INTEGER :: i + REAL*8 :: g01 + REAL*8 :: g01jb + REAL*8 :: g02 + REAL*8 :: g02jb + REAL*8 :: g03 + REAL*8 :: g03jb + REAL*8 :: g04 + REAL*8 :: g04jb + REAL*8 :: g05 + REAL*8 :: g05jb + REAL*8 :: g06 + REAL*8 :: g06jb + REAL*8 :: g07 + REAL*8 :: g07jb + REAL*8 :: g08 + REAL*8 :: g08jb + REAL*8 :: g09 + REAL*8 :: g09jb + REAL*8 :: g10 + REAL*8 :: g10jb + REAL*8 :: g11 + REAL*8 :: g11jb + REAL*8 :: g12 + REAL*8 :: g12jb + INTEGER :: j + REAL*8 :: errou + REAL*8 :: errin +C + INTEGER :: branch + REAL*8 :: x1jb + INTRINSIC MAX + INTRINSIC ABS + REAL*8 :: x2 + REAL*8 :: x1 + REAL*8 :: temp0jb9 + REAL*8 :: temp0jb8 + REAL*8 :: temp0jb7 + REAL*8 :: temp0jb6 + REAL*8 :: x2jb + REAL*8 :: temp0jb5 + REAL*8 :: temp0jb4 + REAL*8 :: temp0jb3 + REAL*8 :: temp0jb2 + REAL*8 :: temp0jb1 + REAL*8 :: temp0jb0 + REAL*8 :: temp0jb + REAL*8 :: temp0jb13 + REAL*8 :: temp0jb12 + REAL*8 :: temp0jb11 + REAL*8 :: temp0jb10 + INTRINSIC MIN + INTEGER :: ii2 + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: y2 + REAL*8 :: y1 +C +C +C *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +C + ionic = 0.d0 + DO i=1,7 + ionic = ionic + molal(i)*z(i)*z(i) + ENDDO + IF (0.5d0*ionic/water > 200.d0) THEN + x1 = 200.d0 + CALL PUSHCONTROL1B(0) + ELSE + x1 = 0.5d0*ionic/water + CALL PUSHCONTROL1B(1) + END IF + IF (x1 < tiny) THEN + CALL PUSHREAL8(ionic) + ionic = tiny + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHREAL8(ionic) + ionic = x1 + CALL PUSHCONTROL1B(1) + END IF +C +C *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +C +C G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +C G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +C +C + CALL KMFUL3(ionic, temp, g01, g02, g03, g04, g05, g06, g07, g08, + + g09, g10, g11, g12) +C + g0(1, 1) = g11 + g0(1, 2) = g07 + g0(1, 3) = g08 + g0(1, 4) = g10 + g0(2, 1) = g01 + g0(2, 2) = g02 + g0(2, 3) = g12 + g0(2, 4) = g03 + g0(3, 1) = g06 + g0(3, 2) = g04 + g0(3, 3) = g09 + g0(3, 4) = g05 +C +C *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +C +C Debye Huckel const. at T + agama = 0.511d0*(298.d0/temp)**1.5d0 + sion = SQRT(ionic) + h = agama*sion/(1.d0+sion) +C + DO i=1,3 + f1(i) = 0.d0 + f2(i) = 0.d0 + ENDDO + f2(4) = 0.d0 +C + DO i=1,3 + CALL PUSHREAL8(zpl) + zpl = z(i) + CALL PUSHREAL8(mpl) + mpl = molal(i)/water + DO j=1,4 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + yji = ch*molal(j+3)/water + f1(i) = f1(i) + yji*(g0(i, j)+zpl*zmi*h) + f2(j) = f2(j) + xij*(g0(i, j)+zpl*zmi*h) + ENDDO + ENDDO + CALL PUSHREAL8(gama(1)) +C +C *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +C +C GAMA(01) = G(2,1)*ZZ(01) ! NACL +C NACL + gama(1) = ((f1(2)/z(2)+f2(1)/z(4))/(z(2)+z(4))-h)*zz(1) + CALL PUSHREAL8(gama(2)) +C GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 +C NA2SO4 + gama(2) = ((f1(2)/z(2)+f2(2)/z(5))/(z(2)+z(5))-h)*zz(2) + CALL PUSHREAL8(gama(3)) +C GAMA(03) = G(2,4)*ZZ(03) ! NANO3 +C NANO3 + gama(3) = ((f1(2)/z(2)+f2(4)/z(7))/(z(2)+z(7))-h)*zz(3) + CALL PUSHREAL8(gama(4)) +C GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 +C (NH4)2SO4 + gama(4) = ((f1(3)/z(3)+f2(2)/z(5))/(z(3)+z(5))-h)*zz(4) + CALL PUSHREAL8(gama(5)) +C GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 +C NH4NO3 + gama(5) = ((f1(3)/z(3)+f2(4)/z(7))/(z(3)+z(7))-h)*zz(5) + CALL PUSHREAL8(gama(6)) +C GAMA(06) = G(3,1)*ZZ(06) ! NH4CL +C NH4CL + gama(6) = ((f1(3)/z(3)+f2(1)/z(4))/(z(3)+z(4))-h)*zz(6) + CALL PUSHREAL8(gama(7)) +C GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 +C 2H-SO4 + gama(7) = ((f1(1)/z(1)+f2(2)/z(5))/(z(1)+z(5))-h)*zz(7) + CALL PUSHREAL8(gama(8)) +C GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 +C H-HSO4 + gama(8) = ((f1(1)/z(1)+f2(3)/z(6))/(z(1)+z(6))-h)*zz(8) + CALL PUSHREAL8(gama(9)) +C GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 +C NH4HSO4 + gama(9) = ((f1(3)/z(3)+f2(3)/z(6))/(z(3)+z(6))-h)*zz(9) + CALL PUSHREAL8(gama(10)) +C GAMA(10) = G(1,4)*ZZ(10) ! HNO3 +C HNO3 + gama(10) = ((f1(1)/z(1)+f2(4)/z(7))/(z(1)+z(7))-h)*zz(10) + CALL PUSHREAL8(gama(11)) +C GAMA(11) = G(1,1)*ZZ(11) ! HCL +C HCL + gama(11) = ((f1(1)/z(1)+f2(1)/z(4))/(z(1)+z(4))-h)*zz(11) + CALL PUSHREAL8(gama(12)) +C GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 +C NAHSO4 + gama(12) = ((f1(2)/z(2)+f2(3)/z(6))/(z(2)+z(6))-h)*zz(12) + CALL PUSHREAL8(gama(13)) +C LC ; SCAPE + gama(13) = 0.2d0*(3.d0*gama(4)+2.d0*gama(9)) +C +C *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +C + DO i=1,13 + IF (gama(i) > 5.0d0) THEN + CALL PUSHCONTROL1B(0) + x2 = 5.0d0 + ELSE + x2 = gama(i) + CALL PUSHCONTROL1B(1) + END IF + IF (x2 < -5.0d0) THEN + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + ENDDO + DO i=13,1,-1 + gamajb(i) = 10.d0**gama(i)*LOG(10.d0)*gamajb(i) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + gamajb(i) = 0.D0 + x2jb = 0.D0 + ELSE + x2jb = gamajb(i) + gamajb(i) = 0.D0 + END IF + CALL POPCONTROL1B(branch) + IF (branch /= 0) gamajb(i) = gamajb(i) + x2jb + ENDDO + CALL POPREAL8(gama(13)) + gamajb(4) = gamajb(4) + 0.2d0*3.d0*gamajb(13) + gamajb(9) = gamajb(9) + 0.2d0*2.d0*gamajb(13) + gamajb(13) = 0.D0 + DO ii1=1,3 + f1jb(ii1) = 0.D0 + ENDDO + DO ii1=1,4 + f2jb(ii1) = 0.D0 + ENDDO + CALL POPREAL8(gama(12)) + temp0jb2 = zz(12)*gamajb(12)/(z(2)+z(6)) + f1jb(2) = f1jb(2) + temp0jb2/z(2) + f2jb(3) = f2jb(3) + temp0jb2/z(6) + hjb = -(zz(12)*gamajb(12)) + gamajb(12) = 0.D0 + CALL POPREAL8(gama(11)) + temp0jb3 = zz(11)*gamajb(11)/(z(1)+z(4)) + f2jb(1) = f2jb(1) + temp0jb3/z(4) + hjb = hjb - zz(11)*gamajb(11) + gamajb(11) = 0.D0 + CALL POPREAL8(gama(10)) + temp0jb4 = zz(10)*gamajb(10)/(z(1)+z(7)) + f1jb(1) = f1jb(1) + temp0jb4/z(1) + temp0jb3/z(1) + f2jb(4) = f2jb(4) + temp0jb4/z(7) + hjb = hjb - zz(10)*gamajb(10) + gamajb(10) = 0.D0 + CALL POPREAL8(gama(9)) + temp0jb5 = zz(9)*gamajb(9)/(z(3)+z(6)) + f1jb(3) = f1jb(3) + temp0jb5/z(3) + hjb = hjb - zz(9)*gamajb(9) + gamajb(9) = 0.D0 + CALL POPREAL8(gama(8)) + temp0jb6 = zz(8)*gamajb(8)/(z(1)+z(6)) + f2jb(3) = f2jb(3) + temp0jb6/z(6) + temp0jb5/z(6) + hjb = hjb - zz(8)*gamajb(8) + gamajb(8) = 0.D0 + CALL POPREAL8(gama(7)) + temp0jb7 = zz(7)*gamajb(7)/(z(1)+z(5)) + f1jb(1) = f1jb(1) + temp0jb7/z(1) + temp0jb6/z(1) + f2jb(2) = f2jb(2) + temp0jb7/z(5) + hjb = hjb - zz(7)*gamajb(7) + gamajb(7) = 0.D0 + CALL POPREAL8(gama(6)) + temp0jb8 = zz(6)*gamajb(6)/(z(3)+z(4)) + f2jb(1) = f2jb(1) + temp0jb8/z(4) + hjb = hjb - zz(6)*gamajb(6) + gamajb(6) = 0.D0 + CALL POPREAL8(gama(5)) + temp0jb9 = zz(5)*gamajb(5)/(z(3)+z(7)) + f2jb(4) = f2jb(4) + temp0jb9/z(7) + hjb = hjb - zz(5)*gamajb(5) + gamajb(5) = 0.D0 + CALL POPREAL8(gama(4)) + temp0jb10 = zz(4)*gamajb(4)/(z(3)+z(5)) + f1jb(3) = f1jb(3) + temp0jb9/z(3) + temp0jb10/z(3) + temp0jb8/z(3) + f2jb(2) = f2jb(2) + temp0jb10/z(5) + hjb = hjb - zz(4)*gamajb(4) + gamajb(4) = 0.D0 + CALL POPREAL8(gama(3)) + temp0jb11 = zz(3)*gamajb(3)/(z(2)+z(7)) + f2jb(4) = f2jb(4) + temp0jb11/z(7) + hjb = hjb - zz(3)*gamajb(3) + gamajb(3) = 0.D0 + CALL POPREAL8(gama(2)) + temp0jb12 = zz(2)*gamajb(2)/(z(2)+z(5)) + f2jb(2) = f2jb(2) + temp0jb12/z(5) + hjb = hjb - zz(2)*gamajb(2) + gamajb(2) = 0.D0 + CALL POPREAL8(gama(1)) + temp0jb13 = zz(1)*gamajb(1)/(z(2)+z(4)) + f1jb(2) = f1jb(2) + temp0jb12/z(2) + temp0jb13/z(2) + temp0jb11/z( + + 2) + f2jb(1) = f2jb(1) + temp0jb13/z(4) + hjb = hjb - zz(1)*gamajb(1) + gamajb(1) = 0.D0 + ionicjb = 0.D0 + DO ii1=1,4 + DO ii2=1,6 + g0jb(ii2, ii1) = 0.D0 + ENDDO + ENDDO + DO i=3,1,-1 + mpljb = 0.D0 + DO j=4,1,-1 + zmi = z(j+3) + ch = 0.25d0*(zpl+zmi)*(zpl+zmi)/ionic + xij = ch*mpl + xijjb = (g0(i, j)+zpl*zmi*h)*f2jb(j) + yji = ch*molal(j+3)/water + g0jb(i, j) = g0jb(i, j) + yji*f1jb(i) + xij*f2jb(j) + hjb = hjb + yji*zpl*zmi*f1jb(i) + xij*zpl*zmi*f2jb(j) + yjijb = (g0(i, j)+zpl*zmi*h)*f1jb(i) + temp0jb1 = molal(j+3)*yjijb/water + molaljb(j+3) = molaljb(j+3) + ch*yjijb/water + chjb = mpl*xijjb + temp0jb1 + waterjb = waterjb - ch*temp0jb1/water + mpljb = mpljb + ch*xijjb + ionicjb = ionicjb - (zpl+zmi)**2*0.25d0*chjb/ionic**2 + ENDDO + CALL POPREAL8(mpl) + molaljb(i) = molaljb(i) + mpljb/water + waterjb = waterjb - molal(i)*mpljb/water**2 + CALL POPREAL8(zpl) + ENDDO + temp0jb0 = agama*hjb/(sion+1.d0) + sionjb = (1.D0-sion/(sion+1.d0))*temp0jb0 + IF (.NOT.ionic == 0.0) ionicjb = ionicjb + sionjb/(2.0*SQRT( + + ionic)) + g05jb = g0jb(3, 4) + g0jb(3, 4) = 0.D0 + g09jb = g0jb(3, 3) + g0jb(3, 3) = 0.D0 + g04jb = g0jb(3, 2) + g0jb(3, 2) = 0.D0 + g06jb = g0jb(3, 1) + g0jb(3, 1) = 0.D0 + g03jb = g0jb(2, 4) + g0jb(2, 4) = 0.D0 + g12jb = g0jb(2, 3) + g0jb(2, 3) = 0.D0 + g02jb = g0jb(2, 2) + g0jb(2, 2) = 0.D0 + g01jb = g0jb(2, 1) + g0jb(2, 1) = 0.D0 + g10jb = g0jb(1, 4) + g0jb(1, 4) = 0.D0 + g08jb = g0jb(1, 3) + g0jb(1, 3) = 0.D0 + g07jb = g0jb(1, 2) + g0jb(1, 2) = 0.D0 + g11jb = g0jb(1, 1) + CALL KMFUL3_JB(ionic, ionicjb, temp, g01, g01jb, g02, g02jb, g03, + + g03jb, g04, g04jb, g05, g05jb, g06, g06jb, g07, + + g07jb, g08, g08jb, g09, g09jb, g10, g10jb, g11, + + g11jb, g12, g12jb) + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + CALL POPREAL8(ionic) + x1jb = 0.D0 + ELSE + CALL POPREAL8(ionic) + x1jb = ionicjb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ionicjb = 0.D0 + ELSE + temp0jb = 0.5d0*x1jb/water + ionicjb = temp0jb + waterjb = waterjb - ionic*temp0jb/water + END IF + DO i=7,1,-1 + molaljb(i) = molaljb(i) + z(i)**2*ionicjb + ENDDO + END + +C Differentiation of kmful3 in reverse (adjoint) mode: +C gradient of useful results: g01 g02 g03 g04 g05 g06 g07 +C g08 g09 g10 g11 g12 ionic +C with respect to varying inputs: ionic +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE KMFUL3 +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD +C FOR AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C +C *** WRITTEN BY CHRISTOS FOUNTOUKIS & ATHANASIOS NENES +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE KMFUL3_JB(ionic, ionicjb, temp, g01, g01jb, g02, g02jb + + , g03, g03jb, g04, g04jb, g05, g05jb, g06, + + g06jb, g07, g07jb, g08, g08jb, g09, g09jb, + + g10, g10jb, g11, g11jb, g12, g12jb) + IMPLICIT NONE + REAL*8 :: ionic, temp, sion, ti, tc, cf1, cf2 + REAL*8 :: ionicjb, sionjb, cf2jb + REAL*8 :: g01, g02, g03, g04, g05, g06, g07, g08, g09, g10 + + , g11, g12 + REAL*8 :: g01jb, g02jb, g03jb, g04jb, g05jb, g06jb, g07jb, + + g08jb, g09jb, g10jb, g11jb, g12jb + REAL*8 :: q1, q2, q3, q4, q5, q6, q7, q8, q10, q11 + REAL*8 :: z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 + INTEGER :: branch + INTRINSIC ABS + REAL*8 :: temp0jb0 + REAL*8 :: temp0jb + REAL*8 :: abs1 + INTRINSIC SQRT + DATA z01, z02, z03, z04, z05, z06, z07, z08, z10, z11 /1.d0, 2.d0 + + , 1.d0, 2.d0, 1.d0, 1.d0, 2.d0, 1.d0, 1.d0, 1.d0/ +C + sion = SQRT(ionic) +C +C *** Coefficients at 25 oC +C + q1 = 2.230d0 + q2 = -0.19d0 + q3 = -0.39d0 + q4 = -0.25d0 + q5 = -1.15d0 + q6 = 0.820d0 + q7 = -.100d0 + q8 = 8.000d0 + q10 = 2.600d0 + q11 = 6.000d0 +C +C +C *** Correct for T other than 298 K +C + ti = temp - 273.d0 + tc = ti - 25.d0 + IF (tc >= 0.) THEN + abs1 = tc + ELSE + abs1 = -tc + END IF + IF (abs1 > 1.d0) THEN + cf1 = 1.125d0 - 0.005d0*ti + CALL PUSHCONTROL1B(0) + ELSE + CALL PUSHCONTROL1B(1) + END IF + g01jb = g01jb + g12jb + g08jb = g08jb + g09jb + g12jb + g11jb = g11jb - g09jb - g12jb + g06jb = g06jb + g09jb + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + cf2jb = -(z10*g10jb) - z07*g07jb - z05*g05jb - z03*g03jb - z01* + + g01jb - z02*g02jb - z04*g04jb - z06*g06jb - z08*g08jb - z11* + + g11jb + g11jb = cf1*g11jb + g10jb = cf1*g10jb + g08jb = cf1*g08jb + g07jb = cf1*g07jb + g06jb = cf1*g06jb + g05jb = cf1*g05jb + g04jb = cf1*g04jb + g03jb = cf1*g03jb + g02jb = cf1*g02jb + g01jb = cf1*g01jb + temp0jb = (0.125d0-ti*0.005d0)*cf2jb + temp0jb0 = -(0.41d0*temp0jb/(sion+1.d0)) + ionicjb = ionicjb + 0.039d0*0.92d0*ionic**(-0.8D0)*temp0jb + sionjb = (1.D0-sion/(sion+1.d0))*temp0jb0 + ELSE + sionjb = 0.D0 + END IF + CALL MKBI_JB(q11, ionic, ionicjb, sion, sionjb, z11, g11, g11jb) + CALL MKBI_JB(q10, ionic, ionicjb, sion, sionjb, z10, g10, g10jb) + CALL MKBI_JB(q8, ionic, ionicjb, sion, sionjb, z08, g08, g08jb) + CALL MKBI_JB(q7, ionic, ionicjb, sion, sionjb, z07, g07, g07jb) + CALL MKBI_JB(q6, ionic, ionicjb, sion, sionjb, z06, g06, g06jb) + CALL MKBI_JB(q5, ionic, ionicjb, sion, sionjb, z05, g05, g05jb) + CALL MKBI_JB(q4, ionic, ionicjb, sion, sionjb, z04, g04, g04jb) + CALL MKBI_JB(q3, ionic, ionicjb, sion, sionjb, z03, g03, g03jb) + CALL MKBI_JB(q2, ionic, ionicjb, sion, sionjb, z02, g02, g02jb) + CALL MKBI_JB(q1, ionic, ionicjb, sion, sionjb, z01, g01, g01jb) + IF (.NOT.ionic == 0.0) ionicjb = ionicjb + sionjb/(2.0*SQRT( + + ionic)) + END + +C Differentiation of mkbi in reverse (adjoint) mode: +C gradient of useful results: sion bi ionic +C with respect to varying inputs: sion ionic +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE MKBI +C *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE MKBI_JB(q, ionic, ionicjb, sion, sionjb, zip, bi, bijb) + IMPLICIT NONE + REAL*8 :: q, ionic, sion, zip, bi + REAL*8 :: ionicjb, sionjb, bijb + REAL*8 :: b, c, xx + REAL*8 :: cjb, xxjb + INTRINSIC EXP + REAL*8 :: tempjb0 + REAL*8 :: tempjb + INTRINSIC LOG10 +C + b = .75d0 - .065d0*q +C C= 1.0 +C IF (IONIC < 6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + c = 1. + .055d0*q*EXP(-(.023d0*ionic*ionic*ionic)) + bi = 1.d0 + b*(1.d0+.1d0*ionic)**q - b +C + xxjb = zip*bijb + bijb = zip*bijb/(bi*LOG(10.0)) + tempjb = -(0.5107d0*xxjb/(c*sion+1.d0)) + tempjb0 = -(sion*tempjb/(c*sion+1.d0)) + sionjb = sionjb + c*tempjb0 + tempjb + cjb = sion*tempjb0 + IF (.1d0*ionic + 1.d0 <= 0.0 .AND. (q == 0.0 .OR. q /= INT(q + + ))) THEN + ionicjb = ionicjb - .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3* + + ionic**2*cjb + ELSE + ionicjb = ionicjb + q*(.1d0*ionic+1.d0)**(q-1)*b*.1d0*bijb - + + .023d0*EXP(-(.023d0*ionic**3))*q*.055d0*3*ionic**2*cjb + END IF + END + +C Differentiation of poly3 in reverse (adjoint) mode: +C gradient of useful results: root +C with respect to varying inputs: a1 a2 a3 +C +C +C======================================================================= +C +C *** ISORROPIA CODE +C *** SUBROUTINE POLY3 +C *** FINDS THE REAL ROOTS OF THE THIRD ORDER ALGEBRAIC EQUATION: +C X**3 + A1*X**2 + A2*X + A3 = 0.0 +C THE EQUATION IS SOLVED ANALYTICALLY. +C +C PARAMETERS A1, A2, A3 ARE SPECIFIED BY THE USER. THE MINIMUM +C NONEGATIVE ROOT IS RETURNED IN VARIABLE 'ROOT'. IF NO ROOT IS +C FOUND (WHICH IS GREATER THAN ZERO), ROOT HAS THE VALUE 1D30. +C AND THE FLAG ISLV HAS A VALUE GREATER THAN ZERO. +C +C SOLUTION FORMULA IS FOUND IN PAGE 32 OF: +C MATHEMATICAL HANDBOOK OF FORMULAS AND TABLES +C SCHAUM'S OUTLINE SERIES +C MURRAY SPIEGER, McGRAW-HILL, NEW YORK, 1968 +C (GREEK TRANSLATION: BY SOTIRIOS PERSIDES, ESPI, ATHENS, 1976) +C +C A SPECIAL CASE IS CONSIDERED SEPERATELY ; WHEN A3 = 0, THEN +C ONE ROOT IS X=0.0, AND THE OTHER TWO FROM THE SOLUTION OF THE +C QUADRATIC EQUATION X**2 + A1*X + A2 = 0.0 +C THIS SPECIAL CASE IS CONSIDERED BECAUSE THE ANALYTICAL FORMULA +C DOES NOT YIELD ACCURATE RESULTS (DUE TO NUMERICAL ROUNDOFF ERRORS) +C +C *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +C *** GEORGIA INSTITUTE OF TECHNOLOGY +C *** WRITTEN BY ATHANASIOS NENES +C *** UPDATED BY CHRISTOS FOUNTOUKIS +C *** ADJOINT & UPDATE BY SHANNON CAPPS +C +C======================================================================= +C + SUBROUTINE POLY3_JB(a1, a1jb, a2, a2jb, a3, a3jb, root, rootjb, + + islv) + IMPLICIT NONE + REAL*8 :: thet1 + REAL*8 :: thet2 + REAL*8 :: zero + REAL*8 :: expon + REAL*8 :: eps + REAL*8 :: pi +C + PARAMETER (expon=1.d0/3.d0, zero=0.d0, thet1=120.d0/180.d0, thet2= + + 240.d0/180.d0, pi=3.1415926535897932D0, eps=1.d-50) +C REAL*8 :: X(3) + REAL*8 :: x(3), a1, a2, a3, root + REAL*8 :: xjb(3), a1jb, a2jb, a3jb, rootjb + INTEGER :: ix + REAL*8 :: d + REAL*8 :: djb + REAL*8 :: sqd + REAL*8 :: sqdjb + REAL*8 :: q + REAL*8 :: qjb + REAL*8 :: u + REAL*8 :: ujb + REAL*8 :: thet + REAL*8 :: thetjb + REAL*8 :: coef + REAL*8 :: coefjb + REAL*8 :: ssig + REAL*8 :: s + REAL*8 :: sjb + REAL*8 :: tsig + REAL*8 :: t + REAL*8 :: tjb + INTEGER :: i + INTEGER :: branch + INTEGER :: islv + REAL*8 :: temp0 + INTRINSIC COS + REAL*8 :: tempjb0 + REAL*8 :: tempjb + INTRINSIC SIGN + INTRINSIC ABS + REAL*8 :: abs3jb + REAL*8 :: abs4jb + INTRINSIC ACOS + REAL*8 :: abs4 + REAL*8 :: abs3 + REAL*8 :: abs2 + REAL*8 :: abs1 + INTRINSIC MIN + INTEGER :: ii1 + INTRINSIC SQRT + REAL*8 :: temp + REAL*8 :: abs2jb + IF (a3 >= 0.) THEN + abs1 = a3 + ELSE + abs1 = -a3 + END IF +C +C *** SPECIAL CASE : QUADRATIC*X EQUATION ***************************** +C + IF (abs1 <= eps) THEN + ix = 1 + x(1) = zero + d = a1*a1 - 4.d0*a2 + IF (d >= zero) THEN + ix = 3 + sqd = SQRT(d) + x(2) = 0.5*(-a1+sqd) + x(3) = 0.5*(-a1-sqd) + CALL PUSHCONTROL3B(0) + ELSE + CALL PUSHCONTROL3B(1) + END IF + ELSE +C +C *** NORMAL CASE : CUBIC EQUATION ************************************ +C +C DEFINE PARAMETERS Q, U, S, T, D +C + q = (3.d0*a2-a1*a1)/9.d0 + u = (9.d0*a1*a2-27.d0*a3-2.d0*a1*a1*a1)/54.d0 + d = q*q*q + u*u +C +C *** CALCULATE ROOTS ************************************************* +C +C D < 0, THREE REAL ROOTS +C + IF (d < -eps) THEN +C D < -EPS : D < ZERO + ix = 3 + thet = expon*ACOS(u/SQRT(-(q*q*q))) + coef = 2.d0*SQRT(-q) + x(1) = coef*COS(thet) - expon*a1 + x(2) = coef*COS(thet+thet1*pi) - expon*a1 + x(3) = coef*COS(thet+thet2*pi) - expon*a1 +C +C D = 0, THREE REAL (ONE DOUBLE) ROOTS +C + CALL PUSHCONTROL3B(2) + ELSE IF (d <= eps) THEN +C -EPS <= D <= EPS : D = ZERO + ix = 2 + ssig = SIGN(1.d0, u) + IF (u >= 0.) THEN + abs2 = u + CALL PUSHCONTROL1B(0) + ELSE + abs2 = -u + CALL PUSHCONTROL1B(1) + END IF + s = ssig*abs2**expon + x(1) = 2.d0*s - expon*a1 + x(2) = -s - expon*a1 +C +C D > 0, ONE REAL ROOT +C + CALL PUSHCONTROL3B(3) + ELSE +C D > EPS : D > ZERO + ix = 1 + sqd = SQRT(d) +C TRANSFER SIGN TO SSIG + ssig = SIGN(1.d0, u + sqd) + tsig = SIGN(1.d0, u - sqd) + IF (u + sqd >= 0.) THEN + abs3 = u + sqd + CALL PUSHCONTROL1B(0) + ELSE + abs3 = -(u+sqd) + CALL PUSHCONTROL1B(1) + END IF +C EXPONENTIATE ABS() + s = ssig*abs3**expon + IF (u - sqd >= 0.) THEN + abs4 = u - sqd + CALL PUSHCONTROL1B(0) + ELSE + abs4 = -(u-sqd) + CALL PUSHCONTROL1B(1) + END IF + t = tsig*abs4**expon + x(1) = s + t - expon*a1 + CALL PUSHCONTROL3B(4) + END IF + END IF +C +C *** SELECT APPROPRIATE ROOT ***************************************** +C + root = 1.d30 + DO i=1,ix + IF (x(i) > zero) THEN + IF (root > x(i)) THEN + root = x(i) + CALL PUSHCONTROL2B(1) + ELSE + CALL PUSHCONTROL2B(2) + root = root + END IF + ELSE + CALL PUSHCONTROL2B(0) + END IF + ENDDO + DO ii1=1,3 + xjb(ii1) = 0.D0 + ENDDO + DO i=ix,1,-1 + CALL POPCONTROL2B(branch) + IF (branch /= 0) THEN + IF (branch == 1) THEN + xjb(i) = xjb(i) + rootjb + rootjb = 0.D0 + END IF + END IF + ENDDO + CALL POPCONTROL3B(branch) + IF (branch < 2) THEN + IF (branch == 0) THEN + a1jb = -(0.5*xjb(3)) + sqdjb = -(0.5*xjb(3)) + xjb(3) = 0.D0 + sqdjb = sqdjb + 0.5*xjb(2) + a1jb = a1jb - 0.5*xjb(2) + IF (d == 0.0) THEN + djb = 0.0 + ELSE + djb = sqdjb/(2.0*SQRT(d)) + END IF + ELSE + a1jb = 0.D0 + djb = 0.D0 + END IF + a1jb = a1jb + 2*a1*djb + a2jb = -(4.d0*djb) + a3jb = 0.D0 + ELSE + IF (branch == 2) THEN + coefjb = COS(thet2*pi+thet)*xjb(3) + thetjb = -(coef*SIN(thet2*pi+thet)*xjb(3)) + a1jb = -(expon*xjb(3)) + xjb(3) = 0.D0 + coefjb = coefjb + COS(thet1*pi+thet)*xjb(2) + thetjb = thetjb - coef*SIN(thet1*pi+thet)*xjb(2) + a1jb = a1jb - expon*xjb(2) + xjb(2) = 0.D0 + coefjb = coefjb + COS(thet)*xjb(1) + thetjb = thetjb - coef*SIN(thet)*xjb(1) + a1jb = a1jb - expon*xjb(1) + IF (-q == 0.0) THEN + qjb = 0.0 + ELSE + qjb = -(2.d0*coefjb/(2.0*SQRT(-q))) + END IF + temp0 = -(q**3) + temp = SQRT(temp0) + tempjb0 = -(expon*thetjb/(SQRT(1.0-(u/temp)**2)*temp)) + ujb = tempjb0 + IF (.NOT.temp0 == 0.0) qjb = qjb + u*3*q**2*tempjb0/(2.0* + + temp**2) + djb = 0.D0 + ELSE + IF (branch == 3) THEN + sjb = -xjb(2) + a1jb = -(expon*xjb(2)) + xjb(2) = 0.D0 + sjb = sjb + 2.d0*xjb(1) + a1jb = a1jb - expon*xjb(1) + IF (abs2 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT( + + expon))) THEN + abs2jb = 0.0 + ELSE + abs2jb = ssig*expon*abs2**(expon-1)*sjb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ujb = abs2jb + ELSE + ujb = -abs2jb + END IF + djb = 0.D0 + ELSE + sjb = xjb(1) + tjb = xjb(1) + a1jb = -(expon*xjb(1)) + IF (abs4 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT( + + expon))) THEN + abs4jb = 0.0 + ELSE + abs4jb = tsig*expon*abs4**(expon-1)*tjb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ujb = abs4jb + sqdjb = -abs4jb + ELSE + sqdjb = abs4jb + ujb = -abs4jb + END IF + IF (abs3 <= 0.0 .AND. (expon == 0.0 .OR. expon /= INT( + + expon))) THEN + abs3jb = 0.0 + ELSE + abs3jb = ssig*expon*abs3**(expon-1)*sjb + END IF + CALL POPCONTROL1B(branch) + IF (branch == 0) THEN + ujb = ujb + abs3jb + sqdjb = sqdjb + abs3jb + ELSE + ujb = ujb - abs3jb + sqdjb = sqdjb - abs3jb + END IF + IF (d == 0.0) THEN + djb = 0.0 + ELSE + djb = sqdjb/(2.0*SQRT(d)) + END IF + END IF + qjb = 0.D0 + END IF + qjb = qjb + 3*q**2*djb + ujb = ujb + 2*u*djb + tempjb = ujb/54.d0 + a1jb = a1jb + (9.d0*a2-2.d0*3*a1**2)*tempjb - 2*a1*qjb/9.d0 + a2jb = 3.d0*qjb/9.d0 + 9.d0*a1*tempjb + a3jb = -(27.d0*tempjb) + END IF + END diff --git a/code/new/isrpia_adj.inc b/code/new/isrpia_adj.inc new file mode 100644 index 0000000..6fba568 --- /dev/null +++ b/code/new/isrpia_adj.inc @@ -0,0 +1,551 @@ +!======================================================================= +! File "isrpia_adj.inc" contains the common block declarations and some +! parameters for the ISORROPIAII code. This file replaces "isoropia.h" from +! previous ISORROPIA implementations. +! ( hotp 8/1/07 ) +! ( previous implementation: bec, bmy, 3/7/05, 6/28/06 ) +! +! Please contact the original authors before making modifications to +! ISOROPIAII. +! +! *** VERY IMPORTANT PORTING WARNING (slc.1.2012) *** +! ANISORROPIA code is optimized for adjoint frameworks and will not +! perform commensurately with publicly released ISORROPIAII code. +! +! Please visit http://nenes.eas.gatech.edu/ISORROPIA for current +! releases of ISORROPIAII for forward modeling. +! +! Original Documentation: +! *** ISORROPIA CODE II +! *** INCLUDE FILE 'ISRPIA.INC' +! *** THIS FILE CONTAINS THE DECLARATIONS OF THE GLOBAL CONSTANTS +! AND VARIABLES. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! *** ADJOINT & UPDATE BY SHANNON CAPPS +! +! NOTES: +! (1 ) Renamed common block GAS to GASCB to avoid confusion with array +! GAS in isoropiaIIcode.f (hotp) +! (2 ) Explicity declared all variables in this file (hotp) +! (3 ) Separated common blocks so that each block has only one type of data (hotp) +! (4 ) Declared all common blocks (except READ-ONLY blocks) as +! THREADPRIVATE (hotp) +! (5 ) Divided common blocks so that each has no more than 8 variables +! (this is to speed compilation) (hotp) +! (6 ) Divided common blocks so that READ-ONLY variables are not mixed with +! variables that are modified (hotp) +! (7 ) Removed DRYF since it is not used (hotp) +! (8 ) Bug fix: CRRAT was being truncated at column 72 (hotp, bmy, 6/1/10) +! (9 ) IONIC should be REAL*8 for consistency with -r8 flag during +! compiling of isoropiaIIcode routines (hotp, bmy, 6/28/10) +! 22 Aug 2011 - S. Capps - ANISORROPIA implementation +!======================================================================= +! +!======================================================================= +! +! *** ISORROPIA CODE +! *** INCLUDE FILE 'ISRPIA_ADJ.INC' +! *** THIS FILE CONTAINS THE DECLARATIONS OF THE GLOBAL CONSTANTS +! AND VARIABLES. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + ! leave this implicit statement for isoropiaIIcode.f variables + ! ideally all variables would be declared + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + + ! INTEGER parameters + INTEGER, PARAMETER :: NCOMP = 8 + INTEGER, PARAMETER :: NERRMX = 25 + INTEGER, PARAMETER :: NGASAQ = 3 + INTEGER, PARAMETER :: NIONS = 10 + INTEGER, PARAMETER :: NPAIR = 23 + INTEGER, PARAMETER :: NSLDS = 19 + INTEGER, PARAMETER :: NZSR = 100 + + !================================================================= + ! Input variables + !================================================================= + + INTEGER :: METSTBL = 0 + INTEGER :: IPROB = 0 + COMMON /INPT/ IPROB, METSTBL +!$OMP THREADPRIVATE( /INPT/ ) + + INTEGER :: NADJ = 0 + COMMON /INPT2/ NADJ + ! INPT2 is read-only + + REAL*8 :: W(NCOMP), WAER(NCOMP) + REAL*8 :: TEMP = 298.d0 + REAL*8 :: RH = 0.9D0 + COMMON /INPT3/ W, WAER, TEMP, RH +!$OMP THREADPRIVATE( /INPT3/ ) + + !================================================================= + ! Water activities of pure salt solutions + !================================================================= + + ! /ZSR/ is read-only and doesn't have to be declared THREADPRIVATE + ! block does not need to be split up to speed compilation + REAL*8 :: AWAS(NZSR), AWSS(NZSR), AWAC(NZSR), AWSC(NZSR) + REAL*8 :: AWAN(NZSR), AWSN(NZSR), AWSB(NZSR), AWAB(NZSR) + REAL*8 :: AWSA(NZSR), AWLC(NZSR), AWCS(NZSR), AWCN(NZSR) + REAL*8 :: AWCC(NZSR), AWPS(NZSR), AWPB(NZSR), AWPN(NZSR) + REAL*8 :: AWPC(NZSR), AWMS(NZSR), AWMN(NZSR), AWMC(NZSR) + COMMON /ZSR / AWAS, AWSS, AWAC, AWSC, + & AWAN, AWSN, AWSB, AWAB, + & AWSA, AWLC, AWCS, AWCN, + & AWCC, AWPS, AWPB, AWPN, + & AWPC, AWMS, AWMN, AWMC + ! ZSR is read-only + + !================================================================= + ! Deliquescence relative humidities + !================================================================= + + INTEGER :: WFTYP + COMMON /WFT/ WFTYP + ! WFTYP is read-only + + REAL*8 :: DRH2SO4, DRNH42S4, DRNAHSO4, DRNACL, DRNANO3 + REAL*8 :: DRNA2SO4, DRNH4HS4, DRLC, DRNH4NO3, DRNH4CL + REAL*8 :: DRCASO4, DRCANO32, DRCACL2, DRK2SO4, DRKHSO4 + REAL*8 :: DRKNO3, DRKCL, DRMGSO4, DRMGNO32, DRMGCL2 + COMMON /DRH / DRH2SO4, DRNH42S4, DRNAHSO4, DRNACL, DRNANO3 + COMMON /DRH2/ DRNA2SO4, DRNH4HS4, DRLC, DRNH4NO3, DRNH4CL + COMMON /DRH3/ DRCASO4, DRCANO32, DRCACL2, DRK2SO4, DRKHSO4 + COMMON /DRH4/ DRKNO3, DRKCL, DRMGSO4, DRMGNO32, DRMGCL2 +!$OMP THREADPRIVATE( /DRH/ ) +!$OMP THREADPRIVATE( /DRH2/ ) +!$OMP THREADPRIVATE( /DRH3/ ) +!$OMP THREADPRIVATE( /DRH4/ ) + + REAL*8 :: DRMLCAB, DRMLCAS, DRMASAN, DRMG1, DRMG2 + REAL*8 :: DRMG3, DRMH1, DRMH2, DRMI1, DRMI2 + REAL*8 :: DRMI3, DRMQ1, DRMR1, DRMR2, DRMR3 + REAL*8 :: DRMR4, DRMR5, DRMR6, DRMR7, DRMR8 + REAL*8 :: DRMR9, DRMR10, DRMR11, DRMR12, DRMR13 + COMMON /MDRH/ DRMLCAB, DRMLCAS, DRMASAN, DRMG1, DRMG2 + COMMON /MDRH2/ DRMG3, DRMH1, DRMH2, DRMI1, DRMI2 + COMMON /MDRH3/ DRMI3, DRMQ1, DRMR1, DRMR2, DRMR3 + COMMON /MDRH4/ DRMR4, DRMR5, DRMR6, DRMR7, DRMR8 + COMMON /MDRH5/ DRMR9, DRMR10, DRMR11, DRMR12, DRMR13 +!$OMP THREADPRIVATE( /MDRH/ ) +!$OMP THREADPRIVATE( /MDRH2/ ) +!$OMP THREADPRIVATE( /MDRH3/ ) +!$OMP THREADPRIVATE( /MDRH4/ ) +!$OMP THREADPRIVATE( /MDRH5/ ) + + REAL*8 :: DRMO1, DRMO2, DRMO3, DRML1, DRML2 + REAL*8 :: DRML3, DRMM1, DRMM2, DRMP1, DRMP2 + REAL*8 :: DRMP3, DRMP4, DRMP5, DRMV1 + COMMON /MDRH6/ DRMO1, DRMO2, DRMO3, DRML1, DRML2 + COMMON /MDRH7/ DRML3, DRMM1, DRMM2, DRMP1, DRMP2 + COMMON /MDRH8/ DRMP3, DRMP4, DRMP5, DRMV1 +!$OMP THREADPRIVATE( /MDRH6/ ) +!$OMP THREADPRIVATE( /MDRH7/ ) +!$OMP THREADPRIVATE( /MDRH8/ ) + + !================================================================= + ! Variables for liquid aerosol phase + !================================================================= + + ! /IONS/ size does not seem to slow compilation + REAL*8 :: MOLAL(NIONS) = 0.0D0 + REAL*8 :: MOLALR(NPAIR) = 0.0D0 + REAL*8 :: M0(NPAIR) = 1.0d5 + REAL*8 :: GAMA(NPAIR) = NPAIR*0.1D0 + REAL*8 :: GAMOU(NPAIR) = NPAIR*1.D10 + REAL*8 :: GAMIN(NPAIR) = NPAIR*1.D10 + REAL*8 :: GASAQ(NGASAQ) = 0.0D0 + REAL*8 :: COH = 0.d0 + REAL*8 :: CHNO3 = 0.d0 + REAL*8 :: CHCL = 0.d0 + REAL*8 :: WATER = 1.d-20 + COMMON /IONS/ MOLAL, MOLALR, M0, + & GAMA, + & GAMOU, GAMIN, GASAQ, + & COH, CHNO3, CHCL, + & WATER +!$OMP THREADPRIVATE( /IONS/ ) + + REAL*8 :: ZZ(NPAIR) = (/ 1,2,1,2,1,1,2,1,1,1,1,1,2,4,2,2,2, + & 1,1,1,4,2,2 /) + REAL*8 :: Z(NIONS) = (/ 1.0D0, 1.0D0, 1.0D0, 1.0D0, 2.0D0, + & 1.0D0, 1.0D0, 2.0D0, 1.0D0, 2.0D0 /) + REAL*8 :: EPSACT = 5D-2 + COMMON /IONS2/ ZZ, Z, EPSACT + ! IONS2 is read-only + + !---------------------------------------------------------------------- + ! Prior to 6/28/10: + ! IONIC should be REAL*8 for consistency with -r8 flag during + ! compiling of isoropiaIIcode routines (hotp 6/23/10) + !REAL*4 :: IONIC + !---------------------------------------------------------------------- + REAL*8 :: IONIC = 0.d0 + COMMON /IONS3/ IONIC +!$OMP THREADPRIVATE( /IONS3/ ) + + ! DRYF removed since it is not used (hotp) + LOGICAL :: CALAOU = .TRUE. + LOGICAL :: CALAIN = .TRUE. + LOGICAL :: FRST = .TRUE. + COMMON /IONS4/ CALAOU, CALAIN, FRST +!$OMP THREADPRIVATE( /IONS4/ ) + + INTEGER :: IACALC = 0 + COMMON /IONS5/ IACALC + ! IONS5 is read-only + !================================================================= + ! Variables for solid aerosol phase + !================================================================= + + REAL*8 :: CH2SO4, CNH42S4, CNH4HS4, CNACL, CNA2SO4 + REAL*8 :: CNANO3, CNH4NO3, CNH4CL, CNAHSO4, CLC, CCASO4 + REAL*8 :: CCANO32, CCACL2, CK2SO4, CKHSO4, CKNO3, CKCL + REAL*8 :: CMGSO4, CMGNO32, CMGCL2 + COMMON /SALT/ CH2SO4, CNH42S4, CNH4HS4, CNACL, CNA2SO4 + COMMON /SALT2/ CNANO3, CNH4NO3, CNH4CL, CNAHSO4, CLC, CCASO4 + COMMON /SALT3/ CCANO32, CCACL2, CK2SO4, CKHSO4, CKNO3, CKCL + COMMON /SALT4/ CMGSO4, CMGNO32, CMGCL2 +!$OMP THREADPRIVATE( /SALT/ ) +!$OMP THREADPRIVATE( /SALT2/ ) +!$OMP THREADPRIVATE( /SALT3/ ) +!$OMP THREADPRIVATE( /SALT4/ ) + + !================================================================= + ! Variables for gas phase + !================================================================= + + REAL*8 :: GNH3, GHNO3, GHCL + COMMON /GASCB/ GNH3, GHNO3, GHCL +!$OMP THREADPRIVATE( /GASCB/ ) + + !================================================================= + ! Equilibrium constants + !================================================================= + + REAL*8 :: XK1, XK2, XK3, XK4, XK5, XK6, XK7, XK8, XK9, XK10 + REAL*8 :: XK11,XK12,XK13,XK14,XKW, XK21,XK22,XK31,XK32,XK41 + REAL*8 :: XK42,XK15,XK16,XK17,XK18,XK19,XK20,XK23 + REAL*8 :: XK24,XK25 + COMMON /EQUK/ XK1, XK2, XK3, XK4, XK5, XK6, XK7, XK8, XK9, XK10 + COMMON /EQUK2/ XK11,XK12,XK13,XK14,XKW, XK21,XK22,XK31,XK32,XK41 + COMMON /EQUK3/ XK42,XK15,XK16,XK17,XK18,XK19,XK20,XK23 + COMMON /EQUK4/ XK24,XK25 + !C & , XK26, XK27 +!$OMP THREADPRIVATE( /EQUK/ ) +!$OMP THREADPRIVATE( /EQUK2/ ) +!$OMP THREADPRIVATE( /EQUK3/ ) +!$OMP THREADPRIVATE( /EQUK4/ ) + + !================================================================= + ! Molecular Weights + !================================================================= + + REAL*8 :: R = 82.0567D-6 + REAL*8 :: IMW(NIONS) = (/ 1.0, 23.0, 18.0, 35.5, 96.0, 97.0, + & 62.0, 40.1, 39.1, 24.3 /) + REAL*8 :: WMW(NCOMP) = (/ 23.0, 98.0, 17.0, 63.0, 36.5, 40.1, + & 39.1, 24.3 /) + REAL*8 :: SMW(NPAIR) = (/ 58.5, 142., 85.0, 132., 80.0, 53.5, + & 98.0, 98.0, 115., 63.0, 36.5, 120., + & 247., 136.1, 164., 111., 174.2, + & 136.1, 101.1, 74.5, 120.3, 148.3, + & 95.2 /) + + COMMON /OTHR/ R, IMW, WMW, SMW + ! OTHR is read-only + + !================================================================= + ! Solution/info variables + !================================================================= + + CHARACTER(LEN=15) :: SCASE + COMMON /CASE/ SCASE +!$OMP THREADPRIVATE( /CASE/ ) + + REAL*8 :: SULRATW, SULRAT, SODRAT, + & SO4RAT, CRNARAT, CRRAT + COMMON /CASE2/ SULRATW, SULRAT, SODRAT, + & SO4RAT, CRNARAT, CRRAT +!$OMP THREADPRIVATE( /CASE2/ ) + + REAL*8 :: EPS = 1.D-10 + COMMON /SOLN/ EPS + ! SOLN is read-only + + INTEGER :: MAXIT = 100 + INTEGER :: NSWEEP = 10 + INTEGER :: NDIV = 5 + INTEGER :: ICLACT = 0 + COMMON /SOLN2/ MAXIT, NSWEEP, NDIV + ! SOLN 2 is read-only + + COMMON /SOLN3/ ICLACT +!$OMP THREADPRIVATE( /SOLN3/ ) + + !================================================================= + ! Error system + !================================================================= + + CHARACTER(LEN=40) :: ERRMSG(NERRMX) = ' ' + COMMON /EROR/ ERRMSG +!$OMP THREADPRIVATE( /EROR/ ) + + INTEGER :: ERRSTK(NERRMX) = 0 + INTEGER :: NOFER = 0 + COMMON /EROR2/ ERRSTK, NOFER +!$OMP THREADPRIVATE( /EROR2/ ) + + LOGICAL :: STKOFL = .FALSE. + COMMON /EROR3/ STKOFL +!$OMP THREADPRIVATE( /EROR3/ ) + + !================================================================= + ! Generic Variables + !================================================================= + + CHARACTER(LEN=15) :: VERSION = '2.0 (03/19/07)' + COMMON /CGEN/ VERSION + ! CGEN is read-only + + REAL*8 :: GREAT = 1.d10 + REAL*8 :: TINY = 1.d-20 + REAL*8 :: TINY2 = 1.d-11 + REAL*8 :: ZERO = 0.d0 + REAL*8 :: ONE = 1.d0 + COMMON /CGEN2/ GREAT, TINY, TINY2, ZERO, ONE + ! CGEN2 is read-only + + !================================================================= + ! coordinates for debugging + !================================================================= + INTEGER :: ICOOR, JCOOR, LCOOR + COMMON /LOC/ ICOOR, JCOOR, LCOOR +!$OMP THREADPRIVATE( /LOC/ ) + + !================================================================= + ! Differentiated Routines + !================================================================= + + ! changes made by hotp 8/2/07 + ! explicitly declared all variables in SOLUT + ! made SOLUT THREADPRIVATE for OPENMP parallelization + REAL*8 :: CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8 + REAL*8 :: CHI9, CHI10, CHI11, CHI12, CHI13, CHI14, CHI15 + REAL*8 :: CHI16, CHI17, PSI1, PSI2, PSI3, PSI4, PSI5, PSI6 + REAL*8 :: PSI7, PSI8, PSI9, PSI10, PSI11, PSI12, PSI13 + REAL*8 :: PSI14, PSI15, PSI16, PSI17, A1, A2, A3, A4, A5, A6 + REAL*8 :: A7, A8, A9, A10, A11, A12, A13, A14, A15, A16, A17 + COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, + & CHI9, CHI10, CHI11, CHI12, CHI13, CHI14, CHI15, + & CHI16, CHI17, PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, + & PSI7, PSI8, PSI9, PSI10, PSI11, PSI12, PSI13, + & PSI14, PSI15, PSI16, PSI17, A1, A2, A3, A4, A5, A6, + & A7, A8, A9, A10, A11, A12, A13, A14, A15, A16, A17 +!$OMP THREADPRIVATE( /SOLUT/ ) + + REAL*8 :: wb(ncomp) + COMMON /inpt_b/ wb +!$OMP THREADPRIVATE( /inpt_b/ ) + + !================================================================= + ! Case A Adjoint + !================================================================= + + REAL*8 :: molalab(nions),gamaab(npair),waterab + COMMON /ions_ab/ molalab, gamaab, waterab +!$OMP THREADPRIVATE( /ions_ab/ ) + + REAL*8 :: wab(ncomp) + COMMON /inpt_ab/ wab +!$OMP THREADPRIVATE( /inpt_ab/ ) + + REAL*8 :: gnh3ab + COMMON /gas_ab/ gnh3ab +!$OMP THREADPRIVATE( /gas_ab/ ) + + !================================================================= + ! Case B Adjoint + !================================================================= + + REAL*8 :: molalbb(nions), gamabb(npair), waterbb + COMMON /ions_bb/ molalbb, gamabb, waterbb +!$OMP THREADPRIVATE( /ions_bb/ ) + + REAL*8 :: gnh3bb + COMMON /gas_bb/ gnh3bb +!$OMP THREADPRIVATE( /gas_bb/ ) + + !================================================================= + ! Case C Adjoint + !================================================================= + + REAL*8 :: molalcb(nions), gamacb(npair), watercb + COMMON /ions_cb/ molalcb, gamacb, watercb +!$OMP THREADPRIVATE( /ions_cb/ ) + + REAL*8 :: gnh3cb + COMMON /gas_cb/ gnh3cb +!$OMP THREADPRIVATE( /gas_cb/ ) + + !================================================================= + ! Case D Adjoint + !================================================================= + + REAL*8 :: molaldnrd(nions), gamadnrd(npair), waterdnrd + COMMON /ions_dnrd/ molaldnrd, gamadnrd, waterdnrd +!$OMP THREADPRIVATE( /ions_dnrd/ ) + + REAL*8 :: chi3db, chi4db, psi1db, psi2db + COMMON /solut_db/ chi3db, chi4db, psi1db, psi2db +!$OMP THREADPRIVATE( /solut_db/ ) + + REAL*8 :: molaldnrddb(nions), gamadnrddb(npair), waterdnrddb + COMMON /ions_dnrd_db/ molaldnrddb, gamadnrddb,waterdnrddb +!$OMP THREADPRIVATE( /ions_dnrd_db/ ) + + REAL*8 :: gnh3db, ghno3db + COMMON /gas_db/ gnh3db, ghno3db +!$OMP THREADPRIVATE( /gas_db/ ) + + REAL*8 :: molaldb(nions), molalrdb(npair), gamadb(npair), + & waterdb + COMMON /ions_db/ molaldb, molalrdb, gamadb, waterdb +!$OMP THREADPRIVATE( /ions_db/ ) + + !================================================================= + ! Case E Adjoint + !================================================================= + + REAL*8 :: molaleb(nions), gamaeb(npair), watereb + COMMON /ions_eb/ molaleb, gamaeb, watereb +!$OMP THREADPRIVATE( /ions_eb/ ) + + REAL*8 :: web(ncomp) + COMMON /inpt_eb/ web +!$OMP THREADPRIVATE( /inpt_eb/ ) + + REAL*8 :: ghno3eb + COMMON /gas_eb/ ghno3eb +!$OMP THREADPRIVATE( /gas_eb/ ) + + !================================================================= + ! Case F Adjoint + !================================================================= + + REAL*8 :: molalfb(nions) + REAL*8 :: gamafb(npair) + REAL*8 :: waterfb + COMMON /ions_fb/ molalfb, gamafb, waterfb +!$OMP THREADPRIVATE( /ions_fb/ ) + + REAL*8 :: wfb(ncomp) + COMMON /inpt_fb/ wfb +!$OMP THREADPRIVATE( /inpt_fb/ ) + + REAL*8 :: ghno3fb + COMMON /gas_fb/ ghno3fb +!$OMP THREADPRIVATE( /gas_fb/ ) + + !================================================================= + ! Case G Adjoint + !================================================================= + + REAL*8 :: molalgnrd(nions), gamagnrd(npair), watergnrd + COMMON /ions_gnrd/ molalgnrd, gamagnrd, watergnrd +!$OMP THREADPRIVATE( /ions_gnrd/ ) + + REAL*8 :: molalgnrdgb(nions), gamagnrdgb(npair), watergnrdgb + COMMON /ions_gnrd_gb/ molalgnrdgb, gamagnrdgb, watergnrdgb +!$OMP THREADPRIVATE( /ions_gnrd_gb/ ) + + REAL*8 :: chi4gb, chi5gb, chi6gb, psi2gb + COMMON /solut_gb/ chi4gb, chi5gb, chi6gb, psi2gb +!$OMP THREADPRIVATE( /solut_gb/ ) + + REAL*8 :: gnh3gb, ghno3gb, ghclgb + COMMON /gas_gb/ gnh3gb, ghno3gb, ghclgb +!$OMP THREADPRIVATE( /gas_gb/ ) + + REAL*8 :: molalgb(nions), molalrgb(npair), gamagb(npair), + & watergb + COMMON /ions_gb/ molalgb, molalrgb, gamagb, watergb +!$OMP THREADPRIVATE( /ions_gb/ ) + + REAL*8 :: wgb(ncomp) + COMMON /inpt_gb/ wgb +!$OMP THREADPRIVATE( /inpt_gb/ ) + + !================================================================= + ! Case H Adjoint + !================================================================= + + REAL*8 :: molalhnrd(nions), gamahnrd(npair), waterhnrd + COMMON /ions_hnrd/ molalhnrd, gamahnrd, waterhnrd +!$OMP THREADPRIVATE( /ions_hnrd/ ) + + REAL*8 :: molalhnrdhb(nions), gamahnrdhb(npair), waterhnrdhb + COMMON /ions_hnrd_hb/ molalhnrdhb, gamahnrdhb, waterhnrdhb +!$OMP THREADPRIVATE( /ions_hnrd_hb/ ) + + REAL*8 :: chi1hb, chi4hb, chi5hb, chi6hb, chi7hb, chi8hb + COMMON /solut_hb/ chi1hb, chi4hb, chi5hb, chi6hb, chi7hb, chi8hb +!$OMP THREADPRIVATE( /solut_hb/ ) + + REAL*8 :: gnh3hb, ghno3hb, ghclhb + COMMON /gas_hb/ gnh3hb, ghno3hb, ghclhb +!$OMP THREADPRIVATE( /gas_hb/ ) + + REAL*8 :: molalhb(nions), molalrhb(npair), gamahb(npair), + & waterhb + COMMON /ions_hb/ molalhb, molalrhb, gamahb, waterhb +!$OMP THREADPRIVATE( /ions_hb/ ) + + !================================================================= + ! Case I Adjoint + !================================================================= + + REAL*8 :: gnh3ib, ghno3ib, ghclib + COMMON /gas_ib/ gnh3ib, ghno3ib, ghclib +!$OMP THREADPRIVATE( /gas_ib/ ) + + REAL*8 :: molalib(nions), gamaib(npair), waterib + COMMON /ions_ib/ molalib, gamaib, waterib +!$OMP THREADPRIVATE( /ions_ib/ ) + + REAL*8 :: wib(ncomp) + COMMON /inpt_ib/ wib +!$OMP THREADPRIVATE( /inpt_ib/ ) + + !================================================================= + ! Case J Adjoint + !================================================================= + + REAL*8 :: gnh3jb, ghno3jb, ghcljb + COMMON /gas_jb/ gnh3jb, ghno3jb, ghcljb +!$OMP THREADPRIVATE( /gas_jb/ ) + + REAL*8 :: molaljb(nions), gamajb(npair), waterjb + COMMON /ions_jb/ molaljb, gamajb, waterjb +!$OMP THREADPRIVATE( /ions_jb/ ) + + REAL*8 :: wjb(ncomp) + COMMON /inpt_jb/ wjb +!$OMP THREADPRIVATE( /inpt_jb/ ) + +! +! === END OF INCLUDE FILE ============================================== +! diff --git a/code/new/linoz.com b/code/new/linoz.com new file mode 100644 index 0000000..093cad2 --- /dev/null +++ b/code/new/linoz.com @@ -0,0 +1,38 @@ +C $Id: linoz.com,v 1.1 2009/06/09 21:51:54 daven Exp $ +C $Log: linoz.com,v $ +C Revision 1.1 2009/06/09 21:51:54 daven +C Initial revision +C +C Revision 2.23 2000/05/24 23:09:33 pjc +C Changed criteria for using Linoz: now must have [Ox]>150ppb AND Level>=9. +C +C Revision 2.10 2000/03/23 20:39:04 pjc +C Initial version created out of McLinden's original files. +C + +C common block for linoz. Created by Philip Cameron-Smith, 00/1/14. + + INTEGER nfields_linoz,nlevels_linoz,nlat_linoz,nmonths_linoz + PARAMETER(nfields_linoz=7) ! Number of linoz fields. + PARAMETER(nlevels_linoz=25) ! Number of levels in linoz fields. + PARAMETER(nlat_linoz=18) ! Number of latitudes in linoz fields. + PARAMETER(nmonths_linoz=12) !Number of months in linoz fields. + + REAL*8 TPARM(nlevels_linoz,nlat_linoz,nmonths_linoz,nfields_linoz) + REAL*8 TLSTT(JJPAR,LLPAR,nfields_linoz) + COMMON/linoz_fields/TPARM,TLSTT + + REAL*8 linoz_min_alt !Minimum altitude covered by linoz data. + PARAMETER(linoz_min_alt=10) ! units=[km] + INTEGER linoz_min_lev ! Minimum GCM level linoz can cover. + COMMON/linoz_levels/linoz_min_lev + +C*PJC* Need to define the minimum Level at which Linoz can be used. +C NB: Linoz data goes down to ~277mbar, so any part of a layer below +C this has effectively no Linoz chemistry. + INTEGER Linoz_min_L + PARAMETER(Linoz_min_L=9) +C*PJC* Define ozone tropopause, below which Linoz not used. + REAL*8 Linoz_min_Ox + PARAMETER(Linoz_min_Ox=150E-9) ! VMR, so 150E-9 = 150 ppb. + diff --git a/code/new/linoz_mod.f b/code/new/linoz_mod.f new file mode 100644 index 0000000..58c885b --- /dev/null +++ b/code/new/linoz_mod.f @@ -0,0 +1,1434 @@ +!$Id: linoz_mod.f,v 1.6 2012/07/13 20:09:14 nicolas Exp $ +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: linoz_mod +! +!###################################################################### +! !!! THIS CODE IS BASED ON LINOZ_MOD.F OF V9 FORWARD (hml, adj32_025) !!! +!###################################################################### +! +! !DESCRIPTION: Module LINOZ\_MOD contains routines to perform the Linoz +! stratospheric ozone chemistry. +!\\ +!\\ +! !INTERFACE: +! + MODULE LINOZ_MOD +! +! !USES: +! + IMPLICIT NONE + PRIVATE +! +! !DEFINED PARAMETERS: +! + INTEGER, PARAMETER :: NFIELDS_LINOZ = 7 ! # of Linoz fields + INTEGER, PARAMETER :: NLEVELS_LINOZ = 25 ! # of levels in Linoz fields + INTEGER, PARAMETER :: NLAT_LINOZ = 18 ! # latitudes in Linoz fields + INTEGER, PARAMETER :: NMONTHS_LINOZ = 12 ! # of months in Linoz fields +! +! !PRIVATE DATA MEMBERS: +! + REAL*8, ALLOCATABLE :: TPARM(:,:,:,:) + REAL*8, ALLOCATABLE :: TLSTT(:,:,:) +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: CLEANUP_LINOZ + PUBLIC :: DO_LINOZ + PUBLIC :: LINOZ_READ +! +! !PRIVATE MEMBER FUNCTIONS: +! + PRIVATE :: INIT_LINOZ + PRIVATE :: LINOZ_CHEM3 + PRIVATE :: LINOZ_STRATL + PRIVATE :: LINOZ_STRT2M + PRIVATE :: LINOZ_SOMLFQ + PRIVATE :: LINOZ_INTPL + PRIVATE :: STRAT_INIT +! +! !REMARKS: +! Dylan Jones (dbj@atmosp.physics.utoronto.ca) wrote: +! . +! Testing this code [in v8-02-04] was more difficult that I thought. +! I began by trying to compare the output of v8-02-04 with our previous +! runs with v8-02-01. I accounted for the changes in the transport_mod.f +! and I tried to undo the changes in when the diagnostics are archived in +! v8-02-04, but I was still getting large differences between v8-02-04 +! and v8-02-01. I finally gave up on this since I may have made a mistake +! in reverting to the old way of doing the diagnostics in v8-02-04. In +! the end I took the new linoz code from v8-02-04 and used it in v8-02-01. +! I ran two GEOS-5 full chemistry simulations for 2007 and the output +! were consistent over the full year. +! . +! I think that it is safe to release [Linoz in v8-02-04]. However, we +! should acknowledge that it was [only] tested in v8-02-01, since I was +! not able to assess the quality of the output in v8-02-04. +! +! REVISION HISTORY: +! 23 Mar 2000 - P. Cameron-Smith - Initial version adapted heavily +! from McLinden's original file. +! 24 Jun 2003 - B. Field & D. Jones - Further updates for GEOS-Chem +! 28 May 2009 - D. Jones - Further modifications +! 18 Nov 2009 - D. Jones - Further modifications +!EOP +!------------------------------------------------------------------------------ +!BOC + + CONTAINS +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: do_linoz +! +! !DESCRIPTION: Subroutine DO\_LINOZ is the main driver for the Linoz +! stratospheric Ozone chemistry package. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE DO_LINOZ +! +! !USES: +! + USE TIME_MOD + USE LOGICAL_ADJ_MOD, ONLY : LADJ + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + +# include "CMN_SIZE" +! +! !REVISION HISTORY: +! 24 Jun 2003 - B. Field & D. Jones - Further updates for GEOS-Chem +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER, SAVE :: LASTMONTH = -99 + REAL*8 :: NSCHEM + + ! if new month, get new parameters? + IF ( GET_MONTH() /= LASTMONTH ) THEN + CALL LINOZ_STRATL + LASTMONTH = GET_MONTH() + ENDIF + + ! Linoz needs time step in seconds + NSCHEM = GET_TS_CHEM() * 60D0 + + ! Call the Linoz chemistry + IF ( LADJ .and. LADJ_STRAT ) THEN + CALL LINOZ_CHEM3_FORADJ( NSCHEM ) + ELSE + CALL LINOZ_CHEM3( NSCHEM ) + ENDIF + + END SUBROUTINE DO_LINOZ +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: linoz_chem3 +! +! !DESCRIPTION: Subroutine LINOZ\_CHEM3 applies linearized chemistry based on +! tables from PRATMO model using climatological T, O3, time of year +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE LINOZ_CHEM3( DTCHEM ) +! +! !USES: +! + USE DAO_MOD + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TRACER_MOD + USE TRACERID_MOD + USE TROPOPAUSE_MOD, ONLY : GET_TPAUSE_LEVEL + USE TROPOPAUSE_MOD, ONLY : GET_MAX_TPAUSE_LEVEL + USE PRESSURE_MOD, ONLY : GET_PEDGE + USE PRESSURE_MOD, ONLY : GET_PCENTER + + ! hml: add for adjoint + USE TIME_MOD, ONLY : GET_NHMS + USE TIME_MOD, ONLY : GET_NYMD + USE TIME_MOD, ONLY : GET_TAU + USE CHECKPOINT_MOD, ONLY : MAKE_UPBDFLX_CHKFILE + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE LOGICAL_ADJ_MOD,ONLY : LADJ_STRAT + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, DO_CHK_FILE + + + +# include "CMN_SIZE" +# include "CMN" +! +! !INPUT PARAMETERS: +! + REAL*8, INTENT(IN) :: DTCHEM ! Time step [seconds] + +! +! !REVISION HISTORY: +! 24 Jun 2003 - B. Field & D. Jones - Further updates for GEOS-Chem +! 18 Nov 2009 - D. Jones - For now, set tagged stratospheric +! tracer to total O3 in the overworld +! to avoid issues with spin ups +! 08 Feb 2010 - R. Yantosca - Deleted obsolete local variables +! 22 Oct 2010 - R. Yantosca - Added OMP parallel loop +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + ! Scalars + INTEGER :: IMX, JM, LM + INTEGER :: I, J, L, N + INTEGER :: LBOT, L_OVERWRLD + INTEGER :: NTRACER, NUM_TRACER, LPOS, ITRC + + REAL*8 :: CLIMO3, CLIMPML, DCO3, DERO3, DERTMP + REAL*8 :: DERCO3, DMASS, DTMP, SSO3 + + INTEGER :: NHMS + INTEGER :: NYMD + REAL*8 :: TAU + + ! Arrays + REAL*8 :: DCOLO3(IIPAR,JJPAR,LLPAR) + REAL*8 :: COLO3(IIPAR,JJPAR,LLPAR) + REAL*8 :: OUT_DATA(IIPAR,JJPAR,LLPAR) + + ! Assign values for local IM and JM (dbj 6/24/03) + IMX = IIPAR + JM = JJPAR + LM = LLPAR + L_OVERWRLD = GET_MAX_TPAUSE_LEVEL() + + ! Stratospheric Chemistry Tables for O3: + ! ====================================== + ! 7 tables, each a function of month (12), latitude + ! (18, -85 to 85 in 10 deg. increments) and altitude + ! (25, z*=10-58 km in 2 km increments). + ! 1- ozone (Logan climatology), v/v + ! 2- Temperature climatology, K + ! 3- Column ozone climatology, Logan ozone integrated above box, DU + ! 4- ozone (P-L) for climatological ozone, v/v/s + ! 5- d(P-L) / dO3, 1/s + ! 6- d(P-L) / dT, v/v/s/K + ! 7- d(P-L) / d(column O3), v/v/s/DU + ! + ! zero storage arrays + ! do n=1,ntrace + ! sttold(n)=0.d0 + ! enddo + + !================================================================= + ! Select the proper tracer number to store O3 into, depending on + ! whether this is a full chemistry run or a tagged Ox run. + ! If tagged Ox, tracer 2 should be the stratospheric tracer. (dbj) + !================================================================= + IF ( ITS_A_FULLCHEM_SIM() ) THEN + NUM_TRACER = 1 + ELSE + IF ( ITS_A_TAGOX_SIM() ) THEN + IF (N_TRACERS > 1) THEN + NUM_TRACER = 2 + ELSE + NUM_TRACER = 1 + ENDIF + ELSE + ! All other simulations don't use O3...print error message + WRITE( 6, '(a)' ) 'This simulation does not use O3!!' + WRITE( 6, '(a)' ) 'STOP in linoz_chem3.f!' + STOP + ENDIF + ENDIF + + ! Echo info + WRITE( 6, 100 ) + 100 FORMAT(' - LINOZ_CHEM3: Doing LINOZ stratospheric chemistry') + + ! **** note dbj: check STT(I,J,20:LLPAR,NTRACER) = with trop level + ! **** : check DMASS + + DO ITRC=1,NUM_TRACER ! dbj loop for tagged + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + NTRACER = IDTOX + ELSE + NTRACER = ITRC + ENDIF + + ! Make checkpoint file + ! WRITING STT and TLSTT TO BE USED IN REVERSE MODE + DO L = 1,LLPAR + DO J = 1,JJPAR + DO I = 1,7 + STT_TMP(I,J,L,1) = TLSTT(J,L,I) + ENDDO + ENDDO + ENDDO + + STT_TMP(:,:,:,2) = STT(:,:,:,NTRACER) + + NHMS = GET_NHMS() + NYMD = GET_NYMD() + TAU = GET_TAU() + IF ( DO_CHK_FILE() ) + & CALL MAKE_UPBDFLX_CHKFILE( NYMD, NHMS, TAU ) + + + WRITE(6,*) '-------------------------------------------------' + write(6,*) ' doing linoz stratospheric chemistry' + WRITE(6,*) '-------------------------------------------------' + + ! Start at top layer and continue to lowest layer for strat. chem + OUT_DATA = 0d0 + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, LBOT, LPOS, L ) +!$OMP+PRIVATE( CLIMPML, DERO3, CLIMO3, DERCO3, DCO3 ) +!$OMP+PRIVATE( DERTMP, DTMP, SSO3, DMASS ) + DO J = 1, JM + DO I = 1, IMX + LBOT = GET_TPAUSE_LEVEL(I,J)+1 + LPOS = 1 + + ! To set LFD properly (hml, 10/12/11) + !IF ( I == IFD.and.J == JFD) THEN + ! print *, 'LBOT = ', LBOT + !ENDIF + + DO WHILE (GET_PEDGE(I,J,LPOS+1) .GE. 0.3D0) + LPOS = LPOS +1 + ENDDO + LPOS = LPOS-1 + + + !--------------------------------------------------------- + ! dbj: for now, set tagged stratospheric tracer to total + ! O3 in the overworld to avoid issues with spin ups + !--------------------------------------------------------- + IF ( ITS_A_TAGOX_SIM() ) THEN + STT(I,J,(L_OVERWRLD+1):LLPAR,NTRACER) = + & STT(I,J,(L_OVERWRLD+1):LLPAR,1) + ENDIF + + DO L = LM,LBOT,-1 + + IF (STT(I,J,L,NTRACER) .LE. 0.D0) CYCLE + + ! calculate ozone column above box (and save) + ! dcolo3 = ozone column (in DU) in given layer + ! colo3 = ozone column above layer + half of + ! column in layer + + !--------------------------------------- + ! GET RATES - assigning PROD and LOSS + !--------------------------------------- + + ! bdf stt is in v/v, make conversion to DU + IF (L .EQ. LM) THEN !top model layer + DCOLO3(I,J,L) = (STT(I,J,L,NTRACER)*AD(I,J,L)/ + & TCVV(NTRACER))/ GET_AREA_CM2(J) * + & 6.022d23/(28.97/TCVV(NTRACER)*1d-3)/ 2.687d16 + COLO3(I,J,L) = DCOLO3(I,J,L)*0.5 + ELSE + DCOLO3(I,J,L) = (STT(I,J,L,NTRACER)*AD(I,J,L)/ + & TCVV(NTRACER))/ GET_AREA_CM2(J) * + & 6.022d23/(28.97/TCVV(NTRACER)*1d-3)/ 2.687d16 + COLO3(I,J,L) = COLO3(I,J,L+1) + + & (DCOLO3(I,J,L)+DCOLO3(I,J,L+1))*0.5 + ENDIF + OUT_DATA(I,J,L) = COLO3(I,J,L) + + ! ++++++ climatological P-L: ++++++ + CLIMPML = TLSTT(J,L,4) ! Climatological P-L = (P-L)^o + + ! ++++++ local ozone feedback: ++++++ + DERO3 = TLSTT(J,L,5) ! Derivative w.r.t. O3. dero3=-1/(time constant) + IF (DERO3 .EQ. 0) CYCLE ! Skip Linoz if lifetime is infinite. + CLIMO3 = TLSTT(J,L,1) ! Climatological O3 = f^o + DERCO3 = TLSTT(J,L,7) ! Derivative w.r.t. Column O3 + DCO3 = (COLO3(I,J,L) - TLSTT(J,L,3)) ! deviation from o3 climatology. + + ! ++++++ temperature feedback: ++++++ + DERTMP = TLSTT(J,L,6) ! Derivative w.r.t. Temperature + DTMP = (T(I,J,L) - TLSTT(J,L,2)) ! Deviation in Temperature from climatology. + + ! ++++++ calculate steady-state ozone: ++++++ + SSO3 = CLIMO3 + & - (CLIMPML + DTMP*DERTMP + DCO3*DERCO3) / DERO3 + + ! ++++++ change in ozone mass due to chemistry: ++++++ + !ssO3 = f^* + DMASS = (SSO3 - STT(I,J,L,NTRACER)) + & * (1.0 - exp(DERO3*DTCHEM)) + + + ! ++++++ update ozone mass ++++++ + ! LINOZ valid only up to 58 km, so do not use above 0.3 hPa + ! dbj: impose exponential fall off of mixing ratio + ! between 0.3 and 0.01 hPa (with fall off of a scale height) + IF (GET_PEDGE(I,J,L) .LE. 0.3D0) THEN + STT(I,J,L,NTRACER) = (GET_PCENTER(I,J,L) + & / GET_PCENTER(I,J,LPOS-1)) + & * STT(I,J,LPOS-1,NTRACER) + ELSE + STT(I,J,L,NTRACER) = STT(I,J,L,NTRACER) + DMASS + ENDIF + ENDDO ! loop over L + ENDDO ! loop over I + ENDDO ! loop pver J + +!$OMP END PARALLEL DO + + !write our calculated column o3 maximum + !write(6,*) 'max of columns= ',maxval(out_data) + + ENDDO ! loop over ntracers + + END SUBROUTINE LINOZ_CHEM3 +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: linoz_stratl +! +! !DESCRIPTION: Subroutine LINOZ\_STRATL performs a monthly fixup of chemistry +! parameters for the Linoz stratospheric ozone chemistry. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE LINOZ_STRATL +! +! !USES: +! + USE GRID_MOD, ONLY : GET_YMID + USE TIME_MOD, ONLY : GET_MONTH + USE PRESSURE_MOD + +# include "CMN_SIZE" +# include "CMN" +! +! !REVISION HISTORY: +! 24 Jun 2003 - B. Field & D. Jones - Further updates for GEOS-Chem +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + integer J,K,L,N,JLATMD(jjpar),JXXX,LR,JJ,i,im1,im2 !,je +! integer jdofm(nmonths_linoz+1),jdmc(nmonths_linoz) +! parameter (je=18) !number of latitudes in look-up table + + ! Now declare IM, JM as local variables + ! since we have removed them from the common block (dbj 6/24/03) + INTEGER IM, JM, MONTH + + real*8 STRTX(nlevels_linoz),YSTRT(nlat_linoz) + real*8 P0L(llpar+1) + real*8 STRT0L(llpar+1),STRT1L(llpar+1),STRT2L(llpar+1) + real*8, PARAMETER :: PSF=1010D0 + + !Define Month names locally (dbj 6/25/03) + CHARACTER(LEN=3) :: CMONTH(12) = (/'jan', 'feb', 'mar', 'apr', + & 'may', 'jun', 'jul', 'aug', + & 'sep', 'oct', 'nov', 'dec'/) + +! data JDOFM/0,31,59,90,120,151,181,212,243,273,304,334,365/ +c----------------------------------------------------------------------- + + ! Assign values for local IM and JM (dbj 6/24/03) + IM = IIPAR + JM = JJPAR + + ! added call to GET_MONTH (dbj 6/25/03) + WRITE(6,*)'#####################################################' + WRITE(6,*)'# Interpolating Linoz fields for ', + & CMONTH( GET_MONTH() ), + & ' #' + WRITE(6,*)'#####################################################' + + +! ***** Linear interpolation between months is not currently used {PJC} ***** +!c get weights for month interpolation +! do i=1,nmonths_linoz +! jdmc(i) = jdofm(i+1) - (jdofm(i+1)-jdofm(i))/2 +! enddo +! +! im1=0 +! do i=1,nmonths_linoz +! if (jdmc(i).lt.jday) then +! im1=i +! endif +! enddo +! if (im1.eq.0) then +! im1=nmonths_linoz +! im2=1 +! wm1=(jdmc(im2)-jday)*1.0/(jdmc(im2)-(jdmc(im1)-365.0)) +! elseif (im1.eq.nmonths_linoz) then +! im2=1 +! wm1=(jdmc(im2)+365.0-jday)/(jdmc(im2)+365.0-jdmc(im1)) +! else +! im2=im1+1 +! wm1=(jdmc(im2)-jday)*1.0/(jdmc(im2)-jdmc(im1)) +! endif +! wm2=1.0-wm1 +! +!c write(6,*)iday,jday,' weights: ',wm1,wm2 +!c write(6,*)'months: ',im1,im2,month +!c write(6,*)'between: ',jdmc(im1),jdmc(im2) +! *************************************************************************** + +c latitude interpolation + + YSTRT(1) = -85.d0 !Latitudes = -85, -75, -65, .... +75, +85. + do J = 2,NLAT_LINOZ + YSTRT(J) = YSTRT(J-1) + 10.d0 + enddo + + + DO J = 1,JJPAR + JXXX = int(0.1d0 * GET_YMID(J) +10.d0) ! (dbj 6/25/03) + JLATMD(J) = MIN(18,MAX(1,JXXX)) !index of nearest Linoz data column + ENDDO + + DO L = 1,LLPAR+1 + P0L(L) = GET_AP(LLPAR+2-L) + (GET_BP(LLPAR+2-L)*PSF) ! dbj + ENDDO + +c-------- TPARM(25,18,12,N) defined for -------------------------------- +c 25 layers from 58 km to 10 km by 2 km intervals +c 18 LATS (85S, 75S, ...85N) +c 12 months +c N tables = NTBLS +c-------- skip interpolating, pick nearest latitude -------------------- + + DO N = 1,nfields_linoz + +! ***** Interpolation between latitudes is not currently used {PJC} ***** +!c----- interpolating along latitude, from TPAR2 to STRTXY +! do K = 1,nlevels_linoz +! do J = 1,nlat_linoz +!c TPAR2(K,J) = TPARM(K,J,MONTH,N) +! TPAR2(K,J) = TPARM(K,J,im1,N) +! enddo +! enddo +! call LINOZ_INTPL(nlevels_linoz,NLAT_LINOZ,JPAR,JM,YSTRT,YDGRD, +! & TPAR2,STRTXY1) +! do K = 1,nlevels_linoz +! do J = 1,nlat_linoz +! TPAR2(K,J) = TPARM(K,J,im2,N) +! enddo +! enddo +! call LINOZ_INTPL(nlevels_linoz,NLAT_LINOZ,JPAR,JM,YSTRT,YDGRD, +! & TPAR2,STRTXY2) +! *********************************************************************** + + DO J = 1,JM + JJ = JLATMD(J) + DO K = 1,nlevels_linoz +! linearly interpolate in latitude and month +! STRTX(K) = STRTXY1(K,J)*wm1 + STRTXY2(K,J)*wm2 +! linearly interpolate in latitude, single month +! STRTX(K) = STRTXY2(K,J) +! nearest latitude, linearly interpolate in month +! STRTX(K) = TPARM(K,JJ,im1,N)*wm1 + TPARM(K,JJ,im2,N)*wm2 +! nearest latitude, single month + STRTX(K) = TPARM(K,JJ,GET_MONTH(),N) ! (dbj 6/25/03) + ENDDO ! loop over K + + + ! *PJC* Interpolate and calculate moments of column distribution + CALL LINOZ_STRT2M(STRTX,nlevels_linoz,STRT0L,STRT1L,STRT2L, + & P0L,LLPAR) + + ! Store loss freq/yields & moments in TLSTT/SWT/SWW + ! for exact CTM layers LM down + ! Order reversed from C.McLinden version {PJC} + DO LR = 1,LLPAR + TLSTT(J,LR,N) = STRT0L(LLPAR+1-LR) + ENDDO + ENDDO ! loop over J + ENDDO ! loop over N + + END SUBROUTINE LINOZ_STRATL +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: linoz_strt2m +! +! !DESCRIPTION: Subroutine LINOZ\_STRT2M sets up a std z* atmosphere: +! p = 1000 * 10**(-z*/16 km). +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE LINOZ_STRT2M(STRTX,NX,STRT0L,STRT1L,STRT2L,P0L,NSTRT) +! +! !USES: +! +# include "CMN_SIZE" +! +! !DEFINED PARAMETERS: +! + ! Parameter (ncbox=25) + ! Now use nlevels_linoz for all routines. {PJC} + INTEGER, PARAMETER :: NL = NLEVELS_LINOZ+5 +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: NX + INTEGER, INTENT(IN) :: NSTRT + REAL*8, INTENT(IN) :: STRTX(NLEVELS_LINOZ) + REAL*8, INTENT(IN) :: P0L(LLPAR+1) +! +! !OUTPUT PARAMETERS: +! + REAL*8, INTENT(OUT) :: STRT0L(LLPAR+1) + REAL*8, INTENT(OUT) :: STRT1L(LLPAR+1) + REAL*8, INTENT(OUT) :: STRT2L(LLPAR+1) +! +! !REVISION HISTORY: +! 24 Jun 2003 - B. Field & D. Jones - Further updates for GEOS-Chem +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + integer ncbox,l,k + + real*8 P1,P2,F0,F1,F2,PS(NL+1),F(NL) + real*8 XPSD,XPSLM1,XPSL +c----------------------------------------------------------------------- +c set up std z* atmosphere: p = 1000 * 10**(-z*/16 km) +c assume that stratospheric chemical parameters always start at +cc 52 km (N=27) scan downward from 52 km to 14 km (NX=20) by 2 km +c 58 km (N=30) scan downward from 58 km to 10 km (NX=25) by 2 km +c intervals, constant >58km +c-------- N.B. F(@30km) assumed to be constant from 29-31 km (by mass) +c +C======== Comments from Chris McLinden by Email ={PJC}================== +C CALL SOMLFQ(P1,P2,F0,F1,F2,PS,F,NL) +C - P1,P2 are the pressure EDGES for the CTM layer onto which the +C coefficients will be mapped. [P1>P2 I believe {PJC}] +C - F0,F1,F2 are the CTM layer vertical moments determined in SOMLFQ +C - PS are the pressure layer edges of the original [ie Linox] grid +C - F is the column of coefficients (on the original grid); note +C F is flipped relative to STRTX and since the coefficients begin +C at z*=10, F(1)=F(2)=...=F(5)=0 +C - NL is 30; size of F() +C +C The box model calculations were performed at z*=10km, 12km, ... and +C so these would represent the centres with the corresponding edges at +C 9,11km ; 11,13km; ... +C PS() represents the edges (although PS(1) is set to 1000mb). +C The first few values are: +C PS(1)=1000 +C PS(2)=874.947105 (note PS(2) is not quite 1000 exp(-1/16) as the +C PS(3)=656.117767 the average pressure is used - not the pressure +C PS(4)=492.018914 at the average z*) +C PS(5)=368.96213 +C PS(6)=276.68257 +C PS(7)=207.48266 +C ... +C PS(30)=0.276682568 +C PS(31)=0.0 +C +C F(1) spans PS(1)-PS(2) +C F(2) spans PS(2)-PS(3) +C ... +C F(30) spans PS(30)-PS(31) +C======================================================================= + + + XPSD = 10.D0 **(-0.125D0) + XPSLM1 = 1000.D0 + PS(1) = 1000.D0 + DO L = 2,NL + XPSL = XPSLM1 *XPSD + PS(L) = 0.5D0 *(XPSLM1 +XPSL) + XPSLM1 = XPSL + ENDDO + PS(NL+1) = 0.D0 + DO L = 1,NL-NX + F(L) = 0.D0 + ENDDO +c-------- K=1 is at the top of atmosphere ------------------------------ + DO K = 1,NX + F(NL+1-K)= STRTX(K) !STRTX has increasing preasure. {PJC} + ENDDO + DO K = 1,NSTRT + P1 = P0L(K+1) + P2 = P0L(K) + CALL LINOZ_SOMLFQ(P1,P2,F0,F1,F2,PS,F,NL) + STRT0L(K)= F0 + STRT1L(K)= F1 + STRT2L(K)= F2 + ENDDO + + END SUBROUTINE LINOZ_STRT2M +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: linoz_somlfq +! +! !DESCRIPTION: subroutine LINOZ\_SOMLFQ calculates loss freq moments from a +! set of loss frequencies at std z*, given a CTM model interval pressure +! range: P1 > P2 (decreasing up) +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE LINOZ_SOMLFQ(P1,P2,F0,F1,F2,PS,F,NL) +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: NL + REAL*8, INTENT(IN) :: F(NL) + REAL*8, INTENT(IN) :: PS(NL+1) + REAL*8, INTENT(OUT) :: P1 + REAL*8, INTENT(OUT) :: P2 +! +! !OUTPUT PARAMETERS: +! + REAL*8, INTENT(OUT) :: F0 + REAL*8, INTENT(OUT) :: F1 + REAL*8, INTENT(OUT) :: F2 +! +! REMARKS: +! The pressure levels BETWEEN z* values are: +! PS(i) > PS(i+1) bounds z*(i) +! . +! NL: z* levels, ==> PS(NL+1) = 0 (extrapolate chemical loss to top) +! Z1 = 16.D0*LOG10(1000.D0/P1) +! Z2 = 16.D0*LOG10(1000.D0/P2) +! . +! The MOMENTS for a square-wave or 'bar': F(x)=f0 b<=x<=c, =0.0 else +! S0 = f0 (x) [from x=b to x=c] +! S1 = 3 f0 (x^2 - x) [from x=b to x=c] +! S2 = 5 f0 (2x^3 - 3x^2 + x) [from x=b to x=c] +! +! !REVISION HISTORY: +! 24 Jun 2003 - B. Field & D. Jones - Further updates for GEOS-Chem +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + integer I + real*8 XB,XC,PC,PB,THIRD,sgnf0 + + F0 = 0.D0 + F1 = 0.D0 + F2 = 0.D0 + DO I = 1,NL + PC = MIN(P1,PS(I)) + PB = MAX(P2,PS(I+1)) + IF (PC .GT. PB) THEN + + ! have condition: P1>=PC > PB>=P2, 0<=XB < XC<=1 + XC = (PC-P2)/(P1-P2) + XB = (PB-P2)/(P1-P2) + + ! assume that the loss freq, F, is constant over interval [XB,XC], + ! F0: (c-b), + ! F1: 6((c2-c)-(b2-b)), + ! F2: 5((2c3-3c2+c)-(2b3-3b2+b)) + ! calculate its contribution to the moments in the interval [0,1] + F0 = F0 +F(I) *(XC -XB) + F1 = F1 +F(I) *3.D0 *((XC *XC -XC) - (XB *XB -XB)) + F2 = F2 +F(I) *5.D0 * + & ((XC+XC-1.D0)*(XC*XC -XC) - (XB+XB-1.D0)*(XB*XB -XB)) + ENDIF + ENDDO + + ! RESTRAIN moments: force monotonicity & positive at min end pt + + ! cam: tables can be + or - + if (f0.ne.0.0) then + sgnf0=f0 / abs(f0) + else + sgnf0=1.0 + endif + f0=abs(f0) + + !F0 = MAX(F0, 0.D0) + THIRD = 1.D0/3.D0 + IF (F2 .GT. 0.D0) THEN + + + ! do not allow reversal of curvature: F2 > 0 + F2 = MIN(F2, ABS(F1)*THIRD, 5.D-1*F0) + IF (F1 .LT .0.D0) THEN + F1 = MAX(-(F0+F2), F1) + ELSE + F1 = MIN(+(F0+F2), F1) + ENDIF + ELSE + + ! F2 < 0 = curved down at ends, allow if F1 < F0 + F1 = MIN(F0,MAX(-F0,F1)) + F2 = MAX(F2,(ABS(F1)-F0),(-ABS(F1)*THIRD)) + ENDIF + + ! cam: apply sign + f0=sgnf0 * f0 + f1=sgnf0 * f1 + f2=sgnf0 * f2 + + END SUBROUTINE LINOZ_SOMLFQ +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: linoz_read +! +! !DESCRIPTION: Subroutine LINOZ\_READ reads the input data file for the +! Linoz stratospheric ozone chemistry. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE LINOZ_READ +! +! !USES: +! + USE FILE_MOD, ONLY : IU_FILE ! Logical unit # + USE FILE_MOD, ONLY : IOERROR ! I/O error subroutine + USE DIRECTORY_MOD, ONLY : DATA_DIR_1x1 ! Data directory path + +# include "CMN_SIZE" +! +! !REMARKS: +! LINOZ_READ is called from "main.f" at the start of the simulation. +! LINOZ_READ will also call INIT_LINOZ to initialize the arrays. +! +! !REVISION HISTORY: +! 24 Jun 2003 - B. Field & D. Jones - Further updates for GEOS-Chem +! 16 Oct 2009 - R. Yantosca - Now use IU_FILE instead of IU_LINOZ +! 16 Oct 2009 - R. Yantosca - Read file from DATA_DIR_1x1 +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: K, J, M, NTBLS, IOS + REAL*8 :: TMAX, TMIN + CHARACTER(LEN=80) :: HEADING, TITL1 + CHARACTER(LEN=255) :: FILENAME + + ! Only initialize arrays on first timestep + IF ( FIRST ) THEN + CALL INIT_LINOZ + FIRST = .FALSE. + ENDIF + + ! Filename + FILENAME = TRIM( DATA_DIR_1x1 ) // + & 'Linoz_200910/Linoz_March2007.dat' + + ! Echo info + WRITE( 6, 100 ) TRIM( FILENAME ) + 100 FORMAT( ' - LINOZ_READ: Reading ', a ) + + ! new std z*=2km levels from model: z*=10,12,...(25*2)+8 km + OPEN( IU_FILE, FILE=TRIM( FILENAME ), STATUS='OLD', + & FORM='FORMATTED', IOSTAT=IOS ) + + ! + IF ( IOS /= 0 ) THEN + CALL IOERROR( IOS, IU_FILE, 'read_linoz_coeff_file' ) + ENDIF + + ! Reade header + READ ( IU_FILE, 901 ) HEADING + WRITE(6,*) TRIM( HEADING ) + + ! Loop thru file + DO NTBLS = 1,nfields_linoz + TMIN = +1.d30 + TMAX = -1.d30 + READ (IU_FILE,901) TITL1 + do M = 1,nmonths_linoz !Month + do J = 1,nlat_linoz !Latitudes + READ (IU_FILE,907) + & (TPARM(K,J,M,NTBLS),K=nlevels_linoz,1,-1) + do K=1,nlevels_linoz + TMAX = max (TMAX, TPARM(K,J,M,ntbls)) + TMIN = min (TMIN, TPARM(K,J,M,ntbls)) + enddo + enddo + enddo + write (6,912) TITL1,TMIN,TMAX + enddo + + WRITE(6,*)'$$ Finished Reading Linoz Data $$' + WRITE(6,*) + + GOTO 999 + + ! If error has occurred + 101 CONTINUE + WRITE(6,*)'**** STOP: Error reading Linoz Coefficients {PJC} ****' + write(6,*)'NTBLS =',ntbls,', M =',m,', J =',j,', K =',k + write(6,*)'TPARM(K,J,M,NTBLS) =',TPARM(K,J,M,NTBLS) + STOP + + ! Format strings + 901 FORMAT(A) + 907 FORMAT(20X,6E11.4/(8E11.4)) +c907 FORMAT(20X,6E10.3/(8E10.3)) + 912 FORMAT(' Linoz Data: ',a80,1p,2e10.3) + + 999 CONTINUE + + ! Close the files + CLOSE( IU_FILE ) + + END SUBROUTINE LINOZ_READ +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: linoz_intpl +! +! !DESCRIPTION: Subroutine LINOZ\_INTPL does some kind of interpolation. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE LINOZ_INTPL(KE,IE,ND,NE,XI,XN,YI,YN) +! +! !INPUT PARAMETERS: +! + INTEGER, INTENT(IN) :: KE + INTEGER, INTENT(IN) :: IE + INTEGER, INTENT(IN) :: ND + INTEGER, INTENT(IN) :: NE + REAL*8, INTENT(IN) :: XI(IE) + REAL*8, INTENT(IN) :: XN(ND) + REAL*8, INTENT(IN) :: YI(KE,IE) +! +! !OUTPUT PARAMETERS: +! + REAL*8, INTENT(OUT) :: YN(KE,ND) + +! +! !REVISION HISTORY: +! 24 Jun 2003 - B. Field & D. Jones - Further updates for GEOS-Chem +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + integer I,II,J,K + real*8 CNST1,CNST2 + + ! k=height; i=lat + J = 2 + do I = 1,NE + if (XN(I) .gt. XI(1 )) then + if (XN(I) .lt. XI(IE)) then + CNST1 = (XI(J) - XN(I)) / (XI(J) - XI(J-1)) + CNST2 = (XN(I) - XI(J-1)) / (XI(J) - XI(J-1)) + do K = 1,KE + YN(K,I) = CNST1 * YI(K,J-1) + CNST2 * YI(K,J) + enddo + II = min(I+1,NE) + if (XN(II) .gt. XI(J)) J = min(IE,J+1) + else + do K = 1 ,KE + YN(K,I) = YI(K,IE) + enddo + endif + else + do K = 1,KE + YN(K,I) = YI(K,1) + enddo + endif + !write(6,*)i,(yn(k,i),k=1,ke) + enddo + + END SUBROUTINE LINOZ_INTPL +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: strat_init +! +! !DESCRIPTION: Subroutine STRAT\_INIT copies the ozone computed by the +! Linoz stratospheric chemistry algorithm back into the GEOS-Chem +! tracer array. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE STRAT_INIT +! +! !USES: +! + USE TRACERID_MOD + USE TRACER_MOD + +# include "CMN_SIZE" +# include "CMN" +! +! !REVISION HISTORY: +! 24 Jun 2003 - B. Field & D. Jones - Further updates for GEOS-Chem +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + INTEGER I, J, L + + CALL LINOZ_STRATL + + DO J = 1,JJPAR + DO I = 1,IIPAR + DO L = MINVAL(LPAUSE),LLPAR + IF (L .LT. LPAUSE(I,J)) CYCLE + STT(I,J,L,IDTOX) = TLSTT(J,L,1) / TCVV(IDTOX) + ENDDO + ENDDO + ENDDO + +! call write_fields2(7) +! call flush(12) + + END SUBROUTINE STRAT_INIT +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: init_linoz +! +! !DESCRIPTION: Subroutine INIT\_LINOZ allocates and zeroes the module arrays +! used in the Linoz stratospheric ozone algorithm. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE INIT_LINOZ +! +! !USES: +! + USE ERROR_MOD, ONLY : ALLOC_ERR + +# include "CMN_SIZE" +! +! !REVISION HISTORY: +! 16 Oct 2009 - R. Yantosca - Initial version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER :: AS + + ! For safety's sake, only allocate arrays on first call + IF ( FIRST ) THEN + + ! Allocate TPARM array + ALLOCATE( TPARM( NLEVELS_LINOZ, NLAT_LINOZ, + & NMONTHS_LINOZ, NFIELDS_LINOZ ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TPARM' ) + TPARM = 0d0 + + ! Allocate TLSTT array + ALLOCATE( TLSTT( JJPAR, LLPAR, NFIELDS_LINOZ ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TPARM' ) + TLSTT = 0d0 + + ! Reset FIRST + FIRST = .FALSE. + ENDIF + + END SUBROUTINE INIT_LINOZ + +!------------------------------------------------------------------- + SUBROUTINE LINOZ_CHEM3_FORADJ( DTCHEM ) + +! +!*************************************************************** +! Subroutine LINOZ_CHEM3_FORADJ is a version that applies +! scaling factors to the strat prod / loss rates in a manner +! equivalent to how GMI rates are adjusted in strat chem. +! (dkh, 02/28/12) +! +!*************************************************************** + USE TIME_MOD, ONLY : GET_NHMS + USE TIME_MOD, ONLY : GET_NYMD + USE TIME_MOD, ONLY : GET_TAU + USE DAO_MOD, ONLY : AD + USE DAO_MOD, ONLY : T + USE ERROR_MOD, ONLY : ERROR_STOP + USE TRACER_MOD, ONLY : TCVV + USE TRACER_MOD, ONLY : STT_TMP + USE TRACER_MOD, ONLY : STT + USE TRACER_MOD, ONLY : N_TRACERS + USE TRACER_MOD, ONLY : ITS_A_TAGOX_SIM + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM + USE TRACERID_MOD, ONLY : IDTOX + USE GRID_MOD, ONLY : GET_AREA_CM2 + USE TROPOPAUSE_MOD, ONLY : GET_TPAUSE_LEVEL + USE TROPOPAUSE_MOD, ONLY : GET_MAX_TPAUSE_LEVEL + USE PRESSURE_MOD, ONLY : GET_PEDGE + USE PRESSURE_MOD, ONLY : GET_PCENTER + USE CHECKPOINT_MOD, ONLY : MAKE_UPBDFLX_CHKFILE + USE LOGICAL_ADJ_MOD, ONLY : LADJ_STRAT + USE LOGICAL_ADJ_MOD, ONLY : LADJ + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : ID_LOSS, NSTPL + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, DO_CHK_FILE + + + IMPLICIT NONE + +# include "CMN_SIZE" +# include "CMN" +!# include "../new/linoz.com" + + REAL*8, INTENT(IN) :: DTCHEM ! Time step [seconds] + + +C============================================== +C define arguments +C============================================== + + ! hml: add for strat prod & loss sense + INTEGER :: IMX, JM, LM + INTEGER :: I, J, L + INTEGER :: NS, NSL + INTEGER :: LBOT, L_OVERWRLD + INTEGER :: NTRACER, NUM_TRACER, LPOS, ITRC + INTEGER :: NHMS, NYMD + + REAL*8 :: CLIMO3, CLIMPML, PMLTOT + REAL*8 :: DCO3, DERO3, DERTMP + REAL*8 :: DERCO3, DMASS, DTMP + REAL*8 :: SSO3 + + REAL*8 :: TAU + REAL*8 :: P, k, M0 + REAL*8 :: PROD, LOSS + REAL*8 :: PROD_0, LOSS_0 + + ! Arrays + REAL*8 :: DCOLO3(IIPAR,JJPAR,LLPAR) + REAL*8 :: COLO3(IIPAR,JJPAR,LLPAR) + REAL*8 :: OUT_DATA(IIPAR,JJPAR,LLPAR) + + + ! Assign values for local IMX and JM (dbj 6/24/03) + IMX = IIPAR + JM = JJPAR + LM = LLPAR ! dbj + + L_OVERWRLD = GET_MAX_TPAUSE_LEVEL() + + + ! ====================================== + ! 7 tables, each a function of month (12), latitude + ! (18, -85 to 85 in 10 deg. increments) and altitude + ! (25, z*=10-58 km in 2 km increments). + ! 1- ozone (Logan climatology), v/v + ! 2- Temperature climatology, K + ! 3- Column ozone climatology, Logan ozone integrated above box, DU + ! 4- ozone (P-L) for climatological ozone, v/v/s + ! 5- d(P-L) / dO3, 1/s + ! 6- d(P-L) / dT, v/v/s/K + ! 7- d(P-L) / d(column O3), v/v/s/DU + ! + ! zero storage arrays + ! do n=1,ntrace + ! sttold(n)=0.d0 + ! enddo + + !================================================================= + + !================================================================= + ! Select the proper tracer number to store O3 into, depending on + ! whether this is a full chemistry run or a tagged Ox run. + ! If tagged Ox, tracer 2 should be the stratospheric tracer. (dbj) + !================================================================= + IF ( ITS_A_FULLCHEM_SIM() ) THEN + NUM_TRACER = 1 + ELSE + IF ( ITS_A_TAGOX_SIM() ) THEN + IF (N_TRACERS > 1) THEN + NUM_TRACER = 2 + ELSE + NUM_TRACER = 1 + ENDIF + ELSE + ! All other simulations don't use O3...print error message + WRITE( 6, '(a)' ) 'This simulation does not use O3!!' + WRITE( 6, '(a)' ) 'STOP in linoz_chem3.f!' + STOP + ENDIF + ENDIF + + ! Echo info + WRITE( 6, 100 ) + 100 FORMAT(' - LINOZ_CHEM3_FORADJ: Doing LINOZ strat chemistry') + + ! **** note dbj: check STT(I,J,20:LLPAR,NTRACER) = with trop level + ! **** : check DMASS + + + DO ITRC=1,NUM_TRACER ! dbj loop for tagged + + IF ( ITS_A_FULLCHEM_SIM() ) THEN + NTRACER = IDTOX + ELSE + NTRACER = ITRC + ENDIF + + ! Make checkpoint file + ! WRITING STT and TLSTT TO BE USED IN REVERSE MODE + IF ( LADJ ) THEN + DO L = 1,LLPAR + DO J = 1,JJPAR + DO I = 1,7 + STT_TMP(I,J,L,1) = TLSTT(J,L,I) + ENDDO + ENDDO + ENDDO + + STT_TMP(:,:,:,2) = STT(:,:,:,NTRACER) + + NHMS = GET_NHMS() + NYMD = GET_NYMD() + TAU = GET_TAU() + IF ( DO_CHK_FILE() ) + & CALL MAKE_UPBDFLX_CHKFILE( NYMD, NHMS, TAU ) + + ENDIF + + WRITE(6,*) '-------------------------------------------------' + write(6,*) ' doing linoz stratospheric chemistry' + WRITE(6,*) '-------------------------------------------------' + + ! Start at top layer and continue to lowest layer for strat. chem + OUT_DATA = 0d0 + + ! Initialize arrays (hml, 10/17/11) + LOSS = 0d0 + PROD = 0d0 + + DO J = 1, JM + DO I = 1, IMX + LBOT = GET_TPAUSE_LEVEL(I,J)+1 + LPOS = 1 + + ! To set LFD properly (hml, 10/12/11) + !IF ( I == IFD.and.J == JFD) THEN + ! print *, 'LBOT = ', LBOT + !ENDIF + + DO WHILE (GET_PEDGE(I,J,LPOS+1) .GE. 0.3D0) + LPOS = LPOS +1 + ENDDO + LPOS = LPOS-1 + + !--------------------------------------------------------- + ! dbj: for now, set tagged stratospheric tracer to total + ! O3 in the overworld to avoid issues with spin ups + !--------------------------------------------------------- + IF ( ITS_A_TAGOX_SIM() ) THEN + STT(I,J,(L_OVERWRLD+1):LLPAR,NTRACER) = + & STT(I,J,(L_OVERWRLD+1):LLPAR,1) + ENDIF + + ! If we just loop from LPOS, rather than LLPAR, then we only deal with + ! levels for which PEDGE > 0.3d0 + DO L = LM,LBOT,-1 + + IF (STT(I,J,L,NTRACER) .LE. 0.D0) CYCLE + + !--------------------------------------- + ! GET RATES - assigning PROD and LOSS + !--------------------------------------- + + !------------------------------------------------------ + ! Recalculate forward model values to get rates + !------------------------------------------------------ + + ! bdf stt is in v/v, make conversion to DU + IF ( L .EQ. LM) THEN !top model layer + DCOLO3(I,J,L) = (STT(I,J,L,NTRACER)*AD(I,J,L)/ + & TCVV(NTRACER))/ GET_AREA_CM2(J) * + & 6.022d23/(28.97/TCVV(NTRACER)*1d-3)/ 2.687d16 + COLO3(I,J,L) = DCOLO3(I,J,L)*0.5 + ELSE + DCOLO3(I,J,L) = (STT(I,J,L,NTRACER)*AD(I,J,L)/ + & TCVV(NTRACER))/ GET_AREA_CM2(J) * + & 6.022d23/(28.97/TCVV(NTRACER)*1d-3)/ 2.687d16 + COLO3(I,J,L) = COLO3(I,J,L+1) + + & (DCOLO3(I,J,L)+DCOLO3(I,J,L+1))*0.5 + ENDIF + + ! ++++++ climatological P-L: ++++++ + CLIMPML = TLSTT(J,L,4) ! Climatological P-L = (P-L)^o + + ! ++++++ local ozone feedback: ++++++ + DERO3 = TLSTT(J,L,5) ! Derivative w.r.t. O3. dero3=-1/(time constant) + IF ( DERO3 .EQ. 0 ) CYCLE ! Skip Linoz if lifetime is infinite. + CLIMO3 = TLSTT(J,L,1) ! Climatological O3 = f^o + DERCO3 = TLSTT(J,L,7) ! Derivative w.r.t. Column O3 + DCO3 = (COLO3(I,J,L) - TLSTT(J,L,3)) ! deviation from o3 climatology. + + ! ++++++ temperature feedback: ++++++ + DERTMP = TLSTT(J,L,6) ! Derivative w.r.t. Temperature + DTMP = (T(I,J,L) - TLSTT(J,L,2)) ! Deviation in Temperature from climatology. + + ! ++++++ calculate steady-state ozone: ++++++ + SSO3 = CLIMO3 + & - (CLIMPML + DTMP*DERTMP + DCO3*DERCO3) /DERO3 + + ! ++++++ change in ozone mass due to chemistry: ++++++ + !ssO3 = f^* + DMASS = (SSO3 - STT(I,J,L,NTRACER)) + & * (1.0 - exp(DERO3*DTCHEM)) + + + ! ++++++ update ozone mass ++++++ + ! LINOZ valid only up to 58 km, so do not use above 0.3 hPa + ! dbj: impose exponential fall off of mixing ratio + ! between 0.3 and 0.01 hPa (with fall off of a scale height) + IF (GET_PEDGE(I,J,L) .LE. 0.3D0) THEN + STT(I,J,L,NTRACER) = (GET_PCENTER(I,J,L) + & / GET_PCENTER(I,J,LPOS-1)) + & * STT(I,J,LPOS-1,NTRACER) + + ! apply prod / loss rates ala GMI strat chem method + ELSE + + ! note: there is a factor of TC / AD * AD / TC that cancels + ! out in definition of PROD_0 + PROD_0 = - (SSO3 * DERO3) + LOSS_0 = - DERO3 + + DO NS = 1, NSTPL + NSL = ID_LOSS(NS) ! same for ID_PROD(NS) + + IF ( NSL .EQ. IDTOx ) THEN + + !! Scaled prod & loss rate + PROD = PROD_0 * PROD_SF(I,J,1,NS) + LOSS = LOSS_0 * LOSS_SF(I,J,1,NS) + + ENDIF + + ENDDO + + k = LOSS ! loss freq [s-1] + P = PROD * AD(I,J,L) / TCVV(NTRACER) ! production term [kg s-1] + + ! Put ozone back to kg (hml, 11/06/11) + M0 = STT(I,J,L,NTRACER) + & * AD(I,J,L) / TCVV(NTRACER)! initial mass [kg] + + ! No prod or loss at all + if ( k .eq. 0d0 .and. P .eq. 0d0 ) cycle + + ! Simple analytic solution to dM/dt = P - kM over [0,t] +! if ( k .gt. 0d0 ) then + STT(I,J,L,NTRACER) = M0 * exp(-k*DTCHEM) + & + (P/k)*(1d0-exp(-k*DTCHEM)) +! else +! STT(I,J,L,NTRACER) = M0 + P*DTCHEM +! endif + + + ! convert units back to v/v, which is was the code expects coming out + ! of LINOZ + STT(I,J,L,NTRACER) = STT(I,J,L,NTRACER) + & * TCVV(NTRACER) / AD(I,J,L) + ENDIF + + ENDDO ! loop over L + + ENDDO ! loop over I + ENDDO ! loop pver J + +!!$OMP END PARALLEL DO + + !write our calculated column o3 maximum + !write(6,*) 'max of columns= ',maxval(out_data) + + ENDDO ! loop over ntracers + + END SUBROUTINE LINOZ_CHEM3_FORADJ +!------------------------------------------------------------------------------ +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: cleanup_linoz +! +! !DESCRIPTION: Subroutine CLEANUP\_LINOZ deallocates all module arrays. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE CLEANUP_LINOZ +! +! !REVISION HISTORY: +! 16 Oct 2009 - R. Yantosca - Initial version +!EOP +!------------------------------------------------------------------------------ +!BOC + ! Deallocate arrays + IF ( ALLOCATED( TPARM ) ) DEALLOCATE( TPARM ) + IF ( ALLOCATED( TLSTT ) ) DEALLOCATE( TLSTT ) + + END SUBROUTINE CLEANUP_LINOZ +!EOC + + ! End of module + END MODULE LINOZ_MOD diff --git a/code/new/linpack.f b/code/new/linpack.f new file mode 100644 index 0000000..96b8495 --- /dev/null +++ b/code/new/linpack.f @@ -0,0 +1,218 @@ +c +c L-BFGS-B is released under the “New BSD License” (aka “Modified BSD License” +c or “3-clause license”) +c Please read attached file License.txt +c + subroutine dpofa(a,lda,n,info) + integer lda,n,info + double precision a(lda,*) +c +c dpofa factors a double precision symmetric positive definite +c matrix. +c +c dpofa is usually called by dpoco, but it can be called +c directly with a saving in time if rcond is not needed. +c (time for dpoco) = (1 + 18/n)*(time for dpofa) . +c +c on entry +c +c a double precision(lda, n) +c the symmetric matrix to be factored. only the +c diagonal and upper triangle are used. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c on return +c +c a an upper triangular matrix r so that a = trans(r)*r +c where trans(r) is the transpose. +c the strict lower triangle is unaltered. +c if info .ne. 0 , the factorization is not complete. +c +c info integer +c = 0 for normal return. +c = k signals an error condition. the leading minor +c of order k is not positive definite. +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas ddot +c fortran sqrt +c +c internal variables +c + double precision ddot,t + double precision s + integer j,jm1,k +c begin block with ...exits to 40 +c +c + do 30 j = 1, n + info = j + s = 0.0d0 + jm1 = j - 1 + if (jm1 .lt. 1) go to 20 + do 10 k = 1, jm1 + t = a(k,j) - ddot(k-1,a(1,k),1,a(1,j),1) + t = t/a(k,k) + a(k,j) = t + s = s + t*t + 10 continue + 20 continue + s = a(j,j) - s +c ......exit + if (s .le. 0.0d0) go to 40 + a(j,j) = sqrt(s) + 30 continue + info = 0 + 40 continue + return + end + +c====================== The end of dpofa =============================== + + subroutine dtrsl(t,ldt,n,b,job,info) + integer ldt,n,job,info + double precision t(ldt,*),b(*) +c +c +c dtrsl solves systems of the form +c +c t * x = b +c or +c trans(t) * x = b +c +c where t is a triangular matrix of order n. here trans(t) +c denotes the transpose of the matrix t. +c +c on entry +c +c t double precision(ldt,n) +c t contains the matrix of the system. the zero +c elements of the matrix are not referenced, and +c the corresponding elements of the array can be +c used to store other information. +c +c ldt integer +c ldt is the leading dimension of the array t. +c +c n integer +c n is the order of the system. +c +c b double precision(n). +c b contains the right hand side of the system. +c +c job integer +c job specifies what kind of system is to be solved. +c if job is +c +c 00 solve t*x=b, t lower triangular, +c 01 solve t*x=b, t upper triangular, +c 10 solve trans(t)*x=b, t lower triangular, +c 11 solve trans(t)*x=b, t upper triangular. +c +c on return +c +c b b contains the solution, if info .eq. 0. +c otherwise b is unaltered. +c +c info integer +c info contains zero if the system is nonsingular. +c otherwise info contains the index of +c the first zero diagonal element of t. +c +c linpack. this version dated 08/14/78 . +c g. w. stewart, university of maryland, argonne national lab. +c +c subroutines and functions +c +c blas daxpy,ddot +c fortran mod +c +c internal variables +c + double precision ddot,temp + integer case,j,jj +c +c begin block permitting ...exits to 150 +c +c check for zero diagonal elements. +c + do 10 info = 1, n +c ......exit + if (t(info,info) .eq. 0.0d0) go to 150 + 10 continue + info = 0 +c +c determine the task and go to it. +c + case = 1 + if (mod(job,10) .ne. 0) case = 2 + if (mod(job,100)/10 .ne. 0) case = case + 2 + go to (20,50,80,110), case +c +c solve t*x=b for t lower triangular +c + 20 continue + b(1) = b(1)/t(1,1) + if (n .lt. 2) go to 40 + do 30 j = 2, n + temp = -b(j-1) + call daxpy(n-j+1,temp,t(j,j-1),1,b(j),1) + b(j) = b(j)/t(j,j) + 30 continue + 40 continue + go to 140 +c +c solve t*x=b for t upper triangular. +c + 50 continue + b(n) = b(n)/t(n,n) + if (n .lt. 2) go to 70 + do 60 jj = 2, n + j = n - jj + 1 + temp = -b(j+1) + call daxpy(j,temp,t(1,j+1),1,b(1),1) + b(j) = b(j)/t(j,j) + 60 continue + 70 continue + go to 140 +c +c solve trans(t)*x=b for t lower triangular. +c + 80 continue + b(n) = b(n)/t(n,n) + if (n .lt. 2) go to 100 + do 90 jj = 2, n + j = n - jj + 1 + b(j) = b(j) - ddot(jj-1,t(j+1,j),1,b(j+1),1) + b(j) = b(j)/t(j,j) + 90 continue + 100 continue + go to 140 +c +c solve trans(t)*x=b for t upper triangular. +c + 110 continue + b(1) = b(1)/t(1,1) + if (n .lt. 2) go to 130 + do 120 j = 2, n + b(j) = b(j) - ddot(j-1,t(1,j),1,b(1),1) + b(j) = b(j)/t(j,j) + 120 continue + 130 continue + 140 continue + 150 continue + return + end + +c====================== The end of dtrsl =============================== + + diff --git a/code/new/netcdf_util_mod.f b/code/new/netcdf_util_mod.f new file mode 100644 index 0000000..2b60e60 --- /dev/null +++ b/code/new/netcdf_util_mod.f @@ -0,0 +1,1102 @@ +!$Id: netcdf_util_mod.f,v 1.1 2012/03/01 22:00:27 daven Exp $ +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: netcdf_util_mod +! +!\\ +!\\ +! !INTERFACE: +! + MODULE NETCDF_UTIL_MOD +! +! !USES: +! + USE NETCDF + IMPLICIT NONE + PRIVATE +! + +! +! !PUBLIC MEMBER FUNCTIONS: +! + ! Functions + PUBLIC :: NCDF_GET_VARID ! Return variable ID + PUBLIC :: NCDF_GET_DIMID ! Return variable ID + + ! Subroutines + PUBLIC :: NCDF_OPEN_FOR_READ + PUBLIC :: NCDF_CLOSE + + PUBLIC :: NCDF_VAR_EXIST + PUBLIC :: NCDF_DIM_EXIST + + PUBLIC :: NCDF_GET_VAR ! Get data from a netCDF file + + PUBLIC :: NCDF_SYNC ! Push data in buffers to the file ahead of close + + PUBLIC :: CHECK_NCDF ! Test for error on netCDF API functions + PUBLIC :: NCDF_INIT ! Set intial variables, etc. +! +! !PRIVATE MEMBER FUNCTIONS: +! +! !PUBLIC DATA MEMBERS: + INTEGER, PUBLIC :: NCDF_CHAR + INTEGER, PUBLIC :: NCDF_INT + INTEGER, PUBLIC :: NCDF_REAL + + INTEGER, PUBLIC :: DEF_LEV ! Deflation level + + ! Dimension IDs + INTEGER, PUBLIC :: LVL_DIMID, LVL_VARID ! Vertical level dimension + INTEGER, PUBLIC :: LVLE_DIMID, LVLE_VARID ! Vertical edge dimension + INTEGER, PUBLIC :: LAT_DIMID, LAT_VARID ! Latitude dimension + INTEGER, PUBLIC :: LON_DIMID, LON_VARID ! Longitude dimension + INTEGER, PUBLIC :: TRACER_DIMID ! Tracer dimension + INTEGER, PUBLIC :: STRLEN_8_DIMID ! CHAR(LEN=8) dimension + INTEGER, PUBLIC :: STRLEN_16_DIMID ! CHAR(LEN=16) dimension + INTEGER, PUBLIC :: STRLEN_64_DIMID ! CHAR(LEN=64) dimension + INTEGER, PUBLIC :: PL_DIMID, PL_VARID ! Prod or Loss dimension + INTEGER, PUBLIC :: REC_DIMID, REC_VARID ! Record dimension (time,unlimited) + INTEGER, PUBLIC :: TRACER_NAME_VARID + +! +! !REMARKS: +! +! References: +! ============================================================================ +! (1 ) +! !REVISION HISTORY: +! 2 Feb 2011 - L. Murray - Initial version. +! 1 Jun 2011 - L. Murray - Read-only version of the code. +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !PRIVATE TYPES: +! + INTERFACE NCDF_GET_VAR + ! Compiler chooses which one is appropriate when called + MODULE PROCEDURE NCDF_GET_VAR_CHAR + MODULE PROCEDURE NCDF_GET_VAR_1D_CHAR + MODULE PROCEDURE NCDF_GET_VAR_2D_CHAR + MODULE PROCEDURE NCDF_GET_VAR_3D_CHAR + MODULE PROCEDURE NCDF_GET_VAR_4D_CHAR + MODULE PROCEDURE NCDF_GET_VAR_5D_CHAR + MODULE PROCEDURE NCDF_GET_VAR_6D_CHAR + MODULE PROCEDURE NCDF_GET_VAR_7D_CHAR + MODULE PROCEDURE NCDF_GET_VAR_INT + MODULE PROCEDURE NCDF_GET_VAR_1D_INT + MODULE PROCEDURE NCDF_GET_VAR_2D_INT + MODULE PROCEDURE NCDF_GET_VAR_3D_INT + MODULE PROCEDURE NCDF_GET_VAR_4D_INT + MODULE PROCEDURE NCDF_GET_VAR_5D_INT + MODULE PROCEDURE NCDF_GET_VAR_6D_INT + MODULE PROCEDURE NCDF_GET_VAR_7D_INT + MODULE PROCEDURE NCDF_GET_VAR_REAL + MODULE PROCEDURE NCDF_GET_VAR_1D_REAL + MODULE PROCEDURE NCDF_GET_VAR_2D_REAL + MODULE PROCEDURE NCDF_GET_VAR_3D_REAL + MODULE PROCEDURE NCDF_GET_VAR_4D_REAL + MODULE PROCEDURE NCDF_GET_VAR_5D_REAL + MODULE PROCEDURE NCDF_GET_VAR_6D_REAL + MODULE PROCEDURE NCDF_GET_VAR_7D_REAL + MODULE PROCEDURE NCDF_GET_VAR_DBLE + MODULE PROCEDURE NCDF_GET_VAR_1D_DBLE + MODULE PROCEDURE NCDF_GET_VAR_2D_DBLE + MODULE PROCEDURE NCDF_GET_VAR_3D_DBLE + MODULE PROCEDURE NCDF_GET_VAR_4D_DBLE + MODULE PROCEDURE NCDF_GET_VAR_5D_DBLE + MODULE PROCEDURE NCDF_GET_VAR_6D_DBLE + MODULE PROCEDURE NCDF_GET_VAR_7D_DBLE + END INTERFACE + + CONTAINS + +!------------------------------------------------------------------------------ + + SUBROUTINE CHECK_NCDF( STATUS ) + USE ERROR_MOD, ONLY : GEOS_CHEM_STOP + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: STATUS + + IF ( STATUS /= nf90_noerr ) THEN + WRITE(6,*) 'Error with netCDF' + PRINT*,trim( nf90_strerror(status) ) + CALL GEOS_CHEM_STOP + END IF + + END SUBROUTINE CHECK_NCDF + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_INIT + ! Call only once + IMPLICIT NONE + + ! Set type flags + NCDF_CHAR = NF90_CHAR + NCDF_INT = NF90_INT + NCDF_REAL = NF90_REAL + + END SUBROUTINE NCDF_INIT + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_OPEN_FOR_READ( NCID, FILENAME ) + IMPLICIT NONE + + CHARACTER(LEN=*), INTENT( IN ) :: FILENAME + INTEGER, INTENT( OUT ) :: NCID + + write(6,*) 'netCDF: Opening file for read: ',trim(filename) + call check_ncdf( nf90_open( trim(filename), nf90_nowrite, ncid ) ) + + END SUBROUTINE NCDF_OPEN_FOR_READ + +!------------------------------------------------------------------------------ + + FUNCTION NCDF_DIM_EXIST( NCID, DIMNAME ) RESULT( DIMEXIST ) + + INTEGER, INTENT( IN ) :: NCID + CHARACTER(LEN=*), INTENT( IN ) :: dimName + LOGICAL :: dimExist + + INTEGER :: dimid, status + + dimExist = .false. + + ! Inquire about the the variable id + status = nf90_inq_dimid( ncid, trim(dimname), dimid ) + if ( status .eq. nf90_NoErr ) dimExist = .true. + + END FUNCTION NCDF_DIM_EXIST + +!------------------------------------------------------------------------------ + + FUNCTION NCDF_VAR_EXIST( NCID, VARNAME ) RESULT( VAREXIST ) + + INTEGER, INTENT( IN ) :: NCID + CHARACTER(LEN=*), INTENT( IN ) :: VARNAME + LOGICAL :: varExist + + INTEGER :: varid, status + + varExist = .false. + + ! Inquire about the the variable id + status = nf90_inq_varid( ncid, trim(varname), varid ) + if ( status .eq. nf90_NoErr ) varExist = .true. + ! status .eq. -49 is variable not found + + END FUNCTION NCDF_VAR_EXIST + +!------------------------------------------------------------------------------ + + FUNCTION NCDF_GET_DIMID( NCID, DIMNAME ) RESULT( DIMID ) + + + INTEGER, INTENT( IN ) :: NCID + CHARACTER(LEN=*), INTENT( IN ) :: DIMNAME + INTEGER :: DIMID + + ! Get the dimiable id + call check_ncdf( nf90_inq_dimid( ncid, trim(dimname), dimid ) ) + + END FUNCTION NCDF_GET_DIMID + +!------------------------------------------------------------------------------ + + FUNCTION NCDF_GET_VARID( NCID, VARNAME ) RESULT( VARID ) + + + INTEGER, INTENT( IN ) :: NCID + CHARACTER(LEN=*), INTENT( IN ) :: VARNAME + INTEGER :: VARID + + ! Get the variable id + call check_ncdf( nf90_inq_varid( ncid, trim(varname), varid ) ) + + END FUNCTION NCDF_GET_VARID + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_CHAR(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + CHARACTER(LEN=*), INTENT( OUT ) :: ARRAY + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_CHAR + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_1D_CHAR(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + CHARACTER(LEN=*), INTENT( OUT ) :: ARRAY(:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_1D_CHAR + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_2D_CHAR(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + CHARACTER(LEN=*), INTENT( OUT ) :: ARRAY(:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_2D_CHAR + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_3D_CHAR(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + CHARACTER(LEN=*), INTENT( OUT ) :: ARRAY(:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_3D_CHAR + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_4D_CHAR(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + CHARACTER(LEN=*), INTENT( OUT ) :: ARRAY(:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_4D_CHAR + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_5D_CHAR(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + CHARACTER(LEN=*), INTENT( OUT ) :: ARRAY(:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_5D_CHAR + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_6D_CHAR(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + CHARACTER(LEN=*), INTENT( OUT ) :: ARRAY(:,:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_6D_CHAR + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_7D_CHAR(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + CHARACTER(LEN=*), INTENT( OUT ) :: ARRAY(:,:,:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_7D_CHAR + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_INT(NCID, VARID, VALUE ) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + INTEGER, INTENT( OUT ) :: VALUE + + ! Get the variable + call check_ncdf( nf90_get_var( ncid, varID, value ) ) + + END SUBROUTINE NCDF_GET_VAR_INT + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_1D_INT(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + INTEGER, INTENT( OUT ) :: ARRAY(:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_1D_INT + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_2D_INT(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + INTEGER, INTENT( OUT ) :: ARRAY(:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_2D_INT + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_3D_INT(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + INTEGER, INTENT( OUT ) :: ARRAY(:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_3D_INT + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_4D_INT(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + INTEGER, INTENT( OUT ) :: ARRAY(:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_4D_INT + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_5D_INT(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + INTEGER, INTENT( OUT ) :: ARRAY(:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_5D_INT + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_6D_INT(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + INTEGER, INTENT( OUT ) :: ARRAY(:,:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_6D_INT + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_7D_INT(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + INTEGER, INTENT( OUT ) :: ARRAY(:,:,:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_7D_INT + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_REAL(NCID, VARID, VALUE ) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*4, INTENT( OUT ) :: VALUE + + ! Get the variable + call check_ncdf( nf90_get_var( ncid, varID, value ) ) + + END SUBROUTINE NCDF_GET_VAR_REAL + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_1D_REAL(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*4, INTENT( OUT ) :: ARRAY(:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_1D_REAL + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_2D_REAL(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*4, INTENT( OUT ) :: ARRAY(:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_2D_REAL + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_3D_REAL(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*4, INTENT( OUT ) :: ARRAY(:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_3D_REAL + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_4D_REAL(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*4, INTENT( OUT ) :: ARRAY(:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_4D_REAL + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_5D_REAL(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*4, INTENT( OUT ) :: ARRAY(:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_5D_REAL + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_6D_REAL(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*4, INTENT( OUT ) :: ARRAY(:,:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_6D_REAL + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_7D_REAL(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*4, INTENT( OUT ) :: ARRAY(:,:,:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_7D_REAL + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_DBLE(NCID, VARID, VALUE ) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*8, INTENT( OUT ) :: VALUE + + ! Get the variable + call check_ncdf( nf90_get_var( ncid, varID, value ) ) + + END SUBROUTINE NCDF_GET_VAR_DBLE + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_1D_DBLE(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*8, INTENT( OUT ) :: ARRAY(:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_1D_DBLE + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_2D_DBLE(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*8, INTENT( OUT ) :: ARRAY(:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_2D_DBLE + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_3D_DBLE(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*8, INTENT( OUT ) :: ARRAY(:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_3D_DBLE + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_4D_DBLE(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*8, INTENT( OUT ) :: ARRAY(:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_4D_DBLE + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_5D_DBLE(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*8, INTENT( OUT ) :: ARRAY(:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_5D_DBLE + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_6D_DBLE(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*8, INTENT( OUT ) :: ARRAY(:,:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_6D_DBLE + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_GET_VAR_7D_DBLE(NCID, VARID, ARRAY, START, COUNT) + + IMPLICIT NONE + + INTEGER, INTENT( IN ) :: NCID + INTEGER, INTENT( IN ) :: VARID + REAL*8, INTENT( OUT ) :: ARRAY(:,:,:,:,:,:,:) + INTEGER, OPTIONAL, INTENT( IN ) :: START(:) + INTEGER, OPTIONAL, INTENT( IN ) :: COUNT(:) + + ! Get the variable + if ( present( start ) .and. present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start, count=count ) ) + else if ( present( start ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & start=start ) ) + else if ( present( count ) ) then + call check_ncdf( nf90_get_var( ncid, varID, array, + & count=count ) ) + else + call check_ncdf( nf90_get_var( ncid, varID, array ) ) + endif + + END SUBROUTINE NCDF_GET_VAR_7D_DBLE + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_SYNC( NCID ) + + + INTEGER, INTENT( IN ) :: NCID + call check_ncdf( nf90_sync( NCID ) ) + + END SUBROUTINE NCDF_SYNC + +!------------------------------------------------------------------------------ + + SUBROUTINE NCDF_CLOSE( NCID ) + USE NETCDF + + INTEGER, INTENT( IN ) :: NCID + call check_ncdf( nf90_close( NCID ) ) + + END SUBROUTINE NCDF_CLOSE + + END MODULE NETCDF_UTIL_MOD diff --git a/code/new/routines.f b/code/new/routines.f new file mode 100644 index 0000000..a216a36 --- /dev/null +++ b/code/new/routines.f @@ -0,0 +1,3955 @@ +c +c L-BFGS-B is released under the “New BSD License” (aka “Modified BSD License” +c or “3-clause license”) +c Please read attached file License.txt +c +c=========== L-BFGS-B (version 3.0. April 25, 2011 =================== +c +c This is a modified version of L-BFGS-B. Minor changes in the updated +c code appear preceded by a line comment as follows +c +c c-jlm-jn +c +c Major changes are described in the accompanying paper: +c +c Jorge Nocedal and Jose Luis Morales, Remark on "Algorithm 778: +c L-BFGS-B: Fortran Subroutines for Large-Scale Bound Constrained +c Optimization" (2011). To appear in ACM Transactions on +c Mathematical Software, +c +c The paper describes an improvement and a correction to Algorithm 778. +c It is shown that the performance of the algorithm can be improved +c significantly by making a relatively simple modication to the subspace +c minimization phase. The correction concerns an error caused by the use +c of routine dpmeps to estimate machine precision. +c +c The total work space **wa** required by the new version is +c +c 2*m*n + 11m*m + 5*n + 8*m +c +c the old version required +c +c 2*m*n + 12m*m + 4*n + 12*m +c +c +c J. Nocedal Department of Electrical Engineering and +c Computer Science. +c Northwestern University. Evanston, IL. USA +c +c +c J.L Morales Departamento de Matematicas, +c Instituto Tecnologico Autonomo de Mexico +c Mexico D.F. Mexico. +c +c March 2011 +c +c============================================================================= + subroutine setulb(n, m, x, l, u, nbd, f, g, factr, pgtol, wa, iwa, + + task, iprint, csave, lsave, isave, dsave) + + character*60 task, csave + logical lsave(4) + integer n, m, iprint, + + nbd(n), iwa(3*n), isave(44) + double precision f, factr, pgtol, x(n), l(n), u(n), g(n), +c +c-jlm-jn + + wa(2*m*n + 5*n + 11*m*m + 8*m), dsave(29) + +c ************ +c +c Subroutine setulb +c +c This subroutine partitions the working arrays wa and iwa, and +c then uses the limited memory BFGS method to solve the bound +c constrained optimization problem by calling mainlb. +c (The direct method will be used in the subspace minimization.) +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c x is a double precision array of dimension n. +c On entry x is an approximation to the solution. +c On exit x is the current approximation. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound on x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound on x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c f is a double precision variable. +c On first entry f is unspecified. +c On final exit f is the value of the function at x. +c +c g is a double precision array of dimension n. +c On first entry g is unspecified. +c On final exit g is the value of the gradient at x. +c +c factr is a double precision variable. +c On entry factr >= 0 is specified by the user. The iteration +c will stop when +c +c (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch +c +c where epsmch is the machine precision, which is automatically +c generated by the code. Typical values for factr: 1.d+12 for +c low accuracy; 1.d+7 for moderate accuracy; 1.d+1 for extremely +c high accuracy. +c On exit factr is unchanged. +c +c pgtol is a double precision variable. +c On entry pgtol >= 0 is specified by the user. The iteration +c will stop when +c +c max{|proj g_i | i = 1, ..., n} <= pgtol +c +c where pg_i is the ith component of the projected gradient. +c On exit pgtol is unchanged. +c +c wa is a double precision working array of length +c (2mmax + 5)nmax + 12mmax^2 + 12mmax. +c +c iwa is an integer working array of length 3nmax. +c +c task is a working string of characters of length 60 indicating +c the current job when entering and quitting this subroutine. +c +c iprint is an integer variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c csave is a working string of characters of length 60. +c +c lsave is a logical working array of dimension 4. +c On exit with 'task' = NEW_X, the following information is +c available: +c If lsave(1) = .true. then the initial X has been replaced by +c its projection in the feasible set; +c If lsave(2) = .true. then the problem is constrained; +c If lsave(3) = .true. then each variable has upper and lower +c bounds; +c +c isave is an integer working array of dimension 44. +c On exit with 'task' = NEW_X, the following information is +c available: +c isave(22) = the total number of intervals explored in the +c search of Cauchy points; +c isave(26) = the total number of skipped BFGS updates before +c the current iteration; +c isave(30) = the number of current iteration; +c isave(31) = the total number of BFGS updates prior the current +c iteration; +c isave(33) = the number of intervals explored in the search of +c Cauchy point in the current iteration; +c isave(34) = the total number of function and gradient +c evaluations; +c isave(36) = the number of function value or gradient +c evaluations in the current iteration; +c if isave(37) = 0 then the subspace argmin is within the box; +c if isave(37) = 1 then the subspace argmin is beyond the box; +c isave(38) = the number of free variables in the current +c iteration; +c isave(39) = the number of active constraints in the current +c iteration; +c n + 1 - isave(40) = the number of variables leaving the set of +c active constraints in the current iteration; +c isave(41) = the number of variables entering the set of active +c constraints in the current iteration. +c +c dsave is a double precision working array of dimension 29. +c On exit with 'task' = NEW_X, the following information is +c available: +c dsave(1) = current 'theta' in the BFGS matrix; +c dsave(2) = f(x) in the previous iteration; +c dsave(3) = factr*epsmch; +c dsave(4) = 2-norm of the line search direction vector; +c dsave(5) = the machine precision epsmch generated by the code; +c dsave(7) = the accumulated time spent on searching for +c Cauchy points; +c dsave(8) = the accumulated time spent on +c subspace minimization; +c dsave(9) = the accumulated time spent on line search; +c dsave(11) = the slope of the line search function at +c the current point of line search; +c dsave(12) = the maximum relative step length imposed in +c line search; +c dsave(13) = the infinity norm of the projected gradient; +c dsave(14) = the relative step length in the line search; +c dsave(15) = the slope of the line search function at +c the starting point of the line search; +c dsave(16) = the square of the 2-norm of the line search +c direction vector. +c +c Subprograms called: +c +c L-BFGS-B Library ... mainlb. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: a +c limited memory FORTRAN code for solving bound constrained +c optimization problems'', Tech. Report, NAM-11, EECS Department, +c Northwestern University, 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ +c-jlm-jn + integer lws,lr,lz,lt,ld,lxp,lwa, + + lwy,lsy,lss,lwt,lwn,lsnd + + if (task .eq. 'START') then + isave(1) = m*n + isave(2) = m**2 + isave(3) = 4*m**2 + isave(4) = 1 ! ws m*n + isave(5) = isave(4) + isave(1) ! wy m*n + isave(6) = isave(5) + isave(1) ! wsy m**2 + isave(7) = isave(6) + isave(2) ! wss m**2 + isave(8) = isave(7) + isave(2) ! wt m**2 + isave(9) = isave(8) + isave(2) ! wn 4*m**2 + isave(10) = isave(9) + isave(3) ! wsnd 4*m**2 + isave(11) = isave(10) + isave(3) ! wz n + isave(12) = isave(11) + n ! wr n + isave(13) = isave(12) + n ! wd n + isave(14) = isave(13) + n ! wt n + isave(15) = isave(14) + n ! wxp n + isave(16) = isave(15) + n ! wa 8*m + endif + lws = isave(4) + lwy = isave(5) + lsy = isave(6) + lss = isave(7) + lwt = isave(8) + lwn = isave(9) + lsnd = isave(10) + lz = isave(11) + lr = isave(12) + ld = isave(13) + lt = isave(14) + lxp = isave(15) + lwa = isave(16) + + call mainlb(n,m,x,l,u,nbd,f,g,factr,pgtol, + + wa(lws),wa(lwy),wa(lsy),wa(lss), wa(lwt), + + wa(lwn),wa(lsnd),wa(lz),wa(lr),wa(ld),wa(lt),wa(lxp), + + wa(lwa), + + iwa(1),iwa(n+1),iwa(2*n+1),task,iprint, + + csave,lsave,isave(22),dsave) + + return + + end + +c======================= The end of setulb ============================= + + subroutine mainlb(n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, + + sy, ss, wt, wn, snd, z, r, d, t, xp, wa, + + index, iwhere, indx2, task, + + iprint, csave, lsave, isave, dsave) + implicit none + character*60 task, csave + logical lsave(4) + integer n, m, iprint, nbd(n), index(n), + + iwhere(n), indx2(n), isave(23) + double precision f, factr, pgtol, + + x(n), l(n), u(n), g(n), z(n), r(n), d(n), t(n), +c-jlm-jn + + xp(n), + + wa(8*m), + + ws(n, m), wy(n, m), sy(m, m), ss(m, m), + + wt(m, m), wn(2*m, 2*m), snd(2*m, 2*m), dsave(29) + +c ************ +c +c Subroutine mainlb +c +c This subroutine solves bound constrained optimization problems by +c using the compact formula of the limited memory BFGS updates. +c +c n is an integer variable. +c On entry n is the number of variables. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric +c corrections allowed in the limited memory matrix. +c On exit m is unchanged. +c +c x is a double precision array of dimension n. +c On entry x is an approximation to the solution. +c On exit x is the current approximation. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c f is a double precision variable. +c On first entry f is unspecified. +c On final exit f is the value of the function at x. +c +c g is a double precision array of dimension n. +c On first entry g is unspecified. +c On final exit g is the value of the gradient at x. +c +c factr is a double precision variable. +c On entry factr >= 0 is specified by the user. The iteration +c will stop when +c +c (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch +c +c where epsmch is the machine precision, which is automatically +c generated by the code. +c On exit factr is unchanged. +c +c pgtol is a double precision variable. +c On entry pgtol >= 0 is specified by the user. The iteration +c will stop when +c +c max{|proj g_i | i = 1, ..., n} <= pgtol +c +c where pg_i is the ith component of the projected gradient. +c On exit pgtol is unchanged. +c +c ws, wy, sy, and wt are double precision working arrays used to +c store the following information defining the limited memory +c BFGS matrix: +c ws, of dimension n x m, stores S, the matrix of s-vectors; +c wy, of dimension n x m, stores Y, the matrix of y-vectors; +c sy, of dimension m x m, stores S'Y; +c ss, of dimension m x m, stores S'S; +c yy, of dimension m x m, stores Y'Y; +c wt, of dimension m x m, stores the Cholesky factorization +c of (theta*S'S+LD^(-1)L'); see eq. +c (2.26) in [3]. +c +c wn is a double precision working array of dimension 2m x 2m +c used to store the LEL^T factorization of the indefinite matrix +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c where E = [-I 0] +c [ 0 I] +c +c snd is a double precision working array of dimension 2m x 2m +c used to store the lower triangular part of +c N = [Y' ZZ'Y L_a'+R_z'] +c [L_a +R_z S'AA'S ] +c +c z(n),r(n),d(n),t(n), xp(n),wa(8*m) are double precision working arrays. +c z is used at different times to store the Cauchy point and +c the Newton point. +c xp is used to safeguard the projected Newton direction +c +c sg(m),sgo(m),yg(m),ygo(m) are double precision working arrays. +c +c index is an integer working array of dimension n. +c In subroutine freev, index is used to store the free and fixed +c variables at the Generalized Cauchy Point (GCP). +c +c iwhere is an integer working array of dimension n used to record +c the status of the vector x for GCP computation. +c iwhere(i)=0 or -3 if x(i) is free and has bounds, +c 1 if x(i) is fixed at l(i), and l(i) .ne. u(i) +c 2 if x(i) is fixed at u(i), and u(i) .ne. l(i) +c 3 if x(i) is always fixed, i.e., u(i)=x(i)=l(i) +c -1 if x(i) is always free, i.e., no bounds on it. +c +c indx2 is an integer working array of dimension n. +c Within subroutine cauchy, indx2 corresponds to the array iorder. +c In subroutine freev, a list of variables entering and leaving +c the free set is stored in indx2, and it is passed on to +c subroutine formk with this information. +c +c task is a working string of characters of length 60 indicating +c the current job when entering and leaving this subroutine. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c csave is a working string of characters of length 60. +c +c lsave is a logical working array of dimension 4. +c +c isave is an integer working array of dimension 23. +c +c dsave is a double precision working array of dimension 29. +c +c +c Subprograms called +c +c L-BFGS-B Library ... cauchy, subsm, lnsrlb, formk, +c +c errclb, prn1lb, prn2lb, prn3lb, active, projgr, +c +c freev, cmprlb, matupd, formt. +c +c Minpack2 Library ... timer +c +c Linpack Library ... dcopy, ddot. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN +c Subroutines for Large Scale Bound Constrained Optimization'' +c Tech. Report, NAM-11, EECS Department, Northwestern University, +c 1994. +c +c [3] R. Byrd, J. Nocedal and R. Schnabel "Representations of +c Quasi-Newton Matrices and their use in Limited Memory Methods'', +c Mathematical Programming 63 (1994), no. 4, pp. 129-156. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + logical prjctd,cnstnd,boxed,updatd,wrk + character*3 word + integer i,k,nintol,itfile,iback,nskip, + + head,col,iter,itail,iupdat, + + nseg,nfgv,info,ifun, + + iword,nfree,nact,ileave,nenter + double precision theta,fold,ddot,dr,rr,tol, + + xstep,sbgnrm,ddum,dnorm,dtd,epsmch, + + cpu1,cpu2,cachyt,sbtime,lnscht,time1,time2, + + gd,gdold,stp,stpmx,time + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + + if (task .eq. 'START') then + + epsmch = epsilon(one) + + call timer(time1) + +c Initialize counters and scalars when task='START'. + +c for the limited memory BFGS matrices: + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + iback = 0 + itail = 0 + iword = 0 + nact = 0 + ileave = 0 + nenter = 0 + fold = zero + dnorm = zero + cpu1 = zero + gd = zero + stpmx = zero + sbgnrm = zero + stp = zero + gdold = zero + dtd = zero + +c for operation counts: + iter = 0 + nfgv = 0 + nseg = 0 + nintol = 0 + nskip = 0 + nfree = n + ifun = 0 +c for stopping tolerance: + tol = factr*epsmch + +c for measuring running time: + cachyt = 0 + sbtime = 0 + lnscht = 0 + +c 'word' records the status of subspace solutions. + word = '---' + +c 'info' records the termination information. + info = 0 + + itfile = 8 + if (iprint .ge. 1) then +c open a summary file 'iterate.dat' + open (8, file = 'iterate.dat', status = 'unknown') + endif + +c Check the input arguments for errors. + + call errclb(n,m,factr,l,u,nbd,task,info,k) + if (task(1:5) .eq. 'ERROR') then + call prn3lb(n,x,f,task,iprint,info,itfile, + + iter,nfgv,nintol,nskip,nact,sbgnrm, + + zero,nseg,word,iback,stp,xstep,k, + + cachyt,sbtime,lnscht) + return + endif + + call prn1lb(n,m,l,u,x,iprint,itfile,epsmch) + +c Initialize iwhere & project x onto the feasible set. + + call active(n,l,u,nbd,x,iwhere,iprint,prjctd,cnstnd,boxed) + +c The end of the initialization. + + else +c restore local variables. + + prjctd = lsave(1) + cnstnd = lsave(2) + boxed = lsave(3) + updatd = lsave(4) + + nintol = isave(1) + itfile = isave(3) + iback = isave(4) + nskip = isave(5) + head = isave(6) + col = isave(7) + itail = isave(8) + iter = isave(9) + iupdat = isave(10) + nseg = isave(12) + nfgv = isave(13) + info = isave(14) + ifun = isave(15) + iword = isave(16) + nfree = isave(17) + nact = isave(18) + ileave = isave(19) + nenter = isave(20) + + theta = dsave(1) + fold = dsave(2) + tol = dsave(3) + dnorm = dsave(4) + epsmch = dsave(5) + cpu1 = dsave(6) + cachyt = dsave(7) + sbtime = dsave(8) + lnscht = dsave(9) + time1 = dsave(10) + gd = dsave(11) + stpmx = dsave(12) + sbgnrm = dsave(13) + stp = dsave(14) + gdold = dsave(15) + dtd = dsave(16) + +c After returning from the driver go to the point where execution +c is to resume. + + if (task(1:5) .eq. 'FG_LN') goto 666 + if (task(1:5) .eq. 'NEW_X') goto 777 + if (task(1:5) .eq. 'FG_ST') goto 111 + if (task(1:4) .eq. 'STOP') then + if (task(7:9) .eq. 'CPU') then +c restore the previous iterate. + call dcopy(n,t,1,x,1) + call dcopy(n,r,1,g,1) + f = fold + endif + goto 999 + endif + endif + +c Compute f0 and g0. + + task = 'FG_START' +c return to the driver to calculate f and g; reenter at 111. + goto 1000 + 111 continue + nfgv = 1 + +c Compute the infinity norm of the (-) projected gradient. + + call projgr(n,l,u,nbd,x,g,sbgnrm) + + if (iprint .ge. 1) then + write (6,1002) iter,f,sbgnrm + write (itfile,1003) iter,nfgv,sbgnrm,f + endif + if (sbgnrm .le. pgtol) then +c terminate the algorithm. + task = 'CONVERGENCE: NORM_OF_PROJECTED_GRADIENT_<=_PGTOL' + goto 999 + endif + +c ----------------- the beginning of the loop -------------------------- + + 222 continue + if (iprint .ge. 99) write (6,1001) iter + 1 + iword = -1 +c + if (.not. cnstnd .and. col .gt. 0) then +c skip the search for GCP. + call dcopy(n,x,1,z,1) + wrk = updatd + nseg = 0 + goto 333 + endif + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Compute the Generalized Cauchy Point (GCP). +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + call timer(cpu1) + call cauchy(n,x,l,u,nbd,g,indx2,iwhere,t,d,z, + + m,wy,ws,sy,wt,theta,col,head, + + wa(1),wa(2*m+1),wa(4*m+1),wa(6*m+1),nseg, + + iprint, sbgnrm, info, epsmch) + if (info .ne. 0) then +c singular triangular system detected; refresh the lbfgs memory. + if(iprint .ge. 1) write (6, 1005) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + cachyt = cachyt + cpu2 - cpu1 + goto 222 + endif + call timer(cpu2) + cachyt = cachyt + cpu2 - cpu1 + nintol = nintol + nseg + +c Count the entering and leaving variables for iter > 0; +c find the index set of free and active variables at the GCP. + + call freev(n,nfree,index,nenter,ileave,indx2, + + iwhere,wrk,updatd,cnstnd,iprint,iter) + nact = n - nfree + + 333 continue + +c If there are no free variables or B=theta*I, then +c skip the subspace minimization. + + if (nfree .eq. 0 .or. col .eq. 0) goto 555 + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Subspace minimization. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + call timer(cpu1) + +c Form the LEL^T factorization of the indefinite +c matrix K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] + + if (wrk) call formk(n,nfree,index,nenter,ileave,indx2,iupdat, + + updatd,wn,snd,m,ws,wy,sy,theta,col,head,info) + if (info .ne. 0) then +c nonpositive definiteness in Cholesky factorization; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1006) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + goto 222 + endif + +c compute r=-Z'B(xcp-xk)-Z'g (using wa(2m+1)=W'(xcp-x) +c from 'cauchy'). + call cmprlb(n,m,x,g,ws,wy,sy,wt,z,r,wa,index, + + theta,col,head,nfree,cnstnd,info) + if (info .ne. 0) goto 444 + +c-jlm-jn call the direct method. + + call subsm( n, m, nfree, index, l, u, nbd, z, r, xp, ws, wy, + + theta, x, g, col, head, iword, wa, wn, iprint, info) + 444 continue + if (info .ne. 0) then +c singular triangular system detected; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1005) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + goto 222 + endif + + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + 555 continue + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Line search and optimality tests. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c Generate the search direction d:=z-x. + + do 40 i = 1, n + d(i) = z(i) - x(i) + 40 continue + call timer(cpu1) + 666 continue + call lnsrlb(n,l,u,nbd,x,f,fold,gd,gdold,g,d,r,t,z,stp,dnorm, + + dtd,xstep,stpmx,iter,ifun,iback,nfgv,info,task, + + boxed,cnstnd,csave,isave(22),dsave(17)) + if (info .ne. 0 .or. iback .ge. 20) then +c restore the previous iterate. + call dcopy(n,t,1,x,1) + call dcopy(n,r,1,g,1) + f = fold + if (col .eq. 0) then +c abnormal termination. + if (info .eq. 0) then + info = -9 +c restore the actual number of f and g evaluations etc. + nfgv = nfgv - 1 + ifun = ifun - 1 + iback = iback - 1 + endif + task = 'ABNORMAL_TERMINATION_IN_LNSRCH' + iter = iter + 1 + goto 999 + else +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1008) + if (info .eq. 0) nfgv = nfgv - 1 + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + task = 'RESTART_FROM_LNSRCH' + call timer(cpu2) + lnscht = lnscht + cpu2 - cpu1 + goto 222 + endif + else if (task(1:5) .eq. 'FG_LN') then +c return to the driver for calculating f and g; reenter at 666. + goto 1000 + else +c calculate and print out the quantities related to the new X. + call timer(cpu2) + lnscht = lnscht + cpu2 - cpu1 + iter = iter + 1 + +c Compute the infinity norm of the projected (-)gradient. + + call projgr(n,l,u,nbd,x,g,sbgnrm) + +c Print iteration information. + + call prn2lb(n,x,f,g,iprint,itfile,iter,nfgv,nact, + + sbgnrm,nseg,word,iword,iback,stp,xstep) + goto 1000 + endif + 777 continue + +c Test for termination. + + if (sbgnrm .le. pgtol) then +c terminate the algorithm. + task = 'CONVERGENCE: NORM_OF_PROJECTED_GRADIENT_<=_PGTOL' + goto 999 + endif + + ddum = max(abs(fold), abs(f), one) + if ((fold - f) .le. tol*ddum) then +c terminate the algorithm. + task = 'CONVERGENCE: REL_REDUCTION_OF_F_<=_FACTR*EPSMCH' + if (iback .ge. 10) info = -5 +c i.e., to issue a warning if iback>10 in the line search. + goto 999 + endif + +c Compute d=newx-oldx, r=newg-oldg, rr=y'y and dr=y's. + + do 42 i = 1, n + r(i) = g(i) - r(i) + 42 continue + rr = ddot(n,r,1,r,1) + if (stp .eq. one) then + dr = gd - gdold + ddum = -gdold + else + dr = (gd - gdold)*stp + call dscal(n,stp,d,1) + ddum = -gdold*stp + endif + + if (dr .le. epsmch*ddum) then +c skip the L-BFGS update. + nskip = nskip + 1 + updatd = .false. + if (iprint .ge. 1) write (6,1004) dr, ddum + goto 888 + endif + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Update the L-BFGS matrix. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + updatd = .true. + iupdat = iupdat + 1 + +c Update matrices WS and WY and form the middle matrix in B. + + call matupd(n,m,ws,wy,sy,ss,d,r,itail, + + iupdat,col,head,theta,rr,dr,stp,dtd) + +c Form the upper half of the pds T = theta*SS + L*D^(-1)*L'; +c Store T in the upper triangular of the array wt; +c Cholesky factorize T to J*J' with +c J' stored in the upper triangular of wt. + + call formt(m,wt,sy,ss,col,theta,info) + + if (info .ne. 0) then +c nonpositive definiteness in Cholesky factorization; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1007) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + goto 222 + endif + +c Now the inverse of the middle matrix in B is + +c [ D^(1/2) O ] [ -D^(1/2) D^(-1/2)*L' ] +c [ -L*D^(-1/2) J ] [ 0 J' ] + + 888 continue + +c -------------------- the end of the loop ----------------------------- + + goto 222 + 999 continue + call timer(time2) + time = time2 - time1 + call prn3lb(n,x,f,task,iprint,info,itfile, + + iter,nfgv,nintol,nskip,nact,sbgnrm, + + time,nseg,word,iback,stp,xstep,k, + + cachyt,sbtime,lnscht) + 1000 continue + +c Save local variables. + + lsave(1) = prjctd + lsave(2) = cnstnd + lsave(3) = boxed + lsave(4) = updatd + + isave(1) = nintol + isave(3) = itfile + isave(4) = iback + isave(5) = nskip + isave(6) = head + isave(7) = col + isave(8) = itail + isave(9) = iter + isave(10) = iupdat + isave(12) = nseg + isave(13) = nfgv + isave(14) = info + isave(15) = ifun + isave(16) = iword + isave(17) = nfree + isave(18) = nact + isave(19) = ileave + isave(20) = nenter + + dsave(1) = theta + dsave(2) = fold + dsave(3) = tol + dsave(4) = dnorm + dsave(5) = epsmch + dsave(6) = cpu1 + dsave(7) = cachyt + dsave(8) = sbtime + dsave(9) = lnscht + dsave(10) = time1 + dsave(11) = gd + dsave(12) = stpmx + dsave(13) = sbgnrm + dsave(14) = stp + dsave(15) = gdold + dsave(16) = dtd + + 1001 format (//,'ITERATION ',i5) + 1002 format + + (/,'At iterate',i5,4x,'f= ',1p,d12.5,4x,'|proj g|= ',1p,d12.5) + 1003 format (2(1x,i4),5x,'-',5x,'-',3x,'-',5x,'-',5x,'-',8x,'-',3x, + + 1p,2(1x,d10.3)) + 1004 format (' ys=',1p,e10.3,' -gs=',1p,e10.3,' BFGS update SKIPPED') + 1005 format (/, + +' Singular triangular system detected;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1006 format (/, + +' Nonpositive definiteness in Cholesky factorization in formk;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1007 format (/, + +' Nonpositive definiteness in Cholesky factorization in formt;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1008 format (/, + +' Bad direction in the line search;',/, + +' refresh the lbfgs memory and restart the iteration.') + + return + + end + +c======================= The end of mainlb ============================= + + subroutine active(n, l, u, nbd, x, iwhere, iprint, + + prjctd, cnstnd, boxed) + + logical prjctd, cnstnd, boxed + integer n, iprint, nbd(n), iwhere(n) + double precision x(n), l(n), u(n) + +c ************ +c +c Subroutine active +c +c This subroutine initializes iwhere and projects the initial x to +c the feasible set if necessary. +c +c iwhere is an integer array of dimension n. +c On entry iwhere is unspecified. +c On exit iwhere(i)=-1 if x(i) has no bounds +c 3 if l(i)=u(i) +c 0 otherwise. +c In cauchy, iwhere is given finer gradations. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer nbdd,i + double precision zero + parameter (zero=0.0d0) + +c Initialize nbdd, prjctd, cnstnd and boxed. + + nbdd = 0 + prjctd = .false. + cnstnd = .false. + boxed = .true. + +c Project the initial x to the easible set if necessary. + + do 10 i = 1, n + if (nbd(i) .gt. 0) then + if (nbd(i) .le. 2 .and. x(i) .le. l(i)) then + if (x(i) .lt. l(i)) then + prjctd = .true. + x(i) = l(i) + endif + nbdd = nbdd + 1 + else if (nbd(i) .ge. 2 .and. x(i) .ge. u(i)) then + if (x(i) .gt. u(i)) then + prjctd = .true. + x(i) = u(i) + endif + nbdd = nbdd + 1 + endif + endif + 10 continue + +c Initialize iwhere and assign values to cnstnd and boxed. + + do 20 i = 1, n + if (nbd(i) .ne. 2) boxed = .false. + if (nbd(i) .eq. 0) then +c this variable is always free + iwhere(i) = -1 + +c otherwise set x(i)=mid(x(i), u(i), l(i)). + else + cnstnd = .true. + if (nbd(i) .eq. 2 .and. u(i) - l(i) .le. zero) then +c this variable is always fixed + iwhere(i) = 3 + else + iwhere(i) = 0 + endif + endif + 20 continue + + if (iprint .ge. 0) then + if (prjctd) write (6,*) + + 'The initial X is infeasible. Restart with its projection.' + if (.not. cnstnd) + + write (6,*) 'This problem is unconstrained.' + endif + + if (iprint .gt. 0) write (6,1001) nbdd + + 1001 format (/,'At X0 ',i9,' variables are exactly at the bounds') + + return + + end + +c======================= The end of active ============================= + + subroutine bmv(m, sy, wt, col, v, p, info) + + integer m, col, info + double precision sy(m, m), wt(m, m), v(2*col), p(2*col) + +c ************ +c +c Subroutine bmv +c +c This subroutine computes the product of the 2m x 2m middle matrix +c in the compact L-BFGS formula of B and a 2m vector v; +c it returns the product in p. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c sy is a double precision array of dimension m x m. +c On entry sy specifies the matrix S'Y. +c On exit sy is unchanged. +c +c wt is a double precision array of dimension m x m. +c On entry wt specifies the upper triangular matrix J' which is +c the Cholesky factor of (thetaS'S+LD^(-1)L'). +c On exit wt is unchanged. +c +c col is an integer variable. +c On entry col specifies the number of s-vectors (or y-vectors) +c stored in the compact L-BFGS formula. +c On exit col is unchanged. +c +c v is a double precision array of dimension 2col. +c On entry v specifies vector v. +c On exit v is unchanged. +c +c p is a double precision array of dimension 2col. +c On entry p is unspecified. +c On exit p is the product Mv. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return, +c = nonzero for abnormal return when the system +c to be solved by dtrsl is singular. +c +c Subprograms called: +c +c Linpack ... dtrsl. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,k,i2 + double precision sum + + if (col .eq. 0) return + +c PART I: solve [ D^(1/2) O ] [ p1 ] = [ v1 ] +c [ -L*D^(-1/2) J ] [ p2 ] [ v2 ]. + +c solve Jp2=v2+LD^(-1)v1. + p(col + 1) = v(col + 1) + do 20 i = 2, col + i2 = col + i + sum = 0.0d0 + do 10 k = 1, i - 1 + sum = sum + sy(i,k)*v(k)/sy(k,k) + 10 continue + p(i2) = v(i2) + sum + 20 continue +c Solve the triangular system + call dtrsl(wt,m,col,p(col+1),11,info) + if (info .ne. 0) return + +c solve D^(1/2)p1=v1. + do 30 i = 1, col + p(i) = v(i)/sqrt(sy(i,i)) + 30 continue + +c PART II: solve [ -D^(1/2) D^(-1/2)*L' ] [ p1 ] = [ p1 ] +c [ 0 J' ] [ p2 ] [ p2 ]. + +c solve J^Tp2=p2. + call dtrsl(wt,m,col,p(col+1),01,info) + if (info .ne. 0) return + +c compute p1=-D^(-1/2)(p1-D^(-1/2)L'p2) +c =-D^(-1/2)p1+D^(-1)L'p2. + do 40 i = 1, col + p(i) = -p(i)/sqrt(sy(i,i)) + 40 continue + do 60 i = 1, col + sum = 0.d0 + do 50 k = i + 1, col + sum = sum + sy(k,i)*p(col+k)/sy(i,i) + 50 continue + p(i) = p(i) + sum + 60 continue + + return + + end + +c======================== The end of bmv =============================== + + subroutine cauchy(n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, + + m, wy, ws, sy, wt, theta, col, head, p, c, wbp, + + v, nseg, iprint, sbgnrm, info, epsmch) + implicit none + integer n, m, head, col, nseg, iprint, info, + + nbd(n), iorder(n), iwhere(n) + double precision theta, epsmch, + + x(n), l(n), u(n), g(n), t(n), d(n), xcp(n), + + wy(n, col), ws(n, col), sy(m, m), + + wt(m, m), p(2*m), c(2*m), wbp(2*m), v(2*m) + +c ************ +c +c Subroutine cauchy +c +c For given x, l, u, g (with sbgnrm > 0), and a limited memory +c BFGS matrix B defined in terms of matrices WY, WS, WT, and +c scalars head, col, and theta, this subroutine computes the +c generalized Cauchy point (GCP), defined as the first local +c minimizer of the quadratic +c +c Q(x + s) = g's + 1/2 s'Bs +c +c along the projected gradient direction P(x-tg,l,u). +c The routine returns the GCP in xcp. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c x is a double precision array of dimension n. +c On entry x is the starting point for the GCP computation. +c On exit x is unchanged. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c g is a double precision array of dimension n. +c On entry g is the gradient of f(x). g must be a nonzero vector. +c On exit g is unchanged. +c +c iorder is an integer working array of dimension n. +c iorder will be used to store the breakpoints in the piecewise +c linear path and free variables encountered. On exit, +c iorder(1),...,iorder(nleft) are indices of breakpoints +c which have not been encountered; +c iorder(nleft+1),...,iorder(nbreak) are indices of +c encountered breakpoints; and +c iorder(nfree),...,iorder(n) are indices of variables which +c have no bound constraits along the search direction. +c +c iwhere is an integer array of dimension n. +c On entry iwhere indicates only the permanently fixed (iwhere=3) +c or free (iwhere= -1) components of x. +c On exit iwhere records the status of the current x variables. +c iwhere(i)=-3 if x(i) is free and has bounds, but is not moved +c 0 if x(i) is free and has bounds, and is moved +c 1 if x(i) is fixed at l(i), and l(i) .ne. u(i) +c 2 if x(i) is fixed at u(i), and u(i) .ne. l(i) +c 3 if x(i) is always fixed, i.e., u(i)=x(i)=l(i) +c -1 if x(i) is always free, i.e., it has no bounds. +c +c t is a double precision working array of dimension n. +c t will be used to store the break points. +c +c d is a double precision array of dimension n used to store +c the Cauchy direction P(x-tg)-x. +c +c xcp is a double precision array of dimension n used to return the +c GCP on exit. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c ws, wy, sy, and wt are double precision arrays. +c On entry they store information that defines the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c sy(m,m) stores S'Y; +c wt(m,m) stores the +c Cholesky factorization of (theta*S'S+LD^(-1)L'). +c On exit these arrays are unchanged. +c +c theta is a double precision variable. +c On entry theta is the scaling factor specifying B_0 = theta I. +c On exit theta is unchanged. +c +c col is an integer variable. +c On entry col is the actual number of variable metric +c corrections stored so far. +c On exit col is unchanged. +c +c head is an integer variable. +c On entry head is the location of the first s-vector (or y-vector) +c in S (or Y). +c On exit col is unchanged. +c +c p is a double precision working array of dimension 2m. +c p will be used to store the vector p = W^(T)d. +c +c c is a double precision working array of dimension 2m. +c c will be used to store the vector c = W^(T)(xcp-x). +c +c wbp is a double precision working array of dimension 2m. +c wbp will be used to store the row of W corresponding +c to a breakpoint. +c +c v is a double precision working array of dimension 2m. +c +c nseg is an integer variable. +c On exit nseg records the number of quadratic segments explored +c in searching for the GCP. +c +c sg and yg are double precision arrays of dimension m. +c On entry sg and yg store S'g and Y'g correspondingly. +c On exit they are unchanged. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c sbgnrm is a double precision variable. +c On entry sbgnrm is the norm of the projected gradient at x. +c On exit sbgnrm is unchanged. +c +c info is an integer variable. +c On entry info is 0. +c On exit info = 0 for normal return, +c = nonzero for abnormal return when the the system +c used in routine bmv is singular. +c +c Subprograms called: +c +c L-BFGS-B Library ... hpsolb, bmv. +c +c Linpack ... dscal dcopy, daxpy. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN +c Subroutines for Large Scale Bound Constrained Optimization'' +c Tech. Report, NAM-11, EECS Department, Northwestern University, +c 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + logical xlower,xupper,bnded + integer i,j,col2,nfree,nbreak,pointr, + + ibp,nleft,ibkmin,iter + double precision f1,f2,dt,dtm,tsum,dibp,zibp,dibp2,bkmin, + + tu,tl,wmc,wmp,wmw,ddot,tj,tj0,neggi,sbgnrm, + + f2_org + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + +c Check the status of the variables, reset iwhere(i) if necessary; +c compute the Cauchy direction d and the breakpoints t; initialize +c the derivative f1 and the vector p = W'd (for theta = 1). + + if (sbgnrm .le. zero) then + if (iprint .ge. 0) write (6,*) 'Subgnorm = 0. GCP = X.' + call dcopy(n,x,1,xcp,1) + return + endif + bnded = .true. + nfree = n + 1 + nbreak = 0 + ibkmin = 0 + bkmin = zero + col2 = 2*col + f1 = zero + if (iprint .ge. 99) write (6,3010) + +c We set p to zero and build it up as we determine d. + + do 20 i = 1, col2 + p(i) = zero + 20 continue + +c In the following loop we determine for each variable its bound +c status and its breakpoint, and update p accordingly. +c Smallest breakpoint is identified. + + do 50 i = 1, n + neggi = -g(i) + if (iwhere(i) .ne. 3 .and. iwhere(i) .ne. -1) then +c if x(i) is not a constant and has bounds, +c compute the difference between x(i) and its bounds. + if (nbd(i) .le. 2) tl = x(i) - l(i) + if (nbd(i) .ge. 2) tu = u(i) - x(i) + +c If a variable is close enough to a bound +c we treat it as at bound. + xlower = nbd(i) .le. 2 .and. tl .le. zero + xupper = nbd(i) .ge. 2 .and. tu .le. zero + +c reset iwhere(i). + iwhere(i) = 0 + if (xlower) then + if (neggi .le. zero) iwhere(i) = 1 + else if (xupper) then + if (neggi .ge. zero) iwhere(i) = 2 + else + if (abs(neggi) .le. zero) iwhere(i) = -3 + endif + endif + pointr = head + if (iwhere(i) .ne. 0 .and. iwhere(i) .ne. -1) then + d(i) = zero + else + d(i) = neggi + f1 = f1 - neggi*neggi +c calculate p := p - W'e_i* (g_i). + do 40 j = 1, col + p(j) = p(j) + wy(i,pointr)* neggi + p(col + j) = p(col + j) + ws(i,pointr)*neggi + pointr = mod(pointr,m) + 1 + 40 continue + if (nbd(i) .le. 2 .and. nbd(i) .ne. 0 + + .and. neggi .lt. zero) then +c x(i) + d(i) is bounded; compute t(i). + nbreak = nbreak + 1 + iorder(nbreak) = i + t(nbreak) = tl/(-neggi) + if (nbreak .eq. 1 .or. t(nbreak) .lt. bkmin) then + bkmin = t(nbreak) + ibkmin = nbreak + endif + else if (nbd(i) .ge. 2 .and. neggi .gt. zero) then +c x(i) + d(i) is bounded; compute t(i). + nbreak = nbreak + 1 + iorder(nbreak) = i + t(nbreak) = tu/neggi + if (nbreak .eq. 1 .or. t(nbreak) .lt. bkmin) then + bkmin = t(nbreak) + ibkmin = nbreak + endif + else +c x(i) + d(i) is not bounded. + nfree = nfree - 1 + iorder(nfree) = i + if (abs(neggi) .gt. zero) bnded = .false. + endif + endif + 50 continue + +c The indices of the nonzero components of d are now stored +c in iorder(1),...,iorder(nbreak) and iorder(nfree),...,iorder(n). +c The smallest of the nbreak breakpoints is in t(ibkmin)=bkmin. + + if (theta .ne. one) then +c complete the initialization of p for theta not= one. + call dscal(col,theta,p(col+1),1) + endif + +c Initialize GCP xcp = x. + + call dcopy(n,x,1,xcp,1) + + if (nbreak .eq. 0 .and. nfree .eq. n + 1) then +c is a zero vector, return with the initial xcp as GCP. + if (iprint .gt. 100) write (6,1010) (xcp(i), i = 1, n) + return + endif + +c Initialize c = W'(xcp - x) = 0. + + do 60 j = 1, col2 + c(j) = zero + 60 continue + +c Initialize derivative f2. + + f2 = -theta*f1 + f2_org = f2 + if (col .gt. 0) then + call bmv(m,sy,wt,col,p,v,info) + if (info .ne. 0) return + f2 = f2 - ddot(col2,v,1,p,1) + endif + dtm = -f1/f2 + tsum = zero + nseg = 1 + if (iprint .ge. 99) + + write (6,*) 'There are ',nbreak,' breakpoints ' + +c If there are no breakpoints, locate the GCP and return. + + if (nbreak .eq. 0) goto 888 + + nleft = nbreak + iter = 1 + + + tj = zero + +c------------------- the beginning of the loop ------------------------- + + 777 continue + +c Find the next smallest breakpoint; +c compute dt = t(nleft) - t(nleft + 1). + + tj0 = tj + if (iter .eq. 1) then +c Since we already have the smallest breakpoint we need not do +c heapsort yet. Often only one breakpoint is used and the +c cost of heapsort is avoided. + tj = bkmin + ibp = iorder(ibkmin) + else + if (iter .eq. 2) then +c Replace the already used smallest breakpoint with the +c breakpoint numbered nbreak > nlast, before heapsort call. + if (ibkmin .ne. nbreak) then + t(ibkmin) = t(nbreak) + iorder(ibkmin) = iorder(nbreak) + endif +c Update heap structure of breakpoints +c (if iter=2, initialize heap). + endif + call hpsolb(nleft,t,iorder,iter-2) + tj = t(nleft) + ibp = iorder(nleft) + endif + + dt = tj - tj0 + + if (dt .ne. zero .and. iprint .ge. 100) then + write (6,4011) nseg,f1,f2 + write (6,5010) dt + write (6,6010) dtm + endif + +c If a minimizer is within this interval, locate the GCP and return. + + if (dtm .lt. dt) goto 888 + +c Otherwise fix one variable and +c reset the corresponding component of d to zero. + + tsum = tsum + dt + nleft = nleft - 1 + iter = iter + 1 + dibp = d(ibp) + d(ibp) = zero + if (dibp .gt. zero) then + zibp = u(ibp) - x(ibp) + xcp(ibp) = u(ibp) + iwhere(ibp) = 2 + else + zibp = l(ibp) - x(ibp) + xcp(ibp) = l(ibp) + iwhere(ibp) = 1 + endif + if (iprint .ge. 100) write (6,*) 'Variable ',ibp,' is fixed.' + if (nleft .eq. 0 .and. nbreak .eq. n) then +c all n variables are fixed, +c return with xcp as GCP. + dtm = dt + goto 999 + endif + +c Update the derivative information. + + nseg = nseg + 1 + dibp2 = dibp**2 + +c Update f1 and f2. + +c temporarily set f1 and f2 for col=0. + f1 = f1 + dt*f2 + dibp2 - theta*dibp*zibp + f2 = f2 - theta*dibp2 + + if (col .gt. 0) then +c update c = c + dt*p. + call daxpy(col2,dt,p,1,c,1) + +c choose wbp, +c the row of W corresponding to the breakpoint encountered. + pointr = head + do 70 j = 1,col + wbp(j) = wy(ibp,pointr) + wbp(col + j) = theta*ws(ibp,pointr) + pointr = mod(pointr,m) + 1 + 70 continue + +c compute (wbp)Mc, (wbp)Mp, and (wbp)M(wbp)'. + call bmv(m,sy,wt,col,wbp,v,info) + if (info .ne. 0) return + wmc = ddot(col2,c,1,v,1) + wmp = ddot(col2,p,1,v,1) + wmw = ddot(col2,wbp,1,v,1) + +c update p = p - dibp*wbp. + call daxpy(col2,-dibp,wbp,1,p,1) + +c complete updating f1 and f2 while col > 0. + f1 = f1 + dibp*wmc + f2 = f2 + 2.0d0*dibp*wmp - dibp2*wmw + endif + + f2 = max(epsmch*f2_org,f2) + if (nleft .gt. 0) then + dtm = -f1/f2 + goto 777 +c to repeat the loop for unsearched intervals. + else if(bnded) then + f1 = zero + f2 = zero + dtm = zero + else + dtm = -f1/f2 + endif + +c------------------- the end of the loop ------------------------------- + + 888 continue + if (iprint .ge. 99) then + write (6,*) + write (6,*) 'GCP found in this segment' + write (6,4010) nseg,f1,f2 + write (6,6010) dtm + endif + if (dtm .le. zero) dtm = zero + tsum = tsum + dtm + +c Move free variables (i.e., the ones w/o breakpoints) and +c the variables whose breakpoints haven't been reached. + + call daxpy(n,tsum,d,1,xcp,1) + + 999 continue + +c Update c = c + dtm*p = W'(x^c - x) +c which will be used in computing r = Z'(B(x^c - x) + g). + + if (col .gt. 0) call daxpy(col2,dtm,p,1,c,1) + if (iprint .gt. 100) write (6,1010) (xcp(i),i = 1,n) + if (iprint .ge. 99) write (6,2010) + + 1010 format ('Cauchy X = ',/,(4x,1p,6(1x,d11.4))) + 2010 format (/,'---------------- exit CAUCHY----------------------',/) + 3010 format (/,'---------------- CAUCHY entered-------------------') + 4010 format ('Piece ',i3,' --f1, f2 at start point ',1p,2(1x,d11.4)) + 4011 format (/,'Piece ',i3,' --f1, f2 at start point ', + + 1p,2(1x,d11.4)) + 5010 format ('Distance to the next break point = ',1p,d11.4) + 6010 format ('Distance to the stationary point = ',1p,d11.4) + + return + + end + +c====================== The end of cauchy ============================== + + subroutine cmprlb(n, m, x, g, ws, wy, sy, wt, z, r, wa, index, + + theta, col, head, nfree, cnstnd, info) + + logical cnstnd + integer n, m, col, head, nfree, info, index(n) + double precision theta, + + x(n), g(n), z(n), r(n), wa(4*m), + + ws(n, m), wy(n, m), sy(m, m), wt(m, m) + +c ************ +c +c Subroutine cmprlb +c +c This subroutine computes r=-Z'B(xcp-xk)-Z'g by using +c wa(2m+1)=W'(xcp-x) from subroutine cauchy. +c +c Subprograms called: +c +c L-BFGS-B Library ... bmv. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,j,k,pointr + double precision a1,a2 + + if (.not. cnstnd .and. col .gt. 0) then + do 26 i = 1, n + r(i) = -g(i) + 26 continue + else + do 30 i = 1, nfree + k = index(i) + r(i) = -theta*(z(k) - x(k)) - g(k) + 30 continue + call bmv(m,sy,wt,col,wa(2*m+1),wa(1),info) + if (info .ne. 0) then + info = -8 + return + endif + pointr = head + do 34 j = 1, col + a1 = wa(j) + a2 = theta*wa(col + j) + do 32 i = 1, nfree + k = index(i) + r(i) = r(i) + wy(k,pointr)*a1 + ws(k,pointr)*a2 + 32 continue + pointr = mod(pointr,m) + 1 + 34 continue + endif + + return + + end + +c======================= The end of cmprlb ============================= + + subroutine errclb(n, m, factr, l, u, nbd, task, info, k) + + character*60 task + integer n, m, info, k, nbd(n) + double precision factr, l(n), u(n) + +c ************ +c +c Subroutine errclb +c +c This subroutine checks the validity of the input data. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + +c Check the input arguments for errors. + + if (n .le. 0) task = 'ERROR: N .LE. 0' + if (m .le. 0) task = 'ERROR: M .LE. 0' + if (factr .lt. zero) task = 'ERROR: FACTR .LT. 0' + +c Check the validity of the arrays nbd(i), u(i), and l(i). + + do 10 i = 1, n + if (nbd(i) .lt. 0 .or. nbd(i) .gt. 3) then +c return + task = 'ERROR: INVALID NBD' + info = -6 + k = i + endif + if (nbd(i) .eq. 2) then + if (l(i) .gt. u(i)) then +c return + task = 'ERROR: NO FEASIBLE SOLUTION' + info = -7 + k = i + endif + endif + 10 continue + + return + + end + +c======================= The end of errclb ============================= + + subroutine formk(n, nsub, ind, nenter, ileave, indx2, iupdat, + + updatd, wn, wn1, m, ws, wy, sy, theta, col, + + head, info) + + integer n, nsub, m, col, head, nenter, ileave, iupdat, + + info, ind(n), indx2(n) + double precision theta, wn(2*m, 2*m), wn1(2*m, 2*m), + + ws(n, m), wy(n, m), sy(m, m) + logical updatd + +c ************ +c +c Subroutine formk +c +c This subroutine forms the LEL^T factorization of the indefinite +c +c matrix K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] +c The matrix K can be shown to be equal to the matrix M^[-1]N +c occurring in section 5.1 of [1], as well as to the matrix +c Mbar^[-1] Nbar in section 5.3. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c nsub is an integer variable +c On entry nsub is the number of subspace variables in free set. +c On exit nsub is not changed. +c +c ind is an integer array of dimension nsub. +c On entry ind specifies the indices of subspace variables. +c On exit ind is unchanged. +c +c nenter is an integer variable. +c On entry nenter is the number of variables entering the +c free set. +c On exit nenter is unchanged. +c +c ileave is an integer variable. +c On entry indx2(ileave),...,indx2(n) are the variables leaving +c the free set. +c On exit ileave is unchanged. +c +c indx2 is an integer array of dimension n. +c On entry indx2(1),...,indx2(nenter) are the variables entering +c the free set, while indx2(ileave),...,indx2(n) are the +c variables leaving the free set. +c On exit indx2 is unchanged. +c +c iupdat is an integer variable. +c On entry iupdat is the total number of BFGS updates made so far. +c On exit iupdat is unchanged. +c +c updatd is a logical variable. +c On entry 'updatd' is true if the L-BFGS matrix is updatd. +c On exit 'updatd' is unchanged. +c +c wn is a double precision array of dimension 2m x 2m. +c On entry wn is unspecified. +c On exit the upper triangle of wn stores the LEL^T factorization +c of the 2*col x 2*col indefinite matrix +c [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c wn1 is a double precision array of dimension 2m x 2m. +c On entry wn1 stores the lower triangular part of +c [Y' ZZ'Y L_a'+R_z'] +c [L_a+R_z S'AA'S ] +c in the previous iteration. +c On exit wn1 stores the corresponding updated matrices. +c The purpose of wn1 is just to store these inner products +c so they can be easily updated and inserted into wn. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c ws, wy, sy, and wtyy are double precision arrays; +c theta is a double precision variable; +c col is an integer variable; +c head is an integer variable. +c On entry they store the information defining the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c sy(m,m) stores S'Y; +c wtyy(m,m) stores the Cholesky factorization +c of (theta*S'S+LD^(-1)L') +c theta is the scaling factor specifying B_0 = theta I; +c col is the number of variable metric corrections stored; +c head is the location of the 1st s- (or y-) vector in S (or Y). +c On exit they are unchanged. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return; +c = -1 when the 1st Cholesky factorization failed; +c = -2 when the 2st Cholesky factorization failed. +c +c Subprograms called: +c +c Linpack ... dcopy, dpofa, dtrsl. +c +c +c References: +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: a +c limited memory FORTRAN code for solving bound constrained +c optimization problems'', Tech. Report, NAM-11, EECS Department, +c Northwestern University, 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer m2,ipntr,jpntr,iy,is,jy,js,is1,js1,k1,i,k, + + col2,pbegin,pend,dbegin,dend,upcl + double precision ddot,temp1,temp2,temp3,temp4 + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + +c Form the lower triangular part of +c WN1 = [Y' ZZ'Y L_a'+R_z'] +c [L_a+R_z S'AA'S ] +c where L_a is the strictly lower triangular part of S'AA'Y +c R_z is the upper triangular part of S'ZZ'Y. + + if (updatd) then + if (iupdat .gt. m) then +c shift old part of WN1. + do 10 jy = 1, m - 1 + js = m + jy + call dcopy(m-jy,wn1(jy+1,jy+1),1,wn1(jy,jy),1) + call dcopy(m-jy,wn1(js+1,js+1),1,wn1(js,js),1) + call dcopy(m-1,wn1(m+2,jy+1),1,wn1(m+1,jy),1) + 10 continue + endif + +c put new rows in blocks (1,1), (2,1) and (2,2). + pbegin = 1 + pend = nsub + dbegin = nsub + 1 + dend = n + iy = col + is = m + col + ipntr = head + col - 1 + if (ipntr .gt. m) ipntr = ipntr - m + jpntr = head + do 20 jy = 1, col + js = m + jy + temp1 = zero + temp2 = zero + temp3 = zero +c compute element jy of row 'col' of Y'ZZ'Y + do 15 k = pbegin, pend + k1 = ind(k) + temp1 = temp1 + wy(k1,ipntr)*wy(k1,jpntr) + 15 continue +c compute elements jy of row 'col' of L_a and S'AA'S + do 16 k = dbegin, dend + k1 = ind(k) + temp2 = temp2 + ws(k1,ipntr)*ws(k1,jpntr) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 16 continue + wn1(iy,jy) = temp1 + wn1(is,js) = temp2 + wn1(is,jy) = temp3 + jpntr = mod(jpntr,m) + 1 + 20 continue + +c put new column in block (2,1). + jy = col + jpntr = head + col - 1 + if (jpntr .gt. m) jpntr = jpntr - m + ipntr = head + do 30 i = 1, col + is = m + i + temp3 = zero +c compute element i of column 'col' of R_z + do 25 k = pbegin, pend + k1 = ind(k) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 25 continue + ipntr = mod(ipntr,m) + 1 + wn1(is,jy) = temp3 + 30 continue + upcl = col - 1 + else + upcl = col + endif + +c modify the old parts in blocks (1,1) and (2,2) due to changes +c in the set of free variables. + ipntr = head + do 45 iy = 1, upcl + is = m + iy + jpntr = head + do 40 jy = 1, iy + js = m + jy + temp1 = zero + temp2 = zero + temp3 = zero + temp4 = zero + do 35 k = 1, nenter + k1 = indx2(k) + temp1 = temp1 + wy(k1,ipntr)*wy(k1,jpntr) + temp2 = temp2 + ws(k1,ipntr)*ws(k1,jpntr) + 35 continue + do 36 k = ileave, n + k1 = indx2(k) + temp3 = temp3 + wy(k1,ipntr)*wy(k1,jpntr) + temp4 = temp4 + ws(k1,ipntr)*ws(k1,jpntr) + 36 continue + wn1(iy,jy) = wn1(iy,jy) + temp1 - temp3 + wn1(is,js) = wn1(is,js) - temp2 + temp4 + jpntr = mod(jpntr,m) + 1 + 40 continue + ipntr = mod(ipntr,m) + 1 + 45 continue + +c modify the old parts in block (2,1). + ipntr = head + do 60 is = m + 1, m + upcl + jpntr = head + do 55 jy = 1, upcl + temp1 = zero + temp3 = zero + do 50 k = 1, nenter + k1 = indx2(k) + temp1 = temp1 + ws(k1,ipntr)*wy(k1,jpntr) + 50 continue + do 51 k = ileave, n + k1 = indx2(k) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 51 continue + if (is .le. jy + m) then + wn1(is,jy) = wn1(is,jy) + temp1 - temp3 + else + wn1(is,jy) = wn1(is,jy) - temp1 + temp3 + endif + jpntr = mod(jpntr,m) + 1 + 55 continue + ipntr = mod(ipntr,m) + 1 + 60 continue + +c Form the upper triangle of WN = [D+Y' ZZ'Y/theta -L_a'+R_z' ] +c [-L_a +R_z S'AA'S*theta] + + m2 = 2*m + do 70 iy = 1, col + is = col + iy + is1 = m + iy + do 65 jy = 1, iy + js = col + jy + js1 = m + jy + wn(jy,iy) = wn1(iy,jy)/theta + wn(js,is) = wn1(is1,js1)*theta + 65 continue + do 66 jy = 1, iy - 1 + wn(jy,is) = -wn1(is1,jy) + 66 continue + do 67 jy = iy, col + wn(jy,is) = wn1(is1,jy) + 67 continue + wn(iy,iy) = wn(iy,iy) + sy(iy,iy) + 70 continue + +c Form the upper triangle of WN= [ LL' L^-1(-L_a'+R_z')] +c [(-L_a +R_z)L'^-1 S'AA'S*theta ] + +c first Cholesky factor (1,1) block of wn to get LL' +c with L' stored in the upper triangle of wn. + call dpofa(wn,m2,col,info) + if (info .ne. 0) then + info = -1 + return + endif +c then form L^-1(-L_a'+R_z') in the (1,2) block. + col2 = 2*col + do 71 js = col+1 ,col2 + call dtrsl(wn,m2,col,wn(1,js),11,info) + 71 continue + +c Form S'AA'S*theta + (L^-1(-L_a'+R_z'))'L^-1(-L_a'+R_z') in the +c upper triangle of (2,2) block of wn. + + + do 72 is = col+1, col2 + do 74 js = is, col2 + wn(is,js) = wn(is,js) + ddot(col,wn(1,is),1,wn(1,js),1) + 74 continue + 72 continue + +c Cholesky factorization of (2,2) block of wn. + + call dpofa(wn(col+1,col+1),m2,col,info) + if (info .ne. 0) then + info = -2 + return + endif + + return + + end + +c======================= The end of formk ============================== + + subroutine formt(m, wt, sy, ss, col, theta, info) + + integer m, col, info + double precision theta, wt(m, m), sy(m, m), ss(m, m) + +c ************ +c +c Subroutine formt +c +c This subroutine forms the upper half of the pos. def. and symm. +c T = theta*SS + L*D^(-1)*L', stores T in the upper triangle +c of the array wt, and performs the Cholesky factorization of T +c to produce J*J', with J' stored in the upper triangle of wt. +c +c Subprograms called: +c +c Linpack ... dpofa. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,j,k,k1 + double precision ddum + double precision zero + parameter (zero=0.0d0) + + +c Form the upper half of T = theta*SS + L*D^(-1)*L', +c store T in the upper triangle of the array wt. + + do 52 j = 1, col + wt(1,j) = theta*ss(1,j) + 52 continue + do 55 i = 2, col + do 54 j = i, col + k1 = min(i,j) - 1 + ddum = zero + do 53 k = 1, k1 + ddum = ddum + sy(i,k)*sy(j,k)/sy(k,k) + 53 continue + wt(i,j) = ddum + theta*ss(i,j) + 54 continue + 55 continue + +c Cholesky factorize T to J*J' with +c J' stored in the upper triangle of wt. + + call dpofa(wt,m,col,info) + if (info .ne. 0) then + info = -3 + endif + + return + + end + +c======================= The end of formt ============================== + + subroutine freev(n, nfree, index, nenter, ileave, indx2, + + iwhere, wrk, updatd, cnstnd, iprint, iter) + + integer n, nfree, nenter, ileave, iprint, iter, + + index(n), indx2(n), iwhere(n) + logical wrk, updatd, cnstnd + +c ************ +c +c Subroutine freev +c +c This subroutine counts the entering and leaving variables when +c iter > 0, and finds the index set of free and active variables +c at the GCP. +c +c cnstnd is a logical variable indicating whether bounds are present +c +c index is an integer array of dimension n +c for i=1,...,nfree, index(i) are the indices of free variables +c for i=nfree+1,...,n, index(i) are the indices of bound variables +c On entry after the first iteration, index gives +c the free variables at the previous iteration. +c On exit it gives the free variables based on the determination +c in cauchy using the array iwhere. +c +c indx2 is an integer array of dimension n +c On entry indx2 is unspecified. +c On exit with iter>0, indx2 indicates which variables +c have changed status since the previous iteration. +c For i= 1,...,nenter, indx2(i) have changed from bound to free. +c For i= ileave+1,...,n, indx2(i) have changed from free to bound. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer iact,i,k + + nenter = 0 + ileave = n + 1 + if (iter .gt. 0 .and. cnstnd) then +c count the entering and leaving variables. + do 20 i = 1, nfree + k = index(i) + +c write(6,*) ' k = index(i) ', k +c write(6,*) ' index = ', i + + if (iwhere(k) .gt. 0) then + ileave = ileave - 1 + indx2(ileave) = k + if (iprint .ge. 100) write (6,*) + + 'Variable ',k,' leaves the set of free variables' + endif + 20 continue + do 22 i = 1 + nfree, n + k = index(i) + if (iwhere(k) .le. 0) then + nenter = nenter + 1 + indx2(nenter) = k + if (iprint .ge. 100) write (6,*) + + 'Variable ',k,' enters the set of free variables' + endif + 22 continue + if (iprint .ge. 99) write (6,*) + + n+1-ileave,' variables leave; ',nenter,' variables enter' + endif + wrk = (ileave .lt. n+1) .or. (nenter .gt. 0) .or. updatd + +c Find the index set of free and active variables at the GCP. + + nfree = 0 + iact = n + 1 + do 24 i = 1, n + if (iwhere(i) .le. 0) then + nfree = nfree + 1 + index(nfree) = i + else + iact = iact - 1 + index(iact) = i + endif + 24 continue + if (iprint .ge. 99) write (6,*) + + nfree,' variables are free at GCP ',iter + 1 + + return + + end + +c======================= The end of freev ============================== + + subroutine hpsolb(n, t, iorder, iheap) + integer iheap, n, iorder(n) + double precision t(n) + +c ************ +c +c Subroutine hpsolb +c +c This subroutine sorts out the least element of t, and puts the +c remaining elements of t in a heap. +c +c n is an integer variable. +c On entry n is the dimension of the arrays t and iorder. +c On exit n is unchanged. +c +c t is a double precision array of dimension n. +c On entry t stores the elements to be sorted, +c On exit t(n) stores the least elements of t, and t(1) to t(n-1) +c stores the remaining elements in the form of a heap. +c +c iorder is an integer array of dimension n. +c On entry iorder(i) is the index of t(i). +c On exit iorder(i) is still the index of t(i), but iorder may be +c permuted in accordance with t. +c +c iheap is an integer variable specifying the task. +c On entry iheap should be set as follows: +c iheap .eq. 0 if t(1) to t(n) is not in the form of a heap, +c iheap .ne. 0 if otherwise. +c On exit iheap is unchanged. +c +c +c References: +c Algorithm 232 of CACM (J. W. J. Williams): HEAPSORT. +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c ************ + + integer i,j,k,indxin,indxou + double precision ddum,out + + if (iheap .eq. 0) then + +c Rearrange the elements t(1) to t(n) to form a heap. + + do 20 k = 2, n + ddum = t(k) + indxin = iorder(k) + +c Add ddum to the heap. + i = k + 10 continue + if (i.gt.1) then + j = i/2 + if (ddum .lt. t(j)) then + t(i) = t(j) + iorder(i) = iorder(j) + i = j + goto 10 + endif + endif + t(i) = ddum + iorder(i) = indxin + 20 continue + endif + +c Assign to 'out' the value of t(1), the least member of the heap, +c and rearrange the remaining members to form a heap as +c elements 1 to n-1 of t. + + if (n .gt. 1) then + i = 1 + out = t(1) + indxou = iorder(1) + ddum = t(n) + indxin = iorder(n) + +c Restore the heap + 30 continue + j = i+i + if (j .le. n-1) then + if (t(j+1) .lt. t(j)) j = j+1 + if (t(j) .lt. ddum ) then + t(i) = t(j) + iorder(i) = iorder(j) + i = j + goto 30 + endif + endif + t(i) = ddum + iorder(i) = indxin + +c Put the least member in t(n). + + t(n) = out + iorder(n) = indxou + endif + + return + + end + +c====================== The end of hpsolb ============================== + + subroutine lnsrlb(n, l, u, nbd, x, f, fold, gd, gdold, g, d, r, t, + + z, stp, dnorm, dtd, xstep, stpmx, iter, ifun, + + iback, nfgv, info, task, boxed, cnstnd, csave, + + isave, dsave) + + character*60 task, csave + logical boxed, cnstnd + integer n, iter, ifun, iback, nfgv, info, + + nbd(n), isave(2) + double precision f, fold, gd, gdold, stp, dnorm, dtd, xstep, + + stpmx, x(n), l(n), u(n), g(n), d(n), r(n), t(n), + + z(n), dsave(13) +c ********** +c +c Subroutine lnsrlb +c +c This subroutine calls subroutine dcsrch from the Minpack2 library +c to perform the line search. Subroutine dscrch is safeguarded so +c that all trial points lie within the feasible region. +c +c Subprograms called: +c +c Minpack2 Library ... dcsrch. +c +c Linpack ... dtrsl, ddot. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ********** + + integer i + double precision ddot,a1,a2 + double precision one,zero,big + parameter (one=1.0d0,zero=0.0d0,big=1.0d+10) + double precision ftol,gtol,xtol + parameter (ftol=1.0d-3,gtol=0.9d0,xtol=0.1d0) + + if (task(1:5) .eq. 'FG_LN') goto 556 + + dtd = ddot(n,d,1,d,1) + dnorm = sqrt(dtd) + +c Determine the maximum step length. + + stpmx = big + if (cnstnd) then + if (iter .eq. 0) then + stpmx = one + else + do 43 i = 1, n + a1 = d(i) + if (nbd(i) .ne. 0) then + if (a1 .lt. zero .and. nbd(i) .le. 2) then + a2 = l(i) - x(i) + if (a2 .ge. zero) then + stpmx = zero + else if (a1*stpmx .lt. a2) then + stpmx = a2/a1 + endif + else if (a1 .gt. zero .and. nbd(i) .ge. 2) then + a2 = u(i) - x(i) + if (a2 .le. zero) then + stpmx = zero + else if (a1*stpmx .gt. a2) then + stpmx = a2/a1 + endif + endif + endif + 43 continue + endif + endif + + if (iter .eq. 0 .and. .not. boxed) then + stp = min(one/dnorm, stpmx) + else + stp = one + endif + + call dcopy(n,x,1,t,1) + call dcopy(n,g,1,r,1) + fold = f + ifun = 0 + iback = 0 + csave = 'START' + 556 continue + gd = ddot(n,g,1,d,1) + if (ifun .eq. 0) then + gdold=gd + if (gd .ge. zero) then +c the directional derivative >=0. +c Line search is impossible. + write(6,*)' ascent direction in projection gd = ', gd + info = -4 + return + endif + endif + + call dcsrch(f,gd,stp,ftol,gtol,xtol,zero,stpmx,csave,isave,dsave) + + xstep = stp*dnorm + if (csave(1:4) .ne. 'CONV' .and. csave(1:4) .ne. 'WARN') then + task = 'FG_LNSRCH' + ifun = ifun + 1 + nfgv = nfgv + 1 + iback = ifun - 1 + if (stp .eq. one) then + call dcopy(n,z,1,x,1) + else + do 41 i = 1, n + x(i) = stp*d(i) + t(i) + 41 continue + endif + else + task = 'NEW_X' + endif + + return + + end + +c======================= The end of lnsrlb ============================= + + subroutine matupd(n, m, ws, wy, sy, ss, d, r, itail, + + iupdat, col, head, theta, rr, dr, stp, dtd) + + integer n, m, itail, iupdat, col, head + double precision theta, rr, dr, stp, dtd, d(n), r(n), + + ws(n, m), wy(n, m), sy(m, m), ss(m, m) + +c ************ +c +c Subroutine matupd +c +c This subroutine updates matrices WS and WY, and forms the +c middle matrix in B. +c +c Subprograms called: +c +c Linpack ... dcopy, ddot. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer j,pointr + double precision ddot + double precision one + parameter (one=1.0d0) + +c Set pointers for matrices WS and WY. + + if (iupdat .le. m) then + col = iupdat + itail = mod(head+iupdat-2,m) + 1 + else + itail = mod(itail,m) + 1 + head = mod(head,m) + 1 + endif + +c Update matrices WS and WY. + + call dcopy(n,d,1,ws(1,itail),1) + call dcopy(n,r,1,wy(1,itail),1) + +c Set theta=yy/ys. + + theta = rr/dr + +c Form the middle matrix in B. + +c update the upper triangle of SS, +c and the lower triangle of SY: + if (iupdat .gt. m) then +c move old information + do 50 j = 1, col - 1 + call dcopy(j,ss(2,j+1),1,ss(1,j),1) + call dcopy(col-j,sy(j+1,j+1),1,sy(j,j),1) + 50 continue + endif +c add new information: the last row of SY +c and the last column of SS: + pointr = head + do 51 j = 1, col - 1 + sy(col,j) = ddot(n,d,1,wy(1,pointr),1) + ss(j,col) = ddot(n,ws(1,pointr),1,d,1) + pointr = mod(pointr,m) + 1 + 51 continue + if (stp .eq. one) then + ss(col,col) = dtd + else + ss(col,col) = stp*stp*dtd + endif + sy(col,col) = dr + + return + + end + +c======================= The end of matupd ============================= + + subroutine prn1lb(n, m, l, u, x, iprint, itfile, epsmch) + + integer n, m, iprint, itfile + double precision epsmch, x(n), l(n), u(n) + +c ************ +c +c Subroutine prn1lb +c +c This subroutine prints the input data, initial point, upper and +c lower bounds of each variable, machine precision, as well as +c the headings of the output. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + + if (iprint .ge. 0) then + write (6,7001) epsmch + write (6,*) 'N = ',n,' M = ',m + if (iprint .ge. 1) then + write (itfile,2001) epsmch + write (itfile,*)'N = ',n,' M = ',m + write (itfile,9001) + if (iprint .gt. 100) then + write (6,1004) 'L =',(l(i),i = 1,n) + write (6,1004) 'X0 =',(x(i),i = 1,n) + write (6,1004) 'U =',(u(i),i = 1,n) + endif + endif + endif + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 2001 format ('RUNNING THE L-BFGS-B CODE',/,/, + + 'it = iteration number',/, + + 'nf = number of function evaluations',/, + + 'nseg = number of segments explored during the Cauchy search',/, + + 'nact = number of active bounds at the generalized Cauchy point' + + ,/, + + 'sub = manner in which the subspace minimization terminated:' + + ,/,' con = converged, bnd = a bound was reached',/, + + 'itls = number of iterations performed in the line search',/, + + 'stepl = step length used',/, + + 'tstep = norm of the displacement (total step)',/, + + 'projg = norm of the projected gradient',/, + + 'f = function value',/,/, + + ' * * *',/,/, + + 'Machine precision =',1p,d10.3) + 7001 format ('RUNNING THE L-BFGS-B CODE',/,/, + + ' * * *',/,/, + + 'Machine precision =',1p,d10.3) + 9001 format (/,3x,'it',3x,'nf',2x,'nseg',2x,'nact',2x,'sub',2x,'itls', + + 2x,'stepl',4x,'tstep',5x,'projg',8x,'f') + + return + + end + +c======================= The end of prn1lb ============================= + + subroutine prn2lb(n, x, f, g, iprint, itfile, iter, nfgv, nact, + + sbgnrm, nseg, word, iword, iback, stp, xstep) + + !(ajt 8/9/13) + USE LOGICAL_ADJ_MOD, ONLY: LATF + + character*3 word + integer n, iprint, itfile, iter, nfgv, nact, nseg, + + iword, iback + double precision f, sbgnrm, stp, xstep, x(n), g(n) + +c ************ +c +c Subroutine prn2lb +c +c This subroutine prints out new information after a successful +c line search. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,imod + + ! (ajt, 8/9/13) + LATF = .TRUE. + +c 'word' records the status of subspace solutions. + if (iword .eq. 0) then +c the subspace minimization converged. + word = 'con' + else if (iword .eq. 1) then +c the subspace minimization stopped at a bound. + word = 'bnd' + else if (iword .eq. 5) then +c the truncated Newton step has been used. + word = 'TNT' + else + word = '---' + endif + if (iprint .ge. 99) then + write (6,*) 'LINE SEARCH',iback,' times; norm of step = ',xstep + write (6,2001) iter,f,sbgnrm + if (iprint .gt. 100) then + write (6,1004) 'X =',(x(i), i = 1, n) + write (6,1004) 'G =',(g(i), i = 1, n) + endif + else if (iprint .gt. 0) then + imod = mod(iter,iprint) + if (imod .eq. 0) write (6,2001) iter,f,sbgnrm + endif + if (iprint .ge. 1) write (itfile,3001) + + iter,nfgv,nseg,nact,word,iback,stp,xstep,sbgnrm,f + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 2001 format + + (/,'At iterate',i5,4x,'f= ',1p,d12.5,4x,'|proj g|= ',1p,d12.5) + 3001 format(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d7.1),1p,2(1x,d10.3)) + + return + + end + +c======================= The end of prn2lb ============================= + + subroutine prn3lb(n, x, f, task, iprint, info, itfile, + + iter, nfgv, nintol, nskip, nact, sbgnrm, + + time, nseg, word, iback, stp, xstep, k, + + cachyt, sbtime, lnscht) + + character*60 task + character*3 word + integer n, iprint, info, itfile, iter, nfgv, nintol, + + nskip, nact, nseg, iback, k + double precision f, sbgnrm, time, stp, xstep, cachyt, sbtime, + + lnscht, x(n) + +c ************ +c +c Subroutine prn3lb +c +c This subroutine prints out information when either a built-in +c convergence test is satisfied or when an error message is +c generated. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + + if (task(1:5) .eq. 'ERROR') goto 999 + + if (iprint .ge. 0) then + write (6,3003) + write (6,3004) + write(6,3005) n,iter,nfgv,nintol,nskip,nact,sbgnrm,f + if (iprint .ge. 100) then + write (6,1004) 'X =',(x(i),i = 1,n) + endif + if (iprint .ge. 1) write (6,*) ' F =',f + endif + 999 continue + if (iprint .ge. 0) then + write (6,3009) task + if (info .ne. 0) then + if (info .eq. -1) write (6,9011) + if (info .eq. -2) write (6,9012) + if (info .eq. -3) write (6,9013) + if (info .eq. -4) write (6,9014) + if (info .eq. -5) write (6,9015) + if (info .eq. -6) write (6,*)' Input nbd(',k,') is invalid.' + if (info .eq. -7) + + write (6,*)' l(',k,') > u(',k,'). No feasible solution.' + if (info .eq. -8) write (6,9018) + if (info .eq. -9) write (6,9019) + endif + if (iprint .ge. 1) write (6,3007) cachyt,sbtime,lnscht + write (6,3008) time + if (iprint .ge. 1) then + if (info .eq. -4 .or. info .eq. -9) then + write (itfile,3002) + + iter,nfgv,nseg,nact,word,iback,stp,xstep + endif + write (itfile,3009) task + if (info .ne. 0) then + if (info .eq. -1) write (itfile,9011) + if (info .eq. -2) write (itfile,9012) + if (info .eq. -3) write (itfile,9013) + if (info .eq. -4) write (itfile,9014) + if (info .eq. -5) write (itfile,9015) + if (info .eq. -8) write (itfile,9018) + if (info .eq. -9) write (itfile,9019) + endif + write (itfile,3008) time + endif + endif + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 3002 format(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d7.1),6x,'-',10x,'-') + 3003 format (/, + + ' * * *',/,/, + + 'Tit = total number of iterations',/, + + 'Tnf = total number of function evaluations',/, + + 'Tnint = total number of segments explored during', + + ' Cauchy searches',/, + + 'Skip = number of BFGS updates skipped',/, + + 'Nact = number of active bounds at final generalized', + + ' Cauchy point',/, + + 'Projg = norm of the final projected gradient',/, + + 'F = final function value',/,/, + + ' * * *') + 3004 format (/,3x,'N',4x,'Tit',5x,'Tnf',2x,'Tnint',2x, + + 'Skip',2x,'Nact',5x,'Projg',8x,'F') + 3005 format (i5,2(1x,i6),(1x,i6),(2x,i4),(1x,i5),1p,2(2x,d10.3)) + 3007 format (/,' Cauchy time',1p,e10.3,' seconds.',/ + + ' Subspace minimization time',1p,e10.3,' seconds.',/ + + ' Line search time',1p,e10.3,' seconds.') + 3008 format (/,' Total User time',1p,e10.3,' seconds.',/) + 3009 format (/,a60) + 9011 format (/, + +' Matrix in 1st Cholesky factorization in formk is not Pos. Def.') + 9012 format (/, + +' Matrix in 2st Cholesky factorization in formk is not Pos. Def.') + 9013 format (/, + +' Matrix in the Cholesky factorization in formt is not Pos. Def.') + 9014 format (/, + +' Derivative >= 0, backtracking line search impossible.',/, + +' Previous x, f and g restored.',/, + +' Possible causes: 1 error in function or gradient evaluation;',/, + +' 2 rounding errors dominate computation.') + 9015 format (/, + +' Warning: more than 10 function and gradient',/, + +' evaluations in the last line search. Termination',/, + +' may possibly be caused by a bad search direction.') + 9018 format (/,' The triangular system is singular.') + 9019 format (/, + +' Line search cannot locate an adequate point after 20 function',/ + +,' and gradient evaluations. Previous x, f and g restored.',/, + +' Possible causes: 1 error in function or gradient evaluation;',/, + +' 2 rounding error dominate computation.') + + return + + end + +c======================= The end of prn3lb ============================= + + subroutine projgr(n, l, u, nbd, x, g, sbgnrm) + + integer n, nbd(n) + double precision sbgnrm, x(n), l(n), u(n), g(n) + +c ************ +c +c Subroutine projgr +c +c This subroutine computes the infinity norm of the projected +c gradient. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + double precision gi + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + + sbgnrm = zero + do 15 i = 1, n + gi = g(i) + if (nbd(i) .ne. 0) then + if (gi .lt. zero) then + if (nbd(i) .ge. 2) gi = max((x(i)-u(i)),gi) + else + if (nbd(i) .le. 2) gi = min((x(i)-l(i)),gi) + endif + endif + sbgnrm = max(sbgnrm,abs(gi)) + 15 continue + + return + + end + +c======================= The end of projgr ============================= + + subroutine subsm ( n, m, nsub, ind, l, u, nbd, x, d, xp, ws, wy, + + theta, xx, gg, + + col, head, iword, wv, wn, iprint, info ) + implicit none + integer n, m, nsub, col, head, iword, iprint, info, + + ind(nsub), nbd(n) + double precision theta, + + l(n), u(n), x(n), d(n), xp(n), xx(n), gg(n), + + ws(n, m), wy(n, m), + + wv(2*m), wn(2*m, 2*m) + +c ********************************************************************** +c +c This routine contains the major changes in the updated version. +c The changes are described in the accompanying paper +c +c Jose Luis Morales, Jorge Nocedal +c "Remark On Algorithm 788: L-BFGS-B: Fortran Subroutines for Large-Scale +c Bound Constrained Optimization". Decemmber 27, 2010. +c +c J.L. Morales Departamento de Matematicas, +c Instituto Tecnologico Autonomo de Mexico +c Mexico D.F. +c +c J, Nocedal Department of Electrical Engineering and +c Computer Science. +c Northwestern University. Evanston, IL. USA +c +c January 17, 2011 +c +c ********************************************************************** +c +c +c Subroutine subsm +c +c Given xcp, l, u, r, an index set that specifies +c the active set at xcp, and an l-BFGS matrix B +c (in terms of WY, WS, SY, WT, head, col, and theta), +c this subroutine computes an approximate solution +c of the subspace problem +c +c (P) min Q(x) = r'(x-xcp) + 1/2 (x-xcp)' B (x-xcp) +c +c subject to l<=x<=u +c x_i=xcp_i for all i in A(xcp) +c +c along the subspace unconstrained Newton direction +c +c d = -(Z'BZ)^(-1) r. +c +c The formula for the Newton direction, given the L-BFGS matrix +c and the Sherman-Morrison formula, is +c +c d = (1/theta)r + (1/theta*2) Z'WK^(-1)W'Z r. +c +c where +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c Note that this procedure for computing d differs +c from that described in [1]. One can show that the matrix K is +c equal to the matrix M^[-1]N in that paper. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c nsub is an integer variable. +c On entry nsub is the number of free variables. +c On exit nsub is unchanged. +c +c ind is an integer array of dimension nsub. +c On entry ind specifies the coordinate indices of free variables. +c On exit ind is unchanged. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is a integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c x is a double precision array of dimension n. +c On entry x specifies the Cauchy point xcp. +c On exit x(i) is the minimizer of Q over the subspace of +c free variables. +c +c d is a double precision array of dimension n. +c On entry d is the reduced gradient of Q at xcp. +c On exit d is the Newton direction of Q. +c +c xp is a double precision array of dimension n. +c used to safeguard the projected Newton direction +c +c xx is a double precision array of dimension n +c On entry it holds the current iterate +c On output it is unchanged + +c gg is a double precision array of dimension n +c On entry it holds the gradient at the current iterate +c On output it is unchanged +c +c ws and wy are double precision arrays; +c theta is a double precision variable; +c col is an integer variable; +c head is an integer variable. +c On entry they store the information defining the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c theta is the scaling factor specifying B_0 = theta I; +c col is the number of variable metric corrections stored; +c head is the location of the 1st s- (or y-) vector in S (or Y). +c On exit they are unchanged. +c +c iword is an integer variable. +c On entry iword is unspecified. +c On exit iword specifies the status of the subspace solution. +c iword = 0 if the solution is in the box, +c 1 if some bound is encountered. +c +c wv is a double precision working array of dimension 2m. +c +c wn is a double precision array of dimension 2m x 2m. +c On entry the upper triangle of wn stores the LEL^T factorization +c of the indefinite matrix +c +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] +c On exit wn is unchanged. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return, +c = nonzero for abnormal return +c when the matrix K is ill-conditioned. +c +c Subprograms called: +c +c Linpack dtrsl. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer pointr,m2,col2,ibd,jy,js,i,j,k + double precision alpha, xk, dk, temp1, temp2 + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) +c + double precision dd_p + + if (nsub .le. 0) return + if (iprint .ge. 99) write (6,1001) + +c Compute wv = W'Zd. + + pointr = head + do 20 i = 1, col + temp1 = zero + temp2 = zero + do 10 j = 1, nsub + k = ind(j) + temp1 = temp1 + wy(k,pointr)*d(j) + temp2 = temp2 + ws(k,pointr)*d(j) + 10 continue + wv(i) = temp1 + wv(col + i) = theta*temp2 + pointr = mod(pointr,m) + 1 + 20 continue + +c Compute wv:=K^(-1)wv. + + m2 = 2*m + col2 = 2*col + call dtrsl(wn,m2,col2,wv,11,info) + if (info .ne. 0) return + do 25 i = 1, col + wv(i) = -wv(i) + 25 continue + call dtrsl(wn,m2,col2,wv,01,info) + if (info .ne. 0) return + +c Compute d = (1/theta)d + (1/theta**2)Z'W wv. + + pointr = head + do 40 jy = 1, col + js = col + jy + do 30 i = 1, nsub + k = ind(i) + d(i) = d(i) + wy(k,pointr)*wv(jy)/theta + + + ws(k,pointr)*wv(js) + 30 continue + pointr = mod(pointr,m) + 1 + 40 continue + + call dscal( nsub, one/theta, d, 1 ) +c +c----------------------------------------------------------------- +c Let us try the projection, d is the Newton direction + + iword = 0 + + call dcopy ( n, x, 1, xp, 1 ) +c + do 50 i=1, nsub + k = ind(i) + dk = d(i) + xk = x(k) + if ( nbd(k) .ne. 0 ) then +c + if ( nbd(k).eq.1 ) then ! lower bounds only + x(k) = max( l(k), xk + dk ) + if ( x(k).eq.l(k) ) iword = 1 + else +c + if ( nbd(k).eq.2 ) then ! upper and lower bounds + xk = max( l(k), xk + dk ) + x(k) = min( u(k), xk ) + if ( x(k).eq.l(k) .or. x(k).eq.u(k) ) iword = 1 + else +c + if ( nbd(k).eq.3 ) then ! upper bounds only + x(k) = min( u(k), xk + dk ) + if ( x(k).eq.u(k) ) iword = 1 + end if + end if + end if +c + else ! free variables + x(k) = xk + dk + end if + 50 continue +c + if ( iword.eq.0 ) then + go to 911 + end if +c +c check sign of the directional derivative +c + dd_p = zero + do 55 i=1, n + dd_p = dd_p + (x(i) - xx(i))*gg(i) + 55 continue + if ( dd_p .gt.zero ) then + call dcopy( n, xp, 1, x, 1 ) + write(6,*) ' Positive dir derivative in projection ' + write(6,*) ' Using the backtracking step ' + else + go to 911 + endif +c +c----------------------------------------------------------------- +c + alpha = one + temp1 = alpha + ibd = 0 + do 60 i = 1, nsub + k = ind(i) + dk = d(i) + if (nbd(k) .ne. 0) then + if (dk .lt. zero .and. nbd(k) .le. 2) then + temp2 = l(k) - x(k) + if (temp2 .ge. zero) then + temp1 = zero + else if (dk*alpha .lt. temp2) then + temp1 = temp2/dk + endif + else if (dk .gt. zero .and. nbd(k) .ge. 2) then + temp2 = u(k) - x(k) + if (temp2 .le. zero) then + temp1 = zero + else if (dk*alpha .gt. temp2) then + temp1 = temp2/dk + endif + endif + if (temp1 .lt. alpha) then + alpha = temp1 + ibd = i + endif + endif + 60 continue + + if (alpha .lt. one) then + dk = d(ibd) + k = ind(ibd) + if (dk .gt. zero) then + x(k) = u(k) + d(ibd) = zero + else if (dk .lt. zero) then + x(k) = l(k) + d(ibd) = zero + endif + endif + do 70 i = 1, nsub + k = ind(i) + x(k) = x(k) + alpha*d(i) + 70 continue +cccccc + 911 continue + + if (iprint .ge. 99) write (6,1004) + + 1001 format (/,'----------------SUBSM entered-----------------',/) + 1004 format (/,'----------------exit SUBSM --------------------',/) + + return + + end +c====================== The end of subsm =============================== + + subroutine dcsrch(f,g,stp,ftol,gtol,xtol,stpmin,stpmax, + + task,isave,dsave) + character*(*) task + integer isave(2) + double precision f,g,stp,ftol,gtol,xtol,stpmin,stpmax + double precision dsave(13) +c ********** +c +c Subroutine dcsrch +c +c This subroutine finds a step that satisfies a sufficient +c decrease condition and a curvature condition. +c +c Each call of the subroutine updates an interval with +c endpoints stx and sty. The interval is initially chosen +c so that it contains a minimizer of the modified function +c +c psi(stp) = f(stp) - f(0) - ftol*stp*f'(0). +c +c If psi(stp) <= 0 and f'(stp) >= 0 for some step, then the +c interval is chosen so that it contains a minimizer of f. +c +c The algorithm is designed to find a step that satisfies +c the sufficient decrease condition +c +c f(stp) <= f(0) + ftol*stp*f'(0), +c +c and the curvature condition +c +c abs(f'(stp)) <= gtol*abs(f'(0)). +c +c If ftol is less than gtol and if, for example, the function +c is bounded below, then there is always a step which satisfies +c both conditions. +c +c If no step can be found that satisfies both conditions, then +c the algorithm stops with a warning. In this case stp only +c satisfies the sufficient decrease condition. +c +c A typical invocation of dcsrch has the following outline: +c +c task = 'START' +c 10 continue +c call dcsrch( ... ) +c if (task .eq. 'FG') then +c Evaluate the function and the gradient at stp +c goto 10 +c end if +c +c NOTE: The user must no alter work arrays between calls. +c +c The subroutine statement is +c +c subroutine dcsrch(f,g,stp,ftol,gtol,xtol,stpmin,stpmax, +c task,isave,dsave) +c where +c +c f is a double precision variable. +c On initial entry f is the value of the function at 0. +c On subsequent entries f is the value of the +c function at stp. +c On exit f is the value of the function at stp. +c +c g is a double precision variable. +c On initial entry g is the derivative of the function at 0. +c On subsequent entries g is the derivative of the +c function at stp. +c On exit g is the derivative of the function at stp. +c +c stp is a double precision variable. +c On entry stp is the current estimate of a satisfactory +c step. On initial entry, a positive initial estimate +c must be provided. +c On exit stp is the current estimate of a satisfactory step +c if task = 'FG'. If task = 'CONV' then stp satisfies +c the sufficient decrease and curvature condition. +c +c ftol is a double precision variable. +c On entry ftol specifies a nonnegative tolerance for the +c sufficient decrease condition. +c On exit ftol is unchanged. +c +c gtol is a double precision variable. +c On entry gtol specifies a nonnegative tolerance for the +c curvature condition. +c On exit gtol is unchanged. +c +c xtol is a double precision variable. +c On entry xtol specifies a nonnegative relative tolerance +c for an acceptable step. The subroutine exits with a +c warning if the relative difference between sty and stx +c is less than xtol. +c On exit xtol is unchanged. +c +c stpmin is a double precision variable. +c On entry stpmin is a nonnegative lower bound for the step. +c On exit stpmin is unchanged. +c +c stpmax is a double precision variable. +c On entry stpmax is a nonnegative upper bound for the step. +c On exit stpmax is unchanged. +c +c task is a character variable of length at least 60. +c On initial entry task must be set to 'START'. +c On exit task indicates the required action: +c +c If task(1:2) = 'FG' then evaluate the function and +c derivative at stp and call dcsrch again. +c +c If task(1:4) = 'CONV' then the search is successful. +c +c If task(1:4) = 'WARN' then the subroutine is not able +c to satisfy the convergence conditions. The exit value of +c stp contains the best point found during the search. +c +c If task(1:5) = 'ERROR' then there is an error in the +c input arguments. +c +c On exit with convergence, a warning or an error, the +c variable task contains additional information. +c +c isave is an integer work array of dimension 2. +c +c dsave is a double precision work array of dimension 13. +c +c Subprograms called +c +c MINPACK-2 ... dcstep +c +c MINPACK-1 Project. June 1983. +c Argonne National Laboratory. +c Jorge J. More' and David J. Thuente. +c +c MINPACK-2 Project. October 1993. +c Argonne National Laboratory and University of Minnesota. +c Brett M. Averick, Richard G. Carter, and Jorge J. More'. +c +c ********** + double precision zero,p5,p66 + parameter(zero=0.0d0,p5=0.5d0,p66=0.66d0) + double precision xtrapl,xtrapu + parameter(xtrapl=1.1d0,xtrapu=4.0d0) + + logical brackt + integer stage + double precision finit,ftest,fm,fx,fxm,fy,fym,ginit,gtest, + + gm,gx,gxm,gy,gym,stx,sty,stmin,stmax,width,width1 + +c Initialization block. + + if (task(1:5) .eq. 'START') then + +c Check the input arguments for errors. + + if (stp .lt. stpmin) task = 'ERROR: STP .LT. STPMIN' + if (stp .gt. stpmax) task = 'ERROR: STP .GT. STPMAX' + if (g .ge. zero) task = 'ERROR: INITIAL G .GE. ZERO' + if (ftol .lt. zero) task = 'ERROR: FTOL .LT. ZERO' + if (gtol .lt. zero) task = 'ERROR: GTOL .LT. ZERO' + if (xtol .lt. zero) task = 'ERROR: XTOL .LT. ZERO' + if (stpmin .lt. zero) task = 'ERROR: STPMIN .LT. ZERO' + if (stpmax .lt. stpmin) task = 'ERROR: STPMAX .LT. STPMIN' + +c Exit if there are errors on input. + + if (task(1:5) .eq. 'ERROR') return + +c Initialize local variables. + + brackt = .false. + stage = 1 + finit = f + ginit = g + gtest = ftol*ginit + width = stpmax - stpmin + width1 = width/p5 + +c The variables stx, fx, gx contain the values of the step, +c function, and derivative at the best step. +c The variables sty, fy, gy contain the value of the step, +c function, and derivative at sty. +c The variables stp, f, g contain the values of the step, +c function, and derivative at stp. + + stx = zero + fx = finit + gx = ginit + sty = zero + fy = finit + gy = ginit + stmin = zero + stmax = stp + xtrapu*stp + task = 'FG' + + goto 1000 + + else + +c Restore local variables. + + if (isave(1) .eq. 1) then + brackt = .true. + else + brackt = .false. + endif + stage = isave(2) + ginit = dsave(1) + gtest = dsave(2) + gx = dsave(3) + gy = dsave(4) + finit = dsave(5) + fx = dsave(6) + fy = dsave(7) + stx = dsave(8) + sty = dsave(9) + stmin = dsave(10) + stmax = dsave(11) + width = dsave(12) + width1 = dsave(13) + + endif + +c If psi(stp) <= 0 and f'(stp) >= 0 for some step, then the +c algorithm enters the second stage. + + ftest = finit + stp*gtest + if (stage .eq. 1 .and. f .le. ftest .and. g .ge. zero) + + stage = 2 + +c Test for warnings. + + if (brackt .and. (stp .le. stmin .or. stp .ge. stmax)) + + task = 'WARNING: ROUNDING ERRORS PREVENT PROGRESS' + if (brackt .and. stmax - stmin .le. xtol*stmax) + + task = 'WARNING: XTOL TEST SATISFIED' + if (stp .eq. stpmax .and. f .le. ftest .and. g .le. gtest) + + task = 'WARNING: STP = STPMAX' + if (stp .eq. stpmin .and. (f .gt. ftest .or. g .ge. gtest)) + + task = 'WARNING: STP = STPMIN' + +c Test for convergence. + + if (f .le. ftest .and. abs(g) .le. gtol*(-ginit)) + + task = 'CONVERGENCE' + +c Test for termination. + + if (task(1:4) .eq. 'WARN' .or. task(1:4) .eq. 'CONV') goto 1000 + +c A modified function is used to predict the step during the +c first stage if a lower function value has been obtained but +c the decrease is not sufficient. + + if (stage .eq. 1 .and. f .le. fx .and. f .gt. ftest) then + +c Define the modified function and derivative values. + + fm = f - stp*gtest + fxm = fx - stx*gtest + fym = fy - sty*gtest + gm = g - gtest + gxm = gx - gtest + gym = gy - gtest + +c Call dcstep to update stx, sty, and to compute the new step. + + call dcstep(stx,fxm,gxm,sty,fym,gym,stp,fm,gm, + + brackt,stmin,stmax) + +c Reset the function and derivative values for f. + + fx = fxm + stx*gtest + fy = fym + sty*gtest + gx = gxm + gtest + gy = gym + gtest + + else + +c Call dcstep to update stx, sty, and to compute the new step. + + call dcstep(stx,fx,gx,sty,fy,gy,stp,f,g, + + brackt,stmin,stmax) + + endif + +c Decide if a bisection step is needed. + + if (brackt) then + if (abs(sty-stx) .ge. p66*width1) stp = stx + p5*(sty - stx) + width1 = width + width = abs(sty-stx) + endif + +c Set the minimum and maximum steps allowed for stp. + + if (brackt) then + stmin = min(stx,sty) + stmax = max(stx,sty) + else + stmin = stp + xtrapl*(stp - stx) + stmax = stp + xtrapu*(stp - stx) + endif + +c Force the step to be within the bounds stpmax and stpmin. + + stp = max(stp,stpmin) + stp = min(stp,stpmax) + +c If further progress is not possible, let stp be the best +c point obtained during the search. + + if (brackt .and. (stp .le. stmin .or. stp .ge. stmax) + + .or. (brackt .and. stmax-stmin .le. xtol*stmax)) stp = stx + +c Obtain another function and derivative. + + task = 'FG' + + 1000 continue + +c Save local variables. + + if (brackt) then + isave(1) = 1 + else + isave(1) = 0 + endif + isave(2) = stage + dsave(1) = ginit + dsave(2) = gtest + dsave(3) = gx + dsave(4) = gy + dsave(5) = finit + dsave(6) = fx + dsave(7) = fy + dsave(8) = stx + dsave(9) = sty + dsave(10) = stmin + dsave(11) = stmax + dsave(12) = width + dsave(13) = width1 + + return + end + +c====================== The end of dcsrch ============================== + + subroutine dcstep(stx,fx,dx,sty,fy,dy,stp,fp,dp,brackt, + + stpmin,stpmax) + logical brackt + double precision stx,fx,dx,sty,fy,dy,stp,fp,dp,stpmin,stpmax +c ********** +c +c Subroutine dcstep +c +c This subroutine computes a safeguarded step for a search +c procedure and updates an interval that contains a step that +c satisfies a sufficient decrease and a curvature condition. +c +c The parameter stx contains the step with the least function +c value. If brackt is set to .true. then a minimizer has +c been bracketed in an interval with endpoints stx and sty. +c The parameter stp contains the current step. +c The subroutine assumes that if brackt is set to .true. then +c +c min(stx,sty) < stp < max(stx,sty), +c +c and that the derivative at stx is negative in the direction +c of the step. +c +c The subroutine statement is +c +c subroutine dcstep(stx,fx,dx,sty,fy,dy,stp,fp,dp,brackt, +c stpmin,stpmax) +c +c where +c +c stx is a double precision variable. +c On entry stx is the best step obtained so far and is an +c endpoint of the interval that contains the minimizer. +c On exit stx is the updated best step. +c +c fx is a double precision variable. +c On entry fx is the function at stx. +c On exit fx is the function at stx. +c +c dx is a double precision variable. +c On entry dx is the derivative of the function at +c stx. The derivative must be negative in the direction of +c the step, that is, dx and stp - stx must have opposite +c signs. +c On exit dx is the derivative of the function at stx. +c +c sty is a double precision variable. +c On entry sty is the second endpoint of the interval that +c contains the minimizer. +c On exit sty is the updated endpoint of the interval that +c contains the minimizer. +c +c fy is a double precision variable. +c On entry fy is the function at sty. +c On exit fy is the function at sty. +c +c dy is a double precision variable. +c On entry dy is the derivative of the function at sty. +c On exit dy is the derivative of the function at the exit sty. +c +c stp is a double precision variable. +c On entry stp is the current step. If brackt is set to .true. +c then on input stp must be between stx and sty. +c On exit stp is a new trial step. +c +c fp is a double precision variable. +c On entry fp is the function at stp +c On exit fp is unchanged. +c +c dp is a double precision variable. +c On entry dp is the the derivative of the function at stp. +c On exit dp is unchanged. +c +c brackt is an logical variable. +c On entry brackt specifies if a minimizer has been bracketed. +c Initially brackt must be set to .false. +c On exit brackt specifies if a minimizer has been bracketed. +c When a minimizer is bracketed brackt is set to .true. +c +c stpmin is a double precision variable. +c On entry stpmin is a lower bound for the step. +c On exit stpmin is unchanged. +c +c stpmax is a double precision variable. +c On entry stpmax is an upper bound for the step. +c On exit stpmax is unchanged. +c +c MINPACK-1 Project. June 1983 +c Argonne National Laboratory. +c Jorge J. More' and David J. Thuente. +c +c MINPACK-2 Project. October 1993. +c Argonne National Laboratory and University of Minnesota. +c Brett M. Averick and Jorge J. More'. +c +c ********** + double precision zero,p66,two,three + parameter(zero=0.0d0,p66=0.66d0,two=2.0d0,three=3.0d0) + + double precision gamma,p,q,r,s,sgnd,stpc,stpf,stpq,theta + + sgnd = dp*(dx/abs(dx)) + +c First case: A higher function value. The minimum is bracketed. +c If the cubic step is closer to stx than the quadratic step, the +c cubic step is taken, otherwise the average of the cubic and +c quadratic steps is taken. + + if (fp .gt. fx) then + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dx/s)*(dp/s)) + if (stp .lt. stx) gamma = -gamma + p = (gamma - dx) + theta + q = ((gamma - dx) + gamma) + dp + r = p/q + stpc = stx + r*(stp - stx) + stpq = stx + ((dx/((fx - fp)/(stp - stx) + dx))/two)* + + (stp - stx) + if (abs(stpc-stx) .lt. abs(stpq-stx)) then + stpf = stpc + else + stpf = stpc + (stpq - stpc)/two + endif + brackt = .true. + +c Second case: A lower function value and derivatives of opposite +c sign. The minimum is bracketed. If the cubic step is farther from +c stp than the secant step, the cubic step is taken, otherwise the +c secant step is taken. + + else if (sgnd .lt. zero) then + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dx/s)*(dp/s)) + if (stp .gt. stx) gamma = -gamma + p = (gamma - dp) + theta + q = ((gamma - dp) + gamma) + dx + r = p/q + stpc = stp + r*(stx - stp) + stpq = stp + (dp/(dp - dx))*(stx - stp) + if (abs(stpc-stp) .gt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + brackt = .true. + +c Third case: A lower function value, derivatives of the same sign, +c and the magnitude of the derivative decreases. + + else if (abs(dp) .lt. abs(dx)) then + +c The cubic step is computed only if the cubic tends to infinity +c in the direction of the step or if the minimum of the cubic +c is beyond stp. Otherwise the cubic step is defined to be the +c secant step. + + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + +c The case gamma = 0 only arises if the cubic does not tend +c to infinity in the direction of the step. + + gamma = s*sqrt(max(zero,(theta/s)**2-(dx/s)*(dp/s))) + if (stp .gt. stx) gamma = -gamma + p = (gamma - dp) + theta + q = (gamma + (dx - dp)) + gamma + r = p/q + if (r .lt. zero .and. gamma .ne. zero) then + stpc = stp + r*(stx - stp) + else if (stp .gt. stx) then + stpc = stpmax + else + stpc = stpmin + endif + stpq = stp + (dp/(dp - dx))*(stx - stp) + + if (brackt) then + +c A minimizer has been bracketed. If the cubic step is +c closer to stp than the secant step, the cubic step is +c taken, otherwise the secant step is taken. + + if (abs(stpc-stp) .lt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + if (stp .gt. stx) then + stpf = min(stp+p66*(sty-stp),stpf) + else + stpf = max(stp+p66*(sty-stp),stpf) + endif + else + +c A minimizer has not been bracketed. If the cubic step is +c farther from stp than the secant step, the cubic step is +c taken, otherwise the secant step is taken. + + if (abs(stpc-stp) .gt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + stpf = min(stpmax,stpf) + stpf = max(stpmin,stpf) + endif + +c Fourth case: A lower function value, derivatives of the same sign, +c and the magnitude of the derivative does not decrease. If the +c minimum is not bracketed, the step is either stpmin or stpmax, +c otherwise the cubic step is taken. + + else + if (brackt) then + theta = three*(fp - fy)/(sty - stp) + dy + dp + s = max(abs(theta),abs(dy),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dy/s)*(dp/s)) + if (stp .gt. sty) gamma = -gamma + p = (gamma - dp) + theta + q = ((gamma - dp) + gamma) + dy + r = p/q + stpc = stp + r*(sty - stp) + stpf = stpc + else if (stp .gt. stx) then + stpf = stpmax + else + stpf = stpmin + endif + endif + +c Update the interval which contains a minimizer. + + if (fp .gt. fx) then + sty = stp + fy = fp + dy = dp + else + if (sgnd .lt. zero) then + sty = stx + fy = fx + dy = dx + endif + stx = stp + fx = fp + dx = dp + endif + +c Compute the new step. + + stp = stpf + + return + end + diff --git a/code/new/strat_chem_mod.f b/code/new/strat_chem_mod.f new file mode 100644 index 0000000..e57def0 --- /dev/null +++ b/code/new/strat_chem_mod.f @@ -0,0 +1,1224 @@ +!$Id: strat_chem_mod.f,v 1.2 2012/07/13 20:09:14 nicolas Exp $ +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !MODULE: strat_chem_mod +! +! !DESCRIPTION: Module STRAT\_CHEM\_MOD contains variables and routines for +! performing a simple linearized chemistry scheme for more realistic +! upper boundary conditions. Archived 3D monthly climatological production +! rates and loss frequencies are applied from the GMI combo model. +! +! In the original schem code (schem.f), only the following species +! were destroyed by photolysis in the stratosphere: +! PAN, H2O2, ACET, MEK, ALD2, RCHO, MVK, MACR, R4N2, CH2O, N2O5, HNO4, MP +! and by reaction with OH for: +! ALK4, ISOP, H2O2, ACET, MEK, ALD2, RCHO, MVK, MACR, PMN, R4N2, +! PRPE, C3H8, CH2O, C2H6, HNO4, MP +! +! The updated code includes at least all of these, and many more. The code +! is flexible enough to automatically apply the rate to any new tracers +! for future simulations that share the name in tracer_mod with the +! GMI name. (See Documentation). +! +!\\ +!\\ +! !INTERFACE: +! + MODULE STRAT_CHEM_MOD +! +! !USES: +! + IMPLICIT NONE + PRIVATE +! +! !PUBLIC MEMBER FUNCTIONS: +! + PUBLIC :: DO_STRAT_CHEM + PUBLIC :: CLEANUP_STRAT_CHEM + + ! hml + PUBLIC :: PROD_0 + PUBLIC :: LOSS_0 + PUBLIC :: PROD + PUBLIC :: LOSS + PUBLIC :: DTCHEM + PUBLIC :: NSCHEM + PUBLIC :: GET_RATES + PUBLIC :: GET_RATES_INTERP + PUBLIC :: Strat_TrID_GC + +! +! !PRIVATE MEMBER FUNCTIONS: +! + PRIVATE :: INIT_STRAT_CHEM + +! +! !ADJOINT GROUP: +! +! +! !PUBLIC DATA MEMBERS: +! +! !REMARKS: +! +! References: +! ============================================================================ +! (1 ) +! !REVISION HISTORY: +! 1 Feb 2011 - L. Murray - Initial version +! 22 Oct 2011 - H.-M. Lee - Modified to implement in adjoint. +! Now we can calculte strat prod and loss sensitivity. adj32_025 +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !PRIVATE TYPES: +! + + ! Scalars + REAL*8 :: dTchem ! chemistry time step [s] + INTEGER, PARAMETER :: NTR_GMI = 120 ! Number of species from GMI model + INTEGER :: NSCHEM ! Number of species upon which to + ! apply P's & k's in GEOS-Chem + + ! Arrays + REAL*8, ALLOCATABLE :: PROD(:,:,:,:) + REAL*8, ALLOCATABLE :: LOSS(:,:,:,:) + REAL*8, ALLOCATABLE :: STRAT_OH(:,:,:) ! Monthly mean OH [v/v] + INTEGER, SAVE :: ncID_strat_rates + + ! For adjoint + REAL*8, ALLOCATABLE :: PROD_0(:,:,:,:) + REAL*8, ALLOCATABLE :: LOSS_0(:,:,:,:) + + CHARACTER(LEN=16) :: GMI_TrName(NTR_GMI) ! Tracer names in GMI + INTEGER :: Strat_TrID_GC(NTR_GMI) ! Maps 1:NSCHEM to STT index + INTEGER :: Strat_TrID_GMI(NTR_GMI) ! Maps 1:NSCHEM to GMI index + ! (At most NTR_GMI species could overlap between G-C & GMI) + + + ! Variables used to calculate the strat-trop exchange flux + REAL*8 :: TauInit ! Initial time + INTEGER :: NymdInit, NhmsInit ! Initial date + REAL*8 :: TpauseL_Cnt ! Tropopause counter + REAL*8, ALLOCATABLE :: TpauseL(:,:) ! Tropopause level aggregator + REAL*8, ALLOCATABLE :: MInit(:,:,:,:) ! Init. atm. state for STE period + REAL*8, ALLOCATABLE :: Before(:,:,:) ! Init. atm. state each chem. dt + REAL*8, ALLOCATABLE :: SChem_Tend(:,:,:,:) ! Stratospheric chemical tendency + ! (total P - L) [kg period-1] + + !================================================================= + ! MODULE ROUTINES -- follow below the "CONTAINS" statement + !================================================================= + CONTAINS +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: DO_STRAT_CHEM +! +! !DESCRIPTION: Function DO\_STRAT\_CHEM is the driver routine for computing +! the simple linearized stratospheric chemistry scheme for a host of species +! whose prod/loss rates were determined from the GMI combo model. Ozone is +! treated using either Linoz or Synoz. +! +! !INTERFACE: +! + SUBROUTINE DO_STRAT_CHEM +! +! !USES: +! + USE DAO_MOD, ONLY : AD, CONVERT_UNITS + USE ERROR_MOD, ONLY : DEBUG_MSG, GEOS_CHEM_STOP + USE LOGICAL_MOD, ONLY : LLINOZ, LPRT + USE LINOZ_MOD, ONLY : DO_LINOZ + USE TIME_MOD, ONLY : GET_MONTH, TIMESTAMP_STRING + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, ITS_A_TAGOX_SIM + USE TRACER_MOD, ONLY : N_TRACERS, STT, TCVV, TRACER_MW_KG + USE TRACERID_MOD, ONLY : IDTOX + USE TROPOPAUSE_MOD, ONLY : GET_MIN_TPAUSE_LEVEL, GET_TPAUSE_LEVEL + USE TROPOPAUSE_MOD, ONLY : ITS_IN_THE_TROP + USE NETCDF_UTIL_MOD + + ! adj_group (hml, 07/25/11) + USE ADJ_ARRAYS_MOD, ONLY : PROD_SF, LOSS_SF + USE ADJ_ARRAYS_MOD, ONLY : ID_LOSS + USE ADJ_ARRAYS_MOD, ONLY : IFD, JFD, LFD, DO_CHK_FILE + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE TRACER_MOD, ONLY : STT_STRAT_TMP + USE LOGICAL_ADJ_MOD,ONLY : LADJ + USE LOGICAL_ADJ_MOD,ONLY : LADJ_STRAT + USE CHECKPOINT_MOD, ONLY : MAKE_BEFSTRAT_CHKFILE + USE TIME_MOD, ONLY : GET_NHMS + USE TIME_MOD, ONLY : GET_NYMD + USE TIME_MOD, ONLY : GET_TAU + USE UPBDFLX_MOD, ONLY : UPBDFLX_O3, INIT_UPBDFLX + + +# include "CMN_SIZE" +! +! !REMARKS: +! +! !REVISION HISTORY: +! 1 Feb 2011 - L. Murray - Initial version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + LOGICAL, SAVE :: FIRST = .TRUE. + INTEGER, SAVE :: LASTMONTH = -999 + INTEGER, SAVE :: LASTSEASON = -1 + INTEGER :: I, J, L, N, LMIN + INTEGER :: IORD, JORD, KORD + INTEGER :: NHMS + INTEGER :: NYMD + INTEGER :: NN, NS, NSL + REAL*8 :: TAU + REAL*8 :: dt, P, k, M0 + REAL*8 :: STT0(IIPAR,JJPAR,LLPAR,N_TRACERS) + CHARACTER(LEN=16) :: STAMP + + + !=============================== + ! DO_STRAT_CHEM begins here! + !=============================== + + STAMP = TIMESTAMP_STRING() + WRITE( 6, 10 ) STAMP + 10 FORMAT( ' - DO_STRAT_CHEM: Linearized strat chemistry at ', a ) + + IF ( FIRST ) THEN + + ! Allocate all module arrays + CALL INIT_STRAT_CHEM + +#if defined( GEOS_3 ) + ! Initialize some Synoz variables + IF ( .NOT. ( LLINOZ ) ) THEN + CALL GET_ORD( IORD, JORD, KORD ) + CALL INIT_UPBDFLX( IORD, JORD, KORD ) + ENDIF +#endif + + ENDIF + + ! Get the minimum level extent of the tropopause + LMIN = GET_MIN_TPAUSE_LEVEL() + + IF ( GET_MONTH() /= LASTMONTH ) THEN + + IF ( LPRT ) CALL DEBUG_MSG( '### STRAT_CHEM: at GET_RATES' ) + + ! Read rates for this month + IF ( ITS_A_FULLCHEM_SIM() ) THEN +#if defined( GRID4x5 ) || defined( GRID2x25 ) + CALL GET_RATES( GET_MONTH() ) +#else + ! For resolutions finer than 2x2.5, nested, + ! or otherwise exotic domains and resolutions + CALL GET_RATES_INTERP( GET_MONTH() ) +#endif + ENDIF + + ! Save month for next iteration + LASTMONTH = GET_MONTH() + ENDIF + + ! Set first-time flag to false + FIRST = .FALSE. + + IF ( LPRT ) CALL DEBUG_MSG( '### STRAT_CHEM: at DO_STRAT_CHEM' ) + + WRITE(6,*) '-----------------------------------------------------' + write(6,*) ' Doing stratospheric chemistry (STRAT_CHEM_MOD) ' + WRITE(6,*) '-----------------------------------------------------' + + + !================================================================ + ! Full chemistry simulations + !================================================================ + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + !! Advance counter for number of times we've sampled the tropopause level + !TpauseL_CNT = TpauseL_CNT + 1d0 + + !============================================================= + ! Do chemical production and loss for non-ozone species for + ! which we have explicit prod/loss rates from GMI + !============================================================= + +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J, L, N, k, P, dt, M0, NS, NN ) +!$OMP+SCHEDULE( DYNAMIC ) + DO J = 1, JJPAR + DO I = 1, IIPAR + + ! Add to tropopause level aggregator for later determining STE flux + TpauseL(I,J) = TpauseL(I,J) + GET_TPAUSE_LEVEL(I,J) + + DO L = LMIN, LLPAR + + IF ( ITS_IN_THE_TROP( I, J, L ) ) CYCLE + + DO N = 1, NSCHEM ! Tracer index of active strat chem species + NN = Strat_TrID_GC(N) ! Tracer index in STT + + ! Skip Ox; we'll always use either Linoz or Synoz + ! Adj use GMI rate for Ox if LINOZ is off (hml, 10/31/11) + !IF ( ITS_A_FULLCHEM_SIM() .and. NN .eq. IDTOx ) CYCLE + IF ( ITS_A_FULLCHEM_SIM() .and. (NN .eq. IDTOx) .and. + & LLINOZ ) CYCLE + + ! adj_group: make a version that applies scaling factors + ! and use this if the stratosphere adjoint ID #'s are active + IF ( LADJ_STRAT ) THEN + DO NS = 1, NSTPL + + NSL = ID_LOSS(NS) ! same for ID_PROD(NS) + + IF ( NN .EQ. NSL ) THEN + + PROD(I,J,L,N) = PROD_0(I,J,L,N) + & * PROD_SF(I,J,1,NS) + LOSS(I,J,L,N) = LOSS_0(I,J,L,N) + & * LOSS_SF(I,J,1,NS) + ENDIF + ENDDO + ENDIF + + ! Check point values of STT + STT_STRAT_TMP(I,J,L,NN) = STT(I,J,L,NN) + + dt = DTCHEM ! timestep [s] + k = LOSS(I,J,L,N) ! loss freq [s-1] + P = PROD(I,J,L,N) * AD(I,J,L) / TCVV(NN)! production term [kg s-1] + M0 = STT(I,J,L,NN) ! initial mass [kg] + + ! debug test + !IF ( I == IFD .and. J == JFD .and. L == LFD ) THEN + ! print*, NN,' STRAT TEST fwd: k = ', k + ! print*, NN,' STRAT TEST fwd: P = ', P + ! print*, NN,' STRAT TEST fwd: M0= ', M0 + !ENDIF + + ! No prod or loss at all + IF ( k .eq. 0d0 .and. P .eq. 0d0 ) CYCLE + + ! Simple analytic solution to dM/dt = P - kM over [0,dt] + IF ( k .gt. 0d0 ) THEN + STT(I,J,L,NN) = M0 * exp(-k*dt) + (P/k) + & * (1d0-exp(-k*dt)) + ELSE + STT(I,J,L,NN) = M0 + P*dt + ENDIF + + ! Aggregate chemical tendency [kg box-1] + SCHEM_TEND(I,J,L,NN) = SCHEM_TEND(I,J,L,NN) + & + ( STT(I,J,L,NN) - M0 ) + + ENDDO ! N + ENDDO ! L + ENDDO ! I + ENDDO ! J +!$OMP END PARALLEL DO + + ! Make check point file + IF ( DO_CHK_FILE() ) THEN + NHMS = GET_NHMS() + NYMD = GET_NYMD() + TAU = GET_TAU() + CALL MAKE_BEFSTRAT_CHKFILE( NYMD, NHMS, TAU ) + ENDIF + + !=================================== + ! Ozone + !=================================== + + ! Make note of inital state for determining tendency later + BEFORE = STT(:,:,:,IDTOX ) + ! Put ozone in v/v + STT(:,:,:,IDTOX ) = STT(:,:,:,IDTOX) * TCVV( IDTOX ) / AD + + IF ( LLINOZ ) THEN + CALL DO_LINOZ ! Linoz + ELSE IF ( .not. LADJ ) THEN + ! Must use Linoz or strat chem Ox fluxes for the adjoint + CALL UPBDFLX_O3 ! Synoz + ENDIF + + ! Now move unit conversion into LINOZ (hml, 11/06/11) + ! Put ozone back to kg + STT(:,:,:,IDTOX) = STT(:,:,:,IDTOX) * AD / TCVV( IDTOX ) + + ! Put tendency into diagnostic array [kg box-1] + SCHEM_TEND(:,:,:,IDTOX) = SCHEM_TEND(:,:,:,IDTOX) + & + ( STT(:,:,:,IDTOX) - BEFORE ) + + + !====================================================================== + ! Tagged Ox simulation + !====================================================================== + + ELSE IF ( ITS_A_TAGOX_SIM() ) THEN + + ! Intial conditions + STT0(:,:,:,:) = STT(:,:,:,:) + + CALL CONVERT_UNITS( 1, N_TRACERS, TCVV, AD, STT ) ! kg -> v/v + + IF ( LLINOZ ) THEN + CALL DO_LINOZ ! Linoz + ELSE IF ( .not. LADJ ) THEN + ! must use Linoz or strat chem Ox fluxes for the adjoint + CALL UPBDFLX_O3 ! Synoz + ENDIF + + CALL CONVERT_UNITS( 2, N_TRACERS, TCVV, AD, STT ) ! v/v -> kg + + ! Add to tropopause level aggregator for later determining STE flux + TpauseL_CNT = TpauseL_CNT + 1d0 +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO I=1,IIPAR + DO J=1,JJPAR + TpauseL(I,J) = TpauseL(I,J) + GET_TPAUSE_LEVEL(I,J) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Aggregate chemical tendency [kg box-1] + DO N=1,NSCHEM + NN = Strat_TrID_GC(N) + SCHEM_TEND(:,:,:,NN) = SCHEM_TEND(:,:,:,NN) + & + ( STT(:,:,:,NN) - STT0(:,:,:,NN) ) + ENDDO + + ELSE + + ! The code will need to be modified for other tagged simulations + ! (e.g., CO). Simulations like CH4, CO2 with standard tracer names + ! should probably just work as is with the full chemistry code above, + ! but would need to be tested. + WRITE( 6, * ) 'Strat chemistry needs to be activated for ' // + & 'your simulation type.' + !WRITE( 6, * ) 'Please see GeosCore/strat_chem_mod.F90' // & + WRITE( 6, * ) 'Please see new/strat_chem_mod.f' // + & 'or disable in input.geos' + CALL GEOS_CHEM_STOP + + ENDIF + + END SUBROUTINE DO_STRAT_CHEM +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: GET_RATES +! +! !DESCRIPTION: Function GET\_RATES reads from disk the chemical production +! and loss rates for the species of interest +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GET_RATES( THISMONTH ) +! +! !USES: +! + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT + USE BPCH2_MOD, ONLY : GET_TAU0, READ_BPCH2 + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE TIME_MOD, ONLY : GET_MONTH + USE LOGICAL_MOD, ONLY : LLINOZ + USE TRACER_MOD, ONLY : N_TRACERS, TRACER_NAME, TRACER_COEFF + USE TRANSFER_MOD, ONLY : TRANSFER_3D + USE NETCDF_UTIL_MOD, ONLY : NCDF_GET_VAR + USE NETCDF_UTIL_MOD, ONLY : NCDF_GET_VARID + USE NETCDF_UTIL_MOD, ONLY : NCDF_OPEN_FOR_READ + USE NETCDF_UTIL_MOD, ONLY : NCDF_CLOSE + + + IMPLICIT NONE + +# include "CMN_SIZE" + +! +! !INPUT PARAMETERS: +! + ! Arguments + INTEGER,INTENT(IN) :: THISMONTH +! +! !REVISION HISTORY: +! 1 Feb 2011 - L. Murray - Initial version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=6) :: SPNAME( NTR_GMI ) + REAL*4 :: ARRAY( IIPAR, JJPAR, LGLOB ) ! Full vertical res + REAL*8 :: ARRAY2( IIPAR, JJPAR, LLPAR )! Actual vertical res + REAL*8 :: XTAU + INTEGER :: N, M, S, F, NN, fileID + INTEGER :: prodID, lossID + INTEGER :: ohID + + + !================================================================= + ! GET_RATES begins here + !================================================================= + + ! Initialize arrays + LOSS = 0d0 + PROD = 0d0 + + WRITE(6, 11 ) + & ' - Getting new strat prod/loss rates for month: ', + & THISMONTH +11 FORMAT( a, I2.2 ) + + M = THISMONTH + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Get stratospheric OH mixing ratio [v/v] + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + FILENAME = 'strat_chem_201206/gmi.clim.OH.' // + & GET_NAME_EXT() // '.' // GET_RES_EXT() // '.nc' + FILENAME = TRIM( DATA_DIR ) // TRIM( FILENAME ) + WRITE(6,'(a)') ' => Reading from file: ' // trim(filename) + call ncdf_open_for_read( fileID, TRIM( FILENAME ) ) + + ohID = ncdf_get_varid( fileID, 'species' ) + + call ncdf_get_var( fileID, ohID, array, + & (/ 1, 1, 1, m /), ! Start + & (/ iipar, jjpar, lglob, 1 /) ) ! Count + call ncdf_close( fileID ) + + ! Cast from REAL*4 to REAL*8 and resize to 1:LLPAR + call transfer_3D( array, array2 ) + + STRAT_OH(:,:,:) = ARRAY2 + + DO N=1,NSCHEM + NN = Strat_TrID_GMI(N) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Open individual species file + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + FILENAME = 'strat_chem_201206/gmi.clim.' // + & TRIM( GMI_TrName(NN) ) // '.' // + & GET_NAME_EXT() // '.' // GET_RES_EXT() // '.nc' + FILENAME = TRIM( DATA_DIR ) // TRIM( FILENAME ) + WRITE(6,'(a)') ' => Reading from file: ' // trim(filename) + call ncdf_open_for_read( fileID, TRIM( FILENAME ) ) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Read production rate [v/v/s] + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! Get the variable IDs for the species, prod and loss rates + prodID = ncdf_get_varid( fileID, 'prod' ) + + call ncdf_get_var( fileID, prodID, array, + & (/ 1, 1, 1, m /), ! Start + & (/ iipar, jjpar, lglob, 1 /) ) ! Count + + ! Cast from REAL*4 to REAL*8 and resize to 1:LLPAR + call transfer_3D( array, array2 ) + + PROD(:,:,:,N) = ARRAY2 + + ! Save rates from file to respective arrays (hml, 09/15/11) + PROD_0(:,:,:,N) = PROD(:,:,:,N) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Read loss frequencies [s^-1] + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + lossID = ncdf_get_varid( fileID, 'loss' ) + + call ncdf_get_var( fileID, lossID, array, + & (/ 1, 1, 1, m /), ! Start + & (/ iipar, jjpar, lglob, 1 /) ) ! Count + + ! Cast from REAL*4 to REAL*8 and resize to 1:LLPAR + call transfer_3D( array, array2 ) + + LOSS(:,:,:,N) = ARRAY2 + + ! Save rates from file to respective arrays (hml, 09/15/11) + LOSS_0(:,:,:,N) = LOSS(:,:,:,N) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Close species file + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + call ncdf_close( fileID ) + + ENDDO + + END SUBROUTINE GET_RATES +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: GET_RATES_INTERP +! +! !DESCRIPTION: Function GET\_RATES\_INTERP reads from disk the chemical +! production and loss rates for the species of interest to resolutions finer +! than 2 x 2.5 (e.g., nested simluations) via simple nearest-neighbor mapping. +!\\ +!\\ +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE GET_RATES_INTERP( THISMONTH ) +! +! !USES: +! + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE GRID_MOD, ONLY : GET_YMID, GET_XMID + USE LOGICAL_MOD, ONLY : LLINOZ + USE TRACER_MOD, ONLY : N_TRACERS, TRACER_NAME, TRACER_COEFF + USE TRANSFER_MOD, ONLY : TRANSFER_3D + USE ADJ_ARRAYS_MOD, ONLY : NSTPL + USE NETCDF_UTIL_MOD, ONLY : NCDF_GET_VAR + USE NETCDF_UTIL_MOD, ONLY : NCDF_GET_VARID + USE NETCDF_UTIL_MOD, ONLY : NCDF_OPEN_FOR_READ + USE NETCDF_UTIL_MOD, ONLY : NCDF_CLOSE + +# include "define.h" +# include "CMN_SIZE" +! +! !INPUT PARAMETERS: +! + ! Arguments + INTEGER,INTENT(IN) :: THISMONTH +! +! !REVISION HISTORY: +! 1 Feb 2011 - L. Murray - Initial version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + CHARACTER(LEN=255) :: FILENAME + CHARACTER(LEN=6) :: SPNAME( NTR_GMI ) + REAL*4 :: ARRAY( IIPAR, JJPAR, LGLOB ) + REAL*8 :: ARRAY2( IIPAR, JJPAR, LLPAR ) + INTEGER :: N, M, S, F + INTEGER :: NN + INTEGER :: ohID + INTEGER :: prodID, lossID + INTEGER :: lat_varID, lon_varID + + REAL*4 :: XMID_COARSE(144), YMID_COARSE(91) + INTEGER :: I_f2c(IIPAR), J_f2c(JJPAR) ! f2c = fine to coar map'ng + INTEGER :: I, J, fileID + INTEGER :: II(1), JJ(1) + REAL*4 :: COLUMN( LGLOB ) + + + + !================================================================= + ! GET_RATES_INTERP begins here + !================================================================= + + ! In the original schem code, the following species were destroyed + ! by photolysis in the stratosphere: + ! PAN, H2O2, ACET, MEK, ALD2, RCHO, MVK, MACR, R4N2, CH2O, + ! N2O5, HNO4, MP + ! And by reaction with OH for: + ! ALK4, ISOP, H2O2, ACET, MEK, ALD2, RCHO, MVK, MACR, PMN, R4N2, + ! PRPE, C3H8, CH2O, C2H6, HNO4, MP + ! The updated code includes at least all of these, and several more. + + ! Initialize arrays + LOSS = 0d0 + PROD = 0d0 + + ! first read in the OH file so that we can get the lat and long + ! values to populate XMID_COARSE and YMID_COARSE + ! Path to input data, use 2 x 2.5 file +#if defined( GEOS_FP ) + FILENAME = 'strat_chem_201206/gmi.clim.OH.geos5' // + & '.2x25.nc' +#else + FILENAME = 'strat_chem_201206/gmi.clim.OH.' // GET_NAME_EXT() // + & '.2x25.nc' +#endif + !FILENAME = TRIM( DATA_DIR_1x1 ) // TRIM( FILENAME ) + !FILENAME = TRIM( DATA_DIR ) // TRIM('../GEOS_2x25/') // + FILENAME = TRIM( DATA_DIR ) // TRIM('../GEOS_2x2.5/') // + & TRIM( FILENAME ) + + WRITE(6, 11 ) + & ' - Getting new strat prod/loss rates for month: ', + & THISMONTH +11 FORMAT( a, I2.2 ) + + ! Open the netCDF file containing the rates + WRITE(6,'(a)') + & ' => Interpolate to resolution from file: ' + & // trim(filename) + call ncdf_open_for_read( fileID, TRIM( filename ) ) + + ! Get the lat and lon centers of the 2x2.5 GMI climatology + ! WARNING MAKE 2x25 after testing + !call NcRd( XMID_COARSE, fileID, 'longitude', (/1/), (/144/) ) + !call NcRd( YMID_COARSE, fileID, 'latitude', (/1/), (/91/) ) + lat_varID = ncdf_get_varid( fileID, 'latitude' ) + lon_varID = ncdf_get_varid( fileID, 'longitude' ) + + !call NcRd( XMID_COARSE, fileID, 'longitude', (/1/), (/144/) ) + !call NcRd( YMID_COARSE, fileID, 'latitude', (/1/), (/91/) ) + call ncdf_get_var( fileID, lon_varID, XMID_COARSE, (/1/), (/144/)) + call ncdf_get_var( fileID, lat_varID, YMID_COARSE, (/1/), (/91/) ) + + ! For each fine grid index, determine the closest coarse (2x2.5) index + ! Note: This doesn't do anything special for the date line, and may + ! therefore not pick the exact closest if it is on the other side. + ! Note: CMN_SIZE_MOD claims in its comments that IIPAR < IGLOB, but + ! in actuality, IIPAR = IGLOB and JJPAR = JGLOB, the dimensions of the nested + ! region. + DO I=1,IGLOB + II = MINLOC( ABS( GET_XMID(I) - XMID_COARSE ) ) + I_f2c(I) = II(1) + !print*,'I:',I,'->',II(1) + ENDDO + DO J=1,JGLOB + JJ = MINLOC( ABS( GET_YMID(J) - YMID_COARSE ) ) + J_f2c(J) = JJ(1) + !print*,'J:',J,'->',JJ(1) + ENDDO + +! call ncdf_close( fileID ) + + M = THISMONTH + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !Get Stratospheric OH concentrations [v/v] + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ohID = ncdf_get_varid( fileID, 'species' ) + + DO I=1,IGLOB + DO J=1,JGLOB + + call ncdf_get_var( fileID, ohID, column, + & (/ I_f2c(I), J_f2c(J), 1, m /), ! Start + & (/ 1, 1, lglob, 1 /) ) ! Count + array( I, J, : ) = column + + ENDDO + ENDDO + call ncdf_close( fileID ) + call transfer_3D( array, array2 ) + STRAT_OH(:,:,:) = ARRAY2 + + + DO N=1,NSCHEM + NN = Strat_TrID_GMI(N) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Open individual species file + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! Path to input data, use 2 x 2.5 file + ! (lzh,02/01/2015) add geosfp - use geos-5 +#if defined( GEOS_FP ) + FILENAME = 'strat_chem_201206/gmi.clim.' // + & TRIM( GMI_TrName(NN) ) // '.geos5' // + & '.2x25.nc' +#else + FILENAME = 'strat_chem_201206/gmi.clim.' // + & TRIM( GMI_TrName(NN) ) // '.' // GET_NAME_EXT() // + & '.2x25.nc' +#endif + !FILENAME = TRIM( DATA_DIR ) // TRIM('../GEOS_2x25/') // + FILENAME = TRIM( DATA_DIR ) // TRIM('../GEOS_2x2.5/') // + & TRIM( FILENAME ) + + WRITE(6,'(a)') + & ' => Interpolate to resolution from file: ' // + & trim(filename) + + call ncdf_open_for_read( fileID, TRIM( FILENAME ) ) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Read production rate [v/v/s] + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + array = 0.0 + + prodID = ncdf_get_varid( fileID, 'prod' ) + + DO I=1,IGLOB + DO J=1,JGLOB + + call ncdf_get_var( fileID, prodID, column, + & (/ I_f2c(I), J_f2c(J), 1, m /), ! Start + & (/ 1, 1, lglob, 1 /) ) ! Count + array( I, J, : ) = column + + ENDDO + ENDDO + + ! Cast from REAL*4 to REAL*8 and resize to 1:LLPAR if necessary + call transfer_3D( array, array2 ) + + PROD(:,:,:,N) = ARRAY2 + + ! Save rates from file to respective arrays (hml, 09/15/11) + PROD_0(:,:,:,N) = PROD(:,:,:,N) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Read loss frequencies [s^-1] + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + array = 0.0 + + lossID = ncdf_get_varid( fileID, 'loss' ) + + DO I=1,IGLOB + DO J=1,JGLOB + + call ncdf_get_var( fileID, lossID, column, + & (/ I_f2c(I), J_f2c(J), 1, m /), ! Start + & (/ 1, 1, lglob, 1 /) ) ! Count + array( I, J, : ) = column + + ENDDO + ENDDO + + ! Cast from REAL*4 to REAL*8 and resize to 1:LLPAR if necessary + call transfer_3D( array, array2 ) + + LOSS(:,:,:,N) = ARRAY2 + + ! Save rates from file to respective arrays (hml, 09/15/11) + LOSS_0(:,:,:,N) = LOSS(:,:,:,N) + + call ncdf_close( fileID ) + + ENDDO + + !call ncdf_close( ncID_strat_rates ) + + END SUBROUTINE GET_RATES_INTERP +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: calc_ste +! +! !DESCRIPTION: Subroutine CALC\_STE estimates what the stratosphere-to- +! troposphere exchange flux must have been since the last time +! it was reset +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE CALC_STE +! +! !USES: +! + USE TRACER_MOD, ONLY : STT, TRACER_MW_KG, N_TRACERS, TRACER_NAME + USE TIME_MOD, ONLY : GET_TAU, GET_NYMD, GET_NHMS, EXPAND_DATE + + IMPLICIT NONE + +#include "define.h" +#include "CMN_SIZE" + +! +! !REVISION HISTORY: +! 28 Apr 2012 - L. Murray - Initial version +!EOP +!------------------------------------------------------------------------------ +!BOC + + REAL*8 :: M1(IIPAR,JJPAR,LLPAR), M2(IIPAR,JJPAR,LLPAR) + REAL*8 :: dStrat, STE, Tend, tauEnd, dt + INTEGER :: N, I, J, L, NN, LTP(IIPAR,JJPAR) + CHARACTER(LEN=256) :: dateStart, dateEnd + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! By simple mass balance, dStrat/dt = P - L - STE, + ! where STE is the net stratosphere-to-troposphere mass exchange. + ! + ! Therefore, we estimate STE as + ! STE = (P-L) - dStrat/dt + ! + ! As the tropopause is dynamic, we use the mean tropopause level during + ! the period for determining initial and end stratospheric masses. + ! (ltm, 04/28/2012) + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +#if defined( NESTED_NA ) || defined( NESTED_CH ) || defined( NESTED_EU ) + ! This method only works for a global domain. + ! It could be modified for nested domains if the total mass flux across the + ! boundaries during the period is taken into account. + RETURN +#endif + + ! Determine mean tropopause level for the period +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO I = 1,IIPAR + DO J = 1,JJPAR + LTP(I,J) = NINT( TPauseL(I,J) / TPauseL_Cnt ) + ENDDO + ENDDO +!$OMP END PARALLEL DO + + ! Period over which STE is being determined [a] + tauEnd = GET_TAU() ! [h] + dt = ( tauEnd - tauInit ) / 24d0 / 365.25d0 + + dateStart = 'YYYY-MM-DD hh:mm' + CALL EXPAND_DATE(dateStart,NymdInit,NhmsInit) + dateEnd = 'YYYY-MM-DD hh:mm' + CALL EXPAND_DATE(dateEnd,GET_NYMD(),GET_NHMS()) + + ! Print to output + WRITE( 6, * ) '' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, '(a)' ) ' Strat-Trop Exchange' + WRITE( 6, '(a)' ) REPEAT( '-', 79 ) + WRITE( 6, '(a)' ) + & ' Global stratosphere-to-troposphere fluxes estimated over' + WRITE( 6, 100 ) TRIM(dateStart), TRIM(dateEnd) + WRITE( 6, * ) '' + WRITE( 6, 110 ) 'Species','[moles a-1]','* [g/mol]','= [Tg a-1]' + + 100 FORMAT( 2x,a16,' to ',a16 ) + 110 FORMAT( 2x,a8,':',4x,a11 ,4x,a9 ,4x, a11 ) + + ! Loop through each species + DO N=1,N_TRACERS + + ! Populate before (M1) and after (M2) state for the species [kg] + M1 = MInit(:,:,:,N) + M2 = STT(:,:,:,N) + + ! Zero out tropopshere and determine total change in the stratospheric + ! burden of species N (dStrat) [kg] +!$OMP PARALLEL DO +!$OMP+DEFAULT( SHARED ) +!$OMP+PRIVATE( I, J ) + DO I=1,IIPAR + DO J=1,JJPAR + M2(I,J,1:LTP(I,J)) = 0d0 + M1(I,J,1:LTP(I,J)) = 0d0 + ENDDO + ENDDO +!$OMP END PARALLEL DO + dStrat = SUM(M2)-SUM(M1) + + ! The total chemical tendency (P-L) over the period for species N [kg] + Tend = SUM(Schem_tend(:,:,:,N)) + + ! Calculate flux as STE = (P-L) - dStrat/dt + STE = (Tend-dStrat)/dt ! [kg a-1] + + ! Print to standard output + WRITE(6,120) TRIM(TRACER_NAME(N)), + & STE/TRACER_MW_KG(N), ! mol/a-1 + & TRACER_MW_KG(N)*1d3, ! g/mol + & STE*1d-9 ! Tg a-1 + + ENDDO + + 120 FORMAT( 2x,a8,':',4x,e11.3,4x,f9.1,4x,f11.4 ) + + WRITE( 6, * ) '' + WRITE( 6, '(a)' ) REPEAT( '=', 79 ) + WRITE( 6, * ) '' + + ! Reset variables for next STE period + NymdInit = GET_NYMD() + NhmsInit = GET_NHMS() + TauInit = GET_TAU() + TPauseL_Cnt = 0d0 + TPauseL(:,:) = 0d0 + SChem_tend(:,:,:,:) = 0d0 + MInit(:,:,:,:) = STT(:,:,:,:) + + END SUBROUTINE CALC_STE +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: init_strat_chem +! +! !DESCRIPTION: Subroutine INIT\_STRAT\_CHEM allocates all module arrays. +! It also opens the necessary rate files. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE INIT_STRAT_CHEM +! +! !USES: +! + USE ERROR_MOD, ONLY : ALLOC_ERR + USE LOGICAL_MOD, ONLY : LLINOZ + USE TRACER_MOD, ONLY : ITS_A_FULLCHEM_SIM, ITS_A_TAGOX_SIM + USE TRACER_MOD, ONLY : N_TRACERS, TRACER_NAME, TRACER_COEFF + USE TRACER_MOD, ONLY : TRACER_COEFF, STT + USE BPCH2_MOD, ONLY : GET_NAME_EXT, GET_RES_EXT + USE DIRECTORY_MOD, ONLY : DATA_DIR + USE TIME_MOD, ONLY : EXPAND_DATE + USE TIME_MOD, ONLY : GET_TAU, GET_NYMD, GET_NHMS + USE TIME_MOD, ONLY : GET_TS_CHEM + USE LOGICAL_ADJ_MOD, ONLY : LADJ + USE UPBDFLX_MOD, ONLY : UPBDFLX_O3, INIT_UPBDFLX + +# include "CMN_SIZE" +! +! !REVISION HISTORY: +! 1 Feb 2011 - L. Murray - Initial version +!EOP +!------------------------------------------------------------------------------ +!BOC +! +! !LOCAL VARIABLES: +! + + CHARACTER(LEN=16) :: sname + INTEGER :: AS, N, NN + + CHARACTER(LEN=255) :: FILENAME, FILENAMEOUT + CHARACTER(LEN=6) :: SPNAME( NTR_GMI ) + INTEGER :: spname_varID + + !================================================================= + ! INIT_STRAT_CHEM begins here! + !================================================================= + + ! Initialize counters, initial times, mapping arrays + TpauseL_Cnt = 0. + NSCHEM = 0 + TauInit = GET_TAU() + NymdInit = GET_NYMD() + NhmsInit = GET_NHMS() + strat_trID_GC(:) = 0 + strat_trID_GMI(:) = 0 + + ! Initialize timestep for chemistry [s] + dTchem = GET_TS_CHEM() * 60d0 + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Determine the mapping for the GMI to the GC variables based on + ! tracer name, which only needs to be done once per model run. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! List of available tracers with archived monthly climatological + ! production rates, loss frequencies, and mixing ratios from the + ! GMI Combo model (tracer names here are as used in GMI). + GMI_TrName = (/ + & 'A3O2', 'ACET', 'ACTA', 'ALD2', 'ALK4', 'ATO2', + & 'B3O2', 'Br', 'BrCl', 'BrO', 'BrONO2', 'C2H6', + & 'C3H8', 'CCl4', 'CF2Br2', 'CF2Cl2', 'CF2ClBr', 'CF3Br', + & 'CFC113', 'CFC114', 'CFC115', 'CFCl3', 'CH2O', 'CH3Br', + & 'CH3CCl3', 'CH3Cl', 'CH4', 'CO', 'Cl', 'Cl2', + & 'Cl2O2', 'ClO', 'ClONO2', 'EOH', 'ETO2', 'ETP', + & 'GCO3', 'GLYC', 'GLYX', 'GP', 'GPAN', 'H', + & 'H2', 'H2402', 'H2O', 'H2O2', 'HAC', 'HBr', + & 'HCFC141b', 'HCFC142b', 'HCFC22', 'HCOOH', 'HCl', 'HNO2', + & 'HNO3', 'HNO4', 'HO2', 'HOBr', 'HOCl', 'IALD', + & 'IAO2', 'IAP', 'INO2', 'INPN', 'ISN1', 'ISNP', + & 'ISOP', 'KO2', 'MACR', 'MAN2', 'MAO3', 'MAOP', + & 'MAP', 'MCO3', 'MEK', 'MGLY', 'MO2', 'MOH', + & 'MP', 'MRO2', 'MRP', 'MVK', 'MVN2', 'N', + & 'N2O', 'N2O5', 'NO', 'NO2', 'NO3', 'NOx', + & 'O', 'O1D', 'O3', 'OClO', 'OH', 'Ox', + & 'PAN', 'PMN', 'PO2', 'PP', 'PPN', 'PRN1', + & 'PRPE', 'PRPN', 'R4N1', 'R4N2', 'R4O2', 'R4P', + & 'RA3P', 'RB3P', 'RCHO', 'RCO3', 'RCOOH', 'RIO1', + & 'RIO2', 'RIP', 'ROH', 'RP', 'VRO2', 'VRP' /) + + + !===========================! + ! Full chemistry simulation ! + !===========================! + IF ( ITS_A_FULLCHEM_SIM() ) THEN + + DO NN = 1, NTR_GMI + + sname = TRIM(GMI_TrName(NN)) + + DO N = 1, N_TRACERS + + IF ( TRIM(TRACER_NAME(N)) .eq. TRIM(sname) ) THEN + + IF ( LLINOZ .and. + & TRIM(TRACER_NAME(N)) .eq. 'Ox' ) THEN + WRITE(6,*), TRIM(TRACER_NAME(N)) // ' (via Linoz)' + + ! For adjoint + !ELSE IF ( TRIM(TRACER_NAME(N)) .eq. 'Ox' ) THEN + ! WRITE(6,*) TRIM(TRACER_NAME(N)) // ' (via Synoz)' + ELSEIF ( TRIM(TRACER_NAME(N)) .eq. 'Ox' ) THEN + WRITE(6,*),TRIM(TRACER_NAME(N)) // ' (Ox via GMI)' + + ELSE + WRITE(6,*), TRIM(TRACER_NAME(N)) // + & ' (via GMI rates)' + ENDIF + + NSCHEM = NSCHEM + 1 + Strat_TrID_GC(NSCHEM) = N ! Maps 1:NSCHEM to STT index + Strat_TrID_GMI(NSCHEM) = NN ! Maps 1:NSCHEM to GMI_TrName index + + ENDIF + + ENDDO + ENDDO + + ! Allocate array to hold monthly mean OH mixing ratio + ALLOCATE( STRAT_OH( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /=0 ) CALL ALLOC_ERR( 'STRAT_OH' ) + STRAT_OH = 0d0 + + !===========! + ! Tagged Ox ! + !===========! + ELSE IF ( ITS_A_TAGOX_SIM() ) THEN + + IF ( LLINOZ ) THEN + WRITE(6,*) 'Linoz ozone performed on: ' + ELSE IF ( .not. LADJ ) THEN + ! must use Linoz or strat chem Ox fluxes for the adjoint + CALL UPBDFLX_O3 ! Synoz + WRITE(6,*) 'Synoz ozone performed on: ' + ENDIF + + DO N = 1, N_TRACERS + IF ( TRIM(TRACER_NAME(N)) .eq. 'Ox' .or. + & TRIM(TRACER_NAME(N)) .eq. 'OxStrt' ) THEN + NSCHEM = NSCHEM + 1 + Strat_TrID_GC(NSCHEM) = N + WRITE(6,*) TRIM(TRACER_NAME(N)) + ENDIF + ENDDO + + ENDIF + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%! + ! Allocate and initialize prod & loss arrays ! + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%! + + ! Allocate PROD -- array for clim. production rates [v/v/s] + ALLOCATE( PROD( IIPAR, JJPAR, LLPAR, NSCHEM ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD' ) + PROD = 0d0 + + ! Allocate LOSS -- array for clim. loss freq [s-1] + ALLOCATE( LOSS( IIPAR, JJPAR, LLPAR, NSCHEM ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS' ) + LOSS = 0d0 + + ! For adjoint + !ALLOCATE( PROD_0( IIPAR, JJPAR, LLPAR, N_TRACERS ), STAT=AS ) + ALLOCATE( PROD_0( IIPAR, JJPAR, LLPAR, NSCHEM ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'PROD_0' ) + PROD_0 = 0d0 + + !ALLOCATE( LOSS_0( IIPAR, JJPAR, LLPAR, N_TRACERS ), STAT=AS ) + ALLOCATE( LOSS_0( IIPAR, JJPAR, LLPAR, NSCHEM ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'LOSS_0' ) + LOSS_0 = 0d0 + + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%! + ! Allocate and initialize arrays for STE calculation ! + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%! + + ! Array to hold initial state of atmosphere at the beginning + ! of the period over which to estimate STE. Populate with + ! initial atm. conditions from restart file [kg]. + ALLOCATE( MInit( IIPAR, JJPAR, LLPAR, N_TRACERS ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'MInit' ) + MInit = STT + + ! Array to determine the mean tropopause level over the period + ! for which STE is being estimated. + ALLOCATE( TPAUSEL( IIPAR, JJPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'TPAUSEL' ) + TPAUSEL = 0d0 + + ! Array to save chemical state before each chemistry time step [kg] + ALLOCATE( BEFORE( IIPAR, JJPAR, LLPAR ), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'BEFORE' ) + BEFORE = 0d0 + + ! Array to aggregate the stratospheric chemical tendency [kg period-1] + ALLOCATE( SCHEM_TEND(IIPAR,JJPAR,LLPAR,N_TRACERS), STAT=AS ) + IF ( AS /= 0 ) CALL ALLOC_ERR( 'SCHEM_TEND' ) + SCHEM_TEND = 0d0 + + + END SUBROUTINE INIT_STRAT_CHEM +!EOC +!------------------------------------------------------------------------------ +! Harvard University Atmospheric Chemistry Modeling Group ! +!------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: cleanup_strat_chem +! +! !DESCRIPTION: Subroutine CLEANUP\_STRAT\_CHEM deallocates all module +! arrays. +!\\ +!\\ +! !INTERFACE: +! + SUBROUTINE CLEANUP_STRAT_CHEM +! +! !USES: +! USE NETCDF_UTIL_MOD +! !REVISION HISTORY: +! 1 Feb 2011 - L. Murray - Initial version +!EOP +!------------------------------------------------------------------------------ +!BOC + + IF ( ALLOCATED( PROD ) ) DEALLOCATE( PROD ) + IF ( ALLOCATED( LOSS ) ) DEALLOCATE( LOSS ) + IF ( ALLOCATED( PROD_0 ) ) DEALLOCATE( PROD_0 ) + IF ( ALLOCATED( LOSS_0 ) ) DEALLOCATE( LOSS_0 ) + IF ( ALLOCATED( STRAT_OH ) ) DEALLOCATE( STRAT_OH ) + IF ( ALLOCATED( MInit ) ) DEALLOCATE( MInit ) + IF ( ALLOCATED( TPAUSEL ) ) DEALLOCATE( TPAUSEL ) + IF ( ALLOCATED( BEFORE ) ) DEALLOCATE( BEFORE ) + IF ( ALLOCATED( SCHEM_TEND ) ) DEALLOCATE( SCHEM_TEND ) + + + + END SUBROUTINE CLEANUP_STRAT_CHEM +!EOC + END MODULE STRAT_CHEM_MOD diff --git a/code/new/timer.f b/code/new/timer.f new file mode 100644 index 0000000..1e2219e --- /dev/null +++ b/code/new/timer.f @@ -0,0 +1,32 @@ +c +c L-BFGS-B is released under the “New BSD License” (aka “Modified BSD License” +c or “3-clause license”) +c Please read attached file License.txt +c + subroutine timer(ttime) + double precision ttime +c + real temp +c +c This routine computes cpu time in double precision; it makes use of +c the intrinsic f90 cpu_time therefore a conversion type is +c needed. +c +c J.L Morales Departamento de Matematicas, +c Instituto Tecnologico Autonomo de Mexico +c Mexico D.F. +c +c J.L Nocedal Department of Electrical Engineering and +c Computer Science. +c Northwestern University. Evanston, IL. USA +c +c January 21, 2011 +c + temp = sngl(ttime) + call cpu_time(temp) + ttime = dble(temp) + + return + + end +