!******************************************************************************
!*
!*               GENERAL ADAPTATIVE GRID WITH ACCURACY CONTROL
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 04/2014
  !
  ! 3) DESCRIPTION: function generating adaptative grid, with control of the
  ! accuracy on the interpolation.
  !==========================================================================

MODULE adaptative_grid

  USE utilities, ONLY:
  USE arrays, ONLY:
  USE integration, ONLY:
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: gridadapt1D, grid_kernel

  INTERFACE gridadapt1D
    MODULE PROCEDURE gridadapt1D_simple, gridadapt1D_zgrid
  END INTERFACE gridadapt1D

CONTAINS

  ! Interface for DPRIMITIVE (removing the first element)
  !-------------------------
  PURE FUNCTION dPrim (x,f,xlog,ylog,lnx,lnf)

    USE utilities, ONLY: DP
    USE integration, ONLY: dPrimitive
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: x, f
    LOGICAL, INTENT(IN) :: xlog, ylog
    REAL(DP), INTENT(IN), DIMENSION(:), OPTIONAL :: lnx, lnf
    REAL(DP), DIMENSION(SIZE(x)-1) :: dPrim

    INTEGER :: N
    REAL(DP), DIMENSION(SIZE(x)) :: dF

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

    N = SIZE(x)
    IF (.NOT. xlog .AND. ylog) THEN
      dF(:) = DPRIMITIVE(x,f,XLOG=xlog,YLOG=ylog,LNF=lnf)
    ELSE IF (xlog .AND. ylog) THEN
      dF(:) = DPRIMITIVE(x,f,XLOG=xlog,YLOG=ylog,LNX=lnx,LNF=lnf)
    ELSE
      dF(:) = DPRIMITIVE(x,f,XLOG=xlog,YLOG=ylog)
    END IF
    dPrim(:) = dF(2:N)

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

  END FUNCTION dPrim

  !==========================================================================
  ! CALL GRIDADAPT1D_SIMPLE (xcoarse[N0],xfine[N],yfine[N],yfunc,accuracy, &
  !                          ABSACC=T/F,INTERP=T/F,INTEG=T/F,primitive[N], &
  !                          XLOG=T/F,YLOG=T/F,REEVALUATE=T/F,MINSTEP=, &
  !                          /LNFUNC,/RESCALE,/ADJUSTXLIM[2], &
  !                          SCALING=,NMAX=)
  !
  !   Returns an adaptative grid xfine[N], and function values yfine[N] of
  ! function, YFUNC, from an initial grid xcoarse[N0] (between x0min and x0max).
  ! The grid adapted so that the accuracy on the linear interpretation between
  ! two values is better than ACCURACY.
  !   If ABSACC is true, then it is an absolute accuracy (default is relative).
  !   If INTEG is true, the accuracy is on the integral and not on the
  ! interpolation.
  !   If keyword REEVALUATE is set, then the function is evaluated on the entire
  ! grid at each iteration, while it is evaluated only at mid-points if it is
  ! not set. REEVALUATE is used when the function needs the entire grid to be
  ! evaluated properly (normalization, etc.).
  !   If keyword SLIM is set, then we keep only the points needed to achieve
  ! the required accuracy, and not necessary the last midpoints. This keyword
  ! is useful when one want use the computed grid later. This way the grid has
  ! the minimal size.
  !  If /LNFUNC, then YFUNC is supposed to return ln(Y) instead of Y.
  !  If /RESCALE, then YFUNC is rescaled at each iteration so that its maximum
  ! sampled is 1. In the end the results YFINE and PRIMITIVE are affected by
  ! this rescaling. This scaling factor can be recovered through the SCALING
  ! argument. This function is useful when sampling a non normalized
  ! probability distribution.
  !==========================================================================

  SUBROUTINE gridadapt1D_simple (xcoarse,xfine,yfine,yfunc,accuracy,Nmax,  &
                                 absacc,interp,integ,primitive,xlog,ylog, &
                                 reevaluate,minstep,slim,verbose,rescale, &
                                 lnfunc,adjustxlim,scaling)

    USE utilities, ONLY: DP, tinyDP, hugeDP, epsDP, trimlr, pring, isNaN, &
                         verbatim
    USE arrays, ONLY: reallocate, ramp, iwhere
    USE integration, ONLY: dPrimitive
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: xcoarse
    REAL(DP), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: xfine, yfine
    REAL(DP), INTENT(IN) :: accuracy
    INTEGER, INTENT(IN), OPTIONAL :: Nmax
    REAL(DP), INTENT(IN), OPTIONAL :: minstep
    LOGICAL, INTENT(IN), OPTIONAL :: absacc, interp, integ, xlog, ylog
    LOGICAL, INTENT(IN), OPTIONAL :: reevaluate, slim, verbose, rescale, lnfunc
    LOGICAL, DIMENSION(2), INTENT(IN), OPTIONAL :: adjustxlim
    REAL(DP), INTENT(OUT), OPTIONAL :: scaling
    REAL(DP), INTENT(OUT), ALLOCATABLE, DIMENSION(:), OPTIONAL :: primitive
    INTERFACE
      FUNCTION yfunc (x)
        USE utilities, ONLY: DP
        IMPLICIT NONE
        REAL(DP), DIMENSION(:), INTENT(IN) :: x
        REAL(DP), DIMENSION(SIZE(x)) :: yfunc
      END FUNCTION yfunc
    END INTERFACE

    INTEGER, PARAMETER :: Nrefmax = 50
    INTEGER, PARAMETER :: Nmax0 = HUGE(KIND(1))

    INTEGER :: i, k, N0, N1, Nref, Nmaxi, counter, Nslim, i1, i2, Nlim
    INTEGER, DIMENSION(:), ALLOCATABLE :: imid0, imid1, ind1
    REAL(DP), DIMENSION(2) :: xlim
    REAL(DP), DIMENSION(:), ALLOCATABLE :: x0, x1, f0, f1, xmid, fmid, fmidint
    REAL(DP), DIMENSION(:), ALLOCATABLE :: lnx0, lnx1, lnf0, lnf1
    REAL(DP), DIMENSION(:), ALLOCATABLE :: lnxmid, lnfmid, lnfmidint
    REAL(DP), DIMENSION(:), ALLOCATABLE :: dF0, dF1, prim1, threshint
    REAL(DP), DIMENSION(:), ALLOCATABLE :: deltadF0, deltadF1, relstep
    REAL(DP) :: threshprim, stepmin, scaling0, scaling1, ratscl, maxf
    LOGICAL :: integacc, relacc, xl, yl, evalall, dontkeep
    LOGICAL :: verb, rescl, lnfn
    LOGICAL, DIMENSION(2) :: adjxlim, limOK
    LOGICAL, DIMENSION(:), ALLOCATABLE :: good0, good1, keep0, keep1

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

    !------------------------------------------------------------------------
    !                             I. Preliminary
    !------------------------------------------------------------------------

    ! 1) Manage keywords and options
    !-------------------------------
    ! Method
    integacc = .False.
    IF (PRESENT(integ)) integacc = integ
    IF (PRESENT(interp)) integacc = (.NOT. interp)

    ! Accuracy
    relacc = .True.
    IF (PRESENT(absacc)) relacc = (.NOT. absacc)

    ! Maximum size if required
    IF (PRESENT(Nmax)) THEN ; Nmaxi = Nmax ; ELSE ; Nmaxi = Nmax0 ; END IF

    ! Minimum step
    stepmin = epsDP
    IF (PRESENT(minstep)) stepmin = minstep

    ! Verbose
    verb = verbatim
    IF (PRESENT(verbose)) verb = verbose

    ! Lin/log
    xl = .False.
    IF (PRESENT(xlog)) xl = xlog
    yl = .False.
    IF (PRESENT(ylog)) yl = ylog

    ! Function evaluation
    evalall = .False.
    IF (PRESENT(reevaluate)) evalall = reevaluate
    lnfn = .False.
    IF (PRESENT(lnfunc)) lnfn = lnfunc
    rescl = .False.
    IF (PRESENT(rescale)) rescl = rescale
    IF (lnfn) THEN
      scaling0 = 0._DP
      scaling1 = 0._DP
    ELSE
      scaling0 = 1._DP
      scaling1 = 1._DP
    END IF

    ! Optimal grid
    dontkeep = .True.
    IF (PRESENT(slim)) dontkeep = slim

    ! Refinement of the coarse grid
    adjxlim(:) = [.False.,.False.]
    IF (PRESENT(adjustxlim)) adjxlim(:) = adjustxlim(:)
    limOK(:) = ( .NOT. adjxlim(:) )
    xlim(:) = [ MINVAL(xcoarse(:)), MAXVAL(xcoarse(:)) ]

    ! 2) Design the coarse grid
    !--------------------------
    ! Initialize the coarse grid
    N0 = SIZE(xcoarse(:))
    ALLOCATE (x0(N0),f0(N0))
    IF (yl .OR. lnfn) ALLOCATE(lnf0(N0))
    x0(:) = xcoarse(:)
    IF (verb) PRINT*, "Adapatative grid: coarse grid; N = "//TRIMLR(PRING(N0))

    ! Push the limits away, if required
    counter = 0
    coarsegrid: DO

      ! Swap
      N1 = N0
      CALL REALLOCATE(x1,N1)
      CALL REALLOCATE(f1,N1)
      IF (yl .OR. lnfn) CALL REALLOCATE(lnf1,N1)
      x1(:) = x0(:)
      scaling1 = scaling0

      ! Evalutate the function
      evalinit: IF (.NOT. evalall) THEN
        notallinit: IF (.NOT. lnfn) THEN
          IF (counter == 0) THEN
            f1(:) = YFUNC(x1(:))
          ELSE
            Nlim = COUNT(.NOT. limOK(:))
            IF (Nlim > 0) THEN
              CALL REALLOCATE(ind1,Nlim)
              ind1(:) = PACK( [1,N1], (.NOT. limOK(:)) )
              f1(ind1(:)) = YFUNC(x1(ind1(:))) / scaling1
            END IF
            f1(i1:i2) = f0(i1:i2)
          END IF
          IF (rescl) THEN
            maxf = MAXVAL(f1(:)) * scaling1
            scaling1 = MERGE( maxf, scaling0, &
                              ABS(maxf) < hugeDP .AND. ABS(maxf) > tinyDP )
            f1(:) = f1(:) * ( scaling0 / scaling1 )
          END IF
          IF (yl) THEN
            lnf1(:) = LOG(f1(:))
            WHERE (f1(:) < tinyDP) lnf1(:) = -hugeDP
          END IF
        ELSE
          IF (counter == 0) THEN
            lnf1(:) = YFUNC(x1(:))
          ELSE
            Nlim = COUNT(.NOT. limOK(:))
            IF (Nlim > 0) THEN
              CALL REALLOCATE(ind1,Nlim)
              ind1(:) = PACK( [1,N1], (.NOT. limOK(:)) )
              lnf1(ind1(:)) = YFUNC(x1(ind1(:))) - scaling1
            END IF
            lnf1(i1:i2) = lnf0(i1:i2)
          END IF
          IF (rescl) THEN
            maxf = MAXVAL(lnf1(:)) + scaling0
            scaling1 = MERGE( maxf, scaling0, ABS(maxf) < hugeDP )
            lnf1(:) = lnf1(:) + ( scaling0 - scaling1 )
          END IF
          f1(:) = EXP(lnf1(:))
        END IF notallinit
      ELSE
        allinit: IF (.NOT. lnfn) THEN
          f1(:) = YFUNC(x1(:))
          IF (rescl) THEN
            maxf = MAXVAL(f1(:))
            scaling1 = MERGE( maxf, 1._DP, &
                              ABS(maxf) < hugeDP .AND. ABS(maxf) > tinyDP )
            f1(:) = f1(:) / scaling1
          END IF
          IF (yl) THEN
            lnf1(:) = LOG(f1(:))
            WHERE (f1(:) < tinyDP) lnf1(:) = -hugeDP
          END IF
        ELSE
          lnf1(:) = YFUNC(x1(:))
          IF (rescl) THEN
            maxf = MAXVAL(lnf1(:))
            scaling1 = MERGE( maxf, 0._DP, ABS(maxf) < hugeDP )
            lnf1(:) = lnf1(:) - scaling1
          END IF
          f1(:) = EXP(lnf1(:))
        END IF allinit
      END IF evalinit

      ! Iterate until we find zeros on each side. This method implicitly assumes
      ! that some non-zero values of the function are included in the original
      ! interval. The iteration looks for the edges (below machine precision).
      ! This method is not appropriate if the function has several narrow peaks
      ! with zeros between them.
      counter = counter + 1
      adjustlim: IF ( ALL(limOK(:)) .OR. counter == Nrefmax ) THEN
        EXIT
      ELSE
        IF (.NOT. limOK(1)) THEN
          IF (f1(1) > tinyDP .AND. f1(2) /= f1(1)) THEN
            xlim(1) = MERGE( x1(1)**2/x1(N1), 2._DP*x1(1)-x1(N1), xl )
          ELSE
            xlim(1) = x1(1)
            limOK(1) = .True.
          END IF
        END IF
        IF (.NOT. limOK(2)) THEN
          IF (f1(N1) > tinyDP .AND. f1(N1-1) /= f1(N1)) THEN
            xlim(2) = MERGE( x1(N1)**2/x1(1), 2._DP*x1(N1)-x1(1), xl )
          ELSE
            xlim(2) = x1(N1)
            limOK(2) = .True.
          END IF
        END IF
        N0 = N1 + COUNT(.NOT. limOK(:))
        IF (verb .AND. ANY(.NOT. limOK(:))) &
          PRINT*, "Adapatative grid: new limits "//TRIMLR(PRING(counter)) &
                  //"; N="//TRIMLR(PRING(N0))
        CALL REALLOCATE(x0,N0)
        CALL REALLOCATE(f0,N0)
        IF (yl .OR. lnfn) CALL REALLOCATE(lnf0,N0)
        i1 = MERGE( 1, 2, limOK(1) )
        i2 = MERGE( N0, N0-1, limOK(2) )
        x0(i1:i2) = x1(:)
        f0(i1:i2) = f1(:)
        scaling0 = scaling1
        IF (yl .OR. lnfn) lnf0(i1:i2) = lnf1(:)
        IF (.NOT. limOK(1)) x0(1) = xlim(1)
        IF (.NOT. limOK(2)) x0(N0) = xlim(2)
      END IF adjustlim

    END DO coarsegrid

    ! Primitive on the coarse grid
    IF (xl) THEN
      ALLOCATE (lnx1(N1))
      lnx1(:) = LOG(x1(:))
    END IF
    IF (integacc) THEN
      ALLOCATE (dF1(N1))
      IF (.NOT. xl .AND. yl) THEN
        dF1(:) = DPRIMITIVE(x1(:),f1(:),XLOG=xl,YLOG=yl,LNF=lnf1(:))
      ELSE IF (xl .AND. yl) THEN
        dF1(:) = DPRIMITIVE(x1(:),f1(:),XLOG=xl,YLOG=yl, &
                            LNX=lnx1(:),LNF=lnf1(:))
      ELSE
        dF1(:) = DPRIMITIVE(x1(:),f1(:),XLOG=xl,YLOG=yl)
      END IF
      ALLOCATE(deltadF1(N1-1))
      deltadF1(:) = SUM(dF1(:)) ! large value for initialization
    END IF
    Nref = N1 - 1
    ALLOCATE (good1(N1-1))
    good1(:) = .False.
    IF (dontkeep) THEN
      ALLOCATE (keep1(N1))
      keep1(:) = .True.
    END IF

    !------------------------------------------------------------------------
    !                         II. Refining the grid
    !------------------------------------------------------------------------

    counter = 0
    refinement: DO

      ! 1) Preamble
      !------------
      ! Update the various arrays
      N0 = N1
      CALL REALLOCATE(x0,N0)
      CALL REALLOCATE(f0,N0)
      CALL REALLOCATE(good0,N0-1)
      IF (dontkeep) CALL REALLOCATE(keep0,N0)
      x0(:) = x1(:)
      f0(:) = f1(:)
      IF (xl) THEN
        CALL REALLOCATE(lnx0,N0)
        lnx0(:) = lnx1(:)
      END IF
      IF (yl .OR. lnfn) THEN
        CALL REALLOCATE(lnf0,N0)
        lnf0(:) = lnf1(:)
      END IF
      good0(:) = good1(:)
      IF (dontkeep) keep0(:) = keep1(:)
      IF (integacc) THEN
        CALL REALLOCATE(dF0,N0)
        dF0(:) = dF1(:)
        CALL REALLOCATE(deltadF0,N0-1)
        deltadF0(:) = deltadF1(:)
      END IF
      IF (rescl) scaling0 = scaling1

      ! Indices where to refine
      N1 = N0 + Nref
      IF (verb) &
        PRINT*, "Adapatative grid: iteration "//TRIMLR(PRING(counter+1)) &
                //"; N = "//TRIMLR(PRING(N1))
      CALL REALLOCATE(imid0,Nref) ! position of mid-points on grid 0 (x0 below)
      CALL REALLOCATE(imid1,Nref) ! position of mid-points on grid 1
      CALL REALLOCATE(ind1,N0)    ! position of grid 0 points on grid 1
      imid0(:) = PACK([(i,i=1,N0-1)],.NOT. good0(:))
      imid1(:) = imid0(:) + [(i,i=1,Nref)]
      k = 0
      ind1(1) = 1
      DO i=2,N0
        IF (.NOT. good0(i-1)) k = k + 1
        ind1(i) = i + k
      END DO

      ! 2) Refine the grid
      !-------------------
      ! Add mid-points where needed
      CALL REALLOCATE(xmid,Nref)
      IF (xl) THEN
        CALL REALLOCATE(lnxmid,Nref)
        lnxmid(:) = 0.5_DP * ( lnx0(imid0(:)+1) + lnx0(imid0(:)) )
        xmid(:) = EXP(lnxmid(:))
      ELSE
        xmid(:) = 0.5_DP * ( x0(imid0(:)+1) + x0(imid0(:)) )
      END IF

      ! Update the refinement of the grid
      CALL REALLOCATE(x1,N1)
      x1(ind1(:)) = x0(:)
      x1(imid1(:)) = xmid(:)
      IF (xl) THEN
        CALL REALLOCATE(lnx1,N1)
        lnx1(ind1(:)) = lnx0(:)
        lnx1(imid1(:)) = lnxmid(:)
      END IF

      ! Evaluate function on the new grid
      evalfunc: IF (.NOT. evalall) THEN
        CALL REALLOCATE(fmid,Nref)
        mideval: IF (.NOT. lnfn) THEN
          fmid(:) = YFUNC(xmid(:))
          midrescl: IF (rescl) THEN
            maxf = MAXVAL(fmid(:))
            scaling1 = MERGE( maxf, scaling0, &
                              ( ABS(maxf) < hugeDP .AND. ABS(maxf) > tinyDP ) )
            IF (scaling1 >= scaling0) THEN
              ratscl = scaling0 / scaling1
              f0(:) = f0(:) * ratscl
              IF (yl) lnf0(:) = lnf0(:) + LOG(ratscl)
              IF (integacc) THEN
                dF0(:) = dF0(:) * ratscl
                deltadF0(:) = deltadF0(:) * ratscl
              END IF
            ELSE
              scaling1 = scaling0
            END IF
            fmid(:) = fmid(:) / scaling1
          END IF midrescl
          IF (yl) THEN
            CALL REALLOCATE(lnfmid,Nref)
            lnfmid(:) = LOG(fmid(:))
            WHERE (fmid(:) < tinyDP) lnfmid(:) = -hugeDP
          END IF
        ELSE
          CALL REALLOCATE(lnfmid,Nref)
          lnfmid(:) = YFUNC(xmid(:))
          midlnrescl: IF (rescl) THEN
            maxf = MAXVAL(lnfmid(:))
            scaling1 = MERGE( maxf, scaling0, ABS(maxf) < hugeDP )
            IF (scaling1 >= scaling0) THEN
              ratscl = EXP( scaling0 - scaling1 )
              f0(:) = f0(:) * ratscl
              lnf0(:) = lnf0(:) + ( scaling0 - scaling1 )
              IF (integacc) THEN
                dF0(:) = dF0(:) * ratscl
                deltadF0(:) = deltadF0(:) * ratscl
              END IF
            ELSE
              scaling1 = scaling0
            END IF
          END IF midlnrescl
          lnfmid(:) = lnfmid(:) - scaling1
          fmid(:) = EXP(lnfmid(:))
        END IF mideval
        CALL REALLOCATE(f1,N1)
        f1(ind1(:)) = f0(:)
        f1(imid1(:)) = fmid(:)
        IF (yl .OR. lnfn) THEN
          CALL REALLOCATE(lnf1,N1)
          lnf1(ind1(:)) = lnf0(:)
          lnf1(imid1(:)) = lnfmid(:)
        END IF
      ELSE
        CALL REALLOCATE(f1,N1)
        CALL REALLOCATE(fmid,Nref)
        alleval: IF (.NOT. lnfn) THEN
          f1(:) = YFUNC(x1(:))
          allrescl: IF (rescl) THEN
            maxf = MAXVAL(f1(:))
            scaling1 = MERGE( maxf, 1._DP, &
                              ( ABS(maxf) < hugeDP .AND. ABS(maxf) > tinyDP ) )
            ratscl = scaling0 / scaling1
            f0(:) = f0(:) * ratscl
            IF (yl) lnf0(:) = lnf0(:) + LOG(ratscl)
            IF (integacc) THEN
              dF0(:) = dF0(:) * ratscl
              deltadF0(:) = deltadF0(:) * ratscl
            END IF
          END IF allrescl
          fmid(:) = f1(imid1(:))
          IF (yl) THEN
            CALL REALLOCATE(lnf1,N1)
            lnf1(:) = LOG(f1(:))
            WHERE (f1(:) < tinyDP) lnf1(:) = -hugeDP
            CALL REALLOCATE(lnfmid,Nref)
            lnfmid(:) = lnf1(imid1(:))
          END IF
        ELSE
          CALL REALLOCATE(lnf1,N1)
          lnf1(:) = YFUNC(x1(:))
          alllnrescl: IF (rescl) THEN
            maxf = MAXVAL(lnf1(:))
            scaling1 = MERGE( maxf, 0._DP, ABS(maxf) < hugeDP )
            ratscl = EXP( scaling0 - scaling1 )
            f0(:) = f0(:) * ratscl
            lnf0(:) = lnf0(:) + ( scaling0 - scaling1 )
            IF (integacc) THEN
              dF0(:) = dF0(:) * ratscl
              deltadF0(:) = deltadF0(:) * ratscl
            END IF
          END IF alllnrescl
          CALL REALLOCATE(lnfmid,Nref)
          lnfmid(:) = lnf1(imid1(:))
          f1(:) = EXP(lnf1(:))
          fmid(:) = f1(imid1(:))
        END IF alleval
      END IF evalfunc

      ! Update the mask
      CALL REALLOCATE(good1,N1-1)
      good1(ind1(1:N0-1)) = good0(:)

      ! 3) Interpolation method
      !------------------------
      interpol: IF (.NOT. integacc) THEN

        ! Interpolation at mid-point
        CALL REALLOCATE(fmidint,Nref)
        IF (yl) THEN
          CALL REALLOCATE(lnfmidint,Nref)
          lnfmidint(:) = lnf0(imid0(:)) &
                       + 0.5_DP * ( lnf0(imid0(:)+1) - lnf0(imid0(:)) )
          fmidint(:) = EXP(lnfmidint(:))
        ELSE
          fmidint(:) = f0(imid0(:)) + 0.5_DP * ( f0(imid0(:)+1) - f0(imid0(:)) )
        END IF

        ! Update the mask
        CALL REALLOCATE(threshint,Nref)
        IF (relacc) THEN
          WHERE( ABS(fmid(:)) > tinyDP/accuracy )
            threshint(:) = ABS(fmid(:)) * accuracy
          ELSEWHERE ( ABS(fmidint(:)) > tinyDP/accuracy )
            threshint(:) = ABS(fmidint(:)) * accuracy
          ELSEWHERE
            threshint(:) = ABS(fmid(:)-fmidint(:)) * 2._DP
          END WHERE
        ELSE
          threshint(:) = accuracy
        END IF
        FORALL (i=1:Nref) &
          good1(imid1(i)-1:imid1(i)) &
            = ( ABS(fmid(i) - fmidint(i)) <= threshint(i) .OR. isNaN(fmid(i)) &
                .OR. threshint(i) < tinyDP )
        IF (yl) THEN
          FORALL (i=1:Nref,fmid(i) < tinyDP) good1(imid1(i)-1:imid1(i)) = .True.
        END IF
      END IF interpol

      ! 4) Integration method
      !----------------------
      ! Compute the primitive
      integr: IF (integacc) THEN
        CALL REALLOCATE(dF1,N1)
        evalprim: IF (.NOT. evalall) THEN

          dF1(ind1(:)) = dF0(:)
          linlog: IF (.NOT. xl .AND. yl) THEN
            FORALL (i=1:Nref) &
              dF1(imid1(i):imid1(i)+1) = &
                DPRIM( [x0(imid0(i)),xmid(i),x0(imid0(i)+1)], &
                       [f0(imid0(i)),fmid(i),f0(imid0(i)+1)], &
                       XLOG=xl,YLOG=(lnf0(imid0(i))/=lnf0(imid0(i)+1)), &
                       LNF=[lnf0(imid0(i)),lnfmid(i),lnf0(imid0(i)+1)] )
          ELSE IF (xl .AND. yl) THEN
            FORALL (i=1:Nref) &
              dF1(imid1(i):imid1(i)+1) = &
                DPRIM( [x0(imid0(i)),xmid(i),x0(imid0(i)+1)], &
                       [f0(imid0(i)),fmid(i),f0(imid0(i)+1)], XLOG=xl, YLOG=yl,&
                       LNX=[lnx0(imid0(i)),lnxmid(i),lnx0(imid0(i)+1)], &
                       LNF=[lnf0(imid0(i)),lnfmid(i),lnf0(imid0(i)+1)] )
          ELSE
            FORALL (i=1:Nref) &
              dF1(imid1(i):imid1(i)+1) = &
                DPRIM( [x0(imid0(i)),xmid(i),x0(imid0(i)+1)], &
                       [f0(imid0(i)),fmid(i),f0(imid0(i)+1)], XLOG=xl, YLOG=yl )
          END IF linlog

        ELSE

          linlog2: IF (.NOT. xl .AND. yl) THEN
            dF1(:) = DPRIMITIVE(x1(:),f1(:),XLOG=xl,YLOG=yl,LNF=lnf1(:))
          ELSE IF (xl .AND. yl) THEN
            dF1(:) = DPRIMITIVE(x1(:),f1(:),XLOG=xl,YLOG=yl, &
                                LNX=lnx1(:),LNF=lnf1(:))
          ELSE
            dF1(:) = DPRIMITIVE(x1(:),f1(:),XLOG=xl,YLOG=yl)
          END IF linlog2

        END IF evalprim
        WHERE (ISNAN(dF1(:))) dF1(:) = 0._DP
        IF (yl) &
          WHERE (dF1(:) <= 0._DP) dF1(:) = 0._DP

        ! Decide where to refine
        CALL REALLOCATE(deltadF1,N1-1)
        deltadF1(ind1(1:N0-1)) = deltadF0(:)
        FORALL (i=1:Nref) &
          deltadF1(imid1(i)-1:imid1(i)) = ABS( SUM(dF1(imid1(i):imid1(i)+1)) &
                                             - dF0(imid0(i)+1) )
        threshprim = MERGE(accuracy * SUM(dF1(:)) / SQRT(REAL(N1,DP)), &
                           accuracy,relacc)
        good1(:) = ( deltadF1(:) <= threshprim )

      END IF integr

      ! 5) Adjustments and exit conditions
      !-----------------------------------
      ! Case of narrow support function
      IF (yl .OR. lnfn) THEN
        IF (COUNT(f1(:) > 0._DP) <= 1) good1(:) = .False.
      END IF

      ! Slim mode
      IF (dontkeep) THEN
        CALL REALLOCATE(keep1,N1)
        keep1(ind1(:)) = keep0(:)
        keep1(imid1(:)) = (.NOT. good1(imid1(:)) )
      END IF

      ! Enforce minimum step
      CALL REALLOCATE (relstep,Nref)
      relstep(:) = (x0(imid0(:)+1)-x0(imid0(:))) &
                 / MERGE(x0(imid0(:)),x0(imid0(:)+1),x0(imid0(:)) /= 0._DP)
      FORALL (i=1:Nref,ABS(relstep(i)) <= stepmin) &
        good1(imid1(i)-1:imid1(i)) = .True.

      ! Exit when no more refinement is needed
      Nref = COUNT(.NOT. good1)
      counter = counter + 1
      IF (counter == Nrefmax .OR. Nref == 0 .OR. N1 >= Nmaxi) EXIT

    END DO refinement

    !------------------------------------------------------------------------
    !                          III. Final grid
    !------------------------------------------------------------------------

    ! Slim mode
    nokeep: IF (.NOT. dontkeep) THEN
      ALLOCATE (xfine(N1),yfine(N1))
      xfine(:) = x1(:)
      yfine(:) = f1(:)
    ELSE
      Nslim = COUNT(keep1(:))
      ALLOCATE (xfine(Nslim),yfine(Nslim))
      xfine(:) = PACK(x1(:),keep1(:))
      yfine(:) = PACK(f1(:),keep1(:))
    END IF nokeep

    ! Primitive
    doprim: IF (integacc .AND. PRESENT(primitive)) THEN
      IF (.NOT. dontkeep) THEN
        ALLOCATE (primitive(N1))
        primitive(1) = 0._DP
        DO i=2,N1 ; primitive(i) = dF1(i) + primitive(i-1) ; END DO
      ELSE
        ALLOCATE (prim1(N1),primitive(Nslim))
        prim1(1) = 0._DP
        DO i=2,N1 ; prim1(i) = dF1(i) + prim1(i-1) ; END DO
        primitive(:) = PACK(prim1(:),keep1(:))
        DEALLOCATE (prim1)
      END IF
    END IF doprim

    ! Scaling
    IF (rescl .AND. PRESENT (scaling)) &
      scaling = MERGE(EXP(scaling1),scaling1,lnfn)

    ! Clean memory
    IF (verb) PRINT*, "Adaptative grid: packing and tagging..."
    DEALLOCATE(x0,x1,f0,f1,ind1,good0,good1,imid0,imid1,xmid,fmid,relstep)
    IF (yl .OR. lnfn) DEALLOCATE(lnf0,lnf1,lnfmid)
    IF (xl) DEALLOCATE(lnx0,lnx1,lnxmid)
    IF (integacc) DEALLOCATE(dF0,dF1,deltadF0,deltadF1)
    IF (dontkeep) DEALLOCATE(keep0,keep1)
    IF (.NOT. integacc) DEALLOCATE(fmidint)
    IF (.NOT. integacc .AND. yl) DEALLOCATE(lnfmidint)
    IF (.NOT. integacc) DEALLOCATE(threshint)

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

  END SUBROUTINE gridadapt1D_simple

  !==========================================================================
  ! CALL GRIDADAPT1D_ZGRID (xcoarse[N0],zgrid[Nz],xfine[N],yfine[N,Nz],yfunc, &
  !                         accuracy,ABSACC=T/F,INTERP=T/F,INTEG=T/F, &
  !                         REEVALUATE=T/F,primitive[N],slim)
  !
  !   Returns an adaptative grid xfine[N], and function values yfine[N] of
  ! function, YFUNC, from an initial grid xcoarse[N0] (between x0min and x0max).
  ! The grid adapted so that the accuracy on the linear interpretation between
  ! two values is better than ACCURACY. The difference between the _SIMPLE and
  ! _ZGRID procedures, is that the interpolation of the data is simple in the
  ! first case, and is done at one value of X, but several value of an
  ! additional parameter Z, for _ZGRID. The latter case, can be the sampling
  ! in wavelength (X) of a black body spectrum, that has to be accurate for
  ! all temperatures (Z).
  !   IF ABSACC is true, then it is an absolute accuracy (default is relative).
  !   If INTEG is true, the accuracy is on the integral and not on the
  ! interpolation.
  !   IF keyword REEVALUATE is set, then the function is evaluated on the entire
  ! grid at each iteration, while it is evaluated only at mid-points if it is
  ! not set. REEVALUATE is used when the function needs the entire grid to be
  ! evaluated properly (normalization, etc.).
  !   IF keyword SLIM is set, then we keep only the points needed to achieve
  ! the required accuracy, and not necessary the last midpoints. This keyword
  ! is useful when one want use the computed grid later. This way the grid has
  ! the minimal size.
  !==========================================================================

  SUBROUTINE gridadapt1D_zgrid (xcoarse,zgrid,xfine,yfine,yfunc,accuracy, &
                                absacc,interp,integ,primitive,xlog,ylog, &
                                reevaluate,minstep,slim,verbose)

    USE utilities, ONLY: DP, tinyDP, hugeDP, epsDP, trimlr, pring, isNaN, &
                         verbatim
    USE arrays, ONLY: reallocate
    USE integration, ONLY: dPrimitive
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:) :: xcoarse, zgrid
    REAL(DP), INTENT(OUT), ALLOCATABLE, DIMENSION(:) :: xfine
    REAL(DP), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:) :: yfine
    REAL(DP), INTENT(IN) :: accuracy
    REAL(DP), INTENT(IN), OPTIONAL :: minstep
    LOGICAL, INTENT(IN), OPTIONAL :: absacc, interp, integ, xlog, ylog
    LOGICAL, INTENT(IN), OPTIONAL :: reevaluate, slim, verbose
    REAL(DP), INTENT(OUT), ALLOCATABLE, DIMENSION(:,:), OPTIONAL :: primitive
    INTERFACE
      FUNCTION yfunc (x,z)
        USE utilities, ONLY: DP
        IMPLICIT NONE
        REAL(DP), DIMENSION(:), INTENT(IN) :: x, z
        REAL(DP), DIMENSION(SIZE(x),SIZE(z)) :: yfunc
      END FUNCTION yfunc
    END INTERFACE

    INTEGER, PARAMETER :: Nrefmax = 50

    INTEGER :: i, k, iz, N0, N1, Nz, Nref, counter, Nslim
    INTEGER, DIMENSION(:), ALLOCATABLE :: imid0, imid1, ind1
    REAL(DP), DIMENSION(SIZE(zgrid)) :: threshprim
    REAL(DP), DIMENSION(:), ALLOCATABLE :: x0, x1, xmid, lnx0, lnx1, lnxmid
    REAL(DP), DIMENSION(:), ALLOCATABLE :: relstep
    REAL(DP), DIMENSION(:,:), ALLOCATABLE :: lnf0, lnf1, f0, f1, fmid, fmidint
    REAL(DP), DIMENSION(:,:), ALLOCATABLE :: lnfmid, lnfmidint, threshint
    REAL(DP), DIMENSION(:,:), ALLOCATABLE :: dF0, dF1, prim1
    REAL(DP), DIMENSION(:,:), ALLOCATABLE :: deltadF0, deltadF1
    REAL(DP) :: stepmin
    LOGICAL :: integacc, relacc, xl, yl, evalall, dontkeep, verb
    LOGICAL, DIMENSION(:), ALLOCATABLE :: good0, good1, keep0, keep1

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

    ! 1. Preliminary
    !---------------
    ! Method
    integacc = .False.
    IF (PRESENT(integ)) integacc = integ
    IF (PRESENT(interp)) integacc = (.NOT. interp)

    ! Accuracy
    relacc = .True.
    IF (PRESENT(absacc)) relacc = (.NOT. absacc)

    ! Minimum step
    stepmin = epsDP
    IF (PRESENT(minstep)) stepmin = minstep

    ! Verbose
    verb = verbatim
    IF (PRESENT(verbose)) verb = verbose

    ! Lin/log
    xl = .False.
    IF (PRESENT(xlog)) xl = xlog
    yl = .False.
    IF (PRESENT(ylog)) yl = ylog

    ! Function evaluation
    evalall = .False.
    IF (PRESENT(reevaluate)) evalall = reevaluate

    ! Optimal grid
    dontkeep = .True.
    IF (PRESENT(slim)) dontkeep = slim

    ! Coarse grid
    N1 = SIZE(xcoarse)
    IF (verb) PRINT*, "Adapatative grid: coarse grid; N = "//TRIMLR(PRING(N1))
    Nz = SIZE(zgrid)
    ALLOCATE (x1(N1),f1(N1,Nz))
    x1(:) = xcoarse(:)
    f1(:,:) = YFUNC(x1(:),zgrid(:))
    IF (xl) THEN
      ALLOCATE (lnx1(N1))
      lnx1(:) = LOG(x1(:))
    END IF
    IF (yl) THEN
      ALLOCATE (lnf1(N1,Nz))
      lnf1(:,:) = LOG(f1(:,:))
      WHERE (f1(:,:) < tinyDP) lnf1(:,:) = -hugeDP
    END IF
    IF (integacc) THEN
      ALLOCATE (dF1(N1,Nz))
      IF (.NOT. xl .AND. yl) THEN
        FORALL(iz=1:Nz) &
          dF1(:,iz) = dPRIMITIVE(x1,f1(:,iz),XLOG=xl,YLOG=yl,LNF=lnf1(:,iz))
      ELSE IF (xl .AND. yl) THEN
        FORALL(iz=1:Nz) &
          dF1(:,iz) = DPRIMITIVE(x1(:),f1(:,iz),XLOG=xl,YLOG=yl, &
                            LNX=lnx1(:),LNF=lnf1(:,iz))
      ELSE
        FORALL(iz=1:Nz) &
          dF1(:,iz) = DPRIMITIVE(x1(:),f1(:,iz),XLOG=xl,YLOG=yl)
      END IF
      ALLOCATE(deltadF1(N1-1,Nz))
      FORALL (iz=1:Nz) deltadF1(:,iz) = SUM(dF1(:,iz)) ! large value for start
    END IF
    Nref = N1 - 1
    ALLOCATE (good1(N1-1))
    good1(:) = .False.
    IF (dontkeep) THEN
      ALLOCATE (keep1(N1))
      keep1(:) = .True.
    END IF

    ! 2. Refining the grid
    !---------------------
    counter = 0
    refinement: DO

      ! Preamble
      N0 = N1
      CALL REALLOCATE(x0,N0)
      CALL REALLOCATE(f0,N0,Nz)
      CALL REALLOCATE(good0,N0-1)
      IF (dontkeep) CALL REALLOCATE(keep0,N0)
      x0(:) = x1(:)
      f0(:,:) = f1(:,:)
      IF (xl) THEN
        CALL REALLOCATE(lnx0,N0)
        lnx0(:) = lnx1(:)
      END IF
      IF (yl) THEN
        CALL REALLOCATE(lnf0,N0,Nz)
        lnf0(:,:) = lnf1(:,:)
      END IF
      good0(:) = good1(:)
      IF (dontkeep) keep0(:) = keep1(:)
      IF (integacc) THEN
        CALL REALLOCATE(dF0,N0,Nz)
        dF0(:,:) = dF1(:,:)
        CALL REALLOCATE(deltadF0,N0-1,Nz)
        deltadF0(:,:) = deltadF1(:,:)
      END IF

      ! Indices where to refine
      N1 = N0 + Nref
      IF (verb) &
        PRINT*, "Adapatative grid: iteration "//TRIMLR(PRING(counter+1)) &
                //"; N = "//TRIMLR(PRING(N1))
      CALL REALLOCATE(imid0,Nref) ! position of mid-points on grid 0 (x0 below)
      CALL REALLOCATE(imid1,Nref) ! position of mid-points on grid 1
      CALL REALLOCATE(ind1,N0)    ! position of grid 0 points on grid 1
      imid0(:) = PACK([(i,i=1,N0-1)],.NOT. good0)
      imid1(:) = imid0(:) + [(i,i=1,Nref)]
      k = 0
      ind1(1) = 1
      DO i=2,N0
        IF (.NOT. good0(i-1)) k = k + 1
        ind1(i) = i + k
      END DO

      ! Add mid-points where needed
      CALL REALLOCATE(xmid,Nref)
      IF (xl) THEN
        CALL REALLOCATE(lnxmid,Nref)
        lnxmid(:) = 0.5_DP * ( lnx0(imid0(:)+1) + lnx0(imid0(:)) )
        xmid(:) = EXP(lnxmid(:))
      ELSE
        xmid(:) = 0.5_DP * ( x0(imid0(:)+1) + x0(imid0(:)) )
      END IF

      ! Update the refinement
      CALL REALLOCATE(x1,N1)
      x1(ind1(:)) = x0(:)
      x1(imid1(:)) = xmid(:)
      IF (xl) THEN
        CALL REALLOCATE(lnx1,N1)
        lnx1(ind1(:)) = lnx0(:)
        lnx1(imid1(:)) = lnxmid(:)
      END IF

      ! Evaluate the function on the new grid
      evalfunc: IF (.NOT. evalall) THEN
        CALL REALLOCATE(fmid,Nref,Nz)
        fmid(:,:) = YFUNC(xmid(:),zgrid(:))
        IF (yl) THEN
          CALL REALLOCATE(lnfmid,Nref,Nz)
          lnfmid(:,:) = LOG(fmid(:,:))
          WHERE (fmid(:,:) < tinyDP) lnfmid(:,:) = -hugeDP
        END IF
        CALL REALLOCATE(f1,N1,Nz)
        f1(ind1(:),:) = f0(:,:)
        f1(imid1(:),:) = fmid(:,:)
        IF (yl) THEN
          CALL REALLOCATE(lnf1,N1,Nz)
          lnf1(ind1(:),:) = lnf0(:,:)
          lnf1(imid1(:),:) = lnfmid(:,:)
        END IF
      ELSE
        CALL REALLOCATE(f1,N1,Nz)
        CALL REALLOCATE(fmid,Nref,Nz)
        f1(:,:) = YFUNC(x1(:),zgrid(:))
        fmid(:,:) = f1(imid1(:),:)
        IF (yl) THEN
          CALL REALLOCATE(lnf1,N1,Nz)
          lnf1(:,:) = LOG(f1(:,:))
          WHERE (f1(:,:) < tinyDP) lnf1(:,:) = -hugeDP
          CALL REALLOCATE(lnfmid,Nref,Nz)
          lnfmid(:,:) = lnf1(imid1(:),:)
        END IF
      END IF evalfunc

      ! Interpolation at mid-point
      CALL REALLOCATE(fmidint,Nref,Nz)
      IF (yl) THEN
        CALL REALLOCATE(lnfmidint,Nref,Nz)
        lnfmidint(:,:) = lnf0(imid0(:),:) &
                       + 0.5_DP * ( lnf0(imid0(:)+1,:) - lnf0(imid0(:),:) )
        fmidint(:,:) = EXP(lnfmidint(:,:))
      ELSE
        fmidint(:,:) = f0(imid0(:),:) &
                     + 0.5_DP * ( f0(imid0(:)+1,:) - f0(imid0(:),:) )
      END IF

      ! Update the mask
      CALL REALLOCATE(good1,N1-1)
      good1(ind1(1:N0-1)) = good0(:)
      interpol: IF (.NOT. integacc) THEN
        CALL REALLOCATE(threshint,Nref,Nz)
        IF (relacc) THEN
          FORALL(iz=1:Nz)
            WHERE( ABS(fmid(:,iz)) > tinyDP/accuracy )
              threshint(:,iz) = ABS(fmid(:,iz)) * accuracy
            ELSEWHERE ( ABS(fmidint(:,iz)) > tinyDP/accuracy )
              threshint(:,iz) = ABS(fmidint(:,iz)) * accuracy
            ELSEWHERE
              threshint(:,iz) = ABS(fmid(:,iz)-fmidint(:,iz)) * 2._DP
            END WHERE
          END FORALL
        ELSE
          threshint(:,:) = accuracy
        END IF
        FORALL (i=1:Nref) &
          good1(imid1(i)-1:imid1(i)) &
            = ALL( ABS(fmid(i,:) - fmidint(i,:)) <= threshint(i,:) &
                   .OR. isNaN(fmid(i,:)) .OR. threshint(i,:) < tinyDP)
        IF (yl) THEN
          FORALL (i=1:Nref,ALL(fmid(i,:) < tinyDP)) &
            good1(imid1(i)-1:imid1(i)) = .True.
        END IF
      END IF interpol

      ! Compute the primitive
      integr: IF (integacc) THEN
        CALL REALLOCATE(dF1,N1,Nz)
        evalprim: IF (.NOT. evalall) THEN

          dF1(ind1(:),:) = dF0(:,:)
          linlog: IF (.NOT. xl .AND. yl) THEN
            FORALL (i=1:Nref,iz=1:Nz) &
              dF1(imid1(i):imid1(i)+1,iz) = &
                DPRIM( [x0(imid0(i)),xmid(i),x0(imid0(i)+1)], &
                       [f0(imid0(i),iz),fmid(i,iz),f0(imid0(i)+1,iz)], &
                       XLOG=xl, YLOG=yl, &
                      LNF=[lnf0(imid0(i),iz),lnfmid(i,iz),lnf0(imid0(i)+1,iz)] )
          ELSE IF (xl .AND. yl) THEN
            FORALL (i=1:Nref,iz=1:Nz) &
              dF1(imid1(i):imid1(i)+1,iz) = &
                DPRIM( [x0(imid0(i)),xmid(i),x0(imid0(i)+1)], &
                       [f0(imid0(i),iz),fmid(i,iz),f0(imid0(i)+1,iz)], &
                       XLOG=xl, YLOG=yl, &
                       LNX=[lnx0(imid0(i)),lnxmid(i),lnx0(imid0(i)+1)], &
                      LNF=[lnf0(imid0(i),iz),lnfmid(i,iz),lnf0(imid0(i)+1,iz)] )
          ELSE
            FORALL (i=1:Nref,iz=1:Nz) &
              dF1(imid1(i):imid1(i)+1,iz) = &
                DPRIM( [x0(imid0(i)),xmid(i),x0(imid0(i)+1)], &
                       [f0(imid0(i),iz),fmid(i,iz),f0(imid0(i)+1,iz)], &
                       XLOG=xl, YLOG=yl )
          END IF linlog

        ELSE

          linlog2: IF (.NOT. xl .AND. yl) THEN
            FORALL (iz=1:Nz) &
              dF1(:,iz) = DPRIMITIVE(x1(:),f1(:,iz),XLOG=xl,YLOG=yl, &
                                     LNF=lnf1(:,iz))
          ELSE IF (xl .AND. yl) THEN
            FORALL (iz=1:Nz) &
              dF1(:,iz) = DPRIMITIVE(x1(:),f1(:,iz),XLOG=xl,YLOG=yl, &
                                     LNX=lnx1(:),LNF=lnf1(:,iz))
          ELSE
            FORALL (iz=1:Nz) &
              dF1(:,iz) = DPRIMITIVE(x1(:),f1(:,iz),XLOG=xl,YLOG=yl)
          END IF linlog2

        END IF evalprim
        WHERE(ISNAN(dF1(:,:))) dF1(:,:) = 0._DP

        ! Decide where to refine
        CALL REALLOCATE(deltadF1,N1-1,Nz)
        deltadF1(ind1(1:N0-1),:) = deltadF0(:,:)
        FORALL (i=1:Nref,iz=1:Nz) &
          deltadF1(imid1(i)-1:imid1(i),iz) &
            = ABS( SUM(dF1(imid1(i):imid1(i)+1,iz)) - dF0(imid0(i)+1,iz) )
        threshprim(:) = MERGE(accuracy*SUM(ABS(dF1(:,:)),1)/SQRT(REAL(N1,DP)), &
                              accuracy,relacc)
        FORALL (i=1:N1-1) good1(i) = ALL( deltadF1(i,:) <= threshprim(:) )
        IF (yl) THEN
          FORALL (i=1:Nref,ALL(fmid(i,:) < tinyDP)) &
            good1(imid1(i)-1:imid1(i)) = .True.
        END IF

      END IF integr

      ! Slim mode
      IF (dontkeep) THEN
        CALL REALLOCATE(keep1,N1)
        keep1(ind1(:)) = keep0(:)
        keep1(imid1(:)) = (.NOT. good1(imid1(:)) )
      END IF

      ! Enforce minimum step
      CALL REALLOCATE (relstep,Nref)
      relstep(:) = (x0(imid0(:)+1)-x0(imid0(:))) &
                 / MERGE(x0(imid0(:)),x0(imid0(:)+1),x0(imid0(:)) /= 0._DP)
      FORALL (i=1:Nref,ABS(relstep(i)) <= stepmin) &
        good1(imid1(i)-1:imid1(i)) = .True.

      ! Exit when no more refinement is needed
      Nref = COUNT(.NOT. good1)
      counter = counter + 1
      IF (counter == Nrefmax .OR. Nref == 0) EXIT

    END DO refinement

    ! 3. Fine grid
    !-------------
    nokeep: IF (.NOT. dontkeep) THEN
      ALLOCATE (xfine(N1),yfine(N1,Nz))
      xfine(:) = x1(:)
      yfine(:,:) = f1(:,:)
    ELSE
      Nslim = COUNT(keep1(:))
      ALLOCATE (xfine(Nslim),yfine(Nslim,Nz))
      xfine(:) = PACK(x1(:),keep1(:))
      FORALL (iz=1:Nz) yfine(:,iz) = PACK(f1(:,iz),keep1(:))
    END IF nokeep

    ! Primitive
    doprim: IF (integacc .AND. PRESENT(primitive)) THEN
      IF (.NOT. dontkeep) THEN
        ALLOCATE (primitive(N1,Nz))
        primitive(1,:) = 0._DP
        DO i=2,N1 ; primitive(i,:) = dF1(i,:) + primitive(i-1,:) ; END DO
      ELSE
        ALLOCATE (prim1(N1,Nz),primitive(Nslim,Nz))
        prim1(1,:) = 0._DP
        DO i=2,N1 ; prim1(i,:) = dF1(i,:) + prim1(i-1,:) ; END DO
        FORALL (iz=1:Nz) primitive(:,iz) = PACK(prim1(:,iz),keep1(:))
        DEALLOCATE (prim1)
      END IF
    END IF doprim

    ! Clean memory
    DEALLOCATE(x0,x1,f0,f1,ind1,good0,good1,imid0,imid1,xmid,fmid,relstep)
    IF (yl) DEALLOCATE(lnf0,lnf1,lnfmid)
    IF (xl) DEALLOCATE(lnx0,lnx1,lnxmid)
    IF (integacc) DEALLOCATE(dF0,dF1,deltadF0,deltadF1)
    IF (dontkeep) DEALLOCATE(keep0,keep1)
    IF (.NOT. integacc) DEALLOCATE(fmidint)
    IF (.NOT. integacc .AND. yl) DEALLOCATE(lnfmidint)
    IF (.NOT. integacc) DEALLOCATE(threshint)

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

  END SUBROUTINE gridadapt1D_zgrid

  !===========================================================================
  !  x[N] = GRID_KERNEL(N,xinf,xsup,xgrid,fgrid,xlog,ylog)
  !
  !  Creates a grid by inversing a cumulative distribution function of f,
  ! which is a tabulated function.
  !===========================================================================

  FUNCTION grid_kernel (N,xinf,xsup,xgrid,fgrid,xlog,ylog)
