      real             function SERFI (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C--S replaces "?": ?ERFI, ?ERFCI, ?ERFIX, ?ERM1
c>> 1998-11-01 SERFI Krogh  Removed some equivalence for "mangle".
c>> 1996-06-18 SERFI Krogh  Changes to use .C. and C%%. J not changed.
c>> 1996-03-30 SERFI Krogh  Added external statements.
C>> 1995-11-28 SERFI Krogh  Removed multiple entries.
C>> 1995-11-03 SERFI Krogh  Removed blanks in numbers for C conversion.
C>> 1994-10-20 SERFI Krogh  Changes to use M77CON
C>> 1994-04-20 SERFI CLL Edited type stmts to make DP & SP files similar
C>> 1987-10-29 SERFI Snyder  Initial code.
c
c     For -1.0 .LT. X .LT. 1.0 calculate the inverse of the error
c     function.  That is, X = ERF(ERFI).
c
c     For 0.0 .LT. X .LT. 2.0 calculate the inverse of the
c     complementary error function.  that is, X = ERFC(ERFCI).  This
c     calculation is carried out by invoking the alternate entry *ERFCI.
c
c     If X is out of range, program execution is terminated by calling
c     the error message processor.
c
c     This subprogram uses approximations due to A. Strecok from
c     Mathematics of Computation 22, (1968) pp 144-158.
c
      external SERFIX
      real             SERFIX
      real             X
      real             ARG, D(6), FSIGN, S
      integer J
c
c     *****     Parameters     *****************************************
c
c MAX...  is the position in C of the last coefficient of a Chebyshev
c         polynomial expansion.
c MIN...  is the position in C of the first coefficient of a Chebyshev
c         polynomial expansion.
c NC      is the upper dimension of the array of coefficients.
c NDELTA  is the number of coefficients of the Chebyshev polynomial
c         expansion used to approximate R(X) in the range
c         0.9975 .LT. X .LE. 1-5.0E-16
c NLAMDA  is the number of coefficients of the Chebyshev polynomial
c         expansion used to approximate R(X) in the range
c         0.8 .LT. X .LE. 0.9975.
c NMU     is the number of coefficients of the Chebyshev polynomial
c         expansion used to approximate R(X) in the range
c         5.0E-16 .GT. 1-X .GE. 1.E-300.
c NXI     is the number of coefficients of the Chebyshev polynomial
c         expansion used to approximate SERFCI(X)/X in the
c         range 0.0 .LE. X .LE. 0.8.
c
c
c     *****     External References     ********************************
c
c R1MACH   Provides the round-off level.  Used to calculate the number
c          of coefficients to retain in each Chebyshev expansion.
c SERM1    Prints an error message and stops if X .LE. -1.0 or
c          X .GE. 1.0 (ERFI) or X .LE. 0.0 or X .GE. 2.0 (ERFCI).
c LOG      Calculates the natural logarithm.
c SQRT     Calculates the square root.
c
c
c     *****     Local Variables      ***********************************
c
c ARG     If ERFI or ERFCI is being approximated by a Chebyshev
c         expansion then ARG is the argument of ERFI or the argument
c         that would be used if ERFCI(X) were computed as ERFC(1-X),
c         that is, ARG = X if ERFI is being computed, or ARG = 1-X if
c         ERFCI is being computed.  If ERFI or ERFCI is being computed
c         using the initial approximation ERFI=SQRT(-LOG((1-X)*(1+X))),
c         then ARG is that initial approximation.
c C       contains the coefficients of polynomial expansions.  They are
c         stored in C in the order DELTA(0..37), LAMDA(0..26),
c         MU(0..25), XI(0..38).
c D       are used to scale the argument of the Chebyshev polynomial
c         expansion in the range 1.E-300 .LT. 1-X .LT. 0.2.
c DELTA   are coefficients of the Chebyshev polynomial expansion of R(X)
c         for 0.9975 .LT. X .LE. 1-5.0E-16.
c FIRST   is a logical SAVE variable indicating whether it is necessary
c         to calculate the number of coefficients to use for each
c         Chebyshev expansion.
c FSIGN   is X or 1.0 - X.  It is used to remember the sign to be
c         assigned to the function value.
c I, J    are used as indices.
c IMIN    is the minimum index of a coefficient in the Chebyshev
c         polynomial expansion to be used.
c JIX     is an array containing MINXI, MAXXI, MINLAM, MAXLAM, MINDEL,
c         MAXDEL, MINMU, MAXMU in locations -1..6
c LAMDA   are coefficients of the Chebyshev polynomial expansion of R(X)
c         for 0.8 .LT. X .LE. 0.9975.
c MU      are coefficients of the Chebyshev polynomial expansion of R(X)
c         for 5.0E-16 .GT. 1-X .GE. 1.E-300.
c S2      is 2.0 * S.
c S       is the argument of the Chebyshev polynomial expansion.
c W1..W3  are adjacent elements of the recurrence used to evaluate the
c         Chebyshev polynomial expansion.
c XI      are coefficients of the Chebyshev polynomial expansion of
c         ERFC(X)/X for 0.0 .LE. X .LE. 0.8.
c
      data D /-1.548813042373261659512742E0
     2,        2.565490123147816151928163E0
     3,       -.5594576313298323225436913E0
     4,        2.287915716263357638965891E0
     5,       -9.199992358830151031278420E0
     6,        2.794990820124599493768426E0/
c
      fsign = x
      arg = abs(x)
      if (arg.lt.0.0e0 .or. arg.ge.1.0e0)then
         call serm1 ('SERFI',1,2,'Argument out of range','X',x,'.')
c     In case the error level is shifted to zero by the caller:
         serfi = 0.0e0
         return
      end if
      if (arg.eq.0.0e0) then
         serfi = 0.0e0
         return
      end if
      if (arg.le.0.8e0) then
         s = 3.125e0*arg*arg - 1.0e0
         j = -1
      else
         if (arg.le.0.9975e0) then
            j = 1
         else
            j = 3
         end if
         arg = sqrt(-log((1.0e0-arg)*(1.0e0+arg)))
         s = d(j)*arg + d(j+1)
      end if
      SERFI = sign(arg*SERFIX(s, j), fsign)
      return
      end
c
c     *****     entry ERFCI     ****************************************
c
      real             function SERFCI(X)
c     Calculate the inverse of the complementary error function.
c
      external SERFIX
      real             SERFIX
      real             X
      real             ARG, D(6), FSIGN, S
      integer J
      data D /-1.548813042373261659512742E0
     2,        2.565490123147816151928163E0
     3,       -.5594576313298323225436913E0
     4,        2.287915716263357638965891E0
     5,       -9.199992358830151031278420E0
     6,        2.794990820124599493768426E0/
c
c     Decide which approximation to use, and calculate the argument of
c     the Chebyshev polynomial expansion.
c
      if (x.le.0.0e0 .or. x.ge.2.0e0) then
         call serm1('SERFCI',1,2,'Argument out of range','X',x,'.')
c     In case the error level is shifted to zero by the caller:
         serfci = 0.0e0
      end if
      if (x.eq.1.0e0) then
         serfci = 0.0e0
         return
      end if
      fsign = 1.0e0 - x
      arg = abs(fsign)
      if (arg.le.0.8e0) then
         s = 3.125e0*arg*arg - 1.0e0
         j = -1
      else
         arg = 2.0e0 - x
         if (x.lt.1.0e0) then
            s = x
         else
            s = arg
         end if
         arg = sqrt(-log(x*arg))
         if (s.lt.5.0e-16) then
            j = 5
            s = d(5)/sqrt(arg) + d(6)
         else
            if (s.ge.0.0025e0) then
               j = 1
            else if (s.ge.5.0e-16) then
               j = 3
            end if
            s = d(j)*arg + d(j+1)
         end if
      end if
      SERFCI = sign(arg*SERFIX(s, j), fsign)
      return
      end
c
      real             function SERFIX(S, J)
c             Subroutine where most of calculations are done.
      external R1MACH
      integer MAXDEL, MAXLAM, MAXMU, MAXXI, MINDEL, MINLAM
      integer MINMU, MINXI, NC, NDELTA, NLAMDA, NMU, NXI
      parameter (MINDEL = 0)
      parameter (NDELTA = 37)
      parameter (MAXDEL = MINDEL + NDELTA)
      parameter (MINLAM = MAXDEL + 1)
      parameter (NLAMDA = 26)
      parameter (MAXLAM = MINLAM + NLAMDA)
      parameter (MINMU = MAXLAM + 1)
      parameter (NMU = 25)
      parameter (MAXMU = MINMU + NMU)
      parameter (MINXI = MAXMU + 1)
      parameter (NXI = 38)
      parameter (MAXXI = MINXI + NXI)
      parameter (NC = MAXXI)
      real             R1MACH
      real             C(0:NC)
      logical FIRST
      save FIRST
      integer I, J, JIX(-1:6)
      save JIX
      integer IMIN
      real             S, S2
      real             W1, W2, W3
c
c     *****     Equivalence Statements     *****************************
c
c Equivalence statements connecting arrays DELTA, LAMDA, MU, XI removed
c by FTK to make "mangle" work.  All references to these arrays have
c been replaced by references to C.
c
c     *****     Data Statements     ************************************
c
c     DELTA(J), J = 0..NDELTA, then
c     LAMDA(J), J = 0..NLAMDA, then
c     MU(J), J = 0..NMU, then
c     XI(J), J = 0..NXI
c
c++ With first index 0, save data by elements if ~.C.
      data C(0) /  .9566797090204925274526373E0 /
      data C(1) / -.0231070043090649036999908E0 /
      data C(2) / -.0043742360975084077333218E0 /
      data C(3) / -.0005765034226511854809364E0 /
      data C(4) / -.0000109610223070923931242E0 /
      data C(5) /  .0000251085470246442787982E0 /
      data C(6) /  .0000105623360679477511955E0 /
      data C(7) /  .0000027544123300306391503E0 /
      data C(8) /  .0000004324844983283380689E0 /
      data C(9) /   -.0000000205303366552086916E0 /
      data C(10) / -.0000000438915366654316784E0 /
      data C(11) / -.0000000176840095080881795E0 /
      data C(12) / -.0000000039912890280463420E0 /
      data C(13) / -.0000000001869324124559212E0 /
      data C(14) /  .0000000002729227396746077E0 /
      data C(15) /  .0000000001328172131565497E0 /
      data C(16) /  .0000000000318342484482286E0 /
      data C(17) /  .0000000000016700607751926E0 /
      data C(18) / -.0000000000020364649611537E0 /
      data C(19) / -.0000000000009648468127965E0 /
      data C(20) / -.0000000000002195672778128E0 /
      data C(21) / -.0000000000000095689813014E0 /
      data C(22) /  .0000000000000137032572230E0 /
      data C(23) /  .0000000000000062538505417E0 /
      data C(24) /  .0000000000000014584615266E0 /
      data C(25) /  .0000000000000001078123993E0 /
      data C(26) / -.0000000000000000709229988E0 /
      data C(27) / -.0000000000000000391411775E0 /
      data C(28) / -.0000000000000000111659209E0 /
      data C(29) / -.0000000000000000015770366E0 /
      data C(30) /  .0000000000000000002853149E0 /
      data C(31) /  .0000000000000000002716662E0 /
      data C(32) /  .0000000000000000000957770E0 /
      data C(33) /  .0000000000000000000176835E0 /
      data C(34) / -.0000000000000000000009828E0 /
      data C(35) / -.0000000000000000000020464E0 /
      data C(36) / -.0000000000000000000008020E0 /
      data C(37) / -.0000000000000000000001650E0 /
      data C(38) /  .9121588034175537733059200E0 /
      data C(39) / -.0162662818676636958546661E0 /
      data C(40) /  .0004335564729494453650589E0 /
      data C(41) /  .0002144385700744592065205E0 /
      data C(42) /  .0000026257510757648130176E0 /
      data C(43) / -.0000030210910501037969912E0 /
      data C(44) / -.0000000124060618367572157E0 /
      data C(45) /  .0000000624066092999917380E0 /
      data C(46) / -.0000000005401247900957858E0 /
      data C(47) /   -.0000000014232078975315910E0 /
      data C(48) /  .0000000000343840281955305E0 /
      data C(49) /  .0000000000335848703900138E0 /
      data C(50) / -.0000000000014584288516512E0 /
      data C(51) / -.0000000000008102174258833E0 /
      data C(52) /  .0000000000000525324085874E0 /
      data C(53) /  .0000000000000197115408612E0 /
      data C(54) / -.0000000000000017494333828E0 /
      data C(55) / -.0000000000000004800596619E0 /
      data C(56) /  .0000000000000000557302987E0 /
      data C(57) /  .0000000000000000116326054E0 /
      data C(58) / -.0000000000000000017262489E0 /
      data C(59) / -.0000000000000000002784973E0 /
      data C(60) /  .0000000000000000000524481E0 /
      data C(61) /  .0000000000000000000065270E0 /
      data C(62) / -.0000000000000000000015707E0 /
      data C(63) / -.0000000000000000000001475E0 /
      data C(64) /  .0000000000000000000000450E0 /
      data C(65) /  .9885750640661893136460358E0 /
      data C(66) /  .0108577051845994776160281E0 /
      data C(67) / -.0017511651027627952494825E0 /
      data C(68) /  .0000211969932065633437984E0 /
      data C(69) /  .0000156648714042435087911E0 /
      data C(70) / -.0000005190416869103124261E0 /
      data C(71) / -.0000000371357897426717780E0 /
      data C(72) /  .0000000012174308662357429E0 /
      data C(73) / -.0000000001768115526613442E0 /
      data C(74) /   -.0000000000119372182556161E0 /
      data C(75) /  .0000000000003802505358299E0 /
      data C(76) / -.0000000000000660188322362E0 /
      data C(77) / -.0000000000000087917055170E0 /
      data C(78) / -.0000000000000003506869329E0 /
      data C(79) / -.0000000000000000697221497E0 /
      data C(80) / -.0000000000000000109567941E0 /
      data C(81) / -.0000000000000000011536390E0 /
      data C(82) / -.0000000000000000001326235E0 /
      data C(83) / -.0000000000000000000263938E0 /
      data C(84) /  .0000000000000000000005341E0 /
      data C(85) / -.0000000000000000000022610E0 /
      data C(86) /  .0000000000000000000009552E0 /
      data C(87) / -.0000000000000000000005250E0 /
      data C(88) /  .0000000000000000000002487E0 /
      data C(89) / -.0000000000000000000001134E0 /
      data C(90) /  .0000000000000000000000420E0 /
      data C(91) /  .9928853766189408231495800E0 /
      data C(92) /  .1204675161431044864647846E0 /
      data C(93) /  .0160781993420999447257039E0 /
      data C(94) /  .0026867044371623158279591E0 /
      data C(95) /  .0004996347302357262947170E0 /
      data C(96) /  .0000988982185991204409911E0 /
      data C(97) /  .0000203918127639944337340E0 /
      data C(98) /  .0000043272716177354218758E0 /
      data C(99) /  .0000009380814128593406758E0 /
      data C(100) /  .0000002067347208683427411E0 /
      data C(101) /  .0000000461596991054300078E0 /
      data C(102) /  .0000000104166797027146217E0 /
      data C(103) /  .0000000023715009995921222E0 /
      data C(104) /  .0000000005439284068471390E0 /
      data C(105) /  .0000000001255489864097987E0 /
      data C(106) /  .0000000000291381803663201E0 /
      data C(107) /  .0000000000067949421808797E0 /
      data C(108) /  .0000000000015912343331469E0 /
      data C(109) /  .0000000000003740250585245E0 /
      data C(110) /  .0000000000000882087762421E0 /
      data C(111) /  .0000000000000208650897725E0 /
      data C(112) /  .0000000000000049488041039E0 /
      data C(113) /  .0000000000000011766394740E0 /
      data C(114) /  .0000000000000002803855725E0 /
      data C(115) /  .0000000000000000669506638E0 /
      data C(116) /  .0000000000000000160165495E0 /
      data C(117) /  .0000000000000000038382583E0 /
      data C(118) /  .0000000000000000009212851E0 /
      data C(119) /  .0000000000000000002214615E0 /
      data C(120) /  .0000000000000000000533091E0 /
      data C(121) /  .0000000000000000000128488E0 /
      data C(122) /  .0000000000000000000031006E0 /
      data C(123) /  .0000000000000000000007491E0 /
      data C(124) /  .0000000000000000000001812E0 /
      data C(125) /  .0000000000000000000000439E0 /
      data C(126) /  .0000000000000000000000106E0 /
      data C(127) /  .0000000000000000000000026E0 /
      data C(128) /  .0000000000000000000000006E0 /
      data C(129) /  .0000000000000000000000002E0 /
c
      data FIRST /.TRUE./
c
      data JIX /MINXI, MAXXI, MINLAM, MAXLAM, MINDEL, MAXDEL
     1,         MINMU, MAXMU/
c
c     *****     Procedures     *****************************************
c
c     Decide which approximation to use, and calculate the argument of
c     the Chebyshev polynomial expansion.
c
c
c     If this is the first call, calculate the degree of each expansion.
c
      if (first) then
         first = .false.
         s2 = 0.5e0*r1mach(3)
         do 120 imin = -1, 5, 2
            do 110 i = jix(imin), jix(imin+1)
               if (abs(c(i)).lt.s2) then
                  jix(imin+1) = i
                  go to 120
               end if
110         continue
120      continue
      end if
c
c     Evaluate the Chebyshev polynomial expansion.
c
      s2 = s + s
      w1 = 0.0e0
      w2 = 0.0e0
      imin = jix(j)
      i = jix(j+1)
200      w3 = w2
         w2 = w1
         w1 = (s2*w2 - w3) + c(i)
         i = i - 1
         if (i.gt.imin) go to 200
      serfix = (s*w1 - w2) + c(imin)
      return
      end


*> \brief \b SSTECT
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SSTECT( N, A, B, SHIFT, NUM )
*
*       .. Scalar Arguments ..
*       INTEGER            N, NUM
*       REAL               SHIFT
*       ..
*       .. Array Arguments ..
*       REAL               A( * ), B( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    SSTECT counts the number NUM of eigenvalues of a tridiagonal
*>    matrix T which are less than or equal to SHIFT. T has
*>    diagonal entries A(1), ... , A(N), and offdiagonal entries
*>    B(1), ..., B(N-1).
*>    See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
*>    Matrix", Report CS41, Computer Science Dept., Stanford
*>    University, July 21, 1966
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The dimension of the tridiagonal matrix T.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (N)
*>          The diagonal entries of the tridiagonal matrix T.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is REAL array, dimension (N-1)
*>          The offdiagonal entries of the tridiagonal matrix T.
*> \endverbatim
*>
*> \param[in] SHIFT
*> \verbatim
*>          SHIFT is REAL
*>          The shift, used as described under Purpose.
*> \endverbatim
*>
*> \param[out] NUM
*> \verbatim
*>          NUM is INTEGER
*>          The number of eigenvalues of T less than or equal
*>          to SHIFT.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_eig
*
*  =====================================================================
      SUBROUTINE SSTECT( N, A, B, SHIFT, NUM )
*
*  -- 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            N, NUM
      REAL               SHIFT
*     ..
*     .. Array Arguments ..
      REAL               A( * ), B( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, THREE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, THREE = 3.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      REAL               M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
     $                   TOM, U, UNFL
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
*     ..
*     .. Executable Statements ..
*
*     Get machine constants
*
      UNFL = SLAMCH( 'Safe minimum' )
      OVFL = SLAMCH( 'Overflow' )
*
*     Find largest entry
*
      MX = ABS( A( 1 ) )
      DO 10 I = 1, N - 1
         MX = MAX( MX, ABS( A( I+1 ) ), ABS( B( I ) ) )
   10 CONTINUE
*
*     Handle easy cases, including zero matrix
*
      IF( SHIFT.GE.THREE*MX ) THEN
         NUM = N
         RETURN
      END IF
      IF( SHIFT.LT.-THREE*MX ) THEN
         NUM = 0
         RETURN
      END IF
*
*     Compute scale factors as in Kahan's report
*     At this point, MX .NE. 0 so we can divide by it
*
      SUN = SQRT( UNFL )
      SSUN = SQRT( SUN )
      SOV = SQRT( OVFL )
      TOM = SSUN*SOV
      IF( MX.LE.ONE ) THEN
         M1 = ONE / MX
         M2 = TOM
      ELSE
         M1 = ONE
         M2 = TOM / MX
      END IF
*
*     Begin counting
*
      NUM = 0
      SSHIFT = ( SHIFT*M1 )*M2
      U = ( A( 1 )*M1 )*M2 - SSHIFT
      IF( U.LE.SUN ) THEN
         IF( U.LE.ZERO ) THEN
            NUM = NUM + 1
            IF( U.GT.-SUN )
     $         U = -SUN
         ELSE
            U = SUN
         END IF
      END IF
      DO 20 I = 2, N
         TMP = ( B( I-1 )*M1 )*M2
         U = ( ( A( I )*M1 )*M2-TMP*( TMP / U ) ) - SSHIFT
         IF( U.LE.SUN ) THEN
            IF( U.LE.ZERO ) THEN
               NUM = NUM + 1
               IF( U.GT.-SUN )
     $            U = -SUN
            ELSE
               U = SUN
            END IF
         END IF
   20 CONTINUE
      RETURN
*
*     End of SSTECT
*
      END


!*************************************************************************
!* Hyperdual Number Module (HDMod_cplx) of Fortran Codes
!*----------------------------------------------------------------

Module HDMod_cplx

  use HDMod
  implicit none

  public

      integer, parameter                   :: SP_cplx = KIND(1.0)      ! Single Precision
      integer, parameter                   :: DP_cplx = KIND(1.d0)     ! Double Precision
      integer, parameter                   :: PRhyd_cplx = DP_cplx             ! Set the precision
      real(PRhyd_cplx), parameter, private    :: pi = ACOS(-1.0_PRhyd)
      complex(PRhyd_cplx), parameter, private :: pi_c = (pi, 0.0_PRhyd)

      !--- DEFINITION OF HYPERDUAL TYPE
      TYPE hyperdual_cplx
          complex(PRhyd) :: x
          complex(PRhyd) :: dx1
          complex(PRhyd) :: dx2
          complex(PRhyd) :: dx1x2
      END TYPE

      !================================================================!
      !                Overloading hdual functions                     !
      !================================================================!

      !----- Constructor
      interface hdual_cplx
        module procedure hdual_cplx_from_dble
      end interface

      interface assignment(=)
        module procedure hdual_cplx_assign_hdual_cplx, hdual_cplx_assign_cplx
      end interface

      interface operator(+)
        module procedure hdual_cplx_plus_hdual_cplx, hdual_cplx_plus_dble, dble_plus_hdual_cplx, &
          hdual_cplx_plus_hdual
      end interface

      interface operator(-)
        module procedure hdual_cplx_minus_hdual_cplx, hdual_cplx_minus_dble, dble_minus_hdual_cplx, &
          minus_hdual_cplx, hdual_cplx_minus_hdual
      end interface

      interface operator(*)
        module procedure hdual_cplx_mul_hdual_cplx, hdual_cplx_mul_dble, dble_mul_hdual_cplx, &
          hdual_mul_hdual_cplx, hdual_cplx_mul_hdual
      end interface

      interface operator(/)
        module procedure hdual_cplx_div_hdual_cplx, hdual_cplx_div_dble, dble_div_hdual_cplx
      end interface

      interface operator(**)
        module procedure hdual_cplx_pow_dble
      end interface

      interface ABS
        module procedure hdual_cplx_abs
      end interface

      interface COS
        module procedure hdual_cplx_cos
      end interface

      interface SIN
        module procedure hdual_cplx_sin
      end interface

      interface CMPLX
        module procedure hdual_cplx_from_hdual, hdual_cplx_tens_from_hdual_tens
      end interface

      interface REAL
        module procedure real_from_hdual_cplx
      end interface

      interface AIMAG
        module procedure aimag_from_hdual_cplx
      end interface AIMAG

      interface IMAG
        module procedure imag_from_hdual_cplx
      end interface IMAG

      interface CONJG
        module procedure conjg_from_hdual_cplx
      end interface

      CONTAINS

      function hdual_cplx_from_dble(x11,x12,x21,x22) result(q)

        implicit none
        complex(PRhyd_cplx), intent(in)  :: x11, x12, x21, x22
        TYPE(hyperdual_cplx)       :: q

        q%x = x11
        q%dx1 = x12
        q%dx2 = x21
        q%dx1x2 = x22

      end function hdual_cplx_from_dble

      subroutine hdual_cplx_assign_hdual_cplx(qcplx_left, qcplx_right)

        implicit none
        TYPE(hyperdual_cplx), intent(out)  :: qcplx_left
        TYPE(hyperdual_cplx), intent(in)   :: qcplx_right

        qcplx_left%x = qcplx_right%x
        qcplx_left%dx1 = qcplx_right%dx1
        qcplx_left%dx2 = qcplx_right%dx2
        qcplx_left%dx1x2 = qcplx_right%dx1x2

      end subroutine hdual_cplx_assign_hdual_cplx

      subroutine hdual_cplx_assign_cplx(qcplx_left, cplx_right)

        implicit none
        complex(PRhyd_cplx), intent(in)    :: cplx_right
        TYPE(hyperdual_cplx), intent(out) :: qcplx_left

        qcplx_left%x = cplx_right
        qcplx_left%dx1 = 0.0d0
        qcplx_left%dx2 = 0.0d0
        qcplx_left%dx1x2 = 0.0d0

      end subroutine hdual_cplx_assign_cplx

      function hdual_cplx_plus_hdual_cplx(qleft, qright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qleft, qright
        TYPE(hyperdual_cplx) :: res

        res%x = qleft%x + qright%x
        res%dx1 = qleft%dx1 + qright%dx1
        res%dx2 = qleft%dx2 + qright%dx2
        res%dx1x2 = qleft%dx1x2 + qright%dx1x2

      end function hdual_cplx_plus_hdual_cplx

      function hdual_cplx_plus_dble(qleft, iright) result(res)

          implicit none
          TYPE(hyperdual_cplx), intent(in) :: qleft
          real(PRhyd_cplx), intent(in)        :: iright
          TYPE(hyperdual_cplx)             :: res

          res%x  = qleft%x + iright
          res%dx1 = qleft%dx1
          res%dx2 = qleft%dx2
          res%dx1x2 = qleft%dx1x2

      end function hdual_cplx_plus_dble

      function dble_plus_hdual_cplx(ileft, qright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qright
        real(PRhyd_cplx), intent(in)        :: ileft
        TYPE(hyperdual_cplx)             :: res

          res%x  = qright%x + ileft
          res%dx1 = qright%dx1
          res%dx2 = qright%dx2
          res%dx1x2 = qright%dx1x2

      end function dble_plus_hdual_cplx

      function hdual_cplx_plus_hdual(qcplx, qright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in)  :: qcplx
        TYPE(hyperdual), intent(in)       :: qright
        TYPE(hyperdual_cplx)              :: res

        res%x = qcplx%x + qright%x
        res%dx1 = qcplx%dx1 + qright%dx1
        res%dx2 = qcplx%dx2 + qright%dx2
        res%dx1x2 = qcplx%dx1x2 + qright%dx1x2

      end function hdual_cplx_plus_hdual

      function hdual_cplx_minus_hdual_cplx(qleft, qright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qleft, qright
        TYPE(hyperdual_cplx) :: res

        res%x = qleft%x - qright%x
        res%dx1 = qleft%dx1 - qright%dx1
        res%dx2 = qleft%dx2 - qright%dx2
        res%dx1x2 = qleft%dx1x2 - qright%dx1x2

      end function hdual_cplx_minus_hdual_cplx

      function hdual_cplx_minus_dble(qleft, iright) result(res)

          implicit none
          TYPE(hyperdual_cplx), intent(in) :: qleft
          real(PRhyd_cplx), intent(in)        :: iright
          TYPE(hyperdual_cplx)             :: res

          res%x  = qleft%x - iright
          res%dx1 = qleft%dx1
          res%dx2 = qleft%dx2
          res%dx1x2 = qleft%dx1x2

      end function hdual_cplx_minus_dble

      function dble_minus_hdual_cplx(ileft, qright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qright
        real(PRhyd_cplx), intent(in)        :: ileft
        TYPE(hyperdual_cplx)             :: res

        res%x = ileft - qright%x
        res%dx1 = - qright%dx1
        res%dx2 = - qright%dx2
        res%dx1x2 = - qright%dx1x2

      end function dble_minus_hdual_cplx

      function minus_hdual_cplx(qright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qright
        TYPE(hyperdual_cplx)             :: res

        res%x     = - qright%x
        res%dx1   = - qright%dx1
        res%dx2   = - qright%dx2
        res%dx1x2 = - qright%dx1x2

      end function minus_hdual_cplx

      function hdual_cplx_minus_hdual(qcplx, qright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in)  :: qcplx
        TYPE(hyperdual), intent(in)       :: qright
        TYPE(hyperdual_cplx)              :: res

        res%x = qcplx%x - qright%x
        res%dx1 = qcplx%dx1 - qright%dx1
        res%dx2 = qcplx%dx2 - qright%dx2
        res%dx1x2 = qcplx%dx1x2 - qright%dx1x2

      end function hdual_cplx_minus_hdual

      function hdual_cplx_mul_hdual_cplx(qleft, qright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qleft, qright
        TYPE(hyperdual_cplx)             :: res

        res%x = qleft%x * qright%x
        res%dx1 = qleft%x * qright%dx1 + qleft%dx1 * qright%x
        res%dx2 = qleft%x * qright%dx2 + qleft%dx2 * qright%x
        res%dx1x2 = qleft%x * qright%dx1x2 + qleft%dx1 * qright%dx2 + qleft%dx2 * qright%dx1 + qleft%dx1x2 * qright%x

      end function hdual_cplx_mul_hdual_cplx

      function hdual_cplx_mul_dble(qleft, iright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qleft
        real(PRhyd_cplx), intent(in)        :: iright
        TYPE(hyperdual_cplx)             :: res

        res%x = qleft%x * iright
        res%dx1 = qleft%dx1 * iright
        res%dx2 = qleft%dx2 * iright
        res%dx1x2 = qleft%dx1x2 * iright

      end function hdual_cplx_mul_dble

      function dble_mul_hdual_cplx(ileft, qright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in)  :: qright
        real(PRhyd_cplx), intent(in)         :: ileft
        TYPE(hyperdual_cplx)              :: res

          res%x = qright%x * ileft
          res%dx1 = qright%dx1 * ileft
          res%dx2 = qright%dx2 * ileft
          res%dx1x2 = qright%dx1x2 * ileft

      end function dble_mul_hdual_cplx

      function hdual_mul_hdual_cplx(qleft, qcplx) result(res)

        ! Hyperdual multiplied by hyperdual complex
        ! FOR subroutine BHCOAT in twoway_rrtmg_aero_optical.F

        implicit none
        TYPE(hyperdual), intent(in)       :: qleft
        TYPE(hyperdual_cplx), intent(in)  :: qcplx
        TYPE(hyperdual_cplx)              :: res

        res%x = qleft%x * qcplx%x
        res%dx1 = qleft%x * qcplx%dx1 + qleft%dx1 * qcplx%x
        res%dx2 = qleft%x * qcplx%dx2 + qleft%dx2 * qcplx%x
        res%dx1x2 = qleft%x * qcplx%dx1x2 + qleft%dx1 * qcplx%dx2 + qleft%dx2 * qcplx%dx1 + qleft%dx1x2 * qcplx%x

      end function hdual_mul_hdual_cplx

      function hdual_cplx_mul_hdual(qcplx, qright) result(res)

        ! Hyperdual multiplied by hyperdual complex
        ! FOR subroutine BHCOAT in twoway_rrtmg_aero_optical.F

        implicit none
        TYPE(hyperdual), intent(in)       :: qright
        TYPE(hyperdual_cplx), intent(in)  :: qcplx
        TYPE(hyperdual_cplx)              :: res

        res%x = qright%x * qcplx%x
        res%dx1 = qright%x * qcplx%dx1 + qright%dx1 * qcplx%x
        res%dx2 = qright%x * qcplx%dx2 + qright%dx2 * qcplx%x
        res%dx1x2 = qright%x * qcplx%dx1x2 + qright%dx1 * qcplx%dx2 + qright%dx2 * qcplx%dx1 + qright%dx1x2 * qcplx%x

      end function hdual_cplx_mul_hdual
      ! DIVISION !

      function hdual_cplx_div_hdual_cplx(qleft, qright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qleft, qright

        TYPE(hyperdual_cplx)             :: inv
        TYPE(hyperdual_cplx)             :: res

        inv = hdual_cplx_pow_dble(qright, -1.0d0)
        res = qleft * inv

      end function hdual_cplx_div_hdual_cplx

      function hdual_cplx_div_dble(qleft, iright) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qleft
        real(PRhyd_cplx), intent(in)        :: iright
        TYPE(hyperdual_cplx)             :: res

        res%x = qleft%x / iright
        res%dx1 = qleft%dx1 / iright
        res%dx2 = qleft%dx2 / iright
        res%dx1x2 = qleft%dx1x2 / iright

      end function hdual_cplx_div_dble

      function dble_div_hdual_cplx(ileft, qright) result(res)
        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qright
        real(PRhyd_cplx), intent(in)        :: ileft
        TYPE(hyperdual_cplx)             :: inv
        TYPE(hyperdual_cplx)             :: res

        inv = hdual_cplx_pow_dble(qright, -1.0d0)
        res = ileft * inv

      end function dble_div_hdual_cplx

      function hdual_cplx_pow_dble(qleft, iright) result(res)

          implicit none
          TYPE(hyperdual_cplx), intent(in)    :: qleft
          real(PRhyd_cplx), intent(in)           :: iright
          complex(PRhyd_cplx)                    :: xval
          complex(PRhyd_cplx)                    :: tol
          complex(PRhyd_cplx)                    :: deriv
          TYPE(hyperdual_cplx)                :: res

          xval = qleft%x
          tol = 1.0e-15
          if (abs(real(xval)) < real(tol)) then

            if (real(xval) >= 0) then
              xval = tol
            endif

            if (real(xval) < 0) then
              xval = -tol
            endif

          endif
          deriv = iright * xval**(iright - 1.0d0)

          res%x = qleft%x**iright
          res%dx1 = qleft%dx1 * deriv
          res%dx2 = qleft%dx2 * deriv
          res%dx1x2 = qleft%dx1x2 * deriv + iright * (iright - 1.0d0) * qleft%dx1 * qleft%dx2 * xval**(iright - 2.0d0)

        end function hdual_cplx_pow_dble

      function hdual_cplx_abs(qcplx) result(res)

        ! using abs on hyperdual complex
        implicit none
        TYPE(hyperdual_cplx), intent(in)   :: qcplx
        TYPE(hyperdual)               :: res

        ! Like applying abs on complex(8), the result
        ! should be a hyperdual number
        res%x = abs(qcplx%x)
        res%dx1 = abs(qcplx%dx1)
        res%dx2 = abs(qcplx%dx2)
        res%dx1x2 = abs(qcplx%dx1x2)

      end function hdual_cplx_abs

      function hdual_cplx_cos(qcplx) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qcplx
        complex(PRhyd_cplx)                 :: funval, deriv
        TYPE(hyperdual_cplx)             :: res

        funval = cos(qcplx%x)
        deriv  = -sin(qcplx%x)

        res%x = funval
        res%dx1 = deriv * qcplx%dx1
        res%dx2 = deriv * qcplx%dx2
        res%dx1x2 = -funval * qcplx%dx1 * qcplx%dx2 + deriv * qcplx%dx1x2

      end function hdual_cplx_cos

      function hdual_cplx_sin(qcplx) result(res)

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qcplx
        complex(PRhyd_cplx)                 :: funval, deriv
        TYPE(hyperdual_cplx)             :: res

        funval = sin(qcplx%x)
        deriv  = cos(qcplx%x)

        res%x = funval
        res%dx1 = deriv * qcplx%dx1
        res%dx2 = deriv * qcplx%dx2
        res%dx1x2 = -funval * qcplx%dx1 * qcplx%dx2 + deriv * qcplx%dx1x2

      end function hdual_cplx_sin

      function hdual_cplx_from_hdual(qreal, qimag) result(qcplx)

        ! Complexify hyperdual numbers using CMPLX

        implicit none
        TYPE(hyperdual), intent(in) :: qreal
        TYPE(hyperdual), intent(in) :: qimag
        TYPE(hyperdual_cplx)        :: qcplx

        qcplx%x = CMPLX(qreal%x, qimag%x, KIND=PRhyd_cplx)
        qcplx%dx1 = CMPLX(qreal%dx1, qimag%dx1, KIND=PRhyd_cplx)
        qcplx%dx2 = CMPLX(qreal%dx2, qimag%dx2, KIND=PRhyd_cplx)
        qcplx%dx1x2 = CMPLX(qreal%dx1x2, qimag%dx1x2, KIND=PRhyd_cplx)

      end function hdual_cplx_from_hdual

      function hdual_cplx_tens_from_hdual_tens(qreal, qimag) result(qcplx)

        ! Complexify hyperdual numbers using CMPLX

        implicit none
        TYPE(hyperdual), dimension(:,:,:), intent(in) :: qreal
        TYPE(hyperdual), dimension(:,:,:), intent(in) :: qimag
        TYPE(hyperdual_cplx), dimension(size(qreal, 1), size(qreal, 2), size(qreal, 3)) :: qcplx

        qcplx%x = CMPLX(qreal%x, qimag%x, KIND=PRhyd_cplx)
        qcplx%dx1 = CMPLX(qreal%dx1, qimag%dx1, KIND=PRhyd_cplx)
        qcplx%dx2 = CMPLX(qreal%dx2, qimag%dx2, KIND=PRhyd_cplx)
        qcplx%dx1x2 = CMPLX(qreal%dx1x2, qimag%dx1x2, KIND=PRhyd_cplx)

      end function hdual_cplx_tens_from_hdual_tens

      function real_from_hdual_cplx(qcplx) result(qreal)

        ! Extract the real component from hyperdual_cplx

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qcplx
        TYPE(hyperdual)                  :: qreal

        qreal%x = real(qcplx%x)
        qreal%dx1 = real(qcplx%dx1)
        qreal%dx2 = real(qcplx%dx2)
        qreal%dx1x2 = real(qcplx%dx1x2)

      end function real_from_hdual_cplx

      function aimag_from_hdual_cplx(qcplx) result(qimag)

        ! Extract the real component from hyperdual_cplx

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qcplx
        TYPE(hyperdual)                  :: qimag

        qimag%x = aimag(qcplx%x)
        qimag%dx1 = aimag(qcplx%dx1)
        qimag%dx2 = aimag(qcplx%dx2)
        qimag%dx1x2 = aimag(qcplx%dx1x2)

      end function aimag_From_hdual_cplx

      function imag_from_hdual_cplx(qcplx) result(qimag)

        ! Extract the real component from hyperdual_cplx

        implicit none
        TYPE(hyperdual_cplx), intent(in) :: qcplx
        TYPE(hyperdual)                  :: qimag

        qimag%x = imag(qcplx%x)
        qimag%dx1 = imag(qcplx%dx1)
        qimag%dx2 = imag(qcplx%dx2)
        qimag%dx1x2 = imag(qcplx%dx1x2)

      end function imag_From_hdual_cplx

      function conjg_from_hdual_cplx(qcplx) result(qconjg)
        TYPE(hyperdual_cplx), intent(in)  :: qcplx
        TYPE(hyperdual_cplx)              :: qconjg

        qconjg%x = conjg(qcplx%x)
        qconjg%dx1 = conjg(qcplx%dx1)
        qconjg%dx2 = conjg(qcplx%dx2)
        qconjg%dx1x2 = conjg(qcplx%dx1x2)

      end function conjg_from_hdual_cplx

  end module HDMod_cplx


program main
    use LTISystemClass
    implicit none

    type(LTISystem_) :: system
    type(Random_) :: random
    type(IO_) :: file,SpectreFile
    real(real64) :: F(2,2),G(2,1),H(1,2),x(2)
    complex(complex64) :: y(4096)
    complex(complex64),allocatable :: spectre(:),in_spectre(:)
    integer(int32) :: i,j

    ! Yule (1927), autoreguressive model
    F(1,:) = [ 0.0d0, -0.65504d0 ]
    F(2,:) = [ 1.0d0,  1.34254d0 ]

    G(1:2,1) = [-0.65504d0, 1.34254d0]

    H(1,1:2) = [1.0d0, 0.0d0]

    x(1) = random%gauss(mu=0.0d0,sigma=1.0d0)
    x(2) = random%gauss(mu=0.0d0,sigma=1.0d0)

    call system%init(&
        State=x,&
        StateTransition=F,&
        Driving=G,&
        ObservMat=H)
    system%sigma = 15.41d0

    call file%open("Observation.txt")

    do i=1,size(y)
        call file%write(i, system%update()+44.333d0 )
        y(i) = system%ObservVec(1)
        if(i>=256)then
            spectre = fft(y(i-255:i) )
            call Spectrefile%open("FFT_Result"//str(i)//".txt")
            do j=1,256/2
                call Spectrefile%write(j, dble(sqrt(spectre(j)*spectre(j))) )
            enddo

            call Spectrefile%close()
        endif
    enddo
    call file%close()

end program main


         subroutine appft (niter, total_time, verified)
         include  'global.h'
         integer niter
	 double precision total_time
	 logical verified
!
! Local variables
!
         integer i, j, k, kt, n12, n22, n32, ii, jj, kk, ii2, ik2
         double precision ap
         double precision twiddle(nx+1,ny,nz)

         double complex xnt(nx+1,ny,nz),y(nx+1,ny,nz),
     &                  pad1(128),pad2(128)
         common /mainarrays/ xnt,pad1,y,pad2,twiddle

         double complex exp1(nx), exp2(ny), exp3(nz)

         do i=1,15
           call timer_clear(i)
	 end do

         call timer_start(2)
         call compute_initial_conditions(xnt,nx,ny,nz)

         call CompExp( nx, exp1 )
         call CompExp( ny, exp2 )
         call CompExp( nz, exp3 )
         call fftXYZ(1,xnt,y,exp1,exp2,exp3,nx,ny,nz)
         call timer_stop(2)

         call timer_start(1)
         if (timers_enabled) call timer_start(13)

         n12 = nx/2
         n22 = ny/2
         n32 = nz/2
         ap = - 4.d0 * alpha * pi ** 2
         do i = 1, nz
	   ii = i-1-((i-1)/n32)*nz
	   ii2 = ii*ii
           do k = 1, ny
	     kk = k-1-((k-1)/n22)*ny
	     ik2 = ii2 + kk*kk
             do j = 1, nx
	         jj = j-1-((j-1)/n12)*nx
                 twiddle(j,k,i) = exp(ap*dble(jj*jj + ik2))
               end do
            end do
         end do
         if (timers_enabled) call timer_stop(13)

         if (timers_enabled) call timer_start(12)
         call compute_initial_conditions(xnt,nx,ny,nz)
         if (timers_enabled) call timer_stop(12)
         if (timers_enabled) call timer_start(15)
         call fftXYZ(1,xnt,y,exp1,exp2,exp3,nx,ny,nz)
         if (timers_enabled) call timer_stop(15)

         do kt = 1, niter
	   if (timers_enabled) call timer_start(11)
	   call evolve(xnt,y,twiddle,nx,ny,nz)
           if (timers_enabled) call timer_stop(11)
           if (timers_enabled) call timer_start(15)
           call fftXYZ(-1,xnt,xnt,exp1,exp2,exp3,nx,ny,nz)
           if (timers_enabled) call timer_stop(15)
           if (timers_enabled) call timer_start(10)
           call CalculateChecksum(sums(kt),kt,xnt,nx,ny,nz)
           if (timers_enabled) call timer_stop(10)
         end do
!
! Verification test.
!
         if (timers_enabled) call timer_start(14)
         call verify(nx, ny, nz, niter, sums, verified)
         if (timers_enabled) call timer_stop(14)
         call timer_stop(1)

	 total_time = timer_read(1)
	 if (.not.timers_enabled) return

	 print*,'FT subroutine timers '
         write(*,40) 'FT total                  ', timer_read(1)
         write(*,40) 'WarmUp time               ', timer_read(2)
         write(*,40) 'fftXYZ body               ', timer_read(3)
         write(*,40) 'Swarztrauber              ', timer_read(4)
         write(*,40) 'X time                    ', timer_read(7)
         write(*,40) 'Y time                    ', timer_read(8)
         write(*,40) 'Z time                    ', timer_read(9)
         write(*,40) 'CalculateChecksum         ', timer_read(10)
         write(*,40) 'evolve                    ', timer_read(11)
         write(*,40) 'compute_initial_conditions', timer_read(12)
         write(*,40) 'twiddle                   ', timer_read(13)
         write(*,40) 'verify                    ', timer_read(14)
         write(*,40) 'fftXYZ                    ', timer_read(15)
         write(*,40) 'Benchmark time            ', total_time
   40    format(' ',A26,' =',F9.4)

         return
      end


      FUNCTION rtsec(func,x1,x2,xacc)
      INTEGER MAXIT
      REAL rtsec,x1,x2,xacc,func
      EXTERNAL func
      PARAMETER (MAXIT=30)
      INTEGER j
      REAL dx,f,fl,swap,xl
      fl=func(x1)
      f=func(x2)
      if(abs(fl).lt.abs(f))then
        rtsec=x1
        xl=x2
        swap=fl
        fl=f
        f=swap
      else
        xl=x1
        rtsec=x2
      endif
      do 11 j=1,MAXIT
        dx=(xl-rtsec)*f/(f-fl)
        xl=rtsec
        fl=f
        rtsec=rtsec+dx
        f=func(rtsec)
        if(abs(dx).lt.xacc.or.f.eq.0.)return
11    continue
      pause 'rtsec exceed maximum iterations'
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rtsec.for


program main
    use device
    implicit none
    class(device_t), allocatable :: fig
    real, allocatable :: x(:), y(:)
    integer :: n = 10**3
    allocate(x(n), y(n))
    call random_seed()
    call random_number(x)
    call random_number(y)

uplot: block
        use  uniplot
        allocate(fig_t::fig)
        call fig%init(100, 100, 'MonteCarlo')
        call monte_carlo(fig, x, y)
        deallocate(fig)
    end block uplot

xplot: block
        use xplot
        allocate(fig_t::fig)
        call fig%init(450, 450, 'MonteCarlo')
        call monte_carlo(fig, x, y)
        deallocate(fig)
    end block xplot

contains
    subroutine monte_carlo(fig, x, y)
        class(device_t), intent(in out) :: fig
        real, intent(in) :: x(:), y(:)
        integer :: i, ix0, iy0, ix1, iy1, k
        k = fig%nx
        print *
        print *, 'Monte Carlo: estimated pi =', 4.0 * count(x**2 + y**2 < 1.0) / size(x)
        !draw box
        call fig%line0(0, 0, k-1, 0)
        call fig%line0(0, 0, 0, k-1)
        call fig%line0(0, k-1, k-1, k-1)
        call fig%line0(k-1, 0, k-1, k-1)
        ! draw 1/4 circle
        ix0 = 0
        iy0 = 0
        do ix1 = 0, k - 1
            iy1 = k - 1 - int(sqrt(real((k-1)**2 - ix1**2)))
            call fig%line0(ix0, iy0, ix1, iy1)
            ix0 = ix1
            iy0 = iy1
        end do

        do i = 1, n
            call fig%point(int(k * x(i)), int(k * y(i)))
        end do
        call fig%show()
    end subroutine monte_carlo

end program main


program expr_03
implicit none
integer :: x
x = -2
if (x /= -2) error stop

x = -2*3
if (x /= -6) error stop

x = -2*(-3)
if (x /= 6) error stop

x = 3 - 1
if (x /= 2) error stop

x = 1 - 3
if (x /= -2) error stop
if (x /= (-2)) error stop

x = 1 - (-3)
if (x /= 4) error stop
if (x /= +4) error stop
if (x /= (+4)) error stop
end program


      PROGRAM FOO
      INTEGER I, J
      INTEGER A(5:10, 5:10)
      DO J = 5 ,10
         DO I = 5 ,10
            A(I,J) = I * J
         enddo
      enddo
      PRINT *,A
      END


c****************************************************************

	subroutine cross(r_u,r_v,r_w)

c****************************************************************
c**
c**	FILE NAME: cross.f
c**
c**     DATE WRITTEN: 8/3/90
c**
c**     PROGRAMMER:Scott Hensley
c**
c** 	FUNCTIONAL DESCRIPTION: The subroutine takes two vectors and returns
c**     their cross product.
c**
c**     ROUTINES CALLED:none
c**
c**     NOTES: none
c**
c**     UPDATE LOG:
c**
c*****************************************************************

       	implicit none

c	INPUT VARIABLES:
        real*8 r_v(3),r_u(3)            !3x1 vectors

c   	OUTPUT VARIABLES:
        real*8 r_w(3)

c	LOCAL VARIABLES:

c  	PROCESSING STEPS:

c       compute vector norm

        r_w(1) = r_u(2)*r_v(3) - r_u(3)*r_v(2)
        r_w(2) = r_u(3)*r_v(1) - r_u(1)*r_v(3)
        r_w(3) = r_u(1)*r_v(2) - r_u(2)*r_v(1)

        end


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   couple.f90 - coupled cavity equation normal form
!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!--------- ----

! Evaluates the algebraic equations or ODE right hand side

! Input arguments :
!      NDIM   :   Dimension of the algebraic or ODE system
!      U      :   State variables
!      ICP    :   Array indicating the free parameter(s)
!      PAR    :   Equation parameters

! Values to be returned :
!      F      :   Equation or ODE right hand side values

! Normally unused Jacobian arguments : IJAC, DFDU, DFDP (see manual)

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
  DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
  DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM),DFDP(NDIM,*)

  DOUBLE PRECISION x, delta,dff,phi,kappa,gamma
  COMPLEX(KIND(1.0d0)) I, AA, BB,FF

  delta=PAR(1)
! kappa = (0.d0,1.d0)*PAR(2)
  kappa = PAR(2)
  phi = PAR(3)

  dff = PAR(4)
  gamma = PAR(5)

  I=COMPLEX(0.d0,1.d0)
  AA=U(1)+I*U(2)
  BB=U(3)+I*U(4)

! FF=I*(delta+AA*CONJG(AA))*AA-AA+(kappa-1/2)*BB+CDEXP(I*phi)*dff
! F(1)=REALPART(FF)
! F(2)=IMAGPART(FF)
! F(1)= dff*dcos(phi) - U(1) - delta*U(2) - U(2)*U(1)**2 -U(2)**3 - U(3)/2 -kappa*U(4)
! F(2)= dff*dsin(phi) + delta*U(1)+ U(1)**3 - U(2) +U(1)*U(2)*U(2)+kappa*U(3)-U(4)/2

  F(1)= dff*dcos(phi) - U(1) - delta*U(2) - U(2)*U(1)**2 -U(2)**3 + gamma*U(3) -kappa*U(4)
  F(2)= dff*dsin(phi) + delta*U(1)+ U(1)**3 - U(2) +U(1)*U(2)*U(2)+kappa*U(3)+gamma*U(4)

! FF=I*(delta+BB*CONJG(BB))*BB-BB+(kappa-1/2)*AA+CDEXP(I*phi)*dff
! F(3)=REALPART(FF)
! F(4)=IMAGPART(FF)

! F(3)=dff*dcos(phi) - U(1)/2 - kappa*U(2) - U(3) - delta*U(4) - U(4)*U(3)**2  - U(4)**3
! F(4)=dff*dsin(phi) + kappa*U(1) - U(2)/2 + delta*U(3) + U(3)**3 - U(4) + U(3)*U(4)**2

  F(3)=dff*dcos(phi) + gamma*U(1) - kappa*U(2) - U(3) - delta*U(4) - U(4)*U(3)**2  - U(4)**3
  F(4)=dff*dsin(phi) + kappa*U(1) + gamma*U(2) + delta*U(3) + U(3)**3 - U(4) + U(3)*U(4)**2

END SUBROUTINE FUNC

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

SUBROUTINE STPNT(NDIM,U,PAR,T)
!--------- -----

! Input arguments :
!      NDIM   :   Dimension of the algebraic or ODE system

! Values to be returned :
!      U      :   A starting solution vector
!      PAR    :   The corresponding equation-parameter values

! Note : For time- or space-dependent solutions this subroutine has
!        the scalar input parameter T contains the varying time or space
!        variable value.

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
  DOUBLE PRECISION, INTENT(IN) :: T

! Initialize the equation parameters
! PAR(1:2) = (/ 0.0d0, 0.0d0 /)
! PAR(1)=-1.20;
! PAR(2)=0.8;
  PAR(1)=-8.00;
  PAR(2)=2.8;
  PAR(3)=0.0;
  PAR(4)=0.00;
  PAR(5)=0.00;

! Initialize the solution
! U(1) = 0.5783549543956;
! U(2) = 0.1279674119301;
! U(3) = 0.5435124237934;
! U(4) = 0.7882331404511;
  U(1) = 0.0;
  U(2) = 0.0;
  U(3) = 0.0;
  U(4) = 0.0;

END SUBROUTINE STPNT

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

SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!--------- ----

! Boundary Conditions

! Input arguments :
!      NDIM   :   Dimension of the ODE system
!      PAR    :   Equation parameters
!      ICP    :   Array indicating the free parameter(s)
!      NBC    :   Number of boundary conditions
!      U0     :   State variable values at the left boundary
!      U1     :   State variable values at the right boundary

! Values to be returned :
!      FB     :   The values of the boundary condition functions

! Normally unused Jacobian arguments : IJAC, DBC (see manual)

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
  DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
  DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
  DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

!   FB(1)= U0(1)
!   FB(2)= U0(2)

END SUBROUTINE BCND

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

SUBROUTINE ICND(NDIM,PAR,ICP,NINT,U,UOLD,UDOT,UPOLD,FI,IJAC,DINT)
!--------- ----

! Integral Conditions

! Input arguments :
!      NDIM   :   Dimension of the ODE system
!      PAR    :   Equation parameters
!      ICP    :   Array indicating the free parameter(s)
!      NINT   :   Number of integral conditions
!      U      :   Value of the vector function U at `time' t

! The following input arguments, which are normally not needed,
! correspond to the preceding point on the solution branch
!      UOLD   :   The state vector at 'time' t
!      UDOT   :   Derivative of UOLD with respect to arclength
!      UPOLD  :   Derivative of UOLD with respect to `time'

! Normally unused Jacobian arguments : IJAC, DINT

! Values to be returned :
!      FI     :   The value of the vector integrand

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, ICP(*), NINT, IJAC
  DOUBLE PRECISION, INTENT(IN) :: PAR(*)
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), UOLD(NDIM), UDOT(NDIM), UPOLD(NDIM)
  DOUBLE PRECISION, INTENT(OUT) :: FI(NINT)
  DOUBLE PRECISION, INTENT(INOUT) :: DINT(NINT,*)

!X FI(1)=

END SUBROUTINE ICND

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

SUBROUTINE FOPT(NDIM,U,ICP,PAR,IJAC,FS,DFDU,DFDP)
!--------- ----
!
! Defines the objective function for algebraic optimization problems
!
! Supplied variables :
!      NDIM   :   Dimension of the state equation
!      U      :   The state vector
!      ICP    :   Indices of the control parameters
!      PAR    :   The vector of control parameters
!
! Values to be returned :
!      FS      :   The value of the objective function
!
! Normally unused Jacobian argument : IJAC, DFDP

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
  DOUBLE PRECISION, INTENT(OUT) :: FS
  DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM),DFDP(*)

!X FS=

END SUBROUTINE FOPT

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

SUBROUTINE PVLS(NDIM,U,PAR)
!--------- ----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
  DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)
  DOUBLE PRECISION, EXTERNAL :: GETP

!----------------------------------------------------------------------
! NOTE :
! Parameters set in this subroutine should be considered as ``solution
! measures'' and be used for output purposes only.
!
! They should never be used as `true'' continuation parameters.
!
! They may, however, be added as ``over-specified parameters'' in the
! parameter list associated with the AUTO-Constant NICP, in order to
! print their values on the screen and in the ``p.xxx file.
!
! They may also appear in the list associated with AUTO-Constant NUZR.
!
!----------------------------------------------------------------------
! For algebraic problems the argument U is, as usual, the state vector.
! For differential equations the argument U represents the approximate
! solution on the entire interval [0,1]. In this case its values must
! be accessed indirectly by calls to GETP, as illustrated below.
!----------------------------------------------------------------------
!
! Set PAR(2) equal to the L2-norm of U(1)
!
! Set PAR(3) equal to the minimum of U(2)
!X PAR(3)=GETP('MIN',2,U)
!
! Set PAR(4) equal to the value of U(2) at the left boundary.
!X PAR(4)=GETP('BV0',2,U)
!
! Set PAR(5) equal to the pseudo-arclength step size used.
!X PAR(5)=GETP('STP',1,U)
!

  Par(6)=GETP('MAX',1,U)*GETP('MAX',1,U)+GETP('MAX',2,U)*GETP('MAX',2,U)
  Par(7)=GETP('MAX',3,U)*GETP('MAX',3,U)+GETP('MAX',4,U)*GETP('MAX',4,U)

!----------------------------------------------------------------------
! The first argument of GETP may be one of the following:
!        'NRM' (L2-norm),     'MAX' (maximum),
!        'INT' (integral),    'BV0 (left boundary value),
!        'MIN' (minimum),     'BV1' (right boundary value).
!
! Also available are
!   'STP' (Pseudo-arclength step size used).
!   'FLD' (`Fold function', which vanishes at folds).
!   'BIF' (`Bifurcation function', which vanishes at singular points).
!   'HBF' (`Hopf function'; which vanishes at Hopf points).
!   'SPB' ( Function which vanishes at secondary periodic bifurcations).
!----------------------------------------------------------------------

END SUBROUTINE PVLS

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


! This file is part of fortran_quaternion
! Author: Pierre de Buyl http://pdebuyl.be/
! License: BSD 3-clause

module quaternion
  implicit none

  private

  public :: qnorm, qnormalize, qconj, qinv, qmul
  public :: qvector, qscalar, qnew
  public :: qrot

  interface qnew
     module procedure qnew_s
     module procedure qnew_v
     module procedure qnew_sv
     module procedure qnew_void
  end interface qnew

contains

  !! Construct a new quaternion from the scalar part s and the vector part v
  pure function qnew_s(s) result(q)
    double precision, intent(in) :: s
    double precision :: q(4)

    q(1:3) = 0
    q(4) = s

  end function qnew_s

  !! Construct a new quaternion from the scalar part s and the vector part v
  pure function qnew_v(v) result(q)
    double precision, intent(in) :: v(3)
    double precision :: q(4)

    q(1:3) = v
    q(4) = 0

  end function qnew_v

  !! Construct a new quaternion from the scalar part s and the vector part v
  pure function qnew_sv(s, v) result(q)
    double precision, intent(in) :: s
    double precision, intent(in) :: v(3)
    double precision :: q(4)

    q(1:3) = v
    q(4) = s

  end function qnew_sv

  !! Construct a new quaternion from the scalar part s and the vector part v
  pure function qnew_void() result(q)
    double precision :: q(4)

    q = 0

  end function qnew_void

  !! Return the vector part of a quaternion
  pure function qvector(q) result(v)
    double precision, intent(in) :: q(4)
    double precision :: v(3)

    v = q(1:3)

  end function qvector

  !! Return the scalar part of a quaternion
  pure function qscalar(q) result(s)
    double precision, intent(in) :: q(4)
    double precision :: s

    s = q(4)

  end function qscalar

  !! Return the norm of quaternion
  pure function qnorm(q) result(n)
    double precision, intent(in) :: q(4)
    double precision :: n

    n = norm2(q)

  end function qnorm

  !! Return normalized quaternion
  pure function qnormalize(q) result(r)
    double precision, intent(in) :: q(4)
    double precision :: r(4)

    double precision :: n

    n = qnorm(q)
    r = q/n
  end function qnormalize

  !! Return conjugate quaternion
  pure function qconj(q) result(n)
    double precision, intent(in) :: q(4)
    double precision :: n(4)

    n(1) = -q(1)
    n(2) = -q(2)
    n(3) = -q(3)
    n(4) = q(4)

  end function qconj

  !! Return cross product between two 3d vectors
  pure function cross(x1, x2) result(r)
    double precision, intent(in) :: x1(3), x2(3)
    double precision :: r(3)

    r(1) = x1(2)*x2(3) - x1(3)*x2(2)
    r(2) = x1(3)*x2(1) - x1(1)*x2(3)
    r(3) = x1(1)*x2(2) - x1(2)*x2(1)

  end function cross

  !! Return inverse quaterion
  pure function qinv(q) result(n)
    double precision, intent(in) :: q(4)
    double precision :: n(4)

    n(1) = -q(1)
    n(2) = -q(2)
    n(3) = -q(3)
    n(4) = q(4)

    n = n / dot_product(n, n)

  end function qinv

  !! Return the product of two quaternions
  pure function qmul(q1, q2) result(r)
    double precision, intent(in) :: q1(4)
    double precision, intent(in) :: q2(4)
    double precision :: r(4)

    r(1:3) = q1(4)*q2(1:3) + q2(4)*q1(1:3) + cross(q1(1:3), q2(1:3))
    r(4) = q1(4)*q2(4) - dot_product(q1(1:3), q2(1:3))

  end function qmul

  !! Return the vector v rotated by the quaternion q
  pure function qrot(q, v) result(r)
    double precision, intent(in) :: q(4)
    double precision, intent(in) :: v(3)
    double precision :: r(3)

    r = qvector(qmul(q, qmul(qnew(v=v), qconj(q))))

  end function qrot

end module quaternion


      module modulo_formas
        implicit none
        private
        public tipo_cuadrado

        type :: tipo_cuadrado
            real :: lado
            contains
                procedure :: area !Declaración de procedimiento
        end type

        contains
        !Definición del procedimiento
        real function area(el_mismo) result(resultado)
            class(tipo_cuadrado), intent(in) :: el_mismo
            resultado=el_mismo%lado**2
        end function
      end module modulo_formas

      program principal ! "principal" .eq. "main"
        use modulo_formas
        implicit none

        !Declaración de variables
        type(tipo_cuadrado) :: cuadradito
        real :: x, lado

        !Inicializando variables
        lado = 0.5
        cuadradito%lado = lado
        x =cuadradito%area()
        ! el "el_mismo" no aparece aquí, esto sucede ya que es
        ! pasado de forma implícita
        print *, "x=" , x
      end program principal

      !x=  0.250000000


module block_mod
! Demonstrate BLOCK construct, which has nothing to do with COMMON BLOCK.
implicit none
contains
pure function correlation_matrix(x) result(corr)
real, intent(in) :: x(:,:)
real             :: corr(size(x,2),size(x,2))
real             :: xstd(size(x,1),size(x,2))
integer          :: i2,j2,n1,n2
n1 = size(x,1)
n2 = size(x,2)
calc_xstd: block ! naming the block allows early exit
   real :: mean,sqrt_sumsq,vec(n1) ! do not exist outside block
   if (n1 < 1) exit calc_xstd ! leave block early to avoid division by 0
   do i2=1,n2
      ! variables x and xstd declared outside block are accessible
      mean = sum(x(:,i2))/n1
      vec  = x(:,i2) - mean
      sqrt_sumsq = sqrt(sum(vec**2))
      xstd(:,i2) = vec/sqrt_sumsq ! standardized columns of x
   end do
end block calc_xstd
do i2=1,n2
   do j2=1,i2-1
      corr(i2,j2) = sum(xstd(:,i2)*xstd(:,j2)) ! lower diagonal
   end do
   corr(i2,i2) = 1.0
end do
! FORALL can be masked. Line below copies lower diagonal to upper.
forall (i2=1:n2,j2=1:n2,j2>i2) corr(i2,j2) = corr(j2,i2)
end function correlation_matrix
end module block_mod
!
program main
use block_mod, only: correlation_matrix
implicit none
integer, parameter :: n1 = 1000, n2 = 3
real :: x(n1,n2),v(n1),corr(n2,n2)
integer :: i2
call random_seed()
call random_number(v)
call random_number(x)
forall (i2=1:n2) x(:,i2) = x(:,i2) + 2*v
corr = correlation_matrix(x)
print "('correlation matrix')"
do i2=1,n2
   write (*,"(*(f6.3))") corr(i2,:)
end do
end program main
! sample output:
! correlation matrix
!  1.000 0.787 0.791
!  0.787 1.000 0.803
!  0.791 0.803 1.000


! $UWHPSC/codes/fortran/rank2.f90

program rank2

    implicit none
    real(kind=8) :: A(3,4), B(12)
    equivalence (A,B)
    integer :: i,j

    A = reshape((/(10*i, i=1,12)/), (/3,4/))

    do i=1,3
        print 20, i, (A(i,j), j=1,4)
 20     format("Row ",i1," of A contains: ", 11x, 4f6.1)
        print 21, i, (3*(j-1)+i, j=1,4)
 21     format("Row ",i1," is in locations",4i3)
        print 22, (B(3*(j-1)+i), j=1,4)
 22     format("These elements of B contain:", 4x, 4f6.1, /)
        enddo

end program rank2


! =====================================================================
! subroutine USHO
!
! This subroutine constructs a simple harmonic oscillator ground state
! wavefunction.
! ---------------------------------------------------------------------
      subroutine USHO(nRP,nR,nP,x0,y0,kX,kY,R,P,U)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: x0
      double precision :: y0
      double precision :: kX
      double precision :: kY
      double precision :: R(nR)
      double precision :: P(nP)
      double complex :: U(nRP)

      integer :: i
      integer :: j
      integer :: k
      double precision :: pi
      double complex :: a
      double complex :: b
      double complex :: bX
      double complex :: bY

      pi = 3.14159265358979323846d0
      a = dcmplx((kX*kY/pi**2)**(0.25d0),0.0d0)

      k = 0
      do j = 1, nP
         do i = 1, nR
            k = k + 1
            bX = dcmplx(-0.5d0*kX*(R(i)*dcos(P(j))-x0)**2,0.0d0)
            bY = dcmplx(-0.5d0*kY*(R(i)*dsin(P(j))-y0)**2,0.0d0)
            b = bX + bY
            U(k) = a*cdexp(b)
         enddo
      enddo

      return
      end
! =====================================================================


SUBROUTINE BottomVincent(FineGrid,GX,GY)
!
! Define bottom profile for Vincent and Briggs experiment (3D), waves are assumed to
! be in the x-direction and the shoal center is placed at x=10.61m, y=13.72.
!
! By Maite Gouin. Modified by H.B. Bingham.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: FineGrid
REAL(KIND=long) :: y, x, xr, yr, k, angle, dy
INTEGER :: Nx, Ny, i, j, GX, GY

Nx = FineGrid%Nx+2*GX
Ny = FineGrid%Ny+2*GY
dy = FineGrid%y(1,Ny)-FineGrid%y(1,Ny-1)
angle = 0              ! We assume waves in the x-direction.
k = angle/180.0_long*pi
DO j = 1, Ny
   DO i = 1 , Nx
      x = FineGrid%x(i,1) - 6.1_long -4.51_long ! shoal is centered at 6.1 + 2 lambda in x.
      y = FineGrid%y(1,j) - 13.72_long+GY*dy ! shoal at 13.72m in y.
      yr = cos(k)*y - sin(k)*x
      xr = sin(k)*y + cos(k)*x
      !
      FineGrid%h(i,j)   = 0.4572_long
      !
      IF ((yr/3.96_long)**2 + (xr/3.05_long)**2<1) THEN
         FineGrid%h(i,j)   = FineGrid%h(i,j) + 0.4572_long - 0.7620_long*sqrt(one-(yr/4.95_long)**2-(xr/3.81_long)**2)
      END IF
   END DO
END DO
WRITE(*,*) '  WARNING: The bottom slopes for the Vincent and Briggs experiment are not defined analytically.,'
WRITE(*,*) '  WARNING: Therefore the derivatives of the bottom profile function are determined numerically.'
WRITE(*,*) '  WARNING: Shoal center is at x=10.61m, y=13.72m. Waves should be in the x-direction'
END SUBROUTINE BottomVincent


!*==dlasv2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLASV2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
!
!       .. Scalar Arguments ..
!       DOUBLE PRECISION   CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLASV2 computes the singular value decomposition of a 2-by-2
!> triangular matrix
!>    [  F   G  ]
!>    [  0   H  ].
!> On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
!> smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
!> right singular vectors for abs(SSMAX), giving the decomposition
!>
!>    [ CSL  SNL ] [  F   G  ] [ CSR -SNR ]  =  [ SSMAX   0   ]
!>    [-SNL  CSL ] [  0   H  ] [ SNR  CSR ]     [  0    SSMIN ].
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] F
!> \verbatim
!>          F is DOUBLE PRECISION
!>          The (1,1) element of the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[in] G
!> \verbatim
!>          G is DOUBLE PRECISION
!>          The (1,2) element of the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[in] H
!> \verbatim
!>          H is DOUBLE PRECISION
!>          The (2,2) element of the 2-by-2 matrix.
!> \endverbatim
!>
!> \param[out] SSMIN
!> \verbatim
!>          SSMIN is DOUBLE PRECISION
!>          abs(SSMIN) is the smaller singular value.
!> \endverbatim
!>
!> \param[out] SSMAX
!> \verbatim
!>          SSMAX is DOUBLE PRECISION
!>          abs(SSMAX) is the larger singular value.
!> \endverbatim
!>
!> \param[out] SNL
!> \verbatim
!>          SNL is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[out] CSL
!> \verbatim
!>          CSL is DOUBLE PRECISION
!>          The vector (CSL, SNL) is a unit left singular vector for the
!>          singular value abs(SSMAX).
!> \endverbatim
!>
!> \param[out] SNR
!> \verbatim
!>          SNR is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[out] CSR
!> \verbatim
!>          CSR is DOUBLE PRECISION
!>          The vector (CSR, SNR) is a unit right singular vector for the
!>          singular value abs(SSMAX).
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup OTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Any input parameter may be aliased with any output parameter.
!>
!>  Barring over/underflow and assuming a guard digit in subtraction, all
!>  output quantities are correct to within a few units in the last
!>  place (ulps).
!>
!>  In IEEE arithmetic, the code works correctly if one matrix element is
!>  infinite.
!>
!>  Overflow will not occur unless the largest singular value itself
!>  overflows or is within a few ulps of overflow. (On machines with
!>  partial overflow, like the Cray, overflow may occur if the largest
!>  singular value is within a factor of 2 of overflow.)
!>
!>  Underflow is harmless if underflow is gradual. Otherwise, results
!>  may correspond to a matrix modified by perturbations of size near
!>  the underflow threshold.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DLASV2(F,G,H,Ssmin,Ssmax,Snr,Csr,Snl,Csl)
      IMPLICIT NONE
!*--DLASV2142
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION Csl , Csr , F , G , H , Snl , Snr , Ssmax , Ssmin
!     ..
!
! =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
      DOUBLE PRECISION HALF
      PARAMETER (HALF=0.5D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.0D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.0D0)
      DOUBLE PRECISION FOUR
      PARAMETER (FOUR=4.0D0)
!     ..
!     .. Local Scalars ..
      LOGICAL gasmal , swap
      INTEGER pmax
      DOUBLE PRECISION a , clt , crt , d , fa , ft , ga , gt , ha , ht ,&
     &                 l , m , mm , r , s , slt , srt , t , temp ,      &
     &                 tsign , tt
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , SIGN , SQRT
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL DLAMCH
!     ..
!     .. Executable Statements ..
!
      ft = F
      fa = ABS(ft)
      ht = H
      ha = ABS(H)
!
!     PMAX points to the maximum absolute element of matrix
!       PMAX = 1 if F largest in absolute values
!       PMAX = 2 if G largest in absolute values
!       PMAX = 3 if H largest in absolute values
!
      pmax = 1
      swap = (ha>fa)
      IF ( swap ) THEN
         pmax = 3
         temp = ft
         ft = ht
         ht = temp
         temp = fa
         fa = ha
         ha = temp
!
!        Now FA .ge. HA
!
      ENDIF
      gt = G
      ga = ABS(gt)
      IF ( ga==ZERO ) THEN
!
!        Diagonal matrix
!
         Ssmin = ha
         Ssmax = fa
         clt = ONE
         crt = ONE
         slt = ZERO
         srt = ZERO
      ELSE
         gasmal = .TRUE.
         IF ( ga>fa ) THEN
            pmax = 2
            IF ( (fa/ga)<DLAMCH('EPS') ) THEN
!
!              Case of very large GA
!
               gasmal = .FALSE.
               Ssmax = ga
               IF ( ha>ONE ) THEN
                  Ssmin = fa/(ga/ha)
               ELSE
                  Ssmin = (fa/ga)*ha
               ENDIF
               clt = ONE
               slt = ht/gt
               srt = ONE
               crt = ft/gt
            ENDIF
         ENDIF
         IF ( gasmal ) THEN
!
!           Normal case
!
            d = fa - ha
            IF ( d==fa ) THEN
!
!              Copes with infinite F or H
!
               l = ONE
            ELSE
               l = d/fa
            ENDIF
!
!           Note that 0 .le. L .le. 1
!
            m = gt/ft
!
!           Note that abs(M) .le. 1/macheps
!
            t = TWO - l
!
!           Note that T .ge. 1
!
            mm = m*m
            tt = t*t
            s = SQRT(tt+mm)
!
!           Note that 1 .le. S .le. 1 + 1/macheps
!
            IF ( l==ZERO ) THEN
               r = ABS(m)
            ELSE
               r = SQRT(l*l+mm)
            ENDIF
!
!           Note that 0 .le. R .le. 1 + 1/macheps
!
            a = HALF*(s+r)
!
!           Note that 1 .le. A .le. 1 + abs(M)
!
            Ssmin = ha/a
            Ssmax = fa*a
            IF ( mm/=ZERO ) THEN
               t = (m/(s+t)+m/(r+l))*(ONE+a)
!
!              Note that M is very tiny
!
            ELSEIF ( l==ZERO ) THEN
               t = SIGN(TWO,ft)*SIGN(ONE,gt)
            ELSE
               t = gt/SIGN(d,ft) + m/t
            ENDIF
            l = SQRT(t*t+FOUR)
            crt = TWO/l
            srt = t/l
            clt = (crt+srt*m)/a
            slt = (ht/ft)*srt/a
         ENDIF
      ENDIF
      IF ( swap ) THEN
         Csl = srt
         Snl = crt
         Csr = slt
         Snr = clt
      ELSE
         Csl = clt
         Snl = slt
         Csr = crt
         Snr = srt
      ENDIF
!
!     Correct signs of SSMAX and SSMIN
!
      IF ( pmax==1 ) tsign = SIGN(ONE,Csr)*SIGN(ONE,Csl)*SIGN(ONE,F)
      IF ( pmax==2 ) tsign = SIGN(ONE,Snr)*SIGN(ONE,Csl)*SIGN(ONE,G)
      IF ( pmax==3 ) tsign = SIGN(ONE,Snr)*SIGN(ONE,Snl)*SIGN(ONE,H)
      Ssmax = SIGN(Ssmax,tsign)
      Ssmin = SIGN(Ssmin,tsign*SIGN(ONE,F)*SIGN(ONE,H))
!
!     End of DLASV2
!
      END SUBROUTINE DLASV2


*DECK BISECT
      SUBROUTINE BISECT (N, EPS1, D, E, E2, LB, UB, MM, M, W, IND, IERR,
     +   RV4, RV5)
C***BEGIN PROLOGUE  BISECT
C***PURPOSE  Compute the eigenvalues of a symmetric tridiagonal matrix
C            in a given interval using Sturm sequencing.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5, D4C2A
C***TYPE      SINGLE PRECISION (BISECT-S)
C***KEYWORDS  EIGENVALUES, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the bisection technique
C     in the ALGOL procedure TRISTURM by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
C
C     This subroutine finds those eigenvalues of a TRIDIAGONAL
C     SYMMETRIC matrix which lie in a specified interval,
C     using bisection.
C
C     On INPUT
C
C        N is the order of the matrix.  N is an INTEGER variable.
C
C        EPS1 is an absolute error tolerance for the computed
C          eigenvalues.  If the input EPS1 is non-positive,
C          it is reset for each submatrix to a default value,
C          namely, minus the product of the relative machine
C          precision and the 1-norm of the submatrix.
C          EPS1 is a REAL variable.
C
C        D contains the diagonal elements of the input matrix.
C          D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the input matrix
C          in its last N-1 positions.  E(1) is arbitrary.
C          E is a one-dimensional REAL array, dimensioned E(N).
C
C        E2 contains the squares of the corresponding elements of E.
C          E2(1) is arbitrary.  E2 is a one-dimensional REAL array,
C          dimensioned E2(N).
C
C        LB and UB define the interval to be searched for eigenvalues.
C          If LB is not less than UB, no eigenvalues will be found.
C          LB and UB are REAL variables.
C
C        MM should be set to an upper bound for the number of
C          eigenvalues in the interval.  WARNING - If more than
C          MM eigenvalues are determined to lie in the interval,
C          an error return is made with no eigenvalues found.
C          MM is an INTEGER variable.
C
C     On OUTPUT
C
C        EPS1 is unaltered unless it has been reset to its
C          (last) default value.
C
C        D and E are unaltered.
C
C        Elements of E2, corresponding to elements of E regarded
C          as negligible, have been replaced by zero causing the
C          matrix to split into a direct sum of submatrices.
C          E2(1) is also set to zero.
C
C        M is the number of eigenvalues determined to lie in (LB,UB).
C          M is an INTEGER variable.
C
C        W contains the M eigenvalues in ascending order.
C          W is a one-dimensional REAL array, dimensioned W(MM).
C
C        IND contains in its first M positions the submatrix indices
C          associated with the corresponding eigenvalues in W --
C          1 for eigenvalues belonging to the first submatrix from
C          the top, 2 for those belonging to the second submatrix, etc.
C          IND is an one-dimensional INTEGER array, dimensioned IND(MM).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          3*N+1      if M exceeds MM.  In this case, M contains the
C                     number of eigenvalues determined to lie in
C                     (LB,UB).
C
C        RV4 and RV5 are one-dimensional REAL arrays used for temporary
C          storage, dimensioned RV4(N) and RV5(N).
C
C     The ALGOL procedure STURMCNT contained in TRISTURM
C     appears in BISECT in-line.
C
C     Note that subroutine TQL1 or IMTQL1 is generally faster than
C     BISECT, if more than N/4 eigenvalues are to be found.
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BISECT
C
      INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM
      REAL D(*),E(*),E2(*),W(*),RV4(*),RV5(*)
      REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP,S1,S2
      INTEGER IND(*)
      LOGICAL FIRST
C
      SAVE FIRST, MACHEP
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BISECT
      IF (FIRST) THEN
         MACHEP = R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      IERR = 0
      TAG = 0
      T1 = LB
      T2 = UB
C     .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES ..........
      DO 40 I = 1, N
         IF (I .EQ. 1) GO TO 20
         S1 = ABS(D(I)) + ABS(D(I-1))
         S2 = S1 + ABS(E(I))
         IF (S2 .GT. S1) GO TO 40
   20    E2(I) = 0.0E0
   40 CONTINUE
C     .......... DETERMINE THE NUMBER OF EIGENVALUES
C                IN THE INTERVAL ..........
      P = 1
      Q = N
      X1 = UB
      ISTURM = 1
      GO TO 320
   60 M = S
      X1 = LB
      ISTURM = 2
      GO TO 320
   80 M = M - S
      IF (M .GT. MM) GO TO 980
      Q = 0
      R = 0
C     .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
C                INTERVAL BY THE GERSCHGORIN BOUNDS ..........
  100 IF (R .EQ. M) GO TO 1001
      TAG = TAG + 1
      P = Q + 1
      XU = D(P)
      X0 = D(P)
      U = 0.0E0
C
      DO 120 Q = P, N
         X1 = U
         U = 0.0E0
         V = 0.0E0
         IF (Q .EQ. N) GO TO 110
         U = ABS(E(Q+1))
         V = E2(Q+1)
  110    XU = MIN(D(Q)-(X1+U),XU)
         X0 = MAX(D(Q)+(X1+U),X0)
         IF (V .EQ. 0.0E0) GO TO 140
  120 CONTINUE
C
  140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP
      IF (EPS1 .LE. 0.0E0) EPS1 = -X1
      IF (P .NE. Q) GO TO 180
C     .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
      IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
      M1 = P
      M2 = P
      RV5(P) = D(P)
      GO TO 900
  180 X1 = X1 * (Q-P+1)
      LB = MAX(T1,XU-X1)
      UB = MIN(T2,X0+X1)
      X1 = LB
      ISTURM = 3
      GO TO 320
  200 M1 = S + 1
      X1 = UB
      ISTURM = 4
      GO TO 320
  220 M2 = S
      IF (M1 .GT. M2) GO TO 940
C     .......... FIND ROOTS BY BISECTION ..........
      X0 = UB
      ISTURM = 5
C
      DO 240 I = M1, M2
         RV5(I) = UB
         RV4(I) = LB
  240 CONTINUE
C     .......... LOOP FOR K-TH EIGENVALUE
C                FOR K=M2 STEP -1 UNTIL M1 DO --
C                (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
      K = M2
  250    XU = LB
C     .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
         DO 260 II = M1, K
            I = M1 + K - II
            IF (XU .GE. RV4(I)) GO TO 260
            XU = RV4(I)
            GO TO 280
  260    CONTINUE
C
  280    IF (X0 .GT. RV5(K)) X0 = RV5(K)
C     .......... NEXT BISECTION STEP ..........
  300    X1 = (XU + X0) * 0.5E0
         S1 = 2.0E0*(ABS(XU) + ABS(X0) + ABS(EPS1))
         S2 = S1 + ABS(X0 - XU)
         IF (S2 .EQ. S1) GO TO 420
C     .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
  320    S = P - 1
         U = 1.0E0
C
         DO 340 I = P, Q
            IF (U .NE. 0.0E0) GO TO 325
            V = ABS(E(I)) / MACHEP
            IF (E2(I) .EQ. 0.0E0) V = 0.0E0
            GO TO 330
  325       V = E2(I) / U
  330       U = D(I) - X1 - V
            IF (U .LT. 0.0E0) S = S + 1
  340    CONTINUE
C
         GO TO (60,80,200,220,360), ISTURM
C     .......... REFINE INTERVALS ..........
  360    IF (S .GE. K) GO TO 400
         XU = X1
         IF (S .GE. M1) GO TO 380
         RV4(M1) = X1
         GO TO 300
  380    RV4(S+1) = X1
         IF (RV5(S) .GT. X1) RV5(S) = X1
         GO TO 300
  400    X0 = X1
         GO TO 300
C     .......... K-TH EIGENVALUE FOUND ..........
  420    RV5(K) = X1
      K = K - 1
      IF (K .GE. M1) GO TO 250
C     .......... ORDER EIGENVALUES TAGGED WITH THEIR
C                SUBMATRIX ASSOCIATIONS ..........
  900 S = R
      R = R + M2 - M1 + 1
      J = 1
      K = M1
C
      DO 920 L = 1, R
         IF (J .GT. S) GO TO 910
         IF (K .GT. M2) GO TO 940
         IF (RV5(K) .GE. W(L)) GO TO 915
C
         DO 905 II = J, S
            I = L + S - II
            W(I+1) = W(I)
            IND(I+1) = IND(I)
  905    CONTINUE
C
  910    W(L) = RV5(K)
         IND(L) = TAG
         K = K + 1
         GO TO 920
  915    J = J + 1
  920 CONTINUE
C
  940 IF (Q .LT. N) GO TO 100
      GO TO 1001
C     .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF
C                EIGENVALUES IN INTERVAL ..........
  980 IERR = 3 * N + 1
 1001 LB = T1
      UB = T2
      RETURN
      END


PROGRAM volterrasolve

! Tom Hagstrom wrote this to solve the same 2nd-kind Volterra IE as AHB's
! test_volterra.m

USE volterra

USE SpecFuns

IMPLICIT NONE

INTEGER :: q,nnodes,n,m,j,it,nsteps,im,jdat
DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: c,u
DOUBLE PRECISION :: ttot,err,size,t,ermax,dt,g,tspan,val

tspan=1.d0
ttot=100.d0

nnodes=128

n=8
q=4

DO im=1,4
!
  m=10*im+q+1
  nnodes=16*im
  ermax=0.d0
  jdat=19+im
  OPEN(UNIT=jdat)
  ALLOCATE(u(0:m),c(0:m))
  CALL BuildCofs(q,nnodes,tspan,Ker,m,dt,c)
  u=0.d0
!
  nsteps=INT(100.d0/dt)
!
  DO it=1,nsteps
    t=DBLE(it)*dt
    CALL f(t,val)
    u(m)=val
    DO j=0,m-1
      u(m)=u(m)-c(j)*u(j)
    END DO
    u(m)=u(m)/c(m)
    err=abs(u(m)-sol(t))
    WRITE (jdat,*)t,u(m)
    IF (err > ermax) THEN
      ermax=err
    END IF
!
! Shuffle
!
    DO j=0,m-1
      u(j)=u(j+1)
    END DO
  END DO
!
  PRINT *,dt,ermax
  DEALLOCATE(c,u)
  CLOSE(UNIT=jdat)
!
END DO

CONTAINS

DOUBLE PRECISION FUNCTION sol(t)

DOUBLE PRECISION, INTENT(IN) :: t

sol=(1.d0+TANH(2.d0*(t-10.d0)))*SIN(20.d0*t)

END FUNCTION sol

DOUBLE PRECISION FUNCTION Ker(t)

DOUBLE PRECISION, INTENT(IN) :: t

Ker=1.d0

END FUNCTION Ker

SUBROUTINE f(t,val)

DOUBLE PRECISION, INTENT(IN) :: t
DOUBLE PRECISION, INTENT(OUT) :: val
DOUBLE PRECISION, DIMENSION(0:1024), SAVE :: s,w
LOGICAL :: first_call=.TRUE.
INTEGER :: j

IF (first_call) THEN
  CALL GaussQCofs(s,w,1024)
  s=.5d0*tspan*(s+1.d0)
  w=.5d0*tspan*w
  first_call=.FALSE.
END IF

val=sol(t)

DO j=0,1024
  val=val+w(j)*Ker(s(j))*sol(t-s(j))
END DO

END SUBROUTINE f

END PROGRAM volterrasolve