!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   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.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/main/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!>  \brief This module contains tests of the module [Integration_mod](@ref integration_mod).
!>  \author Amir Shahmoradi

module Test_Integration_mod

    use Integration_mod
    !use QuadPackDouble_mod, only: dqagi
    use Constants_mod, only: IK, RK
    use Err_mod, only: Err_type
    use Test_mod, only: Test_type
    implicit none

    private
    public :: test_Integration

    type(Test_type) :: Test

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    subroutine test_Integration()
        implicit none
        Test = Test_type(moduleName=MODULE_NAME)
        call Test%run(test_doQuadRombOpen_1, "test_doQuadRombOpen_1")
        call Test%run(test_doQuadRombOpen_2, "test_doQuadRombOpen_2")
        call Test%run(test_doQuadRombOpen_3, "test_doQuadRombOpen_3")
        call Test%run(test_doQuadRombOpen_4, "test_doQuadRombOpen_4")
        call Test%run(test_doQuadRombClosed_1, "test_doQuadRombClosed_1")
        call Test%finalize()
    end subroutine test_Integration

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! integrate the Gaussian PDF via the midexp routine on the open interval \f$[0, +\infty)\f$.
    function test_doQuadRombOpen_1() result(assertion)

        use Constants_mod, only: RK, IK, POSINF_RK
        use Integration_mod

        implicit none

        logical                 :: assertion
        real(RK)                :: integral, relativeError, difference
        real(RK), parameter     :: integral_ref = 0.5_RK
        real(RK), parameter     :: tolerance = 1.e-10_RK
        integer(IK)             :: numFuncEval, ierr

        call doQuadRombOpen ( getFunc = getTestFuncOpenInterval_1 &
                            , integrate = midexp &
                            , lowerLim = 0._RK &
                            , upperLim = POSINF_RK & ! do not set this to huge() as GNU Fortran in debug mode crashes
                            , maxRelativeError = 0.1*tolerance &
                            , nRefinement = 10_IK &
                            , integral = integral &
                            , relativeError = relativeError &
                            , numFuncEval = numFuncEval &
                            , ierr = ierr &
                            )

        assertion = ierr == 0_IK

        if (Test%isVerboseMode .and. .not. assertion) then
            ! LCOV_EXCL_START
            if (Test%isVerboseMode .and. .not. assertion) then
                write(Test%outputUnit,"(*(g0))") "ierr = ", ierr, " /= 0"
            end if
            return
            ! LCOV_EXCL_STOP
        end if

        difference = abs(integral - integral_ref) / abs(integral_ref)
        assertion = difference < tolerance
        assertion = assertion .and. relativeError <= tolerance

        ! LCOV_EXCL_START
        if (Test%isVerboseMode .and. .not. assertion) then
            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "integral_ref  = ", integral_ref
            write(Test%outputUnit,"(*(g0))") "integral      = ", integral
            write(Test%outputUnit,"(*(g0))") "difference    = ", difference
            write(Test%outputUnit,"(*(g0))") "relativeError = ", relativeError
            write(Test%outputUnit,"(*(g0))")
        end if
        ! LCOV_EXCL_STOP

    end function test_doQuadRombOpen_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_doQuadRombOpen_2() result(assertion)

        use Constants_mod, only: RK, IK, POSINF_RK
        use Integration_mod

        implicit none

        logical                 :: assertion
        real(RK)                :: relativeError, difference
        real(RK)                :: integral
        real(RK), parameter     :: integral_ref = 0.078649603525143_RK
        real(RK), parameter     :: tolerance = 1.e-10_RK
        integer(IK)             :: numFuncEval, ierr

        call doQuadRombOpen ( getFunc = getTestFuncOpenInterval_1 &
                            , integrate = midinf &
                            , lowerLim = 1._RK &
                            , upperLim = POSINF_RK & ! do not set this to huge() as GNU Fortran in debug mode crashes
                            , maxRelativeError = 0.1*tolerance &
                            , nRefinement = 10_IK &
                            , integral = integral &
                            , relativeError = relativeError &
                            , numFuncEval = numFuncEval &
                            , ierr = ierr &
                            )

        assertion = ierr == 0_IK

        if (Test%isVerboseMode .and. .not. assertion) then
            ! LCOV_EXCL_START
            if (Test%isVerboseMode .and. .not. assertion) then
                write(Test%outputUnit,"(*(g0))") "ierr = ", ierr, " /= 0"
            end if
            return
            ! LCOV_EXCL_STOP
        end if

        difference = abs(integral - integral_ref) / abs(integral_ref)
        assertion = difference < tolerance
        assertion = assertion .and. relativeError <= tolerance

        if (Test%isVerboseMode .and. .not. assertion) then
        ! LCOV_EXCL_START
            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "integral_ref  = ", integral_ref
            write(Test%outputUnit,"(*(g0))") "integral      = ", integral
            write(Test%outputUnit,"(*(g0))") "difference    = ", difference
            write(Test%outputUnit,"(*(g0))") "relativeError = ", relativeError
            write(Test%outputUnit,"(*(g0))")
        end if
        ! LCOV_EXCL_STOP

    end function test_doQuadRombOpen_2

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_doQuadRombOpen_3() result(assertion)

        use Constants_mod, only: RK, IK, POSINF_RK
        use Integration_mod

        implicit none

        logical                 :: assertion
        real(RK)                :: relativeError, difference
        real(RK)                :: integral
        real(RK), parameter     :: integral_ref = 0.078649603525143_RK
        real(RK), parameter     :: tolerance = 1.e-4_RK
        integer(IK)             :: numFuncEval, ierr

        call doQuadRombOpen ( getFunc = getTestFuncOpenInterval_1 &
                            , integrate = midinf &
                            , lowerLim = POSINF_RK & ! do not set this to huge() as GNU Fortran in debug mode crashes
                            , upperLim = -1._RK &
                            , maxRelativeError = 1.e-10_RK &
                            , nRefinement = 10_IK &
                            , integral = integral &
                            , relativeError = relativeError &
                            , numFuncEval = numFuncEval &
                            , ierr = ierr &
                            )

        assertion = ierr == 0_IK
        if (Test%isVerboseMode .and. .not. assertion) then
            ! LCOV_EXCL_START
            if (Test%isVerboseMode .and. .not. assertion) then
                write(Test%outputUnit,"(*(g0))") "ierr = ", ierr, " /= 0"
            end if
            return
            ! LCOV_EXCL_STOP
        end if

        difference = abs(integral - integral_ref) / abs(integral_ref)
        assertion = difference < tolerance
        assertion = assertion .and. relativeError <= tolerance

        if (Test%isVerboseMode .and. .not. assertion) then
        ! LCOV_EXCL_START
            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "integral_ref  = ", integral_ref
            write(Test%outputUnit,"(*(g0))") "integral      = ", integral
            write(Test%outputUnit,"(*(g0))") "difference    = ", difference
            write(Test%outputUnit,"(*(g0))") "relativeError = ", relativeError
            write(Test%outputUnit,"(*(g0))")
        end if
        ! LCOV_EXCL_STOP

    end function test_doQuadRombOpen_3

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_doQuadRombOpen_4() result(assertion)

        use Constants_mod, only: RK, IK
        use Integration_mod

        implicit none

        logical                 :: assertion
        real(RK)                :: relativeError, difference
        real(RK)                :: integral
        real(RK), parameter     :: integral_ref = 1._RK
        real(RK), parameter     :: tolerance = 1.e-10_RK
        integer(IK)             :: numFuncEval, ierr

        call doQuadRombOpen ( getFunc = getTestFuncOpenInterval_1 &
                            , integrate = midpnt &
                            , lowerLim = -5._RK &
                            , upperLim = +5._RK &
                            , maxRelativeError = 1.e-10_RK &
                            , nRefinement = 10_IK &
                            , integral = integral &
                            , relativeError = relativeError &
                            , numFuncEval = numFuncEval &
                            , ierr = ierr &
                            )

        assertion = ierr == 0_IK
        if (Test%isVerboseMode .and. .not. assertion) then
            ! LCOV_EXCL_START
            if (Test%isVerboseMode .and. .not. assertion) then
                write(Test%outputUnit,"(*(g0))") "ierr = ", ierr, " /= 0"
            end if
            return
            ! LCOV_EXCL_STOP
        end if

        difference = abs(integral - integral_ref) / abs(integral_ref)
        assertion = difference < tolerance
        assertion = assertion .and. relativeError <= tolerance

        if (Test%isVerboseMode .and. .not. assertion) then
        ! LCOV_EXCL_START
            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "integral_ref  = ", integral_ref
            write(Test%outputUnit,"(*(g0))") "integral      = ", integral
            write(Test%outputUnit,"(*(g0))") "difference    = ", difference
            write(Test%outputUnit,"(*(g0))") "relativeError = ", relativeError
            write(Test%outputUnit,"(*(g0))")
        end if
        ! LCOV_EXCL_STOP

    end function test_doQuadRombOpen_4

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_doQuadRombClosed_1() result(assertion)

        use Constants_mod, only: RK, IK
        use Integration_mod

        implicit none

        logical                 :: assertion
        real(RK)                :: relativeError, difference
        real(RK)                :: integral
        real(RK), parameter     :: integral_ref = 1._RK
        real(RK), parameter     :: tolerance = 1.e-10_RK
        integer(IK)             :: numFuncEval, ierr

        call doQuadRombClosed   ( getFunc = getTestFuncOpenInterval_1 &
                                , lowerLim = -5._RK &
                                , upperLim = +5._RK &
                                , maxRelativeError = 0.1*tolerance &
                                , nRefinement = 10_IK &
                                , integral = integral &
                                , relativeError = relativeError &
                                , numFuncEval = numFuncEval &
                                , ierr = ierr &
                                )
        assertion = ierr == 0_IK
        if (Test%isVerboseMode .and. .not. assertion) then
        ! LCOV_EXCL_START
            if (Test%isVerboseMode .and. .not. assertion) then
                write(Test%outputUnit,"(*(g0))") "ierr = ", ierr, " /= 0"
            end if
            return
        ! LCOV_EXCL_STOP
        end if

        difference = abs(integral - integral_ref) / abs(integral_ref)
        assertion = difference < tolerance
        assertion = assertion .and. relativeError <= tolerance

        if (Test%isVerboseMode .and. .not. assertion) then
        ! LCOV_EXCL_START
            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "integral_ref  = ", integral_ref
            write(Test%outputUnit,"(*(g0))") "integral      = ", integral
            write(Test%outputUnit,"(*(g0))") "difference    = ", difference
            write(Test%outputUnit,"(*(g0))") "relativeError = ", relativeError
            write(Test%outputUnit,"(*(g0))")
        end if
        ! LCOV_EXCL_STOP

    end function test_doQuadRombClosed_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! The Gaussian PDF with sigma = 1/sqrt(2)
    function getTestFuncOpenInterval_1(x) result(funcVal)
        use Constants_mod, only: RK, INVSQRTPI, NEGLOGINF_RK
        implicit none
        real(RK), intent(in)    :: x
        real(RK)                :: funcVal
        real(RK), parameter     :: LOGINVSQRTPI = log(INVSQRTPI)
        funcVal = LOGINVSQRTPI - x**2
        if (funcVal<NEGLOGINF_RK) then ! This takes care of the GNU Fortran 9.1 test crash in debug mode.
            funcVal = 0._RK
        else
            funcVal = exp(funcVal)
        end if
    end function getTestFuncOpenInterval_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    ! requires `midsql`.
    ! The MATLAB test function: https://www.mathworks.com/help/matlab/ref/integral.html
    ! LCOV_EXCL_START
    function getTestFuncOpenIntervalMATLAB(x) result(funcVal)
        use Constants_mod, only: RK
        implicit none
        real(RK), intent(in)    :: x
        real(RK)                :: funcVal
        funcVal = exp(-x**2) * log(x)**2
    end function getTestFuncOpenIntervalMATLAB
    ! LCOV_EXCL_STOP

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end module Test_Integration_mod ! LCOV_EXCL_LINE


      program opkdemo7