! TO BE TESTED!!!...

    USE utilities, ONLY: DP
    USE interpolation, ONLY: interp_lin_sorted
    USE integration, ONLY: integ_tabulated
    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N
    REAL(DP), INTENT(IN) :: xinf, xsup
    REAL(DP), DIMENSION(:), INTENT(IN) :: xgrid, fgrid
    REAL(DP), DIMENSION(N) :: grid_kernel
    LOGICAL, INTENT(IN), OPTIONAL :: xlog, ylog

    INTEGER :: i, Ngrid
    REAL(DP) :: intgrid
    REAL(DP), DIMENSION(N) :: ind
    REAL(DP), DIMENSION(SIZE(xgrid)) :: primgrid
    LOGICAL :: xl, yl

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

    ! Options
    xl = .False.
    IF (PRESENT(xlog)) xl = xlog
    yl = .False.
    IF (PRESENT(ylog)) yl = ylog

    ! Primitive of the kernel
    Ngrid = SIZE(xgrid(:))
    intgrid = INTEG_TABULATED(xgrid(:),fgrid(:),XRANGE=[xinf,xsup], &
                              PRIMITIVE=primgrid,XLOG=xl,YLOG=yl)
    primgrid(:) = primgrid(:) / primgrid(Ngrid)

    ! Inversion
    ind(:) = [(i,i=0,N-1)] / REAL(N-1,DP)
    grid_kernel(:) = INTERP_LIN_SORTED(xgrid(:),primgrid(:),ind(:),XLOG=yl)

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

  END FUNCTION grid_kernel

