!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine storecontactprop(ne,ne0,lakon,kon,ipkon,mi,
     & ielmat,elcon,mortar,adb,nactdof,springarea,
     & ncmat_,ntmat_,stx,temax)
!
!     # # # # # # # # # # # # # # # # # # # # # # # # # # # #
!     Routine that computes the natural period of oscillation
!       of the contact elements. A simplified two-dofs model
!       has been used to compute the natural frequencies due
!       to the relative motion between slave and master surf-
!       ace.
!
!     Main variables and meaning
!
!     temax       : max. natural period of oscillation
!     stx      : vector containig results (from results.c)
!     springmm : average mass of master surface
!     springms : average mass of slave surface
!     xk : spring stiffness between the surfaces
!     xmacont : mass of the actual node of the element
!     areaslav : area of the slave surface (stiffness comp)
!
!     Proposed by Matteo Pacher
!
!     # # # # # # # # # # # # # # # # # # # # # # # # # # # #
!
      implicit none
!
      character*8 lakonl,lakon(*)
!
      integer mi(*),ne,ne0,kon(*),ipkon(*),nactdof(0:mi(2),*),
     &     indexe,j,nope,ielmat(mi(3),*),imat,mortar,nopem,
     &     indexn,nelem,ncmat_,ntmat_
!
      real*8 adb(*),springarea(2,*),pi,te,stx(6,mi(1),ne),
     &     springmm,springms,elcon(0:ncmat_,ntmat_,*),springfac,
     &     xmacont,areaslav,xk,temax
!
      intent(in) ne,ne0,lakon,kon,ipkon,mi,ielmat,elcon,mortar,
     &     adb,nactdof,springarea,ncmat_,ntmat_,stx

      intent(out) temax
!
!     Initialization
!
      temax=0.d0
      pi=4.d0*datan(1.d0)

!     Loop over the contact elements
      do nelem=ne0+1,ne
         indexe=ipkon(nelem)
         lakonl=lakon(nelem)
         imat=ielmat(1,nelem)

         xk=elcon(2,1,imat)     ! element stiffness
         springmm=0.0d0         ! mass master surface
         springms=0.0d0         ! mass slave node/surface

         if(mortar.eq.0) then
!
!     Contact node to face
!
!           nope = number of master nodes + 1 (1 slave node)
!
            nope=ichar(lakonl(8:8))-47
            springfac=1.d0
!
            do indexn=1,nope
               xmacont=0.0d0

               do j=1,3
                  if(nactdof(j,kon(indexe+indexn)).gt.0)then
                     xmacont=max(xmacont,
     &                    adb(nactdof(j,kon(indexe+indexn))))
                  endif
               enddo
!     mass accumulation
               if(indexn.eq.nope)then
                  springms=springms+xmacont
!
!                 mean mass at master nodes
!
                  springmm=springmm/(nope-1.0d0)
               else
                  springmm=springmm+xmacont
               endif
            enddo
!
            areaslav=springarea(1,kon(indexe+nope+1))
            xk=xk*areaslav
!
!           checking whether mass or slave side is constrained
!
            if((springmm.le.0.d0).and.(springms.le.0.d0)) then
               cycle
            elseif(springmm.le.0.d0) then
               springmm=springms
            elseif(springms.le.0.d0) then
               springms=springmm
            endif
!
         elseif(mortar.eq.1) then
!
!           Contact face to face
!
!           nopem = number of master nodes
!
            nopem=ichar(lakonl(8:8))-48
            springfac=0.1d0
!
            do indexn=1,kon(indexe)
!
               xmacont=0.0d0
               do j=1,3
                  if(nactdof(j,kon(indexe+indexn)).gt.0)then
                     xmacont=max(xmacont,
     &                    adb(nactdof(j,kon(indexe+indexn))))
                  endif
               enddo
!
               if(indexn.gt.nopem)then !slave
                  springms=springms+xmacont
               else             !master
                  springmm=springmm+xmacont
               endif
            enddo
!
!           mean mass at slave and master nodes
!
            springms=springms/(kon(indexe)-nopem)
            springmm=springmm/nopem
!
            areaslav=springarea(1,kon(1+indexe+kon(indexe)))
            xk=xk*areaslav*springfac
!
!           checking whether mass or slave side is constrained
!
            if((springmm.le.0.d0).and.(springms.le.0.d0)) then
               cycle
            elseif(springmm.le.0.d0) then
               springmm=springms
            elseif(springms.le.0.d0) then
               springms=springmm
            endif
         endif                  ! face-to-face
!
!     Calculation of the natural period according to the 2-dof model
!
         te=0.d0
         if(xk.ne.0.d0)then
            te=2.d0*pi*dsqrt((springmm*springms)/
     &           ((springmm+springms)*xk))
!
!           exponential pressure-overclosure behavior
!
            if(int(elcon(3,1,imat)).eq.1) then
               te=te/10.d0
            endif
         endif
!
         if(stx(4,1,nelem).gt.0.d0) temax=max(te,temax)
!
      enddo                     ! loop over the contact elements
!
      return
      end


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of di in forward (tangent) mode:
!   variations   of useful results: di
!   with respect to varying inputs: *temp *head *propunit *tsal
!                *pres
!   Plus diff mem management of: temp:in head:in propunit:in tsal:in
!                pres:in
!>    @brief average effective diffusivities on cell faces in x direction
!>    @param[in] i grid indices
!>    @param[in] j grid indices
!>    @param[in] k grid indices
!>    @param[in] spec species
!>    @param[in] ismpl local sample index
!>    @return effective diffusivities (J/mK)
DOUBLE PRECISION FUNCTION g_DI(i, j, k, spec, ismpl, di)
  USE ARRAYS

  USE g_ARRAYS

  USE MOD_GENRL
  IMPLICIT NONE
  INTEGER :: ismpl
  INTEGER :: i, j, k
  INTEGER :: spec
  DOUBLE PRECISION :: f1, f2, prod, summ, betx, bety, betz, bet
  DOUBLE PRECISION :: g_f1, g_f2, g_prod, g_summ, g_betx, &
& g_bety, g_betz, g_bet
  EXTERNAL POR, DISP, VX, VY, VZ
  EXTERNAL g_POR, g_DISP, g_VX, g_VY, g_VZ
  DOUBLE PRECISION :: POR, DISP, VX, VY, &
& VZ
  DOUBLE PRECISION :: g_POR, g_DISP, g_VX, g_VY, g_VZ
  INTRINSIC SQRT
  DOUBLE PRECISION :: result1
  DOUBLE PRECISION :: g_result1
  DOUBLE PRECISION :: result2
  DOUBLE PRECISION :: g_result2
  DOUBLE PRECISION :: temp0
  DOUBLE PRECISION :: di
  di = 0.d0
  betx = 0.d0
  bety = 0.d0
  betz = 0.d0
  IF (k0 .GT. 1 .AND. k .LT. k0) THEN
    g_betz = g_VZ(i, j, k, ismpl, betz)
    g_betz = 2*betz*g_betz
    betz = betz*betz
  ELSE
    g_betz = 0.D0
  END IF
  IF (j0 .GT. 1 .AND. j .LT. j0) THEN
    g_bety = g_VY(i, j, k, ismpl, bety)
    g_bety = 2*bety*g_bety
    bety = bety*bety
  ELSE
    g_bety = 0.D0
  END IF
  IF (i0 .GT. 1 .AND. i .LT. i0) THEN
    g_betx = g_VX(i, j, k, ismpl, betx)
    g_betx = 2*betx*g_betx
    betx = betx*betx
    temp0 = SQRT(betx + bety + betz)
    IF (betx + bety + betz .EQ. 0.0) THEN
      g_bet = 0.D0
    ELSE
      g_bet = (g_betx+g_bety+g_betz)/(2.0*temp0)
    END IF
    bet = temp0
    g_result1 = g_POR(i, j, k, ismpl, result1)
    g_result2 = g_DISP(i, j, k, ismpl, result2)
    g_f1 = diff_c(spec)*g_result1 + bet*g_result2 + result2*&
&     g_bet
    f1 = result1*diff_c(spec) + result2*bet
    g_result1 = g_POR(i + 1, j, k, ismpl, result1)
    g_result2 = g_DISP(i + 1, j, k, ismpl, result2)
    g_f2 = diff_c(spec)*g_result1 + bet*g_result2 + result2*&
&     g_bet
    f2 = result1*diff_c(spec) + result2*bet
    g_prod = f2*g_f1 + f1*g_f2
    prod = f1*f2
    g_summ = delx(i+1)*g_f1 + delx(i)*g_f2
    summ = f1*delx(i+1) + f2*delx(i)
    IF (summ .GT. 0.d0) THEN
      g_di = 2.d0*(g_prod-prod*g_summ/summ)/summ
      di = 2.d0*prod/summ
    ELSE
      g_di = 0.D0
    END IF
  ELSE
    g_di = 0.D0
  END IF
  RETURN
END FUNCTION g_DI


c     end iranfeven

c==============================================================================

      subroutine ranfk( N, K )

c------------------------------------------------------------------------------
c
c     This routine calculates 2**46/N, which should be the period of each of the
c     subsequences of random numbers that are being created. Both the numerator
c     and the result of this calculation are represented as an array of four
c     integers, each of which is one digit of a four-digit moduo-4096 number.  The
c     numerator is represented as (1024, 0, 0, 0 ), using base ten digits.
c
c     It returns the result of the division.
c
c------------------------------------------------------------------------------

      include 'pranf.inc'

      integer N, K, nn, r4, r3, r2, r1, q4, q3, q2, q1

      dimension K( IRandNumSize )

c------------------------------------------------------------------------------

      nn = N + iranfeven( N )

      q4 = 1024 / nn
      r4 = 1024 - (nn * q4)
      q3 = (r4 * 4096) / nn
      r3 = (r4 * 4096) - (nn * q3)
      q2 = (r3 * 4096) / nn
      r2 = (r3 * 4096) - (nn * q2)
      q1 = (r2 * 4096) / nn

      K( 1 ) = q1
      K( 2 ) = q2
      K( 3 ) = q3
      K( 4 ) = q4

      return
      end


!------------------------------------------------------------------------------
! INTERP
!
! Does interpolartion of database given two variables V1 and V2

