      subroutine dcopy_wrap(x,y,nx)
cf2py intent(inplace) y
cf2py intent(hide) nx
cf2py threadsafe
      double precision x(nx), y(nx)
      external dcopy
!       dcopy(n,dx,incx,dy,incy)

      CALL dcopy(nx,x,1,y,1)
      RETURN
      END

      SUBROUTINE dtrmm_wrap(M,N,A,B,SIDE,TRANSA,UPLO,ALPHA)
cf2py intent(inplace)::B
cf2py integer intent(hide)::M
cf2py integer intent(hide)::N
cf2py threadsafe

*     .. Scalar Arguments ..
      DOUBLE PRECISION ALPHA
      INTEGER LDA,LDB,M,N
      CHARACTER DIAG,SIDE,TRANSA,UPLO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION A(M,M),B(M,N)

      EXTERNAL DTRMM
! DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*     X = alpha*op( A )*B,   or   X = alpha*B*op( A ),

      DIAG = 'N'
      LDA = M
      LDB = M

      CALL DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
      RETURN
      END

      SUBROUTINE dtrsm_wrap(M,N,A,B,SIDE,TRANSA,UPLO,ALPHA)
cf2py intent(inplace)::B
cf2py integer intent(hide)::M
cf2py integer intent(hide)::N
cf2py threadsafe

*     .. Scalar Arguments ..
      DOUBLE PRECISION ALPHA
      INTEGER LDA,LDB,M,N
      CHARACTER DIAG,SIDE,TRANSA,UPLO
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION A(M,M),B(M,N)

      EXTERNAL DTRSM
! DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
*     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,

      DIAG = 'N'
      LDA = M
      LDB = M

      CALL DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
      RETURN
      END

      SUBROUTINE dpotrf_wrap(A,n,info)

cf2py double precision dimension(n,n), intent(inplace) :: A
cf2py integer depend(A),intent(hide)::n=shape(A,0)
cf2py integer intent(out)::info
cf2py threadsafe

      DOUBLE PRECISION A(n,n)
      INTEGER n, info, i, j

      EXTERNAL DPOTRF
! DPOTRF( UPLO, N, A, LDA, INFO ) Cholesky factorization

!     C <- cholesky(C)
      call DPOTRF( 'U', n, A, n, info )
      do i=2,n
        do j=1,i-1
          A(i,j)=0.0D0
        enddo
      enddo

      return
      END

      subroutine dchdc_wrap(a,p,work,piv,info)

cf2py intent(inplace) a
cf2py intent(hide) p
cf2py intent(hide) work
cf2py intent(out) piv
cf2py intent(out) info
cf2py threadsafe

      integer lda,p,piv(p),job,info
      double precision a(p,p),work(p)

c
c     dchdc computes the cholesky decomposition of a positive definite
c     matrix.  a pivoting option allows the user to estimate the
c     condition of a positive definite matrix or determine the rank
c     of a positive semidefinite matrix.
c
c     on entry
c
c         a      double precision(lda,p).
c                a contains the matrix whose decomposition is to
c                be computed.  onlt the upper half of a need be stored.
c                the lower part of the array a is not referenced.
c
c         lda    integer.
c                lda is the leading dimension of the array a.
c
c         Since f2py will make sure that a is column-major contiguous,
c         lda is set to p in this wrapper.
c
c         p      integer.
c                p is the order of the matrix.
c
c         work   double precision.
c                work is a work array.
c
c         piv   integer(p).
c                piv contains integers that control the selection
c                of the pivot elements, if pivoting has been requested.
c                each diagonal element a(k,k)
c                is placed in one of three classes according to the
c                value of piv(k).
c
c                   if piv(k) .gt. 0, then x(k) is an initial
c                                      element.
c
c                   if piv(k) .eq. 0, then x(k) is a free element.
c
c                   if piv(k) .lt. 0, then x(k) is a final element.
c
c                before the decomposition is computed, initial elements
c                are moved by symmetric row and column interchanges to
c                the beginning of the array a and final
c                elements to the end.  both initial and final elements
c                are frozen in place during the computation and only
c                free elements are moved.  at the k-th stage of the
c                reduction, if a(k,k) is occupied by a free element
c                it is interchanged with the largest free element
c                a(l,l) with l .ge. k.  piv is not referenced if
c                job .eq. 0.
c
c        job     integer.
c                job is an integer that initiates column pivoting.
c                if job .eq. 0, no pivoting is done.
c                if job .ne. 0, pivoting is done.
c
c        In this wrapper, job=1.
c
c     on return
c
c         a      a contains in its upper half the cholesky factor
c                of the matrix a as it has been permuted by pivoting.
c
c         piv   piv(j) contains the index of the diagonal element
c                of a that was moved into the j-th position,
c                provided pivoting was requested.
c
c         info   contains the index of the last positive diagonal
c                element of the cholesky factor.
c
c     for positive definite matrices info = p is the normal return.
c     for pivoting with positive semidefinite matrices info will
c     in general be less than p.  however, info may be greater than
c     the rank of a, since rounding error can cause an otherwise zero
c     element to be positive. indefinite systems will always cause
c     info to be less than p.
c
c     linpack. this version dated 08/14/78 .
c     j.j. dongarra and g.w. stewart, argonne national laboratory and
c     university of maryland.
c
c
c     blas daxpy,dswap
c     fortran dsqrt
c
c     internal variables
c
      integer pu,pl,plp1,i,j,jp,jt,k,kb,km1,kp1,l,maxl
      double precision temp
      double precision maxdia
      logical swapk,negk
c
      pl = 1
      pu = 0
      info = p
      job=1
      lda=p
      if (job .eq. 0) go to 160
c
c        pivoting has been requested. rearrange the
c        the elements according to piv.
c
         do 70 k = 1, p
            swapk = piv(k) .gt. 0
            negk = piv(k) .lt. 0
            piv(k) = k
            if (negk) piv(k) = -piv(k)
            if (.not.swapk) go to 60
               if (k .eq. pl) go to 50
                  call dswap(pl-1,a(1,k),1,a(1,pl),1)
                  temp = a(k,k)
                  a(k,k) = a(pl,pl)
                  a(pl,pl) = temp
                  plp1 = pl + 1
                  if (p .lt. plp1) go to 40
                  do 30 j = plp1, p
                     if (j .ge. k) go to 10
                        temp = a(pl,j)
                        a(pl,j) = a(j,k)
                        a(j,k) = temp
                     go to 20
   10                continue
                     if (j .eq. k) go to 20
                        temp = a(k,j)
                        a(k,j) = a(pl,j)
                        a(pl,j) = temp
   20                continue
   30             continue
   40             continue
                  piv(k) = piv(pl)
                  piv(pl) = k
   50          continue
               pl = pl + 1
   60       continue
   70    continue
         pu = p
         if (p .lt. pl) go to 150
         do 140 kb = pl, p
            k = p - kb + pl
            if (piv(k) .ge. 0) go to 130
               piv(k) = -piv(k)
               if (pu .eq. k) go to 120
                  call dswap(k-1,a(1,k),1,a(1,pu),1)
                  temp = a(k,k)
                  a(k,k) = a(pu,pu)
                  a(pu,pu) = temp
                  kp1 = k + 1
                  if (p .lt. kp1) go to 110
                  do 100 j = kp1, p
                     if (j .ge. pu) go to 80
                        temp = a(k,j)
                        a(k,j) = a(j,pu)
                        a(j,pu) = temp
                     go to 90
   80                continue
                     if (j .eq. pu) go to 90
                        temp = a(k,j)
                        a(k,j) = a(pu,j)
                        a(pu,j) = temp
   90                continue
  100             continue
  110             continue
                  jt = piv(k)
                  piv(k) = piv(pu)
                  piv(pu) = jt
  120          continue
               pu = pu - 1
  130       continue
  140    continue
  150    continue
  160 continue
      do 270 k = 1, p
c
c        reduction loop.
c
         maxdia = a(k,k)
         kp1 = k + 1
         maxl = k
c
c        determine the pivot element.
c
         if (k .lt. pl .or. k .ge. pu) go to 190
            do 180 l = kp1, pu
               if (a(l,l) .le. maxdia) go to 170
                  maxdia = a(l,l)
                  maxl = l
  170          continue
  180       continue
  190    continue
c
c        quit if the pivot element is not positive.
c
         if (maxdia .gt. 0.0d0) go to 200
            info = k - 1
c     ......exit
            go to 280
  200    continue
         if (k .eq. maxl) go to 210
c
c           start the pivoting and update piv.
c
            km1 = k - 1
            call dswap(km1,a(1,k),1,a(1,maxl),1)
            a(maxl,maxl) = a(k,k)
            a(k,k) = maxdia
            jp = piv(maxl)
            piv(maxl) = piv(k)
            piv(k) = jp
  210    continue
c
c        reduction step. pivoting is contained across the rows.
c
         work(k) = dsqrt(a(k,k))
         a(k,k) = work(k)
         if (p .lt. kp1) go to 260
         do 250 j = kp1, p
            if (k .eq. maxl) go to 240
               if (j .ge. maxl) go to 220
                  temp = a(k,j)
                  a(k,j) = a(j,maxl)
                  a(j,maxl) = temp
               go to 230
  220          continue
               if (j .eq. maxl) go to 230
                  temp = a(k,j)
                  a(k,j) = a(maxl,j)
                  a(maxl,j) = temp
  230          continue
  240       continue
            a(k,j) = a(k,j)/work(k)
            work(j) = a(k,j)
            temp = -a(k,j)
            call daxpy(j-k,temp,work(kp1),1,a(kp1,j),1)
  250    continue
  260    continue
  270 continue
  280 continue

