  IMPLICIT NONE
  INTEGER, PARAMETER :: dp=KIND(0.0D0)
  REAL(KIND=dp)      :: res

  res=exp_radius_very_extended(  0    ,      1   ,       0      ,    1, &
                               (/0.0D0,0.0D0,0.0D0/),&
                               (/1.0D0,0.0D0,0.0D0/),&
                               (/1.0D0,0.0D0,0.0D0/),&
                                 1.0D0,1.0D0,1.0D0,1.0D0)
  if (res.ne.1.0d0) STOP 1

CONTAINS

 FUNCTION exp_radius_very_extended(la_min,la_max,lb_min,lb_max,ra,rb,rp,&
                          zetp,eps,prefactor,cutoff) RESULT(radius)

    INTEGER, INTENT(IN)                      :: la_min, la_max, lb_min, lb_max
    REAL(KIND=dp), INTENT(IN)                :: ra(3), rb(3), rp(3), zetp, &
                                                eps, prefactor, cutoff
    REAL(KIND=dp)                            :: radius

    INTEGER                                  :: i, ico, j, jco, la(3), lb(3), &
                                                lxa, lxb, lya, lyb, lza, lzb
    REAL(KIND=dp)                            :: bini, binj, coef(0:20), &
                                                epsin_local, polycoef(0:60), &
                                                prefactor_local, rad_a, &
                                                rad_b, s1, s2

    epsin_local=1.0E-2_dp

    prefactor_local=prefactor*MAX(1.0_dp,cutoff)
    rad_a=SQRT(SUM((ra-rp)**2))
    rad_b=SQRT(SUM((rb-rp)**2))

    polycoef(0:la_max+lb_max)=0.0_dp
    DO lxa=0,la_max
    DO lxb=0,lb_max
       coef(0:la_max+lb_max)=0.0_dp
       bini=1.0_dp
       s1=1.0_dp
       DO i=0,lxa
          binj=1.0_dp
          s2=1.0_dp
          DO j=0,lxb
             coef(lxa+lxb-i-j)=coef(lxa+lxb-i-j) + bini*binj*s1*s2
             binj=(binj*(lxb-j))/(j+1)
             s2=s2*(rad_b)
          ENDDO
          bini=(bini*(lxa-i))/(i+1)
          s1=s1*(rad_a)
       ENDDO
       DO i=0,lxa+lxb
          polycoef(i)=MAX(polycoef(i),coef(i))
       ENDDO
    ENDDO
    ENDDO

    polycoef(0:la_max+lb_max)=polycoef(0:la_max+lb_max)*prefactor_local
    radius=0.0_dp
    DO i=0,la_max+lb_max
          radius=MAX(radius,polycoef(i)**(i+1))
    ENDDO

  END FUNCTION exp_radius_very_extended

END


! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KPP_ROOT_KppDecomp( JVS, IER )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Sparse LU factorization
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!  USE KPP_ROOT_Parameters
!  USE KPP_ROOT_JacobianSP

      INTEGER  :: IER
      KPP_REAL :: JVS(KPP_LU_NONZERO), W(KPP_NVAR), a
      INTEGER  :: k, kk, j, jj

      a = 0. ! mz_rs_20050606
      IER = 0
      DO k=1,NVAR
        ! mz_rs_20050606: don't check if real value == 0
        ! IF ( JVS( LU_DIAG(k) ) .EQ. 0. ) THEN
        IF ( ABS(JVS(LU_DIAG(k))) < TINY(a) ) THEN
            IER = k
            RETURN
        END IF
        DO kk = LU_CROW(k), LU_CROW(k+1)-1
              W( LU_ICOL(kk) ) = JVS(kk)
        END DO
        DO kk = LU_CROW(k), LU_DIAG(k)-1
            j = LU_ICOL(kk)
            a = -W(j) / JVS( LU_DIAG(j) )
            W(j) = -a
            DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1
               W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj)
            END DO
         END DO
         DO kk = LU_CROW(k), LU_CROW(k+1)-1
            JVS(kk) = W( LU_ICOL(kk) )
         END DO
      END DO

END SUBROUTINE KPP_ROOT_KppDecomp

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KPP_ROOT_KppDecompCmplx( JVS, IER )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Sparse LU factorization, complex
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!  USE KPP_ROOT_Parameters
!  USE KPP_ROOT_JacobianSP

      INTEGER  :: IER
      DOUBLE COMPLEX :: JVS(KPP_LU_NONZERO), W(KPP_NVAR), a
      INTEGER  :: k, kk, j, jj

      IER = 0
      DO k=1,NVAR
        IF ( JVS( LU_DIAG(k) ) .EQ. 0. ) THEN
            IER = k
            RETURN
        END IF
        DO kk = LU_CROW(k), LU_CROW(k+1)-1
              W( LU_ICOL(kk) ) = JVS(kk)
        END DO
        DO kk = LU_CROW(k), LU_DIAG(k)-1
            j = LU_ICOL(kk)
            a = -W(j) / JVS( LU_DIAG(j) )
            W(j) = -a
            DO jj = LU_DIAG(j)+1, LU_CROW(j+1)-1
               W( LU_ICOL(jj) ) = W( LU_ICOL(jj) ) + a*JVS(jj)
            END DO
         END DO
         DO kk = LU_CROW(k), LU_CROW(k+1)-1
            JVS(kk) = W( LU_ICOL(kk) )
         END DO
      END DO

END SUBROUTINE KPP_ROOT_KppDecompCmplx

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KPP_ROOT_KppSolveIndirect( JVS, X )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Sparse solve subroutine using indirect addressing
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!  USE KPP_ROOT_Parameters
!  USE KPP_ROOT_JacobianSP

      INTEGER i, j
      KPP_REAL JVS(KPP_LU_NONZERO), X(KPP_NVAR), sum

      DO i=1,NVAR
         DO j = LU_CROW(i), LU_DIAG(i)-1
             X(i) = X(i) - JVS(j)*X(LU_ICOL(j));
         END DO
      END DO

      DO i=NVAR,1,-1
        sum = X(i);
        DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1
          sum = sum - JVS(j)*X(LU_ICOL(j));
        END DO
        X(i) = sum/JVS(LU_DIAG(i));
      END DO

END SUBROUTINE KPP_ROOT_KppSolveIndirect

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE KPP_ROOT_KppSolveCmplx( JVS, X )
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!        Complex sparse solve subroutine using indirect addressing
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!  USE KPP_ROOT_Parameters
!  USE KPP_ROOT_JacobianSP

      INTEGER i, j
      DOUBLE COMPLEX JVS(KPP_LU_NONZERO), X(KPP_NVAR), sum

      DO i=1,NVAR
         DO j = LU_CROW(i), LU_DIAG(i)-1
             X(i) = X(i) - JVS(j)*X(LU_ICOL(j));
         END DO
      END DO

      DO i=NVAR,1,-1
        sum = X(i);
        DO j = LU_DIAG(i)+1, LU_CROW(i+1)-1
          sum = sum - JVS(j)*X(LU_ICOL(j));
        END DO
        X(i) = sum/JVS(LU_DIAG(i));
      END DO

END SUBROUTINE KPP_ROOT_KppSolveCmplx


c
c-----------------------------------------------------------------------
c subroutine: iftsoh
c compute idft for real, symmetric, odd harmonic, n-point sequence
c using n/4-point fft
c symmetric sequence means x(m)=x(n-m), m=1,...,n/2-1
c odd harmonic means x(2*k)=0, all k, where x(k) is the dft of x(m)
c x(m) has the property x(m)=-x(n/2-m), m=0,1,...,n/4-1,  x(n/4)=0
c note: index m is sequence index--not fortran index
c-----------------------------------------------------------------------
c
      subroutine iftsoh(x, n, y)
      dimension x(1), y(1)
c
c  x = real array which on input contains the n/4 real points of
c      the odd harmonics of the transform of the original time sequence
c      i.e. the zero valued imaginary parts are not given nor are the
c      zero valued even harmonics
c      on output x contains the first n/4 points of the original input
c      sequence (symmetrical)
c  n = true size of input
c  y = scratch array of size n/4+2
c
c
c handle n = 2 and n = 4 cases separately
c
      if (n.gt.4) go to 10
c
c for n=2, 4 assume x(1)=x0, x(2)=-x0, compute idft directly
c
      x(1) = x(1)/2.
      return
c
c code for values of n which are multiples of 8
c
  10  twopi = 8.*atan(1.0)
      no2 = n/2
      no4 = n/4
      no8 = n/8
      tpn = twopi/float(n)
c
c first compute x1=x(1) term directly
c use recursion on the sine cosine terms
c
      cosd = cos(tpn*2.)
      sind = sin(tpn*2.)
      cosi = 2.*cos(tpn)
      sini = 2.*sin(tpn)
      x1 = 0.
      do 20 i=1,no4
        x1 = x1 + x(i)*cosi
        temp = cosi*cosd - sini*sind
        sini = cosi*sind + sini*cosd
        cosi = temp
  20  continue
      x1 = x1/float(n)
c
c scramble original dft (x(k)) to give y(k)
c use recursion relation to give sin multipliers
c
      cosi = cos(tpn)
      sini = sin(tpn)
      do 30 i=1,no8
        ind = 2*i
        ind1 = no4 + 1 - i
        ak = (x(i)+x(ind1))/2.
        bk = (x(i)-x(ind1))
        y(ind-1) = ak
        y(ind) = bk*sini
        temp = cosi*cosd - sini*sind
        sini = cosi*sind + sini*cosd
        cosi = temp
  30  continue
c
c the sequence y(k) is the odd harmonics dft output
c use subroutine iftohm to obtain y(m), the inverse transform
c
      call iftohm(y, no2)
c
c form x(m) sequence from y(m) sequence
c use x1 initial condition on the recursion
c
      x(1) = y(1)
      x(2) = x1
      if (no8.eq.1) return
      do 40 i=2,no8
        ind = 2*i
        ind1 = no4 + 2 - i
        t1 = (y(i)+y(ind1))/2.
        x(ind-1) = (y(i)-y(ind1))/2.
        x(ind) = t1 + x(ind-2)
  40  continue
      return
      end


