************************************************************************
*
*     Subroutine LADREG                      Called by: CALIBR, JKNIFE
*
*     Estimate parameters of a censored linear model with NPAR
*     explanatory variables using Powell's Censored Least Absolute
*     Deviation (CLAD) (Powell, 1984).  An iterative linear programming
*     method is used to implement CLAD (Buchinsky, 1994).
*
*     LAD is done via Algorithm 615 from the Association for
*     Computing Machinery (ACM).  Original code obtained from NETLIB
*     TOMS collection.
*
*     *** This routine is for the special case of no censoring ***
*
*
*     local vars
*     ----------
*     INDX     rows of LU
*     NOBS2    number of observations in the last trimmed sample
*     TOT      current RHS of the dual problem
*     XOBS2    copy of the observed values of the explanatory variables
*              (the last trimmed sample)
*     YOBS2    observed uncensored values of the response variable and
*              the estimated value of the response variable for censored
*              observations (the last trimmed sample)
*
************************************************************************
      SUBROUTINE LADREG(NPAR,NUMOBS,XOBS,YOBS,PARAM,BICOR,NOBSCI)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 NPAR,NOBSCI,NUMOBS
      DOUBLE PRECISION BICOR,PARAM(*),YOBS(*),XOBS(NOBSCI,*)
*
*     local vars
*
      INTEGER*4 I,J,NOBS2
      INTEGER*4 INDX(MAXPARMS)
      DOUBLE PRECISION TOT(MAXPARMS),YOBS2(NOBSCI)
      DOUBLE PRECISION XOBS2(NOBSCI,MAXPARMS)
*
*     function declaration
*
      DOUBLE PRECISION PRED
*
*     create copy of matrix of observed X values for input to L1NORM.
*     Original XOBS is not passed.
*
      NOBS2 = 0
      DO I=1,NUMOBS
         DO J=1,NPAR
            XOBS2(I,J) = XOBS(I,J)
         ENDDO
         YOBS2(I) = YOBS(I)
         NOBS2 = NOBS2 + 1
      ENDDO
*
*     obtain initial parameter estimates by calculating Least Absolute
*     Deviation of linear model using detection limit for response
*     variable. (original setup included s/r KBEST for selecting best
*     explanatory variable subsets.  By setting the minimum number of
*     variables NPAR, a conventional LAD regression is done here).
*
      DO I=1,NPAR
         INDX(I) = I
         TOT(I) = 0.D0
      ENDDO
      CALL L1NORM(XOBS2,YOBS2,NOBS2,NPAR,PARAM,TOT,INDX,NOBSCI)
*
*     calculate transformation bias correction factor (BICOR).  BICOR is
*     based on Duan'S Nonparametric Smearing Estimator (mean of the
*     exponentiated residuals)
*
      BICOR = 0.D0
      DO I=1,NUMOBS
         BICOR = BICOR + DEXP(YOBS(I)-PRED(NPAR,NOBSCI,I,XOBS,PARAM))
      ENDDO
      BICOR = BICOR/DBLE(NUMOBS)

      RETURN
      END


      subroutine fmuls1(n,h,x,hx)
      implicit double precision (a-h,o-z)
c
c ce sous-programme effectue le produit  h * x   avec:
c n (e) dimension du probleme
c h (e) dimension n(n+1)/2. tiangle superieur, coefficients par ligne
c x (e) vecteur de dimension n
c hx (s) dimension n. resultat du produit
c
c
c
c parametre
      double precision  zero
      parameter       ( zero=0.0d+0 )
c declarations
      double precision  h(*), x(n), hx(n), aux1
      integer    n, k, km1, kj, j
c
      do 3000 k=1,n
c calcul de la keme composante du produit  h* x
      aux1=zero
c h(kj) est le coefficient (k,j) de la matrice symetrique complete
      kj=k
      km1=k-1
c contribution du triangle inferieur
      if (km1.ge.1) then
      do 1000 j=1,km1
      aux1=aux1 + h(kj) * x(j)
      kj=kj+(n-j)
1000  continue
      endif
c contribution du triangle superieur
      do 2000 j=k,n
      aux1=aux1 + h(kj) * x(j)
      kj=kj+1
2000  continue
c
      hx(k)=aux1
3000  continue
c
      return
      end


      subroutine step
c
c     ******************************************************************
c     *                                                                *
c     *   calculates the permissible time step                         *
c     *                                                                *
c     ******************************************************************
c
c     w(i,j,1)  = density
c     w(i,j,2)  = momentum in x direction
c     w(i,j,3)  = momentum in y direction
c     w(i,j,4)  = total energy
c
c     ******************************************************************
c
      use dims
c
c     ******************************************************************
c
      use flo_var
      use mesh_var
      use solv_var
c
c     ******************************************************************
c
      use flo_param
      use solv_param
c
c     ******************************************************************
c
      implicit none
c
c     ******************************************************************
c
c     local variables
c
c     ******************************************************************
c
      integer  :: i,j,ii
      integer  :: imin,jmin
c
c     ******************************************************************
c
      real     :: slim,rlim,b,dtmin
      real     :: xx,yx,xy,yy,qs,cc,cs
      real     :: v1,v2,rmu,rk,dsi,dsj,vsi,vsj,dtv
      real     :: dpi,dpj,a
c
c     ******************************************************************
c
      real, dimension(0:ib,0:jb)   :: s
      real, dimension(il,jl)       :: dtlc
c
c     ******************************************************************
c
      slim      = .001
      rlim      = .001
      b         = 4.
      dtmin     = 0.
      imin      = 0
      jmin      = 0
c
c     permissible time step
c
      do j=2,jl
      do i=2,il
         cc        = gamma*p(i,j)/max(w(i,j,1),rlim)
         xx        = .5*(x(i,j,1) -x(i-1,j,1) +x(i,j-1,1) -x(i-1,j-1,1))
         yx        = .5*(x(i,j,2) -x(i-1,j,2) +x(i,j-1,2) -x(i-1,j-1,2))
         xy        = .5*(x(i,j,1) -x(i,j-1,1) +x(i-1,j,1) -x(i-1,j-1,1))
         yy        = .5*(x(i,j,2) -x(i,j-1,2) +x(i-1,j,2) -x(i-1,j-1,2))
         qs        = (yy*w(i,j,2) -xy*w(i,j,3))/w(i,j,1)
         cs        = cc*(xy**2  +yy**2)
         radi(i,j) = abs(qs)  +sqrt(cs)
         qs        = (xx*w(i,j,3)  -yx*w(i,j,2))/w(i,j,1)
         cs        = cc*(xx**2  +yx**2)
         radj(i,j) = abs(qs)  +sqrt(cs)
         dtl(i,j)  = 1./(radi(i,j)  +radj(i,j))
         dtlc(i,j) = radi(i,j)  +radj(i,j)
      end do
      end do
c
c     pressure or entropy switch
c
c     if (kvis.eq.0) then
         do j=0,jb
         do i=0,ib
            s(i,j)    = p(i,j)
         end do
         end do
c     else
c        do j=0,jb
c        do i=0,ib
c           s(i,j)    = p(i,j)/w(i,j,1)**gamma
c        end do
c        end do
c     end if
c
c     adaptive time step
c
      do j=2,jl
      do i=2,il
         dpi       = abs((s(i+1,j)  -2.*s(i,j)  +s(i-1,j))/
     .                   (s(i+1,j)  +2.*s(i,j)  +s(i-1,j)  +slim))
         dpj       = abs((s(i,j+1)  -2.*s(i,j)  +s(i,j-1))/
     .                   (s(i,j+1)  +2.*s(i,j)  +s(i,j-1)  +slim))
         rfl(i,j)  = 1./(1.  +min(dim(cfl,1.),b*(dpi  +dpj)))
      end do
      end do

      if (vt.eq.0.) go to 11
c
c     fixed time step
c
      dtmin     = dtl(2,2)
      do j=2,jl
      do i=2,il
         if (dtl(i,j).le.dtmin) then
            dtmin     = dtl(i,j)
            imin      = i
            jmin      = j
         end if
      end do
      end do

      do j=2,jl
      do i=2,il
         rfl(i,j)  = dtmin/dtl(i,j)
      end do
      end do
c
c     option to rescale the dissipative coefficients
c
   11 do j=2,jl
      do i=2,il
         if (iprec.ne.0) then
c           rfli(i,j) = sqrt(radj(i,j)/radi(i,j))
c           rflj(i,j) = sqrt(radi(i,j)/radj(i,j))
            rfli(i,j) = (radj(i,j)/radi(i,j))**.25
            rflj(i,j) = (radi(i,j)/radj(i,j))**.25
c           rfli(i,j) = 1.
c           rflj(i,j) = 1.
         end if
         a         = (radi(i,j)/radj(i,j))**adis
         radi(i,j) = radi(i,j)*(1.  +1./a)
         radj(i,j) = radj(i,j)*(1.  +a)
         if (iprec.eq.0) then
            rfli(i,j) = radi(i,j)/dtlc(i,j)
            rflj(i,j) = radj(i,j)/dtlc(i,j)
         end if
      end do
      end do
c
c
c     reduce the artificial dissipation for viscous flows
c     and adjust the time step estimate
c
      if (kvis.gt.0) then

      v1        = sqrt(gamma)*rm/re
      v2        = 0.
      if (kvis.gt.1) v2 = v1

      do j=2,jl
      do i=2,il
         rk        = gamma *(v1*rlv(i,j)/prn + v2*rev(i,j)/prt)/w(i,j,1)
         rmu       = (v1*rlv(i,j)+v2*rev(i,j))/w(i,j,1)
         xx        = .5*(x(i,j,1) -x(i-1,j,1) +x(i,j-1,1) -x(i-1,j-1,1))
         yx        = .5*(x(i,j,2) -x(i-1,j,2) +x(i,j-1,2) -x(i-1,j-1,2))
         xy        = .5*(x(i,j,1) -x(i,j-1,1) +x(i-1,j,1) -x(i-1,j-1,1))
         yy        = .5*(x(i,j,2) -x(i,j-1,2) +x(i-1,j,2) -x(i-1,j-1,2))
         dsi       = xy**2  +yy**2
         dsj       = xx**2  +yx**2
         vsi       = (rk*dsi + rmu*sqrt(dsi*dsj)/6.)/vol(i,j)
         vsj       = (rk*dsj + rmu*sqrt(dsi*dsj)/6.)/vol(i,j)
         dtv       = dtlc(i,j)+4.*(vsi+vsj)
         dtl(i,j)  = 1./dtv
         radi(i,j) = dim(radi(i,j),vsi)
         radj(i,j) = dim(radj(i,j),vsj)
      end do
      end do

      end if
c
c     set boundary values at i=1 and i=ie
c
      do j=2,jl
         radi(1,j)   = radi(2,j)
         radi(ie,j)  = radi(il,j)
         rfl(1,j)    = rfl(2,j)
         rfl(ie,j)   = rfl(il,j)
         rfli(1,j)   = rfli(2,j)
         rfli(ie,j)  = rfli(il,j)
         rflj(1,j)   = rflj(2,j)
         rflj(ie,j)  = rflj(il,j)
         dtl(1,j)    = dtl(2,j)
         dtl(ie,j)   = dtl(il,j)
      end do
c
c     set boundary values at j=1 and j=je
c
      do i=1,ie
         radj(i,1)   = radj(i,2)
         radj(i,je)  = radj(i,jl)
         rfl(i,1)    = rfl(i,2)
         rfl(i,je)   = rfl(i,jl)
         rfli(i,1)   = rfli(i,2)
         rfli(i,je)  = rfli(i,jl)
         rflj(i,1)   = rflj(i,2)
         rflj(i,je)  = rflj(i,jl)
         dtl(i,1)    = dtl(i,2)
         dtl(i,je)   = dtl(i,jl)
      end do
c
c     set boundary values along the cut
c
      do i=1,itl
         ii        = ib  -i
         radj(ii,1)  = radj(i,2)
         radj(i,1)   = radj(ii,2)
         rfl(ii,1)   = rfl(i,2)
         rfl(i,1)    = rfl(ii,2)
         rfli(ii,1)  = rfli(i,2)
         rfli(i,1)   = rfli(ii,2)
         rflj(ii,1)  = rflj(i,2)
         rflj(i,1)   = rflj(ii,2)
         dtl(ii,1)   = dtl(i,2)
         dtl(i,1)    = dtl(ii,2)
      end do

      return

      end


!==========================================================================
elemental function gsw_pt_from_pot_enthalpy_ice_poly_dh (pot_enthalpy_ice)
!==========================================================================
!
!  Calculates the derivative of potential temperature of ice with respect
!  to potential enthalpy.  This is based on the compuationally-efficient
!  polynomial fit to the potential enthalpy of ice.
!
!  pot_enthalpy_ice  =  potential enthalpy of ice                  [ J/kg ]
!
!  dpt0_ice_dh  =  derivative of potential temperature of ice
!                  with respect to potential enthalpy             [ deg C ]
!--------------------------------------------------------------------------

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: pot_enthalpy_ice

real (r8) :: gsw_pt_from_pot_enthalpy_ice_poly_dh

real (r8), parameter :: q1 = 2.594351081876611e-3_r8
real (r8), parameter :: p2 = 3.530155620427630e-8_r8
real (r8), parameter :: p3 = 2.330421169287162e-13_r8
real (r8), parameter :: p4 = 8.139369017110120e-19_r8
real (r8), parameter :: p5 = 1.610007265856420e-24_r8
real (r8), parameter :: p6 = 1.707103685781641e-30_r8
real (r8), parameter :: p7 = 7.658041152250651e-37_r8

