!     Given a list of pts, find parent elements in hgrid.gr3 (tri or quad), and generate source_sink.in etc
!     Search for parent elements along x- or y- strips (use small mne_bin for efficiency)
!     Works for mixed tri/quad
!     Inputs: ss_pt.bp (list of pts, with z maybe related to volume; see line 217 onwards)
!             hgrid.gr3
!             gen_source.in (see sample below):
!                                         (1) is_xy: search along x (1) or y (2);
!                                         (2) nbin,mne_bin: # of bins & max # of elements in each bin;
!     Output:  source_sink.in, vsource.th, vsink.th, msource.th.
!              If no parent elements are found, the pts are excluded. If >1 pt are in same elem,
!              the results are combined.
!              fort.11: fatal errors.
!
!     ifort -O2 -mcmodel=medium -CB -Bstatic -o gen_source gen_source.f90

!     Sample interpolate_unstructured.in
!     1 !is_xy
!     20000 34000 !nbin,mne_bin

      module global
        implicit real*8(a-h,o-z)

        parameter(pi=3.141592653589793)
        parameter(small1=1.e-4) !small number used to check if a pt is inside a polygon
        integer,save :: mne_bin !max # of elements in each bin

        integer,save :: is_xy,nbin,nebg,npbg
        real*8,save :: binwid,ar_bgmax,xy_min,xy_max

        real*8,save,allocatable :: xbg(:),ybg(:),dpbg(:),areabg(:),arbg(:),xybin(:)
        integer,save,allocatable :: nmbg(:,:),i34bg(:),ne_bin(:),ie_bin(:,:)
      end module global

      program cross
      use global
      implicit real*8(a-h,o-z)
      dimension arco(4),nmfg(4)
      integer,allocatable :: iparen(:),imap_source(:),imap_sink(:),ifl_el(:)
      real*8,allocatable :: dpfg(:),vrate(:),vsource(:),vsink(:),msource(:),total_r(:)

      open(9,file='gen_source.in',status='old')
!     Input x- or y- search (1: x; 2: y)
      read(9,*) is_xy
      if(is_xy/=1.and.is_xy/=2) stop 'Check is_xy'
!     Input # of bins (larger the better; e.g. 20000),
!     and max # of elements in each bin (smaller the better; e.g. # of elements/20000):'
      read(9,*) nbin,mne_bin

!     Set threshold for aspect ratio in background grid (suggest 8) so those triangular elements
!     will be discarded in interpolation
!     Aspect ratio of a triangle is defined as AR=max(Li)/R, where Li are 3 sides, and R=sqrt(A/pi)
!     is equivalent radius (A is area). Note that AR>=2*sqrt(pi/sqrt(3))=2.6935
!      read(9,*) ar_bgmax
!      if(mne_bin<=0.or.ar_bgmax<2.6935) stop 'Check mne_bin or ar_bgmax'
!     Offset in depth in m for output (h_off is added to depths at output if interpolation is done)
!      read(9,*) h_off
      close(9)

      open(10,file='hgrid.gr3',status='old')
      read(10,*)
      read(10,*)nebg,npbg
      allocate(xbg(npbg),ybg(npbg),dpbg(npbg),nmbg(nebg,4),i34bg(nebg),areabg(nebg),arbg(nebg), &
     &xybin(nbin+1),ne_bin(nbin),ie_bin(nbin,mne_bin),stat=istat)
      ie_bin(nbin,mne_bin)=0 !test memory leak
      if(istat/=0) stop 'Allocation failed (1)'
      do i=1,npbg
        read(10,*)j,xbg(i),ybg(i),dpbg(i)
        if(i==1) then
          xmin_bg=xbg(1); xmax_bg=xbg(1)
          ymin_bg=ybg(1); ymax_bg=ybg(1)
        else
          if(xbg(i)<xmin_bg) xmin_bg=xbg(i)
          if(xbg(i)>xmax_bg) xmax_bg=xbg(i)
          if(ybg(i)<ymin_bg) ymin_bg=ybg(i)
          if(ybg(i)>ymax_bg) ymax_bg=ybg(i)
        endif
      enddo !i=1,npbg

!     Nudge min/max values to avoid underflow
      xmin_bg=xmin_bg-1.e-2
      xmax_bg=xmax_bg+1.e-2
      ymin_bg=ymin_bg-1.e-2
      ymax_bg=ymax_bg+1.e-2

      !arbg=0 !init. A.R. for quad
      do i=1,nebg
        read(10,*)j,i34bg(i),(nmbg(i,k),k=1,i34bg(i))
        if(i34bg(i)/=3.and.i34bg(i)/=4) then
          write(*,*)'Only triangles/quad allowed:',i
          stop
        endif
        n1=nmbg(i,1)
        n2=nmbg(i,2)
        n3=nmbg(i,3)
        areabg(i)=signa(xbg(n1),xbg(n2),xbg(n3),ybg(n1),ybg(n2),ybg(n3))
        if(areabg(i)<=0) then
          write(*,*)'Concave element:',i
          stop
        endif
        if(i34bg(i)==4) then
          n4=nmbg(i,4)
          tmp=signa(xbg(n1),xbg(n3),xbg(n4),ybg(n1),ybg(n3),ybg(n4))
          if(tmp<=0) then
            write(*,*)'Concave element (2):',i
            stop
          endif
          areabg(i)=areabg(i)+tmp
        endif

        !Aspect ratio
        !if(i34bg(i)==3) then
        !  rl1=sqrt((xbg(n2)-xbg(n3))**2+(ybg(n2)-ybg(n3))**2)
        !  rl2=sqrt((xbg(n1)-xbg(n3))**2+(ybg(n1)-ybg(n3))**2)
        !  rl3=sqrt((xbg(n2)-xbg(n1))**2+(ybg(n2)-ybg(n1))**2)
        !  arbg(i)=max(rl1,rl2,rl3)/sqrt(areabg(i)/pi)
        !endif !i34bg(i)==3
      enddo !i=1,nebg
      close(10)

!     Bucket strip sorting
!     If an element i is in ie_bin(l,:), it's 'physically' in it (i.e. at least one internal point
!     is inside the bin l; 1<=l<=nbin).
!     If a given pt is inside bin l, search ie_bin(l,:); in addition, also search neighboring
!     (if any) bins if it's right on the border
      ne_bin=0
!      write(98,*)'Max/min:',xmin_bg,xmax_bg,ymin_bg,ymax_bg
      do i=1,nbin+1
        xbin=xmin_bg+(xmax_bg-xmin_bg)/nbin*(i-1)
        ybin=ymin_bg+(ymax_bg-ymin_bg)/nbin*(i-1)
        if(is_xy==1) then
          xybin(i)=xbin
        else
          xybin(i)=ybin
        endif
!        write(98,*)i,xybin(i)
      enddo !i
      binwid=(xybin(nbin+1)-xybin(1))/nbin !bin width
      if(binwid<=0) stop 'negative bin width'

!     Set limits
      if(is_xy==1) then
        xy_min=xmin_bg; xy_max=xmax_bg
      else
        xy_min=ymin_bg; xy_max=ymax_bg
      endif

      iabort=0 !flag for success in binning elements
      do i=1,nebg
        !if(arbg(i)>=ar_bgmax) cycle

        do j=1,i34bg(i)
          nd=nmbg(i,j)
          if(j==1) then
            xe_min=xbg(nd); xe_max=xbg(nd)
            ye_min=ybg(nd); ye_max=ybg(nd)
          else
            if(xbg(nd)<xe_min) xe_min=xbg(nd)
            if(xbg(nd)>xe_max) xe_max=xbg(nd)
            if(ybg(nd)<ye_min) ye_min=ybg(nd)
            if(ybg(nd)>ye_max) ye_max=ybg(nd)
          endif
        enddo !j
        if(is_xy==1) then
          bmin=xe_min; bmax=xe_max
        else
          bmin=ye_min; bmax=ye_max
        endif
        ibin_min=min(nbin,int((bmin-xybin(1))/binwid+1)) !estimate
!        ibin_max=min(nbin,int((bmax-xybin(1))/binwid+1))

        ibin1=0 !start bin #
        ibin2=0 !end bin #
        do l=ibin_min,nbin !min0(ibin_max+1,nbin)
          if(bmin>=xybin(l).and.bmin<xybin(l+1)) ibin1=l
          if(bmax>=xybin(l).and.bmax<=xybin(l+1)) ibin2=l
          if(ibin1/=0.and.ibin2/=0) exit
        enddo !l

        if(ibin1==0.or.ibin2==0) then
          write(11,*)'Cannot find a bin:',i,ibin1,ibin2,bmin,bmax
          do l=1,nbin+1
            write(11,*)xybin(l)
          enddo !l
          stop
        endif
        if(ibin1>ibin2) then
          write(*,*)'Reversed bin'
          stop
        endif
        do l=ibin1,ibin2
          ne_bin(l)=ne_bin(l)+1
          if(ne_bin(l)>mne_bin) then
            if(iabort==0) print*, 'Aborting...'
            iabort=1
          endif
          if(iabort==0) ie_bin(l,ne_bin(l))=i
        enddo !l
      enddo !i=1,nebg

      mne_bin2=maxval(ne_bin)
      if(iabort==0) then
        print*, 'done bucket sorting; actual max. elements in a bin = ',mne_bin2
      else !failed
        write(*,*)'Falied in bucket sort; max. elements in a bin needs to be ',mne_bin2
!'
        stop
      endif
!     end bucket sort

!     Foreground build point file
      open(12,file='ss_pt.bp',status='old')
      read(12,*)
      read(12,*)npfg
      allocate(iparen(npfg),dpfg(npfg),vrate(npfg),ifl_el(nebg),total_r(nebg), &
     &imap_sink(nebg),imap_source(nebg),vsource(nebg),vsink(nebg),msource(nebg))
!     Interpolate and output
      total_r=0
      ifl_el=0 !flag for each bg elem.
      do i=1,npfg
        read(12,*)j,xfg,yfg,vrate(i) !vrate: m/year
        if(vrate(i)==0) cycle

        call binsearch(i,xfg,yfg,iparen(i),arco)

        if(iparen(i)/=0) then
          ie=iparen(i)
          ifl_el(ie)=1
          dpfg(i)=0
          do j=1,i34bg(ie)
            nd=nmbg(ie,j)
            dpfg(i)=dpfg(i)+dpbg(nd)*arco(j)
          enddo !j
          total_r(ie)=total_r(ie)+vrate(i)
        endif
!        write(13,*)i,real(xfg),real(yfg),real(dpfg),iparen(i)
      enddo !i=1,npfg
      close(12)

      nsource=0
      nsink=0
      do i=1,nebg
        if(total_r(i)>0) then
          nsink=nsink+1
          imap_sink(nsink)=i
        endif
        if(total_r(i)<0) then
          nsource=nsource+1
          imap_source(nsource)=i
        endif
      enddo !i

!     Process source outputs
      open(12,file='source_sink.in',status='replace')
      write(12,*)nsource
      do i=1,nsource
        write(12,*)imap_source(i)
      enddo !i
      write(12,*)
      write(12,*)nsink
      do i=1,nsink
        write(12,*)imap_sink(i)
      enddo !i
      close(12)

!     Const. in time for .th
      if(nsource>0) then
        open(13,file='vsource.th',status='replace')
        do i=1,nsource
          ie=imap_source(i)
          dp=max(1.d0,sum(dpbg(nmbg(ie,1:i34bg(ie))))/i34bg(ie))
          rl=100 !100m as a cell? !sqrt(areabg(ie)/pi)
          vsource(i)=abs(total_r(ie))*dp*rl/365/86400 !m^3/s
        enddo !i
        print*, 'Max source=',maxval(vsource(1:nsource))
        write(13,'(1000000(1x,e12.4))')0.,vsource(1:nsource)
        write(13,'(1000000(1x,e12.4))')86400*1000.,vsource(1:nsource)
        close(13)

        open(16,file='msource.th',status='replace')
        ntracers=3
        write(16,'(1000000(1x,e12.4))')0.,(10.,0.,2650.,2650.,2650.,i=1,nsource)
        write(16,'(1000000(1x,e12.4))')86400*1000.,(10.,0.,2650.,2650.,2650.,i=1,nsource)
        close(16)
      endif !nsource

      if(nsink>0) then
        open(13,file='vsink.th',status='replace')
        do i=1,nsink
          ie=imap_sink(i)
          dp=max(1.0d0,sum(dpbg(nmbg(ie,1:i34bg(ie))))/i34bg(ie))
          rl=100 !sqrt(areabg(ie)/pi)
          vsink(i)=-abs(total_r(ie))*dp*rl/365/86400 !m^3/s
        enddo !i
        print*, 'Max sink=',minval(vsink(1:nsink))

        write(13,'(1000000(1x,e12.4))')0.,vsink(1:nsink)
        write(13,'(1000000(1x,e12.4))')86400*1000.,vsink(1:nsink)
        close(13)
      endif !nsink

      stop
      end