subroutine rhs(n, t, y, ydot, rpar, ipar)

  use bl_types
  use bl_constants_module
  use network
  use network_indices
  use rpar_indices

  implicit none
  !$acc routine seq
  !$acc routine(screenz) seq

  ! our convention is that y(1:nspec) are the species (in the same
  ! order as defined in network.f90, and y(nspec+1) is the temperature
  integer,         intent(in   ) :: n, ipar
  real(kind=dp_t), intent(in   ) :: y(n), t
  real(kind=dp_t), intent(  out) :: ydot(n)
  real(kind=dp_t), intent(inout) :: rpar(:)

  integer :: k
  real(kind=dp_t) :: ymass(nspec)

  real(kind=dp_t) :: dens, X_O16
  real(kind=dp_t) :: temp, T9, T9a, dT9dt, dT9adt

  real(kind=dp_t) :: rate, dratedt
  real(kind=dp_t) :: sc1212, dsc1212dt
  real(kind=dp_t) :: xc12tmp

  real(kind=dp_t), PARAMETER :: &
                     one_twelvth = 1.0d0/12.0d0, &
                     five_sixths = 5.0d0/ 6.0d0, &
                       one_third = 1.0d0/ 3.0d0, &
                      two_thirds = 2.0d0/ 3.0d0

  real(kind=dp_t) :: scratch, dscratchdt

  real(kind=dp_t) :: a, b, dadt, dbdt

  dens = rpar(irp_dens)
  temp = rpar(irp_temp)

  X_O16   = rpar(irp_o16)

  ! compute the molar fractions -- needed for the screening
  ymass(ic12_) = y(1)/aion(ic12_)
  ymass(io16_) = X_O16/aion(io16_)
  ymass(img24_) = (ONE - y(1) - X_O16)/aion(img24_)

  ! call the screening routine
  call screenz(temp,dens,6.0d0,6.0d0,12.0d0,12.0d0,ymass,nspec,     &
               aion(1:nspec), zion(1:nspec), sc1212, dsc1212dt)

  ! compute some often used temperature constants
  T9     = temp/1.e9_dp_t
  dT9dt  = ONE/1.e9_dp_t
  T9a    = T9/(1.0e0_dp_t + 0.0396e0_dp_t*T9)
  dT9adt = (T9a / T9 - (T9a / (1.0e0_dp_t + 0.0396e0_dp_t*T9)) * 0.0396e0_dp_t) * dT9dt

  ! compute the CF88 rate
  scratch    = T9a**one_third
  dscratchdt = one_third * T9a**(-2.0e0_dp_t * one_third) * dT9adt

  a       = 4.27e26_dp_t*T9a**five_sixths*T9**(-1.5e0_dp_t)
  dadt    = five_sixths * (a/T9a) * dT9adt - 1.5e0_dp_t * (a/T9) * dT9dt

  b       = dexp(-84.165e0_dp_t/scratch - 2.12e-3_dp_t*T9*T9*T9)
  dbdt    = (84.165e0_dp_t * dscratchdt/ scratch**2.0e0_dp_t                   &
             - 3.0e0_dp_t * 2.12e-3_dp_t * T9 * T9 * dT9dt) * b

  rate    = a *  b
  dratedt = dadt * b + a * dbdt

  ! The change in number density of C12 is
  ! d(n12)/dt = - 2 * 1/2 (n12)**2 <sigma v>
  !
  ! where <sigma v> is the average of the relative velocity times the cross
  ! section for the reaction, and the factor accounting for the total number
  ! of particle pairs has a 1/2 because we are considering a reaction involving
  ! identical particles (see Clayton p. 293).  Finally, the -2 means that for
  ! each reaction, we lose 2 carbon nuclei.
  !
  ! The corresponding Mg24 change is
  ! d(n24)/dt = + 1/2 (n12)**2 <sigma v>
  !
  ! note that no factor of 2 appears here, because we create only 1 Mg nuclei.
  !
  ! Switching over to mass fractions, using n = rho X N_A/A, where N_A is
  ! Avagadro's number, and A is the mass number of the nucleon, we get
  !
  ! d(X12)/dt = -2 *1/2 (X12)**2 rho N_A <sigma v> / A12
  !
  ! d(X24)/dt = + 1/2 (X12)**2 rho N_A <sigma v> (A24/A12**2)
  !
  ! these are equal and opposite.
  !
  ! The quantity [N_A <sigma v>] is what is tabulated in Caughlin and Fowler.

  ! we will always refer to the species by integer indices that come from
  ! the network module -- this makes things robust to a shuffling of the
  ! species ordering

  xc12tmp = max(y(ic12_),0.e0_dp_t)
  ydot(ic12_) = -one_twelvth*dens*sc1212*rate*xc12tmp**2
  ydot(io16_) = 0.0e0_dp_t
  ydot(img24_) = -ydot(ic12_)

  return

end subroutine rhs


	function csqrt(z1)
	complex csqrt, z1, z2
	dimension dummy(2)
	equivalence (a,z2,dummy(1)), (b,dummy(2))

	z2 = z1
	c = cabs(z2)
	c = sqrt(c)
	b = atan2(b, a)/2.0
	a = c*cos(b)
	b = c*sin(b)
	csqrt = z2
	return
	end


program test_UNIFAC
implicit none

integer, parameter  :: n =2, m=3
real(8) :: t
real(8) :: x(n) = (/ .4_8 ,.6_8 /)
real(8) :: qk(m) = (/ .848_8, .54_8, .936_8 /)
real(8) :: rk(m) = (/.9011_8,  .6744_8, 1.207_8 /)
real(8) :: amk(m,m), gamma1(n), expected_gamma(n) = (/ 1.133_8, 1.047_8/)
integer :: vk(n,m)
logical :: equal

t = 308.15_8

vk(1,1) = 2
vk(1,2) = 1
vk(1,3) = 1

vk(2,1) = 2
vk(2,2) = 5
vk(2,3) = 0

amk(1,1) = 0.0_8
amk(1,2) = 0.0_8
amk(1,3) = 255.7

amk(2,1) = 0.0_8
amk(2,2) = 0.0_8
amk(2,3) = 255.7

amk(3,1) = 65.33_8
amk(3,2) = 65.33_8
amk(3,3) = 0.0_8

call getGamma(x, t, n, m, amk, vk, rk, qk, gamma1)
call is_equal_arr(gamma1, expected_gamma, n, equal)

write(*,*) expected_gamma
write(*,*) gamma1
if (.not. equal) then
    write(*,*) "Test failed"
else
    write(*,*) "Test passed"
endif

end program test_UNIFAC

subroutine is_equal_arr(a, b, n, ans)
    integer, intent(in) :: n
    real(8), intent(in) ::a(n), b(n)
    logical, intent(out) :: ans
    integer :: i
    real(8) :: tol = 1e-4
    ans = .true.

    do i=1, n
        if (abs(a(i)- b(i)) .ge. tol ) then
            ans = .false.
            return
        end if
    enddo
end subroutine


C++------------------------------------------------------------------
C Program to compute the gradient map of an image
C Works in all directions
C From Bill Sparks
C
C JLP
C Version of 25-04-90
C--------------------------------------------------------------------
	PROGRAM QUICKGRAD2
	INTEGER*4 DIM1(2),DIM3(2)
	INTEGER*4 IPT1,IPT3,MADRID(1)
	CHARACTER NAME*40,COMMENTS*80
	COMMON /VMR/MADRID

	CALL JLP_BEGIN
	CALL JLP_INQUIFMT

	WRITE(6,23)
23	FORMAT(' Program QUICKGRAD2',/,
     1	' To compute the gradient of the log')
C
	WRITE(6,*) ' Input image:'
        READ(5,10) NAME
	CALL JLP_VM_READIMAG(IPT1,DIM1(1),DIM1(2),NAME,COMMENTS)
	DIM3(1)=DIM1(1)
	DIM3(2)=DIM1(2)

C Getting memory space for the output:
	I=DIM3(1)*DIM3(2)*4
	CALL JLP_GETVM(IPT3,I)

	PRINT *,' ENTER THE SKY LEVEL AND THE NOISE :'
	READ(5,*) BACK,RMS

	CALL QUICKGRAD_SUB(MADRID(IPT1),DIM1,MADRID(IPT3),DIM3,BACK,RMS)

	WRITE(6,*) ' Output gradient map:'
        READ(5,10) NAME
	CALL JLP_WRITEIMAG(MADRID(IPT3),DIM3(1),DIM3(2),
     1	DIM1(1),NAME,COMMENTS)

80	CALL JLP_END
	STOP
	END
C------------------------------------------------------------------
C Subroutine QUICKGRAD_SUB which actually computes the gradient map

      SUBROUTINE QUICKGRAD_SUB(IM,IDIM,GRADIENT,IDGR,BACK,RMS)
      integer idim(2),idgr(2),idker(2)
      real im(idim(1),idim(2)),gradient(idgr(1),idgr(2)),s1(6),s2(6),
     1 f(3)
      character cnum*1
c
c Filter row - assumed antisymmetric
c
      data f/1,1,1/
c
c Subroutine to generate a gradient map by convolution with a kernel
c and quadratic addition of the 2 components.
c Output is log of image with offset Out=Kernel*(Log(Image-Offset))
c
      offset=ABS(back-3.0*rms)
      nfilter=3
      fsum=0
      do i=1,nfilter
CCCCC        call itoc(i,cnum,ist)
CCCCC        call promptr('Top row of filter f'//cnum,'F',f(i))
        fsum=fsum+f(i)
      enddo
c
      do j=1,idim(2)
        write(6,101)j
101	format(1h ,'Doing row:',i4)
        if(j.eq.1.or.j.eq.idim(2))then
          do i=1,idim(1)
            gradient(i,j)=0.0
          enddo
          go to 20
        endif
        do i=1,idim(1)
           if(i.eq.1.or.i.eq.idim(1))then
             gradient(i,j)=0.0
             go to 20
           endif
c Set values below offset to back
c
           s1(1)=im(i-1,j+1)-offset
           s1(2)=im(i,j+1)-offset
           s1(3)=im(i+1,j+1)-offset
           s1(4)=im(i-1,j-1)-offset
           s1(5)=im(i,j-1)-offset
           s1(6)=im(i+1,j-1)-offset
           s2(1)=im(i-1,j+1)-offset
           s2(2)=im(i-1,j)-offset
           s2(3)=im(i-1,j-1)-offset
           s2(4)=im(i+1,j+1)-offset
           s2(5)=im(i+1,j)-offset
           s2(6)=im(i+1,j-1)-offset
           do k=1,6
             if(s1(k).le.0.0)s1(k)=back-offset
             if(s2(k).le.0.0)s2(k)=back-offset
             s1(k)=alog10(s1(k))
             s2(k)=alog10(s2(k))
           enddo
           sum1=(f(1)*s1(1)+f(2)*s1(2)+f(3)*s1(3)-
     1           f(1)*s1(4)-f(2)*s1(5)-f(3)*s1(6))/fsum
           sum2=(f(1)*s2(1)+f(2)*s2(2)+f(3)*s2(3)-
     1           f(1)*s2(4)-f(2)*s2(5)-f(3)*s2(6))/fsum
           sum=sum1*sum1+sum2*sum2
           gradient(i,j)=sqrt(sum)
   20   enddo
      enddo
c
80	return
	end


      SUBROUTINE TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute N Markov parameters M(1), M(2),..., M(N) from a
C     multivariable system whose transfer function matrix G(z) is given.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     NC      (input) INTEGER
C             The number of system outputs, i.e. the number of rows in
C             the transfer function matrix G(z).  NC >= 0.
C
C     NB      (input) INTEGER
C             The number of system inputs, i.e. the number of columns in
C             the transfer function matrix G(z).  NB >= 0.
C
C     N       (input) INTEGER
C             The number of Markov parameters M(k) to be computed.
C             N >= 0.
C
C     IORD    (input) INTEGER array, dimension (NC*NB)
C             This array must contain the order r of the elements of the
C             transfer function matrix G(z), stored row by row.
C             For example, the order of the (i,j)-th element of G(z) is
C             given by IORD((i-1)xNB+j).
C
C     AR      (input) DOUBLE PRECISION array, dimension (NA), where
C             NA = IORD(1) + IORD(2) + ... + IORD(NC*NB).
C             The leading NA elements of this array must contain the
C             denominator coefficients AR(1),...,AR(r) in equation (1)
C             of the (i,j)-th element of the transfer function matrix
C             G(z), stored row by row, i.e. in the order
C             (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ...,
C             (NC,1),(NC,2),...,(NC,NB). The coefficients must be given
C             in decreasing order of powers of z; the coefficient of the
C             highest order term is assumed to be equal to 1.
C
C     MA      (input) DOUBLE PRECISION array, dimension (NA)
C             The leading NA elements of this array must contain the
C             numerator coefficients MA(1),...,MA(r) in equation (1)
C             of the (i,j)-th element of the transfer function matrix
C             G(z), stored row by row, i.e. in the order
C             (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ...,
C             (NC,1),(NC,2),...,(NC,NB). The coefficients must be given
C             in decreasing order of powers of z.
C
C     H       (output) DOUBLE PRECISION array, dimension (LDH,N*NB)
C             The leading NC-by-N*NB part of this array contains the
C             multivariable Markov parameter sequence M(k), where each
C             parameter M(k) is an NC-by-NB matrix and k = 1,2,...,N.
C             The Markov parameters are stored such that H(i,(k-1)xNB+j)
C             contains the (i,j)-th element of M(k) for i = 1,2,...,NC
C             and j = 1,2,...,NB.
C
C     LDH     INTEGER
C             The leading dimension of array H.  LDH >= MAX(1,NC).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The (i,j)-th element of G(z), defining the particular I/O transfer
C     between output i and input j, has the following form:
C
C                          -1         -2               -r
C                    MA(1)z   + MA(2)z   + ... + MA(r)z
C         G  (z) = ----------------------------------------.         (1)
C          ij                -1         -2               -r
C                  1 + AR(1)z   + AR(2)z   + ... + AR(r)z
C
C     The (i,j)-th element of G(z) is defined by its order r, its r
C     moving average coefficients (= numerator) MA(1),...,MA(r) and its
C     r autoregressive coefficients (= denominator) AR(1),...,AR(r). The
C     coefficient of the constant term in the denominator is assumed to
C     be equal to 1.
C
C     The relationship between the (i,j)-th element of the Markov
C     parameters M(1),M(2),...,M(N) and the corresponding element of the
C     transfer function matrix G(z) is given by:
C
C                               -1          -2                -k
C      G  (z) = M  (0) + M  (1)z   + M  (2)z   + ... + M  (k)z  + ...(2)
C       ij       ij       ij          ij                ij
C
C     Equating (1) and (2), we find that the relationship between the
C     (i,j)-th element of the Markov parameters M(k) and the ARMA
C     parameters AR(1),...,AR(r) and MA(1),...,MA(r) of the (i,j)-th
C     element of the transfer function matrix G(z) is as follows:
C
C        M  (1)   = MA(1),
C         ij
C                           k-1
C        M  (k)   = MA(k) - SUM AR(p) x M  (k-p) for 1 < k <= r and
C         ij                p=1          ij
C                      r
C        M  (k+r) = - SUM AR(p) x M  (k+r-p) for k > 0.
C         ij          p=1          ij
C
C     From these expressions the Markov parameters M(k) are computed
C     element by element.
C
C     REFERENCES
C
C     [1] Luenberger, D.G.
C         Introduction to Dynamic Systems: Theory, Models and
C         Applications.
C         John Wiley & Sons, New York, 1979.
C
C     NUMERICAL ASPECTS
C
C     The computation of the (i,j)-th element of M(k) requires:
C        (k-1) multiplications and k additions if k <= r;
C          r   multiplications and r additions if k > r.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TF01ED by S. Van Huffel, Katholieke
C     Univ. Leuven, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Markov parameters, multivariable system, transfer function,
C     transfer matrix.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER           INFO, LDH, N, NB, NC
C     .. Array Arguments ..
      INTEGER           IORD(*)
      DOUBLE PRECISION  AR(*), H(LDH,*), MA(*)
C     .. Local Scalars ..
      INTEGER           I, J, JJ, JK, K, KI, LDHNB, NL, NORD
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( NC.LT.0 ) THEN
         INFO = -1
      ELSE IF( NB.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN
         INFO = -8
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TF01QD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( NC, NB, N ).EQ.0 )
     $   RETURN
C
      LDHNB = LDH*NB
      NL = 1
      K = 1
C
      DO 60 I = 1, NC
C
         DO 50 J = 1, NB
            NORD = IORD(K)
            H(I,J) = MA(NL)
            JK = J
C
            DO 20 KI = 1, NORD - 1
               JK = JK + NB
               H(I,JK) = MA(NL+KI) - DDOT( KI, AR(NL), 1, H(I,J),
     $                                     -LDHNB )
   20       CONTINUE
C
            DO 40 JJ = J, J + (N - NORD - 1)*NB, NB
               JK = JK + NB
               H(I,JK) = -DDOT( NORD, AR(NL), 1, H(I,JJ), -LDHNB )
   40       CONTINUE
C
            NL = NL + NORD
            K = K + 1
   50    CONTINUE
C
   60 CONTINUE
C
      RETURN
C *** Last line of TF01QD ***
      END


c------------------------------------------------------------------
c     Computes double covariance or correlation matrix
c------------------------------------------------------------------
C NCLFORTSTART
      subroutine dcovarxy(x,y,xmsg,ymsg,cxy,n,m,lag,ncrit,iopt)
      implicit none
c                                                      INPUT
      integer n, m, lag, ncrit, iopt
      double precision x(n,m), y(n,m), xmsg, ymsg
c                                                      OUTPUT
      double precision cxy(m,m)
C NCLEND
c                                                      LOCAL
      integer i, j, k
      double precision sumxx, sumyy, sumxy, sumx, sumy, nxy, xvar, yvar

      do i=1,m
        do j=1,m
           cxy(i,j) = xmsg
        end do
      end do

      do i=1,m
        do j=1,m
          nxy  = 0.0d0
          sumx = 0.0d0
          sumy = 0.0d0
          sumxy= 0.0d0
          sumxx= 0.0d0
          sumyy= 0.0d0

          do k=lag+1, n
            if (x(k,i).ne.xmsg .and. y(k-lag,j).ne.ymsg) then
                nxy   = nxy + 1
                sumx  = sumx  + x(k,i)
                sumy  = sumy  + y(k-lag,j)
                sumxy = sumxy + x(k,i)*y(k-lag,j)
                sumxx = sumxx + x(k,i)*x(k,i)
                sumyy = sumyy + y(k-lag,j)*y(k-lag,j)
            end if
          end do
          if (nxy.gt.1d0 .and. nxy.ge.ncrit) then
              cxy(i,j) = (sumxy-(sumx*sumy)/nxy)/(nxy-1d0)

              if (iopt.eq.1 .and.
     &            sumxx.gt.0.0d0 .and. sumyy.gt.0.0d0) then
                  xvar =  (sumxx-((sumx*sumx)/(nxy)) )/(nxy-1.)
                  yvar =  (sumyy-((sumy*sumy)/(nxy)) )/(nxy-1.)
                  cxy(i,j) = cxy(i,j)/(sqrt(xvar)*sqrt(yvar))
              end if

          end if
        end do
      end do

      return
      end


      double precision FUNCTION TNC(T, DF, DELTA, IFAULT)
C
C     ALGORITHM AS 243  APPL. STATIST. (1989), VOL.38, NO. 1
C
C     Cumulative probability at T of the non-central t-distribution
C     with DF degrees of freedom (may be fractional) and non-centrality
C     parameter DELTA.
C
C     Note - requires the following auxiliary routines
C     ALOGAM (X)                         - ACM 291 or AS 245
C     BETAIN (X, A, B, ALBETA, IFAULT)   - AS 63 (updated in ASR 19)
C     ALNORM (X, UPPER)                  - AS 66
C
C Alternations by Marko Laine:
c alogam > lngamma
c declared as double precision
c added subroutine for S-plus .Fortran
      implicit none
      double precision
     *  A, ALBETA, ALNRPI, B, DEL, DELTA, DF, EN, ERRBD, ERRMAX,
     *  GEVEN, GODD, HALF, ITRMAX, LAMBDA, ONE, P, Q, R2PI, RXB, S, T,
     *  TT, TWO, X, XEVEN, XODD, ZERO
      LOGICAL NEGDEL
      integer ifault
      double precision lngamma, betain, alnorm
      external lngamma, betain, alnorm
C
C     Note - ITRMAX and ERRMAX may be changed to suit one's needs.
C
      DATA ITRMAX/100.1/, ERRMAX/1.E-06/
C
C     Constants - R2PI = 1/ {GAMMA(1.5) * SQRT(2)} = SQRT(2 / PI)
C                 ALNRPI = LN(SQRT(PI))
C
      DATA ZERO/0.0/, HALF/0.5/, ONE/1.0/, TWO/2.0/,
     *  R2PI/0.79788 45608 02865 35588/,
     *  ALNRPI/0.57236 49429 24700 08707/
C
      TNC = ZERO
      IFAULT = 2
      IF (DF .LE. ZERO) RETURN
      IFAULT = 0
C
      TT = T
      DEL = DELTA
      NEGDEL = .FALSE.
      IF (T .GE. ZERO) GO TO 1
      NEGDEL = .TRUE.
      TT = -TT
      DEL = -DEL
    1 CONTINUE
C
C     Initialize twin series (Guenther, J. Statist. Computn. Simuln.
C     vol.6, 199, 1978).
C
      EN = ONE
      X = T * T / (T* T + DF)
      IF (X .LE. ZERO) GO TO 20
      LAMBDA = DEL * DEL
      P = HALF * EXP(-HALF * LAMBDA)
      Q = R2PI * P * DEL
      S = HALF - P
      A = HALF
      B = HALF * DF
      RXB = (ONE - X) ** B
      ALBETA = ALNRPI + LNGAMMA(B, IFAULT) - LNGAMMA(A + B, IFAULT)
      XODD = BETAIN(X, A, B, ALBETA, IFAULT)
      GODD = TWO * RXB * EXP(A * LOG(X) - ALBETA)
      XEVEN = ONE - RXB
      GEVEN = B * X * RXB
      TNC = P * XODD + Q * XEVEN
C
C     Repeat until convergence
C
   10 A = A + ONE
      XODD = XODD - GODD
      XEVEN = XEVEN - GEVEN
      GODD = GODD * X * (A + B - ONE) / A
      GEVEN = GEVEN * X * (A + B - HALF) / (A + HALF)
      P = P * LAMBDA / (TWO * EN)
      Q = Q * LAMBDA / (TWO * EN + ONE)
      S = S - P
      EN = EN + ONE
      TNC = TNC + P * XODD + Q * XEVEN
      ERRBD = TWO * S * (XODD - GODD)
      IF (ERRBD .GT. ERRMAX .AND. EN .LE. ITRMAX) GO TO 10
C
   20 IFAULT = 1
      IF (EN .GT. ITRMAX) RETURN
      IFAULT = 0
      TNC = TNC + ALNORM(DEL, .TRUE.)
      IF (NEGDEL) TNC = ONE - TNC
C
      RETURN
      END

c subroutine version of the above for use from S-plus
      subroutine tncsub(t, nt, df, delta, ifault, retval)
      implicit none
      integer nt, ifault(nt), i
      double precision tnc, t(nt), df(nt), delta(nt), retval(nt)
      external tnc
      do 10 i=1,nt
         retval(i) = tnc(t(i), df(i), delta(i), ifault(i))
 10   continue
      end


    Program zhpevx_example

!     ZHPEVX Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dznrm2
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen
      Use lapack_interfaces, Only: zhpevx
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E+0_dp
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: uplo = 'U'
!     .. Local Scalars ..
      Complex (Kind=dp) :: scal
      Real (Kind=dp) :: abstol, vl, vu
      Integer :: i, ifail, il, info, iu, j, k, ldz, m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ap(:), work(:), z(:, :)
      Real (Kind=dp), Allocatable :: rwork(:), w(:)
      Integer, Allocatable :: iwork(:), jfail(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, conjg, maxloc
!     .. Executable Statements ..
      Write (nout, *) 'ZHPEVX Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldz = n
      m = n
      Allocate (ap((n*(n+1))/2), work(2*n), z(ldz,m), rwork(7*n), w(n), iwork( &
        5*n), jfail(n))

!     Read the lower and upper bounds of the interval to be searched,
!     and read the upper or lower triangular part of the matrix A
!     from data file

      Read (nin, *) vl, vu
      If (uplo=='U') Then
        Read (nin, *)((ap(i+(j*(j-1))/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+((2*n-j)*(j-1))/2),j=1,i), i=1, n)
      End If

!     Set the absolute error tolerance for eigenvalues.  With ABSTOL
!     set to zero, the default value is used instead

      abstol = zero

!     Solve the Hermitian eigenvalue problem

      Call zhpevx('Vectors', 'Values in range', uplo, n, ap, vl, vu, il, iu, &
        abstol, m, w, z, ldz, work, rwork, iwork, jfail, info)

      If (info>=0) Then

!       Print solution

        Write (nout, 100) 'Number of eigenvalues found =', m
        Write (nout, *)
        Write (nout, *) 'Eigenvalues'
        Write (nout, 110) w(1:m)
        Flush (nout)

!       Normalize the eigenvectors, largest element real
        Do i = 1, m
          rwork(1:n) = abs(z(1:n,i))
          k = maxloc(rwork(1:n), 1)
          scal = conjg(z(k,i))/abs(z(k,i))/dznrm2(n, z(1,i), 1)
          z(1:n, i) = z(1:n, i)*scal
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', n, m, z, ldz, &
          'Selected eigenvectors', ifail)

        If (info>0) Then
          Write (nout, 100) 'INFO eigenvectors failed to converge, INFO =', &
            info
          Write (nout, *) 'Indices of eigenvectors that did not converge'
          Write (nout, 120) jfail(1:m)
        End If
      Else
        Write (nout, 100) 'Failure in ZHPEVX. INFO =', info
      End If

100   Format (1X, A, I5)
110   Format (3X, (8F8.4))
120   Format (3X, (8I8))
    End Program


      subroutine tstr

!!     ~ ~ ~ PURPOSE ~ ~ ~
!!     computes temperature stress for crop growth - strstmp

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    icr(:)      |none          |sequence number of crop grown within the
!!                               |current year
!!    idplt(:)    |none          |land cover code from crop.dat
!!    ihru        |none          |HRU number
!!    nro(:)      |none          |sequence number of year in rotation
!!    t_base(:)   |deg C         |minimum temperature for plant growth
!!    t_opt(:)    |deg C         |optimal temperature for plant growth
!!    tmn(:)      |deg C         |minimum temperature for the day in HRU
!!    tmp_an(:)   |deg C         |average annual air temperature
!!    tmpav(:)    |deg C         |average air temperature on current day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    strstmp(:)  |none          |fraction of potential plant growth achieved on
!!                               |the day in HRU where the reduction is caused
!!                               |by temperature stress
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    j           |none          |HRU number
!!    rto         |
!!    tgx         |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j
      real :: tgx, rto

      j = 0
      j = ihru

      tgx = 0.
      tgx = tmpav(j) - t_base(idplt(j))

      if (tgx <= 0.) then
        strstmp(j) = 0.
      else
        if (tmpav(j) > t_opt(idplt(j))) then
         tgx = 2. * t_opt(idplt(j)) -
     &                         t_base(idplt(j)) - tmpav(j)
        end if

        rto = 0.
        rto = ((t_opt(idplt(j)) - tmpav(j)) /
     &                                               (tgx + 1.e-6)) ** 2

        if (rto <= 200. .and. tgx > 0.) then
          strstmp(j) = Exp(-0.1054 * rto)
        else
          strstmp(j) = 0.
        end if

        if (tmn(j) <= tmp_an(hru_sub(j)) - 15.) strstmp(j) = 0.

      end if

      return
      end


<ompts:test>
<ompts:testdescription>Test which checks the omp parallel do private directive.</ompts:testdescription>
<ompts:ompversion>2.0</ompts:ompversion>
<ompts:directive>omp parallel do private</ompts:directive>
<ompts:dependences>par do reduction,omp flush</ompts:dependences>
<ompts:testcode>
      SUBROUTINE do_some_work2()
        IMPLICIT NONE
        REAL i
        DOUBLE PRECISION sum
        INTRINSIC sqrt
        INCLUDE "omp_testsuite.f"
        sum = 0.0
        i = 0
        DO WHILE (i < LOOPCOUNT)
           sum = sum + sqrt(i)
           i = i + 1
        END DO
      END

!********************************************************************

      INTEGER FUNCTION <ompts:testcode:functionname>par_do_private</ompts:testcode:functionname>()
        IMPLICIT NONE
        INTEGER sum,known_sum, i, i2, i3
        INCLUDE "omp_testsuite.f"
        sum = 0

!$omp parallel do reduction(+:sum) <ompts:check>private(i2)</ompts:check> schedule(static,1)
        DO i=1, LOOPCOUNT
          i2 = i
!$omp flush
          CALL do_some_work2()
!$omp flush
          sum = sum + i2
        END DO
!$omp end parallel do
          known_sum = (LOOPCOUNT*(LOOPCOUNT+1))/2
        IF ( known_sum .EQ. sum ) THEN
          <testfunctionname></testfunctionname> = 1
        ELSE
          <testfunctionname></testfunctionname> = 0
        END IF
      END
</ompts:testcode>
</ompts:test>


C     ******************************************************************
C     ******************************************************************

      subroutine gencan(n,x,l,u,m,lambda,equatn,linear,rho,epsfeas,
     +epsopt,maxit,iter,f,g,gpsupn,cnorm,cnormu,geninfo,inform)

      implicit none

C     SCALAR ARGUMENTS
      integer geninfo,inform,iter,m,maxit,n
      double precision cnorm,cnormu,epsfeas,epsopt,f,gpsupn

C     ARRAY ARGUMENTS
      logical equatn(m),linear(m)
      double precision g(n),l(n),lambda(m),rho(m),u(n),x(n)

C     Solves the box-constrained minimization problem
C
C            Minimize f(x) subject to l <= x <= u
C
C     using the method described in
C
C     E. G. Birgin and J. M. Martinez, ''Large-scale active-set box-
C     constrained optimization method with spectral projected
C     gradients'', Computational Optimization and Applications 23, pp.
C     101-125, 2002.

C     geninfo:
C
C     0: Small continuous-projected-gradient norm
C     1: Maximum number of gencan iterations reached
C     3: Lack of progress
C     6: Unbounded objective function?

      include "dim.par"
      include "machconst.inc"
      include "algconst.par"
      include "algparam.inc"
      include "probdata.inc"
      include "counters.inc"
      include "outtyp.inc"
      include "rspace.inc"
      include "itetyp.inc"
      include "sydat.inc"

C     LOCAL SCALARS
      character * 6 precond
      character * 2 inniter
      logical forceoi,memfail,vustop
      integer cgcnt,cginfo,cgiter,cgmaxit,chcnt,i,innit,itnfp,itngp,
     +        itnxp,lsinfo,nind,nindprev,nwcnt,lvfit,rbdnnz,trcnt,
     +        trinfo,xind
      double precision acgeps,adsupn,amax,bcgeps,cgeps,cgdel,dsupn,
     +        fbest,fplus,gpeucnb,gieucn,gisupn,gpeucn,gpi,gpsupnb,
     +        lamspg,mslamb,newtrdel,ssupn,tmp,trdel,tsmall,ysupn,xeucn,
     +        xsupn,maxelem

C     LOCAL ARRAYS
      integer rbdind(nmax)
      character rbdtype(nmax)
      double precision d(nmax),dum(nmax),gplus(nmax),xplus(nmax)

C     DATA BLOCKS
      character * 21 ittext(0:4)
      integer BDSREACHED,FSTORDPNT,SECORDPNT,SMALLSTEP,TCLSBNDRY,
     +        TOOSMLTRR,UNBOUNDED,UNDEFSTEP

      data ittext(0) /'(Initial point)     '/
      data ittext(1) /'(SPG step)          '/
      data ittext(2) /'(Truncated Newton)  '/
      data ittext(3) /'(Newton w/MS-system)'/
      data ittext(4) /'(Trust region)      '/

      data BDSREACHED /2/
      data UNBOUNDED  /2/
      data SMALLSTEP  /3/
      data TOOSMLTRR  /4/
      data UNDEFSTEP  /5/
      data FSTORDPNT  /6/
      data SECORDPNT  /7/
      data TCLSBNDRY  /8/

C     EXTERNAL
      logical sstop

C     EXTERNAL SUBROUTINES
      external sevalal,ssetp

C     ==================================================================
C     Initialization
C     ==================================================================

C     Set some initial values:

C     best functional and gradient-norm values
      fbest   = bignum
      gpsupnb = bignum
      gpeucnb = bignum

C     to record a memory failure in the direct solver
      memfail = .false.

C     for Conjugate Gradients
      precond = 'QNCGNA'

C     for the first inner-to-the-face minimization algorithm
      inniter = 'TN'

C     for testing lack of progress checking f, g and x
      itnfp = 0
      itngp = 0
      itnxp = 0

C     to force a leaving-face iteration when lack of progress is
C     detected within a face
      forceoi = .false.

C     for calculating More-Sorensen's direction
      mslamb =  0.0d0

C     for counting number of iterations as well as inner-to-the-face
C     and leaving-face iterations
      iter  = 0
      cgcnt = 0
      nwcnt = 0
      trcnt = 0
      chcnt = 0
      lvfit = 0
      innit = 0

C     just to print "Initial point" in the first ouput
      ittype = 0

C     Print problem information

      if ( iprintinn .ge. 1 ) then
C          write(* ,1000) n,epsopt
          write(10,1000) n,epsopt
      end if

      if ( iprintinn .ge. 4 .and. nprint .ne. 0 ) then
C          write(* ,1010) nprint,(l(i),i=1,nprint)
C          write(* ,1020) nprint,(u(i),i=1,nprint)
C          write(* ,1030) nprint,(x(i),i=1,nprint)

          write(10,1010) nprint,(l(i),i=1,nprint)
          write(10,1020) nprint,(u(i),i=1,nprint)
          write(10,1030) nprint,(x(i),i=1,nprint)
      end if

C     Project initial guess. If the initial guess is infeasible,
C     projection puts it into the box.

      do i = 1,n
          x(i) = max( l(i), min( x(i), u(i) ) )
      end do

C     Compute function and gradient at the initial point

      call ssetp(n,x)

      call sevalal(n,x,m,lambda,rho,equatn,linear,f,inform)
      if ( inform .lt. 0 ) return

      call sevalnal(n,x,m,lambda,rho,equatn,linear,g,inform)
      if ( inform .lt. 0 ) return

C     For feasibility problems, compute scaled and unscaled feasibilities

      if ( ignoref ) then
          call sevalfeas(n,x,m,equatn,cnorm,cnormu,inform)
          if ( inform .lt. 0 ) return

      else
          cnorm  = 0.0d0
          cnormu = 0.0d0
      end if

C     Compute x Euclidian and sup norms, continuous-project-gradient
C     Euclidian and sup norms, internal gradient Euclidian norm. Set
C     nind as the number of free variables and save in array ind their
C     identifiers. Also set variable sameface (same face) indicating
C     that the "previous iterate" does not belong to the current face.

      sameface = .false.

      nind   = 0
      xsupn  = 0.0d0
      xeucn  = 0.0d0
      gpsupn = 0.0d0
      gpeucn = 0.0d0
      gisupn = 0.0d0
      gieucn = 0.0d0
      do i = 1,n
          if ( abs( x(i) ) .ge. xsupn ) then
              xsupn = abs( x(i) )
              xind = i
          end if
          xeucn = xeucn + x(i) ** 2
          gpi = x(i) - g(i)
          if ( l(i) .le. gpi .and. gpi .le. u(i) ) then
              gpi = - g(i)
          else
              gpi = max( l(i), min( gpi, u(i) ) ) - x(i)
          end if
          gpsupn = max( gpsupn, abs( gpi ) )
          gpeucn = gpeucn + gpi ** 2
          if ( x(i) .gt. l(i) + macheps23 * max(1.0d0,abs(l(i))) .and.
     +         x(i) .lt. u(i) - macheps23 * max(1.0d0,abs(u(i))) ) then
              gisupn    = max( gisupn, abs( gpi ) )
              gieucn    = gieucn + gpi ** 2
              nind      = nind + 1
              ind(nind) = i
          end if
      end do
      xeucn  = sqrt( xeucn  )
      gpeucn = sqrt( gpeucn )
      gieucn = sqrt( gieucn )

C     Compute trut-region radius, in case betra is used as inner solver

      trdel    = max( trdelmin, trdelini * max( 1.0d0, xeucn ) )
      newtrdel = 0.0d0

C     Initial spectral steplength

C     Compute a small step and set the point at which the auxiliary
C     gradient will be computed

      if ( gpsupn .ne. 0.0d0 ) then
          tsmall = macheps12 * max( 1.0d0, xsupn / gpsupn )
      else
          tsmall = 0.0d0
      end if

      do i = 1,n
          gpi = x(i) - g(i)
          if ( l(i) .le. gpi .and. gpi .le. u(i) ) then
              gpi = - g(i)
          else
              gpi = max( l(i), min( gpi, u(i) ) ) - x(i)
          end if
          s(i) = x(i) + tsmall * gpi
      end do

C     Compute the gradient at the auxiliary point

      call ssetp(n,s)

      call ievalnal(n,s,m,lambda,rho,equatn,linear,.false.,y,inform)
      if ( inform .lt. 0 ) return

      call ssetp(n,x)

C     Compute s = x_{1/2} - x_0 and y = g_{1/2} - g_0

      sts = 0.0d0
      sty = 0.0d0
      ssupn = 0.0d0
      ysupn = 0.0d0
      yeucn = 0.0d0
      do i = 1,n
          s(i) = s(i) - x(i)
          y(i) = y(i) - g(i)
          sts  = sts + s(i) ** 2
          sty  = sty + s(i) * y(i)
          ssupn = max( ssupn, abs( s(i) ) )
          ysupn = max( ysupn, abs( y(i) ) )
          yeucn = yeucn + y(i) ** 2
      end do
      seucn = sqrt( sts )
      yeucn = sqrt( yeucn )

C     Compute a linear relation between gpsupn and cgeps, i.e.,
C     scalars a and b such that
c
C         a * log10( ||g_P(x_ini)|| ) + b = log10(cgeps_ini) and
c
C         a * log10( ||g_P(x_fin)|| ) + b = log10(cgeps_fin),
c
C     where cgeps_ini and cgeps_fin are provided. Note that if
C     cgeps_ini is equal to cgeps_fin then cgeps will be always
C     equal to cgeps_ini and cgeps_fin.

      acgeps = log10( cgepsf / cgepsi ) / log10( cggpnf / gpsupn )
      bcgeps = log10( cgepsi ) - acgeps * log10( gpsupn )

C     Print initial information

      if ( iprintinn .eq. 1 ) then
          if ( mod(iter,10) .eq. 0 ) then
C              write(* ,1040)
              write(10,1040)
          end if
C          write(* ,1050) iter,f,gpsupn,xsupn
          write(10,1050) iter,f,gpsupn,xsupn

      else if ( iprintinn .ge. 2 ) then
C          write(* ,1070) iter,ittext(ittype)
          write(10,1070) iter,ittext(ittype)

          if ( iprintinn .ge. 3 ) then
C              write(* ,1080) lvfit,innit,fcnt,cgcnt,nwcnt,trcnt,chcnt
              write(10,1080) lvfit,innit,fcnt,cgcnt,nwcnt,trcnt,chcnt
          end if

C          write(* ,1090) f,gpsupn,gpeucn,gisupn,gieucn,xind,xsupn,xeucn,
C     +                   ssupn,seucn
          write(10,1090) f,gpsupn,gpeucn,gisupn,gieucn,xind,xsupn,xeucn,
     +                   ssupn,seucn

          if ( iprintinn .ge. 4 .and. nprint .ne. 0 ) then
C              write(* ,1100) min(nprint,nind),nind,
C     +                       (ind(i),i=1,min(nprint,nind))
C              write(* ,1110) nprint,(x(i),i=1,nprint)
C              write(* ,1130) nprint,(g(i),i=1,nprint)
C              write(* ,1140) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),
C     +                       i=1,nprint)
              write(10,1100) min(nprint,nind),nind,
     +                       (ind(i),i=1,min(nprint,nind))
              write(10,1110) nprint,(x(i),i=1,nprint)
              write(10,1130) nprint,(g(i),i=1,nprint)
              write(10,1140) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),
     +                       i=1,nprint)
          end if
      end if

