MODULE Solve_NonLin

! Corrections to FUNCTION Enorm - 28 November 2003

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)
PRIVATE
PUBLIC  :: hbrd, hybrd

CONTAINS

SUBROUTINE hbrd(fcn, n, x, fvec, epsfcn, tol, info, diag)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-07-15  Time: 13:27:42

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: x(n)
REAL (dp), INTENT(IN OUT)  :: fvec(n)
REAL (dp), INTENT(IN)      :: epsfcn
REAL (dp), INTENT(IN)      :: tol
INTEGER, INTENT(OUT)       :: info
REAL (dp), INTENT(OUT)     :: diag(n)

! EXTERNAL fcn
INTERFACE
  SUBROUTINE FCN(N, X, FVEC, IFLAG)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)
    INTEGER, INTENT(IN)      :: n
    REAL (dp), INTENT(IN)    :: x(n)
    REAL (dp), INTENT(OUT)   :: fvec(n)
    INTEGER, INTENT(IN OUT)  :: iflag
  END SUBROUTINE FCN
END INTERFACE

!   **********

!   SUBROUTINE HBRD

!     THE PURPOSE OF HBRD IS TO FIND A ZERO OF A SYSTEM OF N NONLINEAR
!   FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE POWELL HYBRID METHOD.
!   THIS IS DONE BY USING THE MORE GENERAL NONLINEAR EQUATION SOLVER HYBRD.
!   THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS.
!   THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION.

!   THE SUBROUTINE STATEMENT IS

!     SUBROUTINE HBRD(N, X, FVEC, EPSFCN, TOL, INFO, WA, LWA)

!   WHERE

!     FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH CALCULATES
!       THE FUNCTIONS.  FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT
!       IN THE USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.

!       SUBROUTINE FCN(N, X, FVEC, IFLAG)
!       INTEGER N,IFLAG
!       REAL X(N),FVEC(N)
!       ----------
!       CALCULATE THE FUNCTIONS AT X AND RETURN THIS VECTOR IN FVEC.
!       ---------
!       RETURN
!       END

!       THE VALUE OF IFLAG NOT BE CHANGED BY FCN UNLESS
!       THE USER WANTS TO TERMINATE THE EXECUTION OF HBRD.
!       IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.

!     N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
!       OF FUNCTIONS AND VARIABLES.

!     X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN AN INITIAL
!       ESTIMATE OF THE SOLUTION VECTOR.  ON OUTPUT X CONTAINS THE
!       FINAL ESTIMATE OF THE SOLUTION VECTOR.

!     FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
!       THE FUNCTIONS EVALUATED AT THE OUTPUT X.

!     EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE STEP LENGTH
!       FOR THE FORWARD-DIFFERENCE APPROXIMATION.  THIS APPROXIMATION ASSUMES
!       THAT THE RELATIVE ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF EPSFCN.
!       IF EPSFCN IS LESS THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE
!       RELATIVE ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE
!       PRECISION.

!     TOL IS A NONNEGATIVE INPUT VARIABLE.  TERMINATION OCCURS WHEN THE
!       ALGORITHM ESTIMATES THAT THE RELATIVE ERROR BETWEEN X AND THE SOLUTION
!       IS AT MOST TOL.

!     INFO IS AN INTEGER OUTPUT VARIABLE.  IF THE USER HAS TERMINATED
!       EXECUTION, INFO IS SET TO THE (NEGATIVE) VALUE OF IFLAG.
!       SEE DESCRIPTION OF FCN.  OTHERWISE, INFO IS SET AS FOLLOWS.

!       INFO = 0   IMPROPER INPUT PARAMETERS.

!       INFO = 1   ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
!                  BETWEEN X AND THE SOLUTION IS AT MOST TOL.

!       INFO = 2   NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED 200*(N+1).

!       INFO = 3   TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
!                  THE APPROXIMATE SOLUTION X IS POSSIBLE.

!       INFO = 4   ITERATION IS NOT MAKING GOOD PROGRESS.

!   SUBPROGRAMS CALLED

!     USER-SUPPLIED ...... FCN

!     MINPACK-SUPPLIED ... HYBRD

!   ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!   BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE

! Reference:
! Powell, M.J.D. 'A hybrid method for nonlinear equations' in Numerical Methods
!      for Nonlinear Algebraic Equations', P.Rabinowitz (editor), Gordon and
!      Breach, London 1970.
!   **********
INTEGER    :: maxfev, ml, mode, mu, nfev, nprint
REAL (dp)  :: xtol
REAL (dp), PARAMETER  :: factor = 100.0_dp, zero = 0.0_dp

info = 0

!     CHECK THE INPUT PARAMETERS FOR ERRORS.

IF (n <= 0 .OR. epsfcn < zero .OR. tol < zero) GO TO 20

!     CALL HYBRD.

maxfev = 200*(n + 1)
xtol = tol
ml = n - 1
mu = n - 1
mode = 2
nprint = 0
CALL hybrd(fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mode,  &
           factor, nprint, info, nfev)
IF (info == 5) info = 4
20 RETURN

!     LAST CARD OF SUBROUTINE HBRD.

END SUBROUTINE hbrd

SUBROUTINE hybrd(fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mode,  &
                 factor, nprint, info, nfev)

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: x(n)
REAL (dp), INTENT(IN OUT)  :: fvec(n)
REAL (dp), INTENT(IN)      :: xtol
INTEGER, INTENT(IN OUT)    :: maxfev
INTEGER, INTENT(IN OUT)    :: ml
INTEGER, INTENT(IN)        :: mu
REAL (dp), INTENT(IN)      :: epsfcn
REAL (dp), INTENT(OUT)     :: diag(n)
INTEGER, INTENT(IN)        :: mode
REAL (dp), INTENT(IN)      :: factor
INTEGER, INTENT(IN OUT)    :: nprint
INTEGER, INTENT(OUT)       :: info
INTEGER, INTENT(OUT)       :: nfev

! EXTERNAL fcn
INTERFACE
  SUBROUTINE FCN(N, X, FVEC, IFLAG)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)
    INTEGER, INTENT(IN)      :: n
    REAL (dp), INTENT(IN)    :: x(n)
    REAL (dp), INTENT(OUT)   :: fvec(n)
    INTEGER, INTENT(IN OUT)  :: iflag
  END SUBROUTINE FCN
END INTERFACE

!   **********

!   SUBROUTINE HYBRD

!   THE PURPOSE OF HYBRD IS TO FIND A ZERO OF A SYSTEM OF N NONLINEAR
!   FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE POWELL HYBRID METHOD.
!   THE USER MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS.
!   THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION.

!   THE SUBROUTINE STATEMENT IS

!     SUBROUTINE HYBRD(FCN, N, X, FVEC, XTOL, MAXFEV, ML, MU, EPSFCN,
!                      DIAG, MODE, FACTOR, NPRINT, INFO, NFEV, FJAC,
!                      LDFJAC, R, LR, QTF, WA1, WA2, WA3, WA4)

!   WHERE

!     FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH CALCULATES
!       THE FUNCTIONS.  FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN
!       THE USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.

!       SUBROUTINE FCN(N, X, FVEC, IFLAG)
!       INTEGER N, IFLAG
!       REAL X(N), FVEC(N)
!       ----------
!       CALCULATE THE FUNCTIONS AT X AND
!       RETURN THIS VECTOR IN FVEC.
!       ---------
!       RETURN
!       END

!       THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
!       THE USER WANTS TO TERMINATE EXECUTION OF HYBRD.
!       IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.

!     N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
!       OF FUNCTIONS AND VARIABLES.

!     X IS AN ARRAY OF LENGTH N.  ON INPUT X MUST CONTAIN AN INITIAL
!       ESTIMATE OF THE SOLUTION VECTOR.  ON OUTPUT X CONTAINS THE FINAL
!       ESTIMATE OF THE SOLUTION VECTOR.

!     FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
!       THE FUNCTIONS EVALUATED AT THE OUTPUT X.

!     XTOL IS A NONNEGATIVE INPUT VARIABLE.  TERMINATION OCCURS WHEN THE
!       RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES IS AT MOST XTOL.

!     MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE.  TERMINATION OCCURS WHEN
!       THE NUMBER OF CALLS TO FCN IS AT LEAST MAXFEV BY THE END OF AN
!       ITERATION.

!     ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES THE
!       NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE JACOBIAN MATRIX.
!       IF THE JACOBIAN IS NOT BANDED, SET ML TO AT LEAST N - 1.

!     MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES THE NUMBER
!       OF SUPERDIAGONALS WITHIN THE BAND OF THE JACOBIAN MATRIX.
!       IF THE JACOBIAN IS NOT BANDED, SET MU TO AT LEAST N - 1.

!     EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE STEP LENGTH
!       FOR THE FORWARD-DIFFERENCE APPROXIMATION.  THIS APPROXIMATION
!       ASSUMES THAT THE RELATIVE ERRORS IN THE FUNCTIONS ARE OF THE ORDER
!       OF EPSFCN. IF EPSFCN IS LESS THAN THE MACHINE PRECISION,
!       IT IS ASSUMED THAT THE RELATIVE ERRORS IN THE FUNCTIONS ARE OF THE
!       ORDER OF THE MACHINE PRECISION.

!     DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE BELOW),
!       DIAG IS INTERNALLY SET.  IF MODE = 2, DIAG MUST CONTAIN POSITIVE
!       ENTRIES THAT SERVE AS MULTIPLICATIVE SCALE FACTORS FOR THE
!       VARIABLES.

!     MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE VARIABLES WILL BE
!       SCALED INTERNALLY.  IF MODE = 2, THE SCALING IS SPECIFIED BY THE
!       INPUT DIAG.  OTHER VALUES OF MODE ARE EQUIVALENT TO MODE = 1.

!     FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
!       INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
!       FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
!       TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
!       INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.

!     NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
!       PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
!       FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST
!       ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND
!       IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE
!       FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS
!       OF FCN WITH IFLAG = 0 ARE MADE.

!     INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
!       TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
!       VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
!       INFO IS SET AS FOLLOWS.

!       INFO = 0   IMPROPER INPUT PARAMETERS.

!       INFO = 1   RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
!                  IS AT MOST XTOL.

!       INFO = 2   NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED MAXFEV.

!       INFO = 3   XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
!                  THE APPROXIMATE SOLUTION X IS POSSIBLE.

!       INFO = 4   ITERATION IS NOT MAKING GOOD PROGRESS, AS
!                  MEASURED BY THE IMPROVEMENT FROM THE LAST
!                  FIVE JACOBIAN EVALUATIONS.

!       INFO = 5   ITERATION IS NOT MAKING GOOD PROGRESS, AS MEASURED BY
!                  THE IMPROVEMENT FROM THE LAST TEN ITERATIONS.

!     NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF CALLS TO FCN.

!     FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE ORTHOGONAL MATRIX Q
!       PRODUCED BY THE QR FACTORIZATION OF THE FINAL APPROXIMATE JACOBIAN.

!     LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
!       WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.

!     R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE
!       UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION
!       OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE.

!     LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN (N*(N+1))/2.

!     QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
!       THE VECTOR (Q TRANSPOSE)*FVEC.

!     WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N.

!   SUBPROGRAMS CALLED

!     USER-SUPPLIED ...... FCN

!     MINPACK-SUPPLIED ... DOGLEG,SPMPAR,ENORM,FDJAC1,
!                          QFORM,QRFAC,R1MPYQ,R1UPDT

!     FORTRAN-SUPPLIED ... ABS,MAX,MIN,MIN,MOD

!   ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!   BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE

!   **********

INTEGER    :: i, iflag, iter, j, jm1, l, lr, msum, ncfail, ncsuc, nslow1,  &
              nslow2
INTEGER    :: iwa(1)
LOGICAL    :: jeval, sing
REAL (dp)  :: actred, delta, epsmch, fnorm, fnorm1, pnorm, prered,   &
              ratio, sum, temp, xnorm
REAL (dp), PARAMETER  :: one = 1.0_dp, p1 = 0.1_dp, p5 = 0.5_dp,   &
                         p001 = 0.001_dp, p0001 = 0.0001_dp, zero = 0.0_dp

! The following were workspace arguments
REAL (dp)  :: fjac(n,n), r(n*(n+1)/2), qtf(n), wa1(n), wa2(n),   &
              wa3(n), wa4(n)

!     EPSMCH IS THE MACHINE PRECISION.

epsmch = EPSILON(1.0_dp)

info = 0
iflag = 0
nfev = 0
lr = n*(n+1)/2

!     CHECK THE INPUT PARAMETERS FOR ERRORS.

IF (n > 0 .AND. xtol >= zero .AND. maxfev > 0 .AND. ml >= 0 .AND. mu >=  &
    0 .AND. factor > zero ) THEN
IF (mode == 2) THEN
  diag(1:n) = one
END IF

!     EVALUATE THE FUNCTION AT THE STARTING POINT AND CALCULATE ITS NORM.

iflag = 1
CALL fcn(n, x, fvec, iflag)
nfev = 1
IF (iflag >= 0) THEN
  fnorm = enorm(n, fvec)

!   DETERMINE THE NUMBER OF CALLS TO FCN NEEDED TO COMPUTE THE JACOBIAN MATRIX.

  msum = MIN(ml+mu+1,n)

!     INITIALIZE ITERATION COUNTER AND MONITORS.

  iter = 1
  ncsuc = 0
  ncfail = 0
  nslow1 = 0
  nslow2 = 0

!     BEGINNING OF THE OUTER LOOP.

  20 jeval = .true.

!        CALCULATE THE JACOBIAN MATRIX.

  iflag = 2
  CALL fdjac1(fcn, n, x, fvec, fjac, n, iflag, ml, mu, epsfcn, wa1, wa2)
  nfev = nfev + msum
  IF (iflag >= 0) THEN

!        COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.

    CALL qrfac(n, n, fjac, n, .false., iwa, 1, wa1, wa2, wa3)

!        ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING
!        TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN.

    IF (iter == 1) THEN
      IF (mode /= 2) THEN
        DO  j = 1, n
          diag(j) = wa2(j)
          IF (wa2(j) == zero) diag(j) = one
        END DO
      END IF

