c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c $Rev: 42 $ $Date: 2014-11-07 12:42:45 -0500 (Fri, 07 Nov 2014) $
c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

c ---------------------------------------------------------------------
c  Fortran-90 versions of machine-constant routines R1MACH, D1MACH, I1MACH
c
c  {R,D,I}1MACH revisited: no more uncommenting DATA statements
c
c  Presented at the IFIP WG 2.5 International Workshop on
c  "Current Directions in Numerical Software and High Performance
c  Computing", 19 - 20 October 1995, Kyoto, Japan.
c
c  The widely-used original routines were modified to use Fortran-90
c  intrinsic functions.  This was not completely possible with I1MACH,
c  which returns some parameters (logical unit numbers of standard
c  input, standard output, and standard error) that may require
c  user customization.
c
c  David Gay (dmg@bell-labs.com)
c  Eric Grosse (ehg@bell-labs.com)
c  Bell Laboratories
c  700 Mountain Avenue
c  Murray Hill, New Jersey 07974-0636
c  USA
c
c  References:
c
c  David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray
c    Hill, NJ. submitted to ACM Transactions on Mathematical Software,
c    August 1996.
c
c http://www.nsc.liu.se/~boein/ifip/kyoto/workshop-info/proceedings/einarsson
c    /d1mach.html  (THIS WEB SITE WORKED AS OF APR 2000)
c -------------------------------------------------------------------------

      REAL FUNCTION R1MACH (I)
c
c   R1MACH can be used to obtain machine-dependent parameters for
c   single precision numbers.  The results for various values of I are:
c
c   R1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
c   R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
c   R1MACH(3) = B**(-T), the smallest relative spacing.
c   R1MACH(4) = B**(1-T), the largest relative spacing.
c   R1MACH(5) = LOG10(B)
c
c   Assume single precision numbers are represented in the T-digit,
c   base-B form
c
c              sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
c
c   where 0 <= X(I) < B for I=1,...,T; 0 < X(1); and EMIN <= E <= EMAX.
c
c   The values of B, T, EMIN and EMAX are provided in I1MACH as follows:
c   I1MACH(10) = B, the base.
c   I1MACH(11) = T, the number of base-B digits.
c   I1MACH(12) = EMIN, the smallest exponent E.
c   I1MACH(13) = EMAX, the largest exponent E.
c
c***REFERENCES
c
c  P. Fox, A. Hall and N. Schryer, Framework for a portable library,
c     ACM Transactions on Mathematical Software 4, 177-188 (1978).
c
c  David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray
c     Hill, NJ. submitted to ACM Transactions on Mathematical Software,
c     August 1996.
c
c***REVISION HISTORY  (YYMMDD)
c   790101  DATE WRITTEN
c   960329  Modified for Fortran 90 (BE after suggestions by Eric Grosse)
c --------------------------------------------------------------------

      IMPLICIT NONE
      INTEGER :: I
      REAL :: B, X = 1.0

      B = RADIX(X)

      SELECT CASE (I)
        CASE (1)
          R1MACH = TINY(X)            ! smallest positive magnitude.
        CASE (2)
          R1MACH = HUGE(X)            ! largest magnitude.
        CASE (3)
          R1MACH = B**(-DIGITS(X))    ! smallest relative spacing.
        CASE (4)
          R1MACH = B**(1-DIGITS(X))   ! largest relative spacing.
        CASE (5)
          R1MACH = LOG10(B)
        CASE DEFAULT
          STOP 'R1MACH -- input argument out of bounds'
      END SELECT

      RETURN
      END FUNCTION R1MACH
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c ---------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION D1MACH (I)
c
c   D1MACH can be used to obtain machine-dependent parameters for
c   double precision numbers.  The results for various values of I are:
c
c   D1MACH(1) = B**(EMIN-1), the smallest positive magnitude.
c   D1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
c   D1MACH(3) = B**(-T), the smallest relative spacing.
c   D1MACH(4) = B**(1-T), the largest relative spacing.
c   D1MACH(5) = LOG10(B)
c
c   Assume double precision numbers are represented in the T-digit,
c   base-B form
c
c        sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
c
c   where 0 <= X(I) < B for I=1,...,T; 0 < X(1); and EMIN <= E <= EMAX.
c
c   The values of B, T, EMIN and EMAX are provided in I1MACH as follows:
c   I1MACH(10) = B, the base.
c   I1MACH(11) = T, the number of base-B digits.
c   I1MACH(12) = EMIN, the smallest exponent E.
c   I1MACH(13) = EMAX, the largest exponent E.
c
c***REFERENCES
c
c  P. Fox, A. Hall and N. Schryer, Framework for a portable library,
c     ACM Transactions on Mathematical Software 4, 177-188 (1978).
c
c  David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray
c    Hill, NJ. submitted to ACM Transactions on Mathematical Software,
c    August 1996.
c
c***REVISION HISTORY  (YYMMDD)
c   790101  DATE WRITTEN
c   960329  Modified for Fortran 90 (BE after suggestions by Eric Grosse)
c --------------------------------------------------------------------

      IMPLICIT NONE
      INTEGER :: I
      DOUBLE PRECISION :: B, X = 1.D0

      B = RADIX(X)

      SELECT CASE (I)
        CASE (1)
          D1MACH = TINY(X)            ! smallest positive magnitude.
        CASE (2)
          D1MACH = HUGE(X)            ! largest magnitude.
        CASE (3)
          D1MACH = B**(-DIGITS(X))    ! smallest relative spacing.
        CASE (4)
          D1MACH = B**(1-DIGITS(X))   ! largest relative spacing.
        CASE (5)
          D1MACH = LOG10(B)
        CASE DEFAULT
          STOP 'D1MACH -- input arg out of bounds'
      END SELECT

      RETURN
      END FUNCTION D1MACH
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

c ---------------------------------------------------------------------
      INTEGER FUNCTION I1MACH (I)
c
c   I1MACH can be used to obtain machine-dependent parameters for the
c   local machine environment.  The results for various values of I are:
c
c   I/O unit numbers (**MAY REQUIRE USER CUSTOMIZATION**):
c     I1MACH( 1) = the standard input unit.
c     I1MACH( 2) = the standard output unit.
c     I1MACH( 3) = the standard punch unit (obsolete, will cause error)
c     I1MACH( 4) = the standard error message unit.
c                  (the error message unit is usually 0 in UNIX systems)
c
c   Words:
c     I1MACH( 5) = the number of bits per integer storage unit.
c     I1MACH( 6) = the number of characters per integer storage unit.
c                  (obsolete, will cause an error)
c
c   Integers:
c     assume integers are represented in the S-digit, base-A form
c
c          sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
c
c     where 0 <= X(I) < A for I=0,...,S-1.
c
c     I1MACH( 7) = A, the base.
c     I1MACH( 8) = S, the number of base-A digits.
c     I1MACH( 9) = A**S - 1, the largest magnitude.
c
c   Floating-Point Numbers:
c     Assume floating-point numbers are represented in the T-digit,
c     base-B form
c                sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
c
c     where 0 <= X(I) .LT. B for I=1,...,T; 0 < X(1); and EMIN <= E <= EMAX.
c
c     I1MACH(10) = B, the base.
c
c   Single-Precision:
c     I1MACH(11) = T, the number of base-B digits.
c     I1MACH(12) = EMIN, the smallest exponent E.
c     I1MACH(13) = EMAX, the largest exponent E.
c
c   Double-Precision:
c     I1MACH(14) = T, the number of base-B digits.
c     I1MACH(15) = EMIN, the smallest exponent E.
c     I1MACH(16) = EMAX, the largest exponent E.
c
c***REFERENCES
c
c  P. Fox, A. Hall and N. Schryer, Framework for a portable library,
c     ACM Transactions on Mathematical Software 4, 177-188 (1978).
c
c  David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray
c    Hill, NJ. submitted to ACM Transactions on Mathematical Software,
c    August 1996.
c
c***REVISION HISTORY  (YYMMDD)
c   750101  DATE WRITTEN
c   960411  Modified for Fortran 90 (BE after suggestions by Eric Grosse)
c --------------------------------------------------------------------

      IMPLICIT NONE
      INTEGER :: I
      REAL :: X_single  = 1.0
      DOUBLE PRECISION :: X_double = 1.D0

      SELECT CASE (I)
        CASE (1)
          I1MACH = 5 ! Input unit
        CASE (2)
          I1MACH = 6 ! Output unit
        CASE (3)
          STOP 'I1MACH: input arg = 3 is obsolete'
        CASE (4)
          I1MACH = 0 ! Error message unit
        CASE (5)
          I1MACH = BIT_SIZE(I)
        CASE (6)
          STOP 'I1MACH: input arg = 6 is obsolete'
        CASE (7)
          I1MACH = RADIX(1)
        CASE (8)
          I1MACH = BIT_SIZE(I) - 1
        CASE (9)
          I1MACH = HUGE(1)
        CASE (10)
          I1MACH = RADIX(X_single)
        CASE (11)
          I1MACH = DIGITS(X_single)
        CASE (12)
          I1MACH = MINEXPONENT(X_single)
        CASE (13)
          I1MACH = MAXEXPONENT(X_single)
        CASE (14)
          I1MACH = DIGITS(X_double)
        CASE (15)
          I1MACH = MINEXPONENT(X_double)
        CASE (16)
          I1MACH = MAXEXPONENT(X_double)
        CASE DEFAULT
          STOP 'I1MACH: input argument out of bounds'
      END SELECT

      RETURN
      END FUNCTION I1MACH


! { dg-do run }
program tiny2
  real(4) x4
  real(8) x8
  x4 = tiny(x4)
  x8 = tiny(x8)
  if (minexponent(x4) /= exponent(x4)) STOP 1
  if (minexponent(x8) /= exponent(x8)) STOP 2
end program tiny2


! Copyright (C) 2015-2017, Simone Marsili
! All rights reserved.
! License: BSD 3 clause

module random
  use kinds
  implicit none
  private
  public :: random_initialize
  public :: random_data

  interface random_data
     module procedure random_data_1d
     module procedure random_data_2d
  end interface random_data

contains

  subroutine random_initialize(rseed, pid)
    ! Random Numbers In Scientific Computing: An Introduction by Katzgrabber
    implicit none
    integer, intent(in) :: rseed
    integer, intent(in) :: pid
    integer              :: i, n, seedgen, clock
    integer, allocatable :: seed(:)
    real(kflt)           :: rnd

    call random_seed(size = n)
    allocate(seed(n))
    if (rseed == 0) then
       call system_clock(clock)
    else
       clock = rseed
    end if
    seedgen = abs(mod((clock * 181) * ((pid - 83) * 359), 104729))
    seed = seedgen + 37 * [(i - 1, i = 1, n)]
    call random_seed(PUT = seed)
    deallocate(seed)
    ! well discard the first one
    call random_number(rnd)

  end subroutine random_initialize

  subroutine random_data_1d(nc, data)
    integer, intent(in)    :: nc
    integer, intent(inout) :: data(:)
    integer    :: iv, ic
    real(kflt) :: rnd

    do iv = 1, size(data)
       call random_number(rnd)
       ic = int(rnd * nc) + 1
       data(iv) = ic
    end do

  end subroutine random_data_1d

  subroutine random_data_2d(nc, data)
    integer, intent(in)    :: nc
    integer, intent(inout) :: data(:, :)
    integer :: data_shape(2)
    integer    :: nr
    integer    :: iv, ic, ir
    real(kflt) :: rnd

    data_shape = shape(data)
    nr = data_shape(2)
    do ir = 1, nr
       call random_data_1d(nc, data(:, ir))
    end do

  end subroutine random_data_2d

end module random


      subroutine   furgps(
     i                    chezch)
c
c     + + + PURPOSE + + +
c     This subroutine calculates the coefficient and exponent for equation
c     relating flow rate to a power function of flow area.
c
c     Called from FURROW
c     Author(s): Eugene R. Kottwitz.
c     Reference in User Guide: Chapter 12
c
c     Changes:
c          1) Added local variables TMPVR1-7 to eliminate repeated & expensive
c             calculations, especially in "100" & "200" loops.  With test
c             files, the "100" loop was executed 4-9 times before convergence.
c          2) Restructured to eliminate a GOTO within an IF-ELSE_ENDIF
c             structure, which pointed outside the structure.
c          3) Added counter II to "100" loop to terminate loop if it doesn't
c             converge within 20 iterations.
c
c     Version: This module recoded from WEPP Version 93.06.
c     Date recoded: 06/17/93 - 06/18/93.
c                   06/30/93 - 07/01/93.
c     Recoded by: Charles R. Meyer.
c
c     + + + PARAMETERS + + +
      include 'pmxcrp.inc'
      include 'pmxhil.inc'
      include 'pmxnsl.inc'
      include 'pmxpln.inc'
      include 'pmxres.inc'
      include 'pmxsrg.inc'
      include 'pmxtil.inc'
      include 'pmxtls.inc'
      include 'pntype.inc'
      include 'pxstep.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      real      chezch
c
c     + + + ARGUMENT DEFINITIONS + + +
c     chezch - Chezy friction coefficient (m**(0.5)/s)
c
c     + + + COMMON BLOCKS + + +
      include 'ccrpout.inc'
c       read: rh(mxplan)
c
      include 'ccrpprm.inc'
c       read: rw(mxcrop,mxplan)
c
      include 'cends4.inc'
c       read: rspace(mxplan)
c
      include 'ciraflo.inc'
c     modify: aqcnst,aqexp
c
      include 'cirfur2.inc'
c       read: irslp,qspply(mxsrg),surge
c     modify: srg
c
      include 'cirriga.inc'
c       read; noirr
c
      include 'cstruc.inc'
c       read: iplane
c
c     + + + LOCAL VARIABLES + + +
      integer   i,ii,nsteps
      real      area,deltaa,denom,flodep,flowd1,flowd2,flowr,
     1          flowr2,irsum1,irsum2,irsum3,irsum4,irsum5,natlna,natlnq,
     1          topwid,wperim
      real      tmpvr1,tmpvr2,tmpvr3,tmpvr4,tmpvr5,tmpvr6,tmpvr7