END MODULE adaptative_grid


      FUNCTION BICO(N,K)
      BICO=ANINT(EXP(FACTLN(N)-FACTLN(K)-FACTLN(N-K)))
      RETURN
      END


c=======================================================================
c
c     GENMN
c
c     Multivariate Normal random deviate
c
c-----------------------------------------------------------------------
c
c-----------------------------------------------------------------------
      SUBROUTINE genmn(parm, x, work)
c-----------------------------------------------------------------------
c
c     INPUT :
c      PARM --> Parameters needed to generate multivariate normal
c               deviates (MEANV and Cholesky decomposition of
c               COVM). Set by a previous call to SETGMN.
c               1 : 1                - size of deviate, P
c               2 : P + 1            - mean vector
c               P+2 : P*(P+3)/2 + 1  - upper half of cholesky
c                                       decomposition of cov matrix
c                                             DOUBLE PRECISION PARM(*)
c
c      X  <-- Vector deviate generated (P)                       double
c      WORK <--> scratch array (P)                               double
c
c     Method
c     1) Generate P independent standard normal deviates - Ei ~ N(0,1)
c     2) Using Cholesky decomposition find A s.t. trans(A)*A = COVM
c     3) trans(A)E + MEANV ~ N(MEANV,COVM)
c
c======================================================================
c
c     array arguments
      DOUBLE PRECISION parm(*), work(*), x(*)
