module mod_2d
  use,intrinsic :: iso_fortran_env
  use mod_wall_clock_time, only : wall_clock_time
  use mod_tests_jacobi_iteration_4_point_stencil
  use mod_tests_riemann_flux_roe
  !use mod_tests_metropolis_method_monte_carlo
  implicit none
  private
  public two_dimensional_tests

  contains
    !---
    subroutine two_dimensional_tests(nsize,nsize2,nloop,nloop2,ntrial,napara,nomp)
      integer(int32),intent(in) :: nsize,nsize2,nloop,nloop2,ntrial,napara,nomp

      integer(int32),parameter :: num_tests = 3
      integer(int32),parameter :: max_num_implementation = 5

      character(len=50),dimension(num_tests) :: testname
      ! test 1 : jacobi iteration (4 point stencil)
      real(real64),dimension(:,:),allocatable :: amatrix,bmatrix
      ! test 2 : riemann flux (roe's upwind flux)
      real(real64),dimension(:,:,:),allocatable :: primitives,flux_2d

      integer(int32) :: num_implementation
      character(len=50),dimension(:),allocatable :: implementation_name
      ! wall clock time
      real(real64),dimension(ntrial,max_num_implementation) :: wct_raw  ! wall clock time of each trial
      real(real64),dimension(max_num_implementation) :: wct_ave,wct_sgm ! average and sigma

      integer(int32) ::n,index

      !---parameters---
      print *,'# nsize( jacobi)',nsize
      print *,'# nloop( jacobi)',nloop
      print *,'# nsize(riemann)',nsize2
      print *,'# nloop(riemann)',nloop2
      print *,'# ntrial',ntrial

      ! test 1 : jacobi iteration (4 point stencil)
      print *,'### test 1 ###'
      index = 1
      testname(index) = 'jacobi iteration'
      print *,testname(index)
      num_implementation = 4
      allocate(implementation_name(num_implementation))
      implementation_name(1) ='sequential do'
      implementation_name(2) ='OpenMP do'
      implementation_name(3) ='do concurrent(single loop)'
      implementation_name(4) ='do concurrent(double loop)'

      allocate(amatrix(nsize,nsize),bmatrix(nsize,nsize))
      call random_number(amatrix)
      call random_number(bmatrix)
      wct_raw = 0.0d0;wct_ave=0.0d0;wct_sgm=0.0d0

      do n=1,ntrial
        call tests_jacobi(nsize,nloop,num_implementation,wct_raw(n,:),amatrix,bmatrix)
      end do
      do n=1,num_implementation
        call ave_and_sgm(ntrial,wct_raw(:,n),wct_ave(n),wct_sgm(n))
      end do

      call display(index,napara,nomp,num_implementation,implementation_name,wct_ave,wct_sgm,testname(index))
      deallocate(amatrix,bmatrix,implementation_name)

      ! test 2 : riemann problem
      print *,'### test 2 ###'
      index = 2
      testname(index) = 'riemann problem'
      print *,testname(index)
      num_implementation = 4
      allocate(implementation_name(num_implementation))
      implementation_name(1) ='sequential do'
      implementation_name(2) ='OpenMP do'
      implementation_name(3) ='do concurrent(single loop)'
      implementation_name(4) ='do concurrent(double loop)'

      allocate(primitives(4,nsize2,nsize2),flux_2d(4,nsize2,nsize2))
      call random_number(primitives)
      primitives = primitives+1.0d0
      wct_raw = 0.0d0;wct_ave=0.0d0;wct_sgm=0.0d0

      do n=1,ntrial
        call tests_riemann_flux_roe(nsize2,nloop2,num_implementation,wct_raw(n,:),primitives,flux_2d)
      end do
      do n=1,num_implementation
        call ave_and_sgm(ntrial,wct_raw(:,n),wct_ave(n),wct_sgm(n))
      end do

      call display(index,napara,nomp,num_implementation,implementation_name,wct_ave,wct_sgm,testname(index))
      deallocate(primitives,flux_2d,implementation_name)

    end subroutine two_dimensional_tests
    !---
    subroutine display(index,napara,nomp,nimp,impname,wct_ave,wct_sgm,testname)
      integer(int32),intent(in) :: index,napara,nomp,nimp
      real(real64),dimension(nimp),intent(inout) :: wct_ave(:),wct_sgm(:)
      character(len=50),intent(in) :: testname
      character(len=50),intent(in) :: impname(nimp)
      integer(int32) :: k
      real(real64) :: tmp
      character(len=50) :: filename

      write(filename,'(i3.3,".csv")') index
      open(11,file=filename)
      write(11,*) 'test_name',",",'implementation_name',",",'num_of_threads(auto-parallelize)',",",&
      &                             'num_of_threads(OpenMP)',",",'average[s]',",",'sigma[s]'
      ! data file
      do k=1,nimp
        write(11,*) &
        &     trim(testname),",",trim(impname(k)),",",napara,",",nomp,",",wct_ave(k),",",wct_sgm(k)
      end do
      close(11)

      ! display
      tmp = wct_ave(1)
      wct_ave(:) = wct_ave(:)/tmp
      wct_sgm(:) = wct_sgm(:)/tmp
      print *,'# ',testname
      print *,'# reference time[s]:',tmp
      do k=1,nimp
        write(output_unit,'(a20,f6.3,a3,f7.4)') trim(impname(k)),wct_ave(k),'+-',wct_sgm(k)
      end do
      write(output_unit,*)

    end subroutine display
    !---
    subroutine ave_and_sgm(n,raw,ave,sgm)
      integer(int32),intent(in) :: n
      real(real64),dimension(n),intent(in) :: raw
      real(real64),intent(out) :: ave,sgm
      integer(int32) :: i

      ave = sum(raw(1:n))/real(n,real64)
      sgm = 0.0d0
      do i=1,n
        sgm = sgm + (ave-raw(i))**2
      end do
      sgm = sqrt(sgm/real(n,real64))

      !print *,ave,sgm

    end subroutine ave_and_sgm
    !---
end module mod_2d


      subroutine SCKDER(MODE, M, N, X, FVEC, FJAC, LDFJAC,
     *                  TEST, IMAX, JMAX, TSTMAX)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SCKDER Krogh  Added external statement.
c>> 1994-10-20 SCKDER Krogh  Changes to use M77CON
c>> 1992-01-16 SCKDER CLL@JPL
c>> 1991-12-16 CLL@JPL
C  SCKDER checks a Jacobian matrix of first partial derivatives for
c  consistency with central finite differences of function values.
c
c     Usage:
c
c        Set X() to a trial N-vector.
c        Compute FJAC(,) as the MxN Jacobian matrix of partials of
c           FVEC with respect to X, evaluated at X().
c        MODE = 1
c     10 call SCKDER(MODE,...)
c        if(MODE .eq. 2) then
c           Compute FVEC() as an M-vector of function values
c              evaluated at X().
c           go to 10
c        endif
c        Here the process is completed.
c        Results are in IMAX, JMAX, TSTMAX, and TEST(,).
c     ------------------------------------------------------------------
C                         Subroutine Arguments
c
C  MODE [inout]  On initial entry set MODE = 1.
c       SCKDER will return a number of times with MODE = 2.  The calling
c       code should compute FVEC() as a function of X() and call SCKDER
c       again, not altering MODE.  When SCKDER is finished it returns
c       with MODE = 3.
c  M [in]  Number of terms in FVEC() and number of rows of data
c          in FJAC(,).
c  N [in]  Number of terms in X() and number of cloumns of data
c          in FJAC(,).
c  X() [inout]  Initially must contain the x-vector around which the
c          testing will be done.  Contains perturbed x-vectors on
c          returns with MODE = 2.  On final return with MODE = 3,
c          contains the original x-vector exactly restored.
c  FVEC() [in]  The user stores function values in FVEC().
c  FJAC(,) [in]  The user stores the Jacobian matrix in FVEC(,).
c  LDFJAC [in]  Declared first dimension of the arrays FJAC(,) and
c               TEST(,).  Require LDFJAC .ge. M.
c  TEST(,) [out]  Array with same dimensions as FJAC().
c     For each i = 1, ..., M, and j = 1, ..., N, SCKDER sets TEST(i,j)
c     to the signed difference: FJAC(i,j) minus a central finite-
c     difference approximation to the first partial derivative of
c     f sub i with respect to x sub j.
c  IMAX, JMAX [out]  I and J indices of the value in TEST(,) of
c               largest magnitude.
c  TSTMAX [out]  Magnitude of the value in TEST(,) of largest magnitude,
c               i.e., TSTMAX = abs(TEST(IMAX, JMAX))
c     ------------------------------------------------------------------
c  R1MACH(1) is the underflow limit.
c  R1MACH(4) is the machine precision.
c     ------------------------------------------------------------------
c--S replaces "?": ?CKDER
c     ------------------------------------------------------------------
      external R1MACH
      real             R1MACH
      integer I, IMAX, J, JMAX, LDFJAC, MODE, M, N
      real             ALPHA, DELX, EPS, FAC, FJAC(LDFJAC,N), FVEC(M)
      real             SMALL, TSTIJ, TEST(LDFJAC,N), TSTMAX, X(N), XJ
      logical PLUS
      save ALPHA, DELX, J, PLUS, SMALL, XJ
c     ------------------------------------------------------------------
      go to (10, 20), MODE
c                               ANSI Standard Fortran 77 comes here
c                               if MODE is not 1 or 2.
c
      call IERM1('SCKDER',1,0,'Require MODE = 1 or 2.','MODE',MODE,'.')
      return
c
   10 continue
      EPS = R1MACH(4)
      ALPHA = (3.0e0 * EPS)**0.333333e0
      SMALL = max(1.0e5 * R1MACH(1) / ALPHA, EPS*EPS)
      TSTMAX = 0.0e0
      IMAX = 0
      JMAX = 0
      MODE = 2
      J = 0
   15 continue
         J = J+1
         XJ = X(J)
         if(abs(XJ) .gt. SMALL) then
            DELX = ALPHA * XJ
         elseif(abs(XJ) .gt. 0.0e0) then
            DELX = ALPHA * SMALL
         else
            DELX = ALPHA
         endif
         X(J) = XJ + DELX
         PLUS = .true.
         return
c
c           Here we return to the user's code for computation of
c           FVEC() using X().  Execution will resume here.
c
   20    continue
         if(PLUS) then
c                         Using col N of TEST() to save FVEC()
c                         evaluated using XJ + DELX.
            do 30 I = 1,M
               TEST(I,N) = FVEC(I)
   30       continue
            X(J) = XJ - DELX
            PLUS = .false.
            return
c                  Returning again to the user's code for another
c                  evaluation of FVEC() using the perturbed X().
         endif
c
         FAC = 0.5e0 / DELX
         do 50 I = 1,M
            TSTIJ = FJAC(I,J) - FAC*(TEST(I,N) - FVEC(I))
            TEST(I,J) = TSTIJ
            if(abs(TSTIJ) .gt. TSTMAX) then
               TSTMAX = abs(TSTIJ)
               IMAX = I
               JMAX = J
            endif
   50    continue
c                                     Restore X(J)
         X(J) = XJ
      if(J .lt. N) go to 15
      MODE = 3
      return
      end


! MIT License
! Copyright (c) 2019 Sam Miller
! 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.

module mod_slope_limiter
  !< Summary: Define the various slope limiters
  !< Date: 05/07/2020
  !< Author: Sam Miller
  !< Notes: The slope limiters in the form listed below is based on [1] the slope (not flux)
  !<       limiters. Slope and flux limiters are very similar, but have some subtle differences.
  !<       See the reference for more info. The formulas are based on Eq 10.
  !< References:
  !<   [1] M. Berger, M. Aftosmis, S. Muman, "Analysis of Slope Limiters on Irregular Grids",
  !<       43rd AIAA Aerospace Sciences Meeting and Exhibit (2005), https://doi.org/10.2514/6.2005-490
  !<
  !<   [2] K.H. Kim, C. Kim, "Accurate, efficient and monotonic numerical methods for multi-dimensional compressible flows Part II: Multi-dimensional limiting process",
  !<       Journal of Computational Physics 208 (2005) 570–615, https://doi.org/10.1016/j.jcp.2005.02.022

  use, intrinsic :: iso_fortran_env, only: ik => int32, rk => real64
  use mod_floating_point_utils, only: equal
  use math_constants, only: pi

  implicit none

  private
  public :: slope_limiter_t

  type :: slope_limiter_t
    character(:), allocatable :: name
    procedure(limit), pointer, nopass :: limit => null()
  contains
    final :: finalize
  endtype

  ! These slope limiters are to be used in the form of the following:
  ! See [1], Eq 5.
  ! To compute the edge quantities:
  !
  !     q_{i+1/2} = q_i + 0.5 * phi(R)   * (q_{i+1} - q_{i-1}) / 2
  !     q_{i-1/2} = q_i - 0.5 * phi(1/R) * (q_{i+1} - q_{i-1}) / 2
  !
  !     The relationship between flux (psi(R)) and slope (phi(R)) limiters is the following:
  !     psi(R) = phi(R)((R+1)/2)
  !
  !     phi(R): the slope limiters given in this module
  !     q_i: primitive cell-averaged quantity
  !     q_{i+1/2}: quantity at the cell interface
  !     R = (q_{i+1} - q_i) / (q_i - q_{i-1}); difference ratio, e.g. smoothness indicator
  !
  ! A symmetric form, using "f" instead of R can also be used, where
  ! f is defined as f = (q_{i} - q_{i-1}) / (q_{i+1} - q_{i})

  interface slope_limiter_t
    module procedure constructor
  endinterface

  interface
    real(rk) function limit(R) result(phi_lim)
      import :: rk
      real(rk), intent(in) :: R
    endfunction
  endinterface

contains

  type(slope_limiter_t) function constructor(name, use_symmetric_form) result(limiter)
    !< Slope limiter factory/constructor
    character(len=*), intent(in) :: name
    logical, optional, intent(in) :: use_symmetric_form !< use the f form?
    logical :: use_sym_form

    use_sym_form = .false.

    if(present(use_symmetric_form)) then
      use_sym_form = use_symmetric_form
    endif

    limiter%name = trim(name)

    if(use_sym_form) then
      select case(trim(name))
      case('none')
        write(*, '(a)') "Selecting 'none' as the slope limiter"
        limiter%limit => none
      case('barth_jesperson')
        write(*, '(a)') "Selecting 'barth_jesperson_sym_form' as the slope limiter"
        limiter%limit => barth_jespersen_sym_form
      case('minmod')
        write(*, '(a)') "Selecting 'minmod_sym_form' as the slope limiter"
        limiter%limit => minmod_sym_form
      case('van_leer')
        write(*, '(a)') "Selecting 'van_leer_sym_form' as the slope limiter"
        limiter%limit => van_leer_sym_form
      case default
        error stop "Error in slope_limiter_t%constructor(): Unknown slope limiter name"
      endselect
    else
      select case(trim(name))
      case('none')
        write(*, '(a)') "Selecting 'none' as the slope limiter"
        limiter%limit => none
      case('barth_jesperson')
        write(*, '(a)') "Selecting 'barth_jespersen' as the slope limiter"
        limiter%limit => barth_jespersen
      case('minmod')
        write(*, '(a)') "Selecting 'minmod' as the slope limiter"
        limiter%limit => minmod
      case('van_leer')
        write(*, '(a)') "Selecting 'van_leer' as the slope limiter"
        limiter%limit => van_leer
      case default
        error stop "Error in slope_limiter_t%constructor(): Unknown symmetric slope limiter name"
      endselect
    endif

  endfunction

  subroutine finalize(self)
    type(slope_limiter_t), intent(inout) :: self
    if(associated(self%limit)) nullify(self%limit)
    if(allocated(self%name)) deallocate(self%name)
  endsubroutine finalize

  pure real(rk) function none(R) result(phi_lim)
    !< Unlimited slope
    real(rk), intent(in) :: R !< R  = (u_{i+1} - u_i) / (u_i - u_{i-1})
    phi_lim = 1.0_rk
  endfunction none

  pure real(rk) function barth_jespersen(R) result(phi_lim)
    !< Barth Jesperson slope limiter. See Eq. 8 in [1]
    real(rk), intent(in) :: R !< smoothness indicator

    if(R < 0.0_rk) then
      phi_lim = 0.0_rk
    else
      phi_lim = min(1.0_rk, 4.0_rk / (R + 1.0_rk),(4.0_rk * R) / (R + 1.0_rk))
    endif
  endfunction barth_jespersen

  pure real(rk) function van_leer(R) result(phi_lim)
    !< van Leer slope limiter. See Eq. 8 in [1]
    real(rk), intent(in) :: R !< smoothness indicator

    if(R < 0.0_rk) then
      phi_lim = 0.0_rk
    else
      phi_lim = 4.0_rk * R / (R + 1.0_rk)**2
    endif
  endfunction van_leer

  pure real(rk) function minmod(R) result(phi_lim)
    !< Min-mod slope limiter. See Eq. 8 in [1]
    real(rk), intent(in) :: R !< smoothness indicator

    if(R < 0.0_rk) then
      phi_lim = 0.0_rk
    else
      phi_lim = min(2.0_rk / (1.0_rk + R),(2.0_rk * R) / (1.0_rk + R))
    endif
  endfunction minmod

  pure real(rk) function barth_jespersen_sym_form(f) result(phi_lim)
    !< Barth Jesperson slope limiter. See Eq. 8 in [1]
    real(rk), intent(in) :: f !< symmetric smoothness indicator

    phi_lim = min(1.0_rk, 4.0_rk * f, 4.0_rk * (1.0_rk - f))
  endfunction barth_jespersen_sym_form

  pure real(rk) function van_leer_sym_form(f) result(phi_lim)
    !< van Leer slope limiter. See Eq. 8 in [1]
    real(rk), intent(in) :: f !< symmetric smoothness indicator

    phi_lim = 4.0_rk * f * (1.0_rk - f)
  endfunction van_leer_sym_form

  pure real(rk) function minmod_sym_form(f) result(phi_lim)
    !< Min-mod slope limiter. See Eq. 8 in [1]
    real(rk), intent(in) :: f !< symmetric smoothness indicator

    phi_lim = min(2.0_rk * f, 2.0_rk * (1.0_rk - f))
  endfunction minmod_sym_form
endmodule mod_slope_limiter


        subroutine iddr_rsvd0(m,n,matvect,p1t,p2t,p3t,p4t,
     1                        matvec,p1,p2,p3,p4,krank,u,v,s,ier,
     2                        list,proj,col,work)
c
c       routine iddr_rsvd serves as a memory wrapper
c       for the present routine (please see routine iddr_rsvd
c       for further documentation).
c
        implicit none
        integer m,n,krank,list(n),ier,k
        real*8 p1t,p2t,p3t,p4t,p1,p2,p3,p4,u(m,krank),v(n,krank),
     1         s(krank),proj(krank*(n-krank)),col(m*krank),
     2         work((krank+1)*(m+3*n)+26*krank**2)
        external matvect,matvec
c
c
c       ID a.
c
        call iddr_rid(m,n,matvect,p1t,p2t,p3t,p4t,krank,list,work)
c
c
c       Retrieve proj from work.
c
        do k = 1,krank*(n-krank)
          proj(k) = work(k)
        enddo ! k
c
c
c       Collect together the columns of a indexed by list into col.
c
        call idd_getcols(m,n,matvec,p1,p2,p3,p4,krank,list,col,work)
c
c
c       Convert the ID to an SVD.
c
        call idd_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work)
