MODULE separable_leastsq
IMPLICIT NONE

! This is a conversion of the VARPRO package to F90 style.

! Code converted using TO_F90 by Alan Miller
! Date: 1999-03-15  Time: 11:15:27
! Latest version - 11 May 2001
! Changes from original:
! 1. Many variables needed to be saved in routine VPDPA.
! 2. A couple of arguments previously declared with INTENT(OUT) should
!    have been INTENT(IN OUT).

INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14, 60)

CONTAINS

SUBROUTINE varpro (l, nl, n, nmax, lpp2, iv, t, y, w, ada, a,  &
                   iprint, alf, beta, ierr)

!        GIVEN A SET OF N OBSERVATIONS, CONSISTING OF VALUES Y(1), Y(2), ...,
!     Y(N) OF A DEPENDENT VARIABLE Y, WHERE Y(I) CORRESPONDS TO THE IV
!     INDEPENDENT VARIABLE(S) T(I,1), T(I,2), ..., T(I,IV), VARPRO ATTEMPTS TO
!     COMPUTE A WEIGHTED LEAST SQUARES FIT TO A FUNCTION ETA (THE 'MODEL')
!     WHICH IS A LINEAR COMBINATION

!                           L
!    ETA(ALF, BETA; T)  =  SUM  BETA  * PHI (ALF; T) + PHI   (ALF; T)
!                          J=1      J      J              L+1

!     OF NONLINEAR FUNCTIONS PHI(J) (E.G., A SUM OF EXPONENTIALS AND/
!     OR GAUSSIANS).  THAT IS, DETERMINE THE LINEAR PARAMETERS
!     BETA(J) AND THE VECTOR OF NONLINEAR PARAMETERS ALF BY MINIMIZING

!                      2     N                                 2
!        NORM(RESIDUAL)  =  SUM  W  * (Y  - ETA(ALF, BETA; T )) .
!                           I=1   I     I                   I

!     THE (L+1)-ST TERM IS OPTIONAL, AND IS USED WHEN IT IS DESIRED
!     TO FIX ONE OR MORE OF THE BETA'S (RATHER THAN LET THEM BE
!     DETERMINED).  VARPRO REQUIRES FIRST DERIVATIVES OF THE PHI'S.

!                             NOTES:

!     A)  THE ABOVE PROBLEM IS ALSO REFERRED TO AS 'MULTIPLE NONLINEAR
!     REGRESSION'.  FOR USE IN STATISTICAL ESTIMATION, VARPRO RETURNS THE
!     RESIDUALS, THE COVARIANCE MATRIX OF THE LINEAR AND NONLINEAR PARAMETERS,
!     AND THE ESTIMATED VARIANCE OF THE OBSERVATIONS.

!     B) AN ETA OF THE ABOVE FORM IS CALLED 'SEPARABLE'.  THE CASE OF A
!     NONSEPARABLE ETA CAN BE HANDLED BY SETTING L = 0 AND USING PHI(L+1).

!     C) VARPRO MAY ALSO BE USED TO SOLVE LINEAR LEAST SQUARES PROBLEMS
!     (IN THAT CASE NO ITERATIONS ARE PERFORMED).  SET NL = 0.

!     D)  THE MAIN ADVANTAGE OF VARPRO OVER OTHER LEAST SQUARES PROGRAMS IS
!     THAT NO INITIAL GUESSES ARE NEEDED FOR THE LINEAR PARAMETERS.  NOT ONLY
!     DOES THIS MAKE IT EASIER TO USE, BUT IT OFTEN LEADS TO FASTER CONVERGENCE.

!  DESCRIPTION OF PARAMETERS

!     L       NUMBER OF LINEAR PARAMETERS BETA (MUST BE >= 0).
!     NL      NUMBER OF NONLINEAR PARAMETERS ALF (MUST BE >= 0).
!     N       NUMBER OF OBSERVATIONS.  N MUST BE GREATER THAN L + NL
!             (I.E., THE NUMBER OF OBSERVATIONS MUST EXCEED THE
!             NUMBER OF PARAMETERS).
!     IV      NUMBER OF INDEPENDENT VARIABLES T.
!     T       REAL N BY IV MATRIX OF INDEPENDENT VARIABLES.  T(I, J) CONTAINS
!             THE VALUE OF THE I-TH OBSERVATION OF THE J-TH INDEPENDENT
!             VARIABLE.
!     Y       N-VECTOR OF OBSERVATIONS, ONE FOR EACH ROW OF T.
!     W       N-VECTOR OF NONNEGATIVE WEIGHTS.  SHOULD BE SET TO 1'S IF WEIGHTS
!             ARE NOT DESIRED.  IF VARIANCES OF THE INDIVIDUAL OBSERVATIONS
!             ARE KNOWN, W(I) SHOULD BE SET TO 1./VARIANCE(I).
!     INC     NL X (L+1) INTEGER INCIDENCE MATRIX.  INC(K, J) = 1 IF
!             NON-LINEAR PARAMETER ALF(K) APPEARS IN THE J-TH
!             FUNCTION PHI(J).  (THE PROGRAM SETS ALL OTHER INC(K, J)
!             TO ZERO.)  IF PHI(L+1) IS INCLUDED IN THE MODEL,
!             THE APPROPRIATE ELEMENTS OF THE (L+1)-ST COLUMN SHOULD
!             BE SET TO 1'S.  INC IS NOT NEEDED WHEN L = 0 OR NL = 0.
!             CAUTION:  THE DECLARED ROW DIMENSION OF INC (IN ADA)
!             MUST CURRENTLY BE SET TO 12.  SEE 'RESTRICTIONS' BELOW.
!     NMAX    THE DECLARED ROW DIMENSION OF THE MATRICES A AND T.
!             IT MUST BE AT LEAST MAX(N, 2*NL+3).
!     LPP2    L+P+2, WHERE P IS THE NUMBER OF ONES IN THE MATRIX INC.
!             THE DECLARED COLUMN DIMENSION OF A MUST BE AT LEAST
!             LPP2.  (IF L = 0, SET LPP2 = NL+2. IF NL = 0, SET LPP2 L+2.)
!     A       REAL MATRIX OF SIZE MAX(N, 2*NL+3) BY L+P+2.  ON INPUT
!             IT CONTAINS THE PHI(J)'S AND THEIR DERIVATIVES (SEE
!             BELOW).  ON OUTPUT, THE FIRST L+NL ROWS AND COLUMNS OF
!             A WILL CONTAIN AN APPROXIMATION TO THE (WEIGHTED)
!             COVARIANCE MATRIX AT THE SOLUTION (THE FIRST L ROWS
!             CORRESPOND TO THE LINEAR PARAMETERS, THE LAST NL TO THE
!             NONLINEAR ONES), COLUMN L+NL+1 WILL CONTAIN THE
!             WEIGHTED RESIDUALS (Y - ETA), A(1, L+NL+2) WILL CONTAIN
!             THE (EUCLIDEAN) NORM OF THE WEIGHTED RESIDUAL, AND
!             A(2, L+NL+2) WILL CONTAIN AN ESTIMATE OF THE (WEIGHTED)
!             VARIANCE OF THE OBSERVATIONS, NORM(RESIDUAL)**2 / (N - L - NL).
!     IPRINT  INPUT INTEGER CONTROLLING PRINTED OUTPUT.  IF IPRINT IS
!             POSITIVE, THE NONLINEAR PARAMETERS, THE NORM OF THE
!             RESIDUAL, AND THE MARQUARDT PARAMETER WILL BE OUTPUT
!             EVERY IPRINT-TH ITERATION (AND INITIALLY, AND AT THE
!             FINAL ITERATION).  THE LINEAR PARAMETERS WILL BE
!             PRINTED AT THE FINAL ITERATION.  ANY ERROR MESSAGES
!             WILL ALSO BE PRINTED.  (IPRINT = 1 IS RECOMMENDED AT
!             FIRST.) IF IPRINT = 0, ONLY THE FINAL QUANTITIES WILL
!             BE PRINTED, AS WELL AS ANY ERROR MESSAGES.  IF IPRINT =
!             -1, NO PRINTING WILL BE DONE.  THE USER IS THEN
!             RESPONSIBLE FOR CHECKING THE PARAMETER IERR FOR ERRORS.
!     ALF     NL-VECTOR OF ESTIMATES OF NONLINEAR PARAMETERS
!             (INPUT).  ON OUTPUT IT WILL CONTAIN OPTIMAL VALUES OF
!             THE NONLINEAR PARAMETERS.
!     BETA    L-VECTOR OF LINEAR PARAMETERS (OUTPUT ONLY).
!     IERR    INTEGER ERROR FLAG (OUTPUT):
!             > 0 - SUCCESSFUL CONVERGENCE, IERR IS THE NUMBER OF ITERATIONS
!                 TAKEN.
!             -1  TERMINATED FOR TOO MANY ITERATIONS.
!             -2  TERMINATED FOR ILL-CONDITIONING (MARQUARDT
!                 PARAMETER TOO LARGE.)  ALSO SEE IERR = -8 BELOW.
!             -4  INPUT ERROR IN PARAMETER N, L, NL, LPP2, OR NMAX.
!             -5  INC MATRIX IMPROPERLY SPECIFIED, OR P DISAGREES WITH LPP2.
!             -6  A WEIGHT WAS NEGATIVE.
!             -7  'CONSTANT' COLUMN WAS COMPUTED MORE THAN ONCE.
!             -8  CATASTROPHIC FAILURE - A COLUMN OF THE A MATRIX HAS
!                 BECOME ZERO.  SEE 'CONVERGENCE FAILURES' BELOW.

!             (IF IERR .LE. -4, THE LINEAR PARAMETERS, COVARIANCE
!             MATRIX, ETC. ARE NOT RETURNED.)

!  SUBROUTINES REQUIRED

!        NINE SUBROUTINES, VPDPA, VPFAC1, VPFAC2, VPBSOL, VPPOST, VPCOV,
!     VPNORM, VPINIT, AND VPERR ARE PROVIDED.  IN ADDITION, THE USER MUST
!     PROVIDE A SUBROUTINE (CORRESPONDING TO THE ARGUMENT ADA) WHICH,
!     GIVEN ALF, WILL EVALUATE THE FUNCTIONS PHI(J) AND THEIR PARTIAL
!     DERIVATIVES D PHI(J)/D ALF(K), AT THE SAMPLE POINTS T(I).
!     ITS CALLING SEQUENCE IS

!     SUBROUTINE ADA (L+1, NL, N, NMAX, LPP2, IV, A, INC, T, ALF, ISEL)

!        THE USER SHOULD MODIFY THE EXAMPLE SUBROUTINE 'ADA' (GIVEN
!     ELSEWHERE) FOR HIS OWN FUNCTIONS.

!        THE VECTOR SAMPLED FUNCTIONS PHI(J) SHOULD BE STORED IN THE
!     FIRST N ROWS AND FIRST L+1 COLUMNS OF THE MATRIX A, I.E.,
!     A(I, J) SHOULD CONTAIN PHI(J, ALF; T(I,1), T(I,2), ...,
!     T(I,IV)), I = 1, ..., N; J = 1, ..., L (OR L+1).  THE (L+1)-ST
!     COLUMN OF A CONTAINS PHI(L+1) IF PHI(L+1) IS IN THE MODEL,
!     OTHERWISE IT IS RESERVED FOR WORKSPACE.  THE 'CONSTANT' FUNC-
!     TIONS (THESE ARE FUNCTIONS PHI(J) WHICH DO NOT DEPEND UPON ANY
!     NONLINEAR PARAMETERS ALF, E.G., T(I)**J) (IF ANY) MUST APPEAR
!     FIRST, STARTING IN COLUMN 1.  THE COLUMN N-VECTORS OF NONZERO
!     PARTIAL DERIVATIVES D PHI(J) / D ALF(K) SHOULD BE STORED
!     SEQUENTIALLY IN THE MATRIX A IN COLUMNS L+2 THROUGH L+P+1.
!     THE ORDER IS

!       D PHI(1)  D PHI(2)        D PHI(L)  D PHI(L+1)  D PHI(1)
!       --------, --------, ...,  --------, ----------, --------,
!       D ALF(1)  D ALF(1)        D ALF(1)   D ALF(1)   D ALF(2)

!       D PHI(2)       D PHI(L+1)       D PHI(1)        D PHI(L+1)
!       --------, ..., ----------, ..., ---------, ..., ----------,
!       D ALF(2)        D ALF(2)        D ALF(NL)       D ALF(NL)

!     OMITTING COLUMNS OF DERIVATIVES WHICH ARE ZERO, AND OMITTING
!     PHI(L+1) COLUMNS IF PHI(L+1) IS NOT IN THE MODEL.  NOTE THAT
!     THE LINEAR PARAMETERS BETA ARE NOT USED IN THE MATRIX A.
!     COLUMN L+P+2 IS RESERVED FOR WORKSPACE.

!     THE CODING OF ADA SHOULD BE ARRANGED SO THAT:

!     ISEL = 1  (WHICH OCCURS THE FIRST TIME ADA IS CALLED) MEANS:
!               A.  FILL IN THE INCIDENCE MATRIX INC
!               B.  STORE ANY CONSTANT PHI'S IN A.
!               C.  COMPUTE NONCONSTANT PHI'S AND PARTIAL DERIVATIVES.
!          = 2  MEANS COMPUTE ONLY THE NONCONSTANT FUNCTIONS PHI
!          = 3  MEANS COMPUTE ONLY THE DERIVATIVES

!     (WHEN THE PROBLEM IS LINEAR (NL = 0) ONLY ISEL = 1 IS USED, AND
!     DERIVATIVES ARE NOT NEEDED.)

!  RESTRICTIONS

!        THE SUBROUTINES VPDPA, VPINIT (AND ADA) CONTAIN THE LOCALLY
!     DIMENSIONED MATRIX INC, WHOSE DIMENSIONS ARE CURRENTLY SET FOR
!     MAXIMA OF L+1 = 8, NL = 12.  THEY MUST BE CHANGED FOR LARGER
!     PROBLEMS.  DATA PLACED IN ARRAY A IS OVERWRITTEN ('DESTROYED').
!     DATA PLACED IN ARRAYS T, Y AND INC IS LEFT INTACT.  THE PROGRAM
!     RUNS IN WATFIV, EXCEPT WHEN L = 0 OR NL = 0.

!        IT IS ASSUMED THAT THE MATRIX PHI(J, ALF; T(I)) HAS FULL
!     COLUMN RANK.  THIS MEANS THAT THE FIRST L COLUMNS OF THE MATRIX
!     A MUST BE LINEARLY INDEPENDENT.

!        OPTIONAL NOTE:  AS WILL BE NOTED FROM THE SAMPLE SUBPROGRAM ADA,
!     THE DERIVATIVES D PHI(J)/D ALF(K) (ISEL = 3) MUST BE COMPUTED
!     INDEPENDENTLY OF THE FUNCTIONS PHI(J) (ISEL = 2), SINCE THE FUNCTION
!     VALUES ARE OVERWRITTEN AFTER ADA IS CALLED WITH ISEL = 2.
!     THIS IS DONE TO MINIMIZE STORAGE, AT THE POSSIBLE EXPENSE OF SOME
!     RECOMPUTATION (SINCE THE FUNCTIONS AND DERIVATIVES FREQUENTLY HAVE SOME
!     COMMON SUBEXPRESSIONS).  TO REDUCE THE AMOUNT OF COMPUTATION AT THE
!     EXPENSE OF SOME STORAGE, CREATE A MATRIX B OF DIMENSION NMAX BY L+1
!     IN ADA, AND AFTER THE COMPUTATION OF THE PHI'S (ISEL = 2), COPY THE
!     VALUES INTO B.  THESE VALUES CAN THEN BE USED TO CALCULATE THE
!     DERIVATIVES (ISEL = 3).  (THIS MAKES USE OF THE FACT THAT WHEN A CALL TO
!     ADA WITH ISEL = 3 FOLLOWS A CALL WITH ISEL = 2, THE ALFS ARE THE SAME.)