c
c     local scalars
      DOUBLE PRECISION ae
      INTEGER i, icount, j, p
c
c     external functions
      DOUBLE PRECISION snorm
      EXTERNAL snorm
c
c     intrinsic functions
      INTRINSIC int
c
c     executable statements
      p = int(parm(1))
c
c     generate P independent normal deviates - WORK ~ N(0,1)
      DO 10,i = 1,p
          work(i) = snorm()
   10 CONTINUE
      DO 30,i = 1,p
c
c     PARM (P+2 : P*(P+3)/2 + 1) contains A, the Cholesky
c      decomposition of the desired covariance matrix.
c          trans(A)(1,1) = PARM(P+2)
c          trans(A)(2,1) = PARM(P+3)
c          trans(A)(2,2) = PARM(P+2+P)
c          trans(A)(3,1) = PARM(P+4)
c          trans(A)(3,2) = PARM(P+3+P)
c          trans(A)(3,3) = PARM(P+2-1+2P)  ...
c
c     trans(A)*WORK + MEANV ~ N(MEANV,COVM)
          icount = 0
          ae = 0.0
          DO 20,j = 1,i
              icount = icount + j - 1
              ae = ae + parm(i+ (j-1)*p-icount+p+1)*work(j)
   20     CONTINUE
          x(i) = ae + parm(i+1)
   30 CONTINUE
      RETURN
      END


SUBROUTINE BottomBerkoff(FineGrid,GX,GY)
!
! Define bottom profile for Berkhoff experiment (3D)
!
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: FineGrid
REAL(KIND=long) :: y, x, xr, yr, k, angle, dxrdx, dxrdy, dyrdx, dyrdy
INTEGER :: Nx, Ny, i, j, GX, GY