c
c
        return
        end


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   ext :    Spurious solutions to a boundary value problem
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION P,S,PI,Q

       P= U(1) + U(1)**2 + U(1)**3
       S=SIN(P)
       PI=4*ATAN(1.d0)
       Q=(PAR(1)*PI)**2

       F(1)=U(2)
       F(2)=-Q*S

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

       PAR(1)=0.d0

       U(1)=0.d0
       U(2)=0.d0

      END SUBROUTINE STPNT

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

       FB(1)=U0(1)
       FB(2)=U1(1)

      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


program subroutines_02
implicit none
integer :: i, j
i = 1
j = 1
call f(i, j)
if (i /= 1) error stop
if (j /= 2) error stop

call g(i, j)
if (i /= 1) error stop
if (j /= 0) error stop

call h(i, j)
if (i /= 1) error stop
if (j /= 0) error stop

contains

    subroutine f(a, b)
    integer, intent(in) :: a
    integer, intent(out) :: b
    b = a + 1
    end subroutine

    subroutine g(a, b)
    integer, intent(in) :: a
    integer, intent(out) :: b
    b = a - 1
    end subroutine

    subroutine h(a, b)
    integer, intent(in) :: a
    integer, intent(out) :: b
    call g(a, b)
    end subroutine

end program


      SUBROUTINE J1CAL(J1,SUM,YYDB,BDYMI,ISO)
C
C     'J1CAL' CALCULATES THE TOTAL MOMENT OF INERTIA OF THE SATELLITE IN
C     THE BODY FRAME
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 ISO(3,3),J1(3,3)
C
      DIMENSION SUM(6),YYDB(3,3),BDYMI(3,3)
C
C
      ISO(1,1)=BDYMI(1,1) + SUM(1) + YYDB(2,2) + YYDB(3,3)
      ISO(2,2)=BDYMI(2,2) + SUM(2) + YYDB(1,1) + YYDB(3,3)
      ISO(3,3)=BDYMI(3,3) + SUM(3) + YYDB(1,1) + YYDB(2,2)
C
      ISO(1,2)=BDYMI(1,2) + SUM(4) + YYDB(1,2)
      ISO(1,3)=BDYMI(1,3) + SUM(5) + YYDB(1,3)
      ISO(2,3)=BDYMI(2,3) + SUM(6) + YYDB(2,3)
C
      ISO(2,1)=ISO(1,2)
      ISO(3,1)=ISO(1,3)
      ISO(3,2)=ISO(2,3)
C
      DO 10 I=1,3
      J1(I,I)=ISO(I,I)
      DO 10 J=1,3
   10 IF(I.NE.J) J1(I,J)=-ISO(I,J)
      RETURN
      END


      subroutine DoubleDot(A, B, res)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C**********************************************************************
!     Computes the tensor product of two tensors A and B
!     res = A:B
!
!     Author : Sai Rapaka
!
      implicit none
      real*8, dimension(6)         :: A, B
      real*8                       :: res

      res = sum(A(1:3)*B(1:3)) + 2.0d0*sum(A(4:6)*B(4:6))

      end subroutine DoubleDot


MODULE Leafnumbermod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_leafnumber(deltaTT, &
        phyllochron_t1, &
        hasFlagLeafLiguleAppeared, &
        leafNumber_t1, &
        phase, &
        leafNumber)
        IMPLICIT NONE
        REAL, INTENT(IN) :: deltaTT
        REAL, INTENT(IN) :: phyllochron_t1
        INTEGER, INTENT(IN) :: hasFlagLeafLiguleAppeared
        REAL, INTENT(IN) :: leafNumber_t1
        REAL, INTENT(IN) :: phase
        REAL, INTENT(OUT) :: leafNumber
        REAL:: phyllochron_
        !- Description:
    !            * Title: CalculateLeafNumber Model
    !            * Author: Pierre MARTRE
    !            * Reference: Modeling development phase in the
    !                Wheat Simulation Model SiriusQuality.
    !                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    !            * Institution: INRA Montpellier
    !            * Abstract: calculate leaf number. LeafNumber increase is caped at one more leaf per day
        !- inputs:
    !            * name: deltaTT
    !                          ** description : daily delta TT
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** min : -20
    !                          ** max : 100
    !                          ** default : 23.5895677277199
    !                          ** unit : °C d
    !                          ** inputtype : variable
    !            * name: phyllochron_t1
    !                          ** description : phyllochron
    !                          ** variablecategory : state
    !                          ** inputtype : variable
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 1000
    !                          ** default : 0
    !                          ** unit : °C d leaf-1
    !            * name: hasFlagLeafLiguleAppeared
    !                          ** description : true if flag leaf has appeared (leafnumber reached finalLeafNumber)
    !                          ** variablecategory : state
    !                          ** datatype : INT
    !                          ** min : 0
    !                          ** max : 1
    !                          ** default : 0
    !                          ** unit :
    !                          ** inputtype : variable
    !            * name: leafNumber_t1
    !                          ** description :  Actual number of phytomers
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 25
    !                          ** default : 0
    !                          ** unit : leaf
    !                          ** inputtype : variable
    !            * name: phase
    !                          ** description :  the name of the phase
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 7
    !                          ** default : 1
    !                          ** unit :
    !                          ** uri : some url
    !                          ** inputtype : variable
        !- outputs:
    !            * name: leafNumber
    !                          ** description : Actual number of phytomers
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** min : 0
    !                          ** max : 10000
    !                          ** unit : leaf
    !                          ** uri : some url
        leafNumber = leafNumber_t1
        IF(phase .GE. 1.0 .AND. phase .LT. 4.0) THEN
            IF(hasFlagLeafLiguleAppeared .EQ. 0) THEN
                IF(phyllochron_t1 .EQ. 0.0) THEN
                    phyllochron_ = 0.0000001
                ELSE
                    phyllochron_ = phyllochron_t1
                END IF
                leafNumber = leafNumber_t1 + min(deltaTT / phyllochron_, 0.999)
            END IF
        END IF
    END SUBROUTINE model_leafnumber

END MODULE


      SUBROUTINE CFNOR1 (RIGHT,LEFT,SIZE2,OPTION,RI)
