      subroutine wellphysicsctr(iflg,ndummy)
!***********************************************************************
! Copyright 2006 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!D1
!D1  PURPOSE
!D1
!D1      Well physics including the drift flux model
!D1
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 Initial implementation: 10-20-08, Programmer: G. Zyvoloski
!D2
!D2 $Log:
!D2
!***********************************************************************
!D3
!D3  REQUIREMENTS TRACEABILITY
!D3
!D3  2.2 Finite-Element Coefficient Generation
!D3
C***********************************************************************
!D4
!D4  SPECIAL COMMENTS AND REFERENCES
!D4
!D4 GAZ initial implementation 1-17-05
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
C***********************************************************************
C
C
C Notes:
C
C
C
C***********************************************************************
C
C     INPUT ARGUMENTS -
C
C
C#######################################################################
      use comdti
      use comai
      use combi
      use comci
      use comdi
      use comei
      use comfi
      use comgi
      use comki
      use comrxni
      use comii
      use comflow
      use comxi
      use davidi
      use comwellphys
      use comco2
      use commeth
c
      implicit none
      integer ndummy, iz, iwell_type, mi, ieosd, it, iwelld
      integer iflg,i,j,i1,i2,ik,izone,inode,ii,ij,kb,iafile,neqp1_old
      integer neqp1,iii,node,neq_new, id, nbc, kk
      integer imr,ipr,imrl,iprl,kb2,j1,j2,i3, ncont
      integer neqpi, iexpfl, icoef,nr_old,kbmin,kbmax
      integer open_file, inwel,max_seg_div,max_con,max_well_con
      integer maxiarea,iareap, jj, n_ncon, irnode, isnode, icesd

      real*8  vol0, vol2, pi, pi2, disa, raddif,disr,rad2,amult,area_tol
      real*8  sx_max,area_dum,area_new,sx_dum
      real*8  seg,seg2,dis,segx,segy,segz,segx2,segy2,segz2
      real*8  disx,disy,disz
      real*8  vg,vl,vvkb,sg,sl,covg,vvol,vsgf,sur_ten
      real*8  aparam,bparam,gamma,beta,fv,vdrift,vdrift1,vdrift2
      real*8  ar1,ar2,vv_max,vl_max,vb_max,akuta,vcar
      real*8  well1, well2 , well3, well4, well5, well6, well_rad
      real*8 term1a,dterm1a,term1,dterm1,rlgas,drlgass
c      real*8 rov,drovt,drovp,dvisvt,dvisvp
c      real*8 rol,drolt,drolp,dvislt,dvislp
      real*8 vismix,dvismixp,dvismixt,dvismixs
c      real*8 sw,visv,visl,divipl,tref,tempc
      real*8 sw,divipl,tref,tempc
      real*8 xvisl0,xvisl,drocp0
      real*8 pl,pref,xvisv,agrav

      real*8, allocatable  :: dum(:)
      real*8, allocatable  :: dum1(:,:)
      real*8, allocatable  :: seg_min(:)

      integer, allocatable :: idum(:)
      integer, allocatable :: idum1(:,:)
      integer, allocatable :: idum2(:)
      integer, allocatable :: ncon_new(:)

c
      parameter (area_tol=1.e-10, pi= 3.1415927, pi2=6.2831850)
      parameter (max_seg_div = 100,max_con = 10,max_well_con= 4)
c      parameter(pcl0 = 0.101325)
c      parameter(roc0 = 1.292864)
c

      logical null1

      character*80 dum_string

      integer i4,ic1,node_seg,iseg,ntot2,nodew
      if (.not. allocated(seg_min)) allocate(seg_min(max_con))

C
C#######################################################################
C
c
c     return if no (non-darcy) well physics
c
      pcl0 = 0.101325
c gaz debug roc0 now in comai
c      roc0 = 1.292864
      if(nwellphy.eq.0) return
      agrav = abs(grav)
      if(iflg.eq.0) then
c
c     any required initial calcs
c
c     allocate arrays

         allocate(iwellpt(neq))
         allocate(iwellp(neq))

         allocate(rwell1f(neq))
         allocate(rwell2f(neq))
         allocate(rwell3f(neq))
         allocate(rwell4f(neq))
         allocate(rwell5f(neq))
         allocate(rwell6f(neq))

         allocate(rolsvf(neq))
         allocate(rovsvf(neq))

         allocate(mdriftf(neq))
         allocate(dmdriftp(neq))
         allocate(dmdrifte(neq))
         allocate(dmdriftw(neq))

         allocate(vel_m_well2(neq))
         allocate(rolsv(neq))
         allocate(rovsv(neq))
c
c     read in data (like rlperm.f)
c
c     check for read from other file
c
         iwellp = 0
         i = 0
         j = 0
         ex = .false.
 10      continue
         read(inpt,'(a80)') wdd1
         if(.not. null1(wdd1)) then
            backspace inpt
            read(inpt,*) iwell_type
            backspace inpt
            i = i+1

            if (iwell_type .eq. 1.or.iwell_type .eq. 2) then
c     simplified drift flux model of vapor flow
c     for use with CO2
c     rwell1f is constant term ar1
c     rwell2f is constant term ar2
c     rwell3f is linear term aparam
c     rwell4f is linear term bparam
c     rwell5f is well radius
               read(inpt,*) iwellpt(i),rwell1f(i),rwell2f(i),rwell3f(i),
     &              rwell4f(i), rwell5f(i), rwell6f(i)
            endif
         else
            go to 20
         endif
         go to 10
 20      continue
c     count the number of models
         nwellphy = i
         narrays = 1
         itype(1) = 4
         default(1) = 1
         macro = "wellphysics "
         igroup = 2
         call initdata2( inpt, ischk, n0, narrays,
     2        itype, default, macroread(7), macro, igroup, ireturn,
     3        i4_1=iwellp(1:n0) )

         macroread(7) = .TRUE.

      else if(iflg.eq.1) then
c
c     calculate drift flux flow parameters and derivatives
c
         do i = 1,neq
            mi = i+ndummy

            if (iwellp_flag .eq. 0) then
               it = 0
            else
               it = iwellp(mi)
            end if
            if(it.eq.0) then
               iwelld=0
            else
               iwelld = iwellpt(it)
            endif

            if (iwelld .ne. 0) then
               well1 = rwell1f(it)
               well2 = rwell2f(it)
               well3 = rwell3f(it)
               well4 = rwell4f(it)
               well5 = rwell5f(it)
               well6 = rwell6f(it)
            else
!     Use linear model as default
               well1 = 0.
               well2 = 0.
               well3 = 1.
               well4 = 1.
               well5 = 1.
               well6 = 1.
               iwelld = 1
            end if

            if(iwelld.eq.1) then

c     CO2 model
c     calculate parameters for drift-flux model
c     vg = covg*vvol+vdrift
c     vg = gas phase velocity
c     vl = liquid phase velocity
c     covg = paramater in drft flux equation (calculated)
c     vvol = average velocity
c     vdrift = gas drift velocity
c     sur_ten = surface tension  (kg/m**2)
c     sl = liquid saturation
c     sg = gas saturation
c
c     fixed parameters in drift flux model (for calculating covg)
c
               icesd = ices(mi)
               sw = fw(mi)
               sl = fl(mi)
               sg = fg(mi)
               if(icesd.eq.3) sl = fg(mi)
               ar1 = well1
               ar2 = well2
               aparam = well3
               bparam = well4
               fv = well5
               well_rad = well6
c     for now overwrite with fixed values
c     ar1 = 0.2
c     ar2 = 0.4
c     aparam = 1.2
c     bparam = 0.3
c     fv = 1.0
c     fix surface tension
               sur_ten = 0.7
c
c     sg is the CO2 gas fraction
c     for now set vsgf = vvol (see discussion after eq 5, Shi et al,2005)
c              vvol = vel_m_well2(ii)
               vvol = 0.0
               vsgf = 1.0
               beta = max(sg, fv*sg*abs(vvol)/vsgf)
               gamma = (beta - bparam)/(1.0 - bparam)
               covg = aparam/(1.0 + (aparam - 1)*gamma**2)
c
c     determine region where gas saturation lies
c     for now all set to the same expression see discusion after eq 15, Shi et al,2005)
               if(sg.le.ar1) then
                  akuta = 1.53/covg
               else if(sg.ge.ar2) then
                  akuta = 1.53/covg
               else
                  akuta = 1.53/covg
               endif
c     calculate the characteristic velocity
c     formulation below evaluates drift velocity at last time step
c     = explicit update
               if(iad.eq.0) then
                  rol = co2_prop(mi)
                  rov = co2_prop(9*neq+mi)
                  rolsv(mi) = rol
                  rovsv(mi) = rov
               else
                  rol = rolsv(mi)
                  rov = rovsv(mi)
               endif
c     set surface tension (water-air) to 0.7 kg/m**2
c     need a table - now hardwired
               vcar = (sur_ten*grav*(rol-rov)/rol**2)**0.25
