        subroutine ludcmp0(A,n,np,indx,d)
!***********************************************************************
!  Copyright, 1993, 2004,  The  Regents of the University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  Given an n by n matrix A, with physical dimension np, this routine
CD1  replaces it by the LU decomposition of a rowwise permutation of
CD1  itself.
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/ludcmp0.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:28   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:10:04   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:10:54   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:25:18   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:05:00   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:43:28 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.5   Fri Apr 26 15:45:34 1996   gaz
CD2 returns different singular matrix info
CD2
CD2    Rev 1.4   Fri Feb 16 10:04:30 1996   zvd
CD2 Modified requirement.
CD2
CD2    Rev 1.3   Thu Jan 18 09:54:00 1996   zvd
CD2 Modifications to prolog
CD2
CD2    Rev 1.2   Wed Jan 10 14:33:52 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.1   03/18/94 15:57:48   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:25:30   pvcs
CD2 original version in process of being certified
CD2
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  Not Applicable. This is a general utility routine used in the code
CD3  as needed for solving a matrix.
CD3
C***********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4  Taken from Numerical Recipes, section 2.3.
CD4
CD4 Given an n by n matrix A, with physical dimension np, this routine
CD4 replaces it by the LU decompostion of a row wise permutation of
CD4 itself.  A and n are input.  A is output, arranged as in equation
CD4 2.3.14 above; indx is an output vector which records the row
CD4 permutation effected by the partial pivoting; d is output as +/-1
CD4 depending on whether the number of row interchanges was even or odd,
CD4 respectively.  This routine is used in combination with lubksb0 to
CD4 solve linear equations or invert a matrix.
CD4
C***********************************************************************
CD5
CD5 INTERFACES
CD5
CD5 Formal Calling Parameters
CD5
CD5   Identifier      Type     Use  Description
CD5
CD5   A               REAL*8   I/O  LU decomposition of A
CD5   d               REAL*8   O    Flag denoting even or odd number of
CD5                                   row interchanges
CD5   indx            INT      O    Permutation vector
CD5   n               INT      I    Number of rows/columns in A
CD5   np              INT      I    Dimension of A
CD5
CD5
CD5 Interface Tables
CD5
CD5   None
CD5
CD5 Files
CD5
CD5   None
CD5
C***********************************************************************
CD6
CD6 GLOBAL OBJECTS
CD6
CD6 Global Constants
CD6
CD6   None
CD6
CD6 Global Types
CD6
CD6   None
CD6
CD6 Global Variables
CD6
CD6   None
CD6
CD6 Global Subprograms
CD6
CD6   None
CD6
C***********************************************************************
CD7
CD7 LOCAL IDENTIFIERS
CD7
CD7 Local Constants
CD7
CD7   None
CD7
CD7 Local Types
CD7
CD7   None
CD7
CD7 Local variables
CD7
CD7   Identifier      Type     Description
CD7
CD7   aamax           REAL*8   Maximum value of A in a given row
CD7   dum             REAL*8   Figure of merit for pivot, dummy storage
CD7                              for element intercahnge values
CD7   i               INT      Loop index
CD7   imax            INT      Index of pivot row
CD7   j               INT      Loop index
CD7   k               INT      Loop index
CD7   sum             REAL*8   Modified element value
CD7   vv              REAL*8   Implicit scaling of row
CD7
CD7 Local Subprograms
CD7
CD7   Identifier      Type     Description
CD7
CD7
C***********************************************************************
CPS
CPS PSEUDOCODE
CPS
CPS BEGIN ludcmp0
CPS
CPS   initialize row interchanges flag to even
CPS
CPS   FOR each row
CPS       set max row value of A to zero
CPS       FOR each element in the row
CPS           IF the absolute value of the current element is greater
CPS            than the current maximum value
CPS              set the maximum value to the absolute value of the
CPS               current element
CPS           END IF
CPS       END FOR
CPS
CPS       IF the row maximum value is zero
CPS          pause, the matrix is singular
CPS       END IF
CPS
CPS       set scaling to 1 over maximum row value
CPS   END FOR
CPS
CPS   FOR each column
CPS
CPS       FOR each row down to but excluding diagonal element
CPS           set sum to current element value
CPS           FOR all previous elements in column
CPS               compute updated sum
CPS           END FOR
CPS           set element value to current sum
CPS       END FOR
CPS
CPS       set max row value of A to zero for pivot element search
CPS       set pivot row to current diagonal
CPS
CPS       FOR each row from diagonal element to end
CPS           set sum to current element value
CPS           FOR all previous elements in column up to diagonal
CPS               compute updated sum
CPS           END FOR
CPS           set element value to current sum
CPS
CPS           compute figure of merit for the pivot
CPS           IF this is the best value for pivot
CPS              set the pivot row value to current row number
CPS              set the maximum row value to figure of merit
CPS           END IF
CPS       END FOR
CPS
CPS       IF rows should be interchanged
CPS          FOR each row element
CPS              interchange the elements in the two rows
CPS          END FOR
CPS          toggle row interchanges flag
CPS          interchange scale factor
CPS       END IF
CPS
CPS       set the permutation index
CPS
CPS       IF the diagonal element is now zero
CPS          set it to tiny
CPS       END IF
CPS
CPS       IF this isn't the last column
CPS          compute the pivot scaling factor
CPS          FOR each row below th diagonal
CPS              compute the new element value
CPS          END FOR
CPS       END IF
CPS
CPS   END FOR
CPS
CPS END ludcmp0
CPS
C***********************************************************************

      implicit none

      integer n,i,j,k,imax,indx(n),nmax,np

*     Largest expected n, and a small number.
      parameter (nmax = 100)
*     vv stores the implicit scaling of each row.
      real*8 A(np, np), aamax, d, dum, sum, tiny, vv(nmax)
      parameter (tiny = 1.e-20)

c     No row interchanges yet.
      d = 1.
c     Loop over rows to get the implicit scaling information.
      do i = 1, n
         aamax = 0.
         do j = 1, n
	    if (abs(A(i,j)) .gt. aamax)  aamax = abs(A(i,j))
         enddo
c     No nonzero largest element.
	  if (aamax .eq. 0.)  then
             indx(1)=-1
             return
          endif
c     Save the scaling.
	  vv(i) = 1./aamax
       enddo

c     This is the loop over columns of Crout's method.
       do j = 1, n
c     This is equation 2.3.12 except for i=j.
	  do i = 1, j-1
             sum = A(i,j)
             do k = 1, i-1
                sum = sum - A(i,k)*A(k,j)
             enddo
             A(i,j) = sum
          enddo
c     Initialize for the search for largest pivot element.
	  aamax = 0.
          imax = j
c     This is i=j of equation 2.3.12 and i = j+1...n of equation 2.3.13.
	  do i = j, n
             sum = A(i,j)
             do k = 1, j-1
                sum = sum - A(i,k)*A(k,j)
             enddo
             A(i,j) = sum
c     Figure of merit for the pivot.
             dum = vv(i)*abs(sum)
c     Is it better than the best so far?
             if (dum .ge. aamax) then
                imax = i
                aamax = dum
             end if
          enddo
c     Do we need to interchange rows?
	  if (j .ne. imax) then
c     Yes, do so...
             do k = 1, n
                dum = A(imax,k)
                A(imax,k) = A(j,k)
                A(j,k) = dum
             enddo
c     ...and change the parity of d.
             d = -d
c     Also interchange the scale factor.
             vv(imax) = vv(j)
	  end if
	  indx(j) = imax
	  if (A(j,j) .eq. 0.)  A(j,j) = tiny
c     Now, finally, divide by the pivot element.
	  if (j .ne. n) then
c     If the pivot element is zero the matrix is singular (at least to
c     precision of the algorithm).  For some applications on singular
c     matrics, it is desirable to substitute tiny for zero.
             dum = 1./A(j,j)
             do i = j+1, n
                A(i,j) = A(i,j)*dum
             enddo
	  endif
c     Go back for the next column in the reduction.
       enddo

       return
       end


PROGRAM TestInterp

USE dspline

IMPLICIT NONE

INTEGER :: m,n,ip,j,k,jmin,jmax,jd
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: u,p,xcof
DOUBLE PRECISION :: dt,t,tnow,uev,upev,utrue,uptrue,frac,s

n=500
tnow=17.137d0
dt=tnow/DBLE(n)
ALLOCATE(u(n))

DO m=2,12,2
  ALLOCATE(p(0:m),xcof(0:m))
  CALL Extrap(xcof,m)
  DO j=0,m
    CALL RANDOM_NUMBER(p(j))
    p(j)=-1.d0+2.d0*p(j)
  END DO
  DO ip=0,1
    PRINT *,m,ip
    DO k=(m/2)+1,n-1
      CALL RANDOM_NUMBER(frac)
      t=dt*(DBLE(k)+frac)
      s=dt*frac
      utrue=p(m)
      uptrue=DBLE(m)*p(m)
      DO jd=m-1,1,-1
        utrue=s*utrue+p(jd)
        uptrue=s*uptrue+DBLE(jd)*p(jd)
      END DO
      utrue=s*utrue+p(0)
      u=0.d0
      jmin=MAX(1,k-m)
      jmax=MIN(n,k+(m/2)+2)
      DO j=jmin,jmax
        s=dt*DBLE(j-k)
        u(j)=p(m)
        DO jd=m-1,0,-1
          u(j)=s*u(j)+p(jd)
        END DO
      END DO
      IF ((ip==1).AND.(jmax==n)) THEN
        u(n)=0.d0
        DO j=0,m
          u(n)=u(n)+xcof(j)*u(n+j-m-1)
        END DO
      END IF
      CALL Interp(tnow,t,dt,uev,upev,u,m,n)
      PRINT *,k,ABS(utrue-uev),ABS(uptrue-upev)
    END DO
  END DO
  DEALLOCATE(p,xcof)
END DO

END PROGRAM TestInterp


      module shtns