C
C     CFNOR1 IS A SINGLE-PRECISION ROUTINE (CREATED FOR USE BY
C     THE COMPLEX FEER METHOD) WHICH NORMALIZES A COMPLEX PAIR
C     OF VECTORS TO MAGNITUDE UNITY
C
C     DEFINITION OF INPUT PARAMETERS
C
C     RIGHT    = ORIGINAL RIGHT-HANDED COMPLEX SINGLE PRECISION VECTOR
C     LEFT     = ORIGINAL LEFT -HANDED COMPLEX SINGLE PRECISION VECTOR
C     SIZE2    = LENGTH OF EITHER VECTOR IN SINGLE PRECISION WORDS
C                (I.E., TWICE THE LENGTH OF THE COMPLEX VECTORS)
C     OPTION   = 0  NORMALIZE THE INPUT VECTORS, AND OUTPUT THE
C                   SQUARE ROOT OF THE INNER PRODUCT IN RI(2)
C              = 1  ONLY OUTPUT INNER-PRODUCT, IN RI(2)
C              = 2  ONLY OUTPUT SQUARE ROOT OF INNER-PRODUCT, IN RI(2)
C
C     DEFINITION OF OUTPUT PARAMETERS
C
C     RIGHT    = NORMALIZED RIGHT-HANDED VECTOR
C     LEFT     = NORMALIZED LEFT -HANDED VECTOR
C     RI       = INNER-PRODUCT, OR SQUARE ROOT OF INNER-PRODUCT (SEE
C                OPTION)
C
      LOGICAL         SKIP     ,QPR
      INTEGER         SIZE2    ,OPTION
      REAL            LEFT
      DIMENSION       RIGHT(1) ,LEFT(1)  ,RI(2)    ,RJ(2)
      CHARACTER       UFM*23   ,UWM*25
      COMMON /XMSSG / UFM,UWM
      COMMON /FEERXC/ DUMXC(21),QPR
      COMMON /SYSTEM/ KSYSTM(65)
      EQUIVALENCE     (KSYSTM(2),NOUT)
C
      SKIP = .FALSE.
C
C     COMPUTE INNER PRODUCT (LEFT*RIGHT)
C
    5 RI(1) = 0.
      RI(2) = 0.
      DO 10 I = 1,SIZE2,2
      J = I + 1
      RI(1) = RI(1) + LEFT(I)*RIGHT(I) - LEFT(J)*RIGHT(J)
   10 RI(2) = RI(2) + LEFT(J)*RIGHT(I) + LEFT(I)*RIGHT(J)
      IF (OPTION .EQ. 1) GO TO 50
      IF (SKIP) GO TO 200