c     now set drift velocity
               term1 = (1.0-sg*covg)
               vdrift1 = term1*covg*akuta*vcar
               vdrift2 = sg*covg*sqrt(rov/rol)+term1
               vdrift = vdrift1/vdrift2
c

c
c     apparent gas phase rel perm
c     assumption (set linear rel perm in rlperm_co2,no cap pressure!)
c     gas velocity is a function of volumetric flux
c     vgas is now related to vl
c     vgas = covg*(1.0-sg)/1.0-covg*sg)*vl + vdrift/(1.0-covg*sg)
c     leading sg is for the mass fraction
c     term1 should go to 1 as sg goes to 1

               term1a =  1./(1.0-covg*sg)
               dterm1a = -covg/(1.0-covg*sg)**2
               term1 = covg*(1.0-sg)*term1a
               dterm1 = covg*(1.0-sg)*dterm1a - covg*term1a
               rlgas = sg*term1
               drlgass = term1 + sg*dterm1
c
               rov = co2_prop(9*neq+mi)
               drovt=co2_prop(10*neq+mi)
               drovp=co2_prop(11*neq+mi)
               visv=co2_prop(15*neq+mi)
               dvisvt=co2_prop(16*neq+mi)
               dvisvp=co2_prop(17*neq+mi)
               rol = co2_prop(mi)
               drolt=co2_prop(neq+mi)
               drolp=co2_prop(2*neq+mi)
               visl=co2_prop(6*neq+mi)
               dvislt=co2_prop(7*neq+mi)
               dvislp=co2_prop(8*neq+mi)
               vismix = sg*visv + (1.0-sg)*visl
               dvismixp = sg*dvisvp + (1.0-sg)*dvislp
               dvismixt = sg*dvisvt + (1.0-sg)*dvislt
               dvismixs = visv-visl
c     this definition below gives mass flux of gas with velocity of liquid
               div(mi) = rov/vismix*rlgas
c
               divp(mi) = (drovp/vismix-rov/vismix**2*dvismixp)*rlgas
               dive(mi) = (drovt/vismix-rov/vismix**2*dvismixt)*rlgas
               divw(mi) = (-rov/vismix**2*dvismixs)*rlgas +
     &              rov/vismix*drlgass
c
c     mass associated with drift velocity (for now vdrift is explicitly updated so no derivatives)
c
               mdriftf(mi) = rov*vdrift*term1a
               dmdriftp(mi) = drovp*vdrift*term1a
               dmdrifte(mi) = drovt*vdrift*term1a
               dmdriftw(mi) = rov*vdrift*dterm1a
c
            else if(iwelld.eq.2) then

c     aiw-water model (isothermal)
c     calculate parameters for drift-flux model
c     vg = covg*vvol+vdrift
c     vg = gas phase velocity
c     vl = liquid phase velocity
c     covg = paramater in drft flux equation (calculated)
c     vvol = average velocity
c     vdrift = gas drift velocity
c     sur_ten = surface tension  (kg/m**2)
c     sl = liquid saturation
c     sg = gas saturation
c
c     fixed parameters in drift flux model (for calculating covg)
c
               pl = phi(mi)
               sg = 1.0-s(mi)
               ar1 = well1
               ar2 = well2
               aparam = well3
               bparam = well4
               ar1 = well1
               ar2 = well2
               aparam = well3
               bparam = well4
               fv = well5
               well_rad = well6
c     for now overwrite with fixed values
c     ar1 = 0.2
c     ar2 = 0.4
c     aparam = 1.2
c     bparam = 0.3
c     fv = 0.3
c     fix surface tension
               sur_ten = 0.7
c
c     sg is the CO2 gas fraction
c     for now set vsgf = vvol (see discussion after eq 5, Shi et al,2005)
c     vvol = vel_m_well2(ii)
               vvol = 0.0
               vsgf = 1.0
               beta = max(sg, fv*sg*abs(vvol)/vsgf)

c
c     constrain gamma to 0 <= gamma <= 1.0
c
               if(beta.lt.bparam.and.beta.gt.bparam) then
                  gamma = (beta - bparam)/(1.0 - bparam)
               else if(beta.ge.bparam) then
                  gamma = 1.0
               else if(beta.le.bparam) then
                  gamma = 0.0
               endif
               covg = aparam/(1.0 + (aparam - 1)*gamma**2)
c
c     determine region where gas saturation lies
c     for now all set to the same expression see discusion after eq 15, Shi et al,2005)
               if(sg.le.ar1) then
                  akuta = 1.53/covg
               else if(sg.ge.ar2) then
                  akuta = 1.53/covg
               else
                  akuta = 1.53/covg

               endif
c     calculate the characteristic velocity
c     formulation below evaluates drift velocity at last time step
c     = explicit update
               if(iad.eq.0) then
                  rol = rolf(mi)
                  rov = rovf(mi)
                  rolsv(mi) = rol
                  rovsv(mi) = rov
               else
                  rol = rolsv(mi)
                  rov = rovsv(mi)
               endif
c     set surface tension (water-air) to 0.7 kg/m**2
c     need a table - now hardwired
               vcar = (sur_ten*agrav*(rol-rov)/rol**2)**0.25
c     now set drift velocity
               term1 = (1.0-sg*covg)
               vdrift1 = term1*covg*akuta*vcar
               vdrift2 = sg*covg*sqrt(rov/rol)+term1
               vdrift = vdrift1/vdrift2
c
c
c     apparent gas phase rel perm
c     assumption (set linear rel perm in rlperm_co2,no cap pressure!)
c     gas velocity is a function of volumetric flux
c     vgas is now related to vl
c     vgas = covg*(1.0-sg)/1.0-covg*sg)*vl + vdrift/(1.0-covg*sg)
c     leading sg is for the mass fraction
c     term1 should go to 1 as sg goes to 1
c     remember  dsg = -ds (sg = 1-s(mi))
c
               term1a =  1./(1.0-covg*sg)
               dterm1a = -covg/(1.0-covg*sg)**2
               term1 = covg*(1.0-sg)*term1a
               dterm1 = covg*(1.0-sg)*dterm1a - covg*term1a
               rlgas = sg*term1
               drlgass = term1 + sg*dterm1
c
c     misc. constants  (like at the top of thrair.f)
c
               tref = crl(6,1)
               tempc=(273.0)/(tref+273.0)
               drocp0=roc0*tempc/pcl0
               xvisl0=crl(2,1)
               xvisl = xvisl0
               pref=crl(4,1)
               xvisv=crl(5,1)
               rov = drocp0*pl
               drovp = drocp0
               vismix = sg*xvisv + (1.0-sg)*xvisl
               dvismixp = 0.0
               dvismixt = 0.0
               dvismixs = xvisv-xvisl
c     this definition below gives mass flux of gas with velocity of liquid
               div(mi) = rov/vismix*rlgas
c
               divp(mi) = (drovp/vismix-rov/vismix**2*dvismixp)*rlgas
c     dive has derivative wrt saturation (-1 from sg = 1.-sl)
               dive(mi) = ((-rov/vismix**2*dvismixs)*rlgas +
     &              rov/vismix*drlgass)*(-1.)
c
c     mass associated with drift velocity (for now vdrift is explicitly updated so no derivatives)
c
               mdriftf(mi) = rov*vdrift*term1a
               dmdriftp(mi) = drovp*vdrift*term1a
c     dmdrifte has derivative wrt saturation (-1 from sg = 1.-sl)
               dmdrifte(mi) = (rov*vdrift*dterm1a)*(-1.)
c
               mdriftf(mi) = 0.0
               dmdriftp(mi) = 0.0
               dmdrifte(mi) = 0.0
            endif
         enddo
         continue
      else if(iflg.eq.3) then
c
c     add BC for wellphysics
c
      else if(iflg.eq.4) then
c
c     apply N-R correction
c
      else if(iflg.eq.6) then
c
c     organize output
c
      endif
      end


! 8-JUL-09 mrharper: added Lindemann reactions
! 6/25/08 gmagoon: removed comments for debugging/timing
! 5/14/08 gmagoon: filename: call_dasslAUTOdebug.f90 (includes output used
! for debugging)
! 4/25/08 gmagoon: changed name from CALL_DASPK (sic) to CALL_DASSLAUTO
! to indicate that this version requires changes to RMG
! 4/26/08 gmagoon: changed from .f to .f90 and from "C" comments to "!"
! comments to address compilation issues; also changed "$" continued line
! to "& /n &" continued line
      PROGRAM CALL_DASSLAUTO

      IMPLICIT NONE