! fortran95 interface to the SHTNS library
! (http://users.isterre.fr/nschaeff/SHTns/index.html).
! this version hardwired for gaussian grids.

! The available routines are:

! SUBROUTINE GRDTOSPEC(datagrid,dataspec):
! converts input gridded data array (datagrid) to complex spectral
! coefficients (dataspec).

! SUBROUTINE SPECTOGRD(dataspec,datagrid):
! converts input spectral coefficient array (dataspec) to a grid (datagrid).

! SUBROUTINE GETUV(vrtspec,divspec,ugrid,vgrid,rsphere):
! given input spectral coefficients of vorticity and divergence
! (vrtspec,divspec) calculates gridded winds (ugrid,vgrid).
! rsphere is the radius of the sphere.

! SUBROUTINE GETVRTDIVSPEC(ugrid,vgrid,vrtspec,divspec,rsphere):
! given input gridded winds (ugrid,vgrid) calculates spectral coefficients
! of vorticity and divergence (vrtspec,divspec). rsphere is the radius of
! the sphere.

! SUBROUTINE GETGRAD(dataspec,gradx,grady,rsphere):
! calculates gridded vector gradient (gradx,grady) given input
! spectral coefficients. rsphere is the radius of the sphere.

! SUBROUTINE SHTNS_CLEANUP():
! Garbage collection. Deallocates all memory.
! Call this when you are done with the module to free up memory.

! SUBROUTINE SHTNS_INIT(NLONS,NLATS,NTRUNC):
! initialize transform machinery for a given grid and spectral
! truncation.  Called automatically by other routines if
! grid (as described by input arrays) changes.

! module data:
! lats,lons: 2-d arrays with lat/lon values (radians) of transform grid.
! nlm: number of complex spectral coeffs.
! current_nlon, current_nlat: current values of nlons,nlats
! gauwts: 1-d array (length current_nlat) of gaussian quadrature weights.
! current_ntrunc: current spectral truncation
! degree: array with degree (n) for each spectral coefficient.
! order: array with order (m) for each spectral coefficient.
! lap: lapacian operator (-n*(n+1))
! invlap: inverse of laplacian operator.

! All of these routines use triangular truncation.
! The spherical harmonic coefficients are normalized using an
! 'orthonormalized' norm
! (http://en.wikipedia.org/wiki/Spherical_harmonics#Conventions).

      use kinds, only: r_kind, default_real, r_double
      use iso_c_binding
      implicit none
      private
      public :: shtns_init,grdtospec,spectogrd,getuv,getvrtdivspec,&
                getgrad,shtns_destroy
      public :: gauwts, lats, lons, nlm, degree, order, lap, invlap,&
                current_nlon, current_nlat, current_ntrunc, areawts,&
            print_bool
      INTEGER, PARAMETER :: SHT_NATIVE_LAYOUT=0
      INTEGER, PARAMETER :: SHT_THETA_CONTIGUOUS=256
      INTEGER, PARAMETER :: SHT_PHI_CONTIGUOUS=512
      INTEGER, PARAMETER :: SHT_NO_CS_PHASE=1024
      INTEGER, PARAMETER :: SHT_REAL_NORM=2048
      INTEGER, PARAMETER :: SHT_ORTHONORMAL=0
      INTEGER, PARAMETER :: SHT_FOURPI=1
      INTEGER, PARAMETER :: SHT_SCHMIDT=2
      INTEGER, PARAMETER :: SHT_GAUSS=0
      INTEGER, PARAMETER :: SHT_AUTO=1
      INTEGER, PARAMETER :: SHT_REG_FAST=2
      INTEGER, PARAMETER :: SHT_REG_DCT=3
      INTEGER, PARAMETER :: SHT_QUICK_INIT=4
      INTEGER, PARAMETER :: SHT_REG_POLES=5
      INTEGER, PARAMETER :: SHT_GAUSS_FLY=6
      REAL(r_double), PARAMETER :: SHT_DEFAULT_POLAR_OPT=1.d-10
      INTEGER, SAVE      :: current_nlon = -1
      INTEGER, SAVE      :: current_nlat = -1
      INTEGER, SAVE      :: current_ntrunc = -1
      INTEGER            :: nlm
      INTEGER :: print_bool
! arrays allocated when nlon or nlat or ntrunc change.
      REAL(r_kind), DIMENSION(:), pointer :: lap, invlap, gauwts
      REAL(r_kind), DIMENSION(:,:), pointer :: lats
      REAL(r_kind), DIMENSION(:,:), pointer :: lons, areawts
      INTEGER, DIMENSION(:), pointer :: degree, order
      real(r_double) :: popt ! polar optimization thresh
      integer :: nth ! number of threads to use

      contains

      subroutine sht_assign_arrays(py_lap, py_invlap, py_gauwts,&
              py_lons, py_lats, py_areawts, py_degree,&
              py_order, py_nlons, py_nlats, py_nlm)&
              bind(c, name='gfs_assign_sht_arrays')

          REAL(c_double), DIMENSION(py_nlm), target :: py_lap, py_invlap
          REAL(c_double), DIMENSION(py_nlats), target :: py_gauwts
          REAL(c_double), DIMENSION(py_nlons,py_nlats), target :: py_lats
          REAL(c_double), DIMENSION(py_nlons,py_nlats), target :: py_lons
          REAL(c_double), DIMENSION(py_nlons,py_nlats), target :: py_areawts
          INTEGER(c_int), DIMENSION(py_nlm), target :: py_degree, py_order
          integer(c_int), intent(in) :: py_nlons, py_nlats, py_nlm

          lap => py_lap
          invlap => py_invlap
          gauwts => py_gauwts
          lats => py_lats
          lons => py_lons
          areawts => py_areawts
          degree => py_degree
          order => py_order

      end subroutine sht_assign_arrays

      !subroutine get_lon_lat(longitudes, latitudes) &
      !        bind(c,name='gfs_get_lon_lat')

      !real(c_double), intent(out), dimension(current_nlon,current_nlat)&
      !          :: longitudes, latitudes

      !if(allocated(lats)) then
      !    latitudes(:,:) = lats(:,:)
      !else
      !    print *, 'latitudes not allocated'
      !endif

      !if(allocated(lons)) then
      !    longitudes(:,:) = lons(:,:)
      !else
      !    print *, 'longitudes not allocated'
      !endif

      !end subroutine get_lon_lat

      subroutine shtns_init(nlon,nlat,ntrunc,nthreads,polar_opt)
! initialize library, allocate arrays.
      integer, intent(in) :: nlon,nlat,ntrunc
      integer, intent(in), optional :: nthreads
      real(r_double), intent(in), optional :: polar_opt
      real(r_double), dimension(:), allocatable :: lats1,gauwts1
      real(r_double) pi
      integer m,n,i,j
      print_bool = 0
      if (present(nthreads)) then
         nth = nthreads
      else
         nth = 1
      endif
      if (present(polar_opt)) then
         popt = polar_opt
      else
         popt = SHT_DEFAULT_POLAR_OPT
      endif
      call shtns_destroy()
      call shtns_use_threads(0) ! JOY auto compute number of openmp threads.
      !print *, 'In set_size', ntrunc
      call shtns_set_size(ntrunc,ntrunc,1,SHT_ORTHONORMAL+SHT_NO_CS_PHASE)
      !print *, 'In precompute'
      !print *, nlat, nlon
      call shtns_precompute(SHT_GAUSS_FLY,SHT_PHI_CONTIGUOUS,popt,nlat,nlon)
      call shtns_calc_nlm(nlm,ntrunc,ntrunc,1)
      current_nlat = nlat
      current_nlon = nlon
      current_ntrunc = ntrunc
      if (nlm .ne. (ntrunc+1)*(ntrunc+2)/2) then
         print *,'error: nlm not what expected',nlm,ntrunc
         stop
      endif
      !if (.not. allocated(lats)) allocate(lats(nlon,nlat))
      !if (.not. allocated(gauwts)) allocate(gauwts(nlat))
      !if (.not. allocated(lons)) allocate(lons(nlon,nlat))
      allocate(lats1(nlat))
      allocate(gauwts1(nlat/2))
      call shtns_cos_array(lats1)
      call shtns_gauss_wts(gauwts1)
      ! lats is 2d-array (lon,lat), lats1 is 1d
      do i=1,nlon
         lats(i,:) = asin(lats1)
      enddo
      do j=1,nlat/2
         gauwts(j) = gauwts1(j)
         gauwts(nlat-j+1) = gauwts1(j)
      enddo
      !allocate(areawts(nlon,nlat))
      do i=1,nlon
         areawts(i,:) = gauwts(:)
      enddo
      areawts = areawts/sum(areawts)
      pi = 4.*atan(1.0)
      do j=1,nlat
      do i=1,nlon
         lons(i,j) = 2.*pi*real(i-1)/nlon
      enddo
      enddo
      deallocate(lats1,gauwts1)
      !if (.not. allocated(degree)) allocate(degree(nlm))
      !if (.not. allocated(order)) allocate(order(nlm))
      degree = (/((n,n=m,ntrunc),m=0,ntrunc)/)
      order = (/((m,n=m,ntrunc),m=0,ntrunc)/)
      !if (.not. allocated(lap)) allocate(lap(nlm))
      !if (.not. allocated(invlap)) allocate(invlap(nlm))
      lap = -degree*(degree+1.0)
      invlap = 0
      invlap(2:) = 1./lap(2:)
      end subroutine shtns_init

      subroutine shtns_destroy()
! deallocate arrays.
      call shtns_reset()
      !if (allocated(lats)) deallocate(lats)
      !if (allocated(gauwts)) deallocate(gauwts)
      !if (allocated(areawts)) deallocate(areawts)
      !if (allocated(lons)) deallocate(lons)
      !if (allocated(degree)) deallocate(degree)
      !if (allocated(order)) deallocate(order)
      !if (allocated(lap)) deallocate(lap)
      !if (allocated(invlap)) deallocate(invlap)
      !nullify(lats,gauwts,areawts,lons,degree,order,lap,invlap)
      end subroutine shtns_destroy

      subroutine grdtospec(datagrid,dataspec)
! converts gridded input array (datagrid) to complex spectral coefficients
! (dataspec).
      real(c_double), dimension(:,:), intent(in) :: datagrid
      complex(r_kind), dimension(:), intent(out) :: dataspec
      real(r_double), dimension(:,:), allocatable :: datagrid_tmp
      complex(r_double), dimension(:), allocatable :: dataspec_tmp
      integer nlon,nlat,ntrunc
      ! compute array dimensions and infer truncation limit
      ! from size of input arrays
      nlon = size(datagrid,1)
      nlat = size(datagrid,2)
      ntrunc = nint((-1.+sqrt(1+8*float(size(dataspec))))/2.)-1

      if (nlon .ne. current_nlon .or. &
          nlat .ne. current_nlat .or. &
          ntrunc .ne. current_ntrunc) then
          call shtns_init(nlon,nlat,ntrunc,nth,popt)
      end if
      if (default_real .ne. 2) then
         ! if inputs not double precision convert,
         ! then convert back.
         !if (print_bool == 1) then
         !   print *, datagrid(4,1:3)
         !   print *, 'grdtospec not default_real: ', loc(datagrid)
         !   print *, ''
         !end if

         allocate(datagrid_tmp(nlon,nlat))
         allocate(dataspec_tmp(nlm))
         datagrid_tmp = datagrid
         call shtns_spat_to_sh(datagrid_tmp, dataspec_tmp)
         dataspec = dataspec_tmp
         deallocate(datagrid_tmp,dataspec_tmp)
      else
         call shtns_spat_to_sh(datagrid, dataspec)
      endif
      end subroutine grdtospec

      subroutine spectogrd(dataspec,datagrid)
! converts complex spectral coefficients (dataspec) to
! gridded data array (datagrid).
      real(r_kind), dimension(:,:), intent(out) :: datagrid
      complex(r_kind), dimension(:), intent(in) :: dataspec
      real(r_double), dimension(:,:), allocatable :: datagrid_tmp
      complex(r_double), dimension(:), allocatable :: dataspec_tmp
      integer nlon,nlat,ntrunc
      ! compute array dimensions and infer truncation limit
      ! from size of input arrays
      nlon = size(datagrid,1)
      nlat = size(datagrid,2)
      ntrunc = nint((-1.+sqrt(1+8*float(size(dataspec))))/2.)-1
      if (nlon .ne. current_nlon .or. &
          nlat .ne. current_nlat .or. &
          ntrunc .ne. current_ntrunc) then
          call shtns_init(nlon,nlat,ntrunc,nth,popt)
      end if
      if (default_real .ne. 2) then
         allocate(datagrid_tmp(nlon,nlat))
         allocate(dataspec_tmp(nlm))
         dataspec_tmp = dataspec
         call shtns_sh_to_spat(dataspec_tmp, datagrid_tmp)
         datagrid = datagrid_tmp
         deallocate(datagrid_tmp,dataspec_tmp)
      else
         call shtns_sh_to_spat(dataspec, datagrid)
      endif
      end subroutine spectogrd

      subroutine getuv(vrtspec,divspec,ugrid,vgrid,rsphere)
! given spectral coefficients of vorticity and divergence
! (vrtspec,divspec) compute gridded winds (ugrid,vgrid).
! rsphere is the radius of the sphere in meters.
      real(r_kind), intent(in) :: rsphere
      real(r_kind), dimension(:,:), intent(out) :: ugrid,vgrid
      complex(r_kind), dimension(:), intent(in) :: vrtspec,divspec
      real(r_double), dimension(:,:), allocatable :: ugrid_tmp,vgrid_tmp
      complex(r_double), dimension(:), allocatable :: &
      vrtspec_tmp,divspec_tmp
      integer nlon,nlat,ntrunc
      ! compute array dimensions and infer truncation limit
      ! from size of input arrays
      nlon = size(ugrid,1)
      nlat = size(ugrid,2)
      ntrunc = nint((-1.+sqrt(1+8*float(size(vrtspec))))/2.)-1
      if (nlon .ne. current_nlon .or. &
          nlat .ne. current_nlat .or. &
          ntrunc .ne. current_ntrunc) then
          call shtns_init(nlon,nlat,ntrunc,nth,popt)
      end if
      if (default_real .ne. 2) then
         allocate(ugrid_tmp(nlon,nlat))
         allocate(vrtspec_tmp(nlm))
         allocate(vgrid_tmp(nlon,nlat))
         allocate(divspec_tmp(nlm))
         vrtspec_tmp = invlap*rsphere*vrtspec
         divspec_tmp = invlap*rsphere*divspec
         call shtns_sphtor_to_spat(vrtspec_tmp,divspec_tmp,ugrid_tmp,vgrid_tmp)
         ugrid = ugrid_tmp
         vgrid = vgrid_tmp
         deallocate(ugrid_tmp,vgrid_tmp,vrtspec_tmp,divspec_tmp)
      else
         allocate(vrtspec_tmp(nlm))
         allocate(divspec_tmp(nlm))
         vrtspec_tmp = invlap*rsphere*vrtspec
         divspec_tmp = invlap*rsphere*divspec
         call shtns_sphtor_to_spat(vrtspec_tmp,divspec_tmp,ugrid,vgrid)
         deallocate(vrtspec_tmp,divspec_tmp)
      endif
      end subroutine getuv

      subroutine getvrtdivspec(ugrid,vgrid,vrtspec,divspec,rsphere)
! calculate spectral coefficients of vorticity and divergence
! (vrtspec,divspec) given input gridded winds (ugrid,vgrid).
! rsphere is the radius of the sphere in meters.
      real(r_kind), intent(in) :: rsphere
      real(r_kind), dimension(:,:), intent(in) :: ugrid,vgrid
      complex(r_kind), dimension(:), intent(out) :: vrtspec,divspec
      real(r_double), dimension(:,:), allocatable :: ugrid_tmp,vgrid_tmp
      complex(r_double), dimension(:), allocatable :: &
      vrtspec_tmp,divspec_tmp
      integer nlon,nlat,ntrunc
      ! compute array dimensions and infer truncation limit
      ! from size of input arrays.
      nlon = size(ugrid,1)
      nlat = size(ugrid,2)
      ntrunc = nint((-1.+sqrt(1+8*float(size(vrtspec))))/2.)-1
      if (nlon .ne. current_nlon .or. &
          nlat .ne. current_nlat .or. &
          ntrunc .ne. current_ntrunc) then
          call shtns_init(nlon,nlat,ntrunc,nth,popt)
      end if
      if (default_real .ne. 2) then
         allocate(ugrid_tmp(nlon,nlat))
         allocate(vrtspec_tmp(nlm))
         allocate(vgrid_tmp(nlon,nlat))
         allocate(divspec_tmp(nlm))
         ugrid_tmp = ugrid
         vgrid_tmp = vgrid
         call shtns_spat_to_sphtor(ugrid_tmp, vgrid_tmp, vrtspec_tmp, divspec_tmp)
         vrtspec = vrtspec_tmp
         divspec = divspec_tmp
         deallocate(ugrid_tmp,vgrid_tmp,vrtspec_tmp,divspec_tmp)
      else
         call shtns_spat_to_sphtor(ugrid, vgrid, vrtspec, divspec)
      endif
      vrtspec = (lap/rsphere)*vrtspec; divspec = (lap/rsphere)*divspec
      end subroutine getvrtdivspec

      subroutine getgrad(divspec,ugrid,vgrid,rsphere)
! given spectral coefficients compute gridded vector gradient.
! rsphere is the radius of the sphere in meters.
      real(r_kind), intent(in) :: rsphere
      real(r_kind), dimension(:,:), intent(out) :: ugrid,vgrid
      complex(r_kind), dimension(:), intent(in) :: divspec
      complex(r_kind), dimension(:), allocatable :: vrtspec
      real(r_double), dimension(:,:), allocatable :: ugrid_tmp,vgrid_tmp
      complex(r_double), dimension(:), allocatable :: &
      vrtspec_tmp,divspec_tmp
      integer nlon,nlat,ntrunc
      ! compute array dimensions and infer truncation limit
      ! from size of input arrays
      nlon = size(ugrid,1)
      nlat = size(ugrid,2)
      ntrunc = nint((-1.+sqrt(1+8*float(size(divspec))))/2.)-1
      if (nlon .ne. current_nlon .or. &
          nlat .ne. current_nlat .or. &
          ntrunc .ne. current_ntrunc) then
          call shtns_init(nlon,nlat,ntrunc,nth,popt)
      end if
      if (default_real .ne. 2) then
         allocate(ugrid_tmp(nlon,nlat))
         allocate(vrtspec_tmp(nlm))
         allocate(vgrid_tmp(nlon,nlat))
         allocate(divspec_tmp(nlm))
         vrtspec_tmp = 0.
         divspec_tmp = divspec
         call shtns_sphtor_to_spat(vrtspec_tmp,divspec_tmp,ugrid_tmp,vgrid_tmp)
         ugrid = ugrid_tmp
         vgrid = vgrid_tmp
         deallocate(ugrid_tmp,vgrid_tmp,vrtspec_tmp,divspec_tmp)
      else
         allocate(vrtspec(nlm))
         vrtspec = 0.
         call shtns_sphtor_to_spat(vrtspec,divspec,ugrid,vgrid)
         deallocate(vrtspec)
      endif
      ugrid = ugrid/rsphere; vgrid = vgrid/rsphere
      end subroutine getgrad

! that's it!

      end module shtns


      COMPLEX*16 FUNCTION D040WZ(AQ2,AP2,AM12,AM32)
      IMPLICIT NONE
      REAL*8 EPS1,ABS1,DELTA,AQ2,AP2,Q2,P2
      REAL*8 XMIN,XMAX,STX,RFINTD,IFINTD,ARG,RED0,IMD0,RE2,RE3
      COMPLEX*16 AM12,AM32,M12,M32,DCMPLX
      COMMON /D0PAR/ M12,M32,Q2,P2
      EXTERNAL RFINTD,IFINTD
*
      Q2=AQ2
      P2=AP2
      M12=AM12
      M32=AM32
      EPS1=1D-9
      ABS1=1D-20
      DELTA=1D-12
      XMIN=DELTA
      XMAX=1D0-DELTA
      STX =.25D0*(XMAX-XMIN)
      CALL SIMPV(XMIN,XMAX,STX,EPS1,ABS1,RFINTD,ARG,RED0,RE2,RE3)
      CALL SIMPV(XMIN,XMAX,STX,EPS1,ABS1,IFINTD,ARG,IMD0,RE2,RE3)
      D040WZ=DCMPLX(RED0,IMD0)
      RETURN
      END

      REAL*8 FUNCTION RFINTD(Y)
      IMPLICIT NONE
      REAL*8 Y,Q2,P2,DREAL
      COMPLEX*16 M12,M32,KY2,LOG
      COMMON /D0PAR/ M12,M32,Q2,P2
*
      KY2=M12*Y+M32*(1D0-Y)+Q2*Y*(1D0-Y)
      RFINTD=DREAL(1D0/(P2*KY2-M12*M32)*(LOG((KY2)/M12)+LOG(P2/M32)))
      RETURN
      END

      REAL*8 FUNCTION IFINTD(Y)
      IMPLICIT NONE
      REAL*8 Y,Q2,P2,DIMAG
      COMPLEX*16 M12,M32,KY2,LOG
      COMMON /D0PAR/ M12,M32,Q2,P2
*
      KY2=M12*Y+M32*(1D0-Y)+Q2*Y*(1D0-Y)
      IFINTD=DIMAG(1D0/(P2*KY2-M12*M32)*(LOG((KY2)/M12)+LOG(P2/M32)))
      RETURN
      END


      subroutine qqb_gamgam_v(p,msq)
      implicit none
************************************************************************
*     Authors: R.K. Ellis and John M. Campbell                         *
*     December, 2010.                                                  *
************************************************************************
*                   .                                                  *
*     Matrix element for gamma + gamma production,                     *
*     averaged over initial colours and spins                          *
*                   .                                                  *
*     q(-p1)+qbar(-p2) --> gamma(p3)+gamma(p4)                         *
*                   .                                                  *
************************************************************************
      include 'constants.f'
      include 'ewcouple.f'
      include 'ewcharge.f'
      include 'qcdcouple.f'
      include 'sprods_com.f'
      include 'scheme.f'
      integer j,k
      double precision qa,aq,gg
      double precision msq(-nf:nf,-nf:nf),p(mxpart,4),fac,facgg,Qsum,
     & qagamgam,statfac,virtgamgam
      parameter(statfac=0.5d0)

      scheme='tH-V'

      fac=8d0*xn*esq**2*ason2pi*statfac

      call dotem(4,p,s)
      qa=+qagamgam(3,4,2)*fac*aveqq
      aq=qa

c--- initialize gg 2-loop matrix elements
      Qsum=+Q(1)**2+Q(2)**2+Q(3)**2+Q(4)**2+Q(5)**2
      facgg=4d0*esq*gsq/(16d0*pisq)*Qsum
      gg=avegg*V*facgg**2*statfac*virtgamgam(s(1,2),s(1,3),s(2,3))

      do j=-nf,nf
      do k=-nf,nf
c--set msq=0 to initalize
      msq(j,k)=0d0
C--qa
      if ((j .gt. 0) .and. (k .lt. 0)) then
          if (j .eq. -k) msq(j,k)=Q(j)**4*qa
C--aq
      elseif ((j .lt. 0) .and. (k .gt. 0)) then
          if (j .eq. -k) msq(j,k)=Q(k)**4*aq
C--gg
      elseif ((j .eq. 0) .and. (k .eq. 0)) then
          msq(j,k)=gg
      endif

      enddo
      enddo

      return
      end

      double precision function qagamgam(i1,i2,i3)
      implicit none
c----Matrix element for gamma + gamma production
c----in order alpha_s
c---
c---  0 -> gamma(p1) + gamma(p2) + q(p3) + qb(p4)
c---
      include 'constants.f'
      include 'sprods_com.f'
      include 'epinv.f'
      include 'scale.f'
      include 'scheme.f'
      integer i1,i2,i3
      double complex lnrat,l12,l13,l23
      double precision s12,s13,s23,T0,deltar
      s12=s(i1,i2)
      s13=s(i1,i3)
      s23=s(i2,i3)
      T0=s13/s23+s23/s13
      l12=lnrat(-s12,musq)
      l13=lnrat(-s13,musq)
      l23=lnrat(-s23,musq)

      if     (scheme .eq. 'tH-V') then
        deltar=0d0
      elseif (scheme .eq. 'dred') then
        deltar=1d0
      else
        write(6,*) 'Invalid scheme in qqb_gamgam_v.f'
        stop
      endif

CId,anscdr=cf*((-2*epinv**2-epinv*(3-2*[ln(-s12)])-7-[ln(-s12)]**2)*T0
C    +[ln(-s13)]*(s23-2*s12)/s13
C    +[ln(-s23)]*(s13-2*s12)/s23
C    +(s12**2+s23**2)/s13/s23*(([ln(-s12)]-[ln(-s23)])**2+pisq)
c    +(s12**2+s13**2)/s13/s23*(([ln(-s12)]-[ln(-s13)])**2+pisq)
C    -4*[ln(-s12)]);

      qagamgam=cf*((-2d0*epinv**2-epinv*(3d0-2d0*dble(l12))
     . -7d0+deltar-dble(l12**2))*T0
     . +dble(l13)*(s23-2d0*s12)/s13
     . +dble(l23)*(s13-2d0*s12)/s23
     . +(s12**2+s23**2)/s13/s23*(dble((l12-l23)**2)+pisq)
     . +(s12**2+s13**2)/s13/s23*(dble((l12-l13)**2)+pisq)
     . -4d0*dble(l12))

      return
      end


! { dg-additional-options "-O2" }

program main
   implicit none

   integer :: a(100,100), b(100,100)
   integer :: i, j, d

   !$acc kernels
   do i=1,100
     do j=1,100
       a(i,j) = 1
       b(i,j) = 2
       a(i,j) = a(i,j) + b(i,j)
     end do
   end do
   !$acc end kernels

   d = sum(a)

   print *,d
end program main


module geom

  type point
     real(8), private  :: x = 0
     real(8), private  :: y = 0
   contains
     procedure, public :: get_x
     procedure, public :: get_y
     procedure, public :: set_x
     procedure, public :: set_y
     procedure, public :: print => print_point
  end type point

  type, extends(point) :: circle
     real(8), private  :: r = 0
   contains
     procedure, public :: get_r
     procedure, public :: set_r
     procedure, public :: print => print_circle
  end type circle

contains

  real(8) function get_x(this)
    class(point), intent(in) :: this
    get_x = this%x
  end function get_x

  real(8) function get_y(this)
    class(point), intent(in) :: this
    get_y = this%y
  end function get_y

  subroutine set_x(this, val)
    class(point), intent(inout) :: this
    real(8), intent(in)         :: val
    this%x = val
  end subroutine set_x

  subroutine set_y(this, val)
    class(point), intent(inout) :: this
    real(8), intent(in)         :: val
    this%y = val
  end subroutine set_y

  subroutine print_point(this)
    class(point), intent(in) :: this
    write(*,'(2(a,f0.4),a)') 'Point(',this%x,', ',this%y,')'
  end subroutine print_point

  real(8) function get_r(this)
    class(circle), intent(in) :: this
    get_r = this%r
  end function get_r

  subroutine set_r(this, val)
    class(circle), intent(inout) :: this
    real(8), intent(in)          :: val
    this%r = val
  end subroutine set_r

  subroutine print_circle(this)
    class(circle), intent(in) :: this
    write(*,'(3(a,f0.4),a)') 'Circle(',this%x,', ',this%y,'; ',this%r,')'
  end subroutine print_circle

end module geom

program inh
  use geom

  type(point)  :: p
  type(circle) :: c

  p = point(2.0d0, 3.0d0)
  call p%print

  c = circle(3.0d0, 4.0d0, 5.0d0)
  call c%print

end program inh


module henondim
!  HENONDIM - Implement Algorithm D to determine the dimension of the basin of
!  infinity of the Henon map.
!
!  SYNOPSIS
!    use henondim
!
!  DESCRIPTION
!    The program testing this algorithm (test_henon) will pass a 1D array of
!    epsilons, the dimension of this array, and the dimension d. The basin is
!    calculated using the henon_map subroutine. Then the code, when running in
!    parallel, will thread assigning a different epsilon to each thread. Next,
!    for each epsilon, the subroutine henon_compare will compute basinP and
!    basinM (the basins obtained of the grid shifted by + or - epsilon) and
!    count the number of epsilon-uncertain grid points. To finish, it will use
!    the subroutine linfit of the module lsq, to obtain the dimension (if the
!    no erro flah is returned), which will be then passed to the testing
!    program test_henon.
!
!  PUBLIC ROUTINES DEFINED
!   - henon_map
!   - basin_alg
!   - basin_compare
!
!  REQUIRED DEPENDENCIES
!    precision - to define KINDs for single and double floating-point.
!          lsq - to do the power fitting needed at the end of th Algorithm D.
!
!  REVISION HISTORY
!   10/19/18 - Code works using constructed Matlab functions linspace and
!              meshgrid. Also the subroutine reshape since 2D arrays basins
!              are used.
!   10/24/18 - Removed all Matlab functions and reshaping. Adapted code to work
!              with 1D array basins of dimension NGRID^2. Included subroutine
!              basin_compare in order to use OpenMP. The subroutine will make
!              sure each thread has individual copies of the basins to work with
!              them.
!
!  PROGRAMMER
!   Francisco Castillo-Carrasco, fjcasti1@asu.edu
!
  use lsq
  use precision
  implicit none
  real(DP), parameter:: LOCKOUT=100
  real(DP), parameter:: BOXMIN=-3.0d0, BOXMAX=3.0d0  ! box limits
  integer, parameter:: NGRID=4096  ! number of points on a side
  integer, parameter:: K=100  ! maximum number of iterations
  contains
!-------------------------------------------------------------------------------
  subroutine henon_map(basin,eps)
!  Iterate the Henon map for one or more initial conditions up to
!  MAXITER times or until the orbit of one of the points is further than
!  LOCKOUT units away from the origin.  (It suffices to check whether the
!  |X_n| > LOCKOUT on the nth iteration.)
!
! ARGUMENTS - basin : logical, 1D array of dimension (NGRID*NGRID), True will
!                     mean that the grid point tends to infinity.
!           - eps   : real, eps represents the magnitude of the shifting
!                     of the initial grid.
!
! PROCEDURE : We define the initial grid using array constructors and do loops
!             and store it in the 2D array X0. This array will evolve according
!             to the equations giveni in the Henon map. The grid points will
!             be filtered out using the commands where and all.

    implicit none
    logical , intent(inout) :: basin(NGRID*NGRID)
    real(DP), intent(in)    :: eps

    integer  :: j
    real(DP) :: a = 2.12d0, b = -0.3d0, h
    real(DP), dimension (:)  , allocatable :: x, y
    real(DP), dimension (:)  , allocatable :: aux
    real(DP), dimension (:,:), allocatable :: X0

    allocate(x(NGRID))
    allocate(y(NGRID))
    allocate(X0(NGRID*NGRID,2))
    allocate(aux(NGRID*NGRID))

    h = (BOXMAX-BOXMIN)/(NGRID-1)
    x = (/ (h*(j-1)+BOXMIN+eps, j=1,NGRID)  /)
    y = (/ (h*(j-1)+BOXMIN, j=1,NGRID)  /)

    do j=1,NGRID
      X0(1+(j-1)*NGRID:j*NGRID,1)=x(j)
      X0(1+(j-1)*NGRID:j*NGRID,2)=y(:)
    end do

    basin=all(abs(X0)>LOCKOUT,2)

    do j=1,K
      where(basin.eq. .False.)
        aux(:) = X0(:,1)
        X0(:,1) = a-X0(:,1)**2d0+b*X0(:,2)
        X0(:,2) = aux(:)
        basin=all(abs(X0)>LOCKOUT,2)
      end where
    end do

  end subroutine henon_map
!-------------------------------------------------------------------------------
  subroutine basin_compare(N,eps,basin)
! BASIN_COMPARE - counts the number of epsilon uncertain grid points.
!
! ARGUMENTS - N     : real, N represents the number of epsilon-uncertain points
!                     for the given value of epsilon, eps.
!           - eps   : real, eps represents the magnitude of the shifting of the
!                     initial grid.
!           - basin : logical, array of dimension NGRID^2, it is the original
!                     unshifted basin, used to compare with the shifted ones and
!                     obtain the number of epsilon-uncertain grid points.
!
! PROCEDURE : We simply use the henon_map subroutine to calculate the shifted
!             basins and the function count to obtain the total number of grid
!             points whose basins don't match. This is, the total number of
!             epsilon-uncertain grid points.

    implicit none
    real(DP), intent(in)    :: eps
    real(DP), intent(inout) :: N
    logical, intent(in)     :: basin(NGRID*NGRID)
    logical, dimension(:), allocatable  :: basinP, basinM
    integer :: j

    allocate(basinP(NGRID*NGRID))
    allocate(basinM(NGRID*NGRID))

    call henon_map(basinP,eps)
    call henon_map(basinM,-eps)
    N = count(basin.ne.basinP.or.basin.ne.basinM)
  end subroutine basin_compare
!-------------------------------------------------------------------------------
  subroutine basin_alg(Neps,eps,d)

! BASIN_ALG - implements Algorithm D.
!
! ARGUMENTS - Neps : integer, dimension of 1D arrays N and eps.
!           - eps  : real, 1D array eps which represents the magnitude of the
!                    shifting of the initial grid.
!           - d    : real, d represents the dimension of the basin of attraction.
!
! PROCEDURE : We obtain the basin of attraction of the Henon map for the
!             unshifted grid, basin. Then, for multiple epsilons, we compare
!             the basins obtained out of shifted grids by a magnitued epsilon.
!             This is done in the subroutine basin_compare in such a way that
!             can be parallelizable using OpenMP. Such subroutine returns then
!             two 1D arrays, the number of epsilon uncertain grid points N,
!             and the different epsilon used. Those two arrays are passed to
!             the linfit subroutine to obtain the dimension of the basin of
!             attraction.

    integer,  intent(in)  :: Neps
    real(DP), intent(inout) :: eps(Neps), d

    integer  :: j, ierr
    real(DP) :: param(2), N(Neps)
    logical, dimension(:), allocatable  :: basin

    allocate(basin(NGRID*NGRID))

    call henon_map(basin,0.d0)
    !$omp parallel do
    do j=1,Neps
      call basin_compare(N(j),eps(j),basin)
    enddo
    !$omp end parallel do

    call linfit('Power',Neps,eps,N,param,ierr)
    if(ierr==0) d=1+param(2)
    return
  end subroutine basin_alg
!-------------------------------------------------------------------------------
end module henondim


      program demo_scramble
      use M_random, only : scramble
      implicit none
      character(len=*),parameter :: list(*)=[character(len=5) :: &
      & 'one','two','three','four','five',&
      & 'six','seven','eight','nine','ten']
      integer                    :: i
      integer                    :: n=size(list)
      character(len=len(list))   :: newlist(size(list))
      do i = 1,8
         ! use random values as indices to randomize array
         newlist=list(scramble(n))
         write(*,'(*(a,1x))') newlist
      enddo
      end program demo_scramble


      program testlog
C     Bug: log is not recognized as intrinsics
      x = log(y)
      end


!--------------------------------------------------------------------------------------------------
! PROGRAM     : lib_functions
! DESCRIPTION : is used to define the functions used the whole simulation
!
! Copyright (C) Novadiscovery. MIT
!--------------------------------------------------------------------------------------------------

MODULE lib_functions
  IMPLICIT NONE
  !--------------------------------------------------------------------------
  ! definition of constants & common variables
  !--------------------------------------------------------------------------
CONTAINS
  !--------------------------------------------------------------------------
  ! definition of useful functions
  !--------------------------------------------------------------------------

  ! AND
  !--------------------------------------------------------------------------
  ! @param
  ! @return
  FUNCTION AND_(x) RESULT(y)
    IMPLICIT NONE
    REAL, DIMENSION(:) :: x
    REAL               :: y
    INTEGER            :: i
    y = x(1)
    DO i = 2, SIZE(x,1)
       y = y * x(i)
    END DO
  END FUNCTION AND_

  ! NOT
  !--------------------------------------------------------------------------
  ! @param
  ! @return
  FUNCTION NOT_(x) RESULT(y)
    IMPLICIT NONE
    REAL, DIMENSION(:) :: x
    REAL               :: y
    y = 1.0 - x(1)
  END FUNCTION NOT_

  ! OR
  !--------------------------------------------------------------------------
  ! @param
  ! @return
  FUNCTION OR_(x) RESULT(y)
    IMPLICIT NONE
    REAL, DIMENSION(:) :: x
    REAL               :: y
    INTEGER            :: i
    y = x(1)
    DO i = 2, SIZE(x, 1)
       y = y + x(i) - y * x(i)
    END DO
  END FUNCTION OR_

  ! int2char
  !--------------------------------------------------------------------------
  ! @param x : an integer
  ! @return the char representation of 'x'
  FUNCTION int2char(x) RESULT(y)
    IMPLICIT NONE
    INTEGER                   :: x
    CHARACTER(:), ALLOCATABLE :: y
    CHARACTER(10)             :: n
    WRITE (unit = n, fmt = "(i10)") x
    y = TRIM(ADJUSTL(n))
  END FUNCTION int2char

  ! real2char
  !--------------------------------------------------------------------------
  ! @param
  ! @return
  FUNCTION real2char(x) RESULT(y)
    IMPLICIT NONE
    REAL         :: x
    CHARACTER(7) :: y
    WRITE (unit = y, fmt = "(F7.5)") x
  END FUNCTION real2char

  ! rand_int
  !--------------------------------------------------------------------------
  ! @param
  ! @return
  FUNCTION rand_int(a,b) RESULT(y)
    IMPLICIT NONE
    INTEGER :: a, b, y
    REAL    :: x
    CALL RANDOM_NUMBER(x)
    y = NINT(REAL(a) + x * (REAL(b) - REAL(a)))
  END FUNCTION rand_int
!--------------------------------------------------------------------------
! definition of useful subroutines
!--------------------------------------------------------------------------
  ! init_random_seed
  !--------------------------------------------------------------------------
  SUBROUTINE init_random_seed()
        implicit none
        integer,dimension(:),allocatable::seed
        integer::n,un,istat
        call random_seed(size=n)
        allocate(seed(n))
        open(newunit=un,file="/dev/urandom",access="stream",form="unformatted",action="read",status="old",iostat=istat)
        read(un) seed
        close(un)
        call random_seed(put=seed)
        deallocate(seed)
    END SUBROUTINE init_random_seed

END MODULE lib_functions


!=====================================================================!
! Module handling Euler angle rotation for rigid body dynamics
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module rotation

  use utils

  implicit none

  private

  public :: get_rotation, get_angrate
  public :: get_angrate_dot, get_angrate_inv

  !-------------------------------------------------------------------!
  ! A common interface for different ways of getting ROTATION matrix
  !-------------------------------------------------------------------!
  ! (a) get_rotation_from_angles_vec   -- > input theta as VECTOR
  ! (b) get_rotation_from_angles_array -- > input theta(3) as array
  ! (c) get_rotation_from_cosines -- > input dir cosines and sines
  !-------------------------------------------------------------------!

  interface get_rotation
     module procedure get_rotation_from_angles_array, &
          & get_rotation_from_angles_vec, get_rotation_from_cosines
  end interface get_rotation

  !-------------------------------------------------------------------!
  ! A common interface for different ways of getting DERIVATIVES of
  ! ROTATION matrix with respect to the  rotation parameters (thetas)
  ! -------------------------------------------------------------------!
  ! (a) get_rotation_dot_from_angles_vec -- > input theta as VECTOR
  ! (b) get_rotation_dot_from_angles_array -- > input theta(3) as array
  ! (c) get_rotation_dot_from_cosines -- > input dir cosines and sines
  ! -------------------------------------------------------------------!

  interface get_rotation_dot
     module procedure  get_rotation_dot_array, &
          & get_rotation_dot_vec, get_rotation_dot_cosines
  end interface get_rotation_dot

  !-------------------------------------------------------------------!
  ! A common interface for different ways of getting ANGULAR RATE matrix
  !-------------------------------------------------------------------!
  ! (a) get_angrate_from_angles_vec    -- > input VECTOR theta
  ! (b) get_angrate_from_angles_array  -- > input theta(3)
  ! (c) get_angrate_from_cosines       -- > input dir cosines and sines
  !-------------------------------------------------------------------!

  interface get_angrate
     module procedure get_angrate_from_angles_vec, &
          & get_angrate_from_angles_array, get_angrate_from_cosines
  end interface get_angrate

  !-------------------------------------------------------------------!
  ! A common interface for different ways of getting the time
  ! DERIVATIVE of the ANGULAR RATE matrix
  !-------------------------------------------------------------------!
  ! (a) get_angrate_dot_vec -- > input VECTOR theta, theta_dot
  ! (b) get_angrate_dot_array -- > input theta(3), theta_dot(3)
  ! (c) get_angrate_dot_cosines  -- > input dir cosines and sines
  !-------------------------------------------------------------------!

  interface get_angrate_dot
     module procedure  get_angrate_dot_array, &
          & get_angrate_dot_vec, get_angrate_dot_cosines
  end interface get_angrate_dot

  !-------------------------------------------------------------------!
  ! A common interface for different ways of getting the inverse
  ! of the ang rate matrix
  !-------------------------------------------------------------------!
  ! (a) get_angrate_inv_vec -- > input VECTOR theta, theta_dot
  ! (b) get_angrate_inv_array -- > input theta(3), theta_dot(3)
  ! (c) get_angrate_inv_cosines  -- > input dir cosines and sines
  !-------------------------------------------------------------------!

  interface get_angrate_inv
     module procedure get_angrate_inv_vec, &
          & get_angrate_inv_array, &
          & get_angrate_inv_cosines
  end interface get_angrate_inv

contains

  !--------------------------------------------------------------------!
  ! Returns the rotation transformation matrix based on the euler
  ! angles for 3-2-1 Euler sequence of rotation

  ! C = C1(theta_1)*C2(theta_2)*C3(theta_3)
  !
  ! Input: theta as an array
  ! Output: TMAT of type MATRIX
  !
  ! Ref: Section 2.2 Eq. 18/19 Hughes
  !--------------------------------------------------------------------!

  pure function get_rotation_from_angles_array(theta) result(TMAT)

    real(dp), intent(in) :: theta(NUM_SPAT_DIM)
    type(matrix)         :: TMAT
    real(dp)             :: c1, c2, c3, s1, s2, s3

    ! Compute the sin/cos of the Euler angles
    c1 = cos(theta(1))
    s1 = sin(theta(1))

    c2 = cos(theta(2))
    s2 = sin(theta(2))

    c3 = cos(theta(3))
    s3 = sin(theta(3))

    TMAT = get_rotation_from_cosines(c1, c2, c3, s1, s2, s3)

  end function get_rotation_from_angles_array

  !--------------------------------------------------------------------!
  ! Returns the rotation matrix based on the euler angles
  !
  ! Compute the 3-2-1 Euler angle rotation
  !
  ! TMAT = C1(theta_1)*C2(theta_2)*C3(theta_3)
  !
  ! Input: theta of type VECTOR
  ! Output: TMAT of type MATRIX
  !
  ! Ref: Section 2.2 Eq. 18/19 Hughes
  !--------------------------------------------------------------------!

  pure function get_rotation_from_angles_vec(thetain) result(TMAT)

    type(vector), intent(in) :: thetain
    real(dp)                 :: theta(NUM_SPAT_DIM)
    type(matrix)             :: TMAT

    ! covert to array form
    theta = array(thetain)

    ! call the method that takes angles array
    TMAT  =  get_rotation_from_angles_array(theta)

  end function get_rotation_from_angles_vec

  !--------------------------------------------------------------------!
  ! Returns the rotation matrix (euler angles) based on the sines and
  ! cosines of the euler angles
  !
  ! Compute the 3-2-1 Euler angle rotation
  !
  ! Input: sines and cosines of the euler angles
  ! Output: TMAT of type MATRIX
  !
  ! Ref: Section 2.2 Eq. 18/19 Hughes
  !--------------------------------------------------------------------!

  pure function get_rotation_from_cosines(c1,c2,c3,s1,s2,s3) result(TMAT)

    real(dp), intent(in) :: c1, c2, c3, s1, s2, s3
    type(matrix)         :: TMAT

    TMAT = matrix((/ c2*c3, c2*s3, -s2,&
         & s1*s2*c3 - c1*s3, s1*s2*s3 + c1*c3, s1*c2,&
         & c1*s2*c3 + s1*s3, c1*s2*s3 - s1*c3, c1*c2 /))

  end function get_rotation_from_cosines

  !--------------------------------------------------------------------!
  ! Returns the ang rate matrix from the supplied euler angles
  !
  ! Compute the 3-2-1 Euler angle rotation. The S matrix does not
  ! depend on c3/s3, however we keep these as inputs in case we ever
  ! want to change the Euler sequence.
  !
  ! Input : theta of type VECTOR
  ! Output: SMAT  of type MATRIX
  !
  ! Ref: Section 2.3 Eq. 24/25 Hughes
  !--------------------------------------------------------------------!

  pure function get_angrate_from_angles_vec(thetain) result(SMAT)

    type(vector), intent(in) :: thetain
    real(dp)     :: theta(NUM_SPAT_DIM)
    type(matrix) :: SMAT

    ! convert to array
    theta = array(thetain)

    ! call the function with array signature
    SMAT = get_angrate_from_angles_array(theta)

  end function get_angrate_from_angles_vec

  !--------------------------------------------------------------------!
  ! Returns the ang rate matrix from the supplied euler angles
  !
  ! Compute the 3-2-1 Euler angle rotation. The S matrix does not
  ! depend on c3/s3, however we keep these as inputs in case we ever
  ! want to change the Euler sequence.
  !
  ! Input : theta as an array
  ! Output: SMAT  of type MATRIX
  !
  ! Ref: Section 2.3 Eq. 24/25 Hughes
  !--------------------------------------------------------------------!

  pure function get_angrate_from_angles_array(theta) result(SMAT)

    real(dp), intent(in) :: theta(NUM_SPAT_DIM)
    type(matrix) :: SMAT
    real(dp)     :: c1, c2, c3, s1, s2, s3

    ! Compute the sin/cos of the Euler angles
    c1 = cos(theta(1))
    s1 = sin(theta(1))

    c2 = cos(theta(2))
    s2 = sin(theta(2))

    c3 = cos(theta(3))
    s3 = sin(theta(3))

    SMAT = get_angrate_from_cosines(c1, c2, c3, s1, s2, s3)

  end function get_angrate_from_angles_array

  !--------------------------------------------------------------------!
  ! Returns the rotation matrix (euler angles) based on the sines and
  ! cosines of the euler angles
  !
  ! Compute the 3-2-1 Euler angle rotation. The S matrix does not
  ! depend on c3/s3, however we keep these as inputs in case we ever
  ! want to change the Euler sequence.
  !
  ! Input : sines and cosines of euler angles
  ! Output: SMAT of type MATRIX
  !
  ! Ref: Section 2.3 Eq. 24/25 Hughes
  !--------------------------------------------------------------------!

  pure function get_angrate_from_cosines(c1,c2,c3,s1,s2,s3) result(SMAT)

    real(dp), intent(in) :: c1, c2, c3, s1, s2, s3
    type(matrix)         :: SMAT

    SMAT = matrix((/ 1.0_dp, 0.0_dp, -s2, &
         & 0.0_dp,  c1,  s1*c2, &
         & 0.0_dp,  -s1,  c1*c2 /))

  end function get_angrate_from_cosines

  !--------------------------------------------------------------------!
  ! Returns the time derivative of angular rate matrix
  !
  ! we use the 3-2-1 Euler angles, the S matrix does not depend
  ! on c3/s3, however we keep these as inputs in case we ever
  ! want to change the Euler sequence.
  !
  ! Input : the euler angles and time derivatives as VECTOR
  ! Output: SDOT
  !--------------------------------------------------------------------!

  pure function get_angrate_dot_vec(thetain, dthetain) result(SDOT)

    type(vector), intent(in)  :: thetain, dthetain
    type(matrix) :: SDOT

    real(dp)     :: theta(NUM_SPAT_DIM), dtheta(NUM_SPAT_DIM)

    ! convert vec to array
    theta = array(thetain); dtheta=array(dthetain);

    ! call the function matching array signature
    SDOT = get_angrate_dot_array(theta,dtheta)

  end function get_angrate_dot_vec

  !--------------------------------------------------------------------!
  ! Returns the time derivative of angular rate matrix
  !
  ! we use the 3-2-1 Euler angles, the S matrix does not depend
  ! on c3/s3, however we keep these as inputs in case we ever
  ! want to change the Euler sequence.
  !
  ! Input : the euler angles and time derivatives as arrays
  ! Output: SDOT
  !--------------------------------------------------------------------!

  pure function get_angrate_dot_array(theta, dtheta) result(SDOT)

    real(dp), intent(in) :: theta(NUM_SPAT_DIM), dtheta(NUM_SPAT_DIM)
    type(matrix) :: SDOT
    real(dp)     :: c1, c2, c3, s1, s2, s3

    ! Compute the sin/cos of the Euler angles

    c1 = cos(theta(1))
    s1 = sin(theta(1))

    c2 = cos(theta(2))
    s2 = sin(theta(2))

    c3 = cos(theta(3))
    s3 = sin(theta(3))

    SDOT = get_angrate_dot_cosines( c1, c2, c3, s1, s2, s3, dtheta)

  end function get_angrate_dot_array

  !--------------------------------------------------------------------!
  ! Returns the time derivative of angular rate matrix
  !
  ! we use the 3-2-1 Euler angles, the S matrix does not depend
  ! on c3/s3, however we keep these as inputs in case we ever
  ! want to change the Euler sequence.
  !
  ! Input : The sines and cosines of euler angles
  ! Output: SDOT
  !--------------------------------------------------------------------!

  pure function get_angrate_dot_cosines( c1, c2, c3, s1, s2, s3, dtheta) &
       & result(SDOT)

    real(dp), intent(in) :: dtheta(NUM_SPAT_DIM)
    real(dp), intent(in) :: c1, c2, c3, s1, s2, s3
    type(matrix) :: SDOT
    type(matrix) :: TMP(3)

!!$    SDOT= matrix( (/ 0.0_dp,  0.0_dp,  -c2*dtheta(2), &
!!$         & 0.0_dp, -s1*dtheta(1), c1*c2*dtheta(1) - s1*s2*dtheta(2), &
!!$         & 0.0_dp, -c1*dtheta(1), -s1*c2*dtheta(1) - c1*s2*dtheta(2) /))

    TMP(1) = matrix( (/ 0.0_dp,  0.0_dp,  0.0_dp, &
         & 0.0_dp, -s1, c1*c2,&
         & 0.0_dp, -c1, -s1*c2/) )

    TMP(2) = matrix( (/ 0.0_dp,  0.0_dp,  -c2, &
         & 0.0_dp, 0.0_dp, -s1*s2,&
         & 0.0_dp, 0.0_dp, -c1*s2/))

    SDOT = dtheta(1)*TMP(1) + dtheta(2)*TMP(2) + dtheta(3)*TMP(3)

  end function get_angrate_dot_cosines

  !--------------------------------------------------------------------!
  ! Returns the time derivative of the transformation matrix with
  ! respect to the euler angles
  !
  ! we use the 3-2-1 Euler angles, the S matrix does not depend
  ! on c3/s3, however we keep these as inputs in case we ever
  ! want to change the Euler sequence.
  !
  ! Input : The sines and cosines of euler angles
  ! Output: TDOT
  !--------------------------------------------------------------------!

  pure function get_rotation_dot_cosines( c1, c2, c3, s1, s2, s3, dtheta) &
       & result(TDOT)

    real(dp), intent(in) :: dtheta(NUM_SPAT_DIM)
    real(dp), intent(in) :: c1, c2, c3, s1, s2, s3
    type(matrix) :: TDOT, TMP(3)

    TMP(1) = matrix( (/ 0.0_dp, 0.0_dp, 0.0_dp, &
         &  c1*s2*c3 + s1*s3, c1*s2*s3 - s1*c3, c1*c2, &
         & -s1*s2*c3 + c1*s3, -s1*s2*s3 - c1*c3, -s1*c2 /) )

    TMP(2) = matrix( (/ -s2*c3, -s2*s3, -c2, &
         & s1*c2*c3, s1*c2*s3, -s1*s2, &
         & c1*c2*c3, c1*c2*s3, -c1*s2 /))

    TMP(3) = matrix( (/ -c2*s3, c2*c3, 0.0_dp, &
         & -s1*s2*s3 - c1*c3, s1*s2*c3 - c1*s3, 0.0_dp, &
         & -c1*s2*s3 + s1*c3, c1*s2*c3 + s1*s3, 0.0_dp /) )

    TDOT = dtheta(1)*TMP(1) + dtheta(2)*TMP(2) + dtheta(3)*TMP(3)

  end function get_rotation_dot_cosines

  !--------------------------------------------------------------------!
  ! Returns the time derivative of transformation matrix
  !
  ! we use the 3-2-1 Euler angles, the S matrix does not depend
  ! on c3/s3, however we keep these as inputs in case we ever
  ! want to change the Euler sequence.
  !
  ! Input : the euler angles and time derivatives as VECTOR
  ! Output: TDOT
  !--------------------------------------------------------------------!

  pure function get_rotation_dot_vec(thetain, dthetain) result(TDOT)

    type(vector), intent(in)  :: thetain, dthetain
    type(matrix) :: TDOT

    real(dp)     :: theta(NUM_SPAT_DIM), dtheta(NUM_SPAT_DIM)

    ! convert vec to array
    theta = array(thetain); dtheta=array(dthetain);

    ! call the function matching array signature
    TDOT = get_rotation_dot_array(theta,dtheta)

  end function get_rotation_dot_vec

  !--------------------------------------------------------------------!
  ! Returns the time derivative of transformation matrix
  !
  ! we use the 3-2-1 Euler angles, the S matrix does not depend
  ! on c3/s3, however we keep these as inputs in case we ever
  ! want to change the Euler sequence.
  !
  ! Input : the euler angles and time derivatives as arrays
  ! Output: TDOT
  !--------------------------------------------------------------------!

  pure function get_rotation_dot_array(theta, dtheta) result(TDOT)

    real(dp), intent(in) :: theta(NUM_SPAT_DIM), dtheta(NUM_SPAT_DIM)
    type(matrix) :: TDOT
    real(dp)     :: c1, c2, c3, s1, s2, s3

    ! Compute the sin/cos of the Euler angles

    c1 = cos(theta(1))
    s1 = sin(theta(1))

    c2 = cos(theta(2))
    s2 = sin(theta(2))

    c3 = cos(theta(3))
    s3 = sin(theta(3))

    TDOT = get_rotation_dot_cosines( c1, c2, c3, s1, s2, s3, dtheta)

  end function get_rotation_dot_array

  !--------------------------------------------------------------------!
  ! Returns the inverse of the angular rate matrix for the supplied
  ! theta vector
  !--------------------------------------------------------------------!

  pure function get_angrate_inv_vec(thetain) result(SINV)

    type(vector), intent(in) :: thetain
    type(matrix) :: SINV
    real(dp)     :: theta(NUM_SPAT_DIM)

    ! decompose the vector into array
    theta = array(thetain)

    ! call the method that takes array as input
    SINV =  get_angrate_inv_array(theta)

  end function get_angrate_inv_vec

  !--------------------------------------------------------------------!
  ! Returns the inverse of the angular rate matrix for the supplied
  ! theta array
  !--------------------------------------------------------------------!

  pure function get_angrate_inv_array(theta) result(SINV)

    real(dp), intent(in) :: theta(NUM_SPAT_DIM)
    real(dp)     :: c1, c2, c3, s1, s2, s3
    type(matrix) :: SINV

    c1 = cos(theta(1))
    s1 = sin(theta(1))

    c2 = cos(theta(2))
    s2 = sin(theta(2))

    c3 = cos(theta(3))
    s3 = sin(theta(3))

    SINV =  get_angrate_inv_cosines(  c1, c2, c3, s1, s2, s3)

  end function get_angrate_inv_array

  !--------------------------------------------------------------------!
  ! Returns the inverse of the angular rate matrix for the supplied
  ! direction cosines
  !--------------------------------------------------------------------!

  pure function get_angrate_inv_cosines( c1, c2, c3, s1, s2, s3) result(SINV)

    real(dp), intent(in) :: c1, c2, c3, s1, s2, s3
    type(matrix) :: SINV

    SINV = matrix( (/  1.0_dp, s1*s2/c2, c1*s2/c2, &
         & 0.0_dp, c1, -s1, 0.0_dp,&
         & s1/c2, c1/c2 /))

  end function get_angrate_inv_cosines

end module rotation


/* Examples for testing */

 lambda x:A. x;

lambda x:Bool. x;
(lambda x:Bool->Bool. if x false then true else false)
  (lambda x:Bool. if x then false else true);

lambda x:Nat. succ x;
(lambda x:Nat. succ (succ x)) (succ 0);


c     program DRSHINT
c>> 1996-05-28 DRSHINT  Krogh Added external statement.
c>> 1994-10-19 DRSHINT  Krogh  Changes to use M77CON
c>> 1987-12-09 DRSHINT  Lawson  Initial Code.
c--S replaces "?": DR?HINT, ?HINT
c
      integer I, J, NTAB
      real             X, XTAB(3), YTAB(3), YPTAB(3), YINT, YPINT, YTRUE
      external SHINT
      real             SHINT
c
      data XTAB / 0.E0, .5E0, .75E0 /
      data NTAB / 3 /
c
   10 format(1X,'Demonstration of SHINT by interpolating to the',
     *          ' exponential function,'/
     *          1X,'given values at X = 0.0, 0.5, and 0.75'//
     *          4X,'X',7X,'YTRUE',9X,
     *          'YINT',6X,'YINT-YTRUE',5X,'YPINT',6X,'YPINT-YTRUE'/1X)
   20 format(1X,F5.2,5F13.6)
c
      do 30 I = 1,3
        YTAB(I) = EXP(XTAB(I))
        YPTAB(I) = YTAB(I)
   30 continue
c
      print 10
c
      do 50 J = 10, 110, 5
        X = REAL(J)/100.E0 - 0.1E0
        YINT = SHINT(X,0,NTAB,XTAB,YTAB,YPTAB)
        YPINT = SHINT(X,1,NTAB,XTAB,YTAB,YPTAB)
        YTRUE = EXP(X)
        print 20, X, YTRUE, YINT, YINT-YTRUE, YPINT, YPINT-YTRUE
   50 continue
c
      end


PROGRAM LA_ZGESVX_ET_EXAMPLE
!
!  -- LAPACK95 INTERFACE DRIVER ROUTINE (VERSION 3.0) --
!     UNI-C, DENMARK; UNIV. OF TENNESSEE, USA; NAG LTD., UK
!     SEPTEMBER, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
   USE F95_LAPACK, ONLY: LA_GESVX, LA_GETRF
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
   CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F9.3,1H,,F9.3,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: EQUED
   INTEGER :: I, J, INFO, N, NRHS
   REAL(WP) :: RPVGRW, RCOND, BERR1, FERR1
!  .. LOCAL ARRAYS ..
   INTEGER, ALLOCATABLE :: IPIV(:)
   REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:), FERR(:), BERR(:), R(:), C(:)
   COMPLEX(WP), ALLOCATABLE :: A(:,:), B(:,:), AF(:,:), X(:,:), B1(:), X1(:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'GESVX ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N, NRHS
   ALLOCATE ( IPIV(N), A(N,N), B(N,NRHS), AA(N,N), BB(N,NRHS), &
               FERR(NRHS), BERR(NRHS), R(N), C(N), AF(N,N), &
               X(N,NRHS), B1(N), X1(N) )
!
      DO I = 1, N
        READ (NIN, *) (AA(I, J), J = 1, N)
      ENDDO
      DO J = 1, NRHS
         BB(:,J) = SUM( AA, DIM=2)*J
      ENDDO
      A = AA; B = BB
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N
        WRITE (NOUT,FMT) A(I,:)
      ENDDO
      WRITE(NOUT,*) 'The RHS matrix B:'
      DO J = 1, NRHS
        WRITE (NOUT,FMT) B(:,J)
      ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_ZGESVX LAPACK SUBROUTINE Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GESVX( A, B, X )'
   WRITE(NOUT,*) 'ON ENTRY: A, B'
   WRITE(NOUT,*) '   A - the original matrix'
   WRITE(NOUT,*) '   B - the right hand side matrix'
   WRITE(NOUT,*) 'ON EXIT: X'
   A=AA; B=BB
   CALL LA_GESVX( A, B, X )
   WRITE(NOUT,*)'   The solution vectors X computed by LA_GESVX:'
   DO J = 1, NRHS
      WRITE (NOUT,FMT) X(:,J)
   END DO
   A=AA; B=BB
   B1(1:N)=B(1:N,1)
   CALL LA_GESVX( A, B1, X1 )
   WRITE(NOUT,*)'   The solution vector X computed by LA_GESVX:'
   WRITE (NOUT,FMT) X1(:)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) "CALL LA_GESVX(A, B, X, AF, IPIV, FACT='F', TRANS='N')"
   WRITE(NOUT,*) 'ON ENTRY: A, B, AF, IPIV'
   WRITE(NOUT,*) '   A - the original matrix'
   WRITE(NOUT,*) '   B - the right hand side matrix'
   WRITE(NOUT,*) '   AF - the factors L U of matrix A'
   WRITE(NOUT,*) '   IPIV - the pivot'
   WRITE(NOUT,*) 'ON EXIT: X'
   A=AA; B=BB; AF=A
   CALL LA_GETRF(AF, IPIV)
   CALL LA_GESVX(A,B,X,AF,IPIV,FACT='F',TRANS='N')
   WRITE(NOUT,*)'   The solution vectors X computed by LA_GESVX:'
   DO J = 1, NRHS
      WRITE (NOUT,FMT) X(:,J)
   END DO
   A=AA; B=BB; AF=A
   B1(1:N)=B(1:N,1)
   CALL LA_GETRF(AF, IPIV)
   CALL LA_GESVX(A,B(:,1),X(:,1),AF,IPIV,FACT='F',TRANS='N')
   WRITE(NOUT,*)'   The solution vector X computed by LA_GESVX:'
   WRITE (NOUT,FMT) X(:,1)
   A=AA; B=BB; AF=A
   CALL LA_GETRF(AF, IPIV)
   CALL LA_GESVX(A, B, X, AF, IPIV, 'N', 'N', EQUED, &
                    R, C, FERR, BERR, RCOND, RPVGRW, INFO)
   WRITE(NOUT,*)'   The solution vectors X computed by LA_GESVX:'
   DO J = 1, NRHS
      WRITE (NOUT,FMT) X(:,J)
   END DO
   A=AA; B=BB; AF=A
   B1(1:N)=B(1:N,1)
   CALL LA_GETRF(AF, IPIV)
   CALL LA_GESVX( A, B1, X1, AF, IPIV, 'N', 'N', EQUED, &
                     R, C, FERR1, BERR1, RCOND, RPVGRW, INFO )
   WRITE(NOUT,*)'   The solution vector X computed by LA_GESVX:'
   WRITE (NOUT,FMT) X1(:)
!
END PROGRAM LA_ZGESVX_ET_EXAMPLE


module globals

    implicit none
    public

    real(8), parameter      ::  pi = 4.d0*atan(1.d0)
    integer                 ::  Nslips
    real(8)                 ::  factor
    real(8), allocatable    ::  P(:,:), Omega(:,:)

end module globals


! { dg-do run }
! { dg-warning "Loop variable" "Loop" { target *-*-* } 13 }
! { dg-warning "Start expression" "Start" { target *-*-* } 13 }
! { dg-warning "End expression" "End" { target *-*-* } 13 }
! { dg-warning "Step expression" "Step" { target *-*-* } 13 }
! Test REAL type iterators in DO loops
program real_do_1
  real x, y
  integer n

  n = 0
  y = 1.0
  do x = 1.0, 2.05, 0.1
    call check (x, y)
    y = y + 0.1
    n = n + 1
  end do
  if (n .ne. 11) call abort()
contains
subroutine check (a, b)
  real, intent(in) :: a, b

  if (abs (a - b) .gt. 0.00001) call abort()
end subroutine
end program


! { dg-do run }
! NOT() was not return the two's complement value as reported by
! PR fortran/25458.  In checking other bit manipulation intrinsics,
! IBSET was found to be in error.
program chkbits

  implicit none

  integer(kind=1) i1
  integer(kind=2) i2
  integer(kind=4) i4
  integer(kind=8) i8

  i1 = ibset(huge(0_1), bit_size(i1)-1)
  i2 = ibset(huge(0_2), bit_size(i2)-1)
  i4 = ibset(huge(0_4), bit_size(i4)-1)
  i8 = ibset(huge(0_8), bit_size(i8)-1)
  if (i1 /= -1 .or. i2 /= -1 .or. i4 /= -1 .or. i8 /= -1) STOP 1

  i1 = ibclr(-1_1, bit_size(i1)-1)
  i2 = ibclr(-1_2, bit_size(i2)-1)
  i4 = ibclr(-1_4, bit_size(i4)-1)
  i8 = ibclr(-1_8, bit_size(i8)-1)
  if (i1 /= huge(0_1) .or. i2 /= huge(0_2)) STOP 2
  if (i4 /= huge(0_4) .or. i8 /= huge(0_8)) STOP 3

  i1 = not(0_1)
  i2 = not(0_2)
  i4 = not(0_4)
  i8 = not(0_8)
  if (i1 /= -1 .or. i2 /= -1 .or. i4 /= -1 .or. i8 /= -1) STOP 4

end program chkbits


! { dg-do run }
! Progam to test the dfloat intrinsic.
program dfloat_1
   implicit none
   integer(2) i2
   integer(4) i4
   integer(8) i8
   i2 = -4_2
   i4 = 4_4
   i8 = 10_8
   if (dfloat(i2) /= -4.d0) STOP 1       ! { dg-warning "non-default INTEGER" }
   if (dfloat(i4) /= 4.d0) STOP 2
   if (dfloat(i8) /= 10.d0) STOP 3       ! { dg-warning "non-default INTEGER" }
   if (dfloat(i4*i2) /= -16.d0) STOP 4

   if (kind(dfloat(i4)) /= kind(1.0_8)) STOP 1
   if (kind(dfloat(i8)) /= kind(1.0_8)) STOP 2! { dg-warning "non-default INTEGER" }
end program dfloat_1


! { dg-do run }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } { "*" } { "" } }
!
! List-directed part of PR fortran/43298
! and follow up to PR fortran/34319.
!
! Check handling of "NAN(alphanum)"
!
character(len=200) :: str
real :: r
complex :: z

