*----------------------------------------------------------------------_
*
      Program MyPrj1
*
*     Purpose: Solve the vibration problem
*
      Implicit None
*
*-- Common Definitions
*
*   Write file index
      Integer           IOut
      Common /IO/       IOut
*   Calculation Parameter
      Double Precision  e, rScale, rMin
      Common /CalPar/   e, rScale, rMin
*   Constants
      Double Precision  Pi
      Common /Const/    Pi
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*   Global Integral grid number
      Integer           IGridN
      Common /Grid/     IGridN
*   Zero Tolerence (Two values refers to the error or warning situation)
      Double Precision  Thr0, ThrW0
      Common /ZeroTh/   Thr0, ThrW0
*   Deviation Threahold
*!!   Non-FORTRAN77 syntax: An effort to make the variables stored into
*!!   the memories of the same length
      Integer*8         ItrMax
      Double Precision  DevX, DevY
      Common /DevThr/   ItrMax, DevX, DevY
*
*-- Internal Functions
*
      Double Precision  Itg5P1, Itg5P2, RtSec2, FI
      External          Itg5P1, ITg5P2, RtSec2, FI
      Integer           IFlr
      External          IFlr
*
*-- Internal Variables
*
*   Numbers of B should be calculated
      Integer           bNum
      Parameter         (bNum=40)
      Double Precision  bMax, bMin, bH
*   B as variable
      Double Precision  b
*   Stored Variables
      Double Precision  bV(bNum), TV(bNum), rMinV(bNum)
*   Dummy
      Integer           I
*
*-- Debug Functions
      Double Precision  BCrit, RCrit, FC, FIC1, FIC2, FCRt
      External          BCrit, RCrit, FC, FIC1, FIC2, FCRt
*
*-----------------------------------------------------------------------

*-- Initialize Common Variables

*   IO
      IOut = 11
*   CalPar
      e = 0.3D0
      RScale = 10.0D0
*   Const
      Pi = DACos(-1.0D0)
*   ErStat
      IStat = 0
*   Grid
      IGridN = 50000
*   ZeroTh
      Thr0 = 1.0D-7
      ThrW0 = 1.0D-10
*   DevThr
      ItrMax = 100
      DevX = 1.0D-10
      DevY = 1.0D-10

*-- File I/O
      Open(IOut, File='myprj1.txt')
 1000 Format (1x, F10.4, F15.7, F16.7)
 1010 Format (1x, A10, A15, A16)

*-- Internal Initial variables
      bMin = 0.5D0
      bMax = 2.5D0
      bH = (bMax - bMin) / DBLE(bNum - 1)

*-- Main Program
      Do 10 I = 1, bNum
        b = bMin + DBLE(I-1) * bH
        bV(I) = b
        rMin = FCRt(b)
        rMinV(I) = rMin
        TV(I) = FI(b) / Pi * 1.8D2
  10  Continue

      Write(IOut,*)
      Write(IOut,*) 'Impact Factor Minimum = ', bMin
      Write(IOut,*) 'Impact Factro Maximum = ', bMax
      Write(IOut,*) 'Energy                = ', e
      Write(IOut,*) 'Integral Upper Limit  = ', rScale
      Write(IOut,*)
      Write(IOut,*) 'X Threshold           = ', DevX
      Write(IOut,*) 'Y Threshold           = ', DevY
      Write(IOut,*) 'Integral Grid Numbers = ', IGridN
      Write(IOut,*) 'Maximun Root Search   = ', ItrMax
      Write(IOut,*)
      Write(IOut,*) 'bCrit                 = ', BCrit(e)
      Write(IOut,*) 'rCrit                 = ', RCrit(e)
      Write(IOut,*)
      Write(IOut,1010) '----------', '---------------',
     $                 '----------------'
      Write(IOut,1010) 'Impact', 'rMin', 'Theta'
      Write(IOut,1010) '----------', '---------------',
     $                 '----------------'
      Do 20 I = 1, bNum
        Write(IOut,1000) bV(I), rMinV(I), TV(I)
  20  Continue
      Write(IOut,1010) '----------', '---------------',
     $                 '----------------'

      Stop
      End Program MyPrj1

************************************************************************
*                                                                      *
*     USER DEFINE SUBROUTINES                                          *
*                                                                      *
************************************************************************

*-----------------------------------------------------------------------
*
      Function FI(b)
*
*     Purpose: The integral result (=Theta)
*
      Implicit None
*
*-- Common Variables
*
*   Calculation Parameter
      Double Precision  e, rScale, rMin
      Common /CalPar/   e, rScale, rMin
*   Global Integral grid number
      Integer           IGridN
      Common /Grid/     IGridN
*
*-- Variables
*
      Double Precision  FI, b
*
*-- Internal Variables
*
*   Integral Upper Limit
      Double Precision  rMax
*
*-- External Functions
*
*   Integral Core Function
      Double Precision  FIC1, FIC2
      External          FIC1, FIC2
*   Integral Routine
      Double Precision  Itg5P2
      External          Itg5P2
*   Root of FC (rMin)
      Double Precision  FCRt
      External          FCRt
*
*-----------------------------------------------------------------------

      rMax = rScale

      FI = Itg5P2(FIC2, b, b, rMax, IGridN)
     $   - Itg5P2(FIC1, b, rMin, rMax, IGridN)

      Call Err
      Return
      End Function FI

*-----------------------------------------------------------------------
*
      Function FCRt(b)
*
*     Purpose: Find rMin (Biggest Root of FC)
*
      Implicit None
*
*-- Common Variables
*
*   Write file index
      Integer           IOut
      Common /IO/       IOut
*   Calculation Parameter
      Double Precision  e, rScale, rMin
      Common /CalPar/   e, rScale, rMin
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*
*-- Variables
*
      Double Precision  FCRt, b
*
*-- External Functions
*
*   Critical Values BCrit, RCrit
      Double Precision  BCrit, RCrit
      External          BCrit, RCrit
*   Initial Guess for FC06
      Double Precision  FC06Rt
      External          FC06Rt
*   Initial Guess for FC02
      Double Precision  FC02Rt
*   Secant Search for Root
      Double Precision  RtSec2
      External          RtSec2
*   The Function We Wish to Find Root
      Double Precision  FC
      External          FC