gsw_pt_from_pot_enthalpy_ice_poly_dh = q1 &
    + pot_enthalpy_ice*(p2 + pot_enthalpy_ice*(p3 &
    + pot_enthalpy_ice*(p4 + pot_enthalpy_ice*(p5 + pot_enthalpy_ice*(p6 &
    + pot_enthalpy_ice*p7)))))

return
end function

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


!***********************************************************
!      mtx_colm,mtx_rowp,mtx_mtx
!**********************************************************
      subroutine mtx_colm(a_colm,a_rowp,
     &                    b_colm,b_rowp,
     &                    c_colm,m,l,n)
      integer,intent(in)                :: m,l,n
      integer,intent(in) :: a_colm(m+1),b_colm(l+1)
      integer,intent(inout) :: c_colm(m+1)
      integer,intent(in) :: a_rowp(a_colm(m+1)-1)
      integer,intent(in) :: b_rowp(b_colm(l+1)-1)

      integer      :: i,j,k,p,q,mnnz
      integer      :: itemp(max(m,l))

      mnnz = 1
      itemp = 0
      do i=1,m
         c_colm(i) = mnnz
         do k=a_colm(i),a_colm(i+1)-1
            j=a_rowp(k)
            do p=b_colm(j),b_colm(j+1)-1
               q=b_rowp(p)
               if (itemp(q).ne.i) then
                   itemp(q)=i
                   mnnz = mnnz + 1
               end if
            enddo
         enddo
      enddo
      c_colm(m+1) = mnnz

      end subroutine!mtx_colm

      subroutine mtx_rowp(a_colm,a_rowp,b_colm,b_rowp,
     &                    c_colm,c_rowp,m,l,n,diagflag)
      integer,intent(in)                :: m,l,n
      integer,intent(in) :: a_colm(m+1),b_colm(l+1)
      integer,intent(in) :: c_colm(m+1)
      integer,intent(inout) :: c_rowp(c_colm(m+1)-1)
      integer,intent(in) :: a_rowp(a_colm(m+1)-1)
      integer,intent(in) :: b_rowp(b_colm(l+1)-1)
      logical,intent(in) :: diagflag

      integer      :: i,j,k,p,q,mnnz
      integer      :: itemp(max(m,l))

      mnnz = 0
      itemp = 0
      do i=1,m
         if (diagflag) then
         mnnz = mnnz + 1
         c_rowp(mnnz) = i
         itemp(i)=i
         endif
         do k=a_colm(i),a_colm(i+1)-1
            j=a_rowp(k)
            do p=b_colm(j),b_colm(j+1)-1
               q=b_rowp(p)
               if (itemp(q).ne.i) then
                   itemp(q)=i
                   mnnz = mnnz + 1
                   c_rowp(mnnz) = q
               end if
            enddo
         enddo
      enddo

      end subroutine !mtx_rowp

      subroutine mtx_mtx(a_colm,a_rowp,a_mtx,
     &                   b_colm,b_rowp,b_mtx,
     &                   c_colm,c_rowp,c_mtx,
     &                   m,l,n)
      integer,intent(in)                :: m,l,n
      integer,intent(in) :: a_colm(m+1),b_colm(l+1)
      integer,intent(in) :: c_colm(m+1)
      integer,intent(in) :: c_rowp(c_colm(m+1)-1)
      integer,intent(in) :: a_rowp(a_colm(m+1)-1)
      integer,intent(in) :: b_rowp(b_colm(l+1)-1)

      real(kind=8),intent(in) :: a_mtx(a_colm(m+1)-1)
      real(kind=8),intent(in) :: b_mtx(b_colm(l+1)-1)
      real(kind=8),intent(inout) :: c_mtx(c_colm(m+1)-1)

      integer      :: i,j,k,p,q
      integer      :: itemp(max(m,l))
      real(kind=8) :: rtemp

      c_mtx = 0
      do i=1,m
         do k=c_colm(i),c_colm(i+1)-1
            itemp(c_rowp(k)) = k
         enddo
         do k=a_colm(i),a_colm(i+1)-1
            j = a_rowp(k)
            rtemp = a_mtx(k)
            do p = b_colm(j),b_colm(j+1)-1
               q = b_rowp(p)
               c_mtx(itemp(q)) = c_mtx(itemp(q)) + rtemp*b_mtx(p)
            enddo
         enddo
      enddo

      end subroutine !mtx_mtx

!************************************************************
!     ramg_calcIAI
!        do matrix multiplication for I^T A I
!        actual operation is: A2_ij = I^T_ip A_pq I_qj
!        where p,q are repeated indicies
!
!************************************************************
      subroutine ramg_calcITAI(level1,level2,maxstopsign)
      use ramg_data
      implicit none

      integer,intent(in)             :: level1,level2
      logical,intent(inout)          :: maxstopsign

      integer                        :: i,j,k,m,p,q,r,n,s,p0
      integer,dimension(amg_nshg(level1))  :: itemp
      integer,dimension(amg_nshg(level2))  :: itemp2
      integer                              :: mnnz

      integer,dimension(amg_nshg(level2)+1)   :: ITA_colm
      integer,dimension(:),allocatable        :: ITA_rowp
      real(kind=8),dimension(:),allocatable   :: ITA

      integer                              :: mem_err, mem_err_s

      real(kind=8)                             :: rtp
      character                            :: fname*80
      real,dimension(10)                   :: cpusec

      call cpu_time(cpusec(1))

      IF (level1.eq.0) THEN
          ! reduced serial test here, DO NOT USE IT unless RECOVER
          ! from extract.
      call mtx_colm(I_fc_colm(level1)%p,I_fc_rowp(level1)%p,
!     &              amg_A_colm(level1)%p,amg_A_rowp(level1)%p,
     &              reducecolm,reducerowp,
     &              ITA_colm,amg_nshg(level2),amg_nshg(level1),
     &              amg_nshg(level1))
      mnnz = ITA_colm(amg_nshg(level2)+1)-1
      allocate(ITA_rowp(mnnz),stat=mem_err)
      allocate(ITA(mnnz),stat=mem_err)
      ! IT * A
      ! rowp
      call mtx_rowp(I_fc_colm(level1)%p,I_fc_rowp(level1)%p,
!     &              amg_A_colm(level1)%p,amg_A_rowp(level1)%p,
     &              reducecolm,reducerowp,
     &              ITA_colm,ITA_rowp,
     &              amg_nshg(level2),amg_nshg(level1),
     &              amg_nshg(level1),.false.)
      ! IT * A
      ! value
      call mtx_mtx(I_fc_colm(level1)%p,I_fc_rowp(level1)%p,
     &              I_fc(level1)%p,
!     &              amg_A_colm(level1)%p,amg_A_rowp(level1)%p,
!     &              amg_A_lhs(level1)%p,
     &              reducecolm,reducerowp,reducelhs,
     &              ITA_colm,ITA_rowp,ITA,
     &              amg_nshg(level2),amg_nshg(level1),
     &              amg_nshg(level1))
      call cpu_time(cpusec(2))

      ELSE

      ! IT * A
      ! colm and nnz
      call mtx_colm(I_fc_colm(level1)%p,I_fc_rowp(level1)%p,
     &              amg_A_colm(level1)%p,amg_A_rowp(level1)%p,
     &              ITA_colm,amg_nshg(level2),amg_nshg(level1),
     &              amg_nshg(level1))
      mnnz = ITA_colm(amg_nshg(level2)+1)-1
      allocate(ITA_rowp(mnnz),stat=mem_err)
      allocate(ITA(mnnz),stat=mem_err)
      ! IT * A
      ! rowp
      call mtx_rowp(I_fc_colm(level1)%p,I_fc_rowp(level1)%p,
     &              amg_A_colm(level1)%p,amg_A_rowp(level1)%p,
     &              ITA_colm,ITA_rowp,
     &              amg_nshg(level2),amg_nshg(level1),
     &              amg_nshg(level1),.false.)
      ! IT * A
      ! value
      call mtx_mtx(I_fc_colm(level1)%p,I_fc_rowp(level1)%p,
     &              I_fc(level1)%p,
     &              amg_A_colm(level1)%p,amg_A_rowp(level1)%p,
     &              amg_A_lhs(level1)%p,
     &              ITA_colm,ITA_rowp,ITA,
     &              amg_nshg(level2),amg_nshg(level1),
     &              amg_nshg(level1))
      call cpu_time(cpusec(2))

      ENDIF

      ! ( IT*A ) * I
      ! colm and nnz
      call ramg_allocate(level2,amg_nshg(level2),0,1)
      call mtx_colm(ITA_colm,ITA_rowp,I_cf_colm(level1)%p,
     &              I_cf_rowp(level1)%p,amg_A_colm(level2)%p,
     &              amg_nshg(level2),amg_nshg(level1),
     &              amg_nshg(level2))

      call cpu_time(cpusec(3))
      mnnz = amg_A_colm(level2)%p(amg_nshg(level2)+1)-1
      call ramg_allocate(level2,0,mnnz,1)
      ! ( IT*A ) * I
      ! rowp
      call mtx_rowp(ITA_colm,ITA_rowp,I_cf_colm(level1)%p,
     &              I_cf_rowp(level1)%p,amg_A_colm(level2)%p,
     &              amg_A_rowp(level2)%p,
     &              amg_nshg(level2),amg_nshg(level1),
     &              amg_nshg(level2),.true.)
      call cpu_time(cpusec(4))
      ! ( IT*A ) * I
      ! value
      call mtx_mtx(ITA_colm,ITA_rowp,ITA,I_cf_colm(level1)%p,
     &              I_cf_rowp(level1)%p,I_cf(level1)%p,
     &              amg_A_colm(level2)%p,
     &              amg_A_rowp(level2)%p,amg_A_lhs(level2)%p,
     &              amg_nshg(level2),amg_nshg(level1),
     &              amg_nshg(level2))

      deallocate(ITA_rowp,stat=mem_err)
      deallocate(ITA,stat=mem_err)

      call cpu_time(cpusec(5))

      amg_nshg(level2+1) = 0

      ! put on right hand side
      call ramg_calcIvFC(level1,level2,amg_A_rhs(level1)%p,
     &               amg_A_rhs(level2)%p)

      call cpu_time(cpusec(10))

      do i=1,amg_nshg(level2)
         amg_ppeDiag(level2)%p(i) =
     &   1.0/sqrt(amg_A_lhs(level2)%p(amg_A_colm(level2)%p(i),1))
      enddo
      do i=1,amg_nshg(level2)
         do m=amg_A_colm(level2)%p(i),amg_A_colm(level2)%p(i+1)-1
            j = amg_A_rowp(level2)%p(m)
            amg_A_lhs(level2)%p(m,1)=amg_A_lhs(level2)%p(m,1)*
     &        amg_ppeDiag(level2)%p(i)*amg_ppeDiag(level2)%p(j)
         enddo
      enddo

!      do i=1,amg_nshg(level1)
!         do j=I_cf_colm(level1)%p(i),I_cf_colm(level1)%p(i+1)-1
!            k = I_cf_rowp(level1)%p(j)
!            I_cf(level1)%p(j) =
!     &      I_cf(level1)%p(j)*amg_ppeDiag(level2)%p(k)
!         enddo
!      enddo

!      do i=1,amg_nshg(level2)
!         do j=I_fc_colm(level1)%p(i),I_fc_colm(level1)%p(i+1)-1
!         I_cf(level1)%p(j)=
!     &   I_cf(level1)%p(j)*amg_ppeDiag(level2)%p(i)
!         enddo
!      enddo

      end subroutine ! ramg_calcIAI


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pair_cover( algorithm, n, c1, gg1, c2, gg2, cc, gg )

!  Given a pair of ellipsoids, E1 and E2, determine a third ellipsoid
!  E which covers E1 and E2.
!  E is defined by:  (x-cc)^T * G * G^T * (x-cc) <= 1, where the array gg
!  contains G in packed format.  Similarly for E1 and E2.

!  Algorithms to compute E are:
!     algorithm = 1 - spheroid (no shrinking)
!     algorithm = 2 - covariance (QL implementation)
!     algorithm = 3 - iterative
!     algorithm = 4 - spheroid (shrinking)
!     algorithm = 5 - covariance (Cholesky implementation)

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: algorithm, n
real(k_dp), intent(in)  :: c1(n), gg1((n*(n+1))/2), c2(n), gg2((n*(n+1))/2)
real(k_dp), intent(out) :: cc(n),  gg((n*(n+1))/2)

   if( algorithm == 1 ) then
      call ell_pair_cover_sph( n, c1, gg1, c2, gg2, .false., cc, gg )

   elseif( algorithm == 2 ) then
      call ell_pair_cover_cv_ql( n, c1, gg1, c2, gg2, cc, gg )

   elseif( algorithm == 3 ) then
      call ell_pair_cover_it( n, c1, gg1, c2, gg2, cc, gg )

   elseif( algorithm == 4 ) then
      call ell_pair_cover_sph( n, c1, gg1, c2, gg2, .true., cc, gg )

   elseif( algorithm == 5 ) then
      call ell_pair_cover_cv( n, c1, gg1, c2, gg2, cc, gg )
   else
      write(0,*)'ell_pair_cover: called for invalid algorithm = ', algorithm
	  stop
   endif

   return

end subroutine ell_pair_cover