!hbb Added the ghost points here.
Nx = FineGrid%Nx+2*GX
Ny = FineGrid%Ny+2*GY
angle = 20
k = angle/180.0_long*pi
DO j = 1, Ny
!hbb x and y are 2D arrays in the FineGrid.
   DO i = 1 , Nx
      x = FineGrid%x(i,1) - half*FineGrid%x(Nx,1) ! position shoal in middle relative to y-axis
      y = FineGrid%y(1,j) - 11.0_long ! FIXME: translation relative to standard y-coordinates
      xr = cos(k)*x - sin(k)*y
      yr = sin(k)*x + cos(k)*y
      dxrdx = cos(k)
      dyrdx = sin(k)
      dxrdy = -sin(k)
      dyrdy = cos(k)
      IF (yr<=-5.82_long) THEN
         FineGrid%h(i,j)   = 0.45_long
         FineGrid%hx(i,j)  = zero
         FineGrid%hy(i,j)  = zero
         FineGrid%hxx(i,j) = zero
         FineGrid%hyy(i,j) = zero
      ELSE ! IF (yr>-5.82_long) THEN
         FineGrid%h(i,j)   = 0.45_long-0.02_long*(5.82_long+yr)
         FineGrid%hx(i,j)  = -0.02_long*dyrdx
         FineGrid%hy(i,j)  = -0.02_long*dyrdy
         FineGrid%hxx(i,j) = zero
         FineGrid%hyy(i,j) = zero
      END IF
      IF ((xr/four)**2 + (yr/three)**2<1) THEN
         FineGrid%h(i,j)   = FineGrid%h(i,j) + 0.3_long - half*sqrt(one-(xr/five)**2-(yr/3.75_long)**2)
!WRITE(*,*) '  WARNING: The bottom slopes for the Berkhoff experiment is not defined analytically (i.e. not implemented).'
!WRITE(*,*) '  WARNING: Therefore the derivatives of the bottom profile function is determined numerically.'
         FineGrid%hx(i,j)  = FineGrid%hx(i,j)  + (0.02_long*xr*dxrdx + &
             0.0355556_long*yr*dyrdx)/sqrt(one-0.04_long*xr**2-0.0711111_long*yr**2)
         FineGrid%hy(i,j)  = FineGrid%hy(i,j)  + (0.02_long*xr*dxrdy + &
             0.0355556_long*yr*dyrdy)/sqrt(one-0.04_long*xr**2-0.0711111_long*yr**2)
!         FineGrid%hxx(i,j) = FineGrid%hxx(i,j) +
!         FineGrid%hyy(i,j) = FineGrid%hyy(i,j) +
      END IF
      IF (FineGrid%h(i,j)<0.1_long) THEN
         ! flat bottom profile after shoal
         ! - this is very absorption zone should effectively damp outgoing waves
         FineGrid%h(i,j)   = 0.1_long
         FineGrid%hx(i,j)  = zero
         FineGrid%hy(i,j)  = zero
         FineGrid%hxx(i,j) = zero
         FineGrid%hyy(i,j) = zero
      END IF
   END DO
END DO
WRITE(*,*) '  WARNING: The bottom slopes for the Berkhoff experiment is not defined analytically (i.e. not implemented).'
WRITE(*,*) '  WARNING: Therefore the derivatives of the bottom profile function is determined numerically.'
END SUBROUTINE BottomBerkoff


MODULE FUN_xyzCENTROID
!!#### PURPOSE
!! Calculate the centroid (center-of-mass) of a polygon.

!!#### METHOD
!! First collapse R^3 variables into R^2 using transformation matrix,
!! then calculate centroid via R^2 procedure xyCENTROID_Pg.

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

