* ----------------- BEGIN TMRS_FF_RV_Drvr ---------------------------
      Program TMRS_FF_RV_Drvr

*  Compute SMSIM simulations for a finite-fault model.
*  Obtains parameters (including a list of oscillator periods,
*  magnitudes, and distances) from a file.  The only thing obtained
*  from interactively from the screen is the name of the control file.

*  The control file contains up to 60 comment lines, each line preceeded
*  by "!", with a line of input parameters following each group of
*  comment lines.  The processing stops after "Stop" is encountered in a line
*  (the character string "stop" can be any combination of uppercase and
*  lowercase letters).  Here is a sample of the control file:

*! Control file for program trms_ff_rv_drvr
*! Revision of program involving a change in the control file on this date:
*   02/19/09
*!Name of File with Input Parameters:
*! ***WARNING*** For consistency, the source specified
*! in the parameter file should use DeltaSigma as a parameter
*! (of the 11 sources currently built into the smsim
*! programs, only sources 1, 2, and 11 use the DeltaSigma
*! as a free parameter).  If not, the program writes an error message and quits.
* ofr4.params
*!Output file names stem
*  ff_rv_drvr_m7.0_stress_250_az045_54sites
*!lat and lon of upper edge of fault
*  0.0 0.0
*!strike,dip, depth of fault
*  0.0 50.0 2.0
*!fault type (S=strikeslip; R=reverse; N=normal; U=undifferentiated)
*! (Only used if Wells and Coppersmith is used to obtain FL and FW).
*  R
*!fault length and width, dl, dw, stress_ref
*!Note: Force program to use Wells and Coppersmith for FL and/or FW if either entry = 0.0
*  0.0 0.0 1.5 1.5 70.0 ! used for WC scaling (need an entry as a placeholder even if not used_
*!fq
*   10.0
*!coord flag (1=lat,long; 2=R,Az; 3=N,E)
*   2
*!If "Y" below and strike = 0.0:
*!  if coord flag = 2, move origin of the radial line to the midpoint of
*!                         the top edge of the fault
*!  if coord flag = 3 and coord(1) = 0, redefine coord(1) to be
*!                         the midpoint of the top edge of the fault (so that the
*!                         sites will be along a line normal to the midpoint
*!  if coord flag = 3 and coord(2) = 0, redefine coord(1) to be the
*!                         far end of the fault, so that the sites are along a line
*!                         along the strike of the fault
* Y
*!Damp PerOsc    M  stress coord(1) coord(2)
*0.05	-1	7      250     1.00	45
*0.05	0.0	7      250     1.12	45
*0.05	0.2	7      250     1.26	45
*0.05	2.0	7      250     1.41	45
*  stop

* The column headings on output are "psa" to indicate that the output is
* pseudo absolute acceleration response spectra.  If PerOsc < 0.0, however,
* the computed values are actually pgv.  Because the output can mix
* computations of psa and pgv and only one column heading is used, an earlier
* version of the program used the generic "Y" for the column heading.  In
* this version I decided that it was best to use
* "psa" to make it clear what response spectral ordinate was being computed
* for the most common case (psa will be computed more often than pgv) at the
* risk of confusion when pgv is computed.

*  Uses Random Vibration routines.

* Notes regarding modification of driver:
*  1. All "include" statements assume all subprograms are in the same folder
*     as this program.
*  2. If values of stress other than those in the input parameter file are
*     to be used, set "stressc" equal to the new value, rather than "stress"
*     (and also set the other parameters if the stress changes with moment).

* NOTE: The output is psa, not psv!!!

* Dates: 02/19/09 - Written by D.M. Boore; Modified from tmrs_rv_drvr and reff
*        12/01/09 - Redo computation of fup, depending on the values of fmax and kappa
*        12/16/09 - Unlike other revisions made on about this date, do NOT
*                   modify r by using an effective depth; this requires setting
*                   rmod = r, because the computational subprograms now use
*                   rmod rather than r.
*        12/22/09 - removed constraint that numsource = 1
*                 - Write numsource to output file
*        02/14/10 - As a result of feedback from John Douglas, I replaced "cr"
*                   in the screen prompt with "Enter".
!        08/25/10 - Shorten "patience" screen message.
!        04/08/11 - Remove numsource from the subprogram argument lists (see
!                   comments in gsprd_f for the reason).
!        09/21/11 - Write smsim parameter file name in the first line of the output file.
!        12/02/11 - Add computation of am0 right after specification of amag (previously, it
!                   was contained in spect_scale, but it was not clear from where that routine was
!                   called).
!        01/30/14 - Correct bug: the Q params were being printed in write_Par before they were obtained in the call
!                   to get_params.  The correction is to remove their being printed in write_Par, as they are printed
!                   to the summary file in write_params, after the call to get_params

      dimension siteLocation(2)
      character f_stem*120
      character f_write_input_params*120, f_out*120,
     :          f_smsim_params*120
      character cmnts2skip(50)*80, buf_in*10
      character date*8, time_start*10, time_stop*10,
     :                   time_begin*10, time_end*10

      logical f_exist, specify_length, specify_width, move_site

      character fault_type*10, f_ctl*120

      character buf*80

      real smsim_out

      logical tdflag, fparam_exist

      include 'smsim.fi'

      pi=4.0*atan(1.0)
      twopi = 2.0 * pi
      d2r = pi/180.0

      f_exist = .false.
      do while (.not. f_exist)
        f_ctl = ' '
        write(*, '(a\)')
     :    ' Enter name of input control file '//
     :    '("Enter" = tmrs_ff_rv_drvr.ctl): '
        read(*, '(a)') f_ctl
        call trim_c(f_ctl,nc_f_ctl)
        if (f_ctl(1:4) .eq. '    ')
     :                         f_ctl = 'tmrs_ff_rv_drvr.ctl'
        call trim_c(f_ctl, nc_f_ctl)
        inquire(file=f_ctl(1:nc_f_ctl), exist=f_exist)
        if (.not. f_exist) then
          write(*,'(a)') ' ******* FILE DOES NOT EXIST ******* '
        end if
      end do
      call get_lun(nu_ctl)
      open(unit=nu_ctl, file=f_ctl(1:nc_f_ctl), status='unknown')

      call getInputParameters(nu_ctl,
     :            FaultStrike,FaultDip,h,
     :            FaultLat,FaultLon, move_site,
     :            fault_type,
     :            FaultLength, FaultWidth,
     :            dl, dw,
     :            specify_length, specify_width, stress_ref,
     :            fq,
     :            isitecoordflag_in,
     :            f_stem, nc_f_stem, f_smsim_params, nc_f_smsim_params)

      call banner(6)

      f_write_input_params = ' '
      f_write_input_params = f_stem(1:nc_f_stem)//'_summary.out'
      call trim_c(f_write_input_params, nc_f_write_input_params)
      call get_lun(nu_write_params)

      open (nu_write_params,
     :   file=f_write_input_params(1:nc_f_write_input_params),
     :                  status='unknown')

      call writePar (nu_write_params,
     :   f_smsim_params, nc_f_smsim_params,
     :   FaultStrike,FaultDip,h,
     :   FaultLat, FaultLon,
     :   move_site,
     :   fault_type,
     :   FaultLength, FaultWidth, dl, dw,
     :   specify_length, specify_width, stress_ref,
     :   r_ref, nsprd_segs, rlow, a_s, b_s, m_s,
     :   fq)

! commented these out on 01/30/14
!     :   qr1, s1, ft1, ft2, fr2, qr2, s2, c_q, fq,
!     :   r_ref, nsprd_segs, rlow, a_s, b_s, m_s)

      f_out = ' '
      f_out = f_stem(1:nc_f_stem)//'_psa.out'
      call trim_c(f_out, nc_f_out)
      call get_lun(nu_out)
      open(nu_out, file=f_out(1:nc_f_out), status='unknown')

      write(nu_out,'(a)') ' Parameter file: '//
     :  f_smsim_params(1:nc_f_smsim_params)

      write(nu_out,'(
     :                1x,a,
     :                4x,a,
     :                1x,a, 1x,a, 7x,a, 7x,a, 3x,a, 5x,a,
     :                1x,a, 1x,a,
     :                1x,a, 1x,a,
     :                1x,a, 1x,a,
     :                1x,a, 1x,a,
     :                5x,a, 3x,a, 5x,a, 8x,a,
     :                2x,a, 1x,a, 2x,a,
     :                3x,a,
     :                5x,a,
     :                3x,a,
     :                4x,a,
     :                1x,a
     :                                        )')
     :  'index',
     :  'm',
     :  'numsource', 'stress', 'fl', 'fw', 'dip', 'h',
     :  'siteloc1_in', 'siteloc2_in',
     :  'sitecoord(1)', 'sitecoord(2)',
     :  'isitecoordflag', 'move_site',
     :  'site_lat_degrees', 'site_lon_degrees',
     :  'd_jb', 'd_cd2f', 'reff', 'r',
     :  'damp', 'perosc', 'freqosc',
     :  'psa(cgs)',
     :  'psa(g)',
     :  'psv(cgs)',
     :  'sd(cgs)',
     :  'Arias(cgs)'

      call banner(nu_write_params)

      write(nu_write_params, '(2a)') ' parameter file: ',
     :   f_smsim_params(1:nc_f_smsim_params)
      write(nu_write_params, '(2a)') ' control file: ',
     :   f_ctl(1:nc_f_ctl)

      write(nu_write_params, '(a)')
     :  ' *** Results computed using tmrs_ff_rv_drvr ***'

      tdflag = .false.
      call get_params(f_smsim_params(1:nc_f_smsim_params), tdflag )

      if (numsource /= 1 .and. numsource /= 2 .and.
     :    numsource /= 11)                            then
        print *, ' ERROR: numsource /= 1, 2, or 11; QUITTING!!!'
        stop
      end if

      call write_params(nu_write_params, tdflag)

* Compute fup.  Because the same code appears in a number of drivers, I've
* consolidated it into a subroutine.

      call get_fup(fm, akappa, amp_cutoff, nu_write_params, fup)

* Standard Fortran 90 intrinsic Subroutine DATE_AND_TIME
      call DATE_AND_TIME( date, time_begin )
* Date is returned as 'CCYYMMDD' (character date*8)
* Time is returned as 'hhmmss.sss' (character time*10)
*     character datx*8, time_start*10
      write(nu_write_params, *)
      write(nu_write_params, '(a)')
     :   ' Date: '//date(1:4)//'/'//date(5:6)//'/'//date(7:8)
      write(nu_write_params, '(a)')
     : ' Time Begin: '//
     : time_begin(1:2)//':'//time_begin(3:4)//':'//time_begin(5:10)
      write(nu_write_params, *)

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)

      n_index = 0