module mod_1DVar

  implicit none

  private

  public :: init_1DVar
  public :: compute_chi_square
  public :: update_solution_1DVar

  real , allocatable , dimension(:,:) :: fmKT
  real , allocatable , dimension(:,:) :: KtSeInv
  real , allocatable , dimension(:,:) :: KtSeInvK
  real , allocatable , dimension(:,:) :: A
  real , allocatable , dimension(:,:) :: L
  real , allocatable , dimension(:,:) :: U
  real , allocatable , dimension(:) :: dx
  real , allocatable , dimension(:) :: dot1
  real , allocatable , dimension(:) :: dot2
  real , allocatable , dimension(:) :: dot3
  real , allocatable , dimension(:) :: dot4
  real , allocatable , dimension(:) :: dot5
  real , allocatable , dimension(:) :: d
  real , allocatable , dimension(:) :: x
  real , allocatable , dimension(:) :: y
  real , allocatable , dimension(:) :: r
  real , allocatable , dimension(:) :: dz
  real , allocatable , dimension(:) :: ddx
  real , allocatable , dimension(:) :: totx
  logical , allocatable , dimension(:,:) :: utmask
  integer , allocatable , dimension(:) :: ipivot

  logical :: isinit = .false.

  real , parameter :: xgamma = 3.0

  interface init_1DVar
    module procedure init_1DVar_2arg
    module procedure init_1DVar_arr
  end interface init_1DVar

  interface dotprod
    module procedure dotprod_matrix_matrix
    module procedure dotprod_matrix_array
    module procedure dotprod_array_matrix
    module procedure dotprod_array_array
  end interface

  interface
    subroutine sgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc)
      character(len=1) , intent(in) :: transa , transb
      integer , intent(in) :: m , n , k , lda , ldb , ldc
      real , intent(in) :: alpha , beta
      real , intent(in) , dimension(m,k) :: a
      real , intent(in) , dimension(k,n) :: b
      real , intent(out) , dimension(m,n) :: c
    end subroutine sgemm
  end interface

  interface
    subroutine sgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy)
      implicit none
      character(len=1) , intent(in) :: trans
      integer , intent(in) :: m , n , lda , incx , incy
      real , intent(in) :: alpha , beta
      real , intent(in) , dimension(m,n) :: a
      real , intent(in) , dimension(n) :: x
      real , intent(out) , dimension(m) :: y
    end subroutine sgemv
  end interface

  interface
    subroutine sgetrf(m,n,a,lda,ipivot,info)
      implicit none
      integer , intent(in) :: m , n , lda
      integer , intent(inout) , dimension(min(m,n)) :: ipivot
      real , intent(inout) , dimension(lda,n) :: a
      integer , intent(out) :: info
    end subroutine sgetrf
  end interface

  interface
    subroutine sgesv(n,nrhs,a,lda,ipivot,b,ldb,info)
      implicit none
      integer , intent(in) :: lda , ldb , n , nrhs
      integer , intent(inout) , dimension(n) :: ipivot
      real , intent(in) , dimension(lda,n) :: a
      real , intent(inout) , dimension(ldb,nrhs) :: b
      integer , intent(out) :: info
    end subroutine sgesv
  end interface

  interface
    real function sdot(n,sx,incx,sy,incy)
      implicit none
      integer , intent(in) :: n , incx , incy
      real , intent(in) , dimension(n) :: sx
      real , intent(in) , dimension(n) :: sy
    end function sdot
  end interface

  contains

    subroutine dotprod_matrix_matrix(a,b,c)
      implicit none
      real , dimension(:,:) , intent(in) :: a
      real , dimension(:,:) , intent(in) :: b
      real , dimension(:,:) , intent(out) :: c
      integer :: dim1 , dim2 , dim3
      real , parameter :: alpha = 1.0
      real , parameter :: beta = 0.0
      dim1 = size(a,1)
      dim2 = size(a,2)
      dim3 = size(b,2)
      if ( dim1 /= size(c,1) ) then
        write(0,*) 'Dimension error in DOTPROD : A(dim1) /= C(dim1)'
        write(0,*) 'SHAPE A : ', shape(a)
        write(0,*) 'SHAPE B : ', shape(b)
        write(0,*) 'SHAPE C : ', shape(c)
        stop
      end if
      if ( dim2 /= size(b,1) ) then
        write(0,*) 'Dimension error in DOTPROD : A(dim2) /= B(dim1)'
        write(0,*) 'SHAPE A : ', shape(a)
        write(0,*) 'SHAPE B : ', shape(b)
        write(0,*) 'SHAPE C : ', shape(c)
        stop
      end if
      if ( dim3 /= size(c,2) ) then
        write(0,*) 'Dimension error in DOTPROD : B(dim2) /= C(dim(2)'
        write(0,*) 'SHAPE A : ', shape(a)
        write(0,*) 'SHAPE B : ', shape(b)
        write(0,*) 'SHAPE C : ', shape(c)
        stop
      end if
      call sgemm('N','N',dim1,dim3,dim2,alpha,a,dim1,b,dim2,beta,c,dim1)
    end subroutine dotprod_matrix_matrix

    subroutine dotprod_matrix_array(a,b,c)
      implicit none
      real , dimension(:,:) , intent(in) :: a
      real , dimension(:) , intent(in) :: b
      real , dimension(:) , intent(out) :: c
      integer :: dim1 , dim2
      real , parameter :: alpha = 1.0
      real , parameter :: beta = 0.0
      dim1 = size(a,1)
      dim2 = size(a,2)
      if ( dim1 /= size(c) ) then
        write(0,*) 'Dimension error in DOTPROD : A(dim1) /= size(C)'
        write(0,*) 'SHAPE A : ', shape(a)
        write(0,*) 'SIZE  B : ', size(b)
        write(0,*) 'SIZE  C : ', size(c)
        stop
      end if
      if ( dim2 /= size(b) ) then
        write(0,*) 'Dimension error in DOTPROD : A(dim2) /= B(dim1)'
        write(0,*) 'SHAPE A : ', shape(a)
        write(0,*) 'SIZE  B : ', size(b)
        write(0,*) 'SIZE  C : ', size(c)
        stop
      end if
      call sgemv('N',dim1,dim2,alpha,a,dim1,b,1,beta,c,1)
    end subroutine dotprod_matrix_array

    subroutine dotprod_array_matrix(a,b,c)
      implicit none
      real , dimension(:) , intent(in) :: a
      real , dimension(:,:) , intent(in) :: b
      real , dimension(:) , intent(out) :: c
      real , dimension(1,size(a)) :: tmp
      real , dimension(1,size(b,2)) :: tmp1
      integer :: dim1 , dim2 , dim3
      real , parameter :: alpha = 1.0
      real , parameter :: beta = 0.0
      tmp(1,:) = a
      dim1 = size(tmp,1)
      dim2 = size(tmp,2)
      dim3 = size(b,2)
      if ( dim1 /= size(tmp1,1) ) then
        write(0,*) 'Dimension error in DOTPROD : A(dim1) /= C(dim1)'
        write(0,*) 'SHAPE A : ', shape(tmp)
        write(0,*) 'SHAPE B : ', shape(b)
        write(0,*) 'SHAPE C : ', shape(tmp1)
        stop
      end if
      if ( dim2 /= size(b,1) ) then
        write(0,*) 'Dimension error in DOTPROD : A(dim2) /= B(dim1)'
        write(0,*) 'SHAPE A : ', shape(tmp)
        write(0,*) 'SHAPE B : ', shape(b)
        write(0,*) 'SHAPE C : ', shape(tmp1)
        stop
      end if
      if ( dim3 /= size(tmp1,2) ) then
        write(0,*) 'Dimension error in DOTPROD : B(dim2) /= C(dim(2)'
        write(0,*) 'SHAPE A : ', shape(tmp)
        write(0,*) 'SHAPE B : ', shape(b)
        write(0,*) 'SHAPE C : ', shape(tmp1)
        stop
      end if
      call sgemm('N','N',dim1,dim3,dim2,alpha,tmp,dim1,b,dim2,beta,tmp1,dim1)
      c = tmp1(:,1)
    end subroutine dotprod_array_matrix

    subroutine dotprod_array_array(a,b,d)
      implicit none
      real , intent(in) , dimension(:) :: a , b
      real , intent(out) :: d
      integer :: dim1
      dim1 = size(a)
      if ( dim1 /= size(b) ) then
        write(0,*) 'Dimension error in DOTPROD : A(dim1) /= B(dim1)'
        write(0,*) 'SIZE  A : ', size(a)
        write(0,*) 'SIZE  B : ', size(b)
        stop
      end if
      d = sdot(size(a),a,1,b,1)
    end subroutine dotprod_array_array

    subroutine ludecomp(a,l,u)
      implicit none
      real , intent(in) , dimension(:,:) :: a
      real , intent(out) , dimension(:,:) :: l
      real , intent(out) , dimension(:,:) :: u
      real , dimension(size(a,1),size(a,2)) :: lu
      integer :: i , dim1 , dim2 , info
      dim1 = size(a,1)
      dim2 = size(a,2)
      if ( dim1 /= size(l,1) .or. &
           dim2 /= size(l,2) .or. &
           dim1 /= size(u,1) .or. &
           dim2 /= size(u,2) ) then
        write(0,*) 'Dimension error in ludecomp'
        write(0,*) 'SHAPE A : ', shape(a)
        write(0,*) 'SHAPE L : ', shape(l)
        write(0,*) 'SHAPE U : ', shape(u)
        stop
      end if
      lu = a
      call sgetrf(dim1,dim2,lu,dim1,ipivot,info)
      if ( info /= 0 ) then
        if ( info < 0 ) then
          write(0,*) 'INVALID ARGUMENT NO ',-info
        else
          write(0,*) 'Singular matrix !!!'
          write(0,*) 'U(',info,',',info,') = ',lu(info,info)
        end if
        stop
      end if
      l = 0.0
      u = 0.0
      where (utmask)
        l = lu
      else where
        u = lu
      end where
      do i = 1 , dim2
        l(i,i) = 1.0
      end do
    end subroutine ludecomp

    subroutine solve(A,b,x)
      implicit none
      real , intent(in) , dimension(:,:) :: a
      real , intent(in) , dimension(:) :: b
      real , intent(out) , dimension(:) :: x
      real , dimension(size(a,1),size(a,2)) :: lu
      real , dimension(size(a,1),1) :: xb
      integer :: dim1 , dim2 , info
      dim1 = size(a,1)
      dim2 = size(a,2)
      lu = a
      xb(:,1) = b
      call sgesv(dim2,1,lu,dim1,ipivot,xb,dim1,info)
      x = xb(:,1)
    end subroutine solve

    subroutine init_1DVar_2arg(m,n)
      implicit none
      integer , intent(in) :: n , m
      integer :: i , j
      if ( isinit ) then
        if ( size(KtSeInv,1) /= n  .and. &
             size(KtSeInv,2) /= m ) then
          deallocate(KtSeInv)
          deallocate(KtSeInvK)
          deallocate(fmKT)
          deallocate(A)
          deallocate(utmask)
          deallocate(L)
          deallocate(U)
          deallocate(ipivot)
          deallocate(dx)
          deallocate(d)
          deallocate(x)
          deallocate(y)
          deallocate(r)
          deallocate(dz)
          deallocate(ddx)
          deallocate(totx)
          deallocate(dot1)
          deallocate(dot2)
          deallocate(dot3)
          deallocate(dot4)
          deallocate(dot5)
        else
          return
        end if
      end if
      allocate(KtSeInv(n,m))
      allocate(KtSeInvK(n,n))
      allocate(A(n,n))
      allocate(utmask(n,n))
      allocate(L(n,n))
      allocate(U(n,n))
      allocate(ipivot(n))
      allocate(dx(n))
      allocate(fmKT(n,m))
      allocate(dot1(n))
      allocate(dot2(n))
      allocate(dot3(n))
      allocate(d(n))
      allocate(x(n))
      allocate(y(n))
      allocate(r(n))
      allocate(dz(n))
      allocate(ddx(n))
      allocate(totx(n))
      allocate(dot4(m))
      allocate(dot5(m))
      do j = 1 , n
        do i = 1 , n
          utmask(i,j) = (j-i) > 0
        end do
      end do
      isinit = .true.
    end subroutine init_1DVar_2arg

    subroutine init_1DVar_arr(sh)
      implicit none
      integer , intent(in) , dimension(2) :: sh
      call init_1DVar_2arg(sh(1),sh(2))
    end subroutine init_1DVar_arr

    real function compute_chi_square(m,SEInv,yobs_minus_yhat) result(norm)
      implicit none
      integer , intent(in) :: m
      real , dimension(m,m) , intent(in) :: SEInv
      real , dimension(m) , intent(in) :: yobs_minus_yhat
      if ( .not. isinit ) return
      call dotprod(yobs_minus_yhat,SEInv,dot4)
      dot5 = yobs_minus_yhat/size(yobs_minus_yhat)
      call dotprod(dot4,dot5,norm)
    end function compute_chi_square

    subroutine update_solution_1DVar(m,n,fmK,SEInv,SaInv_ret, &
                                     yobs_minus_yhat,xhat,ap,xhat_new,d2)
      implicit none
      integer , intent(in) :: m , n
      real , dimension(m,n) , intent(in) :: fmK
      real , dimension(m,m) , intent(in) :: SEInv
      real , dimension(n,n) , intent(in) :: SaInv_ret
      real , dimension(m) , intent(in) :: yobs_minus_yhat
      real , dimension(n) , intent(in) :: xhat
      real , dimension(n) , intent(in) :: ap
      real , dimension(n) , intent(out) :: xhat_new
      real , intent(out) :: d2
      if ( .not. isinit ) return
      fmKT = transpose(fmK)
      call dotprod(fmKT,SEInv,KtSeInv)
      call dotprod(KtSeInv,fmK,KtSeInvK)
      A = KtSeInvK+(1.0+xgamma*SaInv_ret)
      dx = xhat - ap
      call dotprod(KtSeInv,yobs_minus_yhat,dot1)
      call dotprod(SaInv_ret,dx,dot2)
      d = dot1 - dot2
      call ludecomp(A,L,U)
      call solve(L,d,y)
      call solve(U,y,x)
      call dotprod(A,x,dot3)
      r = d - dot3
      call solve(L,r,dz)
      call solve(U,dz,ddx)
      totx = x+ddx
      xhat_new = xhat+totx
      call dotprod(totx,d,d2)
    end subroutine update_solution_1DVar