! IN THIS CODE WE ASSUME THAT THE
! MAXIMUM # SPECIES = 1500
! MAXIMUM # REACTIONS = 100,000
! MAXIMUM # THIRDBODYREACTIONS = 100
! MAXIMUM # TROEREACTIONS = 100
! MAXIMUM # LINDEMANNREACTIONS = 100

      INTEGER SPMAX, RMAX, TBRMAX, TROEMAX, LINDEMAX
      PARAMETER (SPMAX = 1500, RMAX = 100000, TBRMAX=100, TROEMAX=100, LINDEMAX=100)

      INTEGER NSTATE, INFO(30), IWORK(1541), LRW, LIW, NEQ, &
     &     REACTIONSIZE, THIRDBODYREACTIONSIZE, TROEREACTIONSIZE, &
     &     REACTIONARRAY(10*RMAX), THIRDBODYREACTIONARRAY(21*TBRMAX), &
     &     TROEREACTIONARRAY(22*TROEMAX), I, J, IDID, impspecies, &
     &     AUTOFLAG, ESPECIES, EREACTIONSIZE, ConstantConcentration(SPMAX+1), &
     &     LINDEREACTIONSIZE, LINDEREACTIONARRAY(21*LINDEMAX)

      DOUBLE PRECISION Y(SPMAX), YPRIME(SPMAX), T, TOUT, RTOL, ATOL,&
     &     RWORK(51+10*SPMAX+SPMAX**2), TEMPERATURE, PRESSURE,&
     &     REACTIONRATEARRAY(5*rmax),&
     &     THIRDBODYREACTIONRATEARRAY(16*Tbrmax),&
     &     TROEREACTIONRATEARRAY(21*TROemax), targetconc, THRESH, &
     &    CORETHRESH, LINDEREACTIONRATEARRAY(17*LINDEMAX)
     ! 4/25/08 gmagoon:make auto arrays allocatable and double
     ! precision for KVEC
     INTEGER, DIMENSION(:), ALLOCATABLE :: NEREAC,NEPROD
     INTEGER, DIMENSION(:,:), ALLOCATABLE :: IDEREAC, IDEPROD
     DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: KVEC

      COMMON /SIZE/ NSTATE, REACTIONSIZE, THIRDBODYREACTIONSIZE,&
     &     TROEREACTIONSIZE, LINDEREACTIONSIZE

      COMMON /REAC/ REACTIONRATEARRAY, THIRDBODYREACTIONRATEARRAY,&
     &     TROEREACTIONRATEARRAY, temperature, pressure,&
     &     REACTIONARRAY, THIRDBODYREACTIONARRAY,&
     &     TROEREACTIONARRAY, ConstantConcentration, &
     &     LINDEREACTIONRATEARRAY, LINDEREACTIONARRAY
!5/12/08 gmagoon: added timing (cf. http://beige.ucs.indiana.edu/B673/node105.html)
!      integer count_0, count_1, count_rate, count_max
!      double precision start, finish
!      call system_clock(count_0, count_rate, count_max)
!      start = count_0 * 1.0 / count_rate

      IDID = 0 !gmagoon 1/25/10: initialize IDID to zero (no meaning in terms of DASSL idid outputs) to avoid a situation where dassl is never called (and hence IDID is never assigned) due to edge exceeding flux at t=0
      OPEN (UNIT=12, FILE = 'SolverInput.dat', STATUS = 'OLD')

! READ THE NUMBER OF SPECIES; 4/24/08 gmagoon: added autoFlag,
! which will equal 1 for automatic (solve ODE until flux
! exceeds threshhold) or -1 for conventional operation
! (i.e. user-specification of time/conversion steps)
      READ(12,*) NSTATE, NEQ, IMPSPECIES, TARGETCONC, AUTOFLAG
      NSTATE = NSTATE+1

!  READ THE CONCENTRATIONS
      READ(12,*) (Y(I), i=1,nstate-1)

! READ THE RATE OF CHANGE OF CONCENTRATIONS
      READ(12,*) (YPRIME(I), i=1,nstate-1)
      YPRIME(NSTATE) = 0;

! READ THE TIME AND TOUT
      READ(12,*) T, TOUT

! READ THE INFO ARRAY
      READ(12,*) (INFO(I), I=1,30)

! READ RTOL AND ATOL
      READ(12,*) RTOL, ATOL

! READ TEMPERATURE AND PRESSURE
      READ(12,*) TEMPERATURE, PRESSURE

      Y(NSTATE) = 8.314*temperature/pressure/1e-6;
      do i=1,nstate-1
         y(i) = y(i)*y(nstate)
!         write(*,*) y(i)
      end do

! READ INFORMATION ABOUT REACTIONS
      READ(12,*) REACTIONSIZE
      READ(12,*) (REACTIONARRAY(I),I=1,10*REACTIONSIZE)
      READ(12,*) (REACTIONRATEARRAY(I),I=1,5*REACTIONSIZE)

! READ INFORMATION ABOUT THIRDBODYREACTIONS
      READ(12,*) THIRDBODYREACTIONSIZE
      READ(12,*)(THIRDBODYREACTIONARRAY(I),I=1,21*THIRDBODYREACTIONSIZE)
      READ(12,*)(THIRDBODYREACTIONRATEARRAY(I),I=1, &
    &  16*THIRDBODYREACTIONSIZE)

! READ INFORMATION ABOUT TROEREACTIONS
      READ(12,*) TROEREACTIONSIZE
      READ(12,*)(TROEREACTIONARRAY(I),I=1,22*TROEREACTIONSIZE)
      READ(12,*)(TROEREACTIONRATEARRAY(I),I=1,21*TROEREACTIONSIZE)

! READ INFORMATION ABOUT LINDEMANNREACTIONS
      READ(12,*) LINDEREACTIONSIZE
      READ(12,*)(LINDEREACTIONARRAY(I),I=1,21*LINDEREACTIONSIZE)
      READ(12,*)(LINDEREACTIONRATEARRAY(I),I=1,17*LINDEREACTIONSIZE)

! 4/24/08 gmagoon: if autoFlag = 1, read in additional information
! specific to automatic time stepping
    IF (AUTOFLAG .EQ. 1) THEN
        ! read the threshhold, corresponding to the value of
        ! termination tolerance specified in condition.txt input file
            !CORETHRESH is the threshhold for moving something from edge to core,
            !whereas THRESH is the threshhold for terminating the run before the end
            !THRESH >= CORETHRESH
        READ(12,*) THRESH, CORETHRESH
        ! read the number of edge species and edge reactions
        READ(12,*) ESPECIES, EREACTIONSIZE
        ! allocate memory for arrays
        ALLOCATE(NEREAC(EREACTIONSIZE), NEPROD(EREACTIONSIZE),&
    &       IDEREAC(EREACTIONSIZE,3), IDEPROD(EREACTIONSIZE,4),&
    &            KVEC(EREACTIONSIZE))
        ! read in the reaction parameters for each reaction;
        ! a maximum of 3 products and 3 reactants is assumed
        ! for each reaction; parameters read for each reaction
        ! are: number of reactants, number of products,
        ! three reactant ID's (integers from 1 to NSTATE-1),
        ! three product ID's (integers from 1 to ESPECIES),
        ! and the rate coefficient k, such that dCi/dt=k*Ca*Cb;
        ! note that cases where abs. value of stoic. coeff.
        ! does not equal one are handled by using repeated
        ! reactant/product IDs
        ! note: use of KVEC rather than Arrhenius parameters
        ! requires assumption that system is isothermal
        ! (and isobaric for pressure dependence)
        DO I=1, EREACTIONSIZE
            READ(12,*) NEREAC(I),NEPROD(I),IDEREAC(I,1), &
         &            IDEREAC(I,2),IDEREAC(I,3),IDEPROD(I,1), &
         &            IDEPROD(I,2), IDEPROD(I,3), IDEPROD(I,4), KVEC(I)
        ! alternative for reading Arrhenius parameters instead
        ! of k values; this allows easier extention to
        ! non-isothermal systems in the future
        ! form: k=A*T^n*e^(Ea/(RT)) *?
        ! units: A[=], n[=]dimensionless, Ea[=]
      !     READ(12,*) NEREAC(I),NEPROD(I),IDEREAC(I,1), &
        ! &               IDEREAC(I,2),IDEREAC(I,3),IDEPROD(I,1), &
        ! &               IDEPROD(I,2),IDEPROD(I,3), AVEC(I), NVEC(I), &
        ! &               EAVEC(I)
    !      for isothermal, isobaric systems, (or just isothermal
    !      systems if pressure dependence is not considered)
      !      the following may be calculated here once
    !      (versus calculating at every timestep)
    !      ...units may need adjustment:
    !           KVEC(I)=AVEC(I)*TEMPERATURE**NVEC(I)*EXP(EAVEC(I) &
    !   &       /(8.314*TEMPERATURE))
        END DO
    END IF

    ! read constantConcentration data (if flag = 1 then the concentration of that species will not be integrated)
    ! there is one integer for each species (up to nstate-1), then the last one is for the VOLUME
    READ(12,*) (ConstantConcentration(I), i=1,nstate)

! READ RWORK AND IWORK
      IF (T .NE. 0.0) THEN
         OPEN(UNIT=13, FILE = 'RWORK.DAT', FORM='UNFORMATTED')
         READ(13) (RWORK(I),I=1,51+10*NSTATE+NSTATE**2)

         OPEN(UNIT=14, FILE = 'IWORK.DAT', FORM='UNFORMATTED')
         READ(14) (IWORK(I),I=1, 41+NSTATE)
      END IF
      !5/13/08 gmagoon: close 13 and 14 to avoid "File already opened
      ! in another unit" error when T.NE.0 (occurs when we want to
      ! write to files later on); I'm surprised this was not
      ! a problem before my modifications...it may have to do with
      ! Fortran90 vs. Fortran 77; perhaps it was a problem with
      ! non-auto cases after my modifications and I just didn't
      ! notice it
     CLOSE(13)
         CLOSE(14)

      CALL SOLVEODE(Y, YPRIME, T, TOUT, INFO, RTOL, ATOL, IDID, &
     &     RWORK, IWORK, IMPSPECIES, TARGETCONC, AUTOFLAG, &
     &     THRESH,CORETHRESH,ESPECIES,EREACTIONSIZE,NEREAC,NEPROD,IDEREAC, &
     &     IDEPROD,KVEC)