888   continue

      buf = ' '
      read(nu_ctl,'(a)',end=999) buf
      call upstr(buf)
      call trim_c(buf,nc_buf)

      if (buf(1:4) .eq. 'STOP') go to 999

      call DATE_AND_TIME( date, time_start )

      read(buf(1:nc_buf),*) damp, perosc, amag, stress_in,
     :                      siteloc1_in, siteloc2_in
      am0 = 10.**(1.5*amag + 16.05)

      siteLocation(1) = siteloc1_in
      siteLocation(2) = siteloc2_in

      print *,' SiteLocation(1),(2) = ', siteLocation(1),siteLocation(2)

      call get_fault_dimensions(
     :    fault_type, amag, stress_in, stress_ref,
     :    dl, dw, nl, nw, nsubs,
     :    specify_length, faultlength,
     :    specify_width, faultwidth)

      isitecoordflag = isitecoordflag_in

      call set_location(faultLength,move_site, isitecoordflag,
     :                        siteLocation)
      call compute_distances(
     :    FaultLat, FaultLon,
     :    FaultLength, FaultWidth,
     :    FaultStrike, FaultDip, h,
     :    siteLocation, isitecoordflag,
     :    dl, dw, nl, nw,
     :    fr1, qr1, s1, ft1, ft2,fr2, qr2, s2, c_q, fq,
     :    r_ref,nsprd_segs,rlow,a_s,b_s,m_s,
     :    amag,
     :    site_lat_degrees,  site_lon_degrees,
     :    d_jb, d_cd2f, reff)

      r = reff
      rmod = r

      stressc = stress_in
      dlsdm = 0.0
!      numsource = 1    ! 12/22/09

      n_index = n_index + 1

* Arias intensity:

      iaorins = 1
      idva = 2
      call gm_rv(smsim_out)
      arias = arias_rv   ! must rename, because the variable arias_rv
                         ! is assigned a value for PerOsc runs, but in
                         ! those cases it is not the true Arias intensity
                         ! (it is the zeroth moment of the oscillator response)

      if (perosc .lt. 0.0 ) then
* pgv:
        iaorins = 1
        idva = 1

        print *
        write(*,'(a,1x,f5.2,1x,f6.1,1x,f5.2, 1x,f7.2)')
     :    '+ Compute pgv for per, r, m, stress = ',
     :     perosc, r, amag, stress
        call gm_rv(smsim_out)
        pgv = smsim_out
        write(nu_write_params, '(a, 1p5(1x,e10.3))')
     :    ' perosc, amag, r, stress, kappa: ',
     :      perosc, amag, r, stress,kappa_f(amag)

      else if (perosc .eq. 0.0 ) then ! pga
* pga:
        iaorins = 1
        idva = 2

        write(*,*)
        write(*,'(a,1x,f5.2,1x,f6.1,1x,f5.2, 1x,f7.2)')
     :    '+ Compute pga for per, r, m, stress = ',
     :     perosc, r, amag, stress
        call gm_rv(smsim_out)
        pga = smsim_out
        write(nu_write_params, '(a, 1p5(1x,e10.3))')
     :    ' perosc, amag, r, stress, kappa: ',
     :      perosc, amag, r, stress,kappa_f(amag)

      else
* psa: (get pga by setting to 0.0 (above) or by specifying suitably
*      small perosc... e.g., 0.001)
        iaorins = 2
        write(*,*)
        write(*,'(a,1x,f5.2,1x,f6.1,1x,f5.2,1x,f7.2)')
     :    '+ Compute psa for per, r, m, stress = ',
     :     perosc, r, amag, stress
        call gm_rv(smsim_out)
        psv = smsim_out
        write(nu_write_params, '(a, 1p5(1x,e10.3))')
     :    ' perosc, amag, r, stress, kappa: ',
     :      perosc, amag, r, stress,kappa_f(amag)

      end if

* Write to column file:
      if (perosc .lt. 0.0) then
        freqosc = -1.0
        psa = -999.0
        psag = -999.9
        psv = pgv
        sd = -999.9
      else if (perosc .eq. 0.0) then
        freqosc = 999.9
        psa = pga
        psag = pga/981.0
        psv = -999.9
        sd = -999.9
      else
        freqosc = 1.0/perosc
        psa = (twopi/perosc)*psv     ! convert psv to psa
        psag = psa/981.0
        psv = (perosc/twopi)*psa
        sd = (perosc/twopi)*psv
      end if

        write(nu_out, '(
     :    1x,i5,
     :    1x,f4.2,
     :    8x,i2, 1x,f6.1, 1x,f8.2, 1x,f8.2, 1x,f5.1, 1x,f5.2,
     :    3x,f9.3, 3x,f9.3,
     :    4x,f9.3, 4x,f9.3,
     :    14x,i1, 9x,l1,
     :    8x,f9.3, 8x,f9.3,
     :    1x,f8.2, 1x,f8.2, 1x,f8.2, 1x,f8.2,
     :    1x,f5.2, 1x,f7.3, 1x,f7.3,
     :    1p, 1x,e10.3,
     :        1x,e10.3,
     :        1x,e10.3,
     :        1x,e10.3,
     :        1x,e10.3
     :                                         )')
     :    n_index,
     :    amag,
     :    numsource, stress, faultlength, faultwidth, faultdip, h,
     :    siteloc1_in, siteloc2_in,
     :    siteLocation(1), siteLocation(2),
     :    isitecoordflag, move_site,
     :    site_lat_degrees,  site_lon_degrees,
     :    d_jb, d_cd2f, reff, r,
     :    damp, perosc, freqosc,
     :    psa,
     :       psag,
     :        psv,
     :         sd,
     :      arias

      call DATE_AND_TIME( date, time_stop )
      call time_diff(time_start, time_stop, time_elapsed)
      write(nu_write_params, '(a,1x,1pe10.3)')
     :     ' Elapsed time (sec): ', time_elapsed
      write(nu_write_params, *)

* Loop back for another set of PerOsc, Amag, R:
      go to 888
999   continue

      call DATE_AND_TIME( date, time_end )
      write(nu_write_params, '(a)')
     : ' Time End: '//
     : time_end(1:2)//':'//time_end(3:4)//':'//time_end(5:10)
      call time_diff(time_begin, time_end, time_elapsed)
      write(nu_write_params, '(a,1x,1pe10.3)')
     :     ' Total elapsed time (sec): ', time_elapsed

      print *,' '
      print *, ' Elapsed time (sec): ', time_elapsed

      close(unit=nu_out)
      close(unit=nu_write_params)
      close(unit=nu_ctl)

      stop
      end
* ----------------- END TMRS_FF_RV_DRVR ---------------------------

!------------------- SUBPROGRAMS -----------------------------------------

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        subroutine findDistanceAndAzimuth (FaultLat,FaultLon,SiteLat,
     *                                 SiteLon,epi,azi,isitecoordflag)
c       calculates distance and azimuth between two
c       points using their latitudes and longitudes

* Modified from a subroutine in Motazedian and Atkinson's
* EXSIM (release version 1.0, October 10, 2005)

* Dates: 02/17/09 - renamed some variables to avoid possible confusion
*                   between angles in degrees and radians.

* The input and output angles are in degrees

        pi = 4.0*atan(1.0)
        d2r = pi/180.0

        if (isitecoordflag .eq. 1) then  ! lat,long

          re=6371.
          alat=(FaultLat+SiteLat)/2.
          alat_radians=d2r*alat
          dlat=SiteLat-FaultLat  ! degrees
          dlon=SiteLon-FaultLon  ! degrees
          r1 = d2r*re*(SiteLat-FaultLat)
          epi= d2r*re*sqrt(dlat**2.+cos(alat_radians)**2.*dlon**2.)
          if(r1.ge.epi)then
             azi_radians=pi
          else
             azi_radians=acos(r1/epi)
          endif

          if (dlon.le.0.) azi_radians=2.0*pi-azi_radians
          azi= azi_radians/d2r

        else if (isitecoordflag .eq. 2) then  ! R,Az

          epi = sitelat
          azi = sitelon

        else  ! assume cartesian coordinates

          xn = sitelat
          xe = sitelon

          epi = sqrt(xn**2 + xe**2)

          azi = 180.0*atan2(xe, xn)/pi
          if (azi .lt. 0.0) then
            azi = 360.0 + azi
          end if

        end if

        return
        end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        real function findSubfaultDistance (R,h,FaultStrike,
     *                  fi2,FaultDip,dl,dw,i,j)
c       computes distance subfaultDistance from center of subfault (i,j)
c       to observation point using formula (1) (Figure 1)

* Modified from a subroutine in Motazedian and Atkinson's
* EXSIM (release version 1.0, October 10, 2005)

* Note confusion in what dip means in the figure 1 of Beresnev and Atkinson.
* What they label as "delta" is what was used in the original version of
* this subroutine as "dip".  Their figure has delta_1 as the true
* fault dip, probably added as a result of a review. I have
* replaced "dip" by 90_faultdip here to eliminate confusion (D. Boore, 17Feb09).

        pi = 4.0*atan(1.0)
        d2r = pi/180.0

        a90_faultdip_radians = d2r*(90.0-FaultDip)
        phi2_strike_radians = d2r*(fi2-FaultStrike)
        t1=R*cos(phi2_strike_radians)-(2.*i-1)*dl/2.
        t2=R*sin(phi2_strike_radians)-(2.*j-1)*dw/2.*
     :       sin(a90_faultdip_radians)
        t3=-h-(2.*j-1)*dw/2.*cos(a90_faultdip_radians)
        findSubfaultDistance=sqrt(t1**2.+t2**2.+t3**2.)
        return
        end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine getInputParameters(nu_ctl,
     :            FaultStrike,FaultDip,h,
     :            FaultLat,FaultLon, move_site,
     :            fault_type,
     :            FaultLength, FaultWidth,
     :            dl, dw,
     :            specify_length, specify_width, stress_ref,
     :            fq,
     :            isitecoordflag,
     :            f_stem, nc_f_stem, f_smsim_params, nc_f_smsim_params)