!        TO CONVERT TO OTHER MACHINES, CHANGE THE OUTPUT UNIT IN THE
!     DATA STATEMENTS IN VARPRO, VPDPA, VPPOST, AND VPERR.  THE
!     PROGRAM HAS BEEN CHECKED FOR PORTABILITY BY THE BELL LABS PFORT
!     VERIFIER.  FOR MACHINES WITHOUT DOUBLE PRECISION HARDWARE, IT
!     MAY BE DESIRABLE TO CONVERT TO SINGLE PRECISION.  THIS CAN BE
!     DONE BY CHANGING (A) THE DECLARATIONS 'DOUBLE PRECISION' TO
!     'REAL', (B) THE PATTERN '.D' TO '.E' IN THE 'DATA' STATEMENT IN
!     VARPRO, (C) DSIGN, SQRT AND ABS TO SIGN, SQRT AND ABS,
!     RESPECTIVELY, AND (D) DEXP TO EXP IN THE SAMPLE PROGRAMS ONLY.

!  NOTE ON INTERPRETATION OF COVARIANCE MATRIX

!        FOR USE IN STATISTICAL ESTIMATION (MULTIPLE NONLINEAR REGRESSION)
!     VARPRO RETURNS THE COVARIANCE MATRIX OF THE LINEAR AND NONLINEAR
!     PARAMETERS.  THIS MATRIX WILL BE USEFUL ONLY IF THE USUAL STATISTICAL
!     ASSUMPTIONS HOLD:  AFTER WEIGHTING, THE ERRORS IN THE OBSERVATIONS ARE
!     INDEPENDENT AND NORMALLY DISTRIBUTED, WITH MEAN ZERO AND THE SAME
!     VARIANCE.  IF THE ERRORS DO NOT HAVE MEAN ZERO (OR ARE UNKNOWN), THE
!     PROGRAM WILL ISSUE A WARNING MESSAGE (UNLESS IPRINT .LT. 0) AND THE
!     COVARIANCE MATRIX WILL NOT BE VALID.  IN THAT CASE, THE MODEL SHOULD BE
!     ALTERED TO INCLUDE A CONSTANT TERM (SET PHI(1) = 1.).

!        NOTE ALSO THAT, IN ORDER FOR THE USUAL ASSUMPTIONS TO HOLD,
!     THE OBSERVATIONS MUST ALL BE OF APPROXIMATELY THE SAME MAGNITUDE
!     (IN THE ABSENCE OF INFORMATION ABOUT THE ERROR OF EACH OBSERVATION),
!     OTHERWISE THE VARIANCES WILL NOT BE THE SAME.  IF THE OBSERVATIONS ARE
!     NOT THE SAME SIZE, THIS CAN BE CURED BY WEIGHTING.

!        IF THE USUAL ASSUMPTIONS HOLD, THE SQUARE ROOTS OF THE DIAGONALS OF
!     THE COVARIANCE MATRIX A GIVE THE STANDARD ERROR S(I) OF EACH PARAMETER.
!     DIVIDING A(I,J) BY S(I)*S(J) YIELDS THE CORRELATION MATRIX OF THE
!     PARAMETERS.  PRINCIPAL AXES AND CONFIDENCE ELLIPSOIDS CAN BE OBTAINED BY
!     PERFORMING AN EIGENVALUE/EIGENVECTOR ANALYSIS ON A.  ONE SHOULD CALL THE
!     EISPACK PROGRAM TRED2, FOLLOWED BY TQL2 (OR USE THE EISPAC CONTROL
!     PROGRAM).

!  CONVERGENCE FAILURES

!        IF CONVERGENCE FAILURES OCCUR, FIRST CHECK FOR INCORRECT
!     CODING OF THE SUBROUTINE ADA.  CHECK ESPECIALLY THE ACTION OF
!     ISEL, AND THE COMPUTATION OF THE PARTIAL DERIVATIVES.  IF THESE
!     ARE CORRECT, TRY SEVERAL STARTING GUESSES FOR ALF.  IF ADA
!     IS CODED CORRECTLY, AND IF ERROR RETURNS IERR = -2 OR -8
!     PERSISTENTLY OCCUR, THIS IS A SIGN OF ILL-CONDITIONING, WHICH
!     MAY BE CAUSED BY SEVERAL THINGS.  ONE IS POOR SCALING OF THE
!     PARAMETERS; ANOTHER IS AN UNFORTUNATE INITIAL GUESS FOR THE
!     PARAMETERS, STILL ANOTHER IS A POOR CHOICE OF THE MODEL.

!  ALGORITHM

!        THE RESIDUAL R IS MODIFIED TO INCORPORATE, FOR ANY FIXED ALF, THE
!     OPTIMAL LINEAR PARAMETERS FOR THAT ALF.  IT IS THEN POSSIBLE TO MINIMIZE
!     ONLY ON THE NONLINEAR PARAMETERS.  AFTER THE OPTIMAL VALUES OF THE
!     NONLINEAR PARAMETERS HAVE BEEN DETERMINED, THE LINEAR PARAMETERS CAN BE
!     RECOVERED BY LINEAR LEAST SQUARES TECHNIQUES (SEE REF. 1).

!        THE MINIMIZATION IS BY A MODIFICATION OF OSBORNE'S (REF. 3)
!     MODIFICATION OF THE LEVENBERG-MARQUARDT ALGORITHM.  INSTEAD OF
!     SOLVING THE NORMAL EQUATIONS WITH MATRIX

!              T      2
!            (J J + NU  * D),      WHERE  J = D(ETA)/D(ALF),

!     STABLE ORTHOGONAL (HOUSEHOLDER) REFLECTIONS ARE USED ON A
!     MODIFICATION OF THE MATRIX
!                                (   J  )
!                                (------) ,
!                                ( NU*D )

!     WHERE D IS A DIAGONAL MATRIX CONSISTING OF THE LENGTHS OF THE
!     COLUMNS OF J.  THIS MARQUARDT STABILIZATION ALLOWS THE ROUTINE
!     TO RECOVER FROM SOME RANK DEFICIENCIES IN THE JACOBIAN.
!     OSBORNE'S EMPIRICAL STRATEGY FOR CHOOSING THE MARQUARDT PARAM-
!     ETER HAS PROVEN REASONABLY SUCCESSFUL IN PRACTICE.  (GAUSS-
!     NEWTON WITH STEP CONTROL CAN BE OBTAINED BY MAKING THE CHANGE
!     INDICATED BEFORE THE INSTRUCTION LABELED 5).  A DESCRIPTION CAN
!     BE FOUND IN REF. (3), AND A FLOW CHART IN (2), P. 22.

!     FOR REFERENCE, SEE

!     1.  GENE H. GOLUB AND V. PEREYRA, 'THE DIFFERENTIATION OF
!         PSEUDO-INVERSES AND NONLINEAR LEAST SQUARES PROBLEMS WHOSE
!         VARIABLES SEPARATE,' SIAM J. NUMER. ANAL. 10, 413-432 (1973).
!     2.  ------, SAME TITLE, STANFORD C.S. REPORT 72-261, FEB. 1972.
!     3.  OSBORNE, MICHAEL R., 'SOME ASPECTS OF NON-LINEAR LEAST
!         SQUARES CALCULATIONS,' IN LOOTSMA, ED., 'NUMERICAL METHODS
!         FOR NON-LINEAR OPTIMIZATION,' ACADEMIC PRESS, LONDON, 1972.
!     4.  KROGH, FRED, 'EFFICIENT IMPLEMENTATION OF A VARIABLE PROJECTION
!         ALGORITHM FOR NONLINEAR LEAST SQUARES PROBLEMS,'
!         COMM. ACM 17, PP. 167-169 (MARCH, 1974).
!     5.  KAUFMAN, LINDA, 'A VARIABLE PROJECTION METHOD FOR SOLVING SEPARABLE
!         NONLINEAR LEAST SQUARES PROBLEMS', B.I.T. 15, 49-57 (1975).
!     6.  DRAPER, N., AND SMITH, H., APPLIED REGRESSION ANALYSIS,
!         WILEY, N.Y., 1966 (FOR STATISTICAL INFORMATION ONLY).
!     7.  C. LAWSON AND R. HANSON, SOLVING LEAST SQUARES PROBLEMS,
!         PRENTICE-HALL, ENGLEWOOD CLIFFS, N. J., 1974.

!                   JOHN BOLSTAD
!                   COMPUTER SCIENCE DEPT., SERRA HOUSE
!                   STANFORD UNIVERSITY
!                   JANUARY, 1977

!     ..................................................................

INTEGER, INTENT(IN)        :: l
INTEGER, INTENT(IN)        :: nl
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: nmax
INTEGER, INTENT(IN)        :: lpp2
INTEGER, INTENT(IN)        :: iv
REAL (dp), INTENT(IN)      :: t(:,:)       ! t(nmax,iv)
REAL (dp), INTENT(IN)      :: y(:)
REAL (dp), INTENT(IN OUT)  :: w(:)
REAL (dp), INTENT(OUT)     :: a(:,:)       ! a(nmax,lpp2)
INTEGER, INTENT(IN)        :: iprint
REAL (dp), INTENT(IN OUT)  :: alf(:)       ! alf(nl)
REAL (dp), INTENT(IN OUT)  :: beta(:)
INTEGER, INTENT(OUT)       :: ierr

! Local variables

REAL (dp) :: acum, gnstep, nu, prjres, r, rnew
INTEGER   :: b1, isel, isub, iter, iterin, j, jsub, k, ksub, lnl2, lp1,  &
             modit, nlp1
LOGICAL   :: skip

INTERFACE
  SUBROUTINE ada (lp1, nl, n, nmax, lpp2, iv, a, inc, t, alf, isel)
    IMPLICIT NONE
    INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14, 60)
    INTEGER, INTENT(IN)     :: lp1
    INTEGER, INTENT(IN)     :: nl
    INTEGER, INTENT(IN)     :: n
    INTEGER, INTENT(IN)     :: nmax
    INTEGER, INTENT(IN)     :: lpp2
    INTEGER, INTENT(IN)     :: iv
    REAL (dp), INTENT(OUT)  :: a(:,:)
    INTEGER, INTENT(OUT)    :: inc(:,:)
    REAL (dp), INTENT(IN)   :: t(:,:)
    REAL (dp), INTENT(IN)   :: alf(:)
    INTEGER, INTENT(IN)     :: isel
  END SUBROUTINE ada
END INTERFACE

!     THE FOLLOWING TWO PARAMETERS ARE USED IN THE CONVERGENCE TEST:
!     EPS1 IS AN ABSOLUTE AND RELATIVE TOLERANCE FOR THE NORM OF THE PROJECTION
!     OF THE RESIDUAL ONTO THE RANGE OF THE JACOBIAN OF THE VARIABLE PROJECTION
!     FUNCTIONAL.
!     ITMAX IS THE MAXIMUM NUMBER OF FUNCTION AND DERIVATIVE EVALUATIONS
!     ALLOWED.
!     CAUTION:  EPS1 MUST NOT BE < 10 TIMES THE UNIT ROUND-OFF OF THE MACHINE.

REAL (dp), PARAMETER :: eps1 = 100._dp * EPSILON(1.0_dp)
INTEGER, PARAMETER   :: itmax = 50, output = 6

!-----------------------------------------------------------------
! CALL LIB MONITOR FROM VARPRO, MAINTENANCE NUMBER 509, DATE 77178
!        CALL LIBMON(509)
!***PLEASE DON'T REMOVE OR CHANGE THE ABOVE CALL. IT IS YOUR ONLY
!***PROTECTION AGAINST YOUR USING AN OUT-OF-DATE OR INCORRECT
!***VERSION OF THE ROUTINE. THE LIBRARY MONITOR REMOVES THIS CALL,
!***SO IT ONLY OCCURS ONCE, ON THE FIRST ENTRY TO THIS ROUTINE.
!-----------------------------------------------------------------
ierr = 1
iter = 0
lp1 = l + 1
b1 = l + 2
lnl2 = l + nl + 2
nlp1 = nl + 1
skip = .false.
modit = iprint
IF (iprint <= 0) modit = itmax + 2
nu = 0.
!              IF GAUSS-NEWTON IS DESIRED REMOVE THE NEXT STATEMENT.
nu = 1.

!              BEGIN OUTER ITERATION LOOP TO UPDATE ALF.
!              CALCULATE THE NORM OF THE RESIDUAL AND THE DERIVATIVE OF
!              THE MODIFIED RESIDUAL THE FIRST TIME, BUT ONLY THE
!              DERIVATIVE IN SUBSEQUENT ITERATIONS.

10 CALL vpdpa (l, nl, n, nmax, lpp2, iv, t, y, w, alf, ada, ierr,  &
               iprint, a, beta, a(:,lp1), r)
gnstep = 1.0
iterin = 0
IF (iter > 0) GO TO 20
IF (nl == 0) GO TO 160
IF (ierr /= 1) GO TO 180

IF (iprint <= 0) GO TO 20
WRITE (output,220) iterin,r
WRITE (output,190) nu
!                              BEGIN TWO-STAGE ORTHOGONAL FACTORIZATION
20 CALL vpfac1 (nlp1, n, l, iprint, a(:,b1:), prjres, ierr)
IF (ierr < 0) GO TO 180
ierr = 2
IF (nu == 0.) GO TO 40

!              BEGIN INNER ITERATION LOOP FOR GENERATING NEW ALF AND
!              TESTING IT FOR ACCEPTANCE.

30 CALL vpfac2 (nlp1, nu, a(:,b1:))

!              SOLVE A NL X NL UPPER TRIANGULAR SYSTEM FOR DELTA-ALF.
!              THE TRANSFORMED RESIDUAL (IN COL. LNL2 OF A) IS OVER-
!              WRITTEN BY THE RESULT DELTA-ALF.

40 CALL vpbsol (nl, a(:,b1:), a(:,lnl2))
a(1:nl,b1) = alf(1:nl) + a(1:nl,lnl2)
!           NEW ALF(K) = ALF(K) + DELTA ALF(K)

!              STEP TO THE NEW POINT NEW ALF, AND COMPUTE THE NEW
!              NORM OF RESIDUAL.  NEW ALF IS STORED IN COLUMN B1 OF A.

60 CALL vpdpa (l, nl, n, nmax, lpp2, iv, t, y, w, a(:,b1), ada, ierr,  &
               iprint, a, beta, a(:,lp1), rnew)
IF (ierr /= 2) GO TO 180
iter = iter + 1
iterin = iterin + 1
skip = MOD(iter,modit) /= 0
IF (skip) GO TO 70
WRITE (output,200) iter
WRITE (output,240) a(1:nl,b1)
WRITE (output,220) iterin, rnew

70 IF (iter < itmax) GO TO 80
ierr = -1
CALL vperr (iprint, ierr, 1)