c-----------------------------------------------------------------------
c Demonstration program for the DLSODI package.
c This is the version of 14 June 2001.
c
c This version is in double precision.
c
C this program solves a semi-discretized form of the Burgers equation,
c
c     u  = -(u*u/2)  + eta * u
c      t           x          xx
c
c for a = -1 .le. x .le. 1 = b, t .ge. 0.
c Here eta = 0.05.
c Boundary conditions: u(-1,t) = u(1,t) = 0.
c Initial profile: square wave
c     u(0,x) = 0    for 1/2 .lt. abs(x) .le. 1
c     u(0,x) = 1/2  for abs(x) = 1/2
c     u(0,x) = 1    for 0 .le. abs(x) .lt. 1/2
c
c An ODE system is generated by a simplified Galerkin treatment
c of the spatial variable x.
c
c Reference:
c R. C. Y. Chin, G. W. Hedstrom, and K. E. Karlsson,
c A Simplified Galerkin Method for Hyperbolic Equations,
c Math. Comp., vol. 33, no. 146 (April 1979), pp. 647-658.
c
c The problem is run with the DLSODI package with a 10-point mesh
c and a 100-point mesh.  In each case, it is run with two tolerances
c and for various appropriate values of the method flag mf.
c Output is on unit lout, set to 6 in a data statement below.
c-----------------------------------------------------------------------
      external res, addabd, addafl, jacbd, jacfl
      integer i, io, istate, itol, iwork, j,
     1   lout, liw, lrw, meth, miter, mf, ml, mu,
     2   n, nout, npts, nerr,
     3   nptsm1, n14, n34, n14m1, n14p1, n34m1, n34p1
      integer nm1
      double precision a, b, eta, delta,
     1   zero, fourth, half, one, hun,
     2   t, tout, tlast, tinit, errfac,
     3   atol, rtol, rwork, y, ydoti, elkup
      double precision eodsq, r4d
      dimension n(1)
      dimension y(99), ydoti(99), tout(4), atol(2), rtol(2)
      dimension rwork(2002), iwork(125)
c Pass problem parameters in the Common block test1.
      common /test1/ r4d, eodsq, nm1
c
c Set problem parameters and run parameters
      data eta/0.05d0/, a/-1.0d0/, b/1.0d0/
      data zero/0.0d0/, fourth/0.25d0/, half/.5d0/, one/1.0d0/,
     1   hun/100.0d0/
      data tinit/0.0d0/, tlast/0.4d0/
      data tout/.10d0,.20d0,.30d0,.40d0/
      data ml/1/, mu/1/, lout/6/
      data nout/4/, lrw/2002/, liw/125/
      data itol/1/, rtol/1.0d-3, 1.0d-6/, atol/1.0d-3, 1.0d-6/
c
      iwork(1) = ml
      iwork(2) = mu
      nerr = 0
c
c Loop over two values of npts.
      do 300  npts = 10, 100, 90
c
c Compute the mesh width delta and other parameters.
      delta = (b - a)/npts
      r4d = fourth/delta
      eodsq = eta/delta**2
      nptsm1 = npts - 1
      n14 = npts/4
      n34 = 3 * n14
      n14m1 = n14 - 1
      n14p1 = n14m1 + 2
      n34m1 = n34 - 1
      n34p1 = n34m1 + 2
      n(1) = nptsm1
      nm1 = n(1) - 1
c
c Set the initial profile (for output purposes only).
c
      do 10 i = 1,n14m1
   10   y(i) = zero
      y(n14) = half
      do 20 i = n14p1,n34m1
   20   y(i) = one
      y(n34) = half
      do 30 i = n34p1,nptsm1
   30   y(i) = zero
c
      if (npts .gt. 10) write (lout,1010)
      write (lout,1000)
      write (lout,1100) eta,a,b,tinit,tlast,ml,mu,n(1)
      write (lout,1200) zero, (y(i), i=1,n(1)), zero
c
c The j loop is over error tolerances.
c
      do 200 j = 1,2
c
c Loop over method flag loop (for demonstration).
c
      do 100 meth = 1,2
       do 100 miter = 1,5
        if (miter .eq. 3)  go to 100
        if (miter .le. 2 .and. npts .gt. 10)  go to 100
        if (miter .eq. 5 .and. npts .lt. 100)  go to 100
        mf = 10*meth + miter
c
c Set the initial profile.
c
        do 40 i = 1,n14m1
   40     y(i) = zero
        y(n14) = half
        do 50 i = n14p1,n34m1
   50     y(i) = one
        y(n34) = half
        do 60 i = n34p1,nptsm1
   60     y(i) = zero
c
        t = tinit
        istate = 0
c
        write (lout,1500) rtol(j), atol(j), mf, npts
c
c  Output loop for each case
c
        do 80 io = 1,nout
c
c         call DLSODI
          if (miter .le. 2) call dlsodi (res, addafl, jacfl, n, y,
     1                      ydoti, t, tout(io), itol, rtol(j), atol(j),
     2                      1, istate, 0, rwork, lrw, iwork, liw, mf)
          if (miter .ge. 4) call dlsodi (res, addabd, jacbd, n, y,
     1                      ydoti, t, tout(io), itol, rtol(j), atol(j),
     2                      1, istate, 0, rwork, lrw, iwork, liw, mf)
          write (lout,2000) t, rwork(11), iwork(14),(y(i), i=1,n(1))
c
c If istate is not 2 on return, print message and loop.
          if (istate .ne. 2) then
            write (lout,4000) mf, t, istate
            nerr = nerr + 1
            go to 100
          endif
c
   80     continue
c
        write (lout,3000) mf, iwork(11), iwork(12), iwork(13),
     1                iwork(17), iwork(18)
c
c Estimate final error and print result.
        itemp = n(1)
        errfac = elkup( itemp, y, rwork(21), itol, rtol(j), atol(j) )
        if (errfac .gt. hun) then
          write (lout,5001)  errfac
          nerr = nerr + 1
        else
          write (lout,5000)  errfac
        endif
  100   continue
  200 continue
  300 continue
c
      write (lout,6000) nerr