* Modified from a subroutine in Motazedian and Atkinson's
* EXSIM (release version 1.0, October 10, 2005)

      character f_stem*(*), f_smsim_params*(*), fault_type*(*)
      character date_ctl_correct*8, date_ctl_in*30
      character cmnts2skip(50)*80, buf_in*10

      logical f_exist, specify_length, specify_width,
     :        move_site

      pi = 4.0*atan(1.0)
      d2r = pi/180.0

      date_ctl_correct = ' '
      date_ctl_correct = '02/19/09'
      call trim_c(date_ctl_correct,nc_date_ctl_correct)

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      date_ctl_in = ' '
      read(nu_ctl,'(a)') date_ctl_in
      call trim_c(date_ctl_in,nc_date_ctl_in)

      if (date_ctl_correct(1:nc_date_ctl_correct) .ne.
     :    date_ctl_in(1:nc_date_ctl_in)) then
        write(*,*)
     :     ' The control file has the wrong date; STOP!'
        write(*,*)
     :     ' The date in the control file is '//
     :      date_ctl_in(1:nc_date_ctl_in)
        write(*,*)
     :     ' The proper date is '//
     :      date_ctl_correct(1:nc_date_ctl_correct)
        close(nu_ctl)
        stop
      end if

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      f_smsim_params = ' '
      read (nu_ctl,'(a)') f_smsim_params
      call trim_c(f_smsim_params, nc_f_smsim_params)

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      f_stem = ' '
      read (nu_ctl,'(a)') f_stem
      call trim_c(f_stem, nc_f_stem)

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      read (nu_ctl,*) FaultLat, FaultLon

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      read (nu_ctl,*) FaultStrike, FaultDip, h

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      fault_type = ' '
      read(nu_ctl,'(a)') fault_type
      call trim_c(fault_type, nc_fault_type)
      call upstr(fault_type(1:1))

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      read (nu_ctl,*) FaultLength, FaultWidth, dl, dw, stress_ref

      if (faultlength .eq. 0.0) then
        specify_length = .false.
      else
        specify_length = .true.
      end if

      if (faultwidth .eq. 0.0) then
        specify_width = .false.
      else
        specify_width = .true.
      end if

* fq:
      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      read(nu_ctl, *) fq

* Site info
      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      read (nu_ctl,*) isitecoordflag
      print *, ' Type of coordinates (1=lat,long; 2=R,Az; 3=N,E):',
     :           isitecoordflag

      call skipcmnt(nu_ctl,cmnts2skip,nc_cmnts2skip)
      buf_in = ' '
      read (nu_ctl,'(a)') buf_in
      call upstr(buf_in)
      call trim_c(buf_in, nc_buf_in)
      if (buf_in(1:1) .eq. 'Y') then
         move_site = .true.
      else
         move_site = .false.
      end if

      if (move_site .and. FaultStrike .ne. 0.0) then
        print *,' ERROR: Cannot request move site if'//
     :          ' the fault strike .ne. 0.0; QUITTING'
        stop
      end if

      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

*----------------- BEGIN SET_LOCATION -----------------------------
      subroutine set_location(faultLength,move_site, isitecoordflag,
     :                        siteLocation)

      logical move_site
      real sitelocation(2)

      pi = 4.0*atan(1.0)
      d2r = pi/180.0

      isitecoordflag_tmp  = isitecoordflag
      if (move_site .and. isitecoordflag_tmp .eq. 1 ) then
        dum = 0.0
          ! eventually might do something with this case
      else if (move_site .and. isitecoordflag_tmp .eq. 2 ) then
        isitecoordflag = 3
        r = siteLocation(1)
        az = siteLocation(2)
        xn = r*cos(d2r*az)
        xe = r*sin(d2r*az)
        siteLocation(1) = faultLength/2.0 + xn
        siteLocation(2) = xe
      else if (move_site .and. isitecoordflag_tmp .eq. 3) then
          if (sitelocation(1) .eq. 0.0) then  ! move to midpoint
            siteLocation(1) = faultLength/2.0
          end if
          if (siteLocation(2) .eq. 0.0) then  ! move to end
            siteLocation(1) = faultLength + siteLocation(1)
          end if
      end if

      return
      end
*----------------- END SET_LOCATION -----------------------------

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
        subroutine site_coords_in_degrees(
     :         FaultLat, FaultLon,
     :         SiteLat, SiteLon, isitecoordflag,
     :         site_lat_degrees, site_lon_degrees )

* Note: site_lat_degrees, site_lon_degrees are relative
* to the origin of the fault coordinates

        pi = 4.0*atan(1.0)
        dtor = pi/180.0

! If site coords not in degrees, convert
        if (isitecoordflag .eq. 1) then  ! degrees
          site_lat_degrees = sitelat
          site_lon_degrees = sitelon
        else if (isitecoordflag .eq. 2) then  ! R,Az
          r = sitelat
          az = sitelon
          xn = r*cos(dtor*az)
          xe = r*sin(dtor*az)
          call km2deg_f( xn, xe, FaultLat, FaultLon,
     :            site_lat_degrees, site_lon_degrees )
        else  ! assume cartesian coordinates
          xn = sitelat
          xe = sitelon
          call km2deg_f( xn, xe, FaultLat, FaultLon,
     :            site_lat_degrees, site_lon_degrees )
        end if

        return
        end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine writePar (ioPar,
     :   f_smsim_params, nc_f_smsim_params,
     :   FaultStrike,FaultDip,h,
     :   FaultLat, FaultLon,
     :   move_site,
     :   fault_type,
     :   FaultLength, FaultWidth, dl, dw,
     :   specify_length, specify_width, stress_ref,
     :   r_ref, nsprd_segs, rlow, a_s, b_s, m_s,
     :   fq)

!     :   qr1, s1, ft1, ft2, fr2, qr2, s2, c_q, fq,
!     :   r_ref, nsprd_segs, rlow, a_s, b_s, m_s)

c     writes modeling parameters to specified ascii file

* Modified from a subroutine in Motazedian and Atkinson's
* EXSIM (release version 1.0, October 10, 2005)

! Dates: 01/30/14 - Removed Q params from input arguments and no longer write them to
!                   ioPar.  But do write fq, as it comes from the tmrs_ff_rv_drvr control
!                   file and not from the smsim params file (so it will not be written
!                   to the summary file by write_params).
!

      logical specify_length, specify_width, move_site

      character fault_type*(*), f_smsim_params*(*)

      real amag, r_ref, rlow(*), a_s(*), b_s(*), m_s(*)

      write(ioPar,'("         modeling parameters     ")' )
      write(ioPar,'(a)') ' File with smsim parameters: '//
     :                   f_smsim_params(1:nc_f_smsim_params)
      write(ioPar,'("Fault Strike              = ",f8.2)')FaultStrike
      write(ioPar,'("Fault dip                 = ",f8.2)')FaultDip
      write(ioPar,'("Fault depth to upper edge = ",f8.2)')h

      write(ioPar,'(a,1x,l1)') ' move_site = ', move_site

      write(ioPar,'(a,1x,l1)') ' specify_length = ', specify_length

      if(.not. specify_length) then
        write(ioPar,'(a,1x, f6.1)')
     :    ' Fault length from Wells and Coppersmith for fault type '//
     :      fault_type(1:1)//', using a reference stress of ',
     :                             stress_ref
      end if
      write(ioPar,'("Fault Length  in            = ",f8.2)')FaultLength

      write(ioPar,'(a,1x,l1)') ' specify_width = ', specify_width

      if(.not. specify_width) then
        write(ioPar,'(a,1x, f6.1)')
     :    ' Fault width from Wells and Coppersmith for fault type '//
     :      fault_type(1:1)//', using a reference stress of ',
     :                             stress_ref
      end if
      write(ioPar,'("Fault Width   in            = ",f8.2)')FaultWidth

      write(ioPar,'("FaultLat                  = ",f8.2)')FaultLat
      write(ioPar,'("FaultLon                  = ",f8.2)')FaultLon

      write(ioPar,'("subfault length in          = ",f8.2)')dl
      write(ioPar,'("subfault width in           = ",f8.2)')dw
      write(ioPar,'("-----------------------------------------------")')
!      write(ioPar,'(a)') ' qr1, s1, ft1, ft2, fr2, qr2, s2, c_q = '
!      write(ioPar,*) qr1, s1, ft1, ft2, fr2, qr2, s2, c_q
      write(ioPar,'(a)') ' fq = '
      write(ioPar,*) fq
      write(ioPar,'("-----------------------------------------------")')

      write(ioPar,'(a)') ' i, nsprd_segs, r_ref, rlow, a_s, b_s, m_s'
      do i = 1, nsprd_segs
        write(ioPar,*)
     :    i, nsprd_segs, r_ref, rlow(i), a_s(i), b_s(i), m_s(i)
      end do

      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

* --------------- BEGIN COMPUTE_DISTANCES ---------------------------------
      subroutine compute_distances(
     :  FaultLat, FaultLon,
     :  FaultLength, FaultWidth,
     :  FaultStrike, FaultDip, h,
     :  SiteCoords, isitecoordflag,
     :  dl, dw, nl, nw,
     :  fr1, qr1, s1, ft1, ft2,
     :  fr2, qr2, s2, c_q, fq,
     :  r_ref,nsprd_segs,rlow,a_s,b_s,m_s,
     :  amag,
     :  site_lat_degrees,  site_lon_degrees,
     :  d_jb, d_cd2f, reff)

* Dates: 12/22/09 - Removed constraint that numsource = 1
!        04/08/11 - I modified gsprd_f to remove the dependence on numsource

      real amag, r_ref, rlow(10), a_s(10), b_s(10), m_s(10)
      real sitecoords(*),
     :     subfaultDistance(200,200), gsprdq(200,200)

      external gsprd_q_avg_f

* Initialize q_f and compute q for f=fq

      dummy = q_f_setup(fr1, qr1, s1, ft1, ft2,
     :                  fr2, qr2, s2, c_q)

* Specify fq, then compute q for this fq.  For no q, let fq = 0.0
* (in this case, q = 9999.0)
* Then write r gsprd(1/q=0) gsprd(q)

      q_fq = q_f(fq)

      inv_q = 1.0/q_fq

* Initialize gsprd_q_f:

!      numsource = 1  ! 12/22/09
      dummy =  gsprd_q_f_setup(r_ref,nsprd_segs,rlow,
     :                     a_s, b_s, m_s,
     :                     amag,
     :                     q_fq, c_q, fq)