! 4/25/08 gmagoon: deallocate memory from allocatable arrays
! (may or may not be useful)
! 5/12/08 gmagoon: changed to only deallocate if autoflag=1
! this should prevent "deallocated a bad pointer" error when
! autoflag is not 1
      IF (AUTOFLAG .EQ. 1) THEN
        DEALLOCATE (NEREAC, NEPROD, KVEC, &
     &  IDEREAC, IDEPROD)
      END IF

      !5/12/08 gmagoon: added timing (see above)
    !  call system_clock(count_1, count_rate, count_max)
    !  finish = count_1 * 1.0 / count_rate
      !5/13/08 gmagoon: just printing value for easier reading by Java
      ! this value will come last (following time-stepping time and
      ! "ODE successful" message)
      !write(*,*) 'Fortran timing: ', (finish-start)
     ! write(*,*) (finish-start)
      END PROGRAM CALL_DASSLAUTO

      SUBROUTINE JAC()
      END SUBROUTINE JAC

! gmagoon 4/24/08: added vars needed as parameters for automatic
! time stepping
      SUBROUTINE SOLVEODE(Y, YPRIME, Time, TOUT, INFO, RTOL, ATOL, &
     &     IDID, RWORK, IWORK, IMPSPECIES, TARGETCONC, AUTOFLAG, &
     &     THRESH,CORETHRESH,ESPECIES,EREACTIONSIZE,NEREAC,NEPROD,IDEREAC, &
     &     IDEPROD,KVEC)

      IMPLICIT NONE

!     INITIALIZE VARIABLES IN COMMON BLOC
      INTEGER SPMAX, RMAX, TBRMAX, TROEMAX, AUTOFLAG, ESPECIES, &
    & EREACTIONSIZE, LINDEMAX
      INTEGER NEREAC(EREACTIONSIZE),NEPROD(EREACTIONSIZE)
      INTEGER IDEREAC(EREACTIONSIZE,3), IDEPROD(EREACTIONSIZE,4)
      DOUBLE PRECISION KVEC(EREACTIONSIZE),MAXRATIO(ESPECIES), &
    & HIGHESTRATIO

      PARAMETER (SPMAX = 1500, RMAX = 100000, TBRMAX=100, TROEMAX=100, &
      &    LINDEMAX=100)

      INTEGER REACTIONSIZE, THIRDBODYREACTIONSIZE, TROEREACTIONSIZE, &
     &     REACTIONARRAY(10*RMAX), THIRDBODYREACTIONARRAY(21*TBRMAX), &
     &     TROEREACTIONARRAY(22*TROEMAX), I, J, NSTATE, EDGEFLAG,    &
     &     EDGEFLAGCORE, CORESTORED, ConstantConcentration(SPMAX+1), &
     &     LINDEREACTIONSIZE, LINDEREACTIONARRAY(21*LINDEMAX)

      DOUBLE PRECISION REACTIONRATEARRAY(5*rmax), &
     &     THIRDBODYREACTIONRATEARRAY(16*Tbrmax), &
     &     TROEREACTIONRATEARRAY(21*TROemax), TEMPERATURE, PRESSURE, &
     &     THRESH, CORETHRESH, LINDEREACTIONRATEARRAY(17*LINDEMAX)

      COMMON /SIZE/ NSTATE, REACTIONSIZE, THIRDBODYREACTIONSIZE, &
     &     TROEREACTIONSIZE, LINDEREACTIONSIZE

      COMMON /REAC/ REACTIONRATEARRAY, THIRDBODYREACTIONRATEARRAY,&
     &     TROEREACTIONRATEARRAY, temperature, pressure,&
     &     REACTIONARRAY, THIRDBODYREACTIONARRAY,&
     &     TROEREACTIONARRAY, ConstantConcentration, &
     &     LINDEREACTIONRATEARRAY, LINDEREACTIONARRAY

      INTEGER  INFO(30), LIW, LRW, IWORK(41 + NSTATE), IPAR(1),IDID, iter, &
     &     IMPSPECIES, conc, ITER_OUTPT, IWORK_OUTPT(41 + NSTATE)
      DOUBLE PRECISION Y(NSTATE), YPRIME(NSTATE), Time, TOUT, RTOL, ATOL &
     &     , RWORK(51 + 10*NSTATE + NSTATE**2), TARGETCONC, Y_OUTPT(NSTATE) &
     &     , YPRIME_OUTPT(NSTATE), TIME_OUTPT  &
     &     , RWORK_OUTPT(51 + 10*NSTATE + NSTATE**2)
     INTEGER PRUNEVEC(ESPECIES)

      DOUBLE PRECISION RPAR(REACTIONSIZE+THIRDBODYREACTIONSIZE+ &
     &     TROEREACTIONSIZE+LINDEREACTIONSIZE),&
     &     TotalReactionFlux(REACTIONSIZE+THIRDBODYREACTIONSIZE+ &
     &     TROEREACTIONSIZE+LINDEREACTIONSIZE),&
     &     CURRENTReactionFlux(REACTIONSIZE+THIRDBODYREACTIONSIZE+ &
     &     TROEREACTIONSIZE+LINDEREACTIONSIZE),&
     &     PREVReactionFlux(REACTIONSIZE+THIRDBODYREACTIONSIZE+&
     &     TROEREACTIONSIZE+LINDEREACTIONSIZE), PREVTIME, &
     &     TOTALREACTIONFLUX_OUTPT(REACTIONSIZE+THIRDBODYREACTIONSIZE+ &
     &     TROEREACTIONSIZE+LINDEREACTIONSIZE)

      EXTERNAL RES, JAC, GETFLUX
    ! 5/13/08 gmagoon: vars for timing
    !  integer count_0T, count_1T, count_rateT, count_maxT
    !  double precision startT, finishT

      conc = 1
      IPAR(1)= NSTATE

      LIW = 41 + NSTATE
      LRW = 51 + 10*NSTATE + NSTATE**2

!     ******* INITIALIZE THE REAL ARRAY
      DO I=0,REACTIONSIZE-1
         RPAR(I+1) = REACTIONRATEARRAY(5*I+1)
      END DO

      DO I=0,THIRDBODYREACTIONSIZE-1
         RPAR(REACTIONSIZE+I+1) = THIRDBODYREACTIONRATEARRAY(16*I+1)
      END DO

      DO I=0,TROEREACTIONSIZE-1
         RPAR(REACTIONSIZE+THIRDBODYREACTIONSIZE+I+1) = &
     &        TROEREACTIONRATEARRAY(21*I+1)
      END DO

      DO I=0,LINDEREACTIONSIZE-1
         RPAR(REACTIONSIZE+THIRDBODYREACTIONSIZE+TROEREACTIONSIZE+I+1) = &
     &        LINDEREACTIONRATEARRAY(17*I+1)
      END DO
!     **********************************
! 5/13/08 gmagoon: added time stepping timing
   !   call system_clock(count_0T, count_rateT, count_maxT)
   !   startT = count_0T * 1.0 / count_rateT

      CALL GETFLUX(Y, YPRIME, RPAR)