C Zero the lower triangle
      do i=2,info
        do j=1,i-1
          a(i,j) = 0.0D0
        enddo
      enddo

C decrement the pivots.
      do i=1,p
        piv(i) = piv(i)-1
      enddo
      return
      end

      SUBROUTINE dpotrs_wrap(chol_fac, b, info, n, m, uplo)

cf2py double precision dimension(n,n), intent(in) :: chol_fac
cf2py integer depend(chol_fac), intent(hide)::n=shape(chol_fac,0)
cf2py integer depend(b), intent(hide)::m=shape(b,1)
cf2py optional character intent(in):: uplo='U'
cf2py integer intent(out)::info
cf2py double precision intent(inplace), dimension(n,m)::b
cf2py threadsafe

      DOUBLE PRECISION chol_fac(n,n), b(n,m)
      INTEGER n, info,m

      CHARACTER uplo

      EXTERNAL DPOTRS
! DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) Solves triangular system

      call DPOTRS(uplo,n,m,chol_fac,n,b,n,info)

      return
      END


    program demo_nearest
    implicit none

       real :: x, y
       x = nearest(42.0, 1.0)
       y = nearest(42.0, -1.0)
       write (*,"(3(g20.15))") x, y, x - y

    !  write (*,"(3(g20.15))") &
    !   nearest(tiny(0.0),1.0), &
    !   nearest(tiny(0.0),-1.0), &
    !   nearest(tiny(0.0),1.0) -nearest(tiny(0.0),-1.0)

    !  write (*,"(3(g20.15))") &
    !   nearest(huge(0.0),1.0), &
    !   nearest(huge(0.0),-1.0), &
    !   nearest(huge(0.0),1.0)- nearest(huge(0.0),-1.0)

    end program demo_nearest


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine presgradient(iponoel,inoel,sa,nk,shockcoef,
     &     dtimef,ipkon,kon,lakon,vold,mi,nmethod,
     &     nactdoh,neqp)
!
!     determining measure for the pressure gradient
!
!     Ref: The Finite Element Method for Fluid Dynamics,
!     O.C. Zienkiewicz, R.L. Taylor & P. Nithiarasu
!     6th edition (2006) ISBN 0 7506 6322 7
!     p. 61
!
      implicit none
!
      character*8 lakon(*)
!
      integer iponoel(*),inoel(2,*),nk,i,j,k,index,indexe,nope,neqp,
     &     ipkon(*),kon(*),node,ielem,mi(*),nmethod,
     &     nactdoh(*)
!
      real*8 sa(*),shockcoef,dtimef,ca,sum,pa,
     &     vold(0:mi(2),*),sumabs,contribution
!
      do i=1,nk
        if(nactdoh(i).le.0) cycle
        if(iponoel(i).le.0) cycle
        j=nactdoh(i)
!
        sum=0.d0
        sumabs=0.d0
        pa=vold(4,i)
        index=iponoel(i)
!
        do
          ielem=inoel(1,index)
          if(ipkon(ielem).lt.0) cycle
          if(lakon(ielem)(1:1).ne.'F') cycle
          if(lakon(ielem)(4:4).eq.'8') then
            nope=8
          elseif(lakon(ielem)(4:4).eq.'4') then
            nope=4
          elseif(lakon(ielem)(4:4).eq.'6') then
            nope=6
          endif
          indexe=ipkon(ielem)
          do k=1,nope
            node=kon(indexe+k)
            if(node.eq.i) cycle
!
!           connecting vector between node i and "node"
!
!
            contribution=(pa-vold(4,node))
            sum=sum+contribution
            sumabs=sumabs+dabs(contribution)
!
          enddo
          index=inoel(2,index)
          if(index.eq.0) exit
        enddo
        if(sumabs.lt.1.d-10) then
          sum=0.d0
          sumabs=1.d0
        endif
        sa(j)=dabs(sum)/(sumabs*dtimef)
      enddo
!
      if(nmethod.eq.4) then
!
!     transient compressible
!
        ca=shockcoef*dtimef
        do i=1,neqp
          sa(i)=ca*sa(i)
        enddo
      else
!
!     steady state compressible
!
        ca=shockcoef*dtimef
        do i=1,neqp
          sa(i)=ca*sa(i)
        enddo
      endif
!
      return
      end


subroutine fgmax_read(fname,ifg)

    ! Read in data file describing any fixed grids.
    ! The file is assumed to have the form:
    !
    ! tstart_max  # start time for monitoring this fgrid.
    ! tend_max    # end time for monitoring this fgrid.
    ! dt_check    # desired maximum time increment between updating max values.
    ! min_level_check # minimum level to check for monitoring values/arrivals
    ! arrival_tol           # tolerance for identifying arrival.
    !
    ! point_style   # 0 ==> list of points, 1 ==> 1d transect,  2 ==> 2d grid, 3 ==> quadrilateral
    ! if point_style==0 this is followed by:
    !   npts        # number of grid points
    !   fname of file containing:    !! MODIFIED from original
    !   x(1), y(1)  # first grid point
    !   ...
    !   x(npts), y(npts)  # last grid point
    ! if point_style==1:
    !   npts
    !   x1, y1     # first point
    !   x2, y2     # last point
    ! if point_style==2:
    !   nx, ny
    !   x1, y1     # lower left corner of cartesian grid
    !   x2, y2     # upper right corner of cartesian grid
    ! if point_style==3:
    !   n12, n23   # number of points on sides 1-2 (also 3-4) and 2-3 (also 4-1)
    !   x1, y1     # first corner of quadrilateral
    !   x2, y2     # second corner
    !   x3, y3     # third corner
    !   x4, y4     # fourth corner
    ! if point_style==4:
    !   read in a topotype=3 file with 0/1 values, 1 at fgmax points

    use fgmax_module
    use amr_module, only: mxnest
    use topo_module, only: read_topo_header

    implicit none
    character(150), intent(in) :: fname
    integer, intent(in) :: ifg
    integer :: k,i,j,point_style,n12,n23
    real(kind=8) :: x1,x2,y1,y2,yj
    real(kind=8) :: x3,x4,y3,y4,x14,y14,x23,y23,xi,eta
    type(fgrid), pointer :: fg
    logical :: foundFile
    character(len=150) :: fname2
    integer omp_get_max_threads, maxthreads
    integer :: clock_start, clock_finish, clock_rate
    real(kind=8), allocatable :: fg_row(:)
    real(kind=8) :: fg_y
    integer :: fg_npts_max, jj

    fname2 = 'NOT_SET'
    inquire(file=trim(fname),exist=foundFile)
    if (.not. foundFile) then
      write(*,*) 'Missing fgmax file...'
      write(*,*) 'Looking for: ',trim(fname)
      stop
      endif

    open(unit=FG_UNIT,file=trim(fname),status='old')

    fg => FG_fgrids(ifg)   ! point to next element of array of fgrids
    read(FG_UNIT,*) fg%tstart_max
    read(FG_UNIT,*) fg%tend_max
    read(FG_UNIT,*) fg%dt_check
    read(FG_UNIT,*) fg%min_level_check
    read(FG_UNIT,*) fg%arrival_tol
    read(FG_UNIT,*) point_style
    fg%point_style = point_style
    if (point_style == 0) then
        read(FG_UNIT,*) fg%npts
        if (fg%npts == 0) then
            ! in this case fname2 is read, separate file containing x,y values:
            read(FG_UNIT,*) fname2
            close(unit=FG_UNIT)
            write(6,*) 'Reading fgmax points from '
            write(6,*) '    ',trim(fname2)
            open(unit=FG_UNIT,file=trim(fname2),status='old')
            read(FG_UNIT,*) fg%npts
            write(6,*) 'npts = ',fg%npts
            endif

        allocate(fg%x(1:fg%npts), fg%y(1:fg%npts))
        do k=1,fg%npts
            read(FG_UNIT,*) fg%x(k), fg%y(k)
            enddo

    else if (point_style == 1) then
        read(FG_UNIT,*) fg%npts
        read(FG_UNIT,*) x1,y1
        read(FG_UNIT,*) x2,y2
        allocate(fg%x(1:fg%npts), fg%y(1:fg%npts))
        do k=1,fg%npts
            fg%x(k) = x1 + (k-1)*(x2-x1)/(fg%npts - 1)
            fg%y(k) = y1 + (k-1)*(y2-y1)/(fg%npts - 1)
            enddo
    else if (point_style == 2) then
        read(FG_UNIT,*) fg%nx, fg%ny
        read(FG_UNIT,*) x1,y1
        read(FG_UNIT,*) x2,y2
        fg%xll = x1
        fg%yll = y1
        fg%dx = (x2-x1)/(fg%nx - 1)
        fg%dy = (y2-y1)/(fg%ny - 1)
        fg%npts = fg%nx*fg%ny
        allocate(fg%x(1:fg%npts), fg%y(1:fg%npts))
        allocate(fg%index(fg%nx, fg%ny)) ! to store index into list of pts
        k = 0
        do j=1,fg%ny
            yj = y1 + (j-1)*(y2-y1)/(fg%ny - 1)
            do i=1,fg%nx
                k = k+1
                fg%x(k) = x1 + (i-1)*(x2-x1)/(fg%nx - 1)
                fg%y(k) = yj
                fg%index(i,j) = k
                enddo
            enddo
    else if (point_style == 3) then
        read(FG_UNIT,*) n12, n23
        read(FG_UNIT,*) x1,y1
        read(FG_UNIT,*) x2,y2
        read(FG_UNIT,*) x3,y3
        read(FG_UNIT,*) x4,y4
        fg%npts = n12*n23
        allocate(fg%x(1:fg%npts), fg%y(1:fg%npts))

        k = 0
        do j=1,n23
            eta = (j-1)/(n23-1.d0)
            x14 = x1 + eta*(x4-x1)
            y14 = y1 + eta*(y4-y1)
            x23 = x2 + eta*(x3-x2)
            y23 = y2 + eta*(y3-y2)
            do i=1,n12
                k = k+1
                xi = (i-1)/(n12-1.d0)
                fg%x(k) = x14 + xi*(x23 - x14)
                fg%y(k) = y14 + xi*(y23 - y14)
                enddo
            enddo
    else if (point_style == 4) then
        ! in this case read in a file name for a file in
        ! topotype=3 format that contains 0 at points not to be used,
        ! and 1 (or maybe an index > 0) at the desired fgmax points
        read(FG_UNIT,*) fname2
        close(unit=FG_UNIT)
        write(6,*) 'Reading fgmax points from '
        write(6,*) '    ',trim(fname2)

        call read_topo_header(fname2,3,fg%nx,fg%ny,fg%xll,fg%yll, &
                         fg%xhi,fg%yhi,fg%dx,fg%dy)

        open(unit=FG_UNIT,file=trim(fname2),status='old')
        ! Skip over header lines read above:
        do i=1,6
            read(FG_UNIT,*)
            enddo

        allocate(fg%index(fg%nx, fg%ny)) ! to store index into list of pts
        allocate(fg_row(fg%nx))          ! temporary for one row
        fg_npts_max = fg%nx * fg%ny
        allocate(fg%x(1:fg_npts_max), fg%y(1:fg_npts_max))  ! list of pts

        k = 0
        fg%index = 0
        do j=1,fg%ny
            jj = fg%ny - j + 1  ! since topo-style file goes from N to S
            read(FG_UNIT,*) (fg_row(i), i=1,fg%nx)
            fg_y = fg%yll + (jj-1)*fg%dy
            !write(6,*) '+++ fg_y = ',fg_y
            do i=1,fg%nx
                if (fg_row(i) > 0) then
                    k = k+1
                    fg%index(i,jj) = k
                    fg%x(k) = fg%xll + (i-1)*fg%dx
                    fg%y(k) = fg_y
                    if ((fg_row(i)>1) .and. (fg_row(i) /= k)) then
                        write(6,*) '*** fg index mismatch, ',fg_row(i),k
                        endif
                    endif
                enddo
            enddo
        fg%npts = k
        write(6,*) 'npts = ',fg%npts

    else
        write(6,*) '*** Unexpected value of point_style in fgmax_read: ',point_style
        write(6,*) '*** Note that format of fgmax file has changed, see documentation'
        stop
        endif

    ! needed to allocate fg%klist array for use on each patch by all threads:
    maxthreads = 1  ! if not using OpenMP