c
c     + + + LOCAL DEFINITIONS + + +
c     i      - do loop counter
c     ii     - counter on convergence loops
c     nsteps - number of flow area increments
c     area   - actual flow area based on the Chezy equation (m**2)
c     deltaa - flow area increment (m**2)
c     denom  - coefficient used as a denominator in calculating the
c              furrow geometry parameters (m**12/s**2)
c     flodep - flow depth (m)
c     flowd1 - current estimate of flow depth at the maximum flow rate,
c              used in a Newton-Raphson solution (m)
c     flowd2 - next estimate of flow depth at the maximum flow rate,
c              used in a Newton-Raphson solution (m)
c     flowr  - flow rate (m**3/s)
c     flowr2 - flowr*flowr (m**6/s**2)
c     irsum1 - summation of the square of flow rates (m**6/2**2)
c     irsum2 - summation of (the square of flow rates)*natlnt
c              (m**6/s**2)
c     irsum3 - summation of (the square of flow rates)*natlnt**2
c              (m**6/2**2)
c     irsum4 - summation of (the square of flow rates)*natlni
c              (m**6/2**2)
c     irsum5 - summation of (the square of flow rates)*natlnt*natlni
c              (m**6/2**2)
c     natlna - natural logarithm of flow area
c     natlnq - natural logarithm of flow rate
c     topwid - width of water surface (m)
c     wperim - wetted perimeter (m)
c
c     + + + DATA INITIALIZATIONS + + +
      data      nsteps/50/
c
c     + + + END SPECIFICATIONS + + +
c
c     Find the maximum of furrow supply rates
c
      flowr = qspply(1)
      if(noirr.eq.2 .and. surge.ge.2)then
        do 10 srg = 2, surge
          flowr = max(flowr,qspply(srg))
   10   continue
      endif
c
c     Determine flow depth corresponding to maximum furrow supply rate
c
      flowd2 = 0.5*rh(iplane)
      tmpvr1 = 2.0*sqrt(1.0+sidslp**2)
      tmpvr2 = flowr/chezch
      tmpvr4 = 2.0*sidslp
c
c      *** Begin L0 Loop ***
      ii = 0
  100 continue
        flowd1 = flowd2
        area = (botwid+sidslp*flowd1)*flowd1
        topwid = botwid+flowd1*tmpvr4
        wperim = botwid+flowd1*tmpvr1
c        Original Code:
c       flowd2 = flowd1-(wperim-(flowr*wperim/chezch)**2/irslp/
c    1           area**3)/(3.*topwid*wperim/area-2.*sqrt(1.+sidslp**2))
        flowd2 = flowd1-(wperim-(wperim*tmpvr2)**2/(irslp*area**3))/
     1           (3.0*topwid*wperim/area-tmpvr1)
        ii = ii + 1
c
c      *** End L0 Loop ***
      if(abs(flowd2-flowd1).gt.0.000001 .and. ii.lt.20) goto 100
c      ---- caution to user
      if(ii.ge.20) then
        write (6,*) ' FURGPS: Calculations suspended after 20',
     1             ' iterations.'
        write (6,*) ' Calculations DID NOT CONVERGE.'
      endif
c
c   NOTE:  When executing above loop and printing a counter with
c          test data sets, loop executes 4-9 times before converging.
c          The "effective duration" and point of maximum soil loss
c          seem to be REALLY SENSITIVE to the order of calculations
c          in the equation above.  Perhaps some double precision
c          calculations are in order? -- CRM -- 6/30/93.
c
c
      area = (botwid+sidslp*flowd2)*flowd2
c
c     Determine values for functions of flow rate and area
c
      natlnq = log(flowr)
      natlna = log(area)
c
c     Calculate summations
c
c      Original Code:
c     flowr2 = flowr**2
c     irsum1 = flowr2
c     irsum2 = flowr2*natlna
c     irsum3 = flowr2*natlna**2
c     irsum4 = flowr2*natlnq
c     irsum5 = flowr2*natlna*natlnq
c
      irsum1 = flowr**2
      irsum2 = irsum1*natlna
      irsum3 = irsum2*natlna
      irsum4 = irsum1*natlnq
      irsum5 = irsum2*natlnq
c
c     Determine flow area increment (deltaa)
c
      deltaa = area/float(nsteps)
      area = 0.0
c
      tmpvr3 = botwid**2
      tmpvr5 = 4.0*sidslp
      tmpvr6 = irslp/wperim
c
c     Calculation loop
c
      do 200  i = 1, nsteps-1
c
c       Increment flow area
c
        area = area+deltaa
c
c       Calculate flow depth, wetted perimeter, and flow rate
c       corresponding to flow area
c
c        Original Code:
c       flodep = (sqrt(botwid**2+4.*sidslp*area)-botwid)/2./sidslp
c       wperim = botwid+2.*flodep*sqrt(1.+sidslp**2)
c       flowr = chezch*sqrt(irslp*area**3/wperim)
        flodep = (sqrt(tmpvr3+tmpvr5*area)-botwid)/tmpvr4
        wperim = botwid+flodep*tmpvr1
c
c        ---- (WEPP Equation 12.9, using area/wperim in place of
c             hydraulic radius)
        flowr = chezch*sqrt(tmpvr6*area**3)
c
c       Determine values functions of flowr and area
c
        natlnq = log(flowr)
        natlna = log(area)
        flowr2 = flowr**2
c
c       Perform summations
c
c        Original Code:
c       irsum1 = irsum1+flowr2
c       irsum2 = irsum2+flowr2*natlna
c       irsum3 = irsum3+flowr2*natlna*natlna
c       irsum4 = irsum4+flowr2*natlnq
c       irsum5 = irsum5+flowr2*natlna*natlnq
c
        tmpvr7 = flowr2*natlna
        irsum1 = irsum1+flowr2
        irsum2 = irsum2+tmpvr7
        irsum3 = irsum3+tmpvr7*natlna
        irsum4 = irsum4+flowr2*natlnq
        irsum5 = irsum5+tmpvr7*natlnq
  200 continue
c
c     Determine constant and exponent relating flow area to flow rate
c
      denom = irsum2**2-irsum1*irsum3
      aqexp = (irsum2*irsum4-irsum1*irsum5)/denom
      aqcnst = exp((irsum2*irsum5-irsum3*irsum4)/denom)
c
      return
      end


  subroutine checkMomentum(gsmObj, results, conserved)

! ======================================================================
!
! Performs the conservation of momentum check within GSM
!
!
! Written by CMJ, XCP-3 (03/2019); parsed from original "gsm03.f90" routine
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use gsm_params, only: hlf, one, two

    implicit none
    class(GSM),        intent(inout) :: gsmObj
    class(GSMResults), intent(in   ) :: results
    logical,           intent(  out) :: conserved

    real(real64)   :: maxMomentum, totalSystemMomentum, totParticleMomentum

    ! For per nucleon check:
    real(real64)   :: approxNumNucleons

    ! For system total check:
    integer(int32) :: pIndx
    real(real64)   :: pxTot, pyTot, pzTot, progenyMom