! 4/24/08 gmagoon: call EdgeFlux if AUTOFLAG is 1 to
! determine EDGEFLAG and EDGEFLAGCORE (-1 if flux threshhold has not yet been met,
! positive integer otherwise)
    EDGEFLAG = -1
    EDGEFLAGCORE = -1
    !initialize flag CORESTORED to -1 indicating that the output values (when core inclusion threshold is exceeded) have not been stored yet; this will be set to 1 once the values are stored
    CORESTORED = -1
    !initialize MAXRATIO to a vector of all zeroes;
    !this variable will track the maxiumum
    !of rate(i)/Rchar for each edge species i, with respect to time
    MAXRATIO = 0
    !initialize HIGHESTRATIO to 0; this variable (a scalar)
    !tracks the maximum of maxratio; when a new maximum is
    !attained, the present time step creating the new maximum
    !will be stored for output from the ODE solver to the Java code
    HIGHESTRATIO = 0
    IF (AUTOFLAG.eq.1) THEN
        CALL EDGEFLUX(EDGEFLAG,EDGEFLAGCORE,Y,YPRIME,THRESH,CORETHRESH,ESPECIES, &
     &     EREACTIONSIZE,NEREAC,NEPROD,IDEREAC,IDEPROD,KVEC, &
     &     MAXRATIO,PRUNEVEC,NSTATE)
        !update HIGHESTRATIO
        !note that we cannot exit the do loop once the IF statement is
        !caught because the HIGHESTRATIO will not necessarily have the highest value
        DO I=1, ESPECIES
            IF (MAXRATIO(I) .GT. HIGHESTRATIO) THEN
            HIGHESTRATIO = MAXRATIO(I)
            END IF
        END DO
        !when core flux threshold is exceeded for the first time, store the values for output
        !we want to use the first point of exceeding the core inclusion threshold
        !(aka error tolerance) to determine which species to add to the core
        !note: TOTALREACTIONFLUX apparently tracks integrated flux, not
        !instantaneous flux, so setting value to be zero here should be OK...
        !in any case, the result doesn't seem to be used by the Java code
        IF(EDGEFLAGCORE .GT. 0 .AND. CORESTORED .EQ. -1) THEN
            ITER_OUTPT=0
            TIME_OUTPT=TIME
            Y_OUTPT = Y
            YPRIME_OUTPT = YPRIME
            !IWORK_OUTPT = IWORK
            !RWORK_OUTPT = RWORK
            TOTALREACTIONFLUX_OUTPT = 0
            !PRUNEVEC_OUTPT = PRUNEVEC !note that we do not copy prunevec for the output value; this will be based on the final time integrated to (in case core threshold, but not termination threshold, is exceeded at t=0...it is ok to prune species that have zero flux at t=0
            CORESTORED = 1
        END IF
    ENDIF

      iter = 0;
      PREVTIME = TIME
      DO I=1,REACTIONSIZE+THIRDBODYREACTIONSIZE+TROEREACTIONSIZE+LINDEREACTIONSIZE
         PREVREACTIONFLUX(I) = 0
         TOTALREACTIONFLUX(I) = 0
         CURRENTREACTIONFLUX(I) = 0
      END DO
      call Reaction_flux(y, prevreactionflux, rpar)

      IF (IMPSPECIES .EQ. -1) THEN
         TARGETCONC = -1E10
         IMPSPECIES = 1
         conc = -1
      END IF

    ! open 'SpeciesProfiles.txt' output file to append to
    OPEN(UNIT=17, FILE='SpeciesProfiles.txt', ACCESS = 'APPEND')

! 4/24/08 gmagoon: added criteria that edgeflag = -1 for loop to
! continue; calls to DASSL will stop once EDGEFLAG takes on a
! different value
 1    IF (Time .LE. TOUT .AND. Y(IMPSPECIES) .GE. TARGETCONC*Y(NSTATE) &
     &    .AND. EDGEFLAG .EQ. -1) &
     &     THEN

         CALL DDASSL(RES, NSTATE, Time, Y, YPRIME, TOUT, INFO, RTOL, &
     &        Atol, IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC)
!         WRITE(*,*) Time, Tout
         IF (IDID .EQ. -1) THEN
            WRITE(*,*) "Warning: 500 steps were already taken, taking &
     &           another 500 steps"
            INFO(1) = 1
            GO TO 1
         ELSE IF ( IDID .EQ. 1) THEN
            iter = iter + 1
            CALL REACTION_FLUX(Y, CURRENTREACTIONFLUX, RPAR)

            DO I=1,REACTIONSIZE+THIRDBODYREACTIONSIZE+TROEREACTIONSIZE+LINDEREACTIONSIZE
               TOTALREACTIONFLUX(I) = TOTALREACTIONFLUX(I) + &
     &              (CURRENTREACTIONFLUX(I) + PREVREACTIONFLUX(I)) * &
     &              (TIME - PREVTIME)/2
               PREVREACTIONFLUX(I) = CURRENTREACTIONFLUX(I)
            END DO
            PREVTIME = TIME
            if (conc .eq. 1 .AND. Time .le. 1E6) then
               tout = 200*time
            end if
!            write(*,*) time, y(impspecies), targetConc*y(nstate)
    ! 4/24/08 gmagoon: call EdgeFlux if AUTOFLAG is 1 to
    ! determine EDGEFLAG
        IF (AUTOFLAG.eq.1) THEN
            CALL EDGEFLUX(EDGEFLAG,EDGEFLAGCORE,Y, YPRIME,THRESH,CORETHRESH,ESPECIES, &
             &     EREACTIONSIZE,NEREAC,NEPROD,IDEREAC,IDEPROD,KVEC, &
         &     MAXRATIO,PRUNEVEC,NSTATE)
            !update HIGHESTRATIO
            DO I=1, ESPECIES
                IF (MAXRATIO(I) .GT. HIGHESTRATIO) THEN
                HIGHESTRATIO = MAXRATIO(I)
                END IF
            END DO
            !when core flux threshold is exceeded for the first time, store the values for output
            IF(EDGEFLAGCORE .GT. 0 .AND. CORESTORED .EQ. -1) THEN
                ITER_OUTPT=ITER
                TIME_OUTPT=TIME
                Y_OUTPT = Y
                YPRIME_OUTPT = YPRIME
                !IWORK_OUTPT = IWORK
                !RWORK_OUTPT = RWORK
                TOTALREACTIONFLUX_OUTPT = TOTALREACTIONFLUX
                CORESTORED = 1
            END IF
        END IF

            ! save time and concentrations to 'SpeciesProfiles.txt'
            WRITE(17,1700) TIME, ( Y(I)/Y(NSTATE), I=1, NSTATE-1)
1700        FORMAT(99999(G12.5,'    ')) ! there should be a tab character between the quotes

            GO TO 1
         END IF
      END IF
      CLOSE(17) ! close 'SpeciesProfiles.txt'

      !5/13/08 gmagoon: added timing (see above)
     ! call system_clock(count_1T, count_rateT, count_maxT)
     ! finishT = count_1T * 1.0 / count_rateT
      !write(*,*) 'Time-stepping timing: ', (finishT-startT)
     ! write(*,*) (finishT-startT)

      !if we are not using AUTOFLAG, we just want to output the final times;
      !another case where we want to use the final time is if the highest ratio
      !never reaches CORETHRESH...if this is the case, we are "converged",
      !as we have reached the target time/conversion without exceeding the
      !core inclusion threshhold, and we therefore want to report the
      !final state back to the Java code so it will recognize that the
      !target time/conversion has been reached
      !in either case, CORESTORED should be -1
      IF (CORESTORED .EQ. -1) THEN
    ITER_OUTPT=ITER
    TIME_OUTPT=TIME
    Y_OUTPT = Y
    YPRIME_OUTPT = YPRIME
    !IWORK_OUTPT = IWORK
    !RWORK_OUTPT = RWORK
    TOTALREACTIONFLUX_OUTPT = TOTALREACTIONFLUX
      END IF
      IWORK_OUTPT = IWORK
      RWORK_OUTPT = RWORK

      OPEN(UNIT=16, FILE='SolverOutput.dat')

      write(16,*) ITER_OUTPT
      WRITE(16,*) NSTATE-1
      write(16,*) TIME_OUTPT
      DO I=1,NSTATE-1
         WRITE(16,*) Y_OUTPT(I)/Y_OUTPT(NSTATE)
      END DO

      DO I=1,NSTATE-1
   ! 5/9/08 gmagoon: these values are read by RMG as flux; corrected to
   ! include volume changing effects (dV/dt) using quotient rule
   !      WRITE(16,*) YPRIME(I)/Y(NSTATE)
          WRITE(16,*) (Y_OUTPT(NSTATE)*YPRIME_OUTPT(I)-Y_OUTPT(I)*YPRIME_OUTPT(NSTATE))/(Y_OUTPT(NSTATE)**2)
      END DO

      DO I=1,REACTIONSIZE+THIRDBODYREACTIONSIZE+TROEREACTIONSIZE+LINDEREACTIONSIZE
         WRITE(16,*) TOTALREACTIONFLUX_OUTPT(I)
      END DO

      write(16,*) Y_OUTPT(nstate)

      !for autoflag cases, display the edgeflag (if < 0, the ODE solver did not reach the target time/conversion),
      !, the final time integrated to,
      !along with pruning information
      IF (AUTOFLAG .EQ. 1) THEN
      WRITE(16,*) EDGEFLAG
      WRITE(16,*) TIME
      DO I=1, ESPECIES
          WRITE(16,*) PRUNEVEC(I)
          WRITE(16,*) MAXRATIO(I)
      END DO
      END IF

      CLOSE(16)

      OPEN(UNIT=14, FILE='RWORK.DAT', FORM='UNFORMATTED')
      WRITE(14) (RWORK_OUTPT(I),I=1,LRW)
      CLOSE(14)

      OPEN(UNIT=15, FILE='IWORK.DAT', FORM='UNFORMATTED')
      WRITE(15) (IWORK_OUTPT(I),I=1,LIW)
      CLOSE(15)

      if (idid .eq. 1 .or. idid .eq. 2 .or. idid .eq. 3 .or. idid .eq. 0) then
         WRITE(*,*) "******ODESOLVER SUCCESSFUL: IDID=",idid
      else
         WRITE(*,*) "******ODESOLVER FAILED : IDID=", idid
      end if
!      write(*,*) yprime(nstate)
      END SUBROUTINE SOLVEode

! 4/24/08 gmagoon: adding subroutines EDGEFLUX and RCHAR

! EDGEFLUX determines whether core or termination threshhold flux has been
! reached by any species; if so, EDGEFLAGCORE and EDGEFLAG, respectively, are set to a
! positive value corresponding to the offending species ID;
! otherwise, these values remain at whatever they were when passed to the function
! EDGEFLUX also calls RCHAR
! when edgeflux exceeds core threshold, edgeflagcore is set to the offending species ID
! if edgeflux also exceeds the termination threshold flux, edgeflag is set to the offending species ID
SUBROUTINE EDGEFLUX(EDGEFLAG,EDGEFLAGCORE,Y,YPRIME,THRESH,CORETHRESH,ESPECIES, &
             &     EREACTIONSIZE,NEREAC,NEPROD,IDEREAC,IDEPROD, &
        &      KVEC,MAXRATIO,PRUNEVEC,NSTATE)
    IMPLICIT NONE
    INTEGER EDGEFLAG, EDGEFLAGCORE, ESPECIES, EREACTIONSIZE, NSTATE, I, J, K
    DOUBLE PRECISION THRESH, CORETHRESH, FLUXRC, RFLUX, Y(NSTATE), YPRIME(NSTATE)
    DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RATE
    INTEGER NEREAC(EREACTIONSIZE),NEPROD(EREACTIONSIZE)
        INTEGER IDEREAC(EREACTIONSIZE,3), IDEPROD(EREACTIONSIZE,4)
    INTEGER PRUNEVEC(ESPECIES)
        DOUBLE PRECISION KVEC(EREACTIONSIZE), RATIO, MAXRATIO(ESPECIES)

    ALLOCATE(RATE(ESPECIES))
    ! initialize array to have all zeroes
    RATE=0
    ! it is assumed edgeflag = -1 at this point, since
      ! this should be the only way to access this subroutine

      ! calculate characteristic flux, FLUXRC
    CALL RCHAR(FLUXRC, Y, YPRIME, NSTATE)

    !initialize PRUNEVEC; at first, assume everything is prunable
    PRUNEVEC=1

    ! calculate the vector of fluxes for each species
    ! by summing contributions from each reaction
    ILOOP: DO I=1, EREACTIONSIZE
          ! calculate reaction flux by multiplying k
        ! by concentration(s)
        RFLUX = KVEC(I)
        KLOOP: DO K=1, NEREAC(I)
            RFLUX = RFLUX*Y(IDEREAC(I,K))/Y(NSTATE)
        END DO KLOOP
        ! loop over reaction products, adding RFLUX
        JLOOP: DO J=1, NEPROD(I)
            RATE(IDEPROD(I,J))=RATE(IDEPROD(I,J))+ RFLUX
            !if RFLUX is zero, then presumably one of the
            !reactant concentrations is zero (it is assumed
            !that k != 0), and therefore, we don't want to
            !prune the species yet
            IF(RFLUX .EQ. 0.0) THEN
                PRUNEVEC(IDEPROD(I,J)) = 0
            END IF
        END DO JLOOP
    END DO ILOOP

    ! check if any of the edge species fluxes exceed
    ! the threshhold and update the MAXRATIO vector
    FLOOP: DO I=1, ESPECIES
        RATIO = RATE(I)/FLUXRC
        !if we reach the error tolerance (aka core tolerance),
        !set EDGEFLAGCORE to the species ID
        !if we also reach the termination tolerance, set EDGEFLAG to the species ID
        IF (RATIO .GE. CORETHRESH) THEN
            EDGEFLAGCORE = I
            IF(RATIO .GE. THRESH) THEN
            EDGEFLAG = I
            END IF
        END IF
        !update the MAXRATIO vector
        IF(RATIO .GT. MAXRATIO(I)) THEN
            MAXRATIO(I) = RATIO
        END IF
    END DO FLOOP
    DEALLOCATE(RATE)
END SUBROUTINE EDGEFLUX

! RCHAR calculates the characteristic flux (i.e. the
! L2 norm of the core species fluxes), which it
! returns through the variable FLUXRC); the subroutine
! is called by EDGEFLUX; Y and YPRIME contain the
! state variables and state variable derivatives,
! respectively; state vars. include the number of moles of
! each species, with the volume as the final state
! variable; NSTATE indicates the number of state
! variables (equal to the number of core species
! plus one)
SUBROUTINE RCHAR(FLUXRC, Y, YPRIME, NSTATE)
       IMPLICIT NONE
    INTEGER NSTATE, I
    DOUBLE PRECISION SSF, FLUXRC, Y(NSTATE), YPRIME(NSTATE)
    ! compute the sum of squared fluxes
    SSF=0.0
    DO I=1, NSTATE-1
    ! add (dCi/dt)^2 with dCi/dt computed based on
      ! quotient rule...dCi/dt=d(Ni/V)/dt
    ! =(V*dNi/dt-Ni*dV/dt)/V^2
        SSF=SSF+((Y(NSTATE)*YPRIME(I)-Y(I)*YPRIME(NSTATE)) &
       &                        /(Y(NSTATE)**2))**2
    END DO
    ! compute the square root, corresponding to
      ! L2 norm
    FLUXRC = SSF**0.5