*
*-----------------------------------------------------------------------

      FC02Rt = b

      If (e.LE.0.75D0) then
        If (b.GE.BCrit(e)) then
          FCRt = RtSec2(FC, b, 0.0D0, FC02Rt+0.1D-2, FC02Rt)
          If (FCRt.LT.RCrit(e)) then
            Write(IOut,*) 'Error Info in Function [FCRt]'
            Write(IOut,*) 'You Possibly find a small root rather than'
            Write(IOut,*) 'the greatest one.'
            IStat = -1
            Call Err
          End If
        Else
          FCRt = RtSec2(FC, b, 0.0D0, FC06Rt(e), 1.0D0)
        End If
      Else
        If (b.GT.2.0D0**(1.0D0/6.0D0)) then
          FCRt = RtSec2(FC, b, 0.0D0, FC02Rt+0.1D-2, FC02Rt)
          If (IStat.EQ.-1) then
            IStat = 0
            FCRt = RtSec2(FC, b, 0.0D0, FC06Rt(e), 1.0D0)
            If (IStat.EQ.-1) then
              Write(IOut,*) 'Error Info in Function [FCRt]'
              Write(IOut,*) 'Cannot Find Root for FC.'
              IStat = 2
              Call Err
            End If
          End If
        Else
          FCRt = RtSec2(FC, b, 0.0D0, FC06Rt(e), 1.0D0)
          If (IStat.EQ.-1) then
            IStat = 0
            FCRt = RtSec2(FC, b, 0.0D0, FC02Rt+0.1D-2, FC02Rt)
            If (IStat.EQ.-1) then
              Write(IOut,*) 'Error Info in Function [FCRt]'
              Write(IOut,*) 'Cannot Find Root for FC.'
              IStat = 2
              Call Err
            End If
          End If
        End If
      End If

      Return
      End Function FCRt

*-----------------------------------------------------------------------
*
      Function FIC1(b,r)
*
*     Purpose: The integral core (for the first function)
*
      Implicit None
*
*-- Common Variables
*
*   Calculation Parameter
      Double Precision  e, rScale, rMin
      Common /CalPar/   e, rScale, rMin
*   Deviation Threahold
*!!   Non-FORTRAN77 syntax: An effort to make the variables stored into
*!!   the memories of the same length
      Integer*8         ItrMax
      Double Precision  DevX, DevY
      Common /DevThr/   ItrMax, DevX, DevY
*
*-- Variables
*
      Double Precision  FIC1, b, r
      Double Precision  Tmp, FC, FCRt, FC1
      External          FC, FCRt, FC1
*
*-----------------------------------------------------------------------

      Tmp = FC(b,r)
      Call Test0(Tmp)
      If (Tmp.LE.DevX.OR.(r-rMin).LE.DevX) then
        Tmp = FC1(b,r)
      Else
        Tmp = Tmp / (r-rMin)
      End If
      FIC1 = (2.0D0 * b / (r*r) ) / DSqrt(Tmp)

      Return
      End Function FIC1

*-----------------------------------------------------------------------
*
      Function FIC2(b,r)
*
*     Purpose: The integral core (for the second function calculate Pi)
*
      Implicit None
*
*-- Variables
*
      Double Precision  FIC2, b, r
      Double Precision  Tmp, FC
      External          FC
*
*-----------------------------------------------------------------------

      Tmp = (r+b) / (r*r)
      FIC2 = (2.0D0 * b / (r*r) ) / DSqrt(Tmp)

      Return
      End Function FIC2

*-----------------------------------------------------------------------
*
      Function FC(b,r)
*
*     Purpose: Part of Integral Core
*
      Implicit None
*
*-- Common Definitions
*
*   Calculation Parameter
      Double Precision  e, rScale, rMin
      Common /CalPar/   e, rScale, rMin
*
*-- Variables
*
      Double Precision  FC, b, r
*
*-----------------------------------------------------------------------

      FC = 1.0D0 - (b*b) / (r*r)
     $     - (4.0D0 * r**(-12.0D0) - 4.0D0 * r**(-6.0D0)) / e

      Return
      End Function FC

*-----------------------------------------------------------------------
*
      Function FC1(b,r)
*
*     Purpose: 1st Derivative (by r) of FC
*
      Implicit None
*
*-- Common Definitions
*
*   Calculation Parameter
      Double Precision  e, rScale, rMin
      Common /CalPar/   e, rScale, rMin
*
*-- Variables
*
      Double Precision  FC1, b, r
*
*-----------------------------------------------------------------------

      FC1 = 2.0D0 * (b*b) / (r*r*r)
     $     + (48.0D0 * r**(-13.0D0) - 24.0D0 * r**(-7.0D0)) / e

      Return
      End Function FC1

*-----------------------------------------------------------------------
*
      Function FC06RT(e)
*
*     Purpose: Calculate Positive Root of 1-4/e(r^12-r^6)==0
*
      Implicit None
*
*-- Variables
*
      Double Precision  FC06RT, e
*
*-----------------------------------------------------------------------

      FC06RT = (0.5D0 * (1.0D0 + DSQRT(1.0D0 + e))) ** (-1.0D0/6.0D0)

      End Function FC06RT

*-----------------------------------------------------------------------
*
      Function RCrit(e)
*
      Implicit None
*
*-- Variables
*
      Double Precision  RCrit, e
*
*-----------------------------------------------------------------------

      RCrit = ((4.0D0 + 2.0D0 * DSqrt(4.0D0 - 5.0D0 * e)) / e)
     $        ** (1.0D0/6.0D0)

      End Function RCrit

*-----------------------------------------------------------------------
*
      Function BCrit(e)
*
      Implicit None
*
*-- Variables
*
      Double Precision  BCrit, e
*
*-----------------------------------------------------------------------

      BCrit = (2.0D0**(2.0D0/3.0D0) * DSqrt(3.0D0) / 5.0D0)
     $        * ((2.0D0 + DSqrt(4.0D0 - 5.0D0 * e)) / e)
     $          ** (1.0D0/6.0D0)
     $        * DSqrt((2.0D0 - DSqrt(4.0D0 - 5.0D0 * e)
     $          + 5.0D0 * e) / e)

      End Function BCrit

************************************************************************
*                                                                      *
*     Program Utilities                                                *
*                                                                      *
************************************************************************

*-----------------------------------------------------------------------
*
      Subroutine Err
*
*     Purpose: Call Err Message and Stop the Program
*
      Implicit None
*
*-- Common Definitions
*
*   Write file index
      Integer           IOut
      Common /IO/       IOut
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*
*-----------------------------------------------------------------------

      If (IStat.GT.0) then
        Write(IOut,*) 'Error Return!'
        Write(IOut,*) 'Return Code: ', IStat
        Stop
      Else If (IStat.EQ.-1) then
        Write(IOut,*) 'Subroutine Error!'
        Write(IOut,*) 'Return Code: ', IStat
        Write(IOut,*) 'Continue running program!'
      End If

      End Subroutine

************************************************************************
*                                                                      *
*     MATHEMATICAL BACKGROUND UTILITIES                                *
*                                                                      *
************************************************************************

*-----------------------------------------------------------------------
*
      Function RtSec1(Func, Num, RtLo, RtUp)