* Compute some distances:

      sitelat = sitecoords(1)
      sitelon = sitecoords(2)

      call site_coords_in_degrees(
     :         FaultLat, FaultLon,
     :         SiteLat, SiteLon, isitecoordflag,
     :         site_lat_degrees, site_lon_degrees )

        h_min_c = 3.0 ! Campbell depth to seismogenic region
        fw1 = 0.0
        fw2 = faultwidth
        fl1 = 0.0
        fl2 = faultlength

        call dist_3df(
     :   site_lat_degrees, site_lon_degrees,
     :   FaultLat, FaultLon, h, FaultStrike, FaultDip,
     :   fw1, fw2, fl1, fl2,
     :   h_min_c, d_jb, az_jb, d_cd2f, az_cd2f, d_c, az_c,
     :   d_sta_n, d_sta_e, irgn_cd2f, irgn_c, irgn_jb)

        fi2=0
        call findDistanceAndAzimuth(FaultLat,FaultLon,SiteLat,
     :                           SiteLon,R,fi2,isitecoordflag)
c     Note that R, azm fi2 are the distance, azm. w.r.t. origin (not epi),
c     Note also I must input faultstrike in degrees and it's converted to rad.

        cum_gsprdq = 0.0  ! need this for computation of reff

        nsubfaults = 0

        DO i=1,nl
          DO j=1,nw

            nsubfaults = nsubfaults + 1

            subfaultDistance(i,j)=
     :                 findSubfaultDistance(R,h,FaultStrike,
     :                           fi2,FaultDip,dl,dw,i,j)

* Compute gsprd*q for this subfault and station:
            gsprdq(i,j) = gsprd_q_f(subfaultDistance(i,j))

            cum_gsprdq = cum_gsprdq + gsprdq(i,j)**2.0

          END DO ! loop over nw to calculate quantities not dependent on nsims
        END DO ! loop over nl to calculate quantities not dependent on nsims

        gsprdq_avg = sqrt(cum_gsprdq/float(nsubfaults))

        dummy =  gsprd_q_avg_f_setup(r_ref, nsprd_segs, rlow,
     :                     a_s, b_s, m_s,
     :                     amag,
     :                     q_fq, c_q, fq,
     :                     gsprdq_avg)
        x1 = 1.0
        x2 = 2000.0
        tol = 0.001
        reff = zbrent(gsprd_q_avg_f,x1,x2,tol)

        dummy =  gsprd_q_avg_f_deallocate()

        dummy =  gsprd_q_f_deallocate()

        return
        end
* --------------- END COMPUTE_DISTANCES ---------------------------------

*----------------- BEGIN GET_FAULT_DIMENSIONS -----------------------------
      subroutine get_fault_dimensions(
     :    fault_type, amag, stress, stress_ref,
     :    dl, dw, nl, nw, nsubs,
     :    specify_length, faultlength,
     :    specify_width, faultwidth)

      character fault_type*1

      logical specify_length, specify_width

      stress_factor = (stress_ref/stress)**(1.0/3.0)

      if (.not. specify_length) then
        if(fault_type(1:1) .eq. 'S') then
          faultlength = 10.0**(-2.57+0.62*amag)
        else if(fault_type(1:1) .eq. 'R') then
          faultlength = 10.0**(-2.42+0.58*amag)
        else if(fault_type(1:1) .eq. 'N') then
          faultlength = 10.0**(-1.88+0.50*amag)
        else
          faultlength = 10.0**(-2.44+0.59*amag)
        end if

        faultlength = stress_factor * faultlength

      end if
      if (.not. specify_width) then
        specify_width  = .false.
        if(fault_type(1:1) .eq. 'S') then
          faultwidth = 10.0**(-0.76+0.27*amag)
        else if(fault_type(1:1) .eq. 'R') then
          faultwidth = 10.0**(-1.61+0.41*amag)
        else if(fault_type(1:1) .eq. 'N') then
          faultwidth = 10.0**(-1.14+0.35*amag)
        else
          faultwidth = 10.0**(-1.01+0.32*amag)
        end if

        faultwidth = stress_factor * faultwidth

      end if

      nl=FaultLength/dl
      if (nl .lt. 1) nl = 1
      nw=FaultWidth/dw
      if (nw .lt. 1) nw = 1

      nsubs = nl * nw

      dl = FaultLength/float(nl)  ! Need to reset dl and dw because nl and nw are integers
      dw = FaultWidth/float(nw)

      return
      end
*----------------- END GET_FAULT_DIMENSIONS -----------------------------

!      include 'rv_subs.for'
!      include 'rv_td_subs.for'
!      include 'recipes.for'
      include 'smsim_subs_for_rv_programs.for'
      include 'smsim_util_subs.for'
      include 'ff_subprograms.for'


      SUBROUTINE DLAMBY(INPUT,MATOUT,SKJ)
C
C     DRIVER FOR DOUBLET LATTICE WITH BODIES
C
      INTEGER         ECORE,SYSBUF,IZ(1),TSKJ,SKJ
      INTEGER         SCR1,SCR2,SCR3,SCR4,SCR5
      DIMENSION       NAME(2)
      COMMON /SYSTEM/ SYSBUF
      COMMON /ZZZZZZ/ Z(1)
      COMMON /BLANK / NK,NJ
      COMMON /AMGMN / MCB(7),NROW,ND,NE,REFC,FMACH,RFK,TSKJ(7),ISK,NSK
      COMMON /DLBDY / NJ1,NK1,NP,NB,NTP,NBZ,NBY,NTZ,NTY,NT0,NTZS,NTYS,
     1                INC,INS,INB,INAS,IZIN,IYIN,INBEA1,INBEA2,INSBEA,
     2                IZB,IYB,IAVR,IARB,INFL,IXLE,IXTE,INT121,INT122,
     3                IZS,IYS,ICS,IEE,ISG,ICG,IXIJ,IX,IDELX,IXIC,IXLAM,
     4                IA0,IXIS1,IXIS2,IA0P,IRIA,INASB,IFLA1,IFLA2,
     5                ITH1A,ITH2A,ECORE,NEXT,SCR1,SCR2,SCR3,SCR4,SCR5,
     6                NTBE
      EQUIVALENCE     (IZ(1),Z(1))
      DATA   NAME /4HDLAM,4HBY  /
      DATA NHAERO,NHPOIN,NHCORE / 4HAERO,4HPOIN,4HCORE/
C
      SCR1 = 301
      SCR2 = 302
      SCR3 = 303
      SCR4 = 304
      SCR5 = 305
C
C     GET CORE THEN SET POINTERS TO ACPT TABLE ARRAYS
C
      ECORE = KORSZ(IZ) - 4*SYSBUF
C
C     READ LENGTHS OF ARRAYS
C
      CALL FREAD(INPUT,NJ1,13,0)
C
C     COMPUTE POINTERS TO OPEN CORE
C
      LNS = INC
      INC = 1
      INS = INC
      INB = INS + NP
      INAS = INB + NP
      IZIN = INAS
      IYIN = IZIN
      INBEA1 = IYIN + NP
      INBEA2 = INBEA1 + NB
      INSBEA = INBEA2 + NB
      IZB = INSBEA + NB
      IYB = IZB + NB
      IAVR = IYB + NB
      IARB = IAVR + NB
      INFL = IARB + NB
      IXLE = INFL + NB
      IXTE = IXLE + NB
      INT121 = IXTE + NB
      INT122 = INT121 + NB
      IZS = INT122 + NB
      N = 3*NP + 12 * NB
C
C     READ FIXED ARRAYS
C
      IF(N .GT. ECORE) GO TO 998
      CALL FREAD(INPUT,IZ,N,0)
C
C     GET LENGTHS OF VARIABLE ARRAYS, PANELS THEN BODIES
C
      LNAS = 0
      IF(NP .EQ. 0) GO TO 20
      DO 10 I=1,NP
   10 LNAS = LNAS + IZ(INAS+I-1)
   20 LNB = 0
      LNSB = 0
      LNFL = 0
      LT1 = 0
      LT2 = 0
      DO 30 I=1,NB
      K = I-1
      LNB = LNB + IZ(INBEA1+K)
      LNSB = LNSB + IZ(INSBEA+K)
      LNFL = LNFL + IZ(INFL+K)
      LT1 = LT1 + IZ(INT121+K)
   30 LT2 = LT2 + IZ(INT122+K)
      NTBE = NTP+LNB
C
C     READ VARIABLE  ARRAYS AND SET POINTERS TO CORE
C
      NEXT = N+1
      N = 2*NB + 5*LNS + 4*NTP + 3*LNB + 4*LNSB + LNAS + 2*LNFL
     *  + LT1 + LT2
      IF(NEXT+N+4*NJ.GE.ECORE) GO TO 998
      CALL FREAD(INPUT,IZ(NEXT),N,1)
      NEXT = NEXT + N + 1
      IYS = IZS + NB + LNS
      ICS = IYS
      IEE = ICS + NB + LNS
      ISG = IEE + LNS
      ICG = ISG + LNS
      IXIJ = ICG
      IX = IXIJ + LNS
      IDELX = IX + NTP + LNB
      IXIC = IDELX + NTP + LNB
      IXLAM = IXIC + NTP
      IA0 = IXLAM + NTP
      IXIS1 = IA0 + LNSB
      IXIS2 = IXIS1 + LNSB
      IA0P = IXIS2 + LNSB
      IRIA = IA0P + LNSB
      INASB = IRIA + LNB
      IFLA1 = INASB + LNAS
      IFLA2 = IFLA1 + LNFL
      ITH1A = IFLA2 + LNFL
      ITH2A = ITH1A + LT1
C
C     BUILD A MATRIX
C
      CALL BUG(NHAERO,100,ND,5)
      CALL BUG(NHPOIN,100,NJ1,59)
      CALL BUG(NHCORE,100,Z,NEXT)
      N1 = NEXT
      N = NEXT + 2*NTBE
      NEXT = NEXT + 4*NTBE
      IF(NT0 .NE. 0) CALL GENDSB(Z(INC),Z(INB),Z(ISG),Z(ICG),Z(INFL),
     *   Z(INBEA1),Z(INBEA2),Z(IFLA1),Z(IFLA2),Z(N1),Z(N1),Z(N))
      N = NTZS + NTYS
      NEXT = N1
      BETA = SQRT(1.0-FMACH**2)
      IF( NT0 .NE. 0 .AND. N .NE. 0) CALL AMGROD(Z(N1),BETA)
      CALL AMGSBA(MATOUT,Z(IA0),Z(IARB),Z(INSBEA),Z(N1),Z(IYB),Z(IZB))
      NROW = NROW + NJ1
