C
C $Id: rbgdfe.f,v 1.12 2008-09-18 00:42:18 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      DOUBLE PRECISION FUNCTION RBGDFE (RLAT)
C
        DOUBLE PRECISION RLAT
C
C The value of RBGDFE(RLAT) is the signed distance, from the equator,
C of the parallel at latitude RLAT; its magnitude is a fraction of the
C length of the equator.
C
C Declare local variables.
C
        DOUBLE PRECISION FLAT,PDFE(19)
C
        INTEGER          ILAT
C
C Define the contents of PDFE per the definition of the Robinson
C projection.  The values are associated with values of latitude from
C 0 North to 90 North at five-degree intervals.
C
        DATA PDFE( 1) / 0.0000D0 /
        DATA PDFE( 2) / 0.0620D0 /
        DATA PDFE( 3) / 0.1240D0 /
        DATA PDFE( 4) / 0.1860D0 /
        DATA PDFE( 5) / 0.2480D0 /
        DATA PDFE( 6) / 0.3100D0 /
        DATA PDFE( 7) / 0.3720D0 /
        DATA PDFE( 8) / 0.4340D0 /
        DATA PDFE( 9) / 0.4958D0 /
        DATA PDFE(10) / 0.5571D0 /
        DATA PDFE(11) / 0.6176D0 /
        DATA PDFE(12) / 0.6769D0 /
        DATA PDFE(13) / 0.7346D0 /
        DATA PDFE(14) / 0.7903D0 /
        DATA PDFE(15) / 0.8435D0 /
        DATA PDFE(16) / 0.8936D0 /
        DATA PDFE(17) / 0.9394D0 /
        DATA PDFE(18) / 0.9761D0 /
        DATA PDFE(19) / 1.0000D0 /
C
C Determine where the parallel of interest lies relative to the ones
C represented in the tables (between the ones associated with elements
C ILAT and ILAT+1 and a fractional distance FLAT from the former to the
C latter).
C
        ILAT=MAX(1,MIN(18,INT(1.D0+ABS(RLAT)/5.D0)))
C
        FLAT=1.D0+ABS(RLAT)/5.D0-DBLE(ILAT)
C
C Return the desired value.
C
        RBGDFE=.5072D0*SIGN((1.D0-FLAT)*PDFE(ILAT)+
     +                             FLAT*PDFE(ILAT+1),RLAT)
C
C Done.
C
        RETURN
C
      END


Module schapery_mod
  ! Module for all Schapery theory-related work

Contains

  Function Schapery_damage(m, eps, Sr_old) result(Sr)
    ! Determine the current Schapery damage state variable based on the current strain state.

    Use matProp_Mod

    ! Arguments
    Type(matProps), intent(IN) :: m
    Double Precision, intent(IN) :: eps(3,3)            ! strain tensor
    Double Precision, intent(IN) :: Sr_old              ! previous converged value for Schapery damage
    Double Precision  :: Sr

    ! Locals
    Double Precision :: Sr_A, Sr_B, Sr_C
    Parameter (zero=0.d0, one=1.d0, two=2.d0, three=3.d0, four=4.d0, six=6.d0)
    ! -------------------------------------------------------------------- !

    ! Determine the reduce Schapery damage state variable, Sr
    Sr_A = ( eps(2,2)**2*m%E2*m%es(4) + (two*eps(1,2))**2*m%G12*m%gs(4) ) / two + one
    Sr_B = ( eps(2,2)**2*m%E2*m%es(3) + (two*eps(1,2))**2*m%G12*m%gs(3) ) / three
    Sr_C = ( eps(2,2)**2*m%E2*m%es(2) + (two*eps(1,2))**2*m%G12*m%gs(2) ) / six

    Sr = ( -Sr_B + SQRT( Sr_B*Sr_B - four*Sr_A*Sr_C ) ) / ( two*Sr_A )

    Sr = max(Sr, Sr_old)

    Return
  End Function Schapery_damage

  Function Schapery_reduction(Sr, c) result(reduction)
    ! Calculates the stiffness reduction according to Schapery theory.

    ! Arguments
    Double Precision, intent(IN) :: Sr           ! Reduced Schapery damage state variable
    Double Precision, intent(IN) :: c(4)         ! Schapery coefficients
    Double Precision :: reduction
    ! -------------------------------------------------------------------- !

    reduction = c(1) + c(2)*Sr + c(3)*Sr**2 + c(4)*Sr**3

    Return
  End Function Schapery_reduction

End Module schapery_mod


!===============================================================================
program chi2_95
!===============================================================================
!  Compute percentage points of the chi-2 probability distribution
   use statistical
   implicit none

   integer,parameter :: rs=8
   real(rs) :: p,v,g
   character(20) :: arg

   if (command_argument_count() /= 1) then
      write(*,'(a)') 'Usage: chi2_95 [degrees of freedom]'
      stop
   endif

   call get_command_argument(1,arg) ; read(arg,*) v
   p = 0.05
   g = log_gamma(v/2._rs)

   write(*,*) ppchi2(p,v,g)

end program chi2_95


!======================================================================
! SUBRUTINA GENERADORA DE VALORES ALEATORIOS CON UNA DISTRIBUCION
! GAUSSIANA.
!
! AUTOR: MARTIN ALEJANDRO PAREDES SOSA
! MODIFICACION DEL DE GABY
!======================================================================

Subroutine RanGauss(Gauss)
  Use cte
  Implicit None

  Real :: Rand1, Rand2 !VALORES ALEATORIOS CON DISTRIBUCION UNIFORME
  Real :: Gauss        !VALORES ALEATORIOS CON DISTRIBUCION GAUSSIANA

  !GENERANDO NUMEROS ALEATORIOS UNIFORMES
12 Call random_number(Rand1)
  Call random_number(Rand2)

  !PREVENIR QUE DIVERJA EL LOGARITMO AL EVALUARLO EN Rand1
  Diver:If (rand1.le.1E-8) Then
     go to 12
  End If Diver

  !GENERANDO UN NUMERO ALEATORIOS CON DISTRIBUCION GAUSSIANA
  Gauss = Sqrt ( -2.0 * log(Rand1) ) * cos(2.0 * pi * Rand2)

End Subroutine RanGauss


!
!*******************************************************************************
!
subroutine log_fact(lfactc, faclog)
!
!*******************************************************************************
!
!  Discussion:
!
!    This subroutine sets up a stored array of the log of n factorial
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   implicit none
   integer(kind=4), intent(in) :: lfactc
   real(kind=8), intent(out) :: faclog(lfactc)
   integer(kind=4) :: i
   real(kind=8) :: fn
!-------------------------------------------------------------------------------
   faclog(1) = 0.0d0
   faclog(2) = 0.0d0
   fn = 1.0d0
   do i = 3, lfactc
      fn = fn + 1.0d0
      faclog(i) = faclog(i-1) + log(fn)
   end do
   return
end subroutine log_fact
!
!*******************************************************************************
!
real(kind=8) function wigner3j(j1,j2,j3,m1,m2,m3)
!
!*******************************************************************************
!
!  Discussion:
!
!    This function computes the Wigner 3J symbol
!    Modified from a FORTRAN77 code of unknown origin
!    Converted and updtated to FORTRAN 90 to remove outdated
!    FORTRAN
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     Functions:
!
!        real(kind=8) :: phase
!        logical :: frac
!        logical :: triangle
!
!     MPI routines:
!
!        None
!
!  Dependencies:
!
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL updated to FORTRAN 90 removing computed IF and GOTO
!      statements
!
!*******************************************************************************
!
!----   uses array fact inside module log_factorial
   use log_factorial
   implicit none
   real(kind=8), intent(in) :: j1, m1, j2, m2, j3, m3
!-------------------------------------------------------------------
   real(kind=8) :: x, y, z

   integer(kind=4) :: ia, ib, ic, id, ie
   integer(kind=4) :: i
   integer(kind=4) :: ih, ii, ij, ik, il, im, in
   integer(kind=4) :: ix, iy, iz
   integer(kind=4) :: minn, nin
   real(kind=8) :: s, t, ta, tb, xddd
!----    Function definitions    ------------------------------
   real(kind=8) :: phase
   logical :: frac, triangle
!----  Phase (-1)**i
   phase(i) = (-1.0d0)**i
!----  Check x is an integer
   frac(x) = abs(x-int(x)) > 1.0d-10
!----   Triangle relation to check if angular momenta can couple
   triangle(x,y,z) = frac(x+y+z) .or. x > y+z .or. x < abs(y-z)
!--------------------------------------------------------------------------
   wigner3j = 0.0d0

   if(abs(m1 + m2 + m3) > 1.0d-6)return    !   check on z-component
   if(triangle(j3,j1,j2))return            !   angular momenta can't couple
   if(j1 - abs(m1) < 0)return           !   m1 > j1 - not allowed
   if(j2 - abs(m2) < 0)return           !   m2 > j1 - not allowed
   if(j3 - abs(m3) < 0)return           !   m3 > j - not allowed

   ia = int(j3 - j2 + m1)

   ib = int(j3 - j1 - m2)

   if(ia < 0)then
      minn = -ia
      if(minn + ib < 0)minn  = -ib
   else
      if(ib < 0)then
         minn = -ia
         if(minn + ib < 0)minn  = -ib
      else
         minn = 0
      end if
   end if

   ic = int(j1 - m1)
   id = int(j2 + m2)
   ie = int(j1 + j2 - j3)
   nin = minn
   t = real(phase(minn),kind=8)
   s = t

   ix = 1
   do while(ix > 0)
      minn = minn + 1
      i = int(j2 - j1 + m3)
      iz = ic - minn + 1
      if(iz > 0)then
         iy = id - minn + 1
         if(iy > 0)then
            ix = ie - minn + 1
            if(ix > 0)then
               ta = real(ix*iy*iz,kind=8)
               tb = real(minn*(ia+minn)*(ib+minn),kind=8)
               t = -t*ta/tb
               s = s + t
            end if
         else
            ix = -1
         end if
      else
         ix = -1
      end if
   end do

   if(abs(s) <= 1.0d-10)then
      wigner3j = 0.0d0
      return
   end if
   ih = int(j1 + m1)
   ii = int(j2 - m2)
   ij = int(j3 + m3)
   ik = int(j3 - m3)
   il = int(j1 + j3 - j2)
   im = int(j2 + j3 - j1)
   in = int(j1 + j2 + j3) + 1
   xddd = 0.5d0*(fact(ih+1) + fact(ic+1) + fact(id+1) +                  &
                 fact(ii+1) + fact(ij+1) + fact(ik+1) +                  &
                 fact(ie+1) + fact(im+1) + fact(il+1) - fact(in+1)) -    &
                 (fact(ic-nin+1) + fact(ia+nin+1) + fact(id-nin+1) +     &
                 fact(ib+nin+1) + fact(nin+1) + fact(ie-nin+1))
   wigner3j = phase(i)*exp(xddd)*s

   return
