MODULE InputPara

  IMPLICIT NONE

  PUBLIC
  INTEGER, PARAMETER :: nx = 101, nz = 101                      ! nx: the total number of grid nodes in x-direction; nz: the total number of grid nodes in z-direction.
  INTEGER, PARAMETER :: npmlx = 20, npmlz = 20                  ! npmlx: the total number of grid nodes in top and bottom side of PML absorbing boundary; npmlz: the total number of grid nodes in left and right side of PML absorbing boundary.
  INTEGER, PARAMETER :: sx = 50, sz = 50                        ! sx: the grid node number of source position in x-direction; sz: the grid node number of source position in z-direction.
  INTEGER, PARAMETER :: dx = 5, dz = 5                          ! dx: the grid node interval in x-direction; dz: the grid node interval in z-direction; Unit: m.
  INTEGER, PARAMETER :: nt = 500                                ! the total number of time nodes for wave calculating.
  REAL   , PARAMETER :: dt = 1.0E-3                             ! the time node interval, Unit: s.
  INTEGER, PARAMETER :: nppw = 12                               ! the total node point number per wavelength for dominant frequency of Ricker wavelet source.
  REAL   , PARAMETER :: amp = 1.0E0                             ! the amplitude of source wavelet.
  INTEGER, PARAMETER :: nodr = 3                                ! half of the order number for spatial difference.
  INTEGER, PARAMETER :: irstr = 1                               ! the node ID of starting reciver point.
  INTEGER, PARAMETER :: nrintv = 3                              ! the total node number between each two adjacent recivers.
  INTEGER, PARAMETER :: itstr = 1                               ! the time node ID of the first snapshot.
  INTEGER, PARAMETER :: ntintv = 5                              ! the total time node number between each two followed snapshot.

  REAL    :: src(nt)                                            ! the time series of source wavelet.
  REAL    :: vp(nz, nx), rho(nz, nx)                            ! vp: the velocity of acoustic wave of model, Unit: m/s; rho: the density of model, Unit: kg/m^3.
  INTEGER, PARAMETER :: nrcvr = CEILING(REAL(nx)/nrintv)        ! the total number of all recivers.
  INTEGER :: xrcvr(nrcvr)                                       ! the grid node number in x-direction of reciver position on ground.

  INTEGER, PRIVATE :: i

  PRIVATE nppw, amp
  PRIVATE ModelVpRho, SrcWavelet

  CONTAINS
    SUBROUTINE IntlzInputPara()
      xrcvr = [ (irstr + (i - 1)*nrintv, i = 1, nrcvr) ]
      CALL ModelVpRho()
      CALL SrcWavelet()
    END SUBROUTINE IntlzInputPara
    SUBROUTINE ModelVpRho()
      ! here you can reset $vp$ and $rho$ for the model.
      vp = 2000
      vp(nz/3:nz, nx/2:nx) = 1000
      rho = 1000
      rho(nz/3:nz, nx/2:nx) = 500
    END SUBROUTINE ModelVpRho
    SUBROUTINE SrcWavelet()
      ! here you can reset $src$ for the source wavelet.
      REAL :: f0, t0, pi = 3.1415926
      REAL :: t(nt)
      f0 = MINVAL(vp)/(MIN(dx, dz)*nppw)
      t0 = 1/f0
      t = [ (i*dt, i = 1, nt) ]
      src = amp*(1 - 2*(pi*f0*(t - t0))**2)*EXP( - (pi*f0*(t - t0))**2)
    END SUBROUTINE SrcWavelet

END MODULE InputPara

MODULE WaveExtrp

  USE InputPara
  IMPLICIT NONE

  PRIVATE
  REAL :: C(nodr)                                               ! the difference coefficients of spatial the $2*nodr$-th order difference approximating.
  INTEGER, PARAMETER :: Nzz = nz + 2*npmlz, Nxx = nx + 2*npmlx  ! Nzz: the total number of grid nodes in z-direction of compute-updating zone including PML layer; Nxx: the total number of grid nodes in x-direction of compute-updating zone including PML layer.
  REAL :: vpp(Nzz, Nxx), rhoo(Nzz, Nxx)                         ! vpp: the velocity of the expanded model including PML layer, Unit: m/s; rhoo: the density of the expanded model including PML layer, Unit: kg/m^3.
  REAL :: dpmlz(Nzz, Nxx), dpmlx(Nzz, Nxx)                      ! dpmlz: the PML damping factor in z-direction; dpmlx: the PML damping factor in x-direction.
  REAL :: Coef1(Nzz, Nxx), Coef2(Nzz, Nxx), &
    & Coef3(Nzz, Nxx), Coef4(Nzz, Nxx), &
    & Coef5(Nzz, Nxx), Coef6(Nzz, Nxx)                          ! Coef1 ~ Coef6: the coefficients of wavefield time-extrapolating formula.

  INTEGER :: i, j

  REAL, PUBLIC :: P(nz, nx, nt)                                 ! the calculating wavefield component varying with time.

  PUBLIC WaveExec

  CONTAINS
    SUBROUTINE WaveExec()
      CALL CalC()
      CALL ModelExpand()
      CALL CalCoefs()
      CALL CalWave()
    END SUBROUTINE WaveExec
    SUBROUTINE CalC()
      REAL :: rtemp1, rtemp2
      DO i = 1,nodr,1
        rtemp1 = 1.0
        rtemp2 = 1.0
        DO j = 1,nodr,1
          IF(j == i) CYCLE
          rtemp1 = rtemp1*((2*j - 1)**2)
          rtemp2 = rtemp2*ABS((2*i - 1)**2 - (2*j - 1)**2)
        END DO
        C(i) = ( - 1)**(i + 1)*rtemp1/((2*i - 1)*rtemp2)
      END DO
    END SUBROUTINE CalC
    SUBROUTINE ModelExpand()
      vpp = 0.0
      rhoo = 0.0
      vpp(npmlz + 1:npmlz + nz, npmlx + 1:npmlx + nx) = vp
      rhoo(npmlz + 1:npmlz + nz, npmlx + 1:npmlx + nx) = rho
      DO i = 1,npmlx,1
        vpp(:, i) = vpp(:, npmlx + 1)
        vpp(:, npmlx + nx + i) = vpp(:, npmlx + nx)
        rhoo(:, i) = rhoo(:, npmlx + 1)
        rhoo(:, npmlx + nx + i) = rhoo(:, npmlx + nx)
      END DO
      DO i = 1,npmlz,1
        vpp(i, :) = vpp(npmlz + 1, :)
        vpp(npmlz + nz + i, :) = vpp(npmlz + nz, :)
        rhoo(i, :) = rhoo(npmlz + 1, :)
        rhoo(npmlz + nz + i, :) = rhoo(npmlz + nz, :)
      END DO
    END SUBROUTINE ModelExpand
    SUBROUTINE CalDpml()
      REAL :: dpml0z, dpml0x
      dpml0z = 3*MAXVAL(vp)/dz*(8.0/15 - 3.0/100*npmlz + 1.0/1500*(npmlz**2))
      DO i = 1,npmlz,1
        dpmlz(i, :) = dpml0z*((REAL(npmlz - i + 1)/npmlz)**2)
      END DO
      dpmlz(npmlz + nz + 1:Nzz, :) = dpmlz(npmlz:1:-1, :)
      dpml0x = 3*MAXVAL(vp)/dx*(8.0/15 - 3.0/100*npmlx + 1.0/1500*(npmlx**2))
      DO i = 1,npmlx,1
        dpmlx(:, i) = dpml0x*((REAL(npmlx - i + 1)/npmlx)**2)
      END DO
      dpmlx(:, npmlx + nx + 1:Nxx) = dpmlx(:, npmlx:1:-1)
    END SUBROUTINE CalDpml
    SUBROUTINE CalCoefs()
      CALL CalDpml()
      Coef1 = (2 - dt*dpmlx)/(2 + dt*dpmlx)
      Coef2 = (2 - dt*dpmlz)/(2 + dt*dpmlz)
      Coef3 = (2*dt/(2 + dt*dpmlx))/(rhoo*dx)
      Coef4 = (2*dt/(2 + dt*dpmlz))/(rhoo*dz)
      Coef5 = (2*dt/(2 + dt*dpmlx))*(rhoo*(vpp**2)/dx)
      Coef6 = (2*dt/(2 + dt*dpmlz))*(rhoo*(vpp**2)/dz)
    END SUBROUTINE CalCoefs
    SUBROUTINE CalWave()
      INTEGER :: it
      INTEGER, PARAMETER :: Nzzz = Nzz + 2*nodr, Nxxx = Nxx + 2*nodr
      INTEGER :: znds(nz) = [ (nodr + npmlz + i, i = 1,nz,1) ], &
        & xnds(nx) = [ (nodr + npmlx + i, i = 1,nx,1) ]
      INTEGER :: Zznds(Nzz) = [ (nodr + i, i = 1,Nzz,1) ], &
        & Xxnds(Nxx) = [ (nodr + i, i = 1,Nxx,1) ]
      INTEGER :: nsrcz = nodr + npmlz + sz, nsrcx = nodr + npmlx + sx
      REAL    :: Pt(Nzzz, Nxxx) = 0, &
        & Pz(Nzzz, Nxxx) = 0, Px(Nzzz, Nxxx) = 0, &
        & vz(Nzzz, Nxxx) = 0, vx(Nzzz, Nxxx) = 0
      REAL    :: SpcSum(Nzz, Nxx)
      DO it = 1,nt,1
        WRITE(*,"(A,G0)") 'The calculating time node is: it = ',it
        Px(nsrcz, nsrcx) = Px(nsrcz, nsrcx) + src(it)/2
        Pz(nsrcz, nsrcx) = Pz(nsrcz, nsrcx) + src(it)/2
        Pt(:, :) = Px(:, :) + Pz(:, :)
        P(:, :, it) = Pt(znds, xnds)
        SpcSum = 0
        DO i = 1,nodr,1
          SpcSum = SpcSum + C(i)*(Pt(Zznds, Xxnds + i) - Pt(Zznds, Xxnds + 1 - i))
        END DO
        vx(Zznds, Xxnds) = Coef1*vx(Zznds, Xxnds) - Coef3*SpcSum
        SpcSum = 0
        DO i = 1,nodr,1
          SpcSum = SpcSum + C(i)*(Pt(Zznds + i, Xxnds) - Pt(Zznds + 1 - i, Xxnds))
        END DO
        vz(Zznds, Xxnds) = Coef2*vz(Zznds, Xxnds) - Coef4*SpcSum
        SpcSum = 0
        DO i = 1,nodr,1
          SpcSum = SpcSum + C(i)*(vx(Zznds, Xxnds - 1 + i) - vx(Zznds, Xxnds - i))
        END DO
        Px(Zznds, Xxnds) = Coef1*Px(Zznds, Xxnds) - Coef5*SpcSum
        SpcSum = 0
        DO i = 1,nodr,1
          SpcSum = SpcSum + C(i)*(vz(Zznds - 1 + i, Xxnds) - vz(Zznds - i, Xxnds))
        END DO
        Pz(Zznds, Xxnds) = Coef2*Pz(Zznds, Xxnds) - Coef6*SpcSum
      END DO
    END SUBROUTINE CalWave

END MODULE WaveExtrp