! ======================================================================

    ! Flag default value:
    conserved = .TRUE.

    ! Obtain total system momentum:
    totalSystemMomentum = sqrt((results%initialProj%kinEnergy + &
         & two * results%initialProj%restMass) * results%initialProj%kinEnergy)

    if ( .not.gsmObj%options%conserveTotalMomentum ) then

       ! Obtain an expected 'average' momentum per nucleon in the system
       approxNumNucleons = results%initialTarg%numBaryons + &
            & max(results%initialProj%restMass, dble(results%initialProj%numBaryons))
       maxMomentum = results%targRes%numBaryons * &
            & totalSystemMomentum/(approxNumNucleons) + hlf

       ! Total Momenta of Recoiled Particle (cannot exceed projectile's momentum)
       ! NOTE: The momentum check SHOULD include the projectile residual's momentum
       !       and ALL PROGENY as well, HOWEVER this is NOT advisable due to the
       !       renormalization routine!
       totParticleMomentum = results%targRes%totalLinearMomentum()
       ! totParticleMomentum = sqrt( (results%targRes%linearMom(1) + results%projRes%linearMom(1) )**2 + &
       !      & (results%targRes%linearMom(2) + results%projRes%linearMom(2) )**2 + &
       !      (results%targRes%linearMom(3) + results%projRes%linearMom(3) )**2 )

    else

       ! Check for total momentum conservation:
       maxMomentum = totalSystemMomentum + hlf
       pxTot = 0
       pyTot = 0
       pzTot = 0
       do pIndx = 1, results%numProgeny
          progenyMom = sqrt( results%progenyBnk(pIndx)%kinEnergy * &
               & (results%progenyBnk(pIndx)%kinEnergy + &
               & two * results%progenyBnk(pIndx)%restMass ) )
          pxTot = pxTot + progenyMom * results%progenyBnk(pIndx)%sinTheta * &
               & cos(results%progenyBnk(pIndx)%phi )
          pyTot = pyTot + progenyMom * results%progenyBnk(pIndx)%sinTheta * &
               & sin(results%progenyBnk(pIndx)%phi )
          pzTot = pzTot + progenyMom * results%progenyBnk(pIndx)%cosTheta
       end do
       pxTot = pxTot + results%targRes%linearMom(1) + results%projRes%linearMom(1)
       pyTot = pyTot + results%targRes%linearMom(2) + results%projRes%linearMom(2)
       pzTot = pzTot + results%targRes%linearMom(3) + results%projRes%linearMom(3)
       totParticleMomentum = sqrt( pxTot**2 + pytot**2 + pzTot**2 )

    end if

    ! Check if the momentum is greater than that allowed in the check:
    ! NOTE: If conserving on average, ensure NOT in anti-lab system, otherwise
    !       check for conservation.
    ! NOTE: For checking on total, anti-lab system does NOT need accounted for.
    if ( totParticleMomentum > maxMomentum .and. &
         & (results%initialProj%system /= antilabSystem .or. &
         & gsmObj%options%conserveTotalMomentum) ) then
       conserved = .FALSE.
    endif

    return
! ======================================================================
  end subroutine checkMomentum


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      subroutine Cal_F_dFdx_dFdy(r,theta,omega,
     &                                 c_mat_type,
     &                                 F,dFdx,dFdy)

c     This function calculates determinant of Jacobian matrix.
      use Global_Elem_Area
      implicit none

      double precision,intent(in)::r,theta,omega
      integer,intent(in)::c_mat_type
      double precision,intent(out)::dFdx(4),dFdy(4),F(4)

      double precision fac,st2,ct2,s3t2,c3t2,st,ct,new_sin,new_cos,
     &                 r2,c_theta,dF1dx1,dF1dx2,dF2dx1,dF2dx2,
     &                 dF3dx1,dF3dx2,dF4dx1,dF4dx2,
     &                 dx1dx,dx2dx,dx1dy,dx2dy

      c_theta = theta
      if (r.ne.0.0D0) then
          r2 = sqrt(r)
      else
          r2 = sqrt(Ave_Elem_Area)*0.1D-4
	      c_theta = 0.0d0
      end if

      ! ------------------------------
      !         ISO material.
      ! ------------------------------
      if (c_mat_type ==1 ) then
	      fac = 0.5D0/r2
	      st2 = sin(c_theta/2.0D0)
	      ct2 = cos(c_theta/2.0D0)
	      s3t2= sin(1.5D0*c_theta)
	      c3t2= cos(1.5D0*c_theta)
	      st  = sin(c_theta)
	      ct  = cos(c_theta)

	      new_sin=sin(-3.0D0*c_theta/2.0D0)
	      new_cos=cos(-3.0D0*c_theta/2.0D0)

          !Tip enrichment functions F.
		  F(1) = r2*st2
		  F(2) = r2*ct2
		  F(3) = r2*st2*st
		  F(4) = r2*ct2*st

	      !dF1dx1 and dF1dx2
	      dF1dx1 = -fac*st2
	      dF1dx2 =  fac*ct2
	      !dF2dx1 and dF2dx2
	      dF2dx1 =  dF1dx2
	      dF2dx2 = -dF1dx1
	      !dF3dx1 and dF3dx2
	      dF3dx1 = -fac*s3t2*st
          dF3dx2 =  fac*(st2 + s3t2*ct)
	      !dF4dx1 and dF4dx2
	      dF4dx1 = -fac*c3t2*st
	      dF4dx2 =  fac*(ct2 + c3t2*ct)

	      !dx1dx
	      dx1dx =  cos(omega)
	      !dx2dx
	      dx2dx = -sin(omega)
	      !dx1dy
	      dx1dy =  sin(omega)
	      !dx2dy
	      dx2dy =  cos(omega)

	      !dFdx and dFdy
	      dFdx(1) = dF1dx1*dx1dx + dF1dx2*dx2dx
	      dFdy(1) = dF1dx1*dx1dy + dF1dx2*dx2dy
	      dFdx(2) = dF2dx1*dx1dx + dF2dx2*dx2dx
	      dFdy(2) = dF2dx1*dx1dy + dF2dx2*dx2dy
          dFdx(3) = dF3dx1*dx1dx + dF3dx2*dx2dx
	      dFdy(3) = dF3dx1*dx1dy + dF3dx2*dx2dy
          dFdx(4) = dF4dx1*dx1dx + dF4dx2*dx2dx
	      dFdy(4) = dF4dx1*dx1dy + dF4dx2*dx2dy
      ! ------------------------------
      !       Orthotropic material.
      ! ------------------------------
      elseif (c_mat_type ==2 .or. c_mat_type ==3) then

      end if

      return
      end SUBROUTINE Cal_F_dFdx_dFdy


C
      SUBROUTINE MOLFYS(T,XKH2,XKH2P,DEH2,DEH2P,deh2nodis,deh2pnodis)
C
C        THIS ROUTINE GIVES DISSOCIATION CONSTANTS XKH2 (=N(H I)*N(H I)/(NH2))
C        AND XKH2P (=N(H I)*N(H II)/N(H2+)), EXPRESSED IN NUMBER PER CM3 AND
C        THE SUM OF ROTATION AND VIBRATION ENERGIES, DEH2 AND
C        DEH2P FOR H2 AND H2+, RESPECTIVELY (EXPRESSED IN ERGS PER MOLECULE)
C        THE DATA ARE FROM VARDYA, M.N.R.A.S. 129, 205 (1965) AND EARLIER
C        REFERENCES. THE DISSOCIATION CONSTANT FOR H2 IS FROM TSUJI,
C        ASTRON. ASTROPHYS. 1973.
C
      DIMENSION A1(5),A2(4),B1(5),B2(5),TE(5)
      DATA A1/12.739,-5.1172,1.2572E-1,-1.4149E-2,6.3021E-4/,
     *A2/11.20699 ,-2.794276 ,-0.079196   ,0.024790   /,
     *B1/2.6757,-1.4772,0.60602,-0.12427,0.009750/,
     *B2/2.9216,-2.0036,1.7231,-0.82685,0.15253/
      TEX=5040./T
      TE(1)=1.
      DO1 K=1,4
    1 TE(K+1)=TE(K)*TEX
      XKH2=0.
      XKH2P=0.
      DEH2=0.
      DEH2P=0.
      DO2 K=1,4
      XKH2=A1(K)*TE(K)+XKH2
      XKH2P=A2(K)*TE(K)+XKH2P
      DEH2=B1(K)*TE(K)+DEH2
    2 DEH2P=B2(K)*TE(K)+DEH2P
      XKH2=A1(5)*TE(5)+XKH2
      DEH2nodis=(B1(5)*TE(5)+DEH2)*8.617E-5*T
      DEH2Pnodis=(B2(5)*TE(5)+DEH2P)*8.617E-5*T
      DEH2=deh2nodis-4.476
      DEH2P=deh2pnodis*T-2.648
      XKH2=10.**XKH2
      XKH2P=10.**XKH2P
      RETURN
      END


SUBROUTINE formaa(vmfl,rmat,daatd)
!
! This subroutine modifies the dee matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::vmfl(:),rmat(:,:)
 REAL(iwp),INTENT(OUT)::daatd(:,:)
 REAL(iwp)::flowt(1,4),flowa(4,1)
 flowt(1,:)=vmfl
 flowa(:,1)=vmfl
 daatd=MATMUL(MATMUL(MATMUL(rmat,flowa),flowt),rmat)
RETURN
END SUBROUTINE formaa


! =============================================================================
!                       MPIC plume test case
!
! This module enerates a spherical plume of approximately uniform liquid-wate
! buoyancy and specific humidity touching the lower surface, together with a
! stratified zone aloft.
! =============================================================================
module moist_3d
    use physics, only : write_physical_quantities, &
                        height_c, q_0, gravity, theta_0, L_v, c_p
    use constants
    use netcdf_writer
    implicit none

    private

    double precision, allocatable :: buoyg(:, :, :), humg(:, :, :)

    integer :: buo_id, hum_id

    type plume_type
        double precision :: H                   ! Relative humidity H (as a fraction < 1) at z_b
        double precision :: z_c                 ! Lifting condensation level
        double precision :: mu                  ! q_bg/q_pl where q_bg is the specific humidity fraction
                                                ! in the mixed layer outside of the plume (note, this should be
                                                ! between H and 1; a value < H would put z_c below z_b)
        double precision :: z_d                 ! Level of dry neutral stratification z_n
        double precision :: z_m                 ! Level of moist neutral stratification (cloud top) z_t
        double precision :: r_plume             ! Radius of the plume, R (must be < z_b/2)
        double precision :: e_values(3)         ! To create asymmetry, we vary the buoyancy in the plume
                                                ! according to  b = b_pl*[1 + (e1*x*y+e2*x*z+e3*yz)/R^2].
    end type plume_type

    type(plume_type) :: moist

    public :: moist_init, &
              moist

    contains

        subroutine moist_init(ncid, dimids, nx, ny, nz, origin, dx)
            integer,          intent(inout) :: ncid
            integer,          intent(in)    :: dimids(:)
            integer,          intent(in)    :: nx, ny, nz
            double precision, intent(in)    :: origin(3)
            double precision, intent(in)    :: dx(3)
            integer                         :: i, j, k
            double precision                :: rpos1, rpos2, rpos3, r2, pos(3), centre(3), extent(3)
            double precision                :: b_pl, dbdz, z_b, h_bg, h_pl, radsq

            call define_netcdf_dataset(ncid=ncid,                           &
                                       name='buoyancy',                     &
                                       long_name='buoyancy',                &
                                       std_name='',                         &
                                       unit='m/s^2',                        &
                                       dtype=NF90_DOUBLE,                   &
                                       dimids=dimids,                       &
                                       varid=buo_id)

            call define_netcdf_dataset(ncid=ncid,                           &
                                       name='humidity',                     &
                                       long_name='humidity',                &
                                       std_name='',                         &
                                       unit='-',                            &
                                       dtype=NF90_DOUBLE,                   &
                                       dimids=dimids,                       &
                                       varid=hum_id)

            call close_definition(ncid)

            if (moist%H .gt. one) then
                write(*,*) 'Error: Relative humidity fraction must be < 1.'
                stop
            endif

            h_pl = q_0 * dexp(- moist%z_c / height_c)

            write(*,"('Humidity inside the plume is ',f6.3)") h_pl

            if ((moist%mu > one) .or. (moist%mu <= moist%H)) then
                write(*,'("Error: mu must be between H and 1. The selected value is ", f6.3)') moist%mu
                stop
            endif

            h_bg = moist%mu * h_pl

            write(*,"('Background humidity is ',f6.3)") h_bg

            z_b = height_c * dlog(q_0 * moist%H / h_bg)

            write(*,"('Base of mixed layer is ',f12.3)") z_b

            dbdz = (gravity * L_v / (c_p * theta_0)) &
                 * (h_pl - q_0 * dexp(-moist%z_m / height_c)) / (moist%z_m - moist%z_d)

            write(*,"('The buoyancy frequency in the stratified zone is ',f12.3)") dsqrt(dbdz)

            !Also obtain the plume liquid-water buoyancy (using also z_b):
            b_pl = dbdz * (moist%z_d - z_b)
            write(*,'(a,f7.5)') '  The plume liquid water buoyancy b_pl = ', b_pl
            write(*,'(a,f7.5)') '  corresponding to (theta_l-theta_0)/theta_0 = ', b_pl * gravity

            if (two * moist%r_plume > z_b) then
                write(*,"('Error: Plume radius is too big. At most it can be ',f7.5)") f12 * z_b
                stop
            endif

            radsq = moist%r_plume ** 2

            moist%e_values = moist%e_values / radsq

            if (origin(3) > zero) then
                write(*, *) "The vertical origin must be zero."
                stop
            endif

            extent = dx * dble((/nx, ny, nz/))

            write(*,*) "Box layout:"
            write(*,*) "z_max           =", extent(3)
            write(*,*) "z_m             =", moist%z_m
            write(*,*) "z_d             =", moist%z_d
            write(*,*) "z_c             =", moist%z_c
            write(*,*) "z_b             =", z_b
            write(*,*) "zmin            =", origin(3)
            write(*,*) "top of plume    =", two * moist%r_plume
            write(*,*) "bottom of plume =", zero

            allocate(buoyg(0:nz, 0:ny-1, 0:nx-1))
            allocate(humg(0:nz, 0:ny-1, 0:nx-1))

            buoyg = zero
            humg = zero

            centre = f12 * (two * origin + extent)

            do i = 0, nx-1
                do j = 0, ny-1
                    do k = 0, nz

                        pos = origin + dx * dble((/i, j, k/))

                        rpos1 = (pos(1) - centre(1))
                        rpos2 = (pos(2) - centre(2))
                        rpos3 = (pos(3) - moist%r_plume)
                        r2 = rpos1 ** 2 + rpos2 ** 2 + rpos3 ** 2

                        if (r2 <= radsq) then
                            buoyg(k, j, i) = b_pl * (one + moist%e_values(1) * rpos1 * rpos2  &
                                                         + moist%e_values(2) * rpos1 * rpos3  &
                                                         + moist%e_values(3) * rpos2 * rpos3)
                            humg(k, j, i) = h_pl
                        else
                            if (pos(3) < z_b) then
                                ! Mixed layer:
                                buoyg(k, j, i) = zero
                                humg(k, j, i) = h_bg
                            else
                                ! Stratified layer
                                buoyg(k, j, i)= dbdz * (pos(3) - z_b)
                                humg(k, j, i) = q_0 * moist%H * dexp(- pos(3) / height_c)
                            endif
                        endif
                    enddo
                enddo
            enddo

            call write_netcdf_dataset(ncid, buo_id, buoyg)
            call write_netcdf_dataset(ncid, hum_id, humg)

            call write_physical_quantities(ncid)

            deallocate(buoyg)
            deallocate(humg)

        end subroutine moist_init

end module moist_3d


      SUBROUTINE BETRNS (TBE,GG,KFLAG,ELID)
C     &    ENTRY BETRND (TBD,GD,KFLAG,ELID)
C
C*****
C     SUBROUTINE WHICH CALCULATES THE TBE TRANSFORMATION
C     MATRIX WHICH RELATES THE ELEMENT TO THE BASIC C.S.
C
C     GG(9) OR GD(9) IS A 9X1 ARRAY WHICH STORES THE GRID PT. COORD.
C     X(G1),Y(G1),Z(G1),X(G2),Y(G2),Z(G2),X(G3),Y(G3),Z(G3)
C     GG(1),GG(2),GG(3),GG(4),GG(5),GG(6),GG(7),GG(8),GG(9), OR
C     GD(1),GD(2),GD(3),GD(4),GD(5),GD(6),GD(7),GD(8),GD(9)
C
C     KFLAG = 0, TBE (OR TBD) IS OUTPUT WITHOUT TRANSPOSING
C           = 1, TBE (OR TBD) IS OUTPUT AFTER IT IS TRANSPOSED
C*****
C
      INTEGER          ELID
      REAL             GG(9),TBE(9),RSSTR(3),RSTR(3),R12(3),RV(3),LEN
      DOUBLE PRECISION GD(9),TBD(9),DSSTR(3),DSTR(3),D12(3),DV(3),
     1                 DTEMP,LED
C
C     SINGLE PRECISION VERSION
C
C*****
C     CALCULATE APPROPRIATE LENGTH QUANTITIES
C*****
      LEN = SQRT((GG(4)-GG(1))**2 + (GG(5)-GG(2))**2
     1          +(GG(6)-GG(3))**2)
      IF (LEN .EQ. 0.0) GO TO 40
C*****
C     CALCULATE APPROPRIATE VECTOR QUANTITIES
C*****
      R12(1) = (GG(4)-GG(1))/LEN
      R12(2) = (GG(5)-GG(2))/LEN
      R12(3) = (GG(6)-GG(3))/LEN
      RV(1)  = (GG(7)-GG(1))
      RV(2)  = (GG(8)-GG(2))
      RV(3)  = (GG(9)-GG(3))
C*****
C     CALCULATE ENTRIES INTO THE TRANSFORMATION MATRIX
C*****
      RSTR(1) = (R12(2)*RV(3) - R12(3)*RV(2))
      RSTR(2) = (R12(3)*RV(1) - R12(1)*RV(3))
      RSTR(3) = (R12(1)*RV(2) - R12(2)*RV(1))
C
      LEN = SQRT (RSTR(1)**2 + RSTR(2)**2 + RSTR(3)**2)
      IF (LEN .EQ. 0.0) GO TO 40
      DO 10 I=1,3
   10 RSTR(I) = RSTR(I)/LEN
C
      RSSTR(1)= (RSTR(2)*R12(3) - RSTR(3)*R12(2))
      RSSTR(2)= (RSTR(3)*R12(1) - RSTR(1)*R12(3))
      RSSTR(3)= (RSTR(1)*R12(2) - RSTR(2)*R12(1))
      TBE(1)  = R12(1)
      TBE(2)  = R12(2)
      TBE(3)  = R12(3)
      TBE(4)  = RSSTR(1)
      TBE(5)  = RSSTR(2)
      TBE(6)  = RSSTR(3)
      TBE(7)  = RSTR(1)
      TBE(8)  = RSTR(2)
      TBE(9)  = RSTR(3)
      IF (KFLAG .EQ. 0) GO TO 30
C*****
C     TRANSPOSE TBE(9) SINCE KFLAG.NE.ZERO
C*****
      TEMP   = TBE(2)
      TBE(2) = TBE(4)
      TBE(4) = TEMP
      TEMP   = TBE(3)
      TBE(3) = TBE(7)
      TBE(7) = TEMP
      TEMP   = TBE(6)
      TBE(6) = TBE(8)
      TBE(8) = TEMP
      GO TO 30
C
      ENTRY BETRND (TBD,GD,KFLAG,ELID)
C     ================================
C
C     DOUBLE PRECISION VERSION
C
C*****
C     CALCULATE APPROPRIATE LENGTH QUANTITIES
C*****
      LED = DSQRT((GD(4)-GD(1))**2 + (GD(5)-GD(2))**2
     1           +(GD(6)-GD(3))**2)
      IF (LED .EQ. 0.0D+0) GO TO 40
      D12(1) = (GD(4)-GD(1))/LED
      D12(2) = (GD(5)-GD(2))/LED
      D12(3) = (GD(6)-GD(3))/LED
      DV(1)  = (GD(7)-GD(1))
      DV(2)  = (GD(8)-GD(2))
      DV(3)  = (GD(9)-GD(3))
C*****
C     CALCULATE ENTRIES INTO THE TRANSFORMATION MATRIX
C*****
      DSTR(1) = (D12(2)*DV(3) - D12(3)*DV(2))
      DSTR(2) = (D12(3)*DV(1) - D12(1)*DV(3))
      DSTR(3) = (D12(1)*DV(2) - D12(2)*DV(1))
C
      LED = DSQRT(DSTR(1)**2 + DSTR(2)**2 + DSTR(3)**2)
      IF (LED .EQ. 0.0D+0) GO TO 40
      DO 20 I=1,3
   20 DSTR(I) = DSTR(I)/LED
C
      DSSTR(1)= (DSTR(2)*D12(3) - DSTR(3)*D12(2))
      DSSTR(2)= (DSTR(3)*D12(1) - DSTR(1)*D12(3))
      DSSTR(3)= (DSTR(1)*D12(2) - DSTR(2)*D12(1))
      TBD(1)  = D12(1)
      TBD(2)  = D12(2)
      TBD(3)  = D12(3)
      TBD(4)  = DSSTR(1)
      TBD(5)  = DSSTR(2)
      TBD(6)  = DSSTR(3)
      TBD(7)  = DSTR(1)
      TBD(8)  = DSTR(2)
      TBD(9)  = DSTR(3)
      IF (KFLAG .EQ. 0) GO TO 30
C*****
C     TRANSPOSE TBD(9) SINCE KFLAG.NE.ZERO
C*****
      DTEMP  = TBD(2)
      TBD(2) = TBD(4)
      TBD(4) = DTEMP
      DTEMP  = TBD(3)
      TBD(3) = TBD(7)
      TBD(7) = DTEMP
      DTEMP  = TBD(6)
      TBD(6) = TBD(8)
      TBD(8) = DTEMP
   30 RETURN
C*****
C     ZERO LENGTH ERROR, BAD GEOMETRY
C*****
   40 CALL MESAGE (-30,31,ELID)
      RETURN
      END


C$Procedure PCKE02 ( PCK, evaluate data record from type 2 segment )

      SUBROUTINE PCKE02 ( ET, RECORD, EULANG )

C$ Abstract
C
C     Evaluate a single PCK data record from a segment of type 2
C     (Chebyshev Polynomials, position only).
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     PCK
C
C$ Keywords
C
C     TRANSFORMATION
C     ROTATION
C
C$ Declarations

      DOUBLE PRECISION      ET
      DOUBLE PRECISION      RECORD   ( * )
      DOUBLE PRECISION      EULANG   ( 6 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     ET         I   Epoch.
C     RECORD     I   Data record.
C     EULANG     O   Euler angles and their derivatives.
C
C$ Detailed_Input
C
C     ET          is an epoch, at which the Euler angles are to
C                 be computed.
C
C     RECORD      is a data record which, when evaluated at epoch ET,
C                 will give the Euler angles of some body.
C
C$ Detailed_Output
C
C     EULANG       the Euler angles and their derivatives at
C                  time ET.
C
C$ Parameters
C
C      None.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C      None.
C
C$ Particulars
C
C     The exact format and structure of type 2 (Chebyshev polynomials,
C     position only) segments are described in the PCK Required Reading
C     file.
C
C     A type 2 segment contains three sets of Chebyshev coefficients,
C     one set each for the Euler angles phi, delta and psi.  PCKE02
C     calls the routine SPKE02 for each set to evalute the polynomial
C     AND its first derivative.
C
C$ Examples
C
C     The PCKEnn routines are almost always used in conjunction with
C     the corresponding PCKRnn routines, which read the records from
C     binary PCK files.
C
C     The data returned by the PCKRnn routine is in its rawest form,
C     taken directly from the segment.  As such, it will be meaningless
C     to a user unless he/she understands the structure of the data type
C     completely.  Given that understanding, however, the PCKRnn
C     routines might be used to examine raw segment data before
C     evaluating it with the PCKEnn routines.
C
C
C  Here we load a binary PCK files and use PCKE02 to get the
C  Euler angles.
C
C  C
C  C  Load binary PCK file.
C  C
C     CALL PCKLOF ('example.pck', HANDLE)
C
C
C  C  Get a segment applicable to a specified body and epoch.
C
C     CALL PCKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND )
C
C     IF ( FOUND ) THEN
C
C
C        Look at parts of the descriptor.
C
C        CALL DAFUS ( DESCR, ND, NI, DCD, ICD )
C        TYPE   = ICD( NT )
C        REF    = ICD( NR )
C
C        IF ( TYPE .EQ. 2 ) THEN
C
C           Read in Chebyshev coefficients from segment.
C
C           CALL PCKR02 ( HANDLE, DESCR, ET, RECORD )
C
C
C           Call evaluation routine to get Euler angles
C           phi, delta, w.
C
C           CALL PCKE02 ( ET, RECORD, EULANG )
C
C
C  The Euler angles and their derivatives are returned
C  in EULANG.
C
C$ Restrictions
C
C      None.
C
C$ Literature_References
C
C      None.
C
C$ Author_and_Institution
C
C      K. S. Zukor   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.1, 03-JAN-2014 (EDW)
C
C        Minor edits to Procedure; clean trailing whitespace.
C        Removed unneeded Revisions section.
C
C-     SPICELIB Version 1.1.0, 13-MAR-1995 (KSZ)
C
C         Added error handling.
C
C-     SPICELIB Version 1.0.0, 30-SEP-1994 (KSZ)
C
C-&

C$ Index_Entries
C
C     get Euler angles and their derivatives
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      TWOPI
      LOGICAL               RETURN

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'PCKE02' )
      END IF