end function wigner3j
!
!*******************************************************************************
!
real(kind=8) function clebr(j1,m1,j2,m2,j3,m3)
!
!*******************************************************************************
!
!  Discussion:
!
!    This function computes Clebsch-Gordan coefficient
!    Modified from a FORTRAN77 code of unknown origin
!    Converted and updtated to FORTRAN 90 to remove outdated
!    FORTRAN
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        real(kind=8) :: wigner3j
!
!     Functions:
!
!        real(kind=8) :: phase
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL updated to FORTRAN 90 removing computed IF and GOTO
!      statements
!
!*******************************************************************************
!
   implicit none
   real(kind=8), intent(in) :: j1, j2, j3
   real(kind=8), intent(in) :: m1, m2, m3
!---------------------------------------------------------------------------
   integer(kind=4) :: i
   integer(kind=4) :: iphase
!----    External functions
   real(kind=8) :: wigner3j
!----  Function definitions
   real(kind=8) :: phase
   phase(i) = (-1.0d0)**i
!--------------------------------------------------------------

   iphase = nint(-j1 + j2 - m3)

   clebr = phase(iphase)*wigner3j(j1,j2,j3,m1,m2,-m3)*sqrt(2.0d0*j3+1.0d0)

   return
end function clebr
!
!*******************************************************************************
!
real(kind=8) function wigner6j(j1,j2,j3,j4,j5,j6)
!
!*******************************************************************************
!
!  Discussion:
!
!    This function computes Wigner 6J symbols defined in Brink and Satcher
!    Modified from a FORTRAN77 code of unknown origin
!    Converted and updtated to FORTRAN 90 to remove outdated
!    FORTRAN
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     Functions:
!
!        real(kind=8) :: phase
!        logical :: frac
!        logical :: triangle
!
!     MPI routines:
!
!        None
!
!  Dependencies:
!
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
!----   uses array fact inside module log_factorial
   use log_factorial
   implicit none
   real(kind=8), intent(in) :: j1, j2, j3, j4, j5, j6
!---------------------------------------------------------------------------
   integer(kind=4) :: i
   integer(kind=4) :: ia, ib, ic, id, ie, ig, ih, m, n, mup
   integer(kind=4) :: it, iu, iv, iw
   real(kind=8) :: xd
   real(kind=8) :: ta, tb, t, s

   real(kind=8) :: x, y, z
!----    Function definitions    ------------------------------
   real(kind=8) :: phase
   logical :: frac, triangle
!----  Phase (-1)**i
   phase(i) = (-1.0d0)**i
!----  Check x is an integer
   frac(x) = abs(x-int(x)) > 1.0d-10
!----   Triangle relation to check if angular momenta can couple
   triangle(x,y,z) = frac(x+y+z) .or. x > y+z .or. x < abs(y-z)
!--------------------------------------------------------------
!
!   call log_fact(num_fac,fact)

   wigner6j = 0.0d0

   if(triangle(j1,j2,j3))return
   if(triangle(j1,j5,j6))return
   if(triangle(j2,j4,j6))return
   if(triangle(j3,j4,j5))return

   ic = int(j1+j2-j3)
   id = int(j5+j4-j3)
   ie = int(j1+j5-j6)
   ig = int(j2+j4-j6)
   ia = int(j3+j6-j1-j4)
   ib = int(j3+j6-j2-j5)
   ih = int(j1+j2+j5+j4) + 1

   m = min(ih,ic,id,ie,ig)

   if(m < 0)return

   mup = min(ia,ib,0)
   t = phase(m)
   n = m
   s = t

   m = m - 1
   do while((m+mup) >= 0)
      ta = (ia+m+1)*(ib+m+1)*(ih-m)*(m+1)
      tb = (ic-m)*(id-m)*(ie-m)*(ig-m)
      t = -t*ta/tb
      s = s + t
      m = m - 1
   end do

   it = int(j1+j2+j3) + 1
   iu = int(j1+j5+j6) + 1
   iv = int(j2+j4+j6) + 1
   iw = int(j3+j4+j5) + 1

   xd = 0.5d0*(fact(1+ic) + fact(1+ie+ib) + fact(1+ia+ig) +          &
               fact(1+ie) + fact(1+ib+ic) + fact(1+ia+id) +          &
               fact(1+ig) + fact(1+ic+ia) + fact(1+id+ib) +          &
               fact(1+id) + fact(1+ia+ie) + fact(1+ib+ig) -          &
               fact(1+it) - fact(1+iu) - fact(1+iv) - fact(1+iw)) +  &
        fact(1+ih-n) - fact(1+n) - fact(1+ia+n) - fact(1+ib+n) -     &
        fact(1+ic-n) - fact(1+id-n) - fact(1+ie-n) - fact(1+ig-n)
   wigner6j = phase(ih-1)*s*exp(xd)

   return
end function wigner6j
!
!*******************************************************************************
!
real(kind=8) function wigner9j(j1,j2,j3,j4,j5,j6,j7,j8,j9)
!
!*******************************************************************************
!
!  Discussion:
!
!    This function computes Wigner 9J symbols defined in Brink and Satcher
!    Modified from a FORTRAN77 code of unknown origin
!    Converted and updtated to FORTRAN 90 to remove outdated
!    FORTRAN
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        real(kind=8) :: wigner6j
!
!     Functions:
!
!        real(kind=8) :: phase
!        logical :: frac
!        logical :: triangle
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   implicit none
   real(kind=8), intent(in) :: j1, j2, j3, j4, j5, j6, j7, j8, j9
!---------------------------------------------------------------------------
   real(kind=8) :: s
   real(kind=8) :: xa, xb, xc, x
   integer(kind=4) :: k
   integer(kind=4) :: i
   real(kind=8) :: xx, yy, zz
!----  External functions    ---------------------------------------------
   real(kind=8) :: wigner6j
!----    Function definitions    ------------------------------
   real(kind=8) :: phase
   logical :: frac, triangle
!----  Phase (-1)**i
   phase(i) = (-1.0d0)**i
!----  Check x is an integer
   frac(x) = abs(xx-int(xx)) > 1.0d-10
!----   Triangle relation to check if angular momenta can couple
   triangle(xx,yy,zz) = frac(xx+yy+zz) .or. xx > yy+zz .or. xx < abs(yy-zz)
!--------------------------------------------------------------
!
   wigner9j = 0.0d0

   if(triangle(j1,j2,j3))return
   if(triangle(j4,j5,j6))return
   if(triangle(j3,j6,j9))return
   if(triangle(j1,j4,j7))return
   if(triangle(j2,j5,j8))return
   if(triangle(j7,j8,j9))return
   s = 0.0d0

   xa = abs(j1-j9)
   xb = abs(j4-j8)
   xc = abs(j2-j6)
   x = xa

   if((x - xb) < 0)x = xb
   if((x - xc) < 0)x = xc

   do while((x-j1-j9) <= 0.0d0 .and. (x-j4-j8) <= 0.0d0 .and.       &
            (x-j2-j6) <= 0.0d0 )
      s = s + (2.0d0*x+1.0d0)*wigner6j(j1,j9,X,j8,j4,j7)*              &
          wigner6j(j2,j6,X,j4,j8,j5)*wigner6j(j1,j9,X,j6,j2,j3)
      x = x + 1.0d0
   end do

   k = int(2.0d0*(j1+j2+j4+j6+j8+j9))
   wigner9j = phase(k)*s
   return
end function wigner9j
!
!*******************************************************************************
!
real(kind=8) function racahr(j1,j2,j3,j4,j5,j6)
!
!*******************************************************************************
!
!  Discussion:
!
!    This function computes Racah 9J symbols defined in Brink and Satcher
!    Modified from a FORTRAN77 code of unknown origin
!    Converted and updtated to FORTRAN 90 to remove outdated
!    FORTRAN
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        real(kind=8) :: wigner6j
!
!     Functions:
!
!        real(kind=8) :: phase
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   implicit none
   real(kind=8), intent(in) :: j1, j2, j3, j4, j5, j6
!---------------------------------------------------------------------------
   integer(kind=4) :: i
   real(kind=8) :: z
!----    Internal inline function
   real(kind=8) :: phase
!----    External functions      -------------------------------
   real(kind=8) :: wigner6j
!----    Function definitions    ------------------------------
!----   Compute phase (-1)**i
   phase(i) = (-1.0d0)**i
!--------------------------------------------------------------
!
   z = abs(j1+j2+j3+j4)
   i = int(z + 0.5d0)
   racahr = phase(i)*wigner6j(j1,j2,j5,j4,j3,j6)
   return
end function racahr


      program tst
      implicit none
      integer :: num, i, r1, c1, m1, pl,in
      CHARACTER(len=32) :: rt, ct, mt

      num = IARGC()
      pl = (num/3) -1
      in = 0

      do i = 1,num,3
         CALL GETARG(i, rt)
         CALL GETARG(i+1, ct)
         CALL GETARG(i+2, mt)
         read(rt, *) r1
         read(ct, *) c1
         read(mt, *) m1

         CALL rnd(r1,c1,m1)
         if(pl>in)then
            write(*,*) "  "
            pl =pl-1
         endif

      end do
      end program tst

      subroutine rnd(r2, c2, m2)
      implicit none
      integer :: r2, c2, m2, r_rand, c_rand
      integer, allocatable :: seed(:)
      integer :: size
      real :: u

      !generating random numbers
      call random_seed(size=size)
      allocate(seed(size))
      call random_seed(put=seed)
      CALL random_number(u)

      r_rand = 1 + FLOOR((r2-1)*u)
      c_rand = 1 + FLOOR((c2-1)*u)
      call matrx(r_rand, c_rand,m2)

      return
      end subroutine rnd

      subroutine matrx(r,c,m)
      implicit none
      integer :: r,c,m,i,j
      real :: A(r,c), B(c,r), rslt(r,r)

      call random_number(A)
      call random_number(B)

      A = (anint(m*A*1000))/1000.0
      B = (anint(m*B*1000))/1000.0
      rslt = matmul(A,B)

      do i=1,r
         write(*,*) ( rslt(i,j), j=1,r )
      end do

      return
      end subroutine matrx