C
C     BUILD SKJ MATRIX BE SURE TO BUMP ISK NSK
C
      CALL AMGBFS(SKJ,Z(IEE),Z(IDELX),Z(INC),Z(INB),Z(IXIS2),Z(IXIS1),
     *      Z(IA0),Z(IA0P),Z(INSBEA))
 1000 RETURN
C
C     ERROR MESSAGES
C
  998 CALL MESAGE(-8,0,NAME)
      GO TO 1000
      END


! Define precision for floating point numbers
! And hence the size of the corresponding datatype
  Module precision
!   Don't use Fortran's implicit variable typing (based on first character of variable name)
    Implicit None
!   Double precision floating point numbers
    Integer, Parameter, Public       :: wp = kind(0.0D0)
    Intrinsic                        :: kind
  End Module precision

! Define integer values corresponding to C enum values in nagfbs.h
! and derived types corresponding to C structs in nagfbs.h
  Module fbstypes

!   We need to access Fortran's C bindings
    Use iso_c_binding

!   Use our definition of floating point number precision
    Use precision, Only: wp

!   Don't use Fortran's implicit variable typing (based on first character of variable name)
    Implicit None

!   enums and return types
!   Parameters are analogous to C/C++ consts
    Integer, Parameter :: FBS_Direct            = 0
    Integer, Parameter :: FBS_BinSearch         = 1

    Integer, Parameter :: FBS_CODE_UNKNOWN      = 1
    Integer, Parameter :: FBS_DIRECT_UNFEASIBLE = 2
    Integer, Parameter :: FBS_X_TOO_LARGE       = 3
    Integer, Parameter :: FBS_NOT_IMPLEMENTED   = 100

!   Fortran derived type corresponding to DirectInfo struct
    Type, Bind(c) :: directinfo
      Real(kind=wp) :: scaler
    End Type directinfo

!   Fortran derived type corresping to FBSInfo struct
    Type, Bind(c) :: fbsinfo
      Type(c_ptr) :: x
      Integer :: n
      Integer :: code
      Logical(c_bool) :: outL, outR
      Type(directinfo) :: direct
    End Type fbsinfo

  End Module fbstypes

! Define the Fortran interfaces for C FBS functions
  Module nagfdemo_ib
!   Don't use Fortran's implicit variable typing (based on first character of variable name)
    Implicit None
    Interface
!     Fortran interface for FBS_getInfo
      Integer Function FBS_getInfo(code, x, n, outLeft, outRight, mem, info)
        Use iso_c_binding, Only: c_bool
        Use precision, Only: wp
        Use fbstypes, Only: fbsinfo
        Implicit None
        Integer, Intent (In) :: code
        Integer, Intent (In) :: n
        Real(kind=wp), Intent (In) :: x(*)
        Logical(c_bool), Intent (In) :: outLeft, outRight
        Integer, Intent (Out) :: mem
        Type(fbsinfo), Intent (Out) :: info
      End Function FBS_getInfo
!     Fortran interface for FBS_setup
      Integer Function FBS_setup(info, cwork)
        Use fbstypes, Only: fbsinfo
        Implicit None
        Type(fbsinfo), Intent (In) :: info
        Integer, Intent (Out) :: cwork(*)
      End Function FBS_setup
!     Fortran interface for FBS_scalar
      Integer Function FBS_scalar(z, cwork)
        Use precision, Only: wp
        Implicit None
        Real (Kind=wp), Intent (In) :: z
        Integer, Intent (In) :: cwork(*)
      End Function FBS_scalar
!     Fortran interface for FBS_vectorial
      Integer Function FBS_vectorial(j, z, m, cwork)
        Use precision, Only: wp
        Implicit None
        Integer, Intent (Out) :: j(*)
        Real (Kind=wp), Intent (In) :: z(*)
        Integer, Intent (In) :: m
        Integer, Intent (In) :: cwork(*)
      End Function FBS_vectorial
    End Interface
  End Module nagfdemo_ib


!> Calculate potenital corrections due to volume correction
!! For documentation see memo: peneloux.pdf
!! \author MH, June 2014

module volume_shift
  use compdata, only: gendata_pointer
  use stringmod, only: str_eq, uppercase, string_match, string_match_val
  use thermopack_constants, only: Rgas
  implicit none
  private
  save
  !> Volume shift identifyers
  integer, parameter :: NOSHIFT=0, PENELOUX=1

  public :: initVolumeShift, &
       eosVolumeFromShiftedVolume, &
       volumeShiftZfac, &
       NOSHIFT, PENELOUX, &
       redefine_volume_shift, &
       vshift_F_terms