C
C     Call evaluation routine to get Euler angles
C     phi, delta, w.
C
      CALL SPKE02 ( ET, RECORD, EULANG )

C
C     Mod the 3rd element of the state by TWOPI.
C     We do this because we've always done this.
C
      EULANG(3) = MOD ( EULANG(3), TWOPI() )

      CALL CHKOUT ( 'PCKE02' )

      RETURN
      END


      subroutine hydchn(flagc,q,sf,c1,z,wb,w,n,crsh,covsh,effsh)
c
c     + + + PURPOSE + + +
c
c     SR HYDCHN computes hydraulics in the channels.
c
c     Called from: SRS CHNRT, DCAP
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real c1, covsh, crsh, effsh, q, sf, w, n, wb, z
      integer flagc
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     c1    -
c     covsh -
c     crsh  -
c     effsh -
c     q     -
c     sf    -
c     w     -
c     n     -
c     wb    -
c     z     -
c     flagc -
c
c     + + + COMMON BLOCKS + + +
c
      include 'cchcon.inc'
c
c     + + + LOCAL VARIABLES + + +
c
      real nt, lc, mulsh, xlc(16), fglc(16), xxb(27), fhxb(27), a, ap,
     1    dif, glc, hxb, rcov, rsh, rstar, xb, xbn, xbo, y, v
      integer ifrus, itrat, m
c
c     + + + LOCAL DEFINITIONS + + +
c
c     nt       -
c     lc       -
c     mulsh    -
c     xlc(16)  -
c     fglc(16) -
c     xxb(27)  -
c     fhxb(27) -
c     a        -
c     ap       -
c     dif      -
c     glc      -
c     hxb      -
c     rcov     -
c     rsh      -
c     rstar    -
c     xb       -
c     xbn      -
c     xbo      -
c     y        -
c     v        -
c     ifrus    -
c     itrat    -
c     m        -
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     table
c
c     + + + DATA INITIALIZATIONS + + +
c
      data xlc /0.0, 0.01, 0.02, 0.04, 0.06, 0.08, 0.1, 0.12, 0.14,
     1    0.16, 0.18, 0.2, 0.22, 0.24, 0.26, 0.28/
c
      data fglc /100000.0, 32.91, 15.487, 7.307, 4.849, 3.713, 3.075,
     1    2.676, 2.408, 2.222, 2.089, 1.994, 1.928, 1.884, 1.858,
     1    1.84866/
c
      data xxb /0.0, 0.01, 0.02, 0.04, 0.06, 0.08, 0.1, 0.12, 0.14,
     1    0.16, 0.18, 0.2, 0.22, 0.24, 0.26, 0.28, 0.3, 0.32, 0.34,
     1    0.36, 0.38, 0.4, 0.42, 0.44, 0.46, 0.48, 0.5/
c
      data fhxb /0.0, .000474, .00154, .00509, .0104, .0177, 0.0269,
     1    .0384, .0524, .0693, .0897, .114, .1432, 0.1782, .2207, .2724,
     1    .3361, .4159, .5176, .6506, 0.8307, 1.0858, 1.4722, 2.1212,
     1    3.4264, 7.3566, 10000.0/
c
c     + + + END SPECIFICATIONS + + +
c
c
      if (flagc.eq.2) go to 20
      if (flagc.ge.3) go to 50
c
   10 continue
c
c     triangular section
c
      ap = (q*n/(1.49*sqrt(sf))) ** 0.375
      y = ap / (c1**0.375)
      w = 2.0 * y * z
      a = z * (y**2)
      nt = n
c
      go to 60
c
   20 continue
c
c     rectangular section
c
      if (wb.eq.0.0) go to 10
      ap = (q*n/(1.49*sqrt(sf))) ** 0.375
      w = wb
      hxb = (ap/w) ** (8.0/3.0)
c
      if (hxb.le.0.114) then
        xbo = 0.2
c
        do 30 m = 1, 25
          xbn = ((1.0-2.0*xbo)*hxb) ** 0.6
c         added check to guard against divide by zero 9-21-2004 jrf
            if (xbn.eq.0.0) xbn = 1.0e-10
            dif = abs((xbn-xbo)/xbn)
          if (dif.le.0.001) go to 40
          xbo = xbn
   30   continue
c
        if (m.ge.25) then
          write (3,1000)
        end if
c
   40   continue
c
        xb = xbn
      else
        ifrus = 4
        itrat = 27

c dcf Fix added to prevent program stop in
c     subroutine TABLE

        if (hxb.gt.9999.99) hxb = 9999.99

        call table(ifrus,itrat,xxb,fhxb,hxb,xb)
      end if
c
      y = w * xb / (1.0-2.0*xb)
      a = y * w
      nt = n
c
      go to 60
c
   50 continue
c
c     naturally eroded section
c
      ap = (q*nbarch/(1.49*sqrt(sf))) ** 0.375
      glc = ap * wtdh2o * sf / crsh
      if (glc.lt.1.84866) go to 70
      ifrus = 3
      itrat = 16
c
c dcf Fix to prevent program stop in subroutine TABLE
c     3-11-04
c
      if (glc.gt.99999.999) glc = 99999.999

      call table(ifrus,itrat,xlc,fglc,glc,lc)
c
      rstar = (-0.34707*(0.5-lc)**3) - (0.54213*(0.5-lc)**2) + (0.66383*
     1    (0.5-lc))
      w = (ap/rstar**0.625) * (0.73-1.46*lc)
      if (flagc.eq.4) go to 80
      hxb = (ap/w) ** (8.0/3.0)
      ifrus = 4
      itrat = 27
c
c dcf Fix to prevent program stop in
c     subroutine TABLE  3-11-04
c
      if (hxb.gt.9999.99) hxb = 9999.99

      call table(ifrus,itrat,xxb,fhxb,hxb,xb)
c
      y = w * xb / (1.0-2.0*xb)
      a = y * w
      nt = nbarch
c
   60 continue
c
c     computation of shear stress components
c
c     added check to guard against divide by zero 9-21-2004 jrf
c
      if (a.eq.0.0) a = 1.0e-10
        v = q / a
      rsh = (v*nbarch/(1.49*sqrt(sf))) ** (1.5)
      rcov = (v*(nt-nbarch)/(1.49*sqrt(sf))) ** (1.5)
      effsh = wtdh2o * rsh * sf
      mulsh = wtdh2o * rcov * sf
      if (mulsh.lt.covsh) go to 80
      n = nbarch
      nt = n
      if (flagc.eq.2) go to 20
      if (flagc.ge.3) go to 50
      go to 10
c
   70 continue
c
      if (wb.eq.0.0) go to 10
      go to 20
c
   80 continue
c
      return