end module mod_1DVar


	FUNCTION FLILO(X,B)
C
C
C       FLILO MEANS LINEAR FUNCTION FOR SMALL ARGUMENT
C       AND LOGARITHM FOR LARGE ARGUMENT
C       SIGN IS PRESERVED
C       FOR /X/.LT.B   FLILO=X
C       FOR /X/.GT.B   FLILO=A*LOG(X)+C IN SUCH A WAY
C       THAT FLILO AND ITS DERIVATIVE ARE CONTINUOUS AT /X/=/B/
C
        XM=ABS(X)
        IF(XM.GT.B) GO TO 1
	 FLILO=X
        RETURN
    1   FT=B*ALOG(XM/B)+B
        FLILO=SIGN(FT,X)
        RETURN
	END
         FUNCTION AFLILO(X,B)
C
C       INVERSE OF FLILO
C
        XM=ABS(X)
        IF(XM.GT.B) GO TO 1
        AFLILO=X
        RETURN
    1   FT=B*EXP(XM/B-1.)
        AFLILO=SIGN(FT,X)
        RETURN
        END
	SUBROUTINE PLTPRT(STRING)
	BYTE STRING(132)
	WRITE (7,100) STRING
  100 FORMAT(' '132A1)
	DO 10 N = 1,132
   10 STRING(N) = ' '
	RETURN
	END
	SUBROUTINE PLTFST(N)
	RETURN
	END
	SUBROUTINE CLOSEF(N)
	RETURN
	END
	SUBROUTINE PLOTF(N)
	RETURN
	END
	SUBROUTINE SCOPST(N)
	RETURN
	END
	SUBROUTINE SCOPLT(N)
	RETURN
	END
	SUBROUTINE SCOPE(N)
	RETURN
	END


! subroutine set_satmod
SUBROUTINE set_satmod(lon0,lat0,spheroid,orb_elements,psx,psy,smodel,istat)

!   lon0,lat0 are the (geo) coordinates of a point on the track
!   orb_elements 1,2,3 are orb_i,orb_R,nodal_p
!   spheroid 1,2 are asph,finv

!   * Re-written as an independent subroutine by JS, Aug 2014

!   Inputs:
!       lon0
!       lat0
!       spheroid
!           1. Spheroid major axis
!           2. Inverse flattening
!           3. Eccentricity squared
!           4. Earth rotational angular velocity rad/sec
!       orb_elements
!           1. Orbital inclination (degrees)
!           2. Semi_major radius (m)
!           3. Angular velocity (rad sec-1)
!       smodel
!           1. phi0
!           2. phi0_p
!           3. rho0
!           4. t0
!           5. lam0
!           6. gamm0
!           7. beta0
!           8. rotn0
!           9. hxy0
!           10. N0
!           11. H0
!           12. th_ratio0
!       psx
!           Approximate pixel size (in degrees longitude)
!       psy
!           Approximate pixel size (in degrees latitude)
!
!   Outputs:
!       smodel
!       istat

    use sys_variables, only : pi, d2r, r2d

    implicit none

    double precision, dimension(4), intent(in) :: spheroid
    double precision, dimension(3), intent(in) :: orb_elements
    double precision, intent(in) :: lon0,lat0
    double precision, intent(in) :: psx,psy
    double precision oi,orad,ws
    double precision asph,finv,e2,we

!   smodel(phi0,phi0_p,rho0,t0,lam0,gamm0,beta0,rotn0,hxy0,N0,H0,th_ratio0)
    double precision, dimension(12), intent(out) :: smodel
    double precision phi0,phi0_p,rho0,t0,lam0,gamm0,beta0,rotn0,hxy0
    double precision N0,H0,th_ratio0
    double precision rn0,temp,psx_out,psy_out,lonin,latin

    integer, intent(out) :: istat

!   Initialise the return status
    istat = 0

!   Satellite orbital parameters
!   orbital inclination (degrees)
!   semi_major radius (m)
!   angular velocity (rad sec-1)
    oi = orb_elements(1)*d2r
    orad = orb_elements(2)
    ws = orb_elements(3)

!   Spheroid parameters
!   Spheroid major axis
!   Inverse flattening
!   Eccentricity squared
!   Earth rotational angular velocity rad/sec
    asph = spheroid(1)
    finv = spheroid(2)
    e2 = spheroid(3)
    we = spheroid(4)

!   now set up the track based on the central point
    phi0 = lat0*d2r
    temp = 1.0d0-e2*sin(phi0)**2
    Rn0 = asph/sqrt(temp)
    phi0_p = phi0-asin(Rn0*e2*sin(phi0)*cos(phi0)/orad)
    rho0 = acos(sin(phi0_p)/sin(oi))
    t0 = (rho0+pi/2.0d0)/ws
    lam0 = lon0*d2r
    gamm0 = lam0+pi/2.0d0-atan(tan(rho0)/cos(oi))
    beta0 = atan(-1.0d0/(tan(oi)*sin(rho0)))
    rotn0 = atan(we*cos(phi0_p)*cos(beta0)/ &
        (ws+we*cos(phi0_p)*sin(beta0)))
    N0 = asph/sqrt(1.0d0-e2*sin(phi0)**2)
    H0 = orad-N0
    th_ratio0 = N0/H0
    lonin = lon0
    latin = lat0
    call geo2metres_pixel_size(latin,psx,psy,spheroid,psx_out,&
                               psy_out,istat)
    hxy0 = psx_out/psy_out

!   smodel(phi0,phi0_p,rho0,t0,lam0,gamm0,beta0,rotn0,hxy0,N0,H0,th_ratio0)
    smodel(1) = phi0
    smodel(2) = phi0_p
    smodel(3) = rho0
    smodel(4) = t0
    smodel(5) = lam0
    smodel(6) = gamm0
    smodel(7) = beta0
    smodel(8) = rotn0
    smodel(9) = hxy0
    smodel(10) = N0
    smodel(11) = H0
    smodel(12) = th_ratio0

    return

END SUBROUTINE set_satmod


module EFIE_grad_matrices

  use tools
  use meshread_mod
  use mpi
  implicit none

  real(8), parameter, private  :: pi = 4d0 * atan(1d0)
  complex(8), parameter, private :: iu = (0.0d0, 1.0d0)

  private:: findIndices, param
  private:: intSauterSchwabIdentical_RWG
  private:: intSauterSchwabEdge_RWG
  private:: intSauterSchwabVertex_RWG
contains

  !----------------------------------------------------------------------------!
  !                                 SUBROUTINES
  !----------------------------------------------------------------------------!

!*****************************************************************************!
subroutine genEFIESauterSchwabMat_RWG(Z, msh, k, nNS, nSG)
  integer, intent(in) :: nNS ! number of quadrature points for non-singular integration
  integer, intent(in) :: nSG ! number of quadrature points for singular integration (Sauter-Schwab)

  complex(8),allocatable,intent(out) :: Z(:,:)

  complex(8),allocatable :: Z_bff(:,:)

  type(Mesh),intent(in) :: msh

  real(8),intent(in) :: k

  integer ::i,j,n,m,ii,jj,cnt,pos(3,2)

  integer :: nd_i(3),nd_j(3)

  integer :: edg_j(3),edg_i(3)

  integer :: opp_nod_j(3),opp_nod_i(3)

  real(8) :: p(3,3),q(3,3)

  real(8) :: n_j(3)

  real(8) :: A_j,A_i,len_j(3),len_i(3)

  real(8) :: f_i(3),f_j(3),df_i

  real(8) :: Rvec(3), R

  real(8) :: q_src_nod(3,3),p_src_nod(3,3)

  complex(8) :: G, intg(3,3)

  integer :: start, finish , ierr,id

  real(8) :: qq(nNS,3),pp(nNS,3)

  real(8):: V(nNS,3),wei(nNS)

  complex(8) :: Ggrad(3)  ! gradient of Green's function
  !real(8) :: fj_cross(3)  ! f_j x n, f_j = RWG basis function

  !-----------------------------------------------------------------------------!
  call gaussQuadratureTriangles(V,wei,nNS)
  ! for parallelization
  call divide_work(start,finish,msh%nbELm)

  ! allocate buffer matrix
  allocate(Z_bff(1:msh%nbEdg,1:msh%nbEdg))
  Z_bff=0.0d0

  do j = start,finish ! loop over the elements

    nd_j      = msh%ELE_NODES(j,1:3)  ! node indices
    edg_j     = msh%ELE_EDGES(j,1:3)  ! edge indices
    opp_nod_j = msh%ELE_EDGES(j,4:6)  ! index of the node opposed to the edge
    len_j     = msh%EDG_LEN(edg_j)    ! length of the edges
    A_j       = msh%A(j)              ! area of the triangle
    n_j = msh%NRM(j,:)                ! normal to i-th element

    q  = msh%POS(nd_j,1:3) ! coordinates of the triangular nodes
    q_src_nod  = msh%POS(abs(opp_nod_j),1:3)
    qq = matmul(V,q)

    do i = 1,msh%nbElm ! loop over the elements to compute inner integral

      nd_i      = msh%ELE_NODES(i,1:3) ! node indices
      edg_i     = msh%ELE_EDGES(i,1:3)  ! edge indices
      opp_nod_i = msh%ELE_EDGES(i,4:6)  ! index of the node opposed to the edge
      len_i     = msh%EDG_LEN(edg_i)
      A_i       = msh%A(i)

      p = msh%POS(nd_i,1:3) ! mesh nodes in i-th element
      p_src_nod = msh%POS(abs(opp_nod_i),1:3) ! mesh nodes in i-th element
      pp = matmul(V,p)

      call findIndices(cnt,pos,nd_j,nd_i)

      if (cnt==3) then

        call intSauterSchwabIdentical_RWG(intg,k,p,p_src_nod,len_i,A_i,opp_nod_i,n_j,nSG)
        Z_bff(edg_j,edg_i) = Z_bff(edg_j,edg_i) + A_i*A_j*intg/pi

      elseif (cnt==2) then

        call intSauterSchwabEdge_RWG(intg,k,pos,&
                                q,q_src_nod,len_j,A_j,opp_nod_j,&
                                p,p_src_nod,len_i,A_i,opp_nod_i, n_j, nSG)

        Z_bff(edg_j,edg_i) = Z_bff(edg_j,edg_i) + A_i*A_j*intg/pi

      elseif (cnt==1) then

        call intSauterSchwabVertex_RWG(intg,k,pos,&
                                q,q_src_nod,len_j,A_j,opp_nod_j,&
                                p,p_src_nod,len_i,A_i,opp_nod_i,n_j, nSG)

        Z_bff(edg_j,edg_i) = Z_bff(edg_j,edg_i) + A_i*A_j*intg/pi

      else

        do jj=1,nNS !quadrature exterior integration

          do ii=1,nNS !quadrature interior integration

            Rvec = qq(jj,:)-pp(ii,:)
            R    = sqrt(sum(Rvec*Rvec))
            G    = exp(iu*k*R)/R/(4.0d0*pi)
            Ggrad = (iu*k-1.0d0/R)*G * Rvec/R

            do m=1,3 !basis functions exterior

              f_j  = sign(1,opp_nod_j(m))*len_j(m)*(q_src_nod(m,:)-qq(jj,:))/(2.0d0*A_j)
              !fj_cross = cross(f_j, n_j)   ! RWG x n

              do n=1,3 !basis functions interior

                f_i  = sign(1,opp_nod_i(n))*len_i(n)*(p_src_nod(n,:)-pp(ii,:))/(2.0d0*A_i)
                df_i = -sign(1,opp_nod_i(n))*len_i(n)/A_i

                Z_bff(edg_j(m),edg_i(n)) = Z_bff(edg_j(m),edg_i(n)) + &
                  A_i*A_j*wei(ii)*wei(jj) * (G*sum(f_i*f_j) + sum(Ggrad*f_j)*df_i/k**2)  !check

              enddo
            enddo
          enddo
        enddo

      endif

    enddo
  enddo

  call mpi_comm_rank(MPI_COMM_WORLD,id,ierr)

  if (id==0) then
    allocate(Z(1:msh%nbEdg,1:msh%nbEdg))
  endif

  call mpi_reduce(Z_bff,Z,msh%nbEdg**2, &
  MPI_double_complex,MPI_sum,0,MPI_comm_world,ierr)
  return

end subroutine genEFIESauterSchwabMat_RWG
!******************************************************************************!
function  param(u, v, p1, p2, p3) result(x)
  real(8),intent(in) :: u,v,p1(3),p2(3),p3(3)
  real(8) :: x(3)
  x =p1+u*(p2-p1)+v*(p3-p2)