! 1000       FORMAT(15X,'IERR AT 45 =',I7)
GO TO 170
80 IF (rnew-r < eps1*(r+1.0_dp)) GO TO 130

!              RETRACT THE STEP JUST TAKEN

IF (nu /= 0.) GO TO 100
!                                             GAUSS-NEWTON OPTION ONLY
gnstep = 0.5*gnstep
IF (gnstep < eps1) GO TO 170
DO  k=1,nl
  a(k,b1) = alf(k) + gnstep*a(k,lnl2)
END DO
GO TO 60
!                                        ENLARGE THE MARQUARDT PARAMETER
100 nu = 1.5*nu
IF (.NOT.skip) WRITE (output,210) nu
IF (nu <= 100.) GO TO 110
ierr = -2
CALL vperr (iprint, ierr, 1)
!       WRITE(6,1000)IERR
! 1000  FORMAT(15X,'IERR AT 60 =',I7)

GO TO 170
!                                        RETRIEVE UPPER TRIANGULAR FORM
!                                        AND RESIDUAL OF FIRST STAGE.
110 DO  k=1,nl
  ksub = lp1 + k
  DO  j=k,nlp1
    jsub = lp1 + j
    isub = nlp1 + j
    a(k,jsub) = a(isub,ksub)
  END DO
END DO
GO TO 30
!                                        END OF INNER ITERATION LOOP
!           ACCEPT THE STEP JUST TAKEN

130 r = rnew
DO  k=1,nl
  alf(k) = a(k,b1)
END DO
!                                        CALC. NORM(DELTA ALF)/NORM(ALF)
acum = gnstep*vpnorm(nl,a(:,lnl2)) / vpnorm(nl,alf)

!           IF ITERIN IS > 1, A STEP WAS RETRACTED DURING THIS OUTER ITERATION.

IF (iterin == 1) nu = 0.5*nu
IF (skip) GO TO 150
WRITE (output,190) nu
WRITE (output,230) acum
150 ierr = 3
IF (prjres > eps1*(r+1.0_dp)) GO TO 10
!           END OF OUTER ITERATION LOOP

!           CALCULATE FINAL QUANTITIES -- LINEAR PARAMETERS, RESIDUALS,
!           COVARIANCE MATRIX, ETC.

160 ierr = iter
170 IF (nl > 0) THEN
  isel = 4
  CALL vpdpa (l, nl, n, nmax, lpp2, iv, t, y, w, alf, ada, isel, iprint, a,  &
              beta, a(:,lp1), r)
END IF
CALL vppost (l, nl, n, lnl2, eps1, r, iprint, alf, w, a, a(:,lp1), beta)
180 RETURN

190 FORMAT ('     NU =',e15.7)
200 FORMAT ('0  ITERATION',i4,'    NONLINEAR PARAMETERS')
210 FORMAT ('     STEP RETRACTED, NU =',e15.7)
220 FORMAT ('0',i5,'  NORM OF RESIDUAL =',e15.7)
230 FORMAT ('     NORM(DELTA-ALF) / NORM(ALF) =',e12.3)
240 FORMAT ('0',7E15.7)
END SUBROUTINE varpro

SUBROUTINE vpfac1 (nlp1, n, l, iprint, b, prjres, ierr)

!            STAGE 1:  HOUSEHOLDER REDUCTION OF

!                   (    .    )      ( DR'. R3 )    NL
!                   ( DR . R2 )  TO  (----. -- ),
!                   (    .    )      (  0 . R4 )  N-L-NL

!                     NL    1          NL   1

!         WHERE DR = -D(Q2)*Y IS THE DERIVATIVE OF THE MODIFIED RESIDUAL
!         PRODUCED BY VPDPA, R2 IS THE TRANSFORMED RESIDUAL FROM DPA,
!         AND DR' IS IN UPPER TRIANGULAR FORM (AS IN REF. (2), P. 18).
!         DR IS STORED IN ROWS L+1 TO N AND COLUMNS L+2 TO L + NL + 1 OF
!         THE MATRIX A (I.E., COLUMNS 1 TO NL OF THE MATRIX B).  R2 IS
!         STORED IN COLUMN L + NL + 2 OF THE MATRIX A (COLUMN NL + 1 OF
!         B).  FOR K = 1, 2, ..., NL, FIND REFLECTION I - U * U' / BETA
!         WHICH ZEROES B(I, K), I = L+K+1, ..., N.

!     ..................................................................

INTEGER, INTENT(IN)        :: nlp1
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: l
INTEGER, INTENT(IN)        :: iprint
REAL (dp), INTENT(IN OUT)  :: b(:,:)     ! b(nmax,nlp1)
REAL (dp), INTENT(OUT)     :: prjres
INTEGER, INTENT(IN OUT)    :: ierr

! Local variables

REAL (dp) :: acum, alpha, beta, u
INTEGER   :: i, j, jsub, k, kp1, lp1, lpk, nl, nl23

nl = nlp1 - 1
nl23 = 2*nl + 3
lp1 = l + 1

DO  k=1,nl
  lpk = l + k
  alpha = SIGN(vpnorm(n+1-lpk, b(lpk:,k)), b(lpk,k))
  u = b(lpk,k) + alpha
  b(lpk,k) = u
  beta = alpha*u
  IF (alpha /= 0.0_dp) GO TO 10
!                                                   COLUMN WAS ZERO
  ierr = -8
  CALL vperr (iprint, ierr, lp1+k)
  GO TO 70
!                                APPLY REFLECTIONS TO REMAINING COLUMNS
!                                OF B AND TO RESIDUAL VECTOR.
  10 kp1 = k+1
  DO  j = kp1,nlp1
    acum = DOT_PRODUCT( b(lpk:n,k), b(lpk:n,j) )
    acum = acum/beta
    DO  i=lpk,n
      b(i,j) = b(i,j) - b(i,k)*acum
    END DO
  END DO
  b(lpk,k) = -alpha
END DO

prjres = vpnorm(nl, b(lp1:,nlp1))

!           SAVE UPPER TRIANGULAR FORM AND TRANSFORMED RESIDUAL, FOR USE
!           IN CASE A STEP IS RETRACTED.  ALSO COMPUTE COLUMN LENGTHS.

IF (ierr == 4) GO TO 70
DO  k=1,nl
  lpk = l + k
  DO  j=k,nlp1
    jsub = nlp1 + j
    b(k,j) = b(lpk,j)
    b(jsub,k) = b(lpk,j)
  END DO
  b(nl23,k) = vpnorm(k, b(lp1:,k))
END DO

70 RETURN
END SUBROUTINE vpfac1

SUBROUTINE vpfac2 (nlp1, nu, b)

!        STAGE 2:  SPECIAL HOUSEHOLDER REDUCTION OF

!                      NL     ( DR' . R3 )      (DR'' . R5 )
!                             (-----. -- )      (-----. -- )
!                  N-L-NL     (  0  . R4 )  TO  (  0  . R4 )
!                             (-----. -- )      (-----. -- )
!                      NL     (NU*D . 0  )      (  0  . R6 )

!                                NL    1          NL    1

!        WHERE DR', R3, AND R4 ARE AS IN VPFAC1, NU IS THE MARQUARDT
!        PARAMETER, D IS A DIAGONAL MATRIX CONSISTING OF THE LENGTHS OF
!        THE COLUMNS OF DR', AND DR'' IS IN UPPER TRIANGULAR FORM.
!        DETAILS IN (1), PP. 423-424.  NOTE THAT THE (N-L-NL) BAND OF
!        ZEROES, AND R4, ARE OMITTED IN STORAGE.

!     ..................................................................

INTEGER, INTENT(IN)     :: nlp1
REAL (dp), INTENT(IN)   :: nu
REAL (dp), INTENT(OUT)  :: b(:,:)     ! b(nmax,nlp1)

! Local variables

REAL (dp) :: acum, alpha, beta, u
INTEGER   :: i, j, k, kp1, nl, nl2, nl23, nlpk, nlpkm1

nl = nlp1 - 1
nl2 = 2*nl
nl23 = nl2 + 3
DO  k=1,nl
  kp1 = k + 1
  nlpk = nl + k
  nlpkm1 = nlpk - 1
  b(nlpk,k) = nu*b(nl23,k)
  b(nl,k) = b(k,k)
  alpha = SIGN(vpnorm(k+1, b(nl:,k)), b(k,k))
  u = b(k,k) + alpha
  beta = alpha*u
  b(k,k) = -alpha
!                        THE K-TH REFLECTION MODIFIES ONLY ROWS K,
!                        NL+1, NL+2, ..., NL+K, AND COLUMNS K TO NL+1.
  DO  j=kp1,nlp1
    b(nlpk,j) = 0.0_dp
    acum = u*b(k,j)
    DO  i=nlp1,nlpkm1
      acum = acum + b(i,k)*b(i,j)
    END DO
    acum = acum/beta
    b(k,j) = b(k,j) - u*acum
    DO  i=nlp1,nlpk
      b(i,j) = b(i,j) - b(i,k)*acum
    END DO
  END DO
END DO

RETURN
END SUBROUTINE vpfac2

SUBROUTINE vpdpa (l, nl, n, nmax, lpp2, iv, t, y, w, alf, ada,  &
                  isel, iprint, a, u, r, rnorm)

!        COMPUTE THE NORM OF THE RESIDUAL (IF ISEL = 1 OR 2), OR THE
!        (N-L) X NL DERIVATIVE OF THE MODIFIED RESIDUAL (N-L) VECTOR
!        Q2*Y (IF ISEL = 1 OR 3).  HERE Q * PHI = S, I.E.,

!         L     ( Q1 ) (     .   .        )   ( S  . R1 .  F1  )
!               (----) ( PHI . Y . D(PHI) ) = (--- . -- . ---- )
!         N-L   ( Q2 ) (     .   .        )   ( 0  . R2 .  F2  )

!                 N       L    1      P         L     1     P

!        WHERE Q IS N X N ORTHOGONAL, AND S IS L X L UPPER TRIANGULAR.
!        THE NORM OF THE RESIDUAL = NORM(R2), AND THE DESIRED DERIVATIVE
!        ACCORDING TO REF. (5), IS
!                                               -1
!                    D(Q2 * Y) = -Q2 * D(PHI)* S  * Q1* Y.

!     ..................................................................

INTEGER, INTENT(IN)        :: l
INTEGER, INTENT(IN)        :: nl
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: nmax
INTEGER, INTENT(IN)        :: lpp2
INTEGER, INTENT(IN)        :: iv
REAL (dp), INTENT(IN)      :: t(:,:)    ! t(nmax,iv)
REAL (dp), INTENT(IN)      :: y(:)
REAL (dp), INTENT(IN OUT)  :: w(:)
REAL (dp), INTENT(IN OUT)  :: alf(:)
INTEGER, INTENT(IN OUT)    :: isel
INTEGER, INTENT(IN)        :: iprint
REAL (dp), INTENT(OUT)     :: a(:,:)    ! a(nmax,lpp2)
REAL (dp), INTENT(IN OUT)  :: u(:)
REAL (dp), INTENT(OUT)     :: r(:)
REAL (dp), INTENT(OUT)     :: rnorm

INTERFACE
  SUBROUTINE ada (lp1, nl, n, nmax, lpp2, iv, a, inc, t, alf, isel)
    IMPLICIT NONE
    INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14, 60)
    INTEGER, INTENT(IN)     :: lp1
    INTEGER, INTENT(IN)     :: nl
    INTEGER, INTENT(IN)     :: n
    INTEGER, INTENT(IN)     :: nmax
    INTEGER, INTENT(IN)     :: lpp2
    INTEGER, INTENT(IN)     :: iv
    REAL (dp), INTENT(OUT)  :: a(:,:)
    INTEGER, INTENT(OUT)    :: inc(:,:)
    REAL (dp), INTENT(IN)   :: t(:,:)
    REAL (dp), INTENT(IN)   :: alf(:)
    INTEGER, INTENT(IN)     :: isel
  END SUBROUTINE ada
END INTERFACE

! Local variables

REAL (dp) :: acum, alpha, beta
INTEGER   :: i, inc(12,8), j, k, kp1, ksub, m
LOGICAL, SAVE   :: nowate, philp1
REAL (dp), SAVE :: saved
INTEGER, SAVE   :: firstc, firstr, lastc, lnl2, lp1, lp2, lpp1, ncon, nconp1

IF (isel /= 1) GO TO 10
lp1 = l + 1
lnl2 = l + 2 + nl
lp2 = l + 2
lpp1 = lpp2 - 1
firstc = 1
lastc = lpp1
firstr = lp1
CALL vpinit (l, nl, n, nmax, lpp2, iv, t, w, alf, ada, isel,  &
             iprint, a, inc, ncon, nconp1, philp1, nowate)
IF (isel /= 1) GO TO 180
GO TO 30

10 CALL ada (lp1, nl, n, nmax, lpp2, iv, a, inc, t, alf, MIN(isel,3))
IF (isel == 2) GO TO 20
!                                                 ISEL = 3 OR 4
firstc = lp2
lastc = lpp1
firstr = (4-isel)*l + 1
GO TO 70
!                                                 ISEL = 2
20 firstc = nconp1
lastc = lp1
IF (ncon == 0) GO TO 30
IF (a(1,ncon) == saved) GO TO 30
isel = -7
CALL vperr (iprint, isel, ncon)
GO TO 180
!                                                  ISEL = 1 OR 2
30 IF (philp1) GO TO 50
r(1:n) = y(1:n)
GO TO 70
50 r(1:n) = y(1:n) - r(1:n)
!                                             WEIGHT APPROPRIATE COLUMNS
70 IF (nowate) GO TO 90
DO  i=1,n
  acum = w(i)
  DO  j=firstc,lastc
    a(i,j) = a(i,j)*acum
  END DO
END DO

!     COMPUTE ORTHOGONAL FACTORIZATIONS BY HOUSEHOLDER REFLECTIONS.
!     IF ISEL = 1 OR 2, REDUCE PHI (STORED IN THE FIRST L COLUMNS OF THE
!     MATRIX A) TO UPPER TRIANGULAR FORM, (Q*PHI = S), AND TRANSFORM Y (STORED
!     IN COLUMN L+1), GETTING Q*Y = R.
!     IF ISEL = 1, ALSO TRANSFORM J = D PHI (STORED IN COLUMNS L+2 THROUGH
!     L+P+1 OF THE MATRIX A), GETTING Q*J = F.
!     IF ISEL = 3 OR 4, PHI HAS ALREADY BEEN REDUCED, TRANSFORM ONLY J.
!     S, R, AND F OVERWRITE PHI, Y, AND J, RESPECTIVELY, AND A FACTORED FORM
!     OF Q IS SAVED IN U AND THE LOWER TRIANGLE OF PHI.

90 IF (l == 0) GO TO 130
DO  k=1,l
  kp1 = k + 1
  IF (isel >= 3 .OR. (isel == 2 .AND. k < nconp1)) GO TO 100
  alpha = SIGN(vpnorm(n+1-k, a(k:,k)), a(k,k))
  u(k) = a(k,k) + alpha
  a(k,k) = -alpha
  firstc = kp1
  IF (alpha /= 0.0_dp) GO TO 100
  isel = -8
  CALL vperr (iprint, isel, k)
  GO TO 180
!                                        APPLY REFLECTIONS TO COLUMNS
!                                        FIRSTC TO LASTC.
  100 beta = -a(k,k)*u(k)
  DO  j=firstc,lastc
    acum = u(k)*a(k,j) + DOT_PRODUCT( a(kp1:n,k), a(kp1:n,j) )
    acum = acum/beta
    a(k,j) = a(k,j) - u(k)*acum
    DO  i=kp1,n
      a(i,j) = a(i,j) - a(i,k)*acum
    END DO
  END DO
END DO

130 IF (isel >= 3) GO TO 140
rnorm = vpnorm(n-l,r(lp1:))
IF (isel == 2) GO TO 180
IF (ncon > 0) saved = a(1,ncon)

!     F2 IS NOW CONTAINED IN ROWS L+1 TO N AND COLUMNS L+2 TO L+P+1 OF THE
!     MATRIX A.   NOW SOLVE THE L X L UPPER TRIANGULAR SYSTEM S*BETA = R1 FOR
!     THE LINEAR PARAMETERS BETA.  BETA OVERWRITES R1.

140 IF (l > 0) CALL vpbsol (l, a, r)

!           MAJOR PART OF KAUFMAN'S SIMPLIFICATION OCCURS HERE.  COMPUTE
!           THE DERIVATIVE OF ETA WITH RESPECT TO THE NONLINEAR PARAMETERS

!   T   D ETA        T    L          D PHI(J)    D PHI(L+1)
!  Q * --------  =  Q * (SUM BETA(J) --------  + ----------)  =  F2*BETA
!      D ALF(K)          J=1         D ALF(K)     D ALF(K)

!           AND STORE THE RESULT IN COLUMNS L+2 TO L+NL+1.  IF ISEL NOT
!           = 4, THE FIRST L ROWS ARE OMITTED.  THIS IS -D(Q2)*Y.  IF
!           ISEL NOT = 4 THE RESIDUAL R2 = Q2*Y (IN COL. L+1) IS COPIED
!           TO COLUMN L+NL+2.  OTHERWISE ALL OF COLUMN L+1 IS COPIED.

DO  i=firstr,n
  IF (l == ncon) GO TO 170
  m = lp1
  DO  k=1,nl
    acum = 0.0_dp
    DO  j=nconp1,l
      IF (inc(k,j) == 0) CYCLE
      m = m + 1
      acum = acum + a(i,m)*r(j)
    END DO
    ksub = lp1+k
    IF (inc(k,lp1) == 0) GO TO 160
    m = m+1
    acum = acum + a(i,m)
    160 a(i,ksub) = acum
  END DO
  170 a(i,lnl2) = r(i)
END DO

180 RETURN
END SUBROUTINE vpdpa

SUBROUTINE vpinit (l, nl, n, nmax, lpp2, iv, t, w, alf, ada, isel,  &
                   iprint, a, inc, ncon, nconp1, philp1, nowate)

!        CHECK VALIDITY OF INPUT PARAMETERS, AND DETERMINE NUMBER OF
!        CONSTANT FUNCTIONS.

!     ..................................................................

INTEGER, INTENT(IN)        :: l
INTEGER, INTENT(IN)        :: nl
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: nmax
INTEGER, INTENT(IN)        :: lpp2
INTEGER, INTENT(IN)        :: iv
REAL (dp), INTENT(IN)      :: t(:,:)   ! t(nmax,iv)
REAL (dp), INTENT(IN OUT)  :: w(:)
REAL (dp), INTENT(IN OUT)  :: alf(:)
INTEGER, INTENT(IN OUT)    :: isel
INTEGER, INTENT(IN)        :: iprint
REAL (dp), INTENT(IN OUT)  :: a(:,:)   ! a(nmax,lpp2)
INTEGER, INTENT(OUT)       :: inc(12,8)
INTEGER, INTENT(OUT)       :: ncon
INTEGER, INTENT(OUT)       :: nconp1
LOGICAL, INTENT(OUT)       :: philp1
LOGICAL, INTENT(OUT)       :: nowate

INTERFACE
  SUBROUTINE ada (lp1, nl, n, nmax, lpp2, iv, a, inc, t, alf, isel)
    IMPLICIT NONE
    INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(14, 60)
    INTEGER, INTENT(IN)     :: lp1
    INTEGER, INTENT(IN)     :: nl
    INTEGER, INTENT(IN)     :: n
    INTEGER, INTENT(IN)     :: nmax
    INTEGER, INTENT(IN)     :: lpp2
    INTEGER, INTENT(IN)     :: iv
    REAL (dp), INTENT(OUT)  :: a(:,:)
    INTEGER, INTENT(OUT)    :: inc(:,:)
    REAL (dp), INTENT(IN)   :: t(:,:)
    REAL (dp), INTENT(IN)   :: alf(:)
    INTEGER, INTENT(IN)     :: isel
  END SUBROUTINE ada
END INTERFACE

! Local variables

INTEGER  :: i, inckj, j, k, lnl2, lp1, p
INTEGER, PARAMETER  :: output = 6

lp1 = l+1
nconp1 = lp1
lnl2 = l+2+nl
!                                          CHECK FOR VALID INPUT
IF (l >= 0 .AND. nl >= 0 .AND. l+nl < n .AND. lnl2 <= lpp2 .AND.   &
    2*nl + 3 <= nmax .AND. n <= nmax .AND. iv > 0 .AND. .NOT.(nl == 0  &
    .AND. l == 0)) GO TO 10
isel = -4
CALL vperr (iprint, isel, 1)
GO TO 90

10 IF (l == 0 .OR. nl == 0) GO TO 30
DO  j=1,lp1
  DO  k=1,nl
    inc(k,j) = 0
  END DO
END DO

30 CALL ada (lp1, nl, n, nmax, lpp2, iv, a, inc, t, alf, isel)

nowate = .true.
DO  i=1,n
  nowate = nowate .AND. (w(i) == 1.0_dp)
  IF (w(i) >= 0.0_dp) GO TO 40
!                                                ERROR IN WEIGHTS
  isel = -6
  CALL vperr (iprint, isel, i)
  GO TO 90
  40 w(i) = SQRT(w(i))
END DO

ncon = l
philp1 = (l == 0)
IF (philp1 .OR. nl == 0) GO TO 90
!                                   CHECK INC MATRIX FOR VALID INPUT AND
!                                   DETERMINE NUMBER OF CONSTANT FCNS.
p = 0
DO  j=1,lp1
  IF (p  == 0) nconp1 = j
  DO  k=1,nl
    inckj = inc(k,j)
    IF (inckj /= 0 .AND. inckj /= 1) GO TO 60
    IF (inckj == 1) p = p + 1
  END DO
END DO

ncon = nconp1-1
IF (iprint >= 0) WRITE (output,100) ncon
IF (l+p+2 == lpp2) GO TO 70
!                                              INPUT ERROR IN INC MATRIX
60 isel = -5
CALL vperr (iprint, isel, 1)
GO TO 90
!                                 DETERMINE IF PHI(L+1) IS IN THE MODEL.
70 DO  k=1,nl
  IF (inc(k,lp1) == 1) philp1 = .true.
END DO

90 RETURN
100 FORMAT ('0  NUMBER OF CONSTANT FUNCTIONS =', i4/)
END SUBROUTINE vpinit

SUBROUTINE vpbsol (n, a, x)

!        BACKSOLVE THE N X N UPPER TRIANGULAR SYSTEM A*X = B.
!        THE SOLUTION X OVERWRITES THE RIGHT SIDE B.

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN)      :: a(:,:)
REAL (dp), INTENT(IN OUT)  :: x(:)