C
C     COMPUTE MAGNITUDE OF SQUARE ROOT
C
      RSQRT = SQRT(SQRT(RI(1)**2+RI(2)**2))
      IF (RSQRT .GT. 0.) GO TO 30
      WRITE  (NOUT,20) UWM
   20 FORMAT (A25,' 3162', //5X,'ATTEMPT TO NORMALIZE NULL VECTOR. ',
     1       'NO ACTION TAKEN.'//)
      GO TO 50
C
C     COMPUTE MODULUS OF SQUARE ROOT
C
   30 THETA2 = .5*ATAN2(RI(2),RI(1))
C
C     COMPUTE REAL AND IMAGINARY PARTS OF SQUARE ROOT OF INNER PRODUCT
C
      RI(1) = RSQRT*COS(THETA2)
      RI(2) = RSQRT*SIN(THETA2)
      IF (OPTION .EQ. 2) GO TO 50
      RJ(1) = RI(1)
      RJ(2) = RI(2)
C
C     INVERT THE ABOVE COMPLEX NUMBER (THETA2 IS DUMMY)
C
      THETA2= 1./(RI(1)**2+RI(2)**2)
      RI(1) = RI(1)*THETA2
      RI(2) =-RI(2)*THETA2
C
C     NORMALIZE THE INPUT VECTORS
C
      DO 40 I = 1,SIZE2,2
      J = I + 1
      THETA2   = RIGHT(I)
      RIGHT(I) = RI(1)*RIGHT(I) - RI(2)*RIGHT(J)
      RIGHT(J) = RI(2)*THETA2   + RI(1)*RIGHT(J)
      THETA2   = LEFT(I)
      LEFT(I)  = RI(1)*LEFT(I) - RI(2)*LEFT(J)
   40 LEFT(J)  = RI(2)*THETA2  + RI(1)*LEFT(J)
C
C     ----------- SPECIAL PRINT ----------------------------------------
      IF (.NOT.QPR) GO TO 45
      SKIP = .TRUE.
      GO TO 5
  200 THETA2 = SQRT(RI(1)**2 + RI(2)**2)
      WRITE  (NOUT,300) THETA2,RI
  300 FORMAT (3H --,32(4H----), /,7H CFNOR1,6X,
     1       16HOUTPUT MAGNITUDE,E16.8,8X,2E16.8, /,3H --,32(4H----))
      WRITE  (NOUT,400) (RIGHT(I),I=1,SIZE2)
  400 FORMAT ((1H ,4E25.16))
      WRITE  (NOUT,500)
  500 FORMAT (3H --,32(4H----))
      WRITE  (NOUT,400) (LEFT(I),I=1,SIZE2)
      WRITE  (NOUT,500)
C     ------------------------------------------------------------------
C
   45 RI(1) = RJ(1)
      RI(2) = RJ(2)
   50 RETURN
      END


program hugeKind
    implicit none;

    !Kind set the  size of data type in bytes ex : kind = 1,2,4,8,16,32....
    integer :: i1;
    integer(kind = 1) :: i2; ! i1 will be of 1 byte so its range is upto 128 i.e. 0-127
    integer(kind = 2) :: i3;
    integer(kind = 4) :: i4;
    integer(kind = 8) :: i5;
    integer(kind = 16) ::i6;

    integer x;
    real r;
    character ch;
    character (len = 20) str;

    !huge() function gives the largest number that can be held by the specific integer data type.
    print *, "deault, huge(i1) : ", huge(i1);
    print *, "kind  = 1 ,huge(i2) : ", huge(i2);
    print *, "kind  = 2 ,huge(i3) : ", huge(i3);
    print *, "kind  = 4 ,huge(i4) : ", huge(i4);
    print *, "kind  = 8 ,huge(i5) : ", huge(i5);
    print *, "kind  = 16 ,huge(i6) : ", huge(i6);

    !The intrinsic function kind() allows you to query the details of the hardware’s data representations before running a program.
    ! for more info ref: https://www.tutorialspoint.com/fortran/fortran_numbers.htm
    print *, "kind(x) = ", kind(x);
    print *, "kind(r) = ", kind(r);
    print *, "kind(ch) = ", kind(ch);
    print *, "kind(str) = ", kind(str); ! why its prints only 1 bytes ...?

end program hugeKind


c=======================================================================
c
c     QNBFGS
c
c     Quasi-Newton optimizer with BFGS method
c
c     Let f(.) a multidimentional function.
c
c     Algorithm: x[i+1] = x[i] - inv(Hi)*Grad(f(x[i]))
c
c     Hi approximation of the Hesssian matrix of f(x)
c     limit (i->+oo) Hi = True Hessian matrix
c
c-------------------------------------------------------------------------
      SUBROUTINE qnbfgs (simul, simext, n, x, f, g, dxmin, df1, epsabs,
     & imp, io, mode, iter, nsim, binf, bsup, iz, rz, izs, rzs, dzs)
c-------------------------------------------------------------------------
c
c     CALL:
c     n2qn1a, fmc11z, fajc1, fretc1, fmani1, fcomp1, fmlag1
c     nlis0, fcube, fuclid, fmc11a, fmc11b, fmc11e, nqhess, f1qhes, f2qhes
c
c-------------------------------------------------------------------------
c
      IMPLICIT DOUBLE PRECISION (a-h, o-z)
      DIMENSION x(n), g(n), dxmin(n), bsup(n), binf(n)
      DIMENSION iz(*), rz(*), izs(*), dzs(*)
      REAL rzs(*)
c
      EXTERNAL simul, simext
      DOUBLE PRECISION gpmopt
c
      IF (imp .ne. 0) THEN
          nw = n*(9 + n)/2
          ni = 2*n + 1
          WRITE (io,1000) n,mode,iter,nsim,imp,df1,epsabs,ni,nw
      ENDIF
 1000 FORMAT (/" N2QN1 : point d'entree"/
     &    5x,"dimension du probleme (n):",i10/
     &    5x,"mode d'entree (mode):     ",i10/
     &    5x,"max iterations (iter):    ",i10/
     &    5x,"max simulation (nsim):    ",i10/
     &    5x,"niveau d'impression (imp):",i10/
     &    5x,"decroissancve attendue de f (df1):",1pd9.2/
     &    5x,"precision absolue (epsabs):       ",1pd9.2/
     &    /" Espace de travail:"/
     &    5x,"entiers:", i6/
     &    5x,"reels:  ", i6)
      IF (n .le. 0
     &  .or. (mode.eq.1 .and. df1.le.0.d0)
     &  .or. epsabs.lt.0.d0
     &  .or. imp.lt.0 .or. imp.gt.5
     &  .or. mode.lt.1 .or. mode.gt.4
     &  .or. iter.le.0
     &  .or. nsim.le.0) THEN
          WRITE (io,1001)
          mode=2
          RETURN
      ENDIF
 1001 FORMAT (/" >>> m2qn1: appel incoherent (n, df1, epsabs, imp,",
     &         " mode, iter ou nsim)"/)
      do i=1,n
          if (dxmin(i).le.0.d0
     &      .or. x(i).lt.binf(i)
     &      .or. x(i).gt.bsup(i)) then
              write (io,1002) i
              mode=2
              return
          endif
      enddo
c
 1002 FORMAT (/" >>> n2qn1: borne(s) sur variable ",i4,
     &         " incoherente(s)"/)
c
      nd     = 1 + (n*(n+1))/2
      nww    = nd + n
      nww1   = nww + n
      nga    = nww1 + n
      nindi  = 1
      nibloc = nindi+n
      ni     = nibloc+n
      s      = 0.d0
c
      DO 110 i=1,n
  110 s      = s + dxmin(i)*dxmin(i)
      epsabs = epsabs*dsqrt(s/dble(float(n)))
c
c     N2QN1A function call
      CALL n2qn1a (simul,simext,n,x,f,g,dxmin,epsabs,df1,mode,
     & iter,nsim,imp,io,rz,rz(nd),rz(nww),rz(nww1),
     & rz(nga),binf,bsup,iz(nindi),iz(nibloc),iz(ni),
     & izs,rzs,dzs)
c
      IF (imp.ge.2) WRITE(io,1003)
 1003 FORMAT (/1x,79("-"))
      IF (imp.ge.1) WRITE(io,1004) mode,iter,nsim,epsabs,gpmopt
 1004 FORMAT (" N2QN1: sortie en mode ",i2/
     &     5x,"nombre d'iterations   = ",i4/
     &     5x,"nombre de simulations = ",i4/
     &     5x,"|gradient projete| moyen       = ",1pd10.3/
     &     5x,"|gradient_dxmin projete| moyen = ",1pd10.3)
      IF (imp.ge.1) WRITE(io,1005) (i,iz(nibloc+i-1),i=1,n)
 1005 FORMAT (5x,"bornes",
     &    " (0: inactive, -1: binf active, +1: bsup active)",/
     &    (10x,"| ",5(i5,": ",i2," |")))
      RETURN
      END


!------------------------------------------------------------------------------
! MODULE: math
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
! @description:
!> Module containing recurring math options
!------------------------------------------------------------------------------
MODULE math

USE ISO_FORTRAN_ENV
USE global_std
USE strings

IMPLICIT NONE

REAL(KIND=rk), PARAMETER :: num_zero   = 1.E-9
REAL(KIND=rk), PARAMETER :: sq2        = sqrt(2._rk)
REAL(KIND=rk), PARAMETER :: pi         = 4.D0*DATAN(1.D0)       !acos(-1._rk)
REAL(KIND=rk), PARAMETER :: pihalf     = 4.D0*DATAN(1.D0)/2._rk !acos(-1._rk)
REAL(KIND=rk), PARAMETER :: inv180     = 1._rk/180._rk
REAL(KIND=rk), PARAMETER :: pi_div_180 = acos(-1._rk)/180._rk   ! * deg = rad

!-- Higher dimensional numbers
TYPE quaternion
   REAL (KIND=rk) :: w,x,y,z
END TYPE quaternion

INTERFACE zero_thres
   MODULE PROCEDURE zerothres_num
   MODULE PROCEDURE zerothres_OnD
   MODULE PROCEDURE zerothres_TwD
   MODULE PROCEDURE zerothres_ThD
END INTERFACE zero_thres

CONTAINS

!------------------------------------------------------------------------------
! SUBROUTINE: transpose_mat
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Spatially transpose a R6x6 matrix (2nd rank tensor).
!
!> @param[in] tensor_in Input tensor
!> @param[in] pos_in Requested combination of euler angles.
!> @param[out] tensor_out Output tensor
!------------------------------------------------------------------------------
SUBROUTINE transpose_mat (tensor_in, pos_in, tensor_out)

     REAL(KIND=rk), DIMENSION(6,6), INTENT(IN)  :: tensor_in
     REAL(KIND=rk), DIMENSION(3)  , INTENT(IN)  :: pos_in
     REAL(KIND=rk), DIMENSION(6,6), INTENT(OUT) :: tensor_out

     REAL(KIND=rk)                 :: alpha, phi, eta
     REAL(KIND=rk), DIMENSION(3)   :: n
     REAL(KIND=rk), DIMENSION(3,3) :: aa
     REAL(KIND=rk), DIMENSION(6,6) :: BB

     !------------------------------------------------------------------------------
     !  Degrees as input, radian as output to sin/cos
     !------------------------------------------------------------------------------
     alpha = REAL(pos_in(1)) * pi / 180._rk
     phi   = REAL(pos_in(2)) * pi / 180._rk
     eta   = REAL(pos_in(3)) * pi / 180._rk

     n = [ COS(phi)*SIN(eta), SIN(phi)*SIN(eta), COS(eta) ]

     n = n / SQRT(SUM(n*n))

     aa = rot_alg(n, alpha)

     BB = tra_R6(aa)

     tensor_out = MATMUL(MATMUL(TRANSPOSE(BB), tensor_in), BB)

END SUBROUTINE transpose_mat

!------------------------------------------------------------------------------
! FUNCTION: rot_x
!------------------------------------------------------------------------------
!> @author Ralf Schneider - HLRS - NUM - schneider@hlrs.de
!
!> @param[in] angle Angle
!> @return[out] aa Output transformation matrix
!------------------------------------------------------------------------------
Function rot_x(angle) Result(aa)

    Real(kind=rk), intent(in) :: angle
    Real(kind=rk), Dimension(3,3) :: aa

    aa(1,:) = [ 1._rk ,   0._rk    ,   0._rk     ]
    aa(2,:) = [ 0._rk , cos(angle) , -sin(angle) ]
    aa(3,:) = [ 0._rk , sin(angle) ,  cos(angle) ]

End Function rot_x

!------------------------------------------------------------------------------
! FUNCTION: rot_y
!------------------------------------------------------------------------------
!> @author Ralf Schneider - HLRS - NUM - schneider@hlrs.de
!
!> @param[in] angle Angle
!> @return[out] aa Output transformation matrix
!------------------------------------------------------------------------------
Function rot_y(angle) Result(aa)

    Real(kind=rk), intent(in) :: angle
    Real(kind=rk), Dimension(3,3) :: aa

    aa(1,:) = [ cos(angle), 0._rk,  sin(angle) ]
    aa(2,:) = [   0._rk   , 1._rk,   0._rk     ]
    aa(3,:) = [-sin(angle), 0._rk,  cos(angle) ]

End Function rot_y

!------------------------------------------------------------------------------
! FUNCTION: rot_z
!------------------------------------------------------------------------------
!> @author Ralf Schneider - HLRS - NUM - schneider@hlrs.de
!
!> @param[in] angle Angle
!> @return[out] aa Output transformation matrix
!------------------------------------------------------------------------------
Function rot_z(angle) Result(aa)

    Real(kind=rk), intent(in) :: angle
    Real(kind=rk), Dimension(3,3) :: aa

    aa(1,:) = [ cos(angle), -sin(angle), 0._rk ]
    aa(2,:) = [ sin(angle),  cos(angle), 0._rk ]
    aa(3,:) = [   0._rk   ,   0._rk    , 1._rk ]

End Function rot_z

!------------------------------------------------------------------------------
! FUNCTION: rot_alg
!------------------------------------------------------------------------------
!> @author Ralf Schneider - HLRS - NUM - schneider@hlrs.de
!
!> last edited : on  05.03.2009
!
!> @param[in]  axis Axis
!> @param[in]  angle Angle
!> @return[out] rr Output transformation matrix
!------------------------------------------------------------------------------
Function rot_alg(axis, angle) Result(rr)

    real(kind=rk), dimension(3), Intent(In) :: axis
    real(kind=rk)              , Intent(In) :: angle
    real(kind=rk), dimension(3, 3) :: rr

    !** normalize rotation axis ***********************************************
    !axis = axis / sqrt(sum(axis*axis))

    !** Setup transformation matrix *******************************************
    rr(1,1) = cos(angle) + axis(1)*axis(1)* (1._8 - cos(angle))
    rr(1,2) = axis(1)*axis(2)* (1._8 - cos(angle)) - axis(3) * sin(angle)
    rr(1,3) = axis(1)*axis(3)* (1._8 - cos(angle)) + axis(2) * sin(angle)

    rr(2,1) = axis(2)*axis(1)* (1._8 - cos(angle)) + axis(3) * sin(angle)
    rr(2,2) = cos(angle) + axis(2)*axis(2)* (1._8 - cos(angle))
    rr(2,3) = axis(2)*axis(3)* (1._8 - cos(angle)) - axis(1) * sin(angle)

    rr(3,1) = axis(3)*axis(1)* (1._8 - cos(angle)) - axis(2) * sin(angle)
    rr(3,2) = axis(3)*axis(2)* (1._8 - cos(angle)) + axis(1) * sin(angle)
    rr(3,3) = cos(angle) + axis(3)*axis(3)* (1._8 - cos(angle))

End Function rot_alg

!------------------------------------------------------------------------------
! FUNCTION: tra_R6
!------------------------------------------------------------------------------
!> @author Ralf Schneider - HLRS - NUM - schneider@hlrs.de
!
!> @brief
!> Transformation matrix for R6x6
!
!> @param[in]  aa Input matrix
!> @return[out] BB Output matrix
!------------------------------------------------------------------------------
Function tra_R6(aa) Result(BB)

    Real(kind=rk), Dimension(3,3), intent(in) :: aa
    Real(kind=rk), Dimension(6,6) :: BB

    BB(1,:) = [ aa(1,1)**2 , aa(1,2)**2 , aa(1,3)**2 , sq2*aa(1,1)*aa(1,2) , sq2*aa(1,1)*aa(1,3), sq2*aa(1,2)*aa(1,3) ]
    BB(2,:) = [ aa(2,1)**2 , aa(2,2)**2 , aa(2,3)**2 , sq2*aa(2,1)*aa(2,2) , sq2*aa(2,1)*aa(2,3), sq2*aa(2,2)*aa(2,3) ]
    BB(3,:) = [ aa(3,1)**2 , aa(3,2)**2 , aa(3,3)**2 , sq2*aa(3,1)*aa(3,2) , sq2*aa(3,1)*aa(3,3), sq2*aa(3,2)*aa(3,3) ]

    BB(4,:) = [ sq2*aa(2,1)*aa(1,1) , sq2*aa(2,2)*aa(1,2) , sq2*aa(2,3)*aa(1,3) , &
        aa(2,1)*aa(1,2)+aa(2,2)*aa(1,1) , aa(2,1)*aa(1,3)+aa(2,3)*aa(1,1) , aa(2,2)*aa(1,3)+aa(2,3)*aa(1,2) ]
    BB(5,:) = [ sq2*aa(1,1)*aa(3,1) , sq2*aa(1,2)*aa(3,2) , sq2*aa(1,3)*aa(3,3) ,  &
        aa(1,1)*aa(3,2)+aa(1,2)*aa(3,1) , aa(1,1)*aa(3,3)+aa(1,3)*aa(3,1) , aa(1,2)*aa(3,3)+aa(1,3)*aa(3,2) ]
    BB(6,:) = [ sq2*aa(2,1)*aa(3,1) , sq2*aa(2,2)*aa(3,2) , sq2*aa(2,3)*aa(3,3) ,  &
        aa(2,1)*aa(3,2)+aa(2,2)*aa(3,1) , aa(2,1)*aa(3,3)+aa(2,3)*aa(3,1) , aa(2,2)*aa(3,3)+aa(2,3)*aa(3,2) ]

End Function tra_R6

!------------------------------------------------------------------------------
! SUBROUTINE: check_sym
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Check the symmetry of an arbitrarily sized matrix.
!
!> @Description
!> Average percentage of deviation of minor diagonals.
!
!> @param[in]  matin Input Matrix
!> @param[out] matout Output Matrix
!------------------------------------------------------------------------------
SUBROUTINE check_sym(matin, sym)

    REAL(KIND=rk), DIMENSION(:,:), INTENT(IN)  :: matin
    REAL(KIND=rk)                , INTENT(OUT) :: sym

    ! INTEGER, DIMENSION(2) :: lb, ub
    INTEGER(KIND=ik) :: ii, jj
    REAL(KIND=rk) :: cummu, entry_counter

    !------------------------------------------------------------------------------
    ! Calculate the differences to get the information of symmetry
    ! Earlier version...
    !------------------------------------------------------------------------------

    cummu = 0._rk
    ii=1_ik
    entry_counter = 0._rk
    DO WHILE (ii < SIZE(matin, DIM=1))

        jj=2_ik
        DO WHILE (jj <= SIZE(matin, DIM=2))
            cummu = cummu + (matin(ii,jj) /  matin(jj,ii))

            !------------------------------------------------------------------------------
            ! How many entries are averaged?
            !------------------------------------------------------------------------------
            entry_counter = entry_counter + 1._rk

            jj = jj + 1_ik
        END DO

        ii = ii + 1_ik
    END DO

    !------------------------------------------------------------------------------
    ! 1 - sym quotient to compare to 0
    !------------------------------------------------------------------------------
    sym = 1._rk - (cummu / entry_counter)

END SUBROUTINE check_sym

!------------------------------------------------------------------------------
! SUBROUTINE: zerothres_num
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Sets a scalar=0 in case it is less than 10^(-11) by default
!
!> @param[in] num Scalar input
!> @param[in] threshold to change to 0
!------------------------------------------------------------------------------
SUBROUTINE zerothres_num(num, thres)

    REAL(KIND=rk), INTENT(INOUT) :: num
    REAL(KIND=rk), INTENT(IN), OPTIONAL :: thres

    REAL(KIND=rk) :: thres_u

    thres_u = num_zero
    IF(PRESENT(thres)) thres_u = thres

    IF (num >= 0._rk) THEN
        IF (num <=  thres_u) num = 0._rk
    ELSE
        IF (num >= -thres_u) num = 0._rk
    END IF

END SUBROUTINE zerothres_num

!------------------------------------------------------------------------------
! SUBROUTINE: zerothres_OnD
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Sets a vector=0 element wise in case it is less than 10^(-11) by default
!
!> @param[in] oneD Scalar input
!> @param[in] threshold to change to 0
!------------------------------------------------------------------------------
SUBROUTINE zerothres_OnD(oneD, thres)

    REAL(KIND=rk), DIMENSION(:), INTENT(INOUT) :: oneD
    REAL(KIND=rk), INTENT(IN), OPTIONAL :: thres

    REAL(KIND=rk) :: thres_u
    INTEGER(KIND=ik) :: ii

    thres_u = num_zero
    IF(PRESENT(thres)) thres_u = thres

    DO ii=1, SIZE(oneD)
        IF (oneD(ii) >= 0._rk) THEN
            IF (oneD(ii) <=  thres_u) oneD(ii) = 0._rk
        ELSE
            IF (oneD(ii) >= -thres_u) oneD(ii) = 0._rk
        END IF
    END DO
END SUBROUTINE zerothres_OnD

!------------------------------------------------------------------------------
! SUBROUTINE: zerothres_TwD
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Sets an array=0 element wise in case it is less than 10^(-11) by default
!
!> @param[in] oneD Scalar input
!> @param[in] threshold to change to 0
!------------------------------------------------------------------------------
SUBROUTINE zerothres_TwD(TwD, thres)

    REAL(KIND=rk), DIMENSION(:,:), INTENT(INOUT) :: TwD
    REAL(KIND=rk), INTENT(IN), OPTIONAL :: thres

    REAL(KIND=rk) :: thres_u
    INTEGER(KIND=ik) :: ii, jj

    thres_u = num_zero
    IF(PRESENT(thres)) thres_u = thres

    DO jj=1, SIZE(TwD, 2)
    DO ii=1, SIZE(TwD, 1)
        IF (TwD(ii, jj) >= 0._rk) THEN
            IF (TwD(ii, jj) <=  thres_u) TwD(ii, jj) = 0._rk
        ELSE
            IF (TwD(ii, jj) >= -thres_u) TwD(ii, jj) = 0._rk
        END IF
    END DO
    END DO
END SUBROUTINE zerothres_TwD

!------------------------------------------------------------------------------
! SUBROUTINE: zerothres_ThD
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Sets an array=0 element wise in case it is less than 10^(-11) by default
!
!> @param[in] oneD Scalar input
!> @param[in] threshold to change to 0
!------------------------------------------------------------------------------
SUBROUTINE zerothres_ThD(ThD, thres)

    REAL(KIND=rk), DIMENSION(:, :, :), INTENT(INOUT) :: ThD
    REAL(KIND=rk), INTENT(IN), OPTIONAL :: thres

    REAL(KIND=rk) :: thres_u
    INTEGER(KIND=ik) :: ii, jj, kk

    thres_u = num_zero
    IF(PRESENT(thres)) thres_u = thres

    DO kk=1, SIZE(ThD, 3)
    DO jj=1, SIZE(ThD, 2)
    DO ii=1, SIZE(ThD, 1)
        IF (ThD(ii, jj, kk) >= 0._rk) THEN
            IF (ThD(ii, jj, kk) <=  thres_u) ThD(ii, jj, kk) = 0._rk
        ELSE
            IF (ThD(ii, jj, kk) >= -thres_u) ThD(ii, jj, kk) = 0._rk
        END IF
    END DO
    END DO
    END DO
END SUBROUTINE zerothres_ThD

!------------------------------------------------------------------------------
! FUNCTION: eul_2_un_quat
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Returns a unit Quaternion based on 3 Euler Angles [radians]
!
!> @description
!> euler_radians(1) -> x-axis -> "alpha"
!> euler_radians(2) -> y-axis -> "beta"
!> euler_radians(3) -> z-axis -> "gamma"
!
!> @param[in] euler_radians Euler radians
!> @return eul_2_un_quat Unit Quaternion
!------------------------------------------------------------------------------
FUNCTION eul_2_un_quat (euler_radians)

    REAL (KIND=rk) , DIMENSION(3) :: euler_radians
    TYPE(Quaternion) :: eul_2_un_quat

    REAL (KIND=rk) :: ca, cb, cg, sa, sb, sg

    euler_radians = euler_radians * 0.5_rk ! angle/2 to get a quaternion!

    ca = COS(euler_radians(1))
    sa = SIN(euler_radians(1))
    cb = COS(euler_radians(2))
    sb = SIN(euler_radians(2))
    cg = COS(euler_radians(3))
    sg = SIN(euler_radians(3))

    eul_2_un_quat%w = ca * cb * cg + sa * sb * sg
    eul_2_un_quat%x = sa * cb * cg - ca * sb * sg
    eul_2_un_quat%y = ca * sb * cg + sa * cb * sg
    eul_2_un_quat%z = ca * cb * sg - sa * sb * cg

END FUNCTION eul_2_un_quat

!------------------------------------------------------------------------------
! FUNCTION: check_un_quat
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Check whether it is a uni quaternion
!
!> @param[in] quat Quaternion
!> @return check_un_quat True or false
!------------------------------------------------------------------------------
FUNCTION check_un_quat (quat)

    TYPE(Quaternion) :: quat
    LOGICAL :: check_un_quat

    REAL(KIND=rk) :: rslt

    rslt = quat%w**2 + quat%x**2 + quat%y**2 + quat%z**2

    IF (rslt-1_rk <= num_zero) THEN
        check_un_quat = .TRUE.
    ELSE
        check_un_quat = .FALSE.
    END IF

END FUNCTION check_un_quat

!------------------------------------------------------------------------------
! FUNCTION: quat_norm
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion norm
!
!> @param[in] quat Quaternion
!> @return quat_norm Norm of the quaternion
!------------------------------------------------------------------------------
FUNCTION quat_norm (quat)

    TYPE(Quaternion) :: quat
    REAL(KIND=rk) :: quat_norm

    quat_norm = quat%w**2 + quat%x**2 + quat%y**2 + quat%z**2

END FUNCTION quat_norm

!------------------------------------------------------------------------------
! FUNCTION: q_add
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Add a scalar to a quaternion. Also works with negative scalars.
!
!> @param[in] q1 Quaternion
!> @param[in] scalar Scalar
!> @return q_add Result of the addition
!------------------------------------------------------------------------------
FUNCTION q_add(q1, scalar)

    TYPE(Quaternion) :: q1, q_add
    REAL(KIND=rk) :: scalar

    q_add%w = q1%w + scalar
    q_add%x = q1%x + scalar
    q_add%y = q1%y + scalar
    q_add%z = q1%z + scalar

END FUNCTION q_add

!------------------------------------------------------------------------------
! FUNCTION: q_mult
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion multiplication. Element wise, not to be confused with quat_prod!
!
!> @param[in] q1 Quaternion
!> @param[in] scalar Scalar
!> @return q_add Result of the multiplication
!------------------------------------------------------------------------------
FUNCTION q_mult (q1, scalar)

    TYPE(Quaternion) :: q1, q_mult
    REAL(KIND=rk) :: scalar

    q_mult%w = q1%w * scalar
    q_mult%x = q1%x * scalar
    q_mult%y = q1%y * scalar
    q_mult%z = q1%z * scalar

END FUNCTION q_mult

!------------------------------------------------------------------------------
! FUNCTION: q_dvd
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion division. Element wise, not to be confused with quat_prod!
!
!> @param[in] q1 Quaternion
!> @param[in] scalar Scalar
!> @return q_add Result of the division
!------------------------------------------------------------------------------
FUNCTION q_dvd (q1, scalar)

    TYPE(Quaternion) :: q1, q_dvd
    REAL(KIND=rk) :: scalar

    q_dvd%w = q1%w / scalar
    q_dvd%x = q1%x / scalar
    q_dvd%y = q1%y / scalar
    q_dvd%z = q1%z / scalar

END FUNCTION q_dvd

!------------------------------------------------------------------------------
! FUNCTION: quat_prod
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion division. Element wise, not to be confused with quat_prod!
!
!> @param[in] q1 Quaternion
!> @param[in] q2 Quaternion
!> @return quat_prod Result of the quaternion multiplication
!------------------------------------------------------------------------------
FUNCTION quat_prod (q1, q2)

    TYPE(Quaternion) :: q1, q2, quat_prod

    quat_prod%w = q1%w*q2%w-q1%x*q2%x-q1%y*q2%y-q1%z*q2%z
    quat_prod%x = q1%w*q2%x+q1%x*q2%w+q1%y*q2%z-q1%z*q2%y
    quat_prod%y = q1%w*q2%y-q1%x*q2%z+q1%y*q2%w+q1%z*q2%x
    quat_prod%z = q1%w*q2%z+q1%x*q2%y-q1%y*q2%x+q1%z*q2%w

END FUNCTION quat_prod

!------------------------------------------------------------------------------
! FUNCTION: conjugate_quat
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Conjugate quaternion.
!
!> @param[in] quat Quaternion
!> @return conjugate_quat Conjugate quaternion
!------------------------------------------------------------------------------
FUNCTION conjugate_quat(quat)

    TYPE(Quaternion) :: quat, conjugate_quat

    conjugate_quat%w =   quat%w
    conjugate_quat%x = - quat%x
    conjugate_quat%y = - quat%y
    conjugate_quat%z = - quat%z

END FUNCTION conjugate_quat

!------------------------------------------------------------------------------
! FUNCTION: rotate_point
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Rotate a point with quaternions. Takes a unit quaternion as input
!
!> @param[in] quat Quaternion
!> @param[in] point Point to rotate with quaternion.
!> @return rotate_point Rotated point.
!------------------------------------------------------------------------------
FUNCTION rotate_point(quat, point)

    TYPE(Quaternion) :: quat
    REAL(KIND=rk), DIMENSION(3) :: point, rotate_point

    TYPE(Quaternion) :: pnt, rtt_pnt

    pnt%w = 0._rk
    pnt%x = point(1)
    pnt%y = point(2)
    pnt%z = point(3)

    rtt_pnt = quat_prod(quat_prod(quat, pnt), conjugate_quat(quat))

    rotate_point(1) = rtt_pnt%x
    rotate_point(2) = rtt_pnt%y
    rotate_point(3) = rtt_pnt%z

END FUNCTION rotate_point

!------------------------------------------------------------------------------
! FUNCTION: quat_2_rot_mat
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Quaternion to rotation matrix.
!
!> @param[in] q Quaternion
!> @return quat_2_rot_mat Rotation matrix
!------------------------------------------------------------------------------
FUNCTION quat_2_rot_mat(q)

    TYPE(Quaternion) :: q
    REAL(KIND=rk), DIMENSION(3,3) :: quat_2_rot_mat

    quat_2_rot_mat(1,:) = [ q%w**2 + q%x**2 - q%y**2 - q%z**2  , &
        2._rk*q%x*q%y - 2._rk*q%w*q%z , 2._rk*q%x*q%z - 2._rk*q%w*q%y  ]
    quat_2_rot_mat(2,:) = [ 2._rk*q%x*q%y + 2._rk*q%w*q%z , &
        q%w**2 - q%x**2 + q%y**2 + - q%z**2 , 2._rk*q%y*q%z - 2._rk*q%w*q%x ]
    quat_2_rot_mat(3,:) = [ 2._rk*q%x*q%z - 2._rk*q%w*q%y , &
        2._rk*q%y*q%z + 2._rk*q%w*q%x , q%w**2 - q%x**2 - q%y**2 + q%z**2   ]

END FUNCTION quat_2_rot_mat

!------------------------------------------------------------------------------
! FUNCTION: crpr
!------------------------------------------------------------------------------
!> @author Johannes Gebert - HLRS - NUM - gebert@hlrs.de
!
!> @brief
!> Cross product of two vectors
!
!> @param[in] a Vector
!> @param[in] b Vector
!> @return crpr Cross product
!------------------------------------------------------------------------------
FUNCTION crpr(a, b)

    REAL(KIND=rk), DIMENSION(3) :: crpr,a,b

    crpr(1) = a(2) * b(3) - a(3) * b(2)
    crpr(2) = a(3) * b(1) - a(1) * b(3)
    crpr(3) = a(1) * b(2) - a(2) * b(1)

END FUNCTION crpr

END MODULE math


*DECK DPCHFE
      SUBROUTINE DPCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
C***BEGIN PROLOGUE  DPCHFE
C***PURPOSE  Evaluate a piecewise cubic Hermite function at an array of
C            points.  May be used by itself for Hermite interpolation,
C            or as an evaluator for DPCHIM or DPCHIC.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3
C***TYPE      DOUBLE PRECISION (PCHFE-S, DPCHFE-D)
C***KEYWORDS  CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP,
C             PIECEWISE CUBIC EVALUATION
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C          DPCHFE:  Piecewise Cubic Hermite Function Evaluator
C
C     Evaluates the cubic Hermite function defined by  N, X, F, D  at
C     the points  XE(J), J=1(1)NE.
C
C     To provide compatibility with DPCHIM and DPCHIC, includes an
C     increment between successive values of the F- and D-arrays.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N, NE, IERR
C        DOUBLE PRECISION  X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE)
C        LOGICAL  SKIP
C
C        CALL  DPCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
C
C   Parameters:
C
C     N -- (input) number of data points.  (Error return if N.LT.2 .)
C
C     X -- (input) real*8 array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F -- (input) real*8 array of function values.  F(1+(I-1)*INCFD) is
C           the value corresponding to X(I).
C
C     D -- (input) real*8 array of derivative values.  D(1+(I-1)*INCFD)
C           is the value corresponding to X(I).
C
C     INCFD -- (input) increment between successive values in F and D.
C           (Error return if  INCFD.LT.1 .)
C
C     SKIP -- (input/output) logical variable which should be set to
C           .TRUE. if the user wishes to skip checks for validity of
C           preceding parameters, or to .FALSE. otherwise.
C           This will save time in case these checks have already
C           been performed (say, in DPCHIM or DPCHIC).
C           SKIP will be set to .TRUE. on normal return.
C
C     NE -- (input) number of evaluation points.  (Error return if
C           NE.LT.1 .)
C
C     XE -- (input) real*8 array of points at which the function is to
C           be evaluated.
C
C          NOTES:
C           1. The evaluation will be most efficient if the elements
C              of XE are increasing relative to X;
C              that is,   XE(J) .GE. X(I)
C              implies    XE(K) .GE. X(I),  all K.GE.J .
C           2. If any of the XE are outside the interval [X(1),X(N)],
C              values are extrapolated from the nearest extreme cubic,
C              and a warning error is returned.
C
C     FE -- (output) real*8 array of values of the cubic Hermite
C           function defined by  N, X, F, D  at the points  XE.
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           Warning error:
C              IERR.GT.0  means that extrapolation was performed at
C                 IERR points.
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C              IERR = -4  if NE.LT.1 .
C             (The FE-array has not been changed in any of these cases.)
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DCHFEV, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811020  DATE WRITTEN
C   820803  Minor cosmetic changes for release 1.
C   870707  Corrected XERROR calls for d.p. name(s).
C   890206  Corrected XERROR calls.
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  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  DPCHFE
C  Programming notes:
C
C     1. To produce a single precision version, simply:
C        a. Change DPCHFE to PCHFE, and DCHFEV to CHFEV, wherever they
C           occur,
C        b. Change the double precision declaration to real,
C
C     2. Most of the coding between the call to DCHFEV and the end of
C        the IR-loop could be eliminated if it were permissible to
C        assume that XE is ordered relative to X.
C
C     3. DCHFEV does not assume that X1 is less than X2.  thus, it would
C        be possible to write a version of DPCHFE that assumes a
C        decreasing X-array by simply running the IR-loop backwards
C        (and reversing the order of appropriate tests).
C
C     4. The present code has a minor bug, which I have decided is not
C        worth the effort that would be required to fix it.
C        If XE contains points in [X(N-1),X(N)], followed by points .LT.
C        X(N-1), followed by points .GT.X(N), the extrapolation points
C        will be counted (at least) twice in the total returned in IERR.
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD, NE, IERR
      DOUBLE PRECISION  X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*)
      LOGICAL  SKIP
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, IERC, IR, J, JFIRST, NEXT(2), NJ
C
C  VALIDITY-CHECK ARGUMENTS.
C
C***FIRST EXECUTABLE STATEMENT  DPCHFE
      IF (SKIP)  GO TO 5