c
 1000 format (/5x,'***** DID NOT CONVERGE IN CHANNEL RECTANGULAR ',
     1    'SECTION',/,11x,'SEE HYDCHN.FOR'//)
      end


!=================================================
! SUBROUTINES
!	FSNPA(we,sa,sb,xp,yp,zp,is,it)
!	SVESE(q,cm,bsv,idb,ls,nod2s)
!
!=================================================

module mod_subsrc

	implicit none

contains
!==========
subroutine FSNPA(we,sa,sb,xp,yp,zp,is,it)

	use prm_matrix
	use prm_var

	implicit none

	integer, intent(in) :: is, it
	real(8), intent(out) :: we(3), sa(3), sb(3), xp, yp, zp

	integer :: mu, mv, muu, mvv
	real(8) :: u1, u2, u3, v1, v2, v3, w1, w2, w3, uu, vv, ww

	mu = is
		if(is == ms) mu = ms - 1
	mv = it
		if(it == mt) mv = mt - 1

	muu = mu + 1
	mvv = mv + 1

	u1 = xtr(muu)     - xtr(mu)
	u2 = ytr(muu,mv ) - ytr(mu,mv)
	u3 = ztr(muu,mv ) - ztr(mu,mv)
	v2 = ytr(mu ,mvv) - ytr(mu,mv)
	v3 = ztr(mu ,mvv) - ztr(mu,mv)

	w1 = u2*v3 - u3*v2
	w2 =       - u1*v3
	w3 = u1*v2

	v1 = w2*u3 - w3*u2
	v2 = w3*u1 - w1*u3
	v3 = w1*u2 - w2*u1

	uu = dsqrt(u1*u1 + u2*u2 + u3*u3)
	vv = dsqrt(v1*v1 + v2*v2 + v3*v3)
	ww = dsqrt(w1*w1 + w2*w2 + w3*w3)

	sa(1) = u1 / uu
	sa(2) = u2 / uu
	sa(3) = u3 / uu

	sb(1) = v1 / vv
	sb(2) = v2 / vv
	sb(3) = v3 / vv

	if(vv == 0.d0) sb(1:3) = 0.d0

	we(1) = w1 / ww
	we(2) = w2 / ww
	we(3) = w3 / ww

	xp = xtr(is)
	yp = ytr(is,it)
	zp = ztr(is,it)

return
end subroutine FSNPA

!==========
subroutine SVESE(q,cm,bsv,idb,ls,nod2s)

	use prm_matrix
	use prm_var
	use prm_inv

	implicit none

	integer, intent(in) :: idb(16), ls, nod2s
	real(8), intent(in) :: bsv(16)

	real(8), intent(out) :: q(4), cm(4,4)

	integer :: i, j, ll, lp, lq, l1, l2

	do i = 1, 4

		q(i) = 0.d0

		do ll = 1, nod2s
			if(idb(ll) == 0) cycle

			j = idmp(idb(ll), i, ls)
				if(j == 0) cycle

			q(i) = q(i) + bsv(ll) * x(j)

		end do

		do j = 1, i

			cm(j,i) = 0.d0

			do lp = 1, nod2s
				if(idb(lp) == 0) cycle

				l1 = idmp(idb(lp), i, ls)
					if(l1 == 0) cycle

				do lq = 1, nod2s
					if(idb(lq) == 0) cycle

					l2 = idmp(idb(lq), i, ls)
						if(l2 == 0) cycle

					cm(j,i) = cm(j,i) + bsv(lp) * bsv(lq) * cs(l1,l2)

				end do
			end do
		end do
	end do

return
end subroutine SVESE

!==========

end module mod_subsrc


      SUBROUTINE RAMBO(LFLAG,N,ET,XM,P)
c------------------------------------------------------
c
c                       RAMBO
c
c    RA(NDOM)  M(OMENTA)  B(EAUTIFULLY)  O(RGANIZED)
c
c    A DEMOCRATIC MULTI-PARTICLE PHASE SPACE GENERATOR
c    AUTHORS:  S.D. ELLIS,  R. KLEISS,  W.J. STIRLING
c    THIS IS VERSION 1.0 -  WRITTEN BY R. KLEISS
c    (MODIFIED BY R. PITTAU)
c
c                INPUT                 OUTPUT
c
c    LFLAG= 0:   N, ET, XM             P, (DJ)
c    LFLAG= 1:   N, ET, XM, P          (DJ)
c
c    N  = NUMBER OF PARTICLES (>1, IN THIS VERSION <101)
c    ET = TOTAL CENTRE-OF-MASS ENERGY
c    XM = PARTICLE MASSES ( DIM=100 )
c    P  = PARTICLE MOMENTA ( DIM=(4,100) )
c    DJ = 1/(WEIGHT OF THE EVENT)
c
c------------------------------------------------------
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION XM(100),P(4,100),Q(4,100),Z(100),R(4),
     .   B(3),P2(100),XM2(100),E(100),V(100),IWARN(5)
      SAVE ACC,ITMAX,IBEGIN,IWARN,Z,TWOPI,PO2LOG
      DATA ACC/1.D-14/,ITMAX/10/,IBEGIN/0/,IWARN/5*0/
C
C INITIALIZATION STEP: FACTORIALS FOR THE PHASE SPACE WEIGHT
      IF(IBEGIN.NE.0) GOTO 103
      IBEGIN=1
      TWOPI=8.*DATAN(1.D0)
      PO2LOG=LOG(TWOPI/4.)
      Z(2)=PO2LOG
      DO 101 K=3,100
  101 Z(K)=Z(K-1)+PO2LOG-2.*LOG(DFLOAT(K-2))
      DO 102 K=3,100
  102 Z(K)=(Z(K)-LOG(DFLOAT(K-1)))
C
C CHECK ON THE NUMBER OF PARTICLES
  103 IF(N.GT.1.AND.N.LT.101) GOTO 104
      PRINT 1001,N
      STOP
C
C CHECK WHETHER TOTAL ENERGY IS SUFFICIENT; COUNT NONZERO MASSES
  104 XMT=0.
      NM=0
      DO 105 I=1,N
      IF(XM(I).NE.0.D0) NM=NM+1
  105 XMT=XMT+ABS(XM(I))
      IF(XMT.LE.ET) GOTO 201
      PRINT 1002,XMT,ET
      STOP

  201 CONTINUE
      if (lflag.eq.1) then
        w0= exp((2.*N-4.)*LOG(ET)+Z(N))
        do j= 1,N
          v(j)= sqrt(p(1,j)**2+p(2,j)**2+p(3,j)**2)
        enddo

        a1= 0.d0
        a3= 0.d0
        a2= 1.d0
        do j= 1,N
          a1= a1+v(j)/ET
          a2= a2*v(j)/p(4,j)
          a3= a3+v(j)*v(j)/p(4,j)/ET
        enddo
        wm= a1**(2*N-3)*a2/a3
        dj= 1.d0/w0/wm
        return
      endif
C
C THE PARAMETER VALUES ARE NOW ACCEPTED
C
C GENERATE N MASSLESS MOMENTA IN INFINITE PHASE SPACE

      DO 202 I=1,N
      call rans(RAN1)
      call rans(RAN2)
      call rans(RAN3)
      call rans(RAN4)
      C=2.*RAN1-1.
      S=SQRT(1.-C*C)
      F=TWOPI*RAN2
      Q(4,I)=-LOG(RAN3*RAN4)
      Q(3,I)=Q(4,I)*C
      Q(2,I)=Q(4,I)*S*COS(F)
  202 Q(1,I)=Q(4,I)*S*SIN(F)
C
C CALCULATE THE PARAMETERS OF THE CONFORMAL TRANSFORMATION
      DO 203 I=1,4
  203 R(I)=0.
      DO 204 I=1,N
      DO 204 K=1,4
  204 R(K)=R(K)+Q(K,I)
      RMAS=SQRT(R(4)**2-R(3)**2-R(2)**2-R(1)**2)
      DO 205 K=1,3
  205 B(K)=-R(K)/RMAS
      G=R(4)/RMAS
      A=1./(1.+G)
      X=ET/RMAS
C
C TRANSFORM THE Q'S CONFORMALLY INTO THE P'S
      DO 207 I=1,N
      BQ=B(1)*Q(1,I)+B(2)*Q(2,I)+B(3)*Q(3,I)
      DO 206 K=1,3
  206 P(K,I)=X*(Q(K,I)+B(K)*(Q(4,I)+A*BQ))
  207 P(4,I)=X*(G*Q(4,I)+BQ)
C
C CALCULATE WEIGHT AND POSSIBLE WARNINGS
      WT=PO2LOG
      IF(N.NE.2) WT=(2.*N-4.)*LOG(ET)+Z(N)
      IF(WT.GE.-180.D0) GOTO 208
      IF(IWARN(1).LE.5) PRINT 1004,WT
      IWARN(1)=IWARN(1)+1
  208 IF(WT.LE. 174.D0) GOTO 209
      IF(IWARN(2).LE.5) PRINT 1005,WT
      IWARN(2)=IWARN(2)+1
C
C RETURN FOR WEIGHTED MASSLESS MOMENTA
  209 IF(NM.NE.0) GOTO 210
      WT=EXP(WT)
      DJ= 1.d0/WT
      RETURN
C
C MASSIVE PARTICLES: RESCALE THE MOMENTA BY A FACTOR X
  210 XMAX=SQRT(1.-(XMT/ET)**2)
      DO 301 I=1,N
      XM2(I)=XM(I)**2
  301 P2(I)=P(4,I)**2
      ITER=0
      X=XMAX
      ACCU=ET*ACC
  302 F0=-ET
      G0=0.
      X2=X*X
      DO 303 I=1,N
      E(I)=SQRT(XM2(I)+X2*P2(I))
      F0=F0+E(I)
  303 G0=G0+P2(I)/E(I)
      IF(ABS(F0).LE.ACCU) GOTO 305
      ITER=ITER+1
      IF(ITER.LE.ITMAX) GOTO 304
      PRINT 1006,ITMAX
      GOTO 305
  304 X=X-F0/(X*G0)
      GOTO 302
  305 DO 307 I=1,N
      V(I)=X*P(4,I)
      DO 306 K=1,3
  306 P(K,I)=X*P(K,I)
  307 P(4,I)=E(I)
C
C CALCULATE THE MASS-EFFECT WEIGHT FACTOR
      WT2=1.
      WT3=0.
      DO 308 I=1,N
      WT2=WT2*V(I)/E(I)
  308 WT3=WT3+V(I)**2/E(I)
      WTM=(2.*N-3.)*LOG(X)+LOG(WT2/WT3*ET)
C
C RETURN FOR  WEIGHTED MASSIVE MOMENTA
      WT=WT+WTM
      IF(WT.GE.-180.D0) GOTO 309
      IF(IWARN(3).LE.5) PRINT 1004,WT
      IWARN(3)=IWARN(3)+1
  309 IF(WT.LE. 174.D0) GOTO 310
      IF(IWARN(4).LE.5) PRINT 1005,WT
      IWARN(4)=IWARN(4)+1
  310 WT=EXP(WT)
      DJ= 1.d0/WT
      RETURN
C
 1001 FORMAT(' RAMBO FAILS: # OF PARTICLES =',I5,' IS NOT ALLOWED')
 1002 FORMAT(' RAMBO FAILS: TOTAL MASS =',D15.6,' IS NOT',
     . ' SMALLER THAN TOTAL ENERGY =',D15.6)
 1004 FORMAT(' RAMBO WARNS: WEIGHT = EXP(',F20.9,') MAY UNDERFLOW')
 1005 FORMAT(' RAMBO WARNS: WEIGHT = EXP(',F20.9,') MAY  OVERFLOW')
 1006 FORMAT(' RAMBO WARNS:',I3,' ITERATIONS DID NOT GIVE THE',
     . ' DESIRED ACCURACY =',D15.6)
      END


c
c ----------------------------------------------------------------------
c
      subroutine iosgld(fi,fo,sc,gc,smass,mNLSP,idecay , vertex)
c
c This subroutine computes an amplitude of the fermion-fermion-scalar
c SUSY Goldstino coupling. In this routine, the NLSP is decaying to a
c boson and a Goldstino. The h.c. of the NLSP decay is handled via the
c input parameter idecay.
c
c input:
c       complex fi(6)          : flow-in  fermion                   |fi>
c       complex fo(6)          : flow-out fermion                   <fo|
c       complex sc(3)          : input    scalar                      s
c       complex gc(2)          : coupling constants                  gsf
c       real    mNLSP          : mass of the NLSP
c       real    smass          : mass of the scalar boson
c       integer idecay         :  1 for NLSP decay to Goldstino
c                              : -1 for Goldstino to NLSP (h.c. of above)
c
c output:
c       complex vertex         : amplitude                     <fo|s|fi>
c
      implicit none
      double complex  fi(6), fo(6), gc(2), sc(3), vertex
      double complex  p14p, p14m, p23p, p23m
      double precision  mNLSP, smass
      integer idecay

      double complex ci, cZero
      parameter( ci = ( 0.0d0, 1.0d0 ), cZero = ( 0.0d0, 0.0d0 ) )
c
      if ( idecay.ne.1 .or. idecay.ne.-1 ) then
         write(6,*) 'error in idecay of IOSGLD'
         stop
      end if

      p14p = dble(sc(2)) + dimag(sc(2))
      p14m = dble(sc(2)) - dimag(sc(2))
      p23p = dble(sc(3)) + dimag(sc(3))*ci
      p23m = dble(sc(3)) - dimag(sc(3))*ci

      vertex = gc(1) *
     &         ( ( ( fo(3)*p14p + fo(4)*p23p )*fi(1)
     &            +( fo(3)*p23m + fo(4)*p14m )*fi(2) )*mNLSP
     &          -( fo(1)*fi(1) + fo(2)*fi(2) )*idecay*smass**2 )

      if ( gc(2).ne.cZero ) then
         vertex = vertex + gc(2) *
     &            ( ( ( fo(1)*p14m - fo(2)*p23p )*fi(3)
     &               -( fo(1)*p23m - fo(2)*p14p )*fi(4) )*mNLSP
     &             -( fo(3)*fi(3) + fo(4)*fi(4) )*idecay*smass**2 )
      end if

      vertex = vertex * sc(1)
c
      return
      end


      MODULE MOD_SETXJL

      CONTAINS

      SUBROUTINE SETXJL(LASTIND, INDLOW, INDNUP, SLNEW, SLOLD, OPAL, XJLAPP,
     $                  NF, XLAMBDA, SCNEW, OPAC,
     $                  NFL, PHI, PWEIGHT, N, EINST, ELEVEL, EN, WEIGHT,
     $                  ND, XJL, ENTOTL, RSTAR, VDOP, DELTAX, XMAX, L, LOE,
     $                  AccFact, NODM, LEVEL, NFIRST, NLAST, NATOM, ENLTE, ITNEL)

!     CALCULATE LINE RADIATION FIELD WITH APPROXIMATE LAMBDA OPERATOR TERMS

      USE MOD_LIPO
      USE MOD_LIOP
      USE MOD_XRUDI
      USE CONSTANTS
      USE COMMON_BLOCK

      IMPLICIT REAL*8(A - H, O - Z)

      PARAMETER (one = 1.d0, two = 2.d0)

      integer, intent(in) :: lastind, N

      DIMENSION EINST(N, N), ELEVEL(N), EN(N), WEIGHT(N)

      DIMENSION XLAMBDA(NF),SCNEW(NF),OPAC(NF)
      DIMENSION PHI(NFL),PWEIGHT(NFL)
      DIMENSION INDNUP(LASTIND),INDLOW(LASTIND)

      INTEGER, INTENT(IN) :: NATOM

      INTEGER, DIMENSION(NATOM), INTENT(IN) :: NFIRST, NLAST

      REAL*8 :: etalind, opalind

      REAL*8, DIMENSION(LASTIND), INTENT(OUT) :: opal

      REAL*8, DIMENSION(LASTIND), INTENT(IN) ::  XJL

      REAL*8, DIMENSION(LASTIND), INTENT(OUT) :: XJLAPP

!     DEPTH INDEX
      INTEGER, INTENT(IN) :: L

!     the Local approximate lambda-Operator Element corresponding to depth L for all lines
      REAL*8, DIMENSION(LASTIND), INTENT(IN) ::  LOE

      REAL*8, DIMENSION(LASTIND), INTENT(IN) ::  SLOLD
      REAL*8, DIMENSION(LASTIND), INTENT(OUT) :: SLNEW, AccFact

      CHARACTER*10, DIMENSION(N), INTENT(IN) :: LEVEL

      REAL*8, DIMENSION(N), INTENT(IN) :: ENLTE

      LOGICAL, INTENT(IN) :: NODM

      INTEGER, INTENT(IN) :: ITNEL

      REAL*8 :: UpperLevelDep, LowerLevelDep

      REAL*8 :: AccFactCutOff

      LOGICAL :: PRINT_COND, DEPTH_ACC_COND

      opal(1 : lastind) = 0.0d0

      DEPTH_ACC_COND = L .NE. ND

      IF (ITNEL .EQ. 1) WRITE(*, '(/,2x,A,5x,A,5x,A,3x,A,7x,A,11x,A,12x,A,13x,A,19x,A,17x,A,14x,A,11x,A,14x,A,13x,A,/)'),
     $                           'LI', 'L', 'BI', 'IND', 'LL', 'UL', 'SLO', 'SLN', 'DE', 'JO', 'DJ', 'DJ/JO', 'ULD', 'LLD'

      XJLAPP(1 : LASTIND) = XJL(1 : LASTIND)

      SLNEW(1 : LASTIND) = 0.0D0

      AccFact(1 : LASTIND) = 0.0D0

!     LOOP OVER ALL LINES
      DO IND = 1, LASTIND

      AccFactCutOff = 10.0D+0

      PRINT_COND = IND .EQ. 1

      LOW = INDLOW(IND)
      NUP = INDNUP(IND)

      IF (LOW .GE. NFIRST(2) .AND. NUP .LE. NLAST(2)) AccFactCutOff = 0.0D0 ! Helium is not accelerated

!     FOR RUDIMENTAL LINES, ZERO CORE IS ASSUMED
      IF (EINST(LOW, NUP) .EQ. -2.0D0) CYCLE

      UpperLevelDep = EN(NUP) / ENLTE(NUP)
      LowerLevelDep = EN(LOW) / ENLTE(LOW)

      XLAM = 1.0D8 / (ELEVEL(NUP) - ELEVEL(LOW))

!      if (ind .eq. 1) print*, 'before liop_sbe:', en(low), en(nup)

      CALL LIOP_SBE(EINST(NUP, LOW), WEIGHT(LOW), WEIGHT(NUP), LOW, NUP,
     $              XLAM, ENTOTL, EN(1 : N), RSTAR, opalind, etalind, VDOP, N)

!      if (ind .eq. 1) print*, 'after liop_sbe:', en(low), en(nup)

!      stop

C***  LASER SECURITY

      IF (opalind .LE. 0.0D0) THEN

         IF (PRINT_COND) WRITE(*, 10000), LAMBDA_ITER, L, ITNEL, IND,
     $                                    LEVEL(LOW), LEVEL(NUP),
     $                                    en(low), en(up),
     $                                    '<---------------- OPAL  IS NEGATIVE'

         CYCLE

      ENDIF

      opal(ind) = opalind

      slnew(ind) = etalind / opalind

!      if (ind .eq. 1) then

!         write(*, '(A,2x,i4,4(2x,e15.7))'), 'setxjl:', ind, slnew(ind), etalind, opalind, opal(ind)

!         stop

!      endif

      IF (SLOLD(IND) .EQ. 0.0D0) THEN

         IF (PRINT_COND) WRITE(*, 10000), LAMBDA_ITER, L, ITNEL, IND,
     $                                    LEVEL(LOW), LEVEL(NUP),
     $                                    UpperLevelDep, LowerLevelDep,
     $                                    '<---------------- SLOLD IS ZERO'

         CALL SET_ACC_FACT(DEPTH_ACC_COND, AccFactCutOff, LOE(IND), AccFact(IND))

         CYCLE

      ENDIF

      CALL SET_ACC_FACT(DEPTH_ACC_COND, AccFactCutOff, LOE(IND), AccFact(IND))

      DELTASL = SLNEW(IND) - SLOLD(IND)

      XJLAPP(IND) = XJLAPP(IND) + AccFact(IND) * DELTASL

      IF (PRINT_COND) WRITE(*, 10001), LAMBDA_ITER, L, ITNEL, IND,
     $                                 LEVEL(LOW), LEVEL(NUP),
     $                                 SLOLD(IND), SLNEW(IND),
     $                                 LOE(IND),
     $                                 XJL(IND), AccFact(IND) * DELTASL,
     $                                 AccFact(IND) * DELTASL / XJL(IND),
     $                                 UpperLevelDep, LowerLevelDep

      IF (.NOT. NODM .AND. PRINT_COND) WRITE(*, '(3x,A)'), 'NEWTON'

      IF (NODM .AND. PRINT_COND)       WRITE(*, '(3x,A)'), 'BROYDEN'

      ENDDO

10000 FORMAT(I5,3x,    ! LI
     $       I3,3x,    ! L
     $       I3,3x,    ! BI
     $       I3,3x,    ! IND
     $       A10,3x,   ! LL
     $       A10,113x, ! UL
     $       E15.7,1x, ! ULD
     $       E15.7,3x, ! LLD
     $       A)

10001 FORMAT(I5,3x,      ! LI
     $       I3,3x,      ! L
     $       I3,3x,      ! BI
     $       I3,3x,      ! IND
     $       A10,3x,     ! LL
     $       A10,1x,     ! UL
     $       E15.7,1x,   ! SLO
     $       E15.7,1x,   ! SLN
     $       E23.15,1x,  ! DE
     $       E15.7,1x,   ! JO
     $       E15.7,1x,   ! DJ
     $       E15.7,1x,   ! R
     $       E15.7,1x,   ! ULD
     $       E15.7,3x,$) ! LLD

      END SUBROUTINE

      SUBROUTINE SET_ACC_FACT(AccCond, AccFactCutOff, LOE, AccFact)

      IMPLICIT NONE

      LOGICAL, INTENT(IN) :: AccCond

      REAL*8, INTENT(IN) ::  AccFactCutOff, LOE

      REAL*8, INTENT(OUT) :: AccFact

      AccFact = 0.0D0

      IF (AccCond) AccFact = LOE

      IF (AccFact .GT. AccFactCutOff) AccFact = AccFactCutOff

      END SUBROUTINE

      END MODULE


PROGRAM ENIAC
!  Emulate the first successful numerical weather prediction.
!  It was run on the ENIAC during 1948 and 1949.
!  The results and method were written up in Tellus 2, p. 237 1950.
!      Robert Grumbine 2 May 1995. Fortran 77
! Typographical translation to Fortran 90 23 March 2019

!  Non-dimensional constants
  INTEGER p, q, n, ip, jp
  PARAMETER (p = 18)
  PARAMETER (q = 15)
  PARAMETER (n = 24)
  PARAMETER (ip = 9)
  PARAMETER (jp = 13)

!  Declare Dimensional Constants
  REAL g, radius, omega, ds, dt
  PARAMETER (g      = 9.81)
  PARAMETER (radius = 6.37E6)
  PARAMETER (omega  = 7.292E-5)
  PARAMETER (ds     = 7.36E5)
  PARAMETER (dt     = omega*86400/n)

!  Rescale feet (input dimension of Z's) to meters
  REAL fttom
  PARAMETER (fttom = 3.048)
  REAL pi
  PARAMETER (pi = 3.141592654)

!  Declare temporary arrays -
!    These were used because of the memory constraint on the ENIAC --
!      these values were on punched cards recycled through the system
  REAL s(0:p,0:p), t(0:q,0:q), v(0:p,0:q)
  REAL r(0:p,0:q), f(0:p,0:q), h(0:p,0:q)
  REAL a(0:p,0:q), b(0:p,0:q)
  REAL alpha(0:p,0:q), beta(0:p,0:q)
  REAL zp(0:p,0:q), zetap(0:p,0:q)

!  Declare data, physical info.
  REAL z(0:p,0:q), zeta(0:p,0:q), eta(0:p,0:q)

!  Declare computational variables
  INTEGER i, j, k, l, m

!***********************************************************!!
!  Set up the initial conditions deck
  DATA (z(0,j),j=0,q)  /910, 899, 900, 885, 880, 890, 895, 885, 895, 920, 910, 890, 870, 860, 850, 840/
  DATA (z(1,j),j=0,q)  /907, 900, 895, 880, 870, 885, 890, 890, 900, 925, 920, 900, 880, 870, 840, 830/
  DATA (z(2,j),j=0,q)  /905, 901, 890, 877, 865, 865, 880, 885, 900, 920, 930, 910, 885, 860, 820, 800/
  DATA (z(3,j),j=0,q)  /908, 901, 888, 870, 847, 830, 830, 850, 890, 900, 900, 890, 860, 800, 760, 720/
  DATA (z(4,j),j=0,q)  /910, 905, 888, 871, 840, 790, 760, 780, 860, 865, 830, 800, 750, 720, 680, 680/
  DATA (z(5,j),j=0,q)  /915, 910, 898, 880, 850, 795, 740, 740, 800, 830, 770, 720, 685, 670, 670, 670/
  DATA (z(6,j),j=0,q)  /918, 919, 915, 900, 865, 810, 750, 730, 750, 740, 730, 690, 655, 665, 665, 665/
  DATA (z(7,j),j=0,q)  /930, 931, 926, 915, 883, 825, 770, 725, 700, 680, 670, 660, 660, 655, 655, 660/
  DATA (z(8,j),j=0,q)  /932, 945, 942, 932, 900, 850, 780, 720, 660, 610, 600, 620, 640, 650, 655, 665/
  DATA (z(9,j),j=0,q)  /935, 950, 950, 942, 924, 890, 800, 710, 640, 600, 590, 580, 600, 645, 660, 675/
  DATA (z(10,j),j=0,q) /933, 940, 945, 942, 926, 890, 810, 720, 650, 600, 580, 560, 620, 655, 670, 685/
  DATA (z(11,j),j=0,q) /931, 934, 939, 935, 897, 880, 830, 750, 690, 620, 600, 600, 630, 670, 685, 700/
  DATA (z(12,j),j=0,q) /925, 926, 925, 920, 890, 865, 830, 760, 710, 670, 620, 620, 650, 690, 700, 710/
  DATA (z(13,j),j=0,q) /920, 919, 896, 903, 875, 845, 810, 760, 735, 730, 710, 720, 720, 740, 730, 730/
  DATA (z(14,j),j=0,q) /915, 913, 889, 897, 860, 825, 790, 780, 790, 830, 840, 850, 820, 780, 760, 740/
  DATA (z(15,j),j=0,q) /912, 910, 885, 891, 860, 830, 820, 840, 860, 890, 900, 900, 850, 790, 770, 755/
  DATA (z(16,j),j=0,q) /908, 908, 885, 900, 880, 870, 880, 890, 910, 925, 920, 900, 870, 800, 780, 765/
  DATA (z(17,j),j=0,q) /905, 907, 886, 905, 890, 900, 910, 920, 920, 920, 900, 890, 870, 840, 800, 780/
  DATA (z(18,j),j=0,q) /903, 906, 886, 910, 900, 920, 920, 925, 915, 910, 890, 880, 860, 850, 820, 810/
!***********************************************************!!

! BEGIN THE EXECUTION HERE
! This file is not comparable to anything in the original program.
  OPEN (UNIT=1, FILE="ENIAC.OUT", FORM="FORMATTED")

  s = 0.
  t = 0.
  v = 0.
  r = 0.
  h = 0.
  f = 0.
  zeta = 0.0
  eta  = 0.0
  a = 0.0
  b = 0.0
  alpha = 0.0
  beta  = 0.0
  zp    = 0.0
  zetap = 0.0

  PRINT *,SECOND()*1000.,' ms'
! Rescale the heights to metric
  z    = z / fttom

!  Prepare the data decks - used due to memory constraints
  DO i = 1, p-1
    DO l = 1, p-1
      s(l,i) = SIN(pi*i*l/p)
    ENDDO
  ENDDO

  DO j = 1, q-1
    DO m = 1, q-1
      t(m,j) = SIN(pi*m*j/q)
    ENDDO
  ENDDO

  DO i = 0, p
    DO j = 0, q
      v(i,j) = p*q*(SIN(pi*i/(2*p))**2 + SIN(pi*j/(2*q))**2 )
      r(i,j) = (ds/(2*radius))**2 *((i-ip)**2+(j-jp)**2)
    ENDDO
  ENDDO

  f = (1.-r)/(1.+r)
  h = g/(2*omega*ds)**2 * (1.+r)**3 / (1.-r)

  DO i = 1, p-1
    DO j = 1, q-1
      zeta(i,j) = z(i+1,j)+z(i,j+1)+z(i-1,j)+z(i,j-1) - 4.*z(i,j)
    ENDDO
  ENDDO
  DO j = 0, q
    zeta(0,j) = 2.*zeta(1,j)  - zeta(2,j)
    zeta(p,j) = 2.*zeta(p-1,j)- zeta(p-2,j)
  ENDDO
  DO i = 0, p
    zeta(i,0) = 2.*zeta(i,1)   - zeta(i,2)
    zeta(i,q) = 2.*zeta(i,q-1) - zeta(i,q-2)
  ENDDO

  eta = f + h*zeta

!     END OF THE PRELIMINARY SET UP SECTION
!***********************************************************!!
!  BEGIN THE ITERATIVE SOLUTION OF THE EQUATIONS
  PRINT *,SECOND()*1000.,' ms'
  DO 2000 k = 0, 3*n-1

    DO j = 1, q-1
      DO i = 1, p-1
        eta(i,j) = f(i,j)+h(i,j)*zeta(i,j)
      ENDDO
    ENDDO

    DO i = 1, p-1
      j = 0
      IF (z(i+1,0) .LT. z(i-1,0)) THEN
        eta(i,j) = f(i,j)+h(i,j)*zeta(i,j)
      ENDIF
      j = q
      IF (z(i+1,q) .GT. z(i-1,q)) THEN
        eta(i,j) = f(i,j)+h(i,j)*zeta(i,j)
      ENDIF
    ENDDO

    DO j = 1, q-1
      i = 0
      IF (z(0,j+1).GT.z(0,j-1)) THEN
        eta(i,j) = f(i,j)+h(i,j)*zeta(i,j)
      ENDIF
      i = p
      IF (z(p,j+1).LT.z(p,j-1)) THEN
        eta(i,j) = f(i,j)+h(i,j)*zeta(i,j)
      ENDIF
    ENDDO

    DO j = 1, q-1
      DO i = 1, p-1
        zetap(i,j) = 0.5*( (eta(i+1,j)-eta(i-1,j)) *(z(i,j+1)-z(i,j-1)) &
            -   (eta(i,j+1)-eta(i,j-1)) *(z(i+1,j)-z(i-1,j)) )
      ENDDO
    ENDDO

    DO j = 1, q-1
      DO i = 1, p-1
        alpha(i,j) = 0.0
        DO l = 1, p-1
          alpha(i,j)=alpha(i,j)+s(l,i)*zetap(l,j)
        ENDDO
      ENDDO
    ENDDO

    DO j = 1, q-1
      DO i = 1, p-1
        a(i,j) = 0.0
        DO m = 1, q-1
          a(i,j) = a(i,j) + t(m,j)*alpha(i,m)
        ENDDO
      ENDDO
    ENDDO

    b = -a / v
    !b(1:p-1,1:q-1) = -a(1:p-1,1:q-1) / v(1:p-1,1:q-1)

    DO j = 1, q-1
      DO i = 1, p-1
        beta(i,j) = 0.0
        DO m = 1, q-1
          beta(i,j) = beta(i,j)+t(m,j)*b(i,m)
        ENDDO
      ENDDO
    ENDDO

    DO j = 1, q-1
      DO i = 1, p-1
        zp(i,j) = 0.0
        DO l = 1, p-1
          zp(i,j) = zp(i,j)+s(l,i)*beta(l,j)
        ENDDO
      ENDDO
    ENDDO

!  SECTION FOR CARRYING FORWARD THE EXTRAPOLATION
   IF (k.EQ.0) THEN
     z    = z    + dt*zp
     zeta = zeta + dt*zetap
    ELSE
     z    = z    + 2.*dt*zp
     zeta = zeta + 2.*dt*zetap
   ENDIF

!  Apply the inflow/outflow conditions
  DO j = 1, q-1
    IF (z(0,j+1) .GT. z(0,j-1)) THEN
      z(0,j)    = z(0,j)
      zeta(0,j) = 2.*zeta(1,j)-zeta(2,j)
     ELSE
      z(0,j)    = z(0,j)
      zeta(0,j) = zeta(0,j)
    ENDIF
    IF (z(p,j+1) .LT. z(p,j-1)) THEN
      z(p,j)    = z(p,j)
      zeta(p,j) = 2.*zeta(p-1,j)-zeta(p-2,j)
     ELSE
      z(p,j)    = z(p,j)
      zeta(p,j) = zeta(p,j)
    ENDIF
  ENDDO
   DO i = 1, p-1
     IF (z(i+1,0) .LT. z(i-1,0)) THEN
       z(i,0)    = z(i,0)
       zeta(i,0) = 2.*zeta(i,1)-zeta(i,2)
     ELSE
       z(i,0)    = z(i,0)
       zeta(i,0) = zeta(i,0)
     ENDIF
     IF (z(i+1,q) .GT. z(i-1,q)) THEN
       z(i,q)    = z(i,q)
       zeta(i,q) = 2.*zeta(i,q-1)-zeta(i,q-2)
     ENDIF
   ENDDO

  WRITE (1,9003) k
  WRITE (1,9001) ((z(i,j),j=0,q),i=0,p)
  WRITE (1,9002)
 9001 FORMAT (16F7.2)
 9002 FORMAT (' ')
 9003 FORMAT (I3)

 2000 CONTINUE

  PRINT *,SECOND()*1000.,' ms'

!***********************************************************!!

  END


      SUBROUTINE MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA,
     $                   A, LDA, U, LDU, NDIM, DWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To reorder the diagonal blocks of a principal submatrix of an
C     upper quasi-triangular matrix A together with their eigenvalues by
C     constructing an orthogonal similarity transformation UT.
C     After reordering, the leading block of the selected submatrix of A
C     has eigenvalues in a suitably defined domain of interest, usually
C     related to stability/instability in a continuous- or discrete-time
C     sense.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the spectrum separation to be
C             performed as follows:
C             = 'C':  continuous-time sense;
C             = 'D':  discrete-time sense.
C
C     STDOM   CHARACTER*1
C             Specifies whether the domain of interest is of stability
C             type (left part of complex plane or inside of a circle)
C             or of instability type (right part of complex plane or
C             outside of a circle) as follows:
C             = 'S':  stability type domain;
C             = 'U':  instability type domain.
C
C     JOBU    CHARACTER*1
C             Indicates how the performed orthogonal transformations UT
C             are accumulated, as follows:
C             = 'I':  U is initialized to the unit matrix and the matrix
C                     UT is returned in U;
C             = 'U':  the given matrix U is updated and the matrix U*UT
C                     is returned in U.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and U.  N >= 1.
C
C     NLOW,   (input) INTEGER
C     NSUP    NLOW and NSUP specify the boundary indices for the rows
C             and columns of the principal submatrix of A whose diagonal
C             blocks are to be reordered.  1 <= NLOW <= NSUP <= N.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The boundary of the domain of interest for the eigenvalues
C             of A. If DICO = 'C', ALPHA is the boundary value for the
C             real parts of eigenvalues, while for DICO = 'D',
C             ALPHA >= 0 represents the boundary value for the moduli of
C             eigenvalues.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain a matrix in a real Schur form whose 1-by-1 and
C             2-by-2 diagonal blocks between positions NLOW and NSUP
C             are to be reordered.
C             On exit, the leading N-by-N part contains the ordered
C             real Schur matrix UT' * A * UT with the elements below the
C             first subdiagonal set to zero.
C             The leading NDIM-by-NDIM part of the principal submatrix
C             D = A(NLOW:NSUP,NLOW:NSUP) has eigenvalues in the domain
C             of interest and the trailing part of this submatrix has
C             eigenvalues outside the domain of interest.
C             The domain of interest for lambda(D), the eigenvalues of
C             D, is defined by the parameters ALPHA, DICO and STDOM as
C             follows:
C               For DICO = 'C':
C                  Real(lambda(D)) < ALPHA if STDOM = 'S';
C                  Real(lambda(D)) > ALPHA if STDOM = 'U'.
C               For DICO = 'D':
C                  Abs(lambda(D)) < ALPHA if STDOM = 'S';
C                  Abs(lambda(D)) > ALPHA if STDOM = 'U'.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= N.
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,N)
C             On entry with JOBU = 'U', the leading N-by-N part of this
C             array must contain a transformation matrix (e.g. from a
C             previous call to this routine).
C             On exit, if JOBU = 'U', the leading N-by-N part of this
C             array contains the product of the input matrix U and the
C             orthogonal matrix UT used to reorder the diagonal blocks
C             of A.
C             On exit, if JOBU = 'I', the leading N-by-N part of this
C             array contains the matrix UT of the performed orthogonal
C             transformations.
C             Array U need not be set on entry if JOBU = 'I'.
C
C     LDU     INTEGER
C             The leading dimension of array U.  LDU >= N.
C
C     NDIM    (output) INTEGER
C             The number of eigenvalues of the selected principal
C             submatrix lying inside the domain of interest.
C             If NLOW = 1, NDIM is also the dimension of the invariant
C             subspace corresponding to the eigenvalues of the leading
C             NDIM-by-NDIM submatrix. In this case, if U is the
C             orthogonal transformation matrix used to compute and
C             reorder the real Schur form of A, its first NDIM columns
C             form an orthonormal basis for the above invariant
C             subspace.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  A(NLOW,NLOW-1) is nonzero, i.e. A(NLOW,NLOW) is not
C                   the leading element of a 1-by-1 or 2-by-2 diagonal
C                   block of A, or A(NSUP+1,NSUP) is nonzero, i.e.
C                   A(NSUP,NSUP) is not the bottom element of a 1-by-1
C                   or 2-by-2 diagonal block of A;
C             = 2:  two adjacent blocks are too close to swap (the
C                   problem is very ill-conditioned).
C
C     METHOD
C
C     Given an upper quasi-triangular matrix A with 1-by-1 or 2-by-2
C     diagonal blocks, the routine reorders its diagonal blocks along
C     with its eigenvalues by performing an orthogonal similarity
C     transformation UT' * A * UT. The column transformation UT is also
C     performed on the given (initial) transformation U (resulted from
C     a possible previous step or initialized as the identity matrix).
C     After reordering, the eigenvalues inside the region specified by
C     the parameters ALPHA, DICO and STDOM appear at the top of
C     the selected diagonal block between positions NLOW and NSUP.
C     In other words, lambda(A(NLOW:NSUP,NLOW:NSUP)) are ordered such
C     that lambda(A(NLOW:NLOW+NDIM-1,NLOW:NLOW+NDIM-1)) are inside and
C     lambda(A(NLOW+NDIM:NSUP,NLOW+NDIM:NSUP)) are outside the domain
C     of interest. If NLOW = 1, the first NDIM columns of U*UT span the
C     corresponding invariant subspace of A.
C
C     REFERENCES
C
C     [1] Stewart, G.W.
C         HQR3 and EXCHQZ: FORTRAN subroutines for calculating and
C         ordering the eigenvalues of a real upper Hessenberg matrix.
C         ACM TOMS, 2, pp. 275-280, 1976.
C
C     NUMERICAL ASPECTS
C                                         3
C     The algorithm requires less than 4*N  operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen,
C     April 1998. Based on the RASP routine SEOR1.
C
C     KEYWORDS
C
C     Eigenvalues, invariant subspace, orthogonal transformation, real
C     Schur form, similarity transformation.
C
C    ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ONE, ZERO
      PARAMETER        ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER        DICO, JOBU, STDOM
      INTEGER          INFO, LDA, LDU, N, NDIM, NLOW, NSUP
      DOUBLE PRECISION ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*), DWORK(*), U(LDU,*)