!        ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X
!        AND INITIALIZE THE STEP BOUND DELTA.

      wa3(1:n) = diag(1:n) * x(1:n)
      xnorm = enorm(n, wa3)
      delta = factor * xnorm
      IF (delta == zero) delta = factor
    END IF

!        FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF.

    qtf(1:n) = fvec(1:n)
    DO  j = 1, n
      IF (fjac(j,j) /= zero) THEN
        sum = zero
        DO  i = j, n
          sum = sum + fjac(i,j) * qtf(i)
        END DO
        temp = -sum / fjac(j,j)
        DO  i = j, n
          qtf(i) = qtf(i) + fjac(i,j) * temp
        END DO
      END IF
    END DO

!        COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R.

    sing = .false.
    DO  j = 1, n
      l = j
      jm1 = j - 1
      IF (jm1 >= 1) THEN
        DO  i = 1, jm1
          r(l) = fjac(i,j)
          l = l + n - i
        END DO
      END IF
      r(l) = wa1(j)
      IF (wa1(j) == zero) sing = .true.
    END DO

!        ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC.

    CALL qform(n, n, fjac, n, wa1)

!        RESCALE IF NECESSARY.

    IF (mode /= 2) THEN
      DO  j = 1, n
        diag(j) = MAX(diag(j), wa2(j))
      END DO
    END IF

!        BEGINNING OF THE INNER LOOP.

!           IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.

    120 IF (nprint > 0) THEN
      iflag = 0
      IF (MOD(iter-1, nprint) == 0) CALL fcn(n, x, fvec, iflag)
      IF (iflag < 0) GO TO 190
    END IF

!           DETERMINE THE DIRECTION P.

    CALL dogleg(n, r, lr, diag, qtf, delta, wa1, wa2, wa3)

!           STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P.

    DO  j = 1, n
      wa1(j) = -wa1(j)
      wa2(j) = x(j) + wa1(j)
      wa3(j) = diag(j) * wa1(j)
    END DO
    pnorm = enorm(n, wa3)

!           ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND.

    IF (iter == 1) delta = MIN(delta, pnorm)

!           EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM.

    iflag = 1
    CALL fcn(n, wa2, wa4, iflag)
    nfev = nfev + 1
    IF (iflag >= 0) THEN
      fnorm1 = enorm(n, wa4)

!           COMPUTE THE SCALED ACTUAL REDUCTION.

      actred = -one
      IF (fnorm1 < fnorm) actred = one - (fnorm1/fnorm) ** 2

!           COMPUTE THE SCALED PREDICTED REDUCTION.

      l = 1
      DO  i = 1, n
        sum = zero
        DO  j = i, n
          sum = sum + r(l) * wa1(j)
          l = l + 1
        END DO
        wa3(i) = qtf(i) + sum
      END DO
      temp = enorm(n, wa3)
      prered = zero
      IF (temp < fnorm) prered = one - (temp/fnorm) ** 2

!           COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED REDUCTION.

      ratio = zero
      IF (prered > zero) ratio = actred / prered

!           UPDATE THE STEP BOUND.

      IF (ratio < p1) THEN
        ncsuc = 0
        ncfail = ncfail + 1
        delta = p5 * delta
      ELSE
        ncfail = 0
        ncsuc = ncsuc + 1
        IF (ratio >= p5 .OR. ncsuc > 1) delta = MAX(delta,pnorm/p5)
        IF (ABS(ratio-one) <= p1) delta = pnorm / p5
      END IF

!           TEST FOR SUCCESSFUL ITERATION.

      IF (ratio >= p0001) THEN

!           SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS.

        DO  j = 1, n
          x(j) = wa2(j)
          wa2(j) = diag(j) * x(j)
          fvec(j) = wa4(j)
        END DO
        xnorm = enorm(n, wa2)
        fnorm = fnorm1
        iter = iter + 1
      END IF

!           DETERMINE THE PROGRESS OF THE ITERATION.

      nslow1 = nslow1 + 1
      IF (actred >= p001) nslow1 = 0
      IF (jeval) nslow2 = nslow2 + 1
      IF (actred >= p1) nslow2 = 0

!           TEST FOR CONVERGENCE.

      IF (delta <= xtol*xnorm .OR. fnorm == zero) info = 1
      IF (info == 0) THEN

!           TESTS FOR TERMINATION AND STRINGENT TOLERANCES.

        IF (nfev >= maxfev) info = 2
        IF (p1*MAX(p1*delta, pnorm) <= epsmch*xnorm) info = 3
        IF (nslow2 == 5) info = 4
        IF (nslow1 == 10) info = 5
        IF (info == 0) THEN

!           CRITERION FOR RECALCULATING JACOBIAN APPROXIMATION
!           BY FORWARD DIFFERENCES.

          IF (ncfail /= 2) THEN

!           CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN
!           AND UPDATE QTF IF NECESSARY.

            DO  j = 1, n
              sum = zero
              DO  i = 1, n
                sum = sum + fjac(i,j) * wa4(i)
              END DO
              wa2(j) = (sum-wa3(j)) / pnorm
              wa1(j) = diag(j) * ((diag(j)*wa1(j))/pnorm)
              IF (ratio >= p0001) qtf(j) = sum
            END DO

!           COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN.

            CALL r1updt(n, n, r, lr, wa1, wa2, wa3, sing)
            CALL r1mpyq(n, n, fjac, n, wa2, wa3)
            CALL r1mpyq(1, n, qtf, 1, wa2, wa3)

!           END OF THE INNER LOOP.

            jeval = .false.
            GO TO 120
          END IF

!        END OF THE OUTER LOOP.

          GO TO 20
        END IF
      END IF
    END IF
  END IF
END IF
END IF

!     TERMINATION, EITHER NORMAL OR USER IMPOSED.

190 IF (iflag < 0) info = iflag
iflag = 0
IF (nprint > 0) CALL fcn(n, x, fvec, iflag)
RETURN

!     LAST CARD OF SUBROUTINE HYBRD.

END SUBROUTINE hybrd

SUBROUTINE dogleg(n, r, lr, diag, qtb, delta, x, wa1, wa2)

INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: lr
REAL (dp), INTENT(IN)      :: r(lr)
REAL (dp), INTENT(IN)      :: diag(n)
REAL (dp), INTENT(IN)      :: qtb(n)
REAL (dp), INTENT(IN)      :: delta
REAL (dp), INTENT(IN OUT)  :: x(n)
REAL (dp), INTENT(OUT)     :: wa1(n)
REAL (dp), INTENT(OUT)     :: wa2(n)

!     **********

!     SUBROUTINE DOGLEG

!     GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL
!     MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, THE
!     PROBLEM IS TO DETERMINE THE CONVEX COMBINATION X OF THE
!     GAUSS-NEWTON AND SCALED GRADIENT DIRECTIONS THAT MINIMIZES
!     (A*X - B) IN THE LEAST SQUARES SENSE, SUBJECT TO THE
!     RESTRICTION THAT THE EUCLIDEAN NORM OF D*X BE AT MOST DELTA.

!     THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM
!     IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
!     QR FACTORIZATION OF A. THAT IS, IF A = Q*R, WHERE Q HAS
!     ORTHOGONAL COLUMNS AND R IS AN UPPER TRIANGULAR MATRIX,
!     THEN DOGLEG EXPECTS THE FULL UPPER TRIANGLE OF R AND
!     THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B.

!     THE SUBROUTINE STATEMENT IS

!       SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)

!     WHERE

!       N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.

!       R IS AN INPUT ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER
!         TRIANGULAR MATRIX R STORED BY ROWS.

!       LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
!         (N*(N+1))/2.

!       DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
!         DIAGONAL ELEMENTS OF THE MATRIX D.

!       QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
!         N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.

!       DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER
!         BOUND ON THE EUCLIDEAN NORM OF D*X.

!       X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED
!         CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION AND THE
!         SCALED GRADIENT DIRECTION.

!       WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N.

!     SUBPROGRAMS CALLED

!       MINPACK-SUPPLIED ... SPMPAR,ENORM

!       FORTRAN-SUPPLIED ... ABS,MAX,MIN,SQRT

!     ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!     BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE

!     **********
INTEGER    :: i, j, jj, jp1, k, l
REAL (dp)  :: alpha, bnorm, epsmch, gnorm, qnorm, sgnorm, sum, temp

!     EPSMCH IS THE MACHINE PRECISION.

epsmch = EPSILON(1.0_dp)

!     FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION.

jj = (n*(n+1)) / 2 + 1
DO  k = 1, n
  j = n - k + 1
  jp1 = j + 1
  jj = jj - k
  l = jj + 1
  sum = 0.0
  IF (n >= jp1) THEN
    DO  i = jp1, n
      sum = sum + r(l) * x(i)
      l = l + 1
    END DO
  END IF
  temp = r(jj)
  IF (temp == 0.0) THEN
    l = j
    DO  i = 1, j
      temp = MAX(temp,ABS(r(l)))
      l = l + n - i
    END DO
    temp = epsmch * temp
    IF (temp == 0.0) temp = epsmch
  END IF
  x(j) = (qtb(j)-sum) / temp
END DO

!     TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE.

DO  j = 1, n
  wa1(j) = 0.0
  wa2(j) = diag(j) * x(j)
END DO
qnorm = enorm(n, wa2)
IF (qnorm > delta) THEN

!     THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE.
!     NEXT, CALCULATE THE SCALED GRADIENT DIRECTION.

  l = 1
  DO  j = 1, n
    temp = qtb(j)
    DO  i = j, n
      wa1(i) = wa1(i) + r(l) * temp
      l = l + 1
    END DO
    wa1(j) = wa1(j) / diag(j)
  END DO

!     CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR
!     THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO.

  gnorm = enorm(n, wa1)
  sgnorm = 0.0
  alpha = delta / qnorm
  IF (gnorm /= 0.0) THEN

!     CALCULATE THE POINT ALONG THE SCALED GRADIENT
!     AT WHICH THE QUADRATIC IS MINIMIZED.

    DO  j = 1, n
      wa1(j) = (wa1(j)/gnorm) / diag(j)
    END DO
    l = 1
    DO  j = 1, n
      sum = 0.0
      DO  i = j, n
        sum = sum + r(l) * wa1(i)
        l = l + 1
      END DO
      wa2(j) = sum
    END DO
    temp = enorm(n, wa2)
    sgnorm = (gnorm/temp) / temp

!     TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE.

    alpha = 0.0
    IF (sgnorm < delta) THEN

!     THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE.
!     FINALLY, CALCULATE THE POINT ALONG THE DOGLEG
!     AT WHICH THE QUADRATIC IS MINIMIZED.

      bnorm = enorm(n, qtb)
      temp = (bnorm/gnorm) * (bnorm/qnorm) * (sgnorm/delta)
      temp = temp - (delta/qnorm) * (sgnorm/delta) ** 2 + SQRT((  &
          temp-(delta/qnorm))**2+(1.0-(delta/qnorm)**2)*(1.0-( sgnorm/delta)**2))
      alpha = ((delta/qnorm)*(1.0-(sgnorm/delta)**2)) / temp
    END IF
  END IF

!     FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON
!     DIRECTION AND THE SCALED GRADIENT DIRECTION.

  temp = (1.0-alpha) * MIN(sgnorm,delta)
  DO  j = 1, n
    x(j) = temp * wa1(j) + alpha * x(j)
  END DO
END IF
RETURN
END SUBROUTINE dogleg

SUBROUTINE fdjac1(fcn, n, x, fvec, fjac, ldfjac, iflag, ml, mu, epsfcn,   &
                  wa1, wa2)

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN OUT)  :: x(n)
REAL (dp), INTENT(IN)      :: fvec(n)
INTEGER, INTENT(IN)        :: ldfjac
REAL (dp), INTENT(OUT)     :: fjac(ldfjac,n)
INTEGER, INTENT(IN OUT)    :: iflag
INTEGER, INTENT(IN)        :: ml
INTEGER, INTENT(IN)        :: mu
REAL (dp), INTENT(IN)      :: epsfcn
REAL (dp), INTENT(IN OUT)  :: wa1(n)
REAL (dp), INTENT(OUT)     :: wa2(n)

! EXTERNAL fcn
INTERFACE
  SUBROUTINE FCN(N, X, FVEC, IFLAG)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(14, 60)
    INTEGER, INTENT(IN)      :: n
    REAL (dp), INTENT(IN)    :: x(n)
    REAL (dp), INTENT(OUT)   :: fvec(n)
    INTEGER, INTENT(IN OUT)  :: iflag
  END SUBROUTINE FCN
END INTERFACE

!   **********

!   SUBROUTINE FDJAC1

!   THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION TO THE N BY N
!   JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED PROBLEM OF N FUNCTIONS IN N
!   VARIABLES.  IF THE JACOBIAN HAS A BANDED FORM, THEN FUNCTION EVALUATIONS
!   ARE SAVED BY ONLY APPROXIMATING THE NONZERO TERMS.

!   THE SUBROUTINE STATEMENT IS

!     SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
!                       WA1,WA2)

!   WHERE

!     FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH CALCULATES
!       THE FUNCTIONS.  FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN
!       THE USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.

!       SUBROUTINE FCN(N,X,FVEC,IFLAG)
!       INTEGER N,IFLAG
!       REAL X(N),FVEC(N)
!       ----------
!       CALCULATE THE FUNCTIONS AT X AND
!       RETURN THIS VECTOR IN FVEC.
!       ----------
!       RETURN
!       END

!       THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
!       THE USER WANTS TO TERMINATE EXECUTION OF FDJAC1.
!       IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.

!     N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
!       OF FUNCTIONS AND VARIABLES.

!     X IS AN INPUT ARRAY OF LENGTH N.

!     FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
!       FUNCTIONS EVALUATED AT X.

!     FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE
!       APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X.

!     LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
!       WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.

!     IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE
!       THE EXECUTION OF FDJAC1.  SEE DESCRIPTION OF FCN.

!     ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
!       THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE
!       JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
!       ML TO AT LEAST N - 1.

!     EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE
!       STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS
!       APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE
!       FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS
!       THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE
!       ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE PRECISION.

!     MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
!       THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE
!       JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
!       MU TO AT LEAST N - 1.