C
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  I = 2, N
         IF ( X(I).LE.X(I-1) )  GO TO 5003
    1 CONTINUE
C
C  FUNCTION DEFINITION IS OK, GO ON.
C
    5 CONTINUE
      IF ( NE.LT.1 )  GO TO 5004
      IERR = 0
      SKIP = .TRUE.
C
C  LOOP OVER INTERVALS.        (   INTERVAL INDEX IS  IL = IR-1  . )
C                              ( INTERVAL IS X(IL).LE.X.LT.X(IR) . )
      JFIRST = 1
      IR = 2
   10 CONTINUE
C
C     SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS.
C
         IF (JFIRST .GT. NE)  GO TO 5000
C
C     LOCATE ALL POINTS IN INTERVAL.
C
         DO 20  J = JFIRST, NE
            IF (XE(J) .GE. X(IR))  GO TO 30
   20    CONTINUE
         J = NE + 1
         GO TO 40
C
C     HAVE LOCATED FIRST POINT BEYOND INTERVAL.
C
   30    CONTINUE
         IF (IR .EQ. N)  J = NE + 1
C
   40    CONTINUE
         NJ = J - JFIRST
C
C     SKIP EVALUATION IF NO POINTS IN INTERVAL.
C
         IF (NJ .EQ. 0)  GO TO 50