*
*     Purpose: Find the root with secant method, where the first two
*              guesses are provided mannually.
*              The root-finding problem should be expressed as:
*                Func(Root) == Num
*
      Implicit None
*
*-- Common Blocks
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*   Deviation Threahold
      Integer*8         ItrMax
      Double Precision  DevX, DevY
      Common /DevThr/   ItrMax, DevX, DevY
*
*-- Variables
*
      Double Precision  RtSec1, Func, Num, RtLo, RtUp
      External          Func
*
*   Func    The function we are concerning
*   Num     The right hand side of the equation
*   RtLo    The minimun guess
*   RtUp    The maximun guess
*
*   Note: Should have (Func(RtLo)-Num) * (Func(RtUp)-Num) < 0
*         or we probably have no or even roots inside within the maximun
*         guess or the minimun guess.
*
*-- Internal Variables
*
*   Iteration Dummy
      Integer           Itr
*   Internal maximun and minimun guess
      Double Precision  RtLoI, RtUpI
*   Internal Result
      Double Precision  FncLo, FncUp, FncSec
*
*-----------------------------------------------------------------------

*   Initialize internal guess
      RtLoI = RtLo
      RtUpI = RtUp
      Itr = 0
      FncLo = Func(RtLoI) - Num
      FncUp = Func(RtUpI) - Num

*   Find the root
  10  Continue
        Itr = Itr + 1
        RtSec1 = ( RtLoI * FncUp - RtUpI * FncLo ) / ( FncUp - FncLo )
        FncSec = Func(RtSec1) - Num
        RtLoI = RtUpI
        FncLo = FncUp
        RtUpI = RtSec1
        FncUp = FncSec
*   Converge Judgement
      If ( (Itr.LT.ItrMax).And.( DAbs(RtUpI-RtLoI).GT.DevX.Or.
     $      (DAbs(FncUp).GT.DevY.And.(FncUp-FncLo).GT.DevY))) then
*     Not converged
        Go To 10
      Else If ( (Itr.GE.ItrMax).And.( DAbs(RtUpI-RtLoI).GT.DevX.Or.
     $      (DAbs(FncUp).GT.DevY.And.(FncUp-FncLo).GT.DevY))) then
*     Not converged but reached the maximun iteration
        Print *, 'Error Info in Function [RtSec1]'
        Print *, 'Not converged but reached the maximun iteration'
        Print *, 'Last Iteration Information:'
        Print *, 'Upper Guess: ', RtUpI, '  Lower Guess: ', RtLoI,
     $           'Upper Func: ', FncUp, '  Lower Guess: ', FncLo
        IStat = -1
      Else
        Return
      End If

      Call Err
      Return
      End Function RtSec1

*-----------------------------------------------------------------------
*
      Function RtSec2(Func, VM, Num, RtLo, RtUp)
*
*     Purpose: Find the root with secant method, where the first two
*              guesses are provided mannually.
*              The root-finding problem should be expressed as:
*                Func(VM, Root) == Num
*
      Implicit None
*
*-- Common Blocks
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*   Deviation Threahold
      Integer*8         ItrMax
      Double Precision  DevX, DevY
      Common /DevThr/   ItrMax, DevX, DevY
*
*-- Variables
*
      Double Precision  RtSec2, Func, VM, Num, RtLo, RtUp
      External          Func
*
*   Func    The function we are concerning
*   Num     The right hand side of the equation
*   RtLo    The minimun guess
*   RtUp    The maximun guess
*
*   Note: Should have (Func(VM, RtLo)-Num) * (Func(VM, RtUp)-Num) < 0
*         or we probably have no or even roots inside within the maximun
*         guess or the minimun guess.
*
*-- Internal Variables
*
*   Iteration Dummy
      Integer           Itr
*   Internal maximun and minimun guess
      Double Precision  RtLoI, RtUpI
*   Internal Result
      Double Precision  FncLo, FncUp, FncSec
*
*-----------------------------------------------------------------------

*   Initialize internal guess
      RtLoI = RtLo
      RtUpI = RtUp
      Itr = 0
      FncLo = Func(VM, RtLoI) - Num
      FncUp = Func(VM, RtUpI) - Num

*   Find the root
  10  Continue
        Itr = Itr + 1
        RtSec2 = ( RtLoI * FncUp - RtUpI * FncLo ) / ( FncUp - FncLo )
        FncSec = Func(VM, RtSec2) - Num
        RtLoI = RtUpI
        FncLo = FncUp
        RtUpI = RtSec2
        FncUp = FncSec
*   Converge Judgement
      If ( (Itr.LT.ItrMax).And.( DAbs(RtUpI-RtLoI).GT.DevX.Or.
     $      (DAbs(FncUp).GT.DevY.And.(FncUp-FncLo).GT.DevY))) then
*     Not converged
        Go To 10
      Else If ( (Itr.GE.ItrMax).And.( DAbs(RtUpI-RtLoI).GT.DevX.Or.
     $      (DAbs(FncUp).GT.DevY.And.(FncUp-FncLo).GT.DevY))) then
*     Not converged but reached the maximun iteration
        Print *, 'Error Info in Function [RtSec2]'
        Print *, 'Not converged but reached the maximun iteration'
        Print *, 'Last Iteration Information:'
        Print *, 'Upper Guess: ', RtUpI, '  Lower Guess: ', RtLoI,
     $           'Upper Func: ', FncUp, '  Lower Guess: ', FncLo
        IStat = -1
      Else
        Return
      End If

      Call Err
      Return
      End Function RtSec2

*-----------------------------------------------------------------------
*
      Function Itg5P1(Func, IntgLo, IntgUp, IGridN)
*
*     Purpose: Integral using Bode's method (Func(Var))
*
*-- Variables
*
      Implicit None
*
      Double Precision  Itg5P1, Func, IntgLo, IntgUp
      Integer           IGridN
      External          Func
*
*   Func      The function integrated
*   IntgUp    Upper limit of the integral
*   InteLo    Lower limit of the integral
*
*-- Internal Variables
*
*   Decleared elsewere
      Integer           IFlr
      External          IFlr
*   Dummy
      Integer           I
*   Iteration Number
      Integer           Itr
*   Grid Seperation
      Double Precision  H
*
*-----------------------------------------------------------------------

*   Redefining Integral grids and make the separation
      Itr = IFlr(DBLE(IGridN) / 4.0D0)
      H = (IntgUp - IntgLo) / (4.0D0 * DBLE(Itr))

*   Initial and final point calculation
      Itg5P1 = 7.0D0 * (Func(IntgLo) - Func(IntgUp))

*   Internal grid point calculation
      Do 10 I = 1, Itr
        Itg5P1 = Itg5P1 + 32.0D0 * Func(IntgLo + DBLE(I*4-3) * H)
     $                  + 12.0D0 * Func(IntgLo + DBLE(I*4-2) * H)
     $                  + 32.0D0 * Func(IntgLo + DBLE(I*4-1) * H)
     $                  + 14.0D0 * Func(IntgLo + DBLE(I*4  ) * H)
  10  Continue