C     Save intermediate data for crash report

      if ( iprintctl(6) ) then
          open(20,file='gencan-tabline.out')
          write(20,1400) f,0.0d0,f,0.0d0,gpsupn,f,0.0d0,f,0.0d0,gpsupn,
     +                   0.0d0,0.0d0,inform,9,.false.,n,m,0,iter,fcnt,0,
     +                   0,0,0,999.9d0
          close(20)
      end if

C     ==================================================================
C     Main loop
C     ==================================================================

 100  continue

C     ==================================================================
C     Test stopping criteria
C     ==================================================================

C     Test user-provided stopping criterion

      if ( useustp ) then

          vustop = sstop(n,x,m,lambda,rho,equatn,linear,inform)
          if ( inform .lt. 0 ) return

          if ( vustop ) then
              geninfo = 8

              if ( iprintinn .ge. 1 ) then
C                  write(*, 1280)
                  write(10,1280)
              end if

              return
          end if

      end if

C     Test whether the continuous-projected-gradient sup-norm
C     is small enough to declare convergence. In the case of
C     feasibility problems, check feasibility.

      if ( ( .not. ignoref .and. gpsupn .le. epsopt  ) .or.
     +     (       ignoref .and. cnormu .le. epsfeas ) ) then
          geninfo = 0

          if ( iprintinn .ge. 1 ) then