C
C     EVALUATE CUBIC AT XE(I),  I = JFIRST (1) J-1 .
C
C       ----------------------------------------------------------------
        CALL DCHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR)
     *              ,NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC)
C       ----------------------------------------------------------------
         IF (IERC .LT. 0)  GO TO 5005
C
         IF (NEXT(2) .EQ. 0)  GO TO 42
C        IF (NEXT(2) .GT. 0)  THEN
C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE
C           RIGHT OF X(IR).
C
            IF (IR .LT. N)  GO TO 41
C           IF (IR .EQ. N)  THEN
C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
               IERR = IERR + NEXT(2)
               GO TO 42
   41       CONTINUE
C           ELSE
C              WE SHOULD NEVER HAVE GOTTEN HERE.
               GO TO 5005
C           ENDIF
C        ENDIF
   42    CONTINUE
C
         IF (NEXT(1) .EQ. 0)  GO TO 49
C        IF (NEXT(1) .GT. 0)  THEN
C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE
C           LEFT OF X(IR-1).
C
            IF (IR .GT. 2)  GO TO 43
C           IF (IR .EQ. 2)  THEN
C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
               IERR = IERR + NEXT(1)
               GO TO 49
   43       CONTINUE
C           ELSE
C              XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST
C              EVALUATION INTERVAL.
C
C              FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1).
               DO 44  I = JFIRST, J-1
                  IF (XE(I) .LT. X(IR-1))  GO TO 45
   44          CONTINUE
C              NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR
C                     IN DCHFEV.
               GO TO 5005
C
   45          CONTINUE
C              RESET J.  (THIS WILL BE THE NEW JFIRST.)
               J = I
C
C              NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY.
               DO 46  I = 1, IR-1
                  IF (XE(J) .LT. X(I)) GO TO 47
   46          CONTINUE
C              NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1).
C
   47          CONTINUE
C              AT THIS POINT, EITHER  XE(J) .LT. X(1)
C                 OR      X(I-1) .LE. XE(J) .LT. X(I) .
C              RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE
C              CYCLING.
               IR = MAX(1, I-1)
C           ENDIF
C        ENDIF
   49    CONTINUE
C
         JFIRST = J
C
C     END OF IR-LOOP.
C
   50 CONTINUE
      IR = IR + 1
      IF (IR .LE. N)  GO TO 10
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHFE',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHFE', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      RETURN
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'DPCHFE',
     +   'X-ARRAY NOT STRICTLY INCREASING', IERR, 1)
      RETURN
C
 5004 CONTINUE
C     NE.LT.1 RETURN.
      IERR = -4
      CALL XERMSG ('SLATEC', 'DPCHFE',
     +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
      RETURN
C
 5005 CONTINUE
C     ERROR RETURN FROM DCHFEV.
C   *** THIS CASE SHOULD NEVER OCCUR ***
      IERR = -5
      CALL XERMSG ('SLATEC', 'DPCHFE',
     +   'ERROR RETURN FROM DCHFEV -- FATAL', IERR, 2)
      RETURN
C------------- LAST LINE OF DPCHFE FOLLOWS -----------------------------
      END


      FUNCTION fmin(x)
      INTEGER n,NP
      REAL fmin,x(*),fvec
      PARAMETER (NP=40)
      COMMON /newtv/ fvec(NP),n
      SAVE /newtv/
CU    USES funcv
      INTEGER i
      REAL sum
      call funcv(n,x,fvec)
      sum=0.
      do 11 i=1,n
        sum=sum+fvec(i)**2
11    continue
      fmin=0.5*sum
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/fmin.for


! Fortran program that reads weights and biases
! from a file and performs a forward propagation

program forward_pass

   ! module with neural network structure
   use fortfp

   implicit none

   ! types
   type (nn) :: mynn                                ! neural network
   type (af), allocatable, dimension(:) :: afuncs   ! activation functions

   ! variables, arrays, and matrices
   real(8), allocatable, dimension (:,:) :: inputs  ! array of inputs: (n_neurons, batch_size)
   real(8), allocatable, dimension (:) :: outputs   ! array of outputs: (n_neurons)
   integer nl                                       ! number of layers in neural network
   integer n_in, n_hi, n_out			    		       ! number of neurons
   integer n_batch			            			    ! input batch size
   integer i, j                                     ! loop parameters

   ! input parameters
   nl = 6
   n_in = 9
   n_out = 6
   n_hi = 100
   n_batch = 1

   ! allocate memory
   allocate(afuncs(nl), inputs(n_in, n_batch), outputs(n_out))

   ! generate some inputs for forward propagation
   do j = 1,n_in
      do i = 1,n_batch
         inputs(j,i) = 0.d0
      enddo
   enddo

   ! define activation functions in each layer
   !    options: htan, lrelu, smax, sigmoid, no_activation
   afuncs(1)%f => null()   ! no activation
   afuncs(2)%f => lrelu
   afuncs(3)%f => lrelu
   afuncs(4)%f => lrelu
   afuncs(5)%f => lrelu
   afuncs(nl)%f => no_activation

   ! define number of neurons in each layer and initialize neural network
   call mynn%init([n_in, n_hi, n_hi, n_hi, n_hi, n_out], afuncs)

   ! perform forward pass for each input
   do i = 1,n_batch

      call mynn%query(inputs(:,i))
      outputs = mynn%layers(nl-1)%y   ! layers' numbers begin from 0
      print *, "inputs: ", inputs(:,i)
      print *, "outputs: ", outputs

   enddo

end program forward_pass


*DECK DQAGE
      SUBROUTINE DQAGE (F, A, B, EPSABS, EPSREL, KEY, LIMIT, RESULT,
     +   ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST, IORD, LAST)
C***BEGIN PROLOGUE  DQAGE
C***PURPOSE  The routine calculates an approximation result to a given
C            definite integral   I = Integral of F over (A,B),
C            hopefully satisfying following claim for accuracy
C            ABS(I-RESLT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A1A1
C***TYPE      DOUBLE PRECISION (QAGE-S, DQAGE-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, GAUSS-KRONROD RULES,
C             GENERAL-PURPOSE, GLOBALLY ADAPTIVE, INTEGRAND EXAMINATOR,
C             QUADPACK, QUADRATURE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Computation of a definite integral
C        Standard fortran subroutine
C        Double precision version
C
C        PARAMETERS
C         ON ENTRY
C            F      - Double precision
C                     Function subprogram defining the integrand
C                     function F(X). The actual name for F needs to be
C                     declared E X T E R N A L in the driver program.
C
C            A      - Double precision
C                     Lower limit of integration
C
C            B      - Double precision
C                     Upper limit of integration
C
C            EPSABS - Double precision
C                     Absolute accuracy requested
C            EPSREL - Double precision
C                     Relative accuracy requested
C                     If  EPSABS.LE.0
C                     and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     the routine will end with IER = 6.
C
C            KEY    - Integer
C                     Key for choice of local integration rule
C                     A Gauss-Kronrod pair is used with
C                          7 - 15 points if KEY.LT.2,
C                         10 - 21 points if KEY = 2,
C                         15 - 31 points if KEY = 3,
C                         20 - 41 points if KEY = 4,
C                         25 - 51 points if KEY = 5,
C                         30 - 61 points if KEY.GT.5.
C
C            LIMIT  - Integer
C                     Gives an upper bound on the number of subintervals
C                     in the partition of (A,B), LIMIT.GE.1.
C
C         ON RETURN
C            RESULT - Double precision
C                     Approximation to the integral
C
C            ABSERR - Double precision
C                     Estimate of the modulus of the absolute error,
C                     which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 Normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                     IER.GT.0 Abnormal termination of the routine
C                             The estimates for result and error are
C                             less reliable. It is assumed that the
C                             requested accuracy has not been achieved.
C            ERROR MESSAGES
C                     IER = 1 Maximum number of subdivisions allowed
C                             has been achieved. One can allow more
C                             subdivisions by increasing the value
C                             of LIMIT.
C                             However, if this yields no improvement it
C                             is rather advised to analyze the integrand
C                             in order to determine the integration
C                             difficulties. If the position of a local
C                             difficulty can be determined(e.g.
C                             SINGULARITY, DISCONTINUITY within the
C                             interval) one will probably gain from
C                             splitting up the interval at this point
C                             and calling the integrator on the
C                             subranges. If possible, an appropriate
C                             special-purpose integrator should be used
C                             which is designed for handling the type of
C                             difficulty involved.
C                         = 2 The occurrence of roundoff error is
C                             detected, which prevents the requested
C                             tolerance from being achieved.
C                         = 3 Extremely bad integrand behaviour occurs
C                             at some points of the integration
C                             interval.
C                         = 6 The input is invalid, because
C                             (EPSABS.LE.0 and
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                             RESULT, ABSERR, NEVAL, LAST, RLIST(1) ,
C                             ELIST(1) and IORD(1) are set to zero.
C                             ALIST(1) and BLIST(1) are set to A and B
C                             respectively.
C
C            ALIST   - Double precision
C                      Vector of dimension at least LIMIT, the first
C                       LAST  elements of which are the left
C                      end points of the subintervals in the partition
C                      of the given integration range (A,B)
C
C            BLIST   - Double precision
C                      Vector of dimension at least LIMIT, the first
C                       LAST  elements of which are the right
C                      end points of the subintervals in the partition
C                      of the given integration range (A,B)
C
C            RLIST   - Double precision
C                      Vector of dimension at least LIMIT, the first
C                       LAST  elements of which are the
C                      integral approximations on the subintervals
C
C            ELIST   - Double precision
C                      Vector of dimension at least LIMIT, the first
C                       LAST  elements of which are the moduli of the
C                      absolute error estimates on the subintervals
C
C            IORD    - Integer
C                      Vector of dimension at least LIMIT, the first K
C                      elements of which are pointers to the
C                      error estimates over the subintervals,
C                      such that ELIST(IORD(1)), ...,
C                      ELIST(IORD(K)) form a decreasing sequence,
C                      with K = LAST if LAST.LE.(LIMIT/2+2), and
C                      K = LIMIT+1-LAST otherwise
C
C            LAST    - Integer
C                      Number of subintervals actually produced in the
C                      subdivision process
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DQK15, DQK21, DQK31, DQK41, DQK51, DQK61,
C                    DQPSRT
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DQAGE
C
      DOUBLE PRECISION A,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2,B,
     1  BLIST,B1,B2,DEFABS,DEFAB1,DEFAB2,D1MACH,ELIST,EPMACH,
     2  EPSABS,EPSREL,ERRBND,ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,F,
     3  RESABS,RESULT,RLIST,UFLOW
      INTEGER IER,IORD,IROFF1,IROFF2,K,KEY,KEYF,LAST,LIMIT,MAXERR,NEVAL,
     1  NRMAX
C
      DIMENSION ALIST(*),BLIST(*),ELIST(*),IORD(*),
     1  RLIST(*)
C
      EXTERNAL F
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                      (ALIST(I),BLIST(I))
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST
C                       ERROR ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C
C
C           MACHINE DEPENDENT CONSTANTS
C           ---------------------------
C
C           EPMACH  IS THE LARGEST RELATIVE SPACING.
C           UFLOW  IS THE SMALLEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQAGE
      EPMACH = D1MACH(4)
      UFLOW = D1MACH(1)
C
C           TEST ON VALIDITY OF PARAMETERS
C           ------------------------------
C
      IER = 0
      NEVAL = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      ALIST(1) = A
      BLIST(1) = B
      RLIST(1) = 0.0D+00
      ELIST(1) = 0.0D+00
      IORD(1) = 0
      IF(EPSABS.LE.0.0D+00.AND.
     1  EPSREL.LT.MAX(0.5D+02*EPMACH,0.5D-28)) IER = 6
      IF(IER.EQ.6) GO TO 999
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
      KEYF = KEY
      IF(KEY.LE.0) KEYF = 1
      IF(KEY.GE.7) KEYF = 6
      NEVAL = 0
      IF(KEYF.EQ.1) CALL DQK15(F,A,B,RESULT,ABSERR,DEFABS,RESABS)
      IF(KEYF.EQ.2) CALL DQK21(F,A,B,RESULT,ABSERR,DEFABS,RESABS)
      IF(KEYF.EQ.3) CALL DQK31(F,A,B,RESULT,ABSERR,DEFABS,RESABS)
      IF(KEYF.EQ.4) CALL DQK41(F,A,B,RESULT,ABSERR,DEFABS,RESABS)
      IF(KEYF.EQ.5) CALL DQK51(F,A,B,RESULT,ABSERR,DEFABS,RESABS)
      IF(KEYF.EQ.6) CALL DQK61(F,A,B,RESULT,ABSERR,DEFABS,RESABS)
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
C
C           TEST ON ACCURACY.
C
      ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT))
      IF(ABSERR.LE.0.5D+02*EPMACH*DEFABS.AND.ABSERR.GT.ERRBND) IER = 2
      IF(LIMIT.EQ.1) IER = 1
      IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS)
     1  .OR.ABSERR.EQ.0.0D+00) GO TO 60
