module scalar_laplacian_routines

    use spherepack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    use spherepack_interfaces, only: &
        scalar_synthesis

    use scalar_synthesis_routines, only: &
        ScalarSynthesisUtility, &
        shsec, shses, shsgc, shsgs

    use type_ScalarHarmonic, only: &
        ScalarHarmonic

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: slapec, slapes, slapgc, slapgs
    public :: islapec, islapes, islapgc, islapgs
    public :: scalar_laplacian_lower_utility_routine
    public :: invert_scalar_laplacian_lower_utility_routine

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: ONE = 1.0_wp

    ! Declare interfaces for submodule implementation
    interface
        module subroutine slapec(nlat, nlon, isym, nt, slap, ids, jds, a, b, mdab, ndab, &
            wshsec, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: slap(ids, jds, nt)
            integer(ip), intent(in)  :: ids
            integer(ip), intent(in)  :: jds
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wshsec(:)
            integer(ip), intent(out) :: ierror
        end subroutine slapec

        module subroutine slapes(nlat, nlon, isym, nt, slap, ids, jds, a, b, mdab, ndab, &
            wshses, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: slap(ids, jds, nt)
            integer(ip), intent(in)  :: ids
            integer(ip), intent(in)  :: jds
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wshses(:)
            integer(ip), intent(out) :: ierror
        end subroutine slapes

        module subroutine slapgc(nlat, nlon, isym, nt, slap, ids, jds, a, b, mdab, ndab, &
            wshsgc, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: slap(ids, jds, nt)
            integer(ip), intent(in)  :: ids
            integer(ip), intent(in)  :: jds
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wshsgc(:)
            integer(ip), intent(out) :: ierror
        end subroutine slapgc

        module subroutine slapgs(nlat, nlon, isym, nt, slap, ids, jds, a, b, mdab, ndab, &
            wshsgs, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(out) :: slap(ids, jds, nt)
            integer(ip), intent(in)  :: ids
            integer(ip), intent(in)  :: jds
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wshsgs(:)
            integer(ip), intent(out) :: ierror
        end subroutine slapgs

        module subroutine islapec(nlat, nlon, isym, nt, xlmbda, sf, ids, jds, a, b, &
            mdab, ndab, wshsec, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(in)  :: xlmbda(:)
            real(wp),    intent(out) :: sf(ids, jds, nt)
            integer(ip), intent(in)  :: ids
            integer(ip), intent(in)  :: jds
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wshsec(:)
            real(wp),    intent(out) :: pertrb(:)
            integer(ip), intent(out) :: ierror
        end subroutine islapec

        module subroutine islapes(nlat, nlon, isym, nt, xlmbda, sf, ids, jds, a, b, &
            mdab, ndab, wshses, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(in)  :: xlmbda(:)
            real(wp),    intent(out) :: sf(ids, jds, nt)
            integer(ip), intent(in)  :: ids
            integer(ip), intent(in)  :: jds
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wshses(:)
            real(wp),    intent(out) :: pertrb(:)
            integer(ip), intent(out) :: ierror
        end subroutine islapes

        module subroutine islapgc(nlat, nlon, isym, nt, xlmbda, sf, ids, jds, a, b, &
            mdab, ndab, wshsgc, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(in)  :: xlmbda(:)
            real(wp),    intent(out) :: sf(ids, jds, nt)
            integer(ip), intent(in)  :: ids
            integer(ip), intent(in)  :: jds
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wshsgc(:)
            real(wp),    intent(out) :: pertrb(:)
            integer(ip), intent(out) :: ierror
        end subroutine islapgc

        module subroutine islapgs(nlat, nlon, isym, nt, xlmbda, sf, ids, jds, a, b, &
            mdab, ndab, wshsgs, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)  :: nlat
            integer(ip), intent(in)  :: nlon
            integer(ip), intent(in)  :: isym
            integer(ip), intent(in)  :: nt
            real(wp),    intent(in)  :: xlmbda(:)
            real(wp),    intent(out) :: sf(ids, jds, nt)
            integer(ip), intent(in)  :: ids
            integer(ip), intent(in)  :: jds
            real(wp),    intent(in)  :: a(mdab, ndab, nt)
            real(wp),    intent(in)  :: b(mdab, ndab, nt)
            integer(ip), intent(in)  :: mdab
            integer(ip), intent(in)  :: ndab
            real(wp),    intent(in)  :: wshsgs(:)
            real(wp),    intent(out) :: pertrb(:)
            integer(ip), intent(out) :: ierror
        end subroutine islapgs
    end interface

contains

    pure subroutine compute_coefficient_multipliers(coeff_multipliers)

        ! Dummy arguments
        real(wp), intent(out) :: coeff_multipliers(:)

        ! Local variables
        integer(ip) :: n
        real(wp)    :: fn

        associate (nlat => size(coeff_multipliers))
            do n=2, nlat
                fn = real(n - 1, kind=wp)
                coeff_multipliers(n) = fn * (fn + ONE)
            end do
        end associate

    end subroutine compute_coefficient_multipliers

    pure subroutine perform_setup_for_scalar_laplacian(a, b, alap, blap, coeff_multipliers)

        ! Dummy arguments
        real(wp),    intent(in)  :: a(:, :, :)
        real(wp),    intent(in)  :: b(:, :, :)
        real(wp),    intent(out) :: alap(:, :, :)
        real(wp),    intent(out) :: blap(:, :, :)
        real(wp),    intent(out) :: coeff_multipliers(:)

        ! Local variables
        integer(ip) :: k, n, m

        associate (&
            order_m => size(alap, dim=1), &
            degree_n => size(alap, dim=2), &
            number_of_synthesis => size(alap, dim=3) &
            )

            ! Set coefficient multiplyers
            call compute_coefficient_multipliers(coeff_multipliers)

            ! Preset coefficients to 0.0
            alap = ZERO
            blap = ZERO

            ! Compute scalar laplacian coefficients for each vector field
            do k=1, number_of_synthesis

                ! Compute m = 0 coefficients
                do n=2, degree_n
                    alap(1, n, k) = -coeff_multipliers(n) * a(1, n, k)
                    blap(1, n, k) = -coeff_multipliers(n) * b(1, n, k)
                end do

                ! Compute m > 0 coefficients
                do m=2, order_m
                    do n=m, degree_n
                        alap(m, n, k) = -coeff_multipliers(n)*a(m, n, k)
                        blap(m, n, k) = -coeff_multipliers(n)*b(m, n, k)
                    end do
                end do
            end do
        end associate

    end subroutine perform_setup_for_scalar_laplacian

    subroutine scalar_laplacian_lower_utility_routine(nlat, nlon, isym, nt, &
        scalar_laplacian, a, b, wavetable, synth_routine, error_flag)

        ! Dummy arguments
        integer(ip),                intent(in)  :: nlat
        integer(ip),                intent(in)  :: nlon
        integer(ip),                intent(in)  :: isym
        integer(ip),                intent(in)  :: nt
        real(wp),                   intent(out) :: scalar_laplacian(:,:,:)
        real(wp), dimension(:,:,:), intent(in)  :: a, b
        real(wp),                   intent(in)  :: wavetable(:)
        procedure(scalar_synthesis)             :: synth_routine
        integer(ip), intent(out)                :: error_flag

        ! Local variables
        type(ScalarHarmonic) :: harmonic
        real(wp)             :: coeff_multipliers(nlat)

        ! Allocate memory
        harmonic = ScalarHarmonic(nlat, nlon, nt)

        associate( &
            ids => size(scalar_laplacian, dim=1), &
            jds => size(scalar_laplacian, dim=2), &
            alap => harmonic%real_component, &
            blap => harmonic%imaginary_component, &
            order_m => harmonic%ORDER_M, &
            degree_n => harmonic%DEGREE_N &
            )

            call perform_setup_for_scalar_laplacian(a, b, alap, blap, coeff_multipliers)

            ! Synthesize alap, blap into scalar_laplacian
            call synth_routine(nlat, nlon, isym, nt, scalar_laplacian, ids, jds, &
                alap, blap, order_m, degree_n, wavetable, error_flag)
        end associate

        ! Release memory
        call harmonic%destroy()

    end subroutine scalar_laplacian_lower_utility_routine

    pure subroutine perform_setup_for_inversion(a, b, as, bs, coeff_multipliers, xlmbda, pertrb)

        ! Dummy arguments
        real(wp), intent(in)  :: a(:, :, :)
        real(wp), intent(in)  :: b(:, :, :)
        real(wp), intent(out) :: as(:, :, :)
        real(wp), intent(out) :: bs(:, :, :)
        real(wp), intent(out) :: coeff_multipliers(:)
        real(wp), intent(in)  :: xlmbda(:)
        real(wp), intent(out) :: pertrb(:)

        ! Local variables
        integer(ip) :: k, n, m

        associate (&
            order_m => size(as, dim=1), &
            degree_n => size(as, dim=2), &
            number_of_syntheses => size(as, dim=3) &
            )

            ! Preset coefficient multiplyers
            call compute_coefficient_multipliers(coeff_multipliers)

            ! Preset synthesis coefficients to zero
            as = ZERO
            bs = ZERO

            do k=1, number_of_syntheses

                ! Compute synthesis coefficients for xlmbda zero or nonzero
                if (xlmbda(k) == ZERO) then
                    do n=2, degree_n
                        as(1, n, k) = -a(1, n, k)/coeff_multipliers(n)
                        bs(1, n, k) = -b(1, n, k)/coeff_multipliers(n)
                    end do
                    do m=2, order_m
                        do n=m, degree_n
                            as(m, n, k) = -a(m, n, k)/coeff_multipliers(n)
                            bs(m, n, k) = -b(m, n, k)/coeff_multipliers(n)
                        end do
                    end do
                else
                    ! xlmbda nonzero so operator invertible unless
                    ! -n*(n-1) = xlmbda(k) < 0.0  for some n
                    !
                    pertrb(k) = ZERO

                    do n=1, degree_n
                        as(1, n, k) = -a(1, n, k)/(coeff_multipliers(n) + xlmbda(k))
                        bs(1, n, k) = -b(1, n, k)/(coeff_multipliers(n) + xlmbda(k))
                    end do

                    do m=2, order_m
                        do n=m, degree_n
                            as(m, n, k) = -a(m, n, k)/(coeff_multipliers(n) + xlmbda(k))
                            bs(m, n, k) = -b(m, n, k)/(coeff_multipliers(n) + xlmbda(k))
                        end do
                    end do
                end if
            end do
        end associate

    end subroutine perform_setup_for_inversion

    subroutine invert_scalar_laplacian_lower_utility_routine(nlat, nlon, isym, &
        nt, helmholtz_constant, perturbation, solution, a, b, wavetable, &
        synth_routine, error_flag)

        ! Dummy arguments
        integer(ip),                intent(in)  :: nlat
        integer(ip),                intent(in)  :: nlon
        integer(ip),                intent(in)  :: isym
        integer(ip),                intent(in)  :: nt
        real(wp),                   intent(in)  :: helmholtz_constant(:)
        real(wp),                   intent(out) :: perturbation(:)
        real(wp),                   intent(out) :: solution(:,:,:)
        real(wp), dimension(:,:,:), intent(in)  :: a, b
        real(wp),                   intent(in)  :: wavetable(:)
        procedure(scalar_synthesis)             :: synth_routine
        integer(ip), intent(out)                :: error_flag

        ! Local variables
        type(ScalarHarmonic) :: harmonic
        real(wp)             :: coeff_multipliers(nlat)

        ! Allocate memory
        harmonic = ScalarHarmonic(nlat, nlon, nt)

        associate( &
            ids => size(solution, dim=1), &
            jds => size(solution, dim=2), &
            as => harmonic%real_component, &
            bs => harmonic%imaginary_component, &
            order_m => harmonic%ORDER_M, &
            degree_n => harmonic%DEGREE_N &
            )
            call perform_setup_for_inversion(a, b, as, bs, coeff_multipliers, &
                helmholtz_constant, perturbation)

            ! Synthesize as, bs into sf
            call synth_routine(nlat, nlon, isym, nt, solution, ids, jds, &
                as, bs, order_m, degree_n, wavetable, error_flag)
        end associate

        ! Release memory
        call harmonic%destroy()

    end subroutine invert_scalar_laplacian_lower_utility_routine

end module scalar_laplacian_routines


************************************************************************
*
*     Subroutine INPUTH3B                            Called by: INPUTH3
*
*     For a user defined regression model (MODNO=99), determine the
*     number of additional data variables (NADDL) and the number of
*     explanatory variables (NEXPL).  For each explanatory variable,
*     determine corresponding data variable (DVNAME) and transformation
*     (TRANS).
*
*     locals vars
*     -----------
*     DVNAMEI  DVNAME on input
*     TRANSI   TRANS on input
*
************************************************************************
      SUBROUTINE INPUTH3B(NADDL,NEXPL,DVNAME,TRANS)
*
*     dimensional parameters and logical devices
*
      INCLUDE 'fmodules.inc'
      INCLUDE 'lda.inc'
*
*     subroutine arguments
*
      INTEGER*4 NADDL,NEXPL
      CHARACTER*5 DVNAME(*),TRANS(*)
*
*     local vars
*
      INTEGER*4 I,IADDL
      CHARACTER*5 DVNAMEI,TRANSI
      CHARACTER*500 BUFFER
*
*     input format statements
*
 1000 FORMAT(2I5)
 1100 FORMAT(I1)
*
*     output format statements
*
 2000 FORMAT(' Number of Additional Data Variables (NADDL):',I5)
 2100 FORMAT(' Number of Explanatory Variables (NEXPL)    :',I5)
 2200 FORMAT(/,' Data',T25,'Transformation',T46,'Explanatory',
     &       /,' Variable (DVNAME)',T25,'Code (TRANS)',T46,'Variable',
     &       /,1X,59('-'))
 2300 FORMAT(1X,A5,T25,A5,T46,A5)
 2301 FORMAT(1X,A5,T25,A5,T46,A5,'^2')
 2302 FORMAT(1X,A5,T25,A5,T46,'sqrt(',A5,')')
 2303 FORMAT(1X,A5,T25,A5,T46,'ln(',A5,')')
 2304 FORMAT(1X,A5,T25,A5,T46,'ln(',A5,')^2')
 2305 FORMAT(1X,A5,T25,A5,T46,'sin(2*Pi*',A5,')')
 2306 FORMAT(1X,A5,T25,A5,T46,'sin(4*Pi*',A5,')')
 2307 FORMAT(1X,A5,T25,A5,T46,'sin(6*Pi*',A5,')')
 2308 FORMAT(1X,A5,T25,A5,T46,'cos(2*Pi*',A5,')')
 2309 FORMAT(1X,A5,T25,A5,T46,'cos(4*Pi*',A5,')')
 2310 FORMAT(1X,A5,T25,A5,T46,'cos(6*Pi*',A5,')')
 2400 FORMAT(/,' *** WARNING: Sin and Cos transformations are normally',
     &       ' ***',/,5X,
     &       'applied to the time variable only (DTIME).  A',/,5X,
     &       'transformation code of ',A5,' has been specified ',/,5X,
     &       'for ',A5,/)
*
*     read the number of additional data variables, NADDL
*
*     NADDL should never exceed 9 due to the way in which the ADDLX
*     independent variable names are formatted (a single digit is
*     assumed to follow 'ADDL'; see FORMAT statement for reading IADDL
*     in INPUT2).  This is probably not a problem -- its hard to
*     envision applications with more than 3 or 4 addional variables,
*     let alone more than 9.
*
      CALL GETLINE(LDHEAD,BUFFER)
      READ(BUFFER,1000) NADDL
      WRITE(LDECHO,2000) NADDL
      IF (NADDL.GT.9) CALL ERROR2(2,NADDL,9)
*
*     read the number of explanatory variables, NEXPL.  There must
*     be at least one explanatory variable, and the total number of
*     explanatory variables cannot exceed the maximum number of
*     parameters minus 1 (in general, the number of parameters equals
*     1 constant plus NEXPL explanatory variables).
*
      CALL GETLINE(LDHEAD,BUFFER)
      READ(BUFFER,1000) NEXPL
      WRITE(LDECHO,2100) NEXPL
      IF (NEXPL.LT.1) CALL ERROR1(12,NEXPL)
      IF (NEXPL.GT.MAXPARMS-1) CALL ERROR2(7,NEXPL,MAXPARMS-1)
*
*     for each explanatory variable, read the name of the data variable
*     (DVNAME) and the transformation code (TRANS).
*
      WRITE(LDECHO,2200)

      DO 10 I=1,NEXPL
         CALL GETLINE(LDHEAD,BUFFER)
         READ (BUFFER,*) DVNAMEI,TRANSI
*
*        Echo DVNAME and TRANS; print error if valid transformation code
*        not found.
*
         IF (TRANSI .EQ. 'NONE') THEN
            WRITE(LDECHO,2300) DVNAMEI,TRANSI,DVNAMEI
         ELSEIF(TRANSI .EQ. 'SQ') THEN
            WRITE(LDECHO,2301) DVNAMEI,TRANSI,DVNAMEI
         ELSEIF(TRANSI .EQ. 'SQRT') THEN
            WRITE(LDECHO,2302) DVNAMEI,TRANSI,DVNAMEI
         ELSEIF(TRANSI .EQ. 'LN') THEN
            WRITE(LDECHO,2303) DVNAMEI,TRANSI,DVNAMEI
         ELSEIF(TRANSI .EQ. 'LNSQ') THEN
            WRITE(LDECHO,2304) DVNAMEI,TRANSI,DVNAMEI
         ELSEIF(TRANSI .EQ. 'SIN2P') THEN
            WRITE(LDECHO,2305) DVNAMEI,TRANSI,DVNAMEI
         ELSEIF(TRANSI .EQ. 'SIN4P') THEN
            WRITE(LDECHO,2306) DVNAMEI,TRANSI,DVNAMEI
         ELSEIF(TRANSI .EQ. 'SIN6P') THEN
            WRITE(LDECHO,2307) DVNAMEI,TRANSI,DVNAMEI
         ELSEIF(TRANSI .EQ. 'COS2P') THEN
            WRITE(LDECHO,2308) DVNAMEI,TRANSI,DVNAMEI
         ELSEIF(TRANSI .EQ. 'COS4P') THEN
            WRITE(LDECHO,2309) DVNAMEI,TRANSI,DVNAMEI
         ELSEIF(TRANSI .EQ. 'COS6P') THEN
            WRITE(LDECHO,2310) DVNAMEI,TRANSI,DVNAMEI
         ELSE
            WRITE(LDECHO,2300) DVNAMEI,TRANSI
            CALL ERROR5(3,TRANSI)
         ENDIF
*
*        make sure data variable names are valid.  Valid names include
*        Q, DTIME, and ADDLi, where i is less than or equal to NADDL.
*
         IF (DVNAMEI(1:4) .EQ. 'ADDL') THEN
            READ(DVNAMEI(5:5),1100) IADDL
            IF (IADDL .GT. NADDL) CALL ERROR5(2,DVNAMEI)
         ELSEIF (DVNAMEI.NE.'Q' .AND. DVNAMEI.NE.'DTIME') THEN
            CALL ERROR5(2,DVNAMEI)
         ENDIF
*
*        Sin and Cos transformations are normally applied to temporal
*        terms only.  Issue a non-fatal warning if sin or cos
*        transformations are applied to anything other than DTIME
*
         IF ((TRANSI(1:3) .EQ. 'SIN' .OR. TRANSI(1:3) .EQ. 'COS')
     &        .AND. (DVNAMEI .NE. 'DTIME'))
     &        WRITE(LDECHO,2400) TRANSI,DVNAMEI
*
*        now that error checking is done, copy strings to vector vars
*
         DVNAME(I) = DVNAMEI
         TRANS(I) = TRANSI
 10   CONTINUE

      RETURN
      END


!> Test for calling C function
Program example_4
  !use itsol2
  implicit none
  integer :: n=10,nnz=10
  integer :: ierr,i
  double precision, allocatable, dimension(:) :: val,rhs,init
  double precision, allocatable, dimension(:) :: solu
  integer, allocatable, dimension(:) :: col_ind,row_ptr

  allocate( val(nnz) )
  allocate( rhs(n) )
  allocate( init(n) )
  allocate( solu(n) )
  allocate( col_ind(nnz) )
  allocate( row_ptr(n+1) )

  do i = 1,nnz
     val(i) = i**2
     col_ind(i) = i
  end do

  do i = 1,n
     rhs(i) = i**3
     row_ptr(i) = i
     init(i) = 0.0
  end do

  row_ptr(n+1) = n+1

  write(*,*) "Hi, this is example 4, testing for linear solvers."

  write(*,*) "Matrix val:"
  write(*,*) val

  write(*,*) "Matrix col_ind:"
  write(*,*) col_ind

  write(*,*) "Matrix row_ptr:"
  write(*,*) row_ptr

  write(*,*) "Right hand side:"
  write(*,*) rhs

  write(*,*) "Initial guess:"
  write(*,*) init

  call arms_fgmres(n,val,col_ind,row_ptr,rhs,solu,init,ierr)

  write(*,*) "Solution:"
  write(*,*) solu

  write(*,*) "ierr = ",ierr,"."

end Program example_4


      FUNCTION timeseed()
      IMPLICIT none
      INTEGER time(3),timeseed
      CHARACTER*8 timec
      call itime(time)
      write(timec,'(I0.2I0.2I0.2)') time(1),time(2),time(3)
      read(timec,*) timeseed
      RETURN
      END

C----------------------------------------------------------------------C
C Random number generators from Numerical Recipes, Press et al.
C----------------------------------------------------------------------C

      FUNCTION ran1(idum)
      INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
      REAL ran1,AM,EPS,RNMX
      PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836,
     *NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
      INTEGER j,k,iv(NTAB),iy
      SAVE iv,iy
      DATA iv /NTAB*0/, iy /0/
      if (idum.le.0.or.iy.eq.0) then
        idum=max(-idum,1)
        do 11 j=NTAB+8,1,-1
          k=idum/IQ
          idum=IA*(idum-k*IQ)-IR*k
          if (idum.lt.0) idum=idum+IM
          if (j.le.NTAB) iv(j)=idum
11      continue
        iy=iv(1)
      endif
      k=idum/IQ
      idum=IA*(idum-k*IQ)-IR*k
      if (idum.lt.0) idum=idum+IM
      j=1+iy/NDIV
      iy=iv(j)
      iv(j)=idum
      ran1=min(AM*iy,RNMX)
      return
      END

      FUNCTION ran2(idum)
      INTEGER idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV
      REAL ran2,AM,EPS,RNMX
      PARAMETER (IM1=2147483563,IM2=2147483399,AM=1./IM1,IMM1=IM1-1,
     *IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791,
     *NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
      INTEGER idum2,j,k,iv(NTAB),iy
      SAVE iv,iy,idum2
      DATA idum2/123456789/, iv/NTAB*0/, iy/0/
      if (idum.le.0) then
        idum=max(-idum,1)
        idum2=idum
        do 11 j=NTAB+8,1,-1
          k=idum/IQ1
          idum=IA1*(idum-k*IQ1)-k*IR1
          if (idum.lt.0) idum=idum+IM1
          if (j.le.NTAB) iv(j)=idum
11      continue
        iy=iv(1)
      endif
      k=idum/IQ1
      idum=IA1*(idum-k*IQ1)-k*IR1
      if (idum.lt.0) idum=idum+IM1
      k=idum2/IQ2
      idum2=IA2*(idum2-k*IQ2)-k*IR2
      if (idum2.lt.0) idum2=idum2+IM2
      j=1+iy/NDIV
      iy=iv(j)-idum2
      iv(j)=idum
      if(iy.lt.1)iy=iy+IMM1
      ran2=min(AM*iy,RNMX)
      return
      END

      FUNCTION ran3(idum)
      INTEGER idum
      INTEGER MBIG,MSEED,MZ
C     REAL MBIG,MSEED,MZ
      REAL ran3,FAC
      PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1./MBIG)
C     PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=1./MBIG)
      INTEGER i,iff,ii,inext,inextp,k
      INTEGER mj,mk,ma(55)
C     REAL mj,mk,ma(55)
      SAVE iff,inext,inextp,ma
      DATA iff /0/
      if(idum.lt.0.or.iff.eq.0)then
        iff=1
        mj=MSEED-iabs(idum)
        mj=mod(mj,MBIG)
        ma(55)=mj
        mk=1
        do 11 i=1,54
          ii=mod(21*i,55)
          ma(ii)=mk
          mk=mj-mk
          if(mk.lt.MZ)mk=mk+MBIG
          mj=ma(ii)
11      continue
        do 13 k=1,4
          do 12 i=1,55
            ma(i)=ma(i)-ma(1+mod(i+30,55))
            if(ma(i).lt.MZ)ma(i)=ma(i)+MBIG
12        continue
13      continue
        inext=0
        inextp=31
        idum=1
      endif
      inext=inext+1
      if(inext.eq.56)inext=1
      inextp=inextp+1
      if(inextp.eq.56)inextp=1
      mj=ma(inext)-ma(inextp)
      if(mj.lt.MZ)mj=mj+MBIG
      ma(inext)=mj
      ran3=mj*FAC
      return
      END

C----------------------------------------------------------------------C

      SUBROUTINE nrand(y1,y2,idum)
      IMPLICIT none
      REAL x1,x2,y1,y2,w,ran2
      INTEGER idum
  101 x1 = 2.0e0*ran2(idum) - 1.0e0
      x2 = 2.0e0*ran2(idum) - 1.0e0
      w  = x1*x1 + x2*x2
      if (w.ge.1.0e0) goto 101
      w  = sqrt(-2.0e0*log(w)/w)
      y1 = x1*w
      y2 = x2*w
      RETURN
      END


      subroutine check_soilthaw(stemperature,phchange,
     $    soilnode,zsoilthaw,nlayer)
c     *********************************************************
c     ****************** added by yyh *************************
c     *********************************************************
c     subroutine calculates the soil thaw depth for each day
c     this code may not apply to the permafrost areas...
c     note: the definition of permafrost is: having soil remaining below 0degC for two or more years...
c     so in this case, I was not able to tell whether this is seasonal thaw above permafrost or not.
c     inputs:   stemperautre  -  soil temperature at each node depth
c               soilnode      -  soil node depth
c     outputs:  zsoilthaw      -  soil thaw depth

c     note that I only check the first 15 layers

      implicit none
      INCLUDE  'pwbm.soil_temperature.h'

      integer phchange(sx:lx+1)
      real*8  stemperature(sx:lx+1)
      real*8  soilnode(sx:lx)
      real*8  zsoilthaw,tsoil,tsoil1,tsoil2
      integer i,isoilnode,nlayer,isoilALD

c whether there is phase change
      if(maxval(phchange) .eq. 1) then
        i=2
        do while(i .le.nlayer+1)
           if(phchange(i) .eq. 1) then
             i=i+1
           else
             isoilALD = i-1
             i=i+lx
           endif
        enddo
      else
        isoilALD = -1
        zsoilthaw = -999.0d0
        return
      endif

      if(isoilALD .gt. nlayer) then
        zsoilthaw = -999.0d0
        return
      endif

c first look for the soil node in the upper layer
      tsoil1 = stemperature(isoilALD) ! the upper layer
      tsoil = stemperature(isoilALD+1)
      tsoil2 = stemperature(isoilALD+2) ! the lower layer
      if(tsoil1*tsoil .le. 0.0d0) then
        zsoilthaw = soilnode(isoilALD-1)+(soilnode(isoilALD)-
     $    soilnode(isoilALD-1))*abs(tsoil1)/(abs(tsoil)+abs(tsoil1))

      else if(tsoil*tsoil2 .le. 0.0d0) then ! then look for the soil node in the lower layer
        zsoilthaw = soilnode(isoilALD)+(soilnode(isoilALD+1)
     $    -soilnode(isoilALD))*abs(tsoil)/(abs(tsoil2)+abs(tsoil))
      else
        zsoilthaw = -999.0d0
      endif

      return
      end


!dis
!dis    Open Source License/Disclaimer, Forecast Systems Laboratory
!dis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
!dis
!dis    This software is distributed under the Open Source Definition,
!dis    which may be found at http://www.opensource.org/osd.html.
!dis
!dis    In particular, redistribution and use in source and binary forms,
!dis    with or without modification, are permitted provided that the
!dis    following conditions are met:
!dis
!dis    - Redistributions of source code must retain this notice, this
!dis    list of conditions and the following disclaimer.
!dis
!dis    - Redistributions in binary form must provide access to this
!dis    notice, this list of conditions and the following disclaimer, and
!dis    the underlying source code.
!dis
!dis    - All modifications to this software must be clearly documented,
!dis    and are solely the responsibility of the agent making the
!dis    modifications.
!dis
!dis    - If significant modifications or enhancements are made to this
!dis    software, the FSL Software Policy Manager
!dis    (softwaremgr@fsl.noaa.gov) should be notified.
!dis
!dis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
!dis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
!dis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
!dis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
!dis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
!dis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
!dis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
!dis
!dis

MODULE vinterp_utils

  ! Module that contains arrays and routines for linear and logarithmic
  ! interpolation

  IMPLICIT NONE

CONTAINS
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   SUBROUTINE compute_lin_weights(p_mid_mb,p_lower_mb,p_upper_mb, &
                                  weight_bot, weight_top)

    ! Computes the weighting coefficient for the top bounding level
    ! of two pressure levels to interpolate to a level in-between using
    ! linear interpolation.

    IMPLICIT NONE
    REAL, INTENT(IN)             :: p_mid_mb  ! Desired pressure level
    REAL, INTENT(IN)             :: p_lower_mb ! Lower bounding pressure
    REAL, INTENT(IN)             :: p_upper_mb ! Upper bounding pressure
    REAL, INTENT(OUT)            :: weight_bot ! Weight given to bottom level
    REAL, INTENT(OUT)            :: weight_top ! Weight given to top level

    weight_bot = (p_mid_mb - p_upper_mb) / (p_lower_mb - p_upper_mb)
    weight_top = 1.0 - weight_bot

  END SUBROUTINE compute_lin_weights
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE compute_log_weights(p_mid_mb,p_lower_mb,p_upper_mb, &
                                 weight_bot, weight_top)

    ! Computes weighting coefficient for upper pressure level that bounds
    ! a desired pressure level for logarithmic interpolation.

    ! NOTE: Pressures must be in mb!!!

    IMPLICIT NONE
    REAL, INTENT(IN)             :: p_mid_mb  ! Desired pressure level
    REAL, INTENT(IN)             :: p_lower_mb ! Lower bounding pressure
    REAL, INTENT(IN)             :: p_upper_mb ! Upper bounding pressure
    REAL, INTENT(OUT)            :: weight_bot ! Weight given to bottom level
    REAL, INTENT(OUT)            :: weight_top ! Weight given to top level

    weight_bot = ( ALOG(p_mid_mb) - ALOG(p_upper_mb) ) / &
                 ( ALOG(p_lower_mb) - ALOG(p_upper_mb) )
    weight_top = 1.0 - weight_bot

  END SUBROUTINE compute_log_weights
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  SUBROUTINE vinterp_3d(var_in, trap_bot_ind, trap_top_ind, &
                        weight_top, below_ground_value, var_out, &
                        nx, ny, nzin, nzout)

    ! Interpolates var_in to var_out using array of trapping indices
    ! and top weight values.  Allows the user to set a default
    ! 2d array to use for "below ground" values

    IMPLICIT NONE
    INTEGER, INTENT(IN)            :: nx
    INTEGER, INTENT(IN)            :: ny
    INTEGER, INTENT(IN)            :: nzin
    INTEGER, INTENT(IN)            :: nzout
    REAL, INTENT(IN)               :: var_in (nx,ny,nzin)
    INTEGER, INTENT(IN)            :: trap_bot_ind(nx,ny,nzout)
    INTEGER, INTENT(IN)            :: trap_top_ind(nx,ny,nzout)
    REAL, INTENT(IN)               :: weight_top(nx,ny,nzout)
    REAL, INTENT(IN)               :: below_ground_value(nx,ny)
    REAL, INTENT(OUT)              :: var_out(nx,ny,nzout)
    INTEGER                        :: i,j,k

    DO j = 1,ny
      DO i = 1,nx
        DO k= 1,nzout

          ! Is level below ground?  If so, zero it out
          IF (trap_bot_ind(i,j,k).LT. 1) THEN
            var_out(i,j,k) = below_ground_value(i,j)

          ! Is it above model top? If so, replicate top value
          ELSE IF (trap_bot_ind(i,j,k).EQ.nzin) THEN
            var_out(i,j,k) = var_in(i,j,nzin)

          ELSE
            var_out(i,j,k) = weight_top(i,j,k) * &
                             var_in(i,j,trap_top_ind(i,j,k)) + &
                             (1.-weight_top(i,j,k)) * &
                             var_in(i,j,trap_bot_ind(i,j,k))
          ENDIF
        ENDDO
      ENDDO
    ENDDO

    RETURN
  END SUBROUTINE vinterp_3d
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
END MODULE vinterp_utils


program grid6_to_g25

  parameter (MAXGRID4=32400)
  character*6 w,grid6
  character c1*1,c2*2
  logical is_grid6

  is_grid6(grid6)=len(trim(grid6)).eq.6 .and.                        &
       grid6(1:1).ge.'A' .and. grid6(1:1).le.'R' .and.               &
       grid6(2:2).ge.'A' .and. grid6(2:2).le.'R' .and.               &
       grid6(3:3).ge.'0' .and. grid6(3:3).le.'9' .and.               &
       grid6(4:4).ge.'0' .and. grid6(4:4).le.'9' .and.               &
       grid6(5:5).ge.'A' .and. grid6(5:5).le.'X' .and.               &
       grid6(6:6).ge.'A' .and. grid6(6:6).le.'X'

  nargs=iargc()
  if(nargs.ne.1) then
     print*,'Convert a 6-character grid to a g25 value.'
     print*,'Usage: grid6_to_g25 IO91NP'
     go to 999
  endif
  call getarg(1,w)
  if(.not. is_grid6(w)) go to 900

  j1=(ichar(w(1:1))-ichar('A'))*18*10*10*24*24
  j2=(ichar(w(2:2))-ichar('A'))*10*10*24*24
  j3=(ichar(w(3:3))-ichar('0'))*10*24*24
  j4=(ichar(w(4:4))-ichar('0'))*24*24
  j5=(ichar(w(5:5))-ichar('A'))*24
  j6=(ichar(w(6:6))-ichar('A'))
  igrid6=j1+j2+j3+j4+j5+j6

  write(*,1000) w,igrid6,igrid6
1000 format('Encoded word: ',a6,'    g25 in binary: ',b25.25/     &
          30x,'decimal:',i9)
  go to 999

900 write(*,1900)
1900 format('Invalid input')

999 end program grid6_to_g25


program hip_dgemm

  use iso_c_binding
  use hipfort
  use hipfort_check
  use hipfort_hipblas

  implicit none

  integer(kind(HIPBLAS_OP_N)), parameter :: transa = HIPBLAS_OP_N, transb = HIPBLAS_OP_N;
  double precision, parameter ::  alpha = 1.1d0, beta = 0.9d0;

  integer, parameter ::  m = 1024, n = 1024, k = 1024;

  double precision, allocatable, dimension(:,:) :: ha, hb, hc, hc_exact

  double precision, pointer, dimension(:,:) :: da, db, dc
  type(c_ptr) :: handle = c_null_ptr

  integer :: i,j
  double precision :: error
  double precision, parameter :: error_max = 10*epsilon(error)

  write(*,"(a)",advance="no") "-- Running test 'DGEMM' (Fortran 2008 interfaces) - "

  call hipblasCheck(hipblasCreate(handle))

  allocate(ha(m,k))
  allocate(hb(k,n))
  allocate(hc(m,n))
  allocate(hc_exact(m,n))

  ! Use these constant matrices so the exact answer is also a
  ! constant matrix and therefore easy to check
  ha(:,:) = 1.d0
  hb(:,:) = 2.d0
  hc(:,:) = 3.d0
  hc_exact = alpha*k*2.d0 + beta*3.d0

  ! Allocate device memory
  call hipCheck(hipMalloc(da,source=ha)) ! implies (blocking) memcpy
  call hipCheck(hipMalloc(db,source=hb))
  call hipCheck(hipMalloc(dc,source=hc))

  call hipblasCheck(hipblasDgemm(handle,transa,transb,m,n,k,alpha,da,size(da,1),db,size(db,1),beta,dc,size(dc,1)))

  call hipCheck(hipDeviceSynchronize())

  ! Transfer data back to host memory
  call hipCheck(hipMemcpy(hc, dc, hipMemcpyDeviceToHost))

  do j = 1,n
    do i = 1,m
       error = abs((hc_exact(i,j) - hc(i,j))/hc_exact(i,j))
       if( error > error_max )then
          write(*,*) "FAILED! Error bigger than max! Error = ", error
          call exit(1)
       end if
    end do
  end do

  call hipCheck(hipFree(da))
  call hipCheck(hipFree(db))
  call hipCheck(hipFree(dc))

  call hipblasCheck(hipblasDestroy(handle))

  deallocate(ha,hb,hc,hc_exact)

  write(*,*) "PASSED!"

end program hip_dgemm


        subroutine i3LDU (Diag, r, code)
c
c----------------------------------------------------------------------
c
c This routine preforms a Cholesky factorization/solve of a set of
c symmetric matrices for 3-D computations, used for block diagonal
c preconditioning in the iterative driver.
c
c input:
c  Diag (numnp,nsymdf)  : block diagonal (symmetric storage)
c  r    (numnp,nflow)    : residual
c  code                 : operation code
c                           .eq. 'LDU_Fact', Cholesky Factor
c                           .eq. 'forward ', forward reduction
c                           .eq. 'backward', backward substitution
c                           .eq. 'product ', product Diag.r
c
c output:
c  Diag (numnp,nsymdf)  : Cholesky decomp. of block diagonal
c  r    (numnp,nflow)    : reduced residual
c
c
c Note: the formulation used here to reduce the diagonal block to
c       symmetric Cholesky triangle is taken from Golub's "Matrix
c       Computations" Book, pages 89 algorithm 5.2-1.  Followed by
c       standard solve.
c
c
c              Diag(1)   Diag(2)     Diag(4)     Diag(7)      Diag(11)
c   T             0      Diag(3)     Diag(5)     Diag(8)      Diag(12)
c  L  =  U  =     0         0        Diag(6)     Diag(9)      Diag(13)
c                 0         0           0        Diag(10)     Diag(14)
c                 0         0           0           0         Diag(15)
c
c  The diagonal terms 1, 3, 6, 10 and 15 are stored in inverted form.
c
c Farzin Shakib, Spring 1987.
c Zdenek Johan,  Fall   1989.  (Modified for option 'product')
c Zdenek Johan,  Winter 1991.  (Fortran 90)
c----------------------------------------------------------------------
c
        include "common.h"
c
        dimension Diag(nshg,nsymdf),        r(nshg,nflow)
c
        character*8 code
c
c.... perform Cholesky decomposition with the Diagonal terms inverted
c
        if (code .eq. 'LDU_Fact') then
c
          Diag(:, 1) = one   / sqrt (Diag(:, 1))
c
          Diag(:, 2) = Diag(:, 1) *  Diag(:, 2)
          Diag(:, 3) = Diag(:, 3) -  Diag(:, 2) * Diag(:, 2)
          Diag(:, 3) = one   / sqrt (Diag(:, 3))
c
          Diag(:, 4) = Diag(:, 1) *  Diag(:, 4)
          Diag(:, 5) = Diag(:, 3) * (Diag(:, 5)
     &                            -  Diag(:, 4) * Diag(:, 2))
          Diag(:, 6) = Diag(:, 6) -  Diag(:, 4) * Diag(:, 4)
     &                            -  Diag(:, 5) * Diag(:, 5)
          Diag(:, 6) = one   / sqrt (Diag(:, 6))
c
          Diag(:, 7) = Diag(:, 1) *  Diag(:, 7)
          Diag(:, 8) = Diag(:, 3) * (Diag(:, 8)
     &                            -  Diag(:, 7) * Diag(:, 2))
          Diag(:, 9) = Diag(:, 6) * (Diag(:, 9)
     &                            -  Diag(:, 7) * Diag(:, 4)
     &                            -  Diag(:, 8) * Diag(:, 5))
c
          Diag(:,10) = Diag(:,10) -  Diag(:, 7) * Diag(:, 7)
     &                            -  Diag(:, 8) * Diag(:, 8)
     &                            -  Diag(:, 9) * Diag(:, 9)
          Diag(:,10) = one   / sqrt (Diag(:,10))
c
          Diag(:,11) = Diag(:, 1) *  Diag(:,11)
          Diag(:,12) = Diag(:, 3) * (Diag(:,12)
     &                            -  Diag(:,11) * Diag(:, 2))
          Diag(:,13) = Diag(:, 6) * (Diag(:,13)
     &                            -  Diag(:,11) * Diag(:, 4)
     &                            -  Diag(:,12) * Diag(:, 5))
          Diag(:,14) = Diag(:,10) * (Diag(:,14)
     &                            -  Diag(:,11) * Diag(:, 7)
     &                            -  Diag(:,12) * Diag(:, 8)
     &                            -  Diag(:,13) * Diag(:, 9))
c
          Diag(:,15) = Diag(:,15) -  Diag(:,11) * Diag(:,11)
     &                            -  Diag(:,12) * Diag(:,12)
     &                            -  Diag(:,13) * Diag(:,13)
     &                            -  Diag(:,14) * Diag(:,14)
          Diag(:,15) = one   / sqrt (Diag(:,15))
c
c.... flop count
c
!      flops = flops + 110*nshg
c
          return
        endif
c
c.... perform forward reduction
c
        if (code .eq. 'forward ') then
c
          r(:,1) = Diag(:, 1) *   r(:,1)
          r(:,2) = Diag(:, 3) * ( r(:,2)
     &                        -   r(:,1) * Diag(:, 2) )
          r(:,3) = Diag(:, 6) * ( r(:,3)
     &                        -   r(:,1) * Diag(:, 4)
     &                        -   r(:,2) * Diag(:, 5) )
          r(:,4) = Diag(:,10) * ( r(:,4)
     &                        -   r(:,1) * Diag(:, 7)
     &                        -   r(:,2) * Diag(:, 8)
     &                        -   r(:,3) * Diag(:, 9) )
          r(:,5) = Diag(:,15) * ( r(:,5)
     &                        -   r(:,1) * Diag(:,11)
     &                        -   r(:,2) * Diag(:,12)
     &                        -   r(:,3) * Diag(:,13)
     &                        -   r(:,4) * Diag(:,14) )
c
c.... flop count
c
!      flops = flops + 25*nshg
c
          return
        endif
c
c.... perform backward substitution
c
        if (code .eq. 'backward') then
c
          r(:,5) = Diag(:,15) *   r(:,5)
          r(:,4) = Diag(:,10) * ( r(:,4)
     &                        -   r(:,5) * Diag(:,14) )
          r(:,3) = Diag(:, 6) * ( r(:,3)
     &                        -   r(:,5) * Diag(:,13)
     &                        -   r(:,4) * Diag(:, 9) )
          r(:,2) = Diag(:, 3) * ( r(:,2)
     &                        -   r(:,5) * Diag(:,12)
     &                        -   r(:,4) * Diag(:, 8)
     &                        -   r(:,3) * Diag(:, 5) )
          r(:,1) = Diag(:, 1) * ( r(:,1)
     &                        -   r(:,5) * Diag(:,11)
     &                        -   r(:,4) * Diag(:, 7)
     &                        -   r(:,3) * Diag(:, 4)
     &                        -   r(:,2) * Diag(:, 2) )
c
c.... flop count
c
!      flops = flops + 25*nshg
c
          return
        endif
c
c.... perform product U.r
c
        if (code .eq. 'product ') then
c
          r(:,1) = r(:,1) / Diag(:, 1) + r(:,2) * Diag(:, 2) +
     &             r(:,3) * Diag(:, 4) + r(:,4) * Diag(:, 7) +
     &             r(:,5) * Diag(:,11)
          r(:,2) = r(:,2) / Diag(:, 3) + r(:,3) * Diag(:, 5) +
     &             r(:,4) * Diag(:, 8) + r(:,5) * Diag(:,12)
          r(:,3) = r(:,3) / Diag(:, 6) + r(:,4) * Diag(:, 9) +
     &             r(:,5) * Diag(:,13)
          r(:,4) = r(:,4) / Diag(:,10) + r(:,5) * Diag(:,14)
          r(:,5) = r(:,5) / Diag(:,15)
c
c.... flop count
c
!      flops = flops + 40*nshg
c
          return
        endif
c
        call error ('i3LDU   ', code, 0)
c
c.... return
c
        return
        end


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_QPT_EXAMPLE
   USE GALAHAD_QPT_double                       ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = wp ), PARAMETER :: infinity = 10.0_wp ** 20 ! solver-dependent
   TYPE ( QPT_problem_type ) :: p
   INTEGER :: s
   INTEGER, PARAMETER :: n = 3, m = 2, h_ne = 4, a_ne = 4
! start problem data
   ALLOCATE( p%name( 6 ) )
   ALLOCATE( p%G( n ), p%X_l( n ), p%X_u( n ) )
   ALLOCATE( p%C( m ), p%C_l( m ), p%C_u( m ) )
   ALLOCATE( p%X( n ), p%Y( m ), p%Z( n ) )
   p%name = TRANSFER( 'QPprob', p%name )      ! name
   p%new_problem_structure = .TRUE.           ! new structure
   p%Hessian_kind = - 1 ; p%gradient_kind = - 1 ! generic quadratic program
   p%n = n ; p%m = m ; p%f = 1.0_wp           ! dimensions & objective constant
   p%G = (/ 0.0_wp, 2.0_wp, 0.0_wp /)         ! objective gradient
   p%C_l = (/ 1.0_wp, 2.0_wp /)               ! constraint lower bound
   p%C_u = (/ 2.0_wp, 2.0_wp /)               ! constraint upper bound
   p%X_l = (/ - 1.0_wp, - infinity, - infinity /) ! variable lower bound
   p%X_u = (/ 1.0_wp, infinity, 2.0_wp /)     ! variable upper bound
   p%X = 0.0_wp ; p%Y = 0.0_wp ; p%Z = 0.0_wp ! start from zero
!  sparse co-ordinate storage format
   CALL SMT_put( p%H%type, 'COORDINATE', s )  ! Specify co-ordinate
   CALL SMT_put( p%A%type, 'COORDINATE', s )  ! storage for H and A
   ALLOCATE( p%H%val( h_ne ), p%H%row( h_ne ), p%H%col( h_ne ) )
   ALLOCATE( p%A%val( a_ne ), p%A%row( a_ne ), p%A%col( a_ne ) )
   p%H%val = (/ 1.0_wp, 2.0_wp, 3.0_wp, 4.0_wp /) ! Hessian H
   p%H%row = (/ 1, 2, 3, 3 /)                     ! NB lower triangle
   p%H%col = (/ 1, 2, 3, 1 /) ; p%H%ne = h_ne
   p%A%val = (/ 2.0_wp, 1.0_wp, 1.0_wp, 1.0_wp /) ! Jacobian A
   p%A%row = (/ 1, 1, 2, 2 /)
   p%A%col = (/ 1, 2, 2, 3 /) ; p%A%ne = a_ne
! problem data complete
! now call minimizer ....
! ...
! ... minimization call completed. Deallocate arrays
   DEALLOCATE( p%name, p%G, p%X_l, p%X_u, p%C, p%C_l, p%C_u, p%X, p%Y, p%Z )
   DEALLOCATE( p%H%val, p%H%row, p%H%col, p%A%val, p%A%row, p%A%col )
   WRITE( 6, "( ' run terminated successfully ' )" )
   END PROGRAM GALAHAD_QPT_EXAMPLE


C     LAST UPDATE 10/12/96
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE ROTATE(VALS,NV)
      IMPLICIT NONE
C
C Purpose: Determine rotation from pairs of points
C
C Calls   2: RDCOMF, FTOSTD
C Called by: FIX
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C FIX include file:
C
      INCLUDE 'FIXPAR.COM'
C
C Arguments:
C
      INTEGER NV
      REAL VALS(10)
C
C Local variables:
C
      INTEGER I,K
      REAL XDIF(MAXPTS/2),YDIF(MAXPTS/2)
      REAL TOP,DEN,RTOD,RESSQ,RESID,PIBY2
      LOGICAL PAIRS
C
      DATA RTOD /57.29578/ , PIBY2 /1.57079633/
C
C-----------------------------------------------------------------------
      PAIRS = .FALSE.
      IF(NV.EQ.0)THEN
         PAIRS = .TRUE.
      ELSEIF(NV.EQ.1)THEN
         IF(GOTCEN)THEN
            IF(NINT(VALS(1)).GE.1.AND.NINT(VALS(1)).LE.NPTS)THEN
               ROTX = ATAN2(XC-FXY(1,NINT(VALS(1))),
     &                      YC-FXY(2,NINT(VALS(1))))
               GOTROT = .TRUE.
            ENDIF
         ELSE
            WRITE(6,1030)
            CALL FLUSH(6)
         ENDIF
      ENDIF
C
C========Compile least-squares solution from each pair of data
C
      TOP = 0.0
      DEN = 0.0
      K = 0
      IF(PAIRS)THEN
         DO 30 I=1,NPTS-1,2
            K = K + 1
            XDIF(K) = FXY(1,I) - FXY(1,I+1)
            YDIF(K) = FXY(2,I) - FXY(2,I+1)
            IF(ABS(XDIF(K)).GT.0.01)THEN
               ROTX = ATAN(YDIF(K)/XDIF(K))
            ELSE
               ROTX = PIBY2
            ENDIF
            WRITE(6,1040)I,I+1,RTOD*ROTX
            TOP = TOP + YDIF(K)*XDIF(K)
            DEN = DEN + XDIF(K)*XDIF(K)
 30      CONTINUE
      ELSE
         DO 40 I=1,NV-1,2
            K = K + 1
            XDIF(K) = FXY(1,NINT(VALS(I))) - FXY(1,NINT(VALS(I+1)))
            YDIF(K) = FXY(2,NINT(VALS(I))) - FXY(2,NINT(VALS(I+1)))
            IF(ABS(XDIF(K)).GT.0.01)THEN
               ROTX = ATAN(YDIF(K)/XDIF(K))
            ELSE
               ROTX = PIBY2
            ENDIF
            WRITE(6,1040)NINT(VALS(I)),NINT(VALS(I+1)),RTOD*ROTX
            TOP = TOP + YDIF(K)*XDIF(K)
            DEN = DEN + XDIF(K)*XDIF(K)
 40      CONTINUE
      ENDIF
C
C========Calculate least-squares rotation and residual
C
      IF(K.GT.1)THEN
         IF(DEN.EQ.0.0)THEN
            ROTX = PIBY2
         ELSE
            ROTX = ATAN2(TOP,DEN)
         ENDIF
         RESSQ = 0.0
         IF(DEN.GT.0.0)THEN
            DO 50 I=1,K
               RESSQ = RESSQ + (XDIF(I)*TOP/DEN-YDIF(I))**2
 50         CONTINUE
         ENDIF
         RESID = RTOD*SQRT(RESSQ/(DEN*FLOAT(K-1)))*COS(ROTX)**2
         WRITE(6,1050)RTOD*ROTX,RESID
         CALL FLUSH(6)
      ENDIF
      ROTY = 0.0
      ROTZ = 0.0
      GOTROT = .TRUE.
      PRINT *, '500 ROTATION ',ROTX*RTOD,ROTY*RTOD,ROTZ*RTOD
      CALL FLUSH(6)
      IF(GOTCEN)CALL FTOSTD
      RETURN
C
 1020 FORMAT(1X,'Enter pairs of points for rotation determination: ',$)
 1030 FORMAT(1X,'200',1X,'Not enough points')
 1040 FORMAT(/1X,'200',
     &       1X,'Points ',I3,' and ',I3,'   rotation angle =',F6.1)
 1050 FORMAT(1X,'Least-squares rotation angle =',F6.1/
     &       1X,'Residual =',F6.2)
 2000 FORMAT(1X,'400 Numeric input only')
      END


!//=========================================================================
!// Oslo CTM3
!//=========================================================================
!// Based on UCI CTM core p-7.1 (1/2013).
!//
!// Ole Amund Sovde, April 2015
!//=========================================================================
!// Routines for regridding datasets,
!//=========================================================================
module regridding
  !//-----------------------------------------------------------------------
  !// MODULE: regridding
  !// DESCRIPTION: Routines for regridding datasets.
  !//
  !// Contains
  !//   subroutine E_GRID
  !//   subroutine E_GRID_Y
  !//   subroutine TRUNG8
  !//   subroutine TRUNG4
  !//   subroutine Regrid_Column_Weights
  !//
  !//-----------------------------------------------------------------------
  implicit none
  !//-----------------------------------------------------------------------
  character(len=*), parameter, private :: f90file = 'regridding.f90'
  !//-----------------------------------------------------------------------
  public
  !//-----------------------------------------------------------------------

contains

  !//-----------------------------------------------------------------------
  subroutine E_GRID(EBOX,XBEDG,YBEDG,IG,JG, EDXY,XDEDG,YDEDG,IM,JM,NEDXY)
    !//---------------------------------------------------------------------
    !// generic regridder of
    !//        emissions EBOX(1:IG,1:JG)
    !//        on regular grid XBEDG(1:IG+1),YBEDG(1:JG+1)
    !//
    !// onto CTM grid   EDXY(1:IM,1:JM)
    !//        EBOX = emissions or absolute quantity (kg or kg/yr, not kg/m2)
    !// IF original data is %-coverage or kg/m2, THEN must be pre-mult by area
    !//
    !//    X's Y's are the grid edges in degrees
    !//    note that the Longitude (X) edges can jump by 360 deg
    !//    XEDG(1,IM+1) is created = CTM longitude-grid edges
    !//                              (radians, monotonic)
    !//
    !//    EDXY(1:IM, 1:JM, 1:6) = emissions partitioned into box (I,J)
    !//                            + moments
    !//           EDXY(:,:,1) = total emissions
    !//           EDXY(:,:,2) = Sx  moment of emissions
    !//           EDXY(:,:,3) = Sxx moment of emissions
    !//           EDXY(:,:,4) = Sy  moment of emissions
    !//           EDXY(:,:,5) = Syy moment of emissions
    !//           EDXY(:,:,6) = Sxy moment of emissions
    !//---------------------------------------------------------------------
    use cmn_precision, only: r8
    use cmn_parameters, only: CPI, C2PI, CPI180
    !//---------------------------------------------------------------------
    implicit none
    !//---------------------------------------------------------------------
    !// Input
    integer, intent(in) :: IG,JG, IM,JM, NEDXY
    real(r8), intent(in) :: EBOX(IG,JG),XBEDG(IG+1),YBEDG(JG+1)
    real(r8), intent(in) :: XDEDG(IM+1),YDEDG(JM+1)
    !// Output
    real(r8), intent(out) :: EDXY(IM,JM,NEDXY)
    !// Locals
    real(r8) :: Y1,Y2,SY1,SY2,DYBOX,YG,  YB1,YB2,SYB1,SYB2
    real(r8) :: B_GYA(JG,JM), B_GYY(JG,JM)
    real(r8) :: B_GXA(IG,IM), B_GXX(IG,IM)
    real(r8) :: KX0,KXX,KY0,KYY,KXY, EMKIKJ
    real(r8) :: SYG(JM+1), XEDG(IM+1)
    real(r8) :: X1,X2,DXBOX,XG,  XB1,XB2
    integer :: J,J1,J2,I,I1,I2, KI,KJ, I2M
    !//---------------------------------------------------------------------

    XEDG(1) = CPI180 * XDEDG(1)
    do I = 2, IM+1
       if (XDEDG(I) .gt. 0._r8) then
          XEDG(I) = CPI180 * XDEDG(I)
       else
          XEDG(I) = CPI180 * (XDEDG(I) + 360._r8)
       end if
    end do

    !// Initialize
    B_GXA(:,:) = 0._r8
    B_GXX(:,:) = 0._r8
    B_GYA(:,:) = 0._r8
    B_GYY(:,:) = 0._r8

    !// for relative area use sin(LATITUDE) x LONGITUDE (degrees)
    do J = 1, JM+1
       SYG(J) = sin(YDEDG(J) * CPI180)
    end do

    !// setup the LATITUDE mapping and weights for the emission boxes
    do KJ = 1, JG
       YB1 = YBEDG(KJ)
       YB2 = YBEDG(KJ+1)
       SYB1 = sin(CPI180 * YB1)
       SYB2 = sin(CPI180 * YB2)
       J1 = JM !// Initialize with J1=JM
       do J = 2, JM
          if (YDEDG(J) .gt. YB1) then
             J1 = J - 1
             exit !// exit J-loop (goto 12)
          end if
       end do
       !//J1 = JM
       !//12   continue

       J2 = JM !// Initialize with J2=JM
       do J = J1+1, JM+1
          if (YDEDG(J) .ge. YB2) then
             J2 = J - 1
             exit !// exit J-loop (goto 14)
          end if
       end do
       !//J2 = JM
       !//14   continue

       !// The emission box KJ=1:JG is contained in CTM grid boxes J1 to J2
       !// save the indices and fractions and weightings
       do J = J1, J2
          Y1 = max(YB1, YDEDG(J))
          Y2 = min(YB2, YDEDG(J+1))
          SY1 = sin(CPI180 * Y1)
          SY2 = sin(CPI180 * Y2)
          DYBOX = (SY2 - SY1) / (SYB2 - SYB1) ! fractional area of emission box
          !// mean value of Y in grid box
          YG = (0.5_r8 * (SY1 + SY2) - SYG(J)) / (SYG(J+1) - SYG(J))

          B_GYA(KJ,J) = DYBOX
          B_GYY(KJ,J) = YG

       end do
    end do

    !// Now setup the LONGITUDE mapping and weights for the emission boxes.
    !// Require XEDG(I=1:IM) to be monotonic,
    !// but XBEDG(KI=1:IG) may have shift at dateline
    do KI = 1, IG
       XB1 = XBEDG(KI) * CPI180
       XB2 = XBEDG(KI+1) * CPI180
       if (XB1 .gt. XB2) XB2 = XB2 + C2PI
       if (XB1 .gt. XB2) then
          !// ERROR
          write(6,'(a)') 'regrid.f90:E_GRID: err#1 emis. X-grid'
          stop
       end if
       if (XB1 .lt. XEDG(1)) then
          XB1 = XB1 + C2PI
          XB2 = XB2 + C2PI
          if (XB1 .lt. XEDG(1)) then
             write(6,'(I4,6F9.3)') KI,XBEDG(KI)*CPI180,XBEDG(KI+1)*CPI180, &
                  XB1,XB2,XEDG(1)
             !// ERROR
             write(6,'(a)') 'regrid.f90:E_GRID: err#2 emis. X-grid'
             stop
          end if
       end if
       if (XB1 .gt. XEDG(IM+1)) then
          XB1 = XB1 - C2PI
          XB2 = XB2 - C2PI
          if (XB1 .gt. XEDG(IM+1)) then
             !// ERROR
             write(6,'(a)') 'regrid.f90:E_GRID: err#3 emis. X-grid'
             stop
          end if
       end if

       I1 = IM !// Initialise with I1=IM
       do I = 2, IM
          if (XEDG(I) .gt. XB1) then
             I1 = I - 1
             exit !// exit loop (goto 16)
          end if
       end do
       !//I1 = IM
       !//16   continue

       I2 = 0 !// Initialize with no value
       do I = I1+1, IM+1
          if (XEDG(I) .ge. XB2) then
             I2 = I - 1
             exit !// Exit this loop (goto 18)
          end if
       end do
       !// If I2 not found, allow for XB2 to extend (wrap) beyond XEDG(IM+1)
       if (I2 .eq. 0) then
          do I = 2, IM
             if ((XEDG(I) + C2PI) .ge. XB2) then
                I2 = IM + I-1
                exit !// Exit this loop (also goto 18)
             end if
          end do
       end if
       !// If I2 still not found, it is 2*IM
       if (I2 .eq. 0) I2 = IM + IM
       !//I2 = IM + IM
       !//18   continue

       !// The emission box K=1:IG is contained in CTM grid boxes I1 to I2
       !// but the I2 may be > IM to wrap around the Longitude circle.
       !// save the indices and fractions and weightings
       I2M = min(I2, IM)
       do I = I1, I2M
          X1 = max(XB1, XEDG(I))
          X2 = min(XB2, XEDG(I+1))
          DXBOX = (X2 - X1) / (XB2 - XB1) ! fractional area of emission box
          XG = (0.5_r8 * (X1 + X2) - XEDG(I)) &
                       / (XEDG(I+1) - XEDG(I)) ! mean X value

          B_GXA(KI,I) = DXBOX
          B_GXX(KI,I) = XG
       end do

       !// while XB1 is constrained ot lie within 1:IM, XB2 may wrap around:
       IF (I2 .gt. IM) then
          I2M = I2 - IM
          do I = 1, I2M
             X1 = max(XB1, XEDG(I) + C2PI)
             X2 = min(XB2, XEDG(I+1) + C2PI)
             DXBOX = (X2 - X1) / (XB2 - XB1)
             XG = (0.5_r8 * (X1 + X2) - XEDG(I) - C2PI) &
                          / (XEDG(I+1) - XEDG(I))

             B_GXA(KI,I) = DXBOX
             B_GXX(KI,I) = XG
          end do
       end if
    end do !// do KI = 1, IG

    !// sum contributions (& moments) to CTM grid (I,J) from emission
    !// boxes (KI,KJ)
    !// SOM XY moments:
    !//     k00 = 1.d0
    !//     kX0 = XG - 0.5d0
    !//     kXX = XG*(XG - 1.d0) + C16TH
    !//     kY0 = YG - 0.5d0
    !//     kYY = YG*(YG - 1.d0) + C16TH
    !//     kXY = (XG - 0.5d0)*(YG - 0.5d0)
    !// for Kronecker-delat approx:  f(x,y) = DXBOX*DYBOX*EMI-BOX * k__(XG,YG)
    !//     So = INTEG[ f(x,y) ] x=0:1, y=0:1
    !//     Sx = 6 * INTEG[ f(x,y) * kX(x) ]
    !//     Sxy = 36 * INTEG[ f(x,y) * kXY(x,y) ]
    !//     Sxx = 30 * INTEG[ f(x,y) * kXX(x) ]
    !// adjust K_s to get So,Sx,Sxx,Sy,Syy,Sxy  (1:6)
    !//     K00 = 1.d0
    !//     KX0 = 6.d0*XG - 3.0d0
    !//     KXX = 30.d0*XG*(XG - 1.d0) + 5.d0
    !//     KY0 = 6.d0*YG - 3.0d0
    !//     KYY = 30.d0*YG*(YG - 1.d0) + 5.d0
    !//     KXY = KX0 * KY0

    if (NEDXY .eq.  6) then
      do J = 1, JM
        do I = 1, IM
          EDXY(I,J,:) = 0._r8
          do KJ = 1, JG
            if (B_GYA(KJ,J) .gt. 1.e-5_r8) then
              do KI = 1, IG
                if (B_GXA(KI,I) .gt. 1.e-5_r8) then
                  EMKIKJ = EBOX(KI,KJ) * B_GXA(KI,I) * B_GYA(KJ,J)
                  XG = B_GXX(KI,I)
                  YG = B_GYY(KJ,J)
                  KX0 = 6._r8 * XG - 3._r8
                  KXX = 30._r8 * XG * (XG - 1._r8) + 5._r8
                  KY0 = 6._r8 * YG - 3._r8
                  KYY = 30._r8 * YG * (YG - 1._r8) + 5._r8
                  KXY = KX0 * KY0
                  EDXY(I,J,1) = EDXY(I,J,1) + EMKIKJ
                  EDXY(I,J,2) = EDXY(I,J,2) + EMKIKJ * KX0
                  EDXY(I,J,3) = EDXY(I,J,3) + EMKIKJ * KXX
                  EDXY(I,J,4) = EDXY(I,J,4) + EMKIKJ * KY0
                  EDXY(I,J,5) = EDXY(I,J,5) + EMKIKJ * KYY
                  EDXY(I,J,6) = EDXY(I,J,6) + EMKIKJ * KXY
                end if
              end do
            end if
          end do
        end do
      end do !// do J = 1, JM

      !// 1st variable - EDXY(I,J,1) has real units of EBOX (kg or m2)
      !// 2nd-6th variables are the XY-moments and dimensionless.
      do J = 1, JM
        do I = 1, IM
          if (EDXY(I,J,1) .gt. 1.e-30_r8) then
            EDXY(I,J,2) = EDXY(I,J,2) / EDXY(I,J,1)
            EDXY(I,J,3) = EDXY(I,J,3) / EDXY(I,J,1)
            EDXY(I,J,4) = EDXY(I,J,4) / EDXY(I,J,1)
            EDXY(I,J,5) = EDXY(I,J,5) / EDXY(I,J,1)
            EDXY(I,J,6) = EDXY(I,J,6) / EDXY(I,J,1)
          end if
        end do
      end do
    else
      !// Do not consider moments (NEDXY == 1)
      do J = 1, JM
        do I = 1, IM
          EDXY(I,J,1) = 0._r8
          do KJ = 1,JG
            if (B_GYA(KJ,J) .gt. 1.e-5_r8) then
              do KI = 1,IG
                if (B_GXA(KI,I) .gt. 1.e-5_r8) then
                  EMKIKJ = EBOX(KI,KJ) * B_GXA(KI,I) * B_GYA(KJ,J)
                  EDXY(I,J,1) = EDXY(I,J,1) + EMKIKJ
                end if
              end do
            end if
          end do
        end do
      end do !// do J = 1, JM
    end if !// if (NEDXY .eq.  6) then

    !// Sum check for complete overlaps (done in calling program)
    !SUMIJ = 0._r8
    !do J = 1, JM
    !   do I = 1, IM
    !      SUMIJ = SUMIJ + EDXY(I,J,1)
    !   end do
    !end do
    !SUMK  = 0._r8
    !do KJ = 1, JG
    !   do KI = 1, IG
    !      SUMK = SUMK + EBOX(KI,KJ)
    !   end do
    !end do
    !if ( abs(SUMIJ - SUMK) .gt. 1.d-6 * SUMK) then
    !   write (6,'(a,1p,e12.5,a,e12.5)') &
    !        ' emissions mis-mapping: ',SUMK,' to ',SUMIJ
    !end if

    !//---------------------------------------------------------------------
  end subroutine E_GRID
  !//-----------------------------------------------------------------------

  !// ----------------------------------------------------------------------
  subroutine E_GRID_Y(EBOX,YBEDG,JG, EDY,YDEDG,JM)
    !// --------------------------------------------------------------------
    !// generic regridder of
    !//    emissions EBOX(1:JG)
    !// on regular grid YBEDG(1:JG+1)
    !// onto CTM grid   EDY(1:JM)
    !//
    !// EBOX = emissions or absolute quantity (kg or kg/yr, not kg/m2)
    !// IF original data is %-coverage or kg/m2, THEN must be pre-mult by area
    !//
    !// Y's are the grid edges in degrees
    !//     note that the Longitude (X) edges can jump by 360 deg
    !//
    !// EDY(1:JM) = emissions partitioned into box (J)
    !//
    !// Based on UCI E_GRID, but only with Y-component
    !// Ole Amund Sovde, December 2009
    !// --------------------------------------------------------------------
    use cmn_precision, only: r8
    use cmn_parameters, only: CPI, C2PI, CPI180
    !// --------------------------------------------------------------------
    implicit none
    !// --------------------------------------------------------------------
    !// Input
    integer, intent(in) :: JG, JM
    real(r8), intent(in) :: EBOX(JG),YBEDG(JG+1)
    real(r8), intent(in) :: YDEDG(JM+1)
    !// Output
    real(r8), intent(out) :: EDY(JM)
    !// Locals
    real(r8) :: Y1,Y2,SY1,SY2,DYBOX,YG,  YB1,YB2,SYB1,SYB2
    real(r8) :: B_GYA(JG,JM)
    real(r8) :: EMKIKJ
    real(r8) :: SYG(JM+1)
    integer :: J,J1,J2,KJ
    !// --------------------------------------------------------------------

    !// Fraction of JG inside each JM
    B_GYA(:,:) = 0._r8

    !// For relative area use sin(LATITUDE) x LONGITUDE (degrees)
    do J = 1,JM+1
       SYG(J) = sin(YDEDG(J) * CPI180)
    end do

    !// Setup the LATITUDE mapping and weights for the emission boxes
    do KJ = 1, JG
       YB1 = YBEDG(KJ)
       YB2 = YBEDG(KJ+1)
       SYB1 = sin(CPI180 * YB1)
       SYB2 = sin(CPI180 * YB2)

       !// Have removed original goto statements. If there was no exit
       !// of loop, J1 was set to JM, so let us initialize it with that.
       J1 = JM !// In case no exit of loop.
       do J = 2, JM
          if (YDEDG(J) .gt. YB1) then
             J1 = J - 1
             exit !// exit J-loop (goto 12)
          end if
       end do
       !J1 = JM
       !12 continue

       !// Same for J2
       J2 = JM
       do J = J1+1, JM+1
          if (YDEDG(J) .ge. YB2) then
             J2 = J - 1
             exit !// exit J-loop (goto 14)
          end if
       end do
       !J2 = JM
       !14 continue

       !// The emission box KJ=1:JG is contained in CTM grid boxes J1 to J2
       !// save the indices and fractions and weightings
       do J = J1, J2
          Y1 = max(YB1, YDEDG(J))
          Y2 = min(YB2, YDEDG(J+1))
          SY1 = sin(CPI180*Y1)
          SY2 = sin(CPI180*Y2)
          DYBOX = (SY2-SY1)/(SYB2-SYB1)     ! fractional area of emission box
          !// mean value of Y in grid box
          YG = (0.5_r8 * (SY1 + SY2) - SYG(J))/(SYG(J+1) - SYG(J))

          B_GYA(KJ,J) = DYBOX
       end do

    end do !// do KJ = 1,JG

    !// Sum contributions to CTM grid (J) from emission boxes (KJ)
    do J = 1, JM
       EDY(J) = 0._r8
       do KJ = 1, JG
          if (B_GYA(KJ,J) .gt. 1.e-5_r8) then
             EMKIKJ = EBOX(KJ) * B_GYA(KJ,J)
             EDY(J) = EDY(J) + EMKIKJ
          end if
       end do
    end do

    !// --------------------------------------------------------------------
  end subroutine E_GRID_Y
  !// ----------------------------------------------------------------------

  !//-----------------------------------------------------------------------
  subroutine TRUNG8(SPHI, SPLO, ZDEGI, ZDEGJ, IMAP, JMAP, IDGRD, &
                    JDGRD, IPARW, JPARW, IM, JM, LM, LV)
    !//---------------------------------------------------------------------
    !// Double precision!
    !// Average gridpoint data to go with truncation of spectral fields.
    !// Or, in other words, map high resolution SPHI onto low resolution
    !// SPLO.
    !//
    !// Will now also work if IPARW==IM and JPARW=JM
    !//
    !// Ole Amund Sovde, July 2015
    !//---------------------------------------------------------------------
    use cmn_precision, only: r8
    !//---------------------------------------------------------------------
    implicit none
    !//---------------------------------------------------------------------
    !// Input
    integer, intent(in) :: IPARW, JPARW, IM, JM, LM, LV
    integer, intent(in) :: IDGRD, JDGRD
    integer, intent(in) :: IMAP(IDGRD,IM), JMAP(JDGRD,JM)
    real(r8), intent(in)  :: SPHI(IPARW,JPARW,LM,LV)
    real(r8), intent(in)  :: ZDEGI(IDGRD,IM),ZDEGJ(JDGRD,IM)
    !// Output
    real(r8), intent(out)  :: SPLO(IM,JM,LM,LV)
    !// Locals
    integer :: I,J,K,L,ix,jx
    !//---------------------------------------------------------------------

    !// If IPARW == IM and JPARW==JM, the resolution is the same!
    if (IPARW .eq. IM .and. JPARW .eq. JM) then
      do K = 1, LV
        do L = 1, LM
          do J = 1, JM
            do I = 1, IM
              SPLO(I,J,L,K) = SPHI(I,J,L,K)
            end do
          end do
        end do
      end do
    else
      !// Zero output array
      SPLO(:,:,:,:) = 0._r8
      !// Map SPHI onto SPLO
      do K = 1, LV
        do L = 1, LM
          do J = 1, JM
            do I = 1, IM
              do jx = 1, jdgrd
                do ix = 1, idgrd
                  SPLO(I,J,L,K) = SPLO(I,J,L,K) &
                                + SPHI(imap(ix,i), jmap(jx,j), L, K) &
                                  * ZDEGI(ix,i) * ZDEGJ(jx,j)
                end do
              end do
            end do
          end do
        end do
      end do
    end if

    !//---------------------------------------------------------------------
  end subroutine TRUNG8
  !//-----------------------------------------------------------------------

  !//-----------------------------------------------------------------------
  subroutine TRUNG4(SPHI, SPLO, ZDEGI, ZDEGJ, IMAP, JMAP, IDGRD, &
                    JDGRD, IPARW, JPARW, IM, JM, LM, LV)
    !//---------------------------------------------------------------------
    !// Single precision!
    !// Average gridpoint data to go with truncation of spectral fields.
    !// Or, in other words, map high resolution SPHI onto low resolution
    !// SPLO.
    !//
    !// Will now also work if IPARW==IM and JPARW=JM
    !//
    !// Ole Amund Sovde, July 2015
    !//---------------------------------------------------------------------
    use cmn_precision, only: r8, r4
    !//---------------------------------------------------------------------
    implicit none
    !//---------------------------------------------------------------------
    !// Input
    integer, intent(in) :: IPARW, JPARW, IM, JM, LM, LV
    integer, intent(in) :: IDGRD, JDGRD
    integer, intent(in) :: IMAP(IDGRD,IM), JMAP(JDGRD,JM)
    real(r4), intent(in) :: SPHI(IPARW,JPARW,LM,LV)
    real(r8), intent(in) :: ZDEGI(IDGRD,IM),ZDEGJ(JDGRD,IM)
    !// Output
    real(r4), intent(out) :: SPLO(IM,JM,LM,LV)
    !// Locals
    integer :: I,J,K,L,ix,jx
    !//---------------------------------------------------------------------

    !// If IPARW == IM and JPARW==JM, the resolution is the same!
    if (IPARW .eq. IM .and. JPARW .eq. JM) then
      do K = 1, LV
        do L = 1, LM
          do J = 1, JM
            do I = 1, IM
              SPLO(I,J,L,K) = SPHI(I,J,L,K)
            end do
          end do
        end do
      end do
    else
      !// Zero output array
      SPLO(:,:,:,:) = 0._r4
      !// Map SPHI onto SPLO
      do K = 1, LV
        do L = 1, LM
          do J = 1, JM
            do I = 1, IM
              do jx = 1, jdgrd
                do ix = 1, idgrd
                  SPLO(I,J,L,K) = SPLO(I,J,L,K) &
                                + SPHI(imap(ix,i), jmap(jx,j), L, K) &
                                  * ZDEGI(ix,i) * ZDEGJ(jx,j)
                end do
              end do
            end do
          end do
        end do
      end do
    end if

    !//---------------------------------------------------------------------
  end subroutine TRUNG4
  !//-----------------------------------------------------------------------

  !//-----------------------------------------------------------------------
  subroutine Regrid_Column_Weights( PEdge1, PEdge2, Weights )
    !//---------------------------------------------------------------------
    !// Based on UCI qcode 72b.
    !//
    !// Ole Amund Sovde, April 2016
    !//---------------------------------------------------------------------
    use cmn_precision, only: r8
    !//---------------------------------------------------------------------
    implicit none
    !//---------------------------------------------------------------------
    ! Input/Output
    real(r8), dimension(:), intent(in) :: PEDGE1, PEDGE2
    real(r8), dimension(:,:), intent(out):: Weights

    !// Local variables
    integer :: LM1, LM2, L, K
    real(r8) :: rsum
    logical, parameter :: CHECK=.true., DEBUG=.false.
    !//---------------------------------------------------------------------
    character(len=*), parameter :: subr = 'Regrid_Column_Weights'
    !// --------------------------------------------------------------------

    !// Initialise
    LM1      = size( PEdge1 ) - 1
    LM2      = size( PEdge2 ) - 1
    Weights(:,:) = 0._r8

    !// Determine fraction of each INPUT box
    !// which contributes to each OUTPUT box

    !// Loop over INPUT layers
    do L = 1, LM1

       !// If top-of-box INPUT pressure is located below model
       !// surface, skip the data. I.e. do not put below-surface
       !// data into surface layer of model.
       if ( ( PEdge1(L+1) .ge. Pedge2(1) ) ) cycle

       !// Loop over OUTPUT layers
       do K = 1, LM2

          !==============================================================
          ! No contribution if:
          ! -------------------
          ! Bottom of OUTPUT layer above Top    of INPUT layer  OR
          ! Top    of OUTPUT layer below Bottom of INPUT layer
          !==============================================================
          if ( ( PEdge2(K)   .lt. PEdge1(L+1)) .or. &
               ( PEdge2(K+1) .gt. PEdge1(L)  ) ) cycle

          !==============================================================
          ! Contribution if:
          ! ----------------
          ! Entire INPUT layer in OUTPUT layer
          !==============================================================
          if ( (PEdge2(K)   .ge. PEdge1(L))   .and. &
               (PEdge2(K+1) .le. PEdge1(L+1)) ) then

             Weights(L,K) = 1._r8

             !// Go to next K iteration
             cycle
          end if

          !==============================================================
          ! Contribution if:
          ! ----------------
          ! Top of OUTPUT layer in INPUT layer
          !==============================================================
          if ( (PEdge2(K+1) .le. PEdge1(L)) .and.  &
               (PEdge2(K)   .ge. PEdge1(L)) ) then

             Weights(L,K) = ( PEdge1(L) - PEdge2(K+1) ) /  &
                            ( PEdge1(L) - PEdge1(L+1) )

             !// Go to next K iteration
             cycle
          end if

          !==============================================================
          ! Contribution if:
          ! ----------------
          ! Entire OUTPUT layer in INPUT layer
          !==============================================================
          if ( (PEdge2(K)   .le. PEdge1(L))   .and.  &
               (PEdge2(K+1) .ge. PEdge1(L+1)) ) then

             Weights(L,K) = ( PEdge2(K) - PEdge2(K+1) ) /  &
                            ( PEdge1(L) - PEdge1(L+1) )

             !// Go to next K iteration
             cycle
          end if

          !==============================================================
          ! Contribution if:
          ! ----------------
          ! Bottom of OUTPUT layer in INPUT layer
          !==============================================================
          if ( (PEdge2(K)   .ge. PEdge1(L+1)) .and. &
               (PEdge2(K+1) .le. PEdge1(L+1)) ) then

             Weights(L,K) = ( PEdge2(K) - PEdge1(L+1) ) /   &
                            ( PEdge1(L) - PEdge1(L+1) )

             !// Go to next K iteration
             cycle
          end if

       end do !// do K = 1, LM2

       !// Consistency Check:
       !// If SUM( WEIGHTS(L,:) ) does not = 1, there may be a problem.
       !//
       !// This is actually only true when Pedge1(1) .le. Pedge2(1).
       !// Otherwise, a only a partial of input is put in output,
       !// the rest going "below surface".
       rsum = sum( Weights(L,:) )
       if ( rsum .gt. 0._r8 .AND. Check ) then
          if ( Pedge1(1) .le. Pedge2(1) .and. &
               abs( 1._r8 - rsum ) .ge. 1.e-4_r8 ) then
             write(6,'(a,i4,1x,f13.7,es20.16)') f90file//':'//subr// &
                  ': Weights does not add to 1:',L,rsum, &
                  Abs( 1._r8 - rsum )
             do K = 1, LM2
                print*,K,Pedge2(K),weights(L,K)
             end do
             print*,Pedge1
             stop
          end if
       end if

    end do !// do L = 1, LM1

    !//---------------------------------------------------------------------
  end subroutine Regrid_Column_Weights
  !//-----------------------------------------------------------------------

  !//-----------------------------------------------------------------------
end module regridding
!//=========================================================================


!!---------------------------------------------------------------------------------------
!!----- Multi-material and multi-phase (Time-stepping module)
!!----- by
!!----- Aditya K Pandare
!!---------------------------------------------------------------------------------------

MODULE time_integration

USE preprocess

implicit none

CONTAINS

!----------------------------------------------------------------------------------------------
!----- Explicit TVD-RK3 time-stepping:
!----------------------------------------------------------------------------------------------

subroutine ExplicitRK3_mm6eq(reconst_mm6eq, ucons, uprim, matint_el)

procedure(), pointer :: reconst_mm6eq
integer  :: itstep, ielem, idof, ieqn, istage
integer  :: matint_el(0:imax+1)
real*8   :: mm(g_tdof), err_log(g_neqns), linfty
real*8   :: ucons(g_tdof,g_neqns,0:imax+1),uconsn(g_tdof,g_neqns,0:imax+1), &
            uprim(g_tdof,g_nprim,0:imax+1), &
            k1(3),k2(3)
real*8   :: rhsel(g_gdof,g_neqns,imax), cons_err(2)

  g_time = 0.d0

  k1(1) = 0.0     !0.0
  k1(2) = 3.0/4.0 !0.5
  k1(3) = 1.0/3.0

  k2(1) = 1.0     !1.0
  k2(2) = 1.0/4.0 !0.5
  k2(3) = 2.0/3.0

  call meconservation_mm6eq(0,ucons,cons_err)

  do itstep = 1,ntstep

     !--- solution update
     uconsn(:,:,:) = ucons(:,:,:)

     !---------------------------------------------------------
     !--- RK stages
     do istage = 1,3 !2

        rhsel(:,:,:) = 0.d0

        call rhs_rdg_mm6eq(ucons, uprim, rhsel, matint_el)

        do ielem = 1,imax

        mm(1) = coord(ielem+1)-coord(ielem)
        if (g_nsdiscr .gt. 0) mm(2) = mm(1) / 3.0

        do ieqn = 1,g_neqns
        do idof = 1,g_gdof

          ucons(idof, ieqn,ielem) = &
              k1(istage) *   uconsn(idof,ieqn,ielem) &
            + k2(istage) * ( ucons(idof,ieqn,ielem) &
                           + dt * rhsel(idof,ieqn,ielem) &
                             / mm(idof) )

        end do !idof
        end do !ieqn
        end do !ielem

        call get_bc_mm6eq(ucons)
        call fill_matintel(ucons, matint_el)
        call weak_recons_primitives(ucons, uprim)
        call ignore_tinyphase_mm6eq(ucons, uprim)
        call reconst_mm6eq(ucons, uprim)

     end do !istage
     !---------------------------------------------------------

     g_time = g_time + (dt/a_nd)

     !----- Diagnostics:
     call meconservation_mm6eq(itstep,ucons,cons_err)

     !----- Screen-output:
     if ((itstep.eq.1) .or. (mod(itstep,n_screen).eq.0)) then
     write(*,*) "--------------------------------------------"
     write(*,*) "  itstep: ", itstep, "   Time: ", g_time
     write(*,*) "  Time step: ", dt/a_nd
     write(*,*) "  Conservation: "
     write(*,*) "  Mass:         ", cons_err(1)
     write(*,*) "  Total-energy: ", cons_err(2)
     write(*,*) "--------------------------------------------"
     write(*,*) " "
     end if

     !----- File-output:
     if ((mod(itstep,n_opfile).eq.0).or.(itstep.eq.1)) then
     call gnuplot_flow_mm6eq(ucons, uprim, matint_el, itstep)
     call gnuplot_flow_p1_mm6eq(ucons, uprim, matint_el, itstep)
     end if

     if ((mod(itstep,10).eq.0) .or. (itstep.eq.1)) then
     call gnuplot_diagnostics_mm6eq(ucons, uprim, cons_err, g_time)
     end if

  end do !itstep

  itstep = itstep - 1

  call gnuplot_flow_mm6eq(ucons, uprim, matint_el, itstep)
  call gnuplot_flow_p1_mm6eq(ucons, uprim, matint_el, itstep)
  call gnuplot_diagnostics_mm6eq(ucons, uprim, cons_err, g_time)

  !----- compute L2-error-norm
  call errorcalc_p1(ucons, g_time*a_nd, err_log, linfty)

  !----- Screen-output:
  write(*,*) "-----------------------------------------------"
  write(*,*) "-------- FINAL OUTPUT: ----- TVD-RK3: ---------"
  write(*,*) "  itstep: ", itstep, "   Time: ", g_time
  write(*,*) "  Time step: ", dt/a_nd
  write(*,*) "  Conservation: "
  write(*,*) "  Mass:         ", cons_err(1)
  write(*,*) "  Total-energy: ", cons_err(2)
  write(*,*) "  log(||e||): ", err_log(1), 10.0**err_log(1)
  write(*,*) "  |e|_inf:    ", linfty
  write(*,*) "-----------------------------------------------"
  write(*,*) "-----------------------------------------------"
  write(*,*) " "

end subroutine ExplicitRK3_mm6eq

!----------------------------------------------------------------------------------------------
!----- Determine what materials are present in cell
!----------------------------------------------------------------------------------------------

subroutine checkmat_mm6eq(ie, ui, mat_present, mat_index)

integer, intent(in) :: ie

integer :: i, mat_present, mat_index(g_mmi%nummat)
real*8  :: rhomat, al_eps, rho, &
           ui(g_tdof,g_neqns)

associate (nummat=>g_mmi%nummat)

  al_eps = 1.d-14

  rho = sum(ui(1,g_mmi%irmin:g_mmi%irmax))

  mat_present = 0
  mat_index = -1

  do i = 1,g_mmi%nummat
    if (ui(1,i) .gt. al_eps) then

      rhomat  = ui(1,g_mmi%irmin+i-1)/ui(1,i)

      mat_present = mat_present + 1
      mat_index(mat_present) = i
    end if
  end do !i

  if (mat_present .eq. 0) then
    write(*,*) "Error: No materials present in cell: ", ie
    call exit
  end if

end associate

end subroutine checkmat_mm6eq

!----------------------------------------------------------------------------------------------
!----- Compute mass and energy conservation for the mm6eq system:
!----------------------------------------------------------------------------------------------

subroutine meconservation_mm6eq(its, ucons, err)

integer, intent(in) :: its
real*8,  intent(in) :: ucons(g_tdof,g_neqns,0:imax+1)

integer :: ie, imat
real*8  :: mass_m, tenergy_m, massi_m, tenergyi_m
real*8  :: err(2)

associate (nummat=>g_mmi%nummat)

  !--- initialize
  if (its .eq. 0) then
    g_mass0_m = 0.0
    g_tenergy0_m = 0.0

  else
    massi_m = 0.0
    tenergyi_m = 0.0

  end if

  do ie = 1,imax

    mass_m = 0.0
    tenergy_m = 0.0
    do imat = 1,nummat
      !--- mass
      mass_m = mass_m + ucons(1,g_mmi%irmin+imat-1,ie)

      !--- total energy
      tenergy_m = tenergy_m + ucons(1,g_mmi%iemin+imat-1,ie)
    end do !imat

    if (its .eq. 0) then
      g_mass0_m = g_mass0_m + mass_m
      g_tenergy0_m = g_tenergy0_m + tenergy_m

    else
      massi_m = massi_m + mass_m
      tenergyi_m = tenergyi_m + tenergy_m

    end if

  end do !ie

  if (its .ne. 0) then
    err(1) = (massi_m - g_mass0_m) !/ g_mass0_m
    err(2) = (tenergyi_m - g_tenergy0_m) !/ g_tenergy0_m
  else
    err(:) = 0.0;
  end if

end associate

end subroutine meconservation_mm6eq

!----------------------------------------------------------------------------------------------

END MODULE time_integration


      program riemann
      implicit none

! time evolution of the exact riemann problem
! original code from bruce fryxell

! declare
      character*80       :: string
      integer            :: npts,itmax,iter,i
      integer, parameter :: n = 1000
      real*8             :: x(n),rho(n),u(n),p(n), &
                            rhol,pl,ul,rhor,pr,ur,xi,xl,xr, &
                            rho1,p1,u1,rho5,p5,u5,p40,p41,f0,tube,eps, &
                            f1,p4,error,z,c5,gmfac1,gmfac2,fact, &
                            u4,rho4,w,p3,u3,rho3,c1,c3,xsh,xcd,xft,xhd,dx

      real*8             :: energy,temper,cv,const1,const2,entropy

! for the time evoluton
      integer            :: j, nstep
      real*8             :: time, tlo, thi, tstep

! for communicating the equation of state
      real*8             :: gamma, gm1, gp1, g2
      common /csmall/       gamma, gm1, gp1, g2

! common formats
10    format('output_',i3.3,'.dat')
11    format (2x, 'i', 10x, 'x', 12x, 'density', 8x, 'pressure', 8x, 'velocity'/)
12    format (i4, 12(2x, 1pe10.2))

! set initial conditions
! state at left of discontinuity
      rhol = 10.0d0
      pl   = 100.0d0
      ul   = 0.d0

! state at right of discontinuity
      rhor = 1.0d0
      pr   = 1.0d0
      ur   = 0.0d0

      if (ul .ne. 0. .or. ur .ne. 0.) stop 'must have ul = ur = 0.'

!  equation of state
      gamma = 1.4d0
      gm1   = gamma - 1.0d0
      gp1   = gamma + 1.0d0
      g2    = 2.0d0 * gamma

! location of discontinuity at t = 0
      xi = 2.0d0

! time at which solution is desired
      tlo   = 0.0d0
      thi   = 0.4d0
      nstep = 41
      tstep = 0.0d0
      if (nstep .ne. 1) tstep = (thi - tlo) / float(nstep - 1)

! number of points in solution
      npts = 500
      if (npts .gt. n) stop 'number of points npts exceeds array size n'

! spatial domain and grid
      xl = 0.0d0
      xr = 5.0d0
      if (xr .lt. xl) stop 'xr must be greater than xl'
      dx = (xr - xl) / (npts - 1)
      do i = 1, npts
       x(i) = xl + dx * float(i - 1)
      enddo

! shock solution
       if (pl .gt. pr) then
        rho1 = rhol
        p1   = pl
        u1   = ul
        rho5 = rhor
        p5   = pr
        u5   = ur
       else
        rho1 = rhor
        p1   = pr
        u1   = ur
        rho5 = rhol
        p5   = pl
        u5   = ul
       endif

! solve for post-shock pressure by secant method
! initial guesses

      p40 = p1
      p41 = p5
      f0  = tube(p40, p1, p5, rho1, rho5)

! maximum number of iterations and maximum allowable relative error
      itmax = 20
      eps   = 1.0d-5

      do iter = 1, itmax
       f1 = tube(p41, p1, p5, rho1, rho5)
       if (f1 .eq. f0) go to 05

       p4 = p41 - (p41 - p40) * f1 / (f1 - f0)

       error = abs (p4 - p41) / p41
       if (error .lt. eps) goto 05

       p40 = p41
       p41 = p4
       f0  = f1
      enddo
      write (6,*) 'post-shock pressure iteration failed to converge'
      stop 'abnormal termination'

05    continue

! compute post-shock density and velocity
      z  = (p4 / p5 - 1.0d0)
      c5 = sqrt (gamma * p5 / rho5)

      gmfac1 = 0.5d0 * gm1 / gamma
      gmfac2 = 0.5d0 * gp1 / gamma

      fact = sqrt (1.0d0 + gmfac2 * z)

      u4 = c5 * z / (gamma * fact)
      rho4 = rho5 * (1.0d0 + gmfac2 * z) / (1.0d0 + gmfac1 * z)

! shock speed
      w = c5 * fact

! compute values at foot of rarefaction
      p3 = p4
      u3 = u4
      rho3 = rho1 * (p3 / p1)**(1.0d0 /gamma)

! begin time evolution
      do j = 1, nstep
       time = tlo + tstep * float(j - 1)

! compute positions of waves
       if (pl .gt. pr) then
        c1 = sqrt (gamma * p1 / rho1)
        c3 = sqrt (gamma * p3 / rho3)

        xsh = xi + w * time
        xcd = xi + u3 * time
        xft = xi + (u3 - c3) * time
        xhd = xi - c1 * time

        do i = 1, npts
         if (x(i) .lt. xhd) then
          rho(i) = rho1
          p(i)   = p1
          u(i)   = u1
         else if (x(i) .lt. xft) then
          u(i)   = 2.0d0 / gp1 * (c1 + (x(i) - xi) / time)
          fact   = 1.0d0 - 0.5d0 * gm1 * u(i) / c1
          rho(i) = rho1 * fact ** (2.0d0 / gm1)
          p(i)   = p1 * fact ** (2.0d0 * gamma / gm1)
         else if (x(i) .lt. xcd) then
          rho(i) = rho3
          p(i)   = p3
          u(i)   = u3
         else if (x(i) .lt. xsh) then
          rho(i) = rho4
          p(i)   = p4
          u(i)   = u4
         else
          rho(i) = rho5
          p(i)   = p5
          u(i)   = u5
         endif
        enddo
       endif

! if pr > pl, reverse solution
       if (pr .gt. pl) then
        c1 = sqrt (gamma * p1 / rho1)
        c3 = sqrt (gamma * p3 / rho3)

        xsh = xi - w * time
        xcd = xi - u3 * time
        xft = xi - (u3 - c3) * time
        xhd = xi + c1 * time

        do i = 1, npts
         if (x(i) .lt. xsh) then
          rho(i) = rho5
          p(i)   = p5
          u(i)   = -u5
         else if (x(i) .lt. xcd) then
         rho(i) = rho4
          p(i)   = p4
          u(i)   = -u4
         else if (x(i) .lt. xft) then
          rho(i) = rho3
          p(i)   = p3
          u(i)   = -u3
         else if (x(i) .lt. xhd) then
          u(i)   = -2.0d0 / gp1 * (c1 + (xi - x(i)) / time)
         fact   = 1.0d0 + 0.5d0 * gm1 * u(i) / c1
          rho(i) = rho1 * fact ** (2.0d0 / gm1)
          p(i)   = p1 * fact ** (2.0d0 * gamma / gm1)
         else
          rho(i) = rho1
          p(i)   = p1
          u(i)   = -u1
         endif
        enddo
       endif

! write solution at this time
       write(string,10) j
       open (unit=1, file=string,status='unknown')
       write(1,'(a,1f5.2)') 'time =',time
       write (1, 11)
       do i = 1, npts
        energy = p(i)/((gamma - 1.0d0)*rho(i))
        temper = energy*(gamma - 1.0d0)
        cv     = energy/temper
!        const1 = gamma/(gamma-1.0d0)
        const1 = (energy + p(i)/rho(i))/temper
        const2 = p(i)/rho(i)**gamma
        entropy = cv*log(const2)

        write (1,12) i, x(i), rho(i), p(i), u(i),energy, temper, cv, const1, const2, entropy

       enddo
       close (unit=1)

! end of time evolution loop
      end do

      stop 'normal termination'
      end program riemann

      real*8 function tube(p4, p1, p5, rho1, rho5)
      implicit none

! shock tube equation

! declare the pass
      real*8  :: p4,p1,p5,rho1,rho5

! for communicating the equation of state
      real*8             :: gamma, gm1, gp1, g2
      common /csmall/       gamma, gm1, gp1, g2

! local variables
      real*8  :: z,c1,c5,fact

      z = (p4 / p5 - 1.0d0)
      c1 = sqrt (gamma * p1 / rho1)
      c5 = sqrt (gamma * p5 / rho5)

      fact = gm1 / g2 * (c5 / c1) * z / sqrt (1.0d0 + gp1 / g2 * z)
      fact = (1.0d0 - fact) ** (g2 / gm1)

      tube = p1 * fact - p4

      return
      end function tube


C--- Implementation of arXiv:0906.0008v1, Eqs. (A.5), (A.6) and (A.7)
c--- with factor of i removed

      double complex function A0phiAQggmppm(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.5) second line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phiAQggmppm=-za(j1,j4)**2*za(j2,j4)
     .                 /(za(j1,j2)*za(j2,j3)*za(j3,j4))

      return
      end

      double complex function A0phiAQggmpmp(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.5) third line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phiAQggmpmp=za(j1,j3)**3/(za(j1,j2)*za(j3,j4)*za(j4,j1))

      return
      end

      double complex function A0phidAQggmppm(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.5) fifth line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phidAQggmppm=-zb(j2,j3)**2*zb(j1,j3)
     .                   /(zb(j1,j2)*zb(j3,j4)*zb(j4,j1))

      return
      end

      double complex function A0phidAQggmpmp(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.5) sixth line
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4

      A0phidAQggmpmp=zb(j2,j4)**3
     .                  /(zb(j1,j2)*zb(j2,j3)*zb(j3,j4))

      return
      end

      double complex function A0phiAQggmpmm(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.6)
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4
      double complex zab2
      double precision s3
      s3(j1,j2,j3)=s(j1,j2)+s(j2,j3)+s(j3,j1)
      zab2(j1,j2,j3,j4)=za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)

      A0phiAQggmpmm=-zab2(j3,j1,j4,j2)**2*za(j4,j1)
     .               /zb(j2,j4)/s3(j4,j1,j2)*(1d0/s(j1,j2)+1d0/s(j4,j1))
     .              -zab2(j4,j1,j3,j2)**2*za(j1,j3)
     .               /(zb(j2,j3)*s(j1,j2)*s3(j1,j2,j3))
     .              +zab2(j1,j3,j4,j2)**2
     .               /(za(j1,j2)*zb(j2,j4)*zb(j2,j3)*zb(j3,j4))

      return
      end

      double complex function A0phidAQggmppp(j1,j2,j3,j4,za,zb)
      implicit none
c--- (A.7)
c----with factor of i removed
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4
      double complex zab2
      double precision s3
      s3(j1,j2,j3)=s(j1,j2)+s(j2,j3)+s(j3,j1)
      zab2(j1,j2,j3,j4)=za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)

      A0phidAQggmppp=-zab2(j1,j2,j3,j4)**2*zb(j2,j3)
     .               /za(j1,j3)/s3(j1,j2,j3)*(1d0/s(j1,j2)+1d0/s(j2,j3))
     .              +zab2(j1,j2,j4,j3)**2*zb(j2,j4)
     .               /(za(j1,j4)*s(j1,j2)*s3(j4,j1,j2))
     .              -zab2(j1,j3,j4,j2)**2
     .               /(zb(j1,j2)*za(j1,j3)*za(j1,j4)*za(j3,j4))

      return
      end


c--- program agridMLsm.v2.f
c --- f95 or gfortran. Needs iosubs
c--- calculates gridded 10**a-values from catalog
c--- this version uses unequal sampling periods
c--- written by Art Frankel  6/94
c -- v2 mods: Steve Harmsen 1/2007.
c-- to run: agridMLsm.v2 parfile
c-- try: agridMLsm.v2 WUSagrid.in
	parameter (nsrcmx=10000,ngrmx=800000,nmagmx=12)
c nsrcmx = maximum # of source records in input catalog
c ngrmx = maximum #  of source grid points in output matrix
c integer*4  to insure that iosubs gets correct information.
      integer*4 readn,nsrc
      real magmin
      logical isok
      character*72 name,name2
      real, dimension (nmagmx) :: ymag
      integer, dimension (nmagmx) :: iyr
      real, dimension (ngrmx) :: asum,asumnew
c      write(6,*) "enter name of input file"
	if(iargc().lt.1)stop"Usage: agridMLsm input.file"
900   format(a)
      call getarg(1,name)
101      inquire(file=name,exist=isok)
      if(isok)then
      open(unit=1,file=name,status='old')
      else
      write(6,50)'Input file not found, please try again: '
50	format(a,$)
      read *,name
      goto 101
      endif
c      open(unit=2,file=name2,status='new')
      write(6,50) "for sites: min lat, max lat of box out: "
      read(1,*) ymin, ymax
	write(6,*)ymin,ymax
      write(6,50) "for sites: min lon, max lon of box out: "
      read(1,*) xmin, xmax
	write(6,*)xmin,xmax
      write(6,50) "increments dlat,dlon for source cell: "
      read(1,*) dsy, dsx
	write(6,*)dsy, dsx
c v2 change: make the nsx, nsy calculations more robust with nint
      nsx= nint((xmax-xmin)/dsx) +1
      nsy= nint((ymax-ymin)/dsy) +1
      nsrc= nsx*nsy
      write(6,*) "Source box: ",nsx,nsy,nsrc
      if(nsrc.gt.ngrmx)stop 'please increase ngrmx to accomodate'
      write(6,*) "enter number of magnitude categories"
      read(1,*) nmag
      if(nmag.gt.nmagmx)stop'number of mags exceeds nmagmx'
      write(6,*) "enter min mag and min year of completeness"
      do 11 i=1,nmag
 11   read(1,*) ymag(i),iyr(i)
c
c
      write(6,*) "enter end year of catalog"
      read(1,*)iyrend
      write(6,50) "enter name of catalog file: "
      read(1,900) name
      write(6,900)name
      inquire(file=name,exist=isok)
      if(.not.isok)write(6,*)'file not found: ',name
      open(unit=2, file=name,status='old')
      write(6,*) "enter minimum mag,dmag, bval"
      read(1,*) magmin,dmag,bval
      dmag= dmag/2.
c-- above for conversion from cumulative to incremental a value
c-- Herrmann's formula is +-dmag
c
      sum= 0.
	asum = 0.	!use vector arithmetic
      atotal=0.
      do 1 i=1,nsrcmx
      read(2,*,end=999,err=999) iyear,xlat,xlon,depth,xmag
      if(depth.gt.50) goto 1
c      if((depth.lt.30).or.(depth.gt.50)) goto 1
      do 12 ii=1,nmag
      if((xmag.ge.ymag(ii)).and.(iyear.ge.iyr(ii))) then
c 2nd place where nint may improve the robustness of the calculation. v2 mod.
         iy= nint((ymax-xlat)/dsy)
         ix= nint((xlon-xmin)/dsx)
      if((iy.lt.0).or.(iy.ge.nsy).or.(ix.lt.0).or.(ix.ge.nsx)) go to 1
c      write(6,*) ix,iy
         n= iy*nsx + ix +1
         asum(n) = asum(n)+1.
         atotal= atotal+1
c      write(6,*) iy,ix,n,xlat,xlon
         go to 1
         endif
 12   continue
 1    continue
 999  continue
      fac= alog10(10.**(bval*dmag)-10.**(-bval*dmag))
      write(6,*) 'fac ',fac
      beta= bval*2.303
      a1= 0.
      a2= 0.
      do 14 i=1,nmag
      a1= a1+ exp(-beta*(ymag(i)+0.5))
 14   a2= a2 + (iyrend-iyr(i))*exp(-beta*(ymag(i)+0.5))
      fac2= a1/a2
      write(6,*) 'fac2=a1/a2 ',fac2
c----above is Herrmann's formula to convert from cumul. to interval a-value
      atotal2=0.
      do 3 i=1,nsrc
      if(asum(i).ne.0.) then
c         write(6,*) asum(i)
         asum(i)= asum(i)*fac2
         atotal2= atotal2+asum(i)
         asum(i)= alog10(asum(i)) + bval*magmin
         asum(i)= asum(i)+ fac
         asum(i)= 10.**asum(i)
         sum= sum+asum(i)
c         write(6,*) asum(i)
c         read(5,*) idum
         endif
   3  continue
      write(6,*) 'atotal, atotal2,sum ',atotal, atotal2, sum
c      read(5,*) idum
      write(6,50) "enter correlation distance in km: "
      read(1,*) a
      write(6,*)a
      a2= a*a
      coef= 3.14159/180.
      avelat= (ymin+ymax)/2.
c-------smoothing part
c--- go out to 3 times correlation distance
c 3rd place where nint may improve the robustness of the calculation. v2 mod.
      lx= nint(3.*a/(111.1*cos(avelat*coef)*dsx))
      ly= nint(3.*a/(111.1*dsy))
      write(6,*) 'correlation distances grid units: ',lx,ly
      do 10 iy=1,nsy
c      write(6,*) iy
      do 10 ix=1,nsx
      indx1= ix-lx
      indy1= iy-ly
      n= (iy-1)*nsx+ix
      rx= xmin+(ix-1)*dsx
      ry= ymax-(iy-1)*dsy
      sum1= 0.
      sum2= 0.
      do 20 iyy= indy1,indy1+2*ly
      do 20 ixx= indx1,indx1+2*lx
       if((ixx.lt.1).or.(ixx.gt.nsx)) go to 20
       if((iyy.lt.1).or.(iyy.gt.nsy)) go to 20
       n2= (iyy-1)*nsx+ixx
       sx= xmin+(ixx-1)*dsx
       sy= ymax-(iyy-1)*dsy
       call delaz(sy,sx,ry,rx,dist,az,baz)
       dist2= dist*dist
c----- Gaussian smoothing
       sum1= asum(n2)*exp(-dist2/a2) + sum1
       sum2= exp(-dist2/a2)+sum2
 20    continue
c---- normalize by area under Gaussian
      asumnew(n)= sum1/sum2
c      write(6,*) asumnew(n)
 10   continue
      sum=0.
      do 35 i=1,nsrc
      sum= sum+ asumnew(i)
 35   continue
      write(6,*) 'summed mean rate of M0: ',sum
      read(1,900) name2
c---output smoothed file with 10**a values
      open(99,file='grid_rate_0_50km_50_0.1_grid.xyz',status='unknown')
      do 100 iy=1,nsy
      do 100 ix=1,nsx
      n= (iy-1)*nsx+ix
      rx= xmin+(ix-1)*dsx
      ry= ymax-(iy-1)*dsy
      write(99,313) rx,ry,asumnew(n)

 100  continue
c 313  format(F7.2,3X,F7.2,3X,E10.4)
 313  format(F7.2,',',F7.2,',',E10.4)
c      call openw(name2)
c      call putbuf2(asumnew,nsrc,readn)
c      write(6,801) nsrc,readn
 801  format('Write: ndata=',i8,' readn=',i8)
      end

      subroutine delaz(sorlat,sorlon,stnlat,stnlon,delta,az,baz)
      coef= 3.14159/180.
      xlat= sorlat*coef
      xlon= sorlon*coef
      st0= cos(xlat)
      ct0= sin(xlat)
      phi0= xlon
      xlat= stnlat*coef
      xlon= stnlon*coef
      ct1= sin(xlat)
      st1= cos(xlat)
      sdlon= sin(xlon-phi0)
      cdlon= cos(xlon-phi0)
      cdelt= st0*st1*cdlon+ct0*ct1
      x= st0*ct1-st1*ct0*cdlon
      y= st1*sdlon
      sdelt= sqrt(x*x+y*y)
      delta= atan2(sdelt,cdelt)
      delta= delta/coef
      az= atan2(y,x)
      az= az/coef
      x= st1*ct0-st0*ct1*cdlon
      y= -sdlon*st0
      baz= atan2(y,x)
      baz= baz/coef
      delta= delta*111.11
      return
      end subroutine delaz