program P18868
    implicit none
    integer :: n_space, n_planet, i, j, k, l, count
    integer, dimension(10, 100) :: sizes
    logical :: success
    read *, n_space, n_planet
    do i = 1, n_space
        read *, (sizes(i, j), j = 1, n_planet)
    end do
    count = 0
    do i = 2, n_space
        do j = 1, i - 1
            success = .true.
            do k = 2, n_planet
                do l = 1, k - 1
                    if (sizes(i, l) < sizes(i, k) .and. sizes(j, l) >= sizes(j, k)) then
                        success = .false.
                        exit
                    else if (sizes(i, l) == sizes(i, k) .and. sizes(j, l) /= sizes(j, k)) then
                        success = .false.
                        exit
                    else if (sizes(i, l) > sizes(i, k) .and. sizes(j, l) <= sizes(j, k)) then
                        success = .false.
                        exit
                    end if
                end do
                if (.not. success) then
                    exit
                end if
            end do
            if (success) then
                count = count + 1
            end if
        end do
    end do
    write (*, '(I0)') count
end program P18868


!!# MODULE: SUBROUTINE <<SUB_levQuadrature>>
MODULE SUB_levQuadrature

!!## PURPOSE
!! Return a product quadrature set on the unit
!! sphere (each polar angle (from z-axis) has the same set of
!! azimuthal angles (angles in xy-plane).

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

!!## EXTERNAL PARAMETERS
USE PAR_Constants_Rdp,ONLY: c_2                !!((02-A-PAR_Constants_Rdp.f90))

!!## EXTERNAL PROCEDURES
USE SUB_CLEAR                                  !!((04-A-SUB_CLEAR.f90))
USE FUN_Error                                  !!((04-A-FUN_Error.f90))
USE SUB_levQuadrature_LMLQ                     !!((08-B-SUB_levQuadrature_LMLQ.f90))
USE FUN_IsError                                !!((05-A-FUN_IsError.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE LISTING
INTERFACE levQuadrature
 MODULE PROCEDURE levQuadrature_Rsp
 MODULE PROCEDURE levQuadrature_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: levQuadrature

!!## MODULE PROCEDURES
CONTAINS

!!### PURE SUBROUTINE: levQuadrature_Rsp
PURE SUBROUTINE levQuadrature_Rsp( Quadrature , aOrder , pOrder , &
                                   xa , xp , wa , wp , &
                                   errint , errmsg , &
                                   UniformZGeometry )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "09-B-SUB_levQuadrature.f90.hdr"
!!--begin--
INCLUDE "09-B-SUB_levQuadrature.f90.bdy"
!!--end--
END SUBROUTINE

!!### PURE SUBROUTINE: levQuadrature_Rdp
PURE SUBROUTINE levQuadrature_Rdp( Quadrature , aOrder , pOrder , &
                                   xa , xp , wa , wp , &
                                   errint , errmsg , &
                                                                   UniformZGeometry )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "09-B-SUB_levQuadrature.f90.hdr"
!!--begin--
INCLUDE "09-B-SUB_levQuadrature.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE


!
!     Copyright (c) 2017, NVIDIA CORPORATION.  All rights reserved.
!
! NVIDIA CORPORATION and its licensors retain all intellectual property
! and proprietary rights in and to this software, related documentation
! and any modifications thereto.
!
!
!    These example codes are a portion of the code samples from the companion
!    website to the book "CUDA Fortran for Scientists and Engineers":
!
! http://store.elsevier.com/product.jsp?isbn=9780124169708
!

program test_accuracy
  real :: x, y, dist
  double precision:: x_dp, y_dp, dist_dp

  x=Z'3F1DC57A'
  y=Z'3F499AA3'
  dist= x**2 +y**2

  x_dp=real(x,8)
  y_dp=real(y,8)
  dist_dp= x_dp**2 +y_dp**2

  print *, 'Result with operands in single precision:'
  print '((2x,z8)) ', dist

  print *, 'Result in double precision with operands'
  print *, 'promoted to double precision:'
  print '((2x,z16))', dist_dp

  print *, 'Result in single precision with operands'
  print *, 'promoted to double precision:'
  print '((2x,z8))', real(dist_dp,4)

end program test_accuracy


      SUBROUTINE LFIT(X,Y,SIG,NDATA,A,MA,LISTA,MFIT,COVAR,NCVM,CHISQ,
     *FUNCS)
      PARAMETER (MMAX=50)
      DIMENSION X(NDATA),Y(NDATA),SIG(NDATA),A(MA),LISTA(MA),
     *    COVAR(NCVM,NCVM),BETA(MMAX),AFUNC(MMAX)
      KK=MFIT+1
      DO 12 J=1,MA
        IHIT=0
        DO 11 K=1,MFIT
          IF (LISTA(K).EQ.J) IHIT=IHIT+1
11      CONTINUE
        IF (IHIT.EQ.0) THEN
          LISTA(KK)=J
          KK=KK+1
        ELSE IF (IHIT.GT.1) THEN
          PAUSE 'Improper set in LISTA'
        ENDIF
12    CONTINUE
      IF (KK.NE.(MA+1)) PAUSE 'Improper set in LISTA'
      DO 14 J=1,MFIT
        DO 13 K=1,MFIT
          COVAR(J,K)=0.
13      CONTINUE
        BETA(J)=0.
14    CONTINUE
      DO 18 I=1,NDATA
        CALL FUNCS(X(I),AFUNC,MA)
        YM=Y(I)
        IF(MFIT.LT.MA) THEN
          DO 15 J=MFIT+1,MA
            YM=YM-A(LISTA(J))*AFUNC(LISTA(J))
15        CONTINUE
        ENDIF
        SIG2I=1./SIG(I)**2
        DO 17 J=1,MFIT
          WT=AFUNC(LISTA(J))*SIG2I
          DO 16 K=1,J
            COVAR(J,K)=COVAR(J,K)+WT*AFUNC(LISTA(K))
16        CONTINUE
          BETA(J)=BETA(J)+YM*WT
17      CONTINUE
18    CONTINUE
      IF (MFIT.GT.1) THEN
        DO 21 J=2,MFIT
          DO 19 K=1,J-1
            COVAR(K,J)=COVAR(J,K)
19        CONTINUE
21      CONTINUE
      ENDIF
      CALL GAUSSJ(COVAR,MFIT,NCVM,BETA,1,1)
      DO 22 J=1,MFIT
        A(LISTA(J))=BETA(J)
22    CONTINUE
      CHISQ=0.
      DO 24 I=1,NDATA
        CALL FUNCS(X(I),AFUNC,MA)
        SUM=0.
        DO 23 J=1,MA
          SUM=SUM+A(J)*AFUNC(J)
23      CONTINUE
        CHISQ=CHISQ+((Y(I)-SUM)/SIG(I))**2
24    CONTINUE
      CALL COVSRT(COVAR,NCVM,MA,LISTA,MFIT)
      RETURN
      END


*=======================================================================
*
* PGSBOX 4.24 - draw curvilinear coordinate axes for PGPLOT.
* Copyright (C) 1997-2014, Mark Calabretta
*
* This file is part of PGSBOX.
*
* PGSBOX is free software: you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* PGSBOX is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with PGSBOX.  If not, see http://www.gnu.org/licenses.
*
* Direct correspondence concerning PGSBOX to mark@calabretta.id.au
*
* Author: Mark Calabretta, Australia Telescope National Facility, CSIRO.
* http://www.atnf.csiro.au/people/Mark.Calabretta
* $Id: pgcrfn.f,v 4.24 2014/09/18 15:25:02 mcalabre Exp $
*=======================================================================
*
* PGCRFN defines separable pairs of non-linear coordinate systems for
* PGSBOX.
*
* Given:
*   OPCODE    I         Transformation code:
*                         +2: Compute a set of pixel coordinates that
*                             describe a path between this and the
*                             previous pair of world coordinates
*                             remembered from the last call with
*                             OPCODE = +1 or +2.
*                         +1: Compute pixel coordinates from world
*                             coordinates.
*                          0: Initialize.
*                         -1: Compute world coordinates from pixel
*                             coordinates.
*
*   NLC       I         Number of elements in FCODE (=8).
*
*   NLI       I         Number of elements in NLIPRM (=2).
*
*   NLD       I         Number of elements in NLDPRM.
*
*   FCODE     C(NLC)*1  Character array (contains the CTYPE array,
*                       see below).
*
* Given and/or returned:
*   NLIPRM    I(NLI)    Integer coefficients (see below).
*
*   NLDPRM    D(2,NLD)  Double precision coefficients (see below).
*
*   WORLD     D(2)      World coordinates.
*                       Given if OPCODE > 0, returned if OPCODE < 0.
*
*   PIXEL     D(2)      Pixel coordinates.
*                       Given if OPCODE < 0, returned if OPCODE > 0.
*
*   CONTRL    I         Control flag for OPCODE = +2 (ignored, always
*                       set to 0 on return).
*
*   CONTXT    D(20)     Context elements (ignored).
*
* Returned:
*   IERR      I         Status return value:
*                         0: Success.
*                         1: Invalid parameters.
*                         2: Invalid world coordinate.
*                         3: Invalid pixel coordinate.
*
* Notes:
*   PGCRFN assumes a simple 2-D image.  The FCODE array contains
*   two four-character mnemonics that select function types:
*
*     "Lin "   Linear
*     "Log "   Logarithmic
*     "Pow "   Power law
*
*   The first two elements of NLIPRM are set on initialization to
*   offsets used by computed GO TOs for each function type.
*
*   Note that PGCRFN treats NLDPRM as an array of dimension two.
*   The NLDPRM are used as follows:
*
*     Type   WORLD(J) =
*      Lin     NLDPRM(J,3) + S
*      Log     NLDPRM(J,3) * LOG10(S)
*      Pow     (NLDPRM(J,3) + S)**NLDPRM(J,4)
*
*   Where in each case S = NLDPRM(J,2)*(PIXEL(J) - NLDPRM(J,1))
*
*=======================================================================
      SUBROUTINE PGCRFN (OPCODE, NLC, NLI, NLD, FCODE, NLIPRM, NLDPRM,
     :   WORLD, PIXEL, CONTRL, CONTXT, IERR)
*-----------------------------------------------------------------------
      INTEGER   CONTRL, IERR, J, NLC, NLD, NLI, OPCODE, NLIPRM(NLI)
      DOUBLE PRECISION CONTXT(20), NLDPRM(2,NLD), PIXEL(2), S, WORLD(2)
      CHARACTER FCODE(2)*4, FCODES*20

      DATA FCODES(1:20)  /'Lin Log Pow         '/
*-----------------------------------------------------------------------
      IERR = 0

      IF (OPCODE.GT.0) THEN
*       Compute pixel coordinates from world coordinates.
        DO 200 J = 1, 2
          GO TO (110, 120, 130) NLIPRM(J)
          IERR = 1
          RETURN

*         Linear.
 110      S = WORLD(J) - NLDPRM(J,3)
          GO TO 190

*         Logarithmic to base 10.
 120      S = 10D0**(WORLD(J)/NLDPRM(J,3))
          GO TO 190

*         Power.
 130      S = WORLD(J)**(1D0/NLDPRM(J,4)) - NLDPRM(J,3)

 190      PIXEL(J) = NLDPRM(J,1) + S/NLDPRM(J,2)
 200    CONTINUE

        CONTRL = 0

      ELSE IF (OPCODE.EQ.0) THEN
*       Initialize.
        IF (NLC.LT.8 .OR. NLI.LT.2 .OR. NLD.LT.3) THEN
          IERR = 1
          RETURN
        END IF

*       Compute pointers.
        NLIPRM(1) = (INDEX(FCODES,FCODE(1)) + 3)/4
        NLIPRM(2) = (INDEX(FCODES,FCODE(2)) + 3)/4
        IF (NLIPRM(1).EQ.0 .OR. NLIPRM(2).EQ.0) THEN
          IERR = 1
          RETURN
        END IF

        CONTRL = 0

      ELSE IF (OPCODE.EQ.-1) THEN
*       Compute world coordinates from pixel coordinates.
        DO 300 J = 1, 2
          S = NLDPRM(J,2)*(PIXEL(J) - NLDPRM(J,1))

          GO TO (210, 220, 230) NLIPRM(J)
          IERR = 1
          RETURN

*         Linear.
 210      WORLD(J) = NLDPRM(J,3) + S
          GO TO 300

*         Logarithmic to base 10.
 220      IF (S.LE.0D0) THEN
            IERR = 1
            RETURN
          END IF
          WORLD(J) = NLDPRM(J,3)*LOG10(S)
          GO TO 300

*         Power.
 230      S = S + NLDPRM(J,3)
          IF (S.LE.0D0 .AND. MOD(NLDPRM(J,4),1D0).NE.0D0) THEN
            IERR = 1
            RETURN
          END IF
          WORLD(J) = S**NLDPRM(J,4)
 300    CONTINUE

      ELSE
        IERR = 1
      END IF

      RETURN
      END


C * * * * * * * * * * * * * * * * * * * * * * * * *
C --- DRIVER FOR RADAU5 ON E5 PROBLEM
C * * * * * * * * * * * * * * * * * * * * * * * * *
        IMPLICIT REAL*8 (A-H,O-Z)
C --- PARAMETERS FOR RADAU5 (FULL JACOBIAN)
        PARAMETER (ND=4,LWORK=4*ND*ND+12*ND+20,LIWORK=3*ND+20)
        DIMENSION Y(ND),WORK(LWORK),IWORK(LIWORK),ISTAT(20)
C -------- END PARAMETER LIST --------
        REAL*4 TARRAY(2),TRESULT
        EXTERNAL FE5,JE5,SOLOUT
c ------ FILE DE DONNEES ----------
        OPEN(8,FILE='res_rad5')
        REWIND 8
C --- LOOP FOR DIFFERENT TOLERANCES
        NTOLMN=2
        NTOLMX=10
        NTOLDF=4
        NRLOOP=(NTOLMX-NTOLMN)*NTOLDF+1
        TOLST=0.1D0**NTOLMN
        TOLFC=0.1D0**(1.D0/NTOLDF)
        DO 30 NTOL=1,NRLOOP
C --- DIMENSION OF THE SYSTEM
        N=4
C --- COMPUTE THE JACOBIAN ANALYTICALLY
        IJAC=1
C --- JACOBIAN IS A FULL MATRIX
        MLJAC=N
C --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
        IMAS=0
C --- OUTPUT ROUTINE IS NOT USED DURING INTEGRATION
        IOUT=0
C --- INITIAL VALUES
        X=0.0D0
        Y(1)=1.76D-3
        Y(2)=0.0D0
        Y(3)=0.0D0
        Y(4)=0.0D0
C --- REQUIRED TOLERANCE
        RTOL=TOLST
        ATOL=1.7D-24
        ITOL=0
C --- INITIAL STEP SIZE
        H=1.0D-6
C --- SET DEFAULT VALUES
        DO I=1,20
           WORK(I)=0.D0
           IWORK(I)=0
           ISTAT(I)=0
        END DO
C --- ENDPOINT OF INTEGRATION
        XEND=10.0D0
        CALL DTIME(TARRAY,TRESULT)
        DO 20 I=1,7
C --- CALL OF THE SUBROUTINE RADAU5
        CALL RADAU5(N,FE5,X,Y,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  JE5,IJAC,MLJAC,MUJAC,
     &                  FE5,IMAS,MLMAS,MUMAS,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C --- PRINT SOLUTION
        WRITE (8,*) Y(1)
        WRITE (8,*) Y(2)
        WRITE (8,*) Y(3)
        WRITE (8,*) Y(4)
c         write (6,*) y(2), y(3)+y(4)
C --- PRINT STATISTICS
         DO J=14,20
            ISTAT(J)=ISTAT(J)+IWORK(J)
         END DO
 20     XEND=XEND*100.D0
        CALL DTIME(TARRAY,TRESULT)
        WRITE(8,*)TARRAY(1)
        WRITE (8,*)(ISTAT(J),J=14,20)
        WRITE(6,*)' ***** TOL=',RTOL,'  ELAPSED TIME=',TARRAY(1),' ****'
        WRITE (6,91) (ISTAT(J),J=14,20)
 91     FORMAT(' fcn=',I5,' jac=',I4,' step=',I4,
     &        ' accpt=',I4,' rejct=',I3,' dec=',I4,
     &        ' sol=',I5)
C -------- NEW TOLERANCE ---
        TOLST=TOLST*TOLFC
 30     CONTINUE
        STOP
        END
C
        SUBROUTINE SOLOUT (NR,XOLD,X,Y,CONT,LRC,N,RPAR,IPAR,IRTRN)
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),CONT(LRC)
           WRITE (6,99) X,Y(1),Y(2),Y(3),NR-1
 99     FORMAT(1X,'X =',F5.2,'    Y =',3E18.10,'    NSTEP =',I4)
        RETURN
        END


program test_ising2d_equal_orderparams
  use, intrinsic :: iso_fortran_env
  use builtin_rand_m
  use ising2d_m
  implicit none
  type(Ising2d)              :: system
  type(builtin_rand_wrapper) :: rng
  real(real64)               :: magne, energy
  real(real64)               :: magne_calc, energy_calc

  system = Ising2d(2.269_rkind, 101, 100)
  call rng%set_seed(42)

  call system%set_updater("Metropolis")
  call system%set_order_spin()
  call system%set_kbt(0.1_rkind)

  call system%update_one_mcs(rng)

  call calc_magne_and_energy(system, magne_calc, energy_calc)
  !> check calc_magne_and_energy == system%mange()m system%energy().
  if (abs(magne_calc-system%magne()) > epsilon) then
     write(error_unit, '(es30.15, a, es30.15)') magne, "/=", system%magne()
     call util_error_stop("magne /= s%m()"&
          , __LINE__, __FILE__)
  end if
  if (abs(energy_calc-system%energy()) > epsilon) then
     write(error_unit, '(es30.15, a, es30.15)') energy_calc, "/=", system%energy()
     call util_error_stop("energy /= s%e()"&
          , __LINE__, __FILE__)
  end if

contains

end program test_ising2d_equal_orderparams


module test_module
  use constants
  use szelliptic
  use szlocal
  use szfuncs
  implicit none

contains

    subroutine test_get_k
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ! Compute the age of the universe two ways: !
        ! (i) carlson symmetric forms               !
        ! (ii) splines                              !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        use cosmo_params, only : ct2
        implicit none
        real(dp) :: r,k,f,fint,p,q,ul,kint,err1
        complex(dp), dimension(3) :: rts
        type(szshell) :: shell
        integer i
        open(unit=3,file='k.txt',form='formatted',status='replace')
        write(3,fmt=*) 'reference (correct) t_age [Mpc]: ', ct2
        write(3,fmt='(9X,A,6X,A,7X,A,3X,A)') &
                'r', 'k(carlson)', 'k(spline)', 'rel. error'
        do i=0,40
            r=1._dp + (200._dp-1._dp)/40 * i
            ul=r
            !new method (carlson)
            call init_shell(r,shell)
            f=sqrt(C0)*szellip_1111(shell%szc,ul)
            !NB. last saved roots does not necessarily
            !correspond to the output of zbrent
            k=get_k(r)

            !spline method
            if (allocated(kspl%ddf)) then
                call splint(kspl%x,kspl%f,kspl%ddf,kspl%n,r,kint)
                p=-kint/OH2
                q=2._dp*Mfunc(r)/OH2
                call fcubic_roots(p,q,rts)
                fint=sqrt(C0)*szellip_1111(rts,ul)
                err1=abs(1._dp-fint/f)
            end if
            write(3,fmt='(f10.4,2f16.9,E13.3)') r, f, fint, err1
        end do
        close(3)
    end subroutine test_get_k

    subroutine test_get_R
        implicit none
        type(szlocal_class) :: szloc
        real(dp) :: t,r
        integer i
        t=-40._dp
        write(*,*) 'Fix t =', t, ', vary r'
        do i=0,40
            r=1._dp + (200._dp-1._dp)/40 * i
            szloc=init_szlocal_class(t,r)
            call get_R(szloc)
            write(*,'(f16.9,f16.9)') r,szloc%f%R
        end do
        r=20._dp
        write(*,*) '*********************************'
        write(*,*) 'Fix r =', r, ', vary t'
        do i=0,40
            t=0._dp + (-400._dp)/40 * i
            szloc=init_szlocal_class(t,r)
            call get_R(szloc)
            write(*,'(f16.9,f16.9)') t,szloc%f%R
        end do
    end subroutine test_get_R

    subroutine test_get_kprime
        use utils, only : dfridr
        implicit none
        type(szlocal_class) :: szloc
        real(dp) :: h,err,r,kp,kp1,err1
        integer i
        real(dp), parameter :: t=0._dp
        h = 0.1_dp
        open(unit=13,file='kp.txt',form='formatted',status='replace')
        write(13,'(9X,A,5X,A,7X,A,3X,A)') &
                'r','k''(numerical)','k''(carlson)','rel. error'
        do i=0,40
            r=1._dp+(200._dp-1._dp)/40*i
            kp=dfridr(k_of_r,r,h,err)
            szloc=init_szlocal_class(t,r)
            call get_kprime(szloc)
            err1=abs(1._dp-kp/szloc%f%kp)
            write(13,'(F10.4,E18.8,E18.8,E13.3)') r,kp,szloc%f%kp,err1
        end do
        close(13)
    contains
        real(dp) function k_of_r(r)
            implicit none
            real(dp), intent(in) :: r
            k_of_r=get_k(r)
        end function k_of_r
    end subroutine test_get_kprime

    subroutine test_get_Rprime
        use utils, only : dfridr
        implicit none
        type(szlocal_class) :: szloc
        real(dp) :: t,h,r,err,err1
        real(dp) :: Rprime,Rprime1
        integer i
        h=0.1_dp
        t=-100._dp
        open(unit=11,file='Rp.txt',form='formatted',status='replace')
        write(11,'(9X,A,3X,A,3X,A,3X,A)') &
                'r', 'R''(numerical)', 'R''(carlson)', 'rel. error'
        do i=0,40
            r=1._dp+(200._dp-1._dp)/40*i
            Rprime=dfridr(R_of_r,r,h,err)
            szloc=init_szlocal_class(t,r)
            call get_Rprime(szloc)
            err1=abs(1._dp-Rprime/szloc%f%Rp)
            write(11,fmt='(F10.4,F16.10,F14.10,E13.3)') r, Rprime, Rprime1, err1
        end do
        close(11)
    contains
        real(dp) function R_of_r(r)
            implicit none
            real(dp), intent(in) :: r
            szloc=init_szlocal_class(t,r)
            call get_R(szloc)
            R_of_r=szloc%f%R
        end function R_of_r
    end subroutine test_get_Rprime

    subroutine test_Rdotprime
        use utils, only : dfridr
        implicit none
        type(szlocal_class) :: szloc
        real(dp) :: t,h,r,err,err1
        real(dp) :: Rdp,Rdp1
        integer i
        h=0.1_dp
        t=-100._dp
        open(unit=14,file='Rdp.txt',form='formatted',status='replace')
        write(14,'(9X,A,3X,A,3X,A,3X,A)') &
                'r', 'Rdot''(numerical)', 'Rdot''(carlson)', 'rel. error'
        do i=0,40
            r=1._dp+(200._dp-1._dp)/40*i
            Rdp=dfridr(Rdot_of_r,r,h,err)
            szloc=init_szlocal_class(t,r)
            call get_Rdotprime(szloc)
            err1=abs(1._dp-Rdp/szloc%f%Rdp)
            write(14,'(F10.4,E19.8,E17.8,E13.3)') r, Rdp, Rdp1, err1
        end do
        close(14)
    contains
        real(dp) function Rdot_of_r(r)
            real(dp), intent(in) :: r
            szloc=init_szlocal_class(t,r)
            call get_Rdot(szloc)
            Rdot_of_r=szloc%f%Rd
        end function Rdot_of_r
    end subroutine test_Rdotprime

    subroutine test_Hubble
        use cosmo_params, only : H0
        implicit none
        type(szlocal_class) :: szloc
        real(dp) :: t,r,H
        integer :: i,j
        open(unit=33,file='H.txt',form='formatted',status='replace')
        write(33,'(A)') 'Hubble function normalised to present H0'
        do i=0,40
            r=1._dp+(200._dp-1._dp)/40*i
            write(33,'(f10.4)',advance='no') r
            do j=0,5
                t=-100._dp/5*j
                szloc=init_szlocal_class(t,r)
                call Hubble(szloc,H)
                write(33,'(f11.6)',advance='no') H/H0
            end do
            write(33,*)
        end do
    end subroutine test_Hubble

    subroutine test_discriminant
        implicit none
        type(szshell) :: shell
        real(dp) :: r,p,q,Dt
        integer i
        open(unit=9,file='discrmt.txt',form='formatted',status='replace')
        write(unit=9,fmt='(9X,A,16X,A,18X,A,7X,A)') 'r','p','q','Discriminant'
        do i=0,40
            r=1._dp+(200._dp-1._dp)/40*i
            call init_shell(r,shell)
            p=shell%szc%p
            q=shell%szc%q
            Dt=-4._dp*p**3-27._dp*q**2
            write(unit=9,fmt='(f10.4,f17.9,f19.9,E19.9)') r,p,q,Dt
        end do
        close(9)
    end subroutine test_discriminant

    subroutine test_p3
        implicit none
        type(szshell) :: shell
        real(dp) :: r
        integer i
        do i=0,40
            r=1._dp+(200._dp-1._dp)/40*i
            call init_shell(r,shell)
            write(*,*) r,shell%szc%p3
        end do
    end subroutine test_p3

    subroutine test_formula_S9
        use utils, only : rd,gaussint
        implicit none
        real(dp), dimension(4) :: a,b !quartic
        real(dp), dimension(:,:), allocatable :: am,bm
        real(dp), dimension(size(a)) :: X,Y
        real(dp), dimension(size(a),size(a)) :: U
        real(dp), dimension(size(a),size(a)) :: d
        real(dp), dimension(size(a),size(a)) :: d1
        real(dp) :: r,p,r2,p2 !upper and lower limits
        real(dp) :: yout,yout_integral
        complex(dp) :: a1,a2,a3
        integer :: na,nb
        a=(/0._dp,1._dp,1._dp,1._dp/)
        b=(/1._dp,1._dp,-1._dp,0._dp/)
        r=1._dp/SQRT2 !in u
        p=1._dp/SQRT3
        na=size(a)
        nb=size(b)
        if (na /= nb) STOP 'ensure a,b are same shape'
        r2=r**2 !in t
        p2=p**2
        X=sqrt(a+b*r2)
        Y=sqrt(a+b*p2)
        U=0._dp
        U(1,4)=(X(1)*X(4)*Y(2)*Y(3)+Y(1)*Y(4)*X(2)*X(3))/(r2-p2)
        allocate(am(na,1))
        allocate(bm(1,na))
        am=reshape(a,(/na,1/))
        bm=reshape(b,(/1,na/))
        d1=matmul(am,bm)
        d=d1-transpose(d1)
        a3=dcmplx(U(1,4)**2)
        a1=a3+1._dp
        a2=a3-1._dp
        yout=THIRD*rd(a1,a2,a3)+r*p/U(1,4)
        yout_integral=gaussint(fn_S9,p,r)
        write(*,*) yout,yout_integral
    contains
        real(dp) function fn_S9(ua)
            implicit none
            real(dp), intent(in) :: ua
            fn_S9=ua**2*1._dp/sqrt(1._dp-ua**4)
        end function fn_S9
    end subroutine test_formula_S9

    subroutine test_formula_213
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ! Evaluate integral (2.13) in Carlson 1987.                            !
        ! This routine differs from test_formula_213 as the full, general      !
        ! formula is used and quantities have not been expanded and simplified !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        use szlocal
        implicit none
        type(szshell) :: shell
        complex(dp), dimension(4) :: a,b
        complex(dp) :: yout,yout2
        real(dp) :: r,ul,ll
        integer, dimension(3) :: p
        r=15._dp
        ul=r
        ll=0._dp
        call init_shell(r,shell)
        a(1) = dcmplx(0._dp)
        a(2:4) = -shell%szc%roots
        b = (/1._dp,1._dp,1._dp,1._dp /)
        p = (/1,2,3/)
        yout = f213(a,b,ul,ll)
        yout2 = f213_2(shell,ul,p)
        write(*,*) yout
        write(*,*) yout2
        ! ul=1._dp/SQRT2
        ! ll=0._dp
        ! a = (/0._dp,1._dp,1._dp,2._dp/)
        ! b = (/1._dp,-1._dp,1._dp,1._dp/)
        ! yout = f213(a,b,ul,ll)
        ! write(*,*) yout
    end subroutine test_formula_213

    complex(dp) function f213(a,b,ulim,llim)
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ! Use the general formula to evaluate eq (2.13) !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        use utils, only : rd,rf,rf_2
        implicit none
        integer, parameter :: n=4
        complex(dp), dimension(n), intent(in) :: a,b
        real(dp), intent(in) :: ulim,llim
        complex(dp), dimension(n) :: X,Y
        complex(dp), dimension(n,1) :: am
        complex(dp), dimension(1,n) :: bm
        complex(dp), dimension(n,n) :: d1,d
        complex(dp) :: U12,U13,U14,U122,U132,U142
        complex(dp) :: s1,s2,s3,t1,t2,t3
        X = sqrt(a+b*ulim)
        Y = sqrt(a+b*llim)
        U12 = (X(1)*X(2)*Y(3)*Y(4) + Y(1)*Y(2)*X(3)*X(4)) / (ulim-llim)
        U13 = (X(1)*X(3)*Y(2)*Y(4) + Y(1)*Y(3)*X(2)*X(4)) / (ulim-llim)
        U14 = (X(1)*X(4)*Y(2)*Y(3) + Y(1)*Y(4)*X(2)*X(3)) / (ulim-llim)
        U122 = U12**2
        U132 = U13**2
        U142 = U14**2
        am = reshape(a, (/n,1/) )
        bm = reshape(b, (/1,n/) )
        d1 = matmul(am,bm)
        d = d1 - transpose(d1)
        s1 = b(1) / d(1,4) - 2._dp * b(2) / d(2,4) - 2._dp * b(3) / d(3,4)
        t1 = 2._dp / 9._dp * s1 * d(1,2) * d(1,3) * rd(U122,U132,U142)
        s2 = b(4) * d(1,2) * d(1,3) / (d(1,4) * d(2,4) * d(3,4))
        t2 = -2._dp / 3._dp * s2 * rf(U122,U132,U142)
        s3 = -2._dp / 3._dp * b(4) / (d(2,4) * d(3,4))
        t3 = s3 * X(1) * X(2) * X(3) / X(4)**3
        f213 = t1 + t2 + t3
    end function f213

    complex(dp) function f213_2(shell,ulim,perm)
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        ! Only cyclic permutations of (1,2,3) allowed         !
        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        use szelliptic
        use utils, only : rd,rf,rd_2
        implicit none
        type(szshell), intent(in) :: shell
        real(dp), intent(in) :: ulim
        integer, dimension(3), intent(in) :: perm
        complex(dp) :: x2,x3,x4,a2,a3,a4
        complex(dp) :: s,t1,t2,t3
        real(dp) :: xi
        x2 = shell%szc%roots(perm(1))
        x3 = shell%szc%roots(perm(2))
        x4 = shell%szc%roots(perm(3))
        a2 = 1._dp/ulim - 1._dp/x2
        a3 = 1._dp/ulim - 1._dp/x3
        a4 = 1._dp/ulim - 1._dp/x4
        xi = shell%szc%xi !sqrt(-x1.x2.x3)
        s = TWOTHIRD * xi * shell%szc%f(perm(3)) / x4**2
        t1 = THIRD * (1._dp / x2 + 1._dp / x3 + 1._dp / x4 &
                      - 3._dp * x4 / (x2 * x3)) * rd(a2,a3,a4)
        t2 = rf(a2,a3,a4)
        ! t3 = -sqrt(a2 * a3 / a4**3)
        t3 = -sqrt(a2) * sqrt(a3) / sqrt(a4)**3
        f213_2 = s * (t1 + t2 + t3)
    end function f213_2

    complex(dp) function f207(shell,ulim,perm)
        use szelliptic
        use utils, only : rd
        implicit none
        real(dp), intent(in) :: ulim
        type(szshell), intent(in) :: shell
        integer, dimension(3), intent(in) :: perm
        complex(dp) :: x2,x3,x4,xi,a2,a3,a4
        x2 = shell%szc%roots(perm(1))
        x3 = shell%szc%roots(perm(2))
        x4 = shell%szc%roots(perm(3))
        xi = shell%szc%xi
        a2 = 1._dp/ulim - 1._dp/x2
        a3 = 1._dp/ulim - 1._dp/x3
        a4 = 1._dp/ulim - 1._dp/x4
        f207 = -TWOTHIRD / (x4 * xi) * rd(a2,a3,a4)
    end function f207

    subroutine test_pX555
        use utils, only : gaussint
        implicit none
        type(szshell) :: shell
        real(dp) :: yout,yout1
        real(dp) :: r,ll,ul
        reaL(dp) :: a1,a2,b2,z2
        integer i
        ll=0._dp
        open(unit=17,file='p5555.txt',form='formatted',status='replace')
        open(unit=18,file='p3555.txt',form='formatted',status='replace')
        open(unit=19,file='p1555.txt',form='formatted',status='replace')
        do i=0,40
            r=1._dp+(200._dp-1._dp)/40*i
            ul=r
            call init_shell(r,shell)
            a1=real(shell%szc%roots(1))
            a2=real(shell%szc%roots(2))
            b2=aimag(shell%szc%roots(2))
            z2=a2**2+b2**2
! All integrals ought to be real valued
            yout=szellip_5555(shell%szc,ul)
            yout1=gaussint(f5555,ll,ul)
            write(17,fmt='(F10.4,E17.9,E17.9)') r,yout,yout1
            yout=szellip_3555(shell%szc,ul)
            yout1=gaussint(f3555,ll,ul)
            write(18,fmt='(F10.4,E17.9,E17.9)') r,yout,yout1
            yout=szellip_1555(shell%szc,ul)
            yout1=gaussint(f1555,ll,ul)
            write(19,fmt='(F10.4,E17.9,E17.9)') r,yout,yout1
        end do
        close(19)
        close(18)
        close(17)
! The first root is real, the others complex conjugate pair
    contains
        real(dp) function f5555(x)
            implicit none
            real(dp), intent(in) :: x
            real(dp) q
! Check branch ambiguity if complex valued
            q=(x-a1)*(x**2-2._dp*a2*x+z2)
            if (q < 0._dp) STOP 'f5555: integrand not real'
            f5555=sqrt(x/q)**5
        end function f5555
        real(dp) function f3555(x)
            implicit none
            real(dp), intent(in) :: x
            real(dp) q
! Check branch ambiguity if complex valued
            q=(x-a1)*(x**2-2._dp*a2*x+z2)
            if (q < 0._dp) STOP 'f3555: integrand not real'
            f3555=sqrt(x)**3/sqrt(q)**5
        end function f3555
        real(dp) function f1555(x)
            implicit none
            real(dp), intent(in) :: x
            real(dp) q
! Check branch ambiguity if complex valued
            q=(x-a1)*(x**2-2._dp*a2*x+z2)
            if (q < 0._dp) STOP 'f1555: integrand not real'
            f1555=sqrt(x)/sqrt(q)**5
        end function f1555
    end subroutine test_pX555

    subroutine test_get_kpprime
        use utils, only : dfridr
        implicit none
        type(szlocal_class) :: szloc
        real(dp) :: h,err,r,kpp,kpp1,err1
        integer i
        real(dp), parameter :: t=0._dp
        h = 0.1_dp
        open(unit=13,file='kpp.txt',form='formatted',status='replace')
        write(13,'(9X,A,4X,A,6X,A,3X,A)') &
                'r','k''''(numerical)','k''''(carlson)','rel. error'
        do i=0,40
            r=1._dp+(200._dp-1._dp)/40*i
            kpp=dfridr(kp_of_r,r,h,err)
            szloc=init_szlocal_class(t,r)
            call get_kpprime(szloc)
            err1=abs(1._dp-kpp/szloc%f%kpp)
            write(13,'(F10.4,E18.8,E18.8,E13.3)') r,kpp,szloc%f%kpp,err1
        end do
        close(13)
    contains
        real(dp) function kp_of_r(r)
            implicit none
            real(dp), intent(in) :: r
            type(szlocal_class) :: szloc
            call get_kprime(szloc)
            kp_of_r=szloc%f%kp
        end function kp_of_r
    end subroutine test_get_kpprime

    subroutine test_rayshoot_dr
        use cosmo_params, only : r_obs,theta_obs
        use sznullgeo
        implicit none
        real(dp) :: RA,DEC,red,obs_pos(3)
        RA=0.78539816339744828_dp
        DEC=0.10210642238260403_dp
        obs_pos=(/r_obs,theta_obs,0.543*PI/)
        call rayshoot_dr(obs_pos,RA,DEC,red,iexit=0,val_exit=-400._dp)
        print *,'redshift', red
    end subroutine test_rayshoot_dr

end module test_module


      SUBROUTINE STRMVT( UPLO, N, T, LDT, X, INCX, Y, INCY, W, INCW, Z,
     $                   INCZ )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     March 13, 2000
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INCW, INCX, INCY, INCZ, LDT, N
*     ..
*     .. Array Arguments ..
      REAL               T( LDT, * ), W( * ), X( * ), Y( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*  STRMVT  performs the matrix-vector operations
*
*     x := T' *y, and w := T *z,
*
*  where x is an n element vector and  T is an n by n
*  upper or lower triangular matrix.
*
*  Arguments
*  =========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  T      - REAL array of DIMENSION ( LDT, n ).
*           Before entry with  UPLO = 'U' or 'u', the leading n by n
*           upper triangular part of the array T must contain the upper
*           triangular matrix and the strictly lower triangular part of
*           T is not referenced.
*           Before entry with UPLO = 'L' or 'l', the leading n by n
*           lower triangular part of the array T must contain the lower
*           triangular matrix and the strictly upper triangular part of
*           T is not referenced.
*
*  LDT    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, n ).
*           Unchanged on exit.
*
*  X      - REAL array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           On exit, X = T' * y
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  Y      - REAL array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCY ) ).
*           Before entry, the incremented array Y must contain the n
*           element vector y.  Unchanged on exit.
*
*  INCY   - INTEGER.
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*  W      - REAL array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCW ) ).
*           On exit, W = T * z
*
*  INCW   - INTEGER.
*           On entry, INCW specifies the increment for the elements of
*           W. INCW must not be zero.
*           Unchanged on exit.
*
*  Z      - REAL array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCZ ) ).
*           Before entry, the incremented array Z must contain the n
*           element vector z.  Unchanged on exit.
*
*  INCY   - INTEGER.
*           On entrz, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*
*     .. Local Scalars ..
      INTEGER            INFO
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, STRMV, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = 1
      ELSE IF( N.LT.0 ) THEN
         INFO = 2
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = 4
      ELSE IF( INCW.EQ.0 ) THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 ) THEN
         INFO = 8
      ELSE IF( INCY.EQ.0 ) THEN
         INFO = 10
      ELSE IF( INCZ.EQ.0 ) THEN
         INFO = 12
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'STRMVT', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
*
*
      IF( INCX.NE.1 .OR. INCY.NE.1 .OR. INCW.NE.1 .OR. INCZ.NE.1 .OR.
     $    .TRUE. ) THEN
         CALL SCOPY( N, Y, INCY, X, INCX )
         CALL STRMV( UPLO, 'C', 'N', N, T, LDT, X, INCX )
         CALL SCOPY( N, Z, INCZ, W, INCW )
         CALL STRMV( UPLO, 'N', 'N', N, T, LDT, W, INCW )
         RETURN
      END IF