!     WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N.  IF ML + MU + 1 IS AT
!       LEAST N, THEN THE JACOBIAN IS CONSIDERED DENSE, AND WA2 IS
!       NOT REFERENCED.

!   SUBPROGRAMS CALLED

!     MINPACK-SUPPLIED ... SPMPAR

!     FORTRAN-SUPPLIED ... ABS,MAX,SQRT

!   ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!   BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE

!   **********
INTEGER    :: i, j, k, msum
REAL (dp)  :: eps, epsmch, h, temp
REAL (dp), PARAMETER  :: zero = 0.0_dp

!     EPSMCH IS THE MACHINE PRECISION.

epsmch = EPSILON(1.0_dp)

eps = SQRT(MAX(epsfcn, epsmch))
msum = ml + mu + 1
IF (msum >= n) THEN

!        COMPUTATION OF DENSE APPROXIMATE JACOBIAN.

  DO  j = 1, n
    temp = x(j)
    h = eps * ABS(temp)
    IF (h == zero) h = eps
    x(j) = temp + h
    CALL fcn(n, x, wa1, iflag)
    IF (iflag < 0) EXIT
    x(j) = temp
    DO  i = 1, n
      fjac(i,j) = (wa1(i)-fvec(i)) / h
    END DO
  END DO
ELSE

!        COMPUTATION OF BANDED APPROXIMATE JACOBIAN.

  DO  k = 1, msum
    DO  j = k, n, msum
      wa2(j) = x(j)
      h = eps * ABS(wa2(j))
      IF (h == zero) h = eps
      x(j) = wa2(j) + h
    END DO
    CALL fcn(n, x, wa1, iflag)
    IF (iflag < 0) EXIT
    DO  j = k, n, msum
      x(j) = wa2(j)
      h = eps * ABS(wa2(j))
      IF (h == zero) h = eps
      DO  i = 1, n
        fjac(i,j) = zero
        IF (i >= j-mu .AND. i <= j+ml) fjac(i,j) = (wa1(i)-fvec(i)) / h
      END DO
    END DO
  END DO
END IF
RETURN

!     LAST CARD OF SUBROUTINE FDJAC1.

END SUBROUTINE fdjac1

SUBROUTINE qform(m, n, q, ldq, wa)

INTEGER, INTENT(IN)     :: m
INTEGER, INTENT(IN)     :: n
INTEGER, INTENT(IN)     :: ldq
REAL (dp), INTENT(OUT)  :: q(ldq,m)
REAL (dp), INTENT(OUT)  :: wa(m)

!   **********

!   SUBROUTINE QFORM

!   THIS SUBROUTINE PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF AN M BY N
!   MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX Q FROM ITS FACTORED FORM.

!   THE SUBROUTINE STATEMENT IS

!     SUBROUTINE QFORM(M,N,Q,LDQ,WA)

!   WHERE

!     M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
!       OF ROWS OF A AND THE ORDER OF Q.

!     N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER OF COLUMNS OF A.

!     Q IS AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN
!       THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM.
!       ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX.

!     LDQ IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
!       WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q.

!     WA IS A WORK ARRAY OF LENGTH M.

!   SUBPROGRAMS CALLED

!     FORTRAN-SUPPLIED ... MIN

!   ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!   BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE

!   **********
INTEGER    :: i, j, jm1, k, l, minmn, np1
REAL (dp)  :: sum, temp
REAL (dp), PARAMETER  :: one = 1.0_dp, zero = 0.0_dp

!     ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS.

minmn = MIN(m,n)
IF (minmn >= 2) THEN
  DO  j = 2, minmn
    jm1 = j - 1
    DO  i = 1, jm1
      q(i,j) = zero
    END DO
  END DO
END IF

!     INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX.

np1 = n + 1
IF (m >= np1) THEN
  DO  j = np1, m
    DO  i = 1, m
      q(i,j) = zero
    END DO
    q(j,j) = one
  END DO
END IF

!     ACCUMULATE Q FROM ITS FACTORED FORM.

DO  l = 1, minmn
  k = minmn - l + 1
  DO  i = k, m
    wa(i) = q(i,k)
    q(i,k) = zero
  END DO
  q(k,k) = one
  IF (wa(k) /= zero) THEN
    DO  j = k, m
      sum = zero
      DO  i = k, m
        sum = sum + q(i,j) * wa(i)
      END DO
      temp = sum / wa(k)
      DO  i = k, m
        q(i,j) = q(i,j) - temp * wa(i)
      END DO
    END DO
  END IF
END DO
RETURN

!     LAST CARD OF SUBROUTINE QFORM.

END SUBROUTINE qform

SUBROUTINE qrfac(m, n, a, lda, pivot, ipvt, lipvt, rdiag, acnorm, wa)

INTEGER, INTENT(IN)        :: m
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: lda
REAL (dp), INTENT(IN OUT)  :: a(lda,n)
LOGICAL, INTENT(IN)        :: pivot
INTEGER, INTENT(IN)        :: lipvt
INTEGER, INTENT(OUT)       :: ipvt(lipvt)
REAL (dp), INTENT(OUT)     :: rdiag(n)
REAL (dp), INTENT(OUT)     :: acnorm(n)
REAL (dp), INTENT(OUT)     :: wa(n)

!   **********

!   SUBROUTINE QRFAC

!   THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN PIVOTING
!   (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE M BY N MATRIX A.
!   THAT IS, QRFAC DETERMINES AN ORTHOGONAL MATRIX Q, A PERMUTATION MATRIX P,
!   AND AN UPPER TRAPEZOIDAL MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING
!   MAGNITUDE, SUCH THAT A*P = Q*R.  THE HOUSEHOLDER TRANSFORMATION FOR
!   COLUMN K, K = 1,2,...,MIN(M,N), IS OF THE FORM

!                         T
!         I - (1/U(K))*U*U

!   WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS.  THE FORM OF THIS
!   TRANSFORMATION AND THE METHOD OF PIVOTING FIRST APPEARED IN THE
!   CORRESPONDING LINPACK SUBROUTINE.

!   THE SUBROUTINE STATEMENT IS

!     SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA)

!   WHERE

!     M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER OF ROWS OF A.

!     N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
!       OF COLUMNS OF A.

!     A IS AN M BY N ARRAY.  ON INPUT A CONTAINS THE MATRIX FOR WHICH THE
!       QR FACTORIZATION IS TO BE COMPUTED.  ON OUTPUT THE STRICT UPPER
!       TRAPEZOIDAL PART OF A CONTAINS THE STRICT UPPER TRAPEZOIDAL PART OF R,
!       AND THE LOWER TRAPEZOIDAL PART OF A CONTAINS A FACTORED FORM OF Q
!       (THE NON-TRIVIAL ELEMENTS OF THE U VECTORS DESCRIBED ABOVE).

!     LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
!       WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A.

!     PIVOT IS A LOGICAL INPUT VARIABLE.  IF PIVOT IS SET TRUE,
!       THEN COLUMN PIVOTING IS ENFORCED.  IF PIVOT IS SET FALSE,
!       THEN NO COLUMN PIVOTING IS DONE.

!     IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT.  IPVT DEFINES THE
!       PERMUTATION MATRIX P SUCH THAT A*P = Q*R.
!       COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
!       IF PIVOT IS FALSE, IPVT IS NOT REFERENCED.

!     LIPVT IS A POSITIVE INTEGER INPUT VARIABLE.  IF PIVOT IS FALSE,
!       THEN LIPVT MAY BE AS SMALL AS 1.  IF PIVOT IS TRUE, THEN
!       LIPVT MUST BE AT LEAST N.

!     RDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
!       DIAGONAL ELEMENTS OF R.

!     ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NORMS OF
!       THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A.
!       IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE WITH RDIAG.

!     WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA
!       CAN COINCIDE WITH RDIAG.

!   SUBPROGRAMS CALLED

!     MINPACK-SUPPLIED ... SPMPAR,ENORM

!     FORTRAN-SUPPLIED ... MAX,SQRT,MIN

!   ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!   BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE

!   **********
INTEGER    :: i, j, jp1, k, kmax, minmn
REAL (dp)  :: ajnorm, epsmch, sum, temp
REAL (dp), PARAMETER  :: one = 1.0_dp, p05 = 0.05_dp, zero = 0.0_dp

!     EPSMCH IS THE MACHINE PRECISION.

epsmch = EPSILON(1.0_dp)

!     COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS.

DO  j = 1, n
  acnorm(j) = enorm(m, a(1:,j))
  rdiag(j) = acnorm(j)
  wa(j) = rdiag(j)
  IF (pivot) ipvt(j) = j
END DO

!     REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS.

minmn = MIN(m,n)
DO  j = 1, minmn
  IF (pivot) THEN

!        BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION.

    kmax = j
    DO  k = j, n
      IF (rdiag(k) > rdiag(kmax)) kmax = k
    END DO
    IF (kmax /= j) THEN
      DO  i = 1, m
        temp = a(i,j)
        a(i,j) = a(i,kmax)
        a(i,kmax) = temp
      END DO
      rdiag(kmax) = rdiag(j)
      wa(kmax) = wa(j)
      k = ipvt(j)
      ipvt(j) = ipvt(kmax)
      ipvt(kmax) = k
    END IF
  END IF

!        COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE
!        J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR.

  ajnorm = enorm(m-j+1, a(j:,j))
  IF (ajnorm /= zero) THEN
    IF (a(j,j) < zero) ajnorm = -ajnorm
    DO  i = j, m
      a(i,j) = a(i,j) / ajnorm
    END DO
    a(j,j) = a(j,j) + one

!        APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS AND UPDATE THE NORMS.

    jp1 = j + 1
    IF (n >= jp1) THEN
      DO  k = jp1, n
        sum = zero
        DO  i = j, m
          sum = sum + a(i,j) * a(i,k)
        END DO
        temp = sum / a(j,j)
        DO  i = j, m
          a(i,k) = a(i,k) - temp * a(i,j)
        END DO
        IF (.NOT.(.NOT.pivot.OR.rdiag(k) == zero)) THEN
          temp = a(j,k) / rdiag(k)
          rdiag(k) = rdiag(k) * SQRT(MAX(zero,one-temp**2))
          IF (p05*(rdiag(k)/wa(k))**2 <= epsmch) THEN
            rdiag(k) = enorm(m-j, a(jp1:,k))
            wa(k) = rdiag(k)
          END IF
        END IF
      END DO
    END IF
  END IF
  rdiag(j) = -ajnorm
END DO
RETURN

!     LAST CARD OF SUBROUTINE QRFAC.

END SUBROUTINE qrfac

SUBROUTINE r1mpyq(m, n, a, lda, v, w)

INTEGER, INTENT(IN)        :: m
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: lda
REAL (dp), INTENT(IN OUT)  :: a(lda,n)
REAL (dp), INTENT(IN)      :: v(n)
REAL (dp), INTENT(IN)      :: w(n)

!   **********

!   SUBROUTINE R1MPYQ

!   GIVEN AN M BY N MATRIX A, THIS SUBROUTINE COMPUTES A*Q WHERE
!   Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS

!         GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)

!   AND GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH
!   ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY.
!   Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE
!   GV, GW ROTATIONS IS SUPPLIED.

!   THE SUBROUTINE STATEMENT IS

!     SUBROUTINE R1MPYQ(M, N, A, LDA, V, W)

!   WHERE

!     M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER OF ROWS OF A.

!     N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER OF COLUMNS OF A.

!     A IS AN M BY N ARRAY.  ON INPUT A MUST CONTAIN THE MATRIX TO BE
!       POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q DESCRIBED ABOVE.
!       ON OUTPUT A*Q HAS REPLACED A.

!     LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
!       WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A.

!     V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE INFORMATION
!       NECESSARY TO RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE.

!     W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE INFORMATION
!       NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED ABOVE.

!   SUBROUTINES CALLED

!     FORTRAN-SUPPLIED ... ABS, SQRT

!   ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!   BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE

!   **********
INTEGER    :: i, j, nmj, nm1
REAL (dp)  :: COS, SIN, temp
REAL (dp), PARAMETER  :: one = 1.0_dp

!     APPLY THE FIRST SET OF GIVENS ROTATIONS TO A.

nm1 = n - 1
IF (nm1 >= 1) THEN
  DO  nmj = 1, nm1
    j = n - nmj
    IF (ABS(v(j)) > one) COS = one / v(j)
    IF (ABS(v(j)) > one) SIN = SQRT(one-COS**2)
    IF (ABS(v(j)) <= one) SIN = v(j)
    IF (ABS(v(j)) <= one) COS = SQRT(one-SIN**2)
    DO  i = 1, m
      temp = COS * a(i,j) - SIN * a(i,n)
      a(i,n) = SIN * a(i,j) + COS * a(i,n)
      a(i,j) = temp
    END DO
  END DO

!     APPLY THE SECOND SET OF GIVENS ROTATIONS TO A.

  DO  j = 1, nm1
    IF (ABS(w(j)) > one) COS = one / w(j)
    IF (ABS(w(j)) > one) SIN = SQRT(one-COS**2)
    IF (ABS(w(j)) <= one) SIN = w(j)
    IF (ABS(w(j)) <= one) COS = SQRT(one-SIN**2)
    DO  i = 1, m
      temp = COS * a(i,j) + SIN * a(i,n)
      a(i,n) = -SIN * a(i,j) + COS * a(i,n)
      a(i,j) = temp
    END DO
  END DO
END IF
RETURN

!     LAST CARD OF SUBROUTINE R1MPYQ.

END SUBROUTINE r1mpyq

SUBROUTINE r1updt(m, n, s, ls, u, v, w, sing)

INTEGER, INTENT(IN)        :: m
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: ls
REAL (dp), INTENT(IN OUT)  :: s(ls)
REAL (dp), INTENT(IN)      :: u(m)
REAL (dp), INTENT(IN OUT)  :: v(n)
REAL (dp), INTENT(OUT)     :: w(m)
LOGICAL, INTENT(OUT)       :: sing

!   **********

!   SUBROUTINE R1UPDT

!   GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U,
!   AND AN N-VECTOR V, THE PROBLEM IS TO DETERMINE AN
!   ORTHOGONAL MATRIX Q SUCH THAT

!                 T
!         (S + U*V )*Q