C     .. Local Scalars ..
      LOGICAL          DISCR, LSTDOM
      INTEGER          IB, L, LM1, NUP
      DOUBLE PRECISION E1, E2, TLAMBD
C     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DLAPY2
      EXTERNAL         DLAPY2, LSAME
C     .. External Subroutines ..
      EXTERNAL         DLASET, DTREXC, MB03QY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        ABS
C     .. Executable Statements ..
C
      INFO = 0
      DISCR = LSAME( DICO, 'D' )
      LSTDOM = LSAME( STDOM, 'S' )
C
C     Check input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( LSTDOM .OR. LSAME( STDOM, 'U' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT. ( LSAME( JOBU, 'I' ) .OR.
     $                 LSAME( JOBU, 'U' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.1 ) THEN
         INFO = -4
      ELSE IF( NLOW.LT.1 ) THEN
         INFO = -5
      ELSE IF( NLOW.GT.NSUP .OR. NSUP.GT.N ) THEN
         INFO = -6
      ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN
         INFO = -7
      ELSE IF( LDA.LT.N ) THEN
         INFO = -9
      ELSE IF( LDU.LT.N ) THEN
         INFO = -11
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB03QD', -INFO )
         RETURN
      END IF
C
      IF( NLOW.GT.1 ) THEN
         IF( A(NLOW,NLOW-1).NE.ZERO ) INFO = 1
      END IF
      IF( NSUP.LT.N ) THEN
         IF( A(NSUP+1,NSUP).NE.ZERO ) INFO = 1
      END IF
      IF( INFO.NE.0 )
     $   RETURN
C
C     Initialize U with an identity matrix if necessary.
C
      IF( LSAME( JOBU, 'I' ) )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU )
C
      NDIM = 0
      L = NSUP
      NUP = NSUP
C
C     NUP is the minimal value such that the submatrix A(i,j) with
C     NUP+1 <= i,j <= NSUP contains no eigenvalues inside the domain of
C     interest. L is such that all the eigenvalues of the submatrix
C     A(i,j) with L+1 <= i,j <= NUP lie inside the domain of interest.
C
C     WHILE( L >= NLOW ) DO
C
   10 IF( L.GE.NLOW ) THEN
         IB = 1
         IF( L.GT.NLOW ) THEN
            LM1 = L - 1
            IF( A(L,LM1).NE.ZERO ) THEN
               CALL MB03QY( N, LM1, A, LDA, U, LDU, E1, E2, INFO )
               IF( A(L,LM1).NE.ZERO ) IB = 2
            END IF
         END IF
         IF( DISCR ) THEN
            IF( IB.EQ.1 ) THEN
               TLAMBD = ABS( A(L,L) )
            ELSE
               TLAMBD = DLAPY2( E1, E2 )
            END IF
         ELSE
            IF( IB.EQ.1 ) THEN
               TLAMBD = A(L,L)
            ELSE
               TLAMBD = E1
            END IF
         END IF
         IF( (      LSTDOM .AND. TLAMBD.LT.ALPHA ) .OR.
     $       ( .NOT.LSTDOM .AND. TLAMBD.GT.ALPHA ) ) THEN
            NDIM = NDIM + IB
            L = L - IB
         ELSE
            IF( NDIM.NE.0 ) THEN
               CALL DTREXC( 'V', N, A, LDA, U, LDU, L, NUP, DWORK,
     $                      INFO )
               IF( INFO.NE.0 ) THEN
                  INFO = 2
                  RETURN
               END IF
               NUP = NUP - 1
               L = L - 1
            ELSE
               NUP = NUP - IB
               L = L - IB
            END IF
         END IF
         GO TO 10
      END IF
C
C     END WHILE 10
C
      RETURN
C *** Last line of MB03QD ***
      END


c___________________________________________________
c
      subroutine fcorsu(dr,nfil,afparam,iftype,sc,rnrmt,cda,lfd)

      include 'iounits.inc'
      include 'decimate.inc'

c       computes table of transfer functions for subroutine rnorm
c       the transfer functions are used for correcting for filter
c       responses;  six things are corrected for
c       1) effect of first differencing
c       2) digital low pass filtering prior to decimation
c       3) correction of units of fourier coefficients (to counts/(sqrt(hz)))
c       4) analogue low pass (anti-alias) filters of instruments
c       5) analogue high pass filters of instruments (if any)
c        5') system response table
c       6) scale factors for individual channels to convert form counts
c                to physically meaningful units; for magnetic channels
c                this will be nt for electric mv/km; transformation of
c                measured channels to a "nice" coordinate system is not
c                done with this