!!#### EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_1_by_6_Rsp => c_1_by_6 !!((02-A-PAR_Constants_Rsp.f90))
USE PAR_Constants_Rdp,ONLY: c_1_by_6_Rdp => c_1_by_6 !!((02-A-PAR_Constants_Rdp.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_xyzSAREA   ,ONLY:                            !!((06-B-FUN_xyzSAREA.f90))
USE FUN_xyzCOLLAPSE,ONLY: xyzCOLLAPSE_Pg             !!((05-B-FUN_xyzCOLLAPSE.f90))
USE FUN_xyCENTROID ,ONLY: xyCENTROID_Pg              !!((05-B-FUN_xyCENTROID.f90))
USE FUN_xyEXPAND   ,ONLY: xyEXPAND_P                 !!((05-B-FUN_xyEXPAND.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyzCENTROID_Pg
 MODULE PROCEDURE xyzCENTROID_Pg_Rsp
 MODULE PROCEDURE xyzCENTROID_Pg_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyzCENTROID_Pg

CONTAINS

FUNCTION xyzCENTROID_Pg_Rsp( N , Pg , M32_transform , SAREA ) RESULT(xyzP)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp        !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_6 = c_1_by_6_Rsp
INCLUDE "07-B-FUN_xyzCENTROID_Pg.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzCENTROID_Pg.f90.bdy"
!!--end--
ENDFUNCTION

FUNCTION xyzCENTROID_Pg_Rdp( N , Pg , M32_transform , SAREA ) RESULT(xyzP)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp        !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_6 = c_1_by_6_Rdp
INCLUDE "07-B-FUN_xyzCENTROID_Pg.f90.hdr"
!!--begin--
INCLUDE "07-B-FUN_xyzCENTROID_Pg.f90.bdy"
!!--end--
ENDFUNCTION

ENDMODULE


program fibo_arr
!  !から行末まではコメントとして扱われる。
!  FOTRANには「固定形式」と「自由形式」という2つの書き方があるらしく、
!  このプログラムは自由形式の方で書いている
!  詳しくは「fortran 自由形式 固定形式」などでググると出てくる

!  「暗黙の型宣言」を行わない。
!  FOTRANではデフォルトでは型宣言を行わない場合
!  [a-ho-z]で始まる変数は実数型、[i-n]で始まる変数は整数型として扱われる
      implicit none
! 整数型のループ変数i
      integer i
! 要素数20の配列の宣言
! 配列の[]はFOTRANでは()となる。又、添字は1から始まる
      integer f(20)
! fib[1]、fib[2]の設定
      f(1) = 1
      f(2) = 1

! 第三項以降を計算して配列の各要素に格納
      do i=3,20
        f(i) = f(i-1) + f(i-2)
      end do
! 配列の中身を表示
      do i=1,20
        print *, f(i)
      end do
end program fibo_arr

! 参考: Fortran入門 <http://www.nag-j.co.jp/fortran/index.html>


      program trnkey

c   TRNKEY -- program to make a numerical version of a transpostion
c     key for use (most likely) in a (cryptographic) transposition
c     cipher.  The input is a character string.
c
c   The way this works is as follows:
c     The user inputs a character string containing any ASCII
c     characters.  The characters are mapped to upper-case and
c     any non-alphabetic characters are eliminated.
c     The letters in the resulting string are then numbered
c     alphabetically, with duplicate letters being numbered from
c     left to right.
c   For instance:
c     JOANN  yields the numerical sequence 2-5-1-3-4.
c     For classical cryptographic applications, 2-5-1-3-4 would be
c     the resultant numerical version of the key.
c     For computer applications, an "inverted" form of the key, with
c     the ordinal number of "1" first, the ordinal number of "2"
c     second, etc., might be more useful.
c
c   Written by Mark Riordan   27 September 1986

      integer nkeymx
      parameter(nkeymx=160)
      integer nkey,j,inew,iold,tint
      logical debug,qchng
      character key(nkeymx)*1,tchar
      integer numkey(nkeymx)

      debug = .false.
cc	write(*,9000)
cc9000	format(' Please input the key string:')
      read(*,8000,end=666) (key(j),j=1,nkeymx)
8000  format(160a)

      inew = 0
      do 120 iold = 1, nkeymx
	if(key(iold).ge.'a' .and. key(iold).le.'z') then
	  key(iold) = char(ichar(key(iold))-32)
	endif
	if(key(iold).ge.'A' .and. key(iold).le.'Z') then
	  inew = inew + 1
	  key(inew) = key(iold)
	endif
120   continue
      nkey = inew
      if(nkey .le. 0) then
	write(*,*) 'No legal key characters were input.'
	go to 999
      endif

      if(debug) then
	write(*,9200) (key(j),j=1,inew)
9200	format(' ',160a)
      endif

c   Create an array of ordinal positions.  The sorted version of
c   this array will be the numerical version of the key.
c   Initially, for this algorithm, we start out with 1-2-3-...
c   in this array.

      do 140 j = 1, nkey
	numkey(j) = j
140   continue

c   Sort the key characters, and drag their ordinal numbers along
c   to keep track of things.

160   continue
      qchng = .false.
	do 200 j = 1, nkey-1
	  if(key(j) .gt. key(j+1)) then
	    tchar = key(j)
	    key(j) = key(j+1)
	    key(j+1) = tchar
	    tint = numkey(j)
	    numkey(j) = numkey(j+1)
	    numkey(j+1) = tint
	    qchng = .true.
	  endif
200	continue
      if(qchng) go to 160

c   The key is now sorted.

      if(debug) then
	write(*,9220) (numkey(j), j=1,nkey)
9220	format(' Row #''s in ordinal order:',40i4)
      endif

cc	open(12,file='tordkey.txt')
cc	rewind 12
      write(*,9030) (numkey(j),j=1,nkey)
9030  format(40i4)

      goto 999
666   continue
	write(*,*) 'Premature end-of-file encountered.'
	go to 999

999   continue
      end
      end


! Main program

program intersections

    use newton, only: solve
    use functions, only: f_int, fprime_int

    implicit none
    real(kind=8) :: x, x0, fx
    real(kind=8) :: x0vals(4)
    integer :: iters, itest
	logical :: debug

    print *, "Test routine for computing zero of f"
    debug = .true.

    ! values to test as x0:
    x0vals = (/-2.2d0, -1.6d0, -0.8d0, 1.45d0/)

    do itest=1,4
        x0 = x0vals(itest)
		print *, ' '  ! blank line
        call solve(f_int, fprime_int, x0, x, iters, debug)

        print 11, x, iters
11      format('solver returns x = ', es22.15, ' after', i3, ' iterations')

        fx = f_int(x)
        print 12, fx
12      format('the value of f(x) is ', es22.15)

        enddo

end program intersections


C++***************************************************************
C Subset of FFT routines modified for fft1.for
C Using NAG library
C (Extracted from fft_nag.for to be compiled with fft1.for)
C
C JLP
C Version of 06-09-95
C--***************************************************************
C********************************************************************
C FFT 1D routine along the columns
C Input:
C TR, TI:  real part and imaginary part  (input/output) of the image
C
C KOD=1, or 2 direct
C KOD=-1, or -2 inverse
C KOD=-2, or 2: power spectrum, and phase
C********************************************************************
	SUBROUTINE FFT_1D_Y_NAG(TR,TI,NX,NY,IDIM1,KOD)
	PARAMETER (IDIM=600)
	REAL TR(IDIM1,*),TI(IDIM1,*)
	DOUBLE PRECISION DR(IDIM*IDIM),DI(IDIM*IDIM),WORK(2000)
	REAL F_NORM
	INTEGER NX,NY,KOD
	PI=3.14159265358979323846

C Main loop on I=1,NX
	DO I=1,NX

C Conversion of the input (when KOD=-2)
	II=0
	IF(KOD.EQ.-2) THEN
	   DO J=1,NY
	    XM=TR(I,J)
	    XP=TI(I,J)
	    II=II+1
	    DR(II)=XM*COS(XP)
	    DI(II)=XM*SIN(XP)
	   ENDDO
        ELSE
	  DO J=1,NY
	    II=II+1
	    DR(II)=TR(I,J)
	    DI(II)=TI(I,J)
	  END DO
	ENDIF

C Compute the FFT:
	  IFAIL=0
C WARNING: NAG FFT divides the result by SQRT(NX*NY)
	  IF(KOD.GT.0)THEN
	    CALL C06FCF(DR,DI,NY,WORK,IFAIL)
	  ELSE
	    CALL C06GCF(DI,NY,IFAIL)
	    CALL C06FCF(DR,DI,NY,WORK,IFAIL)
	    CALL C06GCF(DI,NY,IFAIL)
	  ENDIF

C Copy back the arrays
C Division by sqrt(ntot)
C	F_NORM=1./SQRT(FLOAT(NY))
C JLP2000: NAG already divides by ny:
	F_NORM=1.

	II=0
	  DO J=1,NY
	    II=II+1
	    TR(I,J)=DR(II)*F_NORM
	    TI(I,J)=DI(II)*F_NORM
	  END DO

	  IF(KOD.EQ.2)THEN
C Power and phase spectrum in output when KOD=2:
	    DO J=1,NY
	      AR=TR(I,J)
	      AI=TI(I,J)
	      TR(I,J)=SQRT(AR*AR+AI*AI)
	      IF(AR.EQ.0) THEN
	        TI(I,J)=PI/2.
	        IF(AI.LT.0.)TI(I,J)=3.*PI/2.
	      ELSE
	        TI(I,J)=ATAN(AI/AR)
	        IF(AR.LT.0.)TI(I,J)=TI(I,J)+PI
	      ENDIF
              IF(TI(I,J).LT.0.)TI(I,J)=TI(I,J)+2.*PI
	    ENDDO
	  ENDIF

C End of loop on I=1,NX:
	ENDDO

	RETURN
	END


      subroutine wipowe(vr,vi,p,rr,ri,ierr)
c!purpose
c     computes v^p with v complex and p integer
c!calling sequence
c     subroutine wipowe(vr,vi,p,rr,ri,ierr)
c     integer ierr
c     double precision vr,vi,p,rr,ri
c     vr   : real part of v
c     vi   : imaginary part of v
c     rr   : result's real part
c     ri   : result's imaginary part
c     ierr : error flag
c            ierr=0 if ok
c            ierr=1 if 0**0
c            ierr=2 if  0**k with k<0
c!origin
c Serge Steer INRIA 1996
c!
c     Copyright INRIA
      integer p,ierr
      double precision vr,vi,xr,xi,rr,ri,infinity
c
      ierr=0
c
      if(p.eq.0) then
         rr=1.0d+0
         ri=0.0d+0
      elseif(p.lt.0) then
         if(abs(vr)+abs(vi).ne.0.0d+0) then
            call wdiv(1.0d+0,0.0d+0,vr,vi,rr,ri)
            xr=rr
            xi=ri
            do 10 k=2,abs(p)
               call wmul(xr,xi,rr,ri,rr,ri)
 10         continue
         else
            ri=0.0d0
            rr=infinity(ri)
            ierr=2
         endif
      else
         rr=vr
         ri=vi
         xr=rr
         xi=ri
         do 20 k=2,abs(p)
            call wmul(xr,xi,rr,ri,rr,ri)
 20      continue
      endif
      return
      end


module randutil

   use,intrinsic :: iso_fortran_env

   implicit none
   private

   public :: i1rand, i2rand, i4rand, i8rand, &
             r4rand, r8rand, c8rand, c16rand, strrand

contains

   subroutine i1rand(x)
      integer(kind=1), intent(out) :: x
      real(kind=REAL32) :: r
      call random_number(r)
      x = floor(256*r) - 128
   end subroutine i1rand

   subroutine i2rand(x)
      integer(kind=2), intent(out) :: x
      real(kind=REAL32) :: r
      call random_number(r)
      x = floor(65536*r) - 32768
   end subroutine i2rand

   subroutine i4rand(x)
      integer(kind=4), intent(out) :: x
      integer(kind=2) :: r(2)
      call i2rand(r(1))
      call i2rand(r(2))
      x = transfer(r,x)
   end subroutine i4rand

   subroutine i8rand(x)
      integer(kind=8), intent(out) :: x
      integer(kind=4) :: r(2)
      call i4rand(r(1))
      call i4rand(r(2))
      x = transfer(r,x)
   end subroutine i8rand

   subroutine r4rand(x)
      real(kind=REAL32), intent(out) :: x
      call random_number(x)
   end subroutine r4rand

   subroutine r8rand(x)
      real(kind=REAL64), intent(out) :: x
      call random_number(x)
   end subroutine r8rand

   subroutine c8rand(x)
      complex(kind=REAL32), intent(out) :: x
      real(kind=REAL32) :: r(2)
      call random_number(r)
      x = cmplx(r(1), r(2), kind=REAL32)
   end subroutine c8rand

   subroutine c16rand(x)
      complex(kind=REAL64), intent(out) :: x
      real(kind=REAL64) :: r(2)
      call random_number(r)
         x = cmplx(r(1), r(2), kind=REAL64)
      end subroutine c16rand

      subroutine chrrand(x)
         character, intent(out) :: x
      real(kind=REAL32) :: r
      call random_number(r)
      x = char(floor(32 + 96*r))
   end subroutine chrrand

   subroutine strrand(x)
      character(len=*), intent(out) :: x
      integer :: i
      do i = 1,len(x)
         call chrrand(x(i:i))
      end do
   end subroutine strrand

end module randutil


! Program to test the ABS intrinsic
program intrinsic_abs
   implicit none
   integer i
   real(kind=4) r
   real(kind=8) q
   complex z

   i = 42
   i = abs(i)
   if (i .ne. 42) call abort
   i = -43
   i = abs(i)
   if (i .ne. 43) call abort

   r = 42.0
   r = abs(r)
   if (r .ne. 42.0) call abort
   r = -43.0
   r = abs(r)
   if (r .ne. 43.0) call abort

   q = 42.0_8
   q = abs(q)
   if (q .ne. 42.0_8) call abort
   q = -43.0_8
   q = abs(q)
   if (q .ne. 43.0_8) call abort

   z = (3, 4)
   r = abs(z)
   if (r .ne. 5) call abort
end program


subroutine f_main

!   This program finds polynomial roots.  Double precision, double complex,
!   arbitrary precision real and arbitrary precision complex versions are
!   included.
!   David H Bailey   2004-05-27

use mpmodule
implicit none
integer i, n, ndp, nr
parameter (n = 10, ndp = 500)
real*8 da(0:n), second, tm0, tm1
! real*8 dr, dr0
complex*16 dr, dr0
type (mp_real) a(0:n)
! type (mp_real) r0, r
type (mp_complex) r0, r
data da/1.d0, 1.d0, 0.d0, -1.d0, -1.d0, -1.d0, -1.d0, -1.d0, 0.d0, 1.d0, 1.d0/
! data dr0/1.176d0/
data dr0/(0.457d0, 0.889d0)/

call mpinit
call mpsetprec (ndp)
mpoud = ndp

write (6, 1) da
1 format ('Arbitrary precision polynomial root finder.'/'Coefficients:'/ &
  (1p,4d19.10))

call dcroot (n, dr0, da, nr, dr)
write (6, 2) dr
2 format ('Double precision root:'/(1p,2d19.10))

!  Copy coefficients in da to a.

do i = 0, n
  a(i) = da(i)
enddo

r0 = dr0

!  Find root of polynomial.

tm0 = second ()
! call rroot (n, r0, a, nr, r)
call croot (n, r0, a, nr, r)
tm1 = second ()
write (6, 3) tm1 - tm0
3 format ('cpu time =',f8.2)
write (6, 4)
4 format ('Arbitrary precision root:')
call mpwrite (6, r)
stop
end

subroutine drroot (n, dr0, da, nr, dr)

!   Finds a single double-precision real root, beginning at dr0.

implicit none
integer i, j, n, nit, nr
parameter (nit = 20)
real*8 da(0:n), dad(0:n-1), eps, eps1
real*8 d1, d2, d3, d4, dr, dr0
parameter (eps = 1.d-15)

!   Compute derivative.

do i = 0, n - 1
  dad(i) = (i + 1) * da(i+1)
enddo

d1 = dr0
eps1 = eps * max (abs (d1), 1.d0)

!   Perform up to nit double-precision Newton iterations.

do j = 1, nit

!   Evaluate polynomial at d1.

  d2 = 0.d0

  do i = n, 0, -1
    d2 = d1 * d2 + da(i)
  enddo

!   Evaluate polynomial derivative at d1.

  d3 = 0.d0

  do i = n - 1, 0, -1
    d3 = d1 * d3 + dad(i)
  enddo

  d4 = d1 - d2 / d3
  if (abs (d1 - d4) < eps1) goto 100
  d1 = d4
enddo

write (6, 1)
1 format ('drroot: failed to find double precision real root.')
nr = 0
dr = 0.d0
goto 110

100 continue

nr = 1
dr = d1

110 continue

return
end

subroutine dcroot (n, dr0, da, nr, dr)

!   Finds a single double-precision complex root, beginning at dr0.

implicit none
integer i, j, n, nit, nr
parameter (nit = 20)
real*8 da(0:n), dad(0:n-1), eps, eps1
complex*16 d1, d2, d3, d4, dr, dr0
parameter (eps = 1.d-15)

!   Compute derivative.

do i = 0, n - 1
  dad(i) = (i + 1) * da(i+1)
enddo

d1 = dr0
eps1 = eps * max (abs (d1), 1.d0)

!   Perform up to nit double-precision Newton iterations.

do j = 1, nit

!   Evaluate polynomial at d1.

  d2 = 0.d0

  do i = n, 0, -1
    d2 = d1 * d2 + da(i)
  enddo

!   Evaluate polynomial derivative at d1.

  d3 = 0.d0

  do i = n - 1, 0, -1
    d3 = d1 * d3 + dad(i)
  enddo

  d4 = d1 - d2 / d3
  if (abs (d1 - d4) < eps1) goto 100
  d1 = d4
enddo

write (6, 1)
1 format ('dcroot: failed to find double precision complex root.')
nr = 0
dr = 0.d0
goto 110

100 continue

nr = 1
dr = d1

110 continue

return
end

subroutine rroot (n, r0, a, nr, r)

!   Finds a single arbitrary-precision real root, beginning at r0.

use mpmodule
implicit none
integer i, j, n, nit, nr, nwp, nws
parameter (nit = 100)
type (mp_real) a(0:n), ad(0:n-1), eps1
type (mp_real) t1, t2, t3, t4, r, r0

!   Compute derivative.

do i = 0, n - 1
  ad(i) = (i + 1) * a(i+1)
enddo

call mpgetprecwords (nws)
nwp = 3
call mpsetprecwords (nwp)
t1 = r0
t2 = 0.d0
if (r0 /= t2) then
  eps1 = 2.d0 ** (-96) * abs (t1)
else
  eps1 = 2.d0 ** (-96)
endif

!   Perform up to nit double-precision Newton iterations.

do j = 1, nit

!   Evaluate polynomial at t1.

  t2 = 0.d0

  do i = n, 0, -1
    t2 = t1 * t2 + a(i)
  enddo

!   Evaluate polynomial derivative at t1.

  t3 = 0.d0

  do i = n - 1, 0, -1
    t3 = t1 * t3 + ad(i)
  enddo

  t4 = t1 - t2 / t3
  if (nwp == 3) then
    if (abs (t1 - t4) < eps1) then
      nwp = min (2 * nwp - 1, nws)
      call mpsetprecwords (nwp)
    endif
  elseif (nwp < nws) then
    nwp = min (2 * nwp - 1, nws)
    call mpsetprecwords (nwp)
  else
    t1 = t4
    goto 100
  endif
  t1 = t4
enddo

write (6, 1)
1 format ('rroot: failed to find arbitrary precision real root.')
nr = 0
r = 0.d0
goto 110

100 continue

nr = 1
r = t1

110 continue

return
end

subroutine croot (n, r0, a, nr, r)

!   Finds a single arbitrary-precision complex root, beginning at r0.

use mpmodule
implicit none
integer i, j, n, nit, nr, nwp, nws
parameter (nit = 100)
type (mp_real) a(0:n), ad(0:n-1), eps1
type(mp_complex) t1, t2, t3, t4, r, r0

!   Compute derivative.

do i = 0, n - 1
  ad(i) = (i + 1) * a(i+1)
enddo

call mpgetprecwords (nws)
nwp = 3
call mpsetprecwords (nwp)
t1 = r0
t2 = (0.d0, 0.d0)
if (r0 /= t2) then
  eps1 = 2.d0 ** (-96) * abs (t1)
else
  eps1 = 2.d0 ** (-96)
endif

!   Perform up to nit double-precision Newton iterations.

do j = 1, nit

!   Evaluate polynomial at t1.

  t2 = (0.d0, 0.d0)

  do i = n, 0, -1
    t2 = t1 * t2 + a(i)
  enddo

!   Evaluate polynomial derivative at t1.

  t3 = (0.d0, 0.d0)

  do i = n - 1, 0, -1
    t3 = t1 * t3 + ad(i)
  enddo

  t4 = t1 - t2 / t3
  if (nwp == 3) then
    if (abs (t1 - t4) < eps1) then
      nwp = min (2 * nwp - 1, nws)
      call mpsetprecwords (nwp)
    endif
  elseif (nwp < nws) then
    nwp = min (2 * nwp - 1, nws)
    call mpsetprecwords (nwp)
  else
    t1 = t4
    goto 100
  endif
  t1 = t4
enddo

write (6, 1)
1 format ('croot: failed to find multiple precision complex root.')
nr = 0
r = (0.d0, 0.d0)
goto 110

100 continue

nr = 1
r = t1

110 continue

return
end


*> \brief \b CROTG
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CROTG(CA,CB,C,S)
*
*       .. Scalar Arguments ..
*       COMPLEX CA,CB,S
*       REAL C
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CROTG determines a complex Givens rotation.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] CA
*> \verbatim
*>          CA is COMPLEX
*> \endverbatim
*>
*> \param[in] CB
*> \verbatim
*>          CB is COMPLEX
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*>          C is REAL
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is COMPLEX
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex_blas_level1
*
*  =====================================================================
      SUBROUTINE CROTG(CA,CB,C,S)
*
*  -- Reference BLAS level1 routine (version 3.7.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      COMPLEX CA,CB,S
      REAL C
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      COMPLEX ALPHA
      REAL NORM,SCALE
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC CABS,CONJG,SQRT
*     ..
      IF (CABS(CA).EQ.0.) THEN
         C = 0.
         S = (1.,0.)
         CA = CB
      ELSE
         SCALE = CABS(CA) + CABS(CB)
         NORM = SCALE*SQRT((CABS(CA/SCALE))**2+ (CABS(CB/SCALE))**2)
         ALPHA = CA/CABS(CA)
         C = CABS(CA)/NORM
         S = ALPHA*CONJG(CB)/NORM
         CA = ALPHA*NORM
      END IF
      RETURN
      END


module root_module
   use precision_module, only : wp
   use error_module
   use constants_module

   implicit none
   public

contains

function root(cf,limitL,limitR)
   implicit none
   real(wp) :: cf(5), limitL, limitR
   real(wp) :: rcf1(2),rcf2(3),rcf3(4), rcf4(5)
   real(wp) :: root

   if     (cf(1).eq.0.0d0 .and. &
           cf(2).eq.0.0d0 .and. &
           cf(3).eq.0.0d0) then !linear  potentials
       rcf1=cf(4:5) !get rid of first three elements
       rcf1=rcf1/rcf1(1) !get reduced polynomial
       root=poly1_root(rcf1,limitL,limitR) !find root of cubic polynomial

   elseif (cf(1).eq.0.0d0 .and. &
           cf(2).eq.0.0d0) then !quadratic polynomial
       rcf2=cf(3:5) !get rid of first element
       rcf2=rcf2/rcf2(1) !get reduced polynomial
       root=poly2_root(rcf2,limitL,limitR) !find root of cubic polynomial

   elseif (cf(1).eq.0.0d0) then !cubic polynomial
       rcf3=cf(2:5) !get rid of the first element
       rcf3=rcf3/rcf3(1) !get reduced polynomial
       root=poly3_root(rcf3,limitL,limitR) !find root of cubic polynomial

   else !quiartic polynomial
       rcf4=cf/cf(1) ! get reduced polynomial
       root=poly4_root(rcf4,limitL,limitR) !find root of quartic polynomial
   endif
end function root

!---------------------------------------------------------------------
!---------------------------------------------------------------------
function poly1_root(rcf,limitL,limitR)
   implicit none
   real(wp) :: rcf(2), limitL, limitR
   real(wp) :: x, poly1_root

     x=-rcf(2)
     if (x.gt.limitL .and. x.lt.limitR) then
         poly1_root=x
     else
        call error_message(8)!error code in parentheses
     endif
end function poly1_root

!---------------------------------------------------------------------
!---------------------------------------------------------------------
function poly2_root(rcf,limitL,limitR)
   implicit none
   real(wp) :: rcf(3), limitL, limitR
   real(wp) :: b,c,dd,x1,x2, poly2_root
   integer          :: i

     b=rcf(2)
     c=rcf(3)
     dd=b**2.0d0-4.0d0*c !calculate determinant of reduced polynomial

     i=0 !number of roots
     if (dd.gt.0.0d0) then !two real root
         x1=(-b+sqrt(dd))/2
         x2=(-b-sqrt(dd))/2
         if (x1.gt.limitL .and. x1.lt.limitR) then
            poly2_root=x1
            i=i+1
         elseif (x2.gt.limitL .and. x2.lt.limitR) then
            poly2_root=x1
            i=i+1
         endif
     elseif (dd.eq.0.0d0) then
         x1=-b/2
         if (x1.gt.limitL .and. x1.lt.limitR) then
            poly2_root=x1
            i=i+1
         endif
     endif

   if (i.gt.1) then !multiple crossings in the region of interest
        call error_message(9)
   elseif (i.eq.0) then !no crossings in the region of interest
        call error_message(8)
   endif
end function poly2_root

!---------------------------------------------------------------------
!---------------ROOTS ARE COMPUTED USING CARDANO METHOD---------------
!----see details at http://mathworld.wolfram.com/CubicFormula.html-----
function poly3_root(rcf,limitL,limitR)
   implicit none
   real(wp) :: rcf(4), limitL, limitR
   real(wp) :: poly3_root
   real(wp) :: y1, y2, y3, factor, phi
   real(wp) :: q, r, det, s, t
   complex(wp)   :: y2i, y3i
   integer          :: i

!   rcf=cf/cf(1) ! coefficient in front of x^3 is set to one
   q=(3.0d0*rcf(3)-rcf(2)**2.0d0)/9.0d0
   r=(-2.0d0*rcf(2)**3.0d0+9.0d0*rcf(2)*rcf(3)-27.0d0*rcf(4))/54.0d0
   det=q**3.0d0+r**2.0d0

   if (det.gt.0.0d0) then !Only one real root
    s=r+sqrt(det)
     if (s.lt.0.0d0) then
        s=-((ABS(s))**(1.0d0/3.0d0))
     else
        s=s**(1.0d0/3.0d0)
     endif
    t=r-sqrt(det)
     if (t.lt.0.0d0) then
        t=-(ABS(t)**(1.0d0/3.0d0))
     else
        t=t**(1.0d0/3.0d0)
     endif
    y1=-rcf(2)/3.0d0+s+t

   !!!!!!!!!!!!!SKIP COMPEX ROOTS!!!!!!!!!!!!!!!!!!!!!!!!!
   !   re=-rcf(2)/3.0d0-(s+t)/2.0d0
   !   im=(sqrt(3.0d0)/2.0d0)*(s-t)
   !  y2i=cmplx(re,im)
   !  y3i=cmplx(re,-im)
   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   elseif (det.eq.0.0d0) then ! three real roots (two are equal)
     if (s.lt.0.0d0) then
        s=-((abs(r))**(1.0d0/3.0d0))
     else
        s=r**(1.0d0/3.0d0)
     endif
    y1=-rcf(2)/3.0d0+s*2.0d0
    y2=-rcf(2)/3.0d0-s
    y3=y2

   elseif (det.lt.0.0d0) then ! three real unequal roots
      phi=r/sqrt(abs(q**3.0d0))
      phi=1.0d0/(cos(phi))
      factor=2.0d0*sqrt(-q)
    y1=factor*cos(phi/3.0d0)-rcf(2)/3.0d0
    y2=factor*cos((phi+2.0d0*pi)/3.0d0)-rcf(2)/3.0d0
    y3=factor*cos((phi+4.0d0*pi)/3.0d0)-rcf(2)/3.0d0
   endif

   i=0 !number of roots
   if (det.gt.0.0d0) then !
     if (y1.gt.limitL .and. y1.lt.limitR) then
        poly3_root=y1
        i=i+1
     else
        call error_message(7)!error code in parentheses
     endif
   elseif (det.eq.0.0d0) then !
     if (y1.gt.limitL .and. y1.lt.limitR) then
        poly3_root=y1
        i=i+1
     elseif (y2.gt.limitL .and. y2.lt.limitR) then
        poly3_root=y2 ! y3 is equal to y2, so there's no need to track y3
        i=i+1
     endif
   elseif (det.lt.0.0d0) then!
     if (y1.gt.limitL .and. y1.lt.limitR) then
        poly3_root=y1
        i=i+1
     elseif (y2.gt.limitL .and. y2.lt.limitR) then
        poly3_root=y2
        i=i+1
     elseif (y3.gt.limitL .and. y3.lt.limitR) then
        poly3_root=y3
        i=i+1
     else
        call error_message(8)!error code in parentheses
     endif
   endif

   if (i.gt.1) then !you have multiple crossings in region of interest
        call error_message(9)!error code in parentheses
   endif
end function poly3_root

!---------------------------------------------------------------------
!---------------ROOTS ARE COMPUTED USING FERRARI'S METHOD-------------
!----see details at https://en.wikipedia.org/wiki/Quartic_function----
function poly4_root(rcf,limitL,limitR)
   implicit none
   real(wp) :: rcf(5), limitL, limitR
   real(wp) :: poly4_root
   real(wp) :: a,b,c,d,e
   real(wp) :: p,q, dd,dd0,dd1,T,tmp
   complex(wp)   :: S,x(4)
   integer          :: i,j

   a=rcf(1) !simplify nottion for polynomial coefficients
   b=rcf(2)
   c=rcf(3)
   d=rcf(4)
   e=rcf(5)

   dd=256d0*e**3.0d0-192d0*b*d*e**2.0d0-128d0*c**2.0d0*e**2.0d0
   dd=dd+144*c*d**2.0d0*e-27d0*d**4.0d0+144*b**2.0d0*c*e**2.0d0
   dd=dd-6.0d0*b**2.0d0*d**2.d0*e-80.0d0*b*c**2.0d0*d*e
   dd=dd+18.0d0*b*c*d**3.0d0+16.0d0*c**4.0d0*e-4.0d0*c**3.0d0*d**2.0d0
   dd=dd-27.0d0*b**4.0d0*e**2.0d0+18.0d0*b**3.0d0*c*d*e
   dd=dd-4.0d0*b**3.0d0*d**3.0d0-4.0d0*b**2.0d0*c**3.0d0*e
   dd=dd+b**2.0d0*c**2.0d0*d**2.0d0

   dd0=c**2.0d0-3.0d0*b*d+12.0d0*e
   dd1=2.0d0*c**3.0d0-9.0d0*b*c*d+27.0d0*b**2.0d0*e
   dd1=dd1+27.0d0*d**2.0d0-72.0d0*c*e
   p=(8.0d0*c-3.0d0*b**2.0d0)/8
   q=(b**3.0d0+8.0d0*d-4.0d0*b*c)/8

!   if (dd.lt.0) then

     T=(sqrt(-27.0d0*dd)+dd1)/2
       if (T.lt.0.0d0) then
           T=-(abs(T)**(1.0d0/3.0d0))
       else
           T=T**(1.0d0/3.0d0)
       endif

     S=-2.0d0/3.0d0*p+(T+dd0/T)/3.0d0
     S=0.5d0*sqrt(S)

!print *,'a,b,c,d,e',a,b,c,d,e
!print *,'dd,dd1,dd0',dd,dd1,dd0
!print *,'p,q,T,S',p,q,T,S

   x(1)=-4.0d0*S**2.0d0-2.0d0*p+q/S
   x(1)=-b/4.0d0-S+0.5d0*sqrt(x(1))

   x(2)=-4.0d0*S**2.0d0-2.0d0*p+q/S
   x(2)=-b/4.0d0-S-0.5d0*sqrt(x(2))

   x(3)=-4.0d0*S**2.0d0-2.0d0*p-q/S
   x(3)=-b/4.0d0+S+0.5d0*sqrt(x(3))

   x(4)=-4.0d0*S**2.0d0-2.0d0*p-q/S
   x(4)=-b/4.0d0+S-0.5d0*sqrt(x(4))

!print *,'ROOOOOTS',x(1),x(2),x(3),x(4)
!print *,'IMAG PART',aimag(x(3)),aimag(x(4))
   i=0
   do j=1,4
      if (aimag(x(j)).eq.0.0d0) then !real root
          tmp=real(x(j))
!print *,'tmp',tmp
          if (tmp.gt.limitL .and. tmp.lt.limitR) then
              poly4_root=tmp
              i=i+1
          endif
      endif
   enddo
!print *,'iiiiiiii',i
!print *,'root',poly4_root

   if (i.gt.1) then !multiple crossings in the region of interest
        call error_message(9)
   elseif (i.eq.0) then !no crossings in the region of interest
        call error_message(8)
   endif
end function poly4_root
!---------------------------------------------------------------------
end module root_module


      PROGRAM xsimpr
C     driver for routine simpr
      INTEGER NMAX,NVAR
      REAL HTOT,X1
      PARAMETER(NMAX=3,NVAR=3,X1=0.,HTOT=50.)
      INTEGER i
      REAL a1,a2,a3,y(NMAX),yout(NMAX),
     *     dfdx(NMAX),dfdy(NMAX,NMAX),dydx(NMAX)
      EXTERNAL derivs
      y(1)=1.
      y(2)=1.
      y(3)=0.
      a1=0.5976
      a2=1.4023
      a3=0.
      call derivs(X1,y,dydx)
      call jacobn(X1,y,dfdx,dfdy,NVAR,NMAX)
      write(*,'(1x,a/)') 'Test Problem'
      do 11 i=5,50,5
        call simpr(y,dydx,dfdx,dfdy,NMAX,NVAR,X1,HTOT,i,yout,derivs)
        write(*,'(1x,a,f6.4,a,f7.4,a,i2,a)') 'X = ',X1,
     *       ' to ',X1+HTOT,' in ',i,' steps'
        write(*,'(1x,t5,a,t20,a)') 'Integration','Answer'
        write(*,'(1x,2f12.6)') yout(1),a1
        write(*,'(1x,2f12.6)') yout(2),a2
        write(*,'(1x,2f12.6)') yout(3),a3
11    continue
      END

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


module physics_constants

  use utils_constants

  public

  ! Basic physical constants of matter. The 10^-23 and 10^23 factors
  ! have been removed to ease calculations.

  ! Boltzman Constant - CODATA 2010
  real(8) , parameter :: boltzk = 1.380648813_r8
  ! Avogadro Constant - International Avogadro cohordination 2011
  real(8) , parameter :: navgdr = 6.0221407818_r8

  ! Gas constant in J/K/mol
  real(dp) , parameter :: rgasmol = boltzk*navgdr

  ! Molecular weight of water
  real(dp) , parameter :: watmolwgt = 18.01528_r8 ! g/mol
  ! Mean dry air molecular weight
  real(dp) , parameter :: airmolwgt = 28.96443_r8 ! g/mol
  ! Ratio of mean molecular weight of water to that of dry air
  real(dp) , parameter :: wgtfrac = watmolwgt/airmolwgt

  ! Gas constant for dry air in J/K/kg
  real(dp) , parameter :: rgas = (rgasmol/airmolwgt)*d_1000
  ! Gas constant for water in J/K/kg
  real(dp) , parameter :: rwat = (rgasmol/watmolwgt)*d_1000

  ! 0 C in Kelvin
  real(dp) , parameter :: tzero = 273.16_r8

  ! Standard Gravity (m/sec**2) 3rd CGPM
  real(dp) , parameter :: egrav = 9.80665_r8

  ! Earth radius in meters
  real(8) , parameter :: earthrad = 6.371229D+06
  real(8) , parameter :: erkm = earthrad/d_1000
  ! Angular velocity of rotation of Earth
  real(8) , parameter :: eomeg = 7.2921159D-05
  real(8) , parameter :: eomeg2 = d_2*eomeg

  ! Hydrostatic coefficient
  real(8) , parameter :: gmr = egrav*airmolwgt/rgasmol

  ! Specific heat at constant pressure for dry air J/kg/K
  real(dp) , parameter :: cpd = 1005.46_r8
  ! Specific heat at constant pressure for moist air J/kg/K
  real(dp) , parameter :: cpv = 1869.46_r8
  ! Specific heat of water at 15 Celsius J/kg/K
  real(dp) , parameter :: cpw = 4186.95_r8
  ! Specific heat of water at 0 Celsius J/kg/K
  real(dp) , parameter :: cpw0 = 4218.0_r8

  ! Derived
  real(dp) , parameter :: rgovrw = rgas/rwat
  real(dp) , parameter :: rwovrg = rwat/rgas
  real(dp) , parameter :: rgovcp = rgas/cpd
  real(dp) , parameter :: rgovg  = rgas/egrav
  real(dp) , parameter :: govrg  = egrav/rgas

  real(dp) , parameter :: regrav = d_1/egrav
  real(dp) , parameter :: rrgas = d_1/rgas
  real(dp) , parameter :: rcpd = d_1/cpd

end module physics_constants


*> \brief  DPTSVX computes the solution to system of linear equations A * X = B for PT matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DPTSVX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
*                          RCOND, FERR, BERR, WORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          FACT
*       INTEGER            INFO, LDB, LDX, N, NRHS
*       DOUBLE PRECISION   RCOND
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ),
*      $                   E( * ), EF( * ), FERR( * ), WORK( * ),
*      $                   X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DPTSVX uses the factorization A = L*D*L**T to compute the solution
*> to a real system of linear equations A*X = B, where A is an N-by-N
*> symmetric positive definite tridiagonal matrix and X and B are
*> N-by-NRHS matrices.
*>
*> Error bounds on the solution and a condition estimate are also
*> provided.
*> \endverbatim
*
*> \par Description:
*  =================
*>
*> \verbatim
*>
*> The following steps are performed:
*>
*> 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L
*>    is a unit lower bidiagonal matrix and D is diagonal.  The
*>    factorization can also be regarded as having the form
*>    A = U**T*D*U.
*>
*> 2. If the leading i-by-i principal minor is not positive definite,
*>    then the routine returns with INFO = i. Otherwise, the factored
*>    form of A is used to estimate the condition number of the matrix
*>    A.  If the reciprocal of the condition number is less than machine
*>    precision, INFO = N+1 is returned as a warning, but the routine
*>    still goes on to solve for X and compute error bounds as
*>    described below.
*>
*> 3. The system of equations is solved for X using the factored form
*>    of A.
*>
*> 4. Iterative refinement is applied to improve the computed solution
*>    matrix and calculate error bounds and backward error estimates
*>    for it.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] FACT
*> \verbatim
*>          FACT is CHARACTER*1
*>          Specifies whether or not the factored form of A has been
*>          supplied on entry.
*>          = 'F':  On entry, DF and EF contain the factored form of A.
*>                  D, E, DF, and EF will not be modified.
*>          = 'N':  The matrix A will be copied to DF and EF and
*>                  factored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrices B and X.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is DOUBLE PRECISION array, dimension (N)
*>          The n diagonal elements of the tridiagonal matrix A.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is DOUBLE PRECISION array, dimension (N-1)
*>          The (n-1) subdiagonal elements of the tridiagonal matrix A.
*> \endverbatim
*>
*> \param[in,out] DF
*> \verbatim
*>          DF is DOUBLE PRECISION array, dimension (N)
*>          If FACT = 'F', then DF is an input argument and on entry
*>          contains the n diagonal elements of the diagonal matrix D
*>          from the L*D*L**T factorization of A.
*>          If FACT = 'N', then DF is an output argument and on exit
*>          contains the n diagonal elements of the diagonal matrix D
*>          from the L*D*L**T factorization of A.
*> \endverbatim
*>
*> \param[in,out] EF
*> \verbatim
*>          EF is DOUBLE PRECISION array, dimension (N-1)
*>          If FACT = 'F', then EF is an input argument and on entry
*>          contains the (n-1) subdiagonal elements of the unit
*>          bidiagonal factor L from the L*D*L**T factorization of A.
*>          If FACT = 'N', then EF is an output argument and on exit
*>          contains the (n-1) subdiagonal elements of the unit
*>          bidiagonal factor L from the L*D*L**T factorization of A.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*>          The N-by-NRHS right hand side matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is DOUBLE PRECISION array, dimension (LDX,NRHS)
*>          If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.  LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*>          RCOND is DOUBLE PRECISION
*>          The reciprocal condition number of the matrix A.  If RCOND
*>          is less than the machine precision (in particular, if
*>          RCOND = 0), the matrix is singular to working precision.
*>          This condition is indicated by a return code of INFO > 0.
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*>          FERR is DOUBLE PRECISION array, dimension (NRHS)
*>          The forward error bound for each solution vector
*>          X(j) (the j-th column of the solution matrix X).
*>          If XTRUE is the true solution corresponding to X(j), FERR(j)
*>          is an estimated upper bound for the magnitude of the largest
*>          element in (X(j) - XTRUE) divided by the magnitude of the
*>          largest element in X(j).
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*>          BERR is DOUBLE PRECISION array, dimension (NRHS)
*>          The componentwise relative backward error of each solution
*>          vector X(j) (i.e., the smallest relative change in any
*>          element of A or B that makes X(j) an exact solution).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, and i is
*>                <= N:  the leading minor of order i of A is
*>                       not positive definite, so the factorization
*>                       could not be completed, and the solution has not
*>                       been computed. RCOND = 0 is returned.
*>                = N+1: U is nonsingular, but RCOND is less than machine
*>                       precision, meaning that the matrix is singular
*>                       to working precision.  Nevertheless, the
*>                       solution and error bounds are computed because
*>                       there are a number of situations where the
*>                       computed solution can be more accurate than the
*>                       value of RCOND would suggest.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup doublePTsolve
*
*  =====================================================================
      SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
     $                   RCOND, FERR, BERR, WORK, INFO )
*
*  -- LAPACK driver routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          FACT
      INTEGER            INFO, LDB, LDX, N, NRHS
      DOUBLE PRECISION   RCOND
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), BERR( * ), D( * ), DF( * ),
     $                   E( * ), EF( * ), FERR( * ), WORK( * ),
     $                   X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOFACT
      DOUBLE PRECISION   ANORM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANST
      EXTERNAL           LSAME, DLAMCH, DLANST
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DLACPY, DPTCON, DPTRFS, DPTTRF, DPTTRS,
     $                   XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOFACT = LSAME( FACT, 'N' )
      IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPTSVX', -INFO )
         RETURN
      END IF