*   Coefficient multiplication
      Itg5P1 = Itg5P1 * H * 2.0D0 / 45.0D0

      Call Err
      Return
      End Function

*-----------------------------------------------------------------------
*
C     Function Itg5P2(Func, VM, IntgLo, IntgUp, IGridN)
*
*     Purpose: Integral using Bode's method (Func(VM, VarMain,VarInt))
*
*-- Variables
*
C     Implicit None
*
C     Double Precision  Itg5P2, Func, IntgLo, IntgUp, VM
C     Integer           IGridN
C     External          Func
*
*   Func      The function integrated
*   IntgUp    Upper limit of the integral
*   InteLo    Lower limit of the integral
*   VM        Main Variable but not used in the integral
*
*-- Internal Variables
*
*   Decleared elsewere
C     Integer           IFlr
C     External          IFlr
*   Dummy
C     Integer           I
*   Iteration Number
C     Integer           Itr
*   Grid Seperation
C     Double Precision  H
*
*-----------------------------------------------------------------------

*   Redefining Integral grids and make the separation
C     Itr = IFlr(DBLE(IGridN) / 4.0D0)
C     H = (IntgUp - IntgLo) / (4.0D0 * DBLE(Itr))

*   Initial and final point calculation
C     Itg5P2 = 7.0D0 * (Func(VM, IntgLo) - Func(VM, IntgUp))

*   Internal grid point calculation
C     Do 10 I = 1, Itr
C       Itg5P2 = Itg5P2 + 32.0D0 * Func(VM, IntgLo + DBLE(I*4-3) * H)
C    $                  + 12.0D0 * Func(VM, IntgLo + DBLE(I*4-2) * H)
C    $                  + 32.0D0 * Func(VM, IntgLo + DBLE(I*4-1) * H)
C    $                  + 14.0D0 * Func(VM, IntgLo + DBLE(I*4  ) * H)
C 10  Continue

*   Coefficient multiplication
C     Itg5P2 = Itg5P2 * H * 2.0D0 / 45.0D0

C     Call Err
C     Return
C     End Function

*-----------------------------------------------------------------------
*
      Function Itg5P2(Func, VM, IntgLo, IntgUp, IGridN)
*
*     Purpose: Integral using Bode's method (Func(VM, VarMain,VarInt))
*
*-- Variables
*
      Implicit None
*
      Double Precision  Itg5P2, Func, IntgLo, IntgUp, VM
      Integer           IGridN
      External          Func
*
*   Func      The function integrated
*   IntgUp    Upper limit of the integral
*   InteLo    Lower limit of the integral
*   VM        Main Variable but not used in the integral
*
*-- Internal Variables
*
*   Decleared elsewere
      Integer           IFlr
      External          IFlr
*   Dummy
      Integer           I
*   Iteration Number
      Integer           Itr
*   Grid Seperation
      Double Precision  H
*
*-----------------------------------------------------------------------

*   Redefining Integral grids and make the separation
      Itr = IFlr(DBLE(IGridN) / 4.0D0)
      H = DSqrt(IntgUp - IntgLo) / (4.0D0 * DBLE(Itr))

*   Initial and final point calculation
      Itg5P2 = 7.0D0 * (- 2.0D0 * DSqrt(IntgUp-IntgLo)*Func(VM, IntgUp))

*   Internal grid point calculation
      Do 10 I = 1, Itr
        Itg5P2 = Itg5P2 + 32.0D0 * Func(VM, (DBLE(I*4-3) * H)**2.0D0 +
     $                    IntgLo)
     $                  + 12.0D0 * Func(VM, (DBLE(I*4-2) * H)**2.0D0 +
     $                    IntgLo)
     $                  + 32.0D0 * Func(VM, (DBLE(I*4-1) * H)**2.0D0 +
     $                    IntgLo)
     $                  + 14.0D0 * Func(VM, (DBLE(I*4  ) * H)**2.0D0 +
     $                    IntgLo)
  10  Continue

*   Coefficient multiplication
      Itg5P2 = Itg5P2 * H * 4.0D0 / 45.0D0

      Call Err
      Return
      End Function

*-----------------------------------------------------------------------
*
      Function Dv15P1(Func, Var, Dev)
*
*     Purpose: Calculate the first derviation of a function with Boole's
*              rule (For only one variable function)
*
      Implicit None
*
*-- Variables
      Double Precision  Dv15P1, Func, Var, Dev
      External          Func
*
*   Dev     The seperation of the calculation points
*
*-----------------------------------------------------------------------

      Dv15P1 = (Func(Var-2.0D0*Dev) - 8.0D0 * Func(Var-Dev)
     $        - Func(Var+2.0D0*Dev) + 8.0D0 * Func(Var+Dev))
     $         / (12.0D0 * Dev)

      End Function Dv15P1

*-----------------------------------------------------------------------
*
      Function Dv25P1(Func, Var, Dev)
*
*     Purpose: Calculate the second derviation of a function with
*              Boole's rule (For only one variable function)
*
      Implicit None
*
*-- Variables
      Double Precision  Dv25P1, Func, Var, Dev
      External          Func
*
*   Dev     The seperation of the calculation points
*
*-----------------------------------------------------------------------

      Dv25P1 = (- Func(Var-2.0D0*Dev) + 16.0D0 * Func(Var-Dev)
     $          - Func(Var+2.0D0*Dev) + 16.0D0 * Func(Var+Dev)
     $          - 30.0D0 * Func(Var)) / (12.0D0 * Dev * Dev)

      End Function Dv25P1

*-----------------------------------------------------------------------
*
      Function IFlr(Var)
*
*     Purpose: Evaluate the floor of a double precision float number
*
*-- Variables
*
      Implicit None
*
      Integer           IFlr
      Double Precision  Var
*
*-----------------------------------------------------------------------

      IFlr = Int(Var)

      If (Var.LT.0.0D0) IFlr = IFlr - 1

      Return
      End Function IFlr

*-----------------------------------------------------------------------
*
      Subroutine Test0(Var)
*
      Implicit None
*
*-- Common Definitions
*
*   Write file index
      Integer           IOut
      Common /IO/       IOut
*   Error Information
      Integer           IStat
      Common /ErStat/   IStat
*   Zero Tolerence (Two values refers to the error or warning situation)
      Double Precision  Thr0, ThrW0
      Common /ZeroTh/   Thr0, ThrW0
*
*-- Variables
      Double Precision  Var