end function  param
!******************************************************************************!
subroutine intSauterSchwabIdentical_RWG(intg, k, p, p_src, len_p, A, opp_nod, n_j, nQ)
  real(8),intent(in) :: k,p(3,3),p_src(3,3),len_p(3),A
  integer,intent(in) :: opp_nod(3),nQ
  real(8), intent(in) :: n_j(3)  ! normal to element
  complex(8),intent(out) :: intg(3,3)
  real(8) :: t(nq),w(nq)
  real(8) :: fO(3),fI(3),dfI
  real(8) :: x(3),y(3),x0(3),y0(3)
  integer :: n1,n2,n3,i,n,m,l
  real(8) :: eta1,eta2,eta3,xi,uO,vO,uI,vI
  real(8) :: R0, Rvec(3)
  complex(8) :: G, Ker1(3,3), Ker2(3,3)
  ! !-------------------------------------------------------------------------!

  call gaussQuadrature(t,w,nQ)

  w = 0.5d0*w
  t = 0.5d0*(1.0d0+t)

  intg = 0.0d0

  do n1=1,nQ ! eta1
      eta1 = t(n1)
      do n2=1,nQ !eta2
          eta2 = t(n2)
          do n3=1,nQ !eta3
              eta3 = t(n3)
              do i=1,nQ ! xi
                  xi = t(i)
                  do l=1,6
                    if (l==1) then
                      uO = 1.0d0
                      vO = (1.0d0-eta1+eta1*eta2)
                      uI = (1.0d0-eta1*eta2*eta3)
                      vI = (1.0d0-eta1)
                    elseif (l==2) then
                      uO = (1.0d0-eta1*eta2*eta2)
                      vO = (1.0d0-eta1)
                      uI = 1.0d0
                      vI = (1.0d0-eta1+eta1*eta2)
                    elseif (l==3) then
                      uO = 1.0d0
                      vO = eta1*(1.0d0-eta2+eta2*eta3)
                      uI = (1.0d0-eta1*eta2)
                      vI = eta1*(1.0d0-eta2)
                    elseif (l==4) then
                      uO = (1.0d0-eta1*eta2)
                      vO = eta1*(1.0d0-eta2)
                      uI = 1.0d0
                      vI = eta1*(1.0d0-eta2+eta2*eta3)
                    elseif (l==5) then
                      uO = (1.0d0-eta1*eta2*eta3)
                      vO = eta1*(1.0d0-eta2*eta3)
                      uI = 1.0d0
                      vI = eta1*(1.0d0-eta2)
                    elseif (l==6) then
                      uO = 1.0d0
                      vO = eta1*(1.0d0-eta2)
                      uI = (1.0d0-eta1*eta2*eta3)
                      vI = eta1*(1.0d0-eta2*eta3)
                    endif

                    x =  param(xi*uO,xi*vO,p(1,:),p(2,:),p(3,:))
                    y =  param(xi*uI,xi*vI,p(1,:),p(2,:),p(3,:))
                    Rvec = x - y

                    x0 =  param(uO,vO,p(1,:),p(2,:),p(3,:))
                    y0 =  param(uI,vI,p(1,:),p(2,:),p(3,:))

                    do n=1,3
                      fO = sign(1,opp_nod(n))*len_p(n)*(p_src(n,:)-x)/(2.0d0*A)
                      do m=1,3
                        fI = sign(1,opp_nod(m))*len_p(m)*(p_src(m,:)-y)/(2.0d0*A)
                        dfI = -sign(1,opp_nod(m))*len_p(m)/A

                        Ker1(n,m) = sum(fI*fO)
                        Ker2(n,m) = sum(Rvec*fO)*dfI/k**2
                      enddo
                    enddo

                    R0 = sqrt(sum((x0-y0)**2))
                    G = exp(iu*k*sqrt(sum(Rvec**2))) / R0

                    Ker1 = Ker1 * G * xi**2
                    Ker2 = Ker2 * (iu*k*xi-1.0d0/R0)*G/R0

                    intg = intg + eta1**2*eta2*w(n1)*w(n2)*w(n3)*w(i)*(Ker1 + Ker2)
                  enddo
              enddo
          enddo
      enddo
  enddo
  return
end subroutine intSauterSchwabIdentical_RWG
!******************************************************************************!
subroutine intSauterSchwabEdge_RWG(intg, k, pos, &
                        q, q_src, len_q, A_q, opp_nod_q, &
                        p, p_src, len_p, A_p, opp_nod_p, n_j, nQ)
  real(8),intent(in) :: q(3,3),p(3,3),q_src(3,3),p_src(3,3),k
  real(8),intent(in) :: A_q,A_p,len_q(3),len_p(3)
  integer,intent(in) :: pos(3,2),opp_nod_q(3),opp_nod_p(3),nQ
  real(8), intent(in) :: n_j(3)  ! normal to element
  complex(8),intent(out) :: intg(3,3)
  real(8) :: fO(3),fI(3),dfI
  real(8) :: x(3),y(3),x0(3),y0(3)
  integer :: n1,n2,n3,i,j,n,m,l
  real(8) :: eta1,eta2,eta3,xi,uO,vO,uI,vI
  integer :: nd_q(3),nd_p(3)
  complex(8) :: intgAux(3,3)
  real(8) :: qAux(3,3),pAux(3,3),q_srcAux(3,3),p_srcAux(3,3)
  real(8) :: len_qAux(3),len_pAux(3)
  integer :: opp_nod_qAux(3),opp_nod_pAux(3)
  real(8) :: t(nq),w(nq)
  real(8) :: R0, Rvec(3)
  complex(8) :: G, Ker1(3,3), Ker2(3,3)

  !-------------------------------------------------------------------------!
  call gaussQuadrature(t,w,nQ)

  w = 0.5d0*w
  t = 0.5d0*(1.0d0+t)

  ! find the common edge first:
  nd_q(1:2) = pos(1:2,1)
  nd_p(1:2) = pos(1:2,2)

  if ((nd_q(1).ne.1).and.(nd_q(2).ne.1)) nd_q(3)=1
  if ((nd_q(1).ne.2).and.(nd_q(2).ne.2)) nd_q(3)=2
  if ((nd_q(1).ne.3).and.(nd_q(2).ne.3)) nd_q(3)=3

  if ((nd_p(1).ne.1).and.(nd_p(2).ne.1)) nd_p(3)=1
  if ((nd_p(1).ne.2).and.(nd_p(2).ne.2)) nd_p(3)=2
  if ((nd_p(1).ne.3).and.(nd_p(2).ne.3)) nd_p(3)=3

  pAux =p(nd_p,:)
  qAux =q(nd_q,:)
  p_srcAux = p_src(nd_p,:)
  q_srcAux = q_src(nd_q,:)
  opp_nod_pAux =opp_nod_p(nd_p)
  opp_nod_qAux =opp_nod_q(nd_q)

  len_pAux = len_p(nd_p)
  len_qAux = len_q(nd_q)

  !---------------------------
  intgAux = 0.0d0

  do n1=1,nQ ! eta1
      eta1 = t(n1)
      do n2=1,nQ !eta2
          eta2 = t(n2)
          do n3=1,nQ !eta3
              eta3 = t(n3)
              do i=1,nQ ! xi
                  xi = t(i)
                  do l=1,5
                  !----------------------------------------------------------
                    if (l==1) then
                      uO = 1.0d0
                      vO = eta1*eta3
                      uI = (1.0d0-eta1*eta2)
                      vI = eta1*(1.0d0-eta2)
                    elseif (l==2) then
                      uO = 1.0d0
                      vO = eta1
                      uI = (1.0d0-eta1*eta2*eta3)
                      vI = eta1*eta2*(1.0d0-eta3)
                    elseif (l==3) then
                      uO = (1.0d0-eta1*eta2)
                      vO = eta1*(1.0d0-eta2)
                      uI = 1.0d0
                      vI = eta1*eta2*eta3
                    elseif (l==4) then
                      uO = (1.0d0-eta1*eta2*eta3)
                      vO = eta1*eta2*(1.0d0-eta3)
                      uI = 1.0d0
                      vI = eta1
                    elseif (l==5) then
                      uO = (1.0d0-eta1*eta2*eta3)
                      vO = eta1*(1.0d0-eta2*eta3)
                      uI = 1.0d0
                      vI = eta1*eta2
                    endif

                    x =  param(xi*uO,xi*vO,qAux(1,:),qAux(2,:),qAux(3,:))
                    y =  param(xi*uI,xi*vI,pAux(1,:),pAux(2,:),pAux(3,:))
                    Rvec = x - y

                    x0 =  param(uO,vO,qAux(1,:),qAux(2,:),qAux(3,:))
                    y0 =  param(uI,vI,pAux(1,:),pAux(2,:),pAux(3,:))

                    do n=1,3

                      fO = sign(1,opp_nod_qAux(n))*len_qAux(n)*(q_srcAux(n,:)-x)/(2.0d0*A_q)

                      do m=1,3

                        fI = sign(1,opp_nod_pAux(m))*len_pAux(m)*(p_srcAux(m,:)-y)/(2.0d0*A_p)
                        dfI = -sign(1,opp_nod_pAux(m))*len_pAux(m)/A_p

                        Ker1(n,m) = sum(fI*fO)
                        Ker2(n,m) = sum(Rvec*fO)*dfI/k**2

                      enddo

                    enddo

                    R0 = sqrt(sum((x0-y0)**2))
                    G = exp(iu*k*sqrt(sum(Rvec**2))) / R0

                    Ker1 = Ker1 * G * xi**2
                    Ker2 = Ker2 * (iu*k*xi-1.0d0/R0)*G/R0

                    if (l==1) then
                      intgAux = intgAux + w(n1)*w(n2)*w(n3)*w(i)*eta1**2*(Ker1 + Ker2)
                    else
                      intgAux = intgAux + w(n1)*w(n2)*w(n3)*w(i)*eta1**2*eta2*(Ker1 + Ker2)
                    endif
                  enddo
              enddo
          enddo
      enddo
  enddo

  do i=1,3
    do j=1,3
      intg(nd_q(i),nd_p(j)) = intgAux(i,j)
    enddo
  enddo

  return
end subroutine intSauterSchwabEdge_RWG

!******************************************************************************!
subroutine intSauterSchwabVertex_RWG(intg, k, pos, &
                        q, q_src, len_q, A_q, opp_nod_q, &
                        p, p_src, len_p, A_p, opp_nod_p, n_j, nQ)
  real(8),intent(in) :: q(3,3),p(3,3),q_src(3,3),p_src(3,3),k
  real(8),intent(in) :: A_q,A_p,len_q(3),len_p(3)
  integer,intent(in) :: pos(3,2),opp_nod_q(3),opp_nod_p(3),nQ
  real(8), intent(in) :: n_j(3)  ! normal to element
  complex(8),intent(out) :: intg(3,3)
  real(8) :: fO(3),fI(3),dfI
  real(8) :: x(3),y(3),x0(3),y0(3)
  integer :: n1,n2,n3,i,j,l0,m,n,l
  real(8) :: eta1,eta2,eta3,xi,uO,vO,uI,vI
  integer :: nd_q(3),nd_p(3)
  complex(8) :: intgAux(3,3)

  real(8) :: qAux(3,3),pAux(3,3),q_srcAux(3,3),p_srcAux(3,3)
  real(8) :: len_qAux(3),len_pAux(3)
  integer :: opp_nod_qAux(3),opp_nod_pAux(3)
  real(8) :: t(nq),w(nq)
  real(8) :: R0, Rvec(3)
  complex(8) :: G, Ker1(3,3), Ker2(3,3)

  !-------------------------------------------------------------------------!
  call gaussQuadrature(t,w,nQ)

  w = 0.5d0*w
  t = 0.5d0*(1.0d0+t)

  ! find the common edge first:
  !pos(1,1) in q is pos(1,2) in p
  nd_q(1) = pos(1,1)
  l0 = mod(nd_q(1)+1,3)
  if (l0==0) l0=3
  nd_q(2) = l0
  l0 = mod(nd_q(1)+2,3)
  if (l0==0) l0=3
  nd_q(3) = l0

  nd_p(1) = pos(1,2)
  l0 = mod(nd_p(1)+1,3)
  if (l0==0) l0=3
  nd_p(2) = l0
  l0= mod(nd_p(1)+2,3)
  if (l0==0) l0=3
  nd_p(3) = l0

  pAux =p(nd_p,:)
  qAux =q(nd_q,:)
  p_srcAux = p_src(nd_p,:)
  q_srcAux = q_src(nd_q,:)
  opp_nod_pAux =opp_nod_p(nd_p)
  opp_nod_qAux =opp_nod_q(nd_q)

  len_pAux = len_p(nd_p)
  len_qAux = len_q(nd_q)
  !---------------------------
  intgAux = 0.0d0

  do n1=1,nQ ! eta1
      eta1 = t(n1)
      do n2=1,nQ !eta2
          eta2 = t(n2)
          do n3=1,nQ !eta3
              eta3 = t(n3)
              do i=1,nQ ! xi
                xi = t(i)
                do l=1,2
                  if (l==1) then
                    uO = 1.0d0
                    vO = eta1
                    uI = eta2
                    vI = eta2*eta3
                  elseif (l==2) then
                    uO = eta2
                    vO = eta2*eta3
                    uI = 1.0d0
                    vI = eta1
                  endif

                  x =  param(xi*uO,xi*vO,qAux(1,:),qAux(2,:),qAux(3,:))
                  y =  param(xi*uI,xi*vI,pAux(1,:),pAux(2,:),pAux(3,:))
                  Rvec = x - y

                  x0 =  param(uO,vO,qAux(1,:),qAux(2,:),qAux(3,:))
                  y0 =  param(uI,vI,pAux(1,:),pAux(2,:),pAux(3,:))

                  do n=1,3

                    fO = sign(1,opp_nod_qAux(n))*len_qAux(n)*(q_srcAux(n,:)-x)/(2.0d0*A_q)
                    do m=1,3

                      fI = sign(1,opp_nod_pAux(m))*len_pAux(m)*(p_srcAux(m,:)-y)/(2.0d0*A_p)
                      dfI = -sign(1,opp_nod_pAux(m))*len_pAux(m)/A_p

                      Ker1(n,m) = sum(fI*fO)
                      Ker2(n,m) = sum(Rvec*fO)*dfI/k**2

                    enddo

                  enddo

                  R0 = sqrt(sum((x0-y0)**2))
                  G = exp(iu*k*sqrt(sum(Rvec**2))) / R0

                  Ker1 = Ker1 * G * xi**2
                  Ker2 = Ker2 * (iu*k*xi-1.0d0/R0)*G/R0

                  intgAux = intgAux + w(n1)*w(n2)*w(n3)*w(i)*eta2*(Ker1 + Ker2)

                enddo
              enddo
          enddo
      enddo
  enddo

  do i=1,3
    do j=1,3
      intg(nd_q(i),nd_p(j)) = intgAux(i,j)
    enddo
  enddo
  return