c       =========> fc(nd,nfcmx) = filter coefficients for digital filtering
c                       prior to decimation
c       =========> nfc(nd) = ith element is number of filter coffeficients
c                       for decimating to level i
c       =========> npts(nd) = array of window lengths
c       =========> dr(nd) = array of sampling rates
c       =========> afparam(nfilmax,nch) analogue filter/system response parameters
c>>>>>>>>>> 28 Feb, 1991 changed to character*80 array
c       =========> iftype(nfilmax,nch) indicator variable for formula for
c                    filter/response
c       =========> sc(nch) = scale factors to convert counts to physical
c                       units
c       =========> cda clock offset in seconds (+ for fast)
c
c       =========> lfd  logical array; true if corresponding
c                    channel/decimation level is to be first
c                     differenced
c       <========  rnrmt(nch,nd,npts/2) = conmplex table output

      parameter (pi=3.141592654)

      real dr(nd),sc(nch)
      complex rnrmt(nch,nd,*),afcor,temp,tc
      integer iftype(nfilmax,nch),nfil(nch),nzeros,npoles,kz,kp
      logical lfd(nch,nd)
      real dt,t
      character*256 afparam(nfilmax,nch)

      integer id,i,npts2
      complex poles(100),zeros(100),w
      real*4 a0, dum