! read_real:

r = 1.0
str = 'INfinity' ; read(str,*) r
if (r < 0 .or. r /= r*1.1) call abort()

r = 1.0
str = '-INF' ; read(str,*) r
if (r > 0 .or. r /= r*1.1) call abort()

r = 1.0
str = '+INF' ; read(str,*) r
if (r < 0 .or. r /= r*1.1) call abort()

r = 1.0
str = '-inFiniTY' ; read(str,*) r
if (r > 0 .or. r /= r*1.1) call abort()

r = 1.0
str = 'NAN' ; read(str,*) r
if (.not. isnan(r)) call abort()

r = 1.0
str = '-NAN' ; read(str,*) r
if (.not. isnan(r)) call abort()

r = 1.0
str = '+NAN' ; read(str,*) r
if (.not. isnan(r)) call abort()

r = 1.0
str = 'NAN(0x111)' ; read(str,*) r
if (.not. isnan(r)) call abort()

r = 1.0
str = '-NAN(123)' ; read(str,*) r
if (.not. isnan(r)) call abort()

r = 1.0
str = '+NAN(0xFFE)' ; read(str,*) r
if (.not. isnan(r)) call abort()

! parse_real

z = cmplx(-2.0,-4.0)
str = '(0.0,INfinity)' ; read(str,*) z
if (aimag(z) < 0 .or. aimag(z) /= aimag(z)*1.1) call abort()

