submodule (stdlib_math) stdlib_math_logspace

implicit none

contains

    module procedure logspace_1_rsp_default
      res = logspace(start, end, DEFAULT_LOGSPACE_LENGTH, real(DEFAULT_LOGSPACE_BASE, sp))
    end procedure
    module procedure logspace_1_rdp_default
      res = logspace(start, end, DEFAULT_LOGSPACE_LENGTH, real(DEFAULT_LOGSPACE_BASE, dp))
    end procedure
    module procedure logspace_1_rqp_default
      res = logspace(start, end, DEFAULT_LOGSPACE_LENGTH, real(DEFAULT_LOGSPACE_BASE, qp))
    end procedure
    module procedure logspace_1_csp_default
      res = logspace(start, end, DEFAULT_LOGSPACE_LENGTH, real(DEFAULT_LOGSPACE_BASE, sp))
    end procedure
    module procedure logspace_1_cdp_default
      res = logspace(start, end, DEFAULT_LOGSPACE_LENGTH, real(DEFAULT_LOGSPACE_BASE, dp))
    end procedure
    module procedure logspace_1_cqp_default
      res = logspace(start, end, DEFAULT_LOGSPACE_LENGTH, real(DEFAULT_LOGSPACE_BASE, qp))
    end procedure
    module procedure logspace_1_iint32_default
      res = logspace(start, end, DEFAULT_LOGSPACE_LENGTH, DEFAULT_LOGSPACE_BASE)
    end procedure

    module procedure logspace_1_rsp_n
      res = logspace(start, end, n, real(DEFAULT_LOGSPACE_BASE, sp))
    end procedure
    module procedure logspace_1_rdp_n
      res = logspace(start, end, n, real(DEFAULT_LOGSPACE_BASE, dp))
    end procedure
    module procedure logspace_1_rqp_n
      res = logspace(start, end, n, real(DEFAULT_LOGSPACE_BASE, qp))
    end procedure
    module procedure logspace_1_csp_n
      res = logspace(start, end, n, real(DEFAULT_LOGSPACE_BASE, sp))
    end procedure
    module procedure logspace_1_cdp_n
      res = logspace(start, end, n, real(DEFAULT_LOGSPACE_BASE, dp))
    end procedure
    module procedure logspace_1_cqp_n
      res = logspace(start, end, n, real(DEFAULT_LOGSPACE_BASE, qp))
    end procedure
    module procedure logspace_1_iint32_n
      res = logspace(start, end, n, DEFAULT_LOGSPACE_BASE)
    end procedure

    module procedure logspace_1_rsp_n_rbase
      real(sp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_rsp_n_cbase
      real(sp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_rsp_n_ibase
      real(sp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure
    module procedure logspace_1_rdp_n_rbase
      real(dp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_rdp_n_cbase
      real(dp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_rdp_n_ibase
      real(dp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure
    module procedure logspace_1_rqp_n_rbase
      real(qp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_rqp_n_cbase
      real(qp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_rqp_n_ibase
      real(qp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure
    module procedure logspace_1_csp_n_rbase
      complex(sp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_csp_n_cbase
      complex(sp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_csp_n_ibase
      complex(sp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure
    module procedure logspace_1_cdp_n_rbase
      complex(dp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_cdp_n_cbase
      complex(dp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_cdp_n_ibase
      complex(dp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure
    module procedure logspace_1_cqp_n_rbase
      complex(qp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_cqp_n_cbase
      complex(qp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_cqp_n_ibase
      complex(qp) :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure
    ! Generate logarithmically spaced sequence from qp base to the powers
    ! of qp start and end. [base^start, ... , base^end]
    ! RName = logspace_1_cqp_n_ibase
    module procedure logspace_1_iint32_n_rspbase
      integer :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_iint32_n_cspbase
      integer :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure
    module procedure logspace_1_iint32_n_rdpbase
      integer :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_iint32_n_cdpbase
      integer :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure
    module procedure logspace_1_iint32_n_rqpbase
      integer :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_iint32_n_cqpbase
      integer :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

    module procedure logspace_1_iint32_n_ibase
      integer :: exponents(max(n, 0))
      exponents = linspace(start, end, n)
      res = base ** exponents
    end procedure

end submodule


c     program DRSC2FIT
c>> 1996-07-03 DRSC2FIT Krogh  Changed formats for C conversion.
c>> 1994-10-19 DRSC2FIT Krogh  Changes to use M77CON
c>> 1992-04-27 DRSC2FIT CLL Declared all variables.
c>> 1987-12-09 DRSC2FIT Lawson  Initial Code.
c     Demonstration driver for SC2FIT.
c     C. L. Lawson, JPL, Apr 13 1987, 7/23/87
c     ------------------------------------------------------------------
c--S replaces "?": DR?C2FIT, ?C2FIT, ?HINT
c     ------------------------------------------------------------------
      integer I, NB, NDERIV, NW, NXY
      parameter(NXY = 12, NB = 6, NW = 10)
      external SHINT
      real             SHINT, X(NXY), Y(NXY), SD(01), B(NB), W(NW,5)
      real             YKNOT(NB), YPKNOT(NB), R, SIGFAC, YFIT
      integer IERR
      data X / 2.E0, 4.E0, 6.E0, 8.E0,10.E0,12.E0,
     *        14.E0,16.E0,18.E0,20.E0,22.E0,24.E0/
      data Y /2.2E0,4.0E0,5.0E0,4.6E0,2.8E0,2.7E0,
     *        3.8E0,5.1E0,6.1E0,6.3E0,5.0E0,2.0E0/
      data B / 2.0E0, 6.4E0, 10.8E0, 15.2E0, 19.6E0, 24.0E0 /
      data NDERIV / 0 /
      data SD(1) / -1.E0 /
c     ------------------------------------------------------------------
      call SC2FIT(X, Y, SD, NXY, B, NB, W, NW, YKNOT,YPKNOT,SIGFAC,IERR)
      print
     *   '('' DRSC2FIT..  Demo driver for SC2FIT.  Also uses SHINT.'')'
      print'(/5x,''IERR ='',i5,'',  SIGFAC ='',f10.5//''  YKNOT() = '',
     *   6f10.5)', IERR,SIGFAC, (YKNOT(I),I=1,NB)
      print'('' YPKNOT() = '',6f10.5)', (YPKNOT(I),I=1,NB)
      print'(/''  I    X       Y       YFIT  R=Y-YFIT''/)'
      do 10 I=1,NXY
         YFIT=  SHINT(X(I), NDERIV, NB, B, YKNOT, YPKNOT)
         R=Y(I)-YFIT
         print'(1x,i2,f6.0,2f9.3,f10.3)',I,X(I),Y(I),YFIT,R
   10 continue
      stop
      end


c     program DRDC2FIT
c>> 1996-07-03 DRDC2FIT Krogh  Changed formats for C conversion.
c>> 1994-10-19 DRDC2FIT Krogh  Changes to use M77CON
c>> 1992-04-27 DRDC2FIT CLL Declared all variables.
c>> 1987-12-09 DRDC2FIT Lawson  Initial Code.
c     Demonstration driver for DC2FIT.
c     C. L. Lawson, JPL, Apr 13 1987, 7/23/87
c     ------------------------------------------------------------------
c--D replaces "?": DR?C2FIT, ?C2FIT, ?HINT
c     ------------------------------------------------------------------
      integer I, NB, NDERIV, NW, NXY
      parameter(NXY = 12, NB = 6, NW = 10)
      external DHINT
      double precision DHINT, X(NXY), Y(NXY), SD(01), B(NB), W(NW,5)
      double precision YKNOT(NB), YPKNOT(NB), R, SIGFAC, YFIT
      integer IERR
      data X / 2.D0, 4.D0, 6.D0, 8.D0,10.D0,12.D0,
     *        14.D0,16.D0,18.D0,20.D0,22.D0,24.D0/
      data Y /2.2D0,4.0D0,5.0D0,4.6D0,2.8D0,2.7D0,
     *        3.8D0,5.1D0,6.1D0,6.3D0,5.0D0,2.0D0/
      data B / 2.0D0, 6.4D0, 10.8D0, 15.2D0, 19.6D0, 24.0D0 /
      data NDERIV / 0 /
      data SD(1) / -1.D0 /
c     ------------------------------------------------------------------
      call DC2FIT(X, Y, SD, NXY, B, NB, W, NW, YKNOT,YPKNOT,SIGFAC,IERR)
      print
     *   '('' DRDC2FIT..  Demo driver for DC2FIT.  Also uses DHINT.'')'
      print'(/5x,''IERR ='',i5,'',  SIGFAC ='',f10.5//''  YKNOT() = '',
     *   6f10.5)', IERR,SIGFAC, (YKNOT(I),I=1,NB)
      print'('' YPKNOT() = '',6f10.5)', (YPKNOT(I),I=1,NB)
      print'(/''  I    X       Y       YFIT  R=Y-YFIT''/)'
      do 10 I=1,NXY
         YFIT=  DHINT(X(I), NDERIV, NB, B, YKNOT, YPKNOT)
         R=Y(I)-YFIT
         print'(1x,i2,f6.0,2f9.3,f10.3)',I,X(I),Y(I),YFIT,R
   10 continue
      stop
      end


!======================================================================!
  REAL FUNCTION Dist(xA,yA,zA,xB,yB,zB)
!----------------------------------------------------------------------!
!  Calculates distance between two points.                             !
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-----------------------------[Parameters]-----------------------------!
  REAL :: xA,yA,zA,xB,yB,zB
!--------------------------------[CVS]---------------------------------!
!  $Id: Dist.f90,v 1.5 2002/10/30 16:29:31 niceno Exp $
!  $Source: /home/muhamed/.CVSROOT/T-Rex/Library/Dist.f90,v $
!======================================================================!

  Dist=sqrt( (xA-xB)*(xA-xB) + (yA-yB)*(yA-yB) + (zA-zB)*(zA-zB) )

  END FUNCTION Dist


      program fft_with_MPI
      parameter(indx = 15)
      parameter(nx = 2**indx,maxiters=1000)
      integer comm,myid,nnodes,ierr
      double complex,allocatable,dimension(:)  :: f,g,sct,a,b,t
      integer,allocatable,dimension(:)  :: mixup
      double precision time_begin,time_end
      include 'mpif.h'

      comm = MPI_COMM_WORLD
      call MPI_init(ierr)
      call MPI_COMM_RANK(comm,myid,ierr)
      call MPI_COMM_SIZE(comm,nnodes,ierr)

      kxp = nx/nnodes
      allocate(f(kxp))
      allocate(g(kxp))
      allocate(sct(kxp))
      allocate(mixup(kxp))

      do i=1,kxp
        f(i) = cmplx(real(i),real(myid+1))
      enddo

      isign = 1
      kblok = nnodes

      time_begin =  MPI_Wtime()

      call  bitrv1(mixup,isign,indx,kxp,kblok,sct,myid)
      !do iter =1,maxiters
         call permute(f,g,mixup,indx,kxp,kblok,comm)
         call fft(f,g,isign,mixup,sct,indx,kxp,kblok,comm,myid)
      !enddo
      time_end =  MPI_Wtime()

      print *,'fft of 1-d with size= ',nx,'  took '
      print *,time_end-time_begin,' seconds for ',maxiters,' iterations'

      call MPI_FINALIZE(ierr)

      end

!kblok is the number of processors
!g is the input vector whose fft will be taken
!kxp is the length of local data

        subroutine fft(f,g,isign,mixup,sct,indx,kxp,kblok,comm,myprocid)
        double complex f,g,sct
	dimension f(kxp),g(kxp)
        dimension sct(kxp),mixup(kxp)
        integer myprocid,comm

        include 'mpif.h'

	integer dest,source,nproc,dest_id,lind,lb,ub,sign,info
	double complex t1
        integer status(MPI_STATUS_SIZE)

	nproc = kblok
	nx = 2**indx
	nxh = nx/2
	indx1 = indx !-1
	kbs = nxh/kxp
	dnx = 6.28318530717959/float(nx)
	sign = isign
	temp= log10(float(kxp))/log10(2.0)
        lind = temp

!C ---------------------------
!C inverse fourier transform
!C bit-reverse array elements to temporary
!C ---------------------------

         do  l = 1, indx1
            nxs = 2**(l - 1)
            kxs = nxs/kxp
!C ---------------------------
!C local calculation
!C ---------------------------

            if (kxs.eq.0) then
               do j = 1, kxp
                  lb = (j - 1)/nxs
                  if (lb.eq.(2*(lb/2))) then
                     f(j) = g(j+nxs)
                  else
                     f(j) = g(j-nxs)
                  endif
               enddo
!C ---------------------------
!C perform reduction
!C ---------------------------
               km = kxp/nxs
               do j = 1, kxp
                   kb = j - 1
                   lb = kb/nxs
                   if (sign .eq. -1) then
                      t1 = sct(1+km*(kb-nxs*lb))
                   else if (sign .eq.1) then
                      t1 = conjg(sct(1+km*(kb-nxs*lb)) )
                   endif

                   if (lb.eq.(2*(lb/2))) then
                      g(j) = g(j) + t1*f(j)
                   else
                      g(j) = f(j) - t1*g(j)
                   endif
                enddo
            else
!C ---------------------------
!C copy data
!C ---------------------------

                 if (btest(myprocid,l-lind-1) .eqv. .false.) then
                    dest = ibset(myprocid,l-lind-1)
                    call MPI_SEND(g,kxp,MPI_DOUBLE_COMPLEX,dest,0,comm,ierr)
                 else
                    source = ibclr(myprocid,l-lind-1)
                    call MPI_RECV(f,kxp,MPI_DOUBLE_COMPLEX,source,0,comm,status,ierr)
                 endif

                 if (btest(myprocid,l-lind-1) .eqv.  .true.) then
                    dest = ibclr(myprocid,l-lind-1)
                    call MPI_SEND(g,kxp,MPI_DOUBLE_COMPLEX,dest,0,comm,ierr)
                 else
                    source = ibset(myprocid,l-lind-1)
                    call MPI_RECV(f,kxp,MPI_DOUBLE_COMPLEX,source,0,comm,status,ierr)
                 endif

!C ------------------
!C perform reduction
!C ------------------
               km = nxh/nxs
               dns = dnx*float(km)

               kb = myprocid
               llb = kb/kxs
               kb = kxp*(kb - kxs*llb) - 1
               llb = llb - 2*(llb/2)
               do j = 1, kxp
                   arg = dns*float(j + kb)
                   t1 = cmplx(cos(arg),sign*sin(arg))
                   if (llb.eq.0) then
                      g(j ) = g(j) + t1*f(j)
                   else
                      g(j ) = f(j) - t1*g(j)
                   endif
               enddo
            endif

        enddo
!C do l=1,indx1

        return
        end

        subroutine bitrv1(mixup,isign,indx,kxp,kblok,sct,myprocnum)

        double complex  sct(kxp)
        integer  mixup(kxp)
        integer isign,indx,kxp,kblok,myprocnum

        integer llb,ub
        real arg,dnx

        nx = 2**indx
        nxh = nx/2
        dnx = 6.28318530717959/float(nx)

!C ---------------------------------
!C prepare bit-reverse index table
!C ---------------------------------

        koff = kxp*myprocnum - 1
        do  j = 1, kxp
           lb = j + koff
           ll = 0
           do  l = 1, indx
              jb = lb/2
              it = lb - 2*jb
              lb = jb
              ll = 2*ll + it
           enddo
           mixup(j) = ll + 1
        enddo

        do j = 1, kxp
           arg = dnx*float((nxh*(j - 1))/kxp)
           sct(j) = cmplx(cos(arg),-sin(arg))
        enddo
        return
        end

        subroutine permute(f,g,mixup,indx,kxp,kblok,comm)

        double complex f,g
	dimension f(kxp),g(kxp)
        dimension mixup(kxp)
        integer comm

	double complex global_f(kxp,kblok)
        include 'mpif.h'

!C ---------------------------
!C inverse fourier transform
!C bit-reverse array elements to temporary
!C ---------------------------

         call MPI_ALLGATHER(f,kxp,MPI_DOUBLE_COMPLEX,global_f,kxp,&
              MPI_DOUBLE_COMPLEX,comm,ierr)

         do j = 1, kxp
            ll = mixup(j)
            kk = (ll - 1)/kxp + 1
            jj = ll - kxp*(kk - 1)
            g(j) = global_f(jj,kk)
         enddo

         return
         end


PROGRAM print_constants
! Print some of the constants in the quad. precision package in decimal

USE quadruple_precision
IMPLICIT NONE

CHARACTER (LEN=36)      :: string
INTEGER                 :: ier
TYPE (quad), PARAMETER  :: pt1 = quad( 0.1_dp, -0.5551115123125784E-17_dp)
REAL (dp)               :: error

CALL quad_string(pi, string, ier)
WRITE(*, '(a, t15, a)') ' PI = ', string

CALL quad_string(rad2deg, string, ier)
WRITE(*, '(a, t15, a)') ' rad2deg = ', string

CALL quad_string(ln10, string, ier)
WRITE(*, '(a, t15, a)') ' ln10 = ', string

CALL quad_string(ln2, string, ier)
WRITE(*, '(a, t15, a)') ' ln2 = ', string

CALL quad_string(log10e, string, ier)
WRITE(*, '(a, t15, a)') ' log10e = ', string

CALL quad_string(e, string, ier)
WRITE(*, '(a, t15, a)') ' e = ', string

CALL quad_string(euler, string, ier)
WRITE(*, '(a, t15, a)') ' euler = ', string

CALL quad_string(sqrt2, string, ier)
WRITE(*, '(a, t15, a)') ' sqrt2 = ', string

CALL quad_string(sqrt10, string, ier)
WRITE(*, '(a, t15, a)') ' sqrt10 = ', string
WRITE(*, *)

! And for anyone who still thinks the constants are wrong:

CALL quad_string(pt1, string, ier)
WRITE(*, '(a, t15, a)') ' pt1 = ', string
error = pt1 - 1.0_dp / quad( 10.0_dp, 0.0_dp )
WRITE(*, '(a, g13.5)') ' Error = ', error

STOP
END PROGRAM print_constants


!
! Integrate_Utility
!
! Module containing integration routines.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 27-Aug-2001
!                       paul.vandelst@noaa.gov
!

MODULE Integrate_Utility

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module use
  USE Type_Kinds,            ONLY: fp
  USE Message_Handler,       ONLY: SUCCESS, FAILURE, Display_Message
  USE Fundamental_Constants, ONLY: PI
  USE Compare_Float_Numbers, ONLY: Compare_Float
  USE Interpolate_Utility,   ONLY: Linear_Interpolate, &
                                   Spline_Initialize, Spline_Interpolate
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: Integral
  PUBLIC :: Gauss_Legendre
  PUBLIC :: Integrate_Utility_Version

  ! -----------------
  ! Module parameters
  ! -----------------
  ! Version Id
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  ! Literal constants
  REAL(fp), PARAMETER :: ZERO = 0.0_fp
  REAL(fp), PARAMETER ::  ONE = 1.0_fp
  REAL(fp), PARAMETER ::  TWO = 2.0_fp
  REAL(fp), PARAMETER :: POINT_FIVE = 0.5_fp
  ! MEssage string length
  INTEGER, PARAMETER :: ML = 256

CONTAINS

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Integral
!
! PURPOSE:
!       Function to integrate tabulated data.
!
! CALLING SEQUENCE:
!       Error_Status = Integral( x, y,         &
!                                Integral_Sum, &
!                                n_Points     = n_Points    , &
!                                Force_Spline = Force_Spline  )
!
!
! INPUTS:
!       x, y:          The tabulated function to be integrated. The sizes
!                      of x and y must be the same and be more than one
!                      element.
!                      UNITS:      Argument dependent.
!                      TYPE:       REAL(fp)
!                      DIMENSION:  Rank-1
!                      ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Integral_Sum:  The integration result.
!                      UNITS:      Argument dependent.
!                      TYPE:       REAL(fp)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       n_Points:      Set this argument to an integer value that selects the
!                      closed Newton-Cotes quadrature formula to be used.
!                      Valid values are:
!                        2: Trapezoidal rule
!                        3: Simpson's rule [DEFAULT]
!                        4: Simpson's 3/8 rule
!                        5: Boole's rule
!                        6: 6-point rule
!                        7: 7-point rule
!                      If not specified, a value of 3 is used.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN), OPTIONAL
!
!
!       Force_Spline:  Set this argument to force spline interpolation to be used.
!                      Spline interpolation is the default UNLESS the number of
!                      input x,y points is < 50; then linear interpolation is used.
!                      If == .FALSE., Interpolation method is determined by the
!                                     number of input points. [DEFAULT]
!                         == .TRUE.,  Spline interpolation is always used.
!                      If not specified, default is .FALSE.
!                      UNITS:      N/A
!                      TYPE:       LOGICAL
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN), OPTIONAL
!
! FUNCTION RESULT:
!       Error_Status:  The return value is an integer defining the error status.
!                      The error codes are defined in the Message_Handler module.
!                      If == SUCCESS the computation was successful.
!                         == FAILURE an unrecoverable error occurred.
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Integral( &
    x, y,         &  ! Input
    Integral_Sum, &  ! Output
    n_Points    , &  ! Optional input
    Force_Spline) &  ! Optional input
  RESULT( err_stat )
    ! Arguments
    REAL(fp),           INTENT(IN)  :: x(:)
    REAL(fp),           INTENT(IN)  :: y(:)
    REAL(fp),           INTENT(OUT) :: Integral_Sum
    INTEGER , OPTIONAL, INTENT(IN)  :: n_Points
    LOGICAL , OPTIONAL, INTENT(IN)  :: Force_Spline
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME         = 'Integral'
    REAL(fp),     PARAMETER :: NON_UNIQUE_TOLERANCE = EPSILON(ONE)
    INTEGER, PARAMETER :: DEFAULT_N_POINTS = 3
    INTEGER, PARAMETER :: MIN_N_POINTS = 2
    INTEGER, PARAMETER :: MAX_N_POINTS = 7
    ! Local variables
    CHARACTER(ML) :: msg
    INTEGER  :: alloc_stat
    INTEGER  :: i, j, m, n
    INTEGER  :: idx(MAX_N_POINTS)
    INTEGER  :: n_Even, n_Jdx
    LOGICAL  :: Spline_Interpolation
    REAL(fp) :: dx(SIZE(x)-1)
    REAL(fp) :: c0, c(MAX_N_POINTS), h
    REAL(fp) :: error, tmp, se
    REAL(fp), ALLOCATABLE :: xi(:), yi(:)
    INTEGER , ALLOCATABLE :: jdx(:)
    REAL(fp), ALLOCATABLE :: s(:)

    ! Set up
    err_stat = SUCCESS
    idx = (/ (i,i=1,MAX_N_POINTS) /)
    ! ...Check input vector sizes for agreement
    n = SIZE(x)
    IF ( SIZE(y) /= n ) THEN
      err_stat = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'X and Y input vectors must be same size.', &
                            err_stat )
      RETURN
    END IF
    ! ...Check that all points in X are unique to avoid division by zero
    dx = x(2:n) - x(1:n-1)
    IF ( ANY(ABS(dx) < NON_UNIQUE_TOLERANCE) ) THEN
      err_stat = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'Non-unique X values found.', &
                            err_stat )
      RETURN
    END IF
    ! ...Check that X is monotonically increasing
    IF ( ANY(dx < ZERO) ) THEN
      err_stat = FAILURE
      CALL Display_Message( ROUTINE_NAME, &
                            'X values must be monotonically increasing.', &
                            err_stat )
      RETURN
    END IF
    ! ...Set interpolation type
    m = DEFAULT_N_POINTS
    IF ( PRESENT(n_Points) ) m = n_Points
    ! ...Set interpolation type based on the number of unique input points
    IF ( n > 50 ) THEN
      Spline_Interpolation = .TRUE.
    ELSE
      Spline_Interpolation = .FALSE.
    END IF
    IF ( PRESENT(Force_Spline) ) Spline_Interpolation = Force_Spline

    ! Get the interpolation coefficients
    CALL Newton_Cotes_Coefficients()

    ! Perform the interpolation
    ! ...Determine the number of points to interpolate
    n_Even = n
    DO
      IF ( MOD(n_Even-1,m-1) == 0 ) EXIT
      n_Even = n_Even + 1
    END DO
    ! ...Allocate interpolation arrays
    ALLOCATE( xi(n_Even), yi(n_Even), STAT=alloc_stat )
    IF ( alloc_stat /= 0 ) THEN
      err_stat = FAILURE
      WRITE( msg,'("Error allocating interpolation arrays. STAT = ",i0)' ) alloc_stat
      CALL Display_Message( ROUTINE_NAME, msg, err_stat )
      RETURN
    END IF
    ! ...Construct an evenly spaced abscissa grid
    xi = (/ (REAL(i,fp), i=0,n_Even-1) /) / REAL(n_Even-1,fp)
    xi = xi*(x(n)-x(1)) + x(1)
    ! ...Interpolate data to regular grid
    IF ( Spline_Interpolation ) THEN
      err_stat = Spline_Interpolate( x, y, xi, yi )
    ELSE
      err_stat = Linear_Interpolate( x, y, xi, yi )
    END IF
    IF ( err_stat /= SUCCESS ) THEN
      CALL Display_Message( ROUTINE_NAME, 'Error interpoalting input data', err_stat )
      RETURN
    END IF

    ! Perform the integration
    ! ...Determine the number of indexing points
    n_Jdx = (n_Even-1)/(m-1)
    ! ...Allocate the indexing and summation array
    ALLOCATE( jdx(n_Jdx), s(n_Jdx), STAT=alloc_stat )
    IF ( alloc_stat /= 0 ) THEN
      err_stat = FAILURE
      WRITE( msg,'("Error allocating integration index and sum arrays. STAT = ",i0)' ) alloc_stat
      CALL Display_Message( ROUTINE_NAME, msg, err_stat )
      RETURN
    END IF
    ! ...Set the uniform interval
    h = (xi(n_Even) - xi(1))/REAL(n_Even-1,fp)
    ! ...Construct the index array to use for integration
    jdx = (/ (j, j=1,n_Jdx) /) * (m-1)
    ! ...Accumulate the integral value
    DO j = 1, n_Jdx
      s(j) = c0 * h * SUM(c(1:m) * yi(idx(1:m) + jdx(j) - (m-1)))
    END DO
    ! ...Perform compensated summation
    integral_sum = ZERO
    error = ZERO
    DO j = 1, n_Jdx
      tmp          = integral_sum               ! Save current sum
      se           = s(j) + error               ! Add rounding error to current value
      integral_sum = tmp + se                   ! Compute new sum
      error        = (tmp - integral_sum) + se  ! Compute new rounding error
    END DO

    ! Clean up
    DEALLOCATE( xi, yi, jdx, s, STAT=alloc_stat )

  CONTAINS

    SUBROUTINE Newton_Cotes_Coefficients()
      SELECT CASE(m)
        ! Trapezoidal rule
        CASE(2)
          c0 = 1.0_fp/2.0_fp
          c(1:2) = (/1.0_fp, 1.0_fp/)
        ! Simpson's 3/8 rule
        CASE(4)
          c0 = 3.0_fp/8.0_fp
          c(1:4) = (/1.0_fp, 3.0_fp, 3.0_fp, 1.0_fp/)
        ! Boole's rule
        CASE(5)
          c0 = 2.0_fp/45.0_fp
          c(1:5) = (/7.0_fp, 32.0_fp, 12.0_fp, 32.0_fp, 7.0_fp/)
        ! And higher orders...
        CASE(6)
          c0 = 5.0_fp/288.0_fp
          c(1:6) = (/19.0_fp, 75.0_fp, 50.0_fp, 50.0_fp, 75.0_fp, 19.0_fp/)
        CASE(7)
          c0 = 1.0_fp/140.0_fp
          c(1:7) = (/41.0_fp, 216.0_fp, 27.0_fp, 272.0_fp, 27.0_fp, 216.0_fp, 41.0_fp/)
        ! Default is regular Simpson's rule
        CASE DEFAULT
          c0 = 1.0_fp/3.0_fp
          c(1:3) = (/1.0_fp, 4.0_fp, 1.0_fp/)
          m = DEFAULT_N_POINTS
      END SELECT
    END SUBROUTINE Newton_Cotes_Coefficients

  END FUNCTION Integral

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Gauss_Legendre
!
! PURPOSE:
!       Function to compute the abscissae and weights for the Gauss-Legendre
!       N-point quadrature formula.
!
!       Adapted from the "gauleg" subroutine in W.H.Press et al. "Numerical
!       Recipes in Fortran", sec.4.5, pg145, 2nd ed, 1992
!
! CALLING SEQUENCE:
!       Error_Status = Gauss_Legendre( x, weight,              &
!                                      x_Interval = x_Interval )
!
! OUTPUTS:
!       x:               The array of abscissa values to be used in the N-point
!                        quadrature. The size of this array determines the value
!                        of N used in computing the abscissae and must be the
!                        same size as the WEIGHT argument.
!                        UNITS:      Argument dependent.
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1
!                        ATTRIBUTES: INTENT(OUT)
!
!       weight:          The array of weights to be used in the N-point
!                        quadrature. The size of this array determines
!                        the value of N used in computing the abscissae
!                        and must be the same size as the X argument.
!                        UNITS:      Argument dependent.
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1
!                        ATTRIBUTES: INTENT(OUT)
!
! OPTIONAL INPUTS:
!       x_Interval:      A two-element vector containing the interval over which
!                        the abscissa and weights are to be evaluated.
!                        x_Interval(1) must be > x_Interval(2).
!                        If not supplied the abscissa and weights are
!                        returned that correspond to an interval of [-1,1]
!                        UNITS:      Argument dependent.
!                        TYPE:       REAL(fp)
!                        DIMENSION:  Rank-1
!                        ATTRIBUTES: OPTIONAL, INTENT(IN)
!
! FUNCTION RESULT:
!       Error_Status:    The return value is an integer defining the error status.
!                        The error codes are defined in the Message_Handler module.
!                        If == SUCCESS the computation was successful
!                           == FAILURE an unrecoverable error occurred.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Gauss_Legendre( &
    x         , &  ! Output
    Weight    , &  ! Output
    x_Interval) &  ! Optional input
  RESULT( err_stat )
    ! Arguments
    REAL(fp),          INTENT(OUT) :: x(:)
    REAL(fp),          INTENT(OUT) :: Weight(:)
    REAL(fp),OPTIONAL, INTENT(IN)  :: x_Interval(2)
    ! Function result
    INTEGER :: err_stat
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Gauss_Legendre'
    REAL(fp),     PARAMETER :: TOLERANCE      = EPSILON( ONE )
    INTEGER,      PARAMETER :: MAX_ITERATIONS = 1000
    ! Local variables
    CHARACTER(ML) :: msg
    INTEGER  :: i,  j,  m, n
    REAL(fp) :: ir, jr,    nr
    REAL(fp) :: x_Lower,   x_Upper
    REAL(fp) :: x_Average, x_Halfwidth
    REAL(fp) :: z, z1
    REAL(fp) :: Pj, Pj_1, Pj_2
    REAL(fp) :: Pj_Prime
    INTEGER :: n_Iterations

    ! Set up
    err_stat = SUCCESS
    ! ...Check the integration limits
    IF ( PRESENT(x_Interval) ) THEN
      IF ( x_Interval(2) < x_Interval(1) .OR. &
           Compare_Float( x_Interval(1), x_Interval(2) ) ) THEN
        err_stat = FAILURE
        msg = 'For input integration interval [a,b], b < or = a.'
        CALL Display_Message( ROUTINE_NAME, msg, err_stat )
        RETURN
      END IF
      x_Lower = x_Interval(1)
      x_Upper = x_Interval(2)
    ELSE
      x_Lower = -ONE
      x_Upper =  ONE
    END IF
    ! ...Check the size of the output arrays
    n = SIZE(x)
    IF ( SIZE(Weight) /= n ) THEN
      err_stat = FAILURE
      msg = 'Size of X and WEIGHT output arrays are different.'
      CALL Display_Message( ROUTINE_NAME, msg, err_stat )
      RETURN
    END IF

    ! -----------------------------------------------------
    ! Find the roots and weights of the required polynomial
    ! -----------------------------------------------------
    ! The size of the output X and WEIGHT arrays
    ! determine the polynomial order. Need a floating
    ! point representation of that value
    nr = REAL(n,fp)

    ! The roots are symmetric in the interval
    ! so only half need to be determined
    m = (n + 1) / 2

    ! The scaling values to convert the computed abscissae from
    ! the interval (-1,1) to the input interval (x_Lower, x_Upper)
    x_Average   = POINT_FIVE * ( x_Upper + x_Lower )  ! Average X of interval
    x_Halfwidth = POINT_FIVE * ( x_Upper - x_Lower )  ! Halfwidth of interval

    ! Loop over the roots to find
    Root_Loop: DO i = 1, m

      ! Approximate the i'th root with the analytic
      ! value for Chebyshev polynomials,
      !
      !            (       i - 0.5  )
      !   z  = COS ( PI * --------- )
      !    i       (          n     )
      !
      ir = REAL(i,fp)
      z = COS(PI * (ir - POINT_FIVE) / nr)

      ! Initialise the iteration counter used
      ! to refine the polynomial root value
      n_Iterations = 0

      ! Refine the i'th root by Newton's method
      Root_Find: DO

        ! Increment and test the iteration counter
        n_Iterations = n_Iterations + 1
        IF ( n_Iterations > MAX_ITERATIONS ) THEN
          err_stat = FAILURE
          WRITE( msg,'("Maximum number of iterations exceeded for finding root #",i0)' ) i
          CALL Display_Message( ROUTINE_NAME, msg, err_stat )
          RETURN
        END IF

        ! Initialise the lower order polynomials
        Pj   = ONE    ! j'th   polynomial
        Pj_1 = ZERO   ! j-1'th polynomial

        ! Loop up the recurrence relation to get
        ! the Legendre polynomial evaluated at x
        Recurrence_Loop: DO j = 1, n

          jr = REAL(j,fp)

          ! Demote the previous loop's polynomials
          Pj_2 = Pj_1   ! j-2'th polynomial
          Pj_1 = Pj     ! j-1'th polynomial

          ! Compute the new polynomial using the recurrence relation:
          !
          !  j.P  = (2j-1).x.P     - (j-1).P         .....(1)
          !     j             j-1           j-2
          !
          ! Note that in the NR text the relation (4.5.10) is given as
          !
          !  (j+1).P    = (2j+1).x.P  - (j+1).P      .....(2)
          !         j+1             j          j-1
          !
          ! which is equivalent to the form used in (1) except that
          ! the j+1'th polynomial in (2) is the j'th polynomial in (1)
          Pj = ((((TWO * jr) - ONE) * z * Pj_1) - ((jr - ONE) * Pj_2)) / jr

        END DO Recurrence_Loop

        ! Pj is now the desired Legendre polynomial. Now compute its
        ! derivate, Pj_Prime, using a standard relation involving also
        ! Pj_1, the polynomial of one lower order
        Pj_Prime = nr * ((z * Pj) - Pj_1) / ((z*z) - ONE)

        ! Save the previous root value
        z1 = z

        ! Update the root approximation
        z  = z1 - (Pj / Pj_Prime)

        ! Exit the root finding loop if the desired
        ! accuracy has been reached
        IF ( ABS(z - z1) < TOLERANCE ) EXIT Root_Find

      END DO Root_Find

      ! --------------------------------------------------------
      ! Scale the root value, z, and it's symmetric counterpart
      ! from the (-1,1) interval to (x_Lower,x_Upper)
      !
      ! The input interval and derived quantities:
      !
      !     |                 |                 |
      !  x_Lower          x_Average          x_Upper
      !                       |                 |
      !                       |<- x_Halfwidth ->|
      !
      !
      ! The computed abscissa for half of the interval:
      !
      !                       |  +  +  +  +  +  |
      !                       0                 1
      !
      ! are reflected symmetrically
      !
      !     |  +  +  +  +  +  |
      !    -1                 0
      !
      ! --------------------------------------------------------
      x(i)     = x_Average - (x_Halfwidth * z)
      x(n+1-i) = x_Average + (x_Halfwidth * z)

      ! --------------------------------------------------------
      ! Compute the weight and its symmetric counterpart using
      ! the special form for the Gauss-Legendre case:
      !
      !                     2
      !   w   = ------------------------   .....(4.5.16 from NR)
      !    i     (1 - x ^2) . P'(x )^2
      !                i       N  i
      ! --------------------------------------------------------
      Weight(i)     = TWO * x_Halfwidth / ((ONE - (z**2)) * Pj_Prime**2)
      Weight(n+1-i) = Weight(i)

    END DO Root_Loop

  END FUNCTION Gauss_Legendre

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Integrate_Utility_Version
!
! PURPOSE:
!       Subroutine to return the module version information.
!
! CALLING SEQUENCE:
!       CALL Integrate_Utility_Version( Id )
!
! OUTPUTS:
!       Id:    Character string containing the version Id information
!              for the module.
!              UNITS:      N/A
!              TYPE:       CHARACTER(*)
!              DIMENSION:  Scalar
!              ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE Integrate_Utility_Version( Id )
    CHARACTER(*), INTENT(OUT) :: Id
    Id = MODULE_VERSION_ID
  END SUBROUTINE Integrate_Utility_Version

END MODULE Integrate_Utility


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine tt_calc(xflow,Tt,Pt,kappa,r,A,Ts,icase)
!
!     this subroutine solves the implicit equation
!     f=xflow*dsqrt(Tt)/(a*Pt)-C*(TtdT)**expon*(Ttdt-1)**0.5d0
!     in order to find Tt when Ts , xflow, pt and a are given
!
!     author: Yannick Muller
!
      implicit none
!
      integer icase,i
!
      real*8 xflow,Tt,Pt,Ts,kappa,r,f,df,A,expon,Tt_old,C,TtzTs,
     &     deltaTt,TtzTs_crit,Qred,h1,h2,h3
!
      expon=-0.5d0*(kappa+1.d0)/(kappa-1.d0)
!
      C=dsqrt(2.d0/r*kappa/(kappa-1.d0))
!
!     f=xflow*dsqrt(Tt)/(A*Pt)-C*(Tt/Ts)**expon*(Tt/Ts-1)**0.5d0
!
!     df=-C*Ttdt**expon*(expon/Ts*(Tt/Ts-1)**0.5d0
!     &     -0.5d0*Tt/Ts/Ts*(Tt/Ts-1.d0)**(-0.5d0))
!
      if(dabs(xflow).le.1e-9) then
         Tt=Ts
         return
      endif
!
!     initial guess
!
      Qred=abs(xflow)*dsqrt(Ts)/(A*Pt)
      Tt=Ts*(1+(Qred**2/C**2))
!
!     adiabatic
!
      if(icase.eq.0) then
!
         TtzTs_crit=(kappa+1.d0)/2.d0
!
!     isothermal
!
      else
!
         TtzTs_crit=(1d0+(kappa-1.d0)/(2.d0*kappa))
!
      endif
!
      if(Tt/Ts.gt.TtzTs_crit) then
         Tt=Ts*(TtzTs_crit+1.d0)/2.d0
      endif
!
      i=0
      Tt_old=Tt
!
      do
         i=i+1
         Ttzts=Tt/Ts
         h1=Ttzts-1.d0
         h2=dsqrt(h1)
         h3=Ttzts**expon
!
         f=C*h2*h3
!
         df=0.5*dabs(xflow)/(A*Pt*dsqrt(Tt))
     &        -C*h2*h3*(expon/Tt+1.d0/(2.d0*h1*Ts))
!
         Qred=abs(xflow)*dsqrt(Tt)/(A*Pt)
!
         f=Qred-f
         deltaTt=-f/df
!
         Tt=Tt+deltaTt
!
         if((((dabs(Tt-Tt_old)/Tt_old).le.1.E-8))
     &        .or.((dabs(Tt-Tt_old)).le.1.E-10)
     &        .or.((dabs(f).le.1E-5).and.(deltaTt.lt.1E-3))) then
!
            if(Tt/Ts.gt.TtzTs_crit) then
               Tt=Ts*TtzTs_crit
            endif
            exit
         else if((i.gt.40)) then
            Tt=0.99*Ts*TtzTs_crit
            exit
         endif
         Tt_old=Tt
      enddo
!
      return
      end


       subroutine DAZEL(MODE)
C#  SUB DAZEL(MODE)             Great circle calculations.
       IMPLICIT DOUBLE PRECISION(A-L,N-Y)
C
C     TWO MODES--   0   INPUT LAT AND LON OF END POINT
C                       RETURN DISTANCE AND AZIMUTH TO END PT WITH ELEVATIONS
C                   1   INPUT BEARING (AZIMUTH) OF END POINT
C                       RETURN LAT AND LON OF END POINT WITH ELEVATIONS
C
C   MODE 0
C   INPUT PARAMETERS (THESE DEFINE LOCATION OF POINTS T (TRANSMITTER)
C     AND R (RECEIVER) RELATIVE TO A SPHERICAL EARTH.
C     ZTLAT - LATITUDE (DECIMAL DEGREES NORTH OF EQUATOR) OF POINT T
C     ZTLON - LONGITUDE (DECIMAL DEGREES EAST OF PRIME (GREENWICH)
C            MERIDIAN) OF POINT T
C     ZTHT  - HEIGHT (METERS ABOVE MEAN SEA LEVEL) OF POINT T
C     ZRLAT - LATITUDE (DECIMAL DEGREES NORTH OF EQUATOR) OF POINT R
C     ZRLON - LONGITUDE (DECIMAL DEGREES EAST OF PRIME MERIDIAN OF POINT R
C     ZRHT  - HEIGHT (METERS ABOVE MEAN SEA LEVEL) OF POINT R
C
C   OUTPUT PARAMETERS
C     ZTAZ  - AZUMUTH (DECIMAL DEGREES CLOCKWISE FROM NORTH) AT T OF R
C     ZRAZ  - AZIMUTH (DECIMAL DEGREES CLOCKWISE FROM NORTH) AT R OF T
C     ZTELV - ELEVATION ANGLE (DECIMAL DEGREES ABOVE HORIZONTAL AT T
C            OF STRAIGHT LINE BETWEEN T AND R
C     ZRELV - ELEVATION ANGLE (DECIMAL DEGREES ABOVE HORIZONTAL AT R)
C            OF STRAIGHT LINE BETWEEN T AND R
C     ZTAKOF - TAKE-OFF ANGLE (DECIMAL DEGREES ABOVE HORIZONTAL AT T)
C            OF REFRACTED RAY BETWEEN T AND R (ASSUMED 4/3 EARTH RADIUS)
C     ZRAKOF - TAKE-OFF ANGLE (DECIMAL DEGREES ABOVE HORIZONTAL AT R)
C            OF REFRACTED RAY BETWEEN T AND R (ASSUMED 4/3 EARTH RADIUS)
C     ZD    - STRAIGHT LINE DISTANCE (KILOMETERS) BETWEEN T AND R
C     ZDGC  - GREAT CIRCLE DISTANCE (KILOMETERS) BETWEEN T AND R
C
C   MODE 1
C   INPUT PARAMETERS                    OUTPUT PARAMETERS
C     ZTLAT                                ZRLAT
C     ZTLON                                ZRLON
C     ZTAZ                                 RELEV,ZRAKOF
C     ZDGC                                 TELEV,ZTAKOF
C
C
C     ALL OF THE ABOVE PARAMETERS START WITH THE LETTER Z AND ARE SINGLE
C     PRECISION.  ALL PROGRAM VARIABLES ARE DOUBLE PRECISION.
C     PROGRAM IS UNPREDICTABLE FOR SEPARATIONS LESS THAN 0.00005 DEGREES,
C     ABOUT 5 METERS.
C
C   WRITTEN BY KEN SPIES 5/79
C   REFRACTION AND ST. LINE ELEVATIONS BY EJH
C
      COMMON/AZEL/ ZTLAT,ZTLON,ZTHT,ZRLAT,ZRLON,ZRHT,ZTAZ,ZRAZ,
     * ZTELV,ZRELV,ZD,ZDGC,ZTAKOF,ZRAKOF
      DATA PI/3.141592653589793238462643D0/,RERTH/6370.0D0/
      DATA DTOR/0.01745329252D0/,RTOD/57.29577951D0/
      IF(MODE .EQ. 1) GO TO 200
       TLATS=ZTLAT
       TLONS=ZTLON
       THTS=ZTHT*1.0E-3
       RLATS=ZRLAT
       RLONS=ZRLON
       RHTS=ZRHT*1.0E-3
       IF(TLATS.le.-90.0) tlats=-89.9
       IF(TLATS.ge. 90.0) tlats= 89.9
       IF(RLATS.le.-90.0) rlats=-89.9
       IF(RLATS.ge. 90.0) rlats= 89.9
       DELAT=RLATS-TLATS
       ADLAT=DABS(DELAT)
       DELON=RLONS-TLONS
       IF(DELON-(-180.0))12,16,16
12     DELON=DELON+360.0
       IF(DELON-(-180.0))12,20,20
16     IF(DELON-180.0)20,20,18
18     DELON=DELON-360.0
       IF(DELON-180.0)20,20,18
20     ADLON=DABS(DELON)
       DELHT=RHTS-THTS
       IF(ADLON-1.0E-5)22,22,55
22     IF(ADLAT-1.0E-5)24,24,40
C
C   POINTS T AND R HAVE THE SAME COORDINATES
C
24     ZTAZ=0.0
       ZRAZ=0.0
       IF(DELHT)25,30,35
25     ZTELV=-90.0
       ZRELV=90.0
       ZD=-DELHT
      ZDGC=0.0
       RETURN
30     ZTELV=0.0
       ZRELV=0.0
       ZD=0.0
      ZDGC=0.0
       RETURN
35     ZTELV=90.0
       ZRELV=-90.0
       ZD=DELHT
      ZDGC=0.0
       RETURN
C
C   POINTS T AND R HAVE SAME LONGITUDE, DISTINCT LATITUDES
C
40     IF(DELAT-0.0)42,42,45
42     ZTAZ=180.0
       ZRAZ=0.0
       GO TO 50
45     ZTAZ=0.0
       ZRAZ=180.0
50     GC=ADLAT*DTOR
       SGC=DSIN(0.5*GC)
       D=DSQRT(DELHT*DELHT+4.0*(RERTH+THTS)*(RERTH+RHTS)*SGC*SGC)
      ZD=D
       GO TO 140
C
C   POINTS TAND R HAVE DISTINCT LONGITUDES
C
55     IF(DELON-0.0)56,56,60
56     WLAT=RLATS*DTOR
       ELAT=TLATS*DTOR
       GO TO 65
60     WLAT=TLATS*DTOR
       ELAT=RLATS*DTOR
C
C   CALCULATE AZIMUTHS AT POINTS W AND E
C
65     SDLAT=DSIN(0.5*ADLAT*DTOR)
       SDLON=DSIN(0.5*ADLON*DTOR)
       SADLN=DSIN(ADLON*DTOR)
       CWLAT=DCOS(WLAT)
       CELAT=DCOS(ELAT)
       P=2.0*(SDLAT*SDLAT+SDLON*SDLON*CWLAT*CELAT)
       SGC=DSQRT(P*(2.0-P))
       SDLAT=DSIN(ELAT-WLAT)
       CWAZ=(2.0*CELAT*DSIN(WLAT)*SDLON*SDLON+SDLAT)/SGC
      SWAZ=SADLN*CELAT/SGC
      WAZ=DATAN2(SWAZ,CWAZ)*RTOD
       CEAZ=(2.0*CWLAT*DSIN(ELAT)*SDLON*SDLON-SDLAT)/SGC
      SEAZ=SADLN*CWLAT/SGC
      EAZ=DATAN2(SEAZ,CEAZ)*RTOD
       EAZ=360.0-EAZ
       IF(DELON.le.0.0) then
          ZTAZ=EAZ
          ZRAZ=WAZ
       else
          ZTAZ=WAZ
          ZRAZ=EAZ
       end if
C
C
C   COMPUTE THE STRAIGHT LINE DISTANCE AND GREAT CIRCLE ANGLE BETWEEN T AND R
C
       D=DSQRT(DELHT*DELHT+2.0*(RERTH+THTS)*(RERTH+RHTS)*P)
      ZD=D
       CGC=1.0-P
      GC=DATAN2(SGC,CGC)
C
C   COMPUTE GREAT CIRCLE DISTANCE AND ELEVATION ANGLES
C
140   ZDGC=GC*RERTH
142    IF(DELHT .GE. 0) GOTO 145
       AHT=THTS
       BHT=RHTS
       GO TO 150
145    AHT=RHTS
       BHT=THTS
150    SAELV=0.5*(D*D+DABS(DELHT)*(RERTH+AHT+RERTH+BHT))/(D*(RERTH+AHT))
      ARG=DMAX1(0.0D0,(1.0D0-SAELV*SAELV))
       AELV=DATAN2(SAELV,DSQRT(ARG))
       BELV=(AELV-GC)*RTOD
       AELV=-AELV*RTOD
C   COMPUTE TAKE-OFF ANGLES ASSUMING 4/3 EARTH RADIUS
       R4THD=RERTH*4.0/3.0
       GC=0.75*GC
       SGC=DSIN(0.5*GC)
       P=2.0*SGC*SGC
       AALT=R4THD+AHT
       BALT=R4THD+BHT
       DA=DSQRT(DELHT*DELHT+2.0*AALT*BALT*P)
       SAELV=0.5*(DA*DA+DABS(DELHT)*(AALT+BALT))/(DA*AALT)
      ARG=DMAX1(0.0D0,(1.0D0-SAELV*SAELV))
       ATAKOF=DATAN(SAELV/DSQRT(ARG))
       BTAKOF=(ATAKOF-GC)*RTOD
       ATAKOF=-ATAKOF*RTOD
       IF(DELHT-0.0)151,155,155
151    ZTELV=AELV
       ZRELV=BELV
       ZTAKOF=ATAKOF
       ZRAKOF=BTAKOF
       RETURN
155    ZTELV=BELV
       ZRELV=AELV
       ZTAKOF=BTAKOF
       ZRAKOF=ATAKOF
       RETURN
C
C     COMPUTE END POINT GIVEN DISTANCE AND BEARING
C
200   TLATR=ZTLAT*DTOR
      TLONR=ZTLON*DTOR
      TAZR=ZTAZ*DTOR
      GC=ZDGC/RERTH
      COLAT=PI/2.0 - TLATR
      COSCO=DCOS(COLAT)
      SINCO=DSIN(COLAT)
      COSGC=DCOS(GC)
      SINGC=DSIN(GC)
      COSB=COSCO*COSGC + SINCO*SINGC*DCOS(TAZR)
      ARG=DMAX1(0.0D0,(1.0D0-COSB*COSB))
      B=DATAN2(DSQRT(ARG),COSB)
      ARC=(COSGC-COSCO*COSB)/(SINCO*DSIN(B))
      ARG=DMAX1(0.0D0,(1.0D0-ARC*ARC))
      RDLON=DATAN2(DSQRT(ARG),ARC)
      ZRLAT=(PI/2.0 - DABS(B))*RTOD
      DRLAT=ZRLAT
      ZRLAT=DSIGN(DRLAT,COSB)
      ZRLON=ZTLON+(DABS(RDLON)*RTOD)
      IF(ZTAZ .GT. 180) ZRLON=ZTLON-(DABS(RDLON)*RTOD)
      THTS=ZTHT*1.0E-3
      RHTS=ZRHT*1.0E-3
      DELHT=RHTS-THTS
      SGC=DSIN(0.5*GC)
      D=DSQRT(DELHT*DELHT+4.0*(RERTH+THTS)*(RERTH+RHTS)*SGC*SGC)
      GO TO 142
      END
C------------------------------------------------------------------


!*==ctrsyl.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CTRSYL
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CTRSYL + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
!                          LDC, SCALE, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          TRANA, TRANB
!       INTEGER            INFO, ISGN, LDA, LDB, LDC, M, N
!       REAL               SCALE
!       ..
!       .. Array Arguments ..
!       COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CTRSYL solves the complex Sylvester matrix equation:
!>
!>    op(A)*X + X*op(B) = scale*C or
!>    op(A)*X - X*op(B) = scale*C,
!>
!> where op(A) = A or A**H, and A and B are both upper triangular. A is
!> M-by-M and B is N-by-N; the right hand side C and the solution X are
!> M-by-N; and scale is an output scale factor, set <= 1 to avoid
!> overflow in X.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TRANA
!> \verbatim
!>          TRANA is CHARACTER*1
!>          Specifies the option op(A):
!>          = 'N': op(A) = A    (No transpose)
!>          = 'C': op(A) = A**H (Conjugate transpose)
!> \endverbatim
!>
!> \param[in] TRANB
!> \verbatim
!>          TRANB is CHARACTER*1
!>          Specifies the option op(B):
!>          = 'N': op(B) = B    (No transpose)
!>          = 'C': op(B) = B**H (Conjugate transpose)
!> \endverbatim
!>
!> \param[in] ISGN
!> \verbatim
!>          ISGN is INTEGER
!>          Specifies the sign in the equation:
!>          = +1: solve op(A)*X + X*op(B) = scale*C
!>          = -1: solve op(A)*X - X*op(B) = scale*C
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The order of the matrix A, and the number of rows in the
!>          matrices X and C. M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix B, and the number of columns in the
!>          matrices X and C. N >= 0.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is COMPLEX array, dimension (LDA,M)
!>          The upper triangular matrix A.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in] B
!> \verbatim
!>          B is COMPLEX array, dimension (LDB,N)
!>          The upper triangular matrix B.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is COMPLEX array, dimension (LDC,N)
!>          On entry, the M-by-N right hand side matrix C.
!>          On exit, C is overwritten by the solution matrix X.
!> \endverbatim
!>
!> \param[in] LDC
!> \verbatim
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M)
!> \endverbatim
!>
!> \param[out] SCALE
!> \verbatim
!>          SCALE is REAL
!>          The scale factor, scale, set <= 1 to avoid overflow in X.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>          = 1: A and B have common or very close eigenvalues; perturbed
!>               values were used to solve the equation (but the matrices
!>               A and B are unchanged).
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexSYcomputational
!
!  =====================================================================
      SUBROUTINE CTRSYL(Trana,Tranb,Isgn,M,N,A,Lda,B,Ldb,C,Ldc,Scale,   &
     &                  Info)
      IMPLICIT NONE
!*--CTRSYL161
!
!  -- LAPACK computational 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 ..
      CHARACTER Trana , Tranb
      INTEGER Info , Isgn , Lda , Ldb , Ldc , M , N
      REAL Scale
!     ..
!     .. Array Arguments ..
      COMPLEX A(Lda,*) , B(Ldb,*) , C(Ldc,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE
      PARAMETER (ONE=1.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL notrna , notrnb
      INTEGER j , k , l
      REAL bignum , da11 , db , eps , scaloc , sgn , smin , smlnum
      COMPLEX a11 , suml , sumr , vec , x11
!     ..
!     .. Local Arrays ..
      REAL dum(1)
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      REAL CLANGE , SLAMCH
      COMPLEX CDOTC , CDOTU , CLADIV
      EXTERNAL LSAME , CLANGE , SLAMCH , CDOTC , CDOTU , CLADIV
!     ..
!     .. External Subroutines ..
      EXTERNAL CSSCAL , SLABAD , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , AIMAG , CMPLX , CONJG , MAX , MIN , REAL
!     ..
!     .. Executable Statements ..
!
!     Decode and Test input parameters
!
      notrna = LSAME(Trana,'N')
      notrnb = LSAME(Tranb,'N')
!
      Info = 0
      IF ( .NOT.notrna .AND. .NOT.LSAME(Trana,'C') ) THEN
         Info = -1
      ELSEIF ( .NOT.notrnb .AND. .NOT.LSAME(Tranb,'C') ) THEN
         Info = -2
      ELSEIF ( Isgn/=1 .AND. Isgn/=-1 ) THEN
         Info = -3
      ELSEIF ( M<0 ) THEN
         Info = -4
      ELSEIF ( N<0 ) THEN
         Info = -5
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -7
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -9
      ELSEIF ( Ldc<MAX(1,M) ) THEN
         Info = -11
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CTRSYL',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      Scale = ONE
      IF ( M==0 .OR. N==0 ) RETURN
!
!     Set constants to control overflow
!
      eps = SLAMCH('P')
      smlnum = SLAMCH('S')
      bignum = ONE/smlnum
      CALL SLABAD(smlnum,bignum)
      smlnum = smlnum*REAL(M*N)/eps
      bignum = ONE/smlnum
      smin = MAX(smlnum,eps*CLANGE('M',M,M,A,Lda,dum),                  &
     &       eps*CLANGE('M',N,N,B,Ldb,dum))
      sgn = Isgn
!
      IF ( notrna .AND. notrnb ) THEN
!
!        Solve    A*X + ISGN*X*B = scale*C.
!
!        The (K,L)th block of X is determined starting from
!        bottom-left corner column by column by
!
!            A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
!
!        Where
!                    M                        L-1
!          R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
!                  I=K+1                      J=1
!
         DO l = 1 , N
            DO k = M , 1 , -1
!
               suml = CDOTU(M-k,A(k,MIN(k+1,M)),Lda,C(MIN(k+1,M),l),1)
               sumr = CDOTU(l-1,C(k,1),Ldc,B(1,l),1)
               vec = C(k,l) - (suml+sgn*sumr)
!
               scaloc = ONE
               a11 = A(k,k) + sgn*B(l,l)
               da11 = ABS(REAL(a11)) + ABS(AIMAG(a11))
               IF ( da11<=smin ) THEN
                  a11 = smin
                  da11 = smin
                  Info = 1
               ENDIF
               db = ABS(REAL(vec)) + ABS(AIMAG(vec))
               IF ( da11<ONE .AND. db>ONE ) THEN
                  IF ( db>bignum*da11 ) scaloc = ONE/db
               ENDIF
               x11 = CLADIV(vec*CMPLX(scaloc),a11)
!
               IF ( scaloc/=ONE ) THEN
                  DO j = 1 , N
                     CALL CSSCAL(M,scaloc,C(1,j),1)
                  ENDDO
                  Scale = Scale*scaloc
               ENDIF
               C(k,l) = x11
!
            ENDDO
         ENDDO
!
      ELSEIF ( .NOT.notrna .AND. notrnb ) THEN
!
!        Solve    A**H *X + ISGN*X*B = scale*C.
!
!        The (K,L)th block of X is determined starting from
!        upper-left corner column by column by
!
!            A**H(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
!
!        Where
!                   K-1                           L-1
!          R(K,L) = SUM [A**H(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
!                   I=1                           J=1
!
         DO l = 1 , N
            DO k = 1 , M
!
               suml = CDOTC(k-1,A(1,k),1,C(1,l),1)
               sumr = CDOTU(l-1,C(k,1),Ldc,B(1,l),1)
               vec = C(k,l) - (suml+sgn*sumr)
!
               scaloc = ONE
               a11 = CONJG(A(k,k)) + sgn*B(l,l)
               da11 = ABS(REAL(a11)) + ABS(AIMAG(a11))
               IF ( da11<=smin ) THEN
                  a11 = smin
                  da11 = smin
                  Info = 1
               ENDIF
               db = ABS(REAL(vec)) + ABS(AIMAG(vec))
               IF ( da11<ONE .AND. db>ONE ) THEN
                  IF ( db>bignum*da11 ) scaloc = ONE/db
               ENDIF
!
               x11 = CLADIV(vec*CMPLX(scaloc),a11)
!
               IF ( scaloc/=ONE ) THEN
                  DO j = 1 , N
                     CALL CSSCAL(M,scaloc,C(1,j),1)
                  ENDDO
                  Scale = Scale*scaloc
               ENDIF
               C(k,l) = x11
!
            ENDDO
         ENDDO
!
      ELSEIF ( .NOT.notrna .AND. .NOT.notrnb ) THEN
!
!        Solve    A**H*X + ISGN*X*B**H = C.
!
!        The (K,L)th block of X is determined starting from
!        upper-right corner column by column by
!
!            A**H(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
!
!        Where
!                    K-1
!           R(K,L) = SUM [A**H(I,K)*X(I,L)] +
!                    I=1
!                           N
!                     ISGN*SUM [X(K,J)*B**H(L,J)].
!                          J=L+1
!
         DO l = N , 1 , -1
            DO k = 1 , M
!
               suml = CDOTC(k-1,A(1,k),1,C(1,l),1)
               sumr = CDOTC(N-l,C(k,MIN(l+1,N)),Ldc,B(l,MIN(l+1,N)),Ldb)
               vec = C(k,l) - (suml+sgn*CONJG(sumr))
!
               scaloc = ONE
               a11 = CONJG(A(k,k)+sgn*B(l,l))
               da11 = ABS(REAL(a11)) + ABS(AIMAG(a11))
               IF ( da11<=smin ) THEN
                  a11 = smin
                  da11 = smin
                  Info = 1
               ENDIF
               db = ABS(REAL(vec)) + ABS(AIMAG(vec))
               IF ( da11<ONE .AND. db>ONE ) THEN
                  IF ( db>bignum*da11 ) scaloc = ONE/db
               ENDIF
!
               x11 = CLADIV(vec*CMPLX(scaloc),a11)
!
               IF ( scaloc/=ONE ) THEN
                  DO j = 1 , N
                     CALL CSSCAL(M,scaloc,C(1,j),1)
                  ENDDO
                  Scale = Scale*scaloc
               ENDIF
               C(k,l) = x11
!
            ENDDO
         ENDDO
!
      ELSEIF ( notrna .AND. .NOT.notrnb ) THEN
!
!        Solve    A*X + ISGN*X*B**H = C.
!
!        The (K,L)th block of X is determined starting from
!        bottom-left corner column by column by
!
!           A(K,K)*X(K,L) + ISGN*X(K,L)*B**H(L,L) = C(K,L) - R(K,L)
!
!        Where
!                    M                          N
!          R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B**H(L,J)]
!                  I=K+1                      J=L+1
!
         DO l = N , 1 , -1
            DO k = M , 1 , -1
!
               suml = CDOTU(M-k,A(k,MIN(k+1,M)),Lda,C(MIN(k+1,M),l),1)
               sumr = CDOTC(N-l,C(k,MIN(l+1,N)),Ldc,B(l,MIN(l+1,N)),Ldb)
               vec = C(k,l) - (suml+sgn*CONJG(sumr))
!
               scaloc = ONE
               a11 = A(k,k) + sgn*CONJG(B(l,l))
               da11 = ABS(REAL(a11)) + ABS(AIMAG(a11))
               IF ( da11<=smin ) THEN
                  a11 = smin
                  da11 = smin
                  Info = 1
               ENDIF
               db = ABS(REAL(vec)) + ABS(AIMAG(vec))
               IF ( da11<ONE .AND. db>ONE ) THEN
                  IF ( db>bignum*da11 ) scaloc = ONE/db
               ENDIF
!
               x11 = CLADIV(vec*CMPLX(scaloc),a11)
!
               IF ( scaloc/=ONE ) THEN
                  DO j = 1 , N
                     CALL CSSCAL(M,scaloc,C(1,j),1)
                  ENDDO
                  Scale = Scale*scaloc
               ENDIF
               C(k,l) = x11
!
            ENDDO
         ENDDO
!
      ENDIF
!
!
!     End of CTRSYL
!
      END SUBROUTINE CTRSYL


!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2011 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                     FFTPACK  version 5.1                      *
!     *                                                               *
!     *                 A Fortran Package of Fast Fourier             *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *               Paul Swarztrauber and Dick Valent               *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
! parameter(lensav= l + 3*m + int(log(real(l))/log(2.))
!    .      + 2*int(log(real(m))/log(2.)) + 12)
!
program trfft2

    use, intrinsic :: ISO_Fortran_env, only: &
        wp => REAL64, &
        ip => INT32, &
        stdout => OUTPUT_UNIT, &
        stderr => ERROR_UNIT, &
        compiler_version, &
        compiler_options

    use type_FFTpack, only: &
        FFTpack

    ! Explicit typing only
    implicit none

    !------------------------------------------------------------------
    ! Dictionary
    !------------------------------------------------------------------
    type (FFTpack)          :: my_fft
    integer (ip), parameter :: l=100, m=100
    real (wp)               :: real_data(l,m), data_copy(l,m)
    !------------------------------------------------------------------

    !
    !==> Identify test
    !
    write( stdout, '(A)') 'program trfft2 and related messages:'

    !
    !==> Generate test matrix for forward-backward test
    !
    call random_seed()
    call random_number(real_data)
    data_copy = real_data

    !
    !==> Perform forward transform
    !
    call my_fft%fft2(real_data)

    !
    !==> Perform backward transform
    !
    call my_fft%ifft2(real_data)

    !
    !==> Print test results
    !
    associate( max_err => maxval(abs(real_data-data_copy)) )

        write( stdout, '(A,E23.15E3)' ) 'fft2 (real) forward-backward max error =', max_err

    end associate

    !
    !==> Generate test matrix for backward-forward test
    !
    call random_seed()
    call random_number(real_data)
    data_copy = real_data

    !
    !==> Perform backward transform
    !
    call my_fft%ifft2(real_data)
    !
    !==> Perform forward transform
    !
    call my_fft%fft2(real_data)

    !
    !==> Print test results
    !
    associate( max_err => maxval(abs(real_data-data_copy)) )

        write( stdout, '(A,E23.15E3)' ) 'fft2 (real) backward-forward max error =', max_err
        write( stdout, '(A,/)') 'end program trfft2 and related messages'

    end associate

    !
    !==> Print compiler info
    !
    write( stdout, '(A)' ) ' '
    write( stdout, '(4A)' ) 'This result was compiled by ', &
        compiler_version(), ' using the options ', &
        compiler_options()
    write( stdout, '(A)' ) ' '

end program trfft2


*DECK CARG
      FUNCTION CARG (Z)
C***BEGIN PROLOGUE  CARG
C***PURPOSE  Compute the argument of a complex number.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  A4A
C***TYPE      COMPLEX (CARG-C)
C***KEYWORDS  ARGUMENT OF A COMPLEX NUMBER, ELEMENTARY FUNCTIONS, FNLIB
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CARG(Z) calculates the argument of the complex number Z.  Note
C that CARG returns a real result.  If Z = X+iY, then CARG is ATAN(Y/X),
C except when both X and Y are zero, in which case the result
C will be zero.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CARG
      COMPLEX Z
C***FIRST EXECUTABLE STATEMENT  CARG
      CARG = 0.0
      IF (REAL(Z).NE.0. .OR. AIMAG(Z).NE.0.) CARG =
     1  ATAN2 (AIMAG(Z), REAL(Z))
C
      RETURN
      END


*DECK DBNORM
      DOUBLE PRECISION FUNCTION DBNORM (N, A, NRA, ML, MU, W)
C-----------------------------------------------------------------------
C This function computes the norm of a banded N by N matrix,
C stored in the array A, that is consistent with the weighted max-norm
C on vectors, with weights stored in the array W.
C ML and MU are the lower and upper half-bandwidths of the matrix.
C NRA is the first dimension of the A array, NRA .ge. ML+MU+1.
C In terms of the matrix elements a(i,j), the norm is given by:
C   DBNORM = MAX(i=1,...,N) ( W(i) * Sum(j=1,...,N) ABS(a(i,j))/W(j) )
C-----------------------------------------------------------------------
      INTEGER N, NRA, ML, MU
      INTEGER I, I1, JLO, JHI, J
      DOUBLE PRECISION A, W
      DOUBLE PRECISION AN, SUM
      DIMENSION A(NRA,N), W(N)
      AN = 0.0D0
      DO 20 I = 1,N
        SUM = 0.0D0
        I1 = I + MU + 1
        JLO = MAX(I-ML,1)
        JHI = MIN(I+MU,N)
        DO 10 J = JLO,JHI
 10       SUM = SUM + ABS(A(I1-J,J))/W(J)
        AN = MAX(AN,SUM*W(I))
 20     CONTINUE
      DBNORM = AN
      RETURN
C----------------------- End of Function DBNORM ------------------------
      END


!===============================================================================
subroutine vol_int_part(imin,jmin,kmin,imax,jmax,kmax,FIELD,AREA,dz,DZ_3D,INTEGRAL)
!
!     calculates volume integral (*[m^3]) with partial bottom cells
!
implicit none

! input/output variables
integer                                     :: i,j,k
integer, parameter                          :: imt=3600,jmt=2400,km=42
integer,                        intent(in)  :: imin,jmin,kmin,imax,jmax,kmax
real,    dimension(km),         intent(in)  :: dz
real,    dimension(imt,jmt,km), intent(in)  :: DZ_3D,FIELD
real,    dimension(imt,jmt),    intent(in)  :: AREA
real,                           intent(out) :: INTEGRAL

INTEGRAL = sum( AREA(imin:imax,jmin:jmax)                                      &
                * sum( DZ_3D(imin:imax,jmin:jmax,kmin:kmax)                    &
                       * FIELD(imin:imax,jmin:jmax,kmin:kmax),                 &
               3,DZ_3D(imin:imax,jmin:jmax,kmin:kmax).ne.0.0 ) )

end subroutine vol_int_part
!===============================================================================

!===============================================================================
subroutine vol_int_full(imin,jmin,kmin,imax,jmax,kmax,FIELD,AREA,dz,DZ_3D,INTEGRAL)
!
!     calculates volume integral (*[m^3]) with full bottom cells
!
implicit none

! input/output variables
integer                                     :: k
integer, parameter                          :: imt=3600,jmt=2400,km=42
integer,                        intent(in)  :: imin,jmin,kmin,imax,jmax,kmax
real,    dimension(km),         intent(in)  :: dz
real,    dimension(imt,jmt,km), intent(in)  :: DZ_3D,FIELD
real,    dimension(imt,jmt),    intent(in)  :: AREA
real,                           intent(out) :: INTEGRAL

INTEGRAL = 0.0
do k = kmin,kmax
  INTEGRAL = INTEGRAL                                                          &
           + sum( AREA(imin:imax,jmin:jmax)*FIELD(imin:imax,jmin:jmax,k),      &
                  DZ_3D(imin:imax,jmin:jmax,k).ne.0.0 ) * dz(k)
enddo !k

end subroutine vol_int_full
!===============================================================================
!===============================================================================
subroutine vol_int2(imin,jmin,kmin,imax,jmax,kmax,FIELD,TAREA,DZT,INTEGRAL)
!
!     calculates volume integral (*[m^3]) for TTT-field via Kahan summation
!
implicit none

! input/output variables
integer                                     :: i,j,k
integer, parameter                          :: imt=3600,jmt=2400,km=42
integer,                        intent(in)  :: imin,jmin,kmin,imax,jmax,kmax
real,    dimension(imt,jmt,km), intent(in)  :: DZT,FIELD
real,    dimension(imt,jmt),    intent(in)  :: TAREA
real,                           intent(out) :: INTEGRAL
real                                        :: c, y, t

INTEGRAL = 0.0
c = 0.0
do k = kmin,kmax
  do j = jmin,jmax
    do i = imin,imax
      if ( DZT(i,j,k).ne.0.0 ) then
        y = TAREA(i,j) * DZT(i,j,k) * FIELD(i,j,k) - c
        t = INTEGRAL + y
        c = ( t - INTEGRAL ) - y
        INTEGRAL = t
      endif
    enddo !i
  enddo !j
enddo !k

INTEGRAL = INTEGRAL

end subroutine vol_int2
!===============================================================================

!===============================================================================
subroutine surf_int_3D(imin,jmin,imax,jmax,FIELD,TAREA,DZT_k,INTEGRAL)
!  calculates surface integrals *[m^2] weighting contribution by (pbc)cell-depth
implicit none

integer, parameter                          :: imt=3600,jmt=2400,km=42
integer,                     intent(in)  :: imin,jmin,imax,jmax
real,    dimension(imt,jmt), intent(in)  :: FIELD,TAREA,DZT_k
real,                        intent(out) :: INTEGRAL
real                                     :: avg_dz

avg_dz   = sum( TAREA(imin:imax,jmin:jmax) * DZT_k(imin:imax,jmin:jmax),       &
                DZT_k(imin:imax,jmin:jmax).ne.0.0  ) /    &
           sum( TAREA(imin:imax,jmin:jmax),  DZT_k(imin:imax,jmin:jmax).ne.0.0 )
INTEGRAL = sum( TAREA(imin:imax,jmin:jmax) * FIELD(imin:imax,jmin:jmax)        &
              * DZT_k(imin:imax,jmin:jmax),  DZT_k(imin:imax,jmin:jmax).ne.0.0)
INTEGRAL = INTEGRAL/avg_dz

end subroutine surf_int_3D
!===============================================================================

!===============================================================================
subroutine surf_int_2D(imin,jmin,imax,jmax,FIELD,TAREA,MASK,INTEGRAL)
!
!     calculates surface integral (*[m^2]) for TT-surface, using Kahan Summation
!
implicit none

integer, parameter                          :: imt=3600,jmt=2400,km=42
integer,                     intent(in)  :: imin,jmin,imax,jmax
real,    dimension(imt,jmt), intent(in)  :: FIELD,TAREA,MASK!=DZT(:,:,1)
real,                        intent(out) :: INTEGRAL

INTEGRAL = sum(TAREA(imin:imax,jmin:jmax)*FIELD(imin:imax,jmin:jmax),          &
               MASK(imin:imax,jmin:jmax).ne.0.0)

end subroutine surf_int_2D
!===============================================================================

!===============================================================================
subroutine area_avg(FIELD,DZT,AREA,area_k,avg)
! creates unweighted area average

integer                                     :: i,j,k
integer, parameter                          :: imt=3600,jmt=2400,km=42
real,    dimension(imt,jmt,km), intent(in)  :: FIELD, DZT
real,    dimension(imt,jmt),    intent(in)  :: AREA
real,    dimension(km),         intent(in)  :: area_k
real,    dimension(km),         intent(out) :: avg

do k=1,km
  avg(k) = sum(FIELD(:,:,k)*AREA(:,:),DZT(:,:,k).ne.0.0)/area_k(k)
enddo

end subroutine area_avg
!===============================================================================

!===============================================================================
subroutine area_avg_weighted(FIELD,DZT,AREA,vol,w_avg)
! creates cell depth weighted area average

integer                                     :: i,j,k
integer, parameter                          :: imt=3600,jmt=2400,km=42
real,    dimension(imt,jmt,km), intent(in)  :: FIELD, DZT
real,    dimension(imt,jmt),    intent(in)  :: AREA
real,    dimension(km),         intent(in)  :: vol
real,    dimension(km),         intent(out) :: w_avg

do k=1,km
  w_avg(k) = sum(FIELD(:,:,k)*AREA(imt,jmt)*DZT(:,:,k),DZT(:,:,k).ne.0.0)/vol(k)
enddo

end subroutine area_avg_weighted
!===============================================================================

!===============================================================================
subroutine masked_avg(DXT,DYT,MASK,mask_area,FIELD,value)
implicit none
!
!  reads yearly data that was previoously calculated and written into a binary
!

integer                                  :: i,j,k
integer, parameter                       :: imt=3600,jmt=2400,km=42
real,    dimension(imt,jmt), intent(in)  :: DXT,DYT,FIELD
real,                        intent(in)  :: mask_area
integer, dimension(imt,jmt), intent(in)  :: MASK
real,                        intent(out) :: value

value = sum(FIELD*DXT*DYT*MASK)/mask_area

end subroutine masked_avg
!===============================================================================

!===============================================================================
subroutine vert_int(FIELD,DZT,INTEGRAL)
!
!     calculates vertical integral (*[m]) for TT-surface, using Kahan Summation
!
implicit none

! input/output variables
integer                                     :: i,j,k
integer, parameter                          :: imt=3600,jmt=2400,km=42
real,    dimension(imt,jmt,km), intent(in)  :: DZT, FIELD
real,    dimension(imt,jmt),    intent(out) :: INTEGRAL

INTEGRAL = sum(DZT*FIELD,3)
! DZT in [cm], factor 1e-2 used to achieve [m]

end subroutine vert_int
!===============================================================================

!===============================================================================
subroutine zonal_int(DXT,FIELD,FIELD_zint)
!
!  "zonal" integral, true for Southern Hemisphere, Northern one is distorted
!
implicit none

integer                                  :: i,j,k
integer, parameter                       :: imt=3600,jmt=2400,km=42
real,    dimension(imt,jmt), intent(in)  :: DXT, FIELD
real,    dimension(jmt),     intent(out) :: FIELD_zint

FIELD_zint(:) = sum(FIELD(:,:)*DXT(:,:),1)

end subroutine
!===============================================================================


!==============================================================================!
  subroutine Vof_Initialization_Ellipsoid(mult)
!------------------------------------------------------------------------------!
!   Initialize dependent variables.  (It is a bit of a mess still)             !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Work_Mod, only: prelim_vof     => r_cell_01,  &
                      min_max_crit_1 => r_cell_02,  &
                      min_max_crit_2 => r_cell_03
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Multiphase_Type), target :: mult
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type),  pointer :: grid
  integer                   :: c, n, fu
  integer                   :: ee, n_ellipses
  real                      :: radius_1, radius_2, radius_3
  real                      :: cent_x, cent_y, cent_z, res_dummy
!==============================================================================!

  ! First take aliases
  grid => mult % pnt_grid

  prelim_vof = 0.0

  ! Open file to read Ellipsoid parameters:
  call File_Mod_Open_File_For_Reading('ellipsoid_parameters.dat', fu)

  read(fu, *) n_ellipses

  do ee = 1, n_ellipses

    ! Taking extrema
    min_max_crit_1(:) =  HUGE
    min_max_crit_2(:) = -HUGE

    read(fu, *) radius_1, radius_2, radius_3
    read(fu, *) cent_x, cent_y, cent_z

    do c = 1, grid % n_cells
      ! for every node:
      do n = 1, grid % cells_n_nodes(c)
        res_dummy = sqrt(                                             &
              ((grid % xn(grid % cells_n(n,c))-cent_x)/radius_1)**2   &
            + ((grid % yn(grid % cells_n(n,c))-cent_y)/radius_2)**2   &
            + ((grid % zn(grid % cells_n(n,c))-cent_z)/radius_3)**2)

        min_max_crit_1(c)= min(res_dummy, min_max_crit_1(c))
        min_max_crit_2(c)= max(res_dummy, min_max_crit_2(c))
      end do
    end do

    ! Simply interpolate linearly
    do c = 1, grid % n_cells
      if (min_max_crit_1(c) < 1.0 .and. min_max_crit_2(c) > 1.0) then
        prelim_vof(c) = (1.0 - min_max_crit_1(c))  &
                      / (min_max_crit_2(c)-min_max_crit_1(c))
      else if (min_max_crit_2(c) <= 1.0) then
        prelim_vof(c) = 1.0
      end if
    end do

    ! Precision
    do c = 1, grid % n_cells
      mult % vof % n(c) = max(prelim_vof(c),mult % vof % n(c))
    end do

  end do

  close(fu)

  end subroutine


      INTEGER FUNCTION ICAMAX(N,CX,INCX)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 CLL Typing all variables.
C>> 1985-08-02 ICAMAX Lawson  Initial code.
C
C      RETURNS THE INDEX OF THE COMPONENT OF CX HAVING THE
C      LARGEST SUM OF MAGNITUDES OF REAL AND IMAGINARY PARTS.
C     ICAMAX = FIRST I, I = 1 TO N, TO MINIMIZE
C        ABS(REAL(CX(1-INCX+I*INCX))) + ABS(IMAG(CX(1-INCX+I*INCX)))
C
      integer I, II, INCX, N
      real SUMMAX, SUMRI
      COMPLEX CX(*)
C
      ICAMAX = 0
      IF(N.LE.0) RETURN
      ICAMAX = 1
      IF(N .LE. 1) RETURN
      II = 1
      SUMMAX = ABS(REAL(CX(1))) + ABS(AIMAG(CX(1)))
      DO 20 I=1,N*INCX,INCX
         SUMRI = ABS(REAL(CX(I))) + ABS(AIMAG(CX(I)))
         IF(SUMMAX .lt. SUMRI) then
            SUMMAX = SUMRI
            ICAMAX = II
         endif
         II = II + 1
   20 CONTINUE
      RETURN
      END


c     program DRSSYMQL
c>> 1996-05-28 DRSSYMQL  Krogh Added external statement.
c>> 1994-10-19 DRSSYMQL  Krogh  Changes to use M77CON
c>> 1994-09-22 DRSSYMQL  CLL
c>> 1992-04-23 CLL
c>> 1992-03-04 DRSSYMQL  Krogh Initial version.
c     Demonstrate symmetric eigenvalue/eigenvector subroutine SSYMQL.
c     ------------------------------------------------------------------
c--S replaces "?": DR?SYMQL, ?SYMQL, ?VECP, ?MATP, ?DOT
c     ------------------------------------------------------------------
      integer I, IERR, J, LDA, N
      parameter (LDA = 4)
      real             A(LDA,LDA), ASAV(LDA,LDA), ANORM, D(LDA,LDA)
      external SDOT
      real             SDOT, EVAL(LDA), WORK(LDA)
      data A(1,1)          /  5.0e0 /
      data (A(2,J), J=1,2) /  4.0e0,  5.0e0 /
      data (A(3,J), J=1,3) /  1.0e0,  1.0e0, 4.0e0 /
      data (A(4,J), J=1,4) /  1.0e0,  1.0e0, 2.0e0, 4.0e0 /
      data ANORM / 11.0e0 /
      data N /LDA/
c     ------------------------------------------------------------------
      print*,'DRSSYMQL..  Demo driver for SSYMQL.'
c
c     First copy A() to ASAV() for later residual check.
c
      do 20 I = 1,N
         do 10 J = 1,I
            ASAV(I,J) = A(I,J)
            ASAV(J,I) = ASAV(I,J)
   10    continue
   20 continue
      call SSYMQL(A, LDA, N, EVAL, WORK, IERR)
      if (IERR .eq. 0) then
         call SVECP(EVAL, N, '0 Eigenvalues')
         call SMATP(A, LDA, N, N,  '0 Eigenvectors as column vectors')
c
c        As a check compute D = (ASAV*EVEC - EVEC*EVAL) / ANORM.
c        The EVEC's are in the array A().
c        Expect D to be close to machine precision.
c
         do 40 J = 1, N
            do 30 I = 1, N
               D(I, J) = (SDOT(N, ASAV(I,1), LDA, A(1,J), 1) -
     *                  A(I,J) * EVAL(J)) / ANORM
   30       continue
   40    continue
         call SMATP(D, LDA, N, N,
     *         '0 Residual matrix D = (A*EVEC - EVEC*EVAL) / ANORM')

      else
         print '(/a,i5)',' Convergence failure in SSYMQL, IERR =',IERR
      end if
      stop
      end


      SUBROUTINE niching_func_cons(func,x,dims,cons,fitness,consfit)

!     NEIGHBOURHOOD-BASED SPECIATION DIFFERNETIAL EVOLUTION MULTIMODAL
!     OPTIMIZER WITH FEASIBLE SELECTION FOR CONSTRAINTS.
!
!     Copyright 2018 Daniel Poole
!
!     Permission is hereby granted, free of charge, to any person
!     obtaining a copy of this software and associated documentation
!     files (the "Software"), to deal in the Software without restriction,
!     including without limitation the rights to use, copy, modify, merge,
!     publish, distribute, sublicense, and/or sell copies of the Software,
!     and to permit persons to whom the Software is furnished to do so,
!     subject to the following conditions:
!
!     The above copyright notice and this permission notice shall be
!     included in all copies or substantial portions of the Software.
!
!     THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
!     EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
!     OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
!     NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
!     BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
!     AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR
!     IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
!     THE SOFTWARE.

      IMPLICIT NONE

      INTEGER, INTENT(IN):: func, dims, cons
      DOUBLE PRECISION, INTENT(INOUT), DIMENSION(dims):: x
      DOUBLE PRECISION, INTENT(OUT):: fitness
      DOUBLE PRECISION, INTENT(OUT):: consfit(cons)

      INTEGER:: i, heavi
      DOUBLE PRECISION:: pi, obj1, obj2
      DOUBLE PRECISION:: x1,x2,x3,x4,y1,y2,y3,y4,conseps
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:):: k

      pi=4.0d0*DATAN(1.0d0)
      conseps=1.0E-4

      SELECT CASE(func)
      CASE(10)

        fitness=-SIN(5.0d0*pi*x(1))**6+1.0d0
        consfit(1)=-COS(10.0d0*pi*x(1))

      CASE(11)

!       HIMMELBLAU CONSTRAINED BY QUADRATICS SUCH THAT ONE CONSTRAINT
!       TOUCHES TWO OPTIMAL POINTS, THEREFORE AT EACH OPTIMAL POINT,
!       TWO CONSTRAINTS ARE ACTIVE

        fitness=(x(1)**2+x(2)-11.0d0)**2+(x(1)+x(2)**2-7.0d0)**2+1.0d0

        x1=3.0d0
        y1=2.0d0
        x2=-2.805118d0
        y2=3.131312d0
        x3=-3.779310d0
        y3=-3.283186d0
        x4=3.584428d0
        y4=-1.848126d0

        consfit(1)=(x1*x2)-(x1*x(1))-(x2*x(1))+(y1*y2)-(y1*x(2))-(y2*x(2))+(x(1)**2)+(x(2)**2)
        consfit(2)=(x2*x3)-(x2*x(1))-(x3*x(1))+(y2*y3)-(y2*x(2))-(y3*x(2))+(x(1)**2)+(x(2)**2)
        consfit(3)=(x3*x4)-(x3*x(1))-(x4*x(1))+(y3*y4)-(y3*x(2))-(y4*x(2))+(x(1)**2)+(x(2)**2)
        consfit(4)=(x4*x1)-(x4*x(1))-(x1*x(1))+(y4*y1)-(y4*x(2))-(y1*x(2))+(x(1)**2)+(x(2)**2)

        consfit(:)=-consfit(:)

      CASE(12)

!       HIMMELBLAU CONSTRAINED BY QUADRATICS AND PLANES SUCH THAT
!       AT EACH OPTIMAL POINT THREE CONSTRAINTS ARE ACTIVE.
!       OPTIMAL POINTS AT SINGLE POINT WHERE CONS ARE ACTIVE

        fitness=(x(1)**2+x(2)-11.0d0)**2+(x(1)+x(2)**2-7.0d0)**2+1.0d0

        x1=3.0d0
        y1=2.0d0
        x2=-2.805118d0
        y2=3.131312d0
        x3=-3.779310d0
        y3=-3.283186d0
        x4=3.584428d0
        y4=-1.848126d0

        consfit(1)=(x1*x2)-(x1*x(1))-(x2*x(1))+(y1*y2)-(y1*x(2))-(y2*x(2))+(x(1)**2)+(x(2)**2)
        consfit(2)=(x2*x3)-(x2*x(1))-(x3*x(1))+(y2*y3)-(y2*x(2))-(y3*x(2))+(x(1)**2)+(x(2)**2)
        consfit(3)=(x3*x4)-(x3*x(1))-(x4*x(1))+(y3*y4)-(y3*x(2))-(y4*x(2))+(x(1)**2)+(x(2)**2)
        consfit(4)=(x4*x1)-(x4*x(1))-(x1*x(1))+(y4*y1)-(y4*x(2))-(y1*x(2))+(x(1)**2)+(x(2)**2)
        consfit(1:4)=-consfit(1:4)

        consfit(5)=(x(1)-x1)+(x(2)-y1)
        consfit(6)=-(x(1)-x2)+(x(2)-y2)
        consfit(7)=-(x(1)-x3)-(x(2)-y3)
        consfit(8)=(x(1)-x4)-(x(2)-y4)

      CASE(13,14,15,16,17,18)

!       MODULO-MODIFIED RASTRIGIN: DEB'S MODIFIED RASTRIGIN BUT FOR X<1, NO
!       X^2 UNDERLYING TREND - CAUSES PROBLEM TO HAVE GLOBAL AND LOCAL
!       MINIMA. CREATED BY D. POOLE.

        ALLOCATE(k(dims))

        SELECT CASE(func)
        CASE(13)
          k(1)=1.0d0
        CASE(14)
          k(1)=5.0d0
        CASE(15)
          k(1)=1.0d0
          k(2)=2.0d0
        CASE(16)
          k(1)=2.0d0
          k(2)=3.0d0
        CASE(17)
          k(1)=1.0d0
          k(2)=1.0d0
          k(3)=2.0d0
        CASE(18)
          k(1)=1.0d0
          k(2)=1.0d0
          k(3)=1.0d0
          k(4)=1.0d0
          k(5)=2.0d0
        END SELECT

        obj1=0.0d0
        obj2=0.0d0
        DO i=1,dims
          heavi=heaviside(x(i)-1.0d0)
          obj1=obj1+(10.0d0*(1.0d0+COS(2.0d0*pi*k(i)*x(i)))+&
     &               (2.0d0*k(i)*(x(i)-1.0d0)**2*heavi))

          obj2=obj2+(20.0d0*COS(4.0d0*pi*k(i)*x(i)))
        END DO
        fitness=obj1
        consfit(1)=obj2

      CASE(20)

        obj1=0.0d0
        obj2=0.0d0
        DO i=1,dims
          obj1=obj1+(10.0d0*COS(0.1d0*x(i)))
          obj2=obj2+(x(i)*COS(SQRT(ABS(x(i)))))
        END DO
        fitness=obj1
        consfit(1)=obj2
        consfit(1)=ABS(consfit(1))-conseps

      CASE(21)

        x1=x(1)
        x2=x(2)
        fitness=(x1**2+x1+x2**2+2.1d0*x2)+10.0d0*(1.0d0-COS(2.0d0*pi*x1))+&
     &                                    10.0d0*(1.0d0-COS(2.0d0*pi*x2))
        fitness=10.0d0*(1.0d0-COS(2.0d0*pi*x1))+&
     &                                    10.0d0*(1.0d0-COS(2.0d0*pi*x2))
        consfit(1)=-0.0d0

      CASE DEFAULT
        CALL CMMP(dims, cons, x, fitness, consfit)
      END SELECT

      CONTAINS

      INTEGER FUNCTION heaviside(x)
      IMPLICIT NONE
      DOUBLE PRECISION, INTENT(IN)::x
      IF(x.GE.0.0d0)THEN
        heaviside=1
      ELSE
        heaviside=0
      END IF
      END FUNCTION

      END SUBROUTINE

      SUBROUTINE niching_func_bound_cons(func, dims, bounds)

      IMPLICIT NONE

      INTEGER, INTENT(IN):: func, dims
      DOUBLE PRECISION, INTENT(OUT), DIMENSION(dims,2):: bounds

      SELECT CASE(func)
      CASE(10)
       bounds(:,1)=0.0d0
       bounds(:,2)=1.0d0
      CASE(11,12)
       bounds(:,1)=-6.0d0
       bounds(:,2)=6.0d0
      CASE(13,14,15,16,17,18)
       bounds(:,1)=0.0d0
       bounds(:,2)=2.0d0
      CASE(20)
       bounds(:,1)=-100.0d0
       bounds(:,2)=100.0d0
      CASE(21)
       bounds(:,1)=0.5d0
       bounds(:,2)=4.5d0
      CASE(30:39)
       bounds(:,1)=-DBLE(dims+1)
       bounds(:,2)=DBLE(dims+1)
      CASE DEFAULT
       bounds(:,1)=-DBLE(dims+1)
       bounds(:,2)=DBLE(dims+1)
      END SELECT

      END SUBROUTINE

      SUBROUTINE CMMP(n, J, x, f, g)
      IMPLICIT NONE
!     FROM DEB AND SAHA, GECCO2010
      INTEGER, INTENT(IN):: n, J
      DOUBLE PRECISION, INTENT(IN):: x(n)
      DOUBLE PRECISION, INTENT(OUT):: f, g(J)
!     NOTE: L not currently used
      INTEGER:: i, jj, ii, C
      INTEGER, ALLOCATABLE, DIMENSION(:):: Cvec

!     OBJECTIVE
      f=0.0d0
      DO i=1,n
        f=f+x(i)**2
      END DO

!     CONSTRAINTS
      ALLOCATE(Cvec(J*n))
      ii=0
      DO jj=1,J
       DO i=1,n
         ii=ii+1
         Cvec(ii)=i
       END DO
      END DO
      ii=1
      DO jj=1,J
        ii=ii-1
        g(jj)=0.0d0
        DO i=1,n
            ii=ii+1
            C=Cvec(ii)
            g(jj)=g(jj)+(DBLE(C)**2 * x(i)**2)
        END DO
        g(jj)=n**2 - g(jj)
      END DO

      END SUBROUTINE


Module RouteTypesAndMethods
  Implicit none

  Type :: Route
    Integer :: Dest
    Integer :: Cost
  END Type Route

  Type :: Node
    Type(Route), Dimension(:), Allocatable :: Neighbors
  End Type Node

  contains

  Recursive Function get_longest_path(nodes,length,node_counts,visited,current_node) Result(distance)
    Implicit none
    Integer, Intent(in)                           :: length
    Type (node), dimension(length), Intent(in)    :: nodes
    Integer, Dimension(length), Intent(in)        :: node_counts
    Logical, Dimension(length), Intent(inout)     :: visited
    Integer, Intent(in)                           :: current_node
    Integer                                       :: distance
    Integer :: I,temp_distance,curmax

    temp_distance=0
    curmax=0

    visited(current_node) = .TRUE.
    DO I=1,node_counts(current_node)
      IF (visited( nodes(current_node)%Neighbors(I)%Dest)) THEN
        CYCLE
      END IF
      temp_distance = nodes(current_node)%Neighbors(I)%Cost + &
        get_longest_path(nodes,length,node_counts,visited,nodes(current_node)%Neighbors(I)%Dest)
      IF (temp_distance > curmax) THEN
        curmax=temp_distance
      END IF
    END DO
    visited(current_node) = .FALSE.
    distance = curmax

  End Function get_longest_path

  Subroutine add_routes_to_neighbors(nodes,length,node_counts)
    Implicit none
    Integer, Intent(in)                           :: length
    Type (Node), Dimension(length), Intent(inout) :: nodes
    Integer, Dimension(length), Intent(in)        :: node_counts

    Integer :: err,temp,node_minus_one,destination_minus_one,cost

    OPEN(UNIT=10,FILE='agraph',STATUS='OLD',ACTION='READ',IOSTAT=err)
    IF (err /= 0) THEN
      WRITE (*,*) "Error code of ",err,"in reading file."
      STOP
    END IF

    READ (10,'(I2)') temp
    temp         = 1

    READ(10,*) node_minus_one,destination_minus_one,cost
    DO WHILE (err == 0)
      ! We could do something crazier here, but luckily file is ordered
      DO temp = 1,node_counts(node_minus_one+1)
        nodes(node_minus_one+1)%Neighbors(temp)%Dest = destination_minus_one + 1
        nodes(node_minus_one+1)%Neighbors(temp)%Cost = cost
        READ(10,*,IOSTAT=err) node_minus_one,destination_minus_one,cost
        IF (err /= 0) THEN
          EXIT
        END IF
      END DO

    ENDDO
    CLOSE(10)

  End Subroutine add_routes_to_neighbors

  Subroutine populate_neighbors(nodes,length,node_counts)
    Implicit none
    Integer, Intent(in) :: length
    Type (Node), Intent(inout), Dimension(length) :: nodes
    Integer :: I=0,err,node_minus_one,neighbor,cost
    Integer, Dimension(1:length), Intent(out) :: node_counts
    ! Initialize all of node_counts to zero
    node_counts = 0
    OPEN(UNIT=10,FILE='agraph',STATUS='OLD',ACTION='READ',IOSTAT=err)
    IF (err /= 0) THEN
      WRITE (*,*) "Err of ",err," in reading the file."
      STOP
    END IF

    READ (10,'(I2)') I

    READ(10,*,IOSTAT=err) node_minus_one,neighbor,cost

    DO WHILE (err == 0)
      node_counts(node_minus_one+1) = node_counts(node_minus_one+1)+1
      READ(10,*,IOSTAT=err) node_minus_one,neighbor,cost
    END DO

    AllocateNeighbors: DO I=1,length
      Allocate(nodes(I)%Neighbors(node_counts(I)))
    END DO AllocateNeighbors
    CLOSE(10)
  End Subroutine populate_neighbors

  Subroutine populate_node_array(nodes,total_node_count)
    Implicit none
    Type (Node), Intent(out), Dimension(:), Allocatable  :: nodes
    Integer,     Intent(out)                             :: total_node_count
    Call get_total_nodes(total_node_count)
    If (total_node_count == -1) Then
      WRITE (*,*) "Error reading file - recompile to get error message"
      STOP
    END IF
    ALLOCATE(nodes(total_node_count))
  End Subroutine populate_node_array

  Subroutine get_total_nodes(node_count)
    Implicit none
    Integer, intent(out) :: node_count
    Integer :: err
    OPEN(UNIT=10,FILE='agraph',STATUS='OLD',ACTION='READ',IOSTAT=err)
    READ(10,'(I2)') node_count
    IF (err /= 0) THEN
      node_count = -1
    END IF
    CLOSE(10)
  End Subroutine get_total_nodes
End Module RouteTypesAndMethods

PROGRAM LONGESTROUTE
  Use RouteTypesAndMethods
  Implicit None
  Integer :: total_node_count=0
  Integer, Dimension(:), Allocatable :: node_lengths
  Integer :: I=0
  Integer :: max_distance=0
  Real    :: start_time=0.,end_time=0.
  Type (Node), Dimension(:), Allocatable :: Nodes
  Logical, Dimension(:), Allocatable     :: visited

  ! Read first line and allocate nodes
  Call populate_node_array(Nodes,total_node_count)
  Allocate(node_lengths(total_node_count))
  Allocate(visited(total_node_count))
  node_lengths = 0
  visited      = .FALSE.
  ! Read rest of file and allocate lengths for each node's neighbor array
  Call populate_neighbors(Nodes,total_node_count,node_lengths)
  Call add_routes_to_neighbors(Nodes,total_node_count,node_lengths)
  I = 1
  Call CPU_TIME(start_time)
  !Recursive Function get_longest_path(nodes,length,node_counts,visited,current_node) Result(distance)
  max_distance = get_longest_path(Nodes,total_node_count,node_lengths,visited,I)
  Call CPU_TIME(end_time)
  write (*,'(I4," LANGUAGE Fortran_2003 ",I4)') max_distance, INT((end_time-start_time)*1000)
END PROGRAM LONGESTROUTE


      PROGRAM sphoot
      INTEGER i,m,n,nvar,N2
      PARAMETER (N2=1)
      REAL c2,dx,gamma,q1,x1,x2,v(N2)
      LOGICAL check
      COMMON /sphcom/ c2,gamma,dx,m,n
      COMMON /caller/ x1,x2,nvar
CU    USES newt
      dx=1.e-4
      nvar=3
1     write(*,*) 'input m,n,c-squared (999 to end)'
      read(*,*) m,n,c2
      if (c2.eq.999.) stop
      if ((n.lt.m).or.(m.lt.0)) goto 1
      gamma=1.0
      q1=n
      do 11 i=1,m
        gamma=-0.5*gamma*(n+i)*(q1/i)
        q1=q1-1.0
11    continue
      v(1)=n*(n+1)-m*(m+1)+c2/2.0
      x1=-1.0+dx
      x2=0.0
      call newt(v,N2,check)
      if(check)then
        write(*,*)'shoot failed; bad initial guess'
      else
        write(*,'(1x,t6,a)') 'mu(m,n)'
        write(*,'(1x,f12.6)') v(1)
        goto 1
      endif
      END
      SUBROUTINE load(x1,v,y)
      INTEGER m,n
      REAL c2,dx,gamma,x1,y1,v(1),y(3)
      COMMON /sphcom/ c2,gamma,dx,m,n
      y(3)=v(1)
      if(mod(n-m,2).eq.0)then
        y1=gamma
      else
        y1=-gamma
      endif
      y(2)=-(y(3)-c2)*y1/(2*(m+1))
      y(1)=y1+y(2)*dx
      return
      END
      SUBROUTINE score(x2,y,f)
      INTEGER m,n
      REAL c2,dx,gamma,x2,f(1),y(3)
      COMMON /sphcom/ c2,gamma,dx,m,n
      if (mod(n-m,2).eq.0) then
        f(1)=y(2)
      else
        f(1)=y(1)
      endif
      return
      END
      SUBROUTINE derivs(x,y,dydx)
      INTEGER m,n
      REAL c2,dx,gamma,x,dydx(3),y(3)
      COMMON /sphcom/ c2,gamma,dx,m,n
      dydx(1)=y(2)
      dydx(2)=(2.0*x*(m+1.0)*y(2)-(y(3)-c2*x*x)*y(1))/(1.0-x*x)
      dydx(3)=0.0
      return
      END

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