*
*-----------------------------------------------------------------------

      If (Var.LT.0) then
        If (-Var.LE.ThrW0) then
          Var = 0.0D0
        Else If (-Var.LE.Thr0) then
      Write(IOut,*)'Tested variable less than 0 but larger than 1.0D-15'
          Write(IOut,*) 'Variable value: ', Var
          Var = 0.0D0
        Else
          Write(IOut,*) 'Tested variable less than 0. Error return.'
          Write(IOut,*) 'Variable value: ', Var
          IStat = 1
          Return
        End If
      End If

      Call Err
      Return
      End Subroutine Test0


! { dg-do compile { target { i?86-*-* x86_64-*-* } } }
! { dg-options "-O3 -mavx" }
!
! PR fortran/50875.f90

module test

  implicit none

  integer, parameter :: dp=kind(1.d0)

  integer :: P = 2

  real(kind=dp), allocatable :: real_array_A(:),real_array_B(:,:)
  complex(kind=dp), allocatable :: cmplx_array_A(:)

contains

  subroutine routine_A

    integer :: i

    allocate(cmplx_array_A(P),real_array_B(P,P),real_array_A(P))

    real_array_A = 1
    real_array_B = 1

    do i = 1, p
       cmplx_array_A = cmplx(real_array_B(:,i),0.0_dp,dp)
       cmplx_array_A = cmplx_array_A * exp(cmplx(0.0_dp,real_array_A+1))
    end do

    deallocate(cmplx_array_A,real_array_B,real_array_A)

  end subroutine routine_A

end module test


program runge_kutta_fehlberg
  !! A mini-application for rocket motor simulation:
  !! demonstrating an object-oriented, functional programming style in Fortran 2018
  !! with automatic graphing of results in gnuplot for comparison against a legacy,
  !! procedural simulator written in Fortran 90.
  use motor_interface, only : motor_t
  use state_interface, only : state_t
  use kind_parameters, only : rkind
  implicit none

  real(rkind), parameter :: zero=0._rkind
  character(len=*), parameter :: input_file="app/rocket.inp"
  real(rkind) dt

  type(motor_t) motor
  type(state_t) state, TE !! state variables updated at each time step: mass, energy, time, and burn depth
  type(state_t), allocatable :: history(:)

  call motor%define(input_file)

  associate(chamber => motor%chamber())
    associate(gas => chamber%gas())
      call state%define(input_file, R_gas=gas%R_gas(), c_v=gas%c_v(), volume=chamber%initial_volume(), time=zero, burn_depth=zero)
    end associate
  end associate

  dt = motor%dt()
    history = [state]
    block
      real(rkind), parameter :: B2(*) = [2._rkind/9._rkind]
      real(rkind), parameter :: B3(*) = [1._rkind/12._rkind, 1._rkind/4._rkind]
      real(rkind), parameter :: B4(*) = [69._rkind/128._rkind, -243._rkind/128._rkind, 135._rkind/64._rkind]
      real(rkind), parameter :: B5(*) = [-17._rkind/12._rkind, 27._rkind/4._rkind, -27._rkind/5._rkind, 16._rkind/15._rkind]
      real(rkind), parameter :: B6(*) = &
        [65._rkind/432._rkind, -5._rkind/16._rkind, 13._rkind/16._rkind, 4._rkind/27._rkind, 5._rkind/144._rkind]
      real(rkind), parameter :: CH(*) = &
        [47._rkind/450._rkind, 0._rkind, 12._rkind/25._rkind, 32._rkind/225._rkind, 1._rkind/30._rkind, 6._rkind/25._rkind]
        real(rkind), parameter :: CT(*) = &
          [-1._rkind/150._rkind, 0._rkind, 3._rkind/100._rkind, -16._rkind/75._rkind, -1._rkind/20._rkind, 6._rkind/25._rkind]
        real(rkind), allocatable :: TE_tol(:)

      TE_tol =  [2.7498406275424329E-003_rkind,   16507.011164154210_rkind,        1.7452907228589804E-006_rkind]

      do while(state%time() < motor%t_max())
        associate(k1 => motor%d_dt(state)*dt)
          associate(k2 => motor%d_dt(state + k1*B2(1))*dt)
            associate(k3 => motor%d_dt(state + k1*B3(1) + k2*B3(2))*dt)
              associate(k4 => motor%d_dt(state + k1*B4(1)  + k2*B4(2)+ k3*B4(3))*dt)
                associate(k5 => motor%d_dt(state + k1*B5(1) + k2*B5(2) + k3*B5(3) + k4*B5(4))*dt)
                  associate(k6 => motor%d_dt(state + k1*B6(1) + k2*B6(2) + k3*B6(3) + k4*B6(4) + k5*B6(5))*dt)
                    TE = k1*CT(1) + k2*CT(2) + k3*CT(3) + k4*CT(4) + k5*CT(5) + k6*CT(6)
                    associate(TE_abs => TE%absolute())
                      if (any(TE_abs > TE_tol)) then
                        dt = minval(0.9_rkind*dt*(TE_tol/TE_abs)**.2_rkind)
                        cycle
                      else
                        state = state + k1*CH(1) + k2*CH(2) + k3*CH(3) + k4*CH(4) + k5*CH(5) + k6*CH(6)
                      end if
                    end associate
                  end associate
                end associate
              end associate
            end associate
          end associate
        end associate
        history = [history, state]
      end do
    end block

  call write_results
  call graph_if_requested