end subroutine intSauterSchwabVertex_RWG
!*****************************************************************************!
subroutine findIndices(cnt, pos, indOut, indIn)
  ! cnt: number of vertices in common
  ! pos: coincident vertices
  integer :: pos(:,:),n,indOut(:),indIn(:)
  integer :: i,j,cnt

  n = size(indOut)
  cnt = 0
  pos = 0
  do i=1,n
    do j=1,n
      if (indOut(i)==indIn(j)) then
        cnt = cnt + 1
        pos(cnt,1)=i
        pos(cnt,2)=j
      endif
    end do
  enddo
  return
end subroutine findIndices

end module


subroutine lamcal(phipog, guu, guv, gvv)

      use stel_kinds, only: dp
      use name0, only: cp5, c1p0, c2p0
      use name1, only: nsd1, nznt, mpol1, nmax, nmax1
      use scalars, only: nrzt, ns, mns
      use inputdat, only: nfp
      use mnarray, only: jlam
      use scalefac, only: faclam

      implicit none

      ! TODO: more elegant definition of these BLAS functions
      real(kind=dp) :: dsum, ddot

      real(kind=dp), intent(in) :: phipog(nrzt) ! phi'/sqrt(g) * wint --> ready for integration; on half-grid
      real(kind=dp), intent(in) :: guu(nrzt)    !
      real(kind=dp), intent(in) :: guv(nrzt)    ! metric elements on half--grid
      real(kind=dp), intent(in) :: gvv(nrzt)    !

      real(kind=dp) :: blam(nsd1)
      real(kind=dp) :: clam(nsd1)
      real(kind=dp) :: dlam(nsd1)
      data blam/nsd1*0.0_dp/, & ! initial data for startup ??
           clam/nsd1*0.0_dp/, &
           dlam/nsd1*0.0_dp/

      integer       :: js, l, m, n, lmn
      real(kind=dp) :: tnn, tmn, tmm

      ! A(s), B(s), C(s) in Betancourt (1988) "BETAS", p. 559
      do js = 2, ns
        blam(js) = ddot(nznt, guu(js), ns, phipog(js), ns)
        dlam(js) = ddot(nznt, guv(js), ns, phipog(js), ns)*c2p0*real(nfp)
        clam(js) = ddot(nznt, gvv(js), ns, phipog(js), ns)
      end do

      do m = 0, mpol1
        do n = 0, nmax
          lmn = ns*(n + nmax1*m)

          tnn = real( (n*nfp)**2 )
          tmn = real(m*n)
          tmm = real(m*m)

          if (m.eq.0 .and. n.eq.0) then
            ! only a single term (by t_nn) contributes to faclam for m=0, n=0
            ! since t_mn and t_mm are zero
            ! --> -blam
            tnn = -c1p0
          end if

          ! note: sign(a,b) = |a| * sgn(b)
          ! note: 2/x = 1/(0.5*x)

          do js = jlam(m), ns
            faclam(js+lmn) = -c2p0*c2p0/(       (blam(js) + blam(js+1))            * tnn   &
                                         + sign((dlam(js) + dlam(js+1)), blam(js)) * tmn   &
                                         +      (clam(js) + clam(js+1))            * tmm )
          end do

          ! edge inter-/extrapolation correction at LCFS
          faclam(ns+lmn) = cp5*faclam(ns+lmn)
        end do
      end do

      ! same "lambda factors" for flsc and flcs
      do l = 1, mns
        faclam(l+mns) = faclam(l)
      end do

      return
end


program ch0702
    ! Two Dimensional Arrays and a Map
    implicit none

    integer, parameter :: n = 3
    integer :: lat, long
    real, dimension(1:n,1:n) :: height
    real, parameter :: correct = 10.

    do lat = 1, n
        do long = 1, n
            print *, ' type in value at ', lat, ' ', &
                long
            read *, height(lat,long)
            height(lat,long) = height(lat,long)+correct
        end do
    end do
    print *, ' Corrected data is '
    do lat = 1, n
        do long = 1, n
            print *, height(lat,long)
        end do
    end do
end program


! Testcase for the COMPLEX intrinsic
! { dg-do run }
  if (complex(1_1, -1_2) /= complex(1.0_4, -1.0_8)) STOP 1
  if (complex(1_4, -1.0) /= complex(1.0_4, -1_8)) STOP 2
  end


! TITLE:
!   Fast sort (and select)
!
!
! PURPOSE:
!  This file contains the following modules and subroutines for quickly
!  sorting (either partially or fully) arrays in Fortran.
!
!   SWAP
!    SWAP_I64
!    SWAP_R64
!
!   FAST_SELECT
!    ARGSELECT_R64
!    ARGSELECT_I64
!
!   FAST_SORT
!    ARGSORT_R64
!    ARGPARTITION_R64
!    INSERTION_ARGSORT_R64
!
! Respectively, the purposes of the three modules are:
!
!   SWAP - Swap the value of two variables through a temporary.
!
!   FAST_SELECT - Do a fast "select" operation on an array of numbers,
!     resulting in the value at index K being as if the entire array
!     were sorted. All values before K will be less or equal, but not
!     sorted. All values after K will be greater or equal, but not
!     sorted. This operation is O(N).
!
!   FAST_SORT - Do a fast "sort" operation that uses methods
!     appropriate for the size of the array that will maximize speed.
!
!
! AUTHOR:
!   Thomas C.H. Lux (thomas.ch.lux@gmail.com)
!
!
! NOTES:
!   The algorithm for SELECT was inspired by the Floyd-Rivest method
!   of performing selection. The algorithm for SORT was inspired by
!   Data Structures and Algorithms Analysis by Dr. Clifford A. Shaffer
!   (Virginia Polytechnic Institute and State University).

! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
MODULE SWAP
  USE ISO_FORTRAN_ENV, ONLY: REAL64, INT64
  IMPLICIT NONE

CONTAINS
  SUBROUTINE SWAP_I64(V1, V2)
    INTEGER(KIND=INT64), INTENT(INOUT) :: V1, V2
    ! Local temp
    INTEGER(KIND=INT64) :: TEMP
    TEMP = V1
    V1 = V2
    V2 = TEMP
  END SUBROUTINE SWAP_I64

  SUBROUTINE SWAP_R64(V1, V2)
    REAL(KIND=REAL64), INTENT(INOUT) :: V1, V2
    ! Local temp
    REAL(KIND=REAL64) :: TEMP
    TEMP = V1
    V1 = V2
    V2 = TEMP
  END SUBROUTINE SWAP_R64
END MODULE SWAP
! ____________________________________________________________________

! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
MODULE FAST_SELECT
  USE ISO_FORTRAN_ENV, ONLY: REAL64, INT64
  USE SWAP, ONLY: SWAP_I64, SWAP_R64
  IMPLICIT NONE

CONTAINS
  ! ------------------------------------------------------------------
  !                       FastSelect method
  !
  ! Given VALUES list of numbers, rearrange the elements of VALUES
  ! such that the element at index K has rank K (holds its same
  ! location as if all of VALUES were sorted). Symmetrically rearrange
  ! array INDICES to keep track of prior indices.
  !
  ! This algorithm uses the same conceptual approach as Floyd-Rivest,
  ! but instead of standard-deviation based selection of bounds for
  ! recursion, a rank-based method is used to pick the subset of
  ! values that is searched. This simplifies the code and improves
  ! interpretability, while achieving the same tunable performance.
  !
  ! Arguments:
  !
  !   VALUES   --  A 1D array of real numbers.
  !   INDICES  --  A 1D array of original indices for elements of VALUES.
  !   K        --  A positive integer for the rank index about which
  !                VALUES should be rearranged.
  ! Optional:
  !
  !   DIVISOR  --  A positive integer >= 2 that represents the
  !                division factor used for large VALUES arrays.
  !   MAX_SIZE --  An integer >= DIVISOR that represents the largest
  !                sized VALUES for which the worst-case pivot value
  !                selection is tolerable. A worst-case pivot causes
  !                O( SIZE(VALUES)^2 ) runtime. This value should be
  !                determined heuristically based on compute hardware.
  !
  ! Output:
  !
  !   The elements of the array VALUES are rearranged such that the
  !   element at position VALUES(K) is in the same location it would
  !   be if all of VALUES were in sorted order. Also known as,
  !   VALUES(K) has rank K.
  !
  RECURSIVE SUBROUTINE ARGSELECT_R64(VALUES, INDICES, K, DIVISOR, MAX_SIZE)
    ! Arguments
    REAL(KIND=REAL64),   INTENT(INOUT), DIMENSION(:) :: VALUES
    INTEGER(KIND=INT64), INTENT(INOUT), DIMENSION(:) :: INDICES
    INTEGER(KIND=INT64), INTENT(IN)                  :: K
    INTEGER(KIND=INT64), INTENT(IN), OPTIONAL        :: DIVISOR, MAX_SIZE
    ! Locals
    INTEGER(KIND=INT64) :: LEFT, RIGHT, L, R, MS, D
    REAL(KIND=REAL64) :: P
    ! Initialize the divisor (for making subsets).
    IF (PRESENT(DIVISOR)) THEN ; D = DIVISOR
    ELSE IF (SIZE(VALUES) .GE. 2**23) THEN ; D = 2**5
    ELSE IF (SIZE(VALUES) .GE. 2**20) THEN ; D = 2**3
    ELSE                                   ; D = 2**2
    END IF
    ! Initialize the max size (before subsets are created).
    IF (PRESENT(MAX_SIZE)) THEN ; MS = MAX_SIZE
    ELSE                        ; MS = 2**10
    END IF
    ! Initialize LEFT and RIGHT to be the entire array.
    LEFT = 1
    RIGHT = SIZE(VALUES)
    ! Loop until done finding the K-th element.
    DO WHILE (LEFT .LT. RIGHT)
       ! Use SELECT recursively to improve the quality of the
       ! selected pivot value for large arrays.
       IF (RIGHT - LEFT .GT. MS) THEN
          ! Compute how many elements should be left and right of K
          ! to maintain the same percentile in a subset.
          L = K - K / D
          R = L + (SIZE(VALUES) / D)
          ! Perform fast select on an array a fraction of the size about K.
          CALL ARGSELECT_R64(VALUES(L:R), INDICES(L:R), K - L + 1, DIVISOR, MAX_SIZE)
       END IF
       ! Pick a partition element at position K.
       P = VALUES(K)
       L = LEFT
       R = RIGHT
       ! Move the partition element to the front of the list.
       CALL SWAP_R64(VALUES(LEFT), VALUES(K))
       CALL SWAP_I64(INDICES(LEFT), INDICES(K))
       ! Pre-swap the left and right elements (temporarily putting a
       ! larger element on the left) before starting the partition loop.
       IF (VALUES(RIGHT) .GT. P) THEN
          CALL SWAP_R64(VALUES(LEFT), VALUES(RIGHT))
          CALL SWAP_I64(INDICES(LEFT), INDICES(RIGHT))
       END IF
       ! Now partition the elements about the pivot value "P".
       DO WHILE (L .LT. R)
          CALL SWAP_R64(VALUES(L), VALUES(R))
          CALL SWAP_I64(INDICES(L), INDICES(R))
          L = L + 1
          R = R - 1
          DO WHILE (VALUES(L) .LT. P) ; L = L + 1 ; END DO
          DO WHILE (VALUES(R) .GT. P) ; R = R - 1 ; END DO
       END DO
       ! Place the pivot element back into its appropriate place.
       IF (VALUES(LEFT) .EQ. P) THEN
          CALL SWAP_R64(VALUES(LEFT), VALUES(R))
          CALL SWAP_I64(INDICES(LEFT), INDICES(R))
       ELSE
          R = R + 1
          CALL SWAP_R64(VALUES(R), VALUES(RIGHT))
          CALL SWAP_I64(INDICES(R), INDICES(RIGHT))
       END IF
       ! adjust left and right towards the boundaries of the subset
       ! containing the (k - left + 1)th smallest element
       IF (R .LE. K) LEFT = R + 1
       IF (K .LE. R) RIGHT = R - 1
    END DO
  END SUBROUTINE ARGSELECT_R64

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

  RECURSIVE SUBROUTINE ARGSELECT_I64(VALUES, INDICES, K, DIVISOR, MAX_SIZE)
    ! Arguments
    INTEGER(KIND=INT64), INTENT(INOUT), DIMENSION(:) :: VALUES
    INTEGER(KIND=INT64), INTENT(INOUT), DIMENSION(:) :: INDICES
    INTEGER(KIND=INT64), INTENT(IN)                  :: K
    INTEGER(KIND=INT64), INTENT(IN), OPTIONAL        :: DIVISOR, MAX_SIZE
    ! Locals
    INTEGER(KIND=INT64) :: LEFT, RIGHT, L, R, MS, D, P
    ! Initialize the divisor (for making subsets).
    IF (PRESENT(DIVISOR)) THEN ; D = DIVISOR
    ELSE IF (SIZE(VALUES) .GE. 2**23) THEN ; D = 2**5
    ELSE IF (SIZE(VALUES) .GE. 2**20) THEN ; D = 2**3
    ELSE                                   ; D = 2**2
    END IF
    ! Initialize the max size (before subsets are created).
    IF (PRESENT(MAX_SIZE)) THEN ; MS = MAX_SIZE
    ELSE                        ; MS = 2**10
    END IF
    ! Initialize LEFT and RIGHT to be the entire array.
    LEFT = 1
    RIGHT = SIZE(VALUES)
    ! Loop until done finding the K-th element.
    DO WHILE (LEFT .LT. RIGHT)
       ! Use SELECT recursively to improve the quality of the
       ! selected pivot value for large arrays.
       IF (RIGHT - LEFT .GT. MS) THEN
          ! Compute how many elements should be left and right of K
          ! to maintain the same percentile in a subset.
          L = K - K / D
          R = L + (SIZE(VALUES) / D)
          ! Perform fast select on an array a fraction of the size about K.
          CALL ARGSELECT_I64(VALUES(L:R), INDICES(L:R), K - L + 1, DIVISOR, MAX_SIZE)
       END IF
       ! Pick a partition element at position K.
       P = VALUES(K)
       L = LEFT
       R = RIGHT
       ! Move the partition element to the front of the list.
       CALL SWAP_I64(VALUES(LEFT), VALUES(K))
       CALL SWAP_I64(INDICES(LEFT), INDICES(K))
       ! Pre-swap the left and right elements (temporarily putting a
       ! larger element on the left) before starting the partition loop.
       IF (VALUES(RIGHT) .GT. P) THEN
          CALL SWAP_I64(VALUES(LEFT), VALUES(RIGHT))
          CALL SWAP_I64(INDICES(LEFT), INDICES(RIGHT))
       END IF
       ! Now partition the elements about the pivot value "T".
       DO WHILE (L .LT. R)
          CALL SWAP_I64(VALUES(L), VALUES(R))
          CALL SWAP_I64(INDICES(L), INDICES(R))
          L = L + 1
          R = R - 1
          DO WHILE (VALUES(L) .LT. P) ; L = L + 1 ; END DO
          DO WHILE (VALUES(R) .GT. P) ; R = R - 1 ; END DO
       END DO
       ! Place the pivot element back into its appropriate place.
       IF (VALUES(LEFT) .EQ. P) THEN
          CALL SWAP_I64(VALUES(LEFT), VALUES(R))
          CALL SWAP_I64(INDICES(LEFT), INDICES(R))
       ELSE
          R = R + 1
          CALL SWAP_I64(VALUES(R), VALUES(RIGHT))
          CALL SWAP_I64(INDICES(R), INDICES(RIGHT))
       END IF
       ! adjust left and right towards the boundaries of the subset
       ! containing the (k - left + 1)th smallest element
       IF (R .LE. K) LEFT = R + 1
       IF (K .LE. R) RIGHT = R - 1
    END DO
  END SUBROUTINE ARGSELECT_I64