*
      IF( NOFACT ) THEN
*
*        Compute the L*D*L**T (or U**T*D*U) factorization of A.
*
         CALL DCOPY( N, D, 1, DF, 1 )
         IF( N.GT.1 )
     $      CALL DCOPY( N-1, E, 1, EF, 1 )
         CALL DPTTRF( N, DF, EF, INFO )
*
*        Return if INFO is non-zero.
*
         IF( INFO.GT.0 )THEN
            RCOND = ZERO
            RETURN
         END IF
      END IF
*
*     Compute the norm of the matrix A.
*
      ANORM = DLANST( '1', N, D, E )
*
*     Compute the reciprocal of the condition number of A.
*
      CALL DPTCON( N, DF, EF, ANORM, RCOND, WORK, INFO )
*
*     Compute the solution vectors X.
*
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DPTTRS( N, NRHS, DF, EF, X, LDX, INFO )
*
*     Use iterative refinement to improve the computed solutions and
*     compute error bounds and backward error estimates for them.
*
      CALL DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR,
     $             WORK, INFO )
*
*     Set INFO = N+1 if the matrix is singular to working precision.
*
      IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
     $   INFO = N + 1
*
      RETURN
*
*     End of DPTSVX
*
      END


      FUNCTION BESSI0(X)
      REAL*8 Y,P1,P2,P3,P4,P5,P6,P7,
     *    Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9
      DATA P1,P2,P3,P4,P5,P6,P7/1.0D0,3.5156229D0,3.0899424D0,1.2067492D
     *0,
     *    0.2659732D0,0.360768D-1,0.45813D-2/
      DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,0.1328592D-1,
     *    0.225319D-2,-0.157565D-2,0.916281D-2,-0.2057706D-1,
     *    0.2635537D-1,-0.1647633D-1,0.392377D-2/
      IF (ABS(X).LT.3.75) THEN
        Y=(X/3.75)**2
        BESSI0=P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))
      ELSE
        AX=ABS(X)
        Y=3.75/AX
        BESSI0=(EXP(AX)/SQRT(AX))*(Q1+Y*(Q2+Y*(Q3+Y*(Q4
     *      +Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9))))))))
      ENDIF
      RETURN
      END