END SUBROUTINE RCHAR


! @Copyright 2007 Kristjan Haule
module greenk
  IMPLICIT NONE
  REAL*8, allocatable :: oml(:)
  COMPLEX*16, allocatable :: gk(:,:,:,:)
  INTEGER :: noml, nkpl, cixdm
CONTAINS
  SUBROUTINE greenk__Init__(filename)
    IMPLICIT NONE
    INTEGER, PARAMETER :: fh_gk=94
    CHARACTER*200 :: filename
    !
    INTEGER :: nsymop, norbitals
    INTEGER :: ios, i, j, ik, isym, iom
    CHARACTER*1 :: ch
    REAL*8 :: x, re, im
    REAL*8, allocatable :: gg2(:)
    COMPLEX*16, PARAMETER  :: IMAG = (0.0D0,1.0D0)

    open(fh_gk, FILE=filename, STATUS='old', IOSTAT=ios)

    READ(fh_gk,*) ch, nkpl,nsymop,noml,cixdm,norbitals
    READ(fh_gk,*) ! actual positions of atoms

    allocate( gk(noml, cixdm, cixdm, nkpl), oml(noml) )

    allocate( gg2(cixdm*cixdm*2) )
    do ik=1,nkpl
       do isym=1,nsymop
          do iom=1,noml
             READ(fh_gk,*) x, (gg2(i),i=1,cixdm*cixdm*2)
             if (ik.eq.1 .and. isym.eq.1) then
                oml(iom)=x
             endif
             do i=1,cixdm
                do j=1,cixdm
                   gk(iom,i,j,ik) = gk(iom,i,j,ik) + gg2((i-1)*2*cixdm+j*2-1) + gg2((i-1)*2*cixdm+j*2)*IMAG
                enddo
             enddo
          enddo
       enddo
       if (MODULO(ik,10).EQ.0) WRITE(*,'(A,I5)') 'Finished reading k-point=', ik
    enddo
    deallocate( gg2 )

    if (nsymop.GT.1) gk = gk * (1./nsymop)
    close(fh_gk)
  END SUBROUTINE greenk__Init__

  SUBROUTINE greenk__Destruct__()
    deallocate( gk, oml )
  END SUBROUTINE greenk__Destruct__

end module greenk


*
*     ------------------------------------------------------------------
*	O R T H
*
*     ------------------------------------------------------------------
*
      SUBROUTINE ORTH
*
*	Determine the orthogonality between initial and final state
*
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (NWD=30,NCD=2000,NCD4=4*NCD)
      COMMON/STATES/NCFG,MAXORB,IAJCMP(2*NWD),LJCOMP(2*NWD),
     :NJCOMP(2*NWD),NOCCSH(NCD4),NELCSH(5,NCD4),NOCORB(5,NCD4),
     :J1QNRD(9,NCD4)
      COMMON/OVRLAP/MU,NU,MUP,NUP,NONORT,NOVLPS,IROWMU,IROWNU,ICOLMU,
     1 ICOLNU,NORTH,IORDER,NCALLS,LMU,LNU,LMUP,LNUP,JMU,JNU,JMUP,JNUP,
     2 IORTH(NWD*NWD)

      COMMON/NOR/NCOM,NORBI,NORBF,IWAR
*
*   SET UP OF IORTH VECTOR
*   THE COMMON SET (NCOM) IS ASSUMED TO BE ORTHOGONAL TO BOTH
*   NORBI AND NORBF SETS
*
      IF (NORBI .EQ. 0) RETURN
      M1 = NORBI*NORBF
      DO 70 I = 1,M1
      IORTH(I) = 0
   70 CONTINUE
      NORTH = 0