!     Search for parent element of (x0,y0) and compute area coordinates arco(4)
!     If the parent element cannot be found, iparen=0
!     Sum of arco may not be exactly 1
      subroutine binsearch(node_num,x0,y0,iparen,arco)
      use global
      implicit real*8(a-h,o-z)
      integer, intent(in) :: node_num !info only
      real*8, intent(in) :: x0,y0
      integer, intent(out) :: iparen
      real*8, intent(out) :: arco(4)
      dimension nind(3)

      if(is_xy==1) then
        xy=x0
      else
        xy=y0
      endif

      iparen=0
      if(xy<xy_min.or.xy>xy_max) return

      l=min(nbin,int((xy-xybin(1))/binwid+1))
      if(xy==xybin(l)) then
        ibin1=max(l-1,1); ibin2=l
      else if(xy==xybin(l+1)) then
        ibin1=l; ibin2=min(l+1,nbin)
      else if(xy>xybin(l).and.xy<xybin(l+1)) then
        ibin1=l; ibin2=l
      else
        write(*,*)'Cannot find a bin (2):',node_num,x0,y0,xybin(l),xybin(l+1),binwid,l
        write(99,*)(i,xybin(i),i=1,nbin+1)
        stop
      endif

      loop1: do l=ibin1,ibin2
        do k=1,ne_bin(l)
          ie=ie_bin(l,k)
          suma=0
          do j=1,3
            j_1=j+1
            j_2=j+2
            if(j_1>3) j_1=j_1-3
            if(j_2>3) j_2=j_2-3
            n1=nmbg(ie,j_1)
            n2=nmbg(ie,j_2)
            n3=nmbg(ie,j)
            if(j==1) area2=dabs(signa(xbg(n1),xbg(n2),xbg(n3),ybg(n1),ybg(n2),ybg(n3)))
            arco(j)=dabs(signa(xbg(n1),xbg(n2),x0,ybg(n1),ybg(n2),y0))/area2
            suma=suma+arco(j)
          enddo !j
          if(dabs(suma-1)<small1) then
            iparen=ie
            arco(4)=0
            exit loop1
          endif

          if(i34bg(ie)==4) then
            nind(1)=1; nind(2)=3; nind(3)=4
            suma=0
            do j=1,3
              j_1=j+1
              j_2=j+2
              if(j_1>3) j_1=j_1-3
              if(j_2>3) j_2=j_2-3
              n1=nmbg(ie,nind(j_1))
              n2=nmbg(ie,nind(j_2))
              n3=nmbg(ie,nind(j))
              if(j==1) area2=dabs(signa(xbg(n1),xbg(n2),xbg(n3),ybg(n1),ybg(n2),ybg(n3)))
              arco(nind(j))=dabs(signa(xbg(n1),xbg(n2),x0,ybg(n1),ybg(n2),y0))/area2
              suma=suma+arco(nind(j))
            enddo !j
            if(dabs(suma-1)<small1) then
              iparen=ie
              arco(2)=0
              exit loop1
            endif
          endif !quad
        enddo !k=1,ne_bin(l)
      end do loop1 !l

!      if(iparen==0) then
!        write(*,*)'Cannot find a parent:',x0,y0
!        stop
!      endif

      return
      end

      function signa(x1,x2,x3,y1,y2,y3)
!...  Compute signed area formed by pts 1,2,3
      implicit real*8(a-h,o-z)

      signa=((x1-x3)*(y2-y3)-(x2-x3)*(y1-y3))/2

      return
      end


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!> @brief compf(i,j,k,ismpl) calculates the compressibility of the fluid
!> @param[in] i cell index, direction I0
!> @param[in] j cell index, direction J0
!> @param[in] k cell index, direction K0
!> @param[in] ismpl local sample index
!> @return compf  [1 / Pa]
!> @details
!> compf(i,j,k,ismpl) calculates the compressibility in (in 1/Pa) of
!> salin water, given temperature (t, in c) pressure (p,in pa), and
!> salinity (s, in mol/L) at node(i,j,k)\n\n
!>
!> Sources:\n
!> Driesner & Heinrich, The system H2O-NaCl. Part I: Correlation
!>    formulae for phase relations in temperature-pressure-composition
!>    space from 0 to 1000 C, 0 to 5000 bar, and 0 to 1 XNaCl
!>    Geochimica et Cosmochimica Acta 71 (2007) 4880-4901\n\n
!>
!> Driesner, The system H2O-NaCl. Part II: Correlations for molar
!>    volume, enthalpy, and isobaric heat capacity from 0 to 1000 C, 1
!>    to 5000 bar, and 0 to 1 XNaCl Geochimica et Cosmochimica Acta 71
!>    (2007) 4902-4919\n\n
      double precision function compf(i,j,k,ismpl)
        use arrays, only: temp, pres, tsal
        use mod_flow, only: pa_conv1

        implicit none

        ! Location indices
        integer, intent (in) :: i
        integer, intent (in) :: j
        integer, intent (in) :: k

        ! Sample index
        integer :: ismpl

        ! Molar mass of NaCl [g/mol]
        double precision, parameter :: mmnacl = 58.44277d0

        ! Mass fraction of NaCl in solution [-]
        double precision :: fracnacl

        ! Molar mass of water, H2O [g/mol]
        double precision, parameter :: mmwater = 18.01528d0

        ! Temperature, [degC]
        double precision :: t

        ! Pressure [MPa]
        double precision :: p

        ! Monomials of pressure [bar]
        double precision :: pb, pb2, pb3

        ! Pure water compressibility [1/Pa]
        double precision cw
        double precision, external :: compw

        ! Pure water density [kg/m3]
        double precision rw
        double precision, external :: rhow

        ! Local salinity [mol/kg]
        double precision :: s

        ! Mole fraction of NaCl [-]
        double precision :: xnacl

        ! Temperature at which pure water has the same molar volume
        ! as the solution [K]
        double precision :: tv

        ! Driesner2007: Coefficients

        ! Equation (9)
        double precision :: n1, n10, n11, n12

        ! Equation (10)
        double precision :: n2, n20, n21, n22, n23

        ! Equation (11), (12)
        double precision :: n1x, n2x

        ! Table 4
        double precision :: n30, n300, n301, n302
        double precision :: n31, n310, n311, n312

        ! Deviation function (13)
        double precision :: dt

        ! Local temperature [degC]
        t = temp(i,j,k,ismpl)

        ! Local pressure [MPa]
        p = pres(i,j,k,ismpl)*pa_conv1

        ! Local salinity [mol/L]
        s = tsal(i,j,k,ismpl)

        ! pure water compressibility [1 / Pa]
        cw = compw(p,t)

        if (s<=0.0d0) then

          compf = cw

        else
          ! pure water density [g/L = kg/m3]
          rw = rhow(p,t)

          ! Pressure [bar] and pressure monomials
          pb = p*10.0d0
          pb2 = pb*pb
          pb3 = pb*pb2

          ! Mass fraction of NaCl, mol/L > (g/L) / (g/L) mass fraction
          fracnacl = s*mmnacl/(rw+s*mmnacl)

          ! Mole fraction of NaCl, (mol/L) / (mol/L)
          xnacl = (fracnacl/mmnacl) / (fracnacl/mmnacl+(1-fracnacl)/mmwater)

          ! Driesner2007 parameters, Table 4
          n11 = -54.2958d0 - 45.7623d0*exp(-9.44785d-4*pb)
          n21 = -2.6142d0 - 0.000239092d0*pb
          n22 = 0.0356828d0 + 4.37235d-6*pb + 2.0566d-9*pb2
          n300 = 7.60664d6 / (pb+472.051d0)**2
          n301 = -50.0d0 - 86.1446d0*exp(-6.21128d-4*pb)
          n302 = 294.318d0 * exp(-5.66735d-3*pb)
          n310 = -0.0732761d0 * exp(-2.3772d-3*pb) - 5.2948d-5*pb
          n311 = -47.2747d0 + 24.3653d0*exp(-1.25533D-3*pb)
          n312 = -0.278529 - 0.00081381*pb

          ! Driesner2007: n1 and n2 parameters for liquid NaCl
          n1x = 330.47d0 + 0.942876d0*sqrt(pb) + 0.0817193*pb - &
            2.47556D-8*pb2 + 3.45052D-10*pb3
          n2x = -0.0370751 + 0.00237723*sqrt(pb) + 5.42049D-5*pb + &
            5.84709D-9*pb2 - 5.99373D-13*pb3

          ! Driesner2007: Set xnacl=1 in (9), => n1 = n1x
          n10 = n1x

          ! Driesner2007: Set xnacl=0 in (9) => n1 = 0.0d0
          n12 = -n10 - n11

          ! Driesner2007: Set xnacl=0 in (10) => n2 = 1.0d0
          n20 = 1.0d0 - n21*sqrt(n22)

          ! Driesner2007: Set xnacl=1 in (10) => n2 = n2x
          n23 = n2x - n20 - n21*sqrt(1.0d0+n22)

          ! Driesner2007: Equation (9)
          n1 = n10 + n11*(1.0d0-xnacl) + n12*(1.0d0-xnacl)**2

          ! Driesner2007: Equation (10)
          n2 = n20 + n21*sqrt(xnacl+n22) + n23*xnacl

          ! Driesner2007: deviation function D(T) Equations (14)-(16)
          n30 = n300 * (exp(n301*xnacl) - 1.0d0) + n302 * xnacl
          n31 = n310 * exp(n311*xnacl) + n312 * xnacl
          dt = n30 * exp(n31 * t)

          ! Temperature at which pure water has the same molar volume
          ! as the solution
          tv = n1 + n2*t+dt

          ! Pure water compressibility at tv
          compf = compw(p,tv)

        end if

        return

      end function compf


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                                !!
!!  This file is part of SciFT project                                               !!
!!  Copyright (c) 2011-2013 Nestor F. Aguirre (nfaguirrec@gmail.com)                 !!
!!  Copyright (c) 2000-2008 Roland Schmehl (roland.schmehl@alumni.uni-karlsruhe.de)  !!
!!                                                                                !!
!!  Redistribution and use in source and binary forms, with or without               !!
!!  modification, are permitted provided that the following conditions are met:      !!
!!                                                                                !!
!!  1. Redistributions of source code must retain the above copyright notice, this   !!
!!     list of conditions and the following disclaimer.                              !!
!!  2. Redistributions in binary form must reproduce the above copyright notice,     !!
!!     this list of conditions and the following disclaimer in the documentation     !!
!!     and/or other materials provided with the distribution.                        !!
!!  3. Neither the name of the copyright holders nor the names of its contributors   !!
!!     may be used to endorse or promote products derived from this software         !!
!!     without specific prior written permission.                                    !!
!!                                                                                !!
!!  The copyright holders provide no reassurances that the source code provided      !!
!!  does not infringe any patent, copyright, or any other intellectual property      !!
!!  rights of third parties.  The copyright holders disclaim any liability to any    !!
!!  recipient for claims brought against recipient by any third party for            !!
!!  infringement of that parties intellectual property rights.                       !!
!!                                                                                !!
!!  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND  !!
!!  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED    !!
!!  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE           !!
!!  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR  !!
!!  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES   !!
!!  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;     !!
!!  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND      !!
!!  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT       !!
!!  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS    !!
!!  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                     !!
!!                                                                                !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!**********************************************************************************
!!                                                                                !
!!    (2000-2008) Roland Schmehl                                                   !
!!                roland.schmehl@alumni.uni-karlsruhe.de                           !
!!                                                                                !
!!    This software is distributable under the BSD license. See the terms of the   !
!!    BSD license in the documentation provided with this software.                !
!!                                                                                !
!!    Fortran 90 function parser v1.1                                              !
!!    -------------------------------                                              !
!!                                                                                !
!!    This function parser module is intended for applications where a set of      !
!!    mathematical fortran-style expressions is specified at runtime and is then   !
!!    evaluated for a large number of variable values. This is done by compiling   !
!!    the set of function strings into byte code, which is interpreted efficiently !
!!    for the various variable values.                                             !
!!                                                                                !
!!    The source code is available from http://fparser.sourceforge.net             !
!!                                                                                !
!!    Please send comments, corrections or questions to the author:                !
!!    Roland Schmehl <roland.schmehl@alumni.uni-karlsruhe.de>                      !
!!                                                                                !
!!    The function parser concept is based on a C++ class library written by       !
!!    Juha Nieminen <warp@iki.fi> available from:                                  !
!!    http://warp.povusers.org/FunctionParser/                                     !
!!                                                                                !
!!**********************************************************************************