subroutine interp(v1, v2, vec_f)
    !
    implicit none

    include 'mpintp.inc'

    ! Passed variables:

    real  vec_f(max_mp)
    real  v1, v2

    ! Local variables:
    real X(2)
    real fint
    integer mpp
    !
    if (v1.gt.var1_max) then
        !	write(6,'(a,2(1x,e15.8))')' FATAL ERROR: var1 .gt. max - ',v1,var1_max
        !	STOP

    endif

    if (v1.lt.var1_min) then
        !	write(6,'(a,2(1x,e15.8))')' FATAL ERROR: var1 .lt. min - ',v1,var1_min
        !	STOP
        goto 1
    endif

    if (v2.gt.var2_max) then
        !	write(6,'(a,2(1x,e15.8))')' FATAL ERROR: var2 .gt. max - ',v2,var2_max
        !	STOP
        goto 1
    endif

    if (v2.lt.var2_min) then
        !	write(6,'(a,2(1x,e15.8))')' FATAL ERROR: var2 .lt. min - ',v2,var2_min
        !	STOP
        goto 1
    endif

    if (method_spline.eq.1) then
        ! Get the 62 multipoles (F's) at the grid point (V1,V2)
        ! by 2-dimensional natural cubic spline interpolation.

        call splin2(var1, var2, sf1, d2sf1, nvar1, nvar2, v1, v2, vec_f(1))
        call splin2(var1, var2, sf2, d2sf2, nvar1, nvar2, v1, v2, vec_f(2))
        call splin2(var1, var2, sf3, d2sf3, nvar1, nvar2, v1, v2, vec_f(3))
        call splin2(var1, var2, sf4, d2sf4, nvar1, nvar2, v1, v2, vec_f(4))
        call splin2(var1, var2, sf5, d2sf5, nvar1, nvar2, v1, v2, vec_f(5))
        call splin2(var1, var2, sf6, d2sf6, nvar1, nvar2, v1, v2, vec_f(6))
        call splin2(var1, var2, sf7, d2sf7, nvar1, nvar2, v1, v2, vec_f(7))
        call splin2(var1, var2, sf8, d2sf8, nvar1, nvar2, v1, v2, vec_f(8))
        call splin2(var1, var2, sf9, d2sf9, nvar1, nvar2, v1, v2, vec_f(9))
        call splin2(var1, var2, sf10, d2sf10, nvar1, nvar2, v1, v2, vec_f(10))
        call splin2(var1, var2, sf11, d2sf11, nvar1, nvar2, v1, v2, vec_f(11))
        call splin2(var1, var2, sf12, d2sf12, nvar1, nvar2, v1, v2, vec_f(12))
        call splin2(var1, var2, sf13, d2sf13, nvar1, nvar2, v1, v2, vec_f(13))
        call splin2(var1, var2, sf14, d2sf14, nvar1, nvar2, v1, v2, vec_f(14))
        call splin2(var1, var2, sf15, d2sf15, nvar1, nvar2, v1, v2, vec_f(15))
        call splin2(var1, var2, sf16, d2sf16, nvar1, nvar2, v1, v2, vec_f(16))
        call splin2(var1, var2, sf17, d2sf17, nvar1, nvar2, v1, v2, vec_f(17))
        call splin2(var1, var2, sf18, d2sf18, nvar1, nvar2, v1, v2, vec_f(18))
        call splin2(var1, var2, sf19, d2sf19, nvar1, nvar2, v1, v2, vec_f(19))
        call splin2(var1, var2, sf20, d2sf20, nvar1, nvar2, v1, v2, vec_f(20))
        call splin2(var1, var2, sf21, d2sf21, nvar1, nvar2, v1, v2, vec_f(21))
        call splin2(var1, var2, sf22, d2sf22, nvar1, nvar2, v1, v2, vec_f(22))
        call splin2(var1, var2, sf23, d2sf23, nvar1, nvar2, v1, v2, vec_f(23))
        call splin2(var1, var2, sf24, d2sf24, nvar1, nvar2, v1, v2, vec_f(24))
        call splin2(var1, var2, sf25, d2sf25, nvar1, nvar2, v1, v2, vec_f(25))
        call splin2(var1, var2, sf26, d2sf26, nvar1, nvar2, v1, v2, vec_f(26))
        call splin2(var1, var2, sf27, d2sf27, nvar1, nvar2, v1, v2, vec_f(27))
        call splin2(var1, var2, sf28, d2sf28, nvar1, nvar2, v1, v2, vec_f(28))
        call splin2(var1, var2, sf29, d2sf29, nvar1, nvar2, v1, v2, vec_f(29))
        call splin2(var1, var2, sf30, d2sf30, nvar1, nvar2, v1, v2, vec_f(30))
        call splin2(var1, var2, sf31, d2sf31, nvar1, nvar2, v1, v2, vec_f(31))
        call splin2(var1, var2, sf32, d2sf32, nvar1, nvar2, v1, v2, vec_f(32))
        call splin2(var1, var2, sf33, d2sf33, nvar1, nvar2, v1, v2, vec_f(33))
        call splin2(var1, var2, sf34, d2sf34, nvar1, nvar2, v1, v2, vec_f(34))
        call splin2(var1, var2, sf35, d2sf35, nvar1, nvar2, v1, v2, vec_f(35))
        call splin2(var1, var2, sf36, d2sf36, nvar1, nvar2, v1, v2, vec_f(36))
        call splin2(var1, var2, sf37, d2sf37, nvar1, nvar2, v1, v2, vec_f(37))
        call splin2(var1, var2, sf38, d2sf38, nvar1, nvar2, v1, v2, vec_f(38))
        call splin2(var1, var2, sf39, d2sf39, nvar1, nvar2, v1, v2, vec_f(39))
        call splin2(var1, var2, sf40, d2sf40, nvar1, nvar2, v1, v2, vec_f(40))
        call splin2(var1, var2, sf41, d2sf41, nvar1, nvar2, v1, v2, vec_f(41))
        call splin2(var1, var2, sf42, d2sf42, nvar1, nvar2, v1, v2, vec_f(42))
        call splin2(var1, var2, sf43, d2sf43, nvar1, nvar2, v1, v2, vec_f(43))
        call splin2(var1, var2, sf44, d2sf44, nvar1, nvar2, v1, v2, vec_f(44))
        call splin2(var1, var2, sf45, d2sf45, nvar1, nvar2, v1, v2, vec_f(45))
        call splin2(var1, var2, sf46, d2sf46, nvar1, nvar2, v1, v2, vec_f(46))
        call splin2(var1, var2, sf47, d2sf47, nvar1, nvar2, v1, v2, vec_f(47))
        call splin2(var1, var2, sf48, d2sf48, nvar1, nvar2, v1, v2, vec_f(48))
        call splin2(var1, var2, sf49, d2sf49, nvar1, nvar2, v1, v2, vec_f(49))
        call splin2(var1, var2, sf50, d2sf50, nvar1, nvar2, v1, v2, vec_f(50))
        call splin2(var1, var2, sf51, d2sf51, nvar1, nvar2, v1, v2, vec_f(51))
        call splin2(var1, var2, sf52, d2sf52, nvar1, nvar2, v1, v2, vec_f(52))
        call splin2(var1, var2, sf53, d2sf53, nvar1, nvar2, v1, v2, vec_f(53))
        call splin2(var1, var2, sf54, d2sf54, nvar1, nvar2, v1, v2, vec_f(54))
        call splin2(var1, var2, sf55, d2sf55, nvar1, nvar2, v1, v2, vec_f(55))
        call splin2(var1, var2, sf56, d2sf56, nvar1, nvar2, v1, v2, vec_f(56))
        call splin2(var1, var2, sf57, d2sf57, nvar1, nvar2, v1, v2, vec_f(57))
        call splin2(var1, var2, sf58, d2sf58, nvar1, nvar2, v1, v2, vec_f(58))
        call splin2(var1, var2, sf59, d2sf59, nvar1, nvar2, v1, v2, vec_f(59))
        call splin2(var1, var2, sf60, d2sf60, nvar1, nvar2, v1, v2, vec_f(60))
        call splin2(var1, var2, sf61, d2sf61, nvar1, nvar2, v1, v2, vec_f(61))
        call splin2(var1, var2, sf62, d2sf62, nvar1, nvar2, v1, v2, vec_f(62))
        !
    elseif (method_spline.eq.2) then
        ! Get the 62 multipoles (F's) at the grid point (V1,V2)
        ! by 2-dimensional natural cubic spline interpolation.
        !
        X(1) = v1
        X(2) = v2
        !
        vec_f(1) = fint(2, X, NA, VAR, sf1)
        vec_f(2) = fint(2, X, NA, VAR, sf2)
        vec_f(3) = fint(2, X, NA, VAR, sf3)
        vec_f(4) = fint(2, X, NA, VAR, sf4)
        vec_f(5) = fint(2, X, NA, VAR, sf5)
        vec_f(6) = fint(2, X, NA, VAR, sf6)
        vec_f(7) = fint(2, X, NA, VAR, sf7)
        vec_f(8) = fint(2, X, NA, VAR, sf8)
        vec_f(9) = fint(2, X, NA, VAR, sf9)
        vec_f(10) = fint(2, X, NA, VAR, sf10)
        vec_f(11) = fint(2, X, NA, VAR, sf11)
        vec_f(12) = fint(2, X, NA, VAR, sf12)
        vec_f(13) = fint(2, X, NA, VAR, sf13)
        vec_f(14) = fint(2, X, NA, VAR, sf14)
        vec_f(15) = fint(2, X, NA, VAR, sf15)
        vec_f(16) = fint(2, X, NA, VAR, sf16)
        vec_f(17) = fint(2, X, NA, VAR, sf17)
        vec_f(18) = fint(2, X, NA, VAR, sf18)
        vec_f(19) = fint(2, X, NA, VAR, sf19)
        vec_f(20) = fint(2, X, NA, VAR, sf20)
        vec_f(21) = fint(2, X, NA, VAR, sf21)
        vec_f(22) = fint(2, X, NA, VAR, sf22)
        vec_f(23) = fint(2, X, NA, VAR, sf23)
        vec_f(24) = fint(2, X, NA, VAR, sf24)
        vec_f(25) = fint(2, X, NA, VAR, sf25)
        vec_f(26) = fint(2, X, NA, VAR, sf26)
        vec_f(27) = fint(2, X, NA, VAR, sf27)
        vec_f(28) = fint(2, X, NA, VAR, sf28)
        vec_f(29) = fint(2, X, NA, VAR, sf29)
        vec_f(30) = fint(2, X, NA, VAR, sf30)
        vec_f(31) = fint(2, X, NA, VAR, sf31)
        vec_f(32) = fint(2, X, NA, VAR, sf32)
        vec_f(33) = fint(2, X, NA, VAR, sf33)
        vec_f(34) = fint(2, X, NA, VAR, sf34)
        vec_f(35) = fint(2, X, NA, VAR, sf35)
        vec_f(36) = fint(2, X, NA, VAR, sf36)
        vec_f(37) = fint(2, X, NA, VAR, sf37)
        vec_f(38) = fint(2, X, NA, VAR, sf38)
        vec_f(39) = fint(2, X, NA, VAR, sf39)
        vec_f(40) = fint(2, X, NA, VAR, sf40)
        vec_f(41) = fint(2, X, NA, VAR, sf41)
        vec_f(42) = fint(2, X, NA, VAR, sf42)
        vec_f(43) = fint(2, X, NA, VAR, sf43)
        vec_f(44) = fint(2, X, NA, VAR, sf44)
        vec_f(45) = fint(2, X, NA, VAR, sf45)
        vec_f(46) = fint(2, X, NA, VAR, sf46)
        vec_f(47) = fint(2, X, NA, VAR, sf47)
        vec_f(48) = fint(2, X, NA, VAR, sf48)
        vec_f(49) = fint(2, X, NA, VAR, sf49)
        vec_f(50) = fint(2, X, NA, VAR, sf50)
        vec_f(51) = fint(2, X, NA, VAR, sf51)
        vec_f(52) = fint(2, X, NA, VAR, sf52)
        vec_f(53) = fint(2, X, NA, VAR, sf53)
        vec_f(54) = fint(2, X, NA, VAR, sf54)
        vec_f(55) = fint(2, X, NA, VAR, sf55)
        vec_f(56) = fint(2, X, NA, VAR, sf56)
        vec_f(57) = fint(2, X, NA, VAR, sf57)
        vec_f(58) = fint(2, X, NA, VAR, sf58)
        vec_f(59) = fint(2, X, NA, VAR, sf59)
        vec_f(60) = fint(2, X, NA, VAR, sf60)
        vec_f(61) = fint(2, X, NA, VAR, sf61)
        vec_f(62) = fint(2, X, NA, VAR, sf62)
    endif
    !
    return
    !
    1    do mpp = 1, max_mp
        vec_f(mpp) = 0.0
    enddo
    print *, 'v1= ', v1, ' Q2 min= ', var1_min, ' Q2 max= ', var1_max
    print *, 'v2= ', v2, ' W  min= ', var2_min, ' W  max= ', var2_max
    stop
    !
    return
end


C$Procedure      OSCELT ( Determine conic elements from state )

      SUBROUTINE OSCELT ( STATE, ET, MU, ELTS )
      IMPLICIT NONE

C$ Abstract
C
C     Determine the set of osculating conic orbital elements that
C     corresponds to the state (position, velocity) of a body at
C     some epoch.
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     None.
C
C$ Keywords
C
C     CONIC
C     EPHEMERIS
C
C$ Declarations

      DOUBLE PRECISION      STATE  ( 6 )
      DOUBLE PRECISION      ET
      DOUBLE PRECISION      MU
      DOUBLE PRECISION      ELTS   ( 8 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     STATE      I   State of body at epoch of elements.
C     ET         I   Epoch of elements.
C     MU         I   Gravitational parameter (GM) of primary body.
C     ELTS       O   Equivalent conic elements.
C
C$ Detailed_Input
C
C     STATE      is the state (position and velocity) of the body
C                at some epoch. Components are x, y, z, dx/dt, dy/dt,
C                dz/dt. STATE must be expressed relative to an
C                inertial reference frame.  Units are km and km/sec.
C
C
C     ET         is the epoch of the input state, in ephemeris seconds
C                past J2000.
C
C                                                       3    2
C     MU         is the gravitational parameter (GM, km /sec ) of
C                the primary body.
C
C$ Detailed_Output
C
C     ELTS        are equivalent conic elements describing the orbit
C                 of the body around its primary. The elements are,
C                 in order:
C
C                    RP      Perifocal distance.
C                    ECC     Eccentricity.
C                    INC     Inclination.
C                    LNODE   Longitude of the ascending node.
C                    ARGP    Argument of periapsis.
C                    M0      Mean anomaly at epoch.
C                    T0      Epoch.
C                    MU      Gravitational parameter.
C
C                 The epoch of the elements is the epoch of the input
C                 state. Units are km, rad, rad/sec. The same elements
C                 are used to describe all three types (elliptic,
C                 hyperbolic, and parabolic) of conic orbit.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If MU is not positive, the error SPICE(NONPOSITIVEMASS)
C        is signaled.
C
C     2) If the specific angular momentum vector derived from STATE
C        is the zero vector, the error SPICE(DEGENERATECASE)
C        is signaled.
C
C     3) If the position or velocity vectors derived from STATE
C        is the zero vector, the error SPICE(DEGENERATECASE)
C        is signaled.
C
C     4) If the inclination is determined to be zero or 180 degrees,
C        the longitude of the ascending node is set to zero.
C
C     5) If the eccentricity is determined to be zero, the argument of
C        periapse is set to zero.
C
C     6) If the eccentricy of the orbit is very close to but not
C        equal to zero, the argument of periapse may not be accurately
C        determined.
C
C     7) For inclinations near but not equal to 0 or 180 degrees,
C        the longitude of the ascending node may not be determined
C        accurately.  The argument of periapse and mean anomaly may
C        also be inaccurate.
C
C     8) For eccentricities very close to but not equal to 1, the
C        results of this routine are unreliable.
C
C     9) If the specific angular momentum vector is non-zero but
C        "close" to zero, the results of this routine are unreliable.
C
C    10) If STATE is expressed relative to a non-inertial reference
C        frame, the resulting elements are invalid.  No error checking
C        is done to detect this problem.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The SPICELIB routine CONICS is the inverse of this routine:
C     CONICS maps a set of osculating elements and a time to a state
C     vector.
C
C$ Examples
C
C     Let VINIT contain the initial state of a spacecraft relative to
C     the center of a planet at epoch ET, and let GM be the gravitation
C     parameter of the planet. The call
C
C        CALL OSCELT ( VINIT, ET, GM, ELTS )
C
C     produces a set of osculating elements describing the nominal
C     orbit that the spacecraft would follow in the absence of all
C     other bodies in the solar system.
C
C     Now let STATE contain the state of the same spacecraft at some
C     other epoch, LATER. The difference between this state and the
C     state predicted by the nominal orbit at the same epoch can be
C     computed as follows.
C
C        CALL CONICS ( ELTS, LATER, NOMINAL )
C        CALL VSUBG  ( NOMINAL, STATE, 6, DIFF )
C
C        WRITE (*,*) 'Perturbation in x, dx/dt = ', DIFF(1), DIFF(4)
C        WRITE (*,*) '                y, dy/dt = ', DIFF(2), DIFF(5)
C        WRITE (*,*) '                z, dz/dt = ', DIFF(3), DIFF(6)
C
C$ Restrictions
C
C     1) The input state vector must be expressed relative to an
C        inertial reference frame.
C
C     2) Osculating elements are generally not useful for
C        high-accuracy work.
C
C     3) Accurate osculating elements may be difficult to derive for
C        near-circular or near-equatorial orbits. Osculating elements
C        for such orbits should be used with caution.
C
C     4) Extracting osculating elements from a state vector is a
C        mathematically simple but numerically challenging task.  The
C        mapping from a state vector to equivalent elements is
C        undefined for certain state vectors, and the mapping is
C        difficult to implement with finite precision arithmetic for
C        states near the subsets of R6 where singularities occur.
C
C        In general, the elements found by this routine can have
C        two kinds of problems:
C
C           - The elements are not accurate but still represent
C             the input state accurately.  The can happen in
C             cases where the inclination is near zero or 180
C             degrees, or for near-circular orbits.
C
C           - The elements are garbage.  This can occur when
C             the eccentricity of the orbit is close to but
C             not equal to 1.   In general, any inputs that cause
C             great loss of precision in the computation of the
C             specific angular momentum vector or the eccentricity
C             vector will result in invalid outputs.
C
C        For further details, see the Exceptions section.
C
C        Users of this routine should carefully consider whether
C        it is suitable for their applications.  One recommended
C        "sanity check" on the outputs is to supply them to the
C        SPICELIB routine CONICS and compare the resulting state
C        vector with the one supplied to this routine.
C
C$ Literature_References
C
C     [1] Roger Bate, Fundamentals of Astrodynamics, Dover, 1971.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C     K.R. Gehringer  (JPL)
C     I.M. Underwood  (JPL)
C     E.D. Wright     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.3.1, 28-FEB-2008 (NJB)
C
C        Updated Index_Entries header section to use keywords
C        "osculating" and "convert." Updated Particulars header
C        section to refer to CONICS. Fixed typo in in-line
C        comments.
C
C-    SPICELIB Version 1.3.0, 17-NOV-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL call.
C
C        The Exceptions and Restrictions header sections were updated.
C
C-    SPICELIB Version 1.2.0, 28-JAN-2003 (NJB) (EDW)
C
C        Bug fixes:  routine previously didn't correctly compute
C        the argument of periapse or mean anomaly for some cases.
C        Also, the arguments of the ACOS and DACOSH functions were
C        able to go out of range, causing floating-point exceptions.
C
C        The computations of M0 and INC were re-coded for improved
C        accuracy.
C
C        Also, added error checks for non-positive MU, zero
C        position, velocity, and specific angular momentum vectors.
C
C-    SPICELIB Version 1.1.0, 29-FEB-1996 (KRG)
C
C        The declaration for the SPICELIB function PI is now
C        preceded by an EXTERNAL statement declaring PI to be an
C        external function. This removes a conflict with any
C        compilers that have a PI intrinsic function.
C
C-    SPICELIB Version 1.0.2, 6-APR-1995 (WLT)
C
C        A typo was fixed in the description of the node vector
C        in the comments of the routine.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (IMU)
C
C-&