contains

  subroutine write_history(results, file_name)
    use assertions_interface, only : assert, max_errmsg_len
    use results_interface, only : results_t
    type(results_t), intent(in) :: results
    character(len=*), intent(in) :: file_name
    character(len=max_errmsg_len) error_message
    integer io_status, file_unit
    integer, parameter :: success = 0

    open(newunit=file_unit, file=file_name, status="unknown", iostat=io_status, iomsg=error_message)
    call assert(io_status == success, "main (opening "//file_name//"): io_status == success", diagnostic_data=error_message)
    write(unit=file_unit, fmt=*) results
    close(file_unit)
  end subroutine

  subroutine write_results
    use results_interface, only : results_t
    use refurbished_rocket_module, only : refurbished_rocket
    character(len=*), parameter :: header(*) = &
        [character(len=len("temperature")) :: "time", "pressure", "temperature", "mdotos", "thrust", "volume"]

    interface
     function legacy_rocket(input_file)
       import results_t
       implicit none
       character(len=*), intent(in) :: input_file
       type(results_t) legacy_rocket
     end function
   end interface

    associate( &
      modern_results => results_t(header, motor%derived_variables(history)), &
      legacy_results => legacy_rocket(input_file), &
      refurbished_results => refurbished_rocket(input_file) &
    )
      call write_history(modern_results, "rocket.out")
      call write_history(legacy_results, "legacy_rocket.out")
      call write_history(refurbished_results, "refurbished_rocket.out")
    end associate
  end subroutine

  subroutine graph_if_requested()
    use command_line_interface, only : command_line_t
    type(command_line_t) command
    character(len=*), parameter :: graph(*) = [character(len=len("--graph")):: "--graph", "-g", "/graph", "/g"]

    if (command%argument_present(graph)) call execute_command_line('gnuplot app/gnuplot.inp')
  end subroutine
end program


      REAL FUNCTION slPAV ( V1, V2 )
*+
*     - - - -
*      P A V
*     - - - -
*
*  Position angle of one celestial direction with respect to another.
*
*  (single precision)
*
*  Given:
*     V1    r(3)    direction cosines of one point
*     V2    r(3)    direction cosines of the other point
*
*  (The coordinate frames correspond to RA,Dec, Long,Lat etc.)
*
*  The result is the bearing (position angle), in radians, of point
*  V2 with respect to point V1.  It is in the range +/- pi.  The
*  sense is such that if V2 is a small distance east of V1, the
*  bearing is about +pi/2.  Zero is returned if the two points
*  are coincident.
*
*  V1 and V2 do not have to be unit vectors.
*
*  The routine slBEAR performs an equivalent function except
*  that the points are specified in the form of spherical
*  coordinates.
*
*  Called:  slDPAV
*
*  Last revision:   11 September 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL V1(3), V2(3)

      INTEGER I
      DOUBLE PRECISION D1(3), D2(3)

      DOUBLE PRECISION slDPAV

*  Call the double precision version.
      DO I=1,3
         D1(I) = V1(I)
         D2(I) = V2(I)
      END DO
      slPAV = REAL(slDPAV(D1,D2))

      END


submodule(euler_interface_m) euler_prob_0051_m
    implicit none

    ! Nicely done by my two little wheels, int_2_arr and arr_2_int!
    !---------------------------------------------------------------------------

contains

    module character(len=20) function euler0051()
        write (euler0051, "(i20)") answer()
    end function euler0051

    function answer() result(ret)
        use euler_primes_m, only: sieve_of_Eratosthenes
        implicit none

        integer, parameter :: PRIME_START = 100000, PRIME_END = 999999
        integer :: i, j, s, idx, tmp, p_knt, c_knt, ret
        integer, allocatable :: prime(:), arr(:)
        logical, allocatable :: is_prime(:)

        call sieve_of_Eratosthenes(PRIME_END, is_prime)
        prime = pack([(i, i=0, PRIME_END)], is_prime)
        prime = pack(prime, prime > PRIME_START)

        outer: do idx = 1, size(prime)
            call int_2_arr(prime(idx), arr)
            associate (k => [(count(arr == i), i=0, 2)])
                j = findloc([(mod(k(i), 3) == 0, i=1, 3)], value=.true., dim=1)
                if (j == 0) cycle outer
            end associate

            p_knt = 0; c_knt = 0
            associate (r => pack([(i, i=1, size(arr))], arr == arr(j)))
                s = 0; if (any(r == 1)) s = 1
                inner: do j = s, 9
                    arr(r) = j
                    call arr_2_int(arr, tmp)
                    if (is_prime(tmp)) then
                        p_knt = p_knt + 1
                    else
                        c_knt = c_knt + 1
                    end if
                    if (p_knt >= 8) exit outer
                    if (c_knt >= 3) exit inner
                end do inner
            end associate
        end do outer
        ret = prime(idx)
    end function answer

end submodule euler_prob_0051_m


FUNCTION chyper(point, kk, ll, mm, nn, ifault) RESULT(fn_val)

! Code converted using TO_F90 by Alan Miller
! Date: 2002-09-24  Time: 22:57:18

!     Cumulative hypergeometric probabilities

!     ALGORITHM AS R77  APPL. STATIST. (1989), VOL.38, NO.1
!     Replaces AS 59 and AS 152
!     Incorporates AS R86 from vol.40(2)

!     Auxiliary routines required: ALNFAC (AS 245), ALNORM (AS 66)

IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)

LOGICAL, INTENT(IN)   :: point
INTEGER, INTENT(IN)   :: kk
INTEGER, INTENT(IN)   :: ll
INTEGER, INTENT(IN)   :: mm
INTEGER, INTENT(IN)   :: nn
INTEGER, INTENT(OUT)  :: ifault
REAL(dp)              :: fn_val

INTEGER   :: k, l, m, n, i, j, nl, kl, mnkl
REAL(dp)  :: p, pt,  alnfac,  mean, sig, alnorm, arg
LOGICAL   :: dir
REAL(dp), PARAMETER  :: zero = 0.0_dp, half = 0.5_dp, one = 1.0_dp
INTEGER, PARAMETER   :: mvbig = 1000, mbig = 600
REAL(dp), PARAMETER  :: elimit = -88.0_dp, sxteen = 16.0_dp, scale = 1.0D35, &
                      rootpi = 2.506628274631001_dp, hundrd = 100.0_dp

k = kk + 1
l = ll + 1
m = mm + 1
n = nn + 1
dir = .true.

!     Check arguments are within permitted limits

ifault = 1
fn_val = zero
IF (n < 1 .OR. m < n .OR. k < 1 .OR. k > m) RETURN

ifault = 2
IF (l < 1 .OR. k-l > m-n) RETURN
IF (.NOT. point) fn_val = one
IF (l > n .OR. l > k) RETURN
ifault = 0
fn_val = one
IF (k == 1 .OR. k == m .OR. n == 1 .OR. n == m) RETURN
IF (.NOT. point .AND. ll == MIN(kk, nn)) RETURN

p = REAL(nn, KIND=dp) / REAL(mm - nn, KIND=dp)
IF (REAL(MIN(kk, mm-kk)) > sxteen * MAX(p, one/p) .AND.  &
      mm > mvbig .AND. elimit > -hundrd) THEN

!     Use a normal approximation

  mean = REAL(kk) * REAL(nn) / REAL(mm)
  sig = SQRT(mean * (REAL(mm-nn) / REAL(mm)) * (REAL(mm-kk) / (REAL(mm-1))))
  IF (point) THEN
    arg = -half * (((REAL(ll) - mean) / sig)**2)
    fn_val = zero
    IF (arg >= elimit) fn_val = EXP(arg) / (sig * rootpi)
  ELSE
    fn_val = alnorm((REAL(ll) + half - mean) / sig, .false.)
  END IF

ELSE

!     Calculate exact hypergeometric probabilities.
!     Interchange K and N if this saves calculations.

  IF (MIN(k-1, m-k) > MIN(n-1, m-n)) THEN
    i = k
    k = n
    n = i
  END IF
  IF (m-k < k-1) THEN
    dir = .NOT. dir
    l = n - l + 1
    k = m - k + 1
  END IF

  IF (mm > mbig) THEN