!>
!! @brief
!!
module MathParser_
	implicit none
	private

	public :: &
		MathParser_test

	real(8), parameter :: ZERO = 0.0_8

	integer, parameter :: C_IMMED    = 1
	integer, parameter :: C_NEG      = 2
	integer, parameter :: C_ADD      = 3
	integer, parameter :: C_SUB      = 4
	integer, parameter :: C_MUL      = 5
	integer, parameter :: C_DIV      = 6
	integer, parameter :: C_POW      = 7

	integer, parameter :: C_ABS      = 8
	integer, parameter :: C_EXP      = 9
	integer, parameter :: C_LOG10    = 10
	integer, parameter :: C_LOG      = 11
	integer, parameter :: C_SQRT     = 12
	integer, parameter :: C_SINH     = 13
	integer, parameter :: C_COSH     = 14
	integer, parameter :: C_TANH     = 15
	integer, parameter :: C_SIN      = 16
	integer, parameter :: C_COS      = 17
	integer, parameter :: C_TAN      = 18
	integer, parameter :: C_ASIN     = 19
	integer, parameter :: C_ACOS     = 20
	integer, parameter :: C_ATAN     = 21
	integer, parameter :: C_SGN      = 22
	integer, parameter :: C_CEIL     = 23
	integer, parameter :: C_FLOOR    = 24
	integer, parameter :: C_USTEP    = 25
	integer, parameter :: C_UBOX     = 26

	integer, parameter :: C_VARBEGIN = 27

	character(1), parameter :: STR_OPERATORS(C_ADD:C_POW) &
		= [ '+', '-', '*', '/', '^' ]

	character(6), parameter :: STR_FUNCTIONS(C_ABS:C_UBOX) &
		= [ 'abs   ', 'exp   ', 'log10 ', 'log   ', 'sqrt  ', 'sinh  ', 'cosh  ', &
		    'tanh  ', 'sin   ', 'cos   ', 'tan   ', 'asin  ', 'acos  ', 'atan  ', &
		    'sgn   ', 'ceil  ', 'floor ', 'ustep ', 'ubox  ' ]

	character(*), parameter :: ERROR_MESSAGE(4) &
		 = [ 'Division by zero', 'Argument of SQRT negative', &
		   'Argument of LOG negative', 'Argument of ASIN or ACOS illegal' ]

	type, public :: MathParser
		integer, private, pointer :: bytecode(:)
		integer, private :: bytecodeSize
		real(8), private, pointer :: immed(:)
		integer, private :: immedSize
		real(8), private, pointer :: stack(:)
		integer, private :: stackSize
		integer, private :: stackPtr

		integer, private :: error ! =0: no error occured, >0: evaluation error

		integer, private, allocatable :: funcPosition(:)

		contains
			generic :: init => initDefault
			procedure :: initDefault
! 			generic :: assignment(=) => copyMathParser
! 			procedure :: copy => copyMathParser
! 			procedure :: copyMathParser
			final :: destroy

			procedure :: compile
			procedure :: compileSubstr
			procedure :: parseFunction
			procedure :: evaluateFunction
			procedure :: errorMessage
	end type MathParser

	integer, allocatable :: ipos(:) ! Associates function strings

	contains

	!>
	!! @brief Constructor
	!!
	subroutine initDefault( this )
		class(MathParser) :: this

		nullify( this.bytecode )
		nullify( this.immed )
		nullify( this.stack )
	end subroutine initDefault

	!>
	!! @brief Copy constructor
	!!
! 	subroutine copyMathParser( this, other )
! 			class(MathParser), intent(inout) :: this
! 			class(MathParser), intent(in) :: other
!
! 			write(*,*) "### ERROR ### MathParser.copyMathParser(). Copy constructor is not implemented yet"
! 			stop
! 	end subroutine copyMathParser

	!>
	!! @brief Destructor
	!!
	subroutine destroy( this )
		type(MathParser) :: this

		if( associated(this.bytecode) ) deallocate( this.bytecode )
		if( associated(this.immed) ) deallocate( this.immed )
		if( associated(this.stack) ) deallocate( this.stack )
		if( allocated(this.funcPosition) ) deallocate( this.funcPosition )
	end subroutine destroy

	!>
	!! Parse ith function string funcStr and compile it into bytecode
	!!
	!! @param funcStr Function string
	!! @param var Array with variable names
	!!
	subroutine parseFunction( this, funcStr, var )
		class(MathParser) :: this
		character(*), intent(in) :: funcStr
		character(*), intent(in) :: var(:)

		character(len(funcStr)) :: func ! Function string, local use

		allocate( ipos(len_trim(funcStr)) ) ! Char. positions in orig. string
		func = funcStr ! Local copy of function string
		call replace( '**', '^ ', func ) ! Exponent into 1-Char. format
		call removeSpaces( func ) ! Condense function string
		call checkSyntax( this, func, funcStr, var )
		deallocate( ipos )

		call compile( this, func, var ) ! Compile into bytecode
	end subroutine parseFunction

	!>
	!! Evaluate bytecode of ith function for the values passed in array Val(:)
	!!
	!! @param val Variable values
	!!
	function evaluateFunction( this, val ) result( res )
		class(MathParser) :: this
		real(8), intent(in) :: val(:)
		real(8) :: res
		integer :: IP ! Instruction pointer
		integer :: DP ! Data pointer
		integer :: SP ! Stack pointer

		DP = 1
		SP = 0
		do IP=1,this.ByteCodeSize
			select case( this.ByteCode(IP) )
				case( C_IMMED )
					SP=SP+1
					this.stack(SP) = this.Immed(DP)
					DP = DP+1
				case( C_NEG )
					this.stack(SP) = -this.stack(SP)
				case( C_ADD )
					this.stack(SP-1) = this.stack(SP-1)+this.stack(SP)
					SP = SP-1
				case( C_SUB )
					this.stack(SP-1) = this.stack(SP-1)-this.stack(SP)
					SP = SP-1
				case( C_MUL )
					this.stack(SP-1) = this.stack(SP-1)*this.stack(SP)
					SP = SP-1
				case( C_DIV )
					if( this.stack(SP) == ZERO ) then
						this.error = 1
						res = ZERO
						return
					endif
					this.stack(SP-1) = this.stack(SP-1)/this.stack(SP)
					SP = SP-1
				case( C_POW )
					this.stack(SP-1) = this.stack(SP-1)**this.stack(SP)
					SP = SP-1
				case( C_ABS )
					this.stack(SP) = abs( this.stack(SP) )
				case( C_EXP )
					this.stack(SP) = exp( this.stack(SP) )
				case ( C_LOG10 )
					if( this.stack(SP) <= ZERO ) then
						this.error = 3
						res = ZERO
						return
					endif
					this.stack(SP) = log10( this.stack(SP) )
				case( C_LOG )
					if( this.stack(SP) <= ZERO ) then
						this.error = 3
						res = ZERO
						return
					endif
					this.stack(SP) = log( this.stack(SP) )
				case( C_SQRT )
					if( this.stack(SP) < ZERO ) then
						this.error = 3
						res = ZERO
						return
					endif
					this.stack(SP) = sqrt( this.stack(SP) )
				case( C_SINH )
					this.stack(SP) = sinh( this.stack(SP) )
				case( C_COSH )
					this.stack(SP) = cosh( this.stack(SP) )
				case( C_TANH )
					this.stack(SP) = tanh( this.stack(SP) )
				case( C_SIN )
					this.stack(SP) = sin( this.stack(SP) )
				case( C_COS )
					this.stack(SP) = cos( this.stack(SP) )
				case( C_TAN )
					this.stack(SP) = tan( this.stack(SP) )
				case( C_ASIN )
					if( (this.stack(SP)<-1.0_8) .or. (this.stack(SP)>1.0_8) ) then
						this.error = 4
						res = ZERO
						return
					endif
					this.stack(SP) = asin( this.stack(SP) )
				case( C_ACOS )
					if( (this.stack(SP)<-1.0_8) .or. (this.stack(SP)>1.0_8) ) then
						this.error = 4
						res = ZERO
						return
					endif
					this.stack(SP) = acos( this.stack(SP) )
				case( C_ATAN )
					this.stack(SP) = atan( this.stack(SP) )
				case( C_SGN )
					this.stack(SP) = sign( 1.0_8, this.stack(SP) )
				case( C_CEIL )
					this.stack(SP) = ceiling( this.stack(SP) )
				case( C_FLOOR )
					this.stack(SP) = floor( this.stack(SP) )
#define ustep(x) 0.5_8*( 1.0_8 + tanh( 1.0d12*(x) ) )
				case( C_USTEP )
					this.stack(SP) = ustep( this.stack(SP) )
				case( C_UBOX )
					this.stack(SP) = ustep( this.stack(SP)+0.5_8 ) - ustep( this.stack(SP)-0.5_8 )
