! =====================================================
subroutine rpt2(ixy,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,asdq,bmasdq,bpasdq)
! =====================================================

      implicit none
!
!     # Riemann solver in the transverse direction using an einfeldt
!     Jacobian.

      double precision :: grav, g
      double precision, parameter :: tol = 1.e-14
      common /cparam/ grav

      integer ixy,maxm,meqn,maux,mwaves,mbc,mx,imp

      double precision  ql(meqn,1-mbc:maxm+mbc)
      double precision  qr(meqn,1-mbc:maxm+mbc)
      double precision  asdq(meqn,1-mbc:maxm+mbc)
      double precision  bmasdq(meqn,1-mbc:maxm+mbc)
      double precision  bpasdq(meqn,1-mbc:maxm+mbc)
      double precision  aux1(maux,1-mbc:maxm+mbc)
      double precision  aux2(maux,1-mbc:maxm+mbc)
      double precision  aux3(maux,1-mbc:maxm+mbc)

      double precision  s(3)
      double precision  r(3,3)
      double precision  beta(3)
      double precision  abs_tol
      double precision  hl,hr,hul,hur,hvl,hvr,vl,vr,ul,ur,bl,br
      double precision  uhat,vhat,hhat,roe1,roe3,s1,s2,s3,s1l,s3r
      double precision  delf1,delf2,delf3,dxdcd,dxdcu
      double precision  dxdcm,dxdcp,topo1,topo3,eta

      integer i,m,mw,mu,mv

      abs_tol=tol
      g = grav

      if (ixy.eq.1) then
        mu = 2
        mv = 3
      else
        mu = 3
        mv = 2
      endif

      do i=2-mbc,mx+mbc

         hl=qr(1,i-1)
         hr=ql(1,i)
         hul=qr(mu,i-1)
         hur=ql(mu,i)
         hvl=qr(mv,i-1)
         hvr=ql(mv,i)

!===========determine velocity from momentum===========================
       if (hl.lt.abs_tol) then
          hl=0.d0
          ul=0.d0
          vl=0.d0
       else
          ul=hul/hl
          vl=hvl/hl
       endif

       if (hr.lt.abs_tol) then
          hr=0.d0
          ur=0.d0
          vr=0.d0
       else
          ur=hur/hr
          vr=hvr/hr
       endif

       do mw=1,mwaves
          s(mw)=0.d0
          beta(mw)=0.d0
          do m=1,meqn
             r(m,mw)=0.d0
          enddo
       enddo
      dxdcp = 1.d0
      dxdcm = 1.d0

      if (hl <= tol .and. hr <= tol) go to 90

       !check and see if cell that transverse waves are going in is high and dry
       if (imp.eq.1) then
            eta = qr(1,i-1)  + aux2(1,i-1)
            topo1 = aux1(1,i-1)
            topo3 = aux3(1,i-1)
!            s1 = vl-sqrt(g*hl)
!            s3 = vl+sqrt(g*hl)
!            s2 = 0.5d0*(s1+s3)
       else
            eta = ql(1,i) + aux2(1,i)
            topo1 = aux1(1,i)
            topo3 = aux3(1,i)
!            s1 = vr-sqrt(g*hr)
!            s3 = vr+sqrt(g*hr)
!            s2 = 0.5d0*(s1+s3)
       endif
       if (eta.lt.max(topo1,topo3)) go to 90

!=====Determine some speeds necessary for the Jacobian=================
            vhat=(vr*dsqrt(hr))/(dsqrt(hr)+dsqrt(hl)) + &
              (vl*dsqrt(hl))/(dsqrt(hr)+dsqrt(hl))

            uhat=(ur*dsqrt(hr))/(dsqrt(hr)+dsqrt(hl)) + &
              (ul*dsqrt(hl))/(dsqrt(hr)+dsqrt(hl))
            hhat=(hr+hl)/2.d0

            roe1=vhat-dsqrt(g*hhat)
            roe3=vhat+dsqrt(g*hhat)

            s1l=vl-dsqrt(g*hl)
            s3r=vr+dsqrt(g*hr)

            s1=dmin1(roe1,s1l)
            s3=dmax1(roe3,s3r)

            s2=0.5d0*(s1+s3)

           s(1)=s1
           s(2)=s2
           s(3)=s3
!=======================Determine asdq decomposition (beta)============
         delf1=asdq(1,i)
         delf2=asdq(mu,i)
         delf3=asdq(mv, i)

         beta(1) = (s3*delf1/(s3-s1))-(delf3/(s3-s1))
         beta(2) = -s2*delf1 + delf2
         beta(3) = (delf3/(s3-s1))-(s1*delf1/(s3-s1))
!======================End =================================================

!=====================Set-up eigenvectors===================================
         r(1,1) = 1.d0
         r(2,1) = s2
         r(3,1) = s1

         r(1,2) = 0.d0
         r(2,2) = 1.d0
         r(3,2) = 0.d0

         r(1,3) = 1.d0
         r(2,3) = s2
         r(3,3) = s3
!============================================================================
90      continue
!============= compute fluctuations==========================================

               bmasdq(1,i)=0.0d0
               bpasdq(1,i)=0.0d0
               bmasdq(2,i)=0.0d0
               bpasdq(2,i)=0.0d0
               bmasdq(3,i)=0.0d0
               bpasdq(3,i)=0.0d0
            do  mw=1,3
               if (s(mw).lt.0.d0) then
                 bmasdq(1,i) =bmasdq(1,i) + dxdcm*s(mw)*beta(mw)*r(1,mw)
                 bmasdq(mu,i)=bmasdq(mu,i)+ dxdcm*s(mw)*beta(mw)*r(2,mw)
                 bmasdq(mv,i)=bmasdq(mv,i)+ dxdcm*s(mw)*beta(mw)*r(3,mw)
               elseif (s(mw).gt.0.d0) then
                 bpasdq(1,i) =bpasdq(1,i) + dxdcp*s(mw)*beta(mw)*r(1,mw)
                 bpasdq(mu,i)=bpasdq(mu,i)+ dxdcp*s(mw)*beta(mw)*r(2,mw)
                 bpasdq(mv,i)=bpasdq(mv,i)+ dxdcp*s(mw)*beta(mw)*r(3,mw)
               endif
            enddo
!========================================================================
         enddo
!

!

      return
      end


C
C $Id: curv2.f,v 1.5 2008-07-27 03:10:10 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding double precision routine.
C
      function curv2 (t,n,x,y,yp,sigma)
c
      integer n
      real t,x(n),y(n),yp(n),sigma
c
c                                 coded by alan kaylor cline
c                           from fitpack -- january 26, 1987
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function interpolates a curve at a given point
c using a spline under tension. the subroutine curv1 should
c be called earlier to determine certain necessary
c parameters.
c
c on input--
c
c   t contains a real value to be mapped onto the interpo-
c   lating curve.
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   yp is an array of second derivative values of the curve
c   at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, yp, and sigma should be input
c unaltered from the output of curv1.
c
c on output--
c
c   curv2 contains the interpolated value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c determine interval
c
      im1 = intrvl(t,x,n)
      i = im1+1
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c set up and perform interpolation
c
      del1 = t-x(im1)
      del2 = x(i)-t
      dels = x(i)-x(im1)
      sum = (y(i)*del1+y(im1)*del2)/dels
      if (sigmap .ne. 0.) go to 1
      curv2 = sum-del1*del2*(yp(i)*(del1+dels)+yp(im1)*
     *        (del2+dels))/(6.*dels)
      return
    1 sigdel = sigmap*dels
      call snhcsh (ss,dummy,sigdel,-1)
      call snhcsh (s1,dummy,sigmap*del1,-1)
      call snhcsh (s2,dummy,sigmap*del2,-1)
      curv2 = sum+(yp(i)*del1*(s1-ss)+yp(im1)*del2*(s2-ss))/
     *            (sigdel*sigmap*(1.+ss))
      return
      end


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      FUNCTION PLTPGZ(N,X,Y,Z,XQ,YQ)
      DIMENSION X(3),Y(3),Z(3),D(2)

      X21 = X(2) - X(1)
      X31 = X(3) - X(1)
      Y21 = Y(2) - Y(1)
      Y31 = Y(3) - Y(1)
      Z21 = Z(2) - Z(1)
      Z31 = Z(3) - Z(1)
      A = Y31*Z21 - Z31*Y21
      B = Z31*X21 - X31*Z21
      C = X31*Y21 - Y31*X21
      IF (C.EQ.0.) THEN
         DO 2200 I = 1,N - 2
            D(1) = X(I+1) - X(I)
            D(2) = Y(I+1) - Y(I)
            DDD = D(1)*D(1) + D(2)*D(2)
            IF (DDD.NE.0.) THEN
               GO TO 2210

            END IF

 2200    CONTINUE
 2210    CONTINUE
         IF (DDD.EQ.0.) THEN
            PLTPGZ = 0.0
            RETURN

         END IF

         DDP = D(1)*XQ + D(2)*YQ
         DDP1 = D(1)*X(1) + D(2)*Y(1)
         ALPHA = (DDP-DDP1)/DDD
         PLTPGZ = Z(1) + ALPHA* (Z(2)-Z(1))
         RETURN

      END IF

      PLTPGZ = ((A* (X(1)-XQ)+B* (Y(1)-YQ))/C) + Z(1)
      RETURN

      END