C              write(*, 1200)
              write(10,1200)
          end if

          return
      end if

C     Test whether the number of iterations is exhausted

      if ( iter .ge. maxit ) then
          geninfo = 1

          if ( iprintinn .ge. 1 ) then
C              write(*, 1210)
              write(10,1210)
          end if

          return
      end if

C     ==================================================================
C     Test stopping criteria related to lack of progress
C     ==================================================================

      if ( iter .gt. 0 ) then

C     Test whether we have performed many iterations without
C     moving from the current point, by checking the functional value

      if ( f .ge. fbest - macheps23 * abs( fbest ) )  then
          itnfp = itnfp + 1
      else
          itnfp = 0
      end if

C     Test whether we have performed many iterations without
C     moving from the current point, by checking their gradients

      if ( gpsupn .ge. gpsupnb - macheps23 * gpsupnb .or.
     +     gpeucn .ge. gpeucnb - macheps23 * gpeucnb ) then
          itngp = itngp + 1
      else
          itngp = 0
      end if

C     Test whether we have performed many iterations without
C     moving from the current point, by checking the step norm

      if ( ssupn .le. max( macheps23, macheps * xsupn ) .or.
     +     seucn .le. max( macheps23, macheps * xeucn ) ) then
          itnxp = itnxp + 1
      else
          itnxp = 0
      end if

C     If there was no progress in the objective functional value, its
C     gradient and the current point, stop

      if ( itnfp .ge. maxinnitnp .and. itngp .ge. maxinnitnp .and.
     +     itnxp .ge. maxinnitnp ) then
          geninfo = 3

          if ( iprintinn .ge. 1 ) then
C              write(*, 1230)
              write(10,1230)
          end if

          return
      end if

      end if