END MODULE FAST_SELECT
! ____________________________________________________________________

! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
MODULE FAST_SORT
  USE ISO_FORTRAN_ENV, ONLY: REAL64, INT64
  USE SWAP, ONLY: SWAP_I64, SWAP_R64
  IMPLICIT NONE

CONTAINS
  ! ------------------------------------------------------------------
  !                         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_R64(VALUES, INDICES, MIN_SIZE)
    REAL(KIND=REAL64),   INTENT(INOUT), DIMENSION(:)            :: VALUES
    INTEGER(KIND=INT64), INTENT(INOUT), DIMENSION(SIZE(VALUES)) :: INDICES
    INTEGER(KIND=INT64), INTENT(IN), OPTIONAL                   :: MIN_SIZE
    ! Local variables
    INTEGER(KIND=INT64) :: I, MS
    IF (PRESENT(MIN_SIZE)) THEN ; MS = MIN_SIZE
    ELSE                        ; MS = 2**6
    END IF
    ! Base case, return.
    IF (SIZE(VALUES) .LT. MS) THEN
       CALL INSERTION_ARGSORT_R64(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_R64(VALUES, INDICES)
       ! ---------------------------------------------------------------
       ! I = SIZE(VALUES) / 2
       ! CALL ARGSELECT_R64(VALUES, INDICES, I)
       ! ! Requires 'USE FAST_SELECT' at top of subroutine or module.
       ! ---------------------------------------------------------------
       CALL ARGSORT_R64(VALUES(:I-1), INDICES(:I-1), MS)
       CALL ARGSORT_R64(VALUES(I+1:), INDICES(I+1:), MS)
    END IF
  END SUBROUTINE ARGSORT_R64

  ! 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_R64(VALUES, INDICES) RESULT(LEFT)
    REAL(KIND=REAL64),   INTENT(INOUT), DIMENSION(:)            :: VALUES
    INTEGER(KIND=INT64), INTENT(INOUT), DIMENSION(SIZE(VALUES)) :: INDICES
    INTEGER(KIND=INT64) :: LEFT, MID, RIGHT
    REAL(KIND=REAL64)   :: 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(VALUES)) / 2
    ! Swap the first and last elements (if the last is smaller).
    IF (VALUES(SIZE(VALUES)) < VALUES(1)) THEN
       CALL SWAP_R64(VALUES(1),  VALUES(SIZE(VALUES)))
       CALL SWAP_I64(INDICES(1), INDICES(SIZE(VALUES)))
    END IF
    ! Swap the middle and first elements (if the middle is smaller).
    IF (VALUES(MID) < VALUES(SIZE(VALUES))) THEN
       CALL SWAP_R64(VALUES(MID),  VALUES(SIZE(VALUES)))
       CALL SWAP_I64(INDICES(MID), INDICES(SIZE(VALUES)))
       ! Swap the last and first elements (if the last is smaller).
       IF (VALUES(SIZE(VALUES)) < VALUES(1)) THEN
          CALL SWAP_R64(VALUES(1),  VALUES(SIZE(VALUES)))
          CALL SWAP_I64(INDICES(1), INDICES(SIZE(VALUES)))
       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(SIZE(VALUES))
    LEFT  = 2
    RIGHT = SIZE(VALUES) - 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(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(RIGHT) .LT. PIVOT) EXIT
          RIGHT = RIGHT - 1
       END DO
       ! Now we know that [VALUES(RIGHT) < PIVOT < VALUES(LEFT)], so swap them.
       CALL SWAP_R64(VALUES(LEFT),  VALUES(RIGHT))
       CALL SWAP_I64(INDICES(LEFT), INDICES(RIGHT))
    END DO
    ! The last swap was done even though LEFT == RIGHT, we need to undo.
    CALL SWAP_R64(VALUES(LEFT),  VALUES(RIGHT))
    CALL SWAP_I64(INDICES(LEFT), INDICES(RIGHT))
    ! Finally, we put the pivot back into its proper location.
    CALL SWAP_R64(VALUES(LEFT),  VALUES(SIZE(VALUES)))
    CALL SWAP_I64(INDICES(LEFT), INDICES(SIZE(VALUES)))
  END FUNCTION ARGPARTITION_R64

  ! Insertion sort (best for small lists).
  SUBROUTINE INSERTION_ARGSORT_R64(VALUES, INDICES)
    REAL(KIND=REAL64),   INTENT(INOUT), DIMENSION(:)            :: VALUES
    INTEGER(KIND=INT64), INTENT(INOUT), DIMENSION(SIZE(VALUES)) :: INDICES
    ! Local variables.
    REAL(KIND=REAL64)   :: TEMP_VAL
    INTEGER(KIND=INT64) :: I, BEFORE, AFTER, TEMP_IND
    ! Return for the base case.
    IF (SIZE(VALUES) .LE. 1) RETURN
    ! Put the smallest value at the front of the list.
    I = MINLOC(VALUES,1)
    CALL SWAP_R64(VALUES(1),  VALUES(I))
    CALL SWAP_I64(INDICES(1), INDICES(I))
    ! Insertion sort the rest of the array.
    DO I = 3, SIZE(VALUES)
       TEMP_VAL = VALUES(I)
       TEMP_IND = INDICES(I)
       ! Search backwards in the list,
       BEFORE = I - 1
       AFTER  = I
       DO WHILE (TEMP_VAL .LT. VALUES(BEFORE))
          VALUES(AFTER)  = VALUES(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).
       VALUES(AFTER)  = TEMP_VAL
       INDICES(AFTER) = TEMP_IND
    END DO
  END SUBROUTINE INSERTION_ARGSORT_R64
  ! ------------------------------------------------------------------

END MODULE FAST_SORT


      PROGRAM xscrsho
C     driver for routine scrsho
      REAL bessj0
      EXTERNAL bessj0
      write(*,*) 'Graph of the Bessel Function J0:'
      call scrsho(bessj0)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xscrsho.for


! { dg-do compile }
! { dg-additional-options "-ffrontend-optimize" }
! PR 84133 - this used to ICE. Original test case by
! Gerhard Steinmetz.

program p
   real :: x(2,2) = 1.0
   real :: z(2,2)
   associate (y => matmul(x,x))
      z = y
   end associate
   print *, z
end


! { dg-do compile }
!
! PR fortran/38718
!
  implicit none
  real(kind=8), parameter :: r = kind(0) + 0.2
  complex(kind=8), parameter :: c = (r, -9.3)
  integer, parameter :: k = nint(dreal(c))
  integer, parameter :: l = nint(realpart(c))
  integer(kind=k) :: i
  integer(kind=l) :: j
  i = 42
  j = 42
  print *, k, i, j, r
  end


! { dg-do run }

module e_51_2_mod
contains
  subroutine init (v1, v2, N)
    integer :: i, N
    real :: v1(N), v2(N)
    do i = 1, N
      v1(i) = i + 2.0
      v2(i) = i - 3.0
    end do
  end subroutine

  subroutine init_again (v1, v2, N)
    integer :: i, N
    real :: v1(N), v2(N)
    do i = 1, N
      v1(i) = i - 3.0
      v2(i) = i + 2.0
    end do
  end subroutine

  subroutine check (p, N)
    integer :: i, N
    real, parameter :: EPS = 0.00001
    real :: diff, p(N)
    do i = 1, N
      diff = p(i) - 2 * (i + 2.0) * (i - 3.0)
      if (diff > EPS .or. -diff > EPS) call abort
    end do
  end subroutine

  subroutine vec_mult (N)
    real :: p(N), v1(N), v2(N)
    integer :: i, N
    call init (v1, v2, N)
    !$omp target data map(from: p)
      !$omp target map(to: v1, v2 )
        !$omp parallel do
        do i = 1, N
          p(i) = v1(i) * v2(i)
        end do
      !$omp end target
      call init_again (v1, v2, N)
      !$omp target map(to: v1, v2 )
        !$omp parallel do
        do i = 1, N
          p(i) = p(i) + v1(i) * v2(i)
        end do
      !$omp end target
    !$omp end target data
    call check (p, N)
  end subroutine
end module

program e_51_2
  use e_51_2_mod, only : vec_mult
  integer :: n
  n = 1000
  call vec_mult (n)
end program


program main
    use, intrinsic :: iso_fortran_env, only : error_unit, DP => REAL64
    use :: linalg_mod, only : read_array, write_array
    implicit none
    integer :: nr_eqns, status
    character(len=1024) :: matrix_file_name, vector_file_name, info
    real(kind=DP), dimension(:), allocatable :: b
    integer, dimension(:), allocatable :: pivot
    real(kind=DP), dimension(:, :), allocatable :: A
    external :: dgesv

    call get_arguments(nr_eqns, matrix_file_name, vector_file_name)
    allocate (A(nr_eqns, nr_eqns), stat=status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A)') '#error: can not allocate A'
        stop 15
    end if
    call read_array(matrix_file_name, A, [ nr_eqns, nr_eqns ])

    allocate (b(nr_eqns), stat=status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A)') '#error: can not allocate b'
        stop 15
    end if
    call read_array(vector_file_name, b, [ nr_eqns ])
    allocate (pivot(size(b)), stat=status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A, I0)') '# error: can not allocate pivot of size ', size(b)
        stop 12
    end if
    call dgesv(size(A, 2), 1, A, size(A, 1), pivot, b, size(b), info)
    call write_array(b)

    deallocate (A, b, pivot)