C
C           INITIALIZATION
C           --------------
C
C
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      NRMAX = 1
      IROFF1 = 0
      IROFF2 = 0
C
C           MAIN DO-LOOP
C           ------------
C
      DO 30 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH THE LARGEST ERROR ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        IF(KEYF.EQ.1) CALL DQK15(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1)
        IF(KEYF.EQ.2) CALL DQK21(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1)
        IF(KEYF.EQ.3) CALL DQK31(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1)
        IF(KEYF.EQ.4) CALL DQK41(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1)
        IF(KEYF.EQ.5) CALL DQK51(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1)
        IF(KEYF.EQ.6) CALL DQK61(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1)
        IF(KEYF.EQ.1) CALL DQK15(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2)
        IF(KEYF.EQ.2) CALL DQK21(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2)
        IF(KEYF.EQ.3) CALL DQK31(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2)
        IF(KEYF.EQ.4) CALL DQK41(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2)
        IF(KEYF.EQ.5) CALL DQK51(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2)
        IF(KEYF.EQ.6) CALL DQK61(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        NEVAL = NEVAL+1
        AREA12 = AREA1+AREA2
        ERRO12 = ERROR1+ERROR2
        ERRSUM = ERRSUM+ERRO12-ERRMAX
        AREA = AREA+AREA12-RLIST(MAXERR)
        IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 5
        IF(ABS(RLIST(MAXERR)-AREA12).LE.0.1D-04*ABS(AREA12)
     1  .AND.ERRO12.GE.0.99D+00*ERRMAX) IROFF1 = IROFF1+1
        IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF2 = IROFF2+1
    5   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = MAX(EPSABS,EPSREL*ABS(AREA))
        IF(ERRSUM.LE.ERRBND) GO TO 8
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.
C
        IF(IROFF1.GE.6.OR.IROFF2.GE.20) IER = 2
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF SUBINTERVALS
C           EQUALS LIMIT.
C
        IF(LAST.EQ.LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT A POINT OF THE INTEGRATION RANGE.
C
        IF(MAX(ABS(A1),ABS(B2)).LE.(0.1D+01+0.1D+03*
     1  EPMACH)*(ABS(A2)+0.1D+04*UFLOW)) IER = 3
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
    8   IF(ERROR2.GT.ERROR1) GO TO 10
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 20
   10   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
C           WITH THE LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
C
   20   CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF(IER.NE.0.OR.ERRSUM.LE.ERRBND) GO TO 40
   30 CONTINUE
C
C           COMPUTE FINAL RESULT.
C           ---------------------
C
   40 RESULT = 0.0D+00
      DO 50 K=1,LAST
        RESULT = RESULT+RLIST(K)
   50 CONTINUE
      ABSERR = ERRSUM
   60 IF(KEYF.NE.1) NEVAL = (10*KEYF+1)*(2*NEVAL+1)
      IF(KEYF.EQ.1) NEVAL = 30*NEVAL+15
  999 RETURN
      END


      FUNCTION ADPINT (F, A, B, AERR, RERR, ERREST, IER)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      INTEGER OLDINT

c.....Integral of F(X) from A to B, with error
c.....less than ABS(AERR) + ABS(RERR*INTEGRAL)
c.....Best estimate of error returned in ERREST.
c.....Error code is IER: zero if OK, non-zero if in trouble.

      EXTERNAL F
      PARAMETER (MAXINT = 500)

c     Work space:

      COMMON / ADPWRK /  U(MAXINT), V(MAXINT), FU(MAXINT),
     >     FV(MAXINT), FW(MAXINT), ERR(MAXINT), RESULT(MAXINT), NUMINT
      SAVE / ADPWRK /

      IER = 0
      NUMINT = 5
      DX = (B-A)/ NUMINT
      DO 1  I = 1, NUMINT
         IF (I .EQ. 1)  THEN
            U(I) = A
            FU(I) = F(U(I))
         ELSE
            U(I) = V(I-1)
            FU(I) = FV(I-1)
         ENDIF
         IF (I .EQ. NUMINT) THEN
            V(I) = B
         ELSE
            V(I) = A + DX * I
         ENDIF
         FV(I) = F(V(I))
         CALL ADPCAL(F,I)
 1    CONTINUE

 2    CONTINUE

c.....Error estimate:

      ADPINT = 0.
      ERREST = 0.
      DO 3  I = 1, NUMINT
         ADPINT = ADPINT + RESULT(I)
         ERREST = ERREST + ERR(I)
 3    CONTINUE
      TARGET = ABS(AERR) + ABS(RERR * ADPINT)
      IF (ERREST .GT. TARGET)  THEN
         OLDINT = NUMINT
         DO 4 I = 1, OLDINT
            IF (ERR(I)*2*OLDINT .GT. TARGET)  CALL ADPSPL(F,I,IER)
 4       CONTINUE
         IF (IER .EQ. 0)  GOTO 2
      ENDIF
      RETURN
      END

      FUNCTION INTUSE ()
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)

c.....Return number of intervals used last call to ADPINT

      PARAMETER (MAXINT = 500)
      COMMON / ADPWRK /  U(MAXINT), V(MAXINT), FU(MAXINT),
     >     FV(MAXINT), FW(MAXINT), ERR(MAXINT), RESULT(MAXINT), NUMINT
      INTUSE = NUMINT
      RETURN
      END

      SUBROUTINE ADPCAL (F,I)

c.....Fill in details of interval I given endpoints

      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      EXTERNAL F
      PARAMETER (MAXINT = 500)
      COMMON / ADPWRK /  U(MAXINT), V(MAXINT), FU(MAXINT),
     >     FV(MAXINT), FW(MAXINT), ERR(MAXINT), RESULT(MAXINT), NUMINT

      FW(I) = F( (U(I) + V(I)) /2.)
      DX = V(I) - U(I)
      RESULT(I) = DX * (FU(I) + 4. * FW(I) + FV(I)) / 6.
      ERR(I) = ABS(DX * (FU(I) - 2. * FW(I) + FV(I)) / 12.)
      RETURN
      END

      SUBROUTINE ADPSPL (F, I, IER)

c.....Split interval I

      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      EXTERNAL F
      PARAMETER (MAXINT = 500)
      COMMON / ADPWRK /  U(MAXINT), V(MAXINT), FU(MAXINT),
     >     FV(MAXINT), FW(MAXINT), ERR(MAXINT), RESULT(MAXINT), NUMINT

      IF (NUMINT .GE. MAXINT)  THEN
         IER = 1
         RETURN
      ENDIF
      NUMINT = NUMINT + 1
      V(NUMINT) = V(I)
      U(NUMINT) = (U(I) + V(I)) / 2.
      V(I) = U(NUMINT)
      FV(NUMINT) = FV(I)
      FU(NUMINT) = FW(I)
      FV(I) = FW(I)
      CALL ADPCAL (F, I)
      CALL ADPCAL (F, NUMINT)
      RETURN
      END


      SUBROUTINE TESTST(A,NA,ALPHA,DISC,STABLE,IOP,DUMMY)
C
C   PURPOSE:
C      Compute and test the eigenvalues of a constant real matrix A for
C      stability relative to a parameter 'alpha' in either the continu-
C      ous or digital sense.
C
C   Subroutines employed by TESTST: EIGEN, EQUATE, JUXTC, LNCNT, PRNT
C   Subroutines employing TESTST: ASYREG
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),DUMMY(1)
      DIMENSION NA(2),NDUM1(2),NDUM2(2)
      LOGICAL  DISC,STABLE
C
      STABLE = .FALSE.