!   IS AGAIN LOWER TRAPEZOIDAL.

!   THIS SUBROUTINE DETERMINES Q AS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS

!         GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)

!   WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE
!   WHICH ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY.
!   Q ITSELF IS NOT ACCUMULATED, RATHER THE INFORMATION TO RECOVER THE GV,
!   GW ROTATIONS IS RETURNED.

!   THE SUBROUTINE STATEMENT IS

!     SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING)

!   WHERE

!     M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER OF ROWS OF S.

!     N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
!       OF COLUMNS OF S.  N MUST NOT EXCEED M.

!     S IS AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER
!       TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS
!       THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE.

!     LS IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
!       (N*(2*M-N+1))/2.

!     U IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE VECTOR U.

!     V IS AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR V.
!       ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO
!       RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE.

!     W IS AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION
!       NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED ABOVE.

!     SING IS A LOGICAL OUTPUT VARIABLE.  SING IS SET TRUE IF ANY OF THE
!       DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO.  OTHERWISE SING IS
!       SET FALSE.

!   SUBPROGRAMS CALLED

!     MINPACK-SUPPLIED ... SPMPAR

!     FORTRAN-SUPPLIED ... ABS,SQRT

!   ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!   BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE, JOHN L. NAZARETH

!   **********
INTEGER    :: i, j, jj, l, nmj, nm1
REAL (dp)  :: COS, cotan, giant, SIN, TAN, tau, temp
REAL (dp), PARAMETER  :: one = 1.0_dp, p5 = 0.5_dp, p25 = 0.25_dp, zero = 0.0_dp

!     GIANT IS THE LARGEST MAGNITUDE.

giant = HUGE(1.0_dp)

!     INITIALIZE THE DIAGONAL ELEMENT POINTER.

jj = (n*(2*m-n+1)) / 2 - (m-n)

!     MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W.

l = jj
DO  i = n, m
  w(i) = s(l)
  l = l + 1
END DO

!     ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR
!     IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W.

nm1 = n - 1
IF (nm1 >= 1) THEN
  DO  nmj = 1, nm1
    j = n - nmj
    jj = jj - (m-j+1)
    w(j) = zero
    IF (v(j) /= zero) THEN

!        DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE J-TH ELEMENT OF V.

      IF (ABS(v(n)) < ABS(v(j))) THEN
        cotan = v(n) / v(j)
        SIN = p5 / SQRT(p25+p25*cotan**2)
        COS = SIN * cotan
        tau = one
        IF (ABS(COS)*giant > one) tau = one / COS
      ELSE
        TAN = v(j) / v(n)
        COS = p5 / SQRT(p25+p25*TAN**2)
        SIN = COS * TAN
        tau = SIN
      END IF

!        APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION
!        NECESSARY TO RECOVER THE GIVENS ROTATION.

      v(n) = SIN * v(j) + COS * v(n)
      v(j) = tau

!        APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W.

      l = jj
      DO  i = j, m
        temp = COS * s(l) - SIN * w(i)
        w(i) = SIN * s(l) + COS * w(i)
        s(l) = temp
        l = l + 1
      END DO
    END IF
  END DO
END IF

!     ADD THE SPIKE FROM THE RANK 1 UPDATE TO W.

DO  i = 1, m
  w(i) = w(i) + v(n) * u(i)
END DO

!     ELIMINATE THE SPIKE.

sing = .false.
IF (nm1 >= 1) THEN
  DO  j = 1, nm1
    IF (w(j) /= zero) THEN

!        DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE
!        J-TH ELEMENT OF THE SPIKE.

      IF (ABS(s(jj)) < ABS(w(j))) THEN
        cotan = s(jj) / w(j)
        SIN = p5 / SQRT(p25 + p25*cotan**2)
        COS = SIN * cotan
        tau = one
        IF (ABS(COS)*giant > one) tau = one / COS
      ELSE
        TAN = w(j) / s(jj)
        COS = p5 / SQRT(p25+p25*TAN**2)
        SIN = COS * TAN
        tau = SIN
      END IF

!        APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W.

      l = jj
      DO  i = j, m
        temp = COS * s(l) + SIN * w(i)
        w(i) = -SIN * s(l) + COS * w(i)
        s(l) = temp
        l = l + 1
      END DO

!        STORE THE INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION.

      w(j) = tau
    END IF

!        TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S.

    IF (s(jj) == zero) sing = .true.
    jj = jj + (m-j+1)
  END DO
END IF

!     MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S.

l = jj
DO  i = n, m
  s(l) = w(i)
  l = l + 1
END DO
IF (s(jj) == zero) sing = .true.
RETURN

!     LAST CARD OF SUBROUTINE R1UPDT.

END SUBROUTINE r1updt

FUNCTION enorm(n, x) RESULT(fn_val)

INTEGER, INTENT(IN)    :: n
REAL (dp), INTENT(IN)  :: x(n)
REAL (dp)              :: fn_val

!   **********

!   FUNCTION ENORM

!   GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE EUCLIDEAN NORM OF X.

!   THE EUCLIDEAN NORM IS COMPUTED BY ACCUMULATING THE SUM OF SQUARES IN THREE
!   DIFFERENT SUMS.  THE SUMS OF SQUARES FOR THE SMALL AND LARGE COMPONENTS
!   ARE SCALED SO THAT NO OVERFLOWS OCCUR.  NON-DESTRUCTIVE UNDERFLOWS ARE
!   PERMITTED.  UNDERFLOWS AND OVERFLOWS DO NOT OCCUR IN THE COMPUTATION OF THE UNSCALED
!   SUM OF SQUARES FOR THE INTERMEDIATE COMPONENTS.
!   THE DEFINITIONS OF SMALL, INTERMEDIATE AND LARGE COMPONENTS DEPEND ON
!   TWO CONSTANTS, RDWARF AND RGIANT.  THE MAIN RESTRICTIONS ON THESE CONSTANTS
!   ARE THAT RDWARF**2 NOT UNDERFLOW AND RGIANT**2 NOT OVERFLOW.
!   THE CONSTANTS GIVEN HERE ARE SUITABLE FOR EVERY KNOWN COMPUTER.

!   THE FUNCTION STATEMENT IS

!     REAL FUNCTION ENORM(N, X)

!   WHERE

!     N IS A POSITIVE INTEGER INPUT VARIABLE.

!     X IS AN INPUT ARRAY OF LENGTH N.

!   SUBPROGRAMS CALLED

!     FORTRAN-SUPPLIED ... ABS,SQRT

!   ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
!   BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE

!   **********
INTEGER    :: i
REAL (dp)  :: agiant, floatn, s1, s2, s3, xabs, x1max, x3max
REAL (dp), PARAMETER  :: rdwarf = 1.0D-100, rgiant = 1.0D+100

s1 = 0.0_dp
s2 = 0.0_dp
s3 = 0.0_dp
x1max = 0.0_dp
x3max = 0.0_dp
floatn = n
agiant = rgiant / floatn
DO  i = 1, n
  xabs = ABS(x(i))
  IF (xabs <= rdwarf .OR. xabs >= agiant) THEN
    IF (xabs > rdwarf) THEN

!              SUM FOR LARGE COMPONENTS.

      IF (xabs > x1max) THEN
        s1 = 1.0_dp + s1 * (x1max/xabs) ** 2
        x1max = xabs
      ELSE
        s1 = s1 + (xabs/x1max) ** 2
      END IF
    ELSE

!              SUM FOR SMALL COMPONENTS.

      IF (xabs > x3max) THEN
        s3 = 1.0_dp + s3 * (x3max/xabs) ** 2
        x3max = xabs
      ELSE
        IF (xabs /= 0.0_dp) s3 = s3 + (xabs/x3max) ** 2
      END IF
    END IF
  ELSE

!           SUM FOR INTERMEDIATE COMPONENTS.

    s2 = s2 + xabs ** 2
  END IF
END DO

!     CALCULATION OF NORM.

IF (s1 /= 0.0_dp) THEN
  fn_val = x1max * SQRT(s1 + (s2/x1max)/x1max)
ELSE
  IF (s2 /= 0.0_dp) THEN
    IF (s2 >= x3max) fn_val = SQRT(s2*(1.0_dp + (x3max/s2)*(x3max*s3)))
    IF (s2 < x3max) fn_val = SQRT(x3max*((s2/x3max) + (x3max*s3)))
  ELSE
    fn_val = x3max * SQRT(s3)
  END IF
END IF
RETURN
END FUNCTION enorm

END MODULE Solve_NonLin


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE PKK
      IMPLICIT NONE
C
C Purpose: Subtracts the background under a peak by polynomial fitting
C          to two ranges of points on either side of the peak.
C
      INCLUDE 'COMMON.FOR'
C
C Calls   7: APLOT  , DAWRT  , ERRMSG , FILL   , GETHDR , GETVAL
C            OPNFIL
C Called by: OTOKO
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL    VALUE(10)
      INTEGER ICLO,JOP,IRC,IFRAME,IHFMAX,IFRMAX,IMEM,NCHAN,NFRAME
      INTEGER KREC,ISPEC,LSPEC,MEM,IFFR,ILFR,INCR,IFINC,NVAL
      INTEGER L1,L2,L3,L4,MDEG,NPNTS,NPNT2,I,J,K,L
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 HFNAM,OFNAM
C
C ICLO   : Close file indicator
C JOP    : Open file indicator
C IRC    : Return code
C IFRAME : Total nos. of frames
C IFRMAX : Nos. of frames in sequence
C IHFMAX : Nos. of header file in sequence
C KREC   : Output file record
C ISPEC  : First header file of sequence
C LSPEC  : Last header file in sequence
C MEM    : Positional or calibration data indicator
C IFFR   : First frame in sequence
C ILFR   : Last frame in sequence
C INCR   : Header file increment
C IFINC  : Frame increment
C HFNAM  : Header filename
C OFNAM  : Output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C IMEM   : Output memory dataset
C NCHAN  : Nos. of data points in spectrum
C NFRAME : Nos. of time frames
C
      DATA  IMEM/1/ , KREC/1/
C
C-----------------------------------------------------------------------
10    ICLO=0
      KREC=0
      JOP=0
C
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,IFFR,
     1             ILFR,IFINC,IHFMAX,IFRMAX,NCHAN,IRC)
      IF (IRC.NE.0) GOTO 999
      IFRAME=IHFMAX+IFRMAX-1
C
20    WRITE (IPRINT,1000)
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 10
      IF (IRC.EQ.2) GOTO 20
      IF (NVAL.EQ.0) THEN
         MDEG=1
      ELSE
         MDEG=INT(VALUE(1))
      ENDIF
30    WRITE (IPRINT,1010)
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 10
      IF (IRC.EQ.2) GOTO 30
      IF (NVAL.LT.4) THEN
         CALL ERRMSG ('Error: Insufficient input')
         GOTO 30
      ELSE
         L1=INT(VALUE(1))
         L2=INT(VALUE(2))
         L3=INT(VALUE(3))
         L4=INT(VALUE(4))
         IF ((L1.LT.1.OR.L1.GT.NCHAN).OR.
     1       (L2.LT.1.OR.L2.GT.NCHAN).OR.
     2       (L3.LT.1.OR.L3.GT.NCHAN).OR.
     3       (L4.LT.1.OR.L4.GT.NCHAN)) THEN
            CALL ERRMSG ('Error: Value outside of range')
            GOTO 20
         ENDIF
      ENDIF
      DO 100 I=1,IHFMAX
C
         CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NCHAN,NFRAME,IRC)
         IF (IRC.EQ.0) THEN
C
            ISPEC=ISPEC+INCR
            DO 90 J=1,IFRMAX
               READ (JUNIT,REC=IFFR) (SP1(K),K=1,NCHAN)
               IFFR=IFFR+IFINC
               KREC=KREC+1
C
               CALL FILL (SP3,NCHAN,0.0)
               DO 40 K=L1,L2
                  L=K-L1+1
                  SP5(L)=REAL(K)
                  SP6(L)=1.0
                  SP3(L)=SP1(K)
40             CONTINUE
               DO 50 K=L3,L4
                  L=K-L3+L2-L1+2
                  SP5(L)=REAL(K)
                  SP6(L)=1.0
                  SP3(L)=SP1(K)
50             CONTINUE
               NPNTS=L2-L1+1+L4-L3+1
               CALL VC01A (SP5,SP3,SP6,SP2,NPNTS,SP7,SP8,SP9,SP10,SP11,
     1                     SP12,MDEG,SPW)
               DO 60 K=L1,L4
                  L=K-L1+1
                  SP6(L)=REAL(K)
60             CONTINUE
               NPNT2=L4-L1+1
               CALL POLCAL (SP6,SP3,SP7,SP8,SP9,MDEG,1,NPNT2)
               CALL FILL (SP2,NCHAN,0.0)
               DO 80 K=L1,L4
                  L=K-L1+1
                  SP2(K)=SP1(K)-SP3(L)
80             CONTINUE
               IF (IFRAME.EQ.1) CALL APLOT (ITERM,IPRINT,SP2,NCHAN)
               IF (KREC.GE.IFRAME) ICLO=1
               IF (KREC.EQ.1) THEN
                  CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 110
               ENDIF
               CALL DAWRT (KUNIT,OFNAM,IMEM,NCHAN,IFRAME,HEAD1,HEAD2,
     1                     SP2,KREC,JOP,ICLO,IRC)
               IF (IRC.NE.0) GOTO 110
90          CONTINUE
            CLOSE (UNIT=JUNIT)
         ENDIF
100   CONTINUE
110   CLOSE (UNIT=JUNIT)
      GOTO 10
999   RETURN
C
1000  FORMAT (' Enter degree of polynomial [1]: ',$)
1010  FORMAT (' Enter range of points on either side of peak,',/,
     1        ' low_min, low_max, high_min, high_max: ',$)
      END


!>------------------------------------------------------------------------------------
!!
!> @brief   Astronomical constants and type definitions, as well as basic functions
!!
!> @anchor  slam_astro
!!
!> @author  Vitali Braun
!> @author  Christopher Kebschull
!!
!> @date

!!
VB:  19.12.2012 (added doxygen special commands)

!!
VB:  17.07.2013 (added 'getEarthMass')