C     ==================================================================
C     Iteration
C     ==================================================================

      iter = iter + 1

C     ==================================================================
C     Compute new iterate
C     ==================================================================

C     We abandon the current face if the norm of the internal gradient
C     (here, internal components of the continuous projected gradient)
C     is smaller than eta times the norm of the continuous
C     projected gradient. Using eta = 0.1 is a rather conservative
C     strategy in the sense that internal iterations are preferred over
C     SPG iterations. Replace eta = 0.1 by other tolerance in (0,1) if
C     you find it convenient.

      if ( gieucn .le. eta * gpeucn .or.
     +     gisupn .le. eta * gpsupn .or. forceoi ) then

C         ==============================================================
C         Some constraints should be abandoned. Compute the new iterate
C         using an SPG iteration
C         ==============================================================

          forceoi = .false.
          lvfit = lvfit + 1

C         Compute spectral steplength

          if ( sty .le. 0.0d0 ) then
              lamspg = max( 1.0d0, xsupn / gpsupn )
          else
              lamspg = sts / sty
          end if
          lamspg = min( lspgma, max( lspgmi, lamspg ) )

C         Perform safeguarded quadratic interpolation along the
C         spectral continuous projected gradient

          call spgls(n,x,l,u,m,lambda,rho,equatn,linear,f,g,lamspg,
     +    xplus,fplus,tmp,d,sevalal,ssetp,lsinfo,inform)
          if ( inform .lt. 0 ) return

          call sevalnal(n,xplus,m,lambda,rho,equatn,linear,gplus,inform)
          if ( inform .lt. 0 ) return

C         Set iteration type

          ittype = 1

      else

C         ==============================================================
C         The new iterate will belong to the closure of the current face
C         ==============================================================

          innit = innit + 1

C         Shrink the point, its gradient and the bounds

          call shrink(nind,x)
          call shrink(nind,g)
          call shrink(nind,l)
          call shrink(nind,u)

C         Save values of fixed variables for further evaluations

          do i = 1,n - nind
              xcomplement(i) = x(nind + i)
          end do

          nt = n

C         Compute the new point using a trust-region approach

          if ( inniter .eq. 'TR' ) then

              call betra(n,nind,x,l,u,m,lambda,rho,equatn,linear,f,g,
     +        trdel,newtrdel,mslamb,epsopt,xeucn,xsupn,gpsupn,d,rbdind,
     +        rbdtype,xplus,fplus,gplus,trcnt,chcnt,memfail,trinfo,
     +        inform)

              if ( inform .lt. 0 ) return

C             Set iteration type

              ittype = 4

          end if

C         Compute the descent direction solving the newtonian system

          if ( inniter .eq. 'NW' ) then

C             Solve the Newtonian system
C
C                 ( H + rho A^T A ) x = b
C
C             by solving the Martinez-Santos system
C
C                 H x + A^t y = b
C                 A x - y/rho = 0
C
C             with a direct solver.

              call newtd(nind,x,l,u,g,m,rho,equatn,d,adsupn,maxelem,
     +        memfail,inform)
              if ( inform .lt. 0 ) return

              nwcnt = nwcnt + 1

              if ( .not. memfail ) then

C                 Compute maximum step

                  call compamax(nind,x,l,u,d,amax,rbdnnz,rbdind,rbdtype)

C                 Perform line search

                  call tnls(nind,x,l,u,m,lambda,rho,equatn,linear,f,g,
     +            amax,d,rbdnnz,rbdind,rbdtype,xplus,fplus,gplus,lsinfo,
     +            inform)
                  if ( inform .lt. 0 ) return

              end if

C             Set iteration type

              ittype = 3

          end if

          if (   inniter .eq. 'TN' .or.
     +         ( inniter .eq. 'NW' .and. memfail ) .or.
     +         ( inniter .eq. 'TR' .and. memfail ) .or.
     +         ( inniter .eq. 'TR' .and. trinfo .eq. UNDEFSTEP ) .or.
     +         ( inniter .eq. 'TR' .and. trinfo .eq. TOOSMLTRR ) .or.
     +         ( inniter .eq. 'TR' .and. trinfo .eq. FSTORDPNT ) .or.
     +         ( inniter .eq. 'TR' .and. trinfo .eq. SECORDPNT ) .or.
     +         ( inniter .eq. 'TR' .and. trinfo .eq. TCLSBNDRY ) ) then

C             Compute "trust-region radius" for CG

              if ( iter .eq. 1 ) then
                  cgdel = max( 100.0d0, 100.0d0 * xsupn )
              else
                  cgdel = max( delmin, 10.0d0 * ssupn )
              end if

C             Set conjugate gradient stopping criteria.

              cgmaxit = min( nind, 10000 )
              cgeps   = 10.0d0 ** ( acgeps * log10( gpsupn ) + bcgeps )
              cgeps   = max( cgepsf, min( cgepsi, cgeps ) )

C             Call Conjugate Gradients to solve the Newtonian system

              call cgm(nind,x,m,lambda,rho,equatn,linear,l,u,g,cgdel,
     +        cgeps,cgmaxit,precond,d,rbdnnz,rbdind,rbdtype,cgiter,
     +        cginfo,inform)

              cgcnt = cgcnt + cgiter

              if ( inform .lt. 0 ) return

C             Compute maximum step

              if ( cginfo .eq. BDSREACHED ) then
                  amax = 1.0d0
              else
                  call compamax(nind,x,l,u,d,amax,rbdnnz,rbdind,rbdtype)
              end if

C             Perform line search

              call tnls(nind,x,l,u,m,lambda,rho,equatn,linear,f,g,amax,
     +        d,rbdnnz,rbdind,rbdtype,xplus,fplus,gplus,lsinfo,inform)
              if ( inform .lt. 0 ) return

C             Set iteration type

              ittype = 2

          end if

C         Set iteration type for the next iteration

          dsupn = 0.0d0
          do i = 1,nind
              dsupn = max( dsupn, abs( d(i) ) )
          end do

          if (   memfail .or.
     +         ( ittype .eq. 3 .and. adsupn .gt. maxelem ) .or.
     +         ( ittype .eq. 3 .and. amax .le. macheps12 * dsupn ) )
     +    then
              inniter = 'TN'
          else
              inniter = innslvr
          end if

C         Test whether to force a leaving-face iteration is recommended

          if ( nbds .gt. 0 .and.
     +         ( ittype .eq. 2 .and. lsinfo .eq. SMALLSTEP ) .or.
     +         ( ittype .eq. 4 .and. trinfo .eq. SMALLSTEP ) ) then
              forceoi = .true.
          end if

C         Expand the point, its gradient and the bounds. Also expand
C         xplus and gplus.

          call expand(nind,x)
          call expand(nind,g)
          call expand(nind,l)
          call expand(nind,u)

          call expand(nind,xplus)
          call expand(nind,gplus)
      end if

C     For feasibility problems, compute scaled and unscaled feasibilities

      if ( ignoref ) then
          call sevalfeas(n,x,m,equatn,cnorm,cnormu,inform)
          if ( inform .lt. 0 ) return

      else
          cnorm  = 0.0d0
          cnormu = 0.0d0
      end if

C     Compute s = xplus - x and y = gplus - g

      if ( f      .lt. fbest   ) fbest   = f
      if ( gpsupn .lt. gpsupnb ) gpsupnb = gpsupn
      if ( gpeucn .lt. gpeucnb ) gpeucnb = gpeucn

      sts = 0.0d0
      sty = 0.0d0
      ssupn = 0.0d0
      ysupn = 0.0d0
      yeucn = 0.0d0
      do i = 1,n
          s(i) = xplus(i) - x(i)
          y(i) = gplus(i) - g(i)
          sts  = sts + s(i) ** 2
          sty  = sty + s(i) * y(i)
          ssupn = max( ssupn, abs( s(i) ) )
          ysupn = max( ysupn, abs( y(i) ) )
          yeucn = yeucn + y(i) ** 2
      end do
      seucn = sqrt( sts )
      yeucn = sqrt( yeucn )

C     Set new point

      f = fplus

      do i = 1,n
          x(i) = xplus(i)
          g(i) = gplus(i)
      end do

C     ==================================================================
C     Prepare for the next iteration
C     ==================================================================

C     Compute continuous-project-gradient Euclidian and Sup norms,
C     internal gradient Euclidian norm, and store in nind the number of
C     free variables and in array ind their identifiers. Verify whether
C     x and xprev belong to the same face.

      sameface = .true.
      nindprev = nind

      nind   = 0
      xsupn  = 0.0d0
      xeucn  = 0.0d0
      gpsupn = 0.0d0
      gpeucn = 0.0d0
      gisupn = 0.0d0
      gieucn = 0.0d0
      do i = 1,n
          if ( abs( x(i) ) .ge. xsupn ) then
              xsupn = abs( x(i) )
              xind = i
          end if
          xeucn = xeucn + x(i) ** 2
          gpi = x(i) - g(i)
          if ( l(i) .le. gpi .and. gpi .le. u(i) ) then
              gpi = - g(i)
          else
              gpi = max( l(i), min( gpi, u(i) ) ) - x(i)
          end if
          gpsupn = max( gpsupn, abs( gpi ) )
          gpeucn = gpeucn + gpi ** 2
          if ( x(i) .gt. l(i) + macheps23 * max(1.0d0,abs(l(i))) .and.
     +         x(i) .lt. u(i) - macheps23 * max(1.0d0,abs(u(i))) ) then
              gisupn    = max( gisupn, abs( gpi ) )
              gieucn    = gieucn + gpi ** 2
              nind      = nind + 1
              if ( nind .gt. nindprev .or. ind(nind) .ne. i ) then
                  sameface = .false.
              end if
              ind(nind) = i
          end if
      end do
      xeucn  = sqrt( xeucn  )
      gpeucn = sqrt( gpeucn )
      gieucn = sqrt( gieucn )

C     Print information of this iteration

      if ( iprintinn .eq. 1 ) then
          if ( mod(iter,10) .eq. 0 ) then
C              write(* ,1040)
              write(10,1040)
          end if
C          write(* ,1060) iter,f,gpsupn,xsupn,ssupn,nind,lvfit,innit,fcnt
          write(10,1060) iter,f,gpsupn,xsupn,ssupn,nind,lvfit,innit,fcnt

      else if ( iprintinn .ge. 2 ) then
C          write(* ,1070) iter,ittext(ittype)
          write(10,1070) iter,ittext(ittype)

          if ( iprintinn .ge. 3 ) then
C              write(* ,1080) lvfit,innit,fcnt,cgcnt,nwcnt,trcnt,chcnt
              write(10,1080) lvfit,innit,fcnt,cgcnt,nwcnt,trcnt,chcnt
          end if

C          write(* ,1090) f,gpsupn,gpeucn,gisupn,gieucn,xind,xsupn,xeucn,
C     +                   ssupn,seucn
          write(10,1090) f,gpsupn,gpeucn,gisupn,gieucn,xind,xsupn,xeucn,
     +                   ssupn,seucn

          if ( iprintinn .ge. 4 .and. nprint .ne. 0 ) then
C              write(* ,1100) min(nprint,nind),nind,
C     +                       (ind(i),i=1,min(nprint,nind))
C              write(* ,1110) nprint,(x(i),i=1,nprint)
C              write(* ,1130) nprint,(g(i),i=1,nprint)
C              write(* ,1140) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),
C     +                       i=1,nprint)
              write(10,1100) min(nprint,nind),nind,
     +                       (ind(i),i=1,min(nprint,nind))
              write(10,1110) nprint,(x(i),i=1,nprint)
              write(10,1130) nprint,(g(i),i=1,nprint)
              write(10,1140) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),
     +                       i=1,nprint)
          end if
      end if

C     Save intermediate data for crash report

      if ( iprintctl(6) ) then
          open(20,file='gencan-tabline.out')
          write(20,1400) f,0.0d0,f,0.0d0,gpsupn,f,0.0d0,f,0.0d0,gpsupn,
     +                   0.0d0,0.0d0,inform,9,.false.,n,m,0,iter,fcnt,0,
     +                   0,0,0,999.9d0
          close(20)
      end if

C     ==================================================================
C     Test line-search and trust-region related stopping criteria
C     ==================================================================

C     Test whether the functional value is unbounded

      if ( ( ittype .le. 3 .and. lsinfo .eq. UNBOUNDED ) .or.
     +     ( ittype .eq. 4 .and. trinfo .eq. UNBOUNDED ) ) then
          geninfo = 6

          if ( iprintinn .ge. 1 ) then
C              write(*, 1260)
              write(10,1260)
          end if

          return
      end if

C     ==================================================================
C     Iterate
C     ==================================================================

      go to 100

C     ==================================================================
C     End of main loop
C     ==================================================================