!     Take logarithms of factorials.

    p = alnfac(nn) - alnfac(mm) + alnfac(mm-kk) + alnfac(kk) +  &
        alnfac(mm-nn) - alnfac(ll) - alnfac(nn-ll) - alnfac(kk-ll)  &
        - alnfac(mm-nn-kk+ll)
    fn_val = zero
    IF (p >= elimit) fn_val = EXP(p)
  ELSE

!     Use Freeman/Lund algorithm

    DO  i = 1, l-1
      fn_val = fn_val * REAL(k-i) * REAL(n-i) / (REAL(l-i) * REAL(m-i))
    END DO
    IF (l /= k) THEN
      j = m - n + l
      DO  i = l, k-1
        fn_val = fn_val * REAL(j-i) / REAL(m-i)
      END DO
    END IF

  END IF

  IF (point) RETURN
  IF (fn_val == zero) THEN

!     We must recompute the point probability since it has underflowed.

    IF (mm <= mbig) p = alnfac(nn) - alnfac(mm) + alnfac(kk) +  &
        alnfac(mm-nn) - alnfac(ll) - alnfac(nn-ll) - alnfac(kk-ll) -  &
        alnfac(mm-nn-kk+ll) + alnfac(mm-kk)
    p = p + LOG(scale)
    IF (p < elimit) THEN
      ifault = 3
      IF (ll > REAL(nn*kk + nn + kk +1)/(mm +2)) fn_val = one
      RETURN
    ELSE
      p = EXP(p)
    END IF
  ELSE

!     Scale up at this point.

    p = fn_val * scale
  END IF

  pt = zero
  nl = n - l
  kl = k - l
  mnkl = m - n - kl + 1
  IF (l <= kl) THEN
    DO  i = 1, l-1
      p = p * REAL(l-i) * REAL(mnkl-i) / (REAL(nl+i) * REAL(kl+i))
      pt = pt + p
    END DO
    IF (p == zero) ifault = 3
  ELSE
    dir = .NOT. dir
    DO  j = 0, kl-1
      p = p * REAL(nl-j) * REAL(kl-j) / (REAL(l+j) * REAL(mnkl+j))
      pt = pt + p
    END DO
    IF (p == zero) ifault = 3
  END IF

  IF (dir) THEN
    fn_val = fn_val + (pt / scale)
  ELSE
    fn_val = one - (pt / scale)
  END IF

END IF

END FUNCTION chyper


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!! Copyright (c) 1997 Neil N. Carlson
!!
!! This file is part of MFE1 which is released under the MIT license.  See the
!! file LICENSE or visit http://opensource.org/licenses/MIT for details.
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module problem_data

  use mfe_constants, only: wp
  implicit none
  private

  ! Change of variable functions
  public  :: c_of_u, u_of_c
  private :: c_of_u_scalar, c_of_u_vector, u_of_c_scalar, u_of_c_vector

  real(kind=wp), save, public :: mu, u_scale = 1.0_wp, u_shift = 0.0_wp, t_scale

  interface c_of_u
    module procedure c_of_u_scalar, c_of_u_vector
  end interface

  interface u_of_c
    module procedure u_of_c_scalar, u_of_c_vector
  end interface

  contains

   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   !!
   !!  C_OF_U -- Compute c(u).
   !!
   !!  Using a Newton iteration, this routine inverts the function
   !!
   !!	U(C) = (C/MU + log(C/MU) - U_SHIFT) / U_SCALE.
   !!
   !!  This is done by writing
   !!
   !!	U_SCALE * U + U_SHIFT = (C/MU) + log(C/MU)
   !!
   !!  and then inverting the function y = x + log(x).
   !!
   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    function c_of_u_scalar (u) result (c)

      real(kind=wp), intent(in) :: u
      real(kind=wp) :: c

      integer :: k
      real(kind=wp) :: y
      integer, parameter :: NITR = 4

      y = u_scale * u + u_shift

      if (y < 1.0_wp) then
        c = exp(y - 1.0_wp)
      else
        c = y
      end if

      y = y + 1.0_wp

      do k = 1, NITR
        c = c * (y - log(c)) / (1.0_wp + c)
      end do

      c = mu * c

    end function c_of_u_scalar

    function c_of_u_vector (u) result (c)

      real(kind=wp), dimension(:), intent(in) :: u
      real(kind=wp), dimension(size(u)) :: c

      integer :: k
      real(kind=wp), dimension(size(u)) :: y
      integer, parameter :: NITR = 4

      y = u_scale * u + u_shift

      where (y < 1.0_wp)
        c = exp(y - 1.0_wp)
      elsewhere
        c = y
      end where

      y = y + 1.0_wp

      do k = 1, NITR
        c = c * (y - log(c)) / (1.0_wp + c)
      end do

      c = mu * c

    end function c_of_u_vector

   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   !!
   !!  U_OF_C -- Compute u(c).
   !!
   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    function u_of_c_scalar (c) result (u)

      real(kind=wp), intent(in) :: c
      real(kind=wp) :: u

      u = ((c/mu) + log(c/mu) - u_shift) / u_scale

    end function u_of_c_scalar

    function u_of_c_vector (c) result (u)

      real(kind=wp), dimension(:), intent(in) :: c
      real(kind=wp), dimension(size(c)) :: u

      u = ((c/mu) + log(c/mu) - u_shift) / u_scale

    end function u_of_c_vector

end module problem_data

module problem_init

  use mfe_constants, only: wp
  use problem_data
  use common_io
  implicit none
  private

  public :: read_problem_data

  contains

   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   !!
   !!  READ_PROBLEM_DATA
   !!
   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    subroutine read_problem_data ()

      call read_tagged_data (mu, "Transformation parameter MU")
      call read_tagged_data (t_scale, "Time scale factor")

    end subroutine read_problem_data

end module problem_init