C$ Index_Entries
C
C     conic elements from state
C     osculating elements from state
C     convert state to osculating elements
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.3.0, 02-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL call.
C
C-    SPICELIB Version 1.2.0, 28-JAN-2003 (NJB) (EDW)
C
C        Bug fixes:  routine previously didn't correctly compute
C        the argument of periapse or mean anomaly for some cases.
C        Also, the arguments of the ACOS and DACOSH functions were
C        able to go out of range, causing floating-point exceptions.
C
C        The old computation of ARGP did not work for cases where
C        the inclination was 0 or pi:  the sign of ARGP was sometimes
C        incorrect.
C
C        The new method uses the criterion: for inclination zero or pi
C        the argument of periapse is between zero and pi radians when
C
C           e  *  ( h x n )  >  0
C           -       -   -    -
C
C        where
C
C           e  is the eccentricity vector,
C           -
C
C           h  is the specific angular momentum vector,
C           -
C
C           n  is the node vector.
C           -
C
C        The computation of M0 was re-coded for improved accuracy.
C        The new computation uses ATAN2 rather than ACOS to find
C        the eccentric anomaly for the ellipse case.  The quadrant
C        of M0 is now found by converting the position to the
C        perifocal frame and finding the corresponding longitude.
C
C        The old method, using the sign of <r,v>, did not work
C        for circular orbits and was unreliable for near-circular
C        orbits.
C
C        Inclination is now computed using VSEP.
C
C        Also, added error checks for non-positive MU, zero
C        position, velocity, and specific angular momentum vectors.
C
C-    SPICELIB Version 1.1.0, 29-FEB-1996 (KRG)
C
C        The declaration for the SPICELIB function PI is now
C        preceded by an EXTERNAL statement declaring PI to be an
C        external function. This removes a conflict with any
C        compilers that have a PI intrinsic function.
C
C-    SPICELIB Version 1.0.2, 6-APR-1995 (WLT)
C
C        A typo was fixed in the description of the node vector
C        in the comments of the routine.
C
C-    Beta Version 1.0.1, 27-JAN-1989 (IMU)
C
C        Examples section completed.
C
C-&

C
C     External functions
C
      EXTERNAL              PI

C
C     SPICELIB functions
C
      DOUBLE PRECISION      DACOSH
      DOUBLE PRECISION      EXACT
      DOUBLE PRECISION      PI
      DOUBLE PRECISION      TWOPI
      DOUBLE PRECISION      VNORM
      DOUBLE PRECISION      VDOT
      DOUBLE PRECISION      VSEP

      LOGICAL               RETURN
      LOGICAL               VZERO

C
C     Local parameters
C
      DOUBLE PRECISION      CLOSE
      PARAMETER           ( CLOSE = 1.D-10 )

C
C     Local variables
C
      DOUBLE PRECISION      ARGP
      DOUBLE PRECISION      COSEA
      DOUBLE PRECISION      COSHF
      DOUBLE PRECISION      E      ( 3 )
      DOUBLE PRECISION      EA
      DOUBLE PRECISION      ECC
      DOUBLE PRECISION      H      ( 3 )
      DOUBLE PRECISION      INC
      DOUBLE PRECISION      LNODE
      DOUBLE PRECISION      M0
      DOUBLE PRECISION      N      ( 3 )
      DOUBLE PRECISION      NU
      DOUBLE PRECISION      P
      DOUBLE PRECISION      PERIX  ( 3 )
      DOUBLE PRECISION      PERIY  ( 3 )
      DOUBLE PRECISION      R      ( 3 )
      DOUBLE PRECISION      RMAG
      DOUBLE PRECISION      RP
      DOUBLE PRECISION      SINEA
      DOUBLE PRECISION      V      ( 3 )
      DOUBLE PRECISION      VMAG
      DOUBLE PRECISION      XPROD  ( 3 )
      DOUBLE PRECISION      ZVEC   ( 3 )

C
C     Saved variables
C
      SAVE                  ZVEC

C
C     Initial values
C
      DATA                  ZVEC / 0.D0, 0.D0, 1.D0 /

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

      IF ( MU .LE. 0.0D0 ) THEN

         CALL SETMSG ( 'MU = #; non-positive gravitational parameter' )
         CALL ERRDP  ( '#',  MU                                       )
         CALL SIGERR ( 'SPICE(NONPOSITIVEMASS)'                       )
         CALL CHKOUT ( 'OSCELT'                                       )
         RETURN

      END IF

C
C     In order to convert a position and velocity to an equivalent
C     set of (osculating) orbital elements, we need to determine three
C     principal vectors associated with the orbit:
C
C        h         The angular momentum vector. This is perpendicular
C        -         to the plane of the orbit.
C
C                        h = r X v
C                        -   -   -
C
C        n         The node vector. This is perpendicular to the
C        -         normals of both the reference and orbital planes;
C                  it lies in the intersecton of these planes,
C                  pointing toward the ascending node.
C
C                             ^
C                        n  = k X h  = ( -h , h , 0 )
C                        -        -        y   x
C
C        e         The eccentricity vector. This lies in the plane
C        -         of the orbit, and points toward periapse. The
C                  magnitude of this vector is the eccentricity.
C
C                                      2
C                        e = (1/mu)( (v  - mu/r) r  -  <r,v> v )
C                        -                       -      - -  -
C
      CALL VEQU ( STATE(1), R )
      CALL VEQU ( STATE(4), V )

C
C     Check for non-physical cases. Probably due to user
C     input error
C
      IF ( VZERO(R) ) THEN

         CALL SETMSG ( 'Zero vector for input position vector.' )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                  )
         CALL CHKOUT ( 'OSCELT'                                 )
         RETURN

      END IF

      IF ( VZERO(V) ) THEN

         CALL SETMSG ( 'Zero vector for input velocity vector.' )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                  )
         CALL CHKOUT ( 'OSCELT'                                 )
         RETURN

      END IF

      RMAG   =  VNORM(R)
      VMAG   =  VNORM(V)

      CALL VCRSS ( R, V, H )

C
C     If the specific angular momentum vector is the zero vector,
C     we have a degenerate orbit and cannot proceed.
C
      IF ( VZERO(H) ) THEN

         CALL SETMSG ( 'Input position and velocity are too close '  //
     .                 'to parallel; the specific angular momentum ' //
     .                 'vector is zero.'                              )
         CALL SIGERR ( 'SPICE(DEGENERATECASE)'                        )
         CALL CHKOUT ( 'OSCELT'                                       )
         RETURN

      END IF

      CALL VPACK  ( -H(2), H(1), 0.D0, N )

      CALL VLCOM  ( VMAG**2 - MU/RMAG,  R,  -VDOT(R,V),  V,  E )
      CALL VSCLIP ( 1.D0/MU, E )

C
C     We begin by determining the size and shape of the orbit.
C
C     The eccentricity of the orbit is the magnitude of the
C     eccentricity vector. If the eccentricity is "close" to one,
C     go ahead and make this a parabola.
C
C     The perifocal distance depends on the eccentricity and the
C     semi-latus rectum, which in turn orbit depends only on the
C     specific angular momentum of the orbiting object.
C

      ECC = EXACT ( VNORM ( E ), 1.D0, CLOSE )

      P   = VDOT  ( H,H ) / MU
      RP  = P / (1.D0 + ECC)