contains

  !----------------------------------------------------------------------
  !> Initialize volume shift parameters
  !>
  !> \author MH, June 2014
  !----------------------------------------------------------------------
  function initVolumeShift(nc,comp,shiftId,eos, param_ref) result (volumeShiftId)
    integer, intent(in) :: nc !< Number of components
    type (gendata_pointer), dimension(nc), intent(inout) :: comp !< Component data
    character(len=*), intent(in) :: shiftId !< String volume shif identifyer
    character(len=*), intent(in) :: eos !< Eos string
    character(len=*), optional, intent(in) :: param_ref !< Parameter set
    integer :: volumeShiftId
    ! Locals
    integer :: i
    logical :: found

    found = .false.
    if (str_eq(shiftId, 'PENELOUX')) then
      do i=1,nc
        found = get_database_ci(comp(i)%p_comp%ident,uppercase(eos),&
             comp(i)%p_comp%cid, ref=param_ref)
        if (.not. found) then
          print *, "Using Rackett-factor correlation for Peneloux volume shift"

          if (comp(i)%p_comp%zra > 0.0) then
            if (trim(eos) == 'SRK') then
              comp(i)%p_comp%cid%ciA = 0.40768*(Rgas*comp(i)%p_comp%tc/&
                   comp(i)%p_comp%pc)*(0.29441 - comp(i)%p_comp%zra)
            else if (trim(eos) == 'PR') then
              comp(i)%p_comp%cid%ciA = 0.50033*(Rgas*comp(i)%p_comp%tc/&
                   comp(i)%p_comp%pc)*(0.25969 - comp(i)%p_comp%zra)
            else
              call stoperror('Wrong EOS for Peneloux volume shift')
            endif
          else
            print *, "NB: no volume shift parameter available for ", &
                 comp(i)%p_comp%ident
            comp(i)%p_comp%cid%ciA = 0.0
          end if
        endif
      enddo
      volumeShiftId = PENELOUX
    else
      volumeShiftId = NOSHIFT
    endif
  end function initVolumeShift

  !----------------------------------------------------------------------
  !> Get the volume to feed to the EoS, given the actual (shifted) volume
  !>
  !> \author MH, June 2014
  !----------------------------------------------------------------------
  function eosVolumeFromShiftedVolume(nc,comp,volumeShiftId,t,v,z) result (v_eos)
    ! Transferred variables
    integer, intent(in) :: nc
    type (gendata_pointer), dimension(nc), intent(in) :: comp
    integer, intent(in) :: volumeShiftId !< Volume shift identifier
    real, intent(in) :: t !< K - Temperature
    real, intent(in) :: v !< m3/mol - Actual, shifted volume
    real, dimension(1:nc), intent(in) :: z !< Composition
    real :: v_eos !< m3/mol - EoS volume
    ! Locals
    real :: c, ci, cit, citt
    logical :: ci_temp_dep
    integer :: i
    !
    v_eos = v
    if (volumeShiftId == PENELOUX) then
      c = 0
      do i=1,nc
        call comp(i)%p_comp%cid%get_vol_trs_c(T, ci, cit, citt, ci_temp_dep)
        c = c + z(i)*ci
      enddo
      v_eos = v + c
    endif
  end function eosVolumeFromShiftedVolume

  !----------------------------------------------------------------------
  !> Calculate volume shift
  !>
  !> \author MH, June 2014
  !----------------------------------------------------------------------
  subroutine volumeShiftZfac(nc,comp,volumeShiftId,t,p,z,phase,Zfac,dZdt,dZdp,dZdz)
    ! Transferred variables
    integer, intent(in) :: nc
    type (gendata_pointer), dimension(nc), intent(in) :: comp
    integer, intent(in) :: volumeShiftId !< Volume shift identifyer
    integer, intent(in) :: phase !< Phase identifyer
    real, intent(in) :: t !< K - Temperature
    real, intent(in) :: p !< Pa - Pressure
    real, dimension(1:nc), intent(in) :: z !< Compozition
    real, intent(out) :: Zfac !< - Compressibillity factor
    real, optional, intent(out) :: dzdt !< 1/K - Compressibillity factor differential wrpt. temperature
    real, optional, intent(out) :: dzdp !< 1/Pa - Compressibillity factor differential wrpt. pressure
    real, optional, dimension(1:nc), intent(out) :: dzdz !< 1/mol - Compressibillity factor differential wrpt. mol numbers
    ! Locals
    real :: c, n, ca(nc), cat(nc), citt, ct
    integer :: i
    logical :: shift_t_terms, ci_temp_dep
    !
    if (volumeShiftId == PENELOUX) then
      shift_t_terms = .false.
      do i=1,nc
        call comp(i)%p_comp%cid%get_vol_trs_c(T, ca(i), cat(i), citt, ci_temp_dep)
        if (ci_temp_dep) shift_t_terms = .true.
      enddo
      c = sum(z*ca)
      ct = sum(z*cat)
      n = sum(z)
      Zfac = Zfac - c*P/(n*Rgas*T) ! Volume corrections
      if (present(dzdt)) then
        dzdt = dzdt + c*P/(n*Rgas*T**2)
        if (shift_t_terms) dzdt = dzdt - ct*P/(n*Rgas*T)
      endif
      if (present(dzdp)) then
        dzdp = dzdp - c/(n*Rgas*T)
      endif
      if (present(dzdz)) then
        do i=1,nc
          dzdz(i) = dzdz(i) - (ca(i) - c/n)*P/(n*Rgas*T)
        enddo
      endif
    endif
  end subroutine volumeShiftZfac

  !----------------------------------------------------------------------
  !> Redefine volume shift for component j
  !>
  !> \author MH, May 2019
  !----------------------------------------------------------------------
  subroutine redefine_volume_shift(nc,j,comp,vLcurrent,vLexp)
    integer, intent(in) :: nc !< number of components
    integer, intent(in) :: j !< component
    type (gendata_pointer), dimension(nc), intent(inout) :: comp !< Component data
    real, intent(in) :: vLcurrent !< specific volume with current ci [m3/mol]
    real, intent(in) :: vLexp !< experimental volume [m3/mol]
    ! Locals
    real :: v0
    !
    ! Assume temperature independent volume shift
    v0 = vLcurrent + comp(j)%p_comp%cid%ciA  ! Volume without correction (m3/mol)
    comp(j)%p_comp%cid%ciA = v0 - vLexp  ! Updated volume-shift (m3/mol)
  end subroutine redefine_volume_shift

  !----------------------------------------------------------------------
  !> Look for volume-shift parameters in data-base
  !>
  !> \author Ailo, Sep 2020
  !----------------------------------------------------------------------
  function get_database_ci(cid,eos,cidc,ref) result (found_ci)
    use compdata, only: cidatadb
    use compdatadb, only: cidb, maxcidb
    character(len=*), intent(in) :: eos !< Eos string
    character(len=*), intent(in) :: cid !< Component
    type(cidatadb), intent(inout) :: cidc !< Volume shift type
    character(len=*), optional, intent(in) :: ref !< Reference string
    logical :: found_ci
    ! Locals
    logical :: ref_match
    integer :: idx_lowest, match_val
    integer :: i
    found_ci = .false.
    call cidc%set_zero_vol_trs()
    idx_lowest = 100000
    do i=1,maxcidb
      if (str_eq(cidb(i)%eosid, eos) .and. str_eq(cidb(i)%cid, cid)) then
        if (.not. found_ci) then ! we at least found one match
          cidc = cidb(i)
        end if
        found_ci = .true.

        if (present(ref)) then ! check if there is a match with the ref
          call string_match_val(ref,cidb(i)%ref,ref_match,match_val)
          if (ref_match .and. match_val<idx_lowest) then ! the match takes precedence
            idx_lowest = match_val
            cidc = cidb(i)
          end if
        end if

      endif
    enddo
  end function get_database_ci

  !----------------------------------------------------------------------
  !> Volume shift of residual, reduced Helmholtz energy, F
  !>
  !> Temperature-dependent volume shift not implemented, but easy to do
  !>
  !> \author Ailo, May 2020
  !----------------------------------------------------------------------
  subroutine vshift_F_terms(nc,comp,volumeShiftId,T,V,n,F,F_T,F_V,F_n,F_TT,&
       F_TV,F_VV,F_Tn,F_Vn,F_nn,F_VVV)
    integer, intent(in) :: nc
    type (gendata_pointer), dimension(nc), intent(in) :: comp
    integer, intent(in) :: volumeShiftId !< Volume shift identifier
    real, intent(in) :: T !< K - Temperature
    real, intent(in) :: V !< m3 - Volume
    real, dimension(1:nc), intent(in) :: n !< Mole numbers
    real, optional, intent(inout) :: F,F_T,F_V,F_n(nc)
    real, optional, intent(inout) :: F_TT,F_TV,F_Tn(nc),F_VV,F_VVV,F_Vn(nc),F_nn(nc,nc)
    ! Locals
    integer :: i, j
    real :: C, ci, cj, sumn, Veos, ca(nc), cat(nc), catt(nc), CT, CTT, cit
    logical :: shift_t_terms, ci_temp_dep
    if (volumeShiftId == NOSHIFT) return

    shift_t_terms = .false.
    sumn = sum(n)
    do i=1,nc
      call comp(i)%p_comp%cid%get_vol_trs_c(T, ca(i), cat(i), catt(i), ci_temp_dep)
      if (ci_temp_dep) shift_t_terms = .true.
    enddo
    C = sum(n*ca)
    CT = sum(n*cat)
    CTT = sum(n*catt)
    Veos = V + C

    if (present(F_nn)) then
      do i=1,nc
        ci = ca(i)
        do j=i,nc
          cj = ca(j)
          F_nn(i,j) = F_nn(i,j) + F_Vn(i)*cj + F_Vn(j)*ci + F_VV*ci*cj - (ci+cj)/Veos + sumn*ci*cj/Veos**2
          F_nn(j,i) = F_nn(i,j)
        end do
      end do
    end if

    do i=1,nc
      ci = ca(i)
      if (present(F_Tn)) F_Tn(i) = F_Tn(i) + F_TV*ci
      if (shift_t_terms) then
        cit = cat(i)
        if (present(F_Tn)) F_Tn(i) = F_Tn(i) - (CT + sumn*ciT)/Veos &
             + sumn*CT*ci/Veos**2 + F_VV*ci*CT + F_V*ciT + F_Vn(i)*CT
      endif
      if (present(F_Vn)) F_Vn(i) = F_Vn(i) + F_VV*ci + 1/V-1/Veos + sumn*ci/Veos**2
      if (present(F_n)) F_n(i) = F_n(i) + F_V*ci + log(V/Veos) - sumn*ci/Veos
    end do

    if (shift_t_terms) then
      if (present(F_TT)) F_TT = F_TT - sumn*CTT/Veos + sumn*CT**2/Veos**2 &
           + 2*F_TV*CT + F_VV*CT**2 + F_V*CTT
      if (present(F_TV)) F_TV = F_TV + sumn*CT/Veos**2 + F_VV*CT
      if (present(F_T)) F_T = F_T - sumn*CT/Veos + F_V*CT
    endif

    if (present(F_VVV)) F_VVV = F_VVV + sumn*(2/V**3 - 2/Veos**3)
    if (present(F_VV)) F_VV = F_VV + sumn*(-1/V**2 + 1/Veos**2)
    if (present(F_V)) F_V = F_V + sumn*(1/V-1/Veos)
    if (present(F)) F = F + sumn*log(V/Veos)

  end subroutine vshift_F_terms

end module volume_shift


module umapTest_nd_module

  use amrex_fort_module, only : amrex_real, dim=>bl_spacedim
  use amrex_ebstruct_module, only : cutface, cutcell
  use umap_test_module, only : facedata, ebbndrydata

  implicit none

contains

  function fort_umap_norm (lo, hi, src, src_sz, kt, ktlo, kthi, max_mv,ncomp, p) result(nrm) &
       bind(c,name='fort_umap_norm')
    integer, intent(in) :: lo(3), hi(3), ktlo(3), kthi(3), p, max_mv, ncomp, src_sz
    integer, intent(in) :: kt(ktlo(1):kthi(1),ktlo(2):kthi(2),ktlo(3):kthi(3),max_mv,ncomp)

    real(amrex_real), intent(in) :: src(0:src_sz-1) ! 0-indexing for c compatability
    real(amrex_real) :: nrm

    integer :: i,j,k,n, m, key

    nrm = 0.0_amrex_real
    do n = 1, ncomp
       do m = 1, max_mv
          do       k = lo(3), hi(3)
             do    j = lo(2), hi(2)
                do i = lo(1), hi(1)
                   key = kt(i,j,k,m,n)
                   if (key .ge. 0) then
                      nrm = max(nrm, abs(src(key)))
                   endif
                end do
             end do
          end do
       end do
    enddo
  end function fort_umap_norm

  subroutine do_eb_work(lo, hi, bdmap, Nbd, ccmap, Ncc,&
    ktc, ktclo, ktchi, max_mv, ncomp) bind(C,name="do_eb_work")

    integer,     intent(in) :: lo(0:2), hi(0:2)
    integer,     intent(in) :: Nbd, Ncc
    type(ebbndrydata), intent(in) :: bdmap(0:Nbd-1)
    type(cutcell), intent(in) :: ccmap(0:Nbd-1)
    integer, intent(in) :: ktclo(0:2), ktchi(0:2), max_mv, ncomp
    integer, intent(in) :: ktc(ktclo(0):ktchi(0),ktclo(1):ktchi(1),ktclo(2):ktchi(2),0:max_mv-1,ncomp)

    integer :: i,j,k,n,L,key,d,tot,LL,RR,BB,TT
    real(amrex_real) :: vL, vR, vB, vT, vTOT

    do n = 1, ncomp
       do L = 0, max_mv-1
          do k = lo(2), hi(2)
             do j = lo(1), hi(1)
                do i = lo(0), hi(0)
                   key = ktc(i,j,k,L,n)
                   if (key .ge. 0) then

                      if (ccmap(key)%Nnbr(0,0).gt.0) then
                         LL = ccmap(key)%nbr(0,0,0)
                         if (LL .ge. 0) then
                            vL = bdmap(ktc(i-1,j,k,LL,n))%vol_frac
                         else
                            vL = 1.d0
                         endif
                      else
                         LL = -1
                         vL = 0.d0
                      endif

                      if (ccmap(key)%Nnbr(1,0).gt.0) then
                         RR = ccmap(key)%nbr(0,1,0)
                         if (RR .ge. 0) then
                            vR = bdmap(ktc(i+1,j,k,RR,n))%vol_frac
                         else
                            vR = 1.d0
                         endif
                      else
                         RR = -1
                         vR = 0.d0
                      endif

                      if (ccmap(key)%Nnbr(0,1).gt.0) then
                         BB = ccmap(key)%nbr(0,0,1)
                         if (BB .ge. 0) then
                            vB = bdmap(ktc(i,j-1,k,BB,n))%vol_frac
                         else
                            vB = 1.d0
                         endif
                      else
                         BB = -1
                         vB = 0.d0
                      endif

                      if (ccmap(key)%Nnbr(1,1).gt.0) then
                         TT = ccmap(key)%nbr(0,1,1)
                         if (TT .ge. 0) then
                            vT = bdmap(ktc(i,j+1,k,TT,n))%vol_frac
                         else
                            vT = 1.d0
                         endif
                      else
                         TT = -1
                         vT = 0.d0
                      endif

                      if (i.eq.37 .and. j.eq.57) then
                         print *,'VOL',vL,vR,vB,vT
                      endif

                   endif
                end do
             end do
          end do
       end do
    enddo

  end subroutine do_eb_work

end module umapTest_nd_module