C     NON-EXECUTABLE STATEMENTS

 1000 format(/,5X,'Entry to GENCAN.',
     +       /,5X,'Number of variables: ',I7,
     +       /,5X,'Required optimality tolerance: ',1P,D7.1)

 1010 format(/,5X,'Lower bounds  (first ',I7,' components):',
     +       /,(5X, 6(1X,1P,D11.4)))
 1020 format(/,5X,'Upper bounds  (first ',I7,' components):',
     +       /,(5X, 6(1X,1P,D11.4)))
 1030 format(/,5X,'Initial point (first ',I7,' components):',
     +       /,(5X, 6(1X,1P,D11.4)))

 1040 format(/,5X,'It',16X,'f',2X,'gpsupn',3X,'xsupn',3X,'ssupn',4X,
     +            'nind',3X,'lvfit',3X,'innit',4X,'fcnt')
 1050 format(     I7,1X,1P,D16.8,2(1X,1P,D7.1))
 1060 format(     I7,1X,1P,D16.8,3(1X,1P,D7.1),4(1X,I7))

 1070 format(/,5X,'GENCAN ITERATION                  ',12X,'= ',I7,1X,
     +         A21)
 1080 format(/,5X,'Leaving-face iterations           ',12X,'= ',I7,
     +       /,5X,'Inner-to-the-face iterations      ',12X,'= ',I7,
     +       /,5X,'Functional evaluations            ',12X,'= ',I7,
     +       /,5X,'Conjugate gradient iterations     ',12X,'= ',I7,
     +       /,5X,'Newtonian system factorizations   ',12X,'= ',I7,
     +       /,5X,'Trust-region iterations           ',12X,'= ',I7,
     +       /,5X,'Trust-region matrix factorizations',12X,'= ',I7)

 1090 format(/,5X,'Functional value                              = ',
     +             1P,D24.16,
     +       /,5X,'Sup-norm of the continuous projected gradient = ',
     +             1P,D7.1,' 2-norm = ',1P,D7.1,
     +       /,5X,'Sup-norm of the internal projection of gp     = ',
     +             1P,D7.1,' 2-norm = ',1P,D7.1,
     +       /,5X,'Sup-norm of x (attained at x_{', I7,'})       = ',
     +             1P,D7.1,' 2-norm = ',1P,D7.1,
     +       /,5X,'Sup-norm of x - x_{prev}                      = ',
     +             1P,D7.1,' 2-norm = ',1P,D7.1)
 1100 format(/,5X,'Current free variables (first ',I7,', total ',
     +            'number ',I7,'): ',
     +       /,(5X, 6(1X,I7)))
 1110 format(/,5X,'Current point (first ',I7, ' components): ',
     +       /,(5X, 6(1X,1P,D11.4)))
 1130 format(/,5X,'Current gradient (first ',I7,' components): ',
     +       /,(5X, 6(1X,1P,D11.4)))
 1140 format(/,5X,'Current continuous projected gradient (first ',I7,
     +         5X,'components): ',
     +       /,(5X, 6(1X,1P,D11.4)))

 1200 format(/,5X,'Flag of GENCAN: Solution was found.',/)
 1210 format(/,5X,'Flag of GENCAN: Maximum of iterations reached.',/)
 1230 format(/,5X,'Flag of GENCAN: Lack of progress in the functional ',
     +            'value, its gradient and',/,5X,'the current point. ',
     +            'Probably, an exaggerated small norm of the ',
     +            'continuous',/,5X,'projected gradient is being ',
     +            'required to declare convergence.',/)
 1260 format(/,5X,'Flag of GENCAN: Objective function seems to be ',
     +            'unbounded.',/)
 1280 format(/,5X,'Flag of GENCAN: User-provided stopping criterion ',
     +            'satisfied.',/)

 1400 format(1X,1P,D24.16,1X,1P,D7.1,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1,
     +       1X,1P,D24.16,1X,1P,D7.1,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1,
     +       1X,1P,D7.1,1X,1P,D7.1,1X,I3,1X,I1,1X,L1,1X,I6,1X,I6,1X,I3,
     +       1X,I7,1X,I7,1X,I2,1X,I7,1X,I7,1X,I7,0P,F8.2)

      end

C     ******************************************************************
C     ******************************************************************

      subroutine compamax(nind,x,l,u,d,amax,rbdnnz,rbdind,rbdtype)

      implicit none

C     SCALAR ARGUMENTS
      integer nind,rbdnnz
      double precision amax

C     ARRAY ARGUMENTS
      integer rbdind(nind)
      character rbdtype(nind)
      double precision d(nind),l(nind),u(nind),x(nind)

C     Compute maximum step amax > 0 such that l <= x + amax d <= u.

      include "dim.par"
      include "machconst.inc"

C     LOCAL SCALARS
      integer i
      double precision amaxi

      rbdnnz = 0

      amax = bignum

      do i = 1,nind
         if ( d(i) .gt. 0.0d0 ) then

             amaxi = ( u(i) - x(i) ) / d(i)

             if ( amaxi .lt. amax ) then
                 amax       = amaxi
                 rbdnnz     = 1
                 rbdind(1)  = i
                 rbdtype(1) = 'U'
             else if ( amaxi .eq. amax ) then
                 rbdnnz          = rbdnnz + 1
                 rbdind(rbdnnz)  = i
                 rbdtype(rbdnnz) = 'U'
             end if

         else if ( d(i) .lt. 0.0d0 ) then

             amaxi = ( l(i) - x(i) ) / d(i)

             if ( amaxi .lt. amax ) then
                 amax      = amaxi
                 rbdnnz     = 1
                 rbdind(1)  = i
                 rbdtype(1) = 'L'
             else if ( amaxi .eq. amax ) then
                 rbdnnz          = rbdnnz + 1
                 rbdind(rbdnnz)  = i
                 rbdtype(rbdnnz) = 'L'
             end if

         end if
      end do

      end


!>  Partition a graph specified by a matrix
!
!   Source: http://people.eecs.berkeley.edu/~demmel/cs267/lecture18/lecture18.html
!
program test_PartGraphKway

    use metis_interface, only: idx_t, METIS_PartGraphKway, METIS_SetDefaultOptions, &
        METIS_NOPTIONS, METIS_OPTION_NUMBERING, METIS_OK
    implicit none

    integer(idx_t), parameter :: npart = 3  ! number of partitions
    integer(idx_t), parameter :: n = 8      ! number of nodes
    integer(idx_t), parameter :: m = 10     ! number of edges

    integer(idx_t) :: xadj(n+1), adjncy(2*m) ! graph adjacency structure
    integer(idx_t) :: part(n)
    integer(idx_t) :: options(0:METIS_NOPTIONS-1), ios, objval

    write(*,'(A)') "TEST METIS_PartGraphKway"

    !    1  2  3  4  5  6  7  8
    !  | a  a  a     a          | 1
    !  | a  a     a  a          | 2
    !  | b     b        b       | 3
    !  |    b     b     b       | 4
    !  | a  a           a     a | 5
    !  |       b  b  b          | 6
    !  |                   c  c | 7
    !  |             c     c  c | 8

    xadj = [1,4,7,9,11,15,18,19,21]
    adjncy = [2,3,5,&
              1,4,5,&
              1,6,&
              2,6,&
              1,2,6,8,&
              3,4,5,&
              8,&
              5,7]

    ios = METIS_SetDefaultOptions(options)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_SetDefaultOptions failed with error: ", ios
        error stop 1
    end if
    options(METIS_OPTION_NUMBERING) = 1 ! Fortran-style numbering

    ios = METIS_PartGraphKway(n,ncon=1,xadj=xadj,adjncy=adjncy,nparts=npart,options=options,objval=objval,part=part)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_PartGraphKway failed with error: ", ios
        error stop 1
    end if

    write(*,'(A,I0)') "objval = ", objval
    write(*,'(A,*(I1,:,1X))') "part = ", part

end program


program testinterp3

use phys_consts, only: wp,pi
use interpolation, only : interp3
use h5fortran, only: hdf5_file

implicit none (type, external)

character(1024) :: argv
type(hdf5_file) :: hout
integer, parameter :: lx1=80, lx2=90, lx3=100
integer, parameter :: lx1i=256, lx2i=256, lx3i=256
real, parameter :: stride=0.5

real(wp), allocatable, dimension(:) :: x1, x2, x3, x1i, x2i, x3i
real(wp), allocatable, dimension(:,:,:) :: f, fi

real(wp), allocatable, dimension(:) :: x1ilist,x2ilist,x3ilist,filist

integer :: ix1,ix2,ix3,ik, ierr

allocate(x1(lx1), x2(lx2), x3(lx3), f(lx1,lx2,lx3))
allocate(x1i(lx1i),x2i(lx2i),x3i(lx3i),fi(lx1i,lx2i,lx3i))

allocate(x1ilist(1:lx1i*lx2i*lx3i))
allocate(x2ilist,x3ilist,filist, mold=x1ilist)

!grid for original data
x1=[ ((real(ix1,wp)-1._wp)*stride, ix1=1,lx1) ]
x2=[ ((real(ix2,wp)-1._wp)*stride, ix2=1,lx2) ]
x3=[ ((real(ix3,wp)-1._wp)*stride, ix3=1,lx3) ]

!center grid points at zero
x1=x1-sum(x1)/size(x1,1)
x2=x2-sum(x2)/size(x2,1)
x3=x3-sum(x3)/size(x3,1)

!test function
do ix3=1,lx3
  do ix2=1,lx2
    do ix1=1,lx1
      f(ix1,ix2,ix3)=sin(2._wp*pi/5._wp*x1(ix1))*cos(2._wp*pi/20._wp*x2(ix2))*sin(2._wp*pi/15._wp*x3(ix3))
    end do
  end do
end do

!> grid for interpolated data
x1i=[ ((real(ix1)-1) * stride/(lx1i/real(lx1)), ix1=1,lx1i) ]
x2i=[ ((real(ix2)-1) * stride/(lx2i/real(lx2)), ix2=1,lx2i) ]
x3i=[ ((real(ix3)-1) * stride/(lx3i/real(lx3)), ix3=1,lx3i) ]

!> center grid points at zero
x1i=x1i-sum(x1i)/size(x1i,1)
x2i=x2i-sum(x2i)/size(x2i,1)
x3i=x3i-sum(x3i)/size(x3i,1)

!> try a 333d interpolation
do ix3=1,lx3i
  do ix2=1,lx2i
    do ix1=1,lx1i
      ik=(ix3-1)*lx1i*lx2i+(ix2-1)*lx1i+ix1
      x1ilist(ik)=x1i(ix1)
      x2ilist(ik)=x2i(ix2)
      x3ilist(ik)=x3i(ix3)
    end do
  end do
end do
filist=interp3(x1,x2,x3,f,x1ilist,x2ilist,x3ilist)
fi=reshape(filist,[lx1i,lx2i,lx3i])

!> sanity check

if (any([256, 256, 256] /= [lx1i,lx2i,lx3i])) error stop "test_interp3d: not expected shape"

call get_command_argument(1, argv)
if(argv=="") error stop 'please specify input filename'

print "(A,/,A,/,A)", "interp3d: Finished test interpolation"
!> dump results to a file so we can check things
call hout%open(trim(argv), action="w")

call hout%write("/lx1", lx1, ierr)
call hout%write("/lx2", lx2, ierr)
call hout%write("/lx3", lx3, ierr)
call hout%write("/x1", x1, ierr)
call hout%write("/x2", x2, ierr)
call hout%write("/x3", x3, ierr)
call hout%write("/f", f, ierr)

call hout%close()

call get_command_argument(2, argv)
if(argv=="") error stop 'please specify output filename'

call hout%open(trim(argv), action="w")

call hout%write("/lx1", lx1i, ierr)
call hout%write("/lx2", lx2i, ierr)
call hout%write("/lx3", lx3i, ierr)
call hout%write("/x1", x1i, ierr)
call hout%write("/x2", x2i, ierr)
call hout%write("/x3", x3i, ierr)
call hout%write("/f", fi, ierr)

call hout%close()

end program

!> has no problem with > 2GB output files
! block
!   integer :: u
!   open(newunit=u,file='input3D.dat',status='replace',form='unformatted',access='stream', action='write')
!   write(u) lx1,lx2,lx3
!   write(u) x1,x2,x3,f
!   close(u)
! end block

! block
!   integer :: u
!   open(newunit=u,file='output3D.dat',status='replace',form='unformatted',access='stream', action='write')
!   write(u) lx1i,lx2i,lx3i
!   write(u) x1i,x2i,x3i,fi   !< since only interpolating in x1
!   close(u)
! end block


      subroutine shindx(n,arr,iarr,iopt)
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
! Shindx sorts an index array IARR of an ARR of length N to indicate
! either ascending or descending numerical order
! by the Shell - Mezgar algorithm . (Numerical Recipes p 229)
!
! Inputs:
!   arr  - The array to be indexed
!   n    - length of sort
!   iopt - >0 sort into ascending order
!          <0 "      "  descending order
!
! Outputs:
!   iarr - The index array
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
      real     arr(n)
      integer iarr(n)
!
      parameter ( ALN2I = 1./0.69314718, TINY = 1.E-5)
!
      lognb2 = INT( ALOG( FLOAT(n) ) * ALN2I + TINY)
!
      do i = 1,n
   1     iarr(i) = i
      enddo
!
      if (iopt.lt.0) GO TO 100
      m = n
      do 12 nn = 1, lognb2
        m = m/2
        k = n - m
        do 11 j = 1, k
          i = j
   3      CONTINUE
          l = i + m
          if ( arr( iarr(l) ).lt.arr( iarr(i) ) ) THEN
                 it = iarr(i)
            iarr(i) = iarr(l)
            iarr(l) = it
            i = i - m
            if (i.ge.1) GO TO 3
          endif
   11   continue
   12 continue
      RETURN
!
  100 CONTINUE
      m = n
      do 112 nn = 1, lognb2
        m = m/2
        k = n - m
        do 111 j = 1, k
          i = j
 103      CONTINUE
          l = i + m
          if ( arr( iarr(l) ).gt.arr( iarr(i) ) ) then
                 it = iarr(i)
            iarr(i) = iarr(l)
            iarr(l) = it
            i = i - m
            if (i.ge.1) GO TO 103
          endif
  111   continue
  112 continue
      RETURN
      end