C
C     Next, the orientation of the orbit.
C                                                       ^
C     The inclination of the orbit is the angle between k (which is
C     perpendicular to the equator) and h (which is perpendicular to
C     the orbit.                        -
C
C     If close to zero or pi, make it exact. In either case, the node
C     vector becomes undefined.
C

      INC = VSEP ( H, ZVEC )

      IF ( ABS ( INC - 0.D0 ) .LT. CLOSE ) THEN
         INC = 0.D0
         CALL VPACK ( 1.D0, 0.D0, 0.D0, N )

      ELSE IF ( ABS ( INC - PI() ) .LT. CLOSE ) THEN
         INC = PI()
         CALL VPACK ( 1.D0, 0.D0, 0.D0, N )
      END IF

C
C                                                              ^
C     The longitude of the ascending node is the angle between i
C     (the x-axis) and the node vector, n.
C                                       -
C
      LNODE = ATAN2 ( N(2), N(1) )

      IF ( LNODE .LT. 0.D0 ) THEN
         LNODE = LNODE + TWOPI()
      END IF

C
C     The argument of periapsis is the angle between the node vector
C     n, and the eccentricity vector e. This is not defined for
C     -                              -
C     circular orbits.
C
C
      IF ( ECC .EQ. 0.D0 ) THEN

         ARGP = 0.D0

      ELSE

C
C        Set the magnitude of ARGP; we'll determine the sign next.
C
         ARGP = VSEP ( N, E )

         IF ( ARGP .NE. 0.D0 ) THEN

            IF (  ( INC .EQ. 0.D0 ) .OR. ( INC .EQ. PI() )  ) THEN
C
C              The quadrant of ARGP is determined by the component of E
C              in the direction H x N.
C
               CALL UCRSS ( H, N, XPROD )

               IF (  VDOT( E, XPROD ) .LT. 0.D0 ) THEN

                  ARGP = TWOPI() - ARGP

               END IF

            ELSE IF ( E(3) .LT. 0.D0 ) THEN
C
C              The periapsis is below the reference plane;  the argument
C              of periapsis must be greater than 180 degrees.
C
               ARGP = TWOPI() - ARGP

            END IF

         END IF

      END IF

C
C     And finally, the position of the object within the orbit.
C     The true anomaly, nu, is the angle between the eccentricity
C     and radius vectors, e and r. (For circular orbits, substitute
C     n for e.)           -     -
C     -     -
C
C     This angle increases in the counterclockwise direction about h.
C     We express the position in the perifocal frame in order to
C     extract nu.
C
      IF ( ECC .EQ. 0.D0 ) THEN
C
C        In this case, the argument of periapse is set to zero,
C        so the nu is measured from N.
C
         CALL VHAT  ( N, PERIX )

      ELSE
         CALL VHAT  ( E, PERIX )
      END IF

      CALL UCRSS ( H, PERIX, PERIY )

      NU = ATAN2 ( VDOT(R,PERIY), VDOT(R,PERIX) )

C
C     Unfortunately, the other element routines need the mean
C     anomaly, M. The true and mean anomalies are related through
C     the eccentric anomalies D (parabolas), E (ellipses), and
C     F (hyperbolas), as shown below.
C
C                      e + cos(nu)
C           cos(E)  = ---------------         (ellipse)
C                      1 + e cos(nu)
C
C           M       = E - e sin(E)
C
C
C                       e + cos(nu)
C           cosh(F) = ---------------         (hyperbola)
C                       1 + e cos(nu)
C
C           M       = e sinh(F) - F
C
C
C           D       = tan(nu/2)               (parabola)
C
C                           3
C           M       =  D + D / 3
C
C     For elliptic orbits, the mean anomaly should be in [0,2*pi].
C

      IF ( ECC .LT. 1.D0 ) THEN
C
C        For improved numerical performance, we compute both the
C        sine and cosine of the eccentric anomaly, then let ATAN2
C        find the eccentric anomaly.
C
         COSEA  = ( ECC + COS(NU) )  /  ( 1.D0 + ECC*COS(NU) )

C
C        Here we use the relationships (here b is the length
C        of the semi-minor axis):
C
C           a sin(E) = (a/b) r sin(nu)
C
C           sin(E)   = (r/b) sin(nu)
C                               ______________
C                    = (r/rp) \/ (1-e) / (1+e)  sin(nu)
C
C
         SINEA  = (RMAG/RP) * SQRT( (1.D0-ECC) / (1.D0+ECC) ) * SIN(NU)

         EA     =  ATAN2 ( SINEA, COSEA )

         M0     =  SIGN ( EA - ECC*SIN(EA),  NU )

         IF ( M0 .LT. 0.D0 ) THEN

            M0 = M0 + TWOPI()

         END IF

      ELSE IF ( ECC .GT. 1.D0 ) THEN

         COSHF = (ECC + COS(NU)) / (1.D0 + ECC*COS(NU))

         EA    =  DACOSH (  MAX ( 1.D0, COSHF )  )

         M0    =  SIGN( ECC*SINH(EA) - EA,  NU )

      ELSE

         EA = TAN(NU/2.D0)
         M0 = SIGN ( EA + EA**3/3.D0,  NU )

      END IF

C
C     Return the elements as a vector, suitable for input to CONICS.
C
      ELTS(1) = RP
      ELTS(2) = ECC
      ELTS(3) = INC
      ELTS(4) = LNODE
      ELTS(5) = ARGP
      ELTS(6) = M0
      ELTS(7) = ET
      ELTS(8) = MU

      CALL CHKOUT ( 'OSCELT' )
      RETURN
      END


submodule (calculus) div

implicit none (type, external)

contains

module procedure div3D_curv_3

!------------------------------------------------------------
!-------COMPUTE A 3D DIVERGENCE.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE.  DX(I) IS PRESUMED
!-------TO BE THE *BACKWARD* DIFFERENCE AT POINT I
!-------
!-------AN EXTRA STEP IS NEEDED IN THIS ROUTINE SINCE WE HAVE
!-------TO DETERMINE WHETHER THIS IS A FULL-GRID OR SUBGRID
!-------DERIVATIVE.
!------------------------------------------------------------

integer :: ix1,ix2,ix3,lx1,lx2,lx3

real(wp), dimension(:,:,:), pointer :: h1,h2,h3   !local references to the metric factors to be used in the derivative
real(wp), dimension(:), pointer :: dx1
real(wp), dimension(:), pointer :: dx2
real(wp), dimension(:), pointer :: dx3    !local reference to the backward difference

lx1=size(f1,1)
lx2=size(f1,2)
lx3=size(f1,3)

!ERROR CHECKING TO MAKE SURE DIFFRENCING IS DONE OVER A CONSISTENTLY-SIZED GRID
if (lx1 /= ubnd1-lbnd1+1 .or. lx2 /= ubnd2-lbnd2+1 .or. lx3 /= ubnd3-lbnd3+1) then
  error stop '!!!  Inconsistent array and mesh sizes in gradient function.'   !just bail on it and let the user figure it out
end if

!CHOOSE THE METRIC FACTORS VARIABLES BASED ON THE SIZE OF THE X3-VARIABLE, ALSO RECAST SO THE
!INDICES USED FOR F CAN ALSO BE USED IN THE METRIC FACTOR AND DX VARIABLE
!Can avoid wasting memory and copying of metric factor arrays by recoding with pointers
!Unfortunately a pointer is not guaranteed to be contiguous in memory so there may be a performance hit in doing this...
dx1=>x%dx1(lbnd1:ubnd1)
dx2=>x%dx2(lbnd2:ubnd2)
if (lx3<=x%lx3+4) then     !+4 in case we need to differentiate over ghost cells, e.g. in compression terms
  h1=>x%h1(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  h2=>x%h2(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  h3=>x%h3(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  dx3=>x%dx3(lbnd3:ubnd3)
else if (lx3<=x%lx3all+4) then     !presumes root.  may cause a seg fault since workers don't have the full-grid metric factors (should they?)
  h1=>x%h1all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  h2=>x%h2all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  h3=>x%h3all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  dx3=>x%dx3all(lbnd3:ubnd3)
  print *,   '! Accessing root-only grid information in divergence function div3D'
else
  error stop '!!!  Array size is larger than full mesh.'
end if

!REASSIGNING POINTERS AS SUBARRAYS TO BE DIFFERENCED PRODUCED CLEAN CODE (BELOW), BUT NOW REQUIRES THAT WE OFFSET
!ARRAY INDICES FOR THE POINTER VARIABLES, SINCE, BY DEFAULT, THEY START AT 1...  ACTUALLY THIS SHOULD NOT BE THE CASE
!SINCE EVERYTHING IS GETTING OFFSET (F UPON BEING PASSED INTO THIS FUNCTION AND THEN DIFFERENTIALS IN THE POINTER
!ASSIGNMENTS...

!FINITE DIFFERENCES
do ix3=1,lx3
  do ix2=1,lx2
    div3D_curv_3(1,ix2,ix3)=(h2(2,ix2,ix3)*h3(2,ix2,ix3)*f1(2,ix2,ix3)-h2(1,ix2,ix3)*h3(1,ix2,ix3)*f1(1,ix2,ix3))/dx1(2)
    div3D_curv_3(2:lx1-1,ix2,ix3)=(h2(3:lx1,ix2,ix3)*h3(3:lx1,ix2,ix3)*f1(3:lx1,ix2,ix3)- &
                h2(1:lx1-2,ix2,ix3)*h3(1:lx1-2,ix2,ix3)*f1(1:lx1-2,ix2,ix3)) / (dx1(3:lx1)+dx1(2:lx1-1))
    div3D_curv_3(lx1,ix2,ix3)=(h2(lx1,ix2,ix3)*h3(lx1,ix2,ix3)*f1(lx1,ix2,ix3)- &
                             h2(lx1-1,ix2,ix3)*h3(lx1-1,ix2,ix3)*f1(lx1-1,ix2,ix3))/dx1(lx1)
  end do
end do

if (lx2>1) then   !only if the x2-direction is not null
  do ix3=1,lx3
    do ix1=1,lx1
      div3D_curv_3(ix1,1,ix3)=div3D_curv_3(ix1,1,ix3)+ &
                    (h1(ix1,2,ix3)*h3(ix1,2,ix3)*f2(ix1,2,ix3)-h1(ix1,1,ix3)*h3(ix1,1,ix3)*f2(ix1,1,ix3))/dx2(2)
      div3D_curv_3(ix1,2:lx2-1,ix3)=div3D_curv_3(ix1,2:lx2-1,ix3)+ &
                    (h1(ix1,3:lx2,ix3)*h3(ix1,3:lx2,ix3)*f2(ix1,3:lx2,ix3)- &
                     h1(ix1,1:lx2-2,ix3)*h3(ix1,1:lx2-2,ix3)*f2(ix1,1:lx2-2,ix3)) &
                             /(dx2(3:lx2)+dx2(2:lx2-1))
      div3D_curv_3(ix1,lx2,ix3)=div3D_curv_3(ix1,lx2,ix3)+ &
                    (h1(ix1,lx2,ix3)*h3(ix1,lx2,ix3)*f2(ix1,lx2,ix3)- &
                     h1(ix1,lx2-1,ix3)*h3(ix1,lx2-1,ix3)*f2(ix1,lx2-1,ix3))/dx2(lx2)
    end do
  end do
end if

do ix2=1,lx2
  do ix1=1,lx1
    div3D_curv_3(ix1,ix2,1)=div3D_curv_3(ix1,ix2,1)+ &
               (h1(ix1,ix2,2)*h2(ix1,ix2,2)*f3(ix1,ix2,2)-h1(ix1,ix2,1)*h2(ix1,ix2,1)*f3(ix1,ix2,1))/dx3(2)
    div3D_curv_3(ix1,ix2,2:lx3-1)=div3D_curv_3(ix1,ix2,2:lx3-1)+ &
               (h1(ix1,ix2,3:lx3)*h2(ix1,ix2,3:lx3)*f3(ix1,ix2,3:lx3)- &
                h1(ix1,ix2,1:lx3-2)*h2(ix1,ix2,1:lx3-2)*f3(ix1,ix2,1:lx3-2))&
                          /(dx3(3:lx3)+dx3(2:lx3-1))
    div3D_curv_3(ix1,ix2,lx3)=div3D_curv_3(ix1,ix2,lx3)+ &
               (h1(ix1,ix2,lx3)*h2(ix1,ix2,lx3)*f3(ix1,ix2,lx3)- &
                h1(ix1,ix2,lx3-1)*h2(ix1,ix2,lx3-1)*f3(ix1,ix2,lx3-1))/dx3(lx3)
  end do
end do

div3D_curv_3=div3D_curv_3/(h1*h2*h3)

end procedure div3D_curv_3

module procedure div3D_curv_23

!------------------------------------------------------------
!-------COMPUTE A 3D DIVERGENCE.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE.  DX(I) IS PRESUMED
!-------TO BE THE *BACKWARD* DIFFERENCE AT POINT I
!-------
!-------AN EXTRA STEP IS NEEDED IN THIS ROUTINE SINCE WE HAVE
!-------TO DETERMINE WHETHER THIS IS A FULL-GRID OR SUBGRID
!-------DERIVATIVE.
!------------------------------------------------------------

integer :: ix1,ix2,ix3,lx1,lx2,lx3

real(wp), dimension(:,:,:), pointer :: h1,h2,h3   !local references to the metric factors to be used in the derivative
real(wp), dimension(:), pointer :: dx1
real(wp), dimension(:), pointer :: dx2
real(wp), dimension(:), pointer :: dx3    !local reference to the backward difference

lx1=size(f1,1)
lx2=size(f1,2)
lx3=size(f1,3)

if (lx1/=size(f2,1) .or. lx2/=size(f2,2) .or. lx3/=size(f2,3) .or. lx1/=size(f3,1) .or. &
    lx2/=size(f3,2) .or. lx3/=size(f3,3)) error stop '!!! bad component sizes'

!ERROR CHECKING TO MAKE SURE DIFFRENCING IS DONE OVER A CONSISTENTLY-SIZED GRID
if (lx1 /= ubnd1-lbnd1+1 .or. lx2 /= ubnd2-lbnd2+1 .or. lx3 /= ubnd3-lbnd3+1) then
  error stop '!!!  Inconsistent array and mesh sizes in div3D function.'   !just bail on it and let the user figure it out
end if

!CHOOSE THE METRIC FACTORS VARIABLES BASED ON THE SIZE OF THE X3-VARIABLE, ALSO RECAST SO THE
!INDICES USED FOR F CAN ALSO BE USED IN THE METRIC FACTOR AND DX VARIABLE
!Can avoid wasting memory and copying of metric factor arrays by recoding with pointers
!Unfortunately a pointer is not guaranteed to be contiguous in memory so there may be a performance hit in doing this...
dx1=>x%dx1(lbnd1:ubnd1)
if (lx3<=x%lx3+4 .and. lx2<=x%lx2+4) then     !+4 in case we need to differentiate over ghost cells, e.g. in compression terms
  h1=>x%h1(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  h2=>x%h2(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  h3=>x%h3(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  dx3=>x%dx3(lbnd3:ubnd3)
  dx2=>x%dx2(lbnd2:ubnd2)
else if (lx3<=x%lx3all+4 .and. lx2<=x%lx2all+4) then     !presumes root or some process that has access to ALL full grid variables (normally only root).
  h1=>x%h1all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  h2=>x%h2all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  h3=>x%h3all(lbnd1:ubnd1,lbnd2:ubnd2,lbnd3:ubnd3)
  dx3=>x%dx3all(lbnd3:ubnd3)
  dx2=>x%dx2all(lbnd2:ubnd2)
  print *,   '! Accessing root-only grid information in divergence function div3D'
else
  error stop '!!!  Array size is larger than full mesh or inconsistent sizes in data to be differentiated.'
end if

!REASSIGNING POINTERS AS SUBARRAYS TO BE DIFFERENCED PRODUCED CLEAN CODE (BELOW), BUT NOW REQUIRES THAT WE OFFSET
!ARRAY INDICES FOR THE POINTER VARIABLES, SINCE, BY DEFAULT, THEY START AT 1...  ACTUALLY THIS SHOULD NOT BE THE CASE
!SINCE EVERYTHING IS GETTING OFFSET (F UPON BEING PASSED INTO THIS FUNCTION AND THEN DIFFERENTIALS IN THE POINTER
!ASSIGNMENTS...

!FINITE DIFFERENCES
do ix3=1,lx3
  do ix2=1,lx2
    div3D_curv_23(1,ix2,ix3)=(h2(2,ix2,ix3)*h3(2,ix2,ix3)*f1(2,ix2,ix3)-h2(1,ix2,ix3)*h3(1,ix2,ix3)*f1(1,ix2,ix3))/dx1(2)

    div3D_curv_23(2:lx1-1,ix2,ix3)=(h2(3:lx1,ix2,ix3)*h3(3:lx1,ix2,ix3)*f1(3:lx1,ix2,ix3)- &
                h2(1:lx1-2,ix2,ix3)*h3(1:lx1-2,ix2,ix3)*f1(1:lx1-2,ix2,ix3)) / (dx1(3:lx1)+dx1(2:lx1-1))

    div3D_curv_23(lx1,ix2,ix3)=(h2(lx1,ix2,ix3)*h3(lx1,ix2,ix3)*f1(lx1,ix2,ix3)- &
                             h2(lx1-1,ix2,ix3)*h3(lx1-1,ix2,ix3)*f1(lx1-1,ix2,ix3))/dx1(lx1)
  end do
end do

if (x%lx2>1) then   !only if the x2-direction is not null, this should be based on the grid data and not the data passed into this function
  do ix3=1,lx3
    do ix1=1,lx1
      div3D_curv_23(ix1,1,ix3)=div3D_curv_23(ix1,1,ix3)+ &
                    (h1(ix1,2,ix3)*h3(ix1,2,ix3)*f2(ix1,2,ix3)-h1(ix1,1,ix3)*h3(ix1,1,ix3)*f2(ix1,1,ix3))/dx2(2)

      div3D_curv_23(ix1,2:lx2-1,ix3)=div3D_curv_23(ix1,2:lx2-1,ix3)+ &
                    (h1(ix1,3:lx2,ix3)*h3(ix1,3:lx2,ix3)*f2(ix1,3:lx2,ix3)- &
                     h1(ix1,1:lx2-2,ix3)*h3(ix1,1:lx2-2,ix3)*f2(ix1,1:lx2-2,ix3)) &
                             /(dx2(3:lx2)+dx2(2:lx2-1))

      div3D_curv_23(ix1,lx2,ix3)=div3D_curv_23(ix1,lx2,ix3)+ &
                    (h1(ix1,lx2,ix3)*h3(ix1,lx2,ix3)*f2(ix1,lx2,ix3)- &
                     h1(ix1,lx2-1,ix3)*h3(ix1,lx2-1,ix3)*f2(ix1,lx2-1,ix3))/dx2(lx2)
    end do
  end do
end if

if (x%lx3>1) then    !only if non-singleton 3rd dimension (I'm not sure this will ever be the case due to dimension swapping)
  do ix2=1,lx2
    do ix1=1,lx1
      div3D_curv_23(ix1,ix2,1)=div3D_curv_23(ix1,ix2,1)+ &
                 (h1(ix1,ix2,2)*h2(ix1,ix2,2)*f3(ix1,ix2,2)-h1(ix1,ix2,1)*h2(ix1,ix2,1)*f3(ix1,ix2,1))/dx3(2)

      div3D_curv_23(ix1,ix2,2:lx3-1)=div3D_curv_23(ix1,ix2,2:lx3-1)+ &
                 (h1(ix1,ix2,3:lx3)*h2(ix1,ix2,3:lx3)*f3(ix1,ix2,3:lx3)- &
                  h1(ix1,ix2,1:lx3-2)*h2(ix1,ix2,1:lx3-2)*f3(ix1,ix2,1:lx3-2))&
                            /(dx3(3:lx3)+dx3(2:lx3-1))

      div3D_curv_23(ix1,ix2,lx3)=div3D_curv_23(ix1,ix2,lx3)+ &
                 (h1(ix1,ix2,lx3)*h2(ix1,ix2,lx3)*f3(ix1,ix2,lx3)- &
                  h1(ix1,ix2,lx3-1)*h2(ix1,ix2,lx3-1)*f3(ix1,ix2,lx3-1))/dx3(lx3)
    end do
  end do
end if

div3D_curv_23=div3D_curv_23/(h1*h2*h3)

end procedure div3D_curv_23

end submodule div


!*==zlahr2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to apply the transformation to the unreduced part of A.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZLAHR2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
!
!       .. Scalar Arguments ..
!       INTEGER            K, LDA, LDT, LDY, N, NB
!       ..
!       .. Array Arguments ..
!       COMPLEX*16        A( LDA, * ), T( LDT, NB ), TAU( NB ),
!      $                   Y( LDY, NB )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)
!> matrix A so that elements below the k-th subdiagonal are zero. The
!> reduction is performed by an unitary similarity transformation
!> Q**H * A * Q. The routine returns the matrices V and T which determine
!> Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T.
!>
!> This is an auxiliary routine called by ZGEHRD.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.
!> \endverbatim
!>
!> \param[in] K
!> \verbatim
!>          K is INTEGER
!>          The offset for the reduction. Elements below the k-th
!>          subdiagonal in the first NB columns are reduced to zero.
!>          K < N.
!> \endverbatim
!>
!> \param[in] NB
!> \verbatim
!>          NB is INTEGER
!>          The number of columns to be reduced.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA,N-K+1)
!>          On entry, the n-by-(n-k+1) general matrix A.
!>          On exit, the elements on and above the k-th subdiagonal in
!>          the first NB columns are overwritten with the corresponding
!>          elements of the reduced matrix; the elements below the k-th
!>          subdiagonal, with the array TAU, represent the matrix Q as a
!>          product of elementary reflectors. The other columns of A are
!>          unchanged. See Further Details.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] TAU
!> \verbatim
!>          TAU is COMPLEX*16 array, dimension (NB)
!>          The scalar factors of the elementary reflectors. See Further
!>          Details.
!> \endverbatim
!>
!> \param[out] T
!> \verbatim
!>          T is COMPLEX*16 array, dimension (LDT,NB)
!>          The upper triangular matrix T.
!> \endverbatim
!>
!> \param[in] LDT
!> \verbatim
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB.
!> \endverbatim
!>
!> \param[out] Y
!> \verbatim
!>          Y is COMPLEX*16 array, dimension (LDY,NB)
!>          The n-by-nb matrix Y.
!> \endverbatim
!>
!> \param[in] LDY
!> \verbatim
!>          LDY is INTEGER
!>          The leading dimension of the array Y. LDY >= N.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16OTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  The matrix Q is represented as a product of nb elementary reflectors
!>
!>     Q = H(1) H(2) . . . H(nb).
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**H
!>
!>  where tau is a complex scalar, and v is a complex vector with
!>  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
!>  A(i+k+1:n,i), and tau in TAU(i).
!>
!>  The elements of the vectors v together form the (n-k+1)-by-nb matrix
!>  V which is needed, with T and Y, to apply the transformation to the
!>  unreduced part of the matrix, using an update of the form:
!>  A := (I - V*T*V**H) * (A - Y*V**H).
!>
!>  The contents of A on exit are illustrated by the following example
!>  with n = 7, k = 3 and nb = 2:
!>
!>     ( a   a   a   a   a )
!>     ( a   a   a   a   a )
!>     ( a   a   a   a   a )
!>     ( h   h   a   a   a )
!>     ( v1  h   a   a   a )
!>     ( v1  v2  a   a   a )
!>     ( v1  v2  a   a   a )
!>
!>  where a denotes an element of the original matrix A, h denotes a
!>  modified element of the upper Hessenberg matrix H, and vi denotes an
!>  element of the vector defining H(i).
!>
!>  This subroutine is a slight modification of LAPACK-3.0's DLAHRD
!>  incorporating improvements proposed by Quintana-Orti and Van de
!>  Gejin. Note that the entries of A(1:K,2:NB) differ from those
!>  returned by the original LAPACK-3.0's DLAHRD routine. (This
!>  subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)
!> \endverbatim
!
!> \par References:
!  ================
!>
!>  Gregorio Quintana-Orti and Robert van de Geijn, "Improving the
!>  performance of reduction to Hessenberg form," ACM Transactions on
!>  Mathematical Software, 32(2):180-194, June 2006.
!>
!  =====================================================================
      SUBROUTINE ZLAHR2(N,K,Nb,A,Lda,Tau,T,Ldt,Y,Ldy)
      IMPLICIT NONE
!*--ZLAHR2185
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER K , Lda , Ldt , Ldy , N , Nb
!     ..
!     .. Array Arguments ..
      COMPLEX*16 A(Lda,*) , T(Ldt,Nb) , Tau(Nb) , Y(Ldy,Nb)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16 ZERO , ONE
      PARAMETER (ZERO=(0.0D+0,0.0D+0),ONE=(1.0D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
      INTEGER i
      COMPLEX*16 ei
!     ..
!     .. External Subroutines ..
      EXTERNAL ZAXPY , ZCOPY , ZGEMM , ZGEMV , ZLACPY , ZLARFG , ZSCAL ,&
     &         ZTRMM , ZTRMV , ZLACGV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MIN
!     ..
!     .. Executable Statements ..
!
!     Quick return if possible
!
      IF ( N<=1 ) RETURN
!
      DO i = 1 , Nb
         IF ( i>1 ) THEN
!
!           Update A(K+1:N,I)
!
!           Update I-th column of A - Y * V**H
!
            CALL ZLACGV(i-1,A(K+i-1,1),Lda)
            CALL ZGEMV('NO TRANSPOSE',N-K,i-1,-ONE,Y(K+1,1),Ldy,        &
     &                 A(K+i-1,1),Lda,ONE,A(K+1,i),1)
            CALL ZLACGV(i-1,A(K+i-1,1),Lda)
!
!           Apply I - V * T**H * V**H to this column (call it b) from the
!           left, using the last column of T as workspace
!
!           Let  V = ( V1 )   and   b = ( b1 )   (first I-1 rows)
!                    ( V2 )             ( b2 )
!
!           where V1 is unit lower triangular
!
!           w := V1**H * b1
!
            CALL ZCOPY(i-1,A(K+1,i),1,T(1,Nb),1)
            CALL ZTRMV('Lower','Conjugate transpose','UNIT',i-1,A(K+1,1)&
     &                 ,Lda,T(1,Nb),1)
!
!           w := w + V2**H * b2
!
            CALL ZGEMV('Conjugate transpose',N-K-i+1,i-1,ONE,A(K+i,1),  &
     &                 Lda,A(K+i,i),1,ONE,T(1,Nb),1)
!
!           w := T**H * w
!
            CALL ZTRMV('Upper','Conjugate transpose','NON-UNIT',i-1,T,  &
     &                 Ldt,T(1,Nb),1)
!
!           b2 := b2 - V2*w
!
            CALL ZGEMV('NO TRANSPOSE',N-K-i+1,i-1,-ONE,A(K+i,1),Lda,    &
     &                 T(1,Nb),1,ONE,A(K+i,i),1)
!
!           b1 := b1 - V1*w
!
            CALL ZTRMV('Lower','NO TRANSPOSE','UNIT',i-1,A(K+1,1),Lda,  &
     &                 T(1,Nb),1)
            CALL ZAXPY(i-1,-ONE,T(1,Nb),1,A(K+1,i),1)
!
            A(K+i-1,i-1) = ei
         ENDIF
!
!        Generate the elementary reflector H(I) to annihilate
!        A(K+I+1:N,I)
!
         CALL ZLARFG(N-K-i+1,A(K+i,i),A(MIN(K+i+1,N),i),1,Tau(i))
         ei = A(K+i,i)
         A(K+i,i) = ONE
!
!        Compute  Y(K+1:N,I)
!
         CALL ZGEMV('NO TRANSPOSE',N-K,N-K-i+1,ONE,A(K+1,i+1),Lda,      &
     &              A(K+i,i),1,ZERO,Y(K+1,i),1)
         CALL ZGEMV('Conjugate transpose',N-K-i+1,i-1,ONE,A(K+i,1),Lda, &
     &              A(K+i,i),1,ZERO,T(1,i),1)
         CALL ZGEMV('NO TRANSPOSE',N-K,i-1,-ONE,Y(K+1,1),Ldy,T(1,i),1,  &
     &              ONE,Y(K+1,i),1)
         CALL ZSCAL(N-K,Tau(i),Y(K+1,i),1)
!
!        Compute T(1:I,I)
!
         CALL ZSCAL(i-1,-Tau(i),T(1,i),1)
         CALL ZTRMV('Upper','No Transpose','NON-UNIT',i-1,T,Ldt,T(1,i), &
     &              1)
         T(i,i) = Tau(i)
!
      ENDDO
      A(K+Nb,Nb) = ei
!
!     Compute Y(1:K,1:NB)
!
      CALL ZLACPY('ALL',K,Nb,A(1,2),Lda,Y,Ldy)
      CALL ZTRMM('RIGHT','Lower','NO TRANSPOSE','UNIT',K,Nb,ONE,A(K+1,1)&
     &           ,Lda,Y,Ldy)
      IF ( N>K+Nb ) CALL ZGEMM('NO TRANSPOSE','NO TRANSPOSE',K,Nb,      &
     &                         N-K-Nb,ONE,A(1,2+Nb),Lda,A(K+1+Nb,1),Lda,&
     &                         ONE,Y,Ldy)
      CALL ZTRMM('RIGHT','Upper','NO TRANSPOSE','NON-UNIT',K,Nb,ONE,T,  &
     &           Ldt,Y,Ldy)
!
!
!     End of ZLAHR2
!
      END SUBROUTINE ZLAHR2


      subroutine runF_iiiii(i1,i2,i3,i4,i5,m0sq,Gr,Czero5,N0)
C---  Expression for rearrangement of extension of Eq. 5.69
C---  Calculates Diiii, requires D00iiiii
C---  Small terms of order Gr(i,j)*Dijklmno
C---  Denominator m0sq
      implicit none
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      include 'pvweenumber.f'
      integer ep,N0,i1,i2,i3,i4,i5,m,n,np
      parameter(np=3)
      double precision m0sq,Gr(np,np)
      double complex Czero5(z5max,-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Dv(diiiiiii(z7(n,m,i1,i2,i3,i4,i5))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Dv(dzziiiii(z5(i1,i2,i3,i4,i5))+N0,ep-1)

      Dv(diiiii(z5(i1,i2,i3,i4,i5))+N0,ep)=
     . (28d0*Dv(dzziiiii(z5(i1,i2,i3,i4,i5))+N0,ep)
     . -pole
     . -2d0*Czero5(z5(i1,i2,i3,i4,i5),ep)
     . +bit)/(2d0*m0sq)

      enddo

      return
      end


Function gphotn(y1, y2, pt2)
  Implicit Double Precision (A-H, O-Z)
  Real hipr1(100), hint1(100)
  Common /hparnt/hipr1, ihpr2(50), hint1, ihnt2(50)
  Dimension f(2, 7)
  Save
  xt = 2.D0*dsqrt(pt2)/dble(hint1(1))
  x1 = 0.5D0*xt*(dexp(y1)+dexp(y2))
  x2 = 0.5D0*xt*(dexp(-y1)+dexp(-y2))
  z = dsqrt(1.D0-xt**2/x1/x2)
  ss = x1*x2*dble(hint1(1))**2
  t = -(1.D0-z)/2.D0
  u = -(1.D0+z)/2.D0
  af = 3.D0
  dlam = dble(hipr1(15))
  aph = 12.D0*3.1415926D0/(33.D0-2.D0*af)/dlog(pt2/dlam**2)
  aphem = 1.D0/137.D0
  Call parton(f, x1, x2, pt2)
  g11 = -(u**2+1.D0)/u/3.D0*f(1, 7)*(4.D0*f(2,1)+4.D0*f(2,2)+f(2,3)+f(2,4)+f(2,5)+f(2,6))/9.D0
  g12 = -(t**2+1.D0)/t/3.D0*f(2, 7)*(4.D0*f(1,1)+4.D0*f(1,2)+f(1,3)+f(1,4)+f(1,5)+f(1,6))/9.D0
  g2 = 8.D0*(u**2+t**2)/u/t/9.D0*(4.D0*f(1,1)*f(2,2)+4.D0*f(1,2)*f(2,1)+f(1,3)*f(2,4)+f(1,4)*f(2,3)+f(1,5)*f(2,6)+f(1,6)*f(2,5))/9.D0
  gphotn = (g11+g12+g2)*dble(hipr1(23))*3.14159D0*aph*aphem/ss**2
  Return
End Function gphotn


      MODULE m_phasy1
!     ********************************************************************
!     calculate 4pi*i**l/nop(3)*sum(R){exp(iRG(taual-taur)*conjg(ylm(RG)) }
!     e. wimmer   oct.1984
!     ********************************************************************
      CONTAINS
      SUBROUTINE phasy1(atoms,stars,sym, cell,k, pylm)

      USE m_constants
      USE m_ylm
      USE m_spgrot
      USE m_types
      IMPLICIT NONE
!
!     .. Scalar Arguments ..
      TYPE(t_atoms),INTENT(IN)::atoms
      TYPE(t_stars),INTENT(IN)::stars
      TYPE(t_sym),INTENT(IN)  ::sym
      TYPE(t_cell),INTENT(IN) ::cell
      INTEGER, INTENT (IN) :: k
!     ..
!     .. Array Arguments ..
      COMPLEX, INTENT (OUT):: pylm(:,:)
!     ..
!     .. Local Scalars ..
      COMPLEX sf,csf
      REAL x
      INTEGER j,l,m,n,na,lm,ll1
!     ..
!     .. Local Arrays ..
      COMPLEX ciall(0:atoms%lmaxd)
      COMPLEX phas(sym%nop)
      REAL rg(3)
      INTEGER kr(3,sym%nop)
      COMPLEX, ALLOCATABLE :: ylm(:,:)
!     ..

      ciall(0) = fpi_const/sym%nop
      DO l = 1,atoms%lmaxd
         ciall(l) = ciall(0)*ImagUnit**l
      ENDDO

      CALL spgrot(&
     &           sym%nop,sym%symor,sym%mrot,sym%tau,sym%invtab,&
     &           stars%kv3(:,k),&
     &           kr,phas)
      ALLOCATE ( ylm( (atoms%lmaxd+1)**2, sym%nop ) )
      DO j = 1,sym%nop
          rg=matmul(kr(:,j),cell%bmat)
          CALL ylm4(&
     &              atoms%lmaxd,rg,&
     &              ylm(:,j) )!keep
      ENDDO
      ylm = conjg( ylm )

      na = 1
      DO n = 1,atoms%ntype
         DO lm = 1, (atoms%lmax(n)+1)**2
               pylm(lm,n) = cmplx(0.,0.)
         ENDDO
         DO j = 1,sym%nop
            x = tpi_const* dot_product(real(kr(:,j)),atoms%taual(:,na))
            sf = cmplx(cos(x),sin(x))*phas(j)
            DO l = 0,atoms%lmax(n)
               ll1 = l*(l+1) + 1
               csf = ciall(l)*sf
               DO m = -l,l
                  lm = ll1 + m
                  pylm(lm,n) = pylm(lm,n) + csf*ylm(lm,j)
               ENDDO
            ENDDO
         ENDDO
         na = na + atoms%neq(n)
      ENDDO
      DEALLOCATE ( ylm )

      END SUBROUTINE phasy1
      END MODULE m_phasy1


	SUBROUTINE rqash
C***********************************************************************
C 	RQASH CALCULATES ARRAYS OF MEAN ABORPTION AND SCATTERING
C	EFFICIENCIES FOR FLY-ASH AS A FUNCTION OF PARTICLE SIZE AND
C	TEMPERATURE. SPECTRAL EFFICIENCIES ARE CALCULATED BASED ON
C	THE SIZE PARAMETER (X) AND RELATIVE REFRACTIVE INDEX (REFREL)
C 	FOR A GIVEN SPHERE REFRACTIVE INDEX, MEDIUM REFRACTIVE INDEX,
C 	RADIUS, AND FREE SPACE WAVELENGTH USING MIE THEORY.
C 	MEAN EFFICIENCIES ARE CALCULATED AS THE AVERAGE OF THE PLANCK
C	AND ROSSELAND MEAN ABSORPTION AND SCATTERING EFFICIENCIES.
C
C	SUBROUTINES USED: RMIE, PLANCK, ROSSEL
C	CODED SEPT 1992 BY BRAD ADAMS.
C***********************************************************************
      PARAMETER (NTD = 19, NTT = 14)
      COMMON
     & /LOGR1/  LRADI,LDBRAD,LCCOEF,LRPART,LRSOOT,LRTURB,LRUSNK
     & /RQMEAN/ QACOAL(NTD,NTT),QSCOAL(NTD,NTT),QAASH(NTD,NTT),
     &          QSASH(NTD,NTT),RTDIA(NTD),RTTEMP(NTT)
     & /RUSNK/ UNCOAL,UKCOAL,UNASH,UKASH
      LOGICAL LRADI,LDBRAD,LCCOEF,LRPART,LRSOOT,LRTURB,LRUSNK
      COMPLEX REFREL,S1(200),S2(200)
      DIMENSION QA(50),QS(50),QE(50),QB(50)
      Data PI/3.1415927/
C***********************************************************************
C  	REFMED = (REAL) REFRACTIVE INDEX OF SURROUNDING MEDIUM
C  	REFRACTIVE INDEX OF THE SPHERE = REFRE-I*REFIM
C  	RADIUS (RAD) AND WAVELENGTH (WAVEL) MUST HAVE THE SAME UNITS!
C	X = SIZE PARAMETER
C	DEFAULT REFRACTIVE INDEX IS FOR GOODWIN & MITCHNER'S SPECTRAL
C	FLY-ASH DATA (INT J HEAT MASS TRANSFER, 32, PP.627-638, 1989),
C	IF LRUSNK IS TRUE USER INPUTS ARE USED
C***********************************************************************
	REFMED = 1.0
	NWVL = 27
	DIAM = 0.5
	DO 300 J=1,NTD
	  RAD = DIAM / 2.
	  TEMP = 250.0
	  DO 200 K=1,NTT
	    WAVEL = 0.25
C***********************************************************************
C	GOODWIN'S SPECTRAL FLY-ASH DATA IS TEMPERATURE DEPENDENT
C***********************************************************************
	    DO 100 I=1,NWVL
	      IF (LRUSNK) THEN
	        REFRE = UNASH
	        REFIM = UKASH
	      ELSE IF (I .EQ. 1) THEN
	        REFRE = 1.55
	        REFIM = 0.001
	      ELSE IF (I .EQ. 2) THEN
	        REFRE = 1.55
	        REFIM = 0.00003
	      ELSE IF (I .EQ. 3) THEN
	        REFRE = 1.55
	        REFIM = 0.0003
	      ELSE IF (I .EQ. 4) THEN
	        REFRE = 1.55
	        REFIM = 0.0004
	      ELSE IF (I .EQ. 5) THEN
	        REFRE = 1.55
	        REFIM = 0.0004
	      ELSE IF (I .EQ. 6) THEN
	        REFRE = 1.5
	        REFIM = 0.0003
	      ELSE IF (I .EQ. 7) THEN
	        REFRE = 1.5
	        REFIM = 0.0003
	      ELSE IF (I .EQ. 8) THEN
	        REFRE = 1.5
	        REFIM = 0.0004
	      ELSE IF (I .EQ. 9) THEN
	        REFRE = 1.5
	        REFIM = 0.0004
	      ELSE IF (I .EQ. 10) THEN
	        REFRE = 1.5
	        REFIM = 0.0008
	        IF (TEMP.GT.1290. .AND. TEMP.LE.1650.) REFIM = 0.001
	        IF (TEMP.GT.1650.) REFIM = 0.0012
	      ELSE IF (I .EQ. 11) THEN
	        REFRE = 1.45
	        REFIM = 0.002
	        IF (TEMP.GT.1290. .AND. TEMP.LE.1650.) REFIM = 0.0025
	        IF (TEMP.GT.1650.) REFIM = 0.003
	      ELSE IF (I .EQ. 12) THEN
	        REFRE = 1.45
	        REFIM = 0.006
	        IF (TEMP.GT.1290. .AND. TEMP.LE.1650.) REFIM = 0.0075
	        IF (TEMP.GT.1650.) REFIM = 0.009
	      ELSE IF (I .EQ. 13) THEN
	        REFRE = 1.40
	        REFIM = 0.009
	        IF (TEMP.GT.1290. .AND. TEMP.LE.1650.) REFIM = 0.012
	        IF (TEMP.GT.1650.) REFIM = 0.014
	      ELSE IF (I .EQ. 14) THEN
	        REFRE = 1.35
	        REFIM = 0.012
	        IF (TEMP.GT.1290. .AND. TEMP.LE.1650.) REFIM = 0.016
	        IF (TEMP.GT.1650.) REFIM = 0.019
	      ELSE IF (I .EQ. 15) THEN
	        REFRE = 1.3
	        REFIM = 0.015
	        IF (TEMP.GT.1290. .AND. TEMP.LE.1650.) REFIM = 0.02
	        IF (TEMP.GT.1650.) REFIM = 0.024
	      ELSE IF (I .EQ. 16) THEN
	        REFRE = 1.2
	        REFIM = 0.022
	        IF (TEMP.GT.1290. .AND. TEMP.LE.1650.) REFIM = 0.029
	        IF (TEMP.GT.1650.) REFIM = 0.035
	      ELSE IF (I .EQ. 17) THEN
	        REFRE = 1.0
	        REFIM = 0.08
	      ELSE IF (I .EQ. 18) THEN
	        REFRE = 0.9
	        REFIM = 0.5
	      ELSE IF (I .EQ. 19) THEN
	        REFRE = 1.1
	        REFIM = 0.9
	      ELSE IF (I .EQ. 20) THEN
	        REFRE = 1.40
	        REFIM = 0.9
	      ELSE IF (I .EQ. 21) THEN
	        REFRE = 1.7
	        REFIM = 0.9
	      ELSE IF (I .EQ. 22) THEN
	        REFRE = 2.0
	        REFIM = 0.9
	      ELSE IF (I .EQ. 23) THEN
	        REFRE = 2.3
	        REFIM = 0.4
	      ELSE IF (I .EQ. 24) THEN
	        REFRE = 2.1
	        REFIM = 0.1
	      ELSE IF (I .EQ. 25) THEN
	        REFRE = 1.8
	        REFIM = 0.06
	      ELSE IF (I .EQ. 26) THEN
	        REFRE = 1.7
	        REFIM = 0.15
	      ELSE IF (I .GE. 27) THEN
	        REFRE = 1.7
	        REFIM = 0.20
	      END IF
   	      REFREL=CMPLX(REFRE,REFIM)/REFMED
   	      X=2.0*PI*RAD*REFMED/WAVEL
C***********************************************************************
C  	NANG = NUMBER OF ANGLES BETWEEN 0 AND 90 DEGREES
C  	MATRIX ELEMENTS CALCULATED AT 2*NANG-1 ANGLES
C  	INCLUDING 0, 90, AND 180 DEGREES
C***********************************************************************
   	      NANG=11
   	      DANG=1.570796327/FLOAT(NANG-1)
	      X = MIN(X,1500.)
   	      CALL RMIE(X,REFREL,NANG,S1,S2,QEXT,QSCA,QBACK)
	      QA(I) = QEXT - QSCA
	      QS(I) = QSCA
	      IF (I .EQ. 1) WAVEL = WAVEL + 0.250
	      IF (I .GT. 1) WAVEL = WAVEL + 0.500
100	    CONTINUE
C***********************************************************************
C	NOW CALCULATE PLANCK AND ROSSELAND MEAN EFFICIENCIES;
C	QASH'S ARE AVERAGE OF PLANCK & ROSSELAND MEANS
C***********************************************************************
	    CALL PLANCK(TEMP,QA,QAP)
	    CALL PLANCK(TEMP,QS,QSP)
	    CALL ROSSEL(TEMP,QA,QAR)
	    CALL ROSSEL(TEMP,QS,QSR)
	    QAASH(J,K) = (QAP + QAR) / 2.0
	    QSASH(J,K) = (QSP + QSR) / 2.0
	    RTTEMP(K) = TEMP
	    IF (K.LE.9) THEN
	      TEMP = TEMP + 150.0
	    ELSE IF (K.GT.9 .AND. K.LE.11) THEN
	      TEMP = TEMP + 200.0
	    ELSE IF (K.GT.11) THEN
	      TEMP = TEMP + 500.0
	    END IF
200	  CONTINUE
c	write (6,*) 'ash diam =',diam
c	write (6,*) 'qaash:'
c	write (6,*) (qaash(j,n),n=1,ntbin)
c	write (6,*) 'qsash:'
c	write (6,*) (qsash(j,n),n=1,ntbin)
	  RTDIA(J) = DIAM
	  IF (J.LE.2) THEN
	    DIAM = 2.0 * DIAM
	  ELSE IF (J.GT.2 .AND. J.LE.6) THEN
	    DIAM = DIAM + 2.0
	  ELSE IF (J.GT.6 .AND. J.LE.10) THEN
	    DIAM = DIAM + 2.5
	  ELSE IF (J.GT.10 .AND. J.LE.12) THEN
	    DIAM = DIAM + 5.0
	  ELSE IF (J.GT.12 .AND. J.LE.14) THEN
	    DIAM = DIAM + 10.0
	  ELSE IF (J.GT.14 .AND. J.LE.16) THEN
	    DIAM = DIAM + 25.0
	  ELSE IF (J.GT.16) THEN
	    DIAM = DIAM + 100.0
	  END IF
300	CONTINUE
C
	RETURN
   	END


      subroutine system_csfft(init,isign,n,scale,x,y,table,work,
     &              isys,ntable,nwork)
*************************************************************************
*** Written by Lin-Wang Wang, 2001
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

cccc input x (complex)
cccc output y (real)
      implicit none
      integer init,isign,n,isys,ntable,nwork
      real*8 scale,table(1),work(1)
      real*8 x(1),y(1)
ccccccc  complex to real 1D FFT

cccccc for T3E
c      if(init.eq.1) then
c      call csfft(0,n,scale,0,0,table,0,0)
c      else
c      call csfft(isign,n,scale,x,y,table,work,isys)
c      endif
cccccccccccccccccccccc
cccccc for IBM SP2
      if(init.eq.1) then
      call dcrft(1,0,0,0,0,
     &    n,1,-isign,scale,table,ntable,0,0)
      else
      call dcrft(0,x,0,y,0,n,1,-isign,scale,
     &    table,ntable,work,nwork)
      endif
cccccccccccccccccccccccccccccccccccc
ccccc    for Intel KML
c       if(init.eq.1) then
c       call zdfft1d(y,n,0,table)
c       else
c       call zdfft1d(x,n,1,table)    ! isign, or -isign
ccccc call zdfft1d(x,n,-1,table) is wrong ! The same result as zdfft1d(x,n,1,table)
c        if(isign.eq.-1) then
c        y(1)=x(1)*n*scale
c        do i=2,n
c        y(i)=x(n+2-i)*n*scale
c        enddo
c        else
c        do i=1,n
c        y(i)=x(i)*n*scale
c        enddo
c        endif
c       endif
ccccccccccccccccccccccccccccccccccccccccc

      return
      end


	SUBROUTINE GSGRAF ( ixtyp, iytyp, yszxsz, xl, yb, xr, yt, iret )
C************************************************************************
C* GSGRAF								*
C* 									*
C* This subroutine defines a coordinate system for plotting graphs.	*
C* The X and Y axis coordinate types are specified independently.  	*
C* The user may control the height to width ratio of the plot by 	*
C* setting the parameter YSZXSZ to a positive value.  If YSZXSZ is 	*
C* not positive the plot fills the available space.			*
C* 									*
C* For polar plots, X and Y are the distance and angle (R,THETA)	*
C* respectively.  YSZXSZ is ignored so that R is equidistant in         *
C* all directions.  A centered plot with radius R may be defined 	*
C* by setting XL = R and YB = XR = YT = 0.				*
C* 									*
C* GSGRAF  ( IXTYP, IYTYP, YSZXSZ, XL, YB, XR, YT, IRET )		*
C* 									*
C* Input parameters:							*
C* 	IXTYP		INTEGER		X coordinate type number	*
C*					   1 = linear			*
C*					   2 = logarithmic		*
C*					   3 = ** KAPPA (2/7)		*
C*					   5 =  polar (R) 		*
C* 	IYTYP		INTEGER		Y coordinate type number	*
C*					   1 = linear			*
C*					   2 = logarithmic		*
C*					   3 = ** KAPPA (2/7)		*
C*					   4 = skew			*
C*					   5 = polar (THETA)	        *
C* 	YSZXSZ		REAL		Height to width ratio of plot	*
C* 	XL		REAL		Left limit of X axis 		*
C* 	YB		REAL		Bottom limit of Y axis 		*
C* 	XR		REAL		Right limit of X axis		*
C* 	YT		REAL		Top limit of Y axis 		*
C* 									*
C* Output parameters:							*
C* 	IRET 		INTEGER		Return code			*
C** 									*
C* Log:									*
C* I. Graffman/RDS	 5/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	 9/88	GEMPAK4					*
C* L. Williams/EAi       3/94   Removed blank comments from header      *
C* A. Hardy/GSC          6/98   Cleaned up prolog                       *
C************************************************************************
	INCLUDE 	'FUNCCODE.PRM'
	INCLUDE 	'ERROR.PRM'
C*
	INTEGER 	isend (4)
	REAL 		rsend (5)
C------------------------------------------------------------------------
C*	Load input parameters into buffer and write them to the mailbox.
C
	isend (1) = 9
	isend (2) = FSGRAF
	isend (3) = ixtyp
	isend (4) = iytyp
C
	rsend (1) = yszxsz
	rsend (2) = xl
	rsend (3) = yb
	rsend (4) = xr
	rsend (5) = yt
C
	CALL GPUT  ( isend, 4, iret )
	IF  ( iret .ne. NORMAL )  RETURN
	CALL GPUTR  ( rsend, 5, iret )
	IF  ( iret .ne. NORMAL )  RETURN
C
C*	Get output parameters.
C
	CALL GGET  ( iret, 1, ier )
	IF  ( ier .ne. NORMAL )  iret = ier
C*
	RETURN
	END


      PROGRAM XTEST
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C*  VERSION 3.03  JUNE 2000                                            *
C*  * CHARACTER variable declarations changed to conform with          *
C*    Fortran-77 standard                                              *
C*                                                                     *
C***********************************************************************
C
C  EXAMPLE PROGRAM TO ILLUSTRATE THE USE OF ROUTINE REGTST
C
C  THE ROUTINE READS IN THE SAMPLE L-MOMENTS FOR DIFFERENT SITES IN A
C  REGION AND CALLS ROUTINE REGTST TO COMPUTE DISCORDANCY, HETEROGENEITY
C  AND GOODNESS-OF-FIT STATISTICS.
C
C  PARAMETERS OF PROGRAM:
C  MAXNS  - MAXIMUM NUMBER OF SITES
C  SSEED  - SEED FOR RANDOM-NUMBER GENERATOR
C  NSIM   - NSIM PARAMETER OF ROUTINE REGTST
C  KPRINT - OUTPUT FLAG, KPRINT PARAMETER OF ROUTINE REGTST
C  INFILE - STREAM NUMBER TO WHICH INPUT FILE IS ATTACHED
C  KOUT   - STREAM NUMBER TO WHICH OUTPUT FILE IS ATTACHED
C  NPROB  - NUMBER OF QUANTILES TO BE FOUND
C  A      - ) PARAMETERS OF
C  B      - ) PLOTTING POSITION
C
C  ARRAYS TO BE INITIALIZED IN DATA STATEMENTS:
C  PROB   - PROBABILITIES FOR WHICH QUANTILES ARE TO BE FOUND
C
C  ROUTINES USED: REGTST AND ROUTINES CALLED BY REGTST
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (SSEED=619145091D0,NSIM=500,MAXNS=200)
      PARAMETER (KPRINT=1,INFILE=7,KOUT=6,NPROB=10)
C
      CHARACTER*12 NAMES(MAXNS)
      CHARACTER*60 REGNAM
      DOUBLE PRECISION D(MAXNS),H(3),PARA(5,6),PROB(NPROB),RMOM(5),
     *  VBAR(3),VOBS(3),VSD(3),XMOM(5,MAXNS),Z(5)
      INTEGER LEN(MAXNS)
C
      DATA A/0D0/,B/0D0/
      DATA PROB/0.01D0,0.02D0,0.05D0,0.1D0,0.2D0,
     *  0.5D0,0.90D0,0.95D0,0.99D0,0.999D0/
C
C         READ IN THE AT-SITE L-MOMENTS.
C         DATA FILE MAY CONTAIN ANY NUMBER OF REGIONAL DATA STRUCTURES.
C         A 'REGIONAL DATA STRUCTURE' CONSISTS OF:
C         1. ONE RECORD CONTAINING:
C            (COLUMNS  1- 4) NUMBER OF SITES IN REGION;
C            (COLUMNS  5-56) IDENTIFYING LABEL FOR THE REGION.
C         2. FOR EACH SITE, ONE RECORD CONTAINING:
C            (COLUMNS  1-12) AN IDENTIFYING LABEL FOR THE SITE;
C            (COLUMNS 13-16) THE RECORD LENGTH AT THE SITE;
C            (COLUMNS 17-56) SAMPLE L-MOMENTS L-1, L-CV, T-3, T-4, T-5.
C
    1 READ(INFILE,5000,END=900)NSITES,REGNAM
      WRITE(KOUT,6000)REGNAM,NSITES
      DO 10 ISITE=1,NSITES
      READ(INFILE,5010)NAMES(ISITE),LEN(ISITE),(XMOM(I,ISITE),I=1,5)
   10 CONTINUE
C
C         CALCULATE TEST STATISTICS
C
      SEED=SSEED
      CALL REGTST(NSITES,NAMES,LEN,XMOM,A,B,SEED,NSIM,NPROB,PROB,
     *  KPRINT,KOUT,RMOM,D,VOBS,VBAR,VSD,H,Z,PARA)
      GOTO 1
C
  900 CONTINUE
      WRITE(KOUT,6010)
      STOP
C
 5000 FORMAT(I4,A52)
 5010 FORMAT(A12,I4,5F8.0)
 6000 FORMAT(///1X,A52,I8,' SITES')
 6010 FORMAT(///' ALL DATA PROCESSED')
      END


module mod_primitive_linearized_euler
    use mod_kinds,      only: rk, ik
    use mod_constants,  only: HALF, ONE, TWO, ZERO, PI
    implicit none

    !
    ! Azimuthal orther
    !
    integer(ik) :: mod_m = 0    ! Could get set by boundary conidtions
    integer(ik) :: mod_n = 1    ! Could get set by boundary conidtions

    !
    ! Nondimensionalization
    !
    real(rk), parameter :: u_r    = 1._rk
    real(rk), parameter :: rho_r  = 1._rk
    real(rk), parameter :: l_r    = 1._rk

    real(rk), parameter :: gam       = 1.4_rk
    !real(rk), parameter :: omega = 1432.945684_rk * TWO * PI
    real(rk), parameter :: omega     = 956._rk * TWO * PI
    real(rk), parameter :: thickness = 0.5_rk
    real(rk), parameter :: eps       = 2300_rk

    !
    ! Dimensional mean flow
    !
    real(rk), parameter :: rho_d = 1.225_rk
    real(rk), parameter :: u_d   = 0._rk
    real(rk), parameter :: v_d   = 0._rk
    real(rk), parameter :: w_d   = 0._rk
    real(rk), parameter :: p_d   = 101150.0_rk

!    !
!    ! Nondimensional mean flow
!    !
!    real(rk), parameter :: rho_c  = rho_d  * (l_r/(rho_r*u_r))
!    real(rk), parameter :: rhou_c = rhou_d * (l_r/(rho_r*u_r*u_r))
!    real(rk), parameter :: rhov_c = rhov_d * (l_r/(rho_r*u_r*u_r))
!    real(rk), parameter :: rhow_c = rhow_d * (l_r/(rho_r*u_r*u_r))
!    real(rk), parameter :: rhoE_c = rhoE_d * (l_r/(rho_r*u_r*u_r*u_r))

    !
    ! Mean primitives
    !
    real(rk), parameter :: rhobar = rho_d
    real(rk), parameter :: ubar   = u_d
    real(rk), parameter :: vbar   = v_d
    real(rk), parameter :: wbar   = w_d
    real(rk), parameter :: pbar   = p_d
    real(rk), parameter :: cbar   = sqrt(gam * pbar / rhobar)
    real(rk), parameter :: Mbar   = ubar/cbar

    !
    ! X-Matrix
    !
    real(rk), parameter :: rho_x_rho = ubar
    real(rk), parameter :: rho_x_u   = rhobar
    real(rk), parameter :: rho_x_v   = ZERO
    real(rk), parameter :: rho_x_w   = ZERO
    real(rk), parameter :: rho_x_p   = ZERO

    real(rk), parameter :: u_x_rho   = ZERO
    real(rk), parameter :: u_x_u     = ubar
    real(rk), parameter :: u_x_v     = ZERO
    real(rk), parameter :: u_x_w     = ZERO
    real(rk), parameter :: u_x_p     = ONE/rhobar

    real(rk), parameter :: v_x_rho   = ZERO
    real(rk), parameter :: v_x_u     = ZERO
    real(rk), parameter :: v_x_v     = ubar
    real(rk), parameter :: v_x_w     = ZERO
    real(rk), parameter :: v_x_p     = ZERO

    real(rk), parameter :: w_x_rho   = ZERO
    real(rk), parameter :: w_x_u     = ZERO
    real(rk), parameter :: w_x_v     = ZERO
    real(rk), parameter :: w_x_w     = ubar
    real(rk), parameter :: w_x_p     = ZERO

    real(rk), parameter :: p_x_rho   = ZERO
    real(rk), parameter :: p_x_u     = gam*pbar
    real(rk), parameter :: p_x_v     = ZERO
    real(rk), parameter :: p_x_w     = ZERO
    real(rk), parameter :: p_x_p     = ubar

    !
    ! Y-Matrix
    !
    real(rk), parameter :: rho_y_rho = vbar
    real(rk), parameter :: rho_y_u   = ZERO
    real(rk), parameter :: rho_y_v   = rhobar
    real(rk), parameter :: rho_y_w   = ZERO
    real(rk), parameter :: rho_y_p   = ZERO

    real(rk), parameter :: u_y_rho   = ZERO
    real(rk), parameter :: u_y_u     = vbar
    real(rk), parameter :: u_y_v     = ZERO
    real(rk), parameter :: u_y_w     = ZERO
    real(rk), parameter :: u_y_p     = ZERO

    real(rk), parameter :: v_y_rho   = ZERO
    real(rk), parameter :: v_y_u     = ZERO
    real(rk), parameter :: v_y_v     = vbar
    real(rk), parameter :: v_y_w     = ZERO
    real(rk), parameter :: v_y_p     = ONE/rhobar

    real(rk), parameter :: w_y_rho   = ZERO
    real(rk), parameter :: w_y_u     = ZERO
    real(rk), parameter :: w_y_v     = ZERO
    real(rk), parameter :: w_y_w     = vbar
    real(rk), parameter :: w_y_p     = ZERO

    real(rk), parameter :: p_y_rho   = ZERO
    real(rk), parameter :: p_y_u     = ZERO
    real(rk), parameter :: p_y_v     = gam*pbar
    real(rk), parameter :: p_y_w     = ZERO
    real(rk), parameter :: p_y_p     = vbar

    !
    ! Z-Matrix
    !
    real(rk), parameter :: rho_z_rho = wbar
    real(rk), parameter :: rho_z_u   = ZERO
    real(rk), parameter :: rho_z_v   = ZERO
    real(rk), parameter :: rho_z_w   = rhobar
    real(rk), parameter :: rho_z_p   = ZERO

    real(rk), parameter :: u_z_rho   = ZERO
    real(rk), parameter :: u_z_u     = wbar
    real(rk), parameter :: u_z_v     = ZERO
    real(rk), parameter :: u_z_w     = ZERO
    real(rk), parameter :: u_z_p     = ZERO

    real(rk), parameter :: v_z_rho   = ZERO
    real(rk), parameter :: v_z_u     = ZERO
    real(rk), parameter :: v_z_v     = wbar
    real(rk), parameter :: v_z_w     = ZERO
    real(rk), parameter :: v_z_p     = ZERO

    real(rk), parameter :: w_z_rho   = ZERO
    real(rk), parameter :: w_z_u     = ZERO
    real(rk), parameter :: w_z_v     = ZERO
    real(rk), parameter :: w_z_w     = wbar
    real(rk), parameter :: w_z_p     = ONE/rhobar

    real(rk), parameter :: p_z_rho   = ZERO
    real(rk), parameter :: p_z_u     = ZERO
    real(rk), parameter :: p_z_v     = ZERO
    real(rk), parameter :: p_z_w     = gam*pbar
    real(rk), parameter :: p_z_p     = wbar

contains

end module mod_primitive_linearized_euler


! setup model dimensions
module setup
implicit none
contains

subroutine setup_dimensions
use globals
use process
use utilities
integer :: nl(3), i
character(32) :: filename
integer, allocatable :: seed(:)

if (sync) call barrier
if (master) print *, clock(), 'Setup dimensions'

! dimensions
dx = delta(1:3)
dt = delta(4)
nn = shape_(1:3)
nt = max(shape_(4), 0)

! fault normal
select case (faultnormal(2:2))
case ('o'); ifn = 0
case ('x'); ifn = 1
case ('y'); ifn = 2
case ('z'); ifn = 3
case default; stop 'Error in faultnormal'
end select

! partition for parallelization
nl3 = (nn - 1) / nproc3 + 1
nhalo = 1
if (ifn /= 0) nhalo(ifn) = 2
nl3 = max(nl3, nhalo)
nproc3 = (nn - 1) / nl3 + 1
call rank(ip, ip3, nproc3)

! random seed
call random_seed(size=i)
allocate (seed(i))
seed = ip
call random_seed(put=seed)

! master process
master = ip == 0

! offset from local to global indices
nnoff = nl3 * ip3 - nhalo

! process rank for hypocenter
ip3hypo = floor(hypocenter / nl3)

! size of arrays
nl = min(nl3, nn - nnoff - nhalo)
nm = nl + 2 * nhalo

! boundary conditions
i1bc = 1  - nnoff
i2bc = nn - nnoff

! non-overlapping core region
i1core = 1  + nhalo
i2core = nm - nhalo

! node region
i1node = max(i1bc, 2)
i2node = min(i2bc, nm - 1)

! cell region
i1cell = max(i1bc, 1)
i2cell = min(i2bc - 1, nm - 1)

! pml region
i1pml = i1pml - nnoff
i2pml = i2pml - nnoff

! map rupture index to local indices, and test if fault on this process
irup = 0
if (ifn /= 0) then
    irup = floor(hypocenter(ifn) + 0.000001) - nnoff(ifn) + 1
    if (irup + 1 < i1core(ifn) .or. irup > i2core(ifn)) ifn = 0
end if

! debugging
sync = debug > 1
if (debug > 2) then
    write (filename, "(a,i6.6,a)") 'debug/db', ip, '.json'
    open (1, file=filename, status='replace')
    write (1, '(a)') '{'
    write (1, '(a,i8)') &
        '    "ifn:    ', ifn,  ',', &
        '    "irup":  ', irup, ',', &
        '    "ip:     ', ip,   ','
    write (1, "(a,i8,',',i8,',',i8)") &
        '    "bc1":    [', bc1,    '],', &
        '    "bc2":    [', bc2,    '],', &
        '    "ip3":    [', ip3,    '],', &
        '    "nhalo":  [', nhalo,  '],', &
        '    "nm":     [', nm,     '],', &
        '    "nn":     [', nn,     '],', &
        '    "nnoff":  [', nnoff,  '],', &
        '    "nproc3": [', nproc3, '],', &
        '    "i1bc":   [', i1bc,   '],', &
        '    "i1cell": [', i1cell, '],', &
        '    "i1core": [', i1core, '],', &
        '    "i1node": [', i1node, '],', &
        '    "i1pml":  [', i1pml,  '],', &
        '    "i2bc":   [', i2bc,   '],', &
        '    "i2cell": [', i2cell, '],', &
        '    "i2core": [', i2core, '],', &
        '    "i2node": [', i2node, '],', &
        '    "i2pml":  [', i2pml,  ']'
    write (1, '(a)') '}'
    close (1)
end if

end subroutine

end module


SUBROUTINE bantmul(kb,loads,ans)
! Used in p810
! This subroutine multiplies an unsymmetrical band kb by the vector loads.
! Could be much improved for vector processors.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kb(:,:),loads(0:)
 REAL(iwp),INTENT(OUT)::ans(0:)
 INTEGER::i,j,k,l,m,n,iw
 REAL(iwp)::x,zero=0.0_iwp
 n=SIZE(kb,1)
 l=SIZE(kb,2)
 iw=(l-1)/2
 DO i=1,n
   x=zero
   k=iw+2
   DO j=1,l
     k=k-1
     m=i-k+1
     IF(m<=n.AND.m>=1)x=x+kb(i,j)*loads(m)
   END DO
   ans(i)=x
 END DO
RETURN
END SUBROUTINE bantmul


Module hsay_structure
  Use math_constants
  Use hs_structure
  Implicit None
  Contains

    !Function that calculates the direct correlation function of a Hard Sphere +
    !Attractive Yukawa System using Sharma-Sharma approximation Scheme and Verlet-Weiss
    !for the hard core part
    ! c(k,ϕ,T,z)
    !wave-vector "k" for "k>=0"
    !density "ϕ" for "ϕ>0"
    !temperature "T" for "T>0"
    !Yukawa potential length parameter "z>0"
    Function c_hsay_shvw(phi,T,z,k) result(c)
      Implicit None
      Real * 8, Intent(in) :: phi !Volume fraction value
      Real * 8, Intent(in) :: T !Temperature
      Real * 8, Intent(in) :: z !Yukawa potential length parameter
      Real * 8, Intent(in) :: k !Value of the wave vector
      Real * 8 :: c
      Real * 8 :: k_func,ckdum,chs
      Real * 8 :: k2,z2,k4
      chs = c_hs_vw(phi,k)
      !chs = c_hs_py(phi,k)
      k2 = k * k
      z2 = z ** 2
      if (k > 0.075d0) then
        c = ( k * cos(k) ) + ( z * sin(k) )
        c = c / k
      else
        k4 = k2 * k2
        c = (1.d0 + z) - ((3.d0 + z) / 6.d0) * k2 + ((5.d0 + z) / 120.d0) * k4
      end if
      c = 4.d0 * pi * c / (T * (k2 + z2))
      c = chs + c
      return
    End Function

    !Function that calculates the inverse structure factor of a Hard Sphere +
    !Attractive Yukawa System using Sharma-Sharma approximation Scheme and Verlet-Weiss
    ! 1/S(k,ϕ,T,z)
    !wave-vector "k" for "k>=0"
    !density "ϕ" for "ϕ>0"
    !temperature "T" for "T>0"
    !Yukawa potential length parameter "z>0"
    Function is_hsay_shvw(phi,T,z,k) result(is)
      Implicit None
      Real * 8, Intent(in) :: phi !Volume fraction value
      Real * 8, Intent(in) :: T !Temperature
      Real * 8, Intent(in) :: z !Yukawa potential length parameter
      Real * 8, Intent (in) :: k !Value of the wave vector
      Real * 8 :: is
      Real * 8 :: c
      Real * 8 :: chs
      Real * 8 :: k2,z2,k4, phi_vw
      phi_vw = phi*(1.d0 - (phi / 16.d0))
      chs = c_hs_vw(phi,k)
      !chs = c_hs_py(phi,k)
      k2 = k * k
      z2 = z ** 2
      if (k > 0.075d0) then
        c = ( k * cos(k) ) + ( z * sin(k) )
        c = c / k
      else
        k4 = k2 * k2
        c = (1.d0 + z) - ((3.d0 + z) / 6.d0) * k2 + ((5.d0 + z) / 120.d0) * k4
      end if
      c = 4.d0 * pi * c / (T * (k2 + z2))
      is =  (phi_vw * chs) + (phi * c)
      is = 1.d0 - 6.d0 * is / pi
      return
    End Function

    !Function that calculates the structure factor of a Hard Sphere +
    !Attractive Yukawa System using Sharma-Sharma approximation Scheme and Verlet-Weiss
    ! S(k,ϕ,z)
    !wave-vector "k" for "k>=0"
    !density "ϕ" for "ϕ>0"
    !temperature "T" for "T>0"
    !Yukawa potential length parameter "z>0"
    Function s_hsay_shvw(phi,T,z,k) result(s)
      Implicit None
      Real * 8, Intent(in) :: phi !Volume fraction value
      Real * 8, Intent(in) :: T !Temperature
      Real * 8, Intent(in) :: z !Yukawa potential length parameter
      Real * 8, Intent (in) :: k !Value of the wave vector
      Real * 8 :: s
      s = 1.d0 / is_hsay_shvw(phi,T,z,k)
      return
    End Function

    !Function that calculates the structure factor of a Hard Sphere +
    !Attractive Yukawa System using Generalized Sharma-Sharma approximation Scheme and Verlet-Weiss
    ! S(k,ϕ,z)
    !wave-vector "k" for "k>=0"
    !density "ϕ" for "ϕ>0"
    !temperature "T" for "T>0"
    !Yukawa potential length parameter "z>0"
    Function c_hsay_gsvw(phi,T,z,k,qn,qw) result(c)
      Implicit None
      Real * 8, Intent(in) :: phi !Volume fraction value
      Real * 8, Intent(in) :: T !Temperature
      Real * 8, Intent(in) :: z !Yukawa potential length parameter
      Real * 8, Intent(in) :: k !Value of the wave vector
      Real * 8, Intent(in), dimension(:) :: qn  !Quadrature nodes
      Real * 8, Intent(in), dimension(:) :: qw  !Quadrature weights
      Real * 8 :: c
      Real * 8 :: cay,u,chs,r,w, dumsin,kr
      Real * 8 :: k2,z2,k4
      Integer :: i1
      cay = 0.d0
      do i1=1, size(qn)
        r = qn(i1)
        kr = k * r
        if (kr > 0.075d0 ) then
          w = qw(i1) * r * sin(k * r) / k
        else
          w = qw(i1) * r**2 * (1.d0 + ( (k**2) * r/6.d0) )
        end if
        u = - exp(z * (r-1.d0) )/r
        cay = cay + ( ( exp(-u/T) - 1.d0 ) * w )
      end do
      chs = c_hs_vw(phi,k)
      c = chs + cay
      return
    End Function

    !Function that calculates the inverse structure factor of a Hard Sphere +
    !Attractive Yukawa System using Generalized Sharma-Sharma approximation Scheme and Verlet-Weiss
    ! 1/S(k,ϕ,T,z)
    !wave-vector "k" for "k>=0"
    !density "ϕ" for "ϕ>0"
    !temperature "T" for "T>0"
    !Yukawa potential length parameter "z>0"
    Function is_hsay_gsvw(phi,T,z,k,qn,qw) result(is)
      Implicit None
      Real * 8, Intent(in) :: phi !Volume fraction value
      Real * 8, Intent(in) :: T !Temperature
      Real * 8, Intent(in) :: z !Yukawa potential length parameter
      Real * 8, Intent(in) :: k !Value of the wave vector
      Real * 8, Intent(in), dimension(:) :: qn  !Quadrature nodes
      Real * 8, Intent(in), dimension(:) :: qw  !Quadrature weights
      Real * 8 :: is
      is = c_hsay_gsvw(phi,T,z,k,qn,qw)
      is = 1.d0 - (6.d0 * phi * is / pi)
      return
    End Function

    !Function that calculates the structure factor of a Hard Sphere +
    !Attractive Yukawa System using Generalized Sharma-Sharma approximation Scheme and Verlet-Weiss
    ! S(k,ϕ,z)
    !wave-vector "k" for "k>=0"
    !density "ϕ" for "ϕ>0"
    !temperature "T" for "T>0"
    !Yukawa potential length parameter "z>0"
    Function s_hsay_gsvw(phi,T,z,k,qn,qw) result(s)
      Implicit None
      Real * 8, Intent(in) :: phi !Volume fraction value
      Real * 8, Intent(in) :: T !Temperature
      Real * 8, Intent(in) :: z !Yukawa potential length parameter
      Real * 8, Intent(in) :: k !Value of the wave vector
      Real * 8, Intent(in), dimension(:) :: qn  !Quadrature nodes
      Real * 8, Intent(in), dimension(:) :: qw  !Quadrature weights
      Real * 8 :: s
      s = 1.d0 / is_hsay_gsvw(phi,T,z,k,qn,qw)
      return
    End Function

    Function Ts_hsay_shvw(phi,z) result(Ts)
      Implicit None
      Real * 8, Intent(in) :: phi !Volume fraction value
      Real * 8 :: Ts !Temperature
      Real * 8, Intent(in) :: z !Yukawa potential length parameter
      Real * 8 :: S_HS
      S_HS = s_hs_vw(phi,0.d0)
      Ts = 24.d0 * phi * (z + 1.d0)  * S_HS / (z*z)
      return
    End Function

End Module


      DOUBLE PRECISION FUNCTION DT_SIGVP(Xi,Q2i)

C***********************************************************************
C sigma_Vp                                                             *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION ALPHEM , AMPROT , bot , chm , dnv , dsea ,
     &                 DT_RRM2 , dum1 , dum2 , dum3 , ecm , f2 ,
     &                 GEV2MB , gl , ONE , PI , q2 , Q2i , scale , stot
      DOUBLE PRECISION str , TINY10 , top , TWO , TWOPI , upv , usea ,
     &                 x , Xi , ZERO
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
      PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
     &           PI=TWOPI/TWO,GEV2MB=0.38938D0,AMPROT=0.938D0,
     &           ALPHEM=ONE/137.0D0)
C VDM parameter for photon-nucleus interactions
      INCLUDE 'inc/dtvdmp'

      x = Xi
      q2 = Q2i
      IF ( Xi.LE.ZERO ) x = 0.0001D0
      IF ( Q2i.LE.ZERO ) q2 = 0.0001D0

      ecm = SQRT(q2*(ONE-x)/x+AMPROT**2)

      scale = SQRT(q2)
      IF ( MODega.EQ.1 ) THEN
         CALL DT_CKMT(x,scale,upv,dnv,usea,dsea,str,chm,bot,top,gl,f2,
     &                IDPdf)
C        W = ECM

C        ALLMF2 = PHO_ALLM97(Q2,W)

C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
         DT_SIGVP = 12.0D0*PI**3.0D0*f2/(q2*DT_RRM2(x,q2))*GEV2MB
      ELSE IF ( MODega.EQ.4 ) THEN
         CALL DT_SIGGP(x,q2,ecm,dum1,stot,dum2,dum3)
C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
         DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(x,q2))*stot
      ELSE
         STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
      END IF

      END FUNCTION