ccc   corrections for first difference if appropriate
ccc   correct units of fc's
      do id=1,nd
         npts2=nwin(id)/2
         pi2n=2.*pi/nwin(id)
         t = sqrt(dr(id))
         do ich = 1,nch
            w = cmplx(1.,0.)
            do i = 1,npts2
               if(lfd(ich,id))then
                  w=cmplx(0.0,pi2n*i)
                  w=1./(exp(w)-(1.0,0.0))
               end if
               rnrmt(ich,id,i)=w*sc(ich)*t
            enddo
         enddo
      enddo

ccc   corrections for low pass decimation filters
ccc   New version: 2-23-98   corrects for effect of low pass
ccc   filters on all decimation levels
      do id = 2,nd
         do jd = id,nd
            npts2 = nwin(jd)/2
            pi2n =2*pi*dr(id-1)/(dr(jd)*nwin(jd))
            do i = 1,npts2
               g = fc(id,1)
               do j=2,nfc(id)
                  t = pi2n*i*(j-1)
                  g=g+2.*fc(id,j)*cos(t)
               enddo
               do ich=1,nch
                  rnrmt(ich,jd,i) = rnrmt(ich,jd,i)/g
               enddo
            enddo
         enddo
      enddo

ccc  possible correction of fixed clock offset (seldom done here
ccc  anymore
      do id=1,nd
         do i = 1,npts2
            freq = i*(1./(dr(id)*nwin(id)))
            tc = cexp(cmplx(0.,freq*2.*pi*cda))
            do ich=1,nch
               rnrmt(ich,id,i)=tc*rnrmt(ich,id,i)
            enddo
         enddo
      enddo

ccc   corrections for analogue instrument filters/system response
      do ich = 1,nch
         do k = 1,nfil(ich)

c         read info for each filter out of character array, set
c               up tables for table look up of system response
            j = iftype(k,ich)
            if((j.eq.3).or.(j.eq.4).or.(j.eq.6)) then
               read(afparam(k,ich),*) gain,t0,alpha
            else if((j.eq.2).or.(j.eq.5)) then
               read(afparam(k,ich),*) gain,t0

ccc   EMI MT-1, BF-4 coils or EFSC
            else if(j.eq.7) then
               gain = 1.0
               read(afparam(k,ich),*) cfrsp,imode,igain
               cfrsp = 'sensors/'//cfrsp
               call resptbl(j,imode,igain,freq,temp,0)
            else if(j.eq.8) then
               gain = 1.0
               read(afparam(k,ich),*) cfrsp
               cfrsp = 'sensors/'//cfrsp
               call resptbl(j,imode,igain,freq,temp,0)
            else if(j.eq.10) then
ccc            POLES AND ZEROS representation of TF
               read(afparam(k,ich),*) nzeros,npoles,a0
               read(afparam(k,ich),*) dum,dum,dum,
     &            (zeros(kz),kz=1,nzeros),(poles(kp),kp=1,npoles)

C-PDAS
C       31/7/96 read individual calibration files for each PAB, MFS05
            else if ((j.eq.17) .or. (j.eq.18)) then
               read (afparam(k,ich),*) cfrsp
               cfrsp = 'sensors/'//cfrsp
               call resptbl(j,imode,igain,freq,temp,0)
C     -PDAS
            elseif (j.eq.98 .or. j.eq.99) then
ccc            generic table
               read(afparam(k,ich),*) cfrsp
               cfrsp = 'sensors/'//cfrsp(1:iclong(cfrsp,80))
               call resptbl(j,imode,igain,freq,temp,0)
            elseif (j.eq.101) then
cBooker:       filter to correct timing offsets in individual channels
ccc            read time shift (assumed to be in seconds)
               read(afparam(k,ich),*) dt
cBooker:       filter to correct timing offsets in individual channels
            end if

ccc         this inner loop computes the actual filter response as a
ccc            function of frequency
            do id = 1,nd
            npts2 = nwin(id)/2
               do i = 1,npts2
                  freq = i*(1./(dr(id)*nwin(id)))
                  period = 1./freq
c               corect for filters, system response

C-PDAS
c       if it is a PDAS system iftype = j = 11,12
c       all parameters of the two filter types PD and MX are in
c       function AFCOR, there is no need to read these from the char string
c       afparam
                  if ((j.eq.11).or.(j.eq.12)) then
                     temp = afcor(j,t0,period,alpha)
                     gain = 1.0
                  end if
C-PDAS end
C LMT
c                 if it is an LMT system iftype = j = 13,14,15 or 16
c                 all parameters of the two filters are in FUNCTION AFCOR
                  if (((j.eq.13).or.(j.eq.14)).or.
     &                 ((j.eq.15).or.(j.eq.16))) then
                     temp = afcor(j,t0,period,alpha)
                     gain = 1.0
                  end if

                  if(j.le.6) then
                     temp = afcor(j,t0,period,alpha)
                  else if((j.eq.7).or.(j.eq.8)) then
                     call resptbl(j,imode,igain,freq,temp,1)
                  else if(j.eq.10) then
ccc                  Poles and Zeros
                     call pz_rsp(nzeros,npoles,a0,zeros,poles,freq,
     &                     temp)
                     gain = 1

C                -PDAS  new calibration data files
                  else if ((j.eq.17) .or. (j.eq.18)) then
                     call resptbl(j,imode,igain,freq,temp,1)
                     gain = 1.0
C-PDAS

cvan    iftype = j = 97 is uncallibrated coil (i omega response)
                  else if (j.eq.97) then
                      temp = cmplx(0.0,freq)
                      gain = 1

cnew    iftype = j = 98 is a generic amplitude/phase table
cnew    iftype = j = 99 is a generic real/imaginary table
                     elseif (j.eq.98 .or. j.eq.99) then
                     call resptbl(j,imode,igain,freq,temp,1)
                     gain = 1.0

		  elseif (j.eq. 101) then
cBooker:             filter to correct timing offsets in individual channels
                     gain = 1.
                     temp = cmplx(0.0,-2*pi*freq*dt)
                     temp = cexp(temp)

                  else if(j.eq.9) then
                     temp = 1.0
                     gain = 1.0
                  end if
                  temp = temp*gain
                  rnrmt(ich,id,i) = rnrmt(ich,id,i)/temp
               enddo
            enddo
         enddo
      enddo

      return
      end


! { dg-do compile }
! { dg-require-effective-target vect_double }

subroutine foo (x,nnd)
  dimension x(nnd)
  integer i

  do i=1,nnd
    x(i) = 1.d0 + (1.d0*i)/nnd
  end do

end subroutine foo

! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { target { vect_unpack  && vect_intfloat_cvt } } } }


!	Find observed scale score for weighted sums.
!	Responses are in dat.
!	maxscore is the maximum raw score.
!	maxw provides maximum item weights.
!	minscore is the minimum raw score.
!	minw provides minimum item weights.
!	numberscales is the number of scale scores.
!	numcatobs provides ranges for observations.
!	weight is the weight.
!	scale is the matrix of scale transformations.

subroutine obsscale(dat,maxscore,maxw,minscore,&
    minw,numberscales,numcatobs,weight,presence,&
	scale,observedscales)
implicit none

integer,intent(in)::dat(:,:),maxscore,maxw(:),minscore,minw(:),numberscales,&
	numcatobs(:),weight(:)
logical,intent(out)::presence(:)

real(kind=8),intent(in)::scale(numberscales,minscore:maxscore)
real(kind=8),intent(out)::observedscales(:,:)

!   loc is a pointer to the right place in weight
!	obs is observation number.

!	row is a row counter.
!   sumraw is a cumulated sum.

integer::loc,obs,row,sumraw

presence=.true.

!	Obtain results for each observation.
do obs=1,size(dat,2)

    observedscales(:,obs)=0.0_8
    loc=1
    sumraw=0
    do row=1,size(numcatobs)
        if(maxw(row)==minw(row)) then
            sumraw=sumraw+weight(loc)
        else
            if(dat(row,obs)<0.or.dat(row,obs)>=numcatobs(row)) then
                presence(obs)=.false.

                exit
            else
                sumraw=sumraw+weight(loc+dat(row,obs))
            end if
        end if
        loc=loc+numcatobs(row)
    end do
    if(presence(obs)) then
        observedscales(:,obs)=scale(:,sumraw)
    else
        observedscales(:,obs)=0.0_8

    end if

end do
return
end subroutine obsscale


*DECK ORTRAN
      SUBROUTINE ORTRAN (NM, N, LOW, IGH, A, ORT, Z)
C***BEGIN PROLOGUE  ORTRAN
C***PURPOSE  Accumulate orthogonal similarity transformations in the
C            reduction of real general matrix by ORTHES.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (ORTRAN-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure ORTRANS,
C     NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C
C     This subroutine accumulates the orthogonal similarity
C     transformations used in the reduction of a REAL GENERAL
C     matrix to upper Hessenberg form by  ORTHES.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  BALANC.  If  BALANC  has not been
C          used, set LOW=1 and IGH equal to the order of the matrix, N.
C
C        A contains some information about the orthogonal trans-
C          formations used in the reduction to Hessenberg form by
C          ORTHES  in its strict lower triangle.  A is a two-dimensional
C          REAL array, dimensioned A(NM,IGH).
C
C        ORT contains further information about the orthogonal trans-
C          formations used in the reduction by  ORTHES.  Only elements
C          LOW through IGH are used.  ORT is a one-dimensional REAL
C          array, dimensioned ORT(IGH).
C
C     On OUTPUT
C
C        Z contains the transformation matrix produced in the reduction
C          by  ORTHES  to the upper Hessenberg form.  Z is a two-
C          dimensional REAL array, dimensioned Z(NM,N).
C
C        ORT has been used for temporary storage as is not restored.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  ORTRAN
C
      INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
      REAL A(NM,*),ORT(*),Z(NM,*)
      REAL G
C
C     .......... INITIALIZE Z TO IDENTITY MATRIX ..........
C***FIRST EXECUTABLE STATEMENT  ORTRAN
      DO 80 I = 1, N
C
         DO 60 J = 1, N
   60    Z(I,J) = 0.0E0
C
         Z(I,I) = 1.0E0
   80 CONTINUE
C
      KL = IGH - LOW - 1
      IF (KL .LT. 1) GO TO 200
C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
      DO 140 MM = 1, KL
         MP = IGH - MM
         IF (A(MP,MP-1) .EQ. 0.0E0) GO TO 140
         MP1 = MP + 1
C
         DO 100 I = MP1, IGH
  100    ORT(I) = A(I,MP-1)
C
         DO 130 J = MP, IGH
            G = 0.0E0
C
            DO 110 I = MP, IGH
  110       G = G + ORT(I) * Z(I,J)
C     .......... DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES.
C                DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
            G = (G / ORT(MP)) / A(MP,MP-1)
C
            DO 120 I = MP, IGH
  120       Z(I,J) = Z(I,J) + G * ORT(I)
C
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END


! { dg-do compile }

! PR fortran/35770
! Implicit declaration hides type of internal function.

! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>

IMPLICIT CHARACTER (s)
REAL :: RDA

RDA = S_REAL_SQRT_I(42) ! { dg-bogus "Can't convert" }

CONTAINS

REAL FUNCTION S_REAL_SQRT_I(I) RESULT (R)
  IMPLICIT NONE
  INTEGER :: I
  R = 0.0
END FUNCTION S_REAL_SQRT_I

END