module problem_pde

  use mfe_constants, only: wp
  use problem_data
  use local_arrays
  use local_laplacian
  implicit none
  private

  public  :: pde_rhs
  private :: b_of_u

  contains

   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   !!
   !!  PDE_RHS --
   !!
   !!  RHS inner products for the (transformed) nonlinear diffusion problem
   !!
   !!     dc/dt = Div((1 + c) Grad(c)).
   !!
   !!  The equation is transformed via the change of variable
   !!
   !!     U_SCALE * u + U_SHIFT = (c / MU) + log(c / MU)
   !!
   !!  With a scaled time T = t / T_SCALE the final equation is
   !!
   !!     du/dT = T_SCALE * a(u) * Lapl(u) + (T_SCALE * U_SCALE) * b(u) * |Grad(u)|**2
   !!
   !!  where
   !!
   !!     a(u) = 1 + c(u),   b(u) = MU + (1 - MU) / (1 + c(u)/MU)**2.
   !!
   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    subroutine pde_rhs (t)

      real(kind=wp), intent(in) :: t

      real(kind=wp) :: fac
      real(kind=wp), dimension(2,ncell) :: visc
      real(kind=wp), dimension(ncell) :: b_phi_1, b_phi_2

      real(kind=wp), parameter ::      & ! 3PT GAUSSIAN QUADRATURE PARAMETERS
          w1 = 0.2464717596168727_wp,  & ! (5 / 18) * (Sqrt[5] + Sqrt[3]) / (2 Sqrt[5])
          w2 = 0.2222222222222222_wp,  & ! (4 / 9)  * (1 / 2)
          w3 = 0.03130601816090511_wp, & ! (5 / 18) * (Sqrt[5] - Sqrt[3]) / (2 Sqrt[5])
          c1 = 0.8872983346207417_wp,  & ! (Sqrt[5] + Sqrt[3]) / (2 Sqrt[5])
          c2 = 0.1127016653792583_wp     ! (Sqrt[5] - Sqrt[3]) / (2 Sqrt[5])

      fac = u_scale * t_scale

      b_phi_1 = w1 * b_of_u (c1 * u(1,:) % u + c2 * u(2,:) % u)  + &
                w2 * b_of_u (0.5_wp * (u(1,:) % u + u(2,:) % u)) + &
                w3 * b_of_u (c2 * u(1,:) % u + c1 * u(2,:) % u)

      b_phi_2 = w3 * b_of_u (c1 * u(1,:) % u + c2 * u(2,:) % u)  + &
                w2 * b_of_u (0.5_wp * (u(1,:) % u + u(2,:) % u)) + &
                w1 * b_of_u (c2 * u(1,:) % u + c1 * u(2,:) % u)

      r(1,:) % x = ((fac * dx * dudx**2) * b_phi_1) * n % x
      r(1,:) % u = ((fac * dx * dudx**2) * b_phi_1) * n % u

      r(2,:) % x = ((fac * dx * dudx**2) * b_phi_2) * n % x
      r(2,:) % u = ((fac * dx * dudx**2) * b_phi_2) * n % u

      ! Diffusion coefficients at the cell endpoints.
      visc(1,:) = t_scale * (1.0_wp + c_of_u (u(1,:) % u))
      visc(2,:) = t_scale * (1.0_wp + c_of_u (u(2,:) % u))

      call laplacian (coef=visc)

    end subroutine pde_rhs

    function b_of_u (u) result (b)

      real(kind=wp), dimension(:), intent(in) :: u
      real(kind=wp), dimension(size(u)) :: b

      b = mu + (1.0_wp - mu) / (1.0_wp + c_of_u (u) / mu)**2

    end function b_of_u

end module problem_pde


*     SB03SD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDC, LDT, LDU, LDX
      PARAMETER        ( LDA = NMAX, LDC = NMAX, LDT = NMAX,
     $                   LDU = NMAX, LDX = NMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX*NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 3, 2*NMAX*NMAX ) +
     $                                 NMAX*NMAX + 2*NMAX )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION FERR, RCOND, SCALE, SEPD
      INTEGER          I, INFO1, INFO2, J, N
      CHARACTER*1      DICO, FACT, JOB, LYAPUN, TRANA, TRANAT, UPLO
*     .. Local Arrays ..
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), C(LDC,NMAX), DWORK(LDWORK),
     $                 T(LDT,NMAX), U(LDU,NMAX), X(LDX,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         DLACPY, MA02ED, MB01RU, SB03MD, SB03SD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
      DICO = 'D'
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOB, FACT, TRANA, UPLO, LYAPUN
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * )
     $                         ( ( U(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,N )
         CALL DLACPY( 'Full', N, N, A, LDA, T, LDT )
         CALL DLACPY( 'Full', N, N, C, LDC, X, LDX )
*        Solve the discrete-time Lyapunov matrix equation.
         CALL SB03MD( DICO, 'X', FACT, TRANA, N, T, LDT, U, LDU, X, LDX,
     $                SCALE, SEPD, FERR, DWORK(1), DWORK(N+1), IWORK,
     $                DWORK(2*N+1), LDWORK-2*N, INFO1 )
*
         IF ( INFO1.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99996 )
            DO 10 I = 1, N
               WRITE ( NOUT, FMT = 99995 ) ( X(I,J), J = 1,N )
   10       CONTINUE
            IF ( LSAME( LYAPUN, 'R' ) ) THEN
               IF( LSAME( TRANA, 'N' )  ) THEN
                  TRANAT = 'T'
               ELSE
                  TRANAT = 'N'
               END IF
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, X, LDX,
     $                      U, LDU, X, LDX, DWORK, N*N, INFO2 )
               CALL MA02ED( UPLO, N, X, LDX )
               CALL MB01RU( UPLO, TRANAT, N, N, ZERO, ONE, C, LDC,
     $                      U, LDU, C, LDC, DWORK, N*N, INFO2 )
            END IF
*           Estimate the condition and error bound on the solution.
            CALL SB03SD( JOB, 'F', TRANA, UPLO, LYAPUN, N, SCALE, A,
     $                   LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD,
     $                   RCOND, FERR, IWORK, DWORK, LDWORK, INFO2 )
*
            IF ( INFO2.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO2
            ELSE
               WRITE ( NOUT, FMT = 99993 ) SCALE
               WRITE ( NOUT, FMT = 99992 ) SEPD
               WRITE ( NOUT, FMT = 99991 ) RCOND
               WRITE ( NOUT, FMT = 99990 ) FERR
            END IF
         ELSE
            WRITE ( NOUT, FMT = 99998 ) INFO1
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB03SD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB03MD =',I2)
99997 FORMAT (' INFO on exit from SB03SD =',I2)
99996 FORMAT (' The solution matrix X is')
99995 FORMAT (20(1X,F8.4))
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' Scaling factor = ',F8.4)
99992 FORMAT (/' Estimated separation = ',F8.4)
99991 FORMAT (/' Estimated reciprocal condition number = ',F8.4)
99990 FORMAT (/' Estimated error bound = ',F8.4)
      END


! =================================================
!   Calculate max deviation between two matrices.
! =================================================

subroutine max_deviation(mat, mat0, err)

    use coordinates, only: Nx, Ny
    use conv_config, only: conv_cr
    implicit none

    real*8, intent(in)  :: mat(Nx,Ny)
    real*8, intent(in)  :: mat0(Nx,Ny)
    real*8, intent(out) :: err

    real*8, dimension(Nx*Ny) :: vec, vec0, rand

    vec  = reshape(mat,  (/Nx*Ny/))
    vec0 = reshape(mat0, (/Nx*Ny/))
    call random_seed()
    call random_number(rand)
    err  = maxval(abs(vec - vec0)/(vec0 + 0.001*conv_cr*rand))

end subroutine