c=======================================================================
c
c     subroutine RETLACK
c
c     Arithmetic returns form prices matrix
c
c       r(t+h) = [ price(t+h) - price(t)]/price(t+h) for t = 1,...,n-h
c
c     Take into account of missing data (lack of data),
c     with historical data structure
c
c     X(n,p) = | x(1,1), ..., x(1,p) |
c              | x(2,1), ..., -1000  |
c              | x(3,1), ..., x(3,p) |
c              |   .   , ...,   .    |
c              |   .   , ...,   .    |
c              | x(n,1), ..., x(n,p) |
c
c     where x(2,p) = -1000 denote a missing return
c
c----------------------------------------------------------------------
      SUBROUTINE retlack ( n, p, X, h, R, info )
c----------------------------------------------------------------------
c
c     INPUT :
c            n     : number of prices (n > h)                   integer
c            p     : number of asset(s) (p >= 1)                integer
c            X     : assets value (>0) (n*p)                     double
c            h     : horizon (h > 0)                            integer
c
c     OUTPUT :
c            R     : aritmetic returns ( n-h * p)                double
c            info  : diagnostic argument                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p, h, info
      DOUBLE PRECISION X(n,*), R(n-h,*)
c
c     local variables
      INTEGER i, j
      DOUBLE PRECISION missing, price, eps
      PARAMETER ( eps = 1.E-30 )
c
c-----------------------------------------------------------------------
c
c     initialization
      info  = 0
      missing = -1000
c
c     test if the number of values > h
      IF (n .LE. h) THEN
        info = -2
        RETURN
      ENDIF
c
c     artithmetic return(s)
      DO j = 1,p
        DO i = 1,n - h
           price = X(i, j)
           IF ((price .LT. eps) .AND. (price .GT. missing)) THEN
              info = -103
              RETURN
           ENDIF
           IF ((X(i + h,j) .GT. missing).AND.(price .GT. missing))
     &     THEN
            R(i, j) = ( X(i + h, j) - price )/price
           ELSE
            R(i, j) = -1000
           ENDIF
         ENDDO
      ENDDO
c
      RETURN
      END


      SUBROUTINE CALCI0(ARG,RESULT,JINT)
C--------------------------------------------------------------------
C
C This packet computes modified Bessel functions of the first kind
C   and order zero, I0(X) and EXP(-ABS(X))*I0(X), for real
C   arguments X.  It contains two function type subprograms, BESI0
C   and BESEI0, and one subroutine type subprogram, CALCI0.
C   The calling statements for the primary entries are
C
C                   Y=BESI0(X)
C   and
C                   Y=BESEI0(X)
C
C   where the entry points correspond to the functions I0(X) and
C   EXP(-ABS(X))*I0(X), respectively.  The routine CALCI0 is
C   intended for internal packet use only, all computations within
C   the packet being concentrated in this routine.  The function
C   subprograms invoke CALCI0 with the statement
C          CALL CALCI0(ARG,RESULT,JINT)
C   where the parameter usage is as follows
C
C      Function                     Parameters for CALCI0
C       Call              ARG                  RESULT          JINT
C
C     BESI0(ARG)    ABS(ARG) .LE. XMAX        I0(ARG)           1
C     BESEI0(ARG)    any real ARG        EXP(-ABS(ARG))*I0(ARG) 2
C
C   The main computation evaluates slightly modified forms of
C   minimax approximations generated by Blair and Edwards, Chalk
C   River (Atomic Energy of Canada Limited) Report AECL-4928,
C   October, 1974.  This transportable program is patterned after
C   the machine-dependent FUNPACK packet NATSI0, but cannot match
C   that version for efficiency or accuracy.  This version uses
C   rational functions that theoretically approximate I-SUB-0(X)
C   to at least 18 significant decimal digits.  The accuracy
C   achieved depends on the arithmetic system, the compiler, the
C   intrinsic functions, and proper selection of the machine-
C   dependent constants.
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants.  Let
C
C   beta   = Radix for the floating-point system
C   maxexp = Smallest power of beta that overflows
C
C Then the following machine-dependent constants must be declared
C   in DATA statements.  IEEE values are provided as a default.
C
C   XSMALL = Positive argument such that 1.0 - X = 1.0 to
C            machine precision for all ABS(X) .LE. XSMALL.
C   XINF =   Largest positive machine number; approximately
C            beta**maxexp
C   XMAX =   Largest argument acceptable to BESI0;  Solution to
C            equation:
C               W(X) * (1+1/(8*X)+9/(128*X**2) = beta**maxexp
C            where  W(X) = EXP(X)/SQRT(2*PI*X)
C
C
C     Approximate values for some important machines are:
C
C                          beta       maxexp       XSMALL
C
C CRAY-1        (S.P.)       2         8191       3.55E-15
C Cyber 180/855
C   under NOS   (S.P.)       2         1070       3.55E-15
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)       2          128       2.98E-8
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)       2         1024       5.55D-17
C IBM 3033      (D.P.)      16           63       6.95D-18
C VAX           (S.P.)       2          127       2.98E-8
C VAX D-Format  (D.P.)       2          127       6.95D-18
C VAX G-Format  (D.P.)       2         1023       5.55D-17
C
C
C                               XINF          XMAX
C
C CRAY-1        (S.P.)       5.45E+2465     5682.810
C Cyber 180/855
C   under NOS   (S.P.)       1.26E+322       745.893
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)       3.40E+38         91.900
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)       1.79D+308       713.986
C IBM 3033      (D.P.)       7.23D+75        178.182
C VAX           (S.P.)       1.70D+38         91.203
C VAX D-Format  (D.P.)       1.70D+38         91.203
C VAX G-Format  (D.P.)       8.98D+307       713.293
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  The program returns XINF for BESI0 for ABS(ARG) .GT. XMAX.
C
C
C  Intrinsic functions required are:
C
C     ABS, SQRT, EXP
C
C
C  Authors: W. J. Cody and L. Stoltz
C           Mathematics and Computer Science Division
C           Argonne National Laboratory
C           Argonne, IL 60439
C
C  Latest modification: March 12, 1992
C
C--------------------------------------------------------------------
      INTEGER I,JINT
CS    REAL
      DOUBLE PRECISION
     1       A,ARG,B,EXP40,FORTY,ONE,ONE5,P,PP,Q,QQ,RESULT,
     2       REC15,SUMP,SUMQ,TWO25,X,XINF,XMAX,XSMALL,XX
      DIMENSION P(15),PP(8),Q(5),QQ(7)
C--------------------------------------------------------------------
C  Mathematical constants
C--------------------------------------------------------------------
CS    DATA ONE/1.0E0/,ONE5/15.0E0/,EXP40/2.353852668370199854E17/,
CS   1     FORTY/40.0E0/,REC15/6.6666666666666666666E-2/,
CS   2     TWO25/225.0E0/
      DATA ONE/1.0D0/,ONE5/15.0D0/,EXP40/2.353852668370199854D17/,
     1     FORTY/40.0D0/,REC15/6.6666666666666666666D-2/,
     2     TWO25/225.0D0/
C--------------------------------------------------------------------
C  Machine-dependent constants
C--------------------------------------------------------------------
CS    DATA XSMALL/2.98E-8/,XINF/3.40E38/,XMAX/91.9E0/
      DATA XSMALL/5.55D-17/,XINF/1.79D308/,XMAX/713.986D0/
C--------------------------------------------------------------------
C  Coefficients for XSMALL .LE. ABS(ARG) .LT. 15.0
C--------------------------------------------------------------------
CS    DATA  P/-5.2487866627945699800E-18,-1.5982226675653184646E-14,
CS   1        -2.6843448573468483278E-11,-3.0517226450451067446E-08,
CS   2        -2.5172644670688975051E-05,-1.5453977791786851041E-02,
CS   3        -7.0935347449210549190E+00,-2.4125195876041896775E+03,
CS   4        -5.9545626019847898221E+05,-1.0313066708737980747E+08,
CS   5        -1.1912746104985237192E+10,-8.4925101247114157499E+11,
CS   6        -3.2940087627407749166E+13,-5.5050369673018427753E+14,
CS   7        -2.2335582639474375249E+15/
CS    DATA  Q/-3.7277560179962773046E+03, 6.5158506418655165707E+06,
CS   1        -6.5626560740833869295E+09, 3.7604188704092954661E+12,
CS   2        -9.7087946179594019126E+14/
      DATA  P/-5.2487866627945699800D-18,-1.5982226675653184646D-14,
     1        -2.6843448573468483278D-11,-3.0517226450451067446D-08,
     2        -2.5172644670688975051D-05,-1.5453977791786851041D-02,
     3        -7.0935347449210549190D+00,-2.4125195876041896775D+03,
     4        -5.9545626019847898221D+05,-1.0313066708737980747D+08,
     5        -1.1912746104985237192D+10,-8.4925101247114157499D+11,
     6        -3.2940087627407749166D+13,-5.5050369673018427753D+14,
     7        -2.2335582639474375249D+15/
      DATA  Q/-3.7277560179962773046D+03, 6.5158506418655165707D+06,
     1        -6.5626560740833869295D+09, 3.7604188704092954661D+12,
     2        -9.7087946179594019126D+14/
C--------------------------------------------------------------------
C  Coefficients for 15.0 .LE. ABS(ARG)
C--------------------------------------------------------------------
CS    DATA PP/-3.9843750000000000000E-01, 2.9205384596336793945E+00,
CS   1        -2.4708469169133954315E+00, 4.7914889422856814203E-01,
CS   2        -3.7384991926068969150E-03,-2.6801520353328635310E-03,
CS   3         9.9168777670983678974E-05,-2.1877128189032726730E-06/
CS    DATA QQ/-3.1446690275135491500E+01, 8.5539563258012929600E+01,
CS   1        -6.0228002066743340583E+01, 1.3982595353892851542E+01,
CS   2        -1.1151759188741312645E+00, 3.2547697594819615062E-02,
CS   3        -5.5194330231005480228E-04/
      DATA PP/-3.9843750000000000000D-01, 2.9205384596336793945D+00,
     1        -2.4708469169133954315D+00, 4.7914889422856814203D-01,
     2        -3.7384991926068969150D-03,-2.6801520353328635310D-03,
     3         9.9168777670983678974D-05,-2.1877128189032726730D-06/
      DATA QQ/-3.1446690275135491500D+01, 8.5539563258012929600D+01,
     1        -6.0228002066743340583D+01, 1.3982595353892851542D+01,
     2        -1.1151759188741312645D+00, 3.2547697594819615062D-02,
     3        -5.5194330231005480228D-04/
C--------------------------------------------------------------------
      X = ABS(ARG)
      IF (X .LT. XSMALL) THEN
            RESULT = ONE
         ELSE IF (X .LT. ONE5) THEN
C--------------------------------------------------------------------
C  XSMALL .LE.  ABS(ARG)  .LT. 15.0
C--------------------------------------------------------------------
            XX = X * X
            SUMP = P(1)
            DO 50 I = 2, 15
              SUMP = SUMP * XX + P(I)
   50       CONTINUE
            XX = XX - TWO25
            SUMQ = ((((XX+Q(1))*XX+Q(2))*XX+Q(3))*XX+Q(4))*XX+Q(5)
            RESULT = SUMP / SUMQ
            IF (JINT .EQ. 2) RESULT = RESULT * EXP(-X)
         ELSE IF (X .GE. ONE5) THEN
            IF ((JINT .EQ. 1) .AND. (X .GT. XMAX)) THEN
                  RESULT = XINF
               ELSE
C--------------------------------------------------------------------
C  15.0  .LE.  ABS(ARG)
C--------------------------------------------------------------------
                  XX = ONE / X - REC15
                  SUMP = ((((((PP(1)*XX+PP(2))*XX+PP(3))*XX+PP(4))*XX+
     1                   PP(5))*XX+PP(6))*XX+PP(7))*XX+PP(8)
                  SUMQ = ((((((XX+QQ(1))*XX+QQ(2))*XX+QQ(3))*XX+
     1                   QQ(4))*XX+QQ(5))*XX+QQ(6))*XX+QQ(7)
                  RESULT = SUMP / SUMQ
                  IF (JINT .EQ. 2) THEN
                        RESULT = (RESULT - PP(1)) / SQRT(X)
                     ELSE
C--------------------------------------------------------------------
C  Calculation reformulated to avoid premature overflow
C--------------------------------------------------------------------
                        IF (X .LE.(XMAX-ONE5)) THEN
                              A = EXP(X)
                              B = ONE
                           ELSE
                              A = EXP(X-FORTY)
                              B = EXP40
                        END IF
                        RESULT = ((RESULT*A-PP(1)*A)/SQRT(X))*B
                  END IF
            END IF
      END IF
C--------------------------------------------------------------------
C  Return for ABS(ARG) .LT. XSMALL
C--------------------------------------------------------------------
      RETURN
C----------- Last line of CALCI0 -----------
      END


      DOUBLE PRECISION FUNCTION DBESJ0 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DBESJ0 Krogh  Added external statement.
C>> 1995-11-10 DBESJ0 Krogh  Changed data statment for C converstion.
C>> 1995-11-03 DBESJ0 Krogh  Removed blanks in numbers for C conversion.
C>> 1994-11-11 DBESJ0 Krogh   Declared all vars.
C>> 1994-10-20 DBESJ0 Krogh  Changes to use M77CON
C>> 1990-11-29 DBESJ0 CLL
C>> 1985-08-02 DBESJ0 Lawson  Initial code.
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C C.L.LAWSON & S.CHAN, JPL, 1984 FEB ADAPTED TO JPL MATH77 LIBRARY.
c     ------------------------------------------------------------------
c--D replaces "?": ?BESJ0, ?BMP0, ?INITS, ?CSEVL
c     ------------------------------------------------------------------
      EXTERNAL D1MACH, DCSEVL
      INTEGER NTJ0
      DOUBLE PRECISION X, BJ0CS(19), AMPL, THETA, XSML, Y,
     1  D1MACH, DCSEVL