program Cipher
  implicit none
  ! define a defualt value for the key
  integer :: offset = 10

  ! Input string to be encrypted
  character(3) :: str = 'HAL'
  character(3) :: og = ''
  character(3) :: encrypted = ''
  og = str

  write(*, '(2a)') 'Original string  = '//og

  ! Call the encrypt and concat using `//` <= why would they choose that!
  call encrypt(str, offset)
  write(*, '(2a)') 'Encrypt: '//og//' => '//str
  ! Store the encrypted value
  encrypted = str
  ! Repeat the proccess for decryption
  call decrypt(str, offset)
  write(*, '(2a)') 'Decrypted: '//encrypted//' => '//str

  ! encrypt for [0,26]
  call solve(str, og)

contains

subroutine encrypt(text, shift)
  character(*), intent(inout) :: text
  integer :: shift
  integer :: i

  ! do loop, iterate through the string
  do i = 1, len(text)
    select case(text(i:i))
      case ('A':'Z')
        ! use ascii code and add the shift....thank you stack overflow
        text(i:i) = achar(modulo(iachar(text(i:i)) - 65 + shift, 26) + 65)
      case ('a':'z')
        ! do the same for lowercase leters
        text(i:i) = achar(modulo(iachar(text(i:i)) - 97 + shift, 26) + 97)
    end select
  end do
end subroutine

subroutine decrypt(text, shift)
  character(*), intent(inout) :: text
  integer :: shift
  integer :: i

  do i = 1, len(text)
    select case(text(i:i))
      case ('A':'Z')
        ! subtract the same shift interval
        text(i:i) = achar(modulo(iachar(text(i:i)) - 65 - shift, 26) + 65)
      case ('a':'z')
        ! do the same for the lil letters
        text(i:i) = achar(modulo(iachar(text(i:i)) - 97 - shift, 26) + 97)
    end select
  end do
end subroutine

subroutine solve(text, og)
  character(*), intent(inout) :: text
  character(*), intent(inout) :: og
  character(4) :: key
  integer :: i

  ! The easy part.....call encrypt 27 times
  do i = 0, 26
    text = og
    call encrypt(text, i)
    ! convert int to string.....I miss .lower()
    write(key, '(I2)') i
    ! trim the key because it gets weird otherwise
    write(*, '(2a)') 'Key:'//trim(key)//' => '//text
  end do
end subroutine

end program Cipher


! hilbert transform

use MathClass
use ArrayClass
use IOClass
implicit none

type(Math_) :: math
type(IO_)   :: f
type(Random_) :: random
complex(complex64),allocatable :: t(:), wave(:), h_top_wave(:)&
    ,h_bottom_wave(:),spectre(:),t_w(:,:)
real(real64) :: omega_1
real(real64) :: omega_2

omega_1=0.10d0/math%pi
omega_2=0.3d0/math%pi

t = linspace([0.0d0,1000.0d0],1024)
wave = sin(omega_1*t(:)) * 0.30d0*sin(omega_2*t(:) +2.0d0)* exp(-omega_1/10.0d0*t(:) ) +0.40d0*sin(omega_1*20.0d0*t(:))
wave(500:550) = wave(500:550)  +0.80d0*sin(omega_1*80.0d0*t(500:550))

do i_i=700,750
    wave(i_i) = wave(i_i)  + random%gauss(mu=0.0d0,sigma=1.0d0)
enddo
wave(400:450) = wave(400:450)*2.0d0

call f%open("input_wave.txt")
call f%write(abs(t),real(wave) )
call f%close()
call f%plot(option="with lines")

t_w = short_time_FFT(wave,128)

call f%open("result.txt")
do i_i=1,size(t_w,1)
    do j_j=1,size(t_w,2)/2
        write(f%fh,*) i_i,j_j,abs(t_w(i_i,j_j))
    enddo
    write(f%fh,*) " "
enddo
call f%close()
call f%splot(option="with lines")

end


*> \brief \b SLQT02
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK,
*                          RWORK, RESULT )
*
*       .. Scalar Arguments ..
*       INTEGER            K, LDA, LWORK, M, N
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), AF( LDA, * ), L( LDA, * ),
*      $                   Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
*      $                   WORK( LWORK )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SLQT02 tests SORGLQ, which generates an m-by-n matrix Q with
*> orthonornmal rows that is defined as the product of k elementary
*> reflectors.
*>
*> Given the LQ factorization of an m-by-n matrix A, SLQT02 generates
*> the orthogonal matrix Q defined by the factorization of the first k
*> rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and
*> checks that the rows of Q are orthonormal.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix Q to be generated.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix Q to be generated.
*>          N >= M >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*>          K is INTEGER
*>          The number of elementary reflectors whose product defines the
*>          matrix Q. M >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          The m-by-n matrix A which was factorized by SLQT01.
*> \endverbatim
*>
*> \param[in] AF
*> \verbatim
*>          AF is REAL array, dimension (LDA,N)
*>          Details of the LQ factorization of A, as returned by SGELQF.
*>          See SGELQF for further details.
*> \endverbatim
*>
*> \param[out] Q
*> \verbatim
*>          Q is REAL array, dimension (LDA,N)
*> \endverbatim
*>
*> \param[out] L
*> \verbatim
*>          L is REAL array, dimension (LDA,M)
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the arrays A, AF, Q and L. LDA >= N.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*>          TAU is REAL array, dimension (M)
*>          The scalar factors of the elementary reflectors corresponding
*>          to the LQ factorization in AF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (M)
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is REAL array, dimension (2)
*>          The test ratios:
*>          RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
*>          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_lin
*
*  =====================================================================
      SUBROUTINE SLQT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK,
     $                   RWORK, RESULT )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            K, LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), AF( LDA, * ), L( LDA, * ),
     $                   Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
     $                   WORK( LWORK )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      REAL               ROGUE
      PARAMETER          ( ROGUE = -1.0E+10 )
*     ..
*     .. Local Scalars ..
      INTEGER            INFO
      REAL               ANORM, EPS, RESID
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLANGE, SLANSY
      EXTERNAL           SLAMCH, SLANGE, SLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMM, SLACPY, SLASET, SORGLQ, SSYRK
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, REAL
*     ..
*     .. Scalars in Common ..
      CHARACTER*32       SRNAMT
*     ..
*     .. Common blocks ..
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Executable Statements ..
*
      EPS = SLAMCH( 'Epsilon' )
*
*     Copy the first k rows of the factorization to the array Q
*
      CALL SLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA )
      CALL SLACPY( 'Upper', K, N-1, AF( 1, 2 ), LDA, Q( 1, 2 ), LDA )
*
*     Generate the first n columns of the matrix Q
*
      SRNAMT = 'SORGLQ'
      CALL SORGLQ( M, N, K, Q, LDA, TAU, WORK, LWORK, INFO )
*
*     Copy L(1:k,1:m)
*
      CALL SLASET( 'Full', K, M, ZERO, ZERO, L, LDA )
      CALL SLACPY( 'Lower', K, M, AF, LDA, L, LDA )
*
*     Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)'
*
      CALL SGEMM( 'No transpose', 'Transpose', K, M, N, -ONE, A, LDA, Q,
     $            LDA, ONE, L, LDA )
*
*     Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) .
*
      ANORM = SLANGE( '1', K, N, A, LDA, RWORK )
      RESID = SLANGE( '1', K, M, L, LDA, RWORK )
      IF( ANORM.GT.ZERO ) THEN
         RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, N ) ) ) / ANORM ) / EPS
      ELSE
         RESULT( 1 ) = ZERO
      END IF
*
*     Compute I - Q*Q'
*
      CALL SLASET( 'Full', M, M, ZERO, ONE, L, LDA )
      CALL SSYRK( 'Upper', 'No transpose', M, N, -ONE, Q, LDA, ONE, L,
     $            LDA )
*
*     Compute norm( I - Q*Q' ) / ( N * EPS ) .
*
      RESID = SLANSY( '1', 'Upper', M, L, LDA, RWORK )
*
      RESULT( 2 ) = ( RESID / REAL( MAX( 1, N ) ) ) / EPS
*
      RETURN
*
*     End of SLQT02
*
      END


program l2norm
    implicit none
    integer           :: n
    real, allocatable :: arr(:)

    print '(a)', "Size of the vector: "
    read *, n
    allocate(arr(n))
    print '(a)', "Vector: "
    read *, arr

    print '(a, g0)', "L2-norm is ", norm2(arr)
    deallocate(arr)
end program l2norm