submodule (stdlib_stats) stdlib_stats_moment_scalar

  use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
  use stdlib_error, only: error_stop
  use stdlib_optval, only: optval
  implicit none

contains

      module function moment_scalar_2_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in) :: center
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        if (dim >= 1 .and. dim <= 2) then
          res = sum((x - center)**order, dim) / size(x, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_scalar_2_rdp_rdp
      module function moment_scalar_3_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in) :: center
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        if (dim >= 1 .and. dim <= 3) then
          res = sum((x - center)**order, dim) / size(x, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_scalar_3_rdp_rdp
      module function moment_scalar_4_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in) :: center
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        if (dim >= 1 .and. dim <= 4) then
          res = sum((x - center)**order, dim) / size(x, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_scalar_4_rdp_rdp
      module function moment_scalar_2_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in) :: center
        logical, intent(in), optional :: mask
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        if (dim >= 1 .and. dim <= 2) then
          res = sum((x - center)**order, dim) / size(x, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_scalar_2_cdp_cdp
      module function moment_scalar_3_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in) :: center
        logical, intent(in), optional :: mask
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        if (dim >= 1 .and. dim <= 3) then
          res = sum((x - center)**order, dim) / size(x, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_scalar_3_cdp_cdp
      module function moment_scalar_4_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in) :: center
        logical, intent(in), optional :: mask
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        if (dim >= 1 .and. dim <= 4) then
          res = sum((x - center)**order, dim) / size(x, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_scalar_4_cdp_cdp

      module function moment_scalar_2_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp),intent(in) :: center
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        if (dim >= 1 .and. dim <= 2) then
          res = sum( (real(x, dp) - center)**order, dim) / size(x, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_scalar_2_iint32_dp
      module function moment_scalar_3_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp),intent(in) :: center
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        if (dim >= 1 .and. dim <= 3) then
          res = sum( (real(x, dp) - center)**order, dim) / size(x, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_scalar_3_iint32_dp
      module function moment_scalar_4_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp),intent(in) :: center
        logical, intent(in), optional :: mask
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        if (dim >= 1 .and. dim <= 4) then
          res = sum( (real(x, dp) - center)**order, dim) / size(x, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_scalar_4_iint32_dp

      module function moment_mask_scalar_2_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in) :: center
        logical, intent(in) :: mask(:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        if (dim >= 1 .and. dim <= 2) then
          res = sum((x - center)**order, dim, mask) / count(mask, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_mask_scalar_2_rdp_rdp
      module function moment_mask_scalar_3_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in) :: center
        logical, intent(in) :: mask(:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        if (dim >= 1 .and. dim <= 3) then
          res = sum((x - center)**order, dim, mask) / count(mask, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_mask_scalar_3_rdp_rdp
      module function moment_mask_scalar_4_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in) :: center
        logical, intent(in) :: mask(:,:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        if (dim >= 1 .and. dim <= 4) then
          res = sum((x - center)**order, dim, mask) / count(mask, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_mask_scalar_4_rdp_rdp
      module function moment_mask_scalar_2_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in) :: center
        logical, intent(in) :: mask(:,:)
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        if (dim >= 1 .and. dim <= 2) then
          res = sum((x - center)**order, dim, mask) / count(mask, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_mask_scalar_2_cdp_cdp
      module function moment_mask_scalar_3_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in) :: center
        logical, intent(in) :: mask(:,:,:)
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        if (dim >= 1 .and. dim <= 3) then
          res = sum((x - center)**order, dim, mask) / count(mask, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_mask_scalar_3_cdp_cdp
      module function moment_mask_scalar_4_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in) :: center
        logical, intent(in) :: mask(:,:,:,:)
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        if (dim >= 1 .and. dim <= 4) then
          res = sum((x - center)**order, dim, mask) / count(mask, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_mask_scalar_4_cdp_cdp

      module function moment_mask_scalar_2_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in) :: center
        logical, intent(in) :: mask(:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        if (dim >= 1 .and. dim <= 2) then
          res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_mask_scalar_2_iint32_dp
      module function moment_mask_scalar_3_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in) :: center
        logical, intent(in) :: mask(:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        if (dim >= 1 .and. dim <= 3) then
          res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_mask_scalar_3_iint32_dp
      module function moment_mask_scalar_4_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in) :: center
        logical, intent(in) :: mask(:,:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        if (dim >= 1 .and. dim <= 4) then
          res = sum(( real(x, dp) - center)**order, dim, mask) / count(mask, dim)
        else
          call error_stop("ERROR (moment): wrong dimension")
        end if

      end function moment_mask_scalar_4_iint32_dp

end submodule


Subroutine zeroVariable &
    (AE, BE, MaxLRows, XLL, NDim, iDofT, NodELT, Sol0, Sol1, CommonPar, Param, JParam, DelT, DTm, Time)

	use funcAux
	use loadingLib
    implicit none

    !   ===== SUBROUTINE ARGUMENTS  =======
    integer :: MaxLRows,Ndim,iDofT,NodELT ! all integers
    Real*8 :: DelT, DTm,Time ! all reals
    Real*8 :: AE(MaxLRows,MaxLRows), BE(MaxLRows), XLL(*), Sol0(*), Sol1(*), Param(*), JParam(*), CommonPar(*)

    !   =====   END ARGUMENTS  =======

    Real*8 :: pen
    integer :: Nnodes, NdofPerNode
	integer , parameter :: iShift = 3
	integer :: i, j, ip, dof, node

	Nnodes = nint(commonPar(1))
	NdofPerNode = nint(commonPar(2))
	pen = commonPar(3)

	do i = 1, Nnodes
		node = nint(commonPar(iShift + i))
		do j = 1, NdofPerNode
			dof = nint(commonPar(iShift + Nnodes + j))

			ip = (node-1)*idofT + dof

			AE(ip,ip) = pen
			BE(ip) = 0.0d0

		end do
	end do

end subroutine

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine zeroVariableS(Coupling,CommonPar,iDofT,Ndim,MaxLRows,iAdd)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    implicit none

    Integer :: MaxLRows,Ndim,iDofT, iAdd
    Integer   Coupling(MaxLRows,MaxLRows)
    Real*8 CommonPar(*)

    integer :: Nnodes, NdofPerNode
	integer , parameter :: iShift = 3
	integer :: i, j, ip, dof, node

	Nnodes = nint(commonPar(1))
	NdofPerNode = nint(commonPar(2))

	do i = 1, Nnodes
		node = nint(commonPar(iShift + i))
		do j = 1, NdofPerNode
			dof = nint(commonPar(iShift + Nnodes + j))

			ip = (node-1)*idofT + dof

			Coupling(ip,ip) = 1

		end do
	end do

end Subroutine


c=======================================================================
c
c     Linear Algebra - Level 2 BLAS Routines Interfaces
c
c-----------------------------------------------------------------------
c
c     FUNCTION LIST
c
c     (P)
c       PEVEV   : vector product,        z(n) <- x(n).*y(n)
c       PEVJEV  : vector product,        z(n) <- x(n)./y(n)
c       PMLV    : matrix vector product, y(n) <- A(n,n)*x(n) with A low tringular
c       PMTV    : matrix vector product, y(m) <- A'(n,m)*x(n)
c       PMV     : matrix vector product, y(n) <- A(n,m)*x(m)
c       PMVV    : matrix vector product, z(n) <- A(n,m)*x(m) + y(n)
c       PMVX    : matrix vector product, y(n)  <- alpha*A(n,m)*x(m)
c
c       PV      : product vector/vector, A(n,m) <- x(n)*y(m)'
c       PV1     : product vector/vector, A(n,n) <- x(n)*x(n)'
c
c=======================================================================
c
c     subroutine PEVEV
c
c     vector product, z(n) <- x(n).*y(n)
c
c-----------------------------------------------------------------------
      SUBROUTINE PEVEV (n, x, y, z)
c-----------------------------------------------------------------------
c
c     INPUT
c       n : vector size                                          integer
c       x : vector (n)                                            double
c       y : vector (n)                                            double
c
c     OUTPUT
c       z : vector (n)                                            double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, i
      DOUBLE PRECISION x(*), y(*), z(*)
c
      DO i = 1,n
        z(i) = x(i)*y(i)
      ENDDO
      RETURN
      END
c
c=======================================================================
c
c     subroutine PEVJEV
c
c     vector product, z(n) <- x(n)./y(n)
c
c-----------------------------------------------------------------------
      SUBROUTINE PEVJEV (n, x, y, z, info)
c-----------------------------------------------------------------------
c
c     INPUT
c       n    : vector size                                       integer
c       x    : vector (nvect)                                     double
c       y    : vector (nvect)                                     double
c
c     OUTPUT
c       z    : vector (n)                                         double
c       info : diagnostic argument                               integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, info, i
      DOUBLE PRECISION EPS, x(*), y(*), z(*)
      PARAMETER ( EPS = 1.0E-30 )
c
      info = 0
      DO i = 1,n
         IF ( ABS(y(i)) .GT. EPS ) THEN
            z(i) = x(i) / y(i)
         ELSE
            info = -1
         ENDIF
      ENDDO
      RETURN
      END
c
c=======================================================================
c
c     subroutine PMLV
c
c     matrix vector product, y(n) <- A(n,n)*x(n) with A low tringular
c
c-----------------------------------------------------------------------
      SUBROUTINE PMLV ( n, A, x, y )
c-----------------------------------------------------------------------
c
c     INPUT
c       n : matrix size                                          integer
c       A : matrix (n*n)                                          double
c       x : vector (n)                                            double
c
c     OUTPUT
c       y : vector (n)                                            double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, incz
      DOUBLE PRECISION A(n,*), x(*), y(*)
      PARAMETER (incz=1)
c
c     copy y <- x
      CALL YV ( n, x, y )
c
c     y <- A*y, A low triangular
      CALL DTRMV( 'L', 'N', 'N', n, A, n, y, incz)
      RETURN
      END
c
c=======================================================================
c
c     subroutine PMTV
c
c     matrix vector product, y(m) <- A'(n,m)*x(n)
c
c-----------------------------------------------------------------------
      SUBROUTINE PMTV ( n, m, A, x, y )
c-----------------------------------------------------------------------
c
c     INPUT
c       n  : number of rows of the matrix A                      integer
c       m  : number of columns of the matrix A                   integer
c       A  : matrix (n*m)                                         double
c       x  : vector (n)                                           double
c
c     OUTPUT
c       y  : vector(m) = A*x                                      double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, m
      DOUBLE PRECISION A(n,*), x(*), y(*)
      INTEGER incx, incy
      DOUBLE PRECISION alpha, beta
      PARAMETER( incx=1, incy=1 )
      PARAMETER( alpha=1.0d0, beta=0.0d0 )
c
      CALL DGEMV ( 'T', n, m, alpha, A, n, x, incx, beta, y, incy)
      RETURN
      END
c
c=======================================================================
c
c     subroutine PMV
c
c     matrix vector product, y(n) <- A(n,m)*x(m)
c
c-----------------------------------------------------------------------
      SUBROUTINE PMV ( n, m, A, x, y )
c-----------------------------------------------------------------------
c
c     INPUT
c       n  : number of rows of the matrix A                      integer
c       m  : number of columns of the matrix A                   integer
c       A  : matrix (n*m)                                         double
c       x  : vector (m)                                           double
c
c     OUTPUT
c       y  : vector(n) = A*x (n)                                  double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, m
      DOUBLE PRECISION A(n,*), x(*), y(*)
      INTEGER incx, incy
      DOUBLE PRECISION alpha, beta
      PARAMETER( incx=1, incy=1 )
      PARAMETER( alpha=1.0d0, beta=0.0d0 )
c
      CALL DGEMV ( 'N', n, m, alpha, A, n, x, incx, beta, y, incy)
      RETURN
      END
c
c=======================================================================
c
c     subroutine PMVV
c
c     matrix vector multiply: z(n) <- A(n,m)*x(m) + y(n)
c
c-----------------------------------------------------------------------
      SUBROUTINE PMVV ( n, m, A, x, y, z )
c-----------------------------------------------------------------------
c
c     INPUT
c       n : number of rows of the matrix A                       integer
c       m : number of columns of the matrix A                    integer
c       A : matrix (n*m)                                          double
c       x : vector (m)                                            double
c       y : vector (n)                                            double
c
c     OUTPUT
c       z : vector (n)                                            double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, m
      DOUBLE PRECISION A(n,*), x(*), y(*), z(*)
      INTEGER incx, incz
      DOUBLE PRECISION alpha, beta
      PARAMETER( incx=1, incz=1 )
      PARAMETER( alpha=1.0d0, beta=1.0d0 )
c
c     copies z <- y
      CALL YV ( n, y, z )
c
c     z = A*x + z
      CALL DGEMV ( 'N', n, m, alpha, A, n, x, incx, beta, z, incz)
      RETURN
      END
c=======================================================================
c
c     subroutine PMVX
c
c     matrix vector product, y(n) <- alpha*A(n,m)*x(m)
c
c-----------------------------------------------------------------------
      SUBROUTINE PMVX(n, m, A, x, alpha, y, dwork, info)
c-----------------------------------------------------------------------
c
c     INPUT
c       n     : number of rows                                   integer
c       m     : number of columns                                integer
c       A     : matrix (n*m)                                      double
c       x     : vector (m)                                        double
c       alpha : scalar                                            double
c
c     WORKSPACE
c       dwork : m
c
c     OUTPUT
c       y     : vector (n)                                        double
c       info  : diagnostic argument                              integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, m, info
      DOUBLE PRECISION alpha, A(n,*), x(*), y(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     dwork(m) <- alpha*x(m)
      CALL PVX(m, x, alpha, dwork(1))
c
c     y(n) <- A(n,m)*dwork(m)
      CALL PMV(n, m, A, dwork(1), y)
      info = 0
      RETURN
      END
c
c=======================================================================
c
c     subroutine PV
c
c     product vector/vector A(n,m) <- x(n)*y(m)'
c
c-----------------------------------------------------------------------
      subroutine PV ( n, m, x, y, A )
c-----------------------------------------------------------------------
c
c     INPUT
c       n  : size of vector x                                    integer
c       m  : size of vector y                                    integer
c       x  : column vector (n)                                    double
c       y  : raw vector (m)                                       double
c
c     OUTPUT
c       A  : matrix (n,m)                                         double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n, m, incx, incy
      DOUBLE PRECISION alpha, ZERO, x(*), y(*), A(n,*)
      PARAMETER (alpha=1.0, incx=1, incy=1, ZERO = 0.0 )
c
c     A <- 0
      CALL PMX2 ( n, m, A, ZERO)
c
c     A <- alpha*x*y' + A
      CALL DGER(n, m, alpha, x, incx, y, incy, A, n)
      RETURN
      END
c
c=======================================================================
c
c     subroutine PV1
c
c     product vector/vector, A(n,n) <- x(n)*x(n)'
c
c-----------------------------------------------------------------------
      SUBROUTINE PV1 ( n, x, A )
c-----------------------------------------------------------------------
c
c     INPUT
c       n : vector size                                          integer
c       x : column vector (n)                                     double
c
c     OUTPUT
c       A : matrix (n,n)                                          double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
      INTEGER n
      DOUBLE PRECISION x(*), A(n,*)
c
      CALL PV ( n, n, x, x, A )
      RETURN
      END


! { dg-do run }
! { dg-options "-fno-range-check" }
program test
  integer :: i
  i = int(z'FFFFFFFF',kind(i))
  if (i /= -1) STOP 1
  if (int(z'FFFFFFFF',kind(i)) /= -1) STOP 2

  if (popcnt(int(z'0F00F00080000001',8)) /= 10) STOP 3
  if (popcnt(int(z'800F0001',4)) /= 6) STOP 4

end program test


*=======================================================================
*
* WCSLIB 4.24 - an implementation of the FITS WCS standard.
* Copyright (C) 1995-2014, Mark Calabretta
*
* This file is part of WCSLIB.
*
* WCSLIB is free software: you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* WCSLIB is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with WCSLIB.  If not, see http://www.gnu.org/licenses.
*
* Direct correspondence concerning WCSLIB to mark@calabretta.id.au
*
* Author: Mark Calabretta, Australia Telescope National Facility, CSIRO.
* http://www.atnf.csiro.au/people/Mark.Calabretta
* $Id: tlog.f,v 4.24 2014/09/18 15:25:02 mcalabre Exp $
*=======================================================================

      PROGRAM TLOG
*-----------------------------------------------------------------------
*
* TLOG tests the logarithmic coordinate transformation routines for
* closure.
*
*-----------------------------------------------------------------------
      DOUBLE PRECISION TOL
      PARAMETER (TOL = 2D-13)

      INTEGER   NCRD
      PARAMETER (NCRD = 10000)

      INTEGER   J, K, NFAIL, STAT1(NCRD), STAT2(NCRD), STATUS
      DOUBLE PRECISION CRVAL, LOGC(NCRD), RESID, RESMAX, STEP,
     :          X0(NCRD), X1(NCRD)

      DATA CRVAL /3.3D0/

      INCLUDE 'log.inc'
*-----------------------------------------------------------------------

      WRITE (*, 10)
 10   FORMAT ('Testing closure of WCSLIB logarithmic coordinate ',
     :        'routines (tlog.f)',/,
     :        '-------------------------------------------------',
     :        '-----------------')

*     Construct a logarithmic axis and test closure.
      STEP = (40D0/NCRD) / 2D0
      K = -NCRD
      DO 20 J = 1, NCRD
        X0(J) = K*STEP
        K = K + 2
 20   CONTINUE

      WRITE (*, 30) X0(1), X0(NCRD), X0(2) - X0(1)
 30   FORMAT (/,'Logarithmic range:',F6.1,' to',F5.1,', step:',F7.4)

*     Convert the first to the second.
      STATUS = LOGX2S(CRVAL, NCRD, 1, 1, X0, LOGC, STAT1)
      IF (STATUS.NE.0) THEN
        WRITE (*, 40) STATUS
 40     FORMAT ('LOGX2S ERROR',I2,'.')
      END IF

*     Convert the second back to the first.
      STATUS = LOGS2X(CRVAL, NCRD, 1, 1, LOGC, X1, STAT2)
      IF (STATUS.NE.0) THEN
        WRITE (*, 50) STATUS
 50     FORMAT ('LOGS2X ERROR',I2,'.')
      END IF

*     Test closure.
      NFAIL  = 0
      RESMAX = 0D0
      DO 90 J = 1, NCRD
        IF (STAT1(J).NE.0) THEN
          WRITE (*, 60) X0(J), STAT1(J)
 60       FORMAT ('LOGX2S: X =',1PE20.12,' -> log = ???, stat =',I2,'.')
          GO TO 90
        END IF

        IF (STAT2(J).NE.0) THEN
          WRITE (*, 70) X0(J), LOGC(J), STAT2(J)
 70       FORMAT ('LOGS2X: x =',1PE20.12,' -> log =',1PE20.12,
     :            ' -> x = ???, stat =',I2)
          GO TO 90
        END IF

        IF (X0(J).EQ.0D0) THEN
          RESID = ABS(X1(J) - X0(J))
        ELSE
          RESID = ABS((X1(J) - X0(J)) / X0(J))
          IF (RESID.GT.RESMAX) RESMAX = RESID
        END IF

        IF (RESID.GT.TOL) THEN
          NFAIL = NFAIL + 1
          WRITE (*, 80) X0(J), LOGC(J), X1(J), RESID
 80       FORMAT ('LOGX2S: x =',1PE20.12,' -> log =',1PE20.12,' ->',/,
     :            '        x =',1PE20.12,', resid =',1PE20.12)
        END IF
 90   CONTINUE

      IF (RESMAX.GT.TOL) THEN
        WRITE (*, *)
      END IF
      WRITE (*, 100) RESMAX
 100  FORMAT ('LOGX2S/LOGS2X: Maximum closure residual =',1PE8.1)

      IF (NFAIL.NE.0) THEN
        WRITE (*, 110) NFAIL
 110    FORMAT (/,'FAIL:',I5,' closure residuals exceed reporting ',
     :    'tolerance.')
      ELSE
        WRITE (*, 120)
 120    FORMAT (/,'PASS: All closure residuals are within reporting ',
     :    'tolerance.')
      END IF

      END


! A module for performing one-dimensional root finding via
!
!  brent's method (see sub_brent)
!
! Grey Gordon, 2013
! This code may be reproduced and modified provided it is not sold and the author's
! name and this notice remain intact.
!
! modified by Bonnie Jonkman, Envision Energy, 2016
!
module mod_root1dim
   use NWTC_Library
   use AirFoilInfo_Types
   use BEMTUnCoupled, only: BEMTU_InductionWithResidual

    implicit none

   type, public :: fmin_fcnArgs
      real(ReKi)           :: nu
      integer              :: numBlades
      real(ReKi)           :: rlocal
      real(ReKi)           :: chord
      real(ReKi)           :: theta
      real(ReKi)           :: Vx
      real(ReKi)           :: Vy
      real(ReKi)           :: UserProp
      logical              :: useTanInd
      logical              :: useAIDrag
      logical              :: useTIDrag
      logical              :: useHubLoss
      logical              :: useTipLoss
      real(ReKi)           :: hubLossConst
      real(ReKi)           :: tipLossConst
      logical              :: IsValidSolution
      integer(IntKi)       :: errStat       ! Error status of the operation
      character(ErrMsgLen) :: errMsg        ! Error message if ErrStat /= ErrID_None
   end type fmin_fcnArgs

   integer, parameter, private :: SolveKi = ReKi
   real(SolveKi), parameter, private :: xtoler_def = 1d-6, toler_def = 1d-6, printmod_def = -1, maxiter_def = 100

contains

! Tests whether the two functions values bracket a root -- i.e., have different signs
function bracketsRoot(fa,fb) result(tf)
    logical :: tf
    real(SolveKi) :: fa,fb
    tf = sign(1.0_SolveKi,fb)/=sign(1.0_SolveKi,fa)
end function bracketsRoot

! Written using the FORTRAN program zero in "Algorithms for Minimization
! without Derivatives" by Brent.
!
! Description:
!       Returns a zero x of the function f in the given interval [a,b], to within a tolerance 6macheps|x| + 2t,
! where macheps is the relative machine precision and t is a positive tolerance. The procedure assumes that
! f(a) and f(b) have different signs.
subroutine sub_brent(x,a_in,b_in, toler_in,maxiter_in,fcnArgs,AFInfo,fa_in,fb_in,xtoler_in,printmod_in)

    implicit none

    real(ReKi), intent(out) :: x !< solution
    real(ReKi), intent(in) :: a_in  !< lower bound of solution region
    real(ReKi), intent(in) :: b_in  !< upper bound of solution region

    type(fmin_fcnArgs), intent(inout) :: fcnArgs !< function arguments
    TYPE (AFI_ParameterType),  INTENT(IN   ) :: AFInfo  !< The derived type for holding the constant parameters for this airfoil.
    real(ReKi), intent(in),  optional :: toler_in !< induction tolerance
    real(ReKi), intent(in),  optional :: fa_in !< starting value for f(a), if not present, will be evaluated
    real(ReKi), intent(in),  optional :: fb_in !< starting value for f(b), if not present, will be evaluated
    real(ReKi), intent(in),  optional :: xtoler_in !<
    integer,    intent(in),  optional :: printmod_in !< print switch; otherwise uses default printmod_deff
    integer,    intent(in),  optional :: maxiter_in !< maximum number of iterations; otherwise uses default maxiter_def
    ! local
    real(SolveKi), parameter :: machep = epsilon(0.0_SolveKi)
    real(SolveKi) :: c,fa,fb,fc,toler,xtoler,e,d,m,p,q,tol,t,r,s
    real(ReKi) :: a,b
    integer :: maxiter,printmod,iter
    character(len=6) :: step

    integer                 :: ErrStat_a
    character(ErrMsgLen)    :: ErrMsg_a
    logical                 :: ValidPhi_a
    ! Set of get parameters
    toler = 0.0_SolveKi; if (present(toler_in)) toler = toler_in ! Better to use custom toler here
    xtoler = xtoler_def; if (present(xtoler_in)) xtoler = xtoler_in
    maxiter = maxiter_def; if (present(maxiter_in)) maxiter = maxiter_in
    printmod = printmod_def; if (present(printmod_in)) printmod = printmod_in

    ! Set the user chosen tolerance t to xtoler
    if (xtoler<0.0_SolveKi) then
        CALL WrScr('WARNING: xtoler must be positive. Resetting xtoler.')
        xtoler = 0.0_SolveKi
    end if
    t = xtoler

    ! Get initial bracket
    a=a_in
    b=b_in
    if (present(fa_in)) then
        fa = fa_in
    else
        fa = BEMTU_InductionWithResidual( a,  fcnArgs%theta, fcnArgs%nu, fcnArgs%UserProp, fcnArgs%numBlades,  fcnArgs%rlocal, fcnArgs%chord, AFInfo, &
                            fcnArgs%Vx, fcnArgs%Vy, fcnArgs%useTanInd, fcnArgs%useAIDrag, fcnArgs%useTIDrag, fcnArgs%useHubLoss, fcnArgs%useTipLoss,  fcnArgs%hubLossConst, fcnArgs%tipLossConst,  &
                            ValidPhi_a, errStat_a, errMsg_a)
    end if
    if (present(fb_in)) then
        fb = fb_in
    else
        fb = BEMTU_InductionWithResidual( b,  fcnArgs%theta, fcnArgs%nu, fcnArgs%UserProp, fcnArgs%numBlades,  fcnArgs%rlocal, fcnArgs%chord, AFInfo, &
                            fcnArgs%Vx, fcnArgs%Vy, fcnArgs%useTanInd, fcnArgs%useAIDrag, fcnArgs%useTIDrag, fcnArgs%useHubLoss, fcnArgs%useTipLoss,  fcnArgs%hubLossConst, fcnArgs%tipLossConst,  &
                            fcnArgs%IsValidSolution, fcnArgs%errStat, fcnArgs%errMsg)
    end if

    ! Test whether root is bracketed
    if (.not. bracketsRoot(fa,fb)) then
        if (abs(fa)<abs(fb)) then
            call WrScr( 'brent: WARNING: root is not bracketed, returning best endpoint a = '//trim(Num2Lstr(a))//' fa = '//trim(Num2Lstr(fa)) )
            x = a
            fcnArgs%IsValidSolution = ValidPhi_a
            fcnArgs%errStat         = ErrStat_a
            fcnArgs%errMsg          = ErrMsg_a
        else
            call WrScr( 'brent: WARNING: root is not bracketed, returning best endpoint b = '//trim(Num2Lstr(b))//' fb = '//trim(Num2Lstr(fb)) )
            x = b
        end if
        return
    end if

    step = 'init'

    ! At any point in time, b is the best guess of the root, a is the previous value of b,
    ! and the root is bracketed by b and c.
    do iter = 1,maxiter

        if (iter==1 .or. (fb>0.0_SolveKi .and. fc>0.0_SolveKi) .or. (fb<=0.0_SolveKi .and. fc<=0.0_SolveKi)) then
            c = a
            fc = fa
            e = b - a
            d = e
        end if

        ! If c is strictly better than b, swap b and c so b is the best guess.
        if (abs(fc)<abs(fb)) then
            a = b
            b = c
            c  = a
            fa = fb
            fb = fc
            fc = fa
        end if

        ! Set the tolerance. Note: brent is very careful with these things, so don't deviate from this.
        tol = 2.0_SolveKi*machep*abs(b) + t

        ! Determine what half the length of the bracket [b,c] is
        m = 0.5_SolveKi*(c-b)

        ! If taking a bisection step would move the guess of the root less than tol, then return b the best guess.
        if ((abs(m)<=tol) .or. (fb==0.0_SolveKi)) then
            x = b
            return
        end if

        ! Display info
        if (printmod>0 .and. mod(iter,printmod)==0) write(*,"(A,i5,A,e13.5,A,e13.5,A,A)") &
          'brent: iter ',iter,' b',b,' fb',fb,' ',step

        ! If still here, then check whether need to do bisection or can do interpolation
        if ((abs(e)>=tol) .and. (abs(fa)>abs(fb))) then
            s = fb/fa
            if (a/=c) then
                ! Inverse quadratic interpolation
                q = fa/fc
                r = fb/fc
                p = s*(2.0_SolveKi*m*q*(q-r) - (b-a)*(r-1.0_SolveKi))
                q = (q-1.0_SolveKi)*(r-1.0_SolveKi)*(s-1.0_SolveKi)

                step = 'quad'
            else
                ! Linear interpolation
                p = 2.0_SolveKi*m*s
                q = 1.0_SolveKi-s

                step = 'linear'
            end if

            ! Ensure p is positive
            if (p<=0.0_SolveKi) then
                p = -p
            else
                q = -q
            end if

            s = e
            e = d
            if ((2.0_SolveKi*p>=3.0_SolveKi*m*q-abs(tol*q)) .or. &
                (p>=abs(0.5_SolveKi*s*q))) then
                ! Interpolation step failed to produce good step, bisect instead
                e = m
                d = m ! m is half the distance between b and c
                step = 'bisect'
            else
                !  Do interpolation step (either quadratic or linear)
                d = p/q
            end if
        else

            ! Do bisection step
            e = m
            d = m

        end if

        ! Get new points.
        !! Replace a (the old b) with b.
        a = b
        fa = fb

        !!! Increment b by d if that is greater than the tolerance. O/w, increment by tol.
        if (abs(d)<=tol) then
            ! m is .5*(c-b) with the bracket either [b,c] or [c,b].
            if (m > 0.0_SolveKi) then
                ! If m>0d0, then bracket is [b,c] so move towards c by tol
                b = b + tol
            else
                ! If m<=0d0, then bracket is [c,b] so move towards c by tol
                b = b - tol
            end if
        else
            b = b + d
        end if

        !!! Evaluate at the new point
        fb = BEMTU_InductionWithResidual( b,  fcnArgs%theta, fcnArgs%nu, fcnArgs%UserProp, fcnArgs%numBlades,  fcnArgs%rlocal, fcnArgs%chord, AFInfo, &
                            fcnArgs%Vx, fcnArgs%Vy, fcnArgs%useTanInd, fcnArgs%useAIDrag, fcnArgs%useTIDrag, fcnArgs%useHubLoss, fcnArgs%useTipLoss,  fcnArgs%hubLossConst, fcnArgs%tipLossConst,  &
                            fcnArgs%IsValidSolution, fcnArgs%errStat, fcnArgs%errMsg)

        ! Check my custom tolerance
        if (abs(fb)<toler) then
            x = b
            return
        end if

    end do

end subroutine sub_brent

end module mod_root1dim


!
!  Copyright 2020 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!

#include "config.h"

# define DX(dt) idx(ix+(dt)),iy,iz
# define DY(dt) ix,idy(iy+(dt)),iz
# define DZ(dt) ix,iy,idz(iz+(dt))

subroutine calc_gradient_psi(tpsi,gtpsi,is_array,ie_array,is,ie,idx,idy,idz,nabt,matrix_B)
  implicit none
  integer,intent(in)  :: is_array(3),ie_array(3),is(3),ie(3) &
                        ,idx(is(1)-4:ie(1)+4),idy(is(2)-4:ie(2)+4),idz(is(3)-4:ie(3)+4)
  complex(8),intent(in)  :: tpsi(is_array(1):ie_array(1),is_array(2):ie_array(2),is_array(3):ie_array(3))
  real(8)   ,intent(in)  :: nabt(4,3),matrix_B(3,3)
  complex(8),intent(out) :: gtpsi(3,is_array(1):ie_array(1),is_array(2):ie_array(2),is_array(3):ie_array(3))
  !
  integer :: iz,iy,ix
  complex(8) :: w(3)
  real(8) :: Bt(3,3)

  Bt = transpose(matrix_B)

!$OMP parallel do collapse(2) private(iz,iy,ix,w) schedule(runtime)
  do iz=is(3),ie(3)
  do iy=is(2),ie(2)

#ifdef __FUJITSU
!OCL swp
  do ix=is(1),ie(1)
    gtpsi(1,ix,iy,iz) = &
         &  nabt(1,1)*(tpsi(DX(1)) - tpsi(DX(-1))) &
         & +nabt(2,1)*(tpsi(DX(2)) - tpsi(DX(-2))) &
         & +nabt(3,1)*(tpsi(DX(3)) - tpsi(DX(-3))) &
         & +nabt(4,1)*(tpsi(DX(4)) - tpsi(DX(-4)))
  end do

!OCL swp
  do ix=is(1),ie(1)
    gtpsi(2,ix,iy,iz) = &
         &  nabt(1,2)*(tpsi(DY(1)) - tpsi(DY(-1))) &
         & +nabt(2,2)*(tpsi(DY(2)) - tpsi(DY(-2))) &
         & +nabt(3,2)*(tpsi(DY(3)) - tpsi(DY(-3))) &
         & +nabt(4,2)*(tpsi(DY(4)) - tpsi(DY(-4)))
  end do

!OCL swp
  do ix=is(1),ie(1)
    gtpsi(3,ix,iy,iz) = &
         &  nabt(1,3)*(tpsi(DZ(1)) - tpsi(DZ(-1))) &
         & +nabt(2,3)*(tpsi(DZ(2)) - tpsi(DZ(-2))) &
         & +nabt(3,3)*(tpsi(DZ(3)) - tpsi(DZ(-3))) &
         & +nabt(4,3)*(tpsi(DZ(4)) - tpsi(DZ(-4)))
  end do

!OCL swp
  do ix=is(1),ie(1)
    w(:) = gtpsi(:,ix,iy,iz)
    gtpsi(1,ix,iy,iz) = dot_product(matrix_B(:,1),w) ! B^{T} * (nabla) psi
    gtpsi(2,ix,iy,iz) = dot_product(matrix_B(:,2),w) ! B^{T} * (nabla) psi
    gtpsi(3,ix,iy,iz) = dot_product(matrix_B(:,3),w) ! B^{T} * (nabla) psi
  end do

#else
  do ix=is(1),ie(1)
    w(1) =  nabt(1,1)*(tpsi(DX(1)) - tpsi(DX(-1))) &
         & +nabt(2,1)*(tpsi(DX(2)) - tpsi(DX(-2))) &
         & +nabt(3,1)*(tpsi(DX(3)) - tpsi(DX(-3))) &
         & +nabt(4,1)*(tpsi(DX(4)) - tpsi(DX(-4)))

    w(2) =  nabt(1,2)*(tpsi(DY(1)) - tpsi(DY(-1))) &
         & +nabt(2,2)*(tpsi(DY(2)) - tpsi(DY(-2))) &
         & +nabt(3,2)*(tpsi(DY(3)) - tpsi(DY(-3))) &
         & +nabt(4,2)*(tpsi(DY(4)) - tpsi(DY(-4)))

    w(3) =  nabt(1,3)*(tpsi(DZ(1)) - tpsi(DZ(-1))) &
         & +nabt(2,3)*(tpsi(DZ(2)) - tpsi(DZ(-2))) &
         & +nabt(3,3)*(tpsi(DZ(3)) - tpsi(DZ(-3))) &
         & +nabt(4,3)*(tpsi(DZ(4)) - tpsi(DZ(-4)))

    gtpsi(:,ix,iy,iz) = matmul(Bt,w) ! B^{T} * (nabla) psi
  end do
#endif

  end do
  end do
!$OMP end parallel do

  return
end subroutine calc_gradient_psi


subroutine calc_parameters()
    use global, only: fn_uvwtsg_ids,nrecs,dt_file,t_amend,&
                      tend,tend_file, Kvdiff,Khdiff,dt,fn_ids,&
                      khdt2,kvdt2,output_dir,fn_id_mld,NPP,&
                      pickup,DumpClock,tt,tstart,rec_num
    implicit none
    integer*8 :: i,j

    tt=tstart
    rec_num = floor(tt/dt_file)+1
    print*, 'record number in calc_par...',rec_num,tt,tstart

    kvdt2 = sqrt(2*Kvdiff*dt)
    khdt2 = sqrt(2*Khdiff*dt)
    !time stepping
    tend_file=nrecs*dt_file
    if (tend<=0) then
        tend = nrecs*dt_file
    endif
    t_amend=real(dt/dt_file/2d0,8)

    call set_file_ids()

end subroutine calc_parameters


      SUBROUTINE PARCOF (X0,Y0, XCOEFF,YCOEFF, A,B,C)
C  given parametric form, find line coefficients

      REAL  X0,Y0, XCOEFF,YCOEFF, A,B,C

      A =  YCOEFF
      B = -XCOEFF
      C =  XCOEFF*Y0 - YCOEFF*X0

      END


************************************************************************
* SUBROUTINE PLIPU              ALL SYSTEMS                   97/01/22
* PURPOSE :
* EASY TO USE SUBROUTINE FOR LARGE-SCALE UNCONSTRAINED MINIMIZATION.
*
* PARAMETERS :
*  II  NF  NUMBER OF VARIABLES.
*  RI  X(NF)  VECTOR OF VARIABLES.
*  II  IPAR(7)  INTEGER PAREMETERS:
*      IPAR(1)  MAXIMUM NUMBER OF ITERATIONS.
*      IPAR(2)  MAXIMUM NUMBER OF FUNCTION EVALUATIONS.
*      IPAR(3)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PLIP.
*      IPAR(4)  ESTIMATION INDICATOR. IPAR(4)=0-MINIMUM IS NOT
*         ESTIMATED. IPAR(4)=1-MINIMUM IS ESTIMATED BY THE VALUE
*         RPAR(6).
*      IPAR(5)  METHOD USED. IPAR(5)=1-RANK-ONE METHOD.
*         IPAR(5)=2-RANK-TWO METHOD.
*      IPAR(6)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PLIP.
*      IPAR(7)  MAXIMUM NUMBER OF VARIABLE METRIC UPDATES.
*  RI  RPAR(9)  REAL PARAMETERS:
*      RPAR(1)  MAXIMUM STEPSIZE.
*      RPAR(2)  TOLERANCE FOR THE CHANGE OF VARIABLES.
*      RPAR(3)  TOLERANCE FOR THE CHANGE OF FUNCTION VALUES.
*      RPAR(4)  TOLERANCE FOR THE FUNCTION FALUE.
*      RPAR(5)  TOLERANCE FOR THE GRADIENT NORM.
*      RPAR(6)  ESTIMATION OF THE MINIMUM FUNCTION VALUE.
*      RPAR(7)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PLIP.
*      RPAR(8)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PLIP.
*      RPAR(9)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PLIP.
*  RO  F  VALUE OF THE OBJECTIVE FUNCTION.
*  RO  GMAX  MAXIMUM PARTIAL DERIVATIVE.
*  II  IPRNT  PRINT SPECIFICATION. IPRNT=0-NO PRINT.
*         ABS(IPRNT)=1-PRINT OF FINAL RESULTS.
*         ABS(IPRNT)=2-PRINT OF FINAL RESULTS AND ITERATIONS.
*         IPRNT>0-BASIC FINAL RESULTS. IPRNT<0-EXTENDED FINAL
*         RESULTS.
*  IO  ITERM  VARIABLE THAT INDICATES THE CAUSE OF TERMINATION.
*         ITERM=1-IF ABS(X-XO) WAS LESS THAN OR EQUAL TO TOLX IN
*                   MTESX (USUALLY TWO) SUBSEQUENT ITERATIONS.
*         ITERM=2-IF ABS(F-FO) WAS LESS THAN OR EQUAL TO TOLF IN
*                   MTESF (USUALLY TWO) SUBSEQUENT ITERATIONS.
*         ITERM=3-IF F IS LESS THAN OR EQUAL TO TOLB.
*         ITERM=4-IF GMAX IS LESS THAN OR EQUAL TO TOLG.
*         ITERM=6-IF THE TERMINATION CRITERION WAS NOT SATISFIED,
*                   BUT THE SOLUTION OBTAINED IS PROBABLY ACCEPTABLE.
*         ITERM=11-IF NIT EXCEEDED MIT. ITERM=12-IF NFV EXCEEDED MFV.
*         ITERM=13-IF NFG EXCEEDED MFG. ITERM<0-IF THE METHOD FAILED.
*
* VARIABLES IN COMMON /STAT/ (STATISTICS) :
*  IO  NRES  NUMBER OF RESTARTS.
*  IO  NDEC  NUMBER OF MATRIX DECOMPOSITIONS.
*  IO  NIN  NUMBER OF INNER ITERATIONS.
*  IO  NIT  NUMBER OF ITERATIONS.
*  IO  NFV  NUMBER OF FUNCTION EVALUATIONS.
*  IO  NFG  NUMBER OF GRADIENT EVALUATIONS.
*  IO  NFH  NUMBER OF HESSIAN EVALUATIONS.
*
* SUBPROGRAMS USED :
*  S   PLIP  LIMITED MEMORY SHIFTED VARIABLE METRIC METHOD IN THE
*            PRODUCT FORM.
*
* EXTERNAL SUBROUTINES :
*  SE  OBJ  COMPUTATION OF THE VALUE OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL OBJ(NF,X,FF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND FF IS
*         THE VALUE OF THE OBJECTIVE FUNCTION.
*  SE  DOBJ  COMPUTATION OF THE GRADIENT OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL DOBJ(NF,X,GF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND GF(NF)
*         IS THE GRADIENT OF THE OBJECTIVE FUNCTION.
*
      SUBROUTINE PLIPU(NF,X,IPAR,RPAR,F,GMAX,IPRNT,ITERM)
      INTEGER NF,IPAR(7),IPRNT,ITERM
      DOUBLE PRECISION X(*),RPAR(9),F,GMAX
      INTEGER MF,NB,LGF,LS,LXO,LGO,LSO,LXM,LXR,LGR
      INTEGER NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      COMMON /STAT/ NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      DOUBLE PRECISION RA(:)
      ALLOCATABLE RA
      MF=IPAR(7)
      IF (MF.LE.0) MF=10
      ALLOCATE (RA(5*NF+NF*MF+2*MF))
      NB=0
*
*     POINTERS FOR AUXILIARY ARRAYS
*
      LGF=1
      LS=LGF+NF
      LXO=LS+NF
      LGO=LXO+NF
      LSO=LGO+NF
      LXM=LSO+NF
      LXR=LXM+NF*MF
      LGR=LXR+MF
      CALL PLIP(NF,NB,X,IPAR,RA,RA,RA(LGF),RA(LS),RA(LXO),RA(LGO),
     & RA(LSO),RA(LXM),RA(LXR),RA(LGR),RPAR(1),RPAR(2),RPAR(3),RPAR(4),
     & RPAR(5),RPAR(6),GMAX,F,IPAR(1),IPAR(2),IPAR(4),IPAR(5),MF,IPRNT,
     & ITERM)
      DEALLOCATE (RA)
      RETURN
      END
************************************************************************
* SUBROUTINE PLIPS              ALL SYSTEMS                   97/01/22
* PURPOSE :
* EASY TO USE SUBROUTINE FOR LARGE-SCALE BOX CONSTRAINED MINIMIZATION.
*
* PARAMETERS :
*  II  NF  NUMBER OF VARIABLES.
*  RI  X(NF)  VECTOR OF VARIABLES.
*  II  IX(NF)  VECTOR CONTAINING TYPES OF BOUNDS. IX(I)=0-VARIABLE
*         X(I) IS UNBOUNDED. IX(I)=1-LOWER BOUND XL(I).LE.X(I).
*         IX(I)=2-UPPER BOUND X(I).LE.XU(I). IX(I)=3-TWO SIDE BOUND
*         XL(I).LE.X(I).LE.XU(I). IX(I)=5-VARIABLE X(I) IS FIXED.
*  RI  XL(NF)  VECTOR CONTAINING LOWER BOUNDS FOR VARIABLES.
*  RI  XU(NF)  VECTOR CONTAINING UPPER BOUNDS FOR VARIABLES.
*  II  IPAR(7)  INTEGER PAREMETERS:
*      IPAR(1)  MAXIMUM NUMBER OF ITERATIONS.
*      IPAR(2)  MAXIMUM NUMBER OF FUNCTION EVALUATIONS.
*      IPAR(3)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PLIP.
*      IPAR(4)  ESTIMATION INDICATOR. IPAR(4)=0-MINIMUM IS NOT
*         ESTIMATED. IPAR(4)=1-MINIMUM IS ESTIMATED BY THE VALUE
*         RPAR(6).
*      IPAR(5)  METHOD USED. IPAR(5)=1-RANK-ONE METHOD.
*         IPAR(5)=2-RANK-TWO METHOD.
*      IPAR(6)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PLIP.
*      IPAR(7)  MAXIMUM NUMBER OF VARIABLE METRIC UPDATES.
*  RI  RPAR(9)  REAL PARAMETERS:
*      RPAR(1)  MAXIMUM STEPSIZE.
*      RPAR(2)  TOLERANCE FOR THE CHANGE OF VARIABLES.
*      RPAR(3)  TOLERANCE FOR THE CHANGE OF FUNCTION VALUES.
*      RPAR(4)  TOLERANCE FOR THE FUNCTION FALUE.
*      RPAR(5)  TOLERANCE FOR THE GRADIENT NORM.
*      RPAR(6)  ESTIMATION OF THE MINIMUM FUNCTION VALUE.
*      RPAR(7)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PLIP.
*      RPAR(8)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PLIP.
*      RPAR(9)  THIS PARAMETER IS NOT USED IN THE SUBROUTINE PLIP.
*  RO  F  VALUE OF THE OBJECTIVE FUNCTION.
*  RO  GMAX  MAXIMUM PARTIAL DERIVATIVE.
*  II  IPRNT  PRINT SPECIFICATION. IPRNT=0-NO PRINT.
*         ABS(IPRNT)=1-PRINT OF FINAL RESULTS.
*         ABS(IPRNT)=2-PRINT OF FINAL RESULTS AND ITERATIONS.
*         IPRNT>0-BASIC FINAL RESULTS. IPRNT<0-EXTENDED FINAL
*         RESULTS.
*  IO  ITERM  VARIABLE THAT INDICATES THE CAUSE OF TERMINATION.
*         ITERM=1-IF ABS(X-XO) WAS LESS THAN OR EQUAL TO TOLX IN
*                   MTESX (USUALLY TWO) SUBSEQUENT ITERATIONS.
*         ITERM=2-IF ABS(F-FO) WAS LESS THAN OR EQUAL TO TOLF IN
*                   MTESF (USUALLY TWO) SUBSEQUENT ITERATIONS.
*         ITERM=3-IF F IS LESS THAN OR EQUAL TO TOLB.
*         ITERM=4-IF GMAX IS LESS THAN OR EQUAL TO TOLG.
*         ITERM=6-IF THE TERMINATION CRITERION WAS NOT SATISFIED,
*                   BUT THE SOLUTION OBTAINED IS PROBABLY ACCEPTABLE.
*         ITERM=11-IF NIT EXCEEDED MIT. ITERM=12-IF NFV EXCEEDED MFV.
*         ITERM=13-IF NFG EXCEEDED MFG. ITERM<0-IF THE METHOD FAILED.
*
* VARIABLES IN COMMON /STAT/ (STATISTICS) :
*  IO  NRES  NUMBER OF RESTARTS.
*  IO  NDEC  NUMBER OF MATRIX DECOMPOSITIONS.
*  IO  NIN  NUMBER OF INNER ITERATIONS.
*  IO  NIT  NUMBER OF ITERATIONS.
*  IO  NFV  NUMBER OF FUNCTION EVALUATIONS.
*  IO  NFG  NUMBER OF GRADIENT EVALUATIONS.
*  IO  NFH  NUMBER OF HESSIAN EVALUATIONS.
*
* SUBPROGRAMS USED :
*  S   PLIP  LIMITED MEMORY SHIFTED VARIABLE METRIC METHOD IN THE
*            PRODUCT FORM.
*
* EXTERNAL SUBROUTINES :
*  SE  OBJ  COMPUTATION OF THE VALUE OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL OBJ(NF,X,FF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND FF IS
*         THE VALUE OF THE OBJECTIVE FUNCTION.
*  SE  DOBJ  COMPUTATION OF THE GRADIENT OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL DOBJ(NF,X,GF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND GF(NF)
*         IS THE GRADIENT OF THE OBJECTIVE FUNCTION.
*
      SUBROUTINE PLIPS(NF,X,IX,XL,XU,IPAR,RPAR,F,GMAX,IPRNT,ITERM)
      INTEGER NF,IX(*),IPAR(7),IPRNT,ITERM
      DOUBLE PRECISION X(*),XL(*),XU(*),RPAR(9),F,GMAX
      INTEGER MF,NB,LGF,LS,LXO,LGO,LSO,LXM,LXR,LGR
      INTEGER NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      COMMON /STAT/ NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      DOUBLE PRECISION RA(:)
      ALLOCATABLE RA
      MF=IPAR(7)
      IF (MF.LE.0) MF=10
      ALLOCATE (RA(5*NF+NF*MF+2*MF))
      NB=1
*
*     POINTERS FOR AUXILIARY ARRAYS
*
      LGF=1
      LS=LGF+NF
      LXO=LS+NF
      LGO=LXO+NF
      LSO=LGO+NF
      LXM=LSO+NF
      LXR=LXM+NF*MF
      LGR=LXR+MF
      CALL PLIP(NF,NB,X,IX,XL,XU,RA(LGF),RA(LS),RA(LXO),RA(LGO),
     & RA(LSO),RA(LXM),RA(LXR),RA(LGR),RPAR(1),RPAR(2),RPAR(3),RPAR(4),
     & RPAR(5),RPAR(6),GMAX,F,IPAR(1),IPAR(2),IPAR(4),IPAR(5),MF,IPRNT,
     & ITERM)
      DEALLOCATE (RA)
      RETURN
      END
************************************************************************
* SUBROUTINE PLIP               ALL SYSTEMS                   01/09/22
* PURPOSE :
* GENERAL SUBROUTINE FOR LARGE-SCALE BOX CONSTRAINED MINIMIZATION THAT
* USE THE SHIFTED LIMITED MEMORY VARIABLE METRIC METHOD BASED ON THE
* PRODUCT FORM UPDATES.
*
* PARAMETERS :
*  II  NF  NUMBER OF VARIABLES.
*  II  NB  CHOICE OF SIMPLE BOUNDS. NB=0-SIMPLE BOUNDS SUPPRESSED.
*         NB>0-SIMPLE BOUNDS ACCEPTED.
*  RI  X(NF)  VECTOR OF VARIABLES.
*  II  IX(NF)  VECTOR CONTAINING TYPES OF BOUNDS. IX(I)=0-VARIABLE
*         X(I) IS UNBOUNDED. IX(I)=1-LOVER BOUND XL(I).LE.X(I).
*         IX(I)=2-UPPER BOUND X(I).LE.XU(I). IX(I)=3-TWO SIDE BOUND
*         XL(I).LE.X(I).LE.XU(I). IX(I)=5-VARIABLE X(I) IS FIXED.
*  RI  XL(NF)  VECTOR CONTAINING LOWER BOUNDS FOR VARIABLES.
*  RI  XU(NF)  VECTOR CONTAINING UPPER BOUNDS FOR VARIABLES.
*  RA  GF(NF)  GRADIENT OF THE OBJECTIVE FUNCTION.
*  RO  S(NF)  DIRECTION VECTOR.
*  RU  XO(NF)  VECTORS OF VARIABLES DIFFERENCE.
*  RI  GO(NF)  GRADIENTS DIFFERENCE.
*  RA  SO(NF)  AUXILIARY VECTOR.
*  RA  XM(NF*MF)  AUXILIARY VECTOR.
*  RA  XR(MF)  AUXILIARY VECTOR.
*  RA  GR(MF)  AUXILIARY VECTOR.
*  RI  XMAX  MAXIMUM STEPSIZE.
*  RI  TOLX  TOLERANCE FOR CHANGE OF VARIABLES.
*  RI  TOLF  TOLERANCE FOR CHANGE OF FUNCTION VALUES.
*  RI  TOLB  TOLERANCE FOR THE FUNCTION VALUE.
*  RI  TOLG  TOLERANCE FOR THE GRADIENT NORM.
*  RI  FMIN  ESTIMATION OF THE MINIMUM FUNCTION VALUE.
*  RO  GMAX  MAXIMUM PARTIAL DERIVATIVE.
*  RO  F  VALUE OF THE OBJECTIVE FUNCTION.
*  II  MIT  MAXIMUM NUMBER OF ITERATIONS.
*  II  MFV  MAXIMUM NUMBER OF FUNCTION EVALUATIONS.
*  II  IEST  ESTIMATION INDICATOR. IEST=0-MINIMUM IS NOT ESTIMATED.
*         IEST=1-MINIMUM IS ESTIMATED BY THE VALUE FMIN.
*  II  MET  METHOD USED. MET=1-RANK-ONE METHOD. MET=2-RANK-TWO
*         METHOD.
*  II  MF  NUMBER OF LIMITED MEMORY STEPS.
*  II  IPRNT  PRINT SPECIFICATION. IPRNT=0-NO PRINT.
*         ABS(IPRNT)=1-PRINT OF FINAL RESULTS.
*         ABS(IPRNT)=2-PRINT OF FINAL RESULTS AND ITERATIONS.
*         IPRNT>0-BASIC FINAL RESULTS. IPRNT<0-EXTENDED FINAL
*         RESULTS.
*  IO  ITERM  VARIABLE THAT INDICATES THE CAUSE OF TERMINATION.
*         ITERM=1-IF ABS(X-XO) WAS LESS THAN OR EQUAL TO TOLX IN
*                   MTESX (USUALLY TWO) SUBSEQUEBT ITERATIONS.
*         ITERM=2-IF ABS(F-FO) WAS LESS THAN OR EQUAL TO TOLF IN
*                   MTESF (USUALLY TWO) SUBSEQUEBT ITERATIONS.
*         ITERM=3-IF F IS LESS THAN OR EQUAL TO TOLB.
*         ITERM=4-IF GMAX IS LESS THAN OR EQUAL TO TOLG.
*         ITERM=6-IF THE TERMINATION CRITERION WAS NOT SATISFIED,
*                   BUT THE SOLUTION OBTAINED IS PROBABLY ACCEPTABLE.
*         ITERM=11-IF NIT EXCEEDED MIT. ITERM=12-IF NFV EXCEEDED MFV.
*         ITERM=13-IF NFG EXCEEDED MFG. ITERM<0-IF THE METHOD FAILED.
*
* VARIABLES IN COMMON /STAT/ (STATISTICS) :
*  IO  NRES  NUMBER OF RESTARTS.
*  IO  NDEC  NUMBER OF MATRIX DECOMPOSITION.
*  IO  NIN  NUMBER OF INNER ITERATIONS.
*  IO  NIT  NUMBER OF ITERATIONS.
*  IO  NFV  NUMBER OF FUNCTION EVALUATIONS.
*  IO  NFG  NUMBER OF GRADIENT EVALUATIONS.
*  IO  NFH  NUMBER OF HESSIAN EVALUATIONS.
*
* SUBPROGRAMS USED :
*  S   PCBS04  ELIMINATION OF BOX CONSTRAINT VIOLATIONS.
*  S   PS1L01  STEPSIZE SELECTION USING LINE SEARCH.
*  S   PULSP3  SHIFTED VARIABLE METRIC UPDATE.
*  S   PULVP3  SHIFTED LIMITED-MEMORY VARIABLE METRIC UPDATE.
*  S   PYADC0  ADDITION OF A BOX CONSTRAINT.
*  S   PYFUT1  TEST ON TERMINATION.
*  S   PYRMC0  DELETION OF A BOX CONSTRAINT.
*  S   PYTRCD  COMPUTATION OF PROJECTED DIFFERENCES FOR THE VARIABLE METRIC
*         UPDATE.
*  S   PYTRCG  COMPUTATION OF THE PROJECTED GRADIENT.
*  S   PYTRCS  COMPUTATION OF THE PROJECTED DIRECTION VECTOR.
*  S   MXDRMM  MULTIPLICATION OF A ROWWISE STORED DENSE RECTANGULAR
*         MATRIX A BY A VECTOR X.
*  S   MXDCMD  MULTIPLICATION OF A COLUMNWISE STORED DENSE RECTANGULAR
*         MATRIX A BY A VECTOR X AND ADDITION OF THE SCALED VECTOR
*         ALF*Y.
*  S   MXUCOP  COPYING OF A VECTOR.
*  S   MXUDIR  VECTOR AUGMENTED BY THE SCALED VECTOR.
*  RF  MXUDOT  DOT PRODUCT OF TWO VECTORS.
*  S   MXUNEG  COPYING OF A VECTOR WITH CHANGE OF THE SIGN.
*  S   MXUZER  VECTOR ELEMENTS CORRESPONDING TO ACTIVE BOUNDS ARE SET
*         TO ZERO.
*  S   MXVCOP  COPYING OF A VECTOR.
*
* EXTERNAL SUBROUTINES :
*  SE  OBJ  COMPUTATION OF THE VALUE OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL OBJ(NF,X,FF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND FF IS
*         THE VALUE OF THE OBJECTIVE FUNCTION.
*  SE  DOBJ  COMPUTATION OF THE GRADIENT OF THE OBJECTIVE FUNCTION.
*         CALLING SEQUENCE: CALL DOBJ(NF,X,GF) WHERE NF IS THE NUMBER
*         OF VARIABLES, X(NF) IS THE VECTOR OF VARIABLES AND GF(NF)
*         IS THE GRADIENT OF THE OBJECTIVE FUNCTION.
*
* METHOD :
* HYBRID METHOD WITH SPARSE MARWIL UPDATES FOR SPARSE LEAST SQUARES
* PROBLEMS.
*
      SUBROUTINE PLIP(NF,NB,X,IX,XL,XU,GF,S,XO,GO,SO,XM,XR,GR,XMAX,
     & TOLX,TOLF,TOLB,TOLG,FMIN,GMAX,F,MIT,MFV,IEST,MET,MF,IPRNT,ITERM)
      INTEGER NF,NB,IX(*),MIT,MFV,IEST,MET,MF,IPRNT,ITERM
      DOUBLE PRECISION X(*),XL(*),XU(*),GF(*),S(*),XO(*),GO(*),SO(*),
     & XM(*),XR(*),GR(*),XMAX,TOLX,TOLF,TOLG,TOLB,FMIN,GMAX,F
      INTEGER ITERD,ITERS,ITERH,KD,LD,NTESX,NTESF,MTESX,MTESF,MRED,KIT,
     & IREST,KBF,MEC,MES,MES1,MES2,MES3,MAXST,ISYS,ITES,INITS,KTERS,
     & IRES1,IRES2,NRED,INEW,IOLD,I,NN,N,MFG,META,MET3
      DOUBLE PRECISION R,RO,RP,FO,FP,P,PO,PP,GNORM,SNORM,RMIN,RMAX,
     & UMAX,FMAX,DMAX,ETA0,ETA9,EPS8,EPS9,ALF1,ALF2,PAR1,PAR2,PAR,TOLD,
     & TOLS,TOLP
      DOUBLE PRECISION MXUDOT
      INTEGER NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      COMMON /STAT/ NRES,NDEC,NIN,NIT,NFV,NFG,NFH
      IF (ABS(IPRNT).GT.1) WRITE(6,'(1X,''ENTRY TO PLIP :'')')
*
*     INITIATION
*
      KBF=0
      IF (NB.GT.0) KBF=2
      NRES=0
      NDEC=0
      NIN=0
      NIT=0
      NFV=0
      NFG=0
      NFH=0
      ISYS=0
      ITES=1
      MTESX=2
      MTESF=2
      INITS=2
      ITERM=0
      ITERD=0
      ITERS=2
      ITERH=0
      KTERS=3
      IREST=0
      IRES1=999
      IRES2=0
      MRED=10
      META=1
      MET3=4
      MEC=4
      MES=4
      MES1=2
      MES2=2
      MES3=2
      ETA0=1.0D-15
      ETA9=1.0D 120
      EPS8=1.00D 0
      EPS9=1.00D-8
      ALF1=1.0D-10
      ALF2=1.0D 10
      RMAX=ETA9
      DMAX=ETA9
      FMAX=1.0D 20
      IF (IEST.LE.0) FMIN=-1.0D 60
      IF (IEST.GT.0) IEST=1
      IF (XMAX.LE.0.0D 0) XMAX=1.0D 16
      IF (TOLX.LE.0.0D 0) TOLX=1.0D-16
      IF (TOLF.LE.0.0D 0) TOLF=1.0D-14
      IF (TOLG.LE.0.0D 0) TOLG=1.0D-6
      IF (TOLB.LE.0.0D 0) TOLB=FMIN+1.0D-16
      TOLD=1.0D-4
      TOLS=1.0D-4
      TOLP=0.9D 0
      IF (MET.LE.0) MET=2
      IF (MIT.LE.0) MIT=9000
      IF (MFV.LE.0) MFV=9000
      MFG=MFV
      KD= 1
      LD=-1
      KIT=-(IRES1*NF+IRES2)
      FO=FMIN
*
*     INITIAL OPERATIONS WITH SIMPLE BOUNDS
*
      IF (KBF.GT.0) THEN
      DO 2 I = 1,NF
      IF ((IX(I).EQ.3.OR.IX(I).EQ.4) .AND. XU(I).LE.XL(I)) THEN
      XU(I) = XL(I)
      IX(I) = 5
      ELSE IF (IX(I).EQ.5 .OR. IX(I).EQ.6) THEN
      XL(I) = X(I)
      XU(I) = X(I)
      IX(I) = 5
      END IF
    2 CONTINUE
      CALL PCBS04(NF,X,IX,XL,XU,EPS9,KBF)
      CALL PYADC0(NF,N,X,IX,XL,XU,INEW)
      END IF
      IF (ITERM.NE.0) GO TO 11190
      CALL OBJ(NF,X,F)
      NFV=NFV+1
      CALL DOBJ(NF,X,GF)
      NFG=NFG+1
11120 CONTINUE
      CALL PYTRCG(NF,NF,IX,GF,UMAX,GMAX,KBF,IOLD)
      IF (ABS(IPRNT).GT.1)
     & WRITE (6,'(1X,''NIT='',I5,2X,''NFV='',I5,2X,''NFG='',I5,2X,
     & ''F='', G16.9,2X,''G='',E10.3)') NIT,NFV,NFG,F,GMAX
      CALL PYFUT1(NF,F,FO,UMAX,GMAX,DMAX,TOLX,TOLF,TOLB,TOLG,KD,
     & NIT,KIT,MIT,NFV,MFV,NFG,MFG,NTESX,MTESX,NTESF,MTESF,ITES,
     & IRES1,IRES2,IREST,ITERS,ITERM)
      IF (ITERM.NE.0) GO TO 11190
      IF (KBF.GT.0.AND.RMAX.GT.0.0D 0) THEN
      CALL PYRMC0(NF,N,IX,GF,EPS8,UMAX,GMAX,RMAX,IOLD,IREST)
      END IF
11130 CONTINUE
      IF (IREST.GT.0) THEN
      NN=0
      PAR=1.0D 0
      LD=MIN(LD,1)
      IF (KIT.LT.NIT) THEN
        NRES=NRES+1
        KIT = NIT
      ELSE
        ITERM=-10
        IF (ITERS.LT.0) ITERM=ITERS-5
      END IF
      END IF
      IF (ITERM.NE.0) GO TO 11190
*
*     DIRECTION DETERMINATION
*
      GNORM=SQRT(MXUDOT(NF,GF,GF,IX,KBF))
*
*     NEWTON LIKE STEP
*
      CALL MXUNEG(NF,GF,S,IX,KBF)
      CALL MXDRMM(NF,NN,XM,S,GR)
      CALL MXDCMD(NF,NN,XM,GR,PAR,S,S)
      CALL MXUZER(NF,S,IX,KBF)
      ITERD=1
      SNORM=SQRT(MXUDOT(NF,S,S,IX,KBF))
*
*     TEST ON DESCENT DIRECTION AND PREPARATION OF LINE SEARCH
*
      IF (KD.GT.0) P=MXUDOT(NF,GF,S,IX,KBF)
      IF (ITERD.LT.0) THEN
        ITERM=ITERD
      ELSE
*
*     TEST ON DESCENT DIRECTION
*
      IF (SNORM.LE.0.0D 0) THEN
        IREST=MAX(IREST,1)
      ELSE IF (P+TOLD*GNORM*SNORM.LE.0.0D 0) THEN
        IREST=0
      ELSE
*
*     UNIFORM DESCENT CRITERION
*
      IREST=MAX(IREST,1)
      END IF
      IF (IREST.EQ.0) THEN
*
*     PREPARATION OF LINE SEARCH
*
        NRED = 0
        RMIN=ALF1*GNORM/SNORM
        RMAX=MIN(ALF2*GNORM/SNORM,XMAX/SNORM)
      END IF
      END IF
      IF (ITERM.NE.0) GO TO 11190
      IF (IREST.NE.0) GO TO 11130
      CALL PYTRCS(NF,X,IX,XO,XL,XU,GF,GO,S,RO,FP,FO,F,PO,P,RMAX,ETA9,
     & KBF)
      IF (RMAX.EQ.0.0D 0) GO TO 11175
11170 CONTINUE
      CALL PS1L01(R,RP,F,FO,FP,P,PO,PP,FMIN,FMAX,RMIN,RMAX,
     & TOLS,TOLP,PAR1,PAR2,KD,LD,NIT,KIT,NRED,MRED,MAXST,IEST,
     & INITS,ITERS,KTERS,MES,ISYS)
      IF (ISYS.EQ.0) GO TO 11174
      CALL MXUDIR(NF,R,S,XO,X,IX,KBF)
      CALL PCBS04(NF,X,IX,XL,XU,EPS9,KBF)
      CALL OBJ(NF,X,F)
      NFV=NFV+1
      CALL DOBJ(NF,X,GF)
      NFG=NFG+1
      P=MXUDOT(NF,GF,S,IX,KBF)
      GO TO 11170
11174 CONTINUE
      IF (ITERS.LE.0) THEN
      R=0.0D 0
      F=FO
      P=PO
      CALL MXVCOP(NF,XO,X)
      CALL MXVCOP(NF,GO,GF)
      IREST=MAX(IREST,1)
      LD=KD
      GO TO 11130
      END IF
      CALL MXUNEG(NF,GO,S,IX,KBF)
      CALL PYTRCD(NF,X,IX,XO,GF,GO,R,F,FO,P,PO,DMAX,KBF,KD,LD,ITERS)
      CALL MXUCOP(NF,GF,SO,IX,KBF)
      IF (NN.LT.MF) THEN
      CALL PULSP3(NF,NN,MF,XM,GR,XO,GO,R,PO,PAR,ITERH,MET3)
      ELSE
      CALL PULVP3(NF,NN,XM,XR,GR,S,SO,XO,GO,R,PO,PAR,ITERH,MEC,MET3,
     & MET)
      END IF
11175 CONTINUE
      IF (ITERH.NE.0) IREST=MAX(IREST,1)
      IF (KBF.GT.0) CALL PYADC0(NF,N,X,IX,XL,XU,INEW)
      GO TO 11120
11190 CONTINUE
      IF (IPRNT.GT.1.OR.IPRNT.LT.0)
     & WRITE(6,'(1X,''EXIT FROM PLIP :'')')
      IF (IPRNT.NE.0)
     & WRITE (6,'(1X,''NIT='',I5,2X,''NFV='',I5,2X,''NFG='',I5,2X,
     & ''F='', G16.9,2X,''G='',E10.3,2X,''ITERM='',I3)') NIT,NFV,NFG,
     & F,GMAX,ITERM
      IF (IPRNT.LT.0)
     & WRITE (6,'(1X,''X='',5(G14.7,1X):/(3X,5(G14.7,1X)))')
     & (X(I),I=1,NF)
      RETURN
      END


Subroutine Cell2Point(AE, BE, MaxLRows, XLL, NDim, iDofT, NodElt, Sol0, Sol1, CommonPar, Param, JParam, DelT, DTm, Time)
!     ------------------------------------------------------------------
	use funcAux
	use ptsGaussLib
	use globalVariables, only : NdimE

	implicit none

	!   ===== SUBROUTINE ARGUMENTS  =======
	integer :: MaxLRows,Ndim,iDofT,NodElt ! all integers
	Real*8 :: DelT, DTm,Time ! all reals
	Real*8 :: AE(MaxLRows,MaxLRows), BE(MaxLRows), XLL(*), Sol0(*), Sol1(*), Param(*), JParam(*), CommonPar(*)

	!   =====   END ARGUMENTS  =======

    integer , parameter :: maxNFields = 5, iShiftMapping = 2
	Integer :: NodG, NGP, ipPar, ipSol, i, A, ip ! counters
	real*8 , allocatable :: Xel(:)
	integer ::  NFields , iCell2PointMap(2,maxNFields)
    integer :: iFemType, pOrder, iSimplex,  iBubble, iFtype
    real*8 :: dVol
	type(ptGaussClass) :: PtG

	iFemType = nint(commonPar(1))
	NFields = nint(CommonPar(2))

	do i = 1 , NFields
		ip = iShiftMapping + (i-1)*2
		iCell2PointMap(1,i) = nint(commonPar(ip+1))
		iCell2PointMap(2,i) = nint(commonPar(ip+2))
	end do

	call setFEMtype(iFEMtype,NodG,pOrder,NGP,iSimplex,iBubble)
	call getSliceAllocate(Xel,XLL,1,NodG,1 ,NdimE, Ndim)

	call PtG%init(Xel,NodG,NdimE,NGP,pOrder,iBubble, iSimplex)

	!! supposing NGP == 1
	dVol=dabs(ptG%dV(1))

	do i = 1, NFields
		ipPar = iCell2PointMap(1,i)

		do A = 1 , NodG
			ipSol = (A-1)*iDofT + iCell2PointMap(2,i)

			AE(ipSol,ipSol) = dVol
			BE(ipSol) = dVol*dabs(Param(ipPar))
		end do

	end do

End Subroutine

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine Cell2PointS(Coupling,CommonPar,iDofT,Ndim,MaxLRows,iAdd)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	use ptsGaussLib , only : setNodG

	IMPLICIT NONE
	Integer :: MaxLRows,Ndim,iDofT, iAdd
	Integer   Coupling(MaxLRows,MaxLRows)
	Real*8 CommonPar(*)

	integer , parameter :: maxNFields = 5, iShiftMapping = 2
	integer :: NodG, ipSol, i, A, ip ! counters
	integer ::  NFields , iCell2PointMap(2,maxNFields)
    integer :: iFemType

	iFemType = nint(commonPar(1))
	NFields = nint(CommonPar(2))

	do i = 1 , NFields
		ip = iShiftMapping + (i-1)*2
		iCell2PointMap(1,i) = nint(commonPar(ip+1))
		iCell2PointMap(2,i) = nint(commonPar(ip+2))
	end do

	call setNodG(iFemtype, NodG)

	do i = 1, NFields

		do A = 1 , NodG
			ipSol = (A-1)*iDofT + iCell2PointMap(2,i)

			Coupling(ipSol,ipSol) = 1

		end do

	end do

end Subroutine


!
!     -------------------------------------------------------------
!      S O O 1 2 1 2 P
!     -------------------------------------------------------------
!                                                                  *
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF MATRIX ELEMENTS        *
!     OF ONE PARTICLE OPERATOR IN CASE :           N'1 = N1        *
!                                                                  *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Universite Libre de Bruxelles, Belgium         October 1995  *
!
      SUBROUTINE SOO1212P(IG, KL, IA, IB)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
      USE MEDEFN_C
      USE DIAGNL_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  13:15:20  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE sooa_I
      USE soob_I
      USE two12_I
      USE savenon_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: IG
      INTEGER  :: KL
      INTEGER  :: IA
      INTEGER  :: IB
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: L1, L2, LB, LA, KLM, KLP
      REAL(DOUBLE) :: AP1, A1, C1, C2, G1, GG1, C3, C4, G2, GG2, C55, C66, CC55&
         , CC66, G4, GG4, A2, G3, GG3
!-----------------------------------------------
      L1 = LJ(IA)
      L2 = LJ(IB)
      CALL SOOA (L1, L2, L1, L2, KL, AP1)
      IF (DABS(AP1) < EPS) RETURN
      LB = IJFUL(IB)
      LA = IJFUL(IA)
      KLM = KL - 1
      IF (KLM >= 0) THEN
         CALL SOOB (1, L1, L1, KLM, KL, A1)
         IF (DABS(A1) > EPS) THEN
            CALL TWO12 (KLM, 1, KL, 0, 1, IA, IB, C1)
            CALL TWO12 (KLM, 0, KL, 1, 1, IA, IB, C2)
            G1 = C1 + TWO*C2
            G1 = A1*G1
         ELSE
            G1 = ZERO
         ENDIF
!
         CALL SOOB (1, L2, L2, KLM, KL, A1)
         IF (DABS(A1) > EPS) THEN
            CALL TWO12 (KL, 0, KLM, 1, 1, IA, IB, C1)
            CALL TWO12 (KL, 1, KLM, 0, 1, IA, IB, C2)
            GG1 = C1 + TWO*C2
            GG1 = A1*GG1
         ELSE
            GG1 = ZERO
         ENDIF
      ELSE
         G1 = ZERO
         GG1 = ZERO
      ENDIF
      KLP = KL + 1
      IF (KLP <= IG) THEN
         CALL SOOB (1, L1, L1, KLP, KL, A1)
         IF (DABS(A1) > EPS) THEN
            CALL TWO12 (KLP, 1, KL, 0, 1, IA, IB, C3)
            CALL TWO12 (KLP, 0, KL, 1, 1, IA, IB, C4)
            G2 = C3 + TWO*C4
            G2 = A1*G2
         ELSE
            G2 = ZERO
         ENDIF
!
         CALL SOOB (1, L2, L2, KLP, KL, A1)
         IF (DABS(A1) > EPS) THEN
            CALL TWO12 (KL, 0, KLP, 1, 1, IA, IB, C3)
            CALL TWO12 (KL, 1, KLP, 0, 1, IA, IB, C4)
            GG2 = C3 + TWO*C4
            GG2 = A1*GG2
         ELSE
            GG2 = ZERO
         ENDIF
      ELSE
         G2 = ZERO
         GG2 = ZERO
      ENDIF
      CALL TWO12 (KL, 1, KL, 0, 1, IA, IB, C55)
      CALL TWO12 (KL, 0, KL, 1, 1, IA, IB, C66)
!      CALL TWO12(KL,0,KL,1,1,IA,IB,CC55)
!      CC55=-CC55
!      CALL TWO12(KL,1,KL,0,1,IA,IB,CC66)
!      CC66=-CC66
      CC55 = -C66
      CC66 = -C55
!
!     ( k k )  tenzorine struktura    V  integralas
!
      CALL SOOB (2, L1, L1, KL, KL, A1)
      G4 = C55 + TWO*C66
      G4 = AP1*A1*G4
      IF (DABS(G4) > EPS) CALL SAVENON (7, G4, KL - 1, LA, LB, LA, LB, JA, JB, &
         0)
      CALL SOOB (2, L2, L2, KL, KL, A1)
      GG4 = CC55 + TWO*CC66
      GG4 = AP1*A1*GG4
      IF (DABS(GG4) > EPS) CALL SAVENON (7, GG4, KL - 1, LB, LA, LB, LA, JA, JB&
         , 0)
!
!     ( k  k+1)  ( k k )
!
      CALL SOOB (1, L1, L1, KL, KL, A1)
      CALL SOOB (1, L2, L2, KL, KL, A2)
      G3 = C55 + TWO*C66
      G3 = A1*G3
      GG3 = CC55 + TWO*CC66
      GG3 = A2*GG3
      IF (KL - 1 >= 0) THEN
         A1 = AP1*(G1 + DBLE(KL + 1)*G3)
         IF (DABS(A1) > EPS) CALL SAVENON (6, A1, KL - 2, LB, LA, LB, LA, JA, &
            JB, 0)
         A1 = AP1*(GG1 + DBLE(KL + 1)*GG3)
         IF (DABS(A1) > EPS) CALL SAVENON (6, A1, KL - 2, LA, LB, LA, LB, JA, &
            JB, 0)
      ENDIF
!
!     ( k  k-1)  ( k k )
!
      IF (KLP <= IG) THEN
         A2 = AP1*(G2 - DBLE(KL)*G3)
         IF (DABS(A2) > EPS) CALL SAVENON (6, A2, KL, LA, LB, LA, LB, JA, JB, 0&
            )
         A2 = AP1*(GG2 - DBLE(KL)*GG3)
         IF (DABS(A2) > EPS) CALL SAVENON (6, A2, KL, LB, LA, LB, LA, JA, JB, 0&
            )
      ENDIF
      RETURN
      END SUBROUTINE SOO1212P