*
      RETURN
*
*     End of STRMVT.
*
      END


module clip

character(len=512) :: poly_file
character(len=512) :: input_file
character(len=512) :: output_file
logical :: getPointsInsideBoundary
logical :: getPointsOutsideBoundary
logical :: getPointsOnBoundary
logical :: labelAll
double precision :: epsilon
logical :: printRecord

end module clip

!==================================================================================================!

program main

use io, only: stdin, stdout, stderr, fileExists, line_count
use geom, only: pnpoly

use clip, only: poly_file, &
                input_file, &
                output_file, &
                getPointsInsideBoundary, &
                getPointsOutsideBoundary, &
                getPointsOnBoundary, &
                labelAll, &
                epsilon, &
                printRecord

implicit none

! Local variables
integer :: i, ios, luin, luout, nclip, inout, irecord, ipoly, npoly
character(len=1) :: ch1
character(len=512) :: line
double precision :: x, y
double precision, allocatable :: polygon(:,:,:)
logical :: multiPoly

! Parse command line
call gcmdln()

! Make sure something needs to be printed...
if (.not.getPointsInsideBoundary .and. &
    .not.getPointsOutsideBoundary .and. &
    .not.getPointsOnBoundary .and. &
    .not.labelAll) then
    call usage('clip: no output mode specified')