z = cmplx(-2.0,-4.0)
str = '(-INF,0.0)' ; read(str,*) z
if (real(z) > 0 .or. real(z) /= real(z)*1.1) call abort()

z = cmplx(-2.0,-4.0)
str = '(0.0,+INF)' ; read(str,*) z
if (aimag(z) < 0 .or. aimag(z) /= aimag(z)*1.1) call abort()

z = cmplx(-2.0,-4.0)
str = '(-inFiniTY,0.0)' ; read(str,*) z
if (real(z) > 0 .or. real(z) /= real(z)*1.1) call abort()

z = cmplx(-2.0,-4.0)
str = '(NAN,0.0)' ; read(str,*) z
if (.not. isnan(real(z))) call abort()

z = cmplx(-2.0,-4.0)
str = '(0.0,-NAN)' ; read(str,*) z
if (.not. isnan(aimag(z))) call abort()

z = cmplx(-2.0,-4.0)
str = '(+NAN,0.0)' ; read(str,*) z
if (.not. isnan(real(z))) call abort()

z = cmplx(-2.0,-4.0)
str = '(NAN(0x111),0.0)' ; read(str,*) z
if (.not. isnan(real(z))) call abort()

z = cmplx(-2.0,-4.0)
str = '(0.0,-NaN(123))' ; read(str,*) z
if (.not. isnan(aimag(z))) call abort()