*
*  | 1....NCOM | NCOM1.....NOR1 | NOR11.....NOR2|
*  |   NCOM    |     NORBI      |     NORBF     |
*  |   <= NWD  |     <= NWD     |     <=NWD     |
*
*  THIS LIMITATION IS LINKED TO THE DIMENSION OF BUFFER(NWD) IN
*  ANALYSE SUBROUTINE, where <= stands for LESS THAN or EQUAL.
*
      NCOM1 = NCOM+1
      NOR1  = NCOM + NORBI
      NOR11 = NOR1 + 1
      NOR2  = NOR1 + NORBF
      DO 78 J = NCOM1,NOR1
      DO 79 I = NOR11,NOR2
         IJ = NORBF*(J-NCOM1) + I - NOR1
         IF (LJCOMP(I) .EQ. LJCOMP(J)) THEN
            NORTH = NORTH + 1
            IORTH(IJ) = 1
         ENDIF
   79 CONTINUE
   78 CONTINUE
      RETURN
      END


MODULE sbcice_if
  USE oce
  USE dom_oce
  USE phycst
  USE eosbn2
  USE sbc_oce
  USE ice, ONLY: a_i
  USE in_out_manager
  USE iom
  USE fldread
  USE lib_mpp
  USE lib_fortran
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: sbc_ice_if
  TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_ice
  CONTAINS
  SUBROUTINE sbc_ice_if(kt)
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ji, jj
    INTEGER :: ierror
    INTEGER :: ios
    REAL(KIND = wp) :: ztrp, zsice, zt_fzp, zfr_obs
    REAL(KIND = wp) :: zqri, zqrj, zqrp, zqi
    CHARACTER(LEN = 100) :: cn_dir
    TYPE(FLD_N) :: sn_ice
    NAMELIST /namsbc_iif/ cn_dir, sn_ice
    IF (kt == nit000) THEN
      REWIND(UNIT = numnam_ref)
      READ(numnam_ref, namsbc_iif, IOSTAT = ios, ERR = 901)
901   IF (ios /= 0) CALL ctl_nam(ios, 'namsbc_iif in reference namelist', lwp)
      REWIND(UNIT = numnam_cfg)
      READ(numnam_cfg, namsbc_iif, IOSTAT = ios, ERR = 902)
902   IF (ios > 0) CALL ctl_nam(ios, 'namsbc_iif in configuration namelist', lwp)
      IF (lwm) WRITE(numond, namsbc_iif)
      ALLOCATE(sf_ice(1), STAT = ierror)
      IF (ierror > 0) CALL ctl_stop('STOP', 'sbc_ice_if: unable to allocate sf_ice structure')
      ALLOCATE(sf_ice(1) % fnow(jpi, jpj, 1))
      IF (sn_ice % ln_tint) ALLOCATE(sf_ice(1) % fdta(jpi, jpj, 1, 2))
      CALL fld_fill(sf_ice, (/sn_ice/), cn_dir, 'sbc_ice_if', 'ice-if sea-ice model', 'namsbc_iif')
    END IF
    CALL fld_read(kt, nn_fsbc, sf_ice)
    IF (MOD(kt - 1, nn_fsbc) == 0) THEN
      ztrp = - 40.
      zsice = - 0.04 / 0.8
      CALL eos_fzp(sss_m(:, :), fr_i(:, :))
      !$ACC KERNELS
      fr_i(:, :) = fr_i(:, :) * tmask(:, :, 1)
      !$ACC END KERNELS
      IF (ln_cpl) a_i(:, :, 1) = fr_i(:, :)
      DO jj = 1, jpj
        DO ji = 1, jpi
          zt_fzp = fr_i(ji, jj)
          zfr_obs = sf_ice(1) % fnow(ji, jj, 1)
          IF (sst_m(ji, jj) <= zt_fzp) THEN
            fr_i(ji, jj) = 1.E0
          ELSE
            fr_i(ji, jj) = 0.E0
          END IF
          tsn(ji, jj, 1, jp_tem) = MAX(tsn(ji, jj, 1, jp_tem), zt_fzp)
          qsr(ji, jj) = (1. - zfr_obs) * qsr(ji, jj)
          zqri = ztrp * (tsb(ji, jj, 1, jp_tem) - (zt_fzp - 1.))
          zqrj = ztrp * MIN(0., tsb(ji, jj, 1, jp_tem) - zt_fzp)
          zqrp = (zfr_obs * ((1. - fr_i(ji, jj)) * zqri + fr_i(ji, jj) * zqrj)) * tmask(ji, jj, 1)
          zqi = - 3. + SIGN(1._wp, ff_f(ji, jj))
          qns(ji, jj) = ((1. - zfr_obs) * qns(ji, jj) + zfr_obs * fr_i(ji, jj) * zqi) * tmask(ji, jj, 1) + zqrp
        END DO
      END DO
    END IF
  END SUBROUTINE sbc_ice_if
END MODULE sbcice_if


!>  Module file mat_mod.f90
!
!>  Provides the interface to matrix objects.
module mat

  use kinds, only : ccs_int, ccs_real
  use types, only : ccs_matrix, matrix_spec, matrix_values, ccs_mesh, ccs_vector
  use parallel_types, only: parallel_environment

  implicit none

  private

  public :: create_matrix
  public :: finalise_matrix
  public :: update_matrix
  public :: begin_update_matrix
  public :: end_update_matrix
  public :: set_matrix_values
  public :: set_eqn
  public :: pack_one_matrix_coefficient
  public :: initialise_matrix
  public :: set_matrix_size
  public :: set_nnz
  public :: mat_axpy
  public :: mat_norm
  public :: get_matrix_diagonal
  public :: set_matrix_diagonal
  public :: zero_matrix

  interface

     !>  Interface to create a new matrix object.
     !
     !> @param[in]  mat_properties - contains information about how the matrix should be allocated
     !> @param[out] M       - the matrix object
     module subroutine create_matrix(mat_properties, M)
       type(matrix_spec), intent(in) :: mat_properties
       class(ccs_matrix), allocatable, intent(out) :: M
     end subroutine

    module subroutine finalise_matrix(M)
      class(ccs_matrix), intent(inout) :: M
    end subroutine

     !>  Interface to perform a parallel update of a matrix.
     !
     !> @param[in/out] M - the matrix
     module subroutine update_matrix(M)
       class(ccs_matrix), intent(inout) :: M
     end subroutine

     !>  Interface to begin a parallel update of a matrix.
     !
     !> @param[in/out] M - the matrix
     !
     !> Begins the parallel update to allow overlapping comms and compute.
     module subroutine begin_update_matrix(M)
       class(ccs_matrix), intent(inout) :: M
     end subroutine

     !>  Interface to end a parallel update of a matrix.
     !
     !> @param[in/out] M - the matrix
     !
     !>  Ends the parallel update to allow overlapping comms and compute.
     module subroutine end_update_matrix(M)
       class(ccs_matrix), intent(inout) :: M
     end subroutine

     !>  Interface to store one matrix coefficient and its index for later setting.
     !
     !> @param[in/out] mat_coeffs - object storing the coefficients, their indices and mode to use
     !!                             when setting them.
     !> @param[in]     row_entry  - which entry in the row indices to set?
     !> @param[in]     col_entry  - which entry in the column indices to set?
     !> @param[in]     row        - matrix row index
     !> @param[in]     col        - matrix column index
     !> @param[in]     coeff      - matrix coefficient
     !
     !v  Stores a matrix coefficient and associated row and column indices for later
     !   setting, ensuring they are set appropriately for the backend.
     module subroutine pack_one_matrix_coefficient(row_entry, col_entry, row, col, coeff, mat_coeffs)
       integer(ccs_int), intent(in) :: row_entry
       integer(ccs_int), intent(in) :: col_entry
       integer(ccs_int), intent(in) :: row
       integer(ccs_int), intent(in) :: col
       real(ccs_real), intent(in) :: coeff
       type(matrix_values), intent(inout) :: mat_coeffs
     end subroutine pack_one_matrix_coefficient

    !>  Interface to perform the AXPY matrix operation.
    !
    !>  Performs the AXPY operation
    !>          y[i] = a * x[i] + y[i]
    !
    !> @param[in]     alpha - a scalar value
    !> @param[in]     x     - an input matrix
    !> @param[in,out] y     - matrix serving as input, overwritten with result
    module subroutine mat_axpy(alpha, x, y)
      real(ccs_real), intent(in) :: alpha
      class(ccs_matrix), intent(in) :: x
      class(ccs_matrix), intent(inout) :: y
    end subroutine

    !>  Interface to compute the norm of a matrix
    !
    !> @param[in]  m         - the matrix
    !> @param[in]  norm_type - which norm to compute? Currently supported is the 2 norm:
    !!                         norm_type=2.
    !> @param[out] n         - the computed norm returned as the result of the function
    !!                         call.
    module function mat_norm(M, norm_type) result(n)
      class(ccs_matrix), intent(in) :: M
      integer(ccs_int), intent(in) :: norm_type
      real(ccs_real) :: n
    end function

     !>  Interface to set values in a matrix.
     !
     !> @param[in]     mat_values - contains the values, their indices and the mode to use when setting
     !!                             them.
     !> @param[in/out] M          - the matrix
     module subroutine set_matrix_values(mat_values, M)
       type(matrix_values), intent(in) :: mat_values
       class(ccs_matrix), intent(inout) :: M
     end subroutine

     !>  Interface to set equation
     !
     !> @param[in]  global_rows - array of (global) row indices to set the equation on
     !> @param[in/out]        M - the matrix
     !
     !v  Sets equations in a system of equations by zeroing out the corresponding row in the
     !   system matrix and setting the diagonal to one such that the solution is given by
     !   the corresponding entry in the right-hand side vector.
     module subroutine set_eqn(global_rows, M)
       integer(ccs_int), dimension(:), intent(in) :: global_rows
       class(ccs_matrix), intent(inout) :: M
     end subroutine

    !>  Constructor for default matrix values
    !
    !> param[in/out] mat_properties - the initialised matrix values
     module subroutine initialise_matrix(mat_properties)
      type(matrix_spec), intent(inout) :: mat_properties
    end subroutine initialise_matrix

    !>  Setter for global matrix size
    !
    !> param[in] par_env                - the parallel environment where
    !!                                    the matrix resides
    !> param[in] mesh               - the mesh object
    !> param[in/out] mat_properties  - the matrix data object
    module subroutine set_matrix_size(par_env, mesh, mat_properties)
      class(parallel_environment), allocatable, target, intent(in) :: par_env
      class(ccs_mesh), target, intent(in) :: mesh
      type(matrix_spec), intent(inout) :: mat_properties
    end subroutine

    !>  Setter for matrix number of non-zeros
    !
    !> param[in] nnz                   - the number of non-zeros
    !> param[in/out] mat_properties - the matrix data object
    module subroutine set_nnz(nnz, mat_properties)
      integer(ccs_int), intent(in) :: nnz
      type(matrix_spec), intent(inout) :: mat_properties
    end subroutine

    !>  Extract matrix diagonal elements into a vector
    !
    !> @param[in]  M - the matrix
    !> @param[out] D - a vector containing the diagonal elements of M
    module subroutine get_matrix_diagonal(M, D)
      class(ccs_matrix), intent(in)  :: M
      class(ccs_vector), intent(inout) :: D
    end subroutine get_matrix_diagonal

    module subroutine set_matrix_diagonal(D, M)
      class(ccs_vector), intent(in) :: D
      class(ccs_matrix), intent(inout) :: M
    end subroutine set_matrix_diagonal

    module subroutine zero_matrix(M)
      class(ccs_matrix), intent(inout) :: M
    end subroutine zero_matrix

  end interface