!************************  TDFDAWFS2DSG  ***********************
! Time Domain Finite Difference Acoustic Wave Field Simulating with 2-Dimension Staggered Grid
! Written by Tche. L. from USTC, 2016.7.
! References:
!   Collino and Tsogka, 2001. Geophysics, Application of the perfectly matched absorbing layer model to the linear elastodynamic problem in anisotropic heterogeneous media.
!   Marcinkovich and Olsen, 2003. Journal of Geophysical Research, On the implementation of perfectly mathced layers in a three-dimensional fourth-order velocity-stress finite difference scheme.
!***************************************************************
PROGRAM TDFDAWFS2DSG

  USE InputPara
  USE WaveExtrp
  IMPLICIT NONE

  CHARACTER(LEN = 128) :: SnapFile = './data/Snapshot_****.dat'       ! the snapshot file name template.
  CHARACTER(LEN = 128) :: SyntFile = './data/SyntRcrd.dat'                       ! the synthetic record file name.
  REAL    :: SyntR(nrcvr, nt)
  INTEGER :: i

  CALL IntlzInputPara()
  CALL WaveExec()
  DO i = itstr,nt,ntintv
    WRITE(SnapFile(21:24),"(I4.4)") i
    CALL Output(TRIM(SnapFile), nz, nx, P(:, :, i))
  END DO
  DO i = 1,nt,1
    SyntR(:, i) = P(1, xrcvr, i)
  END DO
  CALL Output(TRIM(SyntFile), nrcvr, nt, SyntR)

END PROGRAM TDFDAWFS2DSG

SUBROUTINE Output(Outfile, M, N, OutA)
  IMPLICIT NONE
  CHARACTER(LEN = *), INTENT(IN) :: Outfile
  INTEGER, INTENT(IN) :: M, N
  REAL, INTENT(IN)    :: OutA(M, N)
  CHARACTER(LEN = 40) :: FmtStr
  INTEGER :: i, j
  INTEGER :: funit
  WRITE(FmtStr,"('(',G0,'E15.6)')") N
  OPEN(NEWUNIT = funit, FILE = Outfile, STATUS = 'UNKNOWN')
    DO i = 1,M,1
      WRITE(funit, FmtStr) (OutA(i, j), j = 1,N,1)
    END DO
  CLOSE(funit)
END SUBROUTINE Output


c       this file contains the following user-callable routines:
c
c
c       routine idzr_aid computes the ID, to a specified rank,
c       of an arbitrary matrix. This routine is randomized.
c
c       routine idzr_aidi initializes routine idzr_aid.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idzr_aid(m,n,a,krank,w,list,proj)
c
c       computes the ID of the matrix a, i.e., lists in list
c       the indices of krank columns of a such that
c
c       a(j,list(k))  =  a(j,list(k))
c
c       for all j = 1, ..., m; k = 1, ..., krank, and
c
c                       min(m,n,krank)
c       a(j,list(k))  =     Sigma      a(j,list(l)) * proj(l,k-krank)(*)
c                            l=1
c
c                     +  epsilon(j,k-krank)
c
c       for all j = 1, ..., m; k = krank+1, ..., n,
c
c       for some matrix epsilon, dimensioned epsilon(m,n-krank),
c       whose norm is (hopefully) minimized by the pivoting procedure.
c
c       input:
c       m -- number of rows in a
c       n -- number of columns in a
c       a -- matrix to be ID'd; the present routine does not alter a
c       krank -- rank of the ID to be constructed
c       w -- initialization array that routine idzr_aidi
c            has constructed
c
c       output:
c       list -- indices of the columns in the ID
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns
c               in the original matrix being ID'd
c
c       _N.B._: The algorithm used by this routine is randomized.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,n,krank,list(n),lw,ir,lr,lw2,iw
        complex*16 a(m,n),proj(krank*(n-krank)),
     1             w((2*krank+17)*n+21*m+80)
c
c
c       Allocate memory in w.
c
        lw = 0
c
        iw = lw+1
        lw2 = 21*m+80+n
        lw = lw+lw2
c
        ir = lw+1
        lr = (krank+8)*2*n
        lw = lw+lr
c
c
        call idzr_aid0(m,n,a,krank,w(iw),list,proj,w(ir))
c
c
        return
        end
c
c
c
c
        subroutine idzr_aid0(m,n,a,krank,w,list,proj,r)
c
c       routine idzr_aid serves as a memory wrapper
c       for the present routine
c       (see idzr_aid for further documentation).
c
        implicit none
        integer k,l,m,n2,n,krank,list(n),mn,lproj
        complex*16 a(m,n),r(krank+8,2*n),proj(krank,n-krank),
     1             w(21*m+80+n)
c
c       Please note that the second dimension of r is 2*n
c       (instead of n) so that if krank+8 >= m/2, then
c       we can copy the whole of a into r.
c
c
c       Retrieve the number of random test vectors
c       and the greatest integer less than m that is
c       a positive integer power of two.
c
        l = w(1)
        n2 = w(2)
c
c
        if(l .lt. n2 .and. l .le. m) then
c
c         Apply the random matrix.
c
          do k = 1,n
            call idz_sfrm(l,m,n2,w(11),a(1,k),r(1,k))
          enddo ! k
c
c         ID r.
c
          call idzr_id(l,n,r,krank,list,w(20*m+81))
c
c         Retrieve proj from r.
c
          lproj = krank*(n-krank)
          call idzr_copyzarr(lproj,r,proj)
c
        endif
c
c
        if(l .ge. n2 .or. l .gt. m) then
c
c         ID a directly.
c
          mn = m*n
          call idzr_copyzarr(mn,a,r)
          call idzr_id(m,n,r,krank,list,w(20*m+81))
c
c         Retrieve proj from r.
c
          lproj = krank*(n-krank)
          call idzr_copyzarr(lproj,r,proj)
c
        endif
c
c
        return
        end
c
c
c
c
        subroutine idzr_copyzarr(n,a,b)
c
c       copies a into b.
c
c       input:
c       n -- length of a and b
c       a -- array to copy into b
c
c       output:
c       b -- copy of a
c
        implicit none
        integer n,k
        complex*16 a(n),b(n)
c
c
        do k = 1,n
          b(k) = a(k)
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idzr_aidi(m,n,krank,w)
c
c       initializes the array w for using routine idzr_aid.
c
c       input:
c       m -- number of rows in the matrix to be ID'd
c       n -- number of columns in the matrix to be ID'd
c       krank -- rank of the ID to be constructed
c
c       output:
c       w -- initialization array for using routine idzr_aid
c
        implicit none
        integer m,n,krank,l,n2
        complex*16 w((2*krank+17)*n+21*m+80)
c
c
c       Set the number of random test vectors to 8 more than the rank.
c
        l = krank+8
        w(1) = l
c
c
c       Initialize the rest of the array w.
c
        n2 = 0
        if(l .le. m) call idz_sfrmi(l,m,n2,w(11))
        w(2) = n2
c
c
        return
        end


!!# FUNCTION MODULE: <FUN_xyPOINT>
MODULE FUN_xyPOINT