z = cmplx(-2.0,-4.0)
str = '(+nan(0xFFE),0.0)' ; read(str,*) z
if (.not. isnan(real(z))) call abort()

end


module trapezoidal_channel

    use define_settings, only: setting
    use define_globals
    use define_indexes
    use define_keys

    implicit none

    !%-----------------------------------------------------------------------------
    !% Description:
    !% Trapezoidal channel geometry
    !%

    private

    public :: trapezoidal_depth_from_volume
    public :: trapezoidal_area_from_depth
    public :: trapezoidal_area_from_depth_singular
    public :: trapezoidal_topwidth_from_depth
    public :: trapezoidal_topwidth_from_depth_singular
    public :: trapezoidal_perimeter_from_depth
    public :: trapezoidal_perimeter_from_depth_singular
    public :: trapezoidal_hyddepth_from_depth
    public :: trapezoidal_hyddepth_from_depth_singular
    public :: trapezoidal_hydradius_from_depth_singular

    contains
!%==========================================================================
!% PUBLIC
!%==========================================================================
!%
    subroutine trapezoidal_depth_from_volume (elemPGx, Npack, thisCol)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Only applies on open channels (or non-surcharged trapezoidal conduits)
        !% Input elemPGx is pointer (already assigned) for elemPGalltm, elemPGetm or elemPGac
        !% Assumes that volume > 0 is enforced in volume computations.
        !% NOTE: this does NOT limit the depth by surcharge height at this point
        !% This will be done after the head is computed.
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:), Npack, thisCol
        integer, pointer :: thisP(:)
        real(8), pointer :: depth(:), volume(:), length(:), breadth(:)
        real(8), pointer :: lslope(:), rslope(:)
        !%-----------------------------------------------------------------------------
        thisP   => elemPGx(1:Npack,thisCol)
        depth   => elemR(:,er_Depth)
        volume  => elemR(:,er_Volume)
        length  => elemR(:,er_Length)
        breadth => elemSGR(:,esgr_Trapezoidal_Breadth)
        lslope  => elemSGR(:,esgr_Trapezoidal_LeftSlope)
        rslope  => elemSGR(:,esgr_Trapezoidal_RightSlope)
        !%-----------------------------------------------------------------------------

        depth(thisP)       = - onehalfR * (breadth(thisP)/(onehalfR*(lslope(thisP) + rslope(thisP))) &
                - sqrt((breadth(thisP)/(onehalfR*(lslope(thisP) + rslope(thisP)))) ** twoR &
                + fourR * volume(thisP)/(onehalfR*length(thisP)*(lslope(thisP) + rslope(thisP)))))

    end subroutine trapezoidal_depth_from_volume