!!
VB:  30.07.2013 (added 'getOrbitalPeriod' and overload for assignment operator for kepler_t types)

!!
VB:  07.08.2013 (moved type definitions to orbit_type.f90)

!!
VB:  10.06.2014 (additional Earth radius to allow for different values to be used for different models)

!!
CHK: XX.XX.2015 (moved to libslam )

!!

!!
!> @copyright Institute of Space Systems / TU Braunschweig
!!
!!------------------------------------------------------------------------------------
module slam_astro

  use slam_error_handling
  use slam_types
  use slam_math, only: pi, halfPi, twoPi, rad2deg, deg2rad

  implicit none

  private

  !** constants
  !---------------------------------------------------------------
  real(dp) :: rekm          ! Earth's radius / km
  real(dp) :: rekm2         ! Earth's radius squared
  real(dp) :: geo_rekm      ! Earth's radius for the geopotential / km
  real(dp) :: massEarth     ! earth's mass in kg
  real(dp) :: mu            ! gravity constant km^3/s^2
  real(dp) :: muorekm2      ! mu/rekm2
  real(dp) :: omega_earth   ! earth's rotational rate rad/s
  real(dp) :: flat          ! flattening
  real(dp) :: sun_radius    ! radius of the sun
  real(dp) :: EESqrd        ! 2f - f**2
  real(dp) :: au            ! 1 astronomical unit (ua)
  real(dp) :: auer          ! 1 au in earth radii

  real(dp), parameter        :: gravConstant = 6.67408d-20   ! Constant of gravity in km**3/kg/s**2 according to CODATA (Mohr et al. 2014)
  real(dp), parameter        :: lightspeed   = 299792458.0d0 ! Speed of Light in m/s according to CODATA (Mohr et al. 2014)
  integer, parameter, public :: EGM96        = 1   ! EGM96 constants
  integer, parameter, public :: EGM08        = 2   ! EGM2008 constants
  integer, parameter, public :: EIGEN_GL04C  = 3   ! EIGEN-GL04C constants
  integer, parameter, public :: IAU          = 4   ! IAU proposed value, including LOD corrections

  logical :: astConstInitialized = .false.  ! telling that already initialized

  !-----------------------------------------------------------------

  !** public methods
  !---------------------------------
  public :: initAstroConstants
  public :: isAstroInitialized

  !** getter
  public :: getAstronomicalUnit
  public :: getEarthGravity
  public :: getEarthMass
  public :: getEarthGeopotentialRadius
  public :: getEarthRadius
  public :: getEarthRotation
  public :: getEesqrd
  public :: getFlattening ! EdG 31.3.16
  public :: getGMST
  public :: getOrbitalPeriod
  public :: getSunRadius
  public :: getSpeedOfLight
  public :: getAstronomicalUnitInEarthRadii

  !** setter
  public :: setEarthGeopotentialRadius
  public :: setEarthGravity
  public :: setEarthRadius