c      stop
c
 1000 format(20x,' Demonstration Problem for DLSODI')
 1010 format(///80('*')///)
 1100 format(/10x,' Simplified Galerkin Solution of Burgers Equation'//
     1       13x,'Diffusion coefficient is eta =',d10.2/
     2       13x,'Uniform mesh on interval',d12.3,' to ',d12.3/
     3       13x,'Zero boundary conditions'/
     4       13x,'Time limits: t0 = ',d12.5,'   tlast = ',d12.5/
     5       13x,'Half-bandwidths ml = ',i2,'   mu = ',i2/
     6       13x,'System size neq = ',i3/)
c
 1200 format('Initial profile:'/17(6d12.4/))
c
 1500 format(///80('-')///'Run with rtol =',d12.2,'  atol =',d12.2,
     1       '   mf =',i3,'   npts =',i4,':'//)
c
 2000 format('Output for time t = ',d12.5,'   current h =',
     1       d12.5,'   current order =',i2,':'/17(6d12.4/))
c
 3000 format(//'Final statistics for mf = ',i2,':'/
     1       i4,' steps,',i5,' res,',i4,' Jacobians,',
     2       '   rwork size =',i6,',   iwork size =',i6)
c
 4000 format(///80('*')//20x,'Final time reached for mf = ',i2,
     1       ' was t = ',d12.5/25x,'at which istate = ',i2////80('*'))
 5000 format('  Final output is correct to within ',d8.1,
     1       '  times local error tolerance')
 5001 format('  Final output is wrong by ',d8.1,
     1       '  times local error tolerance')
 6000 format(//80('*')//
     1       'Run completed.  Number of errors encountered =',i3)
c
c end of main program for the DLSODI demonstration problem.
      end


program watch_point
      implicit none
      integer, parameter :: x_max = 4, y_max = 5, t_max = 100
      real, parameter :: prob = 0.7, boundary  = 0.0
      real, dimension(x_max, y_max) :: temp
      integer :: t

      call init_temp(temp, boundary)
      call show_temp(temp)
      do t = 1, t_max
          call update_temp(temp)
          call perturb_temp(temp, prob)
      end do
      call show_temp(temp)

contains

      subroutine init_temp(temp, boundary)
          implicit none
          real, dimension(:, :), intent(inout) :: temp
          real, intent(in) :: boundary
          integer :: i
          call random_number(temp)
          do i = 1, size(temp, 1)
              temp(i, 1) = boundary
              temp(i, shape(temp, 2)) = boundary
          end do
          do i = 1, size(temp, 2)
              temp(1, i) = boundary
              temp(shape(temp, 1), i) = boundary
          end do
      end subroutine init_temp

      subroutine update_temp(temp)
          implicit none
          real, dimension(:, :), intent(inout) :: temp
          integer :: i, j
          do j = 2, size(temp, 2) - 1
              do i = 2, size(temp, 1) - 1
                  temp(i, j) = 0.25*(temp(i - 1, j) + &
                                     temp(i + 1, j) + &
                                     temp(i,  j - 1) + &
                                     temp(i, j + 1))
              end do
          end do
      end subroutine update_temp

      subroutine perturb_temp(temp, prob)
          implicit none
          real, dimension(:, :), intent(inout) :: temp
          real, intent(in) :: prob
          integer :: i, j
          real :: r
          call random_number(r)
          if (r > prob) then
              call random_number(r)
              i = 1 + int(r*size(temp, 1))
              call random_number(r)
              j = 1 + int(r*size(temp, 2))
              call random_number(r)
              temp(i, j) = r
          end if
      end subroutine perturb_temp

      subroutine show_temp(temp)
          implicit none
          real, dimension(:, :), intent(inout) :: temp
          integer :: i
          character(len=32) :: fmt_str
          write (fmt_str, '(A, I0, A)') '(', size(temp, 2), 'ES15.5)'
          do i = 1, size(temp, 1)
              print fmt_str, temp(i, :)
          end do
      end subroutine show_temp

end program watch_point


program ch0703
    ! Sensible Tabular Output
    implicit none

    integer, parameter :: n = 3
    integer :: lat, long
    real, dimension(1:n,1:n) :: height
    real, parameter :: correct = 10.

    do lat = 1, n
        do long = 1, n
            read *, height(lat,long)
            height(lat,long) = height(lat,long)+correct
        end do
    end do
    do lat = 1, n
        print *, (height(lat,long), long = 1, n)
    end do
end program


program test_permutations
    use, intrinsic :: iso_fortran_env, only : error_unit
    use hash_mod, only : counter_t => ffh_t
    use :: utilities_mod
    implicit none
    integer, parameter :: nr_values = 15, nr_permutations = 20, &
                          nr_stats_values = 5, nr_stats_permutations = 1000000
    integer, dimension(nr_values) :: values
    integer, dimension(nr_stats_values) :: stats_values
    integer :: i, old_count, idx, nr_keys, total
    type(counter_t) :: counter
    character(len=10) :: key
    character(len=10), dimension(120) :: keys

    do i = 1, nr_values
        values(i) = i
    end do
    print '(*(I3))', values

    do i = 1, nr_permutations
        call fisher_yates_shuffle(values)
        print '(*(I3))', values
        call permutation_is_okay(values)
    end do

    do i = 1, nr_stats_values
        stats_values(i) = i
    end do

    nr_keys = 0
    do i = 1, nr_stats_permutations
        call fisher_yates_shuffle(stats_values)
        write (key, fmt='(*(I2))') stats_values
        idx = counter%get_index(key)
        if (idx == -1) then
            nr_keys = nr_keys + 1
            keys(nr_keys) = key
        end if
        old_count = counter%fget_value_or(key, 0)
        call counter%ustore_value(key, old_count + 1)
    end do

    total = 0
    do i = 1, nr_keys
        total = total + counter%fget_value(keys(i))
        print '(A10, I10)', keys(i), counter%fget_value(keys(i))
    end do
    print '(A, I0)', 'keys = ', nr_keys
    print '(A, I0)', 'total = ', total
    print '(A, I0)', 'buckets = ', counter%n_buckets

contains

    subroutine permutation_is_okay(values)
        implicit none
        integer, dimension(:), intent(inout) :: values
        logical, dimension(:), allocatable :: is_present
        integer :: i, idx, status

        allocate (is_present(size(values)), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A)') 'error: can not allocate logical array'
            stop 1
        end if
        is_present = .false.
        do i = 1, size(values)
            idx = values(i)
            if (is_present(idx)) then
                write (unit=error_unit, fmt='(A, *(I3))') 'double entry in ', values
                exit
            else
                is_present(idx) = .true.
            end if
        end do
        if (.not. all(is_present)) then
            write (unit=error_unit, fmt='(A, *(I3))') 'not all entries in ', values
        end if
        deallocate(is_present)
    end subroutine permutation_is_okay

end program test_permutations


      SUBROUTINE TINVIT(NM,N,D,E,E2,M,W,IND,Z,
     X                  IERR,RV1,RV2,RV3,RV4,RV6)
C
c  njtj
c  ###  Cray conversions
c  ###    1)Switch double precision to real.
c  ###    2)Switch double precision parameter
c  ###      to single precision parameter statement.
c  ###  Cray conversions
c  njtj
C
      INTEGER I,J,M,N,P,Q,R,S,II,IP,JJ,NM,ITS,TAG,IERR,GROUP
      INTEGER IND(M)
      DOUBLE PRECISION D(N),E(N),E2(N),W(M),Z(NM,M),
     X       RV1(N),RV2(N),RV3(N),RV4(N),RV6(N)
Cray      REAL D(N),E(N),E2(N),W(M),Z(NM,M),
Cray     X       RV1(N),RV2(N),RV3(N),RV4(N),RV6(N)
      DOUBLE PRECISION U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4,
     X       NORM,ORDER,MACHEP
Cray      REAL U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4,NORM,ORDER,MACHEP
C
      DOUBLE PRECISION ZERO,ONE,ONEM3,TWO
      PARAMETER(ZERO=0.D0,ONE=1.D0,ONEM3=1.D-3,TWO=2.D0)
Cray      PARAMETER(ZERO=0.0,ONE=1.0,ONEM3=1.E-3,TWO=2.0)
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH-
C     NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
C
C     THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL
C     SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES,
C     USING INVERSE ITERATION.
C
C     ON INPUT-
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY,
C
C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E,
C          WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E.
C          E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN
C          THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM
C          OF THE MAGNITUDES OF D(I) AND D(I-1).  E2(1) MUST CONTAIN
C          0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0
C          IF THE EIGENVALUES ARE IN DESCENDING ORDER.  IF  BISECT,
C          TRIDIB, OR  IMTQLV  HAS BEEN USED TO FIND THE EIGENVALUES,
C          THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE,
C
C        M IS THE NUMBER OF SPECIFIED EIGENVALUES,
C
C        W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER,
C
C        IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES
C          ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W --
C          1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM
C          THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC.
C
C     ON OUTPUT-
C
C        ALL INPUT ARRAYS ARE UNALTERED,
C
C        Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS.
C          ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          -R         IF THE EIGENVECTOR CORRESPONDING TO THE R-TH
C                     EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS,
C
C        RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ------------------------------------------------------------------
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
C                **********
      MACHEP = TWO**(-40)
C
      IERR = 0
      IF (M .EQ. 0) GO TO 1001
      TAG = 0
      ORDER = ONE - E2(1)
      Q = 0
C     ********** ESTABLISH AND PROCESS NEXT SUBMATRIX **********
  100 P = Q + 1
C
      DO 120 Q = P, N
         IF (Q .EQ. N) GO TO 140
         IF (E2(Q+1) .EQ. ZERO) GO TO 140
  120 CONTINUE
C     ********** FIND VECTORS BY INVERSE ITERATION **********
  140 TAG = TAG + 1
      S = 0
C
      DO 920 R = 1, M
         IF (IND(R) .NE. TAG) GO TO 920
         ITS = 1
         X1 = W(R)
         IF (S .NE. 0) GO TO 510
C     ********** CHECK FOR ISOLATED ROOT **********
         XU = ONE
         IF (P .NE. Q) GO TO 490
         RV6(P) = ONE
         GO TO 870
  490    NORM = ABS(D(P))
         IP = P + 1
C
         DO 500 I = IP, Q
  500    NORM = NORM + ABS(D(I)) + ABS(E(I))
C     ********** EPS2 IS THE CRITERION FOR GROUPING,
C                EPS3 REPLACES ZERO PIVOTS AND EQUAL
C                ROOTS ARE MODIFIED BY EPS3,
C                EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW **********
         EPS2 = ONEM3 * NORM
         EPS3 = MACHEP * NORM
         UK = REAL(Q-P+1)
         EPS4 = UK * EPS3
         UK = EPS4 / SQRT(UK)
         S = P
  505    GROUP = 0
         GO TO 520
C     ********** LOOK FOR CLOSE OR COINCIDENT ROOTS **********
  510    IF (ABS(X1-X0) .GE. EPS2) GO TO 505
         GROUP = GROUP + 1
         IF (ORDER * (X1 - X0) .LE. ZERO) X1 = X0 + ORDER * EPS3
C     ********** ELIMINATION WITH INTERCHANGES AND
C                INITIALIZATION OF VECTOR **********
  520    V = ZERO
C
         DO 580 I = P, Q
            RV6(I) = UK
            IF (I .EQ. P) GO TO 560
            IF (ABS(E(I)) .LT. ABS(U)) GO TO 540
C     ********** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF
C                E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY **********
            XU = U / E(I)
            RV4(I) = XU
            RV1(I-1) = E(I)
            RV2(I-1) = D(I) - X1
            RV3(I-1) = ZERO
            IF (I .NE. Q) RV3(I-1) = E(I+1)
            U = V - XU * RV2(I-1)
            V = -XU * RV3(I-1)
            GO TO 580
  540       XU = E(I) / U
            RV4(I) = XU
            RV1(I-1) = U
            RV2(I-1) = V
            RV3(I-1) = ZERO
  560       U = D(I) - X1 - XU * V
            IF (I .NE. Q) V = E(I+1)
  580    CONTINUE
C
         IF (U .EQ. ZERO) U = EPS3
         RV1(Q) = U
         RV2(Q) = ZERO
         RV3(Q) = ZERO
C     ********** BACK SUBSTITUTION
C                FOR I=Q STEP -1 UNTIL P DO -- **********
  600    DO 620 II = P, Q
            I = P + Q - II
            RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I)
            V = U
            U = RV6(I)
  620    CONTINUE
C     ********** ORTHOGONALIZE WITH RESPECT TO PREVIOUS
C                MEMBERS OF GROUP **********
         IF (GROUP .EQ. 0) GO TO 700
         J = R
C
         DO 680 JJ = 1, GROUP
  630       J = J - 1
            IF (IND(J) .NE. TAG) GO TO 630
            XU = ZERO
C
            DO 640 I = P, Q
  640       XU = XU + RV6(I) * Z(I,J)
C
            DO 660 I = P, Q
  660       RV6(I) = RV6(I) - XU * Z(I,J)
C
  680    CONTINUE
C
  700    NORM = ZERO
C
         DO 720 I = P, Q
  720    NORM = NORM + ABS(RV6(I))
C
         IF (NORM .GE. ONE) GO TO 840
C     ********** FORWARD SUBSTITUTION **********
         IF (ITS .EQ. 5) GO TO 830
         IF (NORM .NE. ZERO) GO TO 740
         RV6(S) = EPS4
         S = S + 1
         IF (S .GT. Q) S = P
         GO TO 780
  740    XU = EPS4 / NORM
C
         DO 760 I = P, Q
  760    RV6(I) = RV6(I) * XU
C     ********** ELIMINATION OPERATIONS ON NEXT VECTOR
C                ITERATE **********
  780    DO 820 I = IP, Q
            U = RV6(I)
C     ********** IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE
C                WAS PERFORMED EARLIER IN THE
C                TRIANGULARIZATION PROCESS **********
            IF (RV1(I-1) .NE. E(I)) GO TO 800
            U = RV6(I-1)
            RV6(I-1) = RV6(I)
  800       RV6(I) = U - RV4(I) * RV6(I-1)
  820    CONTINUE
C
         ITS = ITS + 1
         GO TO 600
C     ********** SET ERROR -- NON-CONVERGED EIGENVECTOR **********
  830    IERR = -R
         XU = ZERO
         GO TO 870
C     ********** NORMALIZE SO THAT SUM OF SQUARES IS
C                1 AND EXPAND TO FULL ORDER **********
  840    U = ZERO
C
         DO 860 I = P, Q
  860    U = U + RV6(I)**2
C
         XU = ONE / SQRT(U)
C
  870    DO 880 I = 1, N
  880    Z(I,R) = ZERO
C
         DO 900 I = P, Q
  900    Z(I,R) = RV6(I) * XU
C
         X0 = X1
  920 CONTINUE
C
      IF (Q .LT. N) GO TO 100
 1001 RETURN
C     ********** LAST CARD OF TINVIT **********
      END


! { dg-do run }
!
! PR fortran/53255
!
! Contributed by Reinhold Bader.
!
! Before TYPE(ext)'s .tr. wrongly called the base type's trace
! instead of ext's trace_ext.
!
module mod_base
  implicit none
  private
  integer, public :: base_cnt = 0
  type, public :: base
     private
     real :: r(2,2) = reshape( (/ 1.0, 2.0, 3.0, 4.0 /), (/ 2, 2 /))
   contains
     procedure, private :: trace
     generic :: operator(.tr.) => trace
  end type base
contains
  complex function trace(this)
    class(base), intent(in) :: this
    base_cnt = base_cnt + 1
!    write(*,*) 'executing base'
    trace = this%r(1,1) + this%r(2,2)
  end function trace
end module mod_base

module mod_ext
  use mod_base
  implicit none
  private
  integer, public :: ext_cnt = 0
  public :: base, base_cnt
  type, public, extends(base) :: ext
     private
     real :: i(2,2) = reshape( (/ 1.0, 1.0, 1.0, 1.5 /), (/ 2, 2 /))
   contains
     procedure, private :: trace => trace_ext
  end type ext
contains
   complex function trace_ext(this)
    class(ext), intent(in) :: this

!   the following should be executed through invoking .tr. p below
!    write(*,*) 'executing override'
    ext_cnt = ext_cnt + 1
    trace_ext = .tr. this%base + (0.0, 1.0) * ( this%i(1,1) + this%i(2,2) )
  end function trace_ext

end module mod_ext
program test_override
  use mod_ext
  implicit none
  type(base) :: o
  type(ext) :: p
  real :: r

  ! Note: ext's ".tr." (trace_ext) calls also base's "trace"

!  write(*,*) .tr. o
!  write(*,*) .tr. p
  if (base_cnt /= 0 .or. ext_cnt /= 0) call abort ()
  r = .tr. o
  if (base_cnt /= 1 .or. ext_cnt /= 0) call abort ()
  r = .tr. p
  if (base_cnt /= 2 .or. ext_cnt /= 1) call abort ()

  if (abs(.tr. o - 5.0 ) < 1.0e-6  .and. abs( .tr. p - (5.0,2.5)) < 1.0e-6) &
  then
    if (base_cnt /= 4 .or. ext_cnt /= 2) call abort ()
!     write(*,*) 'OK'
  else
    call abort()
!     write(*,*) 'FAIL'
  end if
end program test_override


module mo_weight

PUBLIC :: wsum
PUBLIC :: wmean

INTERFACE wsum
    MODULE PROCEDURE wsum_vec, wsum_mat
END INTERFACE wsum

INTERFACE wmean
    MODULE PROCEDURE wmean_vec, wmean_mat
END INTERFACE wmean

contains

! normalize: default false; if true, sum(ws) = 1
real function wsum_vec(mat, ws, mask, normalize)
    REAL   , dimension(:), intent(in) :: mat
    REAL   , dimension(:), optional, intent(in) :: ws
    LOGICAL, dimension(:), optional, intent(in) :: mask
    LOGICAL,               optional, intent(in) :: normalize

    ! implicit none
    ! real :: args
    ! local
    REAL   , dimension(:), allocatable :: vec
    REAL   , dimension(:), allocatable :: ws2
    REAL   , dimension(:), allocatable :: w
    integer :: nrow, ncol, i, j
    real    :: tol
    LOGICAL :: is_weight

    is_weight = present(ws)
    if (present(ws)) ws2 = ws
    ! can't use print here

    if ( .not. present(mask) ) then
        ! no mask
        if (is_weight) then
            if (present(normalize) .and. normalize) ws2 = ws / sum(ws) * size(ws)
            tol = sum(mat * ws2)
        else
            tol = sum(mat)
        endif
    else
        vec = PACK(mat, mask)

        if (is_weight) then
            w   = PACK(ws2, mask)
            if (present(normalize) .and. normalize) w = w / sum(w) * size(w)

            ! allocate( w(count(mask)) )
            tol = sum(vec * w)
            deallocate(w)
        else
            tol = sum(vec)
        endif
        deallocate(vec)
    endif

    wsum_vec = tol
end function wsum_vec

real function wsum_mat(mat, ws, mask, normalize)
    ! implicit none
    ! real :: args
    REAL   , dimension(:, :), intent(in) :: mat
    REAL   , dimension(:, :), optional, intent(in) :: ws
    LOGICAL, dimension(:, :), optional, intent(in) :: mask
    LOGICAL,                  optional, intent(in) :: normalize

    ! local
    REAL   , dimension(:, :), allocatable :: ws2
    REAL   , dimension(:)   , allocatable :: vec
    REAL   , dimension(:)   , allocatable :: w

    integer :: nrow, ncol, i, j
    real    :: tol
    LOGICAL :: is_weight

    is_weight = present(ws)
    if (present(ws)) ws2 = ws
    ! write (*, *) ws2 !size(ws2, 1), size(ws2, 2)

    if (.not. present(mask)) then
        if (is_weight) then
            ! if normalize, sum(w_mask) = 1
            if (present(normalize) .and. normalize) ws2 = ws / sum(ws) * size(ws)
            tol = sum(mat * ws2)
        else
            tol = sum(mat)
        endif
    else
        vec = PACK(mat, mask)

        if (is_weight) then
            w   = PACK(ws2, mask)
            if (present(normalize) .and. normalize) w = w / sum(w) * size(w)
            ! write (*, *) w !size(ws2, 1), size(ws2, 2)
            ! allocate( w(count(mask)) )
            tol = sum(vec * w)
            deallocate(w)
        else
            tol = sum(vec)
        endif
        deallocate(vec)
    endif
    wsum_mat = tol
end function wsum_mat

real function wmean_vec(mat, ws, mask)
    ! implicit none
    REAL   , dimension(:), intent(in) :: mat
    REAL   , dimension(:), optional, intent(in) :: ws
    LOGICAL, dimension(:), optional, intent(in) :: mask

    real tol;
    integer n;
    ! local
    tol = wsum_vec(mat, ws, mask)

    if (present(mask)) then
        n = count(mask)
    else
        n = size(mat)
    endif
    wmean_vec = tol / n
    ! write (120, *) tol, n, wmean, 11.0/2
end function wmean_vec

real function wmean_mat(mat, ws, mask)
    ! implicit none
    REAL   , dimension(:, :), intent(in) :: mat
    REAL   , dimension(:, :), optional, intent(in) :: ws
    LOGICAL, dimension(:, :), optional, intent(in) :: mask

    real tol;
    integer n;
    ! local
    tol = wsum_mat(mat, ws, mask)

    if (present(mask)) then
        n = count(mask)
    else
        n = size(mat)
    endif
    wmean_mat = tol / n
end function wmean_mat

end module


      module m
      implicit none
      type wrapper
      integer::i
      end type wrapper
      interface operator (+)
      module procedure addw
      end interface
      contains
      function addw(a,b)
      type(wrapper),intent(in)::a,b
      type(wrapper)::addw
      addw%i=a%i+b%i
      end function addw
      end module m

      program t
      use m
      implicit none
      type(wrapper)::x,y
      x%i=2
      y%i=3
      print *,x+y
      end program t


      subroutine matrixtrans(A,AT,n,m)
      integer n,m
      real*8 A(n,m),AT(m,n)
      do i=1,n
      do j=1,m
      AT(j,i)=A(i,j)
      enddo
      enddo
      return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine error

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c   compute the solution error
c
c---------------------------------------------------------------------

      implicit none

      include 'applu.incl'

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, m
      double precision  tmp
      double precision  u000ijk(5)
      double precision  errnm_local(5)

      do m = 1, 5
         errnm(m) = 0.0d+00
      end do

!$omp parallel default(shared) private(i,j,k,m,tmp,u000ijk,errnm_local)
      do m = 1, 5
         errnm_local(m) = 0.0d+00
      end do
!$omp do
      do k = 2, nz-1
         do j = jst, jend
            do i = ist, iend
               call exact( i, j, k, u000ijk )
               do m = 1, 5
                  tmp = ( u000ijk(m) - u(m,i,j,k) )
                  errnm_local(m) = errnm_local(m) + tmp * tmp
               end do
            end do
         end do
      end do
!$omp end do nowait
      do m = 1, 5
!$omp critical
         errnm(m) = errnm(m) + errnm_local(m)
!$omp end critical
      end do
!$omp end parallel

      do m = 1, 5
         errnm(m) = sqrt ( errnm(m) / ( (nx0-2)*(ny0-2)*(nz0-2) ) )
      end do

c        write (*,1002) ( errnm(m), m = 1, 5 )

 1002 format (1x/1x,'RMS-norm of error in soln. to ',
     > 'first pde  = ',1pe12.5/,
     > 1x,'RMS-norm of error in soln. to ',
     > 'second pde = ',1pe12.5/,
     > 1x,'RMS-norm of error in soln. to ',
     > 'third pde  = ',1pe12.5/,
     > 1x,'RMS-norm of error in soln. to ',
     > 'fourth pde = ',1pe12.5/,
     > 1x,'RMS-norm of error in soln. to ',
     > 'fifth pde  = ',1pe12.5)

      return
      end


      subroutine ire_resxx(ctfm,ctfmp,n_U,n_a1,n_alpha,n_b1,n_beta,n_ips
     &i,n_rpsi,nm1_a1,nm1_alpha,nm1_b1,nm1_beta,nm1_ipsi,nm1_rpsi,np1_a1
     &,np1_alpha,np1_b1,np1_beta,np1_ipsi,np1_rpsi,Nx,ht,hx,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_U(Nx)
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_b1(Nx)
      real*8 n_beta(Nx)
      real*8 n_ipsi(Nx)
      real*8 n_rpsi(Nx)
      real*8 nm1_a1(Nx)
      real*8 nm1_alpha(Nx)
      real*8 nm1_b1(Nx)
      real*8 nm1_beta(Nx)
      real*8 nm1_ipsi(Nx)
      real*8 nm1_rpsi(Nx)
      real*8 np1_a1(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_b1(Nx)
      real*8 np1_beta(Nx)
      real*8 np1_ipsi(Nx)
      real*8 np1_rpsi(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=2, Nx-1, 1
      qb = -0.2500000000000000D0 / n_alpha(i) ** 2 / n_b1(i) ** 2 * (-0.
     #1D1 * nm1_b1(i) + np1_b1(i)) ** 2 / ht ** 2 - 0.1250000000000000D0
     # / n_alpha(i) ** 2 * (-0.1D1 * nm1_ipsi(i) + np1_ipsi(i)) ** 2 / h
     #t ** 2 - 0.1250000000000000D0 / n_alpha(i) ** 2 * (-0.1D1 * nm1_rp
     #si(i) + np1_rpsi(i)) ** 2 / ht ** 2 - 0.5000000000000000D0 * (nm1_
     #alpha(i) - 0.1D1 * np1_alpha(i)) / ht ** 2 / n_b1(i) / n_alpha(i)
     #** 3 * (-0.1D1 * nm1_b1(i) + np1_b1(i)) + 0.2D1 / n_alpha(i) ** 2
     #/ n_b1(i) * (-0.1D1 * nm1_b1(i) + 0.2D1 * n_b1(i) - 0.1D1 * np1_b1
     #(i)) / ht ** 2 + 0.5000000000000000D0 * n_U(i) + (0.50000000000000
     #00D0 * (-0.1D1 * nm1_a1(i) + np1_a1(i)) / ht / n_alpha(i) ** 2 / n
     #_b1(i) / n_a1(i) * n_beta(i) * (-0.1D1 * n_b1(i - 1) + n_b1(i + 1)
     #) / hx + 0.5000000000000000D0 / n_b1(i) / n_alpha(i) ** 2 * n_beta
     #(i) * (nm1_b1(i - 1) - 0.1D1 * nm1_b1(i + 1) - 0.1D1 * np1_b1(i -
     #1) + np1_b1(i + 1)) / hx / ht + 0.5000000000000000D0 * (-0.1D1 * n
     #_b1(i - 1) + n_b1(i + 1)) / hx / n_alpha(i) ** 2 / n_b1(i) * (-0.1
     #D1 * nm1_beta(i) + np1_beta(i)) / ht + 0.5000000000000000D0 * (nm1
     #_alpha(i) - 0.1D1 * np1_alpha(i)) / ht / n_b1(i) * n_beta(i) / n_a
     #lpha(i) ** 3 * (-0.1D1 * n_b1(i - 1) + n_b1(i + 1)) / hx + 0.50000
     #00000000000D0 * (-0.1D1 * nm1_b1(i) + np1_b1(i)) / ht / n_alpha(i)
     # ** 2 * n_beta(i) / n_b1(i) ** 2 * (-0.1D1 * n_b1(i - 1) + n_b1(i
     #+ 1)) / hx) / ctfmp(i) + (0.5000000000000000D0 * (n_a1(i - 1) - 0.
     #1D1 * n_a1(i + 1)) / hx ** 2 / n_alpha(i) ** 2 / n_b1(i) / n_a1(i)
     # * n_beta(i) ** 2 * (-0.1D1 * n_b1(i - 1) + n_b1(i + 1)) + 0.25000
     #00000000000D0 / n_b1(i) ** 2 / n_a1(i) ** 2 * (-0.1D1 * n_b1(i - 1
     #) + n_b1(i + 1)) ** 2 / hx ** 2 + 0.1250000000000000D0 / n_alpha(i
     #) ** 2 * (n_ipsi(i - 1) - 0.1D1 * n_ipsi(i + 1)) ** 2 / hx ** 2 *
     #n_beta(i) ** 2 + 0.1250000000000000D0 / n_alpha(i) ** 2 * (-0.1D1
     #* n_rpsi(i - 1) + n_rpsi(i + 1)) ** 2 / hx ** 2 * n_beta(i) ** 2 -
     # 0.1250000000000000D0 / n_a1(i) ** 2 * (n_ipsi(i - 1) - 0.1D1 * n_
     #ipsi(i + 1)) ** 2 / hx ** 2 - 0.1250000000000000D0 / n_a1(i) ** 2
     #* (-0.1D1 * n_rpsi(i - 1) + n_rpsi(i + 1)) ** 2 / hx ** 2 - 0.2500
     #000000000000D0 / n_alpha(i) ** 2 / n_b1(i) ** 2 * (-0.1D1 * n_b1(i
     # - 1) + n_b1(i + 1)) ** 2 / hx ** 2 * n_beta(i) ** 2 - 0.500000000
     #0000000D0 * (n_alpha(i - 1) - 0.1D1 * n_alpha(i + 1)) / hx ** 2 /
     #n_alpha(i) / n_b1(i) / n_a1(i) ** 2 * (-0.1D1 * n_b1(i - 1) + n_b1
     #(i + 1)) + 0.5000000000000000D0 * (-0.1D1 * n_b1(i - 1) + n_b1(i +
     # 1)) / hx ** 2 / n_alpha(i) ** 2 / n_b1(i) * n_beta(i) * (n_beta(i
     # - 1) - 0.1D1 * n_beta(i + 1))) / ctfmp(i) ** 2 + ((nm1_alpha(i) -
     # 0.1D1 * np1_alpha(i)) / ht / n_alpha(i) ** 3 * n_beta(i) + 0.1D1
     #/ n_alpha(i) ** 2 * (-0.1D1 * nm1_beta(i) + np1_beta(i)) / ht + 0.
     #2D1 * (-0.1D1 * nm1_b1(i) + np1_b1(i)) / ht / n_alpha(i) ** 2 / n_
     #b1(i) * n_beta(i) + (-0.1D1 * nm1_a1(i) + np1_a1(i)) / ht / n_alph
     #a(i) ** 2 / n_a1(i) * n_beta(i) + ((-0.1D1 * n_b1(i - 1) + n_b1(i
     #+ 1)) / hx / n_b1(i) / n_a1(i) ** 2 + 0.1D1 / n_alpha(i) ** 2 * n_
     #beta(i) * (n_beta(i - 1) - 0.1D1 * n_beta(i + 1)) / hx - 0.1D1 * (
     #n_alpha(i - 1) - 0.1D1 * n_alpha(i + 1)) / hx / n_alpha(i) / n_a1(
     #i) ** 2 + (n_a1(i - 1) - 0.1D1 * n_a1(i + 1)) / hx / n_a1(i) * n_b
     #eta(i) ** 2 / n_alpha(i) ** 2 - 0.1D1 * (-0.1D1 * n_b1(i - 1) + n_
     #b1(i + 1)) / hx / n_alpha(i) ** 2 / n_b1(i) * n_beta(i) ** 2) / ct
     #fmp(i)) / ctfm(i) + (-0.1D1 * n_beta(i) ** 2 / n_alpha(i) ** 2 + 0
     #.1D1 / n_a1(i) ** 2 - 0.1D1 / n_b1(i) ** 2) / ctfm(i) ** 2
      res(i)=qb
      end do
      END


program tester

use mod_global
use mod_kinds
use mod_QCsymmetry
use mod_QCcrystallography
use mod_io

IMPLICIT NONE

type(QCSpaceGroup_T)        :: QCSG
type(IO_T)                  :: Message
integer(kind=irg)           :: i

do i=6,11
  if (i.ne.7) then
    QCSG = QCspacegroup_T( nD = 3, QCtype = 'Ico')
    call QCSG%setSGnum(i)
! call QCcell_icosahedral%setMetricParametersQC()
    call QCSG%GenerateQCSymmetry(dopg=.FALSE.)
    write (*,*) ' order of icosahedral space group ', i, ' equals ',QCSG%getnsym()
  end if
end do

end program


C     PROGRAM No. 13: RECTANGULAR LIFTING SURFACE (VLM)
C     -------------------------------------------------
C     3D-VLM CODE FOR SIMPLE WING PLANFORMS WITH GROUND EFFECT(BYJOE KATZ,1974).
      DIMENSION QF(6,14,3),QC(4,13,3),DS(4,13,4)
      DIMENSION GAMA(4,13),DL(4,13),DD(4,13),DP(4,13)
      DIMENSION A(52,52),GAMA1(52),DW(52),IP(52)
      DIMENSION A1(5,13),DLY(13),GAMA1J(5),X(4)

      COMMON/NO1/ DS,X,B,C,S,AR,SN1,CS1
      COMMON/NO2/ IB,JB,CH,SIGN
      COMMON/NO3/ A1
      COMMON/NO4/ QF,QC,DXW

C     ==========
C     INPUT DATA
C     ==========
      IB=4
      JB=13
      X(1)=0.
      X(2)=0.
      X(3)=4.
      X(4)=4.
      B=13.
      VT=1.0
      ALPHA1=5.0
      CH=1000.
C     X(1) TO X(4) ARE X-COORDINATES OF THE WING'S FOUR CORNERPOINTS.
C     B - WING SPAN, VT - FREE STREAM SPEED, B - WING SPAN,
C     CH - HEIGHT ABOVE GROUND

C     CONSTANTS
      DXW=100.0*B
      DO 1 I=1,IB
         DO 1 J=1,JB
C           GAMA(I,J)=1.0 IS REQUIRED FOR INFLUENCE MATRIX CALCULATIONS.
 1          GAMA(I,J)=1.0

      RO=1.
      PAY=3.141592654
      ALPHA=ALPHA1*PAY/180.
      SN1=SIN(ALPHA)
      CS1=COS(ALPHA)
      IB1=IB+1
      IB2=IB+2
      JB1=JB+1

C     =============
C     WING GEOMETRY
C     =============
      CALL GRID
      WRITE(6,101)
      WRITE(6,102) ALPHA1,B,C,S,AR,VT,IB,JB,CH

C     ========================
C     AERODYNAMIC CALCULATIONS
C     ========================

C     INFLUENCE COEFFICIENTS CALCULATION
      K=0
      DO 14 I=1,IB
         DO 14 J=1,JB
            SIGN=0.0
            K=K+1
            CALL WING(QC(I,J,1),QC(I,J,2),QC(I,J,3),GAMA,U,V,W,1.0,I,J)
            L=0

            DO 10 I1=1,IB
               DO 10 J1=1,JB
                     L=L+1
C                 A(K,L) - IS THE NORMAL VELOCITY COMPONENT DUE TO A UNIT VORTEX
C                 LATTICE.
 10               A(K,L)=A1(I1,J1)

C           ADD INFLUENCE OF WING'S OTHER HALF
            CALL WING(QC(I,J,1),-QC(I,J,2),QC(I,J,3),GAMA,U,V,W,1.0,I,J)
            L=0
            DO 11 I1=1,IB
               DO 11 J1=1,JB
                  L=L+1
 11               A(K,L)=A(K,L)+A1(I1,J1)

            IF(CH.GT.100.0) GOTO 12

C           ADD INFLUENCE OF MIRROR IMAGE (DUE TO GROUND)
            SIGN=10.0
            CALL WING(QC(I,J,1),QC(I,J,2),-QC(I,J,3),GAMA,U,V,W,1.0,I,J)
            L=0
            DO 8 I1=1,IB
               DO 8 J1=1,JB
                  L=L+1
 8                A(K,L)=A(K,L)+A1(I1,J1)

C           ADD MIRROR IMAGE INFLUENCE OF WING'S OTHER HALF.
            CALL WING(QC(I,J,1),-QC(I,J,2),-QC(I,J,3),GAMA,U,V,W,1.0,I,J)
            L=0
            DO 9 I1=1,IB
               DO 9 J1=1,JB
                  L=L+1
 9                A(K,L)=A(K,L)+A1(I1,J1)
            SIGN=0.0

 12      CONTINUE
 13      CONTINUE

C        CALCULATE WING GEOMETRICAL DOWNWASH
         UINF=VT
         VINF=0.0
         WINF=0.0

C        THIS IS THE GENERAL FORMULATION FOR RIGHT HAND SIDE.
         DW(K)=-(UINF*DS(I,J,1)+VINF*DS(I,J,2)+WINF*DS(I,J,3))
 14   CONTINUE

C     SOLUTION OF THE PROBLEM: DW(I)=A(I,J)*GAMA(I)
      K1=IB*JB
      DO 15 K=1,K1
 15      GAMA1(K)=DW(K)

      CALL DECOMP(K1,52,A,IP)
 16   CONTINUE
      CALL SOLVER(K1,52,A,GAMA1,IP)
C     HERE * THE SAME ARRAY SIZE IS REQUIRED,
C     AS SPECIFIED IN THE BEGINNING OF THE CODE

C     WING VORTEX LATTICE LISTING
      K=0
      DO 17 I=1,IB
         DO 17 J=1,JB
            K=K+1
 17         GAMA(I,J)=GAMA1(K)

C     ==================
C     FORCES CALCULATION
C     ==================
      FL=0.
      FD=0.
      FM=0.
      QUE=0.5*RO*VT*VT
      DO 20 J=1,JB
         DLY(J)=0.
         DO 20 I=1,IB
            IF(I.EQ.1) GAMAIJ=GAMA(I,J)
            IF(I.GT.1) GAMAIJ=GAMA(I,J)-GAMA(I-1,J)
            DYM=QF(I,J+1,2)-QF(I,J,2)
            DL(I,J)=RO*VT*GAMAIJ*DYM
C           INDUCED DRAG CALCULATION
            CALL WING(QC(I,J,1),QC(I,J,2),QC(I,J,3),GAMA,U1,V1,W1,0.0,I,J)
             CALL WING(QC(I,J,1),-QC(I,J,2),QC(I,J,3),GAMA,U2,V2,W2,0.0,I,J)
            IF(CH.GT.100.0) GOTO 194
             CALL WING(QC(I,J,1),QC(I,J,2),-QC(I,J,3),GAMA,U3,V3,W3,0.0,I,J)
            CALL WING(QC(I,J,1),-QC(I,J,2),-QC(I,J,3),GAMA,U4,V4,W4,0.0,I,J)
            GOTO 195
            194 W3=0.
            W4=0.
            195 WIND=W1+W2-W3-W4

C           ADD INFLUENCE OF MIRROR IMAGE (GROUND).
            ALFI=-WIND/VT
            DD(I,J)=RO*DYM*VT*GAMAIJ*ALFI
            DP(I,J)=DL(I,J)/DS(I,J,4)/QUE
            DLY(J)=DLY(J)+DL(I,J)
            FL=FL+DL(I,J)
            FD=FD+DD(I,J)
            FM=FM+DL(I,J)*(QF(I,J,1)-X(1))
 20   CONTINUE
      CL=FL/(QUE*S)
      CD=FD/(QUE*S)
      CM=FM/(QUE*S*C)

C     OUTPUT
      WRITE(6,104) CL,FL,CM,CD
      WRITE(6,110)
      DO 21 J=1,JB
            DO 211 I=2,IB
 211              GAMA1J(I)=GAMA(I,J)-GAMA(I-1,J)
            DLYJ=DLY(J)/B*JB
 21   WRITE(6,103) J,DLYJ,DP(1,J),DP(2,J),DP(3,J),DP(4,J),GAMA(1,J),
     1 GAMA1J(2),GAMA1J(3),GAMA1J(4)

C     END OF PROGRAM
 100  CONTINUE

C     FORMATS
 101  FORMAT(1H ,/,20X,'WING LIFT DISTRIBUTION CALCULATION (WITH GROUND
     1 EFFECT)',/,20X,56('-'))
 102  FORMAT(1H ,/,10X,'ALFA:',F10.2,8X,'B :',
     1F10.2,8X,'C :',F13.2,/,10X,
     2'S :',F10.2,8X,'AR :',F10.2,8X,'V(INF) :',F10.2,/,10X,
     3'IB :',I10,8X,'JB :',I10,8X,'L.E. HEIGHT:', F6.2,/)
 103  FORMAT(1H ,I3,' I ',F9.3,' II ',4(F9.3,' I '),' I ',4(F9.3,' I '))
 104  FORMAT(/,1H ,'CL=',F10.4,2X,'L=',F10.4,4X,'CM=',F10.4,3X,
     1'CD=',F10.4)
 110  FORMAT(1H ,/,5X,'I DL',4X,'II',22X,'DCP',22X,'I I',25X,
     1'GAMA',/,118('='),/,5X,'I',15X,'I= 1',11X,'2',11X,'3',11X,
     2'4',5X,'I I',5X,'1',11X,'2',11X,'3',11X,'4',/,118('='))
 112  FORMAT(1H ,'QF(I=',I2,',J,X.Y.Z)= ',15(F6.1))
 113  FORMAT(1H ,110('='))

      STOP
      END

      SUBROUTINE GRID
      DIMENSION QF(6,14,3),QC(4,13,3),DS(4,13,4),X(4)
      COMMON/NO1/ DS,X,B,C,S,AR,SN1,CS1
      COMMON/NO2/ IB,JB,CH,SIGN
      COMMON/NO4/ QF,QC,DXW

      PAY=3.141592654
C     X(1) - IS ROOT L.E., X(2) TIP L.E., X(3) TIP T.E., AND X(4) IS ROOT T.E.
C     IB: NO. OF CHORDWISE BOXES, JB: NO. OF SPANWISE BOXES
      IB1=IB+1
      IB2=IB+2
      JB1=JB+1

C     WING FIXED VORTICES LOCATION ( QF(I,J,(X,Y,Z))...)
      DY=B/JB
      DO 3 J=1,JB1
         YLE=DY*(J-1)
         XLE=X(1)+(X(2)-X(1))*YLE/B
         XTE=X(4)+(X(3)-X(4))*YLE/B
C        XLE AND XTE ARE L.E. AND T.E. X-COORDINATES
         DX=(XTE-XLE)/IB
         DO 1 I=1,IB1
            QF(I,J,1)=(XLE+DX*(I-0.75))*CS1
            QF(I,J,2)=YLE
            QF(I,J,3)=-QF(I,J,1)*SN1+CH
 1       CONTINUE
C        WAKE FAR FIELD POINTS
         QF(IB2,J,1)=XTE+DXW
         QF(IB2,J,2)=QF(IB1,J,2)
 3    QF(IB2,J,3)=QF(IB1,J,3)

C     WING COLLOCATION POINTS
      DO 4 J=1,JB
         DO 4 I=1,IB
            QC(I,J,1)=(QF(I,J,1)+QF(I,J+1,1)+QF(I+1,J+1,1)+QF(I+1,J,1))/4
            QC(I,J,2)=(QF(I,J,2)+QF(I,J+1,2)+QF(I+1,J+1,2)+QF(I+1,J,2))/4
            QC(I,J,3)=(QF(I,J,3)+QF(I,J+1,3)+QF(I+1,J+1,3)+QF(I+1,J,3))/4

C           COMPUTATION OF NORMAL VECTORS
            CALL PANEL(QF(I,J,1),QF(I,J,2),QF(I,J,3),QF(I+1,J,1),QF(I+1,J,2),
            1QF(I+1,J,3),QF(I,J+1,1),QF(I,J+1,2),QF(I,J+1,3),QF(I+1,J+1,1),
            2QF(I+1,J+1,2),QF(I+1,J+1,3),DS(I,J,1),DS(I,J,2),DS(I,J,3),
            3DS(I,J,4))
 4    CONTINUE

C     B -IS SEMI SPAN, C -AV. CHORD, S - AREA
      S=0.5*(X(3)-X(2)+X(4)-X(1))*B
      C=S/B
      AR=2.*B*B/S

      RETURN
      END

      SUBROUTINE PANEL(X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4,C1,C2,C3,S)
C     CALCULATION OF PANEL AREA AND NORMAL VECTOR.
      A1=X2-X3
      A2=Y2-Y3
      A3=Z2-Z3
      B1=X4-X1
      B2=Y4-Y1
      B3=Z4-Z1

C     NORMAL VECTOR
      X=A2*B3-A3*B2
      Y=B1*A3-A1*B3
      Z=A1*B2-A2*B1
      A=SQRT(X**2+Y**2+Z**2)
      C1=X/A
      C2=Y/A
      C3=Z/A

C     CALCULATION OF PANEL AREA
      E1=X3-X1
      E2=Y3-Y1
      E3=Z3-Z1
      F1=X2-X1
      F2=Y2-Y1
      F3=Z2-Z1

C     NORMAL AREAS (F*B+B*E)
      S11=F2*B3-F3*B2
      S12=B1*F3-F1*B3
      S13=F1*B2-F2*B1
      S21=B2*E3-B3*E2
      S22=E1*B3-B1*E3
      S23=B1*E2-B2*E1
      S=0.5*(SQRT(S11**2+S12**2+S13**2)+SQRT(S21**2+S22**2+S23**2))
      RETURN
      END

      SUBROUTINE VORTEX(X,Y,Z,X1,Y1,Z1,X2,Y2,Z2,GAMA,U,V,W)
C     SUBROUTINE VORTEX CALCULATES THE INDUCED VELOCITY (U,V,W) AT A POI
C     (X,Y,Z) DUE TO A VORTEX ELEMENT VITH STRENGTH GAMA PER UNIT LENGTH
C     POINTING TO THE DIRECTION (X2,Y2,Z2)-(X1,Y1,Z1).
      PAY=3.141592654
      RCUT=1.0E-10

C     CALCULATION OF R1 X R2
      R1R2X=(Y-Y1)*(Z-Z2)-(Z-Z1)*(Y-Y2)
      R1R2Y=-((X-X1)*(Z-Z2)-(Z-Z1)*(X-X2))
      R1R2Z=(X-X1)*(Y-Y2)-(Y-Y1)*(X-X2)

C     CALCULATION OF (R1 X R2 )**2
      SQUARE=R1R2X*R1R2X+R1R2Y*R1R2Y+R1R2Z*R1R2Z

C     CALCULATION OF R0(R1/R(R1)-R2/R(R2))
      R1=SQRT((X-X1)*(X-X1)+(Y-Y1)*(Y-Y1)+(Z-Z1)*(Z-Z1))
      R2=SQRT((X-X2)*(X-X2)+(Y-Y2)*(Y-Y2)+(Z-Z2)*(Z-Z2))
      IF((R1.LT.RCUT).OR.(R2.LT.RCUT).OR.(SQUARE.LT.RCUT)) GOTO 1 GROUND
      R0R1=(X2-X1)*(X-X1)+(Y2-Y1)*(Y-Y1)+(Z2-Z1)*(Z-Z1)
      R0R2=(X2-X1)*(X-X2)+(Y2-Y1)*(Y-Y2)+(Z2-Z1)*(Z-Z2)
      COEF=GAMA/(4.0*PAY*SQUARE)*(R0R1/R1-R0R2/R2)
      U=R1R2X*COEF
      V=R1R2Y*COEF
      W=R1R2Z*COEF
      GOTO 2

C     WHEN POINT (X,Y,Z) LIES ON VORTEX ELEMENT; ITS INDUCED VELOCITY IS
 1    U=0.
      V=0.
      W=0.
 2    CONTINUE
      RETURN
      END

      SUBROUTINE WING(X,Y,Z,GAMA,U,V,W,ONOFF,I1,J1)
      DIMENSION GAMA(4,13),QF(6,14,3),A1(5,13)
      DIMENSION DS(4,13,4)
      COMMON/NO1/ DS
      COMMON/NO2/ IB,JB,CH,SIGN
      COMMON/NO3/ A1
      COMMON/NO4/ QF

C     CALCULATES INDUCED VELOCITY AT A POINT (X,Y,Z), DUE TO VORTICITY
C     DISTRIBUTION GAMA(I,J), OF SEMI-CONFIGURATION - IN A WING FIXED
C     COORDINATE SYSTEM.
      U=0
      V=0
      W=0
      IB1=IB+1
      DO 1 I=1,IB1
      DO 1 J=1,JB

C     I3 IS WAKE VORTEX COUNTER
      I3=I
      IF(I.EQ.IB1) I3=IB
      VORTIC=GAMA(I3,J)
      IF(ONOFF.LT.0.1) GOTO 2
      CALL VORTEX(X,Y,Z,QF(I,J,1),QF(I,J,2),QF(I,J,3),QF(I,J+1,1),QF(I,J
     1+1,2),QF(I,J+1,3),VORTIC,U1,V1,W1)
      CALL VORTEX(X,Y,Z,QF(I+1,J+1,1),QF(I+1,J+1,2),QF(I+1,J+1,3),
     3QF(I+1,J,1),QF(I+1,J,2),QF(I+1,J,3),VORTIC,U3,V3,W3)
 2    CALL VORTEX(X,Y,Z,QF(I,J+1,1),QF(I,J+1,2),QF(I,J+1,3),QF(I+1,J+1,1
     2),QF(I+1,J+1,2),QF(I+1,J+1,3),VORTIC,U2,V2,W2)
      CALL VORTEX(X,Y,Z,QF(I+1,J,1),QF(I+1,J,2),QF(I+1,J,3),QF(I,J,1),
     4QF(I,J,2),QF(I,J,3),VORTIC,U4,V4,W4)

      U0=U2+U4+(U1+U3)*ONOFF
      V0=V2+V4+(V1+V3)*ONOFF
      W0=W2+W4+(W1+W3)*ONOFF
      A1(I,J)=U0*DS(I1,J1,1)+V0*DS(I1,J1,2)+W0*DS(I1,J1,3)
      IF(SIGN.GE.1.0)
      * A1(I,J)=U0*DS(I1,J1,1)+V0*DS(I1,J1,2)-W0*DS(I1,J1,3)
      IF(I.EQ.IB1) A1(IB,J)=A1(IB,J)+A1(IB1,J)
      U=U+U0
      V=V+V0
      W=W+W0

 1    CONTINUE
      RETURN
      END


program ch1203
    ! Elemental Function Use
    implicit none

    real, dimension(1:5) :: x = [ 1., 2., 3., 4., 5. ]

    print *, 'sine of ', x, ' = ', sin(x)
end program


program create_lookup_table
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none
    integer, dimension(256) :: lookup_table
    character(len=1024) :: file_name, msg
    integer :: i, unit_nr, istat

    lookup_table = init_lookup_table()
    if (command_argument_count() /= 1) then
        write (unit=error_unit, fmt='(A)') 'error: expacting file name as argument'
        stop 1
    end if
    call get_command_argument(1, file_name)
    open (newunit=unit_nr, file=trim(file_name), status='replace', &
        access='sequential', form='formatted', iostat=istat, iomsg=msg)
    if (istat /= 0) then
        write (unit=error_unit, fmt='(2A)') 'error: ', trim(msg)
        stop 1
    end if
    do i = 1, 15
        write (unit=unit_nr, fmt='("        ", 16(I3, ","), " &")') &
            lookup_table((i - 1)*16 + 1:i*16)
    end do
    write (unit=unit_nr, fmt='("        ", 15(I3, ","))', advance='no') &
                lookup_table(15*16 + 1:16*16 - 1)
    write (unit=unit_nr, fmt='(I3, " &")') lookup_table(256)
    close (unit=unit_nr)

contains

    function init_lookup_table() result(lookup_table)
        implicit none
        integer, dimension(0:255) :: lookup_table
        integer :: i

        lookup_table(0) = 0
        do i = 1, 255
            lookup_table(i) = and(i, 1) + lookup_table(i/2)
        end do
    end function init_lookup_table

end program create_lookup_table


!*******************************************************************************
!> author: Jacob Williams
!
!  For caching function evaluations.

    module numdiff_cache_module

    use iso_fortran_env, only: ip => int64  ! same number of bits as real(wp)
    use numdiff_kinds_module
    use numdiff_utilities_module,   only: unique

    implicit none

    private

    type :: fx
        !! an [x,f(x)] cached pair.
        private
        real(wp),dimension(:),allocatable :: x    !! vector of input values
        real(wp),dimension(:),allocatable :: f    !! vector of output functions `f(x)`
                                                  !! note: only the elements indicated by `ifs`
                                                  !! will have valid values. The others will
                                                  !! be dummy values.
        integer,dimension(:),allocatable  :: ifs  !! elements of `f` present in the cache
                                                  !! (this is just an array of the indices
                                                  !! present in `f`)
    end type fx

    type,public :: function_cache
        !! a vector function cache.
        private
        integer :: n = 0 !! size of `x`
        integer :: m = 0 !! size of `f`
        type(fx),dimension(:),allocatable :: c  !! the cache of `f(x)`
        integer :: chunk_size = 100 !! for resizing vectors
                                    !! in the [[unique]] function
    contains
        private
        procedure,public :: initialize => initialize_cache
        procedure,public :: get        => get_from_cache
        procedure,public :: put        => put_in_cache
        procedure,public :: destroy    => destroy_cache
        procedure,public :: print      => print_cache
    end type function_cache

    contains
!*******************************************************************************

!*******************************************************************************
!>
!  Initialize the cache. Must be called first before use.

    subroutine initialize_cache(me,isize,n,m,chunk_size)

    implicit none

    class(function_cache),intent(inout) :: me
    integer,intent(in) :: isize !! the size of the hash table
    integer,intent(in) :: n     !! number of independant variables (x)
    integer,intent(in) :: m     !! number of functions (f)
    integer,intent(in),optional :: chunk_size  !! chunk size to speed up reallocation
                                               !! of arrays. A good value is a guess for
                                               !! the actual number of elements of `f` that
                                               !! will be saved per value of `x` [default is 100]

    call me%destroy()

    allocate(me%c(0:isize-1))
    me%n = n
    me%m = m

    if (present(chunk_size)) then
        me%chunk_size = chunk_size
    else
        me%chunk_size = 100
    end if

    end subroutine initialize_cache
!*******************************************************************************

!*******************************************************************************
!>
!  Print the contents of the cache. Used for debugging.

    subroutine print_cache(me,iunit)

    implicit none

    class(function_cache),intent(inout) :: me
    integer,intent(in) :: iunit !! file unit for writing
                                !! (assumed to be opened)

    integer :: i  !! counter

    write(iunit,'(A)') ''
    write(iunit,'(A)') '------------------------'
    if (allocated(me%c)) then
        do i = 1, size(me%c)
            if (allocated(me%c(i)%x)) then
                write(iunit,'(A)') ''
                write(iunit,'(A,1X,I10)') 'Entry ',i
                write(iunit,'(A,1X,*(F27.16,1X))') 'x  :', me%c(i)%x
                if (allocated(me%c(i)%f)) then
                    write(iunit,'(A,1X,*(I27,1X))')    'ifs:', me%c(i)%ifs
                    write(iunit,'(A,1X,*(F27.16,1X))') 'f  :', me%c(i)%f(me%c(i)%ifs)
                end if
                write(iunit,'(A)') '------------------------'
            end if
        end do
    else
        write(iunit,'(A)') 'Cache is not initialized'
        write(iunit,'(A)') '------------------------'
    end if
    write(iunit,'(A)') ''

    end subroutine print_cache
!*******************************************************************************

!*******************************************************************************
!>
!  Check if the `x` vector is in the cache, if so return `f`.
!  Note that only some of the elements may be present, so it will return
!  the ones there are there, and indicate which ones were found.

    subroutine get_from_cache(me,x,ifs,i,f,xfound,ffound)

    implicit none

    class(function_cache),intent(inout)      :: me
    real(wp),dimension(:),intent(in)         :: x      !! independant variable vector
    integer,dimension(:),intent(in)          :: ifs    !! elements of `f` needed
    integer,intent(out)                      :: i      !! index in the hash table
    real(wp),dimension(:),intent(out)        :: f      !! `f(x)` from the cache (if it was found)
    logical,intent(out)                      :: xfound !! if `x` was found in the cache
    logical,dimension(size(ifs)),intent(out) :: ffound !! which `ifs` were found in the cache

    integer :: j !! counter

    ! initialize:
    xfound = .false.
    ffound = .false.

    if (allocated(me%c)) then

        ! get index in the hash table:
        i = mod( abs(vector_djb_hash(x)), int(size(me%c),ip) )

        ! check the table:
        if (allocated(me%c(i)%x) .and. allocated(me%c(i)%f)) then
            if (size(me%c(i)%x)==size(x) .and. &
                size(me%c(i)%f)==size(f)) then
                if (all(me%c(i)%x==x)) then
                    xfound = .true.
                    ! return the elements that were found in the cache:
                    f(me%c(i)%ifs) = me%c(i)%f(me%c(i)%ifs)
                    ! what indices are in the cache?
                    do j = 1, size(ifs)
                        ffound(j) = any(ifs(j)==me%c(i)%ifs)
                    end do
                end if
            end if
        end if

    else
        error stop 'Error: the cache has not been initialized.'
    end if

    end subroutine get_from_cache
!*******************************************************************************

!*******************************************************************************
!>
!  Put a value into the cache.

    subroutine put_in_cache(me,i,x,f,ifs)

    implicit none

    class(function_cache),intent(inout) :: me
    integer,intent(in)                  :: i    !! index in the hash table
    real(wp),dimension(:),intent(in)    :: x    !! independant variable vector (dimension `n`)
    real(wp),dimension(:),intent(in)    :: f    !! function vector `f(x)` (dimension `m`)
    integer,dimension(:),intent(in)     :: ifs  !! elements of `f` to add (should all be `>0, <=m`)

    real(wp),parameter :: null = huge(1.0_wp) !! an unusual value to initialize arrays

    if (allocated(me%c)) then
        if (i<=size(me%c)) then

            if (allocated(me%c(i)%x)) then
                ! we need to check if there is an x already there,
                ! which may already have some function indices present.
                ! if same x, then add the new indices to them.
                ! if a different x, then replace indices.
                if (all(me%c(i)%x==x)) then
                    ! this x is already present in this location.
                    ! so merge the new f,ifs into what is already there.
                    if (allocated(me%c(i)%f)) then
                        me%c(i)%ifs = unique([me%c(i)%ifs,ifs],&
                                                chunk_size=me%chunk_size)
                    else
                        allocate(me%c(i)%f(me%m))
                        me%c(i)%f   = null ! initialize to an unusual value
                        me%c(i)%ifs = ifs
                    end if
                    me%c(i)%f(ifs) = f(ifs)
                else
                    ! replace existing x and f.
                    me%c(i)%x   = x
                    me%c(i)%ifs = ifs
                    if (allocated(me%c(i)%f)) deallocate(me%c(i)%f)
                    allocate(me%c(i)%f(me%m))
                    me%c(i)%f      = null ! initialize to an unusual value
                    me%c(i)%f(ifs) = f(ifs)
                end if
            else
                ! new entry in the cache:
                me%c(i)%x = x
                allocate(me%c(i)%f(me%m))
                me%c(i)%f      = null ! initialize to an unusual value
                me%c(i)%ifs    = ifs
                me%c(i)%f(ifs) = f(ifs)
            end if

        else
            error stop 'Error: invalid index in hash table.'
        end if
    else
        error stop 'Error: the cache has not been initialized.'
    end if

    end subroutine put_in_cache
!*******************************************************************************

!*******************************************************************************
!>
!  Destroy a cache.

    subroutine destroy_cache(me)

    implicit none

    class(function_cache),intent(out) :: me

    end subroutine destroy_cache
!*******************************************************************************

!*******************************************************************************
!>
!  DJB hash algorithm for a `real(wp)` vector.
!
!### See also
!  * J. Shahbazian, Fortran hashing algorithm, July 6, 2013
!   [Fortran Dev](https://fortrandev.wordpress.com/2013/07/06/fortran-hashing-algorithm/)

    pure function vector_djb_hash(r) result(hash)

    real(wp),dimension(:),intent(in) :: r     !! the vector
    integer(ip)                      :: hash  !! the hash value

    integer :: i !! counter

    hash = 5381_ip

    do i=1,size(r)
        hash = ishft(hash,5_ip) + hash + transfer(r(i),1_ip)
    end do

    end function vector_djb_hash
!*******************************************************************************

!*******************************************************************************
    end module numdiff_cache_module
!*******************************************************************************


! { dg-do run }
! { dg-require-effective-target fortran_large_int }

  integer(kind=16) :: i16

  i16 = -1
  if (leadz(i16) /= 0) STOP 1
  if (trailz(i16) /= 0) STOP 2
  if (leadz(-1_16) /= 0) STOP 3
  if (trailz(-1_16) /= 0) STOP 4

  i16 = -64
  if (leadz(i16) /= 0) STOP 5
  if (trailz(i16) /= 6) STOP 6
  if (leadz(-64_16) /= 0) STOP 7
  if (trailz(-64_16) /= 6) STOP 8

  i16 = -108
  if (leadz(i16) /= 0) STOP 9
  if (trailz(i16) /= 2) STOP 10
  if (leadz(-108_16) /= 0) STOP 11
  if (trailz(-108_16) /= 2) STOP 12

  i16 = 1
  if (leadz(i16) /= bit_size(i16) - 1) STOP 13
  if (trailz(i16) /= 0) STOP 14
  if (leadz(1_16) /= bit_size(1_16) - 1) STOP 15
  if (trailz(1_16) /= 0) STOP 16

  i16 = 64
  if (leadz(i16) /= 121) STOP 17
  if (trailz(i16) /= 6) STOP 18
  if (leadz(64_16) /= 121) STOP 19
  if (trailz(64_16) /= 6) STOP 20

end


module io_module

  implicit none

contains

  subroutine output(t, istep, U)

    use grid_module
    use runtime_params_module, only : gamma

    implicit none

    real(dp_t), intent(in) :: t
    integer, intent(in) :: istep
    real(dp_t), intent(in) :: U(a_lo:a_hi, NVAR)

    integer :: lun

    real(dp_t) :: vel, p
    integer :: i
    character(len=4) :: step

    write(step, fmt="(i0.4)") istep

    open(newunit=lun, file="out_"//step//".dat", status="unknown")

    do i = ilo, ihi
       vel = U(i, UMX)/U(i, URHO)
       p = (U(i, UENER) - 0.5_dp_t * U(i, URHO) * vel**2)*(gamma - 1.0_dp_t)

       write(lun, *) x(i), U(i, URHO), vel, p
    enddo

    close(unit=lun)

  end subroutine output

end module io_module


! { dg-do run }
! Test the fix for PR59198, where the field for the component 'term' in
! the derived type 'decay_gen_t' was not being built.
!
! Contributed by Paul Thomas and based on the original testcase by
! Juergen Reuter  <juergen.reuter@desy.de>
!
module decays

  implicit none

  interface
    real elemental function iface (arg)
      real, intent(in) :: arg
    end function
  end interface

  type :: decay_term_t
     type(decay_t), pointer :: unstable_product
     integer :: i
  end type

  type :: decay_gen_t
     procedure(iface), nopass, pointer :: obs1_int
     type(decay_term_t), allocatable :: term
  end type

  type :: rng_t
    integer :: i
  end type

  type, extends (decay_gen_t) :: decay_t
     class(rng_t), allocatable :: rng
  end type

  class(decay_t), allocatable :: object

end

  use decays
  type(decay_t), pointer :: template
  real, parameter :: arg = 1.570796327
  allocate (template)
  allocate (template%rng)
  template%obs1_int => cos
  if (abs (template%obs1_int (arg) - cos (arg)) .gt. 1e-4) STOP 1
  allocate (object, source = template)
  if (abs (object%obs1_int (arg) - cos (arg)) .gt. 1e-4) STOP 2
end


      double complex function A51ppppp(j1,j2,j3,j4,j5,za,zb)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      integer j1,j2,j3,j4,j5
      double complex asym,sym
      asym=+zb(j1,j2)*za(j2,j3)*zb(j3,j4)*za(j4,j1)
     &     -za(j1,j2)*zb(j2,j3)*za(j3,j4)*zb(j4,j1)
      sym=dcmplx(s(j1,j2)*s(j2,j3)+s(j2,j3)*s(j3,j4)
     &          +s(j3,j4)*s(j4,j5)+s(j4,j5)*s(j5,j1)+s(j5,j1)*s(j1,j2))

C----Eq.(4) of hep-ph/9302280v1 of BDK multiplied by 16*pi^2*(-i)*(-1)
C--- to give (16*pi^2)*(-i)*A^{[1/2]}_{5;1}
      A51ppppp=-(sym+asym)
     % /(6d0*za(j1,j2)*za(j2,j3)*za(j3,j4)*za(j4,j5)*za(j5,j1))
      return
      end


 SUBROUTINE fixrfd(xa)
 !***********************************************************************
 !
 !     updates configuration and factors of rotation-free dependant displacements
 !
 !***********************************************************************
 USE ctrl_db, ONLY : ndime
 USE kinc_db, ONLY : npsdf,nndpd,ftsdf
 USE npo_db,  ONLY : ifpre
 USE rfdp_db
 IMPLICIT NONE
 REAL (kind=8),INTENT(IN OUT) :: xa(:,:)

 INTEGER (kind=4) :: i,j,jj,k,l,m,sl
 REAL    (kind=8) :: ll,s,f1,f2,ld,t(ndime),n(ndime),x(ndime,6),xc(ndime),ls(3,2)
 REAL    (kind=8) :: g(ndime,3),tn(2,2),p(3,3),pa(3,3,2),nfd(6,3)
 TYPE (rfdp_nod), POINTER :: rfd
 INTEGER (kind=4), PARAMETER ::  &  !side element connectivities for triangles
           hh(2,3) = RESHAPE((/ 3,2, 1,3, 2,1 /), (/2,3/) )

 rfd => rfd_head       !point to first slave-master pair
 DO m=1,nrfdp          !loop for each pair
   sl = rfd%slave         !slave node

   IF( ndime == 2 )THEN   ! T W O  D I M E N S I O N A L   P R O B L E M S

     s  = rfd%rfpar(1)      !local coordinate
     ld = rfd%rfpar(2)      !original distance

     IF( planar ) THEN      ! 2 - NODE PLANAR APPROACH

       t = (xa(:,rfd%lnods(2)) - xa(:,rfd%lnods(1)))   !tangent vector between nodes (master)
       CALL vecuni(2,t,ll)                 ! ll : present length
       n = (/ -t(2),t(1) /)                !segment normal
       f1 = s                              !factor associated to first node
       f2 = 1d0-s                          !factor associated to second node
       xa(:,sl) = xa(:,rfd%lnods(1))*f1 + xa(:,rfd%lnods(2))*f2 + ld*n !updated slave coordinates
       ld = -ld/ll                         !factor
       tn = RESHAPE( (/ t(1)* n(1),  t(2)* n(1),  t(1)* n(2), t(2)* n(2)/),(/2,2/))*ld
       DO i=1,2  !for each slave DOF
         j  = -ifpre(i,sl)                 !position in the pointer array of first DOF
         k  = npsdf(j)                     !pointer to first DOF in ftsdf
         !new factors
         ftsdf(k)     =  - tn(i,1)
         ftsdf(k+1)   =  - tn(i,2)
         ftsdf(k+2)   =  + tn(i,1)
         ftsdf(k+3)   =  + tn(i,2)
         j = k+i-1
         ftsdf(j)   = ftsdf(j)   + f1
         ftsdf(j+2) = ftsdf(j+2) + f2
       END DO

     ELSE                 ! 3 - NODE CURVED APPROACH

       ls(1,1) = (s**2-s)/2d0                 !first local function
       ls(2,1) = (1d0-s**2)                   !second local function
       ls(3,1) = (s**2+s)/2d0                 !third local function
       ls(1,2) = s-5d-1                       !first local function derivative
       ls(2,2) = -2d0*s                       !second local function derivative
       ls(3,2) = s+5d-1                       !third local function derivative
       x(:,1:3) = xa(:,rfd%lnods)             !gather actual coordinates
       t = MATMUL(x(:,1:3),ls(:,2))           !tangent vector
       CALL vecuni(2,t,s)                     !unit tangent vector
       n = (/ -t(2),t(1) /)                   !nit normal vector
       xa(:,sl) = MATMUL(x(:,1:3),ls(:,1)) + ld*n  !updated slave coordinates
       ! compute proyection matrix
       tn = RESHAPE( (/ t(1)* n(1),  t(2)* n(1),  t(1)* n(2), t(2)* n(2)/),(/2,2/))*ld/s
       !COMPUTE new factors
       DO i=1,2  ! for each DOF
         k  = npsdf(-ifpre(i,sl))            !pointer to first DOF in ftsdf
         DO j=1,3                            !for each master node
           DO l=1,2                            !for each master DOF
             ftsdf(k) = - tn(i,l)*ls(j,2)      ! -t x n  N,xi
             IF( l == i ) ftsdf(k) = ftsdf(k) + ls(j,1) !include shape function
             k = k+1
           END DO
         END DO
       END DO
     END IF

   ELSE !  T H R E E   D I M E N S I O N A L   P R O B L E M S

     x(:,1:3) = xa(:,rfd%lnods(1:3))                 !3-node triangle coordinates
     ld = rfd%rfpar(3)                               !original distance

     IF( planar ) THEN  !  3-NODE PLANAR APPROACH

       xc(1:2) = rfd%rfpar(1:2)                      !local triangular coordinates
       xc(3) = 1d0 - xc(1) - xc(2)                   !third triangular coordinate
       DO i=1,3  !for each side
         g(1:3,i) = x(:,hh(1,i)) - x(:,hh(2,i))      ! lI
       END DO
       CALL vecpro(g(1,1),g(1,2),t(1))               ! t 2a
       CALL vecuni(3,t(1),ll)                        ! t  & ll=2A
       xa(:,sl) = MATMUL(x(:,1:3),xc) + ld*t         !update slave position
       ! compute side derivatives
       DO i=1,3
         CALL vecpro(g(1,i),t(1),p(1,i))             !normal direction times side length
       END DO
       ! compute slave factors for each node
       t = ld*t/ll                          ! d t /2A
       DO i=1,3                             !for each slave DOF
         jj = -ifpre(i,sl)                    !slave DOF order
         k  = npsdf(jj)                       !pointer to first slave DOFs
         DO j=1,3                             !for each master node
           DO l=1,3                             !for each DOF in the master node
             ftsdf(k) = p(i,j)*t(l)                   ! n,i t d /h
             IF( l == i ) ftsdf(k) = ftsdf(k) + xc(j) !include local coordinate
             k = k + 1                                !update master DOF
           END DO
         END DO
       END DO

     ELSE           ! 6-NODE CURVED APPROACH

       f1 = rfd%rfpar(1)       !xita
       f2 = rfd%rfpar(2)       !eta
       s  = 1d0 - f1 - f2      !zeta
       ! nodal functions and functions derivatives
       nfd(:,1) = (/s+f1*f2,f1+f2*s,f2+s*f1,s*(s-1d0)/2d0,f1*(f1-1d0)/2d0,f2*(f2-1d0)/2d0 /)
       nfd(:,2) = (/-1d0+f2, 1d0-f2,   s-f1,      -s+5d-1,        f1-5d-1,      0d0 /)
       nfd(:,3) = (/-1d0+f1,   s-f2, 1d0-f1,      -s+5d-1,            0d0,    f2-5d-1 /)
       ! get additional coordinates
       DO i=4,6
         j = i-3                                 !side
         k = rfd%lnods(i)                        !node
         IF( k > 0 )THEN                         !if side exist
           x(:,i) = xa(:,k)                           !additional node coordinates
         ELSE
           x(:,i) = 0d0                               !null coordinates
           nfd(j,:) = nfd(j,:) - nfd(i,:)             !include auxiliar node factors
           nfd(hh(1,j),:) = nfd(hh(1,j),:) + nfd(i,:) !in shape functions
           nfd(hh(2,j),:) = nfd(hh(2,j),:) + nfd(i,:) !and shape functions derivatives
           nfd(i,:) = 0d0                             !null node contribution
         END IF
       END DO

       g = MATMUL(x,nfd)                         !proyection and derivatives
       CALL vecpro(g(1,2),g(1,3),t(1))           !normal vector
       CALL vecuni(3,t(1),ll)                    !unit vector and twice the area
       xa(:,sl) = g(:,1) + ld*t                  !update slave node position

       ! compute proyection matrix 1 - t x t
       DO i=1,3
         DO j=1,3
           p(i,j) = -t(i)*t(j)
         END DO
         p(i,i) = p(i,i) + 1d0
       END DO
       p = p * ld/ll     ! d/2A (1- t x t)
       DO l=1,2          !compute curl matrices
         j = l+1         !correct pointer to derivatives
         pa(:,:,l) = RESHAPE((/ 0d0,g(3,j),-g(2,j),-g(3,j),0d0,g(1,j),g(2,j),-g(1,j),0d0 /),(/3,3/))
         pa(:,:,l) = MATMUL(p,pa(:,:,l))  !d/h (1 - t x t)*( X,xi x )
       END DO
       ! compute slave factors for each node
       DO i=1,3                                !for each slave DOF
         k  = npsdf(-ifpre(i,sl))              !pointer to first slave DOFs
         DO j=1,6                                !for each master node
           IF( rfd%lnods(j) <= 0 )CYCLE          !skip auxiliar nodes
           DO l=1,3                              !for each DOF in the master node
             ftsdf(k) = pa(i,l,1)*nfd(j,3) - pa(i,l,2)*nfd(j,2)  !normal variation
             IF( l == i ) ftsdf(k) = ftsdf(k) + nfd(j,1)         !include shape function
             k = k + 1
           END DO
         END DO
       END DO
     END IF
   END IF
   rfd => rfd%next                        !point to next pair
 END DO
 RETURN

 END SUBROUTINE fixrfd


C    @(#)abcd.f	20.3 2/13/96
        subroutine abcd (v,i,y)
C
C       This subroutine emulates the ABCD coefficients for a
C       section. It calculates v(2) and i(2) given v(1), i(1),
C       and y(*,*).
C
        double complex v(2), i(2), y(2,2)
        double complex v1, v2, i1, y11, y12, y21, y22

        v1 = dcmplx(dreal(v(1)) , dimag(v(1)))
        v2 = dcmplx(dreal(v(2)) , dimag(v(2)))
        i1 = dcmplx(dreal(i(1)) , dimag(i(1)))
        y11 = dcmplx(dreal(y(1,1)) , dimag(y(1,1)))
        y12 = dcmplx(dreal(y(1,2)) , dimag(y(1,2)))
        y21 = dcmplx(dreal(y(2,1)) , dimag(y(2,1)))
        y22 = dcmplx(dreal(y(2,2)) , dimag(y(2,2)))

        v(2) = ( i1 - y11 ) * v1 / y12
        i(2) = y21 * v1  +  y22 * v2

        return
        end