!%
!%==========================================================================
!%==========================================================================
!%
    elemental real(8) function trapezoidal_area_from_depth (indx) result (outvalue)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes area from known depth for trapezoidal cross section
        !% input may be a scalar or a packed array of indexes
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        !%-----------------------------------------------------------------------------
        outvalue = (elemSGR(indx,esgr_Trapezoidal_Breadth)                        &
                        + onehalfR * (  elemSGR(indx,esgr_Trapezoidal_LeftSlope)  &
                                      + elemSGR(indx,esgr_Trapezoidal_RightSlope) &
                                     ) * elemR(indx,er_Depth)                     &
                    ) * elemR(indx,er_Depth)

    end function trapezoidal_area_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function trapezoidal_area_from_depth_singular (indx) result (outvalue)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes area from known depth for trapezoidal cross section of a single element
        !% The input indx is the row index in full data 2D array.
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), breadth(:), lslope(:), rslope(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        breadth => elemSGR(:,esgr_Trapezoidal_Breadth)
        lslope  => elemSGR(:,esgr_Trapezoidal_LeftSlope)
        rslope  => elemSGR(:,esgr_Trapezoidal_RightSlope)
        !%-----------------------------------------------------------------------------
        outvalue = (breadth(indx) + onehalfR * (lslope(indx) + rslope(indx)) * depth(indx)) * depth(indx)

    end function trapezoidal_area_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine trapezoidal_topwidth_from_depth (elemPGx, Npack, thisCol)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the topwidth from a known depth in a rectangular channel
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:)
        integer, intent(in) ::  Npack, thisCol
        integer, pointer :: thisP(:)
        real(8), pointer :: topwidth(:), depth(:), breadth(:), lslope(:), rslope(:)
        !%-----------------------------------------------------------------------------
        thisP    => elemPGx(1:Npack,thisCol)
        topwidth => elemR(:,er_Topwidth)
        depth    => elemR(:,er_Depth)
        breadth  => elemSGR(:,esgr_Trapezoidal_Breadth)
        lslope   => elemSGR(:,esgr_Trapezoidal_LeftSlope)
        rslope   => elemSGR(:,esgr_Trapezoidal_RightSlope)
        !%-----------------------------------------------------------------------------

        topwidth(thisP) = breadth(thisP) + depth(thisP) * (lslope(thisP) + rslope(thisP))

    end subroutine trapezoidal_topwidth_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function trapezoidal_topwidth_from_depth_singular (indx) result (outvalue)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the topwidth for a trapezoidal cross section of a single element
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), breadth(:), lslope(:), rslope(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        breadth => elemSGR(:,esgr_Trapezoidal_Breadth)
        lslope  => elemSGR(:,esgr_Trapezoidal_LeftSlope)
        rslope  => elemSGR(:,esgr_Trapezoidal_RightSlope)
        !%-----------------------------------------------------------------------------
        outvalue = breadth(indx) + depth(indx) * (lslope(indx) + rslope(indx))

    end function trapezoidal_topwidth_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine trapezoidal_perimeter_from_depth (elemPGx, Npack, thisCol)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the perimeter from a known depth in a trapezoidal channel
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:)
        integer, intent(in) ::  Npack, thisCol
        integer, pointer :: thisP(:)
        real(8), pointer :: perimeter(:), depth(:), breadth(:), lslope(:), rslope(:)
        !%-----------------------------------------------------------------------------
        thisP     => elemPGx(1:Npack,thisCol)
        perimeter => elemR(:,er_Perimeter)
        depth     => elemR(:,er_Depth)
        breadth   => elemSGR(:,esgr_Trapezoidal_Breadth)
        lslope    => elemSGR(:,esgr_Trapezoidal_LeftSlope)
        rslope    => elemSGR(:,esgr_Trapezoidal_RightSlope)
        !%-----------------------------------------------------------------------------

        perimeter(thisP) = breadth(thisP) + depth(thisP) * (sqrt(oneR + lslope(thisP)**twoR) &
                        + sqrt(oneR + rslope(thisP)**twoR))

    end subroutine trapezoidal_perimeter_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function trapezoidal_perimeter_from_depth_singular (indx) result (outvalue)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes wetted perimeter from known depth for a trapezoidal cross section of
        !% a single element
        !%-----------------------------------------------------------------------------
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), breadth(:), lslope(:), rslope(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        breadth => elemSGR(:,esgr_Trapezoidal_Breadth)
        lslope  => elemSGR(:,esgr_Trapezoidal_LeftSlope)
        rslope  => elemSGR(:,esgr_Trapezoidal_RightSlope)
        !%-----------------------------------------------------------------------------

        outvalue =  breadth(indx) + depth(indx) * (sqrt(oneR + lslope(indx)**twoR) + &
                    sqrt(oneR + rslope(indx)**twoR))

    end function trapezoidal_perimeter_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine trapezoidal_hyddepth_from_depth (elemPGx, Npack, thisCol)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the hydraulic (average) depth from a known depth in a rectangular channel
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:)
        integer, intent(in) ::  Npack, thisCol
        integer, pointer :: thisP(:)
        real(8), pointer :: hyddepth(:), depth(:), breadth(:), lslope(:), rslope(:)
        !%-----------------------------------------------------------------------------
        thisP     => elemPGx(1:Npack,thisCol)
        hyddepth  => elemR(:,er_HydDepth)
        depth   => elemR(:,er_Depth)
        breadth => elemSGR(:,esgr_Trapezoidal_Breadth)
        lslope  => elemSGR(:,esgr_Trapezoidal_LeftSlope)
        rslope  => elemSGR(:,esgr_Trapezoidal_RightSlope)
        !%-----------------------------------------------------------------------------

        hyddepth(thisP) = ((breadth(thisP) + onehalfR * (lslope(thisP) + rslope(thisP)) * &
                    depth(thisP)) * depth(thisP)) / (breadth(thisP) + depth(thisP) * &
                    (lslope(thisP) + rslope(thisP)))

    end subroutine trapezoidal_hyddepth_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function trapezoidal_hyddepth_from_depth_singular (indx) result (outvalue)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes hydraulic depth from known depth for trapezoidal cross section of
        !% a single element
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), breadth(:), lslope(:), rslope(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        breadth => elemSGR(:,esgr_Trapezoidal_Breadth)
        lslope  => elemSGR(:,esgr_Trapezoidal_LeftSlope)
        rslope  => elemSGR(:,esgr_Trapezoidal_RightSlope)
        !%-----------------------------------------------------------------------------

        outvalue = ((breadth(indx) + onehalfR * (lslope(indx) + rslope(indx)) * &
                    depth(indx)) * depth(indx)) / (breadth(indx) + depth(indx) * &
                    (lslope(indx) + rslope(indx)))

    end function trapezoidal_hyddepth_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function trapezoidal_hydradius_from_depth_singular (indx) result (outvalue)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes hydraulic radius from known depth for a trapezoidal cross section of
        !% a single element
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), breadth(:), lslope(:), rslope(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        breadth => elemSGR(:,esgr_Trapezoidal_Breadth)
        lslope  => elemSGR(:,esgr_Trapezoidal_LeftSlope)
        rslope  => elemSGR(:,esgr_Trapezoidal_RightSlope)
        !%-----------------------------------------------------------------------------

        outvalue = ((breadth(indx) + onehalfR * (lslope(indx) + rslope(indx)) *  &
                    depth(indx)) * depth(indx)) / (breadth(indx) + depth(indx) * &
                    (sqrt(oneR + lslope(indx)**twoR) + sqrt(oneR + rslope(indx)**twoR)))

    end function trapezoidal_hydradius_from_depth_singular
!%
!%==========================================================================

!%
!%
!%==========================================================================
!%==========================================================================
!%
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !%
        !%-----------------------------------------------------------------------------

        !%-----------------------------------------------------------------------------
        !%
!%
!%
!%==========================================================================
!%==========================================================================
!%
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !%
        !%-----------------------------------------------------------------------------

        !%-----------------------------------------------------------------------------
        !%
!%
!%
!%==========================================================================
!%==========================================================================
!%
        !%
        !%------------------------------------------------------------------
        !% Description:
        !%
        !%------------------------------------------------------------------

        !%------------------------------------------------------------------
        !%
end module trapezoidal_channel