contains

   subroutine get_arguments(nr_eqns, matrix_file_name, vector_file_name)
        implicit none
        integer, intent(out) :: nr_eqns
        character(len=*), intent(out) :: matrix_file_name, vector_file_name
        integer :: status
        character(len=1024) :: buffer, msg

        if (command_argument_count() /= 3) then
            write (unit=error_unit, fmt='(A)') &
                '# error: argument nr_eqns, matrix_file_name, vector_file_name'
            stop 10
        end if
        call get_command_argument(1, buffer)
        read (buffer, fmt=*, iostat=status, iomsg=msg) nr_eqns
        if (status /= 0) then
            write (unit=error_unit, fmt='(2A)') '# error: ', trim(msg)
            stop 11
        end if
        call get_command_argument(2, matrix_file_name)
        call get_command_argument(3, vector_file_name)
    end subroutine get_arguments

end program main


module types
implicit none
private
public dp, i64
integer, parameter :: dp=kind(0.d0)          ! double precision
integer, parameter :: i64 = selected_int_kind(18) ! At least 64-bit integer
end module

module utils
! Various utilities
use types, only: dp, i64
implicit none
private
public trace, mean, std, init_random_seed, randn, assert, stop_error, &
     sysclock2ms

contains

subroutine stop_error(msg)
! Aborts the program with nonzero exit code
!
! The statement "stop msg" will return 0 exit code when compiled using
! gfortran. stop_error() uses the statement "stop 1" which returns an exit code
! 1 and a print statement to print the message.
!
! Example
! -------
!
! call stop_error("Invalid argument")

character(len=*) :: msg ! Message to print on stdout
print *, msg
stop 1
end subroutine

subroutine assert(condition)
! If condition == .false., it aborts the program.
!
! Arguments
! ---------
!
logical, intent(in) :: condition
!
! Example
! -------
!
! call assert(a == 5)

if (.not. condition) call stop_error("Assert failed.")
end subroutine

real(dp) function trace(A) result(t)
real(dp), intent(in) :: A(:, :)
integer :: i
t = 0
do i = 1, size(A, 1)
    t = t + A(i, i)
end do
end function

real(dp) function mean(x) result(t)
real(dp), intent(in) :: x(:)
t = sum(x) / size(x)
end function

real(dp) function std(x) result(t)
real(dp), intent(in) :: x(:)
t = sqrt(mean(abs(x - mean(x))**2))
end function

subroutine init_random_seed()
integer :: i, n, clock
integer, allocatable :: seed(:)
call random_seed(size=n)
allocate(seed(n))
call system_clock(count=clock)
seed = clock + 37 * [ (i - 1, i = 1, n) ]
call random_seed(put=seed)
end subroutine

FUNCTION rnorm() RESULT( fn_val )

!   This subroutine was taken from: http://jblevins.org/mirror/amiller/rnorm.f90

!   Generate a random normal deviate using the polar method.
!   Reference: Marsaglia,G. & Bray,T.A. 'A convenient method for generating
!              normal variables', Siam Rev., vol.6, 260-264, 1964.

IMPLICIT NONE
REAL(dp)  :: fn_val

! Local variables

REAL(dp)            :: u, sum
REAL(dp), SAVE      :: v, sln
LOGICAL, SAVE   :: second = .FALSE.
REAL(dp), PARAMETER :: one = 1, vsmall = TINY( one )

IF (second) THEN
! If second, use the second random number generated on last call

  second = .false.
  fn_val = v*sln

ELSE
! First call; generate a pair of random normals

  second = .true.
  DO
    CALL RANDOM_NUMBER( u )
    CALL RANDOM_NUMBER( v )
    u = SCALE( u, 1 ) - one
    v = SCALE( v, 1 ) - one
    sum = u*u + v*v + vsmall         ! vsmall added to prevent LOG(zero) / zero
    IF(sum < one) EXIT
  END DO
  sln = SQRT(- SCALE( LOG(sum), 1 ) / sum)
  fn_val = u*sln
END IF

RETURN
END FUNCTION rnorm

subroutine randn(A)
real(dp), intent(out) :: A(:, :)
integer :: i, j
do j = 1, size(A, 2)
    do i = 1, size(A, 1)
        A(i, j) = rnorm()
    end do
end do
end subroutine

! Convert a number of clock ticks, as returned by system_clock called
! with integer(i64) arguments, to milliseconds
function sysclock2ms(t)
  integer(i64), intent(in) :: t
  integer(i64) :: rate
  real(dp) :: sysclock2ms, r
  call system_clock(count_rate=rate)
  r = 1000._dp / rate
  sysclock2ms = t * r
end function sysclock2ms

end module

module bench
use utils, only: trace, randn, std, mean, stop_error
use types, only: dp
implicit none
private
public fib, parse_int, printfd, quicksort, mandelperf, pisum, randmatstat, randmatmul

contains

integer recursive function fib(n) result(r)
integer, intent(in) :: n
if (n < 2) then
    r = n
else
    r = fib(n-1) + fib(n-2)
end if
end function

integer function parse_int(s, base) result(n)
character(len=*), intent(in) :: s
integer, intent(in) :: base
integer :: i, d
character :: c
n = 0
do i = 1, len(s)
    c = s(i:i)
    d = 0
    if (ichar(c) >= ichar('0') .and. ichar(c) <= ichar('9')) then
        d = ichar(c) - ichar('0')
    else if (ichar(c) >= ichar('A') .and. ichar(c) <= ichar('Z')) then
        d = ichar(c) - ichar('A') + 10
    else if (ichar(c) >= ichar('a') .and. ichar(c) <= ichar('z')) then
        d = ichar(c) - ichar('a') + 10
    else
        call stop_error("parse_int 1")
    end if

    if (base <= d) call stop_error("parse_int 2")
    n = n*base + d
end do

end function

subroutine printfd(n)
integer, intent(in) :: n
integer :: i , unit
open(unit=1, file="foo")
do i = 1, n
  write(unit=1, fmt=*) i, i
end do
close(unit=1)
end subroutine

integer function mandel(z0) result(r)
complex(dp), intent(in) :: z0
complex(dp) :: c, z
integer :: n, maxiter
maxiter = 80
z = z0
c = z0
do n = 1, maxiter
    if (abs(z) > 2) then
        r = n-1
        return
    end if
    z = z**2 + c
end do
r = maxiter
end function

integer function mandelperf() result(mandel_sum)
integer :: re, im
volatile :: mandel_sum
mandel_sum = 0
re = -20
do while (re <= 5)
    im = -10
    do while (im <= 10)
        mandel_sum = mandel_sum + mandel(cmplx(re/10._dp, im/10._dp, dp))
        im = im + 1
    end do
    re = re + 1
end do
end function

recursive subroutine quicksort(a, lo0, hi)
real(dp), intent(inout) :: a(:)
integer, intent(in) :: lo0, hi
integer :: i, j, lo
real(dp) :: pivot, t
lo = lo0
i = lo
j = hi
do while (i < hi)
    pivot = a((lo+hi)/2)
    do while (i <= j)
        do while (a(i) < pivot)
            i = i + 1
        end do
        do while (a(j) > pivot)
            j = j - 1
        end do
        if (i <= j) then
            t = a(i)
            a(i) = a(j)
            a(j) = t
            i = i + 1
            j = j - 1
        end if
    end do
    if (lo < j) call quicksort(a, lo, j)
    lo = i
    j = hi
end do
end subroutine

real(dp) function pisum() result(s)
integer :: j, k
do j = 1, 500
    s = 0
    do k = 1, 10000
        s = s + 1._dp / k**2
    end do
end do
end function

subroutine randmatstat(t, s1, s2)
integer, intent(in) :: t
real(dp), intent(out) :: s1, s2
real(dp), allocatable, dimension(:, :) :: a, b, c, d, P, Q, X
real(dp), allocatable :: v(:), w(:)
integer :: n, i
n = 5
allocate(a(n, n), b(n, n), c(n, n), d(n, n))
allocate(P(4*n, n), Q(2*n, 2*n), X(2*n, 2*n))
allocate(v(t), w(t))
do i = 1, t
    call randn(a)
    call randn(b)
    call randn(c)
    call randn(d)
    P(:n, :)=a; P(n+1:2*n, :)=b; P(2*n+1:3*n, :)=c; P(3*n+1:, :)=d
    Q(:n,    :n) = a; Q(n+1:,    :n) = b
    Q(:n, n+1: ) = c; Q(n+1:, n+1: ) = d
    X = matmul(transpose(P), P)
    X = matmul(X, X)
    X = matmul(X, X)
    v(i) = trace(X)
    X = matmul(transpose(Q), Q)
    X = matmul(X, X)
    X = matmul(X, X)
    w(i) = trace(X)
end do
s1 = std(v) / mean(v)
s2 = std(w) / mean(w)
end subroutine

subroutine randmatmul(n, C)
integer, intent(in) :: n
real(dp), intent(out), allocatable :: C(:, :)
real(dp), allocatable :: A(:, :), B(:, :)
allocate(A(n, n), B(n, n), C(n, n))
call random_number(A)
call random_number(B)
!C = matmul(A, B)
call dgemm('N','N',n,n,n,1.0d0,A,n,B,n,0.0d0,C,n)
end subroutine

end module

program perf
use types, only: dp, i64
use utils, only: assert, init_random_seed, sysclock2ms
use bench, only: fib, parse_int, printfd, quicksort, mandelperf, pisum, randmatstat, &
    randmatmul
implicit none

integer, parameter :: NRUNS = 1000
integer :: i, f, n, m, k, k2
integer(i64) :: t1, t2, tmin
real(dp) :: pi, s1, s2
real(dp), allocatable :: C(:, :), d(:)
character(len=11) :: s

call init_random_seed()

tmin = huge(0_i64)
do i = 1, 5
    call system_clock(t1)
    do k = 1, NRUNS
        f = fib(20)
    end do
    call system_clock(t2)
    if (t2-t1 < tmin) tmin = t2-t1
end do
call assert(f == 6765)
print "('fortran,recursion_fibonacci,',f0.6)", sysclock2ms(tmin) / NRUNS

tmin = huge(0_i64)
do i = 1, 5
    call system_clock(t1)
    do k2 = 1, NRUNS
        do k = 1, 1000
            call random_number(s1)
            n = int(s1*huge(n))
            write(s, '(z0)') n
            m = parse_int(s(:len_trim(s)), 16)
            call assert(m == n)
        end do
    end do
    call system_clock(t2)
    if (t2-t1 < tmin) tmin = t2-t1
end do
print "('fortran,parse_integers,',f0.6)", sysclock2ms(tmin) / NRUNS

tmin = huge(0_i64)
do i = 1, 5
    call system_clock(t1)
    call printfd(100000)
    call system_clock(t2)
    if (t2-t1 < tmin) tmin = t2-t1
end do
print "('fortran,print_to_file,',f0.6)", sysclock2ms(tmin)

tmin = huge(0_i64)
do i = 1, 5
    call system_clock(t1)
    do k = 1, NRUNS
        f = mandelperf()
    end do
    call system_clock(t2)
    if (t2-t1 < tmin) tmin = t2-t1
end do
call assert(f == 14791)
print "('fortran,iteration_mandelbrot,',f0.6)", sysclock2ms(tmin) / NRUNS

tmin = huge(0_i64)
do i = 1, 5
    call system_clock(t1)
    do k = 1, NRUNS
        allocate(d(5000))
        call random_number(d)
        call quicksort(d, 1, size(d))
        deallocate(d)
    end do
    call system_clock(t2)
    if (t2-t1 < tmin) tmin = t2-t1
end do
print "('fortran,recursion_quicksort,',f0.6)", sysclock2ms(tmin) / NRUNS

tmin = huge(0_i64)
do i = 1, 5
    call system_clock(t1)
    pi = pisum()
    call system_clock(t2)
    if (t2-t1 < tmin) tmin = t2-t1
end do
call assert(abs(pi - 1.644834071848065_dp) < 1e-6_dp)
print "('fortran,iteration_pi_sum,',f0.6)", sysclock2ms(tmin)

tmin = huge(0_i64)
do i = 1, 5
    call system_clock(t1)
    call randmatstat(1000, s1, s2)
    call system_clock(t2)
    if (t2-t1 < tmin) tmin = t2-t1
end do
! call assert(s1 > 0.5_dp .and. s1 < 1)
! call assert(s2 > 0.5_dp .and. s2 < 1)
print "('fortran,matrix_statistics,',f0.6)", sysclock2ms(tmin)

tmin = huge(0_i64)
do i = 1, 5
    call system_clock(t1)
    call randmatmul(1000, C)
    call assert(C(1, 1) >= 0)
    call system_clock(t2)
    if (t2-t1 < tmin) tmin = t2-t1
end do
print "('fortran,matrix_multiply,',f0.6)", sysclock2ms(tmin)

end program


! { dg-do compile }
!
! PR fortran/37203 - check RESHAPE arguments
!

  integer, dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /)
  integer, dimension(2) :: shape1 = (/ 2, 5/)
  integer, dimension(2) :: pad1 = (/ 0, 0/)
  integer, dimension(2) :: t(2,5)

  t = reshape(source1, shape1, pad1, (/2, 1/))        ! ok
  t = reshape(source1, shape1, pad1, (/2.1, 1.2/))    ! { dg-error "must be INTEGER" }
  t = reshape(source1, shape1, pad1, (/2, 2/))        ! { dg-error "invalid permutation" }
  t = reshape(source1, shape1, pad1, (/2, 3/))        ! { dg-error "out-of-range dimension" }
  t = reshape(source1, shape1, pad1, (/2/))           ! { dg-error "wrong number of elements" }
end