!$  maxthreads = omp_get_max_threads()

    ! needed for timing if printing at end of this routine:
    !call system_clock(clock_start,clock_rate)

    ! allocate and initialize arrays
    allocate(fg%valuemax(1:FG_NUM_VAL, 1:fg%npts))
    allocate(fg%levelmax(1:fg%npts))
    allocate(fg%aux(1:mxnest, 1:FG_NUM_AUX, 1:fg%npts))
    allocate(fg%auxdone(1:mxnest))
    allocate(fg%update_now(1:mxnest))
    allocate(fg%tmax(1:FG_NUM_VAL, 1:fg%npts))
    allocate(fg%t_last_updated(1:mxnest))
    allocate(fg%arrival_time(1:fg%npts))
    allocate(fg%klist(1:fg%npts, 0:maxthreads-1))

    fg%valuemax = FG_NOTSET
    fg%levelmax = 0
    fg%aux = FG_NOTSET
    fg%auxdone = .false.
    fg%update_now = .false.
    fg%tmax = FG_NOTSET
    fg%t_last_updated = fg%tstart_max - fg%dt_check - 1.d0
    fg%arrival_time = FG_NOTSET

    ! Set corners of bounding box.
    ! note that when point_style==4 these arrays are longer than fg%npts
    fg%x1bb = minval(fg%x(1:fg%npts))
    fg%x2bb = maxval(fg%x(1:fg%npts))
    fg%y1bb = minval(fg%y(1:fg%npts))
    fg%y2bb = maxval(fg%y(1:fg%npts))

    write(6,*) '+++ fgbb: ', fg%x1bb,fg%x2bb,fg%y1bb,fg%y2bb
    write(6,*) '+++ fgll: ', fg%xll, fg%yll, fg%nx, fg%ny
    write(6,*) '+++ fg%x(npts), fg%y(1): ',fg%x(fg%npts), fg%y(1)

    close(FG_UNIT)

    !call system_clock(clock_finish,clock_rate)
    !write(6,*) '+++ Done with fgmax_read, cpu time, clock_rate: ', &
    !        (clock_finish - clock_start), clock_rate
    !write(6,*) '+++ maxthreads, fg%npts, fg%klist_last: ', maxthreads, &
    !        fg%npts, fg%klist(fg%npts, maxthreads-1)

end subroutine fgmax_read


!##############################################################################
!# Tutorial 014a: Analysis of a 2D brick mesh
!##############################################################################

module tutorial014a

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput
  use storage

  use triangulation
  use meshgeneration

  implicit none
  private

  public :: start_tutorial014a