! <ppsrc.f90 - A component of the City-scale
!                 Chemistry Transport Model EPISODE-CityChem>
!*****************************************************************************!
!*
!* EPISODE - An urban-scale air quality model
!* ==========================================
!* Copyright (C) 2018  NILU - Norwegian Institute for Air Research
!*                     Instituttveien 18
!*                     PO Box 100
!*                     NO-2027 Kjeller
!*                     Norway
!*
!*                     Contact persons: Gabriela Sousa Santos - gss@nilu.no
!*                                      Paul Hamer - pdh@nilu.no
!*
!* Unless explicitly acquired and licensed from Licensor under another license,
!* the contents of this file are subject to the Reciprocal Public License ("RPL")
!* Version 1.5, https://opensource.org/licenses/RPL-1.5 or subsequent versions as
!* allowed by the RPL, and You may not copy or use this file in either source code
!* or executable form, except in compliance with the terms and conditions of the RPL.
!*
!* All software distributed under the RPL is provided strictly on an "AS IS" basis,
!* WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, AND LICENSOR HEREBY
!* DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
!* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT, OR NON-INFRINGEMENT.
!* See the RPL for specific language governing rights and limitations under the RPL.
!*
!* ==========================================
!* The dispersion model EPISODE (Grønskei et. al., 1993; Larssen et al., 1994;
!* Walker et al., 1992, 1999; Slørdal et al., 2003, 2008) is an Eulerian grid model
!* with embedded subgrid models for calculations of pollutant concentrations resulting
!* from different types of sources (area-, line- and point sources). EPISODE solves the
!* time dependent advection/-diffusion equation on a 3 dimensional grid.
!* Finite difference numerical methods are applied to integrate the solution forward in time.
!* It also includes extensions as the implementation of a simplified EMEP photochemistry
!* scheme for urban areas (Walker et al. 2004) and a scheme for Secondary Organic Aerosol
!* implemented by Håvard Slørdal
!*
!* Grønskei, K.E., Walker, S.E., Gram, F. (1993) Evaluation of a model for hourly spatial
!*    concentrations distributions. Atmos. Environ., 27B, 105-120.
!* Larssen, S., Grønskei, K.E., Gram, F., Hagen, L.O., Walker, S.E. (1994) Verification of
!*    urban scale time-dependent dispersion model with sub-grid elements in Oslo, Norway.
!*    In: Air poll. modelling and its appl. X. New York, Plenum Press.
!* Slørdal, L.H., McInnes, H., Krognes, T. (2008): The Air Quality Information System AirQUIS.
!*    Info. Techn. Environ. Eng., 1, 40-47, 2008.
!* Slørdal, L.H., Walker, S.-E., Solberg, S. (2003) The Urban Air Dispersion Model EPISODE
!*    applied in AirQUIS. Technical Description. NILU TR 12/2003. ISBN 82-425-1522-0.
!* Walker, S.E., Grønskei, K.E. (1992) Spredningsberegninger for on-line overvåking i Grenland.
!*    Programbeskrivelse og brukerveiledning. Lillestrøm,
!*    Norwegian Institute for Air Research (NILU OR 55/92).
!* Walker, S.E., Slørdal, L.H., Guerreiro, C., Gram, F., Grønskei, K.E. (1999) Air pollution
!*    exposure monitoring and estimation. Part II. Model evaluation and population exposure.
!*    J. Environ. Monit, 1, 321-326.
!* Walker, S.-E., Solberg, S., Denby, B. (2003) Development and implementation of a
!*    simplified EMEP photochemistry scheme for urban areas in EPISODE. NILU TR 13/2013.
!*    ISBN 82-425-1524-7
!*****************************************************************************!

      subroutine PPSRC(IQ,QIDV,QXV,QYV,QZV,QHSV,QDIV,QHBV,QWBV,QTEV,      &
                      QTGV,QVGV,MQEM,NQEM,QEMVEC)

! The subroutine performs processing on point source data.
! ----------------------------------------------------------------------------------
! Based on:
! Version Episode 5.5 (May29, 2012) prepared for BB-Stand-Alone
! Original source code of EPISODE by Sam-Erik Walker (NILU)
!
! Sam-Erik Walker
! Norwegian Institute for Air Research (NILU)
! Instituttveien 18 P.O. Box 100
! N-2027 Kjeller, NORWAY
! Tel: +47 63898000 Fax: +47 63898050
! E-mail: sam-erik.walker@nilu.no
!
! ----------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------
! REVISION HISTORY
!
!           2016  M. Karl: conversion from num/s to g/s  (num = number of particles)
!
! ----------------------------------------------------------------------------------

      use mod_util
      use mod_main
      use mod_site
      use mod_time
      use mod_mete
      use mod_conc
      use mod_psrc

      implicit none

      integer :: IQ
      integer :: MQEM
      integer :: NQEM

!MSK      CHARACTER(len=256) QIDV
      character(len=10) QIDV

      real :: QXV
      real :: QYV
      real :: QZV
      real :: QHSV
      real :: QDIV
      real :: QHBV
      real :: QWBV
      real :: QTEV
      real :: QTGV
      real :: QVGV
      real :: QEMVEC(MQEM)

! Local variables

      real :: LON0
      real :: QEMV
      real :: QHEV
      real :: QPSV
      real :: QSYV
      real :: QSZV
      real :: UTME
      real :: UTMN
      real :: QXVV
      real :: QYVV

      integer :: I
      integer :: I1
      integer :: I2
      integer :: IC
      integer :: J
      integer :: NPOS

      logical :: LEOF

! Comments out by RuO - 10.01.2008
! Rotate point source main grid coordinates (m)

!      QXVV = +COS(ANGLE*RAD)*(QXV - SITEX0) +
!     .        SIN(ANGLE*RAD)*(QYV - SITEY0) + SITEX0
!      QYVV = -SIN(ANGLE*RAD)*(QXV - SITEX0) +
!     .        COS(ANGLE*RAD)*(QYV - SITEY0) + SITEY0
!
!      QXV = QXVV
!      QYV = QYVV

! If the diameter or velocity is missing then the point source is
! converted to a volume source

      IF (QDIV .LE. 0.0 .OR. QVGV .LE. 0.0) THEN

! If building height is missing use stack height

          IF (QHBV .LE. 0.0) QHBV = QHSV

! If building width is missing use building height

          IF (QWBV .LE. 0.0) QWBV = QHBV

! Calculate stack height and effective emission height

!          QHSV = QHBV/2.0
!          QHEV = QHBV/2.0

!	BRUCE 10032005
!	SET THESE TO THEIR ORIGINAL VALUE DUE TO INPUFF PROBLEMS

          QHSV = QHSV
          QHEV = QHSV

! Calculate plume segment initial sigma-y and sigma-z

          QSYV = QWBV/2.0
          QSZV = QHBV/2.0

      ELSE

! Tentative value of final emission height

          QHEV = QHSV

! Calculate plume segment initial sigma-y and sigma-z

          QSYV = QDIV
          QSZV = QDIV

      ENDIF

! Calculate gas temperature (K)

      IF (QTGV .NE. MISS .AND. IQT .EQ. 1) QTGV = QTGV + CTOK

! Set point source identification

      QID(IQ) = QIDV
!_23May2011:      IF (MESSFE) WRITE (MESSUN,2060) IQ,(QIDV(J:J),J=1,30)
!_18Oct2011:      IF (MESSFE) WRITE (MESSUN,2060) IQ,(QIDV(J:J),J=1,10)

! Set point source main grid coordinates (m)

      QX(IQ) = QXV
      QY(IQ) = QYV
      QZ(IQ) = QZV

! Set point source height (m) and diameter

      QHS(IQ) = QHSV
      QDI(IQ) = QDIV

! Set point source building height (m) and width (m)

      QHB(IQ) = QHBV
      QWB(IQ) = QWBV

! Set point source gas temperature (K) and velocity (m/s)

      QTG(IQ) = QTGV
      QVG(IQ) = QVGV

! Set point source thermal energy (MW)

      QTE(IQ) = 0.

! Set point source initial sigma-y and sigma-z

      QSY(IQ) = QSYV
      QSZ(IQ) = QSZV

! Set point source tentative emission height. For point sources
! that are not volume sources, this will be recalculated later to
! become final emission height taking into account temperature and
! velocity of the gas.

      QHE(IQ) = QHEV

! Set point source tentative degree of penetration. For point
! sources that are not volume sources, this will be recalculated
! later to become final degree of penetration.

      QPS(IQ) = 0.

      !print *,'ppsrc: qhev',IQC(2),QEMVEC(IQC(2))

! Calculate and set point source emission rates (g/s)

      DO 260 IC = 1,NC

          IF (IQC(IC) .GT. 0) THEN
              QEMV = QEMVEC(IQC(IC))
          ELSE
              QEMV = 0.
          ENDIF

!MSK start HERE IS THE PLACE FOR UNIT CONVERSION OF EMISSIONS
! iqu    - Emission rate ..... unit 1: g/s, 2: kg/h, 3: t/a, 4: num/s

!MSK comment:   if iqu==1 nothing to do because emission in psrc file is in g/s

          IF (IQU .EQ. 2) QEMV = QEMV/3.6
          IF (IQU .EQ. 3) QEMV = (1.0E+6/(365.25*24.*3600.))*QEMV

! conversion from num/s to g/s   (num = number of particles)
! emission rate in num/s has to be derived from g/s in the pointsrc input
!                dens_p = 1 g(particles)/cm3
!                V_p    = 4.2e-21 m3    (d_p = 200 nm = 2.e-7 m)
!                m_p    = 4.2e-15 g(particles)   = dens_p*V_p
!                Rate   = 1 g(particles)/s
!                num_p  = 1 g / m_p = 2.39e14 num
! how much particles/s are emitted?
! scale factor = num/s *F = g/s;   F = 4.2e-15
!
! MSK new comment 23.01.2017
! Conversion from num/s to g/s   (num = number of particles)
! Number emission has the right time unit.
! We only have to take care that concentration CRV is not ug/m^3
! but number/m^3. That is in csubp.f90
          IF ((IQU .EQ. 4).or.(CUNIT(IC)(1:3) == 'num') ) then
            QEMV = QEMV * 1.0
          ENDIF
!MSK end

          QEM(IQ,IC) = QEMV

          !if ( (iq==1).and.(ic==2) ) then
          !    print *,'ppsrc qem iq,ic',iq,ic,IQU,QEM(IQ,IC),QEMV
          !endif

  260 CONTINUE

      RETURN

 2060 format ('PPSRC: Included point source number ',I3,      &
           ' with ID: ',256A1)

! End of subroutine PPSRC

      end subroutine ppsrc


      SUBROUTINE CONVRT