! Local variables

REAL (dp) :: acum
INTEGER   :: i, iback, ip1, j, np1

x(n) = x(n)/a(n,n)
IF (n == 1) GO TO 30
np1 = n + 1
DO  iback=2,n
  i = np1 - iback
!           I = N-1, N-2, ..., 2, 1
  ip1 = i + 1
  acum = x(i)
  DO  j=ip1,n
    acum = acum - a(i,j)*x(j)
  END DO
  x(i) = acum/a(i,i)
END DO

30 RETURN
END SUBROUTINE vpbsol

SUBROUTINE vppost (l, nl, n, lnl2, eps, rnorm, iprint, alf,  &
                   w, a, r, u)

!        CALCULATE RESIDUALS, SAMPLE VARIANCE, AND COVARIANCE MATRIX.
!        ON INPUT, U CONTAINS INFORMATION ABOUT HOUSEHOLDER REFLECTIONS
!        FROM VPDPA.  ON OUTPUT, IT CONTAINS THE LINEAR PARAMETERS.

INTEGER, INTENT(IN)        :: l
INTEGER, INTENT(IN)        :: nl
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: lnl2
REAL (dp), INTENT(IN)      :: eps
REAL (dp), INTENT(IN)      :: rnorm
INTEGER, INTENT(IN)        :: iprint
REAL (dp), INTENT(IN OUT)  :: alf(:)
REAL (dp), INTENT(IN OUT)  :: w(:)
REAL (dp), INTENT(IN OUT)  :: a(:,:)
REAL (dp), INTENT(IN OUT)  :: r(:)
REAL (dp), INTENT(IN OUT)  :: u(:)

! Local variables

REAL (dp) :: acum, prjres, SAVE
INTEGER   :: i, isel, k, kback, kp1, lp1, lpnl, lnl1
INTEGER, PARAMETER :: output = 6

lp1 = l + 1
lpnl = lnl2 - 2
lnl1 = lpnl + 1
DO  i=1,n
  w(i) = w(i)**2
END DO

!              UNWIND HOUSEHOLDER TRANSFORMATIONS TO GET RESIDUALS,
!              AND MOVE THE LINEAR PARAMETERS FROM R TO U.

IF (l == 0) GO TO 40
DO  kback=1,l
  k = lp1 - kback
  kp1 = k + 1
  acum = DOT_PRODUCT( a(kp1:n,k), r(kp1:n) )
  SAVE = r(k)
  r(k) = acum/a(k,k)
  acum = -acum/(u(k)*a(k,k))
  u(k) = SAVE
  DO  i=kp1,n
    r(i) = r(i) - a(i,k)*acum
  END DO
END DO
!                                              COMPUTE MEAN ERROR
40 acum = SUM( r(1:n) )
SAVE = acum/n

!              THE FIRST L COLUMNS OF THE MATRIX HAVE BEEN REDUCED TO
!              UPPER TRIANGULAR FORM IN VPDPA.  FINISH BY REDUCING ROWS
!              L+1 TO N AND COLUMNS L+2 THROUGH L+NL+1 TO TRIANGULAR
!              FORM.  THEN SHIFT COLUMNS OF DERIVATIVE MATRIX OVER ONE
!              TO THE LEFT TO BE ADJACENT TO THE FIRST L COLUMNS.

IF (nl == 0) GO TO 70
isel = 4
CALL vpfac1 (nl+1, n, l, iprint, a(:,l+2:), prjres, isel)
DO  i=1,n
  a(i,lnl2) = r(i)
  DO  k=lp1,lnl1
    a(i,k) = a(i,k+1)
  END DO
END DO
!                                              COMPUTE COVARIANCE MATRIX
70 a(1,lnl2) = rnorm
acum = rnorm*rnorm/(n-l-nl)
a(2,lnl2) = acum
CALL vpcov (lpnl, acum, a)

IF (iprint < 0) GO TO 80
WRITE (output,90)
IF (l > 0) WRITE (output,100) u(1:l)
IF (nl > 0) WRITE (output,110) alf(1:nl)
WRITE (output,120) rnorm, SAVE, acum
IF (ABS(SAVE) > eps) WRITE (output,130)
WRITE (output,90)
80 RETURN