C
C SERIES FOR BJ0        ON THE INTERVAL  0.          TO  1.60000D+01
C                                        WITH WEIGHTED ERROR   4.39D-32
C                                         LOG WEIGHTED ERROR  31.36
C                               SIGNIFICANT FIGURES REQUIRED  31.21
C                                    DECIMAL PLACES REQUIRED  32.00
C
      SAVE NTJ0, XSML
C
      DATA BJ0CS / +.10025416196893913701073127264074D+0,
     *  -.66522300776440513177678757831124D+0,
     *  +.24898370349828131370460468726680D+0,
     *  -.33252723170035769653884341503854D-1,
     *  +.23114179304694015462904924117729D-2,
     *  -.99112774199508092339048519336549D-4,
     *  +.28916708643998808884733903747078D-5,
     *  -.61210858663032635057818407481516D-7,
     *  +.98386507938567841324768748636415D-9,
     *  -.12423551597301765145515897006836D-10,
     *  +.12654336302559045797915827210363D-12,
     *  -.10619456495287244546914817512959D-14,
     *  +.74706210758024567437098915584000D-17,
     *  -.44697032274412780547627007999999D-19,
     *  +.23024281584337436200523093333333D-21,
     *  -.10319144794166698148522666666666D-23,
     *  +.40608178274873322700800000000000D-26,
     *  -.14143836005240913919999999999999D-28,
     *  +.43910905496698880000000000000000D-31 /
C
      DATA NTJ0, XSML / 0, 0.D0 /
C     ------------------------------------------------------------------
      IF (NTJ0.NE.0) GO TO 10
      call DINITS (BJ0CS, 19, 0.1D0*D1MACH(3), NTJ0)
      XSML = SQRT (4.0D0*D1MACH(3))
C
 10   Y = ABS(X)
C
      IF (Y .LE. XSML) THEN
        DBESJ0 = 1.D0
      ELSE IF (Y .LE. 4.D0) THEN
        DBESJ0 = DCSEVL (.125D0*Y*Y-1.D0, BJ0CS, NTJ0)
      ELSE
        CALL DBMP0 (Y, AMPL, THETA)
        DBESJ0 = AMPL * COS(THETA)
      END IF
C
      RETURN
      END


C*16-NOV-90 14:24:57 MDS$SOURCE:[KKLARE]ZMUL.FOR;5
      Subroutine zadd(m,n,a,lda,b,ldb,c,ldc)
! matrix add C=A+B, C(M,N)=A(M,N)+B(M,N)
      Integer m,n,lda,ldb,ldc,i,j
      Complex*16 a(lda,1),b(ldb,1),c(ldc,1)
      If(m.le.0) Return
      Do 20 j=1,n
         Do 10 i=1,m
            c(i,j)=a(i,j)+b(i,j)
10       Continue
20    Continue
      Return
      End
      Subroutine zsub(m,n,a,lda,b,ldb,c,ldc)
! matrix subtract C=A-B, C(M,N)=A(M,N)-B(M,N)
      Integer m,n,lda,ldb,ldc,i,j
      Complex*16 a(lda,1),b(ldb,1),c(ldc,1)
      If(m.le.0) Return
      Do 20 j=1,n
         Do 10 i=1,m
            c(i,j)=a(i,j)-b(i,j)
10       Continue
20    Continue
      Return
      End
      Subroutine zmul(l,m,n,a,lda,b,ldb,c,ldc)
! matrix multiply C=A*B, C(L,N)=A(L,M)*B(M,N), C must not overlap A or B
ccif test
c      test2
ccendc test3
      external zdotu
      Integer l,m,n,lda,ldb,ldc,i,j
      Complex*16 a(lda,1),b(ldb,1),c(ldc,1),zdotu
      If(l.le.0) Return
      Do 20 j=1,n
         Do 10 i=1,l
            c(i,j)=zdotu(m,a(i,1),lda,b(1,j),1)
10       Continue
20    Continue
      Return
      End
      Subroutine zmtm(l,m,n,a,lda,b,ldb,c,ldc)
! matrix transpose multiply C=AT*B, C(M,N)=A(L,M)*B(L,N)
! C must not overlap A or B
      external zdotu
      Integer l,m,n,lda,ldb,ldc,i,j
      Complex*16 a(lda,1),b(ldb,1),c(ldc,1),zdotu
      If(m.le.0) Return
      Do 20 j=1,n
         Do 10 i=1,m
            c(i,j)=zdotu(l,a(1,i),1,b(1,j),1)
10       Continue
20    Continue
      Return
      End


subroutine zroots_sp(a,roots,polish)
  use mo_kind,   only : i4, spc, sp, lgt
  use mo_nrutil, only : assert_eq, poly_term
  use mo_nr,     only : laguer
  use mo_sort,   only : sort_index

  implicit none

  complex(spc), dimension(:), intent(in)  :: a
  complex(spc), dimension(:), intent(out) :: roots
  logical(lgt),               intent(in)  :: polish
  real(sp), parameter                     :: eps=1.0e-6_sp
  integer(i4)                             :: j,its,m
  integer(i4),  dimension(size(roots))    :: indx
  complex(spc)                            :: x
  complex(spc), dimension(size(a))        :: ad

  m=assert_eq(size(roots),size(a)-1,'zroots')
  ad(:)=a(:)
  do j=m,1,-1
     x=cmplx(0.0_sp,kind=spc)
     call laguer(ad(1:j+1),x,its)
     if (abs(aimag(x)) <= 2.0_sp*eps**2*abs(real(x))) &
          x=cmplx(real(x),kind=spc)
     roots(j)=x
     ad(j:1:-1)=poly_term(ad(j+1:2:-1),x)
  end do
  if (polish) then
     do j=1,m
        call laguer(a(:),roots(j),its)
     end do
  end if
  indx = sort_index(real(roots))
  !call indexx(real(roots),indx)
  roots=roots(indx)
end subroutine zroots_sp

subroutine zroots_dp(a,roots,polish)
  use mo_kind,   only : i4, dpc, dp, lgt
  use mo_nrutil, only : assert_eq, poly_term
  use mo_nr,     only : laguer
  use mo_sort,   only : sort_index

  implicit none

  complex(dpc), dimension(:), intent(in)  :: a
  complex(dpc), dimension(:), intent(out) :: roots
  logical(lgt),               intent(in)  :: polish
  real(dp), parameter                     :: eps=1.0e-6_dp
  integer(i4)                             :: j,its,m
  integer(i4),  dimension(size(roots))    :: indx
  complex(dpc)                            :: x
  complex(dpc), dimension(size(a))        :: ad

  m=assert_eq(size(roots),size(a)-1,'zroots')
  ad(:)=a(:)
  do j=m,1,-1
     x=cmplx(0.0_dp,kind=dpc)
     call laguer(ad(1:j+1),x,its)
     if (abs(aimag(x)) <= 2.0_dp*eps**2*abs(real(x))) &
          x=cmplx(real(x),kind=dpc)
     roots(j)=x
     ad(j:1:-1)=poly_term(ad(j+1:2:-1),x)
  end do
  if (polish) then
     do j=1,m
        call laguer(a(:),roots(j),its)
     end do
  end if
  indx = sort_index(real(roots))
  ! call indexx(real(roots),indx)
  roots=roots(indx)
end subroutine zroots_dp


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE makeHyper(partPos, fit, length, lb, ub, updateFlag, NF, N)
!------------------------------------------------------------------
!	makeHyper calculated the hyperCube location for the inputs
!
!	Input and output:
!			lb, ub			lower and upper bound on fit space
!	Input:
!			fit				input points
!			NF				# of fitness functions
!			N				divisions in fit space
!			length			# of individuals in fit
!	Output:
!			partPos			hyperLoc of points in fit
!			updateFlag		indicates if the bounds have changed or not
!
!	By: Yousef Naranjani-Apr 04 2016
!------------------------------------------------------------------
	IMPLICIT NONE
	LOGICAL, INTENT(INOUT)::updateFlag
	INTEGER, INTENT(IN)::NF
	INTEGER, INTENT(IN)::length, N(NF)
	INTEGER, INTENT(INOUT):: partPos(length)
	REAL, INTENT(IN)::fit(length*NF)
	REAL, INTENT(INOUT):: lb(NF), ub(NF)

	INTEGER:: i, j
	INTEGER:: z(NF), ztocell
	REAL::h(NF)
	updateFlag = .FALSE.
	DO i = 1, length
		DO j = 1, NF
			IF (fit((i-1)*NF+j) < lb(j)) THEN
				updateFlag = .TRUE. ! archive should be updated according to new bound
				lb(j) = fit((i-1)*NF+j)
			ELSE IF (fit((i-1)*NF+j) > ub(j)) THEN
				updateFlag = .TRUE.
				ub(j) = fit((i-1)*NF+j)
			END IF
		END DO
	END DO

	DO i = 1, NF
		 h(i) = (ub(i)-lb(i)) / N(i)
	END DO

!	Now the bounds are uptodate, we can find the hypercubes, parallelizable loop
	DO i = 1, length
		CALL xtoz(z, fit((i-1)*NF+1:i*NF), h, lb, ub, NF)
		IF (z(1) == -1) THEN
			ERROR STOP "makeHyper: the x coordinate was out of bound"
		ELSE
			partPos(i) = ztocell(z, N, NF)
		END IF
	END DO

END SUBROUTINE makeHyper
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE updateHyper(hyperSpace, partPosArchive, fitArchive, indArchive,&
						hyperLen, lbFit, ubFit,  NF, N)
!------------------------------------------------------------------
!	updateHyper updates the hyperCubes based on new ubFit and lbFit
!
!	Input:
!			fitArchive		archive fitnesses
!			NF				# of fitness functions
!			N				divisions in fit space
!			indArchive		last filled index of archive
!			hyperLen		length of hyperSpace
!			lbFit, ubFit	lower and upper bound on fit space
!	Output:
!			hyperSpace		hyperSpace array (counts of points in each cubic)
!			partPosArchive	each archive particle's hyperCube number
!
!	By: Yousef Naranjani-Apr 04 2016
!------------------------------------------------------------------
	IMPLICIT NONE
	INTEGER, INTENT(IN)::NF, hyperLen, indArchive
	INTEGER, INTENT(IN)::N(NF)
	INTEGER, INTENT(INOUT)::partPosArchive(indArchive) ! or maxArchive
	INTEGER*2, INTENT(INOUT)::hyperSpace(hyperLen)
	REAL, INTENT(IN)::fitArchive(indArchive*NF)
	REAL, INTENT(INOUT):: lbFit(NF), ubFit(NF)

	INTEGER:: i, j
	INTEGER:: z(NF), ztocell
	REAL::h(NF)
	DO i = 1, NF
		 h(i) = (ubFit(i)-lbFit(i)) / N(i)
	END DO

	hyperSpace = 0 ! might not be efficiet (check if it is time consuming)

	DO i = 1, indArchive
		CALL xtoz(z, fitArchive((i-1)*NF+1:i*NF), h, lbFit, ubFit, NF)
		IF (z(1) == -1) THEN
			ERROR STOP "makeHyper: the x coordinate was out of bound"
		ELSE
			partPosArchive(i) = ztocell(z, N, NF)
			hyperSpace(partPosArchive(i)) = hyperSpace(partPosArchive(i)) + 1
		END IF
	END DO

END SUBROUTINE updateHyper


!=====================================================
SUBROUTINE splreg(n,h,y,bi,ci,di)

! Makes a cubic spline of function y(x)
!
! Input:  n                   number of values in y
!         h                   step size in x (aequidistant)
!         y(n)                y-values
! Output: bi(n),ci(n),di(n)   Spline parameters

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                     INTENT(in)  :: n
  REAL(kind=dp),               INTENT(in)  :: h
  REAL(kind=dp), DIMENSION(n), INTENT(in)  :: y
  REAL(kind=dp), DIMENSION(n), INTENT(out) :: bi, ci, di

  REAL(kind=dp)                            :: ak1, ak2, am1, am2, c, e, c1
  REAL(kind=dp), DIMENSION(:), ALLOCATABLE :: al, bt
  INTEGER                                  :: k, n2, i, i5

  ALLOCATE ( al(n), bt(n) )

  ak1 = 0
  ak2 = 0
  am1 = 0
  am2 = 0
  k = n-1
  al(1) = ak1
  bt(1) = am1
  n2 = n-2
  c = -4*h
  DO i = 1,n2
     e = -3*((y(i+2)-y(i+1))-(y(i+1)-y(i)))/h
     c1 = c-al(i)*h
     al(i+1) = h/c1
     bt(i+1) = (h*bt(i)+e)/c1
  END DO
  ci(n) = (am2+ak2*bt(k))/(1-al(k)*ak2)
  DO i = 1,k
     i5 = n-i
     ci(i5) = al(i5)*ci(i5+1)+bt(i5)
  END DO
  n2 = n-1
  DO i = 1,n2
     bi(i) = (y(i+1)-y(i))/h-h*(ci(i+1)+2*ci(i))/3
     di(i) = (ci(i+1)-ci(i))/h/3
  END DO
  DEALLOCATE ( al, bt )

  RETURN
END SUBROUTINE splreg