C
C        'CONVRT' CONVERTS INPUT DATA INTO THE FORM REQUIRED
C        FOR INTERNAL USE
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      REAL*8 I3,I2OVI3
C
      COMMON/CCMBNZ/ CMRK(10),Z01(4),Z02(4),Z03(4),Z04(4),Z11(12),
     .               Z12(12),Z13(12),Z14(12),Z15(12),Z16(12),Z21(36),
     .               Z22(36),Z23(36),Z24(36),Z25(36),Z26(36),Z27(36),
     .               Z28(36),Z31(108),Z32(108),Z33(108),Z34(108),
     .               Z35(108),Z41(324),Z42(324),Z43(324),ZK21(18),
     .               ZK22(18),ZK23(18),ZK31(54),ZK32(54),ZK33(54),
     .               ZK34(54),ZK35(54),ZK36(54),ZK41(162),ZK42(162),
     .               ZK43(162),ZK44(162),ZK45(162),ZK46(162),ZK47(162),
     .               ZK48(162),ZS01(2),ZS02(2),ZS11(6),ZS12(6),ZS13(6),
     .               ZS21(18),ZS22(18),ZS23(18),ZS24(18),ZS31(54),
     .               ZS32(54),ZS41(162),ZT21(108),ZT22(108),STAO(18),
     .               STA1(18),STA2(18),STBO(18),STB1(18),STB2(18),
     .               Z2S01(2),Z2S12(6),Z2S23(18)
C
      COMMON/CCNVRT/ BDYMI(3,3),DPRMI(3,3),EMODLS(10),RTUBE(10),
     .               HTUBE(10),THERMC(10),TIPMS(10),C(10)
C
      COMMON/CFNALP/ SCO,CIZO(3,3),CIYO(3,3),DONA(3,10),DONB(3,10)
     .              ,CDAMP(3,10)
C
      COMMON/CONSTS/ PI,TWOPI,RADIAN
C
      COMMON/CSOLAR/ SAO(10),SKA(9),SKB(9),SKOA(10,3),SKOB(10,3),
     .               STMK(10),SKAA(10,9),SKBB(10,9)
C
      COMMON/CSTVAL/ TSTART,ZL0(10),ZL1(10),ZL2(10),ZLA(10)
C
      COMMON/EISUBK/ EI(10)
C
      COMMON/ELKDMP/ OMKDMP(3,10),IOMKDM(10)
C
      COMMON/IPOOL1/ IGRAV,IDAMP,IK,K1,ITIM,IAB,IAPS,IBB,IBPS,NK(10),
     .               LK(10),LLK(10)
C
C
      COMMON/RPOOL1/ RHOK(10),TIME,SA(3,3),FM1(3,3),ZLK(10),OMEG(3),
     .               ZLKP(10),ZLKDP(10),CMAT(3,3),GBAR(3,3),YBCM(3),
     .               ZBZK(3,10),FCM(3,3),DTO,PHID,PHI
C
C
      COMMON/RNEWR/ZA(10),I3(10),I2OVI3(10),
     *             ZDQ(10),ZJ(10)
C
      COMMON/RTDIST/ TDIS(10)
C
      COMMON/SATLSH/ TAUK(10),OCULTK(10),RADSH
C
C
      DIMENSION STAUK(10),SOCULT(10)
      DIMENSION RHO(10),SAOK(10),ZLOK(10),ZL1K(10),ZL2K(10),EM(10),
     .          HT(10),RT(10),TI(10),TH(10),ST(10),DONB1(3,10),PROD(10),
     .          IL(10),ILL(10),SKOA1(10,3),SKOB1(10,3),TDIST(10)
C
C
C
      REAL*8 INERTA
C
C
C
      DO 5 I=1,3
      DO 5 J=1,3
      CIYO(I,J)=0.D0
    5 CIZO(I,J)=0.D0
C
C
      CIYO(1,1)=(BDYMI(3,3) + BDYMI(2,2) - BDYMI(1,1))/2.D0
      CIYO(2,2)=(BDYMI(3,3) + BDYMI(1,1) - BDYMI(2,2))/2.D0
      CIYO(3,3)=(BDYMI(1,1) + BDYMI(2,2) - BDYMI(3,3))/2.D0
C
      CIZO(1,1)=(DPRMI(3,3) + DPRMI(2,2) - DPRMI(1,1))/2.D0
      CIZO(2,2)=(DPRMI(3,3) + DPRMI(1,1) - DPRMI(2,2))/2.D0
      CIZO(3,3)=(DPRMI(1,1) + DPRMI(2,2) - DPRMI(3,3))/2.D0
C
      CIYO(1,2)=BDYMI(1,2)
      CIYO(1,3)=BDYMI(1,3)
      CIYO(2,3)=BDYMI(2,3)
C
      CIZO(1,2)=DPRMI(1,2)
      CIZO(1,3)=DPRMI(1,3)
      CIZO(2,3)=DPRMI(2,3)
C
      DO 10 I=1,3
      DO 10 J=I,3
      CIYO(J,I)=CIYO(I,J)
   10 CIZO(J,I)=CIZO(I,J)
C
      DO 20 K=1,IK
      STAUK(K)=TAUK(K)
      SOCULT(K)=OCULTK(K)
      TDIST(K)=TDIS(K)
      RHO(K)=RHOK(K)
      SAOK(K)=SAO(K)
      ZLOK(K)=ZL0(K)
      ZL1K(K)=ZL1(K)
      ZL2K(K)=ZLA(K)
      EM(K)=EMODLS(K)
      HT(K)=HTUBE(K)
      RT(K)=RTUBE(K)
      TI(K)=TIPMS(K)
      TH(K)=THERMC(K)
      ST(K)=STMK(K)
      IL(K)=LK(K)
      ILL(K)=LLK(K)
C
      DO 20 I=1,3
      SKOB1(K,I)=SKOB(K,I)
      SKOA1(K,I)=SKOA(K,I)
   20 DONB1(I,K)=CDAMP(I,K)
C
C
C
      DO 60 K=1,IK
      L=IK-K1+K
      IF((K-K1).GT.0) L=K-K1
C
      TAUK(K)=STAUK(L)
      OCULTK(K)=SOCULT(L)
      TDIS(K)=TDIST(L)
      RHOK(K)=RHO(L)
      SAO(K)=SAOK(L)
      ZL0(K)=ZLOK(L)
      ZL1(K)=ZL1K(L)
      ZLA(K)=ZL2K(L)
      EMODLS(K)=EM(L)
      HTUBE(K)=HT(L)
      RTUBE(K)=RT(L)
      TIPMS(K)=TI(L)
      THERMC(K)=TH(L)
      STMK(K)=ST(L)
      LK(K)=IL(L)
      LLK(K)=ILL(L)
C
      DO 30 I=1,3
      SKOA(K,I)=SKOA1(L,I)
      SKOB(K,I)=SKOB1(L,I)
   30 CDAMP(I,K)=DONB1(I,L)
C
   60 CONTINUE
C
C
      DO 70 I=1,IK
      INERTA=PI*RTUBE(I)**3*HTUBE(I)
      PROD(I)=EMODLS(I)*INERTA/144.D0
      EI(I)=6.D0*PROD(I)*THERMC(I)/RTUBE(I)*TDIS(I)
      CMRK(I)=TIPMS(I)/RHOK(I)
      DO 70 J=1,9
      SKAA(I,J)=PROD(I)*(1.0D0+I2OVI3(I))
   70 SKBB(I,J)=PROD(I)*(1.0D0+I2OVI3(I))
C
C
      DO 80 I=1,9
      SKA(I)=0.D0
   80 SKB(I)=0.D0
C
      DO 90 I=1,IK
      SUM=DSQRT(PROD(I)*RHOK(I))
      DO 90 J=1,3
      GO TO (101,102,103),J
  101 N1=1
      N2=19
      M1=1
      M2=10
      GO TO 104
  102 N1=5
      N2=23
      M1=5
      M2=14
      GO TO 104
  103 N1=9
      N2=27
      M1=9
      M2=18
  104 N=N1
      IF (LK(I).EQ.2) N=N2
      M=M1
      IF (LLK(I).EQ.2) M=M2
      SUM1=DSQRT(2.0D0*Z21(N)*ZK21(M))
      SUM2=DSQRT(2.0D0*Z21(N)*ZK23(M))
      DONA(J,I)=SUM*SUM1*2.0D0*CDAMP(J,I)
      DONB(J,I)=SUM*SUM2*2.0D0*CDAMP(J,I)
      IF(IOMKDM(I).EQ.0) GO TO 90
      DONA(J,I)=2.0D0*CDAMP(J,I)*OMKDMP(J,I)
      DONB(J,I)=2.0D0*CDAMP(J,I)*OMKDMP(J,I)
   90 CONTINUE
C
      RETURN
      END


varying vec4 ambientGlobal;

uniform sampler2D colorBuffer;
uniform sampler2D normalBuffer;
uniform sampler2D positionBuffer;
uniform sampler2D lumiBuffer;

uniform mat4 viewMatrix;
uniform mat4 projMatrix;

uniform vec3 buffersize;
uniform vec3 camerarange;

void main()
{
	vec2 texCoord = gl_TexCoord[0].xy;

	vec4 color = vec4(0,0,0,1);

	vec4 ecPosDepth = texture2D(positionBuffer, texCoord);

	if (ecPosDepth.w == 0.0) discard;

	vec4 baseColor = texture2D(colorBuffer, texCoord);

	vec3 n,halfV;
	float NdotL,NdotHV;

	vec3 lightDir;
	vec3 halfVector;

	vec4 litColor = ambientGlobal*baseColor;

	vec4 normalSpec = texture2D(normalBuffer, texCoord);

	n = normalSpec.xyz;

	float specVal = normalSpec.w;

%LIGHTLOOP:START%
	lightDir = normalize(gl_LightSource[%LIGHTID%].position.xyz);
	halfVector = normalize(gl_LightSource[%LIGHTID%].halfVector.xyz);

	NdotL = max(dot(n,lightDir),0.0);

	if (NdotL > 0.0)
	{
		color += baseColor * gl_LightSource[%LIGHTID%].diffuse * NdotL;
	}

	NdotHV = max(dot(n, halfVector),0.0001);

	litColor += specVal * baseColor * pow(NdotHV,texture2D(lumiBuffer,texCoord).z);

	color += litColor;
	litColor = vec4(0,0,0,1);
%LIGHTLOOP:END%

	gl_FragColor = vec4(color.rgb,1);
	gl_FragDepth = ecPosDepth.w;
}