90 FORMAT ('0',50(''''))
100 FORMAT ('0  LINEAR PARAMETERS'//(7E15.7))
110 FORMAT ('0  NONLINEAR PARAMETERS'//(7E15.7))
120 FORMAT ('0  NORM OF RESIDUAL =',e15.7,  &
    ' EXPECTED ERROR OF OBSERVATIONS =',e15.7,/  &
    '   ESTIMATED VARIANCE OF OBSERVATIONS =',e15.7)
130 FORMAT('  WARNING -- EXPECTED ERROR OF OBSERVATIONS IS NOT ZERO.',  &
    ' COVARIANCE MATRIX MAY BE MEANINGLESS.'/)
END SUBROUTINE vppost

SUBROUTINE vpcov (n, sigma2, a)

!           COMPUTE THE SCALED COVARIANCE MATRIX OF THE L + NL
!        PARAMETERS.  THIS INVOLVES COMPUTING

!                               2     -1    -T
!                          SIGMA  *  T   * T

!        WHERE THE (L+NL) X (L+NL) UPPER TRIANGULAR MATRIX T IS
!        DESCRIBED IN SUBROUTINE VPPOST.  THE RESULT OVERWRITES THE
!        FIRST L+NL ROWS AND COLUMNS OF THE MATRIX A.  THE RESULTING
!        MATRIX IS SYMMETRIC.  SEE REF. 7, PP. 67-70, 281.

!     ..................................................................

INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(IN)   :: sigma2
REAL (dp), INTENT(OUT)  :: a(:,:)

! Local variables

REAL (dp) :: sum
INTEGER   :: i, ip1, j, jm1, nm1

DO  j=1,n
  a(j,j) = 1._dp / a(j,j)
END DO

!                 INVERT T UPON ITSELF

IF (n == 1) GO TO 40
nm1 = n - 1
DO  i=1,nm1
  ip1 = i + 1
  DO  j=ip1,n
    jm1 = j - 1
    sum = DOT_PRODUCT( a(i,i:jm1), a(i:jm1,j) )
    a(i,j) = -sum*a(j,j)
  END DO
END DO

!                 NOW FORM THE MATRIX PRODUCT

40 DO  i=1,n
  DO  j=i,n
    sum = DOT_PRODUCT( a(i,j:n), a(j,j:n) )
    sum = sum*sigma2
    a(i,j) = sum
    a(j,i) = sum
  END DO
END DO

RETURN
END SUBROUTINE vpcov

SUBROUTINE vperr (iprint, ierr, k)

!        PRINT ERROR MESSAGES

INTEGER, INTENT(IN)  :: iprint
INTEGER, INTENT(IN)  :: ierr
INTEGER, INTENT(IN)  :: k

INTEGER :: errno
INTEGER, PARAMETER :: output = 6

IF (iprint < 0) GO TO 80
errno = ABS(ierr)
SELECT CASE ( errno )
  CASE (    1)
    WRITE (output,90)
  CASE (    2)
    WRITE (output,100)
  CASE (    3)
    RETURN
  CASE (    4)
    WRITE (output,110)
  CASE (    5)
    WRITE (output,120)
  CASE (    6)
    WRITE (output,130) k
  CASE (    7)
    WRITE (output,140) k
  CASE (    8)
    WRITE (output,150) k
END SELECT

80 RETURN

90 FORMAT ('0  PROBLEM TERMINATED FOR EXCESSIVE ITERATIONS'//)
100 FORMAT ('0  PROBLEM TERMINATED BECAUSE OF ILL-CONDITIONING'//)
110 FORMAT (/' INPUT ERROR IN PARAMETER L, NL, N, LPP2, OR NMAX.'/)
120 FORMAT ('0  ERROR -- INC MATRIX IMPROPERLY SPECIFIED, OR ',  &
    'DISAGREES WITH LPP2.'/)
130 FORMAT ('0  ERROR -- WEIGHT(',i4,') IS NEGATIVE.'/)
140 FORMAT ('0  ERROR -- CONSTANT COLUMN ', i3,  &
    ' MUST BE COMPUTED ONLY WHEN ISEL = 1.'/)
150 FORMAT ('0  CATASTROPHIC FAILURE -- COLUMN', i4,  &
    ' IS ZERO, SEE DOCUMENTATION.'/)
END SUBROUTINE vperr

FUNCTION vpnorm (n, x) RESULT(fn_val)

!        COMPUTE THE L2 (EUCLIDEAN) NORM OF A VECTOR, MAKING SURE TO AVOID
!        UNNECESSARY UNDERFLOWS.  NO ATTEMPT IS MADE TO SUPPRESS OVERFLOWS.

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

! Local variables
REAL (dp) :: rmax, sum, term
INTEGER   :: i

!           FIND LARGEST (IN ABSOLUTE VALUE) ELEMENT
rmax = 0._dp
DO  i=1,n
  IF (ABS(x(i)) > rmax) rmax = ABS(x(i))
END DO

sum = 0._dp
IF (rmax == 0._dp) GO TO 30
DO  i=1,n
  term = 0._dp
  IF (rmax+ABS(x(i)) /= rmax) term = x(i)/rmax
  sum = sum + term*term
END DO

30 fn_val = rmax*SQRT(sum)
RETURN
END FUNCTION vpnorm

END MODULE separable_leastsq


!----------------------------------------------------------------------------------------------
! MODULE: cis_nto_mod
!> @author Marin Sapunar, Ruđer Bošković Institute
!> @date October, 2018
!
!> @brief Subroutines for working with natural transition orbitals from CIS wave functions.
!----------------------------------------------------------------------------------------------
module cis_nto_mod
    use global_defs
    implicit none

contains

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: cis_nto_1state
    !
    !> @brief Generate natural transition orbitals for a CIS wave function.
    !> @details
    !! Uses SVD decomposition of the CI coefficients matrix of a given spin to generate the natural
    !! transition orbitals for that spin. The NTOs are given as linear combinations of canonical
    !! orbitals in the nat_orbs array. The array is filled with the no hole orbitals followed by
    !! the first no particle orbitals.
    !
    !> @note The SVD decomposition is unique up to a sign for each pair of singular vectors (for
    !! non-degenerate singular values).
    !
    !> @note When transforming the wave function to the NTO basis, the sign of can flip. This can
    !! be seen from the overlap between the reference determinant in the NTO and canonical basis.
    !! If it is negative (-1), the sign of the wave function is fixed by changing the sign of the
    !! NTO pair corresponding to the smallest singular value.
    !----------------------------------------------------------------------------------------------
    subroutine cis_nto_1state(nv, no, wf, nto_c, nto_mo)
        use linalg_wrapper_mod, only : gesvd
        use matrix_mod, only : mat_ge_det
        integer, intent(in) :: nv !< Number of virtual orbitals
        integer, intent(in) :: no !< Number of occupied orbitals
        real(dp), intent(in) :: wf(nv, no) !< CIS wave function coefficients
        real(dp), intent(out) :: nto_c(no) !< NTO coefficients
        real(dp), intent(out) :: nto_mo(no+nv, 2*no) !< NTOs in the MO basis
        real(dp) :: wrk_c(nv, no) !< Array for CI coefficients
        real(dp) :: wrk_o(no, no) !< Array for occupied NTOs
        real(dp) :: wrk_v(nv, no) !< Array for virtual NTOs
        wrk_c = wf(:, :)
        call gesvd(wrk_c, s=nto_c, u=wrk_v, vt=wrk_o)
        nto_mo(1:no, 1:no) = transpose(wrk_o)
        nto_mo(no+1:no+nv, no+1:2*no) = wrk_v
        ! Check/fix sign
        if (mat_ge_det(wrk_o) < 0) then
            nto_mo(:, no) = -nto_mo(:, no)
            nto_mo(:, 2*no) = -nto_mo(:, 2*no)
        end if
    end subroutine cis_nto_1state

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: cis_nto
    !> @brief Generate NTOs for a set of CIS wave functions.
    !----------------------------------------------------------------------------------------------
    subroutine cis_nto(wf, nto_c, nto_mo)
        real(dp), intent(in) :: wf(:, :, :) !< CIS wave function coefficients
        real(dp), allocatable, intent(out) :: nto_c(:, :) !< NTO coefficients
        real(dp), allocatable, intent(out) :: nto_mo(:, :, :) !< NTOs in the MO basis
        integer :: nv !< Number of virtual orbitals
        integer :: no !< Number of occupied orbitals
        integer :: ns !< Number of states
        integer :: i
        nv = size(wf, 1)
        no = size(wf, 2)
        ns = size(wf, 3)
        if (.not. allocated(nto_mo)) allocate(nto_mo(no+nv, 2*no, ns), source=0.0_dp)
        if (.not. allocated(nto_c)) allocate(nto_c(no, ns), source=0.0_dp)
        do i = 1, ns
            call cis_nto_1state(nv, no, wf(:, :, i), nto_c(:, i), nto_mo(:, :, i))
        end do
    end subroutine cis_nto

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: cis_nto_and_convert_basis
    !> @brief Generate NTOs and convert to different basis.
    !----------------------------------------------------------------------------------------------
    subroutine cis_nto_and_convert_basis(mo, wf, nto_c, nto_bas)
        use linalg_wrapper_mod, only : gemm
        real(dp), intent(in) :: mo(:, :) !< MO coefficients in target basis
        real(dp), intent(in) :: wf(:, :, :) !< CIS wave function coefficients
        real(dp), allocatable, intent(out) :: nto_c(:, :) !< NTO coefficients
        real(dp), allocatable, intent(out) :: nto_bas(:, :, :) !< NTOs in target basis
        real(dp), allocatable :: nto_mo(:, :) !< NTOs in MO basis
        integer :: nv !< Number of virtual orbitals
        integer :: no !< Number of occupied orbitals
        integer :: ns !< Number of states
        integer :: i

        nv = size(wf, 1)
        no = size(wf, 2)
        ns = size(wf, 3)
        if (.not. allocated(nto_bas)) allocate(nto_bas(size(mo, 1), 2*no, ns), source=0.0_dp)
        if (.not. allocated(nto_c)) allocate(nto_c(no, ns), source=0.0_dp)
        allocate(nto_mo(no+nv, 2*no), source=0.0_dp)
        do i = 1, ns
            call cis_nto_1state(nv, no, wf(:, :, i), nto_c(:, i), nto_mo)
            call gemm(mo, nto_mo, nto_bas(:, :, i))
        end do
    end subroutine cis_nto_and_convert_basis

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: cis_nto_truncate_1state_u
    !
    !> @brief Determine number of alpha/beta orbitals in truncated CIS wave function.
    !> @details
    !! Determine number of NTOs of each spin needed so the truncated CIS wave function has a square
    !! norm higher than trunc.
    !----------------------------------------------------------------------------------------------
    subroutine cis_nto_truncate_1state_u(trunc, c_a, c_b, n_a, n_b)
        real(dp), intent(in) :: trunc !< Threshold for truncating the wave functions
        real(dp), intent(inout) :: c_a(:) !< NTO coefficients alpha
        real(dp), intent(inout) :: c_b(:) !< NTO coefficients beta
        integer, intent(out) :: n_a !< Number of alpha coefficients in truncated wf
        integer, intent(out) :: n_b !< Number of beta coefficients in truncated wf
        real(dp) :: norm !< Squared norm
        real(dp) :: ia !< Current alpha excitation coefficient
        real(dp) :: ib !< Current beta excitation coefficient
        integer :: i

        n_a = 0
        n_b = 0
        norm = 0.0_dp
        ia = c_a(n_a+1)
        ib = c_b(n_b+1)
        do i = 1, size(c_a, 1) + size(c_b, 1)
            if (ia > ib) then
                n_a = n_a + 1
                norm = norm + ia**2
                ia = c_a(n_a+1)
            else
                n_b = n_b + 1
                norm = norm + ib**2
                ib = c_b(n_b+1)
            end if
            if (norm > trunc) exit
        end do
    end subroutine cis_nto_truncate_1state_u

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: cis_nto_truncate_1state_r
    !
    !> @brief Determine number of orbitals in truncated CIS wave function.
    !> @details
    !! Determine number of NTOs needed so the truncated CIS wave function has a square norm higher
    !! than trunc.
    !----------------------------------------------------------------------------------------------
    subroutine cis_nto_truncate_1state_r(trunc, c_a, n_a)
        real(dp), intent(in) :: trunc !< Threshold for truncating the wave functions
        real(dp), intent(inout) :: c_a(:) !< NTO coefficients alpha
        integer, intent(out) :: n_a !< Number of alpha coefficients in truncated wf
        real(dp) :: norm !< Squared norm
        integer :: i

        n_a = 0
        norm = 0.0_dp
        do i = 1, size(c_a, 1)
            n_a = n_a + 1
            norm = norm + c_a(n_a)**2
            if (norm > trunc) exit
        end do
    end subroutine cis_nto_truncate_1state_r

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: cis_nto_truncate
    !
    !> @brief Determine number of alpha/beta orbitals in truncated CIS wave functions.
    !> @details
    !! Determine number of NTOs of each spin needed so the truncated CIS wave functions each have
    !! a square norm higher than trunc.
    !----------------------------------------------------------------------------------------------
    subroutine cis_nto_truncate(beta, trunc_norm, trunc_nex, c_a, c_b, n_a, n_b)
        logical, intent(in) :: beta !< Unrestricted calculation
        real(dp), intent(in) :: trunc_norm !< Threshold for norm based truncation of wave functions
        integer, intent(in) :: trunc_nex !< !< Truncation to fixed number of dominant excitations
        real(dp), intent(inout) :: c_a(:, :) !< NTO coefficients alpha
        real(dp), intent(inout) :: c_b(:, :) !< NTO coefficients beta
        integer, allocatable, intent(out) :: n_a(:) !< Number of alpha coefficients in truncated wf
        integer, allocatable, intent(out) :: n_b(:) !< Number of beta coefficients in truncated wf
        integer :: i, ns, na, nb
        ns = size(c_a, 2)
        na = size(c_a, 1)
        if (beta) nb = size(c_b, 1)
        if (.not. allocated(n_a)) allocate(n_a(ns))
        if (beta .and. (.not. allocated(n_b))) allocate(n_b(ns))
        if (trunc_nex > 0) then
            n_a = min(trunc_nex, na)
            if (beta) n_b = min(trunc_nex, nb)
        else if (trunc_norm >= 1.0_dp) then
            n_a = na
            if (beta) n_b = nb
        else
            do i = 1, size(c_a, 2)
                if (beta) then
                    call cis_nto_truncate_1state_u(trunc_norm, c_a(:, i), c_b(:, i), n_a(i), n_b(i))
                else
                    call cis_nto_truncate_1state_r(trunc_norm, c_a(:, i), n_a(i))
                end if
            end do
        end if
    end subroutine cis_nto_truncate

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: cis_norms_nto
    !
    !> @brief Return norms of truncated CIS NTO expansions.
    !----------------------------------------------------------------------------------------------
    function cis_norms_nto(beta, c_a, c_b, n_a, n_b) result(norms)
        logical, intent(in) :: beta !< Unrestricted calculation
        real(dp), intent(in) :: c_a(:, :) !< NTO coefficients alpha
        real(dp), intent(in) :: c_b(:, :) !< NTO coefficients beta
        integer, intent(in) :: n_a(:) !< Number of alpha coefficients in truncated wf
        integer, intent(in) :: n_b(:) !< Number of beta coefficients in truncated wf
        real(dp), allocatable :: norms(:)
        integer :: ns, i

        ns = size(c_a, 2)
        allocate(norms(ns), source=0.0_dp)
        do i = 1, ns
            norms(i) = norms(i) + sum(c_a(1:n_a(i), i)**2)
            if (beta) norms(i) = norms(i) + sum(c_b(1:n_b(i), i)**2)
        end do
    end function cis_norms_nto

end module cis_nto_mod


module zgrid

   implicit none

   public :: init_zgrid, finish_zgrid
   public :: nzed, nzgrid, nperiod, ntubes
   public :: nztot, nz2pi
   public :: zed
   public :: delzed
   public :: zed_equal_arc
   public :: get_total_arc_length
   public :: get_arc_length_grid
   public :: shat_zero
   public :: grad_x_grad_y_zero
   public :: boundary_option_switch
   public :: boundary_option_zero
   public :: boundary_option_self_periodic
   public :: boundary_option_linked
   public :: boundary_option_linked_stellarator

   private

   integer :: nzed, nzgrid, nztot, nz2pi
   integer :: nperiod, ntubes
   logical :: zed_equal_arc
   real :: shat_zero, grad_x_grad_y_zero
   real, dimension(:), allocatable :: zed, delzed

   integer :: boundary_option_switch
   integer, parameter :: boundary_option_zero = 1, &
                         boundary_option_self_periodic = 2, &
                         boundary_option_linked = 3, &
                         boundary_option_linked_stellarator = 4

   logical :: zgridinit = .false.

contains

   subroutine init_zgrid

      use mp, only: proc0
      use constants, only: pi

      implicit none

      integer :: i

      if (zgridinit) return
      zgridinit = .true.

      if (proc0) then
         call read_parameters
      end if
      call broadcast_parameters

      if (.not. allocated(zed)) allocate (zed(-nzgrid:nzgrid))
      if (.not. allocated(delzed)) allocate (delzed(-nzgrid:nzgrid))

      zed = (/(i * pi / real(nzed / 2), i=-nzgrid, nzgrid)/)
      delzed(:nzgrid - 1) = zed(-nzgrid + 1:) - zed(:nzgrid - 1)
      delzed(nzgrid) = delzed(-nzgrid)

      nztot = 2 * nzgrid + 1
      ! number of zed in a 2*pi segment, including points at +/- pi
      nz2pi = 2 * (nzed / 2) + 1

   end subroutine init_zgrid

   subroutine read_parameters

      use file_utils, only: input_unit_exist, error_unit
      use text_options, only: text_option, get_option_value
      use physics_flags, only: full_flux_surface

      implicit none

      integer :: in_file, ierr
      logical :: exist

      type(text_option), dimension(7), parameter :: boundaryopts = &
                                                    (/text_option('default', boundary_option_zero), &
                                                      text_option('zero', boundary_option_zero), &
                                                      text_option('unconnected', boundary_option_zero), &
                                                      text_option('self-periodic', boundary_option_self_periodic), &
                                                      text_option('periodic', boundary_option_self_periodic), &
                                                      text_option('linked', boundary_option_linked), &
                                                      text_option('stellarator', boundary_option_linked_stellarator)/)
      character(20) :: boundary_option

      namelist /zgrid_parameters/ nzed, nperiod, ntubes, &
         shat_zero, boundary_option, zed_equal_arc, &
         boundary_option, zed_equal_arc, grad_x_grad_y_zero

      nzed = 24
      nperiod = 1
      ntubes = 1
      boundary_option = 'default'
      ! if zed_equal_arc = T, then zed is chosen to be arc length
      ! if zed_equal_arc = F, then zed is poloidal (axisymmetric)
      ! or zeta (toroidal) angle
      zed_equal_arc = .false.
      ! set minimum shat value below which we assume
      ! periodic BC
      shat_zero = 1.e-5
      ! set the minimum nabla x . nabla value at the end of the FT which we assume
      ! periodic BC instead of the stellarator symmetric ones
      grad_x_grad_y_zero = 1.e-5

      in_file = input_unit_exist("zgrid_parameters", exist)
      if (exist) read (unit=in_file, nml=zgrid_parameters)

      ierr = error_unit()
      call get_option_value &
         (boundary_option, boundaryopts, boundary_option_switch, &
          ierr, "boundary_option in dist_fn_knobs")

      ! note that boundary_option may be changed to self-periodic later
      ! if magnetic shear or nabla x \cdot nabla y is smaller than shat_zero or grad_x_grad_y_zero
      ! cannot do this here as these quantities have yet to be input

      nzgrid = nzed / 2 + (nperiod - 1) * nzed

      ! force use of equal arc grid to ensure gradpar alpha-independent
      ! necessary to obtain efficient numerical solution of parallel streaming
      if (full_flux_surface) zed_equal_arc = .true.

   end subroutine read_parameters

   subroutine broadcast_parameters

      use mp, only: broadcast

      implicit none

      call broadcast(nzed)
      call broadcast(nzgrid)
      call broadcast(nperiod)
      call broadcast(ntubes)
      call broadcast(zed_equal_arc)
      call broadcast(shat_zero)
      call broadcast(boundary_option_switch)
      call broadcast(grad_x_grad_y_zero)

   end subroutine broadcast_parameters

   subroutine finish_zgrid

      implicit none

      if (allocated(zed)) deallocate (zed)
      if (allocated(delzed)) deallocate (delzed)

      zgridinit = .false.

   end subroutine finish_zgrid

   subroutine get_total_arc_length(nz, gp, dz, length)

      implicit none

      integer, intent(in) :: nz
      real, dimension(-nz:), intent(in) :: gp
      real, intent(in) :: dz
      real, intent(out) :: length

      call integrate_zed(nz, dz, 1./gp, length)

   end subroutine get_total_arc_length

   subroutine get_arc_length_grid(nz_max, nzext_max, zboundary, gp, dz, zarc)

      implicit none

      integer, intent(in) :: nz_max, nzext_max
      real, intent(in) :: zboundary
      real, dimension(-nzext_max:), intent(in) :: gp
      real, intent(in) :: dz
      real, dimension(-nzext_max:), intent(out) :: zarc

      integer :: iz

      zarc(-nz_max) = zboundary
      if (nz_max /= nzext_max) then
         do iz = -nzext_max, -nz_max - 1
            call integrate_zed(nzext_max, dz, 1./gp(iz:-nz_max), zarc(iz))
            zarc(iz) = zarc(-nz_max) - zarc(iz)
         end do
      end if
      ! this seems very inefficient -- could just add incremental change at each zed,
      ! rather than recomputing from the boundary each time
      do iz = -nz_max + 1, nzext_max
         call integrate_zed(nz_max, dz, 1./gp(-nz_max:iz), zarc(iz))
         zarc(iz) = zarc(-nz_max) + zarc(iz)
      end do

   end subroutine get_arc_length_grid

   ! trapezoidal rule to integrate in zed
   subroutine integrate_zed(nz, dz, f, intf)

      implicit none

      integer, intent(in) :: nz
      real, intent(in) :: dz
      real, dimension(-nz:), intent(in) :: f
      real, intent(out) :: intf

      integer :: iz, iz_max

      iz_max = -nz + size(f) - 1
      intf = 0.
      do iz = -nz + 1, iz_max
         intf = intf + dz * (f(iz - 1) + f(iz))
      end do
      intf = 0.5 * intf

   end subroutine integrate_zed

end module zgrid


      SUBROUTINE CF1FBS (TPOSE,XOUT,IOBUF)
C*******
C     CF1FBS PERFORMS THE SINGLE-PRECISION FORWARD AND BACKWARD SWEEPS
C     FOR THE COMPLEX FEER METHOD. THESE SWEEPS CONSTITUTE THE
C     OPERATIONAL INVERSE (MATRIX INVERSION).
C*******
C     DEFINITION OF INPUT AND OUTPUT PARAMETERS
C*******
C     TPOSE    = .FALSE. --- PERFORM OPERATION L * U
C              = .TRUE.  --- PERFORM OPERATION U-TRANSPOSE * L-TRANSPOSE
C     XOUT     = INPUT VECTOR GETS TRANSFORMED TO OUTPUT VECTOR
C     IOBUF    = INPUT  GINO BUFFER
C*******
      DIMENSION         XOUT(1)
      INTEGER           NAME(2)  ,IOBUF(1) ,EOL      ,CSP
      LOGICAL           TPOSE(1) ,SYMMET   ,QPR
      COMMON  /FEERAA/  AADUM(117),MCBLT(7),MCBUT(7)
      COMMON  /FEERXC/  XCD01(4) ,SYMMET   ,XCD02(9) ,NSWP
     2                 ,XCD03(6) ,QPR
      COMMON  /ZNTPKX/  DA(2)    ,XA(2)    ,II       ,EOL
      COMMON  /NAMES /  RD       ,RDREW    ,WRT      ,WRTREW
     2                 ,REW      ,NOREW    ,EOFNRW   ,RSP
     3                 ,RDP      ,CSP      ,CDP
      COMMON  /SYSTEM/  KSYSTM   ,NOUT
      EQUIVALENCE       (AADUM(42),ISCR6)
      DATA   NAME       /4HCF1F,4HBS  /
      IF (QPR) WRITE (NOUT,8887) TPOSE(1),SYMMET,NSWP,ISCR6
 8887 FORMAT(1H0,12HENTER CF1FBS,8X,11HTRANSPOSE =,L2,L9,2I10)
               JUNK = 0
      IF (TPOSE(1) .AND. .NOT.SYMMET) GO TO 399
C*******
C     BELOW FOR OPERATION L * U
C     (LOGIC COPIED FROM SUBROUTINE CINFBS)
C*******
C     BEGIN FORWARD PASS USING THE LOWER TRIANGLE
C*******
      CALL GOPEN (MCBLT(1),IOBUF(1),RDREW)
      J = 1
 100  CALL INTPK(*200,MCBLT(1),0,CSP,0)
  110 IF (EOL) 3010,120,3010
  120 CALL ZNTPKI
               IF (QPR) WRITE (NOUT,8882) DA,II,EOL,J
 8882          FORMAT(1H ,4HDA =,2E16.8,4X,4HII =,I6,
     2                4X,5HEOL =,I2,4X,3HJ =,I4)
      IF (J-II) 184,130,110
C*******
C     PERFORM THE REQUIRED ROW INTERCHANGE
C*******
  130 IN1 = ( J + IFIX(DA(1)) )*2 - 1
               IF (QPR) WRITE (NOUT,8883) IN1,EOL
 8883          FORMAT(1H ,3X,5HIN1 =,I6,4X,5HEOL =,I2)
      IN2 = IN1+1
      J2 = 2*J
      UNIDUM = XOUT(J2)
      XOUT(J2) = XOUT(IN2)
      XOUT(IN2) = UNIDUM
      J2 = J2-1
      UNIDUM = XOUT(J2)
      XOUT(J2) = XOUT(IN1)
      XOUT(IN1) = UNIDUM
  160 IF (EOL) 200,170,200
  170 CALL ZNTPKI
               IF (QPR) WRITE (NOUT,8882) DA,II,EOL,J
  184 II2 = 2*II
      II1 = II2-1
      J2 = 2*J
      J1 = J2-1
      XOUT(II1) = XOUT(II1) - DA(1)*XOUT(J1) + DA(2)*XOUT(J2)
      XOUT(II2) = XOUT(II2) - DA(2)*XOUT(J1) - DA(1)*XOUT(J2)
      GO TO 160
  200 J = J+1
      IF (J.LT.NSWP) GO TO 100
      CALL CLOSE (MCBLT(1),REW)
C*******
C     BEGIN BACKWARD PASS USING THE UPPER TRIANGLE
C*******
      IOFF = MCBUT(7)-1
               IF (QPR) WRITE (NOUT,8866) IOFF,MCBLT,MCBUT
 8866          FORMAT(1H ,15(1X,I7))
      CALL GOPEN (MCBUT(1),IOBUF(1),RDREW)
      J = NSWP
 210  CALL INTPK(*3020,MCBUT(1),0,CSP,0)
      IF (EOL) 3020,230,3020
  230 CALL ZNTPKI
               IF (QPR) WRITE (NOUT,8882) DA,II,EOL,J
      I = NSWP - II + 1
      IF (I.NE.J) GO TO 275
C*******
C     DIVIDE BY THE DIAGONAL
C*******
      I2 = 2*I
      I1 = I2-1
      UNIDUM = 1./(DA(1)**2+DA(2)**2)
      DTEMP = (DA(1)*XOUT(I1)+DA(2)*XOUT(I2))*UNIDUM
      XOUT(I2) = (DA(1)*XOUT(I2)-DA(2)*XOUT(I1))*UNIDUM
      XOUT(I1) = DTEMP
               IF (QPR) WRITE (NOUT,8884)
 8884          FORMAT(1H ,6X,8HDIAGONAL)
C*******
C     SUBTRACT OFF REMAINING TERMS
C*******
  255 IF (I.GT.J) GO TO 230
      IF (EOL) 300,270,300
  270 CALL ZNTPKI
               IF (QPR) WRITE (NOUT,8882) DA,II,EOL,J
      I = NSWP - II + 1
  275 IN1 = I
      IN2 = J
      IF (I.LT.J) GO TO 279
      K = IN1
      IN1 = IN2-IOFF
               JUNK = 1
      IF (IN1.LE.0) GO TO 3020
      IN2 = K
  279 IN1 = 2*IN1
      IN2 = 2*IN2
      II1 = IN1-1
      II2 = IN2-1
            IF (QPR) WRITE (NOUT,8820) I,J,II1,II2
 8820       FORMAT(1H ,3HI =,I6,6X,3HJ =,I6,6X,5HII1 =,I6,6X,5HII2 =,I6)
      XOUT(II1) = XOUT(II1) - DA(1)*XOUT(II2) + DA(2)*XOUT(IN2)
      XOUT(IN1) = XOUT(IN1) - DA(2)*XOUT(II2) - DA(1)*XOUT(IN2)
      GO TO 255
  300 J = J-1
      IF (J.GT.0) GO TO 210
      CALL CLOSE (MCBUT(1),REW)
      GO TO 4000
C*******
C     BELOW FOR OPERATION U-TRANSPOSE * L-TRANSPOSE
C     (LOGIC COPIED FROM SUBROUTINE CDIFBS)
C*******
C     BEGIN THE FORWARD PASS USING THE UPPER TRIANGLE
C*******
  399 IOFF = MCBUT(7)-1
               IF (QPR) WRITE (NOUT,2216) IOFF
 2216          FORMAT(1H ,30X,6HIOFF =,I10)
      MCSAVE = MCBUT(1)
      MCBUT(1) = ISCR6
      CALL GOPEN (MCBUT(1),IOBUF(1),RDREW)
      DO 500  I = 1,NSWP
               IF (QPR) WRITE (NOUT,2218) I
 2218          FORMAT(1H ,12HLOOP INDEX =,I6)
      J = I+I
      CALL INTPK(*500,MCBUT(1),0,CSP,0)
  410 CALL ZNTPKI
               IF (QPR) WRITE (NOUT,2224) II,EOL,DA
 2224          FORMAT(1H ,4HII =,I14,6X,5HEOL =,I2,
     2                8X,4HDA =,2E16.8)
      IF (II-I) 430,420,440
C*******
C     DIVIDE BY THE DIAGONAL
C*******
  420 I1 = J-1
      UNIDUM = 1./(DA(1)**2+DA(2)**2)
      DTEMP = (XOUT(I1)*DA(1) + XOUT(J)*DA(2))*UNIDUM
      XOUT(J) = (XOUT(J)*DA(1) - XOUT(I1)*DA(2))*UNIDUM
      XOUT(I1) = DTEMP
               IF (QPR) WRITE (NOUT,8884)
      GO TO 490
C*******
C     SUBTRACT OFF NORMAL TERM
C*******
  430 I2 = II+II
      I1 = I2-1
      J1 = J-1
      XOUT(J1) = XOUT(J1) - XOUT(I1)*DA(1) + XOUT(I2)*DA(2)
      XOUT(J) = XOUT(J) - XOUT(I1)*DA(2) - XOUT(I2)*DA(1)
      GO TO 490
C*******
C     SUBTRACT OFF ACTIVE COLUMN TERMS
C*******
  440 K = (I-IOFF)*2
               JUNK = 1
      IN1 = K
      IF (IN1.LE.0) GO TO 3020
      I2 = II+II
      I1 = I2-1
      J1 = K-1
      XOUT(I1) = XOUT(I1) - XOUT(J1)*DA(1) + XOUT(K)*DA(2)
      XOUT(I2) = XOUT(I2) - XOUT(K)*DA(1) - XOUT(J1)*DA(2)
  490 IF (EOL) 500,410,500
  500 CONTINUE
      CALL CLOSE (MCBUT(1),REW)
      MCBUT(1) = MCSAVE
C*******
C     BEGIN BACKWARD PASS USING THE LOWER TRIANGLE
C*******
      CALL GOPEN (MCBLT(1),IOBUF(1),RDREW)
      CALL SKPREC (MCBLT(1),NSWP)
      DO 600  I = 1,NSWP
               IF (QPR) WRITE (NOUT,2218) I
      CALL BCKREC (MCBLT(1))
      INTCHN = 0
      CALL INTPK(*600,MCBLT(1),0,CSP,0)
      J = (NSWP-I+1)*2
  520 CALL ZNTPKI
               IF (QPR) WRITE (NOUT,2224) II,EOL,DA
      IF (II.NE.NSWP-I+1) GO TO 550
      IF (II.LT.J/2) GO TO 3010
C*******
C     PERFORM THE INTERCHANGE
C*******
      INTCHN = IFIX(DA(1))*2
               IF (QPR) WRITE (NOUT,2226) INTCHN
 2226          FORMAT(1H ,4X,11HINTERCHANGE,I6)
      GO TO 590
  530 IN1 = J+INTCHN
               IF (QPR) WRITE (NOUT,2232) J,INTCHN,IN1
 2232          FORMAT(1H ,15X,3I6)
      DTEMP = XOUT(J)
      XOUT(J) = XOUT(IN1)
      XOUT(IN1) = DTEMP
      J1 = J-1
      I1 = IN1-1
      DTEMP = XOUT(J1)
      XOUT(J1) = XOUT(I1)
      XOUT(I1) = DTEMP
      GO TO 600
  550 J1 = J-1
      I2 = II+II
      I1 = I2-1
      XOUT(J1) = XOUT(J1) - XOUT(I1)*DA(1) + XOUT(I2)*DA(2)
      XOUT(J) = XOUT(J) - XOUT(I1)*DA(2) - XOUT(I2)*DA(1)
  590 IF (EOL) 595,520,595
  595 IF (INTCHN) 600,600,530
  600 CALL BCKREC (MCBLT(1))
      CALL CLOSE (MCBLT(1),REW)
      GO TO 4000
 3010 J = MCBLT(1)
      GO TO 3040
 3020 J = MCBUT(1)
 3040 CALL MESAGE (-5,J,NAME)
 4000 CONTINUE
               IF (QPR.AND.JUNK.EQ.0) WRITE (NOUT,5516)
 5516          FORMAT(1H0,30X,13HIOFF NOT USED,/1H )
               IF (QPR.AND.JUNK.NE.0) WRITE (NOUT,5518)
 5518          FORMAT(1H0,30X,13HIOFF WAS USED,/1H )
      RETURN
      END


!*****************************************************************************************
!> author: Jacob Williams
!  license: BSD
!
!  Test cases for the [[diff_module]].

    program test_cases

    use diff_module
    use iso_fortran_env, only: wp => real64 !use double precision

    implicit none

    integer,parameter  :: iord  = 1
    real(wp),parameter :: x0    = 0.12345_wp
    real(wp),parameter :: xmin  = 0.0_wp
    real(wp),parameter :: xmax  = 1.0_wp
    real(wp),parameter :: eps   = 1.0e-9_wp
    real(wp),parameter :: acc   = 0.0_wp

    real(wp) :: deriv, error
    integer  :: ifail

    type,extends(diff_func) :: my_func
        integer :: ifunc = 0
    end type my_func
    type(my_func) :: d

    d%ifunc = 0
    call d%set_function(sin_func)
    call d%compute_derivative(iord,x0,xmin,xmax,eps,acc,deriv,error,ifail)
    call write_results(cos(x0))

    d%ifunc = 0
    call d%set_function(test_func_1)
    call d%compute_derivative(iord,x0,xmin,xmax,eps,acc,deriv,error,ifail)
    call write_results(cos(x0) - sin(x0) + 2.0_wp*x0)

    d%ifunc = 0
    call d%set_function(test_func_2)
    call d%compute_derivative(iord,x0,xmin,xmax,eps,acc,deriv,error,ifail)
    call write_results(6.0_wp*x0**5 + 5.0_wp*x0**4 + 4.0_wp*x0**3 + 2.0_wp*x0 + 1.0_wp)

    !the original test cases:
    call qtest()
    call ktest()

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

    !***********************************************************
        subroutine write_results(truth)

        implicit none

        real(wp),intent(in) :: truth

        write(*,'(A)') ''
        write(*,'(A,E25.16)') 'estimated derivative :', deriv
        write(*,'(A,E25.16)') 'actual derivative    :', truth
        write(*,'(A,E25.16)') 'estimated error      :', error
        write(*,'(A,E25.16)') 'actual error         :', truth - deriv
        write(*,'(A,I5)')     'ifail                :', ifail
        write(*,'(A,I5)')     'func. evaluations    :', d%ifunc
        write(*,'(A)') ''

        end subroutine write_results
    !***********************************************************

    !***********************************************************
        function sin_func(me,x) result(fx)

        implicit none

        class(diff_func),intent(inout) :: me
        real(wp),intent(in) :: x
        real(wp) :: fx

        select type (me)
        type is (my_func)
            me%ifunc = me%ifunc + 1
        end select

        fx = sin(x)

        end function sin_func
    !***********************************************************

    !***********************************************************
        function test_func_1(me,x) result(fx)

        implicit none

        class(diff_func),intent(inout) :: me
        real(wp),intent(in) :: x
        real(wp) :: fx

        select type (me)
        type is (my_func)
            me%ifunc = me%ifunc + 1
        end select

        fx = sin(x) + cos(x) + x**2

        end function test_func_1
    !***********************************************************

    !***********************************************************
        function test_func_2(me,x) result(fx)

        implicit none

        class(diff_func),intent(inout) :: me
        real(wp),intent(in) :: x
        real(wp) :: fx

        select type (me)
        type is (my_func)
            me%ifunc = me%ifunc + 1
        end select

        fx = x**6 + x**5 + x**4 + x**2 + x

        end function test_func_2
    !***********************************************************

    !***********************************************************
        subroutine qtest()

        !! Original DIFF QTEST test case

        implicit none

        real(wp) :: x,min,max,eps,acc,deriv,error
        integer i,order,fail

        write(*,*) ''
        write(*,*) ' qtest '

        order = 1
        eps   = 0.0_wp
        acc   = 0.0_wp
        min   = -3.0_wp
        max   = 3.0_wp

        do i=-1,2
            x=real(i,wp)
            call d%set_function(exp_func)
            call d%compute_derivative(order,x,min,max,eps,acc,deriv,error,fail)
            write(*,'(2(1x,e10.4),1x,i2)') deriv,error,fail
        end do

        end subroutine qtest
    !***********************************************************

    !***********************************************************
      subroutine ktest()

        implicit none

        integer :: iord,ifail
        real(wp) :: x0,xmin,xmax,eps,acc,deriv,error

        iord = 1
        x0   = 1.0_wp
        xmin = .5_wp
        xmax = 1.5_wp
        eps  = 0.0_wp
        acc  = 0.0_wp

        write(*,*) ''
        write(*,*) ' ktest '

        call d%set_function(exp_func)
        call d%compute_derivative(iord,x0,xmin,xmax,eps,acc,deriv,error,ifail)

        write(*,*) 'deriv,error,ifail',deriv,error,ifail

      end subroutine ktest
    !***********************************************************

    !***********************************************************
        function exp_func(me,x) result(fx)

        implicit none

        class(diff_func),intent(inout) :: me
        real(wp),intent(in) :: x
        real(wp) :: fx

        select type (me)
        type is (my_func)
            me%ifunc = me%ifunc + 1
        end select

        fx = exp(4.0_wp * x)

        end function exp_func
    !***********************************************************

!*****************************************************************************************
    end program test_cases
!*****************************************************************************************


! { dg-do run }
!
! CO_REDUCE
!
implicit none (type, external)
intrinsic :: co_reduce
integer :: stat
integer :: i4, i4_2, i

i4 = 21 * this_image()
i4_2 = 21
do i = 2, num_images()
  i4_2 = i4_2 * 21 * i
end do
call co_reduce(i4, op_i4, stat=stat)
if (stat /= 0) STOP 1
if (i4_2 /= i4) STOP 2

contains
  pure integer function op_i4(a,b)
    integer, value :: a, b
    op_i4 = a * b
  end function op_i4
end


program main

  real :: array_1d(3)
  real :: array_2d(3,2)
  integer :: icol_1d(1)
  integer :: icol_2d(2)

  array_1d = (/1.,2.,3./)
  array_2d(:,1) = (/1.,2.,3./)
  array_2d(:,2) = (/4.,5.,6./)

  icol_1d = maxloc( abs(array_1d) )
  icol_2d = maxloc( abs(array_2d) )

  print*,  icol_1d, array_1d(icol_1d(1))
  print*,  icol_2d, array_2d(icol_2d(1),icol_2d(2))
end


INTEGER(kind = INT8), DIMENSION(0:5), PARAMETER                                 :: const_factorial_INT8 = (/ &
                                                                                1_INT8, &
                                                                                1_INT8, &
                                                                                2_INT8, &
                                                                                6_INT8, &
                                                                                24_INT8, &
                                                                                120_INT8  &
                                                                                /)


!Proposal density
!Using the covariance matrix to give the proposal directions typically
!significantly increases the acceptance rate and gives faster movement
!around parameter space.
!We generate a random basis in the eigenvectors, then cycle through them
!proposing changes to each, then generate a new random basis
!The distance proposal in the random direction is given by a two-D Gaussian
!radial function mixed with an exponential, which is quite robust to wrong width estimates
!See http://cosmologist.info/notes/cosmomc.ps.gz

module propose
  use settings
  use Random
  use ParamDef
  implicit none

 logical :: propose_rand_directions = .true.
 logical :: fast_slicing = .false. !slice fast parameters when using Metropolis
 logical :: slice_stepout = .true.
 logical :: slice_randomsize = .false.

 real, allocatable, dimension(:,:), save :: Rot_slow, Rot_fast

contains

 subroutine RotMatrix(M,n)
  integer, intent(in) :: n
  real M(n,n)
  integer i

   if (propose_rand_directions .and. n > 1) then
      call RandRotation(M, n)
   else
      M = 0
      do i = 1, n
           M(i,i) = sign(1., real(ranmar())-0.5)
      end do
   end if

 end  subroutine RotMatrix

 function Propose_r(in_n) result(r_fac)
  !distance proposal function (scale is 1)
   integer, intent(in) :: in_n
   integer i,n
   real r_fac

      if (ranmar() < 0.33d0) then
       r_fac = randexp1()
      else
       n = min(in_n,2)
       r_fac = 0
       do i = 1, n
        r_fac = r_fac + Gaussian1()**2
       end do
       r_fac = sqrt( r_fac / n )
      end if

 end function Propose_r

 subroutine UpdateParamsDirection(tmp, fast, dist,i)
  !Change parameters in tmp by dist in the direction of the ith random e-vector
   Type(ParamSet) tmp
   real vec(num_params_used)
   integer, intent(in) :: i
   logical, intent(in) :: fast
   real, intent(in) :: dist

  if (has_propose_matrix) then
    vec = 0
    if (fast) then
      vec(1:num_fast) =  Rot_fast(:,i) * dist * propose_diag_fast
      tmp%P(fast_params_used) =  tmp%P(fast_params_used) + &
        sigmas(num_slow+1:num_slow+ num_fast) * matmul (propose_matrix_fast, vec(1:num_fast))
    else
      vec(1:num_slow) =  Rot_slow(:,i) * dist * propose_diag(slow_evecs)
      tmp%P(params_used) =  tmp%P(params_used) + &
            sigmas * matmul (propose_matrix(:,slow_evecs), vec(1:num_slow))
    end if
  else
    if (fast) then
     tmp%P(fast_params_used) = tmp%P(fast_params_used) + &
              Rot_fast(:,i) * dist *  Scales%PWidth(fast_params_used)
    else
     tmp%P(params_used(1:num_slow)) = tmp%P(params_used(1:num_slow)) +  &
        Rot_slow(:,i) * dist *  Scales%PWidth(params_used(1:num_slow))
    end if
  end if

 end subroutine UpdateParamsDirection

subroutine GetProposal(In, Out)

  type (ParamSet) In, Out
  integer, save :: fast_ix = 0

  fast_ix = fast_ix + 1
  if (num_slow ==0 .or. num_fast /= 0 .and. &
       mod(fast_ix, 2*(1 + (num_fast*oversample_fast)/num_slow)) /= 0) then
   call GetProposalProjFast(In, Out)
  else
   call GetProposalProjSlow(In, Out)
  end if

end subroutine GetProposal

subroutine GetProposalProjSlow(In, Out)
  use settings
  use Random
  use ParamDef
  implicit none
  type (ParamSet) In, Out
  real  wid
  integer, save :: loopix = 0

  slow_proposals = slow_proposals + 1
!Change only slow params, or eigenvectors of covmat which most change the slow params

   Out= In
   wid = propose_scale
   if (mod(loopix,num_slow)==0) then
        if (.not. allocated(Rot_slow)) allocate(Rot_slow(num_slow,num_slow))
        call RotMatrix(Rot_slow, num_slow)
        loopix = 0
   end if
   loopix = loopix + 1

   call UpdateParamsDirection(Out,.false.,Propose_r(num_slow) * wid, loopix)

end subroutine GetProposalProjSlow

subroutine GetProposalProjFast(In, Out, ascale)
  type (ParamSet) In, Out
  real wid
  real, intent(in), optional :: ascale
  integer, save :: loopix = 0

   Out= In

   wid = propose_scale
   if (present(ascale)) wid = ascale

   if (mod(loopix,num_fast)==0) then
        if (.not. allocated(Rot_fast)) allocate(Rot_fast(num_fast,num_fast))
        call RotMatrix(Rot_fast, num_fast)
        loopix = 0
   end if
   loopix = loopix + 1

   call UpdateParamsDirection(Out,.true.,Propose_r(num_fast) * wid, loopix)

end subroutine GetProposalProjFast

end module propose


*
*     -------------------------------------------------------------
*      N I N E L S
*     -------------------------------------------------------------
*
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT         *
*                                                                  *
*     |  J1/2  J2/2  J3/2 |                                        *
*     |  L1/2  L2/2  L3/2 |                                        *
*     |  K1/2  K2/2  K3/2 |                                        *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vilnius, LITHUANIA                              January 1997 *
*
      SUBROUTINE NINELS(J1,J2,J3,L1,L2,L3,K1,K2,K3,I,IN,A)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      A=ZERO
      IF(I.EQ.1) THEN
        IN=0
        IF(ITTK(J1,J2,J3).EQ.0)RETURN
        IF(ITTK(L1,L2,L3).EQ.0)RETURN
        IF(ITTK(K1,K2,K3).EQ.0)RETURN
        IF(ITTK(J1,L1,K1).EQ.0)RETURN
        IF(ITTK(J2,L2,K2).EQ.0)RETURN
        IF(ITTK(J3,L3,K3).EQ.0)RETURN
        IN=1
        RETURN
      ENDIF
      IN=1
      IF(J1*J2*J3*L1*L2*L3*K1*K2*K3.EQ.0) THEN
        CALL NINE0(J1,J2,J3,L1,L2,L3,K1,K2,K3,A)
      ELSEIF(K3.NE.2) THEN
        CALL NINE(J1,J2,J3,L1,L2,L3,K1,K2,K3,I,IN,A)
      ELSEIF(J3.EQ.L3) THEN
        IF(K1.EQ.K2) THEN
*
*    Case  J3 = L3           and   K1 = K2
*
          CALL NINE11(J1,J2,J3,L1,L2,K1,A)
        ELSEIF(K1-2.EQ.K2) THEN
*
*    Case  J3 = L3           and   K1/2 + 1 = K2/2
*
          CALL NINE12(J1,J2,J3,L1,L2,K1,A)
        ELSEIF(K1+2.EQ.K2) THEN
*
*    Case  J3 = L3           and   K1/2 = K2/2 + 1
*
          CALL NINE12(J2,J1,J3,L2,L1,K2,A)
          IF(MOD(J1+J2+J3+L1+L2+L3+K1+K2+K3,4).NE.0) A=-A
        ELSE
          CALL NINE(J1,J2,J3,L1,L2,L3,K1,K2,K3,I,IN,A)
        ENDIF
      ELSEIF(J3-2.EQ.L3) THEN
        IF(K1.EQ.K2) THEN
*
*    Case  J3/2 + 1 = L3/2   and   K1 = K2
*
          CALL NINE12(J1,L1,K1,J2,L2,J3,A)
        ELSEIF(K1-2.EQ.K2) THEN
*
*    Case  J3/2 + 1 = L3/2   and   K1/2 + 1 = K2/2
*
          CALL NINE13(J1,J2,J3,L1,L2,K1,A)
        ELSEIF(K1+2.EQ.K2) THEN
*
*    Case  J3/2 + 1 = L3/2   and   K1/2 - 1 = K2/2
*
          CALL NINE13(J2,J1,J3,L2,L1,K2,A)
          IF(MOD(J1+J2+J3+L1+L2+L3+K1+K2+K3,4).NE.0) A=-A
        ELSE
          CALL NINE(J1,J2,J3,L1,L2,L3,K1,K2,K3,I,IN,A)
        ENDIF
      ELSEIF(J3+2.EQ.L3) THEN
        IF(K1.EQ.K2) THEN
*
*    Case  J3/2 = L3/2 + 1   and   K1 = K2
*
          CALL NINE12(L1,J1,K1,L2,J2,L3,A)
          IF(MOD(J1+J2+J3+L1+L2+L3+K1+K2+K3,4).NE.0) A=-A
        ELSEIF(K1-2.EQ.K2) THEN
*
*    Case  J3/2 = L3/2 + 1   and   K1/2 - 1 = K2/2
*
          CALL NINE13(L1,L2,L3,J1,J2,K1,A)
          IF(MOD(J1+J2+J3+L1+L2+L3+K1+K2+K3,4).NE.0) A=-A
        ELSEIF(K1+2.EQ.K2) THEN
*
*    Case  J3/2 = L3/2 + 1   and   K1/2 - 1 = K2/2
*
          CALL NINE13(L2,L1,L3,J2,J1,K2,A)
        ELSE
          CALL NINE(J1,J2,J3,L1,L2,L3,K1,K2,K3,I,IN,A)
        ENDIF
      ELSE
        CALL NINE(J1,J2,J3,L1,L2,L3,K1,K2,K3,I,IN,A)
      ENDIF
      RETURN
      END


/* Examples for testing */

 lambda X. lambda x:X. x;
 (lambda X. lambda x:X. x) [All X.X->X];


!*==drot.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b DROT
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)
!
!       .. Scalar Arguments ..
!       DOUBLE PRECISION C,S
!       INTEGER INCX,INCY,N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION DX(*),DY(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    DROT applies a plane rotation.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in,out] DX
!> \verbatim
!>          DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>         storage spacing between elements of DX
!> \endverbatim
!>
!> \param[in,out] DY
!> \verbatim
!>          DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
!> \endverbatim
!>
!> \param[in] INCY
!> \verbatim
!>          INCY is INTEGER
!>         storage spacing between elements of DY
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[in] S
!> \verbatim
!>          S is DOUBLE PRECISION
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup double_blas_level1
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>     jack dongarra, linpack, 3/11/78.
!>     modified 12/3/93, array(1) declarations changed to array(*)
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DROT(N,Dx,Incx,Dy,Incy,C,S)
      IMPLICIT NONE
!*--DROT96
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION C , S
      INTEGER Incx , Incy , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION Dx(*) , Dy(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      DOUBLE PRECISION dtemp
      INTEGER i , ix , iy
!     ..
      IF ( N<=0 ) RETURN
      IF ( Incx==1 .AND. Incy==1 ) THEN
!
!       code for both increments equal to 1
!
         DO i = 1 , N
            dtemp = C*Dx(i) + S*Dy(i)
            Dy(i) = C*Dy(i) - S*Dx(i)
            Dx(i) = dtemp
         ENDDO
      ELSE
!
!       code for unequal increments or equal increments not equal
!         to 1
!
         ix = 1
         iy = 1
         IF ( Incx<0 ) ix = (-N+1)*Incx + 1
         IF ( Incy<0 ) iy = (-N+1)*Incy + 1
         DO i = 1 , N
            dtemp = C*Dx(ix) + S*Dy(iy)
            Dy(iy) = C*Dy(iy) - S*Dx(ix)
            Dx(ix) = dtemp
            ix = ix + Incx
            iy = iy + Incy
         ENDDO
      ENDIF
      END SUBROUTINE DROT


!! main subroutines for preprocessing
!! created by Yanhua O. Yuan ( yanhuay@princeton.edu)

subroutine preprocess(d,NSTEP,deltat,t0,f0,&
        is_laplace,dis_sr,S_x,S_t, &
        is_window,window_type,V_slow,V_fast,&
        mute_near,offset_near,mute_far,offset_far,&
        Wscale,&
        istart,iend)

    !! preprocessing library
    use constants
    implicit none

    real(kind=CUSTOM_REAL), dimension(*), intent(out) :: d
    real(kind=CUSTOM_REAL), intent(in) :: deltat,t0,f0
    integer, intent(in) :: NSTEP, Wscale
    integer, intent(in) :: is_laplace, is_window, window_type,mute_near,mute_far
    real(kind=CUSTOM_REAL), intent(in) :: dis_sr, S_x, S_t,V_slow,V_fast,offset_near,offset_far
    integer, intent(out) :: istart,iend

    integer :: itime,NA
    real(kind=CUSTOM_REAL) :: win(NSTEP)

    istart=1
    iend=NSTEP

    !! mute
    if(mute_near .eq. 1 .and. dis_sr<=offset_near ) then
        d(1:NSTEP) =0.0
        istart=NSTEP
        iend=0
    endif
    if(mute_far .eq. 1 .and. dis_sr>=offset_far) then
        d(1:NSTEP) =0.0
        istart=NSTEP
        iend=0
    endif

    !! laplace damping spatially and temporally
    if (is_laplace .eq. 1 .and. istart<iend) then
        ! spatial
        d(1:NSTEP)=d(1:NSTEP)*exp(-dis_sr*S_x)
        ! temporal
        do itime=1,NSTEP
        d(itime)=d(itime)*exp(-((itime-1)*deltat*S_t))
        enddo
    endif

    ! dip-window using slopes
    if(is_window .eq. 1.and. istart<iend) then
        ! estimate surface-wave arrivals
        istart=max(int((dis_sr/V_fast+t0-1.2/f0)/deltat)+1,istart)
        iend=min(int((dis_sr/V_slow+3.0/f0+t0+1.2/f0)/deltat)+1,iend)
        if(istart<iend) then
            ! window
            win(1:NSTEP)=0.d0
            call window(NSTEP,istart,iend,window_type,win)
            d(1:NSTEP)=d(1:NSTEP)*win(1:NSTEP)
        endif
    endif ! window

    ! WT filtering
    if( Wscale .gt. 0.and. istart<iend) then
        call WT(d,NSTEP,Wscale,NA)
        istart=max(istart-NA,1)
        iend=min(iend+NA,NSTEP)
    endif

end subroutine preprocess

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

subroutine window(npts,istart,iend,window_type,win)
    use constants
    implicit none

    integer, intent(in) :: npts, istart,iend, window_type
    real(kind=CUSTOM_REAL), dimension(*), intent(out) :: win

    integer ::  i, nlen
    real(kind=CUSTOM_REAL) :: sfac1
    real(kind=CUSTOM_REAL), dimension(npts) :: fac

    nlen = iend - istart+1

    ! some constants
    sfac1 = (2./real(nlen))**2   ! for Welch taper

    ! initialization
    win(1:npts) = 0.d0
    fac(1:npts) = 0.d0

    do i = 1, nlen
    if(window_type ==2) then
        fac(i) = 1 - sfac1*((i-1) - real(nlen)/2.)**2
    elseif(window_type ==3) then
        fac(i) = 1. - cos(PI*(i-1)/(nlen-1))**ipwr_t
    elseif(window_type ==4) then
        fac(i) = 0.5 - 0.5*cos(TWOPI*(i-1)/(nlen-1))
    else
        fac(i) = 1. ! boxcar window
    endif
    enddo

    !! return
    win(istart:iend)=fac(1:nlen)

end subroutine window
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine taper(NSTEP,taper_len,tas)
    use constants
    implicit none

    ! input parameters
    integer, intent(in) :: NSTEP,taper_len
    real, dimension(*), intent(out) :: tas

    integer i, n_width_left,n_width_right
    real ::  omega_left,omega_right, f0, f1

    ! initialization
    tas(1:NSTEP)=1.0

    ! set the number of points corresponding to the taper width
    n_width_left=taper_len
    n_width_right=taper_len

    ! set the taper properties according to type
    omega_left = PI/real(n_width_left)
    omega_right = PI/real(n_width_right)
    f0 = 0.5
    f1 = 0.5

    ! apply the taper symmetrically to left side of the data
    do i = 1, n_width_left
    tas(i) = f0-f1*cos(omega_left*(i-1))
    enddo
    do i = 1, n_width_right
    !  print*,i,omega_right,n_width_right,(f0-f1*cos(omega_right*(i-1)))
    tas(NSTEP+1-i) = f0-f1*cos(omega_right*(i-1))
    end do

end subroutine taper
!------------------------------------------------------------------------
subroutine xcorr(d,s,npts1,npts2,cc_array,ishift,cc_max,sigma)
    ! recommended by Yanhua -- to calculate cross-correlation time series cc_array
    ! (length of ntps1+npts2-1) for d and s with
    ! lengths of npts1 and npts2 respectively, as well as their maiximal
    ! coefficients cc_max and corresponding shift ishift
    ! sigma -- A gaussian weighting centered at zero applied to cc_array (if sigma=0
    ! no weighting)
    ! this function can replace xcorr_calc if command the normalization operator
    use constants
    implicit none
    ! inputs
    real(kind=CUSTOM_REAL), dimension(*), intent(in) :: s,d
    integer, intent(in) :: npts1, npts2
    real(kind=CUSTOM_REAL), intent(in) :: sigma

    ! outputs:
    integer, intent(out) :: ishift
    real(kind=CUSTOM_REAL), intent(out) :: cc_max
    real(kind=CUSTOM_REAL), dimension(*), intent(out) :: cc_array

    ! local variables
    integer :: i_left, i_right, i, j,k
    real(kind=CUSTOM_REAL) :: cc

    ! initialise shift and cross correlation to zero
    ishift = 0
    cc_max = 0.0d0

    i_left = -(npts2-1) ! toward right shift (negative)
    i_right =npts1-1    ! toward left shift  (postive)
    ! i is the index to shift to be applied to DATA (d)
    k=0
    do i = i_left, i_right
    k=k+1
    ! cc as a function of i or k
    cc = 0.
    do j = 1,npts2    ! loop over full window length
    if((j+i).ge.1 .and. (j+i).le.npts1) then
        cc = cc + s(j)*d(j+i)  ! d is shifted by i
    endif
    enddo
    cc_array(k)=cc
    ! keeping cc-max only
    if (cc .gt. cc_max) then
        cc_max = cc
        ishift = i
    endif
    !! weighting cc_array with a Gaussian function
    if (sigma>0) then
        cc_array(k)=cc_array(k)*exp(-4*(i**2)/(sigma**2))
    endif

    enddo
end subroutine xcorr
!-------------------------------------------------------------------------
subroutine xconv(d,s,npts1,npts2,c_array,npts3)
    ! Yanhua -- convolution of d with npts1 points and s with npts2 points
    ! output is c_array with length npts3
    use constants
    implicit none
    ! inputs
    real(kind=CUSTOM_REAL), dimension(*), intent(in) :: s,d
    integer, intent(in) :: npts1,npts2,npts3

    ! outputs:
    real(kind=CUSTOM_REAL), dimension(*), intent(out) :: c_array

    ! local variables
    integer :: i_left, i_right, i,j,k
    real(kind=CUSTOM_REAL),dimension(npts1+npts2-1) :: cc_array
    real(kind=CUSTOM_REAL) :: cc

    if (npts3 .lt. 1 .or. npts3 .gt. npts1+npts2-1) then
        write(*,*) 'output length is improper: ', npts3
        return
    endif

    i_left = 2
    i_right = npts1+npts2
    ! i is the index to shift to be applied to DATA (d)
    k=0
    do i = i_left, i_right
    k=k+1
    ! cc as a function of i or k
    cc = 0.
    do j = 1,npts1    ! loop over full window length
    if((i-j) .ge. 1 .and. (i-j) .le. npts2) then
        cc = cc + d(j)*s(i-j)  ! d is shifted by i
    endif
    enddo
    cc_array(k)=cc
    enddo
    i_left=1+ceiling((npts1+npts2-1-npts3)*0.5)
    i_right=npts3+ceiling((npts1+npts2-1-npts3)*0.5)
    c_array(1:npts3)=cc_array(i_left:i_right)

end subroutine xconv
!-----------------------------------------------------------------------
subroutine gaussmf(x,sig,c,npts,f)
    ! Gaussian curve membership function
    ! by Yanhua -- see matlab y = gaussmf(x,[sig c])
    use constants
    implicit none
    ! inputs
    real(kind=CUSTOM_REAL), dimension(*), intent(in) :: x
    real(kind=CUSTOM_REAL), intent(in) :: sig,c
    integer, intent(in) :: npts

    ! outputs:
    real(kind=CUSTOM_REAL), dimension(*), intent(out) :: f

    integer :: i

    do i=1,npts
    f(i)=exp(-(x(i)-c)**2/(2*sig**2))
    enddo
end subroutine gaussmf
!---------------------------------------------------------------------------
subroutine gauspuls(x,npts,fc,sig,c,fe,f )
    ! Gaussian curve membership function
    use constants
    implicit none
    ! inputs
    real(kind=CUSTOM_REAL), dimension(*), intent(in) :: x
    real(kind=CUSTOM_REAL), intent(in) :: fc,sig,c
    integer, intent(in) :: npts

    ! outputs:
    real(kind=CUSTOM_REAL), dimension(*), intent(out) :: fe, f

    ! compute gaussian envelope
    call gaussmf(x,sig,c,npts,fe)
    ! gaussian modulated sine/cosine function
    f(1:npts) = fe(1:npts) * cos(TWOPI*fc*x(1:npts));

end subroutine gauspuls
! ---------------------------------------------------------------------------
subroutine WT(seism,NSTEP,level,NA)
    use constants
    implicit none

    real(kind=CUSTOM_REAL), dimension(*), intent(out) :: seism
    integer, intent(in) :: NSTEP,level
    integer :: iend,istart,i,j,st
    integer, intent(out) :: NA
    real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: basis, seism_WT
    real(kind=CUSTOM_REAL) :: wc
    real(kind=CUSTOM_REAL),dimension(:), allocatable :: nonzero_basis
    character(len=500) :: fname,filename

    NA=0
    if(level .gt. 0) then
        if(level==12) NA=45046
        if(level==11) NA=22518
        if(level==10) NA=11254
        if(level==9) NA=5622
        if(level==8) NA=2806
        if(level==7) NA=1398
        if(level==6) NA=694
        if(level==5) NA=342
        if(level==4) NA=166
        if(level==3) NA=78
        if(level==2) NA=34
        if(level==1) NA=12
    endif !! level

    if(level .gt. 0 .and. NA .gt. 0) then
        allocate(nonzero_basis(NA))
        allocate(basis(NSTEP,1))
        allocate(seism_WT(NSTEP,1))
        seism_WT(1:NSTEP,1)=0.0

        ! print*,' load basis functions for wavelet Daubechies',nvm,' scale',level
        write(fname,"(a,i0,a,i0)") 'scale_basis_Daubechies',nvm,'_scale',level
        ! filename=''//trim(WT_directory)//'/'//trim(fname)//'.dat'
        filename='WT_basis/'//trim(fname)//'.dat'
        ! print*,filename
        OPEN (UNIT=20,FILE=filename,STATUS='OLD',action='read',iostat=st)
        if(st>0) then
            print*,'Error opening file: ',filename
            stop
        else
            read(20,*) nonzero_basis
        end if
        close(20)

        ! initialization
        iend=1
        istart=2-NA
        ! find shifted basis
        do while (istart<=NSTEP)
        basis(1:NSTEP,1)=0.0
        j=0
        do i=istart,iend
        j=j+1
        if(i>=1 .and. i<=NSTEP) then
            basis(i,1)=nonzero_basis(j)
        endif
        enddo
        !! WT
        wc=dot_product(seism(1:NSTEP),basis(1:NSTEP,1))
        !   print*, 'istart=',istart,' wc=',wc
        ! inverse wavelet transform to construct data
        seism_WT(1:NSTEP,1)=seism_WT(1:NSTEP,1)+wc*basis(1:NSTEP,1)
        !    print*, ' prepare for next basis '
        iend=iend+2**level
        istart=istart+2**level
        !    print*, 'istart=',istart,' iend=',iend
        enddo
        seism(1:NSTEP)=seism_WT(1:NSTEP,1)

        deallocate(nonzero_basis)
        deallocate(basis)
        deallocate(seism_WT)
    endif  !! level

end subroutine WT