! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE QPLT1 ( OPT, AREA, XSD, YSD )

! DKQ quadrilateral thin (Kirchoff) plate bending element. This element is based on the following work:

! "Evaluation Of A New Quadrilateral Thin Plate Bending Element", by Jean_louis Batoz and Marbrouk Ben Tahar,
! International Journal For Numerical Methods In Engineering, Vol 18 (1982) pp 1655-1677

! Element matrices calculated are:

!  1) PTE       = element thermal load vectors         , if OPT(2) = 'Y'
!  2) SEi, STEi = element stress data recovery matrices, if OPT(3) = 'Y'
!  3) KE        = element linea stiffness matrix       , if OPT(4) = 'Y'
!  4) PPE       = element pressure load matrix         , if OPT(5) = 'Y'
!  5) KED       = element differen stiff matrix calc   , if OPT(6) = 'Y' = 'Y'

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  F04, WRT_LOG
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, MAX_ORDER_GAUSS, NSUB, NTSUB
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  QPLT1_BEGEND
      USE CONSTANTS_1, ONLY           :  ZERO, FOUR
      USE PARAMS, ONLY                :  IORQ2B
      USE MODEL_STUF, ONLY            :  ALPVEC, BE2, DT, EB, EID, KE, PRESS, PPE, PTE, SE2, STE2, SHELL_D, SHELL_DALP

      USE QPLT1_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'QPLT1'
      CHARACTER(46*BYTE)              :: IORD_MSG          ! Character name of the integration order (used for debug output)
      CHARACTER(1*BYTE), INTENT(IN)   :: OPT(6)            ! 'Y'/'N' flags for whether to calc certain elem matrices
      INTEGER(LONG)                   :: GAUSS_PT          ! Gauss point number (used for DEBUG output in subr SHP2DQ
      INTEGER(LONG)                   :: I,J,K,L,M         ! DO loop indices
      INTEGER(LONG), PARAMETER        :: ID(12) =  (/ 3, & ! ID(1) =  3 means virgin 12x12 elem DOF  1 is MYSTRAN 24X24 elem DOF  3
                                                      4, & ! ID(2) =  4 means virgin 12x12 elem DOF  2 is MYSTRAN 24X24 elem DOF  4
                                                      5, & ! ID(2) =  5 means virgin 12x12 elem DOF  3 is MYSTRAN 24X24 elem DOF  5
                                                      9, & ! ID(3) =  9 means virgin 12x12 elem DOF  4 is MYSTRAN 24X24 elem DOF  9
                                                     10, & ! ID(4) = 10 means virgin 12x12 elem DOF  5 is MYSTRAN 24X24 elem DOF 10
                                                     11, & ! ID(4) = 11 means virgin 12x12 elem DOF  6 is MYSTRAN 24X24 elem DOF 11
                                                     15, & ! ID(5) = 15 means virgin 12x12 elem DOF  7 is MYSTRAN 24X24 elem DOF 15
                                                     16, & ! ID(6) = 16 means virgin 12x12 elem DOF  8 is MYSTRAN 24X24 elem DOF 16
                                                     17, & ! ID(6) = 17 means virgin 12x12 elem DOF  9 is MYSTRAN 24X24 elem DOF 17
                                                     21, & ! ID(7) = 21 means virgin 12x12 elem DOF 10 is MYSTRAN 24X24 elem DOF 21
                                                     22, & ! ID(8) = 22 means virgin 12x12 elem DOF 11 is MYSTRAN 24X24 elem DOF 22
                                                     23 /) ! ID(8) = 23 means virgin 12x12 elem DOF 12 is MYSTRAN 24X24 elem DOF 23

! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
! Do not change IORD_STRESS_Q4. The algorithm to find Gauss point coords in elem x,y space requires there to be the same number of
! shape functions and Gauss points as elem nodes.

      INTEGER(LONG), PARAMETER        :: IORD_STRESS_Q4 = 2! Gauss integration order for stress/strain recovery matrices
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      INTEGER(LONG), PARAMETER        :: NUM_NODES = 8     ! DKQ element has 8 nodes (4 are internal)
                                                           ! Indicator of no output of elem data to BUG file
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = QPLT1_BEGEND

      REAL(DOUBLE) , INTENT(IN)       :: AREA              ! Element area
      REAL(DOUBLE) , INTENT(IN)       :: XSD(4)            ! Diffs in x coords of quad sides in local coords
      REAL(DOUBLE) , INTENT(IN)       :: YSD(4)            ! Diffs in y coords of quad sides in local coords
      REAL(DOUBLE)                    :: ALP(3)            ! Col of ALPVEC
      REAL(DOUBLE)                    :: BB(3,12)          ! Output from subr BBDKQ, called herein. Strain-displ matrix
      REAL(DOUBLE)                    :: DETJ              ! An output from subr JAC2D, called herein. Determinant of JAC
      REAL(DOUBLE)                    :: DPSHG(2,8)        ! Output from subr SHP2DQ. Derivatives of PSH wrt elem isopar coords.
      REAL(DOUBLE)                    :: DPSHX(2,8)        ! Derivatives of PSH wrt elem x, y coords.
      REAL(DOUBLE)                    :: DUM1(3,12)        ! Intermediate matrix used in solving for PTE therm lds & KE stiffness
      REAL(DOUBLE)                    :: DUM2(12,12)       ! Intermediate matrix used in solving for KE element stiffness
      REAL(DOUBLE)                    :: DUM3(12)          ! Intermediate matrix used in solving for PTE thermal loads
      REAL(DOUBLE)                    :: DUM4(12)          ! Intermediate matrix used in solving for PTE thermal loads
      REAL(DOUBLE)                    :: EALP(3)           ! Intermed var used in calc STEi therm stress coeffs
      REAL(DOUBLE)                    :: HHH(MAX_ORDER_GAUSS)
                                                           ! An output from subr ORDER, called herein.  Gauss weights.
      REAL(DOUBLE)                    :: INTFAC            ! An integration factor (constant multiplier for the Gauss integration)
      REAL(DOUBLE)                    :: JAC(2,2)          ! An output from subr JAC2D, called herein. 2 x 2 Jacobian matrix.
      REAL(DOUBLE)                    :: JACI(2,2)         ! An output from subr JAC2D, called herein. 2 x 2 Jacobian inverse.
      REAL(DOUBLE)                    :: PSH(8)            ! Output from subr SHP2DQ. Shape fcn for 8 node serendipity element.
      REAL(DOUBLE)                    :: SLN(4)            ! Quad side lengths
      REAL(DOUBLE)                    :: SSI               ! A particular value of SSS
      REAL(DOUBLE)                    :: SSJ               ! A particular value of SSS
      REAL(DOUBLE)                    :: SSS(MAX_ORDER_GAUSS)
                                                           ! An output from subr ORDER, called herein. Gauss abscissa's.

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Quad side lengths

      DO I=1,4
         SLN(I) = DSQRT(XSD(I)*XSD(I) + YSD(I)*YSD(I))
      ENDDO

! **********************************************************************************************************************************
! Determine element thermal loads.

      IF (OPT(2) == 'Y') THEN

         CALL ORDER_GAUSS ( IORQ2B, SSS, HHH )

         DO I=1,12
            DUM3(I) = ZERO
         ENDDO

         GAUSS_PT = 0
         IORD_MSG = 'for plate bending strains,           IORQ2B = '
         DO I=1,IORQ2B
            DO J=1,IORQ2B
               GAUSS_PT = GAUSS_PT + 1
               SSI = SSS(I)
               SSJ = SSS(J)
               CALL SHP2DQ ( I, J, NUM_NODES, SUBR_NAME, IORD_MSG, IORQ2B, SSI, SSJ, 'N', PSH, DPSHG )
               CALL JAC2D ( SSI, SSJ, XSD, YSD, 'N', JAC, JACI, DETJ )
               CALL MATMULT_FFF ( JACI, DPSHG, 2, 2, 8, DPSHX )
               CALL BBDKQ ( DPSHX, XSD, YSD, SLN, I, J, 'bending strains', 'N', BB )
               CALL MATMULT_FFF_T ( BB, SHELL_DALP, 3, 12, 1, DUM4 )
               INTFAC = DETJ*HHH(I)*HHH(J)
               DO K=1,12
                  DUM3(K) = DUM3(K) + INTFAC*DUM4(K)
               ENDDO
            ENDDO
         ENDDO

         DO J=1,NTSUB
            DO K=1,12
               PTE(ID(K),J) = DUM3(K)*DT(5,J)
            ENDDO
         ENDDO

      ENDIF

! **********************************************************************************************************************************
! Determine element pressure loads.

      IF (OPT(5) == 'Y') THEN
         DO J=1,NSUB
            PPE( 3,J) = AREA*PRESS(3,J)/FOUR
            PPE( 9,J) = AREA*PRESS(3,J)/FOUR
            PPE(15,J) = AREA*PRESS(3,J)/FOUR
            PPE(21,J) = AREA*PRESS(3,J)/FOUR
         ENDDO
      ENDIF

! **********************************************************************************************************************************
! Calculate SE matrix (3 x 24) for stress data recovery.
! Note: stress recovery matrices only make sense for individual plies (or whole elem if only 1 "ply")

      IF (OPT(3) == 'Y') THEN

! Bending moment terms (calculated at center of element). Note that engineering forces (moments) are determined from
! the SE2 matrices using FCONV, which was set in calling routine and is negative.

         SSI = ZERO                                        ! BE2 at element center
         SSJ = ZERO
         GAUSS_PT = 1
         IORD_MSG = 'for plate bending strains,                  = '
         CALL SHP2DQ ( 1, 1, NUM_NODES, SUBR_NAME, IORD_MSG, 1, SSI, SSJ, 'N', PSH, DPSHG )
         CALL JAC2D ( SSI, SSJ, XSD, YSD, 'N', JAC, JACI, DETJ )
         CALL MATMULT_FFF ( JACI, DPSHG, 2, 2, 8, DPSHX )
         CALL BBDKQ ( DPSHX, XSD, YSD, SLN, 1, 1, 'bending strains', 'N', BB )

         DO I=1,3
            DO J=1,12
               BE2(I,ID(J),1) = BB(I,J)
            ENDDO
         ENDDO

! SE2, STE2 generated in elem coords. Then, in LINK9 the stresses, calc'd in elem coords, will be transformed to ply coords

         CALL MATMULT_FFF ( EB, BB, 3, 3, 12, DUM1 )       ! SE2 at element center
         DO I=1,3
            DO J=1,12
               SE2(I,ID(J),1) = DUM1(I,J)
            ENDDO
         ENDDO

         ALP(1) = ALPVEC(1,1)
         ALP(2) = ALPVEC(2,1)
         ALP(3) = ALPVEC(3,1)

         CALL MATMULT_FFF ( EB, ALP, 3, 3, 1, EALP )
         DO J=1,NTSUB
            DO I=1,3
               STE2(I,J,1) = EALP(I)*DT(5,J)
            ENDDO
         ENDDO

! Generate BE2, SE2 at Gauss points

         CALL ORDER_GAUSS ( IORQ2B, SSS, HHH )

         GAUSS_PT = 0
         DO I=1,IORD_STRESS_Q4

            DO J=1,IORD_STRESS_Q4

               GAUSS_PT = GAUSS_PT + 1
               IORD_MSG = 'for plate bending strains,   IORD_STRESS_Q4 = '
               CALL SHP2DQ ( I, J, NUM_NODES, SUBR_NAME, IORD_MSG, IORD_STRESS_Q4, SSS(I), SSS(J), 'N', PSH, DPSHG )
               CALL JAC2D ( SSS(I), SSS(J), XSD, YSD, 'N', JAC, JACI, DETJ )
               CALL MATMULT_FFF ( JACI, DPSHG, 2, 2, 8, DPSHX )
               CALL BBDKQ ( DPSHX, XSD, YSD, SLN, I, J, 'bending strains', 'N', BB )

               DO L=1,3
                  DO M=1,12
                     BE2(L,ID(M),GAUSS_PT+1) = BB(L,M)
                  ENDDO
               ENDDO

               CALL MATMULT_FFF ( EB, BB, 3, 3, 12, DUM1 )        ! Generate SE2 in element coords (at this point EM is elem coords)
               DO L=1,3
                  DO M=1,12
                     SE2(L,ID(M),GAUSS_PT+1) = DUM1(L,M)
                  ENDDO
               ENDDO

            ENDDO

         ENDDO

      ENDIF

! **********************************************************************************************************************************
! Calculate element stiffness matrix KE.

      IF(OPT(4) == 'Y') THEN

         CALL ORDER_GAUSS ( IORQ2B, SSS, HHH )

         GAUSS_PT = 0
         IORD_MSG = 'for plate bending strains,           IORQ2B = '
         DO I=1,IORQ2B
            DO J=1,IORQ2B
               SSI = SSS(I)
               SSJ = SSS(J)
               GAUSS_PT = GAUSS_PT + 1
               CALL SHP2DQ ( I, J, NUM_NODES, SUBR_NAME, IORD_MSG, IORQ2B, SSI, SSJ, 'Y', PSH, DPSHG )
               CALL JAC2D ( SSI, SSJ, XSD, YSD, 'Y', JAC, JACI, DETJ )
               CALL MATMULT_FFF ( JACI, DPSHG, 2, 2, 8, DPSHX )
               CALL BBDKQ ( DPSHX, XSD, YSD, SLN, I, J, 'bending strains', 'Y', BB )
               CALL MATMULT_FFF ( SHELL_D, BB, 3, 3, 12, DUM1 )
               CALL MATMULT_FFF_T ( BB, DUM1, 3, 12, 12, DUM2 )
               INTFAC = DETJ*HHH(I)*HHH(J)
               DO K=1,12
                  DO L=K,12
                     KE(ID(K),ID(L)) = KE(ID(K),ID(L)) + INTFAC*DUM2(K,L)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO

! Set lower triangular partition equal to upper partition

         DO I=2,24
            DO J=1,I-1
               KE(I,J) = KE(J,I)
            ENDDO
         ENDDO

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

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

      END SUBROUTINE QPLT1


! chk_ieee_support.f90
!     Check: does the compiler have the ieee_artihmetic support functions?
!
program chk_ieee_support
    use ieee_arithmetic
    use ieee_exceptions
    implicit none

    real                   :: single
    real(kind=kind(1.0d0)) :: double

    write( *, '(a)' )        'IEEE arithmetic support:'
    write( *, '(a20,3a10)' ) 'Type of support', ' All kinds', '    Single', '    Double'
    write( *, '(a20,3l10)' ) 'IEEE reals  ',ieee_support_datatype(), ieee_support_datatype(single), ieee_support_datatype(double)
    write( *, '(a20,3l10)' ) 'Denormal    ',ieee_support_denormal(), ieee_support_denormal(single), ieee_support_denormal(double)
    write( *, '(a20,3l10)' ) 'Division    ',ieee_support_divide(),   ieee_support_divide(single),   ieee_support_divide(double)
    write( *, '(a20,3l10)' ) 'Infinity    ',ieee_support_inf(),      ieee_support_inf(single),      ieee_support_inf(double)
    write( *, '(a20,3l10)' ) 'NaN         ',ieee_support_nan(),      ieee_support_nan(single),      ieee_support_nan(double)
    write( *, '(a20,3l10)' ) 'SQRT        ',ieee_support_sqrt(),     ieee_support_sqrt(single),     ieee_support_sqrt(double)
    write( *, '(a20,3l10)' ) 'All standard',ieee_support_standard(), ieee_support_standard(single), ieee_support_standard(double)
    write( *, '(a20,3l10)' ) 'Underflow   ',ieee_support_underflow_control(), &
                                            ieee_support_underflow_control(single), &
                                            ieee_support_underflow_control(double)

    write( *, '(a,a)' )      'Rounding modes:'
    write( *, '(a20,3l10)' ) 'Nearest     ',ieee_support_rounding(ieee_nearest),        &
                                            ieee_support_rounding(ieee_nearest,single), &
                                            ieee_support_rounding(ieee_nearest,double)
    write( *, '(a20,3l10)' ) 'To zero     ',ieee_support_rounding(ieee_to_zero),        &
                                            ieee_support_rounding(ieee_to_zero,single), &
                                            ieee_support_rounding(ieee_to_zero,double)
    write( *, '(a20,3l10)' ) 'Up          ',ieee_support_rounding(ieee_up),             &
                                            ieee_support_rounding(ieee_up,single),      &
                                            ieee_support_rounding(ieee_up,double)
    write( *, '(a20,3l10)' ) 'Down        ',ieee_support_rounding(ieee_down),           &
                                            ieee_support_rounding(ieee_down,single),    &
                                            ieee_support_rounding(ieee_down,double)
    write( *, '(a20,3l10)' ) 'Other       ',ieee_support_rounding(ieee_other),          &
                                            ieee_support_rounding(ieee_other,single),   &
                                            ieee_support_rounding(ieee_other,double)

    write( *, '(/,a)' ) 'Exceptions:'
    write( *, '(a20,3a10)' ) 'Flagging support', ' All kinds', '    Single', '    Double'

    write( *, '(a20,3l10)' ) 'Invalid       ', ieee_support_flag(ieee_invalid),         &
                                               ieee_support_flag(ieee_invalid, single), &
                                               ieee_support_flag(ieee_invalid, double)

    write( *, '(a20,3l10)' ) 'Overflow      ', ieee_support_flag(ieee_overflow),         &
                                               ieee_support_flag(ieee_overflow, single), &
                                               ieee_support_flag(ieee_overflow, double)

    write( *, '(a20,3l10)' ) 'Divide by zero', ieee_support_flag(ieee_divide_by_zero),         &
                                               ieee_support_flag(ieee_divide_by_zero, single), &
                                               ieee_support_flag(ieee_divide_by_zero, double)

    write( *, '(a20,3l10)' ) 'Inexact       ', ieee_support_flag(ieee_inexact),         &
                                               ieee_support_flag(ieee_inexact, single), &
                                               ieee_support_flag(ieee_inexact, double)

    write( *, '(a20,3l10)' ) 'Underflow     ', ieee_support_flag(ieee_underflow),         &
                                               ieee_support_flag(ieee_underflow, single), &
                                               ieee_support_flag(ieee_underflow, double)

    write( *, '(a20,3a10)' ) 'Halting support', ' All kinds'
    write( *, '(a20,l10)' ) 'Invalid       ', ieee_support_halting(ieee_invalid)
    write( *, '(a20,l10)' ) 'Overflow      ', ieee_support_halting(ieee_overflow)
    write( *, '(a20,l10)' ) 'Divide by zero', ieee_support_halting(ieee_divide_by_zero)
    write( *, '(a20,l10)' ) 'Inexact       ', ieee_support_halting(ieee_inexact)
    write( *, '(a20,l10)' ) 'Underflow     ', ieee_support_halting(ieee_underflow)
end program chk_ieee_support


! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
! HOHQMesh contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend,
!    https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
! * `fmin`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `spline`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `seval`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
!
! --- End License
MODULE fMinModule
CONTAINS

      DOUBLE PRECISION FUNCTION fmin(ax, bx, crve, pnt, nHat, tol)
      USE SMCurveClass
      IMPLICIT NONE
      double precision ax,bx,tol,pnt(3), nHat(3)
      !EXTERNAL    :: f
      TYPE(SMCurve) :: crve
!      INTERFACE
!         DOUBLE PRECISION FUNCTION distanceSquared(x, crv, p, nHat)
!         USE SMCurveClass
!         IMPLICIT NONE
!         DOUBLE PRECISION :: x, p(3), nHat(3)
!         TYPE(SMCurve)      :: crv
!         DOUBLE PRECISION :: directionPenalty = 1.d-3
!         END FUNCTION distanceSquared
!      END INTERFACE
!
!      an approximation  x  to the point where  f  attains a minimum  on
!  the interval  (ax,bx)  is determined.
!
!  input..
!
!  ax    left endpoint of initial interval
!  bx    right endpoint of initial interval
!  f     function subprogram which evaluates  distanceSquared(x,c,p,nHat)  for any  x
!        in the interval  (ax,bx)
!  tol   desired length of the interval of uncertainty of the final
!        result (.ge.0.)
!
!  output..
!
!  fmin  abcissa approximating the point where  f  attains a
!        minimum
!
!      the method used is a combination of  golden  section  search  and
!  successive parabolic interpolation.  convergence is never much slower
!  than  that  for  a  fibonacci search.  if  f  has a continuous second
!  derivative which is positive at the minimum (which is not  at  ax  or
!  bx),  then  convergence  is  superlinear, and usually of the order of
!  about  1.324....
!      the function  f  is never evaluated at two points closer together
!  than  eps*abs(fmin)+(tol/3), where eps is  approximately  the  square
!  root  of  the  relative  machine  precision.   if   f   is a unimodal
!  function and the computed values of   f   are  always  unimodal  when
!  separated  by  at least  eps*abs(x)+(tol/3), then  fmin  approximates
!  the abcissa of the global minimum of  f  on the interval  ax,bx  with
!  an error less than  3*eps*abs(fmin)+tol.  if   f   is  not  unimodal,
!  then fmin may approximate a local, but perhaps non-global, minimum to
!  the same accuracy.
!      this function subprogram is a slightly modified  version  of  the
!  algol  60 procedure  localmin  given in richard brent, algorithms for
!  minimization without derivatives, prentice-hall, inc. (1973).
!
!
      double precision  a,b,c,d,e,eps,xm,p,q,r,tol1,t2,u,v,w,fu,fv,fw,  &
     &    fx,x,tol3
!
!  c is the squared inverse of the golden ratio
      c=0.5d0*(3.0d0-sqrt(5.0d0))
!
!  eps is approximately the square root of the relative machine
!  precision.
!
      eps=EPSILON(eps)
      tol1=eps+1.0d0
      eps=sqrt(eps)
!
      a=ax
      b=bx
      v=a+c*(b-a)
      w=v
      x=v
      e=0.0d0
      fx=distanceSquared(x,crve,pnt,nHat)
      fv=fx
      fw=fx
      tol3=tol/3.0d0
      d = 0.0d0
!
!  main loop starts here
!
   20 xm=0.5d0*(a+b)
      tol1=eps*abs(x)+tol3
      t2=2.0d0*tol1
!
!  check stopping criterion
!
      if (abs(x-xm).le.(t2-0.5d0*(b-a))) go to 190
      p=0.0d0
      q=0.0d0
      r=0.0d0
      if (abs(e).le.tol1) go to 50
!
!  fit parabola
!
      r=(x-w)*(fx-fv)
      q=(x-v)*(fx-fw)
      p=(x-v)*q-(x-w)*r
      q=2.0d0*(q-r)
      if (q.le.0.0d0) go to 30
      p=-p
      go to 40
   30 q=-q
   40 r=e
      e=d
   50 if ((abs(p).ge.abs(0.5d0*q*r)).or.(p.le.q*(a-x))                &
     &          .or.(p.ge.q*(b-x))) go to 60
!
!  a parabolic-interpolation step
!
      d=p/q
      u=x+d
!
!  f must not be evaluated too close to ax or bx
!
      if (((u-a).ge.t2).and.((b-u).ge.t2)) go to 90
      d=tol1
      if (x.ge.xm) d=-d
      go to 90
!
!  a golden-section step
!
   60 if (x.ge.xm) go to 70
      e=b-x
      go to 80
   70 e=a-x
   80 d=c*e
!
!  f must not be evaluated too close to x
!
   90 if (abs(d).lt.tol1) go to 100
      u=x+d
      go to 120
  100 if (d.le.0.0d0) go to 110
      u=x+tol1
      go to 120
  110 u=x-tol1
  120 fu=distanceSquared(u,crve,pnt,nHat)
!
!  update  a, b, v, w, and x
!
      if (fx.gt.fu) go to 140
      if (u.ge.x) go to 130
      a=u
      go to 140
  130 b=u
  140 if (fu.gt.fx) go to 170
      if (u.ge.x) go to 150
      b=x
      go to 160
  150 a=x
  160 v=w
      fv=fw
      w=x
      fw=fx
      x=u
      fx=fu
      go to 20
  170 if ((fu.gt.fw).and.(w.ne.x)) go to 180
      v=w
      fv=fw
      w=u
      fw=fu
      go to 20
  180 if ((fu.gt.fv).and.(v.ne.x).and.(v.ne.w)) go to 20
      v=u
      fv=fu
      go to 20
!
!  end of main loop
!
  190 fmin=x
      return
      END FUNCTION fMin
!
!////////////////////////////////////////////////////////////////////////
!
      DOUBLE PRECISION FUNCTION distanceSquared(x,c,p,nHat)
         USE SMCurveClass
         IMPLICIT NONE
         DOUBLE PRECISION :: x, p(3), z(3), nHat(3)
         CLASS(SMCurve)   :: c

         z               = c % positionAt(x)
         distanceSquared = DistanceSquaredBetweenPoints(z,p,nHat)
      END FUNCTION distanceSquared
!
!////////////////////////////////////////////////////////////////////////
!
      DOUBLE PRECISION FUNCTION DistanceSquaredBetweenPoints(z,p,nHat)
         USE ProgramGlobals, ONLY: directionPenalty
         IMPLICIT NONE
         DOUBLE PRECISION ::  p(3), z(3), nHat(3)

         DistanceSquaredBetweenPoints = (z(1) - p(1))**2 + (z(2) - p(2))**2 &
                           - MIN((z(1)-p(1))*nHat(1) + (z(2) - p(2))*nHat(2),0.0d0)/directionPenalty
      END FUNCTION DistanceSquaredBetweenPoints
END MODULE fMinModule


! { dg-do compile }
! { dg-options "--std=f95" }
! PR18565
! As we provide "double complex" versions of certain intrinsics an extension.
! However --std=f95 was also breaking the generic versions, which should work
! on any type kind.
program prog
  complex(kind=kind(0d0)) :: c
  print *, abs(c)
  print *, aimag(c)
  print *, conjg(c)
  print *, cos(c)
  print *, exp(c)
  print *, log(c)
  print *, sin(c)
  print *, sqrt(c)
end program


module cellular_automata_mod
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none

    private
        integer, parameter, public :: nr_neighbouts = 3
        type, public :: automaton_t
            integer, dimension(0:2**nr_neighbouts - 1) :: rules
            integer, dimension(:), allocatable :: cells
        end type automaton_t

        public :: init_automaton, step_automaton, print_automaton, &
                  print_rules

contains

    subroutine init_rule(rules, rule_nr)
        implicit none
        integer, dimension(0:2**nr_neighbouts - 1), intent(out) :: rules
        integer, value :: rule_nr
        integer i

        do i = lbound(rules, 1), ubound(rules, 1)
            rules(i) = mod(rule_nr, 2)
            rule_nr = rule_nr/2
        end do
    end subroutine init_rule

    function init_automaton(nr_cells, rule_nr) result(automaton)
        implicit none
        integer, value :: nr_cells, rule_nr
        type(automaton_t) :: automaton
        integer :: i, istat
        real :: r

        allocate(automaton%cells(nr_cells), stat=istat)
        if (istat /= 0) then
            write (unit=error_unit, fmt='(A)') &
                'error: can not allocate cells'
            stop 1
        end if
        do i = 1, nr_cells
            call random_number(r)
            if (r > 0.5) then
                automaton%cells(i) = 1
            else
                automaton%cells(i) = 0
            end if
        end do
        call init_rule(automaton%rules, rule_nr)
    end function init_automaton

    function apply_rule(automaton, left, mid, right) result(new_mid)
        implicit none
        type(automaton_t), intent(in) :: automaton
        integer, intent(in) :: left, mid, right
        integer :: new_mid

        new_mid = automaton%rules(4*left + 2*mid + right)
    end function apply_rule

    subroutine step_automaton(automaton)
        implicit none
        type(automaton_t), intent(inout) :: automaton
        integer :: i, left, last_right, next_left

        left = automaton%cells(size(automaton%cells))
        last_right = automaton%cells(1)
        do i = 1, size(automaton%cells) - 1
            next_left = automaton%cells(i)
            automaton%cells(i) = apply_rule(automaton, &
                                            left, automaton%cells(i), &
                                            automaton%cells(i + 1))
            left = next_left
        end do
        automaton%cells(i) = apply_rule(automaton, &
                                        left, automaton%cells(i), &
                                        last_right)
    end subroutine step_automaton

    subroutine print_automaton(automaton)
        use, intrinsic :: iso_fortran_env, only : output_unit
        implicit none
        type(automaton_t), intent(in) :: automaton
        integer :: i
        character :: c

        do i = 1, size(automaton%cells)
            if (automaton%cells(i) == 1) then
                c = 'X'
            else
                c = ' '
            end if
            write (unit=output_unit, fmt='(A)', advance='no') c
        end do
        print '(A)', ''
    end subroutine print_automaton

    function convert_to_neighbourhood(idx) result(neighbours)
        implicit none
        integer, value :: idx
        character(len=3) :: neighbours
        integer :: i

        do i = nr_neighbouts, 1, -1
            if (mod(idx, 2) == 0) then
                neighbours(i:i) = '0'
            else
                neighbours(i:i) = '1'
            end if
            idx = idx/2
        end do
    end function convert_to_neighbourhood

    subroutine print_rules(automaton)
        implicit none
        type(automaton_t), intent(in) :: automaton
        integer :: i

        do i = lbound(automaton%rules, 1), ubound(automaton%rules, 1)
            print '(A3, x, I1)', convert_to_neighbourhood(i), &
               automaton%rules(i)
        end do
    end subroutine print_rules

end module cellular_automata_mod


module modules_16b

contains

integer function sfloor(x) result(r)
real, intent(in) :: x
r = x
end function

integer function imodulo(x) result(r)
integer, intent(in) :: x
r = sfloor(real(x))
end function

end module


    program demo_minexponent
    use, intrinsic :: iso_fortran_env, only : &
     &real_kinds, real32, real64, real128
    implicit none
    real(kind=real32) :: x
    real(kind=real64) :: y
        print *, minexponent(x), maxexponent(x)
        print *, minexponent(y), maxexponent(y)
    end program demo_minexponent


!-----------------------------------------------------------------------
!
! RAdS Jan12.
! Copyright (C) 2011-2014 by Rodrigo Alvares de Souza.
! Mail: <rsouza01@gmail.com>. Web: "http://www.astro.iag.usp.br/~rsouza/".
! This program may be copied and/or distributed freely. See the
! _ terms and conditions in the files in the doc/ subdirectory.
!
!
! MODULE: tov_module
!
!> @author
!> Rodrigo Souza
!
! DESCRIPTION:
!> TOV related types and functions (EDO's and stuff)
!
!-----------------------------------------------------------------------
module tov_module

use types
use global_constants
use config_module
use output_module
use cubic_spline_module
use stat_module

    implicit none

    contains

    !> \brief Set initial conditions
    !!
    !! \param parameters
    !! \param Y
    !! \param V
    !!
    subroutine set_initial_conditions(parameters, Y, V)
    implicit none

        type(ConfigParameters) :: parameters
        double precision :: Y(N_DIFF_EQUATIONS)
        double precision :: V(N_VARIABLES)

        !Initial conditions

        !n = R_bar = 0
        V(IDX_RADIUS_BAR) = 0.

        !M_bar(0) = 0
        V(IDX_MASS_BAR) = 0.

        !Rho_bar(0) = RHO_0 / RHO_ADIM
        V(IDX_RHO_BAR) = parameters%RHO_0 / parameters%RHO_ADIM

        !P_bar(0) = P_0/(Rho_0 * c^2)
        V(IDX_PRESSURE_BAR) = parameters%P_0_bar

        V(IDX_ENERGY_DENSITY_BAR) = V(IDX_RHO_BAR)

        V(IDX_BARYON_NUMBER) = 0.

        V(IDX_INFOR_ENTROPY) = 0.
        V(IDX_DISEQUILIBRIUM) = 0.

        Y(IDX_EQN_DM_DN) = 0.
        Y(IDX_EQN_DP_DN) = V(IDX_PRESSURE_BAR)

        !write (*,*) &
        !    '(IDX_MASS_BAR, IDX_PRESSURE_BAR, IDX_ENERGY_DENSITY_BAR, IDX_RADIUS_BAR, IDX_RHO_BAR) = (', &
        !    V(IDX_MASS_BAR), ' ,', V(IDX_PRESSURE_BAR), ' ,', V(IDX_ENERGY_DENSITY_BAR), ' ,', &
        !    V(IDX_RADIUS_BAR), ' ,', V(IDX_RHO_BAR), ')'

    end subroutine set_initial_conditions

    !> \brief The calculations that should be performed after the runge-kutta.
    !! Conversions and other values that should be calculated go here
    !!
    !! \param parameters
    !! \param t
    !! \param Y
    !! \param V
    !!
    subroutine process_specific_calculations(parameters, t, Y, V)
        type(ConfigParameters) :: parameters
        double precision :: t
        double precision :: Y(N_DIFF_EQUATIONS)
        double precision :: V(N_VARIABLES)

        !OK
        !write (*,*) &
        !    '(IDX_MASS_BAR, IDX_PRESSURE_BAR, IDX_ENERGY_DENSITY_BAR, IDX_RADIUS_BAR, IDX_RHO_BAR) = (', &
        !    V(IDX_MASS_BAR), ' ,', V(IDX_PRESSURE_BAR), ' ,', V(IDX_ENERGY_DENSITY_BAR), ' ,', &
        !    V(IDX_RADIUS_BAR), ' ,', V(IDX_RHO_BAR), ')'

        V(IDX_RADIUS_BAR) = t;

        V(IDX_PRESSURE_BAR) = Y(IDX_EQN_DP_DN);

        V(IDX_ENERGY_DENSITY_BAR) = energy_density_from_eos(parameters, t, Y, V);

        V(IDX_RHO_BAR) = V(IDX_ENERGY_DENSITY_BAR);

        V(IDX_MASS_BAR) = Y(IDX_EQN_DM_DN);

        V(IDX_INFOR_ENTROPY) = V(IDX_INFOR_ENTROPY) + calc_infor_entropy(parameters, t, Y, V);
        V(IDX_DISEQUILIBRIUM) = V(IDX_DISEQUILIBRIUM) + calc_infor_disequilibrium(parameters, t, Y, V);

        V(IDX_SPEED_OF_SOUND) = SQRT((parameters%P_0 * V(IDX_PRESSURE_BAR))/ &
            (parameters%ENERGY_DENSITY_0 * V(IDX_RHO_BAR))) * &
            LIGHT_SPEED_SCALE(parameters%UNIT_SYSTEM)

        if (parameters%eos_file_provides_baryonic_density) then
            V(IDX_BARYON_NUMBER) = V(IDX_BARYON_NUMBER) + calc_baryon_number(parameters, t, Y, V);
        end if

        !write (*,*) V(IDX_ENERGY_DENSITY_BAR) * (parameters%RHO_ADIM * LIGHT_SPEED(parameters%UNIT_SYSTEM)**2.), &
        !', ', V(IDX_PRESSURE_BAR)* (parameters%RHO_ADIM * LIGHT_SPEED(parameters%UNIT_SYSTEM)**2.)

    end subroutine process_specific_calculations

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> Evaluates derivatives at a point
    !---------------------------------------------------------------------------
    double precision function derivative(parameters, t, Y, V, equationNumber)
    implicit none
        type(ConfigParameters) :: parameters
        double precision :: t, Y(N_DIFF_EQUATIONS), V(N_VARIABLES)
        integer :: equationNumber

        double precision :: returnValue

        !write (*,*) &
        !    '(IDX_MASS_BAR, IDX_PRESSURE_BAR, IDX_ENERGY_DENSITY_BAR, IDX_RADIUS_BAR, IDX_RHO_BAR) = (', &
        !    V(IDX_MASS_BAR), ' ,', V(IDX_PRESSURE_BAR), ' ,', V(IDX_ENERGY_DENSITY_BAR), ' ,', &
        !    V(IDX_RADIUS_BAR), ' ,', V(IDX_RHO_BAR), ')'

        select case (equationNumber)
            case (IDX_EQN_DM_DN)
                  returnValue = dM_dn(parameters, t, Y, V);

            case (IDX_EQN_DP_DN)

                    if (parameters%RHO_0 <= parameters%cutoff_RHO_0) then
                        returnValue = dP_dN_Newtonian(parameters, t, Y, V);
                    else
                        returnValue = dP_dn_Relativistic(parameters, t, Y, V);
                    end if

            case default
                returnValue = 0.;

        end select

        derivative = returnValue

    end function derivative

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> Evaluates the pressure P at a point
    !
    !> Compute \f$ P \f$
    !---------------------------------------------------------------------------
    double precision function dM_dn(parameters, t, Y, V)
    implicit none
        type(ConfigParameters) :: parameters
        double precision :: t
        double precision :: Y(N_DIFF_EQUATIONS)
        double precision :: V(N_VARIABLES)

        double precision :: energy_density_bar

        !write (*,*) '(t, energy density) = (', t, ', ', V(IDX_ENERGY_DENSITY_BAR), ')'

        !V(IDX_ENERGY_DENSITY_BAR) = energy_density_from_eos(parameters, t, Y, V)
        energy_density_bar = energy_density_from_eos(parameters, t, Y, V);

        dM_dn = energy_density_bar * t**2.

    end function dM_dn

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> Evaluates the pressure P at a point (TOV)
    !
    !> Compute \f$ P \f$
    !---------------------------------------------------------------------------
    double precision function dP_dn_Relativistic(parameters, t, Y, V)
    implicit none
        type(ConfigParameters) :: parameters
        double precision :: t
        double precision :: Y(N_DIFF_EQUATIONS)
        double precision :: V(N_VARIABLES)

        double precision :: numerator, denominator

        double precision :: energy_density_bar
        double precision :: pressure_bar

        energy_density_bar = energy_density_from_eos(parameters, t, Y, V);
        pressure_bar = Y(IDX_PRESSURE_BAR);

        !write (*,*) &
        !    '(t, MASS, PRESSURE, ENERGY, RADIUS, RHO) = (', t, ', ', &
        !    V(IDX_MASS_BAR), ' ,', V(IDX_PRESSURE_BAR), ' ,', V(IDX_ENERGY_DENSITY_BAR), ' ,', &
        !    V(IDX_RADIUS_BAR), ' ,', V(IDX_RHO_BAR), ')'

        numerator = - (energy_density_bar + pressure_bar)*(pressure_bar*(t**3.) + V(IDX_MASS_BAR));

        denominator = (t**2.) * (1. - 2. * V(IDX_MASS_BAR) / t);

        !write (*,*) '(t, numerator, denominator)', t, ', ', numerator, ', ', denominator, ')'

        dP_dn_Relativistic = numerator / denominator;
    end function dP_dn_Relativistic

    !---------------------------------------------------------------------------
    ! DESCRIPTION:
    !> Evaluates the pressure P at a point (Newtonian)
    !
    !> Compute \f$ P \f$
    !---------------------------------------------------------------------------
    double precision function dP_dn_Newtonian(parameters, t, Y, V)
    implicit none
        type(ConfigParameters) :: parameters
        double precision :: t, Y(N_DIFF_EQUATIONS), V(N_VARIABLES)

        dP_dn_Newtonian = - (V(IDX_MASS_BAR) * V(IDX_ENERGY_DENSITY_BAR) / (t **2.))
    end function dP_dn_Newtonian

    !> \brief Function that decides whether the program must stop.
    !!
    !! \param parameters
    !! \param t
    !! \param Y
    !! \param V
    !! \return
    !!
    logical function can_stop(parameters, t, Y, V)
    implicit none
        type(ConfigParameters) :: parameters
        double precision :: t
        double precision :: Y(N_DIFF_EQUATIONS)
        double precision :: V(N_VARIABLES)

        !can_stop = (V(IDX_PRESSURE_BAR) <= 0.0 .OR. V(IDX_ENERGY_DENSITY_BAR) <= 0.0);
        can_stop = (V(IDX_RHO_BAR) <= parameters%cutoff_density_bar .OR. &
            V(IDX_PRESSURE_BAR) <= 0.0);

        !DEBUG
        !write (*,*) 'cutoff_density_bar, V(IDX_RHO_BAR) => ', parameters%cutoff_density_bar, &
        !    ',', V(IDX_RHO_BAR)

    end function can_stop

end module tov_module


      SUBROUTINE slPVUE (PV, DATE, PMASS, U, JSTAT)
*+
*     - - - - - -
*      P V U E
*     - - - - - -
*
*  Construct a universal element set based on an instantaneous position
*  and velocity.
*
*  Given:
*     PV        d(6)   heliocentric x,y,z,xdot,ydot,zdot of date,
*                      (AU,AU/s; Note 1)
*     DATE      d      date (TT Modified Julian Date = JD-2400000.5)
*     PMASS     d      mass of the planet (Sun=1; Note 2)
*
*  Returned:
*     U         d(13)  universal orbital elements (Note 3)
*
*                 (1)  combined mass (M+m)
*                 (2)  total energy of the orbit (alpha)
*                 (3)  reference (osculating) epoch (t0)
*               (4-6)  position at reference epoch (r0)
*               (7-9)  velocity at reference epoch (v0)
*                (10)  heliocentric distance at reference epoch
*                (11)  r0.v0
*                (12)  date (t)
*                (13)  universal eccentric anomaly (psi) of date, approx
*
*     JSTAT     i      status:  0 = OK
*                              -1 = illegal PMASS
*                              -2 = too close to Sun
*                              -3 = too slow
*
*  Notes
*
*  1  The PV 6-vector can be with respect to any chosen inertial frame,
*     and the resulting universal-element set will be with respect to
*     the same frame.  A common choice will be mean equator and ecliptic
*     of epoch J2000.
*
*  2  The mass, PMASS, is important only for the larger planets.  For
*     most purposes (e.g. asteroids) use 0D0.  Values less than zero
*     are illegal.
*
*  3  The "universal" elements are those which define the orbit for the
*     purposes of the method of universal variables (see reference).
*     They consist of the combined mass of the two bodies, an epoch,
*     and the position and velocity vectors (arbitrary reference frame)
*     at that epoch.  The parameter set used here includes also various
*     quantities that can, in fact, be derived from the other
*     information.  This approach is taken to avoiding unnecessary
*     computation and loss of accuracy.  The supplementary quantities
*     are (i) alpha, which is proportional to the total energy of the
*     orbit, (ii) the heliocentric distance at epoch, (iii) the
*     outwards component of the velocity at the given epoch, (iv) an
*     estimate of psi, the "universal eccentric anomaly" at a given
*     date and (v) that date.
*
*  Reference:  Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983.
*
*  P.T.Wallace   Starlink   18 March 1999
*
*  Copyright (C) 1999 Rutherford Appleton Laboratory
*
*  License:
*    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; either version 2 of the License, or
*    (at your option) any later version.
*
*    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 (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION PV(6),DATE,PMASS,U(13)
      INTEGER JSTAT

*  Gaussian gravitational constant (exact)
      DOUBLE PRECISION GCON
      PARAMETER (GCON=0.01720209895D0)

*  Canonical days to seconds
      DOUBLE PRECISION CD2S
      PARAMETER (CD2S=GCON/86400D0)

*  Minimum allowed distance (AU) and speed (AU per canonical day)
      DOUBLE PRECISION RMIN,VMIN
      PARAMETER (RMIN=1D-3,VMIN=1D-3)

      DOUBLE PRECISION T0,CM,X,Y,Z,XD,YD,ZD,R,V2,V,ALPHA,RDV

*  Reference epoch.
      T0 = DATE

*  Combined mass (mu=M+m).
      IF (PMASS.LT.0D0) GO TO 9010
      CM = 1D0+PMASS

*  Unpack the state vector, expressing velocity in AU per canonical day.
      X = PV(1)
      Y = PV(2)
      Z = PV(3)
      XD = PV(4)/CD2S
      YD = PV(5)/CD2S
      ZD = PV(6)/CD2S

*  Heliocentric distance, and speed.
      R = SQRT(X*X+Y*Y+Z*Z)
      V2 = XD*XD+YD*YD+ZD*ZD
      V = SQRT(V2)

*  Reject unreasonably small values.
      IF (R.LT.RMIN) GO TO 9020
      IF (V.LT.VMIN) GO TO 9030

*  Total energy of the orbit.
      ALPHA = V2-2D0*CM/R

*  Outward component of velocity.
      RDV = X*XD+Y*YD+Z*ZD

*  Construct the universal-element set.
      U(1) = CM
      U(2) = ALPHA
      U(3) = T0
      U(4) = X
      U(5) = Y
      U(6) = Z
      U(7) = XD
      U(8) = YD
      U(9) = ZD
      U(10) = R
      U(11) = RDV
      U(12) = T0
      U(13) = 0D0

*  Exit.
      JSTAT = 0
      GO TO 9999

*  Negative PMASS.
 9010 CONTINUE
      JSTAT = -1
      GO TO 9999

*  Too close.
 9020 CONTINUE
      JSTAT = -2
      GO TO 9999

*  Too slow.
 9030 CONTINUE
      JSTAT = -3

 9999 CONTINUE
      END


      subroutine cohband(iband,ibcoh,nfreqmax,nfb,ncb,cohw,icohbm)

c      Given limits of narrow processing band (IBAND) returns wider
c      limits of coherence sort band (IBCOH);
c      COHW is input parameter controlling relative width of
c      coherence presort band

      integer iband(2),ibcoh(2),nfreqmax,nfb,ncb,icohbm
      ibcoh(1) = nint(iband(1)/cohw)
      ibcoh(1) = max(ibcoh(1),1)
      ibcoh(2) = nint(iband(2)*cohw)
      ibcoh(2) = min(ibcoh(2),nfreqmax)
      nfb = iband(2)-iband(1)+1
      ncb = ibcoh(2)-ibcoh(1)+1
      if(ncb.lt.icohbm) then
         c = sqrt(float(icohbm))
         ibcoh(1) = nint(iband(1)-c)
         ibcoh(1) = max(1,ibcoh(1))
         ibcoh(2) = ibcoh(1)-1+icohbm
         ncb = ibcoh(2)-ibcoh(1)+1
      end if
      return
      end


*DECK CTANH
      COMPLEX FUNCTION CTANH (Z)
C***BEGIN PROLOGUE  CTANH
C***PURPOSE  Compute the complex hyperbolic tangent.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4C
C***TYPE      COMPLEX (CTANH-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, HYPERBOLIC TANGENT
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CTANH(Z) calculates the complex hyperbolic tangent of complex
C argument Z.  Z is in units of radians.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CTAN
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CTANH
      COMPLEX Z, CI, CTAN
      SAVE CI
      DATA CI /(0.,1.)/
C***FIRST EXECUTABLE STATEMENT  CTANH
      CTANH = -CI*CTAN(CI*Z)
C
      RETURN
      END


!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
! Green's functions for the oscillatory Stokes equations in several
! forms:
!
! - evaluate field/pressure given vector strength mu
! - return matrix/vector mapping vector strength mu to field/pressure
! - evaluate associated stream function (or part thereof for doublet)
! - evaluate vector mapping vector strength to stream function
! - vectorized versions
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

subroutine ostokeslet(zk,src,targ,mu, &
     zvel,ifstress,stress)
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  ! This function evaluates the velocity field
  ! and its derivatives (if requested)
  ! of a stokeslet with density mu
  !
  ! Let gradperp = (-dx2,dx1), and
  ! tau = (-rnorm(2),rnorm(1))
  !
  ! This function returns
  !
  ! zvel = gradperp (gradperp dot mu) G
  !
  ! and zvelder(i,j) = dxi zvel(j) (if requested)
  !
  ! Where G is the Bi-Helmholtz Green's function
  !
  ! G(x,y) = -(i*H_0^(1)(zk*r)/4 + log(r)/(2*pi))/zk^2
  !
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  implicit none
  ! global
  complex *16, intent(in) :: zk, mu(2)
  real *8, intent(in) :: src(2), targ(2)
  integer, intent(in) :: ifstress
  complex *16, intent(out) :: zvel(2), stress(2,2)
  ! local
  complex *16 mat(2,2), stressmat(2,2,2)

  call ostokesletmat(zk,src,targ, &
     mat,ifstress,stressmat)

  zvel(1) = mat(1,1)*mu(1) + mat(1,2)*mu(2)
  zvel(2) = mat(2,1)*mu(1) + mat(2,2)*mu(2)

  if (ifstress .eq. 1) then
     stress(1,1) = stressmat(1,1,1)*mu(1)+stressmat(1,1,2)*mu(2)
     stress(2,1) = stressmat(2,1,1)*mu(1)+stressmat(2,1,2)*mu(2)
     stress(1,2) = stressmat(1,2,1)*mu(1)+stressmat(1,2,2)*mu(2)
     stress(2,2) = stressmat(2,2,1)*mu(1)+stressmat(2,2,2)*mu(2)
  end if
  return
end subroutine ostokeslet

subroutine ostokesletmat(zk,src,targ, &
     mat,ifstress,stressmat)
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  !
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  implicit none
  ! global
  complex *16, intent(in) :: zk
  real *8, intent(in) :: src(2), targ(2)
  integer, intent(in) :: ifstress
  complex *16, intent(out) :: mat(2,2), stressmat(2,2,2)
  ! local
  integer :: ifpot, ifgrad, ifhess, ifder3, ifder4, ifder5
  complex *16 :: pot, grad(2), hess(3), der3(4), der4(5), der5(6)
  complex *16 :: pvec(2)

  ifpot = 0
  ifgrad = 0
  ifhess = 1
  ifder3 = 0
  ifder4 = 0
  ifder5 = 0
  if(ifstress.eq. 1) ifder3=1

  ! grab some derivatives of G

  call obhgreenall(zk,targ,src,ifpot,pot,ifgrad,grad, &
       ifhess,hess,ifder3,der3,ifder4,der4,ifder5,der5)

  ! zvel = gradperp (gradperp dot mu) G

  mat(1,1) = hess(3)
  mat(2,1) = -hess(2)
  mat(1,2) = -hess(2)
  mat(2,2) = hess(1)

  if (ifstress .eq. 1) then
     call ostokesletpvec(zk,src,targ,pvec)

     ! stress(i,j) = -p delta(i,j) + dxi*zvel(j) + dxj*zvel(i)

     stressmat(1,1,1) = 2*der3(3) - pvec(1)
     stressmat(1,1,2) = -2*der3(2) - pvec(2)
     stressmat(2,1,1) = der3(4)-der3(2)
     stressmat(2,1,2) = der3(1)-der3(3)
     stressmat(1,2,1) = der3(4)-der3(2)
     stressmat(1,2,2) = der3(1)-der3(3)
     stressmat(2,2,1) = -2*der3(3) - pvec(1)
     stressmat(2,2,2) = 2*der3(2) - pvec(2)
  endif

  return
end subroutine ostokesletmat

subroutine ostokesletp(zk,src,targ, &
     mu,p)

  implicit none
  ! global
  complex *16, intent(in) :: zk, mu(2)
  real *8, intent(in) :: src(2), targ(2)
  complex *16, intent(out) :: p
  ! local
  real *8 rx, ry, r2, pi2

  pi2 = 8.0d0*datan(1.0d0)

  rx = targ(1)-src(1)
  ry = targ(2)-src(2)

  r2 = rx**2 + ry**2

  p = (-rx*mu(1)-ry*mu(2))/(r2*pi2)

  return
end subroutine ostokesletp

subroutine ostokesletpvec(zk,src,targ, &
     pvec)

  implicit none
  ! global
  complex *16, intent(in) :: zk
  real *8, intent(in) :: src(2), targ(2)
  complex *16, intent(out) :: pvec(2)
  ! local
  real *8 rx, ry, r2, pi2

  pi2 = 8.0d0*datan(1.0d0)

  rx = targ(1)-src(1)
  ry = targ(2)-src(2)

  r2 = rx**2 + ry**2

  pvec(1) = -rx/(r2*pi2)
  pvec(2) = -ry/(r2*pi2)

  return
end subroutine ostokesletpvec

subroutine ostresslet(zk,src,targ,mu,nu, &
     zvel,trans)
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  ! This function evaluates the velocity field
  ! of a stresslet with densities mu and nu
  !
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  implicit none
  ! global
  complex *16, intent(in) :: zk, mu(2), nu(2)
  real *8, intent(in) :: src(2), targ(2)
  character, intent(in) :: trans
  complex *16, intent(out) :: zvel(2)
  ! local
  complex *16 :: mat(2,2)

  call ostressletmat(zk,src,targ,nu, &
     mat,trans)

  zvel(1) = mat(1,1)*mu(1) + mat(1,2)*mu(2)
  zvel(2) = mat(2,1)*mu(1) + mat(2,2)*mu(2)

  return
end subroutine ostresslet

subroutine ostressletmat(zk,src,targ,nu, &
     mat,trans)
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  ! This function produces a matrix such that
  ! mat*mu is a stresslet. trans='T' gives the
  ! transpose of the matrix
  !
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  implicit none
  ! global
  complex *16, intent(in) :: zk, nu(2)
  real *8, intent(in) :: src(2), targ(2)
  character, intent(in) :: trans
  complex *16, intent(out) :: mat(2,2)
  ! local
  integer :: ifpot, ifgrad, ifhess, ifder3, ifder4, ifder5
  complex *16 :: pot, grad(2), hess(3), der3(4), der4(5), der5(6)
  complex *16 :: mat1(2,2), mat2(2,2), tau(2), matl(2,2)
  real *8 :: gradgl(2), pi2, rx, ry, r2, c1,c2,c3

  pi2 = 8.0d0*datan(1.0d0)
  rx = targ(1)-src(1)
  ry = targ(2)-src(2)

  r2 = rx**2 + ry**2

  gradgl(1) = -rx/(r2*pi2)
  gradgl(2) = -ry/(r2*pi2)

  tau(1) = -nu(2)
  tau(2) = nu(1)

  ifpot = 0
  ifgrad = 0
  ifhess = 0
  ifder3 = 1
  ifder4 = 0
  ifder5 = 0

  ! grab some derivatives of G

  call obhgreenall(zk,targ,src,ifpot,pot,ifgrad,grad, &
       ifhess,hess,ifder3,der3,ifder4,der4,ifder5,der5)

  ! stresslet = -nu outer grad G_L - mat1 - mat2

  ! matl = -nu outer gradgl

  matl(1,1) = -nu(1)*gradgl(1)
  matl(2,1) = -nu(2)*gradgl(1)
  matl(1,2) = -nu(1)*gradgl(2)
  matl(2,2) = -nu(2)*gradgl(2)

  ! mat1
  ! -gradperp outer gradperp dnu G
  ! gradperp outer gradperp = (dx2dx2,-dx1dx2;-dx1dx2,dx1dx1)
  mat1(1,1) = -der3(3)*nu(1)-der3(4)*nu(2)
  mat1(2,1) = der3(2)*nu(1)+der3(3)*nu(2)
  mat1(1,2) = mat1(2,1)
  mat1(2,2) = -der3(1)*nu(1)-der3(2)*nu(2)

  ! mat2
  ! grad outer gradperp dtau G
  ! grad outer gradperp = (-dx1dx2,dx1dx1;-dx2dx2,dx1dx2)
  mat2(1,1) = -der3(2)*tau(1)-der3(3)*tau(2)
  mat2(2,1) = -der3(3)*tau(1)-der3(4)*tau(2)
  mat2(1,2) = der3(1)*tau(1)+der3(2)*tau(2)
  mat2(2,2) = der3(2)*tau(1)+der3(3)*tau(2)

  c1 = 1.0d0
  c2 = -1.0d0
  c3 = -1.0d0

  if (trans .eq. 'T') then
     mat(1,1) = c1*matl(1,1)+c2*mat1(1,1)+c3*mat2(1,1)
     mat(1,2) = c1*matl(2,1)+c2*mat1(2,1)+c3*mat2(2,1)
     mat(2,1) = c1*matl(1,2)+c2*mat1(1,2)+c3*mat2(1,2)
     mat(2,2) = c1*matl(2,2)+c2*mat1(2,2)+c3*mat2(2,2)
  else
     mat(1,1) = c1*matl(1,1)+c2*mat1(1,1)+c3*mat2(1,1)
     mat(1,2) = c1*matl(1,2)+c2*mat1(1,2)+c3*mat2(1,2)
     mat(2,1) = c1*matl(2,1)+c2*mat1(2,1)+c3*mat2(2,1)
     mat(2,2) = c1*matl(2,2)+c2*mat1(2,2)+c3*mat2(2,2)
  end if

  return
end subroutine ostressletmat

subroutine ostokeslayermat(zk,src,targ,nu,cs,cd, &
     mat)
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  !
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  implicit none
  ! global
  complex *16, intent(in) :: zk, nu(2), cs, cd
  real *8, intent(in) :: src(2), targ(2)
  complex *16, intent(out) :: mat(2,2)
  ! local
  integer :: ifpot, ifgrad, ifhess, ifder3, ifder4, ifder5
  integer :: ifs, ifd
  complex *16 :: pot, grad(2), hess(3), der3(4), der4(5), der5(6)
  complex *16 :: mat1(2,2), mat2(2,2), tau(2), matl(2,2)
  real *8 :: gradgl(2), pi2, rx, ry, r2, c1,c2,c3,small
  data small /1d-16/

  pi2 = 8.0d0*datan(1.0d0)
  rx = targ(1)-src(1)
  ry = targ(2)-src(2)

  r2 = rx**2 + ry**2

  gradgl(1) = -rx/(r2*pi2)
  gradgl(2) = -ry/(r2*pi2)

  tau(1) = -nu(2)
  tau(2) = nu(1)

  ifs = 1
  ifd = 1
  if (abs(cs) .lt. small) ifs = 0
  if (abs(cd) .lt. small) ifd = 0

  ifpot = 0
  ifgrad = 0
  ifhess = ifs
  ifder3 = ifd
  ifder4 = 0
  ifder5 = 0

  ! grab some derivatives of G

  if (ifs .eq. 1 .or. ifd .eq. 1) then
     call obhgreenall(zk,targ,src,ifpot,pot,ifgrad,grad, &
          ifhess,hess,ifder3,der3,ifder4,der4,ifder5,der5)
  endif

  mat(1,1) = 0.0d0
  mat(2,1) = 0.0d0
  mat(1,2) = 0.0d0
  mat(2,2) = 0.0d0

  !! SINGLE LAYER

  ! zvel = gradperp (gradperp dot mu) G

  if (ifs .eq. 1) then

     mat(1,1) = cs*hess(3)
     mat(2,1) = -cs*hess(2)
     mat(1,2) = -cs*hess(2)
     mat(2,2) = cs*hess(1)
  end if

  !! DOUBLE LAYER = transpose of stresslet

  ! stresslet = -nu outer grad G_L - mat1 - mat2

  ! matl = -nu outer gradgl

  if (ifd .eq. 1) then

     matl(1,1) = -nu(1)*gradgl(1)
     matl(2,1) = -nu(2)*gradgl(1)
     matl(1,2) = -nu(1)*gradgl(2)
     matl(2,2) = -nu(2)*gradgl(2)

     ! mat1
     ! -gradperp outer gradperp dnu G
     ! gradperp outer gradperp = (dx2dx2,-dx1dx2;-dx1dx2,dx1dx1)
     mat1(1,1) = -der3(3)*nu(1)-der3(4)*nu(2)
     mat1(2,1) = der3(2)*nu(1)+der3(3)*nu(2)
     mat1(1,2) = mat1(2,1)
     mat1(2,2) = -der3(1)*nu(1)-der3(2)*nu(2)

     ! mat2
     ! grad outer gradperp dtau G
     ! grad outer gradperp = (-dx1dx2,dx1dx1;-dx2dx2,dx1dx2)
     mat2(1,1) = -der3(2)*tau(1)-der3(3)*tau(2)
     mat2(2,1) = -der3(3)*tau(1)-der3(4)*tau(2)
     mat2(1,2) = der3(1)*tau(1)+der3(2)*tau(2)
     mat2(2,2) = der3(2)*tau(1)+der3(3)*tau(2)

     c1 = 1.0d0
     c2 = -1.0d0
     c3 = -1.0d0

     mat(1,1) = mat(1,1) + cd*(c1*matl(1,1)+c2*mat1(1,1)+c3*mat2(1,1))
     mat(1,2) = mat(1,2) + cd*(c1*matl(2,1)+c2*mat1(2,1)+c3*mat2(2,1))
     mat(2,1) = mat(2,1) + cd*(c1*matl(1,2)+c2*mat1(1,2)+c3*mat2(1,2))
     mat(2,2) = mat(2,2) + cd*(c1*matl(2,2)+c2*mat1(2,2)+c3*mat2(2,2))

  endif

  return
end subroutine ostokeslayermat

subroutine ostokesstressmatmany(zk,ns,src,nt,targ,nu, &
     mat)
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  ! Wrapper for evaluating the interaction between
  ! multiple sources and targets for a stresslet
  !
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  implicit none
  ! global
  complex *16, intent(in) :: zk, nu(2,nt)
  real *8, intent(in) :: src(2,ns), targ(2,nt)
  integer, intent(in) :: ns, nt
  complex *16, intent(out) :: mat(2,2,nt,ns)
  ! local
  integer :: i, j
  character :: trans

  trans='N'

  !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j)
  do j = 1,ns
     do i = 1,nt
        call ostressletmat(zk,src(1,j),targ(1,i),nu(1,i), &
             mat(1,1,i,j),trans)
     enddo
  enddo
  !$OMP END PARALLEL DO

  return
end subroutine ostokesstressmatmany

subroutine ostokeslayermatmany(zk,ns,src,nt,targ,nu,cs,cd, &
     mat)
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  ! This function produces a matrix such that
  ! mat*mu is a stresslet. trans='T' gives the
  ! transpose of the matrix
  !
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  implicit none
  ! global
  complex *16, intent(in) :: zk, nu(2,ns), cs, cd
  real *8, intent(in) :: src(2,ns), targ(2,nt)
  integer, intent(in) :: ns, nt
  complex *16, intent(out) :: mat(2,2,nt,ns)
  ! local
  integer :: i, j

  !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j)
  do j = 1,ns
     do i = 1,nt
        call ostokeslayermat(zk,src(1,j),targ(1,i),nu(1,j),cs,cd, &
             mat(1,1,i,j))
     enddo
  enddo
  !$OMP END PARALLEL DO

  return
end subroutine ostokeslayermatmany

subroutine ostokesletstreammat(zk,src,targ, &
     zmat)
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  implicit none
  ! global
  complex *16, intent(in) :: zk
  real *8, intent(in) :: src(2), targ(2)
  complex *16, intent(out) :: zmat(1,2)
  ! local
  integer :: ifpot, ifgrad, ifhess, ifder3, ifder4, ifder5
  complex *16 :: pot, grad(2), hess(3), der3(4), der4(5), der5(6)
  complex *16 :: pvec(2)

  ifpot = 0
  ifgrad = 1
  ifhess = 0
  ifder3 = 0
  ifder4 = 0
  ifder5 = 0

  ! grab some derivatives of G

  call obhgreenall(zk,targ,src,ifpot,pot,ifgrad,grad, &
       ifhess,hess,ifder3,der3,ifder4,der4,ifder5,der5)

  ! stream function is given by grad perp G dot mu

  zmat(1,1) = -grad(2)
  zmat(1,2) = grad(1)

  return
end subroutine ostokesletstreammat

subroutine ostokdubstreammat(zk,src,targ,nu, &
     zmat)
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  !
  ! applied to a vector density mu, this gives the
  ! stream function part of the double layer potential
  ! (missing the potential part, i.e. the part due
  ! to "pressure")
  !
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  implicit none
  ! global
  complex *16, intent(in) :: zk, nu(2)
  real *8, intent(in) :: src(2), targ(2)
  complex *16, intent(out) :: zmat(1,2)
  ! local
  integer :: ifpot, ifgrad, ifhess, ifder3, ifder4, ifder5
  complex *16 :: pot, grad(2), hess(3), der3(4), der4(5), der5(6)
  complex *16 :: zmat1(1,2), zmat2(1,2), tau(2)
  real *8 :: c1,c2

  tau(1) = -nu(2)
  tau(2) = nu(1)

  ifpot = 0
  ifgrad = 0
  ifhess = 1
  ifder3 = 0
  ifder4 = 0
  ifder5 = 0

  ! grab some derivatives of G

  call obhgreenall(zk,targ,src,ifpot,pot,ifgrad,grad, &
       ifhess,hess,ifder3,der3,ifder4,der4,ifder5,der5)

  ! mat1
  ! - gradperp dnu G
  !
  zmat1(1,1) = hess(2)*nu(1)+hess(3)*nu(2)
  zmat1(1,2) = -hess(1)*nu(1)-hess(2)*nu(2)

  ! mat2
  ! grad dtau G
  !
  zmat2(1,1) = hess(1)*tau(1)+hess(2)*tau(2)
  zmat2(1,2) = hess(2)*tau(1)+hess(3)*tau(2)

  c1 = -1.0d0
  c2 = -1.0d0

  zmat(1,1) = c1*zmat1(1,1) + c2*zmat2(1,1)
  zmat(1,2) = c1*zmat1(1,2) + c2*zmat2(1,2)

  return
end subroutine ostokdubstreammat

subroutine ostokesallstreammat(zk,src,targ,nu,cs,cd, &
     zmat)
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  !
  ! applied to a vector density mu, this gives the
  ! stream function part of the double layer potential
  ! (missing the potential part, i.e. the part due
  ! to "pressure")
  !
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  implicit none
  ! global
  complex *16, intent(in) :: zk, nu(2), cs, cd
  real *8, intent(in) :: src(2), targ(2)
  complex *16, intent(out) :: zmat(1,2)
  ! local
  integer :: ifpot, ifgrad, ifhess, ifder3, ifder4, ifder5
  integer :: ifs, ifd
  complex *16 :: pot, grad(2), hess(3), der3(4), der4(5), der5(6)
  complex *16 :: zmat1(1,2), zmat2(1,2), tau(2)
  real *8 :: c1,c2,small
  data small /1d-16 /

  ifs = 1
  ifd = 1
  if (abs(cs) .lt. small) ifs = 0
  if (abs(cd) .lt. small) ifd = 0

  tau(1) = -nu(2)
  tau(2) = nu(1)

  ifpot = 0
  ifgrad = ifs
  ifhess = ifd
  ifder3 = 0
  ifder4 = 0
  ifder5 = 0

  ! grab some derivatives of G

  call obhgreenall(zk,targ,src,ifpot,pot,ifgrad,grad, &
       ifhess,hess,ifder3,der3,ifder4,der4,ifder5,der5)

  zmat(1,1) = 0.0d0
  zmat(1,2) = 0.0d0

  if (ifs .eq. 1) then
     zmat(1,1) = -cs*grad(2)
     zmat(1,2) = cs*grad(1)
  endif

  if (ifd .eq. 1) then

     ! mat1
     ! - gradperp dnu G
     !
     zmat1(1,1) = hess(2)*nu(1)+hess(3)*nu(2)
     zmat1(1,2) = -hess(1)*nu(1)-hess(2)*nu(2)

     ! mat2
     ! grad dtau G
     !
     zmat2(1,1) = hess(1)*tau(1)+hess(2)*tau(2)
     zmat2(1,2) = hess(2)*tau(1)+hess(3)*tau(2)

     c1 = -1.0d0
     c2 = -1.0d0

     zmat(1,1) = zmat(1,1) + cd*(c1*zmat1(1,1) + c2*zmat2(1,1))
     zmat(1,2) = zmat(1,2) + cd*(c1*zmat1(1,2) + c2*zmat2(1,2))
  endif

  return
end subroutine ostokesallstreammat

subroutine ostokesallstreammatmany(zk,ns,src,nt,targ,nu,cs,cd, &
     zmat)
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  !
  ! applied to a vector density mu, this gives the
  ! stream function part of the double layer potential
  ! (missing the potential part, i.e. the part due
  ! to "pressure")
  !
  !cccccccccccccccccccccccccccccccccccccccccccccccccc
  implicit none
  ! global
  complex *16, intent(in) :: zk, nu(2,ns), cs, cd
  real *8, intent(in) :: src(2,ns), targ(2,nt)
  integer, intent(in) :: ns, nt
  complex *16, intent(out) :: zmat(1,2,nt,ns)
  ! local
  integer :: i, j

  do j = 1,ns
     do i = 1,nt
        call ostokesallstreammat(zk,src(1,j),targ(1,i),nu(1,j),cs,cd, &
             zmat(1,1,i,j))
     enddo
  enddo

  return
end subroutine ostokesallstreammatmany


program main
  use baobzi
  implicit none
  real(kind=c_double) :: center(2), half_length(2), tol
  real(kind=c_double) :: x(2)
  real(kind=c_double), target :: scale_factor
  character(len=64) :: fname
  type(c_ptr) :: func_approx
  type(baobzi_input_t) :: input

  input%func = c_funloc(testfun)
  input%data = c_loc(scale_factor)
  input%dim = 2
  input%order = 6
  input%tol = 1E-8

  scale_factor = 1.0

  center(:) = 0.0
  half_length(:) = 1.0

  x(:) = 0.25

  fname = trim(adjustl('fortran.baobzi'))//char(0)

  func_approx = baobzi_init(input, center, half_length)
  print *, baobzi_eval(func_approx, x) - testfun(x, scale_factor)

  call baobzi_save(func_approx, fname)
  func_approx = baobzi_free(func_approx)

  func_approx = baobzi_restore(fname)
  print *, baobzi_eval(func_approx, x) - testfun(x, scale_factor)

contains
  function testfun (x, data) bind(c) result(y)
    use, intrinsic :: iso_c_binding
    implicit none
    real(kind=c_double), dimension(*) :: x
    real(kind=c_double) :: data
    real(kind=c_double) :: y

    y = data * x(1) * x(2)
  end function testfun

end program main


      subroutine banfac ( w, nroww, nrow, nbandl, nbandu, iflag )
c  from  * a practical guide to splines *  by c. de boor
c  returns in  w  the lu-factorization (without pivoting) of the banded
c  matrix  a  of order	nrow  with  (nbandl + 1 + nbandu) bands or diag-
c  onals in the work array  w .
c
c******  i n p u t  ******
c  w.....work array of size  (nroww,nrow)  containing the interesting
c	 part of a banded matrix  a , with the diagonals or bands of  a
c	 stored in the rows of	w , while columns of  a  correspond to
c	 columns of  w . this is the storage mode used in  linpack  and
c	 results in efficient innermost loops.
c	    explicitly,  a  has  nbandl  bands below the diagonal
c			     +	   1	 (main) diagonal
c			     +	 nbandu  bands above the diagonal
c	 and thus, with    middle = nbandu + 1,
c	   a(i+j,j)  is in  w(i+middle,j)  for i=-nbandu,...,nbandl
c					       j=1,...,nrow .
c	 for example, the interesting entries of a (1,2)-banded matrix
c	 of order  9  would appear in the first  1+1+2 = 4  rows of  w
c	 as follows.
c			   13 24 35 46 57 68 79
c			12 23 34 45 56 67 78 89
c		     11 22 33 44 55 66 77 88 99
c		     21 32 43 54 65 76 87 98
c
c	 all other entries of  w  not identified in this way with an en-
c	 try of  a  are never referenced .
c  nroww.....row dimension of the work array  w .
c	 must be  .ge.	nbandl + 1 + nbandu  .
c  nbandl.....number of bands of  a  below the main diagonal
c  nbandu.....number of bands of  a  above the main diagonal .
c
c******  o u t p u t  ******
c  iflag.....integer indicating success( = 1) or failure ( = 2) .
c     if  iflag = 1, then
c  w.....contains the lu-factorization of  a  into a unit lower triangu-
c	 lar matrix  l	and an upper triangular matrix	u (both banded)
c	 and stored in customary fashion over the corresponding entries
c	 of  a . this makes it possible to solve any particular linear
c	 system  a*x = b  for  x  by a
c	       call banslv ( w, nroww, nrow, nbandl, nbandu, b )
c	 with the solution x  contained in  b  on return .
c     if  iflag = 2, then
c	 one of  nrow-1, nbandl,nbandu failed to be nonnegative, or else
c	 one of the potential pivots was found to be zero indicating
c	 that  a  does not have an lu-factorization. this implies that
c	 a  is singular in case it is totally positive .
c
c******  m e t h o d  ******
c     gauss elimination  w i t h o u t	pivoting is used. the routine is
c  intended for use with matrices  a  which do not require row inter-
c  changes during factorization, especially for the  t o t a l l y
c  p o s i t i v e  matrices which occur in spline calculations.
c     the routine should not be used for an arbitrary banded matrix.
c
      integer iflag,nbandl,nbandu,nrow,nroww,	i,ipk,j,jmax,k,kmax
     *					      ,middle,midmk,nrowm1
      real w(nroww,nrow),   factor,pivot
c
      iflag = 1
      middle = nbandu + 1
c			  w(middle,.) contains the main diagonal of  a .
      nrowm1 = nrow - 1
      if (nrowm1)			999,900,1
    1 if (nbandl .gt. 0)		go to 10
c		 a is upper triangular. check that diagonal is nonzero .
      do 5 i=1,nrowm1
	 if (w(middle,i) .eq. 0.)	go to 999
    5	 continue
					go to 900
   10 if (nbandu .gt. 0)		go to 20
c	       a is lower triangular. check that diagonal is nonzero and
c		  divide each column by its diagonal .
      do 15 i=1,nrowm1
	 pivot = w(middle,i)
	 if(pivot .eq. 0.)		go to 999
	 jmax = min0(nbandl, nrow - i)
	 do 15 j=1,jmax
   15	    w(middle+j,i) = w(middle+j,i)/pivot
					return
c
c	 a  is not just a triangular matrix. construct lu factorization
   20 do 50 i=1,nrowm1
c				   w(middle,i)	is pivot for i-th step .
	 pivot = w(middle,i)
	 if (pivot .eq. 0.)		go to 999
c		  jmax	is the number of (nonzero) entries in column  i
c		      below the diagonal .
	 jmax = min0(nbandl,nrow - i)
c	       divide each entry in column  i  below diagonal by pivot .
	 do 32 j=1,jmax
   32	    w(middle+j,i) = w(middle+j,i)/pivot
c		  kmax	is the number of (nonzero) entries in row  i  to
c		      the right of the diagonal .
	 kmax = min0(nbandu,nrow - i)
c		   subtract  a(i,i+k)*(i-th column) from (i+k)-th column
c		   (below row  i ) .
	 do 40 k=1,kmax
	    ipk = i + k
	    midmk = middle - k
	    factor = w(midmk,ipk)
	    do 40 j=1,jmax
   40	       w(midmk+j,ipk) = w(midmk+j,ipk) - w(middle+j,i)*factor
   50	 continue
c					check the last diagonal entry .
  900 if (w(middle,nrow) .ne. 0.)	return
  999 iflag = 2
					return
      end


PROGRAM GaussianSphericalDiffusion1D

  USE KindModule, ONLY: &
    DP, Pi
  USE UnitsModule, ONLY: &
    Centimeter, &
    Kilometer, &
    MeV, &
    Microsecond, &
    Millisecond
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE TransportProblemsInitializationModule, ONLY: &
    InitializeGaussianSphericalDiffusion1D
  USE TimeSteppingModule, ONLY: &
    EvolveFields, &
    SI_RK

  IMPLICIT NONE

  CALL InitializeProgram &
         ( ProgramName_Option &
             = 'GaussianSphericalDiffusion1D', &
           nX_Option &
             = [ 32, 1, 1 ], &
           swX_Option &
             = [ 1, 0, 0 ], &
           bcX_Option &
             = [ 10, 0, 0 ], &
           xL_Option &
             = [ 0.0d0 * Kilometer, 0.0d0, 0.0d0 ], &
           xR_Option &
             = [ 5.0d1 * Kilometer, Pi,    4.0d0 ], &
           nE_Option &
             = 1, &
           eL_Option &
             = 0.0d0 * MeV, &
           eR_Option &
             = 2.0d2 * MeV, &
           ZoomE_Option &
             = 1.0_DP, &
           nNodes_Option &
             = 3, &
           CoordinateSystem_Option &
             = 'SPHERICAL', &
           ActivateUnits_Option &
             = .TRUE., &
           EquationOfState_Option &
             = 'TABLE', &
           EquationOfStateTableName_Option &
             = 'EquationOfStateTable.h5', &
           Opacity_Option &
             = 'TABLE', &
           OpacityTableName_Option &
             = 'OpacityTable.h5', &
           FluidRadiationCoupling_Option &
             = 'ElasticScattering', &
           EvolveFluid_Option &
             = .FALSE., &
           RadiationSolver_Option &
             = 'M1_DG', &
           RadiationRiemannSolver_Option &
             = 'HLL', &
           EvolveRadiation_Option &
             = .TRUE., &
           ApplySlopeLimiter_Option &
             = .TRUE., &
           BetaTVB_Option &
             = 0.0d0, &
           BetaTVD_Option &
             = 1.8d0, &
           ApplyPositivityLimiter_Option &
             = .TRUE., &
           nStages_SI_RK_Option &
             = 2 )

  CALL InitializeGaussianSphericalDiffusion1D &
         ( t_0 = 3.0d-0 * Millisecond, &
           BackgroundConditions_Option = '01' )

  CALL EvolveFields &
         ( t_begin  = 0.0d+0 * Millisecond, &
           t_end    = 1.0d+1 * Millisecond, &
           dt_write = 1.0d-0 * Millisecond, &
           UpdateFields = SI_RK )

  CALL FinalizeProgram

END PROGRAM GaussianSphericalDiffusion1D