contains

  ! ***************************************************************************

  subroutine start_tutorial014a

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation

    integer, dimension(:), pointer :: p_InodalProperty
    integer, dimension(:,:), pointer :: p_IverticesAtElement
    integer, dimension(:,:), pointer :: p_IneighboursAtElement
    integer, dimension(:,:), pointer :: p_IedgesAtElement
    integer, dimension(:,:), pointer :: p_IverticesAtEdge
    integer, dimension(:,:), pointer :: h_IelementsAtEdge
    real(DP), dimension(:,:), pointer :: p_DvertexCoords
    real(DP), dimension(:), pointer :: p_DelementVolume
    integer, dimension(:), pointer :: p_Iidx
    integer, dimension(:), pointer :: p_IelementsAtVertex

    real(DP) :: dx,dy,dvol
    integer :: i, j, j1, j2, j3, j4

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 014a")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format to work with it.
    ! First create a 3x3-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 2, 2)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Print basic information about the mesh.
    ! =================================

    call output_line ("Mesh analysis: ")
    call output_line ("--------------")

    ! ---------------------------------
    ! Print basic information
    call output_line ("Mesh dimension           : " // trim(sys_siL( rtriangulation%ndim, 10)) )
    call output_lbrk()
    call output_line ("Number of elements       : " // trim(sys_siL( rtriangulation%NEL , 10)) )
    call output_line ("Number of vertices       : " // trim(sys_siL( rtriangulation%NVT , 10)) )
    call output_line ("Number of edges          : " // trim(sys_siL( rtriangulation%NMT , 10)) )
    call output_lbrk()
    call output_line ("Number of boundary comp. : " // trim(sys_siL( rtriangulation%NBCT, 10)) )
    call output_line ("Number of vert. on bd.   : " // trim(sys_siL( rtriangulation%NVBD, 10)) )
    call output_line ("Number of edges on bd.   : " // trim(sys_siL( rtriangulation%NMBD, 10)) )
    call output_lbrk()
    call output_line ("Bounding box             : " // &
        trim(sys_sdL( rtriangulation%DboundingBoxMin(1), 2)) // "/"   // &
        trim(sys_sdL( rtriangulation%DboundingBoxMin(2), 2)) // " - " // &
        trim(sys_sdL( rtriangulation%DboundingBoxMax(1), 2)) // "/"   // &
        trim(sys_sdL( rtriangulation%DboundingBoxMax(2), 2)) )
    call output_lbrk()

    ! ---------------------------------
    ! Access the coordinates of vertex 5.
    ! Get the pointer p_DvertexCoords associated to the handle h_DvertexCoords.
    call storage_getbase_double2d (rtriangulation%h_DvertexCoords,p_DvertexCoords)
    dx = p_DvertexCoords(1,5)
    dy = p_DvertexCoords(2,5)

    call output_line ("Coords of vertex 5       : " // trim(sys_sdL( dx,10 )) // " " &
                                                    // trim(sys_sdL( dy,10 )) )

    ! ---------------------------------
    ! Access boundary status of vertex 1, 2 and 5
    call storage_getbase_int (rtriangulation%h_InodalProperty,p_InodalProperty)
    j1 = p_InodalProperty(1)
    j2 = p_InodalProperty(2)
    j3 = p_InodalProperty(5)

    call output_line ("Boundary comp. vertex 1  : " // trim(sys_siL( j1,10 )) )
    call output_line ("Boundary comp. vertex 2  : " // trim(sys_siL( j2,10 )) )
    call output_line ("Boundary comp. vertex 5  : " // trim(sys_siL( j3,10 )) // " (0=inner node)")

    ! ---------------------------------
    ! Access vertices on element 1
    call storage_getbase_int2d (rtriangulation%h_IverticesAtElement,p_IverticesAtElement)
    j1 = p_IverticesAtElement(1,1)
    j2 = p_IverticesAtElement(2,1)
    j3 = p_IverticesAtElement(3,1)
    j4 = p_IverticesAtElement(4,1)

    call output_line ("Vertices on element 1    : " // trim(sys_siL( j1,10 )) // " " &
                                                    // trim(sys_siL( j2,10 )) // " " &
                                                    // trim(sys_siL( j3,10 )) // " " &
                                                    // trim(sys_siL( j4,10 )) )

    ! ---------------------------------
    ! Access edges on element 1
    call storage_getbase_int2d (rtriangulation%h_IedgesAtElement,p_IedgesAtElement)
    j1 = p_IedgesAtElement(1,1)
    j2 = p_IedgesAtElement(2,1)
    j3 = p_IedgesAtElement(3,1)
    j4 = p_IedgesAtElement(4,1)

    call output_line ("Edges on element 1       : " // trim(sys_siL( j1,10 )) // " " &
                                                    // trim(sys_siL( j2,10 )) // " " &
                                                    // trim(sys_siL( j3,10 )) // " " &
                                                    // trim(sys_siL( j4,10 )) )

    ! ---------------------------------
    ! Access neighbouring elements of element 1
    call storage_getbase_int2d (rtriangulation%h_IneighboursAtElement,p_IneighboursAtElement)
    j1 = p_IneighboursAtElement(1,1)
    j2 = p_IneighboursAtElement(2,1)
    j3 = p_IneighboursAtElement(3,1)
    j4 = p_IneighboursAtElement(4,1)

    call output_line ("Neighbours of element 1  : " // trim(sys_siL( j1,10 )) // " " &
                                                    // trim(sys_siL( j2,10 )) // " " &
                                                    // trim(sys_siL( j3,10 )) // " " &
                                                    // trim(sys_siL( j4,10 )) )

    ! ---------------------------------
    ! Access vertices on edge 3
    call storage_getbase_int2d (rtriangulation%h_IverticesAtEdge,p_IverticesAtEdge)
    j1 = p_IverticesAtEdge(1,1)
    j2 = p_IverticesAtEdge(2,1)

    call output_line ("Vertices on edge 3       : " // trim(sys_siL( j1,10 )) // " " &
                                                    // trim(sys_siL( j2,10 )) )

    ! ---------------------------------
    ! Access elements left and right of edge 3
    call storage_getbase_int2d (rtriangulation%h_IelementsAtEdge,h_IelementsAtEdge)
    j1 = h_IelementsAtEdge(1,1)
    j2 = h_IelementsAtEdge(2,1)

    call output_line ("Elements on edge 3       : " // trim(sys_siL( j1,10 )) // " " &
                                                    // trim(sys_siL( j2,10 )) )

    ! ---------------------------------
    ! Volume of element 1 and of the mesh
    call storage_getbase_double (rtriangulation%h_DelementVolume,p_DelementVolume)

    dvol = p_DelementVolume(1)
    call output_line ("Volume of element 1      : " // trim(sys_sdL( dvol,10 )) )

    dvol = p_DelementVolume(rtriangulation%NEL + 1)
    call output_line ("Volume of the mesh       : " // trim(sys_sdL( dvol,10 )) )

    ! ---------------------------------
    ! Elements adjacent to vertex 5 and 6
    call storage_getbase_int (rtriangulation%h_IelementsAtVertexIdx,p_Iidx)
    call storage_getbase_int (rtriangulation%h_IelementsAtVertex,p_IelementsAtVertex)

    call output_line ("Elements on vertex 5     :" , bnolinebreak=.true.)

    do i = p_Iidx(5), p_Iidx(6)-1
      j = p_IelementsAtVertex(i)
      call output_line ( " " // trim(sys_siL( j, 10 )) , bnolinebreak = (i .ne. p_Iidx(6)-1) )
    end do

    call output_line ("Elements on vertex 6     :" , bnolinebreak=.true.)

    do i = p_Iidx(6), p_Iidx(7)-1
      j = p_IelementsAtVertex(i)
      call output_line ( " " // trim(sys_siL( j, 10 )) , bnolinebreak = (i .ne. p_Iidx(7)-1) )
    end do

    ! =================================
    ! Cleanup
    ! =================================

    call tria_done (rtriangulation)

  end subroutine

end module


cFile: simple.f
      subroutine foo(a,m,n)
      integer m,n,i,j
      real a(m,n)
cf2py intent(in,out) a
cf2py intent(hide) m,n
      do i=1,m
         do j=1,n
            a(i,j) = a(i,j) + 10*i+j
         enddo
      enddo
      end
cEOF


 SUBROUTINE elem16(TASK, nelms, elsnam, dtime, ttime, istop, &
                   lnod, flag1, flag2)

 !master routine for element 16 (TLF) 3-D solid element

 USE ctrl_db, ONLY: ndofn, npoin, dtscal
 USE outp_db, ONLY: sumat, iwrit
 USE ele16_db
 USE npo_db
 USE static_db, ONLY : smass
 USE sms_db, ONLY : selective_mass_scaling, sms_ns , sms_name, sms_thl, sms_alp

 IMPLICIT NONE
 CHARACTER(len=*),INTENT(IN):: TASK

 ! optional parameters

 LOGICAL, OPTIONAL :: flag1,flag2
 CHARACTER (len=*), OPTIONAL :: elsnam
 INTEGER (kind=4), OPTIONAL :: istop,nelms(:)
 INTEGER (kind=4), POINTER, OPTIONAL :: lnod(:,:)
 REAL (kind=8), OPTIONAL :: dtime,ttime

 ! Local variables
 CHARACTER (len=mnam) :: sname
 INTEGER (kind=4) :: nreqs, narch, nelem, ngaus,i
 TYPE (ele16_set), POINTER :: elset, anter
 LOGICAL :: sms
 REAL (kind=8) :: thl,alp

 IF ( .NOT.ASSOCIATED (head) ) RETURN  !no element sets

 NULLIFY (anter)      !nullify pointer to previous set
 elset => head        !point to first set of elements

 DO                   !loop over the element sets
   ! recover control variables for present element set
   CALL comm16 (1,nelem,nreqs,narch,sname,elset,ngaus)

   SELECT CASE (TRIM(task))   !according to the requested task

   CASE ('GAUSSC')      !compute initial constants
     CALL gaus16(elset%head,coord,istop, elset%gauss,elset%angdf,ngaus, &
                 elset%locax,elset%quad,elset%shell)

   !CASE ('LOADPL')      !compute gravity load vector
   ! CALL load16 (igrav, loadv(:,:,iload), gvect, gravy, elset%head,ngaus)

   CASE ('CLOSEF')      !close output file
     CALL close1(nreqs,narch)

   CASE ('LUMASS')      !compute (lumped) mass vector
     CALL luma16( elset%head, emass, sumat, coord)

   CASE ('SLUMAS')      !compute (lumped) mass vector

     sms = .FALSE.
     thl = 0d0
     IF( selective_mass_scaling )THEN
       DO i=1,sms_ns
         IF(TRIM(sms_name(i)) == TRIM(sname) )THEN
           alp = sms_alp(i)
           thl = sms_thl(i)
           sms = .TRUE.
           EXIT
         END IF
       END DO
     END IF
     CALL slum16( nelem, elset%head, smass, coora, elset%btscal, dtscal, sms, alp, thl)

   CASE ('NEW','NSTRA1','NSTRA2')  !release DOFs and other tasks
     CALL acvd16 (ifpre, elset%head,elset%quad,elset%lface,nelem)

   CASE ('UPDLON')      !update local node numbers
     CALL updl16 (elset, oldlb)

   CASE ('OUTDYN')      !output variables for post-processing

     IF(flag1.OR.flag2) CALL outd16 (flag1,flag2, iwrit, &
            elset%head, nreqs, narch, elset%ngrqs, ttime, ngaus)

   CASE ('RESVPL')      !compute internal nodal forces
     CALL resv16 (nelem,elset%head, coora, resid, istop, ttime, elset%small, ngaus, &
                  elset%quad,elset%shell,elset%bbar)

   CASE ('DUMPIN')      !dumps variables for restart
     CALL dump16 ( elset )

   CASE ('WRTPOS')      !writes geometric variables for post-process
     CALL mase16 ( nreqs, nelem, elset%head, elset%ngrqs, narch, &
                  elset%angdf, elset%sname, ngaus, elset%locax )
     elset%narch = narch              !keep output file

   CASE ('INCDLT')      !compute critical time increment
     sms = .FALSE.
     thl = 0d0
     IF( selective_mass_scaling )THEN
       DO i=1,sms_ns
         IF(TRIM(sms_name(i)) == TRIM(sname) )THEN
           alp = sms_alp(i)
           thl = sms_thl(i)
           sms = .TRUE.
           EXIT
         END IF
       END DO
     END IF
     CALL delt16 ( nelem, elset%head, dtime, coora, elset%btscal, sms, alp, thl)

   CASE ('SEARCH')      !search if set named SNAME exists
     IF( flag2 )EXIT
     flag2 = TRIM(elsnam) == TRIM(sname)
     IF (flag2) EXIT

   CASE ('SURFAC','BOUNDA')
     IF( flag2 )EXIT
     flag2 = TRIM(elsnam) == TRIM(sname)
     IF (flag2) THEN
       ! get surface definition from the element set
       CALL surf16 (elset%head,elset%nelem)
       EXIT
     END IF

   CASE ('NODSET')      !compute nodes set from element set
     IF( flag2 )EXIT
     flag2 = TRIM(elsnam) == TRIM(sname)
     IF (flag2) THEN
       ! extracts nodes used in the discretization to nodset
       !CALL nods16(nelem, nnode, elset%head, label)
       EXIT
     END IF

    CASE('SLNODS')
      IF( flag2 )EXIT
       flag2 = TRIM(elsnam) == TRIM(sname)
       IF (flag2) THEN
         ! extracts element connectivities into array IMAT
         CALL slno16(nelem,nnode,elset%head,lnod)
         EXIT
       END IF

   CASE ('SECDAT')
     IF( flag2 )EXIT
     flag2 = TRIM(elsnam) == TRIM(sname)
     IF (flag2) THEN
       !  extract SECTIONs used in the set
       !CALL secd16 (elset%head,elset%nelem,ivect)
       EXIT
     END IF

   CASE ('EXPORT')
     IF( flag2 )EXIT
     flag2 = TRIM(elsnam) == TRIM(sname)
     IF (flag2) THEN
       !export set data
       CALL expo16 (elset,flag1,istop)
       EXIT
     END IF

   END SELECT

   IF ( ASSOCIATED (elset%next) ) THEN   !more sets to process
     elset => elset%next                 !point to next set
   ELSE
     EXIT
   END IF

 END DO

 !     delete null elements sets after Nodal Updating
 IF( TRIM(task) == 'UPDLON')THEN
   NULLIFY (anter)
   elset => head
   DO
     IF(.NOT.ASSOCIATED(elset))EXIT
     IF( elset%nelem == 0 )THEN
       CALL del_ele16 (head, anter, elset)
       nelms(16) = nelms(16) - 1
     END IF
     IF (ASSOCIATED(elset))THEN
       anter => elset
       elset => elset%next
     ELSE IF(ASSOCIATED(anter))THEN
       elset => anter%next
     ELSE IF (ASSOCIATED(head)) THEN
       elset => head
     ELSE
       EXIT
     END IF
   END DO
 END IF

 RETURN

 END SUBROUTINE elem16


submodule (results_interface) results_implementation
    implicit none
contains
    module procedure new_results_t
        new_results_t%output = output
    end procedure

    module procedure distance
        allocate(distance%output, mold=this%output)

        block
          integer row, col
          integer, parameter :: window=4, time=1

          associate(rows => size(distance%output,1), cols => size(distance%output,2))
            do concurrent(row=1:rows, col=1:cols)
              associate(first_row => max(1, row-window), last_row=>min(row+window, rows))
                distance%output(row,col) = minval(hypot( &
                  this%output(first_row:last_row, time) - rhs%output(row, time), &
                  this%output(first_row:last_row,  col) - rhs%output(row,  col) &
                ))
              end associate
            end do
          end associate

        end block
    end procedure

    module procedure max_filtered_normalized_distance
        integer, parameter :: mdotos_column=4, thrust_column=5
        real(dp), allocatable :: rhs_filtered(:,:)
        type(results_t) distance

        distance = this%distance(rhs)

        rhs_filtered = rhs%output

        associate( &
         thrust_noise_threshold => 0.01*maxval(rhs%output(:,thrust_column)), &
         mdotos_noise_threshold => 0.01*maxval(rhs%output(:,mdotos_column)) &
        )
          where(rhs_filtered(:,thrust_column) < thrust_noise_threshold) rhs_filtered(:,thrust_column) = 0._dp
          where(rhs_filtered(:,mdotos_column) < mdotos_noise_threshold) rhs_filtered(:,mdotos_column) = 0._dp
        end associate

        where(rhs_filtered/=0._dp)
          distance%output = distance%output/rhs_filtered
        elsewhere
          distance%output = 0.
        end where

        max_filtered_normalized_distance = maxval(distance%output)
    end procedure
end submodule


      SUBROUTINE DTIMMG( IFLAG, M, N, A, LDA, KL, KU )
*
*  -- LAPACK timing routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      INTEGER            IFLAG, KL, KU, LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DTIMMG generates a real test matrix whose type is given by IFLAG.
*  All the matrices are Toeplitz (constant along a diagonal), with
*  random elements on each diagonal.
*
*  Arguments
*  =========
*
*  IFLAG   (input) INTEGER
*          The type of matrix to be generated.
*          = 0 or 1:   General matrix
*          = 2 or -2:  General banded matrix
*          = 3 or -3:  Symmetric positive definite matrix
*          = 4 or -4:  Symmetric positive definite packed
*          = 5 or -5:  Symmetric positive definite banded
*          = 6 or -6:  Symmetric indefinite matrix
*          = 7 or -7:  Symmetric indefinite packed
*          = 8 or -8:  Symmetric indefinite banded
*          = 9 or -9:  Triangular
*          = 10 or -10:  Triangular packed
*          = 11 or -11:  Triangular banded
*          = 12:         General tridiagonal
*          = 13 or -13:  Positive definite tridiagonal
*          For symmetric or triangular matrices, IFLAG > 0 indicates
*          upper triangular storage and IFLAG < 0 indicates lower
*          triangular storage.
*
*  M       (input) INTEGER
*          The number of rows of the matrix to be generated.
*
*  N       (input) INTEGER
*          The number of columns of the matrix to be generated.
*
*  A       (output) DOUBLE PRECISION array, dimension (LDA,N)
*          The generated matrix.
*
*          If the absolute value of IFLAG is 1, 3, or 6, the leading
*          M x N (or N x N) subblock is used to store the matrix.
*          If the matrix is symmetric, only the upper or lower triangle
*          of this block is referenced.
*
*          If the absolute value of IFLAG is 4 or 7, the matrix is
*          symmetric and packed storage is used for the upper or lower
*          triangle.  The triangular matrix is stored columnwise as a
*          inear array, and the array A is treated as a vector of
*          length LDA.  LDA must be set to at least N*(N+1)/2.
*
*          If the absolute value of IFLAG is 2 or 5, the matrix is
*          returned in band format.  The columns of the matrix are
*          specified in the columns of A and the diagonals of the
*          matrix are specified in the rows of A, with the leading
*          diagonal in row
*              KL + KU + 1,  if IFLAG = 2
*              KU + 1,       if IFLAG = 5 or -2
*              1,            if IFLAG = -5
*          If IFLAG = 2, the first KL rows are not used to leave room
*          for pivoting in DGBTRF.
*
*  LDA     (input) INTEGER
*          The leading dimension of A.  If the generated matrix is
*          packed, LDA >= N*(N+1)/2, otherwise LDA >= max(1,M).
*
*  KL      (input) INTEGER
*          The number of subdiagonals if IFLAG = 2, 5, or -5.
*
*  KU      (input) INTEGER
*          The number of superdiagonals if IFLAG = 2, 5, or -5.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, J, JJ, JN, K, MJ, MU
*     ..
*     .. Local Arrays ..
      INTEGER            ISEED( 4 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MIN, SIGN
*     ..
*     .. External Subroutines ..
      EXTERNAL           DCOPY, DLARNV
*     ..
*     .. Data statements ..
      DATA               ISEED / 0, 0, 0, 1 /
*     ..
*     .. Executable Statements ..
*
      IF( M.LE.0 .OR. N.LE.0 ) THEN
         RETURN
*
      ELSE IF( IFLAG.EQ.0 .OR. IFLAG.EQ.1 ) THEN
*
*        General matrix
*
*        Set first column and row to random values.
*
         CALL DLARNV( 2, ISEED, M, A( 1, 1 ) )
         DO 10 J = 2, N, M
            MJ = MIN( M, N-J+1 )
            CALL DLARNV( 2, ISEED, MJ, A( 1, J ) )
            IF( MJ.GT.1 )
     $         CALL DCOPY( MJ-1, A( 2, J ), 1, A( 1, J+1 ), LDA )
   10    CONTINUE
*
*        Fill in the rest of the matrix.
*
         DO 30 J = 2, N
            DO 20 I = 2, M
               A( I, J ) = A( I-1, J-1 )
   20       CONTINUE
   30    CONTINUE
*
      ELSE IF( IFLAG.EQ.2 .OR. IFLAG.EQ.-2 ) THEN
*
*        General band matrix
*
         IF( IFLAG.EQ.2 ) THEN
            K = KL + KU + 1
         ELSE
            K = KU + 1
         END IF
         CALL DLARNV( 2, ISEED, MIN( M, KL+1 ), A( K, 1 ) )
         MU = MIN( N-1, KU )
         CALL DLARNV( 2, ISEED, MU+1, A( K-MU, N ) )
         DO 40 J = 2, N - 1
            MU = MIN( J-1, KU )
            CALL DCOPY( MU, A( K-MU, N ), 1, A( K-MU, J ), 1 )
            CALL DCOPY( MIN( M-J+1, KL+1 ), A( K, 1 ), 1, A( K, J ), 1 )
   40    CONTINUE
*
      ELSE IF( IFLAG.EQ.3 ) THEN
*
*        Symmetric positive definite, upper triangle
*
         CALL DLARNV( 2, ISEED, N-1, A( 1, N ) )
         A( N, N ) = DBLE( N )
         DO 50 J = N - 1, 1, -1
            CALL DCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 )
   50    CONTINUE
*
      ELSE IF( IFLAG.EQ.-3 ) THEN
*
*        Symmetric positive definite, lower triangle
*
         A( 1, 1 ) = DBLE( N )
         IF( N.GT.1 )
     $      CALL DLARNV( 2, ISEED, N-1, A( 2, 1 ) )
         DO 60 J = 2, N
            CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 )
   60    CONTINUE
*
      ELSE IF( IFLAG.EQ.4 ) THEN
*
*        Symmetric positive definite packed, upper triangle
*
         JN = ( N-1 )*N / 2 + 1
         CALL DLARNV( 2, ISEED, N-1, A( JN, 1 ) )
         A( JN+N-1, 1 ) = DBLE( N )
         JJ = JN
         DO 70 J = N - 1, 1, -1
            JJ = JJ - J
            JN = JN + 1
            CALL DCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 )
   70    CONTINUE
*
      ELSE IF( IFLAG.EQ.-4 ) THEN
*
*        Symmetric positive definite packed, lower triangle
*
         A( 1, 1 ) = DBLE( N )
         IF( N.GT.1 )
     $      CALL DLARNV( 2, ISEED, N-1, A( 2, 1 ) )
         JJ = N + 1
         DO 80 J = 2, N
            CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 )
            JJ = JJ + N - J + 1
   80    CONTINUE
*
      ELSE IF( IFLAG.EQ.5 ) THEN
*
*        Symmetric positive definite banded, upper triangle
*
         K = KL
         MU = MIN( N-1, K )
         CALL DLARNV( 2, ISEED, MU, A( K+1-MU, N ) )
         A( K+1, N ) = DBLE( N )
         DO 90 J = N - 1, 1, -1
            MU = MIN( J, K+1 )
            CALL DCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 )
   90    CONTINUE
*
      ELSE IF( IFLAG.EQ.-5 ) THEN
*
*        Symmetric positive definite banded, lower triangle
*
         K = KL
         A( 1, 1 ) = DBLE( N )
         CALL DLARNV( 2, ISEED, MIN( N-1, K ), A( 2, 1 ) )
         DO 100 J = 2, N
            CALL DCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 )
  100    CONTINUE
*
      ELSE IF( IFLAG.EQ.6 ) THEN
*
*        Symmetric indefinite, upper triangle
*
         CALL DLARNV( 2, ISEED, N, A( 1, N ) )
         DO 110 J = N - 1, 1, -1
            CALL DCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 )
  110    CONTINUE
*
      ELSE IF( IFLAG.EQ.-6 ) THEN
*
*        Symmetric indefinite, lower triangle
*
         CALL DLARNV( 2, ISEED, N, A( 1, 1 ) )
         DO 120 J = 2, N
            CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 )
  120    CONTINUE
*
      ELSE IF( IFLAG.EQ.7 ) THEN
*
*        Symmetric indefinite packed, upper triangle
*
         JN = ( N-1 )*N / 2 + 1
         CALL DLARNV( 2, ISEED, N, A( JN, 1 ) )
         JJ = JN
         DO 130 J = N - 1, 1, -1
            JJ = JJ - J
            JN = JN + 1
            CALL DCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 )
  130    CONTINUE
*
      ELSE IF( IFLAG.EQ.-7 ) THEN
*
*        Symmetric indefinite packed, lower triangle
*
         CALL DLARNV( 2, ISEED, N, A( 1, 1 ) )
         JJ = N + 1
         DO 140 J = 2, N
            CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 )
            JJ = JJ + N - J + 1
  140    CONTINUE
*
      ELSE IF( IFLAG.EQ.8 ) THEN
*
*        Symmetric indefinite banded, upper triangle
*
         K = KL
         MU = MIN( N, K+1 )
         CALL DLARNV( 2, ISEED, MU, A( K+2-MU, N ) )
         DO 150 J = N - 1, 1, -1
            MU = MIN( J, K+1 )
            CALL DCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 )
  150    CONTINUE
*
      ELSE IF( IFLAG.EQ.-8 ) THEN
*
*        Symmetric indefinite banded, lower triangle
*
         K = KL
         CALL DLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) )
         DO 160 J = 2, N
            CALL DCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 )
  160    CONTINUE
*
      ELSE IF( IFLAG.EQ.9 ) THEN
*
*        Upper triangular
*
         CALL DLARNV( 2, ISEED, N, A( 1, N ) )
         A( N, N ) = SIGN( DBLE( N ), A( N, N ) )
         DO 170 J = N - 1, 1, -1
            CALL DCOPY( J, A( N-J+1, N ), 1, A( 1, J ), 1 )
  170    CONTINUE
*
      ELSE IF( IFLAG.EQ.-9 ) THEN
*
*        Lower triangular
*
         CALL DLARNV( 2, ISEED, N, A( 1, 1 ) )
         A( 1, 1 ) = SIGN( DBLE( N ), A( 1, 1 ) )
         DO 180 J = 2, N
            CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( J, J ), 1 )
  180    CONTINUE
*
      ELSE IF( IFLAG.EQ.10 ) THEN
*
*        Upper triangular packed
*
         JN = ( N-1 )*N / 2 + 1
         CALL DLARNV( 2, ISEED, N, A( JN, 1 ) )
         A( JN+N-1, 1 ) = SIGN( DBLE( N ), A( JN+N-1, 1 ) )
         JJ = JN
         DO 190 J = N - 1, 1, -1
            JJ = JJ - J
            JN = JN + 1
            CALL DCOPY( J, A( JN, 1 ), 1, A( JJ, 1 ), 1 )
  190    CONTINUE
*
      ELSE IF( IFLAG.EQ.-10 ) THEN
*
*        Lower triangular packed
*
         CALL DLARNV( 2, ISEED, N, A( 1, 1 ) )
         A( 1, 1 ) = SIGN( DBLE( N ), A( 1, 1 ) )
         JJ = N + 1
         DO 200 J = 2, N
            CALL DCOPY( N-J+1, A( 1, 1 ), 1, A( JJ, 1 ), 1 )
            JJ = JJ + N - J + 1
  200    CONTINUE
*
      ELSE IF( IFLAG.EQ.11 ) THEN
*
*        Upper triangular banded
*
         K = KL
         MU = MIN( N, K+1 )
         CALL DLARNV( 2, ISEED, MU, A( K+2-MU, N ) )
         A( K+1, N ) = SIGN( DBLE( K+1 ), A( K+1, N ) )
         DO 210 J = N - 1, 1, -1
            MU = MIN( J, K+1 )
            CALL DCOPY( MU, A( K+2-MU, N ), 1, A( K+2-MU, J ), 1 )
  210    CONTINUE
*
      ELSE IF( IFLAG.EQ.-11 ) THEN
*
*        Lower triangular banded
*
         K = KL
         CALL DLARNV( 2, ISEED, MIN( N, K+1 ), A( 1, 1 ) )
         A( 1, 1 ) = SIGN( DBLE( K+1 ), A( 1, 1 ) )
         DO 220 J = 2, N
            CALL DCOPY( MIN( N-J+1, K+1 ), A( 1, 1 ), 1, A( 1, J ), 1 )
  220    CONTINUE
*
      ELSE IF( IFLAG.EQ.12 ) THEN
*
*        General tridiagonal
*
         CALL DLARNV( 2, ISEED, 3*N-2, A )
*
      ELSE IF( IFLAG.EQ.13 .OR. IFLAG.EQ.-13 ) THEN
*
*        Positive definite tridiagonal
*
         DO 230 J = 1, N
            A( J, 1 ) = 2.0D0
  230    CONTINUE
         CALL DLARNV( 2, ISEED, N-1, A( N+1, 1 ) )
      END IF
*
      RETURN
*
*     End of DTIMMG
*
      END


!##############################################################################
!# Tutorial 022b: Calculate an L2 and H1 norm, standard integration, subdomain
!##############################################################################

module tutorial022b

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use cubature
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock
  use bilinearformevaluation

  use derivatives
  use domainintegration
  use collection
  use pprocerror

  implicit none
  private

  public :: start_tutorial022b

contains

  !****************************************************************************

!<subroutine>

  subroutine fcharFunctionSubdomain (rdiscretisation, nelements,&
      npointsPerElement, Dpoints, IdofsTest, rdomainIntSubset,  Dvalues, rcollection)

!<description>
  ! Defines the characteristic function of the domain where to calculate.
  ! This is multiplied to the error/norm in the cubature point.
!</description>

!<input>
  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(in) :: rdiscretisation

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in) :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in) :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! DIMENSION(NDIM2D,npointsPerElement,nelements)
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  real(DP), dimension(:,:,:), intent(in) :: Dpoints

  ! An array accepting the DOF`s on all elements trial in the trial space.
  ! DIMENSION(\#local DOF`s in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It is usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in) :: rdomainIntSubset

  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional :: rcollection

!</input>

!<output>
  ! This array has to receive the values of the weights in all the
  ! points specified in Dpoints, or the appropriate derivative of
  ! the function, respectively, according to cderivative.
  ! DIMENSION(npointsPerElement,nelements)
  real(DP), dimension(:,:), intent(out) :: Dvalues
!</output>

!</subroutine>

    ! local variables
    integer :: iel,ipt
    real(DP) :: dx,dy

    ! Loop over the elements in the current set.
    do iel = 1,nelements

      ! Loop over all cubature points on the current element
      do ipt = 1,npointsPerElement

        ! Get the coordinates of the point
        dx = Dpoints(1,ipt,iel)
        dy = Dpoints(2,ipt,iel)

        ! Characteristic function of a part of the domain.
        if (dx .le. 0.25_DP) then
          Dvalues(ipt,iel) = 1.0_DP
        else
          Dvalues(ipt,iel) = 0.0_DP
        end if

      end do ! icubp

    end do ! iel

  end subroutine

  ! ***************************************************************************

  subroutine start_tutorial022b

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr
    type(t_scalarCubatureInfo), target :: rcubatureInfo
    type(t_vectorBlock) :: rx

    integer :: ivt
    real(DP) :: dx, dintvalue
    real(DP), dimension(:,:), pointer :: p_DvertexCoords
    real(DP), dimension(:), pointer :: p_Ddata

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 022b")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 9x9-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 8, 8)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rspatialDiscr
    ! which describes the discretisation.
    ! We generate a 1x1 system with Q1.
    ! =================================

    ! Create a spatial discretisation with Q1
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Create a block discretisation with 1 block Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

    ! =================================
    ! Create a scalar vector.
    ! =================================

    ! Create a vector.
    call lsysbl_createVector (rblockDiscr,rx)

    ! =================================
    ! Fill the vector with data.
    ! =================================

    ! Get a pointer to the data.
    call lsyssc_getbase_double (rx%RvectorBlock(1),p_Ddata)

    ! Get a pointer to the point coordinates.
    call storage_getbase_double2d (rtriangulation%h_DvertexCoords,p_DvertexCoords)

    ! Set the entries of the vector according to the function
    !    u(x,y) = 1/exp(x)
    do ivt=1,rx%NEQ
      dx = p_DvertexCoords(1,ivt)
      p_Ddata(ivt) = 1.0_DP / exp(dx)
    end do

    ! =================================
    ! Define cubature formula
    ! =================================

    ! Use a Gauss 3x3 formula for the discretisation.
    call spdiscr_createDefCubStructure (rspatialDiscr,rcubatureInfo,CUB_GEN_AUTO_G3)

    ! =================================
    ! Calculate the L2-norm of u
    ! =================================

    ! Calculate the "error" between the FE function and the zero function.
    ! This gives the L2 norm.
    call pperr_scalar (PPERR_L2ERROR, dintvalue, rx%RvectorBlock(1),&
        ffunctionWeight=fcharFunctionSubdomain,rcubatureInfo=rcubatureInfo)

    call output_line ("L2-norm = "//trim(sys_sdL(dintvalue,10)))

    ! =================================
    ! Calculate the H1-(semi)norm of u
    ! =================================

    ! Calculate the "error" between the FE function and the zero function.
    ! This gives the H1 (semi-)norm.
    call pperr_scalar (PPERR_H1ERROR, dintvalue, rx%RvectorBlock(1),&
        ffunctionWeight=fcharFunctionSubdomain,rcubatureInfo=rcubatureInfo)

    call output_line ("H1-norm = "//trim(sys_sdL(dintvalue,10)))

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the vector
    call lsysbl_releaseVector (rx)

    ! Cubature done.
    call spdiscr_releaseCubStructure (rcubatureInfo)

    ! Release the discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


SUBROUTINE BMG2_SymStd_SETUP_TAUSCH(&
     &                NOG, &
     &                DimX, DimY, DimXfine, DimYfine,&
     &                NProcI, NProcJ &
     &                ) BIND(C, NAME='BMG2_SymStd_SETUP_Tausch')

  use ModInterface
  IMPLICIT NONE

  integer(C_INT), VALUE :: NOG, NProcI, NProcJ
  INTEGER(len_t) :: DimX(NProcI,NOG), DimY(NProcJ,NOG)
  INTEGER(len_t) :: DimXfine(NProcI), DimYfine(NProcJ)

  integer(len_t) :: I, J, iGs, jGs
  integer N

  DO I=1, NProcI
     DimX(I,NOG) = DimXfine(I)
  END DO

  DO J=1, NProcJ
     DimY(J,NOG) = DimYfine(J)
  END DO

  DO N=NOG-1, 1, -1

     iGs = 1

     DO I=1, NProcI

        if (mod(iGs,2).eq.1) then
           DimX(I,N) = (DimX(I,N+1)+1)/2
        else
           IF (mod(DimX(I,N+1),2).eq.1) THEN
              DimX(I,N) = (DimX(I,N+1)-1)/2
           ELSE
              DimX(I,N) = (DimX(I,N+1)+1)/2
           ENDIF
        endif

        iGs = iGs + DimX(I,N+1)

     END DO

     jGs = 1

     DO J=1, NProcJ

        if (mod(jGs,2).eq.1) then
           DimY(J,N) = (DimY(J,N+1)+1)/2
        else
           IF (mod(DimY(J,N+1),2).eq.1) THEN
              DimY(J,N) = (DimY(J,N+1)-1)/2
           ELSE
              DimY(J,N) = (DimY(J,N+1)+1)/2
           ENDIF
        endif

        jGs = jGs + DimY(J,N+1)

     END DO

  END DO

end SUBROUTINE BMG2_SymStd_SETUP_TAUSCH


!This code checks all the spectra in the table and look if there are any NaN

program check_tables_NaN
  implicit none

  integer, parameter :: spec_dim = 2999
  integer, parameter :: nmaxp = 10000
  double precision, parameter :: ergsev  = 1.602197d-12 ! Convert eV to ergs

  integer    :: i, j, unit, rownum, rowmax, start_ind, end_ind, index_scat, index_xil
  integer    :: par_dim, tot_spec_num, cont_bad_spec, cont, &
                tot_spec_analysed
  real       :: variation, norm, sum, sum_ref, threshold, E, dE, ratio, temp
  real       :: spec(spec_dim), spec_ref(spec_dim)
  real       :: ene_lo(spec_dim), ene_hi(spec_dim)
  real       :: earx(0 : spec_dim)
  ! real       :: en(spec_dim)
  real, allocatable :: par_val(:), save_par_val(:)
  logical    :: check
  character (len=200) :: filename, hdu_name
  integer           , allocatable :: num_of_val_par(:)
  character (len=12), allocatable :: par_names(:)

  double precision :: wp(nmaxp), spec_dble
  real             :: Icomp_scat(nmaxp)

!Simple check to find out if the IF statement recognize a NaN
  ! spec(2) = 0.0
  ! spec(1) =  0.0/ spec(2)
  ! write(*, *) spec(1)

  ! if (spec(1) .ne. spec(1)) then
  !    write(*,*) 'It is a NaN'
  ! endif
  ! if (spec(1) .eq. spec(1)) then
  !    write(*,*) 'It is NOT a NaN'
  ! endif

  ! stop

  filename = '/Users/gullo/Software/relxill/tables/xillverCp_v3.6.fits' !xillver-comp.fits
  write(*,*) 'Reading table: ', trim(filename), ' (press Enter to continue)'
  read(*,*)

  ! Emax = 100.0
  ! Emin = 0.07177
  ! dloge = log10( Emax / Emin ) / float(spec_dim)
  ! do i = 0, spec_dim
  !    earx(i) = Emin * (Emax/Emin)**(float(i)/float(spec_dim))
  !    ! write(*,*) i, earx(i)
  ! end do

!Open the fits file and leave it opened
  call open_fits(filename, unit)

  hdu_name = 'PARAMETERS'
  call get_rownum(unit, hdu_name, rowmax)
  par_dim = rowmax
  write(*,*) 'number of parameters in the table', par_dim

  allocate(par_names(par_dim))
  allocate(num_of_val_par(par_dim))
  call get_parameters(unit, par_dim, par_names, num_of_val_par)

  call get_energy(unit, spec_dim, ene_lo, ene_hi)

  do i = 1, spec_dim
     earx(i - 1) =  ene_lo(i)
  enddo
  earx(spec_dim) = ene_hi(spec_dim)

  allocate(par_val(par_dim))
  allocate(save_par_val(par_dim))

  hdu_name = 'SPECTRA'
  call get_rownum(unit, hdu_name, rowmax)
  tot_spec_num = rowmax

!range between 20keV and 50keV (1713 - 1991)
!range between 25keV and 35keV (1782 - 1883)
  start_ind = 1713
  end_ind   = 1991
  save_par_val = 0.0
  cont_bad_spec = 0
  tot_spec_analysed = 0
  threshold = 1e2
  cont  = 0

  open (10, file='bad_xill_spectra.qdp')
  write(10,*) 'skip on'
  ! open (20, file='xill_spectra_parameters_ratio.txt')
  ! write(20,*) '  Spec number      Gamma        A_Fe             log_xi            kTe              Dens             Incl               ratio'

!loop through all the spectra in the xillver table
  ! tot_spec_num = 1
  write(*,*)
  write(*,*) 'I start reading the table...'
  do j = 1, tot_spec_num

     rownum = j
     ! rownum = 338382

     ! get the parameters (par_val) and the spectrum (spec)
     call get_par_and_spec(unit, rownum, par_dim, par_val, spec_dim, spec)

     !Check if the spectrum has NaN
     do i = 1, spec_dim
        if(spec(i) .ne. spec(i)) then
           write(*,*) 'Found NaN in the spectrum: ', par_val(i)
           write(*,*) 'The value of the spectrum is: ', spec(i)
           write(*,*) 'Spectrum number on the table: ',  rownum
           cont_bad_spec = cont_bad_spec + 1
        end if
     enddo

     do i = 1, spec_dim
        dE = (ene_hi(i) - ene_lo(i))
        E  = (ene_hi(i) + ene_lo(i)) * 0.5
        write(10, *) E, spec(i) * E / dE
     enddo
     write(10,*) 'no no'

        !    cont_bad_spec = cont_bad_spec + 1

        ! endif
        tot_spec_analysed = tot_spec_analysed + 1
     ! endif

     enddo
  write(*,*) "I've finished reading."
  write(*,*)

666 continue

  write(10,*) 'scr white'
  write(10,*) 'log y x on'
  close(10)
  call close_fits(unit)

  write(*,*)
  write(*,*)
  write(*,*)
  write(*,*) 'total number of spectra in the table', tot_spec_num
  write(*,*) 'total number of spectra analysed', tot_spec_analysed
  write (*,'(A, I6, A)') 'there are ', cont_bad_spec, ' bad spectra in the table'

end program check_tables_NaN


!-----------------------------------------------------------------------!
!  The Community Multiscale Air Quality (CMAQ) system software is in    !
!  continuous development by various groups and is based on information !
!  from these groups: Federal Government employees, contractors working !
!  within a United States Government contract, and non-Federal sources  !
!  including research institutions.  These groups give the Government   !
!  permission to use, prepare derivative works of, and distribute copies!
!  of their work in the CMAQ system to the public and to permit others  !
!  to do so.  The United States Environmental Protection Agency         !
!  therefore grants similar permission to use the CMAQ system software, !
!  but users are requested to provide copies of derivative works or     !
!  products designed to operate in the CMAQ system to the United States !
!  Government without restrictions as to use by others.  Software       !
!  that is used with the CMAQ system but distributed under the GNU      !
!  General Public License or the GNU Lesser General Public License is   !
!  subject to their copyright restrictions.                             !
!-----------------------------------------------------------------------!

C RCS file, release, date & time of last delta, author, state, [and locker]
C $Header: /project/yoj/arc/JPROC/src/driver/jproc_table/tridiag.f,v 1.5 2011/10/29 01:03:56 sjr Exp $

C what(1) key, module and SID; SCCS file; date and time of last delta:
C @(#)tridiag.F	1.1 /project/mod3/JPROC/src/driver/jproc_table/SCCS/s.tridiag.F 23 May 1997 12:44:32

C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
      SUBROUTINE TRIDIAG ( A, B, E, D, U, N )
C-----------------------------------------------------------------------
C
C  FUNCTION:
C    Solves tridiagonal system by Thomas algorithm.  Algorithm fails
C    if first pivot is zero.  In that case, rewrite the
C    equation as a set of order N-1, with U(2) trivially eliminated.
C The associated tri-diagonal system is stored in 3 arrays
C   B: diagonal
C   A: sub-diagonal
C   E: super-diagonal
C   D: right hand side function
C   U : return solution from tridiagonal solver
C
C     [ B(1) E(1) 0    0    0 ...       0     ]
C     [ A(2) B(2) E(2) 0    0 ...       .     ]
C     [ 0    A(3) B(3) E(3) 0 ...       .     ]
C     [ .       .     .     .           .     ] U(i) = D(i)
C     [ .             .     .     .     0     ]
C     [ .                   .     .     .     ]
C     [ 0                           A(n) B(n) ]
C
C  PRECONDITIONS REQUIRED:
C
C  SUBROUTINES AND FUNCTIONS CALLED:
C
C  REVISION HISTORY:
C    NO.   DATE     WHO      WHAT
C    __    ____     ___      ____
C    4     4/3/96    SJR  copied code and modified for use in JPROC
C    3     8/16/94   XKX  configuration management include statements
C    2     3/15/92   CJC  For use in Models-3 LCM.
C    1     10/19/89  JKV  converted for use on IBM
C    0      3/89     BDX  Initial version
C                    yoj
C-----------------------------------------------------------------------

      IMPLICIT NONE

      INTEGER, PARAMETER :: NMAX = 400

C...ARGUMENTS and their descriptions:

      INTEGER     N                ! number of rows in matrix

      REAL        A( NMAX )        ! subdiagonal
      REAL        B( NMAX )        ! diagonal
      REAL        E( NMAX )        ! superdiagonal
      REAL        D( NMAX )        ! R.H. side
      REAL        U( NMAX )        ! solution

C SCRATCH LOCAL VARIABLES and their descriptions:

      INTEGER     J                ! loop index

      REAL        BET              !
      REAL        GAM( NMAX )      !

C...begin body of subroutine  TRIDIAG
C...  Decomposition and forward substitution:

      BET = 1.0 / B( 1 )
      U( 1 ) = BET * D( 1 )

      DO J = 2, N
        GAM( J ) = BET * E( J - 1 )
        BET = 1.0 / ( B( J ) - A( J ) * GAM( J ) )
        U( J ) = BET * ( D( J ) - A( J ) * U( J - 1) )
      END DO

C...Back-substitution:

      DO J = N - 1, 1, -1
        U( J ) = U( J ) - GAM( J + 1 ) * U( J + 1 )
      END DO

      RETURN
      END


module mod_find_mode

!Module contains function that reduces the first dimension of an array by finding the mode of a
!slice of the first dimension (and is a single point in the remaining dimensions) and using that
!as the new value for the position of that slice. Contains a subroutine for reducing a four
!dimensional array and a subroutine for reducing a three dimensional array

implicit none

contains

subroutine find_mode_4d(array_in,array_out,naxis1,naxis2,naxis3,naxis4)

!Reduces the first dimension of a four dimensional array to the mode of that
!dimension for slices spanning that dimension at each point in the remaining dimensions

implicit none

!Variables with intent IN
!Dimensions of the input array
integer, intent(in) :: naxis1, naxis2, naxis3, naxis4
!Input array
integer, intent(in), dimension(naxis1,naxis2,naxis3,naxis4) :: array_in

!Variables with intent OUT
!Output array
integer, intent(out), dimension(naxis2,naxis3,naxis4) :: array_out

!Local variables
!List of counts of unique values found in a slice
integer, allocatable, dimension(:) :: unique_nums
!highest number in the input array
integer :: max_num
!counters
integer :: i,j,k,l
    !Assuming all values are non-negative this (+1) is the maximum number of elements
    !the list of unique values requires
    max_num = MAXVAL(array_in)
    !Create a static list of counts of unique values and initialize to zero
    allocate(unique_nums(max_num+1))
    unique_nums = 0
    !Iterate over each point in all the dimensions other than the first
    do l = 1,naxis4
        do k = 1,naxis3
            do j = 1,naxis2
                !Iterate over a slice of the first dimension
                do i = 1,naxis1
                    !Ignore negative values
                    if (array_in(i,j,k,l) < 0) cycle
                    !Increment count for this value of this element, add offset of 1 as count
                    !of the value zero is held in position 1
                    unique_nums(array_in(i,j,k,l) + 1) = unique_nums(array_in(i,j,k,l) + 1) + 1
                end do
                !Allocate the value of this point in the output array as the highest count found
                !in the list of unique values and then reset the array to 0 for the next cycle
                array_out(j,k,l) = MAXLOC(unique_nums,1) - 1
                unique_nums = 0
            end do
        end do
    end do
    deallocate(unique_nums)
end subroutine find_mode_4d

subroutine find_mode_3d(array_in,array_out,naxis1,naxis2,naxis3)

!Reduces the first dimension of a three dimensional array to the mode of that
!dimension for slices spanning that dimension at each point in the remaining dimensions

implicit none

!Variables with intent IN
!Dimensions of the input array
integer, intent(in) :: naxis1, naxis2, naxis3
!Input array
integer, intent(in), dimension(naxis1,naxis2,naxis3) :: array_in
!Variables with intent OUT
!Output array
integer, intent(out), dimension(naxis2,naxis3) :: array_out

!Local variables
!List of counts of unique values found in a slice
integer, allocatable, dimension(:) :: unique_nums
!highest number in the input array
integer :: max_num
!counters
integer :: i,j,k
    !Assuming all values are non-negative this (+1) is the maximum number of elements
    !the list of unique values requires
    max_num = MAXVAL(array_in)
    !Create a static list of counts of unique values and initialize to zero
    allocate(unique_nums(max_num+1))
    unique_nums = 0
    !Iterate over each point in all the dimensions other than the first
    do k = 1,naxis3
        do j = 1,naxis2
            !Iterate over a slice of the first dimension
            do i = 1,naxis1
                !Ignore negative values
                if (array_in(i,j,k) < 0) cycle
                !Increment count for this value of this element, add offset of 1 as count
                !of the value zero is held in position 1
                unique_nums(array_in(i,j,k)+1) = unique_nums(array_in(i,j,k)+1) + 1
            end do
            array_out(j,k) = MAXLOC(unique_nums,1) - 1
            unique_nums = 0
        end do
    end do
    deallocate(unique_nums)
end subroutine find_mode_3d

end module mod_find_mode