program test_products
  use mod_orrb
  implicit none

  character(len=*), parameter :: fmt="(A40, 'Time: ',ES8.2,', error: ',ES8.2, ', ', A10)"
  character(len=40) :: test_name

  real(kind=dp) :: t0, t1
  integer(kind=int32) :: ma, na, lbwb, ubwb
  type(error_info) :: error
  real(kind=dp), parameter :: tol=1e-15, c=7.0
  !
  real(kind=dp), dimension(:,:), allocatable :: b_d, a_d, c0_d, c1_d
  complex(kind=dp), dimension(:,:), allocatable :: b_z, a_z, c0_z, c1_z

  type(d_ub), allocatable :: ub_d
  type(d_bv), allocatable :: bv_d
  type(d_wb), allocatable :: wb_d
  type(d_bt), allocatable :: bt_d
  type(d_ubt), allocatable :: ubt_d
  type(d_wbv), allocatable :: wbv_d

  type(z_ub), allocatable :: ub_z
  type(z_bv), allocatable :: bv_z
  type(z_wb), allocatable :: wb_z
  type(z_bt), allocatable :: bt_z
  type(z_ubt), allocatable :: ubt_z
  type(z_wbv), allocatable :: wbv_z

  call initialize_errors
  print *
  print *, "--------------------------------"
  print *
  print *, "Tests of Real Products"
  print *

  ma=40; na=10; lbwb=5; ubwb=7
  a_d=d_random_matrix(ma,na)
  ub_d=d_random_ub(ma,lbwb,ubwb,error=error)
  b_d = general(ub_d,error)
  call cpu_time(t0)
  c0_d=d_product_of_ub_and_general(ub_d,a_d,error)
  call cpu_time(t1)
  c1_d=matmul(b_d,a_d)
  test_name = "Real UB Times Gen. (40x10)"
  call d_output_result(test_name,c0_d,c1_d,t0,t1,c*tol,error)

  ma=40; na=10; lbwb=5; ubwb=7
  a_d=d_random_matrix(ma,na)
  bv_d=d_random_bv(ma,lbwb,ubwb,error=error)
  b_d = general(bv_d,error)
  call cpu_time(t0)
  c0_d=d_product_of_bv_and_general(bv_d,a_d,error)
  call cpu_time(t1)
  c1_d=matmul(b_d,a_d)
  test_name = "Real BV Times Gen. (40x10)"
  call d_output_result(test_name,c0_d,c1_d,t0,t1,c*tol,error)

  ma=40; na=10; lbwb=5; ubwb=7
  a_d=d_random_matrix(ma,na)
  wb_d=d_random_wb(ma,lbwb,ubwb,error=error)
  b_d = general(wb_d,error)
  call cpu_time(t0)
  c0_d=d_product_of_wb_and_general(wb_d,a_d,error)
  call cpu_time(t1)
  c1_d=matmul(b_d,a_d)
  test_name = "Real WB Times Gen. (40x10)"
  call d_output_result(test_name,c0_d,c1_d,t0,t1,c*tol,error)

  ma=40; na=10; lbwb=5; ubwb=7
  a_d=d_random_matrix(ma,na)
  bt_d=d_random_bt(ma,lbwb,ubwb,error=error)
  b_d = general(bt_d,error)
  call cpu_time(t0)
  c0_d=d_product_of_bt_and_general(bt_d,a_d,error)
  call cpu_time(t1)
  c1_d=matmul(b_d,a_d)
  test_name = "Real BT Times Gen. (40x10)"
  call d_output_result(test_name,c0_d,c1_d,t0,t1,c*tol,error)

  ma=40; na=10; lbwb=5; ubwb=7
  a_d=d_random_matrix(ma,na)
  ubt_d=d_random_ubt(ma,lbwb,ubwb,error=error)
  b_d = general(ubt_d,error)
  call cpu_time(t0)
  c0_d=d_product_of_ubt_and_general(ubt_d,a_d,error)
  call cpu_time(t1)
  c1_d=matmul(b_d,a_d)
  test_name = "Real UBT Times Gen. (40x10)"
  call d_output_result(test_name,c0_d,c1_d,t0,t1,c*tol,error)

  ma=40; na=10; lbwb=5; ubwb=7
  a_d=d_random_matrix(ma,na)
  wbv_d=d_random_wbv(ma,lbwb,ubwb,error=error)
  b_d = general(wbv_d,error)
  call cpu_time(t0)
  c0_d=d_product_of_wbv_and_general(wbv_d,a_d,error)
  call cpu_time(t1)
  c1_d=matmul(b_d,a_d)
  test_name = "Real WBV Times Gen. (40x10)"
  call d_output_result(test_name,c0_d,c1_d,t0,t1,c*tol,error)

  ma=10; na=40; lbwb=5; ubwb=7
  a_d=d_random_matrix(ma,na)
  ub_d=d_random_ub(na,lbwb,ubwb,error=error)
  b_d = general(ub_d,error)
  call cpu_time(t0)
  c0_d=d_product_of_general_and_ub(a_d, ub_d,error)
  call cpu_time(t1)
  c1_d=matmul(a_d,b_d)
  test_name = "Real Gen. Times UB. (10x40)"
  call d_output_result(test_name,c0_d,c1_d,t0,t1,c*tol,error)

  print *
  print *, "--------------------------------"
  print *
  print *, "Tests of Complex Products"
  print *

  ma=40; na=10; lbwb=5; ubwb=7
  a_z=z_random_matrix(ma,na)
  ub_z=z_random_ub(ma,lbwb,ubwb,error=error)
  b_z = general(ub_z,error)
  call cpu_time(t0)
  c0_z=z_product_of_ub_and_general(ub_z,a_z,error)
  call cpu_time(t1)
  c1_z=matmul(b_z,a_z)
  test_name = "Complex UB Times Gen. (40x10)"
  call z_output_result(test_name,c0_z,c1_z,t0,t1,c*tol,error)

  ma=40; na=10; lbwb=5; ubwb=7
  a_z=z_random_matrix(ma,na)
  bv_z=z_random_bv(ma,lbwb,ubwb,error=error)
  b_z = general(bv_z,error)
  call cpu_time(t0)
  c0_z=z_product_of_bv_and_general(bv_z,a_z,error)
  call cpu_time(t1)
  c1_z=matmul(b_z,a_z)
  test_name = "Complex BV Times Gen. (40x10)"
  call z_output_result(test_name,c0_z,c1_z,t0,t1,c*tol,error)

  ma=40; na=10; lbwb=5; ubwb=7
  a_z=z_random_matrix(ma,na)
  wb_z=z_random_wb(ma,lbwb,ubwb,error=error)
  b_z = general(wb_z,error)
  call cpu_time(t0)
  c0_z=z_product_of_wb_and_general(wb_z,a_z,error)
  call cpu_time(t1)
  c1_z=matmul(b_z,a_z)
  test_name = "Complex WB Times Gen. (40x10)"
  call z_output_result(test_name,c0_z,c1_z,t0,t1,c*tol,error)

  ma=40; na=10; lbwb=5; ubwb=7
  a_z=z_random_matrix(ma,na)
  bt_z=z_random_bt(ma,lbwb,ubwb,error=error)
  b_z = general(bt_z,error)
  call cpu_time(t0)
  c0_z=z_product_of_bt_and_general(bt_z,a_z,error)
  call cpu_time(t1)
  c1_z=matmul(b_z,a_z)
  test_name = "Complex BT Times Gen. (40x10)"
  call z_output_result(test_name,c0_z,c1_z,t0,t1,c*tol,error)

  ma=40; na=10; lbwb=5; ubwb=7
  a_z=z_random_matrix(ma,na)
  ubt_z=z_random_ubt(ma,lbwb,ubwb,error=error)
  b_z = general(ubt_z,error)
  call cpu_time(t0)
  c0_z=z_product_of_ubt_and_general(ubt_z,a_z,error)
  call cpu_time(t1)
  c1_z=matmul(b_z,a_z)
  test_name = "Complex UBT Times Gen. (40x10)"
  call z_output_result(test_name,c0_z,c1_z,t0,t1,c*tol,error)

  ma=40; na=10; lbwb=5; ubwb=7
  a_z=z_random_matrix(ma,na)
  wbv_z=z_random_wbv(ma,lbwb,ubwb,error=error)
  b_z = general(wbv_z,error)
  call cpu_time(t0)
  c0_z=z_product_of_wbv_and_general(wbv_z,a_z,error)
  call cpu_time(t1)
  c1_z=matmul(b_z,a_z)
  test_name = "Complex WBV Times Gen. (40x10)"
  call z_output_result(test_name,c0_z,c1_z,t0,t1,c*tol,error)

  ma=10; na=40; lbwb=5; ubwb=7
  a_z=z_random_matrix(ma,na)
  ub_z=z_random_ub(na,lbwb,ubwb,error=error)
  b_z = general(ub_z,error)
  call cpu_time(t0)
  c0_z=z_product_of_general_and_ub(a_z, ub_z,error)
  call cpu_time(t1)
  c1_z=matmul(a_z,b_z)
  test_name = "Complex Gen. Times UB. (10x40)"
  call z_output_result(test_name,c0_z,c1_z,t0,t1,c*tol,error)