endif

! Read clipping polygon
if(.not.fileExists(poly_file)) then
    call usage('clip: no polygon file found named "'//trim(poly_file)//'"')
endif
nclip = line_count(poly_file)

! Check to see whether file contains single or multiple polygons
open(unit=21,file=poly_file,status='old')
read(21,'(A)') ch1
npoly = 1
if (ch1.eq.'>') then
    multiPoly = .true.
    do i = 1,nclip
        read(21,'(A)')
        if (ch1.eq.'>') then
            npoly = npoly + 1
        endif
    enddo
    allocate(polygon(npoly,nclip,2))
else
    multiPoly = .false.
    allocate(polygon(npoly,nclip,2))
endif
rewind(21)

npoly = 1
do i = 1,nclip
    read(21,'(A)') line
    if (line.eq.'>'.and.i.gt.1) then
        npoly = npoly + 1
        cycle
    endif
    read(line,*,iostat=ios) polygon(npoly,i,1),polygon(npoly,i,2)
    if (ios.ne.0) then
        write(stderr,*) 'clip: error reading polygon file coordinates at line ',i
        call usage(     'Offending line: '//trim(line))
    endif
enddo
close(21)

! Determine input/output streams
if (input_file.eq.''.or.input_file.eq.'none'.or.input_file.eq.'stdin') then
    luin = stdin
else
    if (.not.fileExists(input_file)) then
        call usage('clip: no file found named "'//trim(input_file)//'"')
    endif
    luin = 11
    open(unit=luin,file=input_file,status='old')
endif

if (output_file.eq.''.or.output_file.eq.'none'.or.output_file.eq.'stdout') then
    luout = stdout
else
    luout = 12
    open(unit=luout,file=output_file,status='unknown')
endif

! Read input data and clip it
irecord = 0
do
    read(luin,'(A)',iostat=ios) line
    if (ios.ne.0) then
        exit
    endif

    irecord = irecord + 1
    read(line,*,iostat=ios) x,y
    if (ios.ne.0) then
        write(stderr,*) 'clip: error reading input file coordinates'
        call usage(     'Offending line: '//trim(line))
    endif

    do ipoly = 1,npoly
        call pnpoly(x,y,polygon(ipoly,:,1),polygon(ipoly,:,2),nclip,inout,epsilon)
        if (inout.eq.1) then
            exit
        endif
    enddo

    if (getPointsInsideBoundary.and.inout.eq.1) then
        if (printRecord) then
            write(luout,*) irecord,trim(line)
        else
            write(luout,*) trim(line)
        endif
    elseif (getPointsOutsideBoundary.and.inout.eq.-1) then
        if (printRecord) then
            write(luout,*) irecord,trim(line)
        else
            write(luout,*) trim(line)
        endif
    elseif (getPointsOnBoundary.and.inout.eq.0) then
        if (printRecord) then
            write(luout,*) irecord,trim(line)
        else
            write(luout,*) trim(line)
        endif
    elseif (labelAll) then
        if (printRecord) then
            if (multiPoly) then
                write(luout,*) irecord,inout,ipoly
            else
                write(luout,*) irecord,inout
            endif
        else
            if (multiPoly) then
                write(luout,*) inout,ipoly
            else
                write(luout,*) inout
            endif
        endif
    endif
enddo

if (luin.ne.stdin) then
    close(11)
endif
if (luout.ne.stdout) then
    close(12)
endif

end

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

subroutine gcmdln()

use clip, only: poly_file, &
                input_file, &
                output_file, &
                getPointsInsideBoundary, &
                getPointsOutsideBoundary, &
                getPointsOnBoundary, &
                labelAll, &
                epsilon, &
                printRecord

implicit none

! Local variables
integer :: i, ios, narg
character(len=512) :: tag, arg

poly_file = ''
input_file = ''
output_file = ''
getPointsInsideBoundary = .false.
getPointsOutsideBoundary = .false.
getPointsOnBoundary = .false.
labelAll = .false.
epsilon = 1.0d-8
printRecord = .false.

! Number of arguments
narg = command_argument_count()
if (narg.eq.0) then
  call usage('')
endif

! Read arguments
i = 1
call get_command_argument(i,poly_file)
i = i + 1

do while (i.le.narg)

    call get_command_argument(i,tag)

    if (trim(tag).eq.'-f') then
        i = i + 1
        call get_command_argument(i,input_file)

    elseif (tag.eq.'-o') then
        i = i + 1
        call get_command_argument(i,output_file)

    elseif (tag.eq.'-in') then
        getPointsInsideBoundary = .true.

    elseif (tag.eq.'-out') then
        getPointsOutsideBoundary = .true.

    elseif (tag.eq.'-on') then
        getPointsOnBoundary = .true.
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) epsilon

    elseif (tag.eq.'-NR') then
        printRecord = .true.

    elseif (tag.eq.'-l') then
        labelAll = .true.
        i = i + 1
        if (i.gt.narg) then
            cycle
        else
            call get_command_argument(i,arg)
            read(arg,*,iostat=ios) epsilon
            if (ios.ne.0) then
                i = i - 1
            endif
        endif

    else
        call usage('clip: no option '//trim(tag))
    endif

    i = i + 1

enddo

return
end subroutine

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

subroutine usage(str)

use io, only: stderr
implicit none
character(len=*) :: str

if (str.ne.'') then
    write(stderr,*) trim(str)
    write(stderr,*)
endif

write(stderr,*) 'Usage: clip CLIP_FILE ...options...'
write(stderr,*)
write(stderr,*) 'CLIP_FILE         Clipping boundary'
write(stderr,*) '-f FILE           X-Y-Z data to clip (default: stdin)'
write(stderr,*) '-o FILE           Clipped data (default: stdout)'
write(stderr,*) '-in               Keep points inside clipping boundary'
write(stderr,*) '-out              Keep points outside clipping boundary'
write(stderr,*) '-on EPS           Keep points within EPS of boundary'
write(stderr,*) '-NR               Print record of clipped lines'
write(stderr,*) '-l [EPS]          Print in(+1), out(-1), or on(0) boundary'
write(stderr,*)

call error_exit(1)
end subroutine


! { dg-do compile }
! { dg-options "-fdump-tree-original" }
! PR 61999 - this used to ICE.
! Original test case by A. Kasahara
program main
   use, intrinsic:: iso_fortran_env, only: output_unit

   implicit none

   write(output_unit, *) dot_product([1, 2], [2.0, 3.0])

   stop
end program main
! { dg-final { scan-tree-dump-times "8\\.0e\\+0" 1 "original" } }


!==============================================================================
MODULE DATA_TYPE
   IMPLICIT NONE
   INTEGER(KIND=4), PARAMETER :: IB=4, RP=KIND(0.D0), DRP=KIND(0.D0), SP=KIND(0.0)
   REAL(KIND=RP),   PARAMETER :: PI2  = 3.141592653589793238462643383279502884197_RP
   COMPLEX(KIND=RP),PARAMETER :: cir  = CMPLX(0._RP,1._RP,KIND=RP)
   COMPLEX(KIND=SP),PARAMETER :: cis  = CMPLX(0._SP,1._SP,KIND=SP)
END MODULE DATA_TYPE
!==============================================================================


program P10799
    implicit none
    character(len = 100000) :: parens
    integer :: stack, sum
    integer :: i

    read *, parens
    sum = 0
    stack = 0
    do i = 1, len_trim(parens)
        if (parens(i:i) == '(') then
            stack = stack + 1
        else if (parens(i:i) == ')') then
            stack = stack - 1
            if (parens((i - 1):(i - 1)) == '(') then
                sum = sum + stack
            else
                sum = sum + 1
            end if
        end if
    end do
    write (*, '(I0)') sum
end program P10799


program problem_8b

    use aoc_utilities

    implicit none

    integer :: iunit, i, j, k, n, n_lines
    character(len=:),allocatable :: line, readings_str
    logical :: status_ok
    type(string),dimension(:),allocatable :: vals
    type(string),dimension(:),allocatable :: vals_readings
    type(string),dimension(:),allocatable :: vals_outputs
    integer,dimension(4) :: output_count
    integer :: total

    logical,dimension(7, 7) :: matrix

    ! 0 - 9 correct string values (sorted):
    character(len=*),dimension(10),parameter :: numbers = ['abcefg ', &
                                                           'cf     ', &
                                                           'acdeg  ', &
                                                           'acdfg  ', &
                                                           'bcdf   ', &
                                                           'abdfg  ', &
                                                           'abdefg ', &
                                                           'acf    ', &
                                                           'abcdefg', &
                                                           'abcdfg ' ]
    character(len=*),dimension(7),parameter :: abcdefg=['a','b','c','d','e','f','g'] ! full set
    character(len=:),allocatable :: full_str
    character(len=1),dimension(:),allocatable :: full_str_vec
    character(len=1) :: ch
    integer,dimension(7) :: icounts
    character(len=1) :: a,b,c,d,e,f,g
    integer,dimension(1) :: iloc
    character(len=:),allocatable :: converted_string
    integer :: output_num, output_sum

    !----------------------------
    ! 1:   C  F
    ! 7: A C  F
    ! 4:  BCD F
    ! 8: ABCDEFG
    ! 2: A CDE G
    ! 3: A CD FG
    ! 5: AB D FG
    ! 6: AB DEFG
    ! 0: ABC EFG
    ! 9: ABCD FG
    !----------------------------

    ! frequency analysis:

    ! first get the counts of the string: '0123456789':
    full_str = ''
    do i = 1, 10
        full_str = full_str//trim(numbers(i))
    end do
    write(*,*) len(full_str)
    allocate(full_str_vec(len(full_str)))
    do i = 1, len(full_str)
        full_str_vec(i) = full_str(i:i)
    end do
    ! histogram
    write(*,*) ''
    write(*,*) 'histogram:'
    do i = 1, 7
        ch = achar(i+iachar('a')-1)
        write(*,*) ch, ':', count(full_str_vec==ch)
    end do
    write(*,*) ''

    !----------------------------
    ! algorithm to get them (after generating the above histogram):

    ! letter    char count in full list    how to get it
    ! e:           4                       <---- known, just count chars and we have it
    ! b:           6                       <---- known, just count chars and we have it
    ! f:           9                       <---- known, just count chars and we have it
    ! c:           8                       <---- from 1: the non f character in the only one with 2 letters
    ! a:           8                       <---- the other one with 8 character count
    ! d:           7                       <---- from 4: the non (b,c,f) character in the one with 4 letters
    ! g:           7                       <---- the other one with 7 character count

    a=' '
    b=' '
    c=' '
    d=' '
    e=' '
    f=' '
    g=' '
    output_sum = 0

    open(newunit=iunit,file='inputs/day8.txt')

    n_lines = number_of_lines_in_file(iunit)

    total = 0
    do i = 1, n_lines
        call read_line_from_file(iunit,line,status_ok)
        call split(trim(line),'|',vals)
        call split(trim(adjustl(vals(1)%str)),' ',vals_readings)
        readings_str = ''
        do j = 1, size(vals_readings)
            readings_str = readings_str//trim(vals_readings(j)%str)
        end do
        icounts = compute_counts(readings_str) ! counts for a-g

        ! these we get just with the frequency analysis:
        iloc = findloc(icounts,4); e = abcdefg(iloc(1))
        iloc = findloc(icounts,6); b = abcdefg(iloc(1))
        iloc = findloc(icounts,9); f = abcdefg(iloc(1))

        ! c: 8 <---- from 1: the non f character in the only one with 2 letters
        do j = 1, size(vals_readings)
            if (len(vals_readings(j)%str) == 2) then
                if (vals_readings(j)%str(1:1)==f) then
                    c = vals_readings(j)%str(2:2)
                else
                    c = vals_readings(j)%str(1:1)
                end if
            end if
        end do

        ! a: 8 <---- the other one with 8 character count (that isn't c)
        do j = 1, size(icounts)
            if (icounts(j)==8) then
                if (abcdefg(j)/=c) then
                    a = abcdefg(j)
                    exit
                end if
            end if
        end do

        ! d: 7 <---- from 4: the non (b,c,f) character in the one with 4 letters
        dloop : do j = 1, size(vals_readings)
            if (len(vals_readings(j)%str) == 4) then ! has 4 letters
                do k = 1, 4
                    if (vals_readings(j)%str(k:k)==b .or. &
                        vals_readings(j)%str(k:k)==c .or. &
                        vals_readings(j)%str(k:k)==f ) then
                        cycle
                    else
                        d = vals_readings(j)%str(k:k)
                        exit dloop
                    end if
                end do
            end if
        end do dloop

        ! g: 7 <---- the other one with 7 character count (that's isn't d)
        do j = 1, size(icounts)
            if (icounts(j)==7) then
                if (abcdefg(j)/=d) then
                    g = abcdefg(j)
                    exit
                end if
            end if
        end do

        ! now, from the outputs, compute the number:
        call split(trim(adjustl(vals(2)%str)),' ',vals_outputs)

        output_num = 0
        k = 0
        do j = 4,1,-1
            k = k + 1
            converted_string = convert(vals_outputs(j)%str)
            !write(*,*) vals_outputs(j)%str, ' -> ', converted_string, ' -> ', to_number(converted_string)
            output_num = output_num + to_number(converted_string) * 10**(k-1)
        end do

        output_sum = output_sum + output_num

    end do

    write(*,*) '8b: ', output_sum

    contains

    function compute_counts(str) result(icounts)
    implicit none
    character(len=*),intent(in) :: str ! concatenated string of all readings
    integer,dimension(7) :: icounts    ! counts of a-g

    character(len=1),dimension(:),allocatable :: vec
    integer :: i
    character(len=1) :: ch

    allocate(vec(len_trim(str)))
    do i = 1, len(str)
        vec(i) = str(i:i) ! a temp array just to use count
    end do
    do i = 1, 7
        ch = achar(i+iachar('a')-1)
        icounts(i) = count(vec==ch)
    end do

    end function compute_counts

    function to_number(str) result(inum)
        implicit none
        character(len=*),intent(in) :: str
        integer :: inum
        integer :: i,j,k
        logical :: match

        main: do i = 1, size(numbers)
            if (len_trim(str)/=len_trim(numbers(i))) cycle  ! not a match
            ! output can be in any order so we sort it
            ! numbers is already sorted
            inum = i-1
            match = .true.
            do j = 1, len(str)
                if (index(numbers(i), str(j:j)) <= 0 ) then
                    match = .false.
                    cycle main
                end if
            end do
            if (match) return
        end do main
        error stop 'error: string not found: '//str

    end function to_number

    function convert(str) result(str2)
        implicit none
        character(len=*),intent(in) :: str
        character(len=len(str)) :: str2
        integer :: i
        integer,dimension(1) :: iloc
        character(len=1),dimension(7) :: key
        key = [a,b,c,d,e,f,g]
        do i = 1, len(str)
            iloc = findloc(key, str(i:i))
            str2(i:i) = abcdefg(iloc(1))
        end do

    end function convert

end program problem_8b


!>
program p_test_schrodinger

  use m_io
  use m_schrodinger

  ! debug
  use m_diffeq

  implicit none

  integer , parameter :: n_x = 10001
  double precision , parameter :: omega = 1.0d0
  double precision , parameter :: step_size = 20.0d0/dble(n_x)
  integer , parameter :: n_wf = 10
  double precision :: wf(n_x, n_wf)
  double precision :: energies(n_wf)
  integer :: status = 0

  double precision :: x_grid(n_x)
  integer :: ii

  ! initialise x_grid
  do ii = 1, n_x
    x_grid(ii) = step_size*(dble(ii) - dble(n_x + 1)/2.0d0)
  end do

  !
  call harmonic_oscillator(n_x, step_size, omega, n_wf, wf, energies, status)

  ! terminate program if harmonic_oscillator failed
  if (status /= 0) then
    write (*, *) "harmonic_oscillatory() failed"
    write (*, *) "exiting p_test_schrodinger"
    call exit(status)
  end if

  ! display energies
  write (*, *) "energies"
  call display_vector(n_wf, energies)

  ! visualise
  write (*, *) "wavefunctions"
  do ii = 1, n_wf
    write (*, *) "n = ", int_trim(ii)
    call display_graph(n_x, x_grid, wf(:, ii), width=80, height=30)
  end do

contains

end program p_test_schrodinger


      ! -------------------------------------------------------------
      !
      ! Copyright (C) 2021 The Simons Foundation
      !
      ! Author: Jason Kaye
      !
      ! -------------------------------------------------------------
      !
      ! libdlr is licensed under the Apache License, Version 2.0 (the
      ! "License"); you may not use this file except in compliance with
      ! the License.  You may obtain a copy of the License at
      !
      !     http://www.apache.org/licenses/LICENSE-2.0
      !
      ! Unless required by applicable law or agreed to in writing,
      ! software distributed under the License is distributed on an "AS
      ! IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either
      ! express or implied.  See the License for the specific language
      ! governing permissions and limitations under the License.
      !
      ! -------------------------------------------------------------

      program ha_it

      ! Test discrete Lehmann representation using Green's function
      ! generated from Lehmann representation with density which is a
      ! sum of two delta functions. Recover DLR coefficients from
      ! values of Green's function on imaginary time grid, and measure
      ! the error of the resulting DLR expansion on a test grid.

      implicit none
      integer ntst
      real *8 lambda,eps,beta

      ! Input parameters

      lambda = 1000.0d0   ! DLR high energy cutoff
      eps = 1.0d-14       ! DLR error tolerance

      ntst = 10000        ! # imaginary time test points
      beta = 1000.0d0     ! Inverse temperature

      ! Main test subroutine

      call ha_it_main(lambda,eps,ntst,beta)

      end program ha_it

      subroutine ha_it_main(lambda,eps,ntst,beta)

      implicit none
      integer ntst
      real *8 lambda,eps,beta

      integer i,j,r
      integer, allocatable :: it2cfp(:)
      real *8 one,gtrue,gtest,errl2,errlinf,gmax,gl2
      real *8, allocatable :: ttst(:),it2cf(:,:),dlrit(:),dlrrf(:)
      real *8, allocatable :: g(:),gc(:)

      one = 1.0d0

      ! Get DLR frequencies, imaginary time grid

      r = 500 ! Upper bound on DLR rank

      allocate(dlrrf(r),dlrit(r))

      call dlr_it_build(lambda,eps,r,dlrrf,dlrit)

      ! Get imaginary time values -> DLR coefficients matrix (LU form)

      allocate(it2cf(r,r),it2cfp(r))

      call dlr_it2cf_init(r,dlrrf,dlrit,it2cf,it2cfp)

      ! Sample G at imaginary time nodes

      allocate(g(r))

      do i=1,r

        call gfun(beta,dlrit(i),g(i))

      enddo

      ! Get DLR coefficients of G

      allocate(gc(r))

      call dlr_it2cf(r,it2cf,it2cfp,g,gc)

      ! Get test points in relative format

      allocate(ttst(ntst))

      call eqpts_rel(ntst,ttst)

      ! Measure L^inf and L^2 errors

      errlinf = 0*one
      errl2 = 0*one
      gmax = 0*one
      gl2 = 0*one

      do i=1,ntst

        ! Evaluate Green's function

        call gfun(beta,ttst(i),gtrue)

        ! Evaluate DLR

        call dlr_it_eval(r,dlrrf,gc,ttst(i),gtest)

        ! Update L^inf and L^2 errors, norms

        errlinf = max(errlinf,abs(gtrue-gtest))
        errl2 = errl2 + (gtrue-gtest)**2

        gmax = max(gmax,abs(gtrue))
        gl2 = gl2 + gtrue**2

      enddo

      errl2 = sqrt((ttst(2)-ttst(1))*errl2)
      gl2 = sqrt((ttst(2)-ttst(1))*gl2)

      write(6,*) ''
      write(6,*) 'DLR rank = ',r
      write(6,*) 'Abs L^inf err = ',errlinf
      write(6,*) 'Abs L^2 err   = ',errl2
      write(6,*) 'Rel L^inf err = ',errlinf/gmax
      write(6,*) 'Rel L^2 err   = ',errl2/gl2
      write(6,*) ''

      ! Return failed status if error is not sufficiently small

      if (errlinf.gt.1.0d-13) then
        call exit(1)
      endif

      end subroutine ha_it_main

      subroutine gfun(beta,t,g)

      ! Evaluate Green's function with sum-of-delta-functions spectral
      ! density

      implicit none
      real *8 beta,t,g
      real *8, external :: kfunf_rel

      real *8 a1,a2,a3,a4,a5

      a1 = -0.804d0
      a2 = -0.443d0
      a3 =  0.093d0
      a4 =  0.915d0
      a5 =  0.929d0

      g = kfunf_rel(t,beta*a1) + kfunf_rel(t,beta*a2) &
        + kfunf_rel(t,beta*a3) + kfunf_rel(t,beta*a4) &
        + kfunf_rel(t,beta*a5)

      end subroutine gfun


module mod_mnist

  ! Procedures to work with MNIST dataset, usable with data format
  ! as provided in this repo and not the original data format (idx).

  use iso_fortran_env, only: real32 ! TODO make MNIST work with arbitrary precision
  use mod_io, only: read_binary_file
  use mod_kinds, only: ik, rk

  implicit none

  private

  public :: label_digits, load_mnist, print_image

contains

  pure function digits(x)
    ! Returns an array of 10 reals, with zeros everywhere
    ! and a one corresponding to the input number, for example:
    !   digits(0) = [1., 0., 0., 0., 0., 0., 0., 0., 0., 0.]
    !   digits(1) = [0., 1., 0., 0., 0., 0., 0., 0., 0., 0.]
    !   digits(6) = [0., 0., 0., 0., 0., 0., 1., 0., 0., 0.]
    real(rk), intent(in) :: x
    real(rk) :: digits(10)
    digits = 0
    digits(int(x + 1)) = 1
  end function digits

  pure function label_digits(labels) result(res)
    ! Converts an array of MNIST labels into a form
    ! that can be input to the network_type instance.
    real(rk), intent(in) :: labels(:)
    real(rk) :: res(10, size(labels))
    integer(ik) :: i
    do i = 1, size(labels)
      res(:,i) = digits(labels(i))
    end do
  end function label_digits

  subroutine load_mnist(tr_images, tr_labels, te_images,&
                        te_labels, va_images, va_labels)
    ! Loads the MNIST dataset into arrays.
    real(rk), allocatable, intent(in out) :: tr_images(:,:), tr_labels(:)
    real(rk), allocatable, intent(in out) :: te_images(:,:), te_labels(:)
    real(rk), allocatable, intent(in out), optional :: va_images(:,:), va_labels(:)
    integer(ik), parameter :: dtype = 4, image_size = 784
    integer(ik), parameter :: tr_nimages = 50000
    integer(ik), parameter :: te_nimages = 10000
    integer(ik), parameter :: va_nimages = 10000

    call read_binary_file('../data/mnist/mnist_training_images.dat',&
                          dtype, image_size, tr_nimages, tr_images)
    call read_binary_file('../data/mnist/mnist_training_labels.dat',&
                          dtype, tr_nimages, tr_labels)

    call read_binary_file('../data/mnist/mnist_testing_images.dat',&
                          dtype, image_size, te_nimages, te_images)
    call read_binary_file('../data/mnist/mnist_testing_labels.dat',&
                          dtype, te_nimages, te_labels)

    if (present(va_images) .and. present(va_labels)) then
      call read_binary_file('../data/mnist/mnist_validation_images.dat',&
                            dtype, image_size, va_nimages, va_images)
      call read_binary_file('../data/mnist/mnist_validation_labels.dat',&
                            dtype, va_nimages, va_labels)
    end if

  end subroutine load_mnist

  subroutine print_image(images, labels, n)
    ! Prints a single image and label to screen.
    real(rk), intent(in) :: images(:,:), labels(:)
    integer(ik), intent(in) :: n
    real(rk) :: image(28, 28)
    character(len=1) :: char_image(28, 28)
    integer(ik) i, j
    image = reshape(images(:,n), [28, 28])
    char_image = '.'
    where (image > 0) char_image = '#'
    print *, labels(n)
    do j = 1, 28
      print *, char_image(:,j)
    end do
  end subroutine print_image

end module mod_mnist


!   this is old cartezian extremum code adapted to F90

!   May  , 2012, Dmitri Pogosyan    -   change to planar input of 3D boxes
!   March, 2012, Dmitri Pogosyan    -   first rewrite of an old code
!
!   Input:    dt(:)        - field map
!             nd           - number of dimensions
!             n1,n2(,n3)   - box dimensions
!
!   Output:   ext%pix      - pixel position of extrema
!             ext%ang(2)   - angular position (more accurate than pix center)
!             ext%hes(2,2) - hessian
!             ext%eig(2)   - eigenvalues
!             ext%type     - min, max, saddle
!

MODULE extrema_mod
  use extrema_types
  use omp_lib

  IMPLICIT NONE
  PRIVATE

  type NEIGH_DATA
     INTEGER(I8B)      :: pix
     REAL(DP)          :: val
     INTEGER(I4B)      :: xyz(3)
  end type NEIGH_DATA

  type EXT_META
     integer(I8B), allocatable :: l_map(:)
     real(DP),     allocatable :: CNA(:, :), AtCNA(:, :)
     integer(I8B) :: JITTER=0
  end type EXT_META

  integer(I4B), allocatable :: mod_ikvadr(:, :)
  public  :: FIND_EXTREMA

CONTAINS

  subroutine FIND_EXTREMA(dt, nn, nd, ext, ctrl)

    real(SP),             intent(in), dimension(0:) :: dt
    integer(I4B),         intent(in)                :: nd, nn(:)
    type(EXT_DATA),       intent(inout), optional   :: ext(:)
    type(CND_CNTRL_TYPE), intent(in), optional      :: ctrl

    integer(I8B)            :: ic, n_ext, n_ext_low, n_ext_up
    integer(I4B)            :: nparam, nneigh
    type(NEIGH_DATA)        :: neighbour_list(3**nd - 1)
    type(EXT_DATA)          :: extc
    type(EXT_META), save    :: extmeta

    logical                 :: ifextremum, ifjustprint
    real(SP)                :: dtc
    real(DP)                :: bfit(nd*(nd+3)/2)
    real(DP)                :: am(nd, nd), vm(nd), xm(nd)
    integer(I8B)            :: NCHUNK, NCHUNKE
    integer(I4B)            :: NPROC, OMP_GET_THREAD_NUM
    integer :: i

    logical :: stop_now

    logical, save :: firstCall = .true.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Data read-in and setup

    NPIX = product(int(nn(1:nd), I8B))

    if (allocated(extmeta%l_map)) deallocate(extmeta%l_map)
    allocate(extmeta%l_map(0:NPIX-1))     ! Allocate index map
    extmeta%l_map = 0

    if ( PRESENT(ext) ) then
       n_ext_low   = lbound(ext, 1)
       n_ext_up    = ubound(ext, 1)
       ext(:)%typ = -1
       ext(:)%pix = 0
       do i = 1, 3
          ext(:)%eig(i) = 0
          ext(:)%pos(i) = 0
       end do
       ext(:)%val = 0

       ifjustprint = .false.
    else
       ! write(0, *) 'array to store extrema is not supplied, just print out'
       ifjustprint  = .true.
    endif

    nneigh = 3**nd - 1
    nparam = nd*(nd+3)/2

    call preset_neighbours(nd, neighbour_list, nneigh)
    call set_basis(nd, neighbour_list, nneigh, nparam, extmeta)

    if ( PRESENT(ctrl) ) then
       NPROC       = ctrl%nproc
       if (NPROC == -1) then
          NPROC = OMP_GET_MAX_THREADS()
       end if

       ifjustprint = ctrl%justprint
    endif
    NCHUNK  = NPIX/NPROC
    NCHUNKE = (n_ext_up - n_ext_low + 1)/NPROC

    n_ext = 0
    stop_now = .false.

    !$OMP PARALLEL DEFAULT(SHARED)                                                 &
    !$OMP private(dtc, ic, bfit, am, vm, xm, ifextremum, extc) &
    !$OMP FIRSTPRIVATE(n_ext, neighbour_list) NUM_THREADS(NPROC)
    !$OMP DO SCHEDULE(DYNAMIC, NCHUNK)
    do ic = 0, NPIX-1
       ! Early break if stop_now flag is true
       if (stop_now) cycle

       call set_current_neighbours(dt, ic, nn, nd, neighbour_list, nneigh)

       ! fit quadratic to the neightbours
       call quadratic_fit(neighbour_list, nneigh, nparam, bfit, extmeta)
       call setmatrix(bfit, am, vm, nd)
       call findextremum(am, vm, xm, nd)
       ifextremum = checkextremum(xm, ic, nn, nd, neighbour_list, nneigh, extmeta)
       if ( ifextremum ) then               ! do postprocessing
          dtc = dt(ic)
          call setmatrix(bfit, am, vm, nd)
          call extremum_properties(ic, dtc, nn, nd, am, vm, xm, extc)
          call markextremum(ic, neighbour_list, nneigh, extc%typ, extmeta)
          if ( ifjustprint ) then
             ! write(*, '(3(f7.2,1x),4(e10.3,1x),i1)') extc%pos, extc%eig, extc%val, extc%typ
          else
             if ( n_ext >= NCHUNKE ) then
                write(0, *) 'Run out of output storage', n_ext, NCHUNKE, n_ext_low, n_ext_up, 'exiting'
                stop_now = .true.
             endif
             ext(n_ext_low + OMP_GET_THREAD_NUM()*NCHUNKE + n_ext) = extc
             n_ext = n_ext + 1
          endif
       endif
    enddo
    !$OMP END DO
    !$OMP END PARALLEL

    deallocate(extmeta%l_map)
    firstCall = .false.
    return
  END SUBROUTINE FIND_EXTREMA

  !! Fill the neighbours with the positions of the neighbours (except for central one)
  SUBROUTINE preset_neighbours(nd, neighbour_list, nneigh)
    integer(I4B),     intent(in)    :: nd, nneigh
    TYPE(NEIGH_DATA), intent(out)   :: neighbour_list(:)

    integer(I4B), dimension(nd)     :: nn_neigh
    integer(I8B)                    :: i
    integer(I4B)                    :: nc

    nn_neigh = 3
    nc = 1
    do i = 0, nneigh
       if ( 2*i /= nneigh ) then
          neighbour_list(nc)%xyz(1:nd) = index_to_grid(i, nn_neigh, nd) - 1
          nc = nc+1
       endif
    enddo
    return
  END SUBROUTINE preset_neighbours

  !!
  subroutine set_basis(nd, neighbour_list, nneigh, nparam, extmeta)
    integer(I4B), intent(in)      :: nd, nneigh, nparam
    type(NEIGH_DATA), intent(in)  :: neighbour_list(:)
    type(EXT_META), intent(inout) :: extmeta

    REAL(DP),  dimension(nneigh, nparam)  :: AA
    REAL(DP),  dimension(nneigh, nneigh)  :: CNpp

    integer(I4B)                         :: i, j, ic

    if (allocated(extmeta%CNA)) deallocate(extmeta%CNA)
    if (allocated(extmeta%AtCNA)) deallocate(extmeta%AtCNA)
    allocate(extmeta%CNA(nneigh, nparam))
    allocate(extmeta%AtCNA(nparam, nparam))

    ! Set basis
    do i = 1, nd
       AA(:, i) = neighbour_list(:)%xyz(i)
       AA(:, i+nd) = 0.5_dp*AA(:, i)**2
    enddo

    ic=1
    do j = 2, nd
       do i = 1, j-1
          AA(:, 2*nd+ic) = AA(:, i)*AA(:, j)
          ic = ic+1
       enddo
    enddo

    ! Set weights
    CNpp = 0.d0
    forall(i=1:nneigh) CNpp(i, i) = 1.d0/SUM(neighbour_list(i)%xyz(1:nd)**2)
    !    forall(i=1:nneigh) CNpp(i, i) = 1.d0

    call DSYMM('L', 'L', nneigh, nparam, 1.d0, CNpp, nneigh, AA, nneigh, 0.d0, &
         extmeta%CNA, nneigh)
    call DGEMM('T', 'N', nparam, nparam, nneigh, 1.d0, AA, nneigh, extmeta%CNA, nneigh, 0.d0,&
         extmeta%AtCNA, nparam)
    return
  END SUBROUTINE set_basis

  !> Set the neighbours around a cell
  SUBROUTINE set_current_neighbours(dt, icell, nn, nd, neighbour_list, nneigh)
    real(SP),      intent(in), dimension(0:)      :: dt
    integer(I8B),  intent(in)                     :: icell
    integer(I4B),  intent(in), dimension(:)       :: nn
    integer(I4B),  intent(in)                     :: nd, nneigh
    type(NEIGH_DATA), intent(inout)          :: neighbour_list(:)

    integer(I4B), dimension(nd)            :: ijkc, ijk
    integer(I8B)                           :: ineigh
    integer(I4B)                           :: i

    ijkc = index_to_grid(icell, nn, nd)

    do i = 1, nneigh
       ijk = ikvadr(neighbour_list(i)%xyz + ijkc, nn)
       ineigh = grid_to_index(ijk, nn, nd)
       neighbour_list(i)%pix = ineigh
       neighbour_list(i)%val = dt(ineigh) - dt(icell)
    enddo
    return
  END SUBROUTINE set_current_neighbours

  subroutine precompute_ikvadr(nn, ikvadr, lbnd, ubnd)
    integer(I4B), intent(in) :: nn(:)
    integer, intent(in) :: lbnd, ubnd
    integer(I4B), intent(inout) :: ikvadr(1:size(nn),lbnd:ubnd)

    integer(I4B) :: i, d

    do d = 1, size(nn)
       do i = -nn(d), 2*nn(d)
          ikvadr(d, i) = modulo(i, nn(d))
       end do
    end do
  end subroutine precompute_ikvadr

  FUNCTION ikvadr(ijk, nn)
    integer(I4B), intent(in) :: ijk(:), nn(:)
    integer(I4B)             :: ikvadr(size(nn))

    integer(I4B) :: d

    where (ijk < 0)
       ikvadr = ijk + nn
    elsewhere (ijk >= nn)
       ikvadr = ijk - nn
    elsewhere
       ikvadr = ijk
    endwhere

    return
  END FUNCTION ikvadr

  FUNCTION fkvadr(xyz, nn)
    real(DP),     intent(in) :: xyz(:)
    integer(I4B), intent(in) :: nn(:)
    real(DP)                 :: fkvadr(size(nn))

    where (xyz < -0.5d0 )
       fkvadr = xyz + nn - 1.d-5
    elsewhere (xyz >= nn-0.5d0)
       fkvadr = xyz - nn + 1.d-5
    elsewhere
       fkvadr = xyz
    endwhere
    return
  END FUNCTION fkvadr

  FUNCTION rkvadr(xyz, nn)
    real(DP),     intent(in) :: xyz(:)
    integer(I4B), intent(in) :: nn(:)
    real(DP)                 :: rkvadr(size(nn))

    integer                  :: i

    do i=1, size(nn)
       if (xyz(i) < -0.5d0 ) then
          rkvadr(i) = xyz(i) + nn(i)
       elseif (xyz(i) >= nn(i)-0.5d0) then
          rkvadr = xyz(i) - nn(i)
       else
          rkvadr(i) = xyz(i)
       endif
    enddo
    return
  END FUNCTION rkvadr

  FUNCTION grid_to_index(ijk, nn, nd)
    integer(I4B), intent(in), dimension(:) :: ijk, nn
    integer(I4B), intent(in)               :: nd
    integer(I8B)                           :: grid_to_index

    integer                           :: i

    integer(I8B), save, allocatable :: prod_dims(:)
    logical, save :: firstCall = .true.

    if (firstCall) then
       allocate(prod_dims(2:size(nn)))
       do i = 2, nd
          prod_dims(i) = product(int(nn(1:i-1)))
       end do
       firstCall = .false.
    end if

    grid_to_index = ijk(1)
    do i = 2, nd
       grid_to_index = grid_to_index + ijk(i)*prod_dims(i)
       ! if (product(int(nn(1:i-1), I8B)) /= prod_dims(i)) write(*, *) 'f**k 2'
    enddo

    return
  END FUNCTION grid_to_index

  FUNCTION index_to_grid(ic, nn, nd)
    integer(I8B), intent(in)                :: ic
    integer(I4B), intent(in), dimension(:)  :: nn
    integer(I4B), intent(in)                :: nd
    integer(I4B),             dimension(nd) :: index_to_grid

    integer(I8B)                            :: icell, ibase
    integer(I4B)                            :: i

    icell=ic
    do i = nd, 2, -1
       ibase=PRODUCT(nn(2:i))
       index_to_grid(i) = icell/ibase
       icell = icell - index_to_grid(i)*ibase
    enddo
    index_to_grid(1) = icell
    return
  END FUNCTION index_to_grid

  subroutine quadratic_fit(neighbour_list, nneigh, nparam, bfit, extmeta)
    INTEGER(I4B),     intent(in)  :: nneigh, nparam
    TYPE(NEIGH_DATA), intent(in)  :: neighbour_list(:)
    real(DP),         intent(out) :: bfit(:)
    type(EXT_META), intent(inout) :: extmeta

    real(dp), allocatable         :: tmp_val(:)

    INTEGER(I4B)                               :: i, INFO
    REAL(DP), DIMENSION(40)                    :: WORK
    INTEGER(I4B), DIMENSION(nparam)            :: IPIV
    REAL(DP), DIMENSION(nparam, nparam)         :: AtCNA_loc

    AtCNA_loc = extmeta%AtCNA

    allocate(tmp_val(size(neighbour_list)))
    tmp_val = neighbour_list(:)%val

    ! bfit := 1*CNA'*val.
    call DGEMV('T', nneigh, nparam, 1._dp, extmeta%CNA, nneigh, tmp_val,&
         1, 0._dp, bfit, 1)
    deallocate(tmp_val)

    ! solves AtCNA_loc * X = bfit, thus getting the location
    call DSYSV('L', nparam, 1, AtCNA_loc, nparam, IPIV, bfit, nparam, WORK, 40, INFO)

    return
  END SUBROUTINE quadratic_fit

  !> Solves A*X = -v, where
  !! :param A the input array
  !! :param v the value
  SUBROUTINE findextremum(a, v, x, nd)
    REAL(DP), intent(inout)  :: a(:, :), v(:)
    REAL(DP), intent(out)    :: x(:)
    INTEGER(I4B), intent(in) :: nd

    INTEGER(I4B)        :: INFO, IPIV(nd)
    integer, save       :: lwork
    real(DP)            :: WORK(40)
    ! as it is, matrix 'a' is destroyed and v is overwritten

    if (lwork == 0) lwork = -1

    x = -v
    call DSYSV( 'L', nd, 1, a, nd, IPIV, x, nd, WORK, lwork, INFO )
    lwork = int(WORK(1))
    return
  END SUBROUTINE findextremum

  logical function checkextremum(x, icell, nn, nd, neighbour_list, nneigh, extmeta)
    REAL(DP),     intent(in), dimension(:)     :: x
    INTEGER(I8B), intent(in)                   :: icell
    INTEGER(I4B), intent(in)                   :: nn(:), nd, nneigh
    type(NEIGH_DATA), intent(in)               :: neighbour_list(:)
    type(EXT_META), intent(inout) :: extmeta

    INTEGER(I8B)                           :: ic
    INTEGER(I4B)                           :: i

    if (extmeta%l_map(icell) > 0) then
       checkextremum = .false.
       return
    endif

    ! Find extrema coordinates on a grid, and the nearest grid point
    ic = grid_to_index(nint(fkvadr(x+index_to_grid(icell, nn, nd), nn)), nn, nd)

    if ( ic == icell ) then
       checkextremum = .true.
    else
       ! checking for 'jitter'
       checkextremum = .false.
       do i = 1, nneigh
          if ( ic == neighbour_list(i)%pix ) then
             !             if (icell == 11100) write(0, *)'lmap', ic, l_map(ic), checkextremum
             if ( extmeta%l_map(ic) == -icell-1 ) then
                checkextremum = .true.
                !                JITTER = JITTER + 1           ! just counter for info
             else
                extmeta%l_map(icell) = -ic-1
             endif
             exit
          endif
       enddo
    endif
    return

  END FUNCTION checkextremum

  subroutine markextremum(vert, neighbour_list, nneigh, typ, extmeta)
    INTEGER(I8B), intent(in)          :: vert
    INTEGER(I4B), intent(in)          :: nneigh, typ
    TYPE(NEIGH_DATA), intent(in)      :: neighbour_list(:)
    type(EXT_META), intent(inout) :: extmeta

    INTEGER(I4B)                           :: i

    extmeta%l_map(vert) = typ
    forall (i=1:nneigh) extmeta%l_map(neighbour_list(i)%pix) = typ
    return

  END SUBROUTINE markextremum

  SUBROUTINE extremum_properties(vert, dc, nn, nd, a, v, x, ext)
    INTEGER(I8B),    intent(in)    :: vert
    REAL(SP),        intent(in)    :: dc
    INTEGER(I4B),    intent(in)    :: nn(:)
    INTEGER(I4B),    intent(in)    :: nd
    REAL(DP),        intent(in)    :: a(:, :), v(:), x(:)
    TYPE(EXT_DATA),  intent(inout) :: ext

    INTEGER(I4B)      :: WORK(10)
    INTEGER(I4B)      :: INFO

    ext%val       = dc + DOT_PRODUCT(x, 0.5_dp*MATMUL(a, x)+v)
    ext%pos(1:nd) = x + index_to_grid(vert, nn, nd)
    ext%pix       = grid_to_index(nint(fkvadr(ext%pos(1:nd), nn)), nn, nd)

    ! Find eigenvalues
    call DSYEV( 'N', 'L', nd, a, nd, ext%eig, WORK, 10, INFO )

    ! Set type
    ext%typ = nd + 1 - COUNT( ext%eig > 0 )

    return
  END SUBROUTINE extremum_properties

  !> Copies A first nd values into vm, the nd next into am diagonal
  !! and the rest of a into the out-of-diagonal part
  SUBROUTINE setmatrix(a, am, vm, nd)
    real(DP),  intent(in)    :: a(:) !! test
    integer(I4B), intent(in) :: nd
    real(DP),  intent(out)   :: am(nd, nd), vm(nd)

    integer(I4B)             :: i, j, m
    do i=1, nd
       vm(i)=a(i)
       am(i, i)=a(nd+i)
    enddo
    m=2*nd+1
    do j=2, nd
       do i=1, j-1
          am(i, j)=a(m)
          am(j, i)=am(i, j)
          m=m+1
       enddo
    enddo
    return

  END SUBROUTINE setmatrix

END MODULE extrema_mod