!!## PURPOSE
!! Determine a point from:
!!  @ a plane.
!!  @ a line segment and a parametric location.

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
USE FUN_xyDIST                                 !!((04-B-FUN_xyDIST.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE xyPOINT_Pn
 MODULE PROCEDURE xyPOINT_Pn_Rsp
 MODULE PROCEDURE xyPOINT_Pn_Rdp
END INTERFACE
INTERFACE xyPOINT_LsL
 MODULE PROCEDURE xyPOINT_LsL_Rsp
 MODULE PROCEDURE xyPOINT_LsL_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyPOINT_Pn
PUBLIC :: xyPOINT_LsL

CONTAINS

PURE FUNCTION xyPOINT_Pn_Rsp( Pn ) RESULT( xyP )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyPOINT_Pn.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyPOINT_Pn.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPOINT_Pn_Rdp( Pn ) RESULT( xyP )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyPOINT_Pn.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyPOINT_Pn.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyPOINT_LsL_Rsp( Ls,L ) RESULT( xyP )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rsp                          !!((02-A-PAR_Constants_Rsp.f90))
INCLUDE "05-B-FUN_xyPOINT_LsL.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyPOINT_LsL.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyPOINT_LsL_Rdp( Ls,L ) RESULT( xyP )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp                          !!((02-A-PAR_Constants_Rdp.f90))
INCLUDE "05-B-FUN_xyPOINT_LsL.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyPOINT_LsL.f90.bdy"
!!--end--
END FUNCTION

END MODULE


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYALEM
C...Calculates the running alpha_electromagnetic.

      DOUBLE PRECISION FUNCTION PYALEM(Q2)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Commonblocks.
      include 'inc/pydat1'

C...Calculate real part of photon vacuum polarization.
C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
C...For hadrons use parametrization of H. Burkhardt et al.
C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
      AEMPI=PARU(101)/(3D0*PARU(1))
      IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
        RPIGG=0D0
      ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
        RPIGG=0D0
      ELSEIF(MSTU(101).EQ.2) THEN
        RPIGG=1D0-PARU(101)/PARU(103)
      ELSEIF(Q2.LT.0.09D0) THEN
        RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
      ELSEIF(Q2.LT.9D0) THEN
        RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
     &  0.00238D0*LOG(1D0+3.927D0*Q2)
      ELSEIF(Q2.LT.1D4) THEN
        RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
     &  0.00299D0*LOG(1D0+Q2)
      ELSE
        RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
     &  0.00293D0*LOG(1D0+Q2)
      ENDIF

C...Calculate running alpha_em.
      PYALEM=PARU(101)/(1D0-RPIGG)
      PARU(108)=PYALEM

      RETURN
      END


subroutine dens_eck (temp, sal, rho ,rhods ,rhodt )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  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 3.
!
!  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, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: dens_eck.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/compute/dens_eck.f90 $
!!--description-----------------------------------------------------------------
!
! calculation salinity ---> density
! eckart (1958): salt formula in FLOW
! seawater:
! temperature range: 0 - 40 DGR Celsius
! salinity range: 0 - 40
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
!
    use precision
    implicit none
!
! Global variables
!
    real(fp), intent(in)  :: temp
    real(fp), intent(in)  :: sal
    real(fp), intent(out) :: rho
    real(fp), intent(out) :: rhods
    real(fp), intent(out) :: rhodt
!
! Local variables
!
    real(fp)   ::   cp0
    real(fp)   ::   clam
    real(fp)   ::   clam0
    real(fp)   ::   cp1
    real(fp)   ::   clam1
    real(fp)   ::   alph0
    real(fp)   ::   cp1ds
    real(fp)   ::   cp1dt
    real(fp)   ::   cladt
    real(fp)   ::   rhom
!
! Data statements
!
    data     alph0/0.698_fp/, rhom/0.0_fp/
!
!! executable statements -------------------------------------------------------
!
    cp0   = 5890.0_fp + 38.00_fp*temp - 0.3750_fp*temp*temp
    clam  = 1779.5_fp + 11.25_fp*temp - 0.0745_fp*temp*temp
    clam0 =    3.8_fp +  0.01_fp*temp
    cp1   = cp0  + 3.0_fp*sal
    clam1 = clam - clam0 *sal
    rho   = 1000.0_fp*cp1/(alph0*cp1+clam1) - rhom
    !
    cp1ds = 3.0_fp
    rhods = 1000.0_fp * (cp1ds*clam1+cp1*clam0) / (alph0*cp1+clam1)**2
    !
    cp1dt = 38.0_fp - 0.75_fp*temp
    cladt = 11.25_fp - 0.149_fp*temp - 0.01_fp*sal
    rhodt = 1000.0_fp * (cp1dt*clam1-cp1*cladt) / (alph0*cp1+clam1)**2
end subroutine dens_eck


*=======================================================================
* File:    maphs2.f
* Author:  Alex Stivala, based on spphase1.m by Prof. Yinyu Ye.
* Created: July 2008
*
* This is a reimplementation using FORTRAN-77 and MA57
* of spphase1.m from Prof. Yinyu Ye
* http://www.stanford.edu/~yyye/matlab/spphase2.m
*
* This uses sparse symmetric linear solver MA57 from HSL 2007
* http://hsl.rl.ac.uk/hsl2007/distrib/hsl2007.html
* needs registration as a registred researcher
*
* $Id: maphs2.F 2969 2009-11-22 01:29:39Z astivala $
*=======================================================================

      subroutine maphs2(Q, ldq, A, lda, m, n, c, alpha, beta, lambda,
     $     toler, obvalue, ob,
     $     x, y, Eirn, Ejcn, Ea, nzmax, lkeep, keep,
     $     u, h, xxvec, gg, XX, ldxx,
     $     AA, ldaa,  wvec, info2)

      implicit none
*
* maphs2 - phase 2 of dsoqp:
*          Repeatedly solve an ellipsoid constrained QP problem
*          by solving a linear system until a positive solution is
*          found.
*
*     .. Scalar Arguments ..
      integer            ldq,lda,m,n,nzmax,ldxx,ldaa,info2,lkeep
      double precision   alpha,beta,lambda,toler,obvalue,ob
*     ..
*     .. Array Arguments ..
      integer            Eirn(*),Ejcn(*),keep(*)
      double precision   Q(ldq,*),A(lda,*),c(*),x(*),y(*),
     $     Ea(*),u(*),h(*),xxvec(*),gg(*),XX(ldxx,*),
     $     AA(ldaa, *), wvec(*)

*     ..
*
* The phase 1 procedure called by masoqp.
* For more details see masoqp.f.
*
* Arguments
* =========
*
* Q      (input) DOUBLE PRECISION array, dimension (n, n)
*        The symmetric objective matrix
*
*
* ldq    (input) INTGER
*        leading dimension of Q. ldq >= n
*
* A      (input) DOUBLE PRECISION array, dimension (m, n)
*        the constraint left-hand matrix
*
* lda    (input) INTGER
*        leading dimension of A. lda >= m
*
* m      (input) INTEGER
*        number of rows in matrix A
*
* n      (input) INTEGER
*        number of columns in matrix A
*
* c      (input) DOUBLE PRECISION vector, dimension(n)
*        objective column vector
*
* alpha  (input) DOUBLE PRECISION
*        solution descent parameter
*
* beta   (input) DOUBLE PRECISION
*        step size 0 < beta < 1
*
* lambda (input/output) DOUBLE PRECISION
*        solution descent parameter
*
* toler  (input) DOUBLE PRECISION
*        relative stopping tolerance
*
* obvalue (input) DOUBLE PRECISION
*        previous objective value
*
* ob     (input/output) DOUBLE PRECISION
*        objective value
*
* x      (input/output) DOUBLE PRECISION vector, dimension (n)
*        solution vector
*
* y      (output) DOUBLE PRECISION vector, dimension (m)
*        optimal dual solution (Lagrangian multiplier)
*
* Eirn   (output) INTEGER vector, dimension (nzmax)
*        workspace
*        sparse storage for matrix E for MA47
*
* Ejcn  (output) INTEGER vector, dimension (nzmax)
*        workspace
*        sparse storage for matrix E for MA57
*
* Ea     (output) DOUBLE PRECICISION vector, dimension (nzmax)
*        workspace
*        sparse storage for matrix E for MA57
*
* lkeep  (input) INTEGER
*        length of keep array for MA57.
*        must be >= 5*maxorder+nzmax+max(maxorder,nzmax)+42
*         where maxorder = nmax*mmax
*
* keep   (output) INTEGER vector, dimension (lkeep)
*        workspace for MA57
*
* nzmax  (input) INTEGER
*        maximum allowed number of nonzero values in E.
*        Dimensions Ei and Ex.
*
* u      (output) DOUBLE PRECISION vector, dimension (m+n)
*        workspace
*        solution from MA57
*
* h      (output) DOUBLE PRECISION vector, dimension (m+n)
*        workspace
*        rhs vector MA57
*
* xxvec  (output) DOUBLE PRECISION vector, dimension (n)
*        workspace
*
* gg     (output) DOUBLE PRECISION vector, dimension (n)
*        workspace
*
* XX     (output) DOUBLE PRECISION, dimension (n, n)
*        workspace
*
* ldxx   (input) INTEGER
*        leading dimension of XX. ldxx >= n
*
* AA     (output) DOUBLE PRECISION, dimension (m, n)
*        workspace
*
* ldaa   (input) INTEGER
*        leading dimension of AA. ldaa >= m.
*
* wvec    (output) DOUBLE PRECISION, dimension (n)
*        workspace
*
* info2  (output) INTEGER
*        = 0  : successful
*        = 1  : too many nonzero values, increase nzmax
*        = 999: the problem seems unbounded
*       other : info code from LAPACK
*
*=======================================================================
*

*     .. Parameters ..
*     eps is the machine epsilon for double precision
*     this is for GNU FORTRAN (g77) on Linux x86/64
*     MAY NEED CHANGING ON DIFFERENT SYSTEMS/COMPILERS
      double precision eps
      parameter (eps = 2.2204d-16)
      double precision infty
      parameter (infty=1.79769d+308)
      double precision neginf
      parameter (neginf=-1.79769d+308)
      integer mmax,nmax,lwork,lfact,lifact
      parameter(mmax = 220, nmax = 4000)
      integer iworklen
      parameter(iworklen = 5*mmax*nmax)
      parameter(lwork = mmax*nmax)
      parameter(lfact = 5*mmax*nmax)
      parameter(lifact = 5*mmax*nmax)
*     ..
*     .. Common block Arrays ..
*     lsyfac2 is true after maphs2 symbolic factorization done
*     lsyfac1 is true after maphs1 symbolic factorization done
      logical lsyfac2,lsyfac1
      common /macommon/ lsyfac2,lsyfac1
*     ..
*     .. Local Scalars ..
*     MA57 variables
      integer ne,nrhs,job
*     other local scalars
      integer i,j,incr,order,ixE
      double precision w1,w2,blasa,blasb,nora,valgo
      character uplo
*     ..
*     .. Local Arrays ..
*     MA57 workspace
      integer iwork(iworklen)
      integer icntl(20),mainfo(40)
      double precision cntl(5),rinfo(20)
      double precision work(lwork)
      integer ifact(lifact)
      double precision fact(lfact)
*     ..
*     .. Intrinsic Functions ..
      intrinsic min,abs,int
*     ..
*     .. External Subroutines and Functions ..
      external demvv
      double precision dvmin
      external dvmin
*     MA57 subroutines
      external MA57ID,MA57AD,MA57BD,MA57CD
*     BLAS level 1 subroutines/functions
      external daxpy,dscal,dcopy
      double precision ddot
      external ddot
*     BLAS level 2 subroutines
      external dsymv
*     BLAS level 3 subroutines

*     ..
*     .. Executable Statements ..
*

*     ==================================================================
*
*     Repeatedly solve the ellipsoid constrained QP problem by solving
*     the linear system
*
*     E*u = h where
*
*     E (m+n, m+n)  =    ( XXlam (n, n)   AA' (n, m) )
*                        ( AA    (m, n)    0  (m, m) )
*
*     h (m+n)       =    ( dx (n, 1) )
*                        ( 0  (m, 1) )
*
*     dx (n, 1) is elementwise -x.*gg where gg = Q*x+c
*     XXlam = XX + lambda*eye(n,n) where XX = dx * Q * dx
*                                  where dx(n) is x along diagonal
*
*     until a positive solution is found.
*
*     XX (and therefore XXlam) is square, symmetric. But not really
*     sparse; it has a kind of 'grid' structure but may be e.g. 58%
*     nonzero.
*
*     E is square, symmetric, and sparse (but not very sparse
*     as in the other cases in DPSOQP,MAPHS1, since the top left
*     submatrix is XX which is not sparse). E.g. may be 43% nonzero.
*
*     But it is not necessarily positive definite so we cannot always
*     use CHOLMOD to efficiently solve the system.  We therefore use
*     MA57 with sparse matrix E stored in the HSL2007 MA57 format.  In
*     this format, the i and j indices of the nonzero entries of E are
*     stored in Eirn and Ejcn respectively. (Only one triangle is
*     stored). The nonzero values are stored in Ea, corresponding to the
*     i,j indices in Eirn and Ejcn.
*
*     Inside the loop, only the top left submatrix of E is updated
*     (lambda is modified), other 3 submatrices are constant.
*     So we can build the matrix in sparse format
*     outside the loop, and inside the loop need only update
*     the n diagonal elements in top left n by n submatrix by
*     adding new value of lambda to diagonal elements of XX.
*
*     If E were positive definite, which can efficiently be tested
*     for with Cholesky factorization, it could be solved by that means
*     more efficiently than the general case using LU decomposition.
*
*     TODO: use CHOLMOD to test for postive definiteness and use if
*           it is.
*
*     ==================================================================

*     set parameters for MA57
      call MA57ID(cntl, icntl)
*      icntl(5) = 4  ! debug messages enabled
      nrhs = 1

      lambda = (1.0d0 - beta) * lambda

      valgo = 0.0d0

*     always using increment of 1 in BLAS calls
      incr = 1

*     gg = Q*x + c
*     Q is symmetric  (using upper tri arbitrarily here, see TODO below)
*     stored in gg not directly in F(1:n) as used again later
      call dcopy(n, c, incr, gg, incr)
      uplo = 'U'
      blasa = 1.0d0
      blasb = 1.0d0
      call dsymv(uplo, n, blasa, Q, ldq, x, incr, blasb, gg, incr)

*     dx = diagonal matrix with x along main diagonal
*     AA = A*dx
*     XX = dx*Q*dx
*     since XX is diagonal we can compute
*     XX <- A*dx and
*     XX <- Q*dx just by
*     scaling each column by x(j) for j=1,n
*     then finally we can compute
*     XX <- dx*XX
*     by scaling each ROW by x(i) for i = 1,n
*     with only BLAS level 1 subroutines DCOPY and DSCAL,
*     although the last one is row-wise so inefficient memory access
*     in FORTRAN.
      do 10 j = 1,n
         call dcopy(m, A(1, j), incr, AA(1, j), incr)
         call dscal(m, x(j), AA(1, j), incr)
         call dcopy(n, Q(1, j), incr, XX(1, j), incr)
         call dscal(n, x(j), XX(1, j), incr)
 10   continue
      do 20 i = 1,n
*        NB using INCX=ldxx to scale rows not columns of XX
         call dscal(n, x(i), XX(i, 1), ldxx)
 20   continue

*     build constant part of rhs vector h
*     h(n+1:n+m) = 0
      do 190 i = n+1, n+m
         h(i) = 0.0d0
 190  continue

 200  if (valgo .le. 0.0d0) then

*     (For now we are building the whole sparse E every iteration in
*     the loop)
*        TODO:
*        update E by seting diaongal elements of top left n by n submatrix
*        to diagonal of XX + lambda. (We previously made sure these
*        elements are present in the sparse storage format, even if zero).
*     This doesn't matter much as this loop typically only has one
*     iteration anyway - the expense is multiple calls of MAPHS2
*     from MASOQP.

*     ixE is the current index in Eirn and Ejcn and Ea.
*     We make sure we always store the diagonal elements of XX in
*     top left submatrix of E, even if zero, since we update them in loop.
*     And all diagonal elements must be explicitly stored in HSL MA57
*     sparse matrix format anyway.
         ixE = 1
         do 250 i = 1, n
            do 240 j = i, n
               if (i .eq. j) then
                  Eirn(ixE) = i
                  Ejcn(ixE) = j
                  Ea(ixE) = XX(i, j) + lambda
                  ixE = ixE + 1
                  if (ixE .gt. nzmax) then
                     write(*,*)
     $                    'Max number of nonzero values exceeded.'
                     info2 = 1
                     return
                  endif
               elseif  (XX(i, j) .ne. 0.0d0) then
                  Eirn(ixE) = i
                  Ejcn(ixE) = j
                  Ea(ixE) = XX(i, j)
                  ixE = ixE + 1
                  if (ixE .gt. nzmax) then
                     write(*,*)
     $                    'Max number of nonzero values exceeded.'
                     info2 = 1
                     return
                  endif
               endif
 240        continue
            do 245, j = 1, m
               if (AA(j,i) .ne. 0.0d0) then
                  Eirn(ixE) = i
                  Ejcn(ixE) = n + j
                  Ea(ixE) = AA(j,i)
                  ixE = ixE + 1
                  if (ixE .gt. nzmax) then
                     write(*,*)
     $                    'Max number of nonzero values exceeded.'
                     info2 = 1
                     return
                  endif
               endif
 245        continue
 250     continue
         ne = ixE - 1

*        update nonconstant part of rhs vector h
*        h(1:n) = -x .* gg
         call dcopy(n, x, incr, h, incr)
         call demvv(n, gg, h)
         blasa = -1.0d0
         call dscal(n, blasa, h, incr)

         order = m + n

*        reordering and symbolic factorization
*        We do this once on the first iteration of loop in first call
*        of this function, it is then reused on subsequent
*        iterations + calls as the structure of the matrix does not change
*        and analysis is an expensive operation
         if (.not. lsyfac2) then
            CALL MA57AD (order, ne, Eirn, Ejcn, lkeep, keep, iwork,
     $           icntl, mainfo, rinfo)
            if (mainfo(1) .lt. 0) then
               write(*,*) 'MA57 symbolic analysis failed, info = ',
     $              mainfo(1)
               info2 = -3
               return
            endif
            lsyfac2 = .true.
         endif

*        numeric factorization and
*        solve E*u=h without iterative refinement
         CALL MA57BD (order, ne, Ea, fact, lfact, ifact, lifact,
     $        lkeep, keep, iwork,
     $        icntl, cntl, mainfo, rinfo)
         if (mainfo(1) .lt. 0) then
            write(*,*) 'MA57 factorization failed, info = ',
     $           mainfo(1)
            info2 = -3
            return
         endif
*        MA57CD puts solution in rhs vector so copy h into u for this
         call dcopy(order, h, incr, u, incr)
         job = 0
         CALL MA57CD (job, order, fact, lfact, ifact, lifact,
     $        1, u, mmax+nmax, work, lwork, iwork, icntl, mainfo)
         if (mainfo(1) .lt. 0) then
            write(*,*) 'MA57 solve failed, info = ',mainfo(1)
            info2 = -3
            return
         endif
*        The solution is in u

*        xxvec = x + x .* u(1:n)
         call dcopy(n, x, incr, xxvec, incr)
         call demvv(n, u, xxvec)
         blasa = 1.0d0
         call daxpy(n, blasa, x, incr, xxvec, incr)

         valgo = dvmin(n, xxvec)
         if (valgo .gt. 0.0d0) then
*           ob = (xxvec' * Q * xxvec)/2 + c'*xxvec
            uplo = 'U'
            blasa = 1.0d0
            blasb = 0.0d0
*           blasb is zero so wvec can be uninitialized on entry to DSYMV
            call dsymv(uplo, n, blasa, Q, ldq, xxvec, incr, blasb,
     $                 wvec, incr)
            ob = ddot(n, xxvec, incr, wvec, incr) / 2.0d0 +
     $           ddot(n, c, incr, xxvec, incr)

C            write(*,399),valgo,obvalue,ob
C 399        format('valgo = ',f10.6,' obvalue = ',f10.6,
C     $           ' ob = ',f10.6)

            valgo = min(valgo, obvalue - ob + eps)
         endif
         lambda = 2.0d0 * lambda

C          write(*,400),lambda
C  400     format ('lambda = ',f12.6)

         if (lambda .ge. (1.0d0 + abs(obvalue))/toler) then
            write(*,*) 'The problem seems unbounded.'
            info2 = 999
            return
         endif
         goto 200
*     end of while (valgo .le .0.0) loop
      endif

*     y = -u(n+1:n+m)
      call dcopy(m, u(n+1), incr, y, incr)
      blasa = -1.0d0
      call dscal(m, blasa, y, incr)
*     from now on we only use first n elements of u
      nora = dvmin(n, u)
      if (nora .lt. 0.0d0) then
         nora = -alpha / nora
      elseif (nora .eq. 0.0d0) then
         nora = alpha
      else
         nora = infty
      endif

*     u = x.* u
*     w1 = u'*Q*u
*     w2 = -u'*gg
      call demvv(n, x, u)
      uplo = 'U'
      blasa = 1.0d0
      blasb = 0.0d0
*     blasb is zero so wvec can be uninitialized on entry to DSYMV
      call dsymv(uplo, n, blasa, Q, ldq, u, incr, blasb, wvec, incr)
C      call dgemv('N',n, n, blasa, Q, ldq, u, incr, blasb, wvec, incr)
      w1 = ddot(n, u, incr, wvec, incr)
      w2 = -1.0d0 * ddot(n, u, incr, gg, incr)
      if (w1 .gt. 0.0d0) then
         nora = min(w2/w1, nora)
      endif
      if (nora .eq. infty) then
         ob = neginf
      else
*        x = x + nora*u
         call daxpy(n, nora, u, incr, x, incr)
*        ob = (x' * Q * x)/2 + c'*x
         uplo = 'U'
         blasa = 1.0d0
         blasb = 0.0d0
*        blasb is zero so wvec can be uninitialized on entry to DSYMV
C         call dsymv(uplo, n, blasa, Q, ldq, x, incr, blasb, wvec, incr)
         call dgemv('N',n, n, blasa, Q, ldq, x, incr, blasb, wvec, incr)
         ob = ddot(n, x, incr, wvec, incr) / 2.0d0 +
     $        ddot(n, c, incr, x, incr)
      endif

*     end of MAPHS2 , phase 2 subroutine of MASOQP.

      info2 = 0
      return
      end


      DOUBLE PRECISION FUNCTION GG_GGG(IHEL)
C
C RETURNS AMPLITUDE SQUARED SUMMED/AVG OVER COLORS
C FOR PROCESS : g g -> g g g (h)
C
      IMPLICIT NONE
      include 'constants.f'
      integer ngluons
      parameter (ngluons=5)

      INTEGER IHEL(NGLUONS)
      double complex amp_h5g

      integer PERM(NGLUONS),IHELX(NGLUONS)
      DOUBLE COMPLEX Z(6),ZTEMP
      INTEGER I,J

c      LOGICAL CHECKS
c      DATA CHECKS/.false./

c--   permutations
      INTEGER IP(NGLUONS,6)

c--   color matrix
c     c_ij= (N^2-1)*N^3/4*CIJ/2 in the GM normalization
      INTEGER CIJ(6,6)

      DATA  (IP(I,1),i=1,5)/1,2,3,4,5/
      DATA  (IP(I,2),i=1,5)/1,2,4,3,5/
      DATA  (IP(I,3),i=1,5)/1,3,2,4,5/
      DATA  (IP(I,4),i=1,5)/1,3,4,2,5/
      DATA  (IP(I,5),i=1,5)/1,4,2,3,5/
      DATA  (IP(I,6),i=1,5)/1,4,3,2,5/

      DATA  (CIJ(I,1),i=1,6)/8,4,4,2,2,0/
      DATA  (CIJ(I,2),i=1,6)/4,8,2,0,4,2/
      DATA  (CIJ(I,3),i=1,6)/4,2,8,4,0,2/
      DATA  (CIJ(I,4),i=1,6)/2,0,4,8,2,4/
      DATA  (CIJ(I,5),i=1,6)/2,4,0,2,8,4/
      DATA  (CIJ(I,6),i=1,6)/0,2,2,4,4,8/

      save ip,cij
!$omp threadprivate(ip,cij)

C-----
C  BEGIN CODE
C-----

      GG_GGG = 0D0

         DO I=1,6

         PERM(1)=IP(1,I)
         PERM(2)=IP(2,I)
         PERM(3)=IP(3,I)
         PERM(4)=IP(4,I)
         PERM(5)=IP(5,I)

         call iperm(IHEL,PERM,IHELX,NGLUONS)

         Z(I)=amp_h5g(PERM,IHELX)

c
c    check on the properties of the amplitudes
c
c         if (checks) then
c         call checker(z,i,perm,ihelx)
c         endif
c=============================================================

         ENDDO !sum over permutations

c
c   sum over color
c
         DO J = 1, 6
            ZTEMP = (0.D0,0.D0)
            DO I = 1, 6
               ZTEMP = ZTEMP + Z(I)*CIJ(I,J)
            ENDDO
            GG_GGG =GG_GGG+DBLE(ZTEMP*DCONJG(Z(J)))
         ENDDO

c     Overall normalization of CIJ
         GG_GGG=GG_GGG*XN**3*(XN**2-1D0)/4d0

      RETURN
      END


      subroutine ct1d_d(c1,d2,t2,dect1d)

      implicit double precision(a-h,o-z)

      dimension d2(3),t2(3,3),dect1d(3)

c  this subroutine evaluates the quadrupole-quadrupole
c  electrostatic interaction

      dect1d(1)=c1*(t2(1,1)*d2(1)+t2(1,2)*d2(2)+t2(1,3)*d2(3))
      dect1d(2)=c1*(t2(1,2)*d2(1)+t2(2,2)*d2(2)+t2(2,3)*d2(3))
      dect1d(3)=c1*(t2(1,3)*d2(1)+t2(2,3)*d2(2)+t2(3,3)*d2(3))

      return
      end


! chk_parity.f90 --
!     Check if the compiler supports the Fortran 2008 function parity
!
program chk_parity
    implicit none

    write( *, '(a,l)' ) 'The parity of [True,False,True] is ', parity((/.true.,.false.,.true./))
end program chk_parity


      subroutine adv_setprob(period_in)
      implicit none

      double precision pi, tperiod, pi2, period_in

      common /compi/ pi
      common /comvt/ tperiod,pi2

      tperiod = period_in

      pi = 4.d0*datan(1.d0)
      pi2 = 2.d0*pi

      end


SUBROUTINE crank(n,w,s)
INTEGER n
REAL*8 s,w(n)
INTEGER j,ji,jt
REAL*8 rank,t
s=0.
j=1
1     if(j.lt.n)then
  if(w(j+1).ne.w(j))then
    w(j)=j
    j=j+1
  else
    do jt=j+1,n
      if(w(jt).ne.w(j))goto 2
    enddo
    jt=n+1
2         rank=0.5*(j+jt-1)
    do ji=j,jt-1
      w(ji)=rank
    enddo
    t=jt-j
    s=s+t**3-t
    j=jt
  endif
goto 1
endif
if(j.eq.n)w(n)=n
return
END


! { dg-do run }

  use :: ieee_arithmetic
  implicit none

  real :: sx1, sx2, sx3
  double precision :: dx1, dx2, dx3
  integer, parameter :: s = kind(sx1), d = kind(dx1)
  type(ieee_round_type) :: mode

  ! Test IEEE_IS_FINITE

  if (ieee_support_datatype(0._s)) then
    if (.not. ieee_is_finite(0.2_s)) call abort
    if (.not. ieee_is_finite(-0.2_s)) call abort
    if (.not. ieee_is_finite(0._s)) call abort
    if (.not. ieee_is_finite(-0._s)) call abort
    if (.not. ieee_is_finite(tiny(0._s))) call abort
    if (.not. ieee_is_finite(tiny(0._s)/100)) call abort
    if (.not. ieee_is_finite(huge(0._s))) call abort
    if (.not. ieee_is_finite(-huge(0._s))) call abort
    sx1 = huge(sx1)
    if (ieee_is_finite(2*sx1)) call abort
    if (ieee_is_finite(2*(-sx1))) call abort
    sx1 = ieee_value(sx1, ieee_quiet_nan)
    if (ieee_is_finite(sx1)) call abort
  end if

  if (ieee_support_datatype(0._d)) then
    if (.not. ieee_is_finite(0.2_d)) call abort
    if (.not. ieee_is_finite(-0.2_d)) call abort
    if (.not. ieee_is_finite(0._d)) call abort
    if (.not. ieee_is_finite(-0._d)) call abort
    if (.not. ieee_is_finite(tiny(0._d))) call abort
    if (.not. ieee_is_finite(tiny(0._d)/100)) call abort
    if (.not. ieee_is_finite(huge(0._d))) call abort
    if (.not. ieee_is_finite(-huge(0._d))) call abort
    dx1 = huge(dx1)
    if (ieee_is_finite(2*dx1)) call abort
    if (ieee_is_finite(2*(-dx1))) call abort
    dx1 = ieee_value(dx1, ieee_quiet_nan)
    if (ieee_is_finite(dx1)) call abort
  end if

  ! Test IEEE_IS_NAN

  if (ieee_support_datatype(0._s)) then
    if (ieee_is_nan(0.2_s)) call abort
    if (ieee_is_nan(-0.2_s)) call abort
    if (ieee_is_nan(0._s)) call abort
    if (ieee_is_nan(-0._s)) call abort
    if (ieee_is_nan(tiny(0._s))) call abort
    if (ieee_is_nan(tiny(0._s)/100)) call abort
    if (ieee_is_nan(huge(0._s))) call abort
    if (ieee_is_nan(-huge(0._s))) call abort
    sx1 = huge(sx1)
    if (ieee_is_nan(2*sx1)) call abort
    if (ieee_is_nan(2*(-sx1))) call abort
    sx1 = ieee_value(sx1, ieee_quiet_nan)
    if (.not. ieee_is_nan(sx1)) call abort
    sx1 = -1
    if (.not. ieee_is_nan(sqrt(sx1))) call abort
  end if

  if (ieee_support_datatype(0._d)) then
    if (ieee_is_nan(0.2_d)) call abort
    if (ieee_is_nan(-0.2_d)) call abort
    if (ieee_is_nan(0._d)) call abort
    if (ieee_is_nan(-0._d)) call abort
    if (ieee_is_nan(tiny(0._d))) call abort
    if (ieee_is_nan(tiny(0._d)/100)) call abort
    if (ieee_is_nan(huge(0._d))) call abort
    if (ieee_is_nan(-huge(0._d))) call abort
    dx1 = huge(dx1)
    if (ieee_is_nan(2*dx1)) call abort
    if (ieee_is_nan(2*(-dx1))) call abort
    dx1 = ieee_value(dx1, ieee_quiet_nan)
    if (.not. ieee_is_nan(dx1)) call abort
    dx1 = -1
    if (.not. ieee_is_nan(sqrt(dx1))) call abort
  end if

  ! IEEE_IS_NEGATIVE

  if (ieee_support_datatype(0._s)) then
    if (ieee_is_negative(0.2_s)) call abort
    if (.not. ieee_is_negative(-0.2_s)) call abort
    if (ieee_is_negative(0._s)) call abort
    if (.not. ieee_is_negative(-0._s)) call abort
    if (ieee_is_negative(tiny(0._s))) call abort
    if (ieee_is_negative(tiny(0._s)/100)) call abort
    if (.not. ieee_is_negative(-tiny(0._s))) call abort
    if (.not. ieee_is_negative(-tiny(0._s)/100)) call abort
    if (ieee_is_negative(huge(0._s))) call abort
    if (.not. ieee_is_negative(-huge(0._s))) call abort
    sx1 = huge(sx1)
    if (ieee_is_negative(2*sx1)) call abort
    if (.not. ieee_is_negative(2*(-sx1))) call abort
    sx1 = ieee_value(sx1, ieee_quiet_nan)
    if (ieee_is_negative(sx1)) call abort
    sx1 = -1
    if (ieee_is_negative(sqrt(sx1))) call abort
  end if

  if (ieee_support_datatype(0._d)) then
    if (ieee_is_negative(0.2_d)) call abort
    if (.not. ieee_is_negative(-0.2_d)) call abort
    if (ieee_is_negative(0._d)) call abort
    if (.not. ieee_is_negative(-0._d)) call abort
    if (ieee_is_negative(tiny(0._d))) call abort
    if (ieee_is_negative(tiny(0._d)/100)) call abort
    if (.not. ieee_is_negative(-tiny(0._d))) call abort
    if (.not. ieee_is_negative(-tiny(0._d)/100)) call abort
    if (ieee_is_negative(huge(0._d))) call abort
    if (.not. ieee_is_negative(-huge(0._d))) call abort
    dx1 = huge(dx1)
    if (ieee_is_negative(2*dx1)) call abort
    if (.not. ieee_is_negative(2*(-dx1))) call abort
    dx1 = ieee_value(dx1, ieee_quiet_nan)
    if (ieee_is_negative(dx1)) call abort
    dx1 = -1
    if (ieee_is_negative(sqrt(dx1))) call abort
  end if

  ! Test IEEE_IS_NORMAL

  if (ieee_support_datatype(0._s)) then
    if (.not. ieee_is_normal(0.2_s)) call abort
    if (.not. ieee_is_normal(-0.2_s)) call abort
    if (.not. ieee_is_normal(0._s)) call abort
    if (.not. ieee_is_normal(-0._s)) call abort
    if (.not. ieee_is_normal(tiny(0._s))) call abort
    if (ieee_is_normal(tiny(0._s)/100)) call abort
    if (.not. ieee_is_normal(-tiny(0._s))) call abort
    if (ieee_is_normal(-tiny(0._s)/100)) call abort
    if (.not. ieee_is_normal(huge(0._s))) call abort
    if (.not. ieee_is_normal(-huge(0._s))) call abort
    sx1 = huge(sx1)
    if (ieee_is_normal(2*sx1)) call abort
    if (ieee_is_normal(2*(-sx1))) call abort
    sx1 = ieee_value(sx1, ieee_quiet_nan)
    if (ieee_is_normal(sx1)) call abort
    sx1 = -1
    if (ieee_is_normal(sqrt(sx1))) call abort
  end if

  if (ieee_support_datatype(0._d)) then
    if (.not. ieee_is_normal(0.2_d)) call abort
    if (.not. ieee_is_normal(-0.2_d)) call abort
    if (.not. ieee_is_normal(0._d)) call abort
    if (.not. ieee_is_normal(-0._d)) call abort
    if (.not. ieee_is_normal(tiny(0._d))) call abort
    if (ieee_is_normal(tiny(0._d)/100)) call abort
    if (.not. ieee_is_normal(-tiny(0._d))) call abort
    if (ieee_is_normal(-tiny(0._d)/100)) call abort
    if (.not. ieee_is_normal(huge(0._d))) call abort
    if (.not. ieee_is_normal(-huge(0._d))) call abort
    dx1 = huge(dx1)
    if (ieee_is_normal(2*dx1)) call abort
    if (ieee_is_normal(2*(-dx1))) call abort
    dx1 = ieee_value(dx1, ieee_quiet_nan)
    if (ieee_is_normal(dx1)) call abort
    dx1 = -1
    if (ieee_is_normal(sqrt(dx1))) call abort
  end if

end


      SUBROUTINE FVDGE (X,Y,DS,DY)
C
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION X(5), Y(5)
      DATA H/0.5D+0/,TWO/2.0D+0/
C
      X1=X(1)
      X2=X(2)
      X3=X(3)
      X4=X(4)
      X5=X(5)
C
      Y1=Y(1)
      Y2=Y(2)
      Y3=Y(3)
      Y4=Y(4)
      Y5=Y(5)
C
C     FIND DELTA-Y
      F1=(X3-X1)*(X3-X2)
      F1=TWO/F1
C
      F2=(X4-X3)*(X3-X2)
      F2=-TWO/F2
C
      F3=(X5-X3)*(X4-X3)
      F3=TWO/F3
C
      Z13=X1+X2+X2-X4-X4-X5
      A1=(X2+X3-X4-X5)/Z13
      A3=(X1+X2-X3-X4)/Z13
C
      YP21=(Y2-Y1)/(X2-X1)
      YP32=(Y3-Y2)/(X3-X2)
      YP43=(Y4-Y3)/(X4-X3)
      YP54=(Y5-Y4)/(X5-X4)
C
      X21=H*(X2+X1)
      X32=H*(X3+X2)
      X43=H*(X4+X3)
      X54=H*(X5+X4)
C
      YPP1=(YP32-YP21)/(X32-X21)
      YPP2=(YP43-YP32)/(X43-X32)
      YPP3=(YP54-YP43)/(X54-X43)
      DS=A1*YPP1+A3*YPP3-YPP2
      FX=F2-A1*F1-A3*F3
      DY=DS/FX
C
      RETURN
      END


	SUBROUTINE GH_SPRL ( grid, imax, jmax, ibeg, iend, jbeg, jend,
     +			     iret )
C************************************************************************
C* GH_SPRL 								*
C*									*
C* This subroutine finds the beginning and ending columns and rows      *
C* which contain values less than the minimum contour threshold of 10.  *
C*									*
C* GH_SPRL ( GRID, IMAX, JMAX, IBEG, IEND, JBEG, JEND, IRET )		*
C*									*
C* Input parameters:							*
C*	GRID(IMAX,JMAX) REAL		Grid data array			*
C*      IMAX		INTEGER		Maximum number of rows		*
C*      JMAX		INTEGER		Maximum number of columns	*
C*									*
C* Output parameters:							*
C*	IBEG		INTEGER		Beginning row			*
C*	IEND		INTEGER		Ending row			*
C*	JBEG		INTEGER	        Beginning column		*
C*	JEND		INTEGER		Ending column			*
C*	IRET		INTEGER		Return code			*
C*					   0 = normal return            *
C*					   1 = contourable data >=58 deg*
C*					  -2 = no contourable data      *
C**									*
C* Log:									*
C* D. Kidwell/NCEP	4/01 						*
C* D. Kidwell/NCEP	6/01 	Added return code value of 1		*
C* D. Kidwell/NCEP	4/02 	Changed to check for contour minimum    *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
        REAL		grid (imax,jmax)
C*
	LOGICAL		done
C-----------------------------------------------------------------------
	iret = -2
	cmin = 10.
C
C*	Find the first non-zero column.
C
	done = .false.
	i    = 1
	DO WHILE ( .not. done )
	    DO j = 1, jmax
		IF ( grid ( i, j ) .gt. cmin ) done = .true.
	    END DO
	    IF ( done .or. ( i .eq. imax ) ) THEN
		ibeg = i
		done = .true.
	      ELSE
		i = i + 1
	    END IF
	END DO
C
C*	Find the last non-zero column.
C
	done = .false.
	i    = imax
	DO WHILE ( .not. done )
	    DO j = 1, jmax
		IF ( grid ( i, j ) .gt. cmin ) done = .true.
	    END DO
	    IF ( done .or. ( i .eq. 1 ) ) THEN
		iend = i
		done = .true.
	      ELSE
		i = i - 1
	    END IF
	END DO
C
C*	Find the first non-zero row.
C
	done = .false.
	j    = 1
	DO WHILE ( .not. done )
	    DO i = 1, imax
		IF ( grid ( i, j ) .gt. cmin ) done = .true.
	    END DO
	    IF ( done .or. ( j .eq. jmax ) ) THEN
		jbeg = j
		done = .true.
	      ELSE
		j = j + 1
	    END IF
	END DO
C
C*	Find the last non-zero row.
C
	done = .false.
	j    = jmax
	DO WHILE ( .not. done )
	    DO i = 1, imax
		IF ( grid ( i, j ) .gt. cmin ) done = .true.
	    END DO
	    IF ( done .or. ( j .eq. 1 ) ) THEN
		jend = j
		done = .true.
	      ELSE
		j = j - 1
	    END IF
	END DO
C
C*	Check for contourable data and value above 58 N.
C
	IF ( ( ibeg .le. iend ) .and. ( jbeg .le. jend ) ) THEN
	    iret = 0
	    IF ( jend .ge. ( jmax - 2 ) ) iret = 1
	END IF
C*
	RETURN
	END


PROGRAM TEST
  USE ISO_FORTRAN_ENV, ONLY: RT => REAL32
  IMPLICIT NONE
  REAL :: A(3,3)
  REAL :: B(3)
  REAL :: C(SIZE(B))
  INTEGER :: I, J
  REAL :: D(10000)
  INTEGER :: DI(SIZE(D))
  ! Compute A.
  PRINT *, 'A:'
  DO I = 1, SIZE(A,1)
     A(I,:I) = 1.0
     A(:,I+1:) = 0.0
     PRINT *, '  ', A(I,:)
  END DO
  ! Compute B.
  B(:) = 1.0
  PRINT *, 'B:'
  PRINT *, '  ', B(:)
  ! Compute C.
  C = MATMUL(B(:), A(:,:))
  PRINT *, 'C:'
  PRINT *, '  ', C(:)

  C = MAX(2.0, MATMUL(B(:), A(:,:)))
  PRINT *, 'MAX(2,C):'
  PRINT *, '  ', C(:)
  PRINT *, ''
  test_loop : DO I = 1, 1000
     CALL RANDOM_NUMBER(D(:))
     CALL ARGSORT(D(:), DI(:))
     DO J = 1, SIZE(D)-1
        IF (D(DI(J)) .GT. D(DI(J+1))) THEN
           PRINT *, 'ARGSORT ERROR between indices', J, 'and', J+1
           PRINT *, 'D: ', D(:)
           PRINT *, 'DI:', DI(:)
           EXIT test_loop
        END IF
     END DO
  END DO test_loop

CONTAINS

    SUBROUTINE SWAP_INT(V1, V2)
      INTEGER, INTENT(INOUT) :: V1, V2
      INTEGER :: TEMP
      TEMP = V1
      V1 = V2
      V2 = TEMP
    END SUBROUTINE SWAP_INT

    ! ------------------------------------------------------------------
    !                         FastSort
    !
    ! This routine uses a combination of QuickSort (with modestly
    ! intelligent pivot selection) and Insertion Sort (for small arrays)
    ! to achieve very fast average case sort times for both random and
    ! partially sorted data. The pivot is selected for QuickSort as the
    ! median of the first, middle, and last values in the array.
    !
    ! Arguments:
    !
    !   VALUES   --  A 1D array of real numbers.
    !   INDICES  --  A 1D array of original indices for elements of VALUES.
    !
    ! Optional:
    !
    !   MIN_SIZE --  An positive integer that represents the largest
    !                sized VALUES for which a partition about a pivot
    !                is used to reduce the size of a an unsorted array.
    !                Any size less than this will result in the use of
    !                INSERTION_ARGSORT instead of ARGPARTITION.
    !
    ! Output:
    !
    !   The elements of the array VALUES are sorted and all elements of
    !   INDICES are sorted symmetrically (given INDICES = 1, ...,
    !   SIZE(VALUES) beforehand, final INDICES will show original index
    !   of each element of VALUES before the sort operation).
    !
    RECURSIVE SUBROUTINE ARGSORT(VALUES, INDICES, MIN_SIZE, INIT_INDS)
      REAL(KIND=RT), INTENT(IN),    DIMENSION(:) :: VALUES
      INTEGER,       INTENT(INOUT), DIMENSION(:) :: INDICES
      INTEGER,       INTENT(IN), OPTIONAL        :: MIN_SIZE
      LOGICAL,       INTENT(IN), OPTIONAL        :: INIT_INDS
      ! Local variables
      LOGICAL :: INIT
      INTEGER :: I, MS
      IF (PRESENT(MIN_SIZE)) THEN ; MS = MIN_SIZE
      ELSE                        ; MS = 2**6
      END IF
      IF (PRESENT(INIT_INDS)) THEN ; INIT = INIT_INDS
      ELSE                         ; INIT = .TRUE.
      END IF
      ! Initialize all indices (for the first call).
      IF (INIT) THEN
         FORALL (I=1:SIZE(INDICES)) INDICES(I) = I
      END IF
      ! Base case, return.
      IF (SIZE(INDICES) .LT. MS) THEN
         CALL INSERTION_ARGSORT(VALUES, INDICES)
         ! Call this function recursively after pivoting about the median.
      ELSE
         ! ---------------------------------------------------------------
         ! If you are having slow runtime with the selection of pivot values
         ! provided by ARGPARTITION, then consider using ARGSELECT instead.
         I = ARGPARTITION(VALUES, INDICES)
         ! ---------------------------------------------------------------
         ! I = SIZE(INDICES) / 2
         ! CALL ARGSELECT(VALUES, INDICES, I)
         ! ! Requires 'USE FAST_SELECT' at top of subroutine or module.
         ! ---------------------------------------------------------------
         CALL ARGSORT(VALUES(:), INDICES(:I-1), MS, INIT_INDS=.FALSE.)
         CALL ARGSORT(VALUES(:), INDICES(I+1:), MS, INIT_INDS=.FALSE.)
      END IF
    END SUBROUTINE ARGSORT

    ! This function efficiently partitions values based on the median
    ! of the first, middle, and last elements of the VALUES array. This
    ! function returns the index of the pivot.
    FUNCTION ARGPARTITION(VALUES, INDICES) RESULT(LEFT)
      REAL(KIND=RT), INTENT(IN),    DIMENSION(:) :: VALUES
      INTEGER,       INTENT(INOUT), DIMENSION(:) :: INDICES
      INTEGER :: LEFT, MID, RIGHT
      REAL(KIND=RT)   :: PIVOT
      ! Use the median of the first, middle, and last element as the
      ! pivot. Place the pivot at the end of the array.
      MID = (1 + SIZE(INDICES)) / 2
      ! Swap the first and last elements (if the last is smaller).
      IF (VALUES(INDICES(SIZE(INDICES))) < VALUES(INDICES(1))) THEN
         CALL SWAP_INT(INDICES(1), INDICES(SIZE(INDICES)))
      END IF
      ! Swap the middle and first elements (if the middle is smaller).
      IF (VALUES(INDICES(MID)) < VALUES(INDICES(SIZE(INDICES)))) THEN
         CALL SWAP_INT(INDICES(MID), INDICES(SIZE(INDICES)))
         ! Swap the last and first elements (if the last is smaller).
         IF (VALUES(INDICES(SIZE(INDICES))) < VALUES(INDICES(1))) THEN
            CALL SWAP_INT(INDICES(1), INDICES(SIZE(INDICES)))
         END IF
      END IF
      ! Set the pivot, LEFT index and RIGHT index (skip the smallest,
      ! which is in location 1, and the pivot at the end).
      PIVOT = VALUES(INDICES(SIZE(INDICES)))
      LEFT  = 2
      RIGHT = SIZE(INDICES) - 1
      ! Partition all elements to the left and right side of the pivot
      ! (left if they are smaller, right if they are bigger).
      DO WHILE (LEFT < RIGHT)
         ! Loop left until we find a value that is greater or equal to pivot.
         DO WHILE (VALUES(INDICES(LEFT)) < PIVOT)
            LEFT = LEFT + 1
         END DO
         ! Loop right until we find a value that is less or equal to pivot (or LEFT).
         DO WHILE (RIGHT .NE. LEFT)
            IF (VALUES(INDICES(RIGHT)) .LT. PIVOT) EXIT
            RIGHT = RIGHT - 1
         END DO
         ! Now we know that [VALUES(RIGHT) < PIVOT < VALUES(LEFT)], so swap them.
         CALL SWAP_INT(INDICES(LEFT), INDICES(RIGHT))
      END DO
      ! The last swap was done even though LEFT == RIGHT, we need to undo.
      CALL SWAP_INT(INDICES(LEFT), INDICES(RIGHT))
      ! Finally, we put the pivot back into its proper location.
      CALL SWAP_INT(INDICES(LEFT), INDICES(SIZE(INDICES)))
    END FUNCTION ARGPARTITION

    ! Insertion sort (best for small lists).
    SUBROUTINE INSERTION_ARGSORT(VALUES, INDICES)
      REAL(KIND=RT), INTENT(IN),    DIMENSION(:) :: VALUES
      INTEGER,       INTENT(INOUT), DIMENSION(:) :: INDICES
      ! Local variables.
      REAL(KIND=RT)   :: TEMP_VAL
      INTEGER :: I, BEFORE, AFTER, TEMP_IND
      ! Return for the base case.
      IF (SIZE(INDICES) .LE. 1) RETURN
      ! Put the smallest value at the front of the list.
      I = MINLOC(VALUES(INDICES(:)),1)
      CALL SWAP_INT(INDICES(1), INDICES(I))
      ! Insertion sort the rest of the array.
      DO I = 3, SIZE(INDICES)
         TEMP_IND = INDICES(I)
         TEMP_VAL = VALUES(TEMP_IND)
         ! Search backwards in the list,
         BEFORE = I - 1
         AFTER  = I
         DO WHILE (TEMP_VAL .LT. VALUES(INDICES(BEFORE)))
            INDICES(AFTER) = INDICES(BEFORE)
            BEFORE = BEFORE - 1
            AFTER  = AFTER - 1
         END DO
         ! Put the value into its place (where it is greater than the
         ! element before it, but less than all values after it).
         INDICES(AFTER) = TEMP_IND
      END DO
    END SUBROUTINE INSERTION_ARGSORT
    ! ------------------------------------------------------------------

END PROGRAM TEST


!!## MODULE: FUNCTION  IntervalBisection
MODULE FUN_IntervalBisection

!!### PURPOSE
!! use the standard bisection search to determine the interval
!! indices <l(1:2)> in the ordered list of <N> real or
!! integer values, <x> which contain <x0>.

!!### USAGE
!
!       l = IntervalBisection( x0 , x [, MAX_span] )
!
!! where the returned interval <l> has three possibilities
!
!    1. l(1)=LB,l(2)=UB  for x(LB) <= x0 < x(UB)
!    2. l(1)=0 ,l(2)=1   for          x0 < x(1)
!    3. l(1)=N ,l(2)=N+1 for x(N)  <= x0
!
!! and the optional argument <MAX_span> indicates the desired
!! maximum number of points to include in the interval,
!! <UB-LB+1 = MAX_span>.

!!### METHOD
!! Standard bisection search.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp,& !!((01-A-KND_IntrinsicTypes.f90))
                             KIND_I1,KIND_I2,KIND_I4,KIND_I8,&
                             KIND_S

!!### HISTORY
! 1.[waw] Author   = William A. Wieselquist
!         Modified = 105.2006
!         Contact  = william.wieselquist AT gmail.com

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!### INTERFACE DEFINITION
INTERFACE IntervalBisection
 MODULE PROCEDURE IntervalBisection_Rsp
 MODULE PROCEDURE IntervalBisection_Rdp
 MODULE PROCEDURE IntervalBisection_I1
 MODULE PROCEDURE IntervalBisection_I2
 MODULE PROCEDURE IntervalBisection_I4
 MODULE PROCEDURE IntervalBisection_I8
 MODULE PROCEDURE IntervalBisection_S
END INTERFACE

!!### PUBLIC ACCESS LIST
PUBLIC :: IntervalBisection

!!## MODULE PROCEDURES
CONTAINS

PURE FUNCTION IntervalBisection_Rsp( x0 , x , MAX_span ) RESULT(l)
INTEGER,PARAMETER :: KIND_x=KIND_Rsp
INCLUDE "03-A-FUN_IntervalBisection_R.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IntervalBisection.f90.sup"
INCLUDE "03-A-FUN_IntervalBisection.f90.alg"
INCLUDE "03-A-FUN_IntervalBisection.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION IntervalBisection_Rdp( x0 , x , MAX_span ) RESULT(l)
INTEGER,PARAMETER :: KIND_x=KIND_Rdp
INCLUDE "03-A-FUN_IntervalBisection_R.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IntervalBisection.f90.sup"
INCLUDE "03-A-FUN_IntervalBisection.f90.alg"
INCLUDE "03-A-FUN_IntervalBisection.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION IntervalBisection_I1( x0 , x , MAX_span ) RESULT(l)
INTEGER,PARAMETER :: KIND_x=KIND_I1
INCLUDE "03-A-FUN_IntervalBisection_I.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IntervalBisection.f90.sup"
INCLUDE "03-A-FUN_IntervalBisection.f90.alg"
INCLUDE "03-A-FUN_IntervalBisection.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION IntervalBisection_I2( x0 , x , MAX_span ) RESULT(l)
INTEGER,PARAMETER :: KIND_x=KIND_I2
INCLUDE "03-A-FUN_IntervalBisection_I.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IntervalBisection.f90.sup"
INCLUDE "03-A-FUN_IntervalBisection.f90.alg"
INCLUDE "03-A-FUN_IntervalBisection.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION IntervalBisection_I4( x0 , x , MAX_span ) RESULT(l)
INTEGER,PARAMETER :: KIND_x=KIND_I4
INCLUDE "03-A-FUN_IntervalBisection_I.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IntervalBisection.f90.sup"
INCLUDE "03-A-FUN_IntervalBisection.f90.alg"
INCLUDE "03-A-FUN_IntervalBisection.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION IntervalBisection_I8( x0 , x , MAX_span ) RESULT(l)
INTEGER,PARAMETER :: KIND_x=KIND_I8
INCLUDE "03-A-FUN_IntervalBisection_I.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IntervalBisection.f90.sup"
INCLUDE "03-A-FUN_IntervalBisection.f90.alg"
INCLUDE "03-A-FUN_IntervalBisection.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION IntervalBisection_S( x0 , x , MAX_span ) RESULT(l)
INTEGER,PARAMETER :: KIND_x=KIND_S
INCLUDE "03-A-FUN_IntervalBisection_S.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_IntervalBisection.f90.sup"
INCLUDE "03-A-FUN_IntervalBisection.f90.alg"
INCLUDE "03-A-FUN_IntervalBisection.f90.bdy"
!!--end--
END FUNCTION

END MODULE


function i8_uniform ( a, b, seed )

!*****************************************************************************80
!
!! I8_UNIFORM returns a scaled pseudorandom I8.
!
!  Discussion:
!
!    An I8 is an integer ( kind = 8 ) value.
!
!    Note that ALL integer variables in this routine are
!    of type integer ( kind = 8 )!
!
!    The input arguments to this function should NOT be constants; they should
!    be variables of type integer ( kind = 8 )!
!
!    The pseudorandom number should be uniformly distributed
!    between A and B.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 November 2006
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Springer Verlag, pages 201-202, 1983.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley Interscience, page 95, 1998.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, pages 362-376, 1986.
!
!    Peter Lewis, Allen Goodman, James Miller
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, pages 136-143, 1969.
!
!  Parameters:
!
!    Input, integer ( kind = 8 ) A, B, the limits of the interval.
!
!    Input/output, integer ( kind = 8 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, integer ( kind = 8 ) I8_UNIFORM, a number between A and B.
!
  implicit none

  integer ( kind = 8 ) a
  integer ( kind = 8 ) b
  integer ( kind = 8 ) i8_uniform
  real ( kind = 8 ) r
  real ( kind = 8 ) r8i8_uniform_01
  integer ( kind = 8 ) seed
  integer ( kind = 8 ) value

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'I8_UNIFORM - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop
  end if

  r = r8i8_uniform_01 ( seed )
!
!  Scale R to lie between A-0.5 and B+0.5.
!
  r = ( 1.0D+00 - r ) * ( real ( min ( a, b ), kind = 8 ) - 0.5D+00 ) &
    +             r   * ( real ( max ( a, b ), kind = 8 ) + 0.5D+00 )
!
!  Use rounding to convert R to an integer between A and B.
!
  value = nint ( r, kind = 8 )

  value = max ( value, min ( a, b ) )
  value = min ( value, max ( a, b ) )

  i8_uniform = value

  return
end


! { dg-do run }
! PR34540 cshift, eoshift, kind=1 and kind=2 arguments...
program main
  integer(kind=1) :: d1
  integer(kind=2) :: d2
  integer(kind=4) :: d4
  integer(kind=8) :: d8
  integer(kind=1), dimension(2) :: s1
  integer(kind=2), dimension(2) :: s2
  integer(kind=4), dimension(2) :: s4
  integer(kind=8), dimension(2) :: s8
  real, dimension(2,2) :: r, r1, r2
  data r /1.0, 2.0, 3.0, 4.0/
  data r1 /2.0, 0.0, 4.0, 0.0/
  data r2 /2.0, 1.0, 4.0, 3.0/
  s1 = (/1, 1/)
  s2 = (/1, 1/)
  s4 = (/1, 1/)
  s8 = (/1, 1/)
  d1 = 1
  d2 = 1
  d4 = 1
  d8 = 1
  if (any(eoshift(r,shift=s1,dim=d1) /= r1)) STOP 1
  if (any(eoshift(r,shift=s2,dim=d2) /= r1)) STOP 2
  if (any(eoshift(r,shift=s4,dim=d4) /= r1)) STOP 3
  if (any(eoshift(r,shift=s8,dim=d8) /= r1)) STOP 4
  if (any(cshift(r,shift=s1,dim=d1) /= r2)) STOP 5
  if (any(cshift(r,shift=s2,dim=d2) /= r2)) STOP 6
  if (any(cshift(r,shift=s4,dim=d4) /= r2)) STOP 7
  if (any(cshift(r,shift=s8,dim=d8) /= r2)) STOP 8
end program main


! PR fortran/77352
! { dg-do compile }
! { dg-additional-options "-fstack-arrays -O2" }
! { dg-additional-options "-fopenacc" { target fopenacc } }

program pr77352
  real, allocatable :: a(:,:), b(:)
  integer :: m, n
  m = 4
  n = 2
  allocate (a(m,n), b(m))
  a = 1.0
!$omp parallel workshare
  b(:) = [ sum(a, dim=1) ]
!$omp end parallel workshare
end


! BSD 3-Clause License
!
! Copyright (c) 2020, Fabio Durastante
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
submodule (psfun_utils_mod) psfun_d_utils_mod
  !! Real variants of the utils functions
  use psb_base_mod
  implicit none

contains

  module function ellipkkp(L) result(K)
    !! Complete elliptic integral of the first kind, with complement.
    !! Returns the value of the complete elliptic integral of the first kind,
    !! evaluated at \(M=\exp(-2\pi L)\), \(0 < L < \infty\), and the
    !! complementarity parameter \(1-M\).
    use psb_base_mod
    implicit none

    real(psb_dpk_), intent(in)  :: L
    real(psb_dpk_)              :: K(2)

    ! Local variables
    real(psb_dpk_)    :: M,a0,a1,b0,b1,c1,w1,s0,MM
    integer(psb_ipk_) :: i1

    ! When M=exp(-2 π L) ≈ 0, use an O(M) approximation
    if(L > 10) then
      K(1) = DPI/2_psb_dpk_
      K(2) = DPI*L + log(4.0_psb_dpk_)
      return
    end if

    M = exp(-2.0_psb_dpk_*DPI*L)
    a0 = 1.0_psb_dpk_
    b0 = sqrt(1-M)
    s0 = M
    i1 = 0
    MM = 1.0_psb_dpk_
    do while (MM > EPSILON(MM) )
      a1 = (a0+b0)/2.0_psb_dpk_
      b1 = sqrt(a0*b0)
      c1 = (a0-b0)/2.0_psb_dpk_
      i1 = i1 + 1
      w1 = (2.0_psb_dpk_**i1)*(c1**2)
      MM = w1
      s0 = s0 + w1
      a0 = a1
      b0 = b1
    end do
    K(1) = DPI/(2.0_psb_dpk_*a1)

    a0 = 1.0_psb_dpk_
    b0 = sqrt(M)
    s0 = 1-M
    i1 = 0
    MM = 1.0_psb_dpk_
    do while (MM > EPSILON(MM) )
      a1 = (a0+b0)/2.0_psb_dpk_
      b1 = sqrt(a0*b0)
      c1 = (a0-b0)/2.0_psb_dpk_
      i1 = i1 + 1
      w1 = (2.0_psb_dpk_**i1)*(c1**2)
      MM = w1
      s0 = s0 + w1
      a0 = a1
      b0 = b1
    end do
    K(2) = DPI/(2.0_psb_dpk_*a1)

    return

  end function ellipkkp

  module subroutine d_ellipj(u,L,sn,cn,dn)
    !! Returns the values of the Jacobi elliptic functions evaluated at double
    !! argument u and parameter \(M = \exp(-2 \pi L)\), \(0 < L < \infty\).
    !! For \(M = K^2\), and \(K\) the elliptic modulus.
    !
    real(psb_dpk_), intent(in)    :: u
    real(psb_dpk_), intent(in)    :: L
    real(psb_dpk_), intent(out)   :: sn,cn,dn

    real(psb_dpk_) :: m
    m = exp(-2.0_psb_dpk_*DPI*L)

    call sncndn( u, m, sn, cn, dn )

    return

  end subroutine

  module function horner(coeffs, x) result (res)
    !! Apply Horner rule to evaluate a polynomial

    use psb_base_mod
    implicit none
    real(psb_dpk_), dimension (:), intent (in) :: coeffs
    real(psb_dpk_), intent (in) :: x
    real(psb_dpk_) :: res

    ! Local Variable
    integer :: i

    res = 0.0_psb_dpk_
    do i = size(coeffs), 1, -1
      res = res * x + coeffs (i)
    end do

    return

  end function horner

end submodule


! To compile and run: make

program q2
  use integrator_r8
  implicit none

  real, parameter :: pi = 3.1415926535897932384626433832795028841971693993751058

  call main()

contains

  subroutine main()
    integer, parameter :: steps_per_second = 2**8
    real, parameter :: time_period = 100.0 * sqrt(1.0 / 9.806)
    real, parameter :: dt = 1.0 / steps_per_second
    integer, parameter :: steps = steps_per_second * time_period
    real :: ys(4, steps)
    real :: ts(steps)

    print *
    print "(a)", "Q2. Plot energy violation and create video animation"
    print "(a)", "    Initial conditions: theta_1 = pi / 3, theta_2 = -pi/3"
    print "(a, f9.7, a)", "    dt: ", dt, "s"
    print *
    call run(steps, dt, ts, ys, y0=[pi / 3, 0.0, -pi / 3, 0.0])
    call write_csv("results.csv", steps, ts, ys)
    call execute_command_line("python plot.py results.csv --plot-results")
    print *
  end subroutine

  subroutine write_csv(filename, n, t, y)
    !! Output a csv file with plottable data
    integer, parameter :: ofh = 2
    character(len=64), parameter :: fmt_str = &
      "(ES24.16, ',', ES24.16, ',', ES24.16, ',', ES24.16)"
    character(len=*) :: filename
    integer :: n, i
    real :: t(n), y(4, n)
    real :: E0

    E0 = energy(y(:, 1))

    open(unit=ofh, file=filename, action="write", status="replace")
    write(ofh, *) "Time, $\theta_1$, $\theta_2$, Energy violation"
    do i = 1, n
      write(ofh, fmt_str) t(i), y(1, i), y(3, i), energy(y(:, i)) / E0 - 1.0
    end do
    close(ofh)
  end subroutine

  subroutine run(n, dt, ts, ys, y0)
    !! Run simulation for given initial condition y0 at time step dt
    !! Returns simulation results in ts and ys
    integer :: n, i
    real :: ys(4, n), ts(n), y0(4), y(4), dt

    ts = [(i * dt, i=0,n-1)]
    y = y0

    do i = 1, n
      ys(:, i) = y
      call gl10(y, dt)
    end do
  end subroutine

end program q2


program gp_in
    use m_util
    use m_gp
    use m_gp_sparse
    use m_gp_dense
    use m_gp_optim
    use m_cov_all
    use m_noise_all
    use readIO, only : readArray, readFileDimensions

    implicit none

    class(BaseGP), allocatable :: gp

    ! number of training points, dimension of the input, dimension of design
    integer :: trainingSampleSize, trainingDimensionSize, designDimensionSize

    ! loop counter
    integer :: ind
    ! number of hyperparameters and noise parameters required
    integer :: ntheta, nnu

    integer :: ioStatusCode

    real(dp), dimension(:), allocatable :: tmpArray
    real(dp), dimension(:), allocatable :: theta, nu, responseVector, lbounds, ubounds
    real(dp), dimension(:,:), allocatable :: designMatrix
    real(dp), dimension(:,:), allocatable :: trainingDataMatrix

    integer, dimension(:), allocatable :: trainingDataObservationTypeVector

    real(dp), dimension(16) :: tmpTheta = (/0.9010, 0.9650, 0.6729, 3.5576, 4.7418, 1.2722, &
     4.0612, 0.5, 2.4, 4.3, 3.2, 1.5, 0.5, 2.4, 4.3, 3.2 /)

    logical :: optimize

    integer :: optimize_max_iter
    real(dp) :: optimize_ftol

    character(len=max_name_len) :: covariance_function = 'LINSQEXP'
    character(len=max_name_len) :: noise_model_name    = 'VAL'

    character(len=1000) :: trainingDataInputFile
    character(len=1000) :: trainedEmulatorGPFile
    character(len=1) :: separator
    logical :: debugFlag

    NAMELIST /inputoutput/  &
                          trainingDataInputFile, & ! training data
                          trainedEmulatorGPFile, & ! output of executable (trained emulator)
                          separator,  & ! separator of data file
                          debugFlag

    class(cov_fn), allocatable :: cf
    class(noise_model), allocatable :: nm

    !!!!!!!!!!!!!!!!! END OF DECLARATIONS

    ! READ NAMELIST
    open  (1,status='old',file='train.nml', iostat = ioStatusCode)
        if ( ioStatusCode /= 0 ) stop "Error opening train.nml file"
        read  (1, nml=inputoutput)
    close (1)

    ! set dimension integers
    call readFileDimensions( trainingDataInputFile, trainingSampleSize, trainingDimensionSize, separator, debugFlag)

    designDimensionSize = trainingDimensionSize-2

    ! allocate matrices & vectors according to dimensions
    allocate( real(dp) :: trainingDataMatrix( trainingSampleSize, trainingDimensionSize ) )
    allocate(real(dp) :: designMatrix(trainingSampleSize,designDimensionSize))
    allocate(integer :: trainingDataObservationTypeVector(trainingSampleSize))
    allocate(real(dp) :: responseVector(trainingSampleSize))
    allocate(real(dp) :: tmpArray(trainingSampleSize))

    ! assign array values
    call readArray(trainingDataInputFile, trainingDataMatrix, separator, debugFlag)

    designMatrix(:,:) = trainingDataMatrix(:, 1:designDimensionSize)
    trainingDataObservationTypeVector(:) = int(trainingDataMatrix(:, trainingDimensionSize-1 ))
    responseVector(:) = trainingDataMatrix(:, trainingDimensionSize)

    ! Transform response and design here
    responseVector = standardize(responseVector,trainingSampleSize)
    do ind=1,designDimensionSize
        tmpArray = standardize( designMatrix(:,ind), trainingSampleSize )
        designMatrix(:,ind) = tmpArray
    end do
    !!!!!!!!!!!!!!!!!!!!!!!! END OF READING INPUT DATA

    call string_to_cov_fn(covariance_function, cf)
    call string_to_noise_model(noise_model_name, nm)

    nnu = nm%nparams_required(designDimensionSize)
    ntheta = cf%ntheta_required(designDimensionSize)

    allocate(real(dp) :: nu(nnu))
    allocate(real(dp) :: theta(ntheta))
    allocate(real(dp) :: lbounds(nnu + ntheta))
    allocate(real(dp) :: ubounds(nnu + ntheta))

    nu = 0.001
    theta = tmpTheta(1:designDimensionSize+1)
    lbounds(1) = 0.001
    lbounds(2:) = 0.01
    ubounds(:) = 100.0
    ubounds(1) = 0.001

    optimize = .true.
    optimize_max_iter = 10000
    optimize_ftol = 1.0d-7

    if ( debugFlag ) then
        write(*,*) "trainingDataInputFile: ", trim(trainingDataInputFile)
        write(*,*) "trainedEmulatorGPFile: ", trim(trainedEmulatorGPFile)
        write(*,*) "rows: ", trainingSampleSize
        write(*,*) "columns: ", trainingDimensionSize
        print*, "trainingDataMatrix(1,:)", trainingDataMatrix(1,:)
        print*, "trainingDataMatrix(2,:)", trainingDataMatrix(2,:)
        print*, "shape designMatrix", shape(designMatrix)
        print*, "shape trainingDataMatrix", shape(trainingDataMatrix)
        print*, "100's design second variable", designMatrix(100, 2)
        print*, "100's obs type", trainingDataObservationTypeVector(100)
        print*, "100's response", responseVector(100)
        print*, "100's trainingDataMatrix", trainingDataMatrix(100,:)
        print*, "nnu", nnu
        print*, "ntheta", ntheta
        print*, "lbounds", lbounds
        print*, "ubounds", ubounds
        print*, "optimize_max_iter", optimize_max_iter
        print*, "optimize_ftol", optimize_ftol
    end if

    allocate(gp, source=DenseGP(nu, theta, designMatrix, trainingDataObservationTypeVector, responseVector, cf, nm))

    if (optimize) then
        call log_lik_optim(nnu + ntheta, gp, lbounds, ubounds, optimize_max_iter, optimize_ftol)
    else
        gp%theta = (/ 0.9010,0.9650,0.6729,3.5576,4.7418,1.2722,4.0612, 1.5 /)
        gp%nu = 0.001
        call gp%update_matrices
    end if

    print *, gp%nu,' and ', gp%theta

    call gp%write_out(trainedEmulatorGPFile)

contains
    function mean(x,dmn) result(res)
        integer dmn
        real(dp) x(dmn)
        real(dp) :: res

        res = sum(x)/dmn
    end function mean

    function std(x,meanx,dmn) result(res)
        integer dmn
        real(dp) x(dmn)
        real(dp) :: meanx
        real(dp) :: res

        res = sqrt(sum((x - meanx)**2)/(dmn-1))
    end function std

    function standardize(x,dmn) result(res)
        integer dmn
        real(dp) x(dmn)

        real(dp), dimension(dmn) :: res

        real(dp) :: meanx
        real(dp) :: stdx

        meanx= mean(x,dmn)

        stdx = std(x,meanx,dmn)

        res = (x - meanx)/stdx
    end function standardize

    function logistic(x) result(res)
        real(dp), intent(in) :: x
        real(dp) :: res
        res = 0.9 * x + 0.05;
        res = log(res) - log(1-res)
    end function logistic

    function logistic_vector(x,dmn) result(res)
        integer dmn
        real(dp)  x(dmn)
        real(dp),dimension(dmn) :: res
        res = 0.9 * x + 0.05
        res = log(res) - log(1-res)
    end function logistic_vector

    function inv_logistic(x) result(res)
        real(dp), intent(in) :: x
        real(dp) :: res
        res =  ( (1.0 / (1.0 + exp(-x))) - 0.05) / 0.9
    end function inv_logistic

    function inv_logistic_vector(x,dmn) result(res)
        integer dmn
        real(dp), intent(in),dimension(dmn) :: x
        real(dp),dimension(dmn) :: res
        res = ( (1.0 / (1.0 + exp(-x))) - 0.05) / 0.9
    end function inv_logistic_vector

end program gp_in


*DECK DGAMI
      DOUBLE PRECISION FUNCTION DGAMI (A, X)
C***BEGIN PROLOGUE  DGAMI
C***PURPOSE  Evaluate the incomplete Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      DOUBLE PRECISION (GAMI-S, DGAMI-D)
C***KEYWORDS  FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate the incomplete gamma function defined by
C
C DGAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) .
C
C DGAMI is evaluated for positive values of A and non-negative values
C of X.  A slight deterioration of 2 or 3 digits accuracy will occur
C when DGAMI is very large or very small, because logarithmic variables
C are used.  The function and both arguments are double precision.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DGAMIT, DLNGAM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DGAMI
      DOUBLE PRECISION A, X, FACTOR, DLNGAM, DGAMIT
C***FIRST EXECUTABLE STATEMENT  DGAMI
      IF (A .LE. 0.D0) CALL XERMSG ('SLATEC', 'DGAMI',
     +   'A MUST BE GT ZERO', 1, 2)
      IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'DGAMI',
     +   'X MUST BE GE ZERO', 2, 2)
C
      DGAMI = 0.D0
      IF (X.EQ.0.0D0) RETURN
C
C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW.
      FACTOR = EXP (DLNGAM(A) + A*LOG(X))
C
      DGAMI = FACTOR * DGAMIT (A, X)
C
      RETURN
      END


!> Tests the random numbers module.
PROGRAM test_random_numbers
    USE random_numbers
    USE kinds
    IMPLICIT NONE
    REAL(dp) :: unif1(1), unif2(1)
    REAL(dp) :: gran1(1), gran2(1)

    call initialize_rn
    ! Check out the uniform random numbers
    unif1 = uniform_rn(unif1)
    unif2 = uniform_rn(unif2)
    IF ( unif1(1) == unif2(1) ) THEN
        WRITE(*,*) 'uniform random numbers are identical!'
        STOP 1
    END IF
    ! Check out the gaussian random numbers
    gran1 = gaussian_rn(gran1)
    gran2 = gaussian_rn(gran2)
    IF ( gran1(1) == gran2(1) ) THEN
        WRITE(*,*) 'gaussian random numbers are identical!'
        STOP 1
    END IF

END PROGRAM test_random_numbers


program testdotf
    use ISO_FORTRAN_ENV
    use OMP_LIB
    implicit none
    integer, parameter :: n=100000
    integer :: i,j
    real(kind=REAL128) :: x128(n),y128(n)
    real(kind=REAL128) :: z128,zmix
    real(kind=REAL64) :: x64(n),y64(n)
    real(kind=REAL64) :: z64
    real(kind=REAL32) :: x32(n),y32(n)
    real(kind=REAL32) :: z32
    double precision :: t0,t1,dt32,dt64,dt128,dtmix
    call random_seed()
    call random_number(x128)
    call random_number(y128)
    do i=1,n
        x64(i) = x128(i)
        x32(i) = x128(i)
        y64(i) = y128(i)
        y32(i) = y128(i)
    enddo
!    do i=1,n
!      write(6,1128) i,x128(i),y128(i)
!    enddo
!    do i=1,n
!      write(6,164) i,x64(i),y64(i)
!    enddo
!    do i=1,n
!      write(6,132) i,x32(i),y32(i)
!    enddo
    dt128 = 0.0d0
    dtmix = 0.0d0
    dt64  = 0.0d0
    dt32  = 0.0d0
    do j=1,100
        t0 = omp_get_wtime()
        call mydotf128(n,x128,1,y128,1,z128)
        t1 = omp_get_wtime()
        dt128 = dt128 + t1 - t0
        t0 = omp_get_wtime()
        call mydotf64(n,x64 ,1,y64 ,1,z64)
        t1 = omp_get_wtime()
        dt64 = dt64 + t1 - t0
        t0 = omp_get_wtime()
        call mydotof128if64(n,x64 ,1,y64 ,1,zmix)
        t1 = omp_get_wtime()
        dtmix = dtmix + t1 - t0
        t0 = omp_get_wtime()
        call mydotf32(n,x32 ,1,y32 ,1,z32)
        t1 = omp_get_wtime()
        dt32 = dt32 + t1 - t0
        if (j.eq.1) then
            ! check accuracy visually on first iteration
            write(6,*) dt128,',',z128
            write(6,*) dt64 ,',',z64
            write(6,*) dtmix,',',zmix
            write(6,*) dt32 ,',',z32
            ! ignore timing for first iteration
            dt128 = 0.0d0
            dtmix = 0.0d0
            dt64  = 0.0d0
            dt32  = 0.0d0
        endif
    enddo
    write(6,1000) dt32,dt64,dtmix,dt128
 132  format(' float32  ',i9,',',e14.7 ,',',e14.7)
 164  format(' float64  ',i9,',',e21.14,',',e21.14)
 1128 format(' float128 ',i9,',',e35.28,',',e35.28)
 1000 format('Timings ',f14.7,' (32b),',f14.7,' (64b),',f14.7,' (mix)',f14.7,' (128b)')
end program testdotf