contains

  !========================================================================
  !
  ! Astronomical constant initialization
  !
  !----------------------------------------------------
  !
  !> @brief Initialization of astronomical constants
  !!
  !> @anchor      initAstroConstants
  !!
  !> @author      Vitali Braun
  !!
  !> @date

  !!
 22.03.2013 (added special comments for doxygen docu)

  !!
 17.07.2013 (added Earth's mass)

  !!
 10.06.2014 (added Earth's geopotential radius)

  !!

  !!
  !> @param[in]   consttyp  type of constants to use, e.g. EGM96
  !!
  !> @details     This routine initializes astronomical constants, which then can
  !!              be used in all computations. The following parameters are set:
  !!

  !!
Earth's equatorial radius         - 'rekm'

  !!
Earth's equatorial radius squared - 'rekm2'

  !!
Earth's gravity constant          - 'mu'

  !!
Earth's mass                      - 'massEarth'

  !!
Earth's siderial rotation         - 'omega_earth'

  !!
Earth's flattening                - 'flat'

  !!
Earth's eccentricity squared      - 'EESqrd'

  !!
Astronomical unit in Earth radii  - 'auer'

  !!
Sun radius                        - 'sun_radius'

  !!
Term mu/rekm2                     - 'muorekm2'

  !!

  !-----------------------------------------------------------------------------
  subroutine initAstroConstants(consttyp)

    integer, intent(in) :: consttyp   ! type of constants to use

    select case(consttyp)

      case(EGM96, EGM08)

        rekm = 6378.1363d0
        mu   = 398600.4415d0

      case default ! EIGEN-GL04C

        rekm = 6378.13646d0
        mu   = 398600.4415d0

    end select

    geo_rekm    = rekm      ! set to rekm as default.

    sun_radius  = 696.d3    ! in km
    massEarth   = mu/gravConstant
    omega_earth = 7.2921158553d-5
    flat        = 1.d0/298.257223563d0
    EESqrd      = flat*(2.d0 - flat)
    au          = 149597870.7d0
    auer        = au/rekm

    rekm2       = rekm**2.d0
    muorekm2    = mu/rekm2

    astconstInitialized = .true.

    return

  end subroutine initAstroConstants

  !=========================================================================
  !>  @anchor isAstroInitialized
  !>  @brief  Checks whether astronomical constants are already initialized
  !!
  !>  @author Vitali Braun
  !>  @returns logical indicating wether the Astro module is initialized or not
  !>  @date

  !!
10.11.2013 (initial design)

  !!

  !!
  !!------------------------------------------------------------
  logical function isAstroInitialized()

    isAstroInitialized = astConstInitialized
    return

  end function isAstroInitialized

  !=========================================================================
  !
  !>  @brief  Get astronomical unit in km
  !!
  !>  @author Vitali Braun
  !>  @returns real(dp) the astronomical unit in km
  !>  @date

  !!
13.02.2015 (initial design)

  !!

  !!
  !!
  !!-------------------------------------------------------------
  real(dp) function getAstronomicalUnit()

    if(.not. astConstInitialized) then
      call initAstroConstants(EIGEN_GL04C)
    end if

    getAstronomicalUnit = au

    return

  end function getAstronomicalUnit

  !=========================================================================
  !> @anchor getEarthGravity
  !> @brief Get Earth's gravity constant
  !> @returns real(dp) Earth's gravity constant
  !
  !-------------------------------------------------------------
  real(dp) function getEarthGravity()

    if(.not. astConstInitialized) then

      call initAstroConstants(EIGEN_GL04C)

    end if

    getEarthGravity = mu

    return

  end function getEarthGravity

  !==============================================================================
  !
  !> @anchor      getEarthMass
  !!
  !> @brief       Get Earth's mass in kg
  !> @author      Vitali Braun
  !!
  !> @date

  !!
 17.07.2013 (initial design)

  !!

  !!
  !!-----------------------------------------------------------------------------
  real(dp) function getEarthMass()

    if(.not. astConstInitialized) then

      call initAstroConstants(EIGEN_GL04C)

    end if

    getEarthMass = massEarth

    return

  end function getEarthMass

  !=========================================================================
  !> @anchor getEarthRadius
  !> @brief Get Earth's radius in km
  !
  !-------------------------------------------------------------
  real(dp) function getEarthRadius()
    implicit none
    if(.not. astConstInitialized) then
      call initAstroConstants(EIGEN_GL04C)
    end if
    getEarthRadius = rekm
    return
  end function getEarthRadius

  !=========================================================================
  !
  !> @brief   Get Earth's radius as used for the geopotential
  !!
  !> @author  Vitali Braun
  !!
  !> @date

  !!
10.06.2014 (initial implementation)

  !!

  !!
  !> @anchor  getEarthGeopotentialRadius
  !
  !-------------------------------------------------------------
  real(dp) function getEarthGeopotentialRadius()
    implicit none
    if(.not. astConstInitialized) then
      call initAstroConstants(EIGEN_GL04C)
    end if
    getEarthGeopotentialRadius = geo_rekm
    return
  end function getEarthGeopotentialRadius

  !================================================================================
  !> @anchor getEarthRotation
  !> @brief Get Earth's angular velocity
  !!
  !> @author  Vitali Braun
  !> @returns real(dp) the Earth's rotation parameter
  !!
  !> @param[in] lod     Length of day in seconds
  !> @param[in] itype   model to derive angular velocity from, e.g. EGM96 or IAU
  !--------------------------------------------------------------------------------
  real(dp) function getEarthRotation(lod,itype)

    real(dp),  intent(in) :: lod     ! Length of day in seconds
    integer, intent(in) :: itype   ! model to derive angular velocity from

    select case(itype)
      case(EGM96, EGM08, EIGEN_GL04C)
        getEarthRotation = 7.2921158553d-5
        return
      case(IAU)
        getEarthRotation = 7.292115146706979d-5*(1.d0 - lod/86400.d0)
        return
      case default
        getEarthRotation = omega_earth
        return
    end select

  end function getEarthRotation

  !=========================================================================
  !> @anchor getEesqrd
  !> @brief Get Earth's eccentricity squared
  !> @returns real(dp)
  !-------------------------------------------------------------
  real(dp) function getEesqrd()

    if(.not. astConstInitialized) then

      call initAstroConstants(EIGEN_GL04C)

    end if

    getEesqrd = EESqrd

  end function

  !=========================================================================
  !
  !> @brief     Get Earth's flattening
  !> @author    Vitali Braun
  !> @returns   Earth flattening
  !> @date

  !!
10.06.2014 (initial implementation)

  !!

  !!
  !! @anchor  getFlattening
  !
  !-------------------------------------------------------------
  real(dp) function getFlattening()
    implicit none
    if(.not. astConstInitialized) call initAstroConstants(EIGEN_GL04C)
    getFlattening = flat
    return
  end function getFlattening

  !==========================================================================
  !
  !> @anchor getGMST
  !> @returns real(dp) the Greenwich mean siderial time
  !
  !> @brief Compute Greenwich mean sidereal time (GMST)
  !!
  !> @author  Vitali Braun
  !!
  !> @param[in] mjd_ut1    Date in UT1
  !!
  !-----------------------------------------------------------
  real(dp) function getGMST( mjd_ut1 ) ! <-- DBL date (modified julian day) in UT1
    use slam_time, only: jd245

    !** interface
    !-------------------------------------------
    real(dp), intent(in) :: mjd_ut1
    !-------------------------------------------

    real(dp) :: tut1      ! number of julian centuries since J2000.0

    tut1 = (mjd_ut1 - (2451545.d0 - jd245))/36525.d0

    getGMST = 4.8949612128d0 + (230121.675315423d0 + (6.77071394d-6 - 4.508767234d-10*tut1)*tut1)*tut1

    ! Achnowledge the reduced precision of this method
    !getGMST = dint(getGMST*10D8)*10D-8

    !** reduce to angle between -2pi...2pi
    getGMST = mod(getGMST, twopi)

    return

  end function getGMST

  !=========================================================================
  !> @anchor getSunRadius
  !> @brief Get Sun's radius
  !> @returns real(dp) the Sun radius
  !-------------------------------------------------------------
  real(dp) function getSunRadius()

    if(.not. astConstInitialized) then

      call initAstroConstants(EIGEN_GL04C)

    end if

    getSunRadius = sun_radius

    return

  end function getSunRadius

  !==============================================================================
  !
  !> @anchor      getOrbitalPeriod
  !!
  !> @brief       Get orbit period in seconds
  !> @author      Vitali Braun
  !!
  !> @param[in]   sma   Semi-major axis in km
  !> @returns     real(dp) the orbital period
  !> @date

  !!
 30.07.2013 (initial design)

  !!

  !!
  !!-----------------------------------------------------------------------------
  real(dp) function getOrbitalPeriod(sma)

    real(dp), intent(in) :: sma

    character(len=*), parameter :: csubid = 'getOrbitalPeriod'

    if(isControlled()) then
      if(hasToReturn()) return
      call checkIn(csubid)
    end if

    getOrbitalPeriod = -999999.d0

    if (sma > 0.d0) then
      getOrbitalPeriod = twopi*sqrt(sma**3.d0/mu)
    else
      call setError(E_SEMI_MAJOR_AXIS, FATAL)
      return
    end if

    if(isControlled()) then
      call checkOut(csubid)
    end if

    return

  end function

  !=================================================================
  !> @anchor setEarthGravity
  !> @brief Set Earth's gravity constant
  !!
  !> @author  Vitali Braun
  !> @author  Eduard Gamper
  !!
  !> @details
  !!

  !!
EdG: 31.03.2016 (Corrected checking for valid Earth gravity and added "return" statement)

  !!

  !!
  !> @param[in] mu_in   Earth's gravity constant in km/s**3
  !
  !--------------------------------------------------------
  subroutine setEarthGravity(mu_in)

    !** interface
    !---------------------------
    real(dp), intent(in) :: mu_in
    !---------------------------

    character(len=*), parameter :: csubid = 'setEarthGravity'

    if(isControlled()) then
      if(hasToReturn()) return
      call checkIn(csubid)
    end if

    if(mu_in < 398500.d0 .or. mu_in > 398700.d0) then !EdG changed .and. to .or.
      call setError(E_EARTH_GRAVITY, WARNING)
      return
    end if

    mu = mu_in

    !** refresh Earth's mass
    massEarth = mu/gravConstant

    !** done
    if(isControlled()) then
      call checkOut(csubid)
    end if

  end subroutine setEarthGravity

  !=================================================================
  !> @anchor    setEarthRadius
  !> @brief     Set Earth's radius
  !!
  !> @author    Vitali Braun
  !> @author    Eduard Gamper
  !!
  !! @details

  !!
EdG: 31.03.2016 (Corrected checking for valid radiusand added "return" statement)

  !!

  !!
  !> @param[in] rekm_in   Earth's equatorial radius in km
  !
  !--------------------------------------------------------
  subroutine setEarthRadius(rekm_in)

    !** interface
    !---------------------------
    real(dp), intent(in) :: rekm_in
    !---------------------------

    character(len=*), parameter :: csubid = 'setEarthRadius'

    if(isControlled()) then
      if(hasToReturn()) return
      call checkIn(csubid)
    end if

    if(rekm_in < 6320 .or. rekm_in > 6390) then !EdG changed .and. to .or.
      call setError(E_EARTH_RADIUS, WARNING)
      return
    end if

    rekm  = rekm_in
    rekm2 = rekm**2.d0

    !** done
    if(isControlled()) then
      call checkOut(csubid)
    end if

  end subroutine setEarthRadius

  !=================================================================
  !
  !> @brief     Set Earth's geopotential radius
  !!
  !> @author    Vitali Braun
  !> @author    Eduard Gamper
  !!
  !> @details

  !!
VB:  10.06.2014 (initial implementation)

  !!
EdG: 31.03.2016 (Corrected checking for valid radius and added "return" statement)

  !!

  !!
  !> @param[in] rekm_in   Earth's equatorial radius in km to be used for the geopotential
  !!
  !> @anchor    setEarthGeopotentialRadius
  !!
  !--------------------------------------------------------
  subroutine setEarthGeopotentialRadius(rekm_in)

    !** interface
    !---------------------------
    real(dp), intent(in) :: rekm_in
    !---------------------------

    character(len=*), parameter :: csubid = 'setEarthGeopotentialRadius'

    if(isControlled()) then
      if(hasToReturn()) return
      call checkIn(csubid)
    end if

    if(rekm_in < 6320 .or. rekm_in > 6390) then
      call setError(E_EARTH_RADIUS, WARNING) !EdG changed .and. to .or.
      return
    end if

    geo_rekm  = rekm_in

    !** done
    if(isControlled()) then
      call checkOut(csubid)
    end if

    return

  end subroutine setEarthGeopotentialRadius

  !=========================================================================
  !
  !> @brief     Get Speed of light for this universe
  !!
  !> @returns   real(dp) the Speed of Light
  !> @author    Christopher Kebschull
  !> @date
  !!

  !!
ChK: 09.02.2016 (initial implementation)

  !!

  !> @anchor getSpeedOfLight
  !-------------------------------------------------------------
  real(dp) function getSpeedOfLight()
    implicit none
    getSpeedOfLight = lightspeed
    return
  end function getSpeedOfLight

  !=========================================================================
  !
  !> @brief     Get Astronomical Unit in Earth Radii
  !!
  !> @returns   real(dp) the Astronomical Unit in Earth radii
  !> @author    Volker Schaus
  !> @date
  !!

  !!
ChK: 17.08.2018 (initial implementation)

  !!

  !> @anchor    getAstronomicalUnitInEarthRadii
  !-------------------------------------------------------------
  real(dp) function getAstronomicalUnitInEarthRadii()

    if(.not. astConstInitialized) then

      call initAstroConstants(EIGEN_GL04C)

    end if

    getAstronomicalUnitInEarthRadii = auer

    return

  end function getAstronomicalUnitInEarthRadii

end module slam_astro


*dk,int_edge
      subroutine int_edge(x1,y1,z1,x2,y2,z2,x3,y3,z3,xi,yi,zi)
C
C #####################################################################
C
C     PURPOSE -
C
C        None
C
C     INPUT ARGUMENTS -
C
C        None
C
C     OUTPUT ARGUMENTS -
C
C        None
C
C     CHANGE HISTORY -
C
C        $Log: int_edge.f,v $
C        Revision 2.00  2007/11/05 19:45:59  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.1   Mon Apr 14 16:51:54 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.0   11/10/94 12:15:26   pvcs
CPVCS    Original version.
C
C ######################################################################
C
       implicit real*8 (a-h,o-z)
C
      character*132 logmess
C
      xsmall=1.0d-10
      cx=  (y2-y1)*(z3-z1)-(y3-y1)*(z2-z1)
      cy=-((x2-x1)*(z3-z1)-(x3-x1)*(z2-z1))
      cz=  (x2-x1)*(y3-y1)-(x3-x1)*(y2-y1)
      x1p=x1+cx
      y1p=y1+cy
      z1p=z1+cz
      call eullag3(1,x1,y1,z1,x1p,y1p,z1p,x1,y1,z1,a1,b1,c1)
      call eullag3(1,x1,y1,z1,x1p,y1p,z1p,x2,y2,z2,a2,b2,c2)
      call eullag3(1,x1,y1,z1,x1p,y1p,z1p,x3,y3,z3,a3,b3,c3)
      da32=a3-a2
      db32=b3-b2
      if(abs(da32).le.xsmall) then
         xa=a2
         ya=b1
         za=0.0
      elseif(abs(db32).le.xsmall) then
         xa=a1
         ya=b2
         za=0.0
      else
         c1=db32/da32
         c2=-1.0/c1
         d1=-c1*a2+b2
         d2=-c2*a1+b1
         xa=(d2-d1)/(c1-c2+xsmall)
         ya=(c1*d2-c2*d1)/(c1-c2+xsmall)
         za=0.0
      endif
      call eullag3(2,x1,y1,z1,x1p,y1p,z1p,xa,ya,za,xi,yi,zi)
      return
      end


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   man :  Stable manifold of the origen in the Lorenz model
!----------------------------------------------------------------------
!----------------------------------------------------------------------

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

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

      DOUBLE PRECISION Period

       Period=PAR(11)

       F(1)= Period * (PAR(3) * (U(2)- U(1)))
       F(2)= Period * (PAR(1)*U(1) - U(2) - U(1)*U(3))
       F(3)= Period * (U(1)*U(2) -  PAR(2)*U(3))

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

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

      DOUBLE PRECISION rad,h,Period,RLength,pi,theta,cs,sn,V1(3),V2(3)

       PAR(1)=28.
       PAR(2)=8.d0/3.d0
       PAR(3)=10.

       rad=5.0
       h=0.1
       Period=1e-5
       RLength=0.

       PAR(4)=rad
       PAR(5)=h

       CALL EIGV(NDIM,PAR,V1,V2)

! Set initial approximate solution (for small Period)
       pi=4*ATAN(1.d0)
       theta=2*pi*h
       cs=COS(theta)
       sn=SIN(theta)

       U(1)= rad * ( cs*V1(1) + sn*V2(1) )
       U(2)= rad * ( cs*V1(2) + sn*V2(2) )
       U(3)= rad * ( cs*V1(3) + sn*V2(3) )

       PAR(6) = U(1)
       PAR(7) = U(2)
       PAR(8) = U(3)
       PAR(9) = SQRT(U(1)**2 + U(2)**2 + U(3)**2)
       PAR(11)=Period
       PAR(12)=RLength

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

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

      DOUBLE PRECISION V1(3),V2(3),pi,rad,h,theta,cs,sn

       CALL EIGV(NDIM,PAR,V1,V2)

       pi=4*ATAN(1.d0)
       rad=PAR(4)
       h=PAR(5)
       theta=2*pi*h
       cs=COS(theta)
       sn=SIN(theta)
! At time=0
       FB(1)= U0(1) - rad * ( cs*V1(1) + sn*V2(1) )
       FB(2)= U0(2) - rad * ( cs*V1(2) + sn*V2(2) )
       FB(3)= U0(3) - rad * ( cs*V1(3) + sn*V2(3) )
! At time=1
       FB(4)= U1(1) - PAR(6)
       FB(5)= U1(2) - PAR(7)
       FB(6)= U1(3) - PAR(8)
       FB(7)= SQRT(U1(1)**2 + U1(2)**2 + U1(3)**2) - PAR(9)

      END SUBROUTINE BCND
!----------------------------------------------------------------------
      SUBROUTINE EIGV(NDIM,PAR,V1,V2)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: V1(NDIM),V2(NDIM)
      LOGICAL, SAVE :: ifirst = .TRUE.

      DOUBLE PRECISION e,ss

! Stable eigenvalue/vector 1
       V1(1)= 0.
       V1(2)= 0.
       V1(3)= 1./2.66667

! Stable eigenvalue/vector 2
       e=-(11+SQRT(1201.d0))/2
       V2(1)=1+e
       V2(2)=PAR(1)
       V2(3)= 0.
       ss=SQRT(V2(1)**2+V2(2)**2)
       V2(1)=V2(1)/(ss*22.8277)
       V2(2)=V2(2)/(ss*22.8277)
       IF(ifirst)THEN
         WRITE(10,*)V2(1),V2(2)
         ifirst=.FALSE.
       ENDIF

      END SUBROUTINE EIGV
!----------------------------------------------------------------------
      SUBROUTINE ICND(NDIM,PAR,ICP,NINT,U,UOLD,UDOT,UPOLD,FI,IJAC,DINT)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NINT, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), UOLD(NDIM), UDOT(NDIM), UPOLD(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FI(NINT)
      DOUBLE PRECISION, INTENT(INOUT) :: DINT(NINT,*)

      DOUBLE PRECISION FF(3),DFDU(1),DFDP(1)

       CALL FUNC(NDIM,U,ICP,PAR,0,FF,DFDU,DFDP)
       FI(1)=SQRT(FF(1)**2 + FF(2)**2 + FF(3)**2 ) - PAR(12)

      END SUBROUTINE ICND

      SUBROUTINE PVLS
      END SUBROUTINE PVLS

      SUBROUTINE FOPT
      END SUBROUTINE FOPT


!
!==================================================================================
!
!     Purpose: This program evaluates the three-dimensional free-surface
!              Green function and derivatives in deep water
!
!              Code Original Author: Hui Liang       created on  2016.12.26
!
!  License:
!
!
!    This routine is a free software package: you can redistribute it and/or modify it
!    under the terms of the GNU Lesser General Public License as published by the
!    Free Software Foundation, either version 3 of the License, or (at your option)
!    any later version.
!
!    You should have received a copy of the GNU General Public License (either V3
!    or later), along with this routine. If not, see <http://www.gnu.org/licenses/>.
!
!  Modified on:
!
!    January 02, 2018
!
!  Reference:
!
!
!	[1]	H. Wu, C. Zhang, Y. Zhu, W. Li, D. Wan, F. Noblesse,
!		A global approximation to the Green function for
!		diffraction radiation of water waves,
!		Eur. J. Mech. B Fluids 65 (2017) 54-64.
!
!	[2]	H. Liang, H. Wu, F. Noblesse,
!		Validation of a global approximation for
!		wave diffraction-radiation in deep water,
!		Appl. Ocean Res. 74 (2018) 80-86.
!
!   Remarks
!
!	The local-flow component is approximated by mean of the global
!	approximations [1]. The computations reported in [2] provides
!	strong evidence that the global approximations are sufficiently
!	accurate to compute linear and second-order wave loads in practice.
!
!
!	It should be noted that the Rankine source term -2/d appeared in L_z
!	given by (8a) in Ref. [2] is not evaluated here (there is a typo in (8a)).
!	These Rankine source components are required to evaluate in another routine
!	due to strong singular behavior.
!
!	For any questions, please contact: lianghuistar@gmail.com
!
!   We define the flow-field point (x,y,z) and source point (xi,eta,zeta).
!   Please note that all variables are non-dimensionalized with respect to
!	the wavenumber k0
!
!   The Green function is defiend as
!
!   G = -1/r-1/d+GF,
!
!   where
!
!   r = sqrt((x-xi)^2+(y-eta)^2+(z-zeta)^2);
!   d = sqrt((x-xi)^2+(y-eta)^2+(z+zeta)^2).
!
!   Parameters:
!
!       Input:      dx  --- x-xi
!                   dy  --- y-eta
!                   vv  --- z+zeta
!
!       Output:     GF(0)  --- free surface itself GF
!                   GF(1)  --- x-derivative GF_x
!                   GF(2)  --- y-derivative GF_y
!                   GF(3)  --- part of z-derivative GF_z = GF(3) - 2/d
!
! ==================================================================================

module INFG3D_Open

      USE Const_mod
      implicit none

      PUBLIC :: INFGREEN3D

!      REAL*8            ::	pi	=	4.0D0*datan(1.0D0)
      REAL*8			::	gama=	0.5772156649D0
      COMPLEX*16		::  Im	=	dcmplx(0.0D0,1.0D0)

      REAL*8			::	GF_alpha
      REAL*8			::	GF_beta
      REAL*8			::	GF_sigma
      REAL*8			::	GF_rho
      REAL*8			::	GF_dd

      REAL*8			::	GF_hh
      REAL*8			::	GF_vv

contains

!***********************************************************************
!        FREE-SURFACE GREEN FUNCTION AND ITS NORMAL DERIVATIVES
!***********************************************************************

SUBROUTINE INFGREEN3D(XF,XP,YF,YP,ZF,ZP,V,GRN,FLAG)

        IMPLICIT NONE

        INTEGER,INTENT(IN):: FLAG
        REAL*8,INTENT(IN):: XF,XP,YF,YP,ZF,ZP,V
        COMPLEX*16,INTENT(OUT):: GRN(4)

        REAL*8:: R,R1,RR,XPQ,YPQ,ZPQ,PI
        COMPLEX*16:: GF,GFH

        DATA  PI /3.141592653589793D0/

        XPQ=XF-XP
        YPQ=YF-YP
        ZPQ=ZP+ZF

        RR  =SQRT(XPQ**2+YPQ**2)
        R =SQRT(RR**2+(ZP-ZF)**2)
        R1 =SQRT(RR**2+ZPQ*ZPQ)

        GRN(:)=CMPLX(0.D0,0.D0)

        CALL HavelockGF(V*RR,V*ZPQ,GF,GFH)

        IF (ABS(V).LT.1.E-8) THEN

         IF (FLAG.EQ.1) THEN
          GRN(1)=GRN(1)+1.D0/R1
          GRN(2)=GRN(2)-XPQ/R1**3
          GRN(3)=GRN(3)-YPQ/R1**3
          GRN(4)=GRN(4)-ZPQ/R1**3
         ELSE
          GRN(1)=GRN(1)+1.D0/R1+1.D0/R
          GRN(2)=GRN(2)-XPQ/R1**3-XPQ/R**3
          GRN(3)=GRN(3)-YPQ/R1**3-YPQ/R**3
          GRN(4)=GRN(4)-ZPQ/R1**3-(ZF-ZP)/R**3
         ENDIF

        ELSEIF (ABS(V+1.D0).LT.1.E-8) THEN

         IF (FLAG.EQ.1) THEN
          GRN(1)=GRN(1)-1.D0/R1
          GRN(2)=GRN(2)+XPQ/R1**3
          GRN(3)=GRN(3)+YPQ/R1**3
          GRN(4)=GRN(4)+ZPQ/R1**3
         ELSE
          GRN(1)=GRN(1)-1.D0/R1+1.D0/R
          GRN(2)=GRN(2)+XPQ/R1**3-XPQ/R**3
          GRN(3)=GRN(3)+YPQ/R1**3-YPQ/R**3
          GRN(4)=GRN(4)+ZPQ/R1**3-(ZF-ZP)/R**3
         ENDIF

        ELSE

         IF(RR.GT.1.E-6) THEN
          GRN(2)=-V**2.D0*GFH*XPQ/RR
          GRN(3)=-V**2.D0*GFH*YPQ/RR
         ELSE
          GRN(2)=CMPLX(0.D0,0.D0)
          GRN(3)=CMPLX(0.D0,0.D0)
         ENDIF

          GRN(1)=-V*GF
          GRN(4)=-V**2.D0*GF+2.D0*V/R1

         IF (FLAG.EQ.1) THEN
          GRN(1)=GRN(1)+1.D0/R1
          GRN(2)=GRN(2)-XPQ/R1**3
          GRN(3)=GRN(3)-YPQ/R1**3
          GRN(4)=GRN(4)-ZPQ/R1**3
         ELSE
          GRN(1)=GRN(1)+1.D0/R1+1.D0/R
          GRN(2)=GRN(2)-XPQ/R1**3-XPQ/R**3
          GRN(3)=GRN(3)-YPQ/R1**3-YPQ/R**3
          GRN(4)=GRN(4)-ZPQ/R1**3-(ZF-ZP)/R**3
         ENDIF

        ENDIF

      RETURN
END SUBROUTINE INFGREEN3D

!===============================================================
subroutine HavelockGF(hh,vv,GF,GFh)
!
    implicit none
! --- Variables -------------------------------------------
    REAL*8,intent(in)        ::    hh,vv
    COMPLEX*16,intent(out)    ::    GF, GFh

! --- Local variables -------------------------------------
!    REAL*8                    ::    hh

!    hh    =    dsqrt(dx*dx+dy*dy)
    call    GF_DivParameters(hh,vv)

    GF    =    GF_Func_L0(hh,vv)+GF_Func_W(hh,vv)
    GFh =    GF_Func_Ls(hh,vv)+GF_Func_Wh(hh,vv)

end subroutine HavelockGF

!=============================================================
! Calculate parameters
subroutine GF_DivParameters(hh,vv)
    implicit none

! --- Variables -------------------------------------------
    REAL*8,intent(in)        ::    hh,vv

! --- Local variables -------------------------------------

    GF_dd		=	dsqrt(hh*hh+vv*vv)     ! r1=sqrt((x-x0)^2+(y-y0)^2+(z-z0)^2)
	GF_alpha	=	-vv/GF_dd
	GF_beta		=	hh/GF_dd
	GF_sigma	=	hh/(GF_dd-vv)
	GF_rho		=	GF_dd/(1.0D0+GF_dd)

	return
end subroutine GF_DivParameters

!=============================================================
function GF_Func_L0(hh,vv)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	hh,vv

! --- Local variables -------------------------------------
	integer					::	ii
	REAL*8					::	PP,Lp,Cal_L0
	REAL*8					::	GF_Func_L0

	PP	=	dlog(0.5D0*(GF_dd-vv))+gama-2.0D0*GF_dd*GF_dd
	PP	=	dexp(vv)*PP
	PP	=	PP+GF_dd*GF_dd-vv      ! Eq. (22b) in [1]

	Lp	=	GF_Func_Lp(hh,vv)   ! L', i.e. Eq.(22c) in [1]

	GF_Func_L0	=	2.0D0*PP/(1.0D0+GF_dd**3)+2.0D0*Lp  ! Eq. (22a) in [1] excluding the term -1/d

	return
end function GF_Func_L0

!=============================================================
function GF_Func_Lp(hh,vv)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	hh,vv

! --- Local variables -------------------------------------
	REAL*8					::	A,B,C,D,RR,Lp
	REAL*8					::	GF_Func_Lp

	A	=	GF_FuncA(GF_rho)    ! below: Eq.(33d) ~ (33g) in [1]
	B	=	GF_FuncB(GF_rho)
	C	=	GF_FuncC(GF_rho)
	D	=	GF_FuncD(GF_rho)

	RR	=	(1.0D0-GF_beta)*A    ! below: Eq (26b) in [1]
	RR	=	RR-GF_beta*B
	RR	=	RR-GF_alpha*C/(1.0D0+6.0D0*GF_alpha*GF_rho*(1.0D0-GF_rho))
	RR	=	RR+GF_beta*(1.0D0-GF_beta)*D

	GF_Func_Lp	=	GF_rho*(1.0D0-GF_rho)**3*RR     ! Eq.(26a) in [1]

	return
end function GF_Func_Lp

!=============================================================
function GF_Func_W(hh,vv)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	hh,vv

! --- Local variables -------------------------------------
	REAL*8					::	H0,J0
	COMPLEX*16				::	GF_Func_W

	H0	=	StruveH0(hh)
	J0	=	BesselJ0(hh)

	GF_Func_W	=	2.0D0*pi*(H0-Im*J0)*dexp(vv)

	return
end function GF_Func_W

!=============================================================
function GF_FuncA(tt)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	tt

! --- Local variables -------------------------------------
	REAL*8					::	A0,A1,A2,A3,A4
	REAL*8					::	A5,A6,A7,A8,A9
	REAL*8					::	GF_FuncA

	data	A0,A1,A2,A3,A4,A5,A6,A7,A8,A9			&
		/	+1.21D0,	-13.328D0,	+215.896D0,		&
			-1763.96D0,	+8418.94D0,	-24314.21D0,	&
			+42002.57D0,-41592.9D0,	21859.0D0,		&
			-4838.6D0	/

	GF_FuncA	=	(A8+A9*tt)*tt
	GF_FuncA	=	(A7+GF_FuncA)*tt
	GF_FuncA	=	(A6+GF_FuncA)*tt
	GF_FuncA	=	(A5+GF_FuncA)*tt
	GF_FuncA	=	(A4+GF_FuncA)*tt
	GF_FuncA	=	(A3+GF_FuncA)*tt
	GF_FuncA	=	(A2+GF_FuncA)*tt
	GF_FuncA	=	(A1+GF_FuncA)*tt
	GF_FuncA	=	A0+GF_FuncA

	return
end function GF_FuncA

!=============================================================
function GF_FuncB(tt)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	tt

! --- Local variables -------------------------------------
	REAL*8					::	B0,B1,B2,B3,B4
	REAL*8					::	B5,B6,B7,B8,B9
	REAL*8					::	GF_FuncB

	data	B0,B1,B2,B3,B4,B5,B6,B7,B8,B9			&
		/	+0.938D0,	+5.373D0,	-67.92D0,		&
			+796.534D0,	-4780.77D0,	+17137.74D0,	&
			-36618.81D0,+44894.06D0,-29030.24D0,	&
			+7671.22D0	/

	GF_FuncB	=	(B8+B9*tt)*tt
	GF_FuncB	=	(B7+GF_FuncB)*tt
	GF_FuncB	=	(B6+GF_FuncB)*tt
	GF_FuncB	=	(B5+GF_FuncB)*tt
	GF_FuncB	=	(B4+GF_FuncB)*tt
	GF_FuncB	=	(B3+GF_FuncB)*tt
	GF_FuncB	=	(B2+GF_FuncB)*tt
	GF_FuncB	=	(B1+GF_FuncB)*tt
	GF_FuncB	=	B0+GF_FuncB

	return
end function GF_FuncB

!=============================================================
function GF_FuncC(tt)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	tt

! --- Local variables -------------------------------------
	REAL*8					::	C0,C1,C2,C3,C4
	REAL*8					::	C5,C6,C7
	REAL*8					::	GF_FuncC

	data	C0,C1,C2,C3,C4,C5,C6,C7					&
		/	+1.268D0,	-9.747D0,	+209.653D0,		&
			-1397.89D0,	+5155.67D0,	-9844.35D0,		&
			+9136.4D0,	-3272.62D0		/

	GF_FuncC	=	(C6+C7*tt)*tt
	GF_FuncC	=	(C5+GF_FuncC)*tt
	GF_FuncC	=	(C4+GF_FuncC)*tt
	GF_FuncC	=	(C3+GF_FuncC)*tt
	GF_FuncC	=	(C2+GF_FuncC)*tt
	GF_FuncC	=	(C1+GF_FuncC)*tt
	GF_FuncC	=	C0+GF_FuncC

	return
end function GF_FuncC

!=============================================================
function GF_FuncD(tt)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	tt

! --- Local variables -------------------------------------
	REAL*8					::	D0,D1,D2,D3,D4
	REAL*8					::	D5,D6,D7,D8,D9
	REAL*8					::	GF_FuncD

	data	D0,D1,D2,D3,D4,D5,D6,D7,D8,D9			&
		/	+0.632D0,	-40.97D0,	+667.16D0,		&
			-6072.07D0,	+31127.39D0,-96293.05D0,	&
			+181856.75D0,			-205690.43D0,	&
			+128170.2D0,-33744.6D0	/

	GF_FuncD	=	(D8+D9*tt)*tt
	GF_FuncD	=	(D7+GF_FuncD)*tt
	GF_FuncD	=	(D6+GF_FuncD)*tt
	GF_FuncD	=	(D5+GF_FuncD)*tt
	GF_FuncD	=	(D4+GF_FuncD)*tt
	GF_FuncD	=	(D3+GF_FuncD)*tt
	GF_FuncD	=	(D2+GF_FuncD)*tt
	GF_FuncD	=	(D1+GF_FuncD)*tt
	GF_FuncD	=	D0+GF_FuncD

	return
end function GF_FuncD

!=============================================================
function GF_Func_Ls(hh,vv)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	hh,vv

! --- Local variables -------------------------------------
	REAL*8					::	PS,QS,Lsp
	REAL*8					::	GF_Func_Ls

	PS	=	(GF_beta+hh)/(GF_dd-vv)
	PS	=	PS-2.0D0*GF_beta+2.0D0*dexp(vv)*GF_dd-hh   ! the first equation in Eq.(27b) in [1]

	QS	=	dexp(-GF_dd)*(1.0D0-GF_beta)
	QS	=	QS*(1.0D0+GF_dd/(1.0D0+GF_dd**3))    ! the second equation in Eq.(27b) in [1]

	Lsp	=	GF_Func_Lsp(hh,vv)

	GF_Func_Ls	=	2.0D0*PS/(1.0D0+GF_dd**3)-4.0D0*QS+2.0D0*Lsp    ! Eq.(27a) in [1]

	return
end function GF_Func_Ls

!=============================================================
function GF_Func_Lsp(hh,vv)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	hh,vv

! --- Local variables -------------------------------------
	REAL*8					::	A,B,C,RR
	REAL*8					::	GF_Func_Lsp

	A	=	GF_dFuncA(GF_rho)   ! below: Eq.(34e) ~ (34g) in [1]
	B	=	GF_dFuncB(GF_rho)
	C	=	GF_dFuncC(GF_rho)

	RR	=	GF_beta*A           ! below: Eq (31b) in [1]
	RR	=	RR-(1.0D0-GF_alpha)*B
	RR	=	RR+GF_beta*(1.0D0-GF_beta)*GF_rho*(1.0D0-2.0D0*GF_rho)*C

	GF_Func_Lsp	=	GF_rho*(1.0D0-GF_rho)**3*RR      ! Eq.(31a) in [1]

	return
end function GF_Func_Lsp

!=============================================================
function GF_Func_Wh(hh,vv)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	hh,vv

! --- Local variables -------------------------------------
	REAL*8					::	H1,J1
	COMPLEX*16				::	GF_Func_Wh

	H1	=	StruveH1(hh)
	J1	=	BesselJ1(hh)

	GF_Func_Wh	=	2.0D0*pi*(2.0D0/pi-H1+Im*J1)*dexp(vv)
!	GF_Func_Wh	=	2.0D0*pi*(-H1+Im*J1)*dexp(vv)

	return
end function GF_Func_Wh

!=============================================================
function GF_dFuncA(tt)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	tt

! --- Local variables -------------------------------------
	REAL*8					::	A0,A1,A2,A3,A4
	REAL*8					::	A5,A6,A7,A8,A9
	REAL*8					::	GF_dFuncA

	data	A0,A1,A2,A3,A4,A5,A6,A7,A8,A9			&
		/	+2.948D0,	-24.53D0,	+249.69D0,		&
			-754.85D0,	-1187.71D0,	+16370.75D0,	&
			-48811.41D0,+68220.87D0,-46688.0D0,		&
			+12622.25D0	/

	GF_dFuncA	=	(A8+A9*tt)*tt
	GF_dFuncA	=	(A7+GF_dFuncA)*tt
	GF_dFuncA	=	(A6+GF_dFuncA)*tt
	GF_dFuncA	=	(A5+GF_dFuncA)*tt
	GF_dFuncA	=	(A4+GF_dFuncA)*tt
	GF_dFuncA	=	(A3+GF_dFuncA)*tt
	GF_dFuncA	=	(A2+GF_dFuncA)*tt
	GF_dFuncA	=	(A1+GF_dFuncA)*tt
	GF_dFuncA	=	A0+GF_dFuncA

	return
end function GF_dFuncA

!=============================================================
function GF_dFuncB(tt)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	tt

! --- Local variables -------------------------------------
	REAL*8					::	B0,B1,B2,B3,B4
	REAL*8					::	B5,B6,B7,B8,B9
	REAL*8					::	GF_dFuncB

	data	B0,B1,B2,B3,B4,B5,B6,B7,B8,B9			&
		/	+1.11D0,	+2.894D0,	-76.765D0,		&
			+1565.35D0,	-11336.19D0,+44270.15D0,	&
			-97014.11D0,+118879.26D0,-76209.82D0,	&
			+19923.28D0	/

	GF_dFuncB	=	(B8+B9*tt)*tt
	GF_dFuncB	=	(B7+GF_dFuncB)*tt
	GF_dFuncB	=	(B6+GF_dFuncB)*tt
	GF_dFuncB	=	(B5+GF_dFuncB)*tt
	GF_dFuncB	=	(B4+GF_dFuncB)*tt
	GF_dFuncB	=	(B3+GF_dFuncB)*tt
	GF_dFuncB	=	(B2+GF_dFuncB)*tt
	GF_dFuncB	=	(B1+GF_dFuncB)*tt
	GF_dFuncB	=	B0+GF_dFuncB

	return
end function GF_dFuncB

!=============================================================
function GF_dFuncC(tt)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	tt

! --- Local variables -------------------------------------
	REAL*8					::	C0,C1,C2,C3,C4,C5
	REAL*8					::	GF_dFuncC

	data	C0,C1,C2,C3,C4,C5						&
		/	+14.19D0,	-148.24D0,	+847.8D0,		&
			-2318.58D0,	+3168.35D0,	-1590.27D0		/

	GF_dFuncC	=	(C4+C5*tt)*tt
	GF_dFuncC	=	(C3+GF_dFuncC)*tt
	GF_dFuncC	=	(C2+GF_dFuncC)*tt
	GF_dFuncC	=	(C1+GF_dFuncC)*tt
	GF_dFuncC	=	C0+GF_dFuncC

	return
end function GF_dFuncC

!**************************************
function BesselJ0(xx)
!
	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	xx

! --- Local variables -------------------------------------
	REAL*8					::	yy,y2,f0,theta0
	REAL*8					::	BesselJ0
	REAL*8					::	P0,P1,P2,P3,P4,P5,P6
	REAL*8					::	R0,R1,R2,R3,R4,R5
	REAL*8					::  S1,S2,S3,S4,S5

	data	P0,P1,P2,P3,P4,P5,P6		&
		/	+0.999999999D0,	-2.249999879D0,	+1.265623060D0,	&
			-0.316394552D0,	+0.044460948D0,	-0.003954479D0,	&
			+0.000212950D0	/

	data	R0,R1,R2,R3,R4,R5			&
		/	+0.79788454D0,	-0.00553897D0,	+0.00099336D0,	&
			-0.00044346D0,	+0.00020445D0,	-0.00004959D0	/

	data	S1,S2,S3,S4,S5				&
		/	-0.04166592D0,	+0.00239399D0,	-0.00073984D0,	&
			+0.00031099D0,	-0.00007605D0	/

	if(xx <= 3.0D0) then
		yy	=	(xx/3.0D0)**2
		BesselJ0	=	 P0+(P1+(P2+(P3+(P4+(P5+P6*yy)*yy)*yy)*yy)*yy)*yy
	else
		yy	=	3.0D0/xx
		y2	=	yy**2

		f0			=	R0+(R1+(R2+(R3+(R4+R5*y2)*y2)*y2)*y2)*y2

		theta0		=	 xx	-	0.25D0*pi		&
						+(S1+(S2+(S3+(S4+S5*y2)*y2)*y2)*y2)*yy

		BesselJ0	=	f0*dcos(theta0)/dsqrt(xx)
	end if

	return
end function BesselJ0

!===============================================================
function BesselJ1(xx)
!
	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	xx

! --- Local variables -------------------------------------
	REAL*8					::	yy,y2,f1,theta1
	REAL*8					::	BesselJ1

	REAL*8					::	P0,P1,P2,P3,P4,P5,P6
	REAL*8					::	R0,R1,R2,R3,R4,R5
	REAL*8					::  S1,S2,S3,S4,S5

	data	P0,P1,P2,P3,P4,P5,P6		&
		/	+0.500000000D0,	-0.562499992D0,	+0.210937377D0,	&
			-0.039550040D0,	+0.004447331D0,	-0.000330547D0,	&
			+0.000015525D0	/

	data	R0,R1,R2,R3,R4,R5			&
		/	+0.79788459D0,	+0.01662008D0,	-0.00187002D0,	&
			+0.00068519D0,	-0.00029440D0,	+0.00006952D0	/

	data	S1,S2,S3,S4,S5				&
		/	+0.12499895D0,	-0.00605240D0,	+0.00135825D0,	&
			-0.00049616D0,	+0.00011531D0	/

	if(xx <= 3.0D0) then
		yy	=	xx/3.0D0
		y2	=	yy*yy
		BesselJ1	=	P0+(P1+(P2+(P3+(P4+(P5+P6*y2)*y2)*y2)*y2)*y2)*y2

		BesselJ1	=	BesselJ1*xx
	else
		yy	=	3.0D0/xx
		y2	=	yy*yy
		f1			=	R0+(R1+(R2+(R3+(R4+R5*y2)*y2)*y2)*y2)*y2

		theta1		=	 xx	-	0.75D0*pi		&
						+(S1+(S2+(S3+(S4+S5*y2)*y2)*y2)*y2)*yy

		BesselJ1	=	f1*dcos(theta1)/dsqrt(xx)
	end if

	return
end function BesselJ1

!===============================================================
function BesselY0(xx)
!
	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	xx

! --- Local variables -------------------------------------
	REAL*8					::	f0,theta0
	REAL*8					::	BesselY0

	if(xx <= 3.0D0) then
		BesselY0	=	(2.0D0/pi)*dlog(xx/2.0D0)*BesselJ0(xx)	&
						+0.367466907D0							&
						+0.605593797D0*(xx/3.0D0)**2			&
						-0.743505078D0*(xx/3.0D0)**4			&
						+0.253005481D0*(xx/3.0D0)**6			&
						-0.042619616D0*(xx/3.0D0)**8			&
						+0.004285691D0*(xx/3.0D0)**10			&
						-0.000250716D0*(xx/3.0D0)**12
	else
		f0			=	 0.79788454D0					&
						-0.00553897D0*(3.0D0/xx)**2		&
						+0.00099336D0*(3.0D0/xx)**4		&
						-0.00044346D0*(3.0D0/xx)**6		&
						+0.00020445D0*(3.0D0/xx)**8		&
						-0.00004959D0*(3.0D0/xx)**10

		theta0		=	 xx		-	0.25D0*pi			&
						-0.04166592D0*(3.0D0/xx)**1		&
						+0.00239399D0*(3.0D0/xx)**3		&
						-0.00073984D0*(3.0D0/xx)**5		&
						+0.00031099D0*(3.0D0/xx)**7		&
						-0.00007605D0*(3.0D0/xx)**9

		BesselY0	=	f0*dsin(theta0)/dsqrt(xx)

	end if

	return
end function BesselY0

!===============================================================
	function BesselY1(xx)
!
	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	xx

! --- Local variables -------------------------------------
	REAL*8					::	f1,theta1
	REAL*8					::	BesselY1

	if(xx <= 3.0D0) then
		BesselY1	=	(2.0D0/pi)*(dlog(xx/2.0D0)*BesselJ1(xx)-1.0D0/xx)	&
						+0.07373571D0*(xx/3.0D0)**1				&
						+0.72276433D0*(xx/3.0D0)**3				&
						-0.43885620D0*(xx/3.0D0)**5				&
						+0.10418264D0*(xx/3.0D0)**7				&
						-0.01340825D0*(xx/3.0D0)**9				&
						+0.00094249D0*(xx/3.0D0)**11
	else
		f1			=	 0.79788459D0						&
						+0.01662008D0*(3.0D0/xx)**2		&
						-0.00187002D0*(3.0D0/xx)**4		&
						+0.00068519D0*(3.0D0/xx)**6		&
						-0.00029440D0*(3.0D0/xx)**8		&
						+0.00006952D0*(3.0D0/xx)**10

		theta1		=	 xx		-	3.0D0*pi/4.0D0		&
						+0.12499895D0*(3.0D0/xx)**1		&
						-0.00605240D0*(3.0D0/xx)**3		&
						+0.00135825D0*(3.0D0/xx)**5		&
						-0.00049616D0*(3.0D0/xx)**7		&
						+0.00011531D0*(3.0D0/xx)**9

		BesselY1	=	f1*dsin(theta1)/dsqrt(xx)

	end if

	return
end function BesselY1

!===============================================================
function StruveH0(xx)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	xx

! --- Local variables -------------------------------------

	integer					::	ii
	REAL*8					::	P0,P1,P2
	REAL*8					::	P3,P4,P5
	REAL*8					::	a0,a1,a2,a3
	REAL*8					::	b1,b2,b3
	REAL*8					::	c1,c2
	REAL*8					::	yy,StruveH0

	if(xx <= 3.0D0) then

		yy	=	(xx/3.0D0)**2

		P0	=	+1.909859164D0
		P1	=	-1.909855001D0
		P2	=	+0.687514637D0
		P3	=	-0.126164557D0
 		P4	=	+0.013828813D0
		P5	=	-0.000876918D0

		StruveH0	=	P0+(P1+(P2+(P3+(P4+P5*yy)*yy)*yy)*yy)*yy

		StruveH0	=	StruveH0*(xx/3.0D0)

    else

		yy	=	(3.0D0/xx)**2

		a0	=	0.99999906D0
		a1	=	4.77228920D0
		a2	=	3.85542044D0
		a3	=	0.32303607D0

		b1	=	4.88331068D0
		b2	=	4.28957333D0
		b3	=	0.52120508D0

		c1	=	2.0D0*(a0	+	(a1+(a2+a3*yy)*yy)*yy)
		c2	=	pi*xx*(1.0D0+	(b1+(b2+b3*yy)*yy)*yy)

		StruveH0	=	c1/c2+	BesselY0(xx)

	end if

	return
end function StruveH0

!===============================================================
function StruveH1(xx)

	implicit none

! --- Variables -------------------------------------------
	REAL*8,intent(in)		::	xx

! --- Local variables -------------------------------------

	integer					::	ii
	REAL*8					::	P1,P2,P3
	REAL*8					::	P4,P5,P6
	REAL*8					::	a0,a1,a2,a3
	REAL*8					::	b1,b2,b3
	REAL*8					::	c1,c2,yy
	REAL*8					::	StruveH1

	if(xx <= 3.0D0) then

		yy	=	(xx/3.0D0)**2

		P1	=	+1.909859286D0
		P2	=	-1.145914713D0
		P3	=	+0.294656958D0
		P4	=	-0.042070508D0
 		P5	=	+0.003785727D0
		P6	=	-0.000207183D0

		StruveH1	=	(P1+(P2+(P3+(P4+(P5+P6*yy)*yy)*yy)*yy)*yy)*yy

    else

		yy	=	(3.0D0/xx)**2

		a0	=	1.00000004D0
		a1	=	3.92205313D0
		a2	=	2.64893033D0
		a3	=	0.27450895D0

		b1	=	3.81095112D0
		b2	=	2.26216956D0
		b3	=	0.10885141D0

		c1	=	2.0D0*(a0	+	(a1+(a2+a3*yy)*yy)*yy)
		c2	=	pi*(1.0D0	+	(b1+(b2+b3*yy)*yy)*yy)

		StruveH1	=	c1/c2	+	BesselY1(xx)

	end if

	return
end function StruveH1

end module INFG3D_Open


program test_minimization
use types, only: dp
use ofdft_fe, only: free_energy_min
use ofdft, only: read_pseudo
use constants, only: Ha2eV, pi
use utils, only: loadtxt, assert
use splines, only: spline3pars, iixmin, poly3
use interp3d, only: trilinear
use feutils, only: quad_gauss
implicit none
real(dp) :: Eh, Een, Ts, Exc, Etot
integer :: p, DOF !, Nx, Ny, Nz, u
real(dp) :: Z, Ediff
real(dp), allocatable :: R(:), V(:)
real(dp) :: Rcut, L, T_eV, T_au

!open(newunit=u, file="plots/Ven_reg128.txt", status="old")
!read(u, *) Nx, Ny, Nz
!allocate(values(Nx, Ny, Nz))
!read(u, *) values
!close(u)
!call read_pseudo("H.pseudo", R, V, Z, Ediff)
!V = -V
allocate(R(1), V(1)); Z=1; Ediff=0
!call loadtxt("Venr.txt", D)
!allocate(c(0:4, size(D, 1)-1))
!call spline3pars(D(:, 1), D(:, 2), [2, 2], [0._dp, 0._dp], c)
Rcut = R(size(R))
Rcut = 0.3_dp
p = 2
L = 2
T_eV = 0.0862_dp
T_au = T_ev / Ha2eV
call free_energy_min(1._dp, L, 2, 2, 2, p, T_au, nen, ne, &
    5, quad_gauss, 1e-9_dp, &
    Eh, Een, Ts, Exc, DOF)
Etot = Ts + Een + Eh + Exc
print *, "p =", p
print *, "DOF =", DOF
print *, "Rcut =", Rcut
print *, "T_au =", T_au
print *, "Summary of energies [a.u.]:"
print "('    Ts   = ', f14.8)", Ts
print "('    Een  = ', f14.8)", Een
print "('    Eee  = ', f14.8)", Eh
print "('    Exc  = ', f14.8)", Exc
print *, "   ---------------------"
print "('    Etot = ', f14.8, ' a.u. = ', f14.8, ' eV')", Etot, Etot*Ha2eV

! These values are specific to the given Nq, p, Nx, Ny, Nz above, and
! self-consistency 1e-9. The energy components (Ts, Een, Eh, Exc) have lower
! accuracy than the total energy.
call assert(abs(Ts-1.5262_dp) < 1e-4_dp)
call assert(abs(Een-(-1.4563_dp)) < 1e-4_dp)
call assert(abs(Eh-0.0981_dp) < 1e-4_dp)
call assert(abs(Exc-(-0.5481_dp)) < 1e-4_dp)
call assert(abs(Etot-(-0.38016292_dp)) < 1e-8_dp)

contains

real(dp) function nen(x, y, z_) result(n)
real(dp), intent(in) :: x, y, z_
real(dp), parameter :: alpha = 12
real(dp) :: r
r = sqrt((x-L/2)**2+(y-L/2)**2+(z_-L/2)**2)
! This density:
n = -Z*alpha**3/pi**(3._dp/2)*exp(-alpha**2*R**2)
! Corresponds to the potential:
!V = -Z*erf(alpha*R)/R
end function

real(dp) function ne(x, y, z) result(n)
real(dp), intent(in) :: x, y, z
real(dp), parameter :: alpha = 1, Z_ = 1
real(dp) :: r
r = sqrt((x-L/2)**2+(y-L/2)**2+(z-L/2)**2)
n = Z_*alpha**3/pi**(3._dp/2)*exp(-alpha**2*R**2)
n = 1
end function

end program