end module mat


	SUBROUTINE GDTFIL ( gdfile, ikx, iky, gfunc, time1, time2,
     +			ivcord, nbits, gltln, iret )
C************************************************************************
C* GDTFIL								*
C*									*
C* This subroutine will create a grid file for the topography data.	*
C*									*
C* GDTFIL ( GDFILE, IKX, IKY, GFUNC, TIME1, TIME2, IVCORD, NBITS, GLTLN,*
C*		 IRET )							*
C*									*
C* Input parameters:							*
C*	GDFILE		CHAR*(*)	Grid file name			*
C*	IKX		INTEGER		Number of X points		*
C*	IKY		INTEGER		Number of Y points		*
C*	GLTLN(4)	REAL		Lat/lon bounds			*
C* Output parameters:							*
C*	IGDFLN		INTEGER		Grid file number		*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* S. Jacobs/SSAI	11/91						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	gdfile, gfunc, time1, time2
	INTEGER		ikx, iky, ivcord, nbits, iret
	REAL		gltln(*)
C*
	CHARACTER	proj*4, newfil*(LLMXLN)
	REAL		dbnds(4), rnvblk(LLNNAV), anlblk(LLNANL)
	INTEGER		ebnds(4)
	LOGICAL		angflg, exist
C------------------------------------------------------------------------
C
C*	See if file exists
C
	CALL FL_INQR ( gdfile, exist, newfil, ier )
C
	IF ( .not. exist ) THEN
	    proj   = 'CED'
	    angle1 = 0.
	    angle2 = 0.
	    angle3 = 0.
	    angflg = .false.
	    deltan = 0.0
	    maxgrd = 10
	    navsz  = LLNNAV
	    ianlsz = LLNANL
	    ihdrsz = 2
	    DO  i = 1, 4
	        ebnds(i) = 0.0
	        dbnds(i)  = RMISSD
	    END DO
C
	    CALL GR_MNAV ( proj, ikx, iky, gltln(1), gltln(2),
     +		       gltln(3), gltln(4), angle1, angle2,
     +		       angle3, angflg, rnvblk, ier1 )
C
	    CALL GR_MBN2 ( deltan, ebnds, dbnds, rnvblk, anlblk, ier2 )
C
C
	    CALL GD_CREF ( gdfile, navsz, rnvblk, ianlsz, anlblk,
     +		       ihdrsz, maxgrd, igdfln, iret )
	ELSE
C
C*	    Open the grid file
C
	    CALL GD_OPEN ( gdfile, .true., LLNANL, LLNNAV, igdfln,
     +			anlblk, rnvblk, maxgrd, iret )
	END IF
C*
	IF ( iret .eq. 0 ) THEN
	    write(*,*) 'write out grid '
	    CALL cgdtwdt ( igdfln, ikx, iky, gfunc, time1, time2, ivcord,
     +		nbits, rnvblk, ier)
	    CALL GD_CLOS ( igdfln, ier)
	END IF
C
	RETURN
	END


!----------------------Subroutine--------------------------------------!
!
      SUBROUTINE JCBZ( ISLV,MU,ML,MK )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Zero the Jacobian matrix elements and solution vector.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle's Pacific Northwest Division, 1996.
!     Last Modified by MD White on September 5, 1996.

!     $Id: jcbz.F 1080 2017-03-14 16:22:02Z d3c002 $
!

!----------------------Fortran 90 Modules------------------------------!
!
      USE GLB_PAR
      USE WELL_CL
      USE SOLTN
      USE JACOB
      USE GRID
      USE GEOMECH
      USE COUP_WELL
!

!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!

!
!----------------------Common Blocks-----------------------------------!
!

!
!----------------------Executable Lines--------------------------------!
!
      ISUB_LOG = ISUB_LOG+1
      SUB_LOG(ISUB_LOG) = '/JCBZ'
      IF( INDEX(SVN_ID(121)(1:1),'$').EQ.0 ) SVN_ID(121) =
     & '$Id: jcbz.F 1080 2017-03-14 16:22:02Z d3c002 $'
      ICNV = 3
      NSPILL = LSPILL
!
!---  Number of unknowns equals number of active nodes x number of
!     coupled equations + number of coupled wells  ---
!
      IF( N_CW.GT.0 ) THEN
        NUKX = ISLV*(NFBN-NRFN-NXP) + N_CW
!
!---  Number of unknowns equals number of number of coupled equations
!     x (number of active nodes + number of wells +
!     number of surface nodes)
!
      ELSEIF( LSPILL.GT.0 ) THEN
        NUKX = ISLV*(NFBN-NRFN-NXP+NWLN+IJFLD)
!
!---  Number of unknowns equals number of number of coupled equations
!     x (number of active nodes + number of wells)
!
      ELSE
        NUKX = ISLV*(NFBN-NRFN-NXP+NWLN)
      ENDIF
!
!---  Dual-porosity option  ---
!
      IF( ISLC(11).EQ.1 ) NUKX = NUKX + ISLV*(NFBN-NRFN-NXP)
!
!---  Banded solver  ---
!
      IF( ILES.EQ.1 ) THEN
        NCOL = NUKX
        NROW = 2*MU + ML + 1
        DO 110 MCOL = 1,NCOL
          DO 100 MROW = 1,NROW
            ALU(MROW,MCOL) = 0.D+0
  100     CONTINUE
          BLU(MCOL) = 0.D+0
          ILU(MCOL) = MCOL
  110   CONTINUE
!
!---  SPLib Solver  ---
!
      ELSEIF( ILES.EQ.3 ) THEN
        NROW = NUKX
!$OMP PARALLEL DO
!$OMP& DEFAULT(NONE)
!$OMP& SHARED(DLU)
!$OMP& FIRSTPRIVATE(MK)
!$OMP& PRIVATE(MROW)
        DO 300 MROW = 1,MK
          DLU(MROW) = 0.D+0
  300   CONTINUE
!$OMP END PARALLEL DO
!$OMP PARALLEL DO
!$OMP& DEFAULT(NONE)
!$OMP& SHARED(BLU)
!$OMP& FIRSTPRIVATE(NROW)
!$OMP& PRIVATE(MROW)
        DO 310 MROW = 1,NROW
          BLU(MROW) = 0.D+0
  310   CONTINUE
!$OMP END PARALLEL DO

!
!---  Unknown Solver  ---
!
      ELSE

        INDX = 3
        CHMSG = 'Unknown Linear Equation Solver'
        CALL WRMSGS( INDX )
      ENDIF
      ISUB_LOG = ISUB_LOG-1
!
!---  End of JCBZ group  ---
!
      RETURN
      END