contains

  subroutine d_output_result(name,a0,a1,t0,t1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    type(error_info) :: error

    real(kind=dp) :: err
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       err = maxabs(a1-a0)
       if (err < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, err, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,t0,t1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    type(error_info) :: error

    real(kind=dp) :: err
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       err = maxabs(a1-a0)
       if (err < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, err, test_result
    end if
  end subroutine z_output_result

end program test_products


module ekat_ut

  use iso_c_binding, only: c_int, c_double, c_float

  implicit none

#ifdef EKAT_TEST_DOUBLE_PRECISION
  integer, parameter :: c_real = c_double
#else
  integer, parameter :: c_real = c_float
#endif

contains

  subroutine linear_interp_c(x1,x2,y1,y2,km1,km2,ncol,minthresh) bind(c)

    integer(kind=c_int), value, intent(in) :: km1, km2, ncol
    real(kind=c_real), value, intent(in) :: minthresh
    real(kind=c_real), intent(in) :: x1(ncol,km1), y1(ncol,km1)
    real(kind=c_real), intent(in) :: x2(ncol,km2)
    real(kind=c_real), intent(out) :: y2(ncol,km2)

    call linear_interp(x1,x2,y1,y2,km1,km2,ncol,minthresh)

  end subroutine linear_interp_c

  !==============================================================
  ! Linear interpolation to get values on various grids

  subroutine linear_interp(x1,x2,y1,y2,km1,km2,ncol,minthresh)
    use iso_c_binding
    implicit none

    integer(kind=c_int), intent(in) :: km1, km2
    integer(kind=c_int), intent(in) :: ncol
    real(kind=c_real), intent(in) :: x1(ncol,km1), y1(ncol,km1)
    real(kind=c_real), intent(in) :: x2(ncol,km2)
    real(kind=c_real), intent(in) :: minthresh
    real(kind=c_real), intent(out) :: y2(ncol,km2)

    integer :: k1, k2, i

    do i=1,ncol
       do k2=1,km2
          if( x2(i,k2) <= x1(i,1) ) then
             y2(i,k2) = y1(i,1) + (y1(i,2)-y1(i,1))*(x2(i,k2)-x1(i,1))/(x1(i,2)-x1(i,1))
          elseif( x2(i,k2) >= x1(i,km1) ) then
             y2(i,k2) = y1(i,km1) + (y1(i,km1)-y1(i,km1-1))*(x2(i,k2)-x1(i,km1))/(x1(i,km1)-x1(i,km1-1))
          else
             do k1 = 2,km1
                if( (x2(i,k2)>=x1(i,k1-1)).and.(x2(i,k2)<x1(i,k1)) ) then
                   y2(i,k2) = y1(i,k1-1) + (y1(i,k1)-y1(i,k1-1))*(x2(i,k2)-x1(i,k1-1))/(x1(i,k1)-x1(i,k1-1))
                endif
             enddo ! end k1 loop
          endif

          if (y2(i,k2) .lt. minthresh) then
             y2(i,k2) = minthresh
          endif

       enddo ! end k2 loop
    enddo ! i loop

    return

end subroutine linear_interp

end module ekat_ut


! Find the kth entry of one in the vth row or column of the matrix A.

function kth_one(arr, v, direction, k, m, n) result(i)

  implicit none

  integer, intent(in) :: direction, m, n, k, v
  integer, intent(in) :: arr(m, n)
  integer :: total, i

  ! Keep track of the number of ones we've seen so far.
  total = 0

  ! If direction==1, then search along column k.
  if (direction .eq. 1) then

     do i=1, m
        if (arr(i, v) .eq. 1) then
           total = total + 1
        end if
        if (total .eq. k) then
           exit
        end if
     end do

  ! Otherwise, if direction==2, then search along row k.
  else

     do i=1, n
        if (arr(v, i) .eq. 1) then
           total = total + 1
        end if
        if (total .eq. k) then
           exit
        end if
     end do

  end if

end function kth_one

! Seed the PRNG with the integer n.

! The random_seed routine requires m seeds, but we just pass the same
! seed n a total of m times for convenience.

subroutine seed_prng(n)

  implicit none

  integer, intent(in) :: n
  integer :: m
  integer, allocatable :: x(:)

  call random_seed(size = m)
  allocate(x(m))
  x = n
  call random_seed(put = x)
  deallocate(x)

end subroutine seed_prng

! Find the smallest index i such that dist(i)>p.

! We use a binary search.

function choice(dist, n, p) result(i)

  implicit none

  integer, intent(in) ::  n
  double precision, intent(in) :: dist(n)
  double precision, intent(in) :: p
  integer :: i

  i = 1
  do while (i<=n .and. dist(i)<p)
    i = i+1
  end do

end function choice

! Construct the normalized cumulative sum of arr.

subroutine cdf(output, arr, n)

  implicit none

  integer, intent(in) :: n
  integer, intent(in) :: arr(n)
  integer :: i
  double precision :: output(n)

  output(1) = arr(1)
  do i=2,n
     output(i) = arr(i) + output(i-1)
  end do
  output = output / sum(arr)

end subroutine cdf

subroutine bipartite_edge_swap(B, A, nswap, max_tries, seed, verbose, m, n)

  implicit none

  logical, intent(in) :: verbose
  integer, intent(in) :: m, n, nswap, max_tries, seed
  integer, intent(in) :: A(m,n)
  integer, intent(out) :: B(m,n)
  integer :: u, v, x1, y1, x2, y2, swapcount, iter, i
  integer :: kth_one, choice
  integer :: x_degrees(m), y_degrees(n)
  double precision :: r(4), x_dist(m), y_dist(n)

  ! Initialize the permuted matrix.
  B = A
  swapcount = 0
  iter = 0

  ! Find the degrees of the nodes in each partition.
  do i=1,m
    x_degrees(i) = sum(B(i,:))
  end do
  do i=1,n
    y_degrees(i) = sum(B(:,i))
  end do

  ! Convert the degree into degree distributions.
  call cdf(x_dist, x_degrees, m)
  call cdf(y_dist, y_degrees, n)

  ! Use the given random seed.
  call seed_prng(seed)

  ! Try to swap until reaching the maximum number of swaps or tries.
  do while (swapcount < nswap .and. iter < max_tries)

    ! Select four random numbers uniformly in [0,1] for each iteration.
    call random_number(r)

    ! Select random nodes in each partition.
    x1 = choice(x_dist, m, r(1))
    y1 = choice(y_dist, n, r(2))

    ! Choose a random neighbor of each node.
    u  = int(r(3) * x_degrees(x1)) + 1
    v  = int(r(4) * y_degrees(y1)) + 1

    y2 = kth_one(B, x1, 2, u, m, n)
    x2 = kth_one(B, y1, 1, v, m, n)

    ! If x1 is not already connected to y1 and x2 is not already
    ! connected to y2, then we can perform the edge swap.

    if ((B(x1, y1) .eq. 0) .and. (B(x2, y2) .eq. 0)) then
      swapcount = swapcount + 1

      ! Update the adjacency matrix.
      B(x1, y1) = 1
      B(x1, y2) = 0
      B(x2, y2) = 1
      B(x2, y1) = 0

    end if

    iter = iter + 1

  end do

  ! Warn if the maximum number of tries were reached.
  if (iter >= max_tries) then
     print *, '[Warning] Bipartite edge swap: Maximum tries exceeded.'
  end if

  if (verbose) then
    print *, 'Number of swaps:        ', swapcount
    print *, 'Maximum number of swaps:', nswap
    print *, 'Number of tries:        ', iter
    print *, 'Maximum number of tries:', max_tries
  end if

end subroutine bipartite_edge_swap


!*****************************************************************************************
!>
!  This program tests codes for the least-squares solution of
!  M nonlinear equations in n variables. it consists of a driver
!  And an interface subroutine fcn. the driver reads in data,
!  Calls the nonlinear least-squares solver, and finally prints
!  Out information on the performance of the solver. this is
!  Only a sample driver, many other drivers are possible. the
!  Interface subroutine fcn is necessary to take into account the
!  Forms of calling sequences used by the function and jacobian
!  Subroutines in the various nonlinear least-squares solvers.
!
!### Reference
!  * ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!    BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE

program test

    use minpack_module
    use iso_fortran_env, only: output_unit

    implicit none

    integer :: i, ic, info, k, ldfjac, lwa, m, n, NFEv, NJEv, NPRob, ntries
    integer :: iwa(40), ma(60), na(60), nf(60), nj(60), np(60), nx(60)
    real(wp) :: factor, fnorm1, fnorm2, tol
    real(wp) :: fjac(65, 40), fnm(60), fvec(65), wa(265), x(40)

    integer, parameter :: nwrite = output_unit ! logical output unit
    real(wp), parameter :: one = 1.0_wp
    real(wp), parameter :: ten = 10.0_wp

    tol = sqrt(dpmpar(1))
    ldfjac = 65
    lwa = 265
    ic = 0
    n = 40
    m = 65
    ntries = 1
    do NPRob = 1, 20
    if (NPRob == 20) then
        write (nwrite, 99002) ic
99002   format('1SUMMARY OF ', i3, ' CALLS TO LMDER1'/)
        write (nwrite, 99003)
99003   format(' NPROB   N    M   NFEV  NJEV  INFO  FINAL L2 NORM'/)
        do i = 1, ic
            write (nwrite, 99004) np(i), na(i), ma(i), nf(i), nj(i),&
                               & nx(i), fnm(i)
99004       format(3i5, 3i6, 1x, d15.7)
        end do
        stop
    else
        factor = one
        do k = 1, ntries
            ic = ic + 1
            call initpt(n, x, NPRob, factor)
            call ssqfcn(m, n, x, fvec, NPRob)
            fnorm1 = enorm(m, fvec)
            write (nwrite, 99005) NPRob, n, m
99005       format(////5x, ' PROBLEM', i5, 5x, ' DIMENSIONS', 2i5, 5x//)
            NFEv = 0
            NJEv = 0
            call lmder1(fcn, m, n, x, fvec, fjac, ldfjac, tol, info, iwa, wa, lwa)
            call ssqfcn(m, n, x, fvec, NPRob)
            fnorm2 = enorm(m, fvec)
            np(ic) = NPRob
            na(ic) = n
            ma(ic) = m
            nf(ic) = NFEv
            nj(ic) = NJEv
            nx(ic) = info
            fnm(ic) = fnorm2
            write (nwrite, 99006) fnorm1, fnorm2, NFEv, NJEv, info, &
                               & (x(i), i=1, n)
99006       format(5x, ' INITIAL L2 NORM OF THE RESIDUALS', d15.7//5x, &
                   ' FINAL L2 NORM OF THE RESIDUALS  ', d15.7//5x, &
                   ' NUMBER OF FUNCTION EVALUATIONS  ', i10//5x, &
                   ' NUMBER OF JACOBIAN EVALUATIONS  ', i10//5x, &
                   ' EXIT PARAMETER', 18x, i10//5x, &
                   ' FINAL APPROXIMATE SOLUTION'//(5x, 5d15.7))
            factor = ten*factor
        end do
    end if
    end do

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

!*****************************************************************************************
!>
!  THE CALLING SEQUENCE OF FCN SHOULD BE IDENTICAL TO THE
!  CALLING SEQUENCE OF THE FUNCTION SUBROUTINE IN THE NONLINEAR
!  LEAST-SQUARES SOLVER. FCN SHOULD ONLY CALL THE TESTING
!  FUNCTION AND JACOBIAN SUBROUTINES SSQFCN AND SSQJAC WITH
!  THE APPROPRIATE VALUE OF PROBLEM NUMBER (NPROB).

    subroutine fcn(m, n, x, Fvec, Fjac, Ldfjac, Iflag)

        implicit none

        integer, intent(in) :: m !! the number of functions.
        integer, intent(in) :: n !! the number of variables.
        integer, intent(in) :: ldfjac !! leading dimension of the array fjac.
        integer, intent(inout) :: iflag !! if iflag = 1 calculate the functions at x and
                                       !! return this vector in fvec. do not alter fjac.
                                       !! if iflag = 2 calculate the jacobian at x and
                                       !! return this matrix in fjac. do not alter fvec.
                                       !!
                                       !! the value of iflag should not be changed by fcn unless
                                       !! the user wants to terminate execution of lmder.
                                       !! in this case set iflag to a negative integer.
        real(wp), intent(in) :: x(n) !! independant variable vector
        real(wp), intent(inout) :: fvec(m) !! value of function at `x`
        real(wp), intent(inout) :: fjac(ldfjac, n) !! jacobian matrix at `x`

        select case (iflag)
        case (1)
            call ssqfcn(m, n, x, Fvec, NPRob)
            NFEv = NFEv + 1
        case (2)
            call ssqjac(m, n, x, Fjac, Ldfjac, NPRob)
            NJEv = NJEv + 1
        case default
            error stop 'invalid iflag value'
        end select

    end subroutine fcn
!*****************************************************************************************

!*****************************************************************************************
!>
!  Replaced statement function in original code.

    pure elemental function dfloat(i) result(f)
        implicit none
        integer, intent(in) :: i
        real(wp) :: f
        f = real(i, wp)
    end function dfloat
!*****************************************************************************************

!*****************************************************************************************
!
!  This subroutine defines the jacobian matrices of eighteen
!  nonlinear least squares problems. The problem dimensions are
!  as described in the prologue comments of [[ssqfcn]].

    subroutine ssqjac(m, n, x, Fjac, Ldfjac, Nprob)
        implicit none

        integer, intent(in) :: m !! positive integer input variables. n must not exceed m.
        integer, intent(in) :: n !! positive integer input variables. n must not exceed m.
        integer, intent(in) :: ldfjac !! a positive integer input variable not less than m
                                   !! which specifies the leading dimension of the array fjac.
        integer, intent(in) :: nprob !! a positive integer variable which defines the
                                  !! number of the problem. nprob must not exceed 18.
        real(wp), intent(in) :: x(n) !! an input array of length n.
        real(wp), intent(out) :: fjac(ldfjac, n) !! an m by n output array which contains the jacobian
                                             !! matrix of the nprob function evaluated at x.

        real(wp), parameter :: v(11) = [4.0_wp, 2.0_wp, 1.0_wp, 5.0e-1_wp, &
                                        2.5e-1_wp, 1.67e-1_wp, 1.25e-1_wp, 1.0e-1_wp, &
                                        8.33e-2_wp, 7.14e-2_wp, 6.25e-2_wp]

        real(wp), parameter :: zero = 0.0_wp
        real(wp), parameter :: one = 1.0_wp
        real(wp), parameter :: two = 2.0_wp
        real(wp), parameter :: three = 3.0_wp
        real(wp), parameter :: four = 4.0_wp
        real(wp), parameter :: five = 5.0_wp
        real(wp), parameter :: eight = 8.0_wp
        real(wp), parameter :: ten = 10.0_wp
        real(wp), parameter :: c14 = 14.0_wp
        real(wp), parameter :: c20 = 20.0_wp
        real(wp), parameter :: c29 = 29.0_wp
        real(wp), parameter :: c45 = 45.0_wp
        real(wp), parameter :: c100 = 100.0_wp

        integer :: i, ivar, j, k, mm1, nm1
        real(wp) :: div, dx, prod, s2, temp, ti, tmp1, tmp2, tmp3, tmp4, tpi

        Fjac(1:m, 1:n) = zero

        ! JACOBIAN ROUTINE SELECTOR.

        select case (Nprob)
        case (2)

            ! LINEAR FUNCTION - RANK 1.

            do j = 1, n
                do i = 1, m
                    Fjac(i, j) = dfloat(i)*dfloat(j)
                end do
            end do

        case (3)

            ! LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.

            do j = 1, n
                do i = 1, m
                    Fjac(i, j) = zero
                end do
            end do
            nm1 = n - 1
            mm1 = m - 1
            if (nm1 >= 2) then
                do j = 2, nm1
                    do i = 2, mm1
                        Fjac(i, j) = dfloat(i - 1)*dfloat(j)
                    end do
                end do
            end if

        case (4)

            ! ROSENBROCK FUNCTION.

            Fjac(1, 1) = -c20*x(1)
            Fjac(1, 2) = ten
            Fjac(2, 1) = -one
            Fjac(2, 2) = zero

        case (5)

            ! HELICAL VALLEY FUNCTION.

            tpi = eight*atan(one)
            temp = x(1)**2 + x(2)**2
            tmp1 = tpi*temp
            tmp2 = sqrt(temp)
            Fjac(1, 1) = c100*x(2)/tmp1
            Fjac(1, 2) = -c100*x(1)/tmp1
            Fjac(1, 3) = ten
            Fjac(2, 1) = ten*x(1)/tmp2
            Fjac(2, 2) = ten*x(2)/tmp2
            Fjac(2, 3) = zero
            Fjac(3, 1) = zero
            Fjac(3, 2) = zero
            Fjac(3, 3) = one

        case (6)

            ! POWELL SINGULAR FUNCTION.

            do j = 1, 4
                do i = 1, 4
                    Fjac(i, j) = zero
                end do
            end do
            Fjac(1, 1) = one
            Fjac(1, 2) = ten
            Fjac(2, 3) = sqrt(five)
            Fjac(2, 4) = -Fjac(2, 3)
            Fjac(3, 2) = two*(x(2) - two*x(3))
            Fjac(3, 3) = -two*Fjac(3, 2)
            Fjac(4, 1) = two*sqrt(ten)*(x(1) - x(4))
            Fjac(4, 4) = -Fjac(4, 1)

        case (7)

            ! FREUDENSTEIN AND ROTH FUNCTION.

            Fjac(1, 1) = one
            Fjac(1, 2) = x(2)*(ten - three*x(2)) - two
            Fjac(2, 1) = one
            Fjac(2, 2) = x(2)*(two + three*x(2)) - c14

        case (8)

            ! BARD FUNCTION.

            do i = 1, 15
                tmp1 = dfloat(i)
                tmp2 = dfloat(16 - i)
                tmp3 = tmp1
                if (i > 8) tmp3 = tmp2
                tmp4 = (x(2)*tmp2 + x(3)*tmp3)**2
                Fjac(i, 1) = -one
                Fjac(i, 2) = tmp1*tmp2/tmp4
                Fjac(i, 3) = tmp1*tmp3/tmp4
            end do

        case (9)

            ! KOWALIK AND OSBORNE FUNCTION.

            do i = 1, 11
                tmp1 = v(i)*(v(i) + x(2))
                tmp2 = v(i)*(v(i) + x(3)) + x(4)
                Fjac(i, 1) = -tmp1/tmp2
                Fjac(i, 2) = -v(i)*x(1)/tmp2
                Fjac(i, 3) = Fjac(i, 1)*Fjac(i, 2)
                Fjac(i, 4) = Fjac(i, 3)/v(i)
            end do

        case (10)

            ! MEYER FUNCTION.

            do i = 1, 16
                temp = five*dfloat(i) + c45 + x(3)
                tmp1 = x(2)/temp
                tmp2 = exp(tmp1)
                Fjac(i, 1) = tmp2
                Fjac(i, 2) = x(1)*tmp2/temp
                Fjac(i, 3) = -tmp1*Fjac(i, 2)
            end do

        case (11)

            ! WATSON FUNCTION.

            do i = 1, 29
                div = dfloat(i)/c29
                s2 = zero
                dx = one
                do j = 1, n
                    s2 = s2 + dx*x(j)
                    dx = div*dx
                end do
                temp = two*div*s2
                dx = one/div
                do j = 1, n
                    Fjac(i, j) = dx*(dfloat(j - 1) - temp)
                    dx = div*dx
                end do
            end do
            do j = 1, n
                do i = 30, 31
                    Fjac(i, j) = zero
                end do
            end do
            Fjac(30, 1) = one
            Fjac(31, 1) = -two*x(1)
            Fjac(31, 2) = one

        case (12)

            ! BOX 3-DIMENSIONAL FUNCTION.

            do i = 1, m
                temp = dfloat(i)
                tmp1 = temp/ten
                Fjac(i, 1) = -tmp1*exp(-tmp1*x(1))
                Fjac(i, 2) = tmp1*exp(-tmp1*x(2))
                Fjac(i, 3) = exp(-temp) - exp(-tmp1)
            end do

        case (13)

            ! JENNRICH AND SAMPSON FUNCTION.

            do i = 1, m
                temp = dfloat(i)
                Fjac(i, 1) = -temp*exp(temp*x(1))
                Fjac(i, 2) = -temp*exp(temp*x(2))
            end do

        case (14)

            ! BROWN AND DENNIS FUNCTION.

            do i = 1, m
                temp = dfloat(i)/five
                ti = sin(temp)
                tmp1 = x(1) + temp*x(2) - exp(temp)
                tmp2 = x(3) + ti*x(4) - cos(temp)
                Fjac(i, 1) = two*tmp1
                Fjac(i, 2) = temp*Fjac(i, 1)
                Fjac(i, 3) = two*tmp2
                Fjac(i, 4) = ti*Fjac(i, 3)
            end do

        case (15)

            ! CHEBYQUAD FUNCTION.

            dx = one/dfloat(n)
            do j = 1, n
                tmp1 = one
                tmp2 = two*x(j) - one
                temp = two*tmp2
                tmp3 = zero
                tmp4 = two
                do i = 1, m
                    Fjac(i, j) = dx*tmp4
                    ti = four*tmp2 + temp*tmp4 - tmp3
                    tmp3 = tmp4
                    tmp4 = ti
                    ti = temp*tmp2 - tmp1
                    tmp1 = tmp2
                    tmp2 = ti
                end do
            end do

        case (16)

            ! BROWN ALMOST-LINEAR FUNCTION.

            prod = one
            do j = 1, n
                prod = x(j)*prod
                do i = 1, n
                    Fjac(i, j) = one
                end do
                Fjac(j, j) = two
            end do
            do j = 1, n
                temp = x(j)
                if (temp == zero) then
                    temp = one
                    prod = one
                    do k = 1, n
                        if (k /= j) prod = x(k)*prod
                    end do
                end if
                Fjac(n, j) = prod/temp
            end do

        case (17)

            ! OSBORNE 1 FUNCTION.

            do i = 1, 33
                temp = ten*dfloat(i - 1)
                tmp1 = exp(-x(4)*temp)
                tmp2 = exp(-x(5)*temp)
                Fjac(i, 1) = -one
                Fjac(i, 2) = -tmp1
                Fjac(i, 3) = -tmp2
                Fjac(i, 4) = temp*x(2)*tmp1
                Fjac(i, 5) = temp*x(3)*tmp2
            end do

        case (18)

            ! OSBORNE 2 FUNCTION.

            do i = 1, 65
                temp = dfloat(i - 1)/ten
                tmp1 = exp(-x(5)*temp)
                tmp2 = exp(-x(6)*(temp - x(9))**2)
                tmp3 = exp(-x(7)*(temp - x(10))**2)
                tmp4 = exp(-x(8)*(temp - x(11))**2)
                Fjac(i, 1) = -tmp1
                Fjac(i, 2) = -tmp2
                Fjac(i, 3) = -tmp3
                Fjac(i, 4) = -tmp4
                Fjac(i, 5) = temp*x(1)*tmp1
                Fjac(i, 6) = x(2)*(temp - x(9))**2*tmp2
                Fjac(i, 7) = x(3)*(temp - x(10))**2*tmp3
                Fjac(i, 8) = x(4)*(temp - x(11))**2*tmp4
                Fjac(i, 9) = -two*x(2)*x(6)*(temp - x(9))*tmp2
                Fjac(i, 10) = -two*x(3)*x(7)*(temp - x(10))*tmp3
                Fjac(i, 11) = -two*x(4)*x(8)*(temp - x(11))*tmp4
            end do

        case default

            ! LINEAR FUNCTION - FULL RANK.

            temp = two/dfloat(m)
            do j = 1, n
                do i = 1, m
                    Fjac(i, j) = -temp
                end do
                Fjac(j, j) = Fjac(j, j) + one
            end do

        end select

    end subroutine ssqjac
!*****************************************************************************************

!*****************************************************************************************
!>
!  This subroutine specifies the standard starting points for the
!  functions defined by subroutine [[ssqfcn]]. the subroutine returns
!  in x a multiple (factor) of the standard starting point. for
!  the 11th function the standard starting point is zero, so in
!  this case, if factor is not unity, then the subroutine returns
!  the vector  x(j) = factor, j=1,...,n.

    subroutine initpt(n, x, Nprob, Factor)
        implicit none

        integer, intent(in) :: n !! a positive integer input variable.
        integer, intent(in) :: nprob !! a positive integer input variable which defines the
                                  !! number of the problem. nprob must not exceed 18.
        real(wp), intent(in) :: factor !! an input variable which specifies the multiple of
                                    !! the standard starting point. if factor is unity, no
                                    !! multiplication is performed.
        real(wp), intent(out) :: x(n) !! an output array of length n which contains the standard
                                   !! starting point for problem nprob multiplied by factor.

        real(wp), parameter :: zero = 0.0_wp
        real(wp), parameter :: half = 0.5_wp
        real(wp), parameter :: one = 1.0_wp
        real(wp), parameter :: two = 2.0_wp
        real(wp), parameter :: three = 3.0_wp
        real(wp), parameter :: five = 5.0_wp
        real(wp), parameter :: seven = 7.0_wp
        real(wp), parameter :: ten = 10.0_wp
        real(wp), parameter :: twenty = 20.0_wp
        real(wp), parameter :: twntf = 25.0_wp

        real(wp), parameter :: c1 = 1.2_wp
        real(wp), parameter :: c2 = 2.5e-1_wp
        real(wp), parameter :: c3 = 3.9e-1_wp
        real(wp), parameter :: c4 = 4.15e-1_wp
        real(wp), parameter :: c5 = 2.0e-2_wp
        real(wp), parameter :: c6 = 4.0e3_wp
        real(wp), parameter :: c7 = 2.5e2_wp
        real(wp), parameter :: c8 = 3.0e-1_wp
        real(wp), parameter :: c9 = 4.0e-1_wp
        real(wp), parameter :: c10 = 1.5_wp
        real(wp), parameter :: c11 = 1.0e-2_wp
        real(wp), parameter :: c12 = 1.3_wp
        real(wp), parameter :: c13 = 6.5e-1_wp
        real(wp), parameter :: c14 = 7.0e-1_wp
        real(wp), parameter :: c15 = 6.0e-1_wp
        real(wp), parameter :: c16 = 4.5_wp
        real(wp), parameter :: c17 = 5.5_wp

        integer :: ivar, j
        real(wp) :: h

        x(1:n) = zero

        ! SELECTION OF INITIAL POINT.

        select case (Nprob)
        case (4)

            ! ROSENBROCK FUNCTION.

            x(1) = -c1
            x(2) = one

        case (5)

            ! HELICAL VALLEY FUNCTION.

            x(1) = -one
            x(2) = zero
            x(3) = zero

        case (6)

            ! POWELL SINGULAR FUNCTION.

            x(1) = three
            x(2) = -one
            x(3) = zero
            x(4) = one

        case (7)

            ! FREUDENSTEIN AND ROTH FUNCTION.

            x(1) = half
            x(2) = -two

        case (8)

            ! BARD FUNCTION.

            x(1) = one
            x(2) = one
            x(3) = one

        case (9)

            ! KOWALIK AND OSBORNE FUNCTION.

            x(1) = c2
            x(2) = c3
            x(3) = c4
            x(4) = c3

        case (10)

            ! MEYER FUNCTION.

            x(1) = c5
            x(2) = c6
            x(3) = c7

        case (11)

            ! WATSON FUNCTION.

            do j = 1, n
                x(j) = zero
            end do

        case (12)

            ! BOX 3-DIMENSIONAL FUNCTION.

            x(1) = zero
            x(2) = ten
            x(3) = twenty

        case (13)

            ! JENNRICH AND SAMPSON FUNCTION.

            x(1) = c8
            x(2) = c9

        case (14)

            ! BROWN AND DENNIS FUNCTION.

            x(1) = twntf
            x(2) = five
            x(3) = -five
            x(4) = -one

        case (15)

            ! CHEBYQUAD FUNCTION.

            h = one/dfloat(n + 1)
            do j = 1, n
                x(j) = dfloat(j)*h
            end do

        case (16)

            ! BROWN ALMOST-LINEAR FUNCTION.

            do j = 1, n
                x(j) = half
            end do

        case (17)

            ! OSBORNE 1 FUNCTION.

            x(1) = half
            x(2) = c10
            x(3) = -one
            x(4) = c11
            x(5) = c5

        case (18)

            ! OSBORNE 2 FUNCTION.

            x(1) = c12
            x(2) = c13
            x(3) = c13
            x(4) = c14
            x(5) = c15
            x(6) = three
            x(7) = five
            x(8) = seven
            x(9) = two
            x(10) = c16
            x(11) = c17

        case default

            ! LINEAR FUNCTION - FULL RANK OR RANK 1.

            do j = 1, n
                x(j) = one
            end do

        end select

        ! COMPUTE MULTIPLE OF INITIAL POINT.

        if (Factor /= one) then
            if (Nprob == 11) then
                do j = 1, n
                    x(j) = Factor
                end do
            else
                do j = 1, n
                    x(j) = Factor*x(j)
                end do
            end if
        end if

    end subroutine initpt
!*****************************************************************************************

!*****************************************************************************************
!>
!  THIS SUBROUTINE DEFINES THE FUNCTIONS OF EIGHTEEN NONLINEAR
!  LEAST SQUARES PROBLEMS. THE ALLOWABLE VALUES OF (M,N) FOR
!  FUNCTIONS 1,2 AND 3 ARE VARIABLE BUT WITH M .GE. N.
!  FOR FUNCTIONS 4,5,6,7,8,9 AND 10 THE VALUES OF (M,N) ARE
!  (2,2),(3,3),(4,4),(2,2),(15,3),(11,4) AND (16,3), RESPECTIVELY.
!  FUNCTION 11 (WATSON) HAS M = 31 WITH N USUALLY 6 OR 9.
!  HOWEVER, ANY N, N = 2,...,31, IS PERMITTED.
!  FUNCTIONS 12,13 AND 14 HAVE N = 3,2 AND 4, RESPECTIVELY, BUT
!  ALLOW ANY M .GE. N, WITH THE USUAL CHOICES BEING 10,10 AND 20.
!  FUNCTION 15 (CHEBYQUAD) ALLOWS M AND N VARIABLE WITH M .GE. N.
!  FUNCTION 16 (BROWN) ALLOWS N VARIABLE WITH M = N.
!  FOR FUNCTIONS 17 AND 18, THE VALUES OF (M,N) ARE
!  (33,5) AND (65,11), RESPECTIVELY.

    subroutine ssqfcn(m, n, x, Fvec, Nprob)

        implicit none

        integer,intent(in) :: m !! positive integer input variable. n must not exceed m.
        integer,intent(in) :: n !! positive integer input variable. n must not exceed m.
        integer,intent(in) :: nprob !! a positive integer input variable which defines the
                                    !! number of the problem. nprob must not exceed 18.
        real(wp),intent(in) :: x(n) !! an input array of length n.
        real(wp),intent(out) :: fvec(m) !! an output array of length m which contains the nprob
                                        !! function evaluated at x.

        real(wp),parameter :: zero  = 0.0_wp
        real(wp),parameter :: zp25  = 0.25_wp
        real(wp),parameter :: zp5   = 0.5_wp
        real(wp),parameter :: one   = 1.0_wp
        real(wp),parameter :: two   = 2.0_wp
        real(wp),parameter :: five  = 5.0_wp
        real(wp),parameter :: eight = 8.0_wp
        real(wp),parameter :: ten   = 10.0_wp
        real(wp),parameter :: c13   = 13.0_wp
        real(wp),parameter :: c14   = 14.0_wp
        real(wp),parameter :: c29   = 29.0_wp
        real(wp),parameter :: c45   = 45.0_wp

        integer :: i, iev, ivar, j, nm1
        real(wp) :: div, dx, prod, sum, s1, s2, temp, ti, &
                    tmp1, tmp2, tmp3, tmp4, tpi

        real(wp),parameter :: v(11) = [ &
             4.0_wp, 2.0_wp, 1.0_wp, 5.0e-1_wp, 2.5e-1_wp, 1.67e-1_wp, &
             1.25e-1_wp, 1.0e-1_wp, 8.33e-2_wp, 7.14e-2_wp, 6.25e-2_wp]
        real(wp),parameter :: y1(15) = [ &
             1.4e-1_wp, 1.8e-1_wp, 2.2e-1_wp, 2.5e-1_wp, 2.9e-1_wp, 3.2e-1_wp, &
             3.5e-1_wp, 3.9e-1_wp, 3.7e-1_wp, 5.8e-1_wp, 7.3e-1_wp, 9.6e-1_wp, &
             1.34_wp, 2.1_wp, 4.39_wp]
        real(wp),parameter :: y2(11) = [1.957e-1_wp, 1.947e-1_wp, &
             1.735e-1_wp, 1.6e-1_wp, 8.44e-2_wp, 6.27e-2_wp, 4.56e-2_wp, 3.42e-2_wp,  &
             3.23e-2_wp, 2.35e-2_wp, 2.46e-2_wp ]
        real(wp),parameter :: y3(16) = [ &
             3.478e4_wp, 2.861e4_wp, 2.365e4_wp, 1.963e4_wp, &
             1.637e4_wp, 1.372e4_wp, 1.154e4_wp, 9.744e3_wp, 8.261e3_wp, 7.03e3_wp,   &
             6.005e3_wp, 5.147e3_wp, 4.427e3_wp, 3.82e3_wp, 3.307e3_wp, 2.872e3_wp ]
        real(wp),parameter :: y4(33) = [ 8.44e-1_wp,&
             9.08e-1_wp, 9.32e-1_wp, 9.36e-1_wp, 9.25e-1_wp, 9.08e-1_wp, 8.81e-1_wp,  &
             8.5e-1_wp, 8.18e-1_wp, 7.84e-1_wp, 7.51e-1_wp, 7.18e-1_wp, 6.85e-1_wp,   &
             6.58e-1_wp, 6.28e-1_wp, 6.03e-1_wp, 5.8e-1_wp, 5.58e-1_wp, 5.38e-1_wp,   &
             5.22e-1_wp, 5.06e-1_wp, 4.9e-1_wp, 4.78e-1_wp, 4.67e-1_wp, 4.57e-1_wp,   &
             4.48e-1_wp, 4.38e-1_wp, 4.31e-1_wp, 4.24e-1_wp, 4.2e-1_wp, 4.14e-1_wp,   &
             4.11e-1_wp, 4.06e-1_wp ]
        real(wp),parameter :: y5(65) = [ 1.366_wp, &
             1.191_wp, 1.112_wp, 1.013_wp, 9.91e-1_wp, 8.85e-1_wp, 8.31e-1_wp,  &
             8.47e-1_wp, 7.86e-1_wp, 7.25e-1_wp, 7.46e-1_wp, 6.79e-1_wp, 6.08e-1_wp,  &
             6.55e-1_wp, 6.16e-1_wp, 6.06e-1_wp, 6.02e-1_wp, 6.26e-1_wp, 6.51e-1_wp,  &
             7.24e-1_wp, 6.49e-1_wp, 6.49e-1_wp, 6.94e-1_wp, 6.44e-1_wp, 6.24e-1_wp,  &
             6.61e-1_wp, 6.12e-1_wp, 5.58e-1_wp, 5.33e-1_wp, 4.95e-1_wp, 5.0e-1_wp,   &
             4.23e-1_wp, 3.95e-1_wp, 3.75e-1_wp, 3.72e-1_wp, 3.91e-1_wp, 3.96e-1_wp,  &
             4.05e-1_wp, 4.28e-1_wp, 4.29e-1_wp, 5.23e-1_wp, 5.62e-1_wp, 6.07e-1_wp,  &
             6.53e-1_wp, 6.72e-1_wp, 7.08e-1_wp, 6.33e-1_wp, 6.68e-1_wp, 6.45e-1_wp,  &
             6.32e-1_wp, 5.91e-1_wp, 5.59e-1_wp, 5.97e-1_wp, 6.25e-1_wp, 7.39e-1_wp,  &
             7.1e-1_wp, 7.29e-1_wp, 7.2e-1_wp, 6.36e-1_wp, 5.81e-1_wp, 4.28e-1_wp,    &
             2.92e-1_wp, 1.62e-1_wp, 9.8e-2_wp, 5.4e-2_wp ]

        ! initialize:
        fvec = zero

        ! FUNCTION ROUTINE SELECTOR.

        select case (Nprob)
        case (2)

            ! LINEAR FUNCTION - RANK 1.

            sum = zero
            do j = 1, n
                sum = sum + dfloat(j)*x(j)
            end do
            do i = 1, m
                Fvec(i) = dfloat(i)*sum - one
            end do
        case (3)

            ! LINEAR FUNCTION - RANK 1 WITH ZERO COLUMNS AND ROWS.

            sum = zero
            nm1 = n - 1
            if (nm1 >= 2) then
                do j = 2, nm1
                    sum = sum + dfloat(j)*x(j)
                end do
            end if
            do i = 1, m
                Fvec(i) = dfloat(i - 1)*sum - one
            end do
            Fvec(m) = -one
        case (4)

            ! ROSENBROCK FUNCTION.

            Fvec(1) = ten*(x(2) - x(1)**2)
            Fvec(2) = one - x(1)
        case (5)

            ! HELICAL VALLEY FUNCTION.

            tpi = eight*atan(one)
            tmp1 = sign(zp25, x(2))
            if (x(1) > zero) tmp1 = atan(x(2)/x(1))/tpi
            if (x(1) < zero) tmp1 = atan(x(2)/x(1))/tpi + zp5
            tmp2 = sqrt(x(1)**2 + x(2)**2)
            Fvec(1) = ten*(x(3) - ten*tmp1)
            Fvec(2) = ten*(tmp2 - one)
            Fvec(3) = x(3)
        case (6)

            ! POWELL SINGULAR FUNCTION.

            Fvec(1) = x(1) + ten*x(2)
            Fvec(2) = sqrt(five)*(x(3) - x(4))
            Fvec(3) = (x(2) - two*x(3))**2
            Fvec(4) = sqrt(ten)*(x(1) - x(4))**2
        case (7)

            ! FREUDENSTEIN AND ROTH FUNCTION.

            Fvec(1) = -c13 + x(1) + ((five - x(2))*x(2) - two)*x(2)
            Fvec(2) = -c29 + x(1) + ((one + x(2))*x(2) - c14)*x(2)
        case (8)

            ! BARD FUNCTION.

            do i = 1, 15
                tmp1 = dfloat(i)
                tmp2 = dfloat(16 - i)
                tmp3 = tmp1
                if (i > 8) tmp3 = tmp2
                Fvec(i) = y1(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3))
            end do
        case (9)

            ! KOWALIK AND OSBORNE FUNCTION.

            do i = 1, 11
                tmp1 = v(i)*(v(i) + x(2))
                tmp2 = v(i)*(v(i) + x(3)) + x(4)
                Fvec(i) = y2(i) - x(1)*tmp1/tmp2
            end do
        case (10)

            ! MEYER FUNCTION.

            do i = 1, 16
                temp = five*dfloat(i) + c45 + x(3)
                tmp1 = x(2)/temp
                tmp2 = exp(tmp1)
                Fvec(i) = x(1)*tmp2 - y3(i)
            end do
        case (11)

            ! WATSON FUNCTION.

            do i = 1, 29
                div = dfloat(i)/c29
                s1 = zero
                dx = one
                do j = 2, n
                    s1 = s1 + dfloat(j - 1)*dx*x(j)
                    dx = div*dx
                end do
                s2 = zero
                dx = one
                do j = 1, n
                    s2 = s2 + dx*x(j)
                    dx = div*dx
                end do
                Fvec(i) = s1 - s2**2 - one
            end do
            Fvec(30) = x(1)
            Fvec(31) = x(2) - x(1)**2 - one
        case (12)

            ! BOX 3-DIMENSIONAL FUNCTION.

            do i = 1, m
                temp = dfloat(i)
                tmp1 = temp/ten
                Fvec(i) = exp(-tmp1*x(1)) - exp(-tmp1*x(2)) &
                        & + (exp(-temp) - exp(-tmp1))*x(3)
            end do
        case (13)

            ! JENNRICH AND SAMPSON FUNCTION.

            do i = 1, m
                temp = dfloat(i)
                Fvec(i) = two + two*temp - exp(temp*x(1)) - exp(temp*x(2))
            end do
        case (14)

            ! BROWN AND DENNIS FUNCTION.

            do i = 1, m
                temp = dfloat(i)/five
                tmp1 = x(1) + temp*x(2) - exp(temp)
                tmp2 = x(3) + sin(temp)*x(4) - cos(temp)
                Fvec(i) = tmp1**2 + tmp2**2
            end do
        case (15)

            ! CHEBYQUAD FUNCTION.

            do i = 1, m
                Fvec(i) = zero
            end do
            do j = 1, n
                tmp1 = one
                tmp2 = two*x(j) - one
                temp = two*tmp2
                do i = 1, m
                    Fvec(i) = Fvec(i) + tmp2
                    ti = temp*tmp2 - tmp1
                    tmp1 = tmp2
                    tmp2 = ti
                end do
            end do
            dx = one/dfloat(n)
            iev = -1
            do i = 1, m
                Fvec(i) = dx*Fvec(i)
                if (iev > 0) Fvec(i) = Fvec(i) + one/(dfloat(i)**2 - one)
                iev = -iev
            end do
        case (16)

            ! BROWN ALMOST-LINEAR FUNCTION.

            sum = -dfloat(n + 1)
            prod = one
            do j = 1, n
                sum = sum + x(j)
                prod = x(j)*prod
            end do
            do i = 1, n
                Fvec(i) = x(i) + sum
            end do
            Fvec(n) = prod - one
        case (17)

            ! OSBORNE 1 FUNCTION.

            do i = 1, 33
                temp = ten*dfloat(i - 1)
                tmp1 = exp(-x(4)*temp)
                tmp2 = exp(-x(5)*temp)
                Fvec(i) = y4(i) - (x(1) + x(2)*tmp1 + x(3)*tmp2)
            end do
        case (18)

            ! OSBORNE 2 FUNCTION.

            do i = 1, 65
                temp = dfloat(i - 1)/ten
                tmp1 = exp(-x(5)*temp)
                tmp2 = exp(-x(6)*(temp - x(9))**2)
                tmp3 = exp(-x(7)*(temp - x(10))**2)
                tmp4 = exp(-x(8)*(temp - x(11))**2)
                Fvec(i) = y5(i) - (x(1)*tmp1 + x(2)*tmp2 + x(3)*tmp3 + x(4)*tmp4)
            end do
        case default

            ! LINEAR FUNCTION - FULL RANK.

            sum = zero
            do j = 1, n
                sum = sum + x(j)
            end do
            temp = two*sum/dfloat(m) + one
            do i = 1, m
                Fvec(i) = -temp
                if (i <= n) Fvec(i) = Fvec(i) + x(i)
            end do
        end select

    end subroutine ssqfcn
!*****************************************************************************************

!*****************************************************************************************
    end program test
!*****************************************************************************************


	include 'VICMAIN_FOR'
	subroutine main44

	implicit none
	real*4	buffer(32000)
	real*4	mean,sigma
	real*4	x,y,u,t
	real*4	ranx,rany
	integer*4	nl,ns
	integer*4	cnt,status
	integer*4	line,samp
	integer*4	unit,seed
	integer*8 dseed
	character*8 format

	call xvmessage('gausnois version 2016-06-08',' ')
	call xvp('NL',nl,cnt)
	call xvp('NS',ns,cnt)
	call xvp('FORMAT',format,cnt)

	call xvunit(unit,'OUT',1,status,' ')
	call xvopen(unit,status, 'IO_ACT','SA','OPEN_ACT','SA',
     +		'OP','WRITE',  'U_FORMAT','REAL', 'O_FORMAT',format,
     +		'U_NL',NL, 'U_NS',NS,' ')
	call xvp('SEED',seed,cnt)
	dseed = seed
c	get_seconds parm is (long)
	if (cnt .eq. 0)  then				!no seed entered
		call get_seconds(dseed)			!p2 subroutine
	endif
        call xvp('MEAN',mean,cnt)
        call xvp('SIGMA',sigma,cnt)
c	rangen parms are (long,float)
	do line = 1,nl
	    do samp = 1,ns
		call rangen(dseed,ranx)
		call rangen(dseed,rany)
		x = max( ranx, 1.0e-10)
		y = rany
		u = sqrt((-2.)*log(x)) * cos(2*3.1415927*y)
		t = sigma*u
		buffer(samp) = sigma*u + mean
	    enddo
	    call xvwrit(unit,buffer,status,' ')
	enddo

	call xvclose(unit,status,' ')

	return
	end


!> \brief Compute the potential vorticity, z
!! \detail Given the current pressure and velocity fields,
!! computes the potential voriticity.
module compute_z_mod
  use kind_params_mod
  use kernel_mod
  use argument_mod
  use grid_mod
  use field_mod
  implicit none

  private

  public invoke_compute_z
  public compute_z, compute_z_code

  type, extends(kernel_type) :: compute_z
     type(go_arg), dimension(6) :: meta_args =      &
          (/ go_arg(GO_WRITE, GO_CF, GO_POINTWISE), & ! z
             go_arg(GO_READ,  GO_CT, GO_POINTWISE), & ! p
             go_arg(GO_READ,  GO_CU, GO_POINTWISE), & ! u
             go_arg(GO_READ,  GO_CV, GO_POINTWISE), & ! v
             go_arg(GO_READ,  GO_GRID_DX_CONST),    & ! dx
             go_arg(GO_READ,  GO_GRID_DY_CONST)     & ! dy
           /)
     !> This kernel operates on fields that live on an
     !! orthogonal, regular grid.
     integer :: GRID_TYPE = GO_ORTHOGONAL_REGULAR

     !> This kernel writes only to internal points of the
     !! simulation domain.
     integer :: ITERATES_OVER = GO_INTERNAL_PTS

     !> Although the staggering of variables used in an Arakawa
     !! C grid is well defined, the way in which they are indexed is
     !! an implementation choice. This can be thought of as choosing
     !! which grid-point types have the same (i,j) index as a T
     !! point. This kernel assumes that the U,V and F points that
     !! share the same index as a given T point are those immediately
     !! to the South and West of it.
     integer :: index_offset = GO_OFFSET_SW

   contains
     procedure, nopass :: code => compute_z_code
  end type compute_z

contains

  !===================================================

  !> Manual implementation of the code needed to invoke
  !! compute_z_code().
  subroutine invoke_compute_z(zfld, pfld, ufld, vfld)
    implicit none
    type(r2d_field), intent(inout) :: zfld
    type(r2d_field), intent(in)    :: pfld, ufld, vfld
    ! Locals
    integer :: I, J
    real(go_wp) :: dx, dy

    dx = zfld%grid%dx
    dy = zfld%grid%dy

    do J=zfld%internal%ystart, zfld%internal%ystop, 1
       do I=zfld%internal%xstart, zfld%internal%xstop, 1

          call compute_z_code(i, j,      &
                              zfld%data, &
                              pfld%data, &
                              ufld%data, &
                              vfld%data, &
                              dx, dy)

       end do
    end do

  end subroutine invoke_compute_z

  !===================================================

  !> Compute the potential vorticity on the grid point (i,j)
  subroutine compute_z_code(i, j, z, p, u, v, dx, dy)
    implicit none
    integer,  intent(in) :: I, J
    real(go_wp), intent(in) :: dx, dy
    real(go_wp), intent(inout), dimension(:,:) :: z
    real(go_wp), intent(in),  dimension(:,:) :: p, u, v

    ! Original code looked like:
    ! DO J=1,N
    !    DO I=1,M
    !       Z(I+1,J+1) =(FSDX*(V(I+1,J+1)-V(I,J+1))-FSDY*(U(I+1,J+1) &
    !                    -U(I+1,J)))/(P(I,J)+P(I+1,J)+P(I+1,J+1)+P(I,J+1))

    Z(I,J) =( (4.0d0/dx)*( V(I,J)-V(I-1,J))-    &
              (4.0d0/dy)*( U(I,J)-U(I,J-1)) ) / &
            (P(I-1,J-1)+P(I,J-1)+ P(I,J)+P(I-1,J))

  end subroutine compute_z_code

end module compute_z_mod


module ccm_numz
! basic real types
    integer, parameter:: b8 = selected_real_kind(10)
contains
     function ccm_time()
        implicit none
        integer i
        integer :: ccm_start_time(8) = (/(-100,i=1,8)/)
        real(b8) :: ccm_time,tmp
        integer,parameter :: norm(13)=(/  &
               0, 2678400, 5097600, 7776000,10368000,13046400,&
        15638400,18316800,20995200,23587200,26265600,28857600,31536000/)
        integer,parameter :: leap(13)=(/  &
               0, 2678400, 5184000, 7862400,10454400,13132800,&
        15724800,18403200,21081600,23673600,26352000,28944000,31622400/)
        integer :: values(8),m,sec
        save
        call date_and_time(values=values)
        if(mod(values(1),4) .eq. 0)then
           m=leap(values(2))
        else
           m=norm(values(2))
        endif
        sec=((values(3)*24+values(5))*60+values(6))*60+values(7)
        tmp=real(m,b8)+real(sec,b8)+real(values(8),b8)/1000.0_b8
        !write(*,*)"vals ",values
        if(values(1) .ne. ccm_start_time(1))then
            if(mod(ccm_start_time(1),4) .eq. 0)then
                tmp=tmp+real(leap(13),b8)
            else
                tmp=tmp+real(norm(13),b8)
            endif
        endif
        ccm_time=tmp
    end function

subroutine invert (matrix,size)
    implicit none
    real(b8) matrix(:,:)
    integer size
    integer switch,k, jj, kp1, i, j, l, krow, irow,nmax
    parameter (nmax=1000)
    dimension switch(nmax,2)
    real(b8) pivot,temp
    do  k = 1,size
        jj = k
        if (k .ne. size) then
            kp1 = k + 1
            pivot = (matrix(k, k))
            do i = kp1,size
                temp = (matrix(i, k))
                if ( abs(pivot) .lt.  abs(temp)) then
                    pivot = temp
                    jj = i
                endif
            enddo
        endif
        switch(k, 1) = k
        switch(k, 2) = jj
        if (jj .ne. k) then
            do  j = 1 ,size
                temp = matrix(jj, j)
                matrix(jj, j) = matrix(k, j)
                matrix(k, j) = temp
            enddo
        endif
        do j = 1,size
            if (j .ne. k)matrix(k, j) = matrix(k, j) / matrix(k, k)
        enddo
        matrix(k, k) = 1.0_b8 / matrix(k, k)
        do  i = 1,size
            if (i.ne.k) then
                do  j = 1,size
                    if(j.ne.k)matrix(i,j)=matrix(i,j)-matrix(k,j)*matrix(i,k)
                enddo
            endif
        enddo
        do i = 1, size
            if (i .ne. k)matrix(i, k) = -matrix(i, k) * matrix(k, k)
        enddo
    enddo
    do  l = 1,size
        k = size - l + 1
        krow = switch(k, 1)
        irow = switch(k, 2)
        if (krow .ne. irow) then
            do  i = 1,size
                temp = matrix(i, krow)
                matrix(i, krow) = matrix(i, irow)
                matrix(i, irow) = temp
            enddo
        endif
    enddo
end subroutine

subroutine mset(m,  n,  in)
    real(b8) :: m(:,:)
    integer n,in
    integer i,j
    do i=1,n
        do j=1,n
            if( i .eq. j)then
                m(i,j)=in
            else
                m(i,j)=1
            endif
        enddo
    enddo
end subroutine

function mcheck(m,  n,  in)
    real(b8) :: m(:,:)
    real(b8) mcheck,x
    integer n,in
    integer i,j
    x=0
    do i=1,n
        do j=1,n
            if( i .eq. j)then
                x=x+abs(m(i,j)-in)
            else
                x=x+abs(m(i,j)-1)
            endif
        enddo
    enddo
    mcheck=x
end function
end module ccm_numz