C
      CALL EQUATE(A,NA,DUMMY,NA)
      N1= NA(1)**2 + 1
      N2= N1+NA(1)
      N3= N2+NA(1)
      ISV = 0
      CALL EIGEN(NA(1),NA(1),DUMMY,DUMMY(N1),DUMMY(N2),ISV,ISV,V,DUMMY(N
     13),IERR)
      NEVL = NA(1)
      IF( IERR .EQ. 0 ) GO TO 200
      CALL LNCNT(4)
      WRITE(6,100) IERR
  100 FORMAT(BZ,//' IN TESTST, THE ',I5,' EIGENVALUE OF A HAS NOT BEEN
     1FOUND AFTER 30 ITERATIONS'/)
      RETURN
C
  200 CONTINUE
      NDUM1(1) = NEVL
      NDUM1(2) = 1
      CALL JUXTC(DUMMY(N1),NDUM1,DUMMY(N2),NDUM1,DUMMY,NDUM2)
C
      IF( DISC ) GO TO 400
      DO 300 I=1,NEVL
      IF( DUMMY(I) .GE. ALPHA ) GO TO 600
  300 CONTINUE
      GO TO 550
  400 CONTINUE
      N = NDUM2(1)*NDUM2(2)+1
      DO 500 I =1,NEVL
      K = I + NEVL
      L=N +I -1
      DUMMY(L) = DSQRT((DUMMY(I)**2)+(DUMMY(K)**2))
  500 CONTINUE
C
      IF( DUMMY(L) .GE. ALPHA ) GO TO 600
C
  550 CONTINUE
      STABLE =.TRUE.
  600 CONTINUE
      IF( IOP .EQ. 0 ) RETURN
      CALL LNCNT(4)
      WRITE(6,700)
  700 FORMAT(//' PROGRAM TO TEST THE RELATIVE STABILITY OF THE MATRIX A
     1'/)
      CALL PRNT(A,NA,' A  ',1)
      CALL LNCNT(4)
  750 FORMAT(//' EIGENVALUES OF A '/)
      CALL PRNT(DUMMY,NDUM2,'EVLA',1)
      IF(  .NOT. DISC ) GO TO 850
      CALL LNCNT(4)
      WRITE(6,800)
  800 FORMAT(//' MODULI OF EIGENVALUES OF A'/)
      CALL PRNT(DUMMY(N),NDUM1,'MODA',1)
C
  850 CONTINUE
      CALL LNCNT(4)
      IF(STABLE) WRITE(6,900) ALPHA
      IF( .NOT. STABLE) WRITE(6,950) ALPHA
  900 FORMAT(//' MATRIX A  IS STABLE RELATIVE TO ',D16.8,/)
  950 FORMAT(//' MATRIX A  IS UNSTABLE RELATIVE TO ' ,D16.8,/)
C
      RETURN
      END


      INCLUDE 'VICMAIN_FOR'

      SUBROUTINE MAIN44
C TEST PROGRAM FOR THE SUBROUTINE MINMAX
      BYTE  BUF(25)
      DATA BUF/1,2,3,4,5,6,7,0,1,2,3,-1,34,55,6,78,47,24,
     &      11,22,33,44,55,66,77/     ! -1 IS DN OF 255.
      INTEGER*2  I2BUF(2)
      DATA I2BUF/1,2/
      INTEGER*4  I4BUF(30)
      DATA I4BUF/1,12,123,1234,12345,123456,7,78,789,
     &      10,-11,12,13,14,154,16789,-170,123,1905,20345,21345,
     &      229876,23098,24567,25,.26,270001,2.8,29.678,.30/
      REAL*4     R4BUF(10)
      DATA R4BUF/-1278.0,123.45,345.12,4987.23,5678.12,
     &      -612.11,-.7,8,.91,0/
      REAL*8     R8BUF(5)
      DATA R8BUF/1.23456789,0.0,-12345678,987654,12/
      COMPLEX    CBUF(5)
      DATA CBUF/ ( -1., -1.), ( 0., 0.), ( 1., 0.),
     &                     ( 0., 1.),   ( 1., 1.)   /

      INTEGER*4 DCODE
      INTEGER*4  N,MIN,MAX,IMIN,IMAX
      REAL*4	  RMIN,RMAX
      REAL*8	  RMIN8,RMAX8

C TEST FOR BYTE ARRAY
      DCODE = 1
      N = 25

      CALL MINMAX(DCODE,N,BUF,MIN,MAX,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(4,1,MIN,'MIN =.')
      CALL PRNT(4,1,MAX,'MAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('*****************.',' ')

C TEST FOR INTEGER*2 ARRAY
      DCODE = 2
      N = 2

      CALL MINMAX(DCODE,N,I2BUF,MIN,MAX,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(4,1,MIN,'MIN =.')
      CALL PRNT(4,1,MAX,'MAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('*****************.',' ')

C TEST FOR INTEGER*4 ARRAY
      DCODE = 4
      N = 25

      CALL MINMAX(DCODE,N,I4BUF,MIN,MAX,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(4,1,MIN,'MIN =.')
      CALL PRNT(4,1,MAX,'MAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('*****************.',' ')
C TEST FOR REAL*4
      DCODE = 7
      N = 10

      CALL MINMAX(DCODE,N,R4BUF,RMIN,RMAX,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(7,1,RMIN,'RMIN =.')
      CALL PRNT(7,1,RMAX,'RMAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('********************.',' ')

C TEST FOR REAL*8 ARRAY

      DCODE = 8
      N = 5

      CALL MINMAX(DCODE,N,R8BUF,RMIN8,RMAX8,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(8,1,RMIN8,'RMIN =.')
      CALL PRNT(8,1,RMAX8,'RMAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('*****************.',' ')

C TEST FOR COMPLEX ARRAY

      DCODE = 10
      N = 5

      CALL MINMAX(DCODE,N,CBUF,RMIN,RMAX,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(7,1,RMIN,'RMIN =.')
      CALL PRNT(7,1,RMAX,'RMAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('*****************.',' ')

      call XVMESSAGE( 'NOW TEST MINMAXE',' ')

C TEST FOR BYTE ARRAY
      DCODE = 1
      N = 25

      CALL MINMAXE(DCODE,N,BUF,0,MIN,MAX,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(4,1,MIN,'MIN =.')
      CALL PRNT(4,1,MAX,'MAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('*****************.',' ')

C TEST FOR INTEGER*2 ARRAY
      DCODE = 2
      N = 2

      CALL MINMAXE(DCODE,N,I2BUF,0,MIN,MAX,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(4,1,MIN,'MIN =.')
      CALL PRNT(4,1,MAX,'MAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('*****************.',' ')

C TEST FOR INTEGER*4 ARRAY
      DCODE = 4
      N = 25

      CALL MINMAXE(DCODE,N,I4BUF,0,MIN,MAX,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(4,1,MIN,'MIN =.')
      CALL PRNT(4,1,MAX,'MAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('*****************.',' ')
C TEST FOR REAL*4
      DCODE = 7
      N = 10

      CALL MINMAXE(DCODE,N,R4BUF,0.,RMIN,RMAX,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(7,1,RMIN,'RMIN =.')
      CALL PRNT(7,1,RMAX,'RMAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('********************.',' ')

C TEST FOR REAL*8 ARRAY

      DCODE = 8
      N = 5

      CALL MINMAXE(DCODE,N,R8BUF,0.,RMIN8,RMAX8,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(8,1,RMIN8,'RMIN =.')
      CALL PRNT(8,1,RMAX8,'RMAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('*****************.',' ')

C TEST FOR COMPLEX ARRAY

      DCODE = 10
      N = 5

      CALL MINMAXE(DCODE,N,CBUF,0.,RMIN,RMAX,IMIN,IMAX)

      CALL PRNT(4,1,DCODE,'DCODE=.')
      CALL PRNT(7,1,RMIN,'RMIN =.')
      CALL PRNT(7,1,RMAX,'RMAX =.')
      CALL PRNT(4,1,IMAX,'IMAX = .')
      CALL PRNT(4,1,IMIN,'IMIN = .')
      CALL XVMESSAGE('*****************.',' ')

      CALL XVMESSAGE(
     . 'Repeat some cases in C to test C interface: zminmax & zminmaxe',
     .   ' ')

      call tzminmax

      RETURN
      END


      double complex function q4ghpmp3(p1,p2,p3,p4,p5,za,zb)
      implicit none
C     This is the reduced matrix element squared
C     for the process
c     q(p1)+qbar(p2) --> H((p5+p6)+Q(p3)+qbar(p4)+g(p5)
c     calculated by the program Hq4g.frm
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_decl.f'
      integer p1,p2,p3,p4,p5
      double precision s5h,t134,t234,t125
      integer i1,i2,i3
      double complex zab
      zab(i1,i2,i3)=+za(i1,i2)*zb(i2,i3)

      t134=s(p1,p3)+s(p3,p4)+s(p4,p1)
      t234=s(p2,p3)+s(p3,p4)+s(p4,p2)
      t125=s(p1,p2)+s(p2,p5)+s(p5,p1)
      s5h=s(p1,p2)+s(p1,p3)+s(p1,p4)
     .            +s(p2,p3)+s(p2,p4)
     .                     +s(p3,p4)

C %\cite{DelDuca:2004wt}
C \bibitem{DelDuca:2004wt}
C V.~Del Duca, A.~Frizzo and F.~Maltoni,
C %``Higgs boson production in association with three jets,''
C JHEP {\bf 0405}, 064 (2004)
C [arXiv:hep-ph/0404013].
C %%CITATION = HEP-PH 0404013;%%
C Eq. B15
      q4ghpmp3=
     . -za(p2,p3)*zb(p1,p5)/(s(p3,p4)*t234*s5h)
     . *(-zb(p1,p5)*(zab(p1,p2,p4)+zab(p1,p3,p4))
     . -zb(p4,p5)*t234)
      q4ghpmp3=q4ghpmp3
     . -1d0/(za(p1,p5)*s(p3,p4)*t125)
     . *(za(p2,p3)*zb(p3,p4)*(za(p3,p1)*zb(p1,p5)+za(p3,p2)*zb(p2,p5))
     . +za(p3,p4)*zb(p4,p5)*(zab(p2,p1,p4)+zab(p2,p5,p4)))
      q4ghpmp3=q4ghpmp3
     . +za(p1,p2)/(za(p1,p5)*za(p2,p5)*s(p3,p4)*t125)
     . *(za(p2,p3)*zb(p3,p4)*(zab(p3,p2,p1)+zab(p3,p5,p1))
     . -za(p3,p4)*zb(p1,p4)*(zab(p2,p1,p4)+zab(p2,p5,p4)))
     . +zb(p1,p4)/(s(p3,p4)*t134*s5h)
     . *(-zab(p2,p1,p5)-zab(p2,p3,p5)-zab(p2,p4,p5))
     . *(zab(p3,p1,p5)+zab(p3,p4,p5))

      return
      end


program stats_checker

    use test_stats_randu
    use test_stats_randn

    call test_stats_randu_integer
    call test_stats_randu_real
    print *, "*<INFO>* All tests in `test_stats_randu` passed."

    call test_stats_randn_real
    print *, "*<INFO>* All tests in `test_stats_randn` passed."

end program stats_checker


      subroutine marquarderr(y,ndata,a,mnodos,n)

	implicit real*4 (a-h,o-z)

	include 'PARAMETER'  !por mmx==kn, que aqui se tomaba igual a 200
c        parameter (mmx=200)
c        dimension y(ndata),a(*),mnodos(*),beta(200),errcv(mmx)

        dimension y(ndata),a(*),mnodos(*),beta(kn),errcv(kn)

        common/errores/errcv

	nn=n
        call marqcoeferr(y,ndata,a,mnodos,nn,beta)

	 rn=1./float(nn)
c	 rn=1.
	 do i=1,nn
            b=beta(i)
            if(b.lt.1.e-10)b=1.e-10
	    errcv(i)=rn/b
	 end do

        return
	end


      subroutine UniBosConsts_Bos ()
      implicit none!
      include "s2n_declare.h"

      real*8 a0fw,a0fz,a0fh
      real*8 b0fzww,b0fzzh,b0fwwz,b0fwwh,b0fhww,b0fhzz,b0fhhh

*                       Za1Bos ZmzZzBos ZmwZwBos ZmhZhBos DeltarhoBos
      common/unibos_bos/za1bos,zmzzzbos,zmwzwbos,zmhzhbos,deltarhobos

      a0fw = log(rwm2/thmu2) - 1d0
      a0fz = log(rzm2/thmu2) - 1d0
      a0fh = log(rhm2/thmu2) - 1d0

      b0fzww = dreal(b0f(-rzm2,thmu2,wm2,wm2))
      b0fzzh = dreal(b0f(-rzm2,thmu2,zm2,hm2))
      b0fwwz = dreal(b0f(-rwm2,thmu2,wm2,zm2))
      b0fwwh = dreal(b0f(-rwm2,thmu2,wm2,hm2))
      b0fhww = dreal(b0f(-rhm2,thmu2,wm2,wm2))
      b0fhzz = dreal(b0f(-rhm2,thmu2,zm2,zm2))
      b0fhhh = dreal(b0f(-rhm2,thmu2,hm2,hm2))

      za1bos =
     & -7d0/3*stw2-3*a0fw*stw2

      zmzzzbos =
     &     -65d0/9+32d0/3*stw2-4*stw4-1d0/18/ctw2-1d0/6*rhm2/rwm2
     &     +2*rwm2/rhm2+1/ctw2*rzm2/rhm2
     &     +b0fzww*(-25d0/3+41d0/3*stw2-4*stw4+1d0/12/ctw2)
     &     +b0fzzh*(1/ctw2+1d0/12*rhm2**2/rwm2/rzm2-1d0/3*rhm2/rwm2)
     &     +a0fw*(-13d0/2+32d0/3*stw2-4*stw4+3*rwm2/rhm2)
     &     +a0fz*(+3d0/2/ctw2*rzm2/rhm2+1d0/6/ctw2-1d0/12*rhm2/rwm2)
     &     +a0fh*(+1d0/2*rhm2/rwm2+1d0/12*rhm2**2/rwm2/rzm2)

      zmwzwbos =
     &     -64d0/9-4*stw2-1d0/6/ctw2-1d0/6*rhm2/rwm2+2*rwm2/rhm2+
     &     1/ctw2*rzm2/rhm2
     &     +b0fwwz*(-29d0/3+4*stw2+4d0/3/ctw2+1d0/12/ctw4)
     &     +b0fwwh*(1-1d0/3*rhm2/rwm2+1d0/12*rhm2**2/rwm2**2)
     &     +a0fw*(-5+4*stw2-1d0/12/ctw2-1d0/12*rhm2/rwm2+3*rwm2/rhm2)
     &     +a0fz*(-2+2d0/3/ctw2+1d0/12/ctw4+3d0/2/ctw2*rzm2/rhm2)
     &     +a0fh*(+1d0/2*rhm2/rwm2+1d0/12*rhm2**2/rwm2**2)

      zmhzhbos =
     &     +b0fhww*(-1+1d0/4*rhm2/rwm2+3*rwm2/rhm2)
     &     +b0fhzz*(-1d0/2/ctw2+1d0/8*rhm2/rwm2+3d0/2/ctw2*rzm2/rhm2)
     &     +9d0/8*b0fhhh*rhm2/rwm2
     &     +a0fw*(1d0/2+3*rwm2/rhm2)
     &     +a0fz*(1d0/4/ctw2+3d0/2/ctw2*rzm2/rhm2)
     &     +a0fh*(3d0/4*rhm2/rwm2)

      deltarhobos = zmwzwbos-zmzzzbos

      return
      end