#undef ustep
				case  default
					SP = SP+1
					this.stack(SP) = val( this.ByteCode(IP)-C_VARBEGIN+1 )
			end select
		end do

		this.error = 0
		res = this.stack(1)
	end function evaluateFunction

	!>
	!! Check syntax of function string,  returns 0 if syntax is ok
	!!
	!! @param func Function string without spaces
	!! @param funcStr Original function string
	!! @param var Array with variable names
	!!
	subroutine checkSyntax( this, func, funcStr, var )
		class(MathParser) :: this
		character(*), intent(in) :: func
		character(*), intent(in) :: funcStr
		character(*), dimension(:), intent(in) :: var

		integer :: n
		character(1) :: c
		real(8) :: r
		logical :: err
		integer :: parCounter ! Parenthesis counter
		integer :: j,ib,in,lFunc

		j = 1
		parCounter = 0
		lFunc = len_trim(func)

		do while( .true. )
			if( j > lFunc) call parseErrMsg( j, funcStr )
			c = func(j:j)

			! Check for valid operand (must appear)
			if( c == '-' .OR. c == '+' ) then ! Check for leading - or +
				j = j+1
				if( j > lFunc) then
					call parseErrMsg(j, funcStr, 'Missing operand' )
				end if
				c = func(j:j)
				if( any(c == STR_OPERATORS)) call parseErrMsg( j, funcStr, 'Multiple operators' )
			end if
			n = MathFunctionIndex (func(j:))
			if( n > 0) then ! Check for math function
				j = j+len_trim(STR_FUNCTIONS(n))
				if( j > lFunc) call parseErrMsg( j, funcStr, 'Missing function argument' )
				c = func(j:j)
				if( c /= '(' ) call parseErrMsg( j, funcStr, 'Missing opening parenthesis' )
			end if
			if( c == '(' ) then ! Check for opening parenthesis
				parCounter = parCounter+1
				j = j+1
				CYCLE
			end if
			if( scan(c,'0123456789.' ) > 0 ) then ! Check for number
				r = strToReal(func(j:),ib,in,err)
				if( err) call parseErrMsg( j, funcStr, 'Invalid number format:  '//func(j+ib-1:j+in-2))
				j = j+in-1
				if( j > lFunc) exit
				c = func(j:j)
			else ! Check for variable
				n = variableIndex(func(j:),var,ib,in)
				if( n == 0) call parseErrMsg( j, funcStr, 'Invalid element: '//func(j+ib-1:j+in-2))
				j = j+in-1
				if( j > lFunc) exit
				c = func(j:j)
			end if
			do while (c == ')' ) ! Check for closing parenthesis
				parCounter = parCounter-1
				if( parCounter < 0) call parseErrMsg( j, funcStr, 'Mismatched parenthesis' )
				if( func(j-1:j-1) == '(' ) call parseErrMsg (j-1, funcStr, 'Empty parentheses' )
				j = j+1
				if( j > lFunc) exit
				c = func(j:j)
			end do

			! Now, we have a legal operand: A legal operator or end of string must follow
			if( j > lFunc) exit
			if( any(c == STR_OPERATORS)) then ! Check for multiple operators
				if( j+1 > lFunc) call parseErrMsg( j, funcStr)
				if( any(func(j+1:j+1) == STR_OPERATORS)) call parseErrMsg (j+1, funcStr, 'Multiple operators' )
			else ! Check for next operand
				call parseErrMsg( j, funcStr, 'Missing operator' )
			end if

			! Now, we have an operand and an operator: the next loop will check for another
			! operand (must appear)
			j = j+1
		end do

		if( parCounter > 0 ) then
			call parseErrMsg( j, funcStr, 'Missing )' )
		end if
	end subroutine checkSyntax

	!>
	!! Return error message
	!!
	function errorMessage( this ) result (msg)
		class(MathParser) :: this
		character(len(ERROR_MESSAGE)) :: msg

		if( this.error < 1 .or. this.error > size(ERROR_MESSAGE) ) then
			msg = ''
		else
			msg = ERROR_MESSAGE(this.error)
		endif
	end function errorMessage

	!>
	!! Print error message and terminate program
	!!
	subroutine parseErrMsg( j, funcStr, msg )
		integer, intent(in) :: j
		character(*), intent(in) :: funcStr       ! Original function string
		character(*), optional, intent(in) :: msg

		integer :: k

		if( present(msg) ) then
			write(*,*) '*** Error in syntax of function string: '//msg
		else
			write(*,*) '*** Error in syntax of function string:'
		endif

		write(*,'(a)') ' '//trim(funcStr)

		do k=1,ipos(j)
			write(*,'(A)',advance='no') ' '! Advance to the jth position
		end do

		write(*,'(A)') '^'
		stop
	end subroutine parseErrMsg

	!>
	!! @brief Return operator index
	!!
	function operatorIndex( c ) result( n )
		character(1), intent(in) :: c
		integer :: n

		integer :: j

		n = 0
		do j=C_ADD,C_POW
			if( c == STR_OPERATORS(j) ) then
				n = j
				exit
			end if
		end do
	end function operatorIndex

	!>
	!! @brief Return index of math function beginnig at 1st position of string str
	!!
	integer function mathFunctionIndex( str )
		character(*), intent(in) :: str

		integer :: j, k
		character(len(STR_FUNCTIONS)) :: lcFunc

		mathFunctionIndex = 0
		do j=C_ABS,C_UBOX ! Check all math functions
			k = min( len_trim(STR_FUNCTIONS(j)), len(str) )

			call toLowercase( str(1:k), lcFunc )

			if( lcFunc(1:k) == STR_FUNCTIONS(j) ) then ! Compare lower case letters
				mathFunctionIndex = j ! Found a matching function
				exit
			end if
		end do
	end function mathFunctionIndex

	!>
	!! Return index of variable at begin of string str (returns 0 if no variable found)
	!!
	!! @param str String
	!! @param var Array with variable names
	!! @param n Index of variable
	!! @param ibegin Start position of variable name
	!! @param inext Position of character after name
	!!
	function variableIndex( str, var, ibegin, inext ) result( n )
		character(*), intent(in) :: str
		character(*), intent(in) :: var(:)
		integer, optional, intent(out) :: ibegin
		integer, optional, intent(out) :: inext
		integer :: n

		integer :: j,ib,in,lstr

		n = 0
		lstr = len_trim(str)
		if( lstr > 0 ) then
			do ib=1,lstr ! Search for first character in str
				if ( str(ib:ib) /= ' ' ) exit ! When lstr>0 at least 1 char in str
			end do

			do in=ib,lstr ! Search for name terminators
				if( scan(str(in:in),'+-*/^) ') > 0 ) exit
			end do

			do j=1,size(var)
				if( str(ib:in-1) == var(j) ) then
					n = j ! Variable name found
					exit
				end if
			end do
		end if

		if( present(ibegin) ) ibegin = ib
		if( present(inext) ) inext  = in
	end function variableIndex

	!>
	!! @brief Remove Spaces from string, remember positions of characters in old string
	!!
	subroutine removeSpaces( str )
		character(*), intent(inout) :: str

		integer :: k
		integer :: lstr

		lstr = len_trim(str)
		ipos = (/ (k,k=1,lstr) /)

		k = 1
		do while( str(k:lstr) /= ' ' )
			if( str(k:k) == ' ' ) then
				str(k:lstr)  = str(k+1:lstr)//' '                  ! Move 1 character to left
				ipos(k:lstr) = (/ ipos(k+1:lstr), 0 /)             ! Move 1 element to left
				k = k-1
			end if
			k = k+1
		end do
	end subroutine removeSpaces

	!>
	!! Replace ALL appearances of character set ca in string str by character set cb
	!!
	subroutine replace( ca, cb, str )
		character(*), intent(in) :: ca
		character(len(ca)), intent(in) :: cb ! LEN(ca) must be LEN(cb)
		character(*), intent(inout) :: str

		integer :: j,lca

		lca = len(ca)
		do j=1,len_trim(str)-lca+1
			if( str(j:j+lca-1) == ca ) str(j:j+lca-1) = cb
		end do
	end subroutine replace

	!>
	!! Compile i-th function string F into bytecode
	!!
	!! @param i Function identifier
	!! @param f Function string
	!! @param var Array with variable names
	!!
	subroutine compile( this, f, var )
		class(MathParser) :: this
		character(*), intent(in) :: f
		character(*), intent(in) :: var(:)

		integer :: istat

		if( associated(this.bytecode) ) then
			deallocate( this.bytecode )
			deallocate( this.immed )
			deallocate( this.stack )
		end if

		this.bytecodeSize = 0
		this.immedSize = 0
		this.stackSize = 0
		this.stackPtr = 0

		call compileSubstr( this, f, 1, len_trim(f), var ) ! compile string to determine size

		allocate( this.bytecode( this.bytecodeSize ), stat=istat )
		allocate( this.immed( this.immedSize ), stat=istat )
		allocate( this.stack( this.stackSize ), stat=istat )

		if( istat /= 0 ) then
			write(*,*) '*** MathParser error: Memmory allocation for byte code failed'
			stop
		else
			this.bytecodeSize = 0
			this.immedSize = 0
			this.stackSize = 0
			this.stackPtr = 0

			call compileSubstr( this, f, 1, len_trim(f), var ) ! Compile string into bytecode
		end if
	end subroutine compile

	!>
	!! Compile function string f into bytecode
	!!
	!! @param f Function substring
	!! @param b Begin position substring
	!! @param e End position substring
	!! @param var Array with variable names
	!!
	recursive subroutine compileSubstr( this, f, b, e, var )
		class(MathParser) :: this
		character(*), intent(in) :: f
		integer, intent(in) :: b,e
		character(*), intent(in) :: var(:)

		integer :: n
		integer :: b2,j,k,io
		character(*), parameter :: calpha = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'

		! Check for special cases of substring
		if( f(b:b) == '+' ) then ! Case 1: f(b:e) = '+...'
! 			write(*,*)'1. f(b:e) = "+..."'
			call compileSubstr( this, f, b+1, e, var )
			return
		elseif( completelyEnclosed( f, b, e ) ) then ! Case 2: f(b:e) = '(...)'
! 			write(*,*)'2. f(b:e) = "(...)"'
			call compileSubstr( this, f, b+1, e-1, var )
			return
		elseif( scan(f(b:b),calpha) > 0 ) then
			n = mathFunctionIndex( f(b:e) )
			if( n > 0 ) then
				b2 = b + index( f(b:e), '(' ) - 1
				if( completelyEnclosed( f, b2, e ) ) then ! Case 3: f(b:e) = 'fcn(...)'
! 					write(*,*)'3. f(b:e) = "fcn(...)"'
					call compileSubstr( this, f, b2+1, e-1, var )
					call addCompiledByte( this, n )
					return
				end if
			end if
		elseif( f(b:b) == '-' ) then
			if( completelyEnclosed(f, b+1, e) ) then ! Case 4: f(b:e) = '-(...)'
! 			        write(*,*)'4. f(b:e) = "-(...)"'
				call compileSubstr( this, f, b+2, e-1, var )
				call addCompiledByte( this, C_NEG )
				return
			elseif( scan( f(b+1:b+1), calpha ) > 0 ) then
				n = mathFunctionIndex( f(b+1:e) )
				if( n > 0 ) then
					b2 = b+index(f(b+1:e),'(')
					if( completelyEnclosed( f, b2, e ) ) then ! Case 5: f(b:e) = '-fcn(...)'
! 						write(*,*)'5. f(b:e) = "-fcn(...)"'
						call compileSubstr( this, f, b2+1, e-1, var)
						call addCompiledByte( this, n )
						call addCompiledByte( this, C_NEG )
						return
					end if
				end if
			endif
		end if

		! Check for operator in substring: check only base level (k=0), exclude expr. in ()
		do io=C_ADD,C_POW ! Increasing priority +-*/^
			k = 0
			do j=e,b,-1
				if( f(j:j) == ')' ) then
					k = k+1
				elseif( f(j:j) == '(' ) then
					k = k-1
				end if
					if( k == 0 .and. f(j:j) == STR_OPERATORS(io) .and. isBinaryOperator(j, F) ) then
						if( any(f(j:j) == STR_OPERATORS(C_MUL:C_POW)) .and. f(b:b) == '-' ) then ! Case 6: F(b:e) = '-...Op...' with Op > -
! 						write(*,*)'6. f(b:e) = "-...Op..." with Op > -'
						call compileSubstr( this, f, b+1, e, var )
						call addCompiledByte( this, C_NEG )
						return
					else ! Case 7: f(b:e) = '...BinOp...'
! 						write(*,*)'7. Binary operator',f(j:j)
						call compileSubstr( this, f, b, j-1, var )
						call compileSubstr( this, f, j+1, e, var )
						call addCompiledByte( this, operatorIndex(STR_OPERATORS(io)) )
						this.StackPtr = this.StackPtr - 1
						return
					end if
				end if
			end do
		end do

		! check for remaining items, i.e. variables or explicit numbers
		b2 = b
		if( f(b:b) == '-' ) b2 = b2+1
		n = mathItemIndex( this, f(b2:e), var )
! 		write(*,*)'8. AddCompiledByte ', n
		call addCompiledByte( this, n )
		this.stackPtr = this.stackPtr + 1
		if( this.StackPtr > this.StackSize ) this.stackSize = this.stackSize + 1
		if( b2 > b ) call addCompiledByte( this, C_NEG )
	end subroutine compileSubstr

	!>
	!! Add compiled byte to bytecode
	!!
	subroutine addCompiledByte( this, b )
		class(MathParser) :: this
		integer, intent(in) :: b ! Value of byte to be added

		this.ByteCodeSize = this.ByteCodeSize + 1
		IF( associated(this.ByteCode) ) this.byteCode( this.byteCodeSize ) = b
	end subroutine addCompiledByte

	!>
	!! Return math item index, if item is real number, enter it into Comp-structure
	!!
	function mathItemIndex( this, f, var ) result( n )
		class(MathParser) :: this
		character(*), intent(in) :: f ! Function substring
		character(*), intent(in) :: var(:) ! Array with variable names
		integer :: n ! Byte value of math item

		n = 0
		if( scan( f(1:1), '0123456789.' ) > 0 ) then ! Check for begin of a number
			this.immedSize = this.immedSize + 1
			if( associated(this.immed) ) then
				this.immed( this.immedSize ) = strToReal( f )
			end if
			n = C_IMMED
		else                                                     ! Check for a variable
			n = variableIndex( f, var )
			if( n > 0 ) n = C_VARBEGIN+n-1
		end if
	end function mathItemIndex

	!>
	!! Check if function substring F(b:e) is completely enclosed by a pair of parenthesis
	!!
	function completelyEnclosed( f, b, e ) result( res )
		character(*), intent(in) :: f ! Function substring
		integer, intent(in) :: b, e ! First and last pos. of substring

		logical :: res
		integer :: j,k

		res = .false.
		if( f(b:b) == '(' .and. f(e:e) == ')' ) then
			k = 0
			do j=b+1,e-1
				if( f(j:j) == '(' ) then
					k = k+1
				else if( f(j:j) == ')' ) then
					k = k-1
				end if
				if (k < 0) exit
			end do
			if (k == 0) res=.true. ! All opened parenthesis closed
		end if
	end function completelyEnclosed

	!>
	!! Check if operator str(j:j) in string str is binary operator
	!! Special cases already covered elsewhere:( that is corrected in v1.1 )
	!! operator character str(j:j) is first character of string (j=1)
	!!
	!! @param j Position of Operator
	!! @param str String
	!!
	!! @return res Result
	!!
	function isBinaryOperator( j, str ) result( res )
		integer, intent(in) :: j
		character(*), intent(in) :: str
		logical :: res

		integer :: k
		logical :: dFlag
		logical :: pFlag

		res = .true.

		if( str(j:j) == '+' .or. str(j:j) == '-' ) then ! Plus or minus sign:
			if( j == 1 ) then ! leading unary operator ?
				res = .false.
			else if ( scan( str(j-1:j-1), '+-*/^(' ) > 0 ) then ! other unary operator ?
				res = .false.
			else if ( scan( str(j+1:j+1), '0123456789' ) > 0 .and. & ! in exponent of real number ?
				scan( str(j-1:j-1), 'eEdD' ) > 0 ) then

				dFlag=.false.; pFlag=.false.

				k = j-1
				do while( k > 1 ) ! step to the left in mantissa
					k = k-1

					if( scan( str(k:k), '0123456789' ) > 0 ) then
						dFlag = .true.
					else if( str(k:k) == '.' ) then
						if (pFlag) then
							exit ! exit: 2nd appearance of '.'
						else
							pFlag = .true. ! mark 1st appearance of '.'
						endif
					else
						exit ! all other characters
					end if
				end do
				if( dFlag .and. ( k == 1 .or. scan( str(k:k), '+-*/^(' ) > 0 ) ) res = .false.
			end if
		end if
	end function isBinaryOperator

	!>
	!! @brief Get real number from string - Format: [blanks][+|-][nnn][.nnn][e|E|d|D[+|-]nnn]
	!!
	!! @param str String to transform
	!! @param ibegin Start position of real number (OPTIONAL)
	!! @param 1st character after real number (OUTPUT,OPTIONAL)
	!! @param error Error flag (OPTIONAL)
	!!
	!! @return res String converted to real
	!!
	function strToReal( str, ibegin, inext, error ) result ( res )
		character(*), intent(in) :: str
		integer, optional, intent(out) :: ibegin
		integer, optional, intent(out) :: inext
		logical, optional, intent(out) :: error
		real(8) :: res

		integer :: ib,in,istat
		logical :: bFlag  ! .T. at begin of number in str
		logical :: inMan  ! .T. in mantissa of number
		logical :: pFlag  ! .T. after 1st '.' encountered
		logical :: eFlag  ! .T. at exponent identifier 'eEdD'
		logical :: inExp  ! .T. in exponent of number
		logical :: dInMan ! .T. if at least 1 digit in mant.
		logical :: dInExp ! .T. if at least 1 digit in exp.
		logical :: err    ! Local error flag

		bFlag=.true.
		inMan=.false.
		pFlag=.false.
		eFlag=.false.
		inExp=.false.
		dInMan=.false.
		dInExp=.false.

		ib = 1
		in = 1

		do while( in <= len_trim(str) )
			select case( str(in:in) )
				case( ' ' ) ! Only leading blanks permitted
					ib = ib+1

					if( inman .or. eflag .or. inexp ) then
						exit
					end if
				CASE( '+', '-' ) ! Permitted only
					if( bFlag ) then
						inMan=.true.; bFlag=.false. ! at beginning of mantissa
					else if( eFlag ) then
						inExp=.true.; eFlag=.false. ! at beginning of exponent
					else
						exit ! - otherwise STOP
					endif
				case( '0' : '9' ) ! Mark
					if( bFlag ) then
						inMan=.true.; bFlag=.false. ! beginning of mantissa
					else if( eFlag ) then
						inExp=.true.; eFlag=.false. ! beginning of exponent
					endif

					if( inMan ) dInMan=.true. ! Mantissa contains digit
					if( inExp ) dInExp=.true. ! Exponent contains digit
				case( '.' )
					if( bFlag ) then
						pFlag=.true. ! mark 1st appearance of '.'
						inMan=.true.; bFlag=.false. ! mark beginning of mantissa
					else if( inMan .and. .not. pFlag ) then
						pFlag=.true. ! mark 1st appearance of '.'
					else
						exit ! otherwise STOP
					end if
				CASE( 'e', 'E', 'd', 'D' ) ! Permitted only
					if( inMan ) then
						eFlag=.true.; inMan=.false. ! following mantissa
					else
						exit ! otherwise STOP
					endif
				case default
					exit ! STOP at all other characters
			end select
			in = in+1
		end do

		err = ( ib > in-1 ) .or. ( .not. dInMan ) .or. ( (eFlag .or. inExp) .and. .not. dInExp )

		if( err ) then
			res = 0.0_8
		else
			read( str(ib:in-1), *, iostat=istat ) res
			err = istat /= 0
		end if

		if( present(ibegin) ) ibegin = ib
		if( present(inext) )  inext = in
		if( present(error) )  error = err
	end function strToReal

	!>
	!! @brief Transform upper case letters in str into lower case letters
	!!
	subroutine toLowercase( str, lcStr )
		character(*), intent(in) :: str
		character(*), intent(out) :: lcStr

		character(*), parameter :: lc = 'abcdefghijklmnopqrstuvwxyz'
		character(*), parameter :: uc = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'

		integer :: j,k

		lcStr = str
		do j=1,len_trim(str)
			k = index( uc, str(j:j) )
			if (k > 0) lcStr(j:j) = lc(k:k)
		end do
	end subroutine toLowercase

	!>
	!! @brief Test method
	!!
	subroutine MathParser_test()
		type(MathParser) :: parser
		character(255) :: func
		character(6) :: var(5)
		real(8) :: val(5)

		character(10), allocatable :: cVar(:)
		real(8), allocatable :: cVal(:)

		allocate( cVar(2) )
		cVar = [ 'r', 's ' ]

		allocate( cVal(2) )
		cVal = [ 2.0_8, 3.0_8 ]

		call parser.init()

		func = "-0.5*12*cos(0.5)*(a**2+2)*sin(b*0.5+0.6)*1e-2+0.5*x+r+s"
		var  = [ 'x', 'a', 'b', cVar ]
		val  = [ 2.0_8, 3.0_8, 4.0_8, cVal ]

		call parser.parseFunction( func, var )
		write(*,"(A60,A6,F10.6)") trim(func), "  ==> ", parser.evaluateFunction( val )

		call parser.parseFunction( "0.5*10.8", ["x"] )
		write(*,"(A60,A6,F10.6)") "0.5*10.8", "  ==> ", parser.evaluateFunction( [0.0_8] )

		func = "sgn(-1.456)"
		call parser.parseFunction( func, var )
		write(*,"(A60,A6,F10.6)") trim(func), "  ==> ", parser.evaluateFunction( [0.0_8] )

		func = "ustep(1.456)"
		call parser.parseFunction( func, var )
		write(*,"(A60,A6,F10.6)") trim(func), "  ==> ", parser.evaluateFunction( [0.0_8] )

		func = "ustep(-1.456)"
		call parser.parseFunction( func, var )
		write(*,"(A60,A6,F10.6)") trim(func), "  ==> ", parser.evaluateFunction( [0.0_8] )

		func = "ustep(0.0)"
		call parser.parseFunction( func, var )
		write(*,"(A60,A6,F10.6)") trim(func), "  ==> ", parser.evaluateFunction( [0.0_8] )

		func = "ubox(-0.6)"
		call parser.parseFunction( func, var )
		write(*,"(A60,A6,F10.6)") trim(func), "  ==> ", parser.evaluateFunction( [0.0_8] )

		func = "ubox(-0.5)"
		call parser.parseFunction( func, var )
		write(*,"(A60,A6,F10.6)") trim(func), "  ==> ", parser.evaluateFunction( [0.0_8] )

		func = "ubox(0.0)"
		call parser.parseFunction( func, var )
		write(*,"(A60,A6,F10.6)") trim(func), "  ==> ", parser.evaluateFunction( [0.0_8] )

		func = "ubox(0.3)"
		call parser.parseFunction( func, var )
		write(*,"(A60,A6,F10.6)") trim(func), "  ==> ", parser.evaluateFunction( [0.0_8] )

		func = "ubox(0.5)"
		call parser.parseFunction( func, var )
		write(*,"(A60,A6,F10.6)") trim(func), "  ==> ", parser.evaluateFunction( [0.0_8] )

		func = "ubox(0.6)"
		call parser.parseFunction( func, var )
		write(*,"(A60,A6,F10.6)") trim(func), "  ==> ", parser.evaluateFunction( [0.0_8] )

	end subroutine MathParser_test

end module MathParser_


program unittests

  implicit none

  integer :: info

  write(*,*) 'Test 1 - Random DP matrix generation'
  call testrandDP(info)
  if (info .eq. 0) then
     write(*,*) 'OK'
  else
     write(*,*) 'NOT OK'
  end if

  write(*,*) 'Test 2 - Random Lower Chol generation'
  call testrandchol(info)
  if (info .eq. 0) then
     write(*,*) 'OK'
  else
     write(*,*) 'NOT OK'
  end if

  write(*,*) 'Test 3 - Random DP Householder matrix generation'
  call testrandhDP(1.0D0,info)
  if (info .eq. 0) then
     write(*,*) 'OK'
  else
     write(*,*) 'NOT OK'
  end if

  write(*,*) 'Test 4 - Random Indefinite matrix generation'
  call testrandhDP(- 1.0D0,info)
  if (info .ne. 0) then
     write(*,*) 'OK'
  else
     write(*,*) 'NOT OK'
  end if

contains

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

  subroutine testrandDP(info)

    use gentests

    implicit none

    real(8),allocatable :: A(:,:)
    integer :: i,j,n,info

    interface
       subroutine dpotrf (UPLO, N, A, LDA, INFO)
         character :: UPLO
         integer   :: N,LDA,INFO
         real(8)   :: A(LDA,*)

         intent(   in) :: UPLO,N,LDA
         intent(inout) :: A
         intent(  out) :: INFO
       end subroutine dpotrf
    end interface

    do n = 10,1010,100

       allocate(A(n,n))

       call genRandDP(n,A,5.0D-1)

       CALL dpotrf('L',n,A,n,info)

       if (info .ne. 0) then
          write(*,*) 'Error in the SDP creation: Matrix is not DP. n=', n
          exit
       end if

       deallocate(A)

    end do

  end subroutine testrandDP

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

  subroutine testrandhDP(mult,info)

    use gentests

    implicit none

    real(8),allocatable :: A(:,:)
    real(8) :: mult
    integer :: i,j,n,info

    interface
       subroutine dpotrf (UPLO, N, A, LDA, INFO)
         character :: UPLO
         integer   :: N,LDA,INFO
         real(8)   :: A(LDA,*)

         intent(   in) :: UPLO,N,LDA
         intent(inout) :: A
         intent(  out) :: INFO
       end subroutine dpotrf
    end interface

    do n = 10,1010,100

       allocate(A(n,n))

       call genRandHouseDP(n,A,2.0D-1,mult * n)

       CALL dpotrf('L',n,A,n,info)

       if (info .ne. 0) then
          exit
       end if

       deallocate(A)

    end do

  end subroutine testrandhDP

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

  subroutine testrandchol(info)

    use gentests

    implicit none

    real(8),allocatable :: L(:,:)
    integer :: i,j,n,info
    real(8) :: tmp

    info = 0

    do n = 10,1010,100

       allocate(L(n,n))

       call genRandCholL(n,L,5.0D-1)

       tmp = 1.0D+20
       do i = 1,n
          tmp = min(tmp,L(i,i))
       end do

       if (tmp .le. 1.0D-5) then
          write(*,*) 'Error in the lower Chol. creation. Negative diag. n=', &
               n
          info = -1
          exit
       end if

       tmp = 0.0D0
       do j = 1,n
          do i = 1,j - 1
             tmp = max(tmp,L(i,j))
          end do
       end do

       if (tmp .gt. 0.0D0) then
          write(*,*) 'Error in the lower Chol. creation. Nonzero upper. n=', &
               n
          info = -1
          exit
       end if

       deallocate(L)

    end do

  end subroutine testrandchol

end program unittests


      program t
C test for g, o, z, d, and / in format-item-list
      real::a=3.141592654
 0123 format (O15,O15.2 (2/) Z10,Z10.6//////g15.3,g15.3e3,D15.2)
      write(*,0123) a,a,a,a,a,a,a
      endprogram t


subroutine nsm_InitStats(a)
   use typre
   use Mod_NavierStokes
   implicit none
   class(NavierStokesProblem) :: a

   !Write info
   a%tamin=1.0e20_rp                  ! Minimum tau
   a%tamax=0.0_rp                     ! Maximum tau
   a%tamea=0.0_rp                     ! Mean tau
   a%remin=1.0e20_rp                  ! Minimum Re
   a%remax=0.0_rp                     ! Maximum Re
   a%remea=0.0_rp                     ! Mean Re
   a%nmean=0
end subroutine

subroutine nsm_InGaussStats(a,acden,acvis,gpvno,chale,timom)
   use typre
   use Mod_NavierStokes
   implicit none
   class(NavierStokesProblem) :: a
   real(rp) :: acden,acvis,gpvno,chale(2),timom

   real(rp) :: reyno

   ! Compute cell reynolds number and store values.
   a%nmean = a%nmean+1
   reyno = acden*gpvno*chale(2)/acvis
   a%remin = min(a%remin,reyno)
   a%remax = max(a%remax,reyno)
   a%remea = a%remea + reyno

   a%tamin = min(a%tamin,timom)
   a%tamax = max(a%tamax,timom)
   a%tamea = a%tamea + timom
end subroutine

subroutine nsm_FinalizeStats(a)
   use typre
   use Mod_NavierStokes
   implicit none
   class(NavierStokesProblem) :: a

   a%tamea=a%tamea/real(a%nmean,rp)
   a%remea=a%remea/real(a%nmean,rp)

end subroutine


program preview
  use pnm_tools
  use filtering
  use gradation_processing
  use posterization
  implicit none
  character(len=100) :: filename
  integer, allocatable :: img(:, :, :)
  integer :: maximum_value = 255

  call get_command_argument(1, filename)

  img = load_pnm(filename)

  call display_img(img, maximum_value)
  ! filtering.f90
  call display_img(laplacian(img, maximum_value), maximum_value)
  call display_img(gaussian(img, maximum_value, 3), maximum_value)
  call display_img(sobel(img, maximum_value, is_canny=.false.), maximum_value)
  ! call display_img(canny_edge_detection(img, maximum_value), maximum_value)
  call display_img(bilateral(img, 0.3, maximum_value, 3), maximum_value)
  call display_img(emboss(img, maximum_value), maximum_value)
  ! gradation_processing.f90
  call display_img(linear_translation(img, maximum_value), maximum_value)
  call display_img(brightness_translation(img, 45, maximum_value), maximum_value)
  call display_img(contrast_translation(img, maximum_value, 0.3), maximum_value)
  call display_img(gamma_correction(img, maximum_value, 3.0), maximum_value)
  call display_img(histogram_equalization(img, maximum_value), maximum_value)
  ! posterization.f08
  call display_img(to_binary(img, 45), 1)
  call display_img(otsu(img, maximum_value), 1)
  call display_img(adaptive_threshold(img, maximum_value, 15), 1)
  call display_img(quantize(img, 8, maximum_value), 8)
  call display_img(dither(img, maximum_value), 1)
  call display_img(error_diffusion(img, maximum_value), 1)
  call display_img(rgb_to_gray(img), maximum_value)
end program preview


! These various sort routines are provided as
! examples, rather than being fully optimised
! for the best possible performance. MJR 9/2019
!
! So far the collection is:
!
!  bubble_sort           (order N**2)
!  selection_sort        (order N**2)
!  inline_selection_sort (order N**2)
!  insertion_sort        (order N**2)
!  binary_insertion_sort (order N**2)
!  pair_insertion_sort   (order N**2)
!  double_insertion_sort (order N**2)
!  shell_sort            (order N**(4/3)) (possibly)
!  merge_sort            (order N log N)
!  alt_merge_sort        (order N log N)
!  heap_sort             (order N log N)
!  heap_sort_nr          (order N log N)
!  smoothsort            (order N log N)
!  quicksort             (order N log N) (usually)
!  quicksort_nr          (order N log N) (usually)
!  dpquicksort           (order N log N) (usually)

! 14/10/19 and 18/10/19 indexing errors in heap sorts corrected

! 4/4/20 smooth sort and non-recursive quicksort added, and some
!        minor code tidying

module sorts
  implicit none
  integer, parameter :: prec=kind(1d0), i64=selected_int_kind(15)

  ! array L used by smoothsort

  integer, parameter :: L(0:43) = (/ 1, 1, 3, 5, 9, 15, 25, 41, 67, 109, &
       177, 287, 465, 753, 1219, 1973, 3193, 5167, 8361, &
       13529, 21891, 35421, 57313, 92735, 150049, &
       242785, 392835, 635621, 1028457, 1664079, 2692537, &
       4356617, 7049155, 11405773, 18454929, 29860703, &
       48315633, 78176337, 126491971, 204668309, 331160281, &
       535828591, 866988873, 1402817465 /)

  private :: binary_search, merge_arrays, heapify, heapify_nr, &
       smooth_heapify, smooth_extract, sift_in, interheap_sift, L

contains

  recursive subroutine quicksort(array)
    real(prec), intent(inout)::array(:)
    real(prec) :: temp,pivot
    integer :: i,j,last,left,right

    last=size(array)

    if (last.lt.50) then ! use insertion sort on small arrays
       do i=2,last
          temp=array(i)
          do j=i-1,1,-1
             if (array(j).le.temp) exit
             array(j+1)=array(j)
          enddo
          array(j+1)=temp
       enddo
       return
    endif
    ! find median of three pivot
    ! and place sentinels at first and last elements
    temp=array(last/2)
    array(last/2)=array(2)
    if (temp.gt.array(last)) then
       array(2)=array(last)
       array(last)=temp
    else
       array(2)=temp
    endif
    if (array(1).gt.array(last)) then
       temp=array(1)
       array(1)=array(last)
       array(last)=temp
    endif
    if (array(1).gt.array(2)) then
       temp=array(1)
       array(1)=array(2)
       array(2)=temp
    endif
    pivot=array(2)

    left=3
    right=last-1
    do
       do while(array(left).lt.pivot)
          left=left+1
       enddo
       do while(array(right).gt.pivot)
          right=right-1
       enddo
       if (left.ge.right) exit
       temp=array(left)
       array(left)=array(right)
       array(right)=temp
       left=left+1
       right=right-1
    enddo
    if (left.eq.right) left=left+1
    call quicksort(array(1:left-1))
    call quicksort(array(left:))

  end subroutine quicksort

  ! This version maintains its own stack, to avoid needing to call
  ! itself recursively. By always pushing the larger "half" to the
  ! stack, and moving directly to calculate the smaller "half",
  ! it can guarantee that the stack needs no more than log_2(N)
  ! entries
  subroutine quicksort_nr(array)
    real(prec), intent(inout)::array(:)
    real(prec) :: temp,pivot
    integer :: i,j,left,right,low,high
    ! If your compiler lacks storage_size(), replace
    ! storage_size(i) by 64
    integer :: stack(2,storage_size(i)),stack_ptr

    low=1
    high=size(array)
    stack_ptr=1

    do

       if (high-low.lt.50) then ! use insertion sort on small arrays
          do i=low+1,high
             temp=array(i)
             do j=i-1,low,-1
                if (array(j).le.temp) exit
                array(j+1)=array(j)
             enddo
             array(j+1)=temp
          enddo
          ! now pop from stack
          if (stack_ptr.eq.1) return
          stack_ptr=stack_ptr-1
          low=stack(1,stack_ptr)
          high=stack(2,stack_ptr)
          cycle
       endif

       ! find median of three pivot
       ! and place sentinels at first and last elements
       temp=array((low+high)/2)
       array((low+high)/2)=array(low+1)
       if (temp.gt.array(high)) then
          array(low+1)=array(high)
          array(high)=temp
       else
          array(low+1)=temp
       endif
       if (array(low).gt.array(high)) then
          temp=array(low)
          array(low)=array(high)
          array(high)=temp
       endif
       if (array(low).gt.array(low+1)) then
          temp=array(low)
          array(low)=array(low+1)
          array(low+1)=temp
       endif
       pivot=array(low+1)

       left=low+2
       right=high-1
       do
          do while(array(left).lt.pivot)
             left=left+1
          enddo
          do while(array(right).gt.pivot)
             right=right-1
          enddo
          if (left.ge.right) exit
          temp=array(left)
          array(left)=array(right)
          array(right)=temp
          left=left+1
          right=right-1
       enddo
       if (left.eq.right) left=left+1
       !          call quicksort(array(1:left-1))
       !          call quicksort(array(left:))
       if (left.lt.(low+high)/2) then
          stack(1,stack_ptr)=left
          stack(2,stack_ptr)=high
          stack_ptr=stack_ptr+1
          high=left-1
       else
          stack(1,stack_ptr)=low
          stack(2,stack_ptr)=left-1
          stack_ptr=stack_ptr+1
          low=left
       endif

    enddo
  end subroutine quicksort_nr

  ! dual pivot quicksort
  recursive subroutine dpquicksort(array)
    real(prec), intent(inout)::array(:)
    real(prec) :: temp,p1,p2
    integer :: i,j,last,l,k,g

    last=size(array)

    if (last.lt.40) then ! use insertion sort on small arrays
       do i=2,last
          temp=array(i)
          do j=i-1,1,-1
             if (array(j).le.temp) exit
             array(j+1)=array(j)
          enddo
          array(j+1)=temp
       enddo
       return
    endif
    p1=array(last/3)
    p2=array(2*last/3)
    if (p2.lt.p1) then
       temp=p1
       p1=p2
       p2=temp
    endif
    array(last/3)=array(1)
    array(1)=p1
    array(2*last/3)=array(last)
    array(last)=p2

    g=last
    l=2
    do while (array(l).lt.p1)
       l=l+1
    enddo
    k=l

    do while(k.lt.g)
       temp=array(k)
       if (temp.lt.p1) then
          array(k)=array(l)
          array(l)=temp
          l=l+1
       else if (temp.gt.p2) then
          do while(array(g-1).gt.p2)
             g=g-1
          enddo
          if (k.ge.g) exit
          g=g-1
          if (array(g).lt.p1) then
             array(k)=array(l)
             array(l)=array(g)
             array(g)=temp
             l=l+1
          else
             array(k)=array(g)
             array(g)=temp
          endif
       endif
       k=k+1
    enddo
    if (l.gt.2) then
       array(1)=array(l-1)
       array(l-1)=p1
       call dpquicksort(array(1:l-2))
    endif
    call dpquicksort(array(l:g-1))
    if (g.lt.last) then
       array(last)=array(g)
       array(g)=p2
       call dpquicksort(array(g+1:last))
    endif

  end subroutine dpquicksort

  function binary_search(array, x, start, end)
    integer binary_search
    integer, intent(in) :: start,end
    real(prec), intent(in) :: x,array(:)
    integer :: a,b,mid

    a=start
    b=end

    do
       if (a.eq.b) then
          if (array(a).gt.x) then
             binary_search=a
             return
          else
             binary_search=a+1
             return
          endif
       endif
       if (a.gt.b) then
          binary_search=a
          return
       end if

       mid=(a+b)/2
       if (array(mid).lt.x) then
          a=mid+1
       else if (array(mid).gt.x) then
          b=mid-1
       else
          binary_search=mid
          return
       endif

    end do
  end function binary_search

  subroutine binary_insertion_sort(array)
    real(prec), intent(inout) :: array(:)
    integer :: i,j,pos
    real(prec) :: x

    do i=2,size(array)
       x=array(i)
       pos=binary_search(array,x,1,i-1)
       do j=i,pos+1,-1
          array(j)=array(j-1)
       enddo
       array(pos)=x
    enddo
  end subroutine binary_insertion_sort

  subroutine insertion_sort(array)
    real(prec), intent(inout) :: array(:)
    integer :: i,j
    real(prec) :: temp

    do i=2,size(array)
       temp=array(i)
       do j=i-1,1,-1
          if (array(j).le.temp) exit
          array(j+1)=array(j)
       enddo
       array(j+1)=temp
    enddo
  end subroutine insertion_sort

  subroutine double_insertion_sort(array)
    real(prec), intent(inout) :: array(:)
    integer :: i,j,left,right,last
    real(prec) :: temp,p,next

    last=size(array)

    p=0.5*(array(1)+array(last))
    if (array(1).gt.array(last)) then
       temp=array(last)
       array(last)=array(1)
       array(1)=temp
    endif

    left=1
    right=last
    temp=array(2)

    do i=2,last-1
       if (temp.lt.p) then
          do j=left,1,-1
             if (array(j).le.temp) exit
             array(j+1)=array(j)
          enddo
          array(j+1)=temp
          temp=array(left+2)
          left=left+1
       else
          next=array(right-1)
          do j=right,last
             if (array(j).ge.temp) exit
             array(j-1)=array(j)
          enddo
          array(j-1)=temp
          temp=next
          right=right-1
       endif
    enddo

  end subroutine double_insertion_sort

  subroutine pair_insertion_sort(array)
    real(prec), intent(inout) :: array(:)
    integer :: i,j,last
    real(prec) :: t1,t2

    last=size(array)
    do i=2,last-1,2
       t1=min(array(i),array(i+1))
       t2=max(array(i),array(i+1))
       j=i-1
       do while((j.ge.1).and.(array(j).gt.t2))
          array(j+2)=array(j)
          j=j-1
       enddo
       array(j+2)=t2
       do while((j.ge.1).and.(array(j).gt.t1))
          array(j+1)=array(j)
          j=j-1
       enddo
       array(j+1)=t1
    end do

    if(mod(last,2).eq.0)then
       t1=array(last)
       do j=last-1,1,-1
          if (array(j).le.t1) exit
          array(j+1)=array(j)
       end do
       array(j+1)=t1
    endif

  end subroutine pair_insertion_sort

  subroutine merge_arrays(a,b,out)
    ! routine used by merge_sort()
    real(prec), intent(in) :: a(:),b(:)
    real(prec), intent(out) :: out(:)
    integer :: ai,bi,oi,i

    ai=1
    bi=1
    oi=1

    do
       if (ai.gt.size(a)) then
          do i=bi,size(b)
             out(oi)=b(i)
             oi=oi+1
          enddo
          return
       endif
       if (bi.gt.size(b)) then
          do i=ai,size(a)
             out(oi)=a(i)
             oi=oi+1
          enddo
          return
       endif

       if (a(ai).lt.b(bi)) then
          out(oi)=a(ai)
          ai=ai+1
       else
          out(oi)=b(bi)
          bi=bi+1
       endif
       oi=oi+1
    enddo
  end subroutine merge_arrays

  recursive subroutine merge_sort(array)
    ! With a little skill, the extra copy of "array=temp"
    ! can be avoided
    real(prec), intent(inout) :: array(:)
    real(prec), allocatable :: temp(:)
    integer :: last

    last=size(array)

    if (last.lt.40) then
       call insertion_sort(array)
       return
    endif

    call merge_sort(array(1:last/2))
    call merge_sort(array(last/2+1:last))
    allocate(temp(last))
    call merge_arrays(array(1:last/2),array(last/2+1:last),temp)
    array=temp
    deallocate(temp)
  end subroutine merge_sort

  recursive subroutine alt_merge_sort(array)
    ! Alternate merges between array and temp
    ! to avoid copy
    real(prec), intent(inout) :: array(:)
    real(prec), allocatable :: temp(:)
    integer :: last

    last=size(array)

    if (last.lt.40) then
       call insertion_sort(array)
       return
    endif

    call alt_merge_sort(array(1:last/4))
    call alt_merge_sort(array(last/4+1:last/2))
    call alt_merge_sort(array(last/2+1:last/2+last/4))
    call alt_merge_sort(array(last/2+last/4+1:last))

    allocate(temp(last))
    call merge_arrays(array(1:last/4),array(last/4+1:last/2),temp(1:last/2))
    call merge_arrays(array(last/2+1:last/2+last/4),  &
         array(last/2+last/4+1:last),temp(last/2+1:last))
    call merge_arrays(temp(1:last/2),temp(last/2+1:last),array)
    deallocate(temp)
  end subroutine alt_merge_sort

  subroutine selection_sort(array)
    ! This version uses Fortran's minloc intrinsic
    real(prec), intent(inout) :: array(:)
    real(prec) :: temp
    integer :: i,j

    do i=1,size(array)-1
       j=minloc(array(i:),1)+i-1
       temp=array(i)
       array(i)=array(j)
       array(j)=temp
    enddo

  end subroutine selection_sort

  subroutine inline_selection_sort(array)
    ! This version does not use Fortran's minloc intrinsic
    real(prec), intent(inout) :: array(:)
    real(prec) :: temp
    integer :: i,j,k

    do i=1,size(array)-1
       temp=array(i)
       j=i
       do k=i+1,size(array)
          if (array(k).lt.temp) then
             temp=array(k)
             j=k
          endif
       enddo
       array(j)=array(i)
       array(i)=temp
    enddo

  end subroutine inline_selection_sort

  subroutine shell_sort(array)
    ! There are many choices of intervals
    ! The sequence (3**k-1)/2 used below is given by Knuth
    ! The sort relies on the insertion sort of nearly sorted
    ! data being fast (i.e. not order N**2)
    real(prec), intent(inout) :: array(:)
    integer :: i,interval,last

    interval=1
    last=size(array)
    do while(interval<last/3)
       interval=3*interval+1
    enddo

    do while(interval>0)
       do i=1,interval
          ! The following syntax passes a subarray with elements
          ! array(i),array(i+interval),array(i+2*interval),...
          call insertion_sort(array(i::interval))
       enddo
       interval=(interval-1)/3
    enddo

  end subroutine shell_sort

  subroutine bubble_sort(array)

    real(prec), intent(inout) :: array(:)
    real(prec) :: temp
    integer :: i,j,last

    last=size(array)
    do i=last-1,1,-1
       do j=1,i
          if (array(j+1).lt.array(j)) then
             temp=array(j+1)
             array(j+1)=array(j)
             array(j)=temp
          endif
       enddo
    enddo

  end subroutine bubble_sort

  subroutine heap_sort(array)
    real(prec), intent(inout) :: array(:)
    real(prec) :: temp
    integer :: i,last

    last=size(array)

    ! Build heap
    do i=last/2,1,-1
       call heapify(array,i)
    enddo

    ! Unpick heap
    do i=last,2,-1
       temp=array(1)
       array(1)=array(i)
       array(i)=temp
       call heapify(array(1:i-1),1)
    end do

  end subroutine heap_sort

  recursive subroutine heapify(array,root)
    real(prec), intent(inout) :: array(:)
    real(prec) :: temp
    integer :: left,right,root,last,largest

    last=size(array)
    left=2*root
    right=left+1
    largest=root

    if (left.le.last) then
       if(array(left).gt.array(largest)) largest=left
    endif

    if (right.le.last) then
       if(array(right).gt.array(largest)) largest=right
    endif

    if (largest.ne.root) then
       temp=array(root)
       array(root)=array(largest)
       array(largest)=temp
       call heapify(array,largest)
    end if

  end subroutine heapify

  subroutine heap_sort_nr(array)
    ! The same but with a non-recursive heapify
    real(prec), intent(inout) :: array(:)
    real(prec) :: temp
    integer :: i,last

    last=size(array)

    ! Build heap
    do i=last/2,1,-1
       call heapify_nr(array,i)
    enddo

    ! Unpick heap
    do i=last,2,-1
       temp=array(1)
       array(1)=array(i)
       array(i)=temp
       call heapify_nr(array(1:i-1),1)
    end do

  end subroutine heap_sort_nr

  subroutine heapify_nr(array,i)
    ! A non-recursive heapify
    real(prec), intent(inout) :: array(:)
    real(prec) :: root_val
    integer :: i,left,right,root,last,largest

    last=size(array)
    root=i
    left=2*root
    root_val=array(root)
    largest=root

    do while(left.le.last)
       right=left+1

       if (left.le.last) then
          if(array(left).gt.array(largest)) largest=left
       endif

       if (right.le.last) then
          if(array(right).gt.array(largest)) largest=right
       endif

       if (largest.eq.root) exit

       array(root)=array(largest)
       array(largest)=root_val
       root=largest
       left=2*root
    enddo

    !    array(largest)=root_val

  end subroutine heapify_nr

  ! Smoothsort is introduced by Edsger Dijkstra
  ! https://doi.org/10.1016/0167-6423(82)90016-8
  !
  ! This Fortran version owes much to https://www.keithschwarz.com/smoothsort/
  ! and the C version given by Martin Knoblauch Revuelta at
  ! http://code.google.com/archive/p/combsortcs2p-and-other-sorting-algorithms

  subroutine smoothsort(array)
    real(prec), intent(inout) :: array(:)
    integer(i64) :: mask
    integer :: offset

    if (size(array).le.1) return

    call smooth_heapify(array,mask,offset)

    call smooth_extract(array,mask,offset)
  end subroutine smoothsort

  subroutine smooth_heapify(array,mask,offset)
    real(prec), intent(inout) :: array(0:)
    integer(i64), intent(out) :: mask
    integer, intent(out) :: offset
    integer :: i,last
    logical :: wbf

    mask=1
    offset=1
    last=size(array)

    do i=1,last-1
       if (iand(mask,2_i64).eq.2) then
          mask=ior(ishft(mask,-2),1_i64)
          offset=offset+2
       else if (offset.eq.1) then
          mask=ior(ishft(mask,1),1_i64)
          offset=0
       else
          mask=ior(ishft(mask,offset-1),1_i64)
          offset=1
       endif
       wbf=(((iand(mask,2_i64).eq.2).and.(i+1.lt.last)).or. &
            ((offset.gt.0).and.(1+i+L(offset-1).lt.last)))
       if (wbf) then
          call sift_in(array,i,offset)
       else
          call interheap_sift(array,i,mask,offset)
       endif
    enddo

  end subroutine smooth_heapify
  subroutine smooth_extract(array,mask,offset)
    real(prec), intent(inout) :: array(0:)
    integer :: i,j,last,ch(2)
    integer(i64),value :: mask
    integer, value :: offset

    last=size(array)

    do i=last-1,2,-1
       if (offset.lt.2) then
          do
             mask=ishft(mask,-1)
             offset=offset+1
             if (iand(mask,1_i64).eq.1) exit
          enddo
       else
          ch(2)=i-1
          ch(1)=ch(2)-L(offset-2)
          mask=iand(mask,not(1_i64))
          do j=1,2
             mask=ior(ishft(mask,1),1_i64)
             offset=offset-1
             call interheap_sift(array,ch(j),mask,offset)
          end do
       end if
    end do

  end subroutine smooth_extract

  subroutine sift_in(array,root,sz)
    real(prec), intent(inout) :: array(0:)
    real(prec) :: tmp
    integer :: left,right,next
    integer,value :: root,sz

    if (sz.lt.2) return

    tmp=array(root)

    do
       right=root-1
       left=right-L(sz-2)

       if (array(right).lt.array(left)) then
          next=left
          sz=sz-1
       else
          next=right
          sz=sz-2
       end if

       if (array(next).le.tmp) exit

       array(root)=array(next)

       root=next
       if (sz.le.1) exit
    end do

    array(root)=tmp

  end subroutine sift_in

  subroutine interheap_sift(array,root,mask,offset)
    real(prec), intent(inout) :: array(0:)
    real(prec) :: tmp,mx
    integer :: left,right,next
    integer(i64),value :: mask
    integer, value :: root,offset

    tmp=array(root)

    do while (mask.ne.1)
       mx=tmp

       if (offset.gt.1) then
          right=root-1
          left=right-L(offset-2)
          mx=max(mx,array(left),array(right))
       end if

       next=root-L(offset)

       if (array(next).le.mx) exit

       array(root)=array(next)
       root=next

       do
          mask=ishft(mask,-1)
          offset=offset+1
          if (iand(mask,1_i64).eq.1) exit
       end do
    end do

    array(root)=tmp
    call sift_in(array,root,offset)
  end subroutine interheap_sift

end module sorts


*DECK INITDS
      FUNCTION INITDS (OS, NOS, ETA)
C***BEGIN PROLOGUE  INITDS
C***PURPOSE  Determine the number of terms needed in an orthogonal
C            polynomial series so that it meets a specified accuracy.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C3A2
C***TYPE      DOUBLE PRECISION (INITS-S, INITDS-D)
C***KEYWORDS  CHEBYSHEV, FNLIB, INITIALIZE, ORTHOGONAL POLYNOMIAL,
C             ORTHOGONAL SERIES, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C  Initialize the orthogonal series, represented by the array OS, so
C  that INITDS is the number of terms needed to insure the error is no
C  larger than ETA.  Ordinarily, ETA will be chosen to be one-tenth
C  machine precision.
C
C             Input Arguments --
C   OS     double precision array of NOS coefficients in an orthogonal
C          series.
C   NOS    number of coefficients in OS.
C   ETA    single precision scalar containing requested accuracy of
C          series.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891115  Modified error message.  (WRB)
C   891115  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  INITDS
      DOUBLE PRECISION OS(*)
C***FIRST EXECUTABLE STATEMENT  INITDS
      IF (NOS .LT. 1) CALL XERMSG ('SLATEC', 'INITDS',
     +   'Number of coefficients is less than 1', 2, 1)
C
      ERR = 0.
      DO 10 II = 1,NOS
        I = NOS + 1 - II
        ERR = ERR + ABS(REAL(OS(I)))
        IF (ERR.GT.ETA) GO TO 20
   10 CONTINUE
C
   20 IF (I .EQ. NOS) CALL XERMSG ('SLATEC', 'INITDS',
     +   'Chebyshev series too short for specified accuracy', 1, 1)
      INITDS = I
C
      RETURN
      END


! { dg-do run }
! Tests the fix for PR25072, in which mask expressions
! that start with an internal or intrinsic function
! reference would give a syntax error.
!
! The fix for PR28119 is tested as well; here, the forall
! statement could not be followed by another statement on
! the same line.
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
!
module foo
  integer, parameter :: n = 4
contains
  pure logical function foot (i)
    integer, intent(in) :: i
    foot = (i == 2) .or. (i == 3)
  end function foot
end module foo

  use foo
  integer :: i, a(n)
  logical :: s(n)
  s = (/(foot (i), i=1, n)/)

! Check that non-mask case is still OK and the fix for PR28119
  a = 0
  forall (i=1:n) a(i) = i ; if (any (a .ne. (/1,2,3,4/))) call abort ()

! Now a mask using a function with an explicit interface
! via use association.
  a = 0
  forall (i=1:n, foot (i)) a(i) = i
  if (any (a .ne. (/0,2,3,0/))) call abort ()

! Now an array variable mask
  a = 0
  forall (i=1:n, .not. s(i)) a(i) = i
  if (any (a .ne. (/1,0,0,4/))) call abort ()

! This was the PR - an internal function mask
  a = 0
  forall (i=1:n, t (i)) a(i) = i
  if (any (a .ne. (/0,2,0,4/))) call abort ()

! Check that an expression is OK - this also gave a syntax
! error
  a = 0
  forall (i=1:n, mod (i, 2) == 0) a(i) = i
  if (any (a .ne. (/0,2,0,4/))) call abort ()

! And that an expression that used to work is OK
  a = 0
  forall (i=1:n, s (i) .or. t(i)) a(i) = w (i)
  if (any (a .ne. (/0,3,2,1/))) call abort ()

contains
  pure logical function t(i)
    integer, intent(in) :: i
    t = (mod (i, 2) == 0)
  end function t
  pure integer function w(i)
    integer, intent(in) :: i
    w = 5 - i
  end function w
end


! sample compile command to generate *.o object file:
!      gfortran -fopenmp -c Fig_10.4_loopCollapse.f90

   subroutine Apply(N, M, A, MFUNC)
      use omp_lib
      implicit none

      integer :: N, M
      real :: A(N,M), res
      integer :: i, j

      interface
         function MFUNC (i,j,x) result (res)
            integer, intent(in) :: i, j
            real :: x, res
         end function MFUNC
      end interface

      ! apply a function MFUNC to each element of an N by M array

      !$omp parallel do num_threads(4) collapse(2) if(N*M>100)
          do i = 1, N
             do j = 1, M
                res = MFUNC(i, j, A(i,j))
             enddo
          enddo
       !$omp end parallel do
   end subroutine


	FUNCTION FWHM_IDS(X)

c	Returns FWHM at wavelength X(A) according to Table 8 of
c	Worthey and Ottaviani (1997, ApJS, 111, 377)

c	Data points from Table 8
	parameter (nw=5)
	real w(nw),f(nw),linear
	data w/4000.,4400.,4900.,5400.,6000./
	data f/ 11.5,  9.2,  8.4,  8.4,  9.8/

c	Interpolate at wavelength X
	icall=0
	if (x.le.w(1)) then
		fwhm_ids=f(1)
	elseif (x.ge.w(nw)) then
		fwhm_ids=f(5)
	else
		icall=0
		fwhm_ids=linear(x,w,f,nw,icall)
	endif
	return
	end


 module OCFD_precision
 implicit none
 include "mpif.h"
      integer,parameter::OCFD_REAL_KIND=8,  OCFD_DATA_TYPE=MPI_DOUBLE_PRECISION   ! double precison computing
 end module OCFD_precision

 !------parameters used in OpenCFD---------------------------------------
 module OCFD_constants
   Use OCFD_precision
   implicit none
!---------The common (global) variables in original opencfd.h ----------------------
!--------MPI-------------------
    integer,save:: my_id,npx,npy,npz,npx0,npy0,npz0, ID_XP1,ID_XM1,ID_YP1,ID_YM1,ID_ZP1,ID_ZM1,       &
                  MSG_BLOCK_SIZE,BLOCK_COMPACT_Z,BLOCK_COMPACT_Y, MPI_COMM_X,MPI_COMM_Y,MPI_COMM_Z,  &
                  MPI_COMM_XY,MPI_COMM_XZ,MPI_COMM_YZ, &
                  TYPE_LAPX1,TYPE_LAPY1,TYPE_LAPZ1,TYPE_LAPX2,TYPE_LAPY2,TYPE_LAPZ2,np_size
   integer,save::  i_offset(0:1024),j_offset(0:1024),k_offset(0:1024),i_nn(0:1024),j_nn(0:1024),k_nn(0:1024)
!--------------------------------
!-------------------------------------------
 end module OCFD_constants

 !--------------------------------------------------------------------------------------------------------
 !--------------------------------------------------------------------------------------------------------
  module  OCFD_flow_parameters
  use OCFD_constants
  implicit none
 !-------- integer parameters for MPI -----------------------------

!------------------
! integer parameters for goemtry
   integer,save::    nx_global,ny_global,nz_global,nx,ny,nz,LAP
! parameters related with   Flow
   integer,save::    IFLAG_G,NUM_TIME_Advance, &
        Iflag_grid(3),Iperiodic(3),Kstep_save,Ksave_style,Kread_style,    &
        Kstep_show,Nvars,Istep,KRK
   real(kind=OCFD_REAL_KIND),save:: dt,end_time,tt

!  Coordinate parameters
   real(kind=OCFD_REAL_KIND),save:: SLx,SLy,SLz,hx,hy,hz
   real(kind=OCFD_REAL_KIND),allocatable,save,dimension(:) :: xx,yy,zz,xx0,yy0,zz0,sx,sy,sz,sx0,sy0,sz0

!--------------------------------------------------
  end module  OCFD_flow_parameters

 ! initial of data , OpenCFD Ver 1.8  by Li Xinliang , Institute of Mechanics, CAS
  subroutine init(u,u1)
  Use OCFD_flow_parameters
  implicit none
  integer i,j,k,i1,k1,ierr
  real(kind=OCFD_REAL_KIND),dimension(1-LAP:nx+LAP,1-LAP:ny+LAP,1-LAP:nz+LAP):: u
  real(kind=OCFD_REAL_KIND),dimension(nx,ny,nz):: u1
  real(kind=OCFD_REAL_KIND) nn1
  integer x_lxj,y_lxj,z_lxj
  integer incx,incy,incz
  nn1=nx_global*ny_global*nz_global*1.0d0
   u=0.0001d0
!   u1=0.0001d0
incx=mod(nx_global,npx0)
incy=mod(ny_global,npy0)
incz=mod(nz_global,npz0)
do k=1,nz

    if(npz<incz)then
       z_lxj=npz*nz+k
    else
       z_lxj=npz*nz+k+incz
    endif
   do j=1,ny

       if(npy<incy)then
           y_lxj=npy*ny+j
       else
           y_lxj=npy*ny+j+incy
       endif

        do i=1,nx
         if(npx<incx)then
             x_lxj=npx*nx+i
         else
             x_lxj=npx*nx+i+incx
         endif

           u(i,j,k)=x_lxj*y_lxj*z_lxj/nn1-0.0001d0
           u1(i,j,k)=u(i,j,k)
       enddo
    enddo
enddo

   allocate ( xx(1-LAP:nx+LAP),yy(1-LAP:ny+LAP),zz(1-LAP:nz+LAP),  &
       xx0(nx_global),yy0(ny_global),zz0(nz_global),        &
       sx(1-LAP:nx+LAP),sy(1-LAP:ny+LAP),sz(1-LAP:nz+LAP),  &
       sx0(nx_global),sy0(ny_global),sz0(nz_global) )
!------define hx, hy, hz -----------------------
         if(Iperiodic(1).eq.0) then
          hx=SLx/(nx_global-1.d0)
         else
          hx=SLX/nx_global
         endif

       do k=1-LAP,nx+LAP
        k1=i_offset(npx)+k-1
        if(k1.ge.1 .and. k1 .le. nx_global) then
          if(Iflag_grid(1).eq.1) then
           xx(k)=xx0(k1)
           sx(k)=sx0(k1)
              else
           xx(k)=(k1-1.d0)*hx
           sx(k)=1.d0
            endif
        endif
       enddo
!--------------------------------------
         if(Iperiodic(2).eq.0) then
           hy=SLy/(ny_global-1.d0)
         else
           hy=SLy/ny_global
         endif

       do k=1-LAP,ny+LAP
       k1=j_offset(npy)+k-1
       if(k1.ge.1 .and. k1 .le. ny_global) then
        if(Iflag_grid(2).eq.1) then
          yy(k)=yy0(k1)
          sy(k)=sy0(k1)
         else
           yy(k)=(k1-1.d0)*hy
          sy(k)=1.d0
         endif
       endif
       enddo
!--------------------------------------
        if(Iperiodic(3).eq.0) then
           hz=SLz/(nz_global-1.d0)
        else
           hz=SLz/nz_global
        endif

       do k=1-LAP,nz+LAP
       k1=k_offset(npz)+k-1
       if(k1.ge.1 .and. k1 .le. nz_global) then
        if(Iflag_grid(3).eq.1) then
           zz(k)=zz0(k1)
          sz(k)=sz0(k1)
         else
          zz(k)=(k1-1.d0)*hz
          sz(k)=1.d0
         endif
       endif
       enddo

 end


program upacs_convention
  implicit none
  !$xev test
  type block
     integer in,jn,kn
     double precision,pointer::dq(:,:,:,:)
     double precision,pointer::inv_vol(:,:,:)
  end type block
  type face
     double precision,pointer:: flux(:)
  end type face
  type(block) blk
  type(face) cface(1024,1024,1024)
  integer n,i,j,k,im,jm,km
  integer:: bdtv_nFlowVar=1024
  integer,dimension(3) :: idelta
  blk%in = 1024
  blk%jn = 1024
  blk%kn = 1024
  allocate(blk%dq(1024,1024,1024,1024))
  allocate(blk%inv_vol(1024,1024,1024))
  do k=1,1024
     do j=1,1024
        do i=1,1024
           allocate(cface(i,j,k)%flux(1024))
           do n=1,1024
              cface(i,j,k)%flux(n) = n
              blk%dq(i,j,k,n) = n
              blk%inv_vol(i,j,k) = i*j*k
           end do
        end do
     end do
  end do
  !$xev end test

  ! kernel
  do n=1,bdtv_nFlowVar
     do k=1,blk%kn
        do j=1,blk%jn
           do i=1,blk%in
              im=i-idelta(1)
              jm=j-idelta(2)
              km=k-idelta(3)
              blk%dq(i,j,k,n) = blk%dq(i,j,k,n) - blk%inv_vol(i,j,k) &
                   * ( cface(i,j,k)%flux(n) - cface(im,jm,km)%flux(n) )
           end do
        end do
     end do
  end do
end program upacs_convention


c
c
c
c     =================================================
      function fss(s)
c     =================================================
      implicit double precision (a-h,o-z)
      common/fsscorn/ xc0,yc0,xc1,yc1
c
c     # compute fdisc at distance s between corners (xc0,yc0) and (xc1,yc1)
c
      x = xc0 + s*(xc1-xc0)
      y = yc0 + s*(yc1-yc0)
      fss = fdisc(x,y)
      return
      end


! 4. Write a function that returns the elements on odd positions in a list.

    program Exercises
        implicit none
        integer :: list(5)
        integer :: odd(3)

        list = (/6, 2, 1, 10, 5/)
        odd = getOddPositionElements(list)

        contains
        function getOddPositionElements(list) result(r)
            integer, dimension(1:), intent(in) :: list
            integer, dimension(1:(size(list)+1)/2) :: r
            integer :: i
            integer :: j

            j=1
            do i=1,size(list)
                if (modulo(i, 2) == 1) then ! Odd position
                    r(j) = list(i)
                    j = j + 1
                end if
            end do

        end function getOddPositionElements

    end program Exercises