*> \brief \b DCKCSD
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH,
*                          MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK,
*                          WORK, RWORK, NIN, NOUT, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, NIN, NM, NMATS, MMAX, NOUT
*       DOUBLE PRECISION   THRESH
*       ..
*       .. Array Arguments ..
*       INTEGER            ISEED( 4 ), IWORK( * ), MVAL( * ), PVAL( * ),
*      $                   QVAL( * )
*       DOUBLE PRECISION   RWORK( * ), THETA( * )
*       DOUBLE PRECISION   U1( * ), U2( * ), V1T( * ), V2T( * ),
*      $                   WORK( * ), X( * ), XF( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DCKCSD tests DORCSD:
*>        the CSD for an M-by-M orthogonal matrix X partitioned as
*>        [ X11 X12; X21 X22 ]. X11 is P-by-Q.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] NM
*> \verbatim
*>          NM is INTEGER
*>          The number of values of M contained in the vector MVAL.
*> \endverbatim
*>
*> \param[in] MVAL
*> \verbatim
*>          MVAL is INTEGER array, dimension (NM)
*>          The values of the matrix row dimension M.
*> \endverbatim
*>
*> \param[in] PVAL
*> \verbatim
*>          PVAL is INTEGER array, dimension (NM)
*>          The values of the matrix row dimension P.
*> \endverbatim
*>
*> \param[in] QVAL
*> \verbatim
*>          QVAL is INTEGER array, dimension (NM)
*>          The values of the matrix column dimension Q.
*> \endverbatim
*>
*> \param[in] NMATS
*> \verbatim
*>          NMATS is INTEGER
*>          The number of matrix types to be tested for each combination
*>          of matrix dimensions.  If NMATS >= NTYPES (the maximum
*>          number of matrix types), then all the different types are
*>          generated for testing.  If NMATS < NTYPES, another input line
*>          is read to get the numbers of the matrix types to be used.
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension (4)
*>          On entry, the seed of the random number generator.  The array
*>          elements should be between 0 and 4095, otherwise they will be
*>          reduced mod 4096, and ISEED(4) must be odd.
*>          On exit, the next seed in the random number sequence after
*>          all the test matrices have been generated.
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is DOUBLE PRECISION
*>          The threshold value for the test ratios.  A result is
*>          included in the output file if RESULT >= THRESH.  To have
*>          every test ratio printed, use THRESH = 0.
*> \endverbatim
*>
*> \param[in] MMAX
*> \verbatim
*>          MMAX is INTEGER
*>          The maximum value permitted for M, used in dimensioning the
*>          work arrays.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is DOUBLE PRECISION array, dimension (MMAX*MMAX)
*> \endverbatim
*>
*> \param[out] XF
*> \verbatim
*>          XF is DOUBLE PRECISION array, dimension (MMAX*MMAX)
*> \endverbatim
*>
*> \param[out] U1
*> \verbatim
*>          U1 is DOUBLE PRECISION array, dimension (MMAX*MMAX)
*> \endverbatim
*>
*> \param[out] U2
*> \verbatim
*>          U2 is DOUBLE PRECISION array, dimension (MMAX*MMAX)
*> \endverbatim
*>
*> \param[out] V1T
*> \verbatim
*>          V1T is DOUBLE PRECISION array, dimension (MMAX*MMAX)
*> \endverbatim
*>
*> \param[out] V2T
*> \verbatim
*>          V2T is DOUBLE PRECISION array, dimension (MMAX*MMAX)
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*>          THETA is DOUBLE PRECISION array, dimension (MMAX)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (MMAX)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array
*> \endverbatim
*>
*> \param[in] NIN
*> \verbatim
*>          NIN is INTEGER
*>          The unit number for input.
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*>          NOUT is INTEGER
*>          The unit number for output.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0 :  successful exit
*>          > 0 :  If DLAROR returns an error code, the absolute value
*>                 of it is returned.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE DCKCSD( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH,
     $                   MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK,
     $                   WORK, RWORK, NIN, NOUT, INFO )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, NIN, NM, NMATS, MMAX, NOUT
      DOUBLE PRECISION   THRESH
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 ), IWORK( * ), MVAL( * ), PVAL( * ),
     $                   QVAL( * )
      DOUBLE PRECISION   RWORK( * ), THETA( * )
      DOUBLE PRECISION   U1( * ), U2( * ), V1T( * ), V2T( * ),
     $                   WORK( * ), X( * ), XF( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NTESTS
      PARAMETER          ( NTESTS = 15 )
      INTEGER            NTYPES
      PARAMETER          ( NTYPES = 4 )
      DOUBLE PRECISION   GAPDIGIT, ONE, ORTH, TEN, ZERO
      PARAMETER          ( GAPDIGIT = 18.0D0, ONE = 1.0D0,
     $                     ORTH = 1.0D-12,
     $                     TEN = 10.0D0, ZERO = 0.0D0 )
      DOUBLE PRECISION   PIOVER2
      PARAMETER ( PIOVER2 = 1.57079632679489661923132169163975144210D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            FIRSTT
      CHARACTER*3        PATH
      INTEGER            I, IINFO, IM, IMAT, J, LDU1, LDU2, LDV1T,
     $                   LDV2T, LDX, LWORK, M, NFAIL, NRUN, NT, P, Q, R
*     ..
*     .. Local Arrays ..
      LOGICAL            DOTYPE( NTYPES )
      DOUBLE PRECISION   RESULT( NTESTS )
*     ..
*     .. External Subroutines ..
      EXTERNAL           ALAHDG, ALAREQ, ALASUM, DCSDTS, DLACSG, DLAROR,
     $                   DLASET
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MIN
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLARAN, DLARND
      EXTERNAL           DLARAN, DLARND
*     ..
*     .. Executable Statements ..
*
*     Initialize constants and the random number seed.
*
      PATH( 1: 3 ) = 'CSD'
      INFO = 0
      NRUN = 0
      NFAIL = 0
      FIRSTT = .TRUE.
      CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
      LDX = MMAX
      LDU1 = MMAX
      LDU2 = MMAX
      LDV1T = MMAX
      LDV2T = MMAX
      LWORK = MMAX*MMAX
*
*     Do for each value of M in MVAL.
*
      DO 30 IM = 1, NM
         M = MVAL( IM )
         P = PVAL( IM )
         Q = QVAL( IM )
*
         DO 20 IMAT = 1, NTYPES
*
*           Do the tests only if DOTYPE( IMAT ) is true.
*
            IF( .NOT.DOTYPE( IMAT ) )
     $         GO TO 20
*
*           Generate X
*
            IF( IMAT.EQ.1 ) THEN
               CALL DLAROR( 'L', 'I', M, M, X, LDX, ISEED, WORK, IINFO )
               IF( M .NE. 0 .AND. IINFO .NE. 0 ) THEN
                  WRITE( NOUT, FMT = 9999 ) M, IINFO
                  INFO = ABS( IINFO )
                  GO TO 20
               END IF
            ELSE IF( IMAT.EQ.2 ) THEN
               R = MIN( P, M-P, Q, M-Q )
               DO I = 1, R
                  THETA(I) = PIOVER2 * DLARND( 1, ISEED )
               END DO
               CALL DLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK )
               DO I = 1, M
                  DO J = 1, M
                     X(I+(J-1)*LDX) = X(I+(J-1)*LDX) +
     $                                ORTH*DLARND(2,ISEED)
                  END DO
               END DO
            ELSE IF( IMAT.EQ.3 ) THEN
               R = MIN( P, M-P, Q, M-Q )
               DO I = 1, R+1
                  THETA(I) = TEN**(-DLARND(1,ISEED)*GAPDIGIT)
               END DO
               DO I = 2, R+1
                  THETA(I) = THETA(I-1) + THETA(I)
               END DO
               DO I = 1, R
                  THETA(I) = PIOVER2 * THETA(I) / THETA(R+1)
               END DO
               CALL DLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK )
            ELSE
               CALL DLASET( 'F', M, M, ZERO, ONE, X, LDX )
               DO I = 1, M
                  J = INT( DLARAN( ISEED ) * M ) + 1
                  IF( J .NE. I ) THEN
                     CALL DROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX), 1,
     $                 ZERO, ONE )
                  END IF
               END DO
            END IF
*
            NT = 15
*
            CALL DCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T,
     $                   LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK,
     $                   RWORK, RESULT )
*
*           Print information about the tests that did not
*           pass the threshold.
*
            DO 10 I = 1, NT
               IF( RESULT( I ).GE.THRESH ) THEN
                  IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
                     FIRSTT = .FALSE.
                     CALL ALAHDG( NOUT, PATH )
                  END IF
                  WRITE( NOUT, FMT = 9998 )M, P, Q, IMAT, I,
     $               RESULT( I )
                  NFAIL = NFAIL + 1
               END IF
   10       CONTINUE
            NRUN = NRUN + NT
   20    CONTINUE
   30 CONTINUE
*
*     Print a summary of the results.
*
      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
*
 9999 FORMAT( ' DLAROR in DCKCSD: M = ', I5, ', INFO = ', I15 )
 9998 FORMAT( ' M=', I4, ' P=', I4, ', Q=', I4, ', type ', I2,
     $      ', test ', I2, ', ratio=', G13.6 )
      RETURN
*
*     End of DCKCSD
*
      END
*
*
*
      SUBROUTINE DLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK )
      IMPLICIT NONE
*
      INTEGER            LDX, M, P, Q
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   THETA( * )
      DOUBLE PRECISION   WORK( * ), X( LDX, * )
*
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
*
      INTEGER            I, INFO, R
*
      R = MIN( P, M-P, Q, M-Q )
*
      CALL DLASET( 'Full', M, M, ZERO, ZERO, X, LDX )
*
      DO I = 1, MIN(P,Q)-R
         X(I,I) = ONE
      END DO
      DO I = 1, R
         X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) = COS(THETA(I))
      END DO
      DO I = 1, MIN(P,M-Q)-R
         X(P-I+1,M-I+1) = -ONE
      END DO
      DO I = 1, R
         X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
     $      -SIN(THETA(R-I+1))
      END DO
      DO I = 1, MIN(M-P,Q)-R
         X(M-I+1,Q-I+1) = ONE
      END DO
      DO I = 1, R
         X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
     $      SIN(THETA(R-I+1))
      END DO
      DO I = 1, MIN(M-P,M-Q)-R
         X(P+I,Q+I) = ONE
      END DO
      DO I = 1, R
         X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
     $      COS(THETA(I))
      END DO
      CALL DLAROR( 'Left', 'No init', P, M, X, LDX, ISEED, WORK, INFO )
      CALL DLAROR( 'Left', 'No init', M-P, M, X(P+1,1), LDX,
     $             ISEED, WORK, INFO )
      CALL DLAROR( 'Right', 'No init', M, Q, X, LDX, ISEED,
     $             WORK, INFO )
      CALL DLAROR( 'Right', 'No init', M, M-Q,
     $             X(1,Q+1), LDX, ISEED, WORK, INFO )
*
      END


      subroutine gen4h(r,p,wt4,*)
c--- Generates 2->4 phase space with (3456) a Breit-Wigner around
c--- the Higgs mass
      implicit none
      include 'constants.f'
      include 'mxdim.f'
      include 'debug.f'
      include 'masses.f'
      include 'phasemin.f'
      include 'interference.f'
      include 'x1x2.f'
      integer nu,icount
      double precision r(mxdim)
      double precision wt4,p1(4),p2(4),p3(4),p4(4),p5(4),p6(4)
      double precision p(mxpart,4),rtshat
      double precision pswt,xjac
      double precision s3456,wt3456,ymax,yave
      include 'energy.f'
      data icount/1/
      save icount
!$omp threadprivate(icount)

      wt4=0d0

      call breitw(r(9),0d0,sqrts**2,hmass,hwidth,s3456,wt3456)

      rtshat=dsqrt(s3456)
      ymax=dlog(sqrts/rtshat)
      yave=ymax*(two*r(10)-1d0)
      xjac=two*ymax*wt3456

      xx(1)=rtshat/sqrts*exp(+yave)
      xx(2)=rtshat/sqrts*exp(-yave)

      if   ((xx(1) .gt. 1d0)
     & .or. (xx(2) .gt. 1d0)
     & .or. (xx(1) .lt. xmin)
     & .or. (xx(2) .lt. xmin)) then
c      write(6,*) 'problems with xx(1),xx(2) in gen4h',xx(1),xx(2)
      return 1
      endif

      p1(4)=-0.5d0*xx(1)*sqrts
      p1(1)=0d0
      p1(2)=0d0
      p1(3)=-0.5d0*xx(1)*sqrts

      p2(4)=-0.5d0*xx(2)*sqrts
      p2(1)=0d0
      p2(2)=0d0
      p2(3)=+0.5d0*xx(2)*sqrts

      call phase4(r,p1,p2,p3,p4,p5,p6,pswt,*999)

      do nu=1,4
      p(1,nu)=p1(nu)
      p(2,nu)=p2(nu)
      p(3,nu)=p3(nu)
      p(4,nu)=p4(nu)
      p(5,nu)=p5(nu)
      p(6,nu)=p6(nu)
      p(7,nu)=0d0
      enddo

      if (interference) then
        if (icount .eq. 1) then
          bw34_56=.true.
          icount=icount-1
        else
          bw34_56=.false.
          do nu=1,4
            p(4,nu)=p6(nu)
            p(6,nu)=p4(nu)
          enddo
          icount=icount+1
        endif
      endif

      wt4=xjac*pswt/sqrts**2

      if (debug) write(6,*) 'wt4 in gen4h',wt4
      return

 999  return 1
      end


! =========================================================================
elemental function gsw_pt_from_t_ice (t, p, p_ref)
! =========================================================================
!
!  Calculates potential temperature of ice Ih with the general reference
!  pressure, p_ref, from in-situ temperature, t.
!
!  A faster gsw routine exists if p_ref is indeed zero dbar.  This routine
!  is "gsw_pt0_from_t_ice(t,p)".
!
!  t  =  in-situ temperature (ITS-90)                             [ deg C ]
!  p  =  sea pressure                                              [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!  p_ref  =  reference pressure                                    [ dbar ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_t0

use gsw_mod_toolbox, only : gsw_gibbs_ice, gsw_gibbs_ice_part_t

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: t, p, p_ref

real (r8) :: gsw_pt_from_t_ice

integer :: number_of_iterations
real (r8) :: dentropy, dentropy_dt, dp
real (r8) :: pt_ice, pt_ice_old, ptm_ice, true_entropy

real (r8), parameter :: p1 = -2.259745637898635e-4_r8
real (r8), parameter :: p2 =  1.486236778150360e-9_r8
real (r8), parameter :: p3 =  6.257869607978536e-12_r8
real (r8), parameter :: p4 = -5.253795281359302e-7_r8
real (r8), parameter :: p5 =  6.752596995671330e-9_r8
real (r8), parameter :: p6 =  2.082992190070936e-11_r8

real (r8), parameter :: q1 = -5.849191185294459e-15_r8
real (r8), parameter :: q2 =  9.330347971181604e-11_r8
real (r8), parameter :: q3 =  3.415888886921213e-13_r8
real (r8), parameter :: q4 =  1.064901553161811e-12_r8
real (r8), parameter :: q5 = -1.454060359158787e-10_r8
real (r8), parameter :: q6 = -5.323461372791532e-13_r8

! This is the starting polynomial for pt of ice Ih.
dp = p - p_ref

pt_ice = t + dp*(p1 + (p + p_ref)*(p2 + p3*t) + t*(p4 + t*(p5 + p6*t)))

if (pt_ice.lt.-gsw_t0) pt_ice = -gsw_t0

if (pt_ice.lt.-273.0_r8) pt_ice = pt_ice + 0.05_r8
! we add 0.05 to the initial estimate of pt_ice at temps less than -273 to
! ensure that it is never less than -273.15.

dentropy_dt = -gsw_gibbs_ice(2,0,pt_ice,p_ref)

true_entropy = -gsw_gibbs_ice_part_t(t,p)

do number_of_iterations = 1, 3
    pt_ice_old = pt_ice
    dentropy = -gsw_gibbs_ice_part_t(pt_ice_old,p_ref) - true_entropy
    pt_ice = pt_ice_old - dentropy/dentropy_dt
    ptm_ice = 0.5_r8*(pt_ice + pt_ice_old)
    dentropy_dt = -gsw_gibbs_ice(2,0,ptm_ice,p_ref)
    pt_ice = pt_ice_old - dentropy/dentropy_dt
end do

if (pt_ice.lt.-273.0_r8) then

    pt_ice = t + (p - p_ref)*(q1 + (p + p_ref)*(q2 + q3*t) &
        + t*(q4 + t*(q5 + q6*t)))

    dentropy_dt = -gsw_gibbs_ice(2,0,pt_ice+0.01_r8,p_ref)
    ! we add 0.01 to the initial estimate of pt_ice used in the derivative to
    ! ensure that it is never less than -273.15 because the derivative
    ! approaches zero at absolute zero.

    do number_of_iterations = 1, 3
        pt_ice_old = pt_ice
        dentropy = -gsw_gibbs_ice_part_t(pt_ice_old,p_ref) - true_entropy
        pt_ice = pt_ice_old - dentropy/dentropy_dt
        ptm_ice = 0.5_r8*(pt_ice + pt_ice_old)
        ptm_ice = ptm_ice + 0.01_r8
        dentropy_dt = -gsw_gibbs_ice(2,0,ptm_ice,p_ref)
        pt_ice = pt_ice_old - dentropy/dentropy_dt
    end do

end if

! For temperatures less than -273.1 degsC the maximum error is less than
! 2x10^-7 degsC. For temperatures between -273.1 and 273 the maximum error
! is less than 8x10^-8 degsC, and for temperatures greater than -273 degsC the
! maximum error is 1.5x10^-12 degsC.  These errors are over the whole
! ocean depths with both p and pref varying independently between 0 and
! 10,000 dbar, while the in-situ temperature varied independently between
! -273.15 and +2 degsC.

gsw_pt_from_t_ice = pt_ice

return
end function

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


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2019 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.
!
! cd compressible for class 3 orifices where l/d>0 and r/d>0
! type d) with 0.5<=l/d<=2 (eq. 27)
!
!     author: Yannick Muller
!
      subroutine pk_cdc_cl3d(lqd,rqd,reynolds,p2p1,beta,cdc_cl3d)
!
      implicit none
!
      real*8 lqd,rqd,reynolds,p2p1,beta,cdc_cl3d,cdi_rl,cdc_cl3_choked,
     &     jpsqpt,zeta
!
      cdc_cl3_choked=1.d0-(0.008d0+0.992d0*exp(-5.5d0*rqd
     &     -3.5d0*rqd**2.d0))*(1.d0-0.838d0)
!
      call pk_cdi_rl(lqd,rqd,reynolds,beta,cdi_rl)
!
!     help function for eq 26
      if (p2p1.ge.1d0) then
         jpsqpt=1.d0
      elseif(p2p1.ge.0.1d0) then
         zeta=(1.d0-p2p1)/0.6d0
         jpsqpt=exp(-4.6d0*zeta**7d0-2.2d0*zeta**1.5d0)
      else
         jpsqpt=0.d0
      endif
!
      cdc_cl3d=cdc_cl3_choked-jpsqpt*(cdc_cl3_choked-cdi_rl)
!
      return
!
      end


      subroutine azdip(vec,az,dip)
      dimension vec(3)
c
c     convert eigenvectors to angles
c
      degrad=3.1415826/180.
      a1=vec(1)
      a2=vec(2)
      if(a1.ne.0.0.or.a2.ne.0.0) go to 65
c
      az=0.0
      if(vec(3).gt.0.0) az=180.
      go to 70
c
   65 az=atan2(a1,a2)
      az=az/degrad
   70 a3=sqrt(a1**2+a2**2)
      a4=abs(vec(3))
      dip=atan2(a4,a3)
      dip=dip/degrad
      if(vec(3).gt.0.0) az=az-180.
      if(abs(az).gt.180.) az=az-sign(360.,az)
c
      return
      end


*DECK XPQNU
      SUBROUTINE XPQNU (NU1, NU2, MU, THETA, ID, PQA, IPQA, IERROR)
C***BEGIN PROLOGUE  XPQNU
C***SUBSIDIARY
C***PURPOSE  To compute the values of Legendre functions for XLEGF.
C            This subroutine calculates initial values of P or Q using
C            power series, then performs forward nu-wise recurrence to
C            obtain P(-MU,NU,X), Q(0,NU,X), or Q(1,NU,X). The nu-wise
C            recurrence is stable for P for all mu and for Q for mu=0,1.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      SINGLE PRECISION (XPQNU-S, DXPQNU-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  XADD, XADJ, XPSI
C***COMMON BLOCKS    XBLK1
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  XPQNU
      REAL A,NU,NU1,NU2,PQ,PQA,XPSI,R,THETA,W,X,X1,X2,XS,
     1 Y,Z
      REAL DI,DMU,PQ1,PQ2,FACTMU,FLOK
      DIMENSION PQA(*),IPQA(*)
      COMMON /XBLK1/ NBITSF
      SAVE /XBLK1/
C
C        J0, IPSIK, AND IPSIX ARE INITIALIZED IN THIS SUBROUTINE.
C        J0 IS THE NUMBER OF TERMS USED IN SERIES EXPANSION
C        IN SUBROUTINE XPQNU.
C        IPSIK, IPSIX ARE VALUES OF K AND X RESPECTIVELY
C        USED IN THE CALCULATION OF THE XPSI FUNCTION.
C
C***FIRST EXECUTABLE STATEMENT  XPQNU
      IERROR=0
      J0=NBITSF
      IPSIK=1+(NBITSF/10)
      IPSIX=5*IPSIK
      IPQ=0
C        FIND NU IN INTERVAL [-.5,.5) IF ID=2  ( CALCULATION OF Q )
      NU=MOD(NU1,1.)
      IF(NU.GE..5) NU=NU-1.
C        FIND NU IN INTERVAL (-1.5,-.5] IF ID=1,3, OR 4  ( CALC. OF P )
      IF(ID.NE.2.AND.NU.GT.-.5) NU=NU-1.
C        CALCULATE MU FACTORIAL
      K=MU
      DMU=MU
      IF(MU.LE.0) GO TO 60
      FACTMU=1.
      IF=0
      DO 50 I=1,K
      FACTMU=FACTMU*I
   50 CALL XADJ(FACTMU,IF,IERROR)
      IF (IERROR.NE.0) RETURN
   60 IF(K.EQ.0) FACTMU=1.
      IF(K.EQ.0) IF=0
C
C        X=COS(THETA)
C        Y=SIN(THETA/2)**2=(1-X)/2=.5-.5*X
C        R=TAN(THETA/2)=SQRT((1-X)/(1+X)
C
      X=COS(THETA)
      Y=SIN(THETA/2.)**2
      R=TAN(THETA/2.)
C
C        USE ASCENDING SERIES TO CALCULATE TWO VALUES OF P OR Q
C        FOR USE AS STARTING VALUES IN RECURRENCE RELATION.
C
      PQ2=0.0
      DO 100 J=1,2
      IPQ1=0
      IF(ID.EQ.2) GO TO 80
C
C        SERIES FOR P ( ID = 1, 3, OR 4 )
C        P(-MU,NU,X)=1./FACTORIAL(MU)*SQRT(((1.-X)/(1.+X))**MU)
C                *SUM(FROM 0 TO J0-1)A(J)*(.5-.5*X)**J
C
      IPQ=0
      PQ=1.
      A=1.
      IA=0
      DO 65 I=2,J0
      DI=I
      A=A*Y*(DI-2.-NU)*(DI-1.+NU)/((DI-1.+DMU)*(DI-1.))
      CALL XADJ(A,IA,IERROR)
      IF (IERROR.NE.0) RETURN
      IF(A.EQ.0.) GO TO 66
      CALL XADD(PQ,IPQ,A,IA,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
   65 CONTINUE
   66 CONTINUE
      IF(MU.LE.0) GO TO 90
      X2=R
      X1=PQ
      K=MU
      DO 77 I=1,K
      X1=X1*X2
   77 CALL XADJ(X1,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      PQ=X1/FACTMU
      IPQ=IPQ-IF
      CALL XADJ(PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 90
C
C        Z=-LN(R)=.5*LN((1+X)/(1-X))
C
   80 Z=-LOG(R)
      W=XPSI(NU+1.,IPSIK,IPSIX)
      XS=1./SIN(THETA)
C
C        SERIES SUMMATION FOR Q ( ID = 2 )
C        Q(0,NU,X)=SUM(FROM 0 TO J0-1)((.5*LN((1+X)/(1-X))
C    +XPSI(J+1,IPSIK,IPSIX)-XPSI(NU+1,IPSIK,IPSIX)))*A(J)*(.5-.5*X)**J
C
C        Q(1,NU,X)=-SQRT(1./(1.-X**2))+SQRT((1-X)/(1+X))
C             *SUM(FROM 0 T0 J0-1)(-NU*(NU+1)/2*LN((1+X)/(1-X))
C                 +(J-NU)*(J+NU+1)/(2*(J+1))+NU*(NU+1)*
C     (XPSI(NU+1,IPSIK,IPSIX)-XPSI(J+1,IPSIK,IPSIX))*A(J)*(.5-.5*X)**J
C
C        NOTE, IN THIS LOOP K=J+1
C
      PQ=0.
      IPQ=0
      IA=0
      A=1.
      DO 85 K=1,J0
      FLOK=K
      IF(K.EQ.1) GO TO 81
      A=A*Y*(FLOK-2.-NU)*(FLOK-1.+NU)/((FLOK-1.+DMU)*(FLOK-1.))
      CALL XADJ(A,IA,IERROR)
      IF (IERROR.NE.0) RETURN
   81 CONTINUE
      IF(MU.GE.1) GO TO 83
      X1=(XPSI(FLOK,IPSIK,IPSIX)-W+Z)*A
      IX1=IA
      CALL XADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      GO TO 85
   83 X1=(NU*(NU+1.)*(Z-W+XPSI(FLOK,IPSIK,IPSIX))+(NU-FLOK+1.)
     1  *(NU+FLOK)/(2.*FLOK))*A
      IX1=IA
      CALL XADD(PQ,IPQ,X1,IX1,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
   85 CONTINUE
      IF(MU.GE.1) PQ=-R*PQ
      IXS=0
      IF(MU.GE.1) CALL XADD(PQ,IPQ,-XS,IXS,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      IF(J.EQ.2) MU=-MU
      IF(J.EQ.2) DMU=-DMU
   90 IF(J.EQ.1) PQ2=PQ
      IF(J.EQ.1) IPQ2=IPQ
      NU=NU+1.
  100 CONTINUE
      K=0
      IF(NU-1.5.LT.NU1) GO TO 120
      K=K+1
      PQA(K)=PQ2
      IPQA(K)=IPQ2
      IF(NU.GT.NU2+.5) RETURN
  120 PQ1=PQ
      IPQ1=IPQ
      IF(NU.LT.NU1+.5) GO TO 130
      K=K+1
      PQA(K)=PQ
      IPQA(K)=IPQ
      IF(NU.GT.NU2+.5) RETURN
C
C        FORWARD NU-WISE RECURRENCE FOR F(MU,NU,X) FOR FIXED MU
C        USING
C        (NU+MU+1)*F(MU,NU,X)=(2.*NU+1)*F(MU,NU,X)-(NU-MU)*F(MU,NU-1,X)
C        WHERE F(MU,NU,X) MAY BE P(-MU,NU,X) OR IF MU IS REPLACED
C        BY -MU THEN F(MU,NU,X) MAY BE Q(MU,NU,X).
C        NOTE, IN THIS LOOP, NU=NU+1
C
  130 X1=(2.*NU-1.)/(NU+DMU)*X*PQ1
      X2=(NU-1.-DMU)/(NU+DMU)*PQ2
      CALL XADD(X1,IPQ1,-X2,IPQ2,PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      CALL XADJ(PQ,IPQ,IERROR)
      IF (IERROR.NE.0) RETURN
      NU=NU+1.
      PQ2=PQ1
      IPQ2=IPQ1
      GO TO 120
C
      END


!!  The model is placed into HSE by the following differencing:
!!
!!   (1/dr) [ <P>_i - <P>_{i-1} ] = (1/2) [ <rho>_i + <rho>_{i-1} ] g
!!
!!  This will be iterated over in tandem with the EOS call,
!!  P(i-1) = P_eos(rho(i-1), T(i-1), X(i-1)
!!

program init_1d

  use bl_types
  use bl_constants_module
  use bl_error_module
  use eos_module, only: eos_input_rt, eos, eos_init
  use eos_type_module, only: eos_t
  use extern_probin_module, only: use_eos_coulomb
  use network, only : nspec, network_species_index, spec_names, network_init
  use fundamental_constants_module, only: Gconst
  use model_parser_module

  implicit none

  integer :: i, n

  character(len=128) :: params_file

  real (kind=dp_t), DIMENSION(nspec) :: xn

  real (kind=dp_t), allocatable :: xzn_hse(:), xznl_hse(:), xznr_hse(:)
  real (kind=dp_t), allocatable :: model_hse(:,:)

  real :: A

  integer ::nx

  integer :: lun1, lun2

  real (kind=dp_t) :: xmin, xmax, dCoord

  real (kind=dp_t) :: dens_zone, temp_zone, pres_zone, entropy
  real (kind=dp_t) :: dpd

  real (kind=dp_t) :: p_want, drho, dtemp, delx

  real (kind=dp_t) :: g_zone, g_const, M_enclosed
  logical :: do_invsq_grav

  real (kind=dp_t), parameter :: TOL = 1.e-10

  integer, parameter :: MAX_ITER = 250

  integer :: iter

  logical :: converged_hse, fluff

  real (kind=dp_t) :: low_density_cutoff, temp_cutoff, smallx, max_T
  real (kind=dp_t) :: model_shift

  integer :: index_base

  character (len=256) :: outfile, outfile2
  character (len=8) :: num
  character (len=32) :: dxstr
  character (len=32) :: num_to_unitstring
  character (len=64) :: model_file

  real (kind=dp_t) :: max_hse_error, dpdr, rhog

  character (len=128) :: model_prefix

  integer :: narg

  type (eos_t) :: eos_state

  namelist /params/ nx, model_file, xmin, xmax, g_const, &
                    temp_cutoff, do_invsq_grav, &
                    low_density_cutoff, model_prefix, model_shift

  ! determine if we specified a runtime parameters file or use the default
  narg = command_argument_count()

  if (narg == 0) then
     params_file = "_params"
  else
     call get_command_argument(1, value = params_file)
  endif

  ! define defaults for the parameters for this model
  nx = 640

  model_file = "model.in"

  model_shift = 0.0_dp_t

  xmin = 0.0_dp_t
  xmax = 2.e3_dp_t

  do_invsq_grav = .false.
  g_const = -1.0

  model_prefix = "model"

  low_density_cutoff = 1.d-4
  temp_cutoff = 1.d6

  smallx = 1.d-10

  ! this comes in via extern_probin_module -- override the default
  ! here if we want
  use_eos_coulomb = .true.

  ! initialize the EOS and network
  call eos_init()
  call network_init()

  ! check the namelist for any changed parameters
  open(unit=11, file=params_file, status="old", action="read")
  read(unit=11, nml=params)
  close(unit=11)

  ! start by reading in the Lagrangian initial model
  call read_model_file(model_file)

  ! apply the shift
  do i = 1, npts_model
     model_r(i) = model_r(i) - model_shift
  enddo

!-----------------------------------------------------------------------------
! Create a 1-d uniform grid that is identical to the mesh that we are
! mapping onto, and then we want to force it into HSE on that mesh.
!-----------------------------------------------------------------------------

  ! allocate storage
  allocate(xzn_hse(nx))
  allocate(xznl_hse(nx))
  allocate(xznr_hse(nx))
  allocate(model_hse(nx,nvars_model))

  ! compute the coordinates of the new gridded function
  dCoord = (xmax - xmin) / dble(nx)

  do i = 1, nx
     xznl_hse(i) = xmin + (dble(i) - ONE)*dCoord
     xzn_hse(i)  = xmin + (dble(i) - HALF)*dCoord
     xznr_hse(i) = xmin + (dble(i))*dCoord
  enddo

!-----------------------------------------------------------------------------
! put the model onto our new uniform grid
!-----------------------------------------------------------------------------

  fluff = .false.

  do i = 1, nx
     do n = 1, nvars_model
        if (n == itemp_model) then
           model_hse(i,n) = max(temp_cutoff, interpolate(xzn_hse(i), n, interpolate_top=.true.))
        else
           model_hse(i,n) = interpolate(xzn_hse(i), n)
        endif
     enddo

     ! make it all thermodynamically consistent
     eos_state%rho = model_hse(i,idens_model)
     eos_state%T = model_hse(i,itemp_model)
     eos_state%xn(:) = model_hse(i,ispec_model:ispec_model-1+nspec)

     call eos(eos_input_rt, eos_state)

     model_hse(i,ipres_model) = eos_state%p
  enddo

  ! find the index to integrate from by looking for the peak temperature
  index_base = -1
  max_T = -1.0_dp_t

  do i = 1, nx
     if (model_hse(i,itemp_model) > max_T) then
        index_base = i
        max_T = model_hse(i,itemp_model)
     endif
  enddo

  if (index_base == -1) then
     call bl_error('ERROR: invalid base_height')
  endif

  print *, 'index_base = ', index_base

  ! make the base thermodynamics consistent for this base point -- that is
  ! what we will integrate from!
  eos_state%rho = model_hse(index_base,idens_model)
  eos_state%T = model_hse(index_base,itemp_model)
  eos_state%xn(:) = model_hse(index_base,ispec_model:ispec_model-1+nspec)

  call eos(eos_input_rt, eos_state)

  model_hse(index_base,ipres_model) = eos_state%p

!-----------------------------------------------------------------------------
! HSE + entropy solve
!-----------------------------------------------------------------------------

  ! the HSE state will be done respecting the interpolated temperature
  ! from the initial model.  When the temperature drops below T_lo,
  ! we floor it.

  !---------------------------------------------------------------------------
  ! integrate up
  !---------------------------------------------------------------------------
  do i = index_base+1, nx

     delx = xzn_hse(i) - xzn_hse(i-1)

     ! compute the gravitation acceleration at the lower edge
     if (do_invsq_grav) then
        g_zone = -Gconst*M_enclosed/xznl_hse(i)**2
     else
        g_zone = g_const
     endif

     ! we've already set initial guesses for density, temperature, and
     ! composition
     dens_zone = model_hse(i,idens_model)
     temp_zone = max(temp_cutoff, model_hse(i,itemp_model))
     xn(:) = model_hse(i,ispec_model:ispec_model-1+nspec)

     !-----------------------------------------------------------------------
     ! iteration loop
     !-----------------------------------------------------------------------

     ! start off the Newton loop by saying that the zone has not converged
     converged_hse = .FALSE.

     do iter = 1, MAX_ITER

        ! what pressure does HSE say we want?
        p_want = model_hse(i-1,ipres_model) + &
             delx*0.5*(dens_zone + model_hse(i-1,idens_model))*g_zone

        ! (t, rho) -> (p)
        eos_state%T   = temp_zone
        eos_state%rho = dens_zone
        eos_state%xn(:) = xn(:)

        call eos(eos_input_rt, eos_state)

        entropy = eos_state%s
        pres_zone = eos_state%p

        dpd = eos_state%dpdr

        drho = (p_want - pres_zone)/(dpd - 0.5*delx*g_zone)

        dens_zone = max(0.9*dens_zone, &
             min(dens_zone + drho, 1.1*dens_zone))

        if (abs(drho) < TOL*dens_zone) then
           converged_hse = .TRUE.
           exit
        endif

        if (dens_zone < low_density_cutoff) then
           dens_zone = low_density_cutoff
           temp_zone = temp_cutoff
           converged_hse = .TRUE.
           exit
        endif

     enddo

     if (.NOT. converged_hse) then
        print *, 'Error zone', i, ' did not converge in init_1d'
        print *, 'integrate up'
        print *, dens_zone, temp_zone
        print *, p_want
        print *, drho, dtemp
        call bl_error('Error: HSE non-convergence')
     endif

     ! call the EOS one more time for this zone and then go on to the next
     ! (t, rho) -> (p)
     eos_state%T     = temp_zone
     eos_state%rho   = dens_zone
     eos_state%xn(:) = xn(:)

     call eos(eos_input_rt, eos_state)

     pres_zone = eos_state%p

     ! update the thermodynamics in this zone
     model_hse(i,idens_model) = dens_zone
     model_hse(i,itemp_model) = temp_zone
     model_hse(i,ipres_model) = pres_zone

     ! to make this process converge faster, set the density in the
     ! next zone to the density in this zone
     ! model_hse(i+1,idens) = dens_zone

  enddo

  !---------------------------------------------------------------------------
  ! integrate down -- using the temperature profile defined above
  !---------------------------------------------------------------------------
  do i = index_base-1, 1, -1

     delx = xzn_hse(i+1) - xzn_hse(i)

     ! compute the gravitation acceleration at the upper edge
     if (do_invsq_grav) then
        g_zone = -Gconst*M_enclosed/xznr_hse(i)**2
     else
        g_zone = g_const
     endif

     ! we already set the temperature and composition profiles
     temp_zone = max(temp_cutoff, model_hse(i,itemp_model))
     xn(:) = model_hse(i,ispec_model:ispec_model-1+nspec)

     ! use our previous initial guess for density
     dens_zone = model_hse(i,idens_model)

     !-----------------------------------------------------------------------
     ! iteration loop
     !-----------------------------------------------------------------------

     ! start off the Newton loop by saying that the zone has not converged
     converged_hse = .FALSE.

     do iter = 1, MAX_ITER

        ! get the pressure we want from the HSE equation, just the
        ! zone below the current.  Note, we are using an average of
        ! the density of the two zones as an approximation of the
        ! interface value -- this means that we need to iterate for
        ! find the density and pressure that are consistent

        ! HSE differencing
        p_want = model_hse(i+1,ipres_model) - &
             delx*0.5*(dens_zone + model_hse(i+1,idens_model))*g_zone

        ! we will take the temperature already defined in model_hse
        ! so we only need to zero:
        !   A = p_want - p(rho)

        ! (t, rho) -> (p)
        eos_state%T     = temp_zone
        eos_state%rho   = dens_zone
        eos_state%xn(:) = xn(:)

        call eos(eos_input_rt, eos_state)

        pres_zone = eos_state%p

        dpd = eos_state%dpdr

        A = p_want - pres_zone

        drho = A/(dpd + 0.5*delx*g_zone)

        dens_zone = max(0.9_dp_t*dens_zone, &
             min(dens_zone + drho, 1.1_dp_t*dens_zone))

        if (abs(drho) < TOL*dens_zone) then
           converged_hse = .TRUE.
           exit
        endif

     enddo

     if (.NOT. converged_hse) then

        print *, 'Error zone', i, ' did not converge in init_1d'
        print *, 'integrate down'
        print *, dens_zone, temp_zone
        print *, p_want
        print *, drho
        call bl_error('Error: HSE non-convergence')

     endif

     ! call the EOS one more time for this zone and then go on to the next
     ! (t, rho) -> (p)
     eos_state%T     = temp_zone
     eos_state%rho   = dens_zone
     eos_state%xn(:) = xn(:)

     call eos(eos_input_rt, eos_state)

     pres_zone = eos_state%p

     ! update the thermodynamics in this zone
     model_hse(i,idens_model) = dens_zone
     model_hse(i,itemp_model) = temp_zone
     model_hse(i,ipres_model) = pres_zone

  enddo

  write(num,'(i8)') nx

  dxstr = num_to_unitstring(dCoord)

  outfile = trim(model_prefix) // ".hse" // ".dx_" // trim(adjustl(dxstr))
  outfile2 = trim(outfile) // ".extras"

  open (newunit=lun1, file=outfile, status="unknown")
  open (newunit=lun2, file=outfile2, status="unknown")

  write (lun1,1001) "# npts = ", nx
  write (lun1,1001) "# num of variables = ", nvars_model
  write (lun1,1002) "# density"
  write (lun1,1002) "# temperature"
  write (lun1,1002) "# pressure"

  do n = 1, nspec
     write (lun1, 1003) "# ", spec_names(n)
  enddo

1000 format (1x, 100(g26.16, 1x))
1001 format (a, i5)
1002 format (a)
1003 format (a,a)

  do i = 1, nx
     write (lun1,1000) xzn_hse(i), model_hse(i,idens_model), &
                       model_hse(i,itemp_model), model_hse(i,ipres_model), &
                      (model_hse(i,ispec_model-1+n), n=1,nspec)
  enddo

  write (lun2,1001), "# npts = ", nx
  write (lun2,1001), "# num of variables = ", 2
  write (lun2,1002), "# entropy"
  write (lun2,1002), "# c_s"

  ! test: bulk EOS call -- Maestro will do this once we are mapped, so make
  ! sure that we are in HSE with updated thermodynamics
  do i = 1, nx
     eos_state%rho = model_hse(i,idens_model)
     eos_state%T = model_hse(i,itemp_model)
     eos_state%xn(:) = model_hse(i,ispec_model:ispec_model-1+nspec)

     call eos(eos_input_rt, eos_state)

     model_hse(i,ipres_model) = eos_state%p

     write (lun2,1000), xzn_hse(i), eos_state%s, eos_state%cs
  enddo

  ! compute the maximum HSE error
  max_hse_error = -1.d30

  do i = 2, nx-1

     ! compute the gravitation acceleration at the lower edge
     if (do_invsq_grav) then
        g_zone = -Gconst*M_enclosed/xznl_hse(i)**2
     else
        g_zone = g_const
     endif

     dpdr = (model_hse(i,ipres_model) - model_hse(i-1,ipres_model))/delx
     rhog = HALF*(model_hse(i,idens_model) + model_hse(i-1,idens_model))*g_zone

     if (dpdr /= ZERO .and. model_hse(i+1,idens_model) > low_density_cutoff) then
        max_hse_error = max(max_hse_error, abs(dpdr - rhog)/abs(dpdr))
     endif

  enddo

  print *, 'maximum HSE error = ', max_hse_error
  print *, ' '

  close (unit=lun1)
  close (unit=lun2)

end program init_1d

function num_to_unitstring(value)

  use bl_types
  implicit none

  real (kind=dp_t) :: value
  character (len=32) :: num_to_unitstring
  character (len=16) :: temp

  if (value > 1.d5) then

     ! work in km
     write(temp,'(f6.3)') value/1.d5
     num_to_unitstring = trim(temp) // "km"
  else

     ! work in cm
     if (value > 1.d3) then
        write(temp,'(f8.3)') value
        num_to_unitstring = trim(temp) // "cm"

     else
        write(temp,'(f6.3)') value
        num_to_unitstring = trim(temp) // "cm"
     endif

  endif

  return
end function num_to_unitstring


SUBROUTINE volscatt(tts,tto,psi,ttl,chi_s,chi_o,frho,ftau)

    !********************************************************************************
    !*tts= solar zenith
    !*tto= viewing zenith
    !*psi= azimuth
    !*ttl= leaf inclination angle
    !*chi_s= interception functions
    !*chi_o= interception functions
    !*frho= function to be multiplied by leaf reflectance rho
    !*ftau= functions to be multiplied by leaf transmittance tau
    !********************************************************************************

    !Compute volume scattering functions and interception coefficients
    !for given solar zenith, viewing zenith, azimuth and leaf inclination angle.

    !chi_s and chi_o are the interception functions.
    !frho and ftau are the functions to be multiplied by leaf reflectance rho and
    !leaf transmittance tau, respectively, in order to obtain the volume scattering
    !function.

    !Wout Verhoef, april 2001, for CROMA

    IMPLICIT NONE

    REAL*8,INTENT(in) :: tts,tto,psi,ttl
    REAL*8,INTENT(inout) :: chi_s,chi_o,frho,ftau

    REAL*8 :: pi,rd
    common /angle/ pi,rd

    REAL*8 costs,costo,sints,sinto,cospsi
    REAL*8 psir
    REAL*8 costl,sintl,cs,co,ss,so,ds
    REAL*8 cosbts,cosbto,bts,bto
    REAL*8 btran1,btran2,bt1,bt2,bt3,t1,t2
    REAL*8 doo,denom

    costs=COS(rd*tts)
    costo=COS(rd*tto)
    sints=SIN(rd*tts)
    sinto=SIN(rd*tto)
    cospsi=COS(rd*psi)

    psir=rd*psi

    costl=COS(rd*ttl)
    sintl=SIN(rd*ttl)
    cs=costl*costs
    co=costl*costo
    ss=sintl*sints
    so=sintl*sinto

    !c ..............................................................................
    !c     betas -bts- and betao -bto- computation
    !c     Transition angles (beta) for solar (betas) and view (betao) directions
    !c     if thetav+thetal>pi/2, bottom side of the leaves is observed for leaf azimut
    !c     interval betao+phi<leaf azimut<2pi-betao+phi.
    !c     if thetav+thetal<pi/2, top side of the leaves is always observed, betao=pi
    !c     same consideration for solar direction to compute betas
    !c ..............................................................................

    cosbts=5.
    IF (ABS(ss).gt.1e-6) THEN
        cosbts=-cs/ss
    ENDIF

    cosbto=5.
    IF (ABS(so).gt.1e-6) THEN
        cosbto=-co/so
    ENDIF

    IF (ABS(cosbts).lt.1.d0) THEN
        bts=ACOS(cosbts)
        ds=ss
    ELSE
        bts=pi
        ds=cs
    ENDIF

    chi_s=2./pi*((bts-pi*.5)*cs+sin(bts)*ss)

    IF (ABS(cosbto).lt.1.d0) THEN
        bto=ACOS(cosbto)
        doo=so
    ELSEIF(tto.lt.90.) THEN
        bto=pi
        doo=co
    ELSE
        bto=0
        doo=-co
    ENDIF

    chi_o=2./pi*((bto-pi*.5)*co+SIN(bto)*so)

    !c ..............................................................................
    !c   Computation of auxiliary azimut angles bt1, bt2, bt3 used
    !c   for the computation of the bidirectional scattering coefficient w
    !c .............................................................................

    btran1=abs(bts-bto)
    btran2=pi-abs(bts+bto-pi)

    IF (psir.le.btran1) THEN
        bt1=psir
        bt2=btran1
        bt3=btran2
    ELSE
        bt1=btran1
        IF (psir.le.btran2) THEN
            bt2=psir
            bt3=btran2
        ELSE
            bt2=btran2
            bt3=psir
        ENDIF
    ENDIF

    t1=2.*cs*co+ss*so*cospsi
    t2=0.
    IF (bt2.gt.0.) THEN
        t2=SIN(bt2)*(2.*ds*doo+ss*so*COS(bt1)*COS(bt3))
    ENDIF

    denom=2.*pi*pi
    frho=((pi-bt2)*t1+t2)/denom
    ftau=    (-bt2*t1+t2)/denom

    IF (frho.lt.0) THEN
        frho=0
    ENDIF

    IF (ftau.lt.0) THEN
        ftau=0
    ENDIF

    RETURN
END SUBROUTINE volscatt


C
C $Id: ngritd.f,v 1.4 2008-07-27 00:17:18 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C This is a modified version of ngritd.f that was generated using
C nag_apt to convert from single to double precision.
C
      SUBROUTINE DNGRITD (IAXS,ANGL,UCRD,VCRD,WCRD)
      DOUBLE PRECISION ANGL
      DOUBLE PRECISION UCRD
      DOUBLE PRECISION VCRD
      DOUBLE PRECISION WCRD
      DOUBLE PRECISION DTOR
      DOUBLE PRECISION SINA
      DOUBLE PRECISION COSA
      DOUBLE PRECISION UTMP
      DOUBLE PRECISION VTMP
      DOUBLE PRECISION WTMP
C
C Define a multiplicative constant to convert from degrees to radians.
C
        DATA DTOR / .017453292519943D0 /
C
C This routine rotates the point with coordinates (UCRD,VCRD,WCRD) by
C the angle ANGL about the axis specified by IAXS (1 for the U axis,
C 2 for the V axis, 3 for the W axis).  A right-handed coordinate
C system is assumed.
C
        SINA=SIN(DTOR*ANGL)
        COSA=COS(DTOR*ANGL)
C
        UTMP=UCRD
        VTMP=VCRD
        WTMP=WCRD
C
        IF (IAXS.EQ.1) THEN
          VCRD=VTMP*COSA-WTMP*SINA
          WCRD=WTMP*COSA+VTMP*SINA
        ELSE IF (IAXS.EQ.2) THEN
          UCRD=UTMP*COSA+WTMP*SINA
          WCRD=WTMP*COSA-UTMP*SINA
        ELSE
          UCRD=UTMP*COSA-VTMP*SINA
          VCRD=VTMP*COSA+UTMP*SINA
        END IF
C
        RETURN
C
      END


#include "Config.fpp"

module mod_expchirp_signal

 !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_expchirp_signal'
 !
 !          Purpose:
 !                   Exponential Chirp Signal
 !                   Implementation of exponential chirp signal
 !                   in complex domain
 !
 !          History:
 !                        Date: 09-08-2017
 !                        Time: 11:36 GMT+2
 !            Modified:
 !                      By Bernard Gingold on: 10-03-2018, 11:19 GMT+2
 !                   1) Refactoring to Fortran 2003 standard.
 !                   2) Removing unnecessary type-bound members
 !                   3) Adding computational subroutines (additive noise)
 !                   4) Removing unnecessary destructor,copy and initialization subroutines.
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:  Bernard Gingold
 !
 !
 !
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85

 ! Tab:5 col - Type and etc.. definitions
 ! Tab:10,11 col - Type , function and subroutine code blocks.

    use module_kinds ,  only : I32P, R64P
    use mod_code_timing
    use mod_complex_arithm , only : vcmag
    use mod_jonesvec
    implicit none
    private

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Major version
    integer(I32P), parameter, public :: MOD_EXPCHIRP_SIGNAL_MAJOR = 1

    ! Minor version
    integer(I32P), parameter, public :: MOD_EXPCHIRP_SIGNAL_MINOR = 0

    ! Micro version
    integer(I32P), parameter, public :: MOD_EXPCHIRP_SIGNAL_MICRO = 0

    ! Module/file full version
    integer(I32P), parameter, public :: MOD_EXPCHIRP_SIGNAL_FULLVER = 1000*MOD_EXPCHIRP_SIGNAL_MAJOR+100*MOD_EXPCHIRP_SIGNAL_MINOR + &
                                                                      10*MOD_EXPPCHIRP_SIGNAL_MICRO

    ! Module/file creation date
    character(*),  parameter, public :: MOD_EXPCHIRP_SIGNAL_CREATE_DATE = "09-08-2017 12:21 +00200 (WED 09 AUG 2017 GMT+2)"

    ! Module/file build date (should be set to latest  successful build date/time)
    character(*),  parameter, public :: MOD_EXPCHIRP_SIGNAL_BUILD_DATE = " "

    ! Module/file author info
    character(*),  parameter, public :: MOD_EXPCHIRP_SIGNAL_AUTHOR = "Programmer: Bernard Gingold e-mail: beniekg@gmail.com"

    ! Module short description
    character(*),  parameter, public :: MOD_EXPCHIRP_SIGNAL_DESCRIPT = "Exponential Chirp complex domain implememtation."

    real(R64P),    parameter, private :: MINFREQ = 1.0e+7_R64P

    real(R64P),    parameter, private :: SMALLTS = 0.0000152587890625_R64P ! smallest time step = 1/2^-16

    !======================================================60
    !  Type: ExpChirpSignal_t
    !======================================================60

    type, public :: ExpChirpSignal_t

         private

         character(len=64)   :: m_name      ! Name of this signal

         integer(I32P)       :: m_sid       ! Signal id i.e. cardinal number in signal train

         integer(I32P)       :: m_nsamp     ! number of samples

         real(R64P)          :: m_dur       ! signal duration in ns

         real(R64P)          :: m_sfreq     ! Chirp start frequency (f0)

         real(R64P)          :: m_efreq     ! Chirp end frequency (f1)

         real(R64P)          :: m_stsinc    ! Chirp signal time step increment.

         real(R64P)          :: m_siphi     ! Chirp signal initial phase (radians)

         real(R64P)          :: m_chrate    ! Chirp rate i.e. [f1-f0/T]

         real(R64P)          :: m_sinit     ! Chirp signal starting time point

         type(JonesVector_t), allocatable, dimension(:),  public :: m_jvec      ! Jones Vector field(polarization)

         ! Electric field far from radar source
         complex(R64P), allocatable, dimension(:),        public :: m_E
!DIR$   ATTRIBUTES ALIGN : 64 :: m_E

        ! Signal enevelope i.e natural envelope
         real(R64P), allocatable, dimension(:),           public :: m_nenvp
!DIR$   ATTRIBUTES ALIGN : 64 :: m_nenvp

        ! Signal phase (phi(t))
         real(R64P), allocatable, dimension(:),           public :: m_phi
!DIR$   ATTRIBUTES ALIGN : 64 :: m_phi

        ! Signal canonical form i.e. S(t) = gc(t)*cos(wct)-gs(t)*sin(wct)
         complex(R64P), allocatable, dimension(:),        public  :: m_canform
!DIR$   ATTRIBUTES ALIGN : 64 :: m_canform

        ! Signal basic form i.e. S(t) = g(t)*cos[wct+phi(t)]
         real(R64P), allocatable, dimension(:),           public  :: m_basform
!DIR$   ATTRIBUTES ALIGN : 64 :: m_basform
        ! Signal complex envelope
         complex(R64P), allocatable, dimension(:),        public  :: m_cenvp
!DIR$   ATTRIBUTES ALIGN : 64 :: m_cenvp

        ! Signal amplitude  A(phi,theta)/r used for calculation electric field
        ! far from emmiter(antenna)
         real(R64P), allocatable, dimension(:),           public   :: m_amp
!DIR$   ATTRIBUTES ALIGN : 64 :: m_amp

        ! Time-averaged power density

         complex(R64P), allocatable, dimension(:),        public   :: m_S
!DIR$   ATTRIBUTES ALIGN : 64 :: m_S

        contains

        !========================================
        !  Constructor, destructor subroutines
        !========================================

        ! Default constructor creates zero waveform
        ! Can be used as zero interval in signal train
        !procedure, pass(this), public :: default_signal

        ! Construct complex exponential chirp signal
        procedure, pass(this), public :: expchirp_signal

        ! Creates signal with noise modulated phase
        procedure, pass(this), public :: phase_noise_expchirp_signal

        ! Creates signal with noise modulated phase
        ! coupled with background additive noise.
        procedure, pass(this), public :: additive_noise_expchirp_signal

        !==========================================52
        !   Getter pure functions
        !==========================================52

        procedure, pass(this), public :: get_name

        procedure, pass(this), public :: get_sid

        procedure, pass(this), public :: get_nsamp

        procedure, pass(this), public :: get_dur

        procedure, pass(this), public :: get_sfreq

        procedure, pass(this), public :: get_efreq

        procedure, pass(this), public :: get_stsinc

        procedure, pass(this), public :: get_siphi

        procedure, pass(this), public :: get_chrate

        procedure, pass(this), public :: get_sinit

        ! Computational subroutines

        procedure, pass(this), public :: dphi_dt

        procedure, pass(this), public :: analytic_signal

        !==============================================56
        ! write/read subroutines
        !==============================================56
        procedure, nopass, public :: read_state

        procedure, nopass, public :: write_state

        !==============================================56
        !  Class helper procedures
        !==============================================56
        procedure, nopass, public :: dbg_info

        !==============================================56
        !  Generic operators
        !==============================================56
        procedure, public :: copy_assign

        generic :: assignment (=) => copy_assign

    end type ExpChirpSignal_t

    interface ExpChirpSignal_t
          procedure :: constructor
    end interface ExpChirpSignal_t

    contains

    !======================================================60
    ! @function:  constructor
    !             default initialization (no physical meaning)
    !======================================================60
    type(ExpChirpSignal_t) function constructor(name,sid,nsamp,logging, &
                                            verbose, filename,append  )
          use mod_print_error,  only : handle_fatal_memory_error
          use mod_constants,    only : LAM_MINSAMP, LAM_PINF
          character(len=*),        intent(in)    :: name
          integer(I32P),           intent(in)    :: sid
          integer(I32P),           intent(inout) :: nsamp
          logical(I32P),           intent(in)    :: verbose,logging
          character(len=*),        intent(in)    :: filename
          logical(I32P),           intent(in)    :: append
          ! Locals

          character(len=256) :: emsg
          integer(I32P)      :: aerr
          ! Start of executable statements
          if(nsamp <= LAM_MINSAMP) then
              nsamp = LAM_MINSAMP
          end if
           ! Begin construction
          constructor%m_name   = name
          constructor%m_sid    = sid
          constructor%m_nsamp  = nsamp
          constructor%m_dur    = LAM_PINF
          constructor%m_sfreq  = LAM_PINF
          constructor%m_efreq  = LAM_PINF
          constructor%m_stsinc = LAM_PINF
          constructor%m_siphi  = LAM_PINF
          constructor%m_chrate = LAM_PINF
          constructor%m_sinit  = LAM_PINF
          associate(n=>constructor%m_nsamp)
              allocate(constructor%m_jvec(n),    &
                       constructor%m_E(n),       &
                       constructor%m_nenvp(n),   &
                       constructor%m_phi(n),     &
                       constructor%m_canform(n), &
                       constructor%m_basform(n), &
                       constructor%m_cenvp(n),   &
                       constructor%m_amp(n),     &
                       constructor%m_S(n),       &
                       STAT=aerr,         &
                       ERRMSG=emsg )
          end associate
         if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,filename,   &
                                             "logger:300 --> mod_expchirp_signal/constructor: Memory Allocation Failure!",  &
                                             "mod_expchirp_signal/constructor:300 -- Memory Allocation Failure !"  ,        &
                                             emsg,__LINE__ )
         end if
         constructor%m_jvec    = JonesVector_t()
         constructor%m_E       = CMPLX(LAM_PINF,LAM_PINF,R64P)
         constructor%m_nenvp   = LAM_PINF
         constructor%m_phi     = LAM_PINF
         constructor%m_canform = CMPLX(LAM_PINF,LAM_PINF,R64P)
         constructor%m_basform = LAM_PINF
         constructor%cenvp     = CMPLX(LAM_PINF,LAM_PINF,R64P)
         constructor%m_amp     = LAM_PINF
         constructor%m_S       = CMPLX(LAM_PINF,LAM_PINF,R64P)
    end function constructor

    !======================================================60
    !  @subroutine: expchirp_signal
    !              Physical representation of complex expo-
    !              nential chirp signal
    !======================================================60
    subroutine expchirp_signal(this,ierr,dur,sfreq,efreq,   &
                             stsinc,siphi,chrate,sinit,r,h,v,logging, &
                             verbose,filename,append,profiling,qpctimer )
          use mod_print_error,  only : handle_fatal_memory_error
          use mod_constants,    only : LAM_NS, LAM_2PI, LAM_c
          class(ExpChirpSignal_t),     intent(inout) :: this
          integer(I32P),               intent(inout) :: ierr
          real(R64P),                  intent(inout) :: dur
          real(R64P),                  intent(inout) :: sfreq,efreq
          real(R64P),                  intent(in)    :: stsinc,siphi
          real(R64P),                  intent(in)    :: chrate,sinit
          real(R64P), dimension(:),    intent(in)    :: r    ! range
!DIR$     ASSUME_ALIGNED r:64
          complex(R64P), dimension(:), intent(in)    :: h,v
!DIR$     ASSUME_ALIGNED h:64,v:64
          logical(I32P),               intent(in)    :: logging,verbose
          character(len=*),            intent(in)    :: filename
          logical(I32P),               intent(in)    :: append,profiling
          type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals

          character(len=256) :: emsg
          integer(I32P) :: i,aerr
          integer(BOOL) :: ifail
          logical(I32P) :: bfail
          real(R64P) :: insamp,t,t2,delta,lnK,ilnK,tc,ts
          complex(R64P), allocatable, dimension(:) :: tmp
!DIR$     ATTRIBUTES ALIGN : 64 :: tmp
          real(R64P), allocatable, dimension(:) :: ct ! copy of running 't' variable.
!DIR$     ATTRIBUTES ALIGN : 64 :: ct
          ! Start of executable statements

          if(ierr < 0_I32P) ierr = 0_I32P
          if(efreq == sfreq) then
              ierr = -1_I32P
              return
          end if
          if(dur <= 0._R64P) then
              dur =  LAM_NS
          end if
          ! Begin construction
          this%m_dur      = dur
          this%m_sfreq    = sfreq
          this%m_efreq    = efreq
          this%m_stsinc   = stsinc
          this%m_siphi    = siphi
          this%m_chrate   = chrate
          this%m_sinit    = sinit
          associate(n=>this%m_nsamp)
              allocate( tmp(n),            &
                        ct(n),             &
                        STAT=aerr,         &
                        ERRMSG=emsg      )

          end associate

          if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,filename,   &
                                             "logger:380 --> mod_expchirp_signal/expchirp_signal: Memory Allocation Failure!" ,  &
                                             "mod_expchirp_signal/expchirp_signal:380 -- Memory Allocation Failure" ,  &
                                             emsg,__LINE__  )
          end if

          t = 0._R64P
          t2 = 0._R64P
          delta = 0._R64P
          insamp = 1._R64P/DBLE(this%m_nsamp)
          lnK = DLOG(this%m_chrate)
          ilnK = 1._R64P/lnK
          if(profiling) then
              call qpctimer_start(qpctimer,ifail)
              if(ifail == 0) then
                  write(stderr,*) "mod_expchirp_signal/expchirp_signal: qpctimer_start failed to query performance frequency counter!!"
              end if
          end if
          ! Construct Electric field
          do i = 1_I32P, this%m_nsamp
               this%m_sinit = this%m_sinit+this%m_stsinc
               delta = DBLE(i)*insamp
               t = this%m_sinit*delta
               t2 = t-r(i)/LAM_c
               this%m_phi(i) = this%m_siphi+(LAM_2PI*this%m_sfreq)*(this%m_chrate**t2-1)*ilnK
               this%m_E(i) = DCMPLX(DCOS(this%m_phi(i)),DSIN(this%m_phi(i)))
          end do
           ! Compute A(phi,theta)/r - magnitude of electric field E
          call vcmag(this%m_E,this%m_amp)
          ! Create signal complex components
          do i = 1, this%m_nsamp
              this%m_sinit = this%m_sinit+this%m_stsinc
              delta = DBLE(i)*insamp
              t = this%m_sinit*delta
              ct(i) = t ! use later in canonical form
              this%m_phi(i) = this%m_siphi+(LAM_2PI*this%m_sfreq)*(this%m_chrate**t-1)*ilnK
              tmp(i) = DCMPLX(DCOS(this%m_phi(i)),DSIN(this%m_phi(i)))
          end do
          ! Compute natural envelope
          call vcmag(tmp,this%m_nenvp)
          tc = 0._R64P
          ts = 0._R64P
          ! Create canonical representation
          do i = 1_I32P, this%m_nsamp
              tc = this%m_nenvp(i)*DCOS(this%m_phi(i))
              ts = this%m_nenvp(i)*DSIN(this%m_phi(i))
              this%m_cenvp(i) = DCMPLX(tc,ts)
              this%m_canform(i) = DCMPLX(tc*DCOS(ct(i)),ts*DSIN(ct(i)))
              this%m_basform(i) = DREAL(this%m_canform(i))
          end do
          ! Compute time-average power density i.e. 0.5xExE*/n
          do i = 1_I32P, this%m_nsamp
              this%m_S(i) = 0.5_R64P*this%m_E(i)*DCONJG(this%m_E(i))*0.0026525198938992_R64P
          end do

          if(profiling) then
                if(ifail == 0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail .EQ. .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(ERROR_UNIT,*) "mod_expchirp_signal/expchirp_signal: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(ERROR_UNIT,*) "mod_expchirp_signal/expchirp_signal: Unable to read performance counter -- fatal!!"
                end if
          end if
     end subroutine expchirp_signal

    !======================================================60
    !  @subroutine: phase_noise_expchirp_signal
    !              Physical representation of Exponential Chirp
    !              signal.
    !              This signal is corrupted by phase additive
    !              noise.
    !======================================================60
    subroutine phase_noise_expchirp_signal(this,ierr,dur,sfreq,efreq,   &
                                 stsinc,siphi,chrate,sinit,phnoise,r,h,v, &
                                 verbose,logging,filename,append,profiling,qpctimer )
          use mod_print_error,  only : handle_fatal_memory_error
          use mod_constants,    only : LAM_NS, LAM_c, LAM_2PI, LAM_PINF
          class(ExpChirpSignal_t),     intent(inout) :: this
          integer(I32P),               intent(inout) :: ierr
          real(R64P),                  intent(inout) :: dur
          real(R64P),                  intent(inout) :: sfreq,efreq
          real(R64P),                  intent(in)    :: stsinc,siphi
          real(R64P),                  intent(in)    :: chrate,sinit
          real(R64P), dimension(:),    intent(in)    :: phnoise,r    ! range
!DIR$     ASSUME_ALIGNED phnoise:64,r:64
          complex(R64P), dimension(:), intent(in)    :: h,v
!DIR$     ASSUME_ALIGNED h:64,v:64
          logical(I32P),               intent(in)    :: verbose,logging
          character(len=*),            intent(in)    :: filename
          logical(I32P),               intent(in)    :: append,profiling
          type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals
          character(len=256) :: emsg
          integer(I32P) :: i,aerr
          integer(BOOL) :: ifail
          logical(I32P) :: bfail
          real(R64P) :: insamp,t,t2,delta,lnK,ilnK,tc,ts,tn
          complex(R64P), allocatable, dimension(:) :: tmp
!DIR$     ATTRIBUTES ALIGN : 64 :: tmp
          real(R64P), allocatable, dimension(:) :: ct ! copy of running 't' variable.
!DIR$     ATTRIBUTES ALIGN : 64 :: ct

          ! Start of executable statements

          if(ierr < 0_I32P) ierr = 0_I32P
          if(efreq <= sfreq) then
              ierr = -1_I32P
              return
          end if
          if(dur.LE.0._R64P) then
              dur =  LAM_NS
          end if
          ! Begin construction
          this%m_dur      = dur
          this%m_sfreq    = sfreq
          this%m_efreq    = efreq
          this%m_stsinc   = stsinc
          this%m_siphi    = siphi
          this%m_chrate   = chrate
          this%m_sinit    = sinit
          associate(n=>this%m_nsamp)
              allocate( tmp(n),             &
                        ct(n),              &
                        STAT=aerr,          &
                        ERRMSG=emsg   )

          end associate
          if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,filename,    &
                                             "logger:515 --> mod_expchirp_signal/phase_noise_expchirp_signal: Memory Allocation Failure"  , &
                                             "mod_expchirp_signal/phase_noise_expchirp_signal:515 -- Memory Allocation Failure!"   , &
                                             emsg,__LINE__ )
          end if
          tmp = CMPLX(LAM_PINF,LAM_PINF,R64P)
          ct  = LAM_PINF
          t = 0._R64P
          t2 = 0._R64P
          delta = 0._R64P
          insamp = 1._R64P/DBLE(this%m_nsamp)
          lnK = DLOG(this%m_chrate)
          ilnK = 1._R64P/lnK
          if(profiling) then
              call qpctimer_start(qpctimer,ifail)
              if(ifail == 0) then
                  write(stderr,*) "mod_expchirp_signal/phase_noise_expchirp_signal: qpctimer_start failed to query performance frequency counter!!"
              end if
          end if
           ! Construct Electric field
          do i = 1_I32P, this%m_nsamp
               this%m_sinit = this%m_sinit+this%m_stsinc
               delta = DBLE(i)*insamp
               t = this%m_sinit*delta
               t2 = t-r(i)/LAM_c
               tn = t2+phnoise(i)
               this%m_phi(i) = this%m_siphi+(LAM_2PI*this%m_sfreq)*(this%m_chrate**tn-1)*ilnK
               this%m_E(i) = DCMPLX(DCOS(this%m_phi(i)),DSIN(this%m_phi(i)))
          end do
            ! Compute A(phi,theta)/r - magnitude of electric field E
          call vcmag(this%m_E,this%m_amp)
          ! Create signal complex components
          do i = 1_I32P, this%m_nsamp
              this%m_sinit = this%m_sinit+this%m_stsinc
              delta = DBLE(i)*insamp
              t = this%m_sinit*delta
              tn = t+phnoise(i)
              ct(i) = tn ! use later in canonical form
              this%m_phi(i) = this%m_siphi+(LAM_2PI*this%m_sfreq)*(this%m_chrate**tn-1)*ilnK
              tmp(i) = DCMPLX(DCOS(this%m_phi(i)),DSIN(this%m_phi(i)))
          end do
            ! Compute natural envelope
          call vcmag(tmp,this%m_nenvp)
          tc = 0._R64P
          ts = 0._R64P
          ! Create canonical representation
          do i = 1_I32P, this%m_nsamp
              tc = this%m_nenvp(i)*DCOS(this%m_phi(i))
              ts = this%m_nenvp(i)*DSIN(this%m_phi(i))
              this%m_cenvp(i) = DCMPLX(tc,ts)
              this%m_canform(i) = DCMPLX(tc*DCOS(ct(i)),ts*DSIN(ct(i)))
              this%m_basform(i) = DREAL(this%m_canform(i))
          end do
          ! Compute time-average power density i.e. 0.5xExE*/n
          do i = 1_I32P, this%m_nsamp
              this%m_S(i) = 0.5_R64P*this%m_E(i)*DCONJG(this%m_E(i))*0.0026525198938992_R64P
          end do

          if(profiling) then
                if(ifail == 0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail == .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(ERROR_UNIT,*) "mod_expchirp_signal/phase_noise_expchirp_signal: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(ERROR_UNIT,*) "mod_expchirp_signal/phase_noise_expchirp_signal: Unable to read performance counter -- fatal!!"
                end if
          end if
    end subroutine phase_noise_expchirp_signal

    !======================================================60
    !  @subroutine: additive_noise_expchirp_signal
    !              Physical representation of Exponential Chirp
    !              signal.
    !              This signal is corrupted by phase additive
    !              noise and by background additive noise.
    !======================================================60
    subroutine additive_noise_expchirp_signal(this,ierr,dur,sfreq,efreq,   &
                                 stsinc,siphi,chrate,sinit,phnoise,bnoise,r,h,v, &
                                 verbose,logging,filename,append,profiling,qpctimer )
          use mod_print_error,  only : handle_fatal_memory_error
          use mod_constants,    only : LAM_NS, LAM_c, LAM_2PI, LAM_PINF
          class(ExpChirpSignal_t),     intent(inout) :: this
          integer(I32P),               intent(inout) :: ierr
          real(R64P),                  intent(inout) :: dur
          real(R64P),                  intent(inout) :: sfreq,efreq
          real(R64P),                  intent(in)    :: stsinc,siphi
          real(R64P),                  intent(in)    :: chrate,sinit
          real(R64P), dimension(:),    intent(in)    :: phnoise,bnoise,r    ! range
!DIR$     ASSUME_ALIGNED phnoise:64,bnoise:64,r:64
          complex(R64P), dimension(:), intent(in)    :: h,v
!DIR$     ASSUME_ALIGNED h:64,v:64
          logical(I32P),               intent(in)    :: verbose,logging
          character(len=*),            intent(in)    :: filename
          logical(I32P),               intent(in)    :: append,dbg,profiling
          type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals

          character(len=256) :: emsg
          integer(I32P) :: i,aerr
          integer(BOOL) :: ifail
          logical(I32P) :: bfail
          real(R64P) :: insamp,t,t2,delta,lnK,ilnK,tc,ts,tn
          complex(R64P), allocatable, dimension(:) :: tmp
!DIR$     ATTRIBUTES ALIGN : 64 :: tmp
          real(R64P), allocatable, dimension(:) :: ct ! copy of running 't' variable.
!DIR$     ATTRIBUTES ALIGN : 64 :: ct
          ! Start of executable statements
          if(ierr < 0_I32P) ierr = 0_I32P
          if(efreq <= sfreq) then
              ierr = -1_I32P
              return
          end if
          if(dur <= 0._R64P) then
              dur =  LAM_NS
          end if
          this%m_dur      = dur
          this%m_sfreq    = sfreq
          this%m_efreq    = efreq
          this%m_stsinc   = stsinc
          this%m_siphi    = siphi
          this%m_chrate   = chrate
          this%m_sinit    = sinit
          associate(n=>this%m_nsamp)
              allocate(  tmp(n),            &
                         ct(n),             &
                         STAT=aerr,         &
                         ERRMSG=emsg   )

          end associate
          if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,filename,   &
                                             "logger:651 --> mod_expchirp_signal/additive_noise_expchirp_signal: Memory Allocation Failure", &
                                             "mod_expchirp_signal/additive_noise_expchirp_signal:651 -- Memory Allocation Failure!"  ,  &
                                             emsg,__LINE__ )
          end if
          tmp = CMPLX(LAM_PINF,LAM_PINF,R64P)
          ct  = LAM_PINF

          t = 0._R64P
          t2 = 0._R64P
          delta = 0._R64P
          insamp = 1._R64P/DBLE(this%m_nsamp)
          lnK = DLOG(this%m_chrate)
          ilnK = 1._R64P/lnK
          if(profiling) then
              call qpctimer_start(qpctimer,ifail)
              if(ifail == 0) then
                  write(stderr,*) "mod_expchirp_signal/additive_noise_expchirp_signal: qpctimer_start failed to query performance frequency counter!!"
              end if
          end if
          ! Construct Electric field
          do i = 1_I32P, this%m_nsamp
               this%m_sinit = this%m_sinit+this%m_stsinc
               delta = DBLE(i)*insamp
               t = this%m_sinit*delta
               t2 = t-r(i)/LAM_c
               tn = t2+phnoise(i)
               this%m_phi(i) = this%m_siphi+(LAM_2PI*this%m_sfreq)*(this%m_chrate**tn-1)*ilnK
               this%m_E(i) = DCMPLX(bnoise(i)+DCOS(this%m_phi(i)),bnoise(i)+DSIN(this%m_phi(i)))
          end do
           ! Compute A(phi,theta)/r - magnitude of electric field E
          call vcmag(this%m_E,this%m_amp)
          ! Create signal complex components
          do i = 1_I32P, this%m_nsamp
              this%m_sinit = this%m_sinit+this%m_stsinc
              delta = DBLE(i)*insamp
              t = this%m_sinit*delta
              tn = t+phnoise(i)
              ct(i) = tn ! use later in canonical form
              this%m_phi(i) = this%m_siphi+(LAM_2PI*this%m_sfreq)*(this%m_chrate**tn-1)*ilnK
              tmp(i) = DCMPLX(bnoise(i)+DCOS(this%m_phi(i)),bnoise(i)+DSIN(this%m_phi(i)))
          end do
          ! Compute natural envelope
          call vcmag(tmp,this%m_nenvp)
          tc = 0._R64P
          ts = 0._R64P
          ! Create canonical representation
          do i = 1_I32P, this%m_nsamp
              tc = this%m_nenvp(i)*DCOS(this%m_phi(i))
              ts = this%m_nenvp(i)*DSIN(this%m_phi(i))
              this%m_cenvp(i) = DCMPLX(tc,ts)
              this%m_canform(i) = DCMPLX(tc*DCOS(ct(i)),ts*DSIN(ct(i)))
              this%m_basform(i) = DREAL(this%m_canform(i))
          end do
          ! Compute time-average power density i.e. 0.5xExE*/n
          do i = 1_I32P, this%m_nsamp
              this%m_S(i) = 0.5_R64P*this%m_E(i)*DCONJG(this%m_E(i))*0.0026525198938992_R64P
          end do
          this%m_isbuilt = .true.
          if(profiling) then
                if(ifail == 0) then
                    call qpctimer_stop(qpctimer,ifail)
                    call qpctimer_delta(qpctimer,bfail)
                    if(bfail .EQ. .false.) then
                         call qpctimer_print(qpctimer)
                    else
                         write(ERROR_UNIT,*) "mod_expchirp_signal/additive_noise_expchirp_signal: qpctimer_delta: failed to compute delta measurement!!"
                    end if
                else
                    write(ERROR_UNIT,*) "mod_expchirp_signal/additive_noise_expchirt_signal: Unable to read performance counter -- fatal!!"
                end if
          end if
    end subroutine  additive_noise_expchirp_signal

    !======================================================60
    ! Getter pure functions
    !======================================================60

    pure function get_name(this) result(name)
          implicit none
          class(ExpChirpSignal_t), intent(in) :: this
          ! Locals
          character(len=64) :: name
          ! Start of executable statements
          name = this%m_name
    end function

    pure function get_sid(this) result(sid)
          implicit none
          class(ExpChirpSignal_t), intent(in) :: this
          ! Locals
          integer(I32P) :: sid
          ! Start of executable statements
          sid = this%m_sid
    end function

    pure function get_nsamp(this) result(nsamp)
          implicit none
          class(ExpChirpSignal_t), intent(in) :: this
          ! Locals
          integer(I32P) :: nsamp
          ! Start of executable statements
          nsamp = this%m_nsamp
    end function

    pure function get_dur(this) result(dur)
          implicit none
          class(ExpChirpSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: dur
          ! Start of executable statements
          dur = this%m_dur
    end function

    pure function get_sfreq(this) result(sfreq)
          implicit none
          class(ExpChirpSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: sfreq
          ! Start of executable statements
          sfreq = this%m_sfreq
    end function

    pure function get_efreq(this) result(efreq)
          implicit none
          class(ExpChirpSignal_t), intent(in) :: this
          ! Loclas
          real(R64P) :: efreq
          ! Start of executable statements
          efreq = this%m_efreq
    end function

    pure function get_stsinc(this) result(stsinc)
          implicit none
          class(ExpChirpSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: stsinc
          ! Start of executable sttements
          stsinc = this%m_stsinc
    end function

    pure function get_siphi(this) result(siphi)
          implicit none
          class(ExpChirpSignal_t), intent(in) :: this
          ! Locals
          real(R64P) :: siphi
          ! Start pf executable statements
          siphi = this%m_siphi
    end function

    pure function get_chrate(this) result(chrate)
          implicit none
          class(ExpChirpSignal_t), intent(in) :: this
          ! Loclas
          real(R64P) :: chrate
          ! Start of executable statements
          chrate = this%m_chrate
    end function

    pure function get_sinit(this) result(sinit)
          implicit none
          class(ExpChirpSignal_t), intent(in) :: this
          ! Loclas
          real(R64P) :: sinit
          ! Start of executable statements
          sinit = this%m_sinit
    end function

    !======================================================60
    !    Computational procedures
    !======================================================60
    ! TODO:
    !        ! Consider using CADNA to test for cancellation errors
    subroutine dphi_dt(this,dphi,sfac)
          use mod_constants, LAM_MEPS8
          class(ExpChirpSignal_t),  intent(in)     :: this
          real(R64P), dimension(:), intent(out)    :: dphi
!DIR$     ASSUME_ALIGNED dphi:32
          integer(I64P),            intent(inout)  :: sfac   ! scaling factor up to 16 digits of precision
          ! Locals
          integer(I32P) :: i
          real(R64P)    :: eps,tmp,isfac
          ! Start of executable statements
          if(sfac.LE.0) then
              sfac =  1000000000000000_I64P
          end if
          isfac = 1._R64P/DBLE(sfac)
          eps = MACHEPSF64**0.333333333333333333333333_R64P
          do i = 2, this%m_nsamp-1
              tmp = this%m_phi(i+1)-this%m_phi(i-1)
              dphi(i) = this%m_phi(i+1)-this%m_phi(i-1)/ &
                        (2._R64P*eps*DMAX1(DABS(tmp),isfac)*DSIGN(tmp,tmp))
          end do
    end subroutine

    !======================================================60
    ! subroutine: analytic signal
    !======================================================60
    subroutine analytic_signal(this,asig,tmplen,wlen,iplen, &
                                profiling,qpctimer )
          use mod_fftsg, only : rdft

          class(ExpChirpSignal_t),     intent(inout) :: this
          complex(R64P), dimension(:), intent(out)   :: asig
!DIR$     ASSUME_ALIGNED asig:64
          integer(I32P),               intent(in)    :: tmplen   ! nsamp-1
          integer(I32P),               intent(in)    :: wlen     ! nsamp/2-1
          integer(I32P),               intent(in)    :: iplen    ! 2+2**(int(log(n/2+0.5)/log(2.0))/2)
          logical(I32P),               intent(in)    :: profiling
          type(QPCTimer_t),            intent(inout) :: qpctimer
          ! Locals
          integer(BOOL) :: ifail
          logical(I32P) :: bfail
          integer(I32P) :: i
          real(R64P), dimension(0:tmplen)   :: tmp,tmp2
          real(R64P), dimension(0:wlen)     :: w
          integer(I32P), dimension(0:iplen) :: ip
!DIR$     ATTRIBUTES ALIGN : 64 :: tmp
!DIR$     ATTRIBUTES ALIGN : 64 :: tmp2
!DIR$     ATTRIBUTES ALIGN : 64 :: w
          ! Start of executable statements

          if(profiling) then
             call qpctimer_start(qpctimer,ifail)
             if(ifail.EQ.0) then
                 write(stderr,*) "mod_expchirp_signal/analytic_signal:879, qpctimer_start failed to query performance frequency counter!!"
             end if
          end if
          ! Copy real part of canonical representation
!DIR$     SIMD VECTORLENGTHFOR(REAL(KIND=8))
          do i = 0, tmplen
              tmp(i) = DREAL(this%m_canform(i))
          end do
          ! Real FFT
          ip(0) = 0
          call rdft(tmplen,1,tmp,ip,w)
          do i = 0, tmplen
              tmp2(i) = tmp(i)+DSIGN(tmp(i),tmp(i)))*tmp(i)  ! Construct argument to Inverse FFT
          end do
          ! Inverse real FFT
          call rdft(tmplen,-1,tmp2,ip,w)
          ! Construct analytic signal content
          do i = 0, tmplen
              asig(i) = DCMPLX(DREAL(this%m_canform(i)),tmp2(i))
          end do
          if(profiling) then
               if(ifail.EQ.0) then
                   call qpctimer_stop(qpctimer,ifail)
                   call qpctimer_delta(qpctimer,bfail)
                   if(bfail .EQ. .false.) then
                        call qpctimer_print(qpctimer)
                   else
                        write(stderr,*) "mod_expchirp_signal/analytic_signal:1020, qpctimer_delta: failed to compute delta measurement!!"
                   end if
               else
                       write(stderr,*) "module_expchirp_signal/analytic_signal:1020 Unable to read performance counter -- fatal!!"
               end if
          end if
    end subroutine  analytic_signal

    !============================================
    !   Read/write procedures
    !============================================
    subroutine read_state(this,form,unit,ioerr)

          class(ExpChirpSignal_t), intent(in) :: this
          character(len=*),        intent(in) :: form
          integer(I32P),           intent(in) :: unit
          integer(I32P),           intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              READ(unit,*,iostat=ioerr) this
          case default
              READ(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine read_state

    subroutine write_state(this,form,unit,ioerr)

          class(ExpChirpSignal_t), intent(in) :: this
          character(len=*),        intent(in) :: form
          integer(I32P),           intent(in) :: unit
          integer(I32P),           intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              WRITE(unit,*,iostat=ioerr) this
          case default
              WRITE(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine write_state

    !======================================================60
    !  subroutine: dbg_info
    !======================================================60
    subroutine dbg_info(this)

          class(ExpChirpSignal_t), intent(in) :: this
          ! Locals
          character(len=40) :: dstr,tstr
          ! Start of executable statements
          call DATE_AND_TIME(date=dstr,time=tstr)
          print*, "======================================================"
          print*, "   ***Printing components of ExpChirpSignal_t***"
          print*, "   printing subroutine called at: " , &
                     sdate(1:4),"-",sdate(5:6),"-",sdate(7:8), " ", &
                     stime(1:2),":",stime(3:4),":",stime(5:6)
          print*, "           Dumping scalar components "
          print*, "======================================================"
          print*, "Name:               ", this%m_name
          print*, "Signal ID:          ", this%m_sid
          print*, "Number of samples:  ", this%m_nsamp
          print*, "Signal duration:    ", this%m_dur
          print*, "Frequency (f0):     ", this%m_sfreq
          print*, "Frequency (f1):     ", this%m_efreq
          print*, "Time step:          ", this%m_stsinc
          print*, "Initial phase:      ", this%m_siphi
          print*, "Chirp rate(f1-f0/T),", this%m_chrate
          print*, "Start time-point:   ", this%m_sinit
          print*, "           Dumping array components  "
          print*, "===================================================="

          print*, "Signal polarization:", this%m_jvec
          print*, "Electric field:     ", this%m_E
          print*, "Natural Envelope:   ", this%m_nenvp
          print*, "Phase:              ", this%m_phi
          print*, "Canonical form:     ", this%m_canform
          print*, "Base form:          ", this%m_basform
          print*, "Complex envelope:   ", this%m_cenvp
          print*, "Amplitude:          ", this%m_amp
          print*, "Time-average power: ", this%m_S
          print*,"======================================================"

          print*, "           End                     "
    end subroutine  dbg_info

    !============================================
    !  Operator assignment (=)
    !============================================
    subroutine copy_assign(lhs,rhs)
          class(ExpChirpSignal_t),  intent(inout) :: lhs
          class(ExpChirpSignal_t),  intent(in)    :: rhs
          ! Start of executable statements
          lhs%m_name    = rhs%m_name
          lhs%m_sid     = rhs%m_sid
          lhs%m_nsamp   = rhs%m_nsamp
          lhs%m_dur     = rhs%m_dur
          lhs%m_sfreq   = rhs%m_sfreq
          lhs%m_efreq   = rhs%m_efreq
          lhs%m_stsinc  = rhs%m_stsinc
          lhs%m_siphi   = rhs%m_siphi
          lhs%m_chrate  = rhs%m_chrate
          lhs%m_sinit   = rhs%m_sinit
          lhs%m_jvec    = rhs%m_jvec
          lhs%m_E       = rhs%m_E
          lhs%m_nenvp   = rhs%m_nenvp
          lhs%m_phi     = rhs%m_phi
          lhs%m_canform = rhs%m_canform
          lhs%m_basform = rhs%m_basform
          lhs%m_cenvp   = rhs%m_cenvp
          lhs%m_amp     = rhs%m_amp
          lhs%m_S       = rhs%m_S
    end subroutine copy_assign

end module mod_expchirp_signal


program testCacheLineSize
  use :: CacheInfo, only: cache_line_size, get_page_size
  use, intrinsic :: ISO_FORTRAN_ENV, only: stdout => output_unit, stderr => error_unit, int64
  implicit none
  character(len=*), parameter :: CSV_FLAG="--csv" !! Comma separated value output
  integer :: cmd_len=-1, ierr=-2
  integer(int64) :: page_size, line_size, lines_per_page
  character(len=:), allocatable :: full_cmd_line

  ! Check for option flags in command line
  ! First retrieve
  call get_command(length=cmd_len)
  if(cmd_len < 1) error stop "Unable to get command line length."
  allocate(character(len=cmd_len) :: full_cmd_line)
  call get_command(command=full_cmd_line, status=ierr)
  if(ierr /= 0) error stop "Unable to retrieve command line."

  ! Fetch the values of interest
  page_size = get_page_size()
  line_size = cache_line_size()
  if (line_size == 0) error stop "Could not determine cache line size!"
  lines_per_page = page_size / line_size

  ! Determine how to print the data and print it
  if( index(full_cmd_line, CSV_FLAG) == 0) then
     ! Flag NOT found
     write(stdout,'(A,I0,A)') "Page size is ", page_size, " bytes."
     write(stdout,'(A,I0,A)') "Cache line size is ", line_size, " bytes."
     write(stdout,'(A,I0,A)') "There are ", lines_per_page, " cache lines per page."
     write(stdout,'(A)') "Test Passed!"
  else
     ! CSV flag found
     write(stdout,'(A)') "page size (bytes), line size (bytes), lines-per-page"
     write(stdout,'(I0,2(", ",I0))') page_